Subversion Repositories w11

#! /usr/bin/env tclsh
# -*- tcl -*-
# $Id: ti_rri 440 2011-12-18 20:08:09Z mueller $
#
# Copyright 2011- by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
#
# This program is free software; you may redistribute and/or modify it under
# the terms of the GNU General Public License as published by the Free
# Software Foundation, either version 2, or at your option any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for complete details.
#
#  Revision History:
# Date         Rev Version  Comment
# 2011-12-19   440   1.0.3  re-organize option handling for --term and --fifo
# 2011-12-04   435   1.0.2  add flow attribute to --term
# 2011-04-22   379   1.0.1  check for RETROBASE; proper exit handling; help text
# 2011-04-17   376   1.0    Initial version
# 2011-03-19   371   0.1    First draft
#
#
# --fifo[=name,opts,...]
# --term[=name,baud,opts,...]
# --run=command
# --log=filename      ; default "-"
# --logl=n            ; default 2
# --dmpl=n            ; default 0
# --tiol=n            ; default 0
# --int
# --help
# --
#   tcl cmds 
#   @...tcl
#

array set opts { 
    fifo   0
    fifo_  ""
    term   0
    term_  ""
    run_   ""
    log_   "-"
    logl_  2
    dmpl_  0
    tiol_  0
    int    0
    help   0
}

set clist {}
set optsendseen 0
set runpid {}

#
# cleanup handler
#   must be in a proc so that it can be called from tclreadline
#   must be defined before ::tclreadline::Loop called (all after ignored...)
#
proc exit_cleanup {} {
  global opts
  global runpid

  # now close rlink connection
  if { $opts(fifo) || $opts(term) } {
    rlc close
  }

  # FIXME_code: should sync here with -run process run-down
  #             but no wait available in tcl (grr...)
  if { "$runpid" ne ""  } {
    after 100;                          # currently just wait 100ms
  }
  return
}

foreach arg $argv {
  if { $optsendseen } {
    lappend clist $arg
    continue
  }
  switch -regexp -- $arg {
    ^--?fifo=?.*$ { set opts(fifo) 1; regexp -- {=(.*)} $arg dummy opts(fifo_) }
    ^--?term=?.*$ { set opts(term) 1; regexp -- {=(.*)} $arg dummy opts(term_) }
    ^--?run=.+$   { regexp -- {=(.*)} $arg dummy opts(run_) }
    ^--?log=.+$   { regexp -- {=(.*)} $arg dummy opts(log_) }
    ^--?logl=.+$  { regexp -- {=(.*)} $arg dummy opts(logl_) }
    ^--?dmpl=.+$  { regexp -- {=(.*)} $arg dummy opts(dmpl_) }
    ^--?tiol=.+$  { regexp -- {=(.*)} $arg dummy opts(tiol_) }
    ^--?int$      { set opts(int) 1 }
    ^--?help$     { set opts(help) 1 }
    ^--$          { set optsendseen 1 }
    ^--.+$        { puts "-E: bad option $arg, see --help for proper usage"
                    return 1
                  }
    default       { lappend clist $arg }
  }
}

if { $opts(help) } {
  # use {} as defimiter here to avoid that escaping of all [] 
  puts {usage: ti_rri [OPTION]... [COMMAND]...}
  puts {}
  puts {Options:}
  puts {  --run=CMD      exec's CMD as subprocess before the rlink port opened}
  puts {                 useful to start test benches, usually via 'tbw'}
  puts {  --fifo[=ARGS]  open fifo type rlink port. Optional arguments are:}
  puts {                   --fifo=[NAME[,KEEP]]}
  puts {                     NAME  fifo name prefix, default 'rlink_cext_fifo'}
  puts {                     OPTS  further options (comma separated list):}
  puts {                             keep  fifo is kept open on exit}
  puts {  --term[=ARGS]  open term type rlink port. Optional arguments are:}
  puts {                   --term=[NAME[,BAUD[,OPTS]]]}
  puts {                     NAME  tty device name, default 'USB0'}
  puts {                           if not starting with '/' the name is}
  puts {                           prefixed with '/dev/tty'}
  puts {                     BAUD  serial port baud rate, default '115k'}
  puts {                           allowed baud rate settings are:}
  puts {                             2400, 4800, 9600, 19200, 19k, 38400, 38k}
  puts {                             57600, 57k, 115200, 115k, 230400, 230k}
  puts {                             460800, 460k, 500000, 500k, 921600, 921k}
  puts {                             1000000, 1000k, 1M, 1500000, 1500k}
  puts {                             2000000, 2000k, 2M, 2500000, 2500k}
  puts {                             3000000, 3000k, 3M, 4000000, 4000k, 4M}
  puts {                     OPTS  further options (comma separated list):}
  puts {                             break  send a break, do autobaud}
  puts {                             cts    hardware flow control (cts/rts)}
  puts {                             xon    software flow control (xon/xoff)}
  puts {  --log=FILE     set log file name. Default is to write to stdout.}
  puts {  --logl=LVL     set log level, default is '2' allowed values:}
  puts {                   0 no logging}
  puts {                   1 log rlink commands with communication errors}
  puts {                   2 log rlink commands with failed checks}
  puts {                   3 log all rlink commands}
  puts {  --dmpl=LVL     set dump level, default is '0', values like logl}
  puts {  --tiol=LVL     set i/o trace level, default is '0', allowed values:}
  puts {                   0 no i/o trace}
  puts {                   1 trace buffer activities}
  puts {                   2 trace character activities}
  puts {  --int          enter interactive mode even when commands given}
  puts {  --help         display this help and exit}
  puts {  --             all following arguments are treated as tcl commands}
  puts {}
  puts {Command handling:}
  puts {  For arguments of the form '@<name>.tcl' the respective file is}
  puts {  sourced. All other arguments are treated as Tcl commands and executed}
  puts {  with eval.}
  puts {}
  puts {For further details consults the ti_rri man page.}
  return 0
}

if {![info exists env(RETROBASE)]} {
  puts "-E: RETROBASE environment variable not defined"
  return 1
}

if { $opts(fifo) && $opts(term) } {
  puts "-E: both --fifo and --term given, only one allowed"
  return 1
}

lappend auto_path [file join $env(RETROBASE) tools tcl]
lappend auto_path [file join $env(RETROBASE) tools lib]

package require rlink
package require rutiltpp
package require rlinktpp

rlinkconnect rlc

# setup logging
if { $opts(log_) ne "-" } {
  rlc config -logfile       $opts(log_)
}
rlc config -logprintlevel $opts(logl_)
rlc config -logdumplevel  $opts(dmpl_)
rlc config -logtracelevel $opts(tiol_)

# first start, if specified with --run, the test bench
if { $opts(run_) ne "" } {
  if { [catch {eval "exec $opts(run_) &" } runpid] } {
    puts "-E: failed to execute \"$opts(run_)\" with error message\n  $runpid"
    puts "aborting..."
    return 1
  }
}

# than open the rlink connection
# handle --fifo
if { $opts(fifo) } {
  set nlist [split $opts(fifo_) ","]
  set path [lindex $nlist 0]
  if {$path eq ""} {set path "rlink_cext_fifo"}
  set url "fifo:$path"
  set delim "?"
  foreach opt [lrange $nlist 1 end] {
    if {$opt  ne ""} {append url "$delim$opt"}
    set delim ";"
  }
  # puts "-I: $url"
  rlc open $url
}

# handle --term
if { $opts(term) } {
  set nlist [split $opts(term_) ","]
  set dev  [lindex $nlist 0]
  set baud [lindex $nlist 1]
  if {$dev  eq ""} {set dev  "USB0"}
  if {$baud eq ""} {set baud "115k"}
  set url "term:$dev?baud=$baud"
  foreach opt [lrange $nlist 2 end] {
    if {$opt  ne ""} {append url ";$opt"}
  }
  # puts "-I: $url"
  rlc open $url
}

# setup simulation mode default
set rlink::sim_mode [rlink::isfifo]

foreach cmd $clist {
  # handle @filename commands
  if { [regexp {^@(.+)} $cmd dummy filename] } {
    # handle @file.tcl --> source tcl file
    if { [regexp {\.tcl$} $filename] } {
      if { [catch {source $filename} errmsg] } {
        puts "-E: failed to source file \"$filename\" with error message:"
        if {[info exists errorInfo]} {puts $errorInfo} else {puts $errmsg}
        puts "aborting..."
        break
      }
    # handle @file.dat ect --> not yet supported
    } else {
      puts "-E: only tcl supported but $filename found"
      puts "aborting..."
      break
    }

  # handle normal tcl commands --> eval them
  } else {
    if { [catch {eval $cmd} errmsg] } {
      puts "-E: eval of \"$cmd\" failed with error message:"
      if {[info exists errorInfo]} {puts $errorInfo} else {puts $errmsg}
      puts "aborting..."
      break
    }
  }
}

# if tclsh runs a script given on the command line or is invoked
# like here via a shebang the tcl_interactive is always set to 0
# so we have to check whether stdin/stdout is a terminal and set
# tcl_interactive accordingly

# FIXME_code: fstat not available (grr...), currently just assume istty
set tcl_interactive 1

if { $opts(int) || [llength $clist] == 0 } {
  if {$tcl_interactive} {
    package require tclreadline
    namespace eval tclreadline {
      proc prompt1 {} {
        set version [info tclversion]
        return "ti_rri > "
      }
    }
    ::tclreadline::readline eofchar {::exit_cleanup; puts {}; exit}
    ::tclreadline::Loop
  }
} else {
  exit_cleanup
}

return 0