URL
https://opencores.org/ocsvn/w11/w11/trunk
Subversion Repositories w11
[/] [w11/] [tags/] [w11a_V0.6/] [tools/] [bin/] [ti_rri] - Rev 20
Go to most recent revision | Compare with Previous | Blame | View Log
#! /usr/bin/env tclsh
# -*- tcl -*-
# $Id: ti_rri 511 2013-04-27 13:51:46Z mueller $
#
# Copyright 2011-2013 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
# 2013-04-26 510 1.1.5 reorganize readline startup
# 2013-04-12 504 1.1.4 add --pack; trailing '-' argv implies --int
# 2013-02-05 482 1.1.3 stop server is rls found
# 2013-01-27 478 1.1.2 use 'exec sh -c $cmd &' for --run implementation
# 2013-01-02 467 1.1.1 call rlc close only when really open
# 2012-12-27 465 1.1 add --cuff support
# 2012-02-09 457 1.0.4 disable autoexec
# 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
#
#
# --pack=pname,...
# --fifo[=name,opts,...]
# --term[=name,baud,opts,...]
# --cuff[=name,...]
# --run=command
# --log=filename ; default "-"
# --logl=n ; default 2
# --dmpl=n ; default 0
# --tiol=n ; default 0
# --int
# --help
# --
# tcl cmds
# @...tcl
#
set tirri_interactive 0
array set opts {
pack_ ""
fifo 0
fifo_ ""
term 0
term_ ""
cuff 0
cuff_ ""
run_ ""
log_ "-"
logl_ 2
dmpl_ 0
tiol_ 0
int 0
help 0
}
set clist {}
set optsendseen 0
set runpid {}
# disable autoexec
set auto_noexec 1
#
# 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 tirri_exit {{doexit 1}} {
global opts
global runpid
# check for rlink server, stop it
if { [info commands rls] eq "rls" } { rls server -stop }
# now close rlink connection
if { $opts(fifo) || $opts(term) || $opts(cuff) } {
if { [rlc open] ne "" } { 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
}
if { $doexit } {
puts {}; # \n to ensure shell prompt on new line
exit
}
return
}
foreach arg $argv {
if { $optsendseen } {
lappend clist $arg
continue
}
switch -regexp -- $arg {
^--?pack=.+$ { regexp -- {=(.*)} $arg dummy opts(pack_) }
^--?fifo=?.*$ { set opts(fifo) 1; regexp -- {=(.*)} $arg dummy opts(fifo_) }
^--?term=?.*$ { set opts(term) 1; regexp -- {=(.*)} $arg dummy opts(term_) }
^--?cuff=?.*$ { set opts(cuff) 1; regexp -- {=(.*)} $arg dummy opts(cuff_) }
^--?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 }
}
}
# check whether last element in clist is plain '-'
if { [llength clist] } {
if { [lindex $clist end] eq "-" } {
set opts(int) 1
set clist [lrange $clist 0 end-1]
}
}
if { $opts(help) } {
# use {} as defimiter here to avoid that escaping of all []
puts {usage: ti_rri [OPTION]... [COMMAND]...}
puts {}
puts {Options:}
puts { --pack=PLIST load, with package require, additional packages}
puts { PLIST is comma separated list of package names}
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[,OPTS]]}
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 { --cuff[=ARGS] open cuff type rlink port. Optional arguments are:}
puts { --cuff=[NAME[,OPTS]]}
puts { NAME USB path, default derived from environment}
puts { variables RETRO_FX2_VID and RETRO_FX2_PID}
puts { OPTS further options (comma separated list):}
puts { trace trace USB activities}
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
}
# check consistency of connection open options
set nopen 0;
if { $opts(fifo) } { incr nopen }
if { $opts(term) } { incr nopen }
if { $opts(cuff) } { incr nopen }
if { $nopen > 1 } {
puts "-E: more than one of --fifo,--term,--cuff 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
rlinkserver rls rlc
# load additional packages (if -pack given)
if { $opts(pack_) ne "" } {
foreach pack [split $opts(pack_) ","] {
package require $pack
}
}
# 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
# exec sh -c $cmd is used to execute a shell command including [], '',""
# in a direct exec the tcl expansion logic will interfere...
#
if { $opts(run_) ne "" } {
if { [catch {exec sh -c $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
}
# handle --cuff
if { $opts(cuff) } {
set nlist [split $opts(cuff_) ","]
set path [lindex $nlist 0]
set url "cuff:$path"
set delim "?"
foreach opt [lrange $nlist 1 end] {
if {$opt ne ""} {append url "$delim$opt"}
set delim ";"
}
# puts "-I: $url"
rlc open $url
}
# setup simulation mode default
set rlink::sim_mode [rlink::isfifo]
# 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
# determine whether interactive mode, if yes, initialize readline
if {$opts(int) || [llength $clist] == 0 } {
set tirri_interactive 1
package require tclreadline
namespace eval tclreadline {
proc prompt1 {} {
set version [info tclversion]
return "ti_rri > "
}
}
::tclreadline::readline eofchar {::tirri_exit; puts {}; exit}
}
# now execute all commands and scripts given as start-up arguments
foreach cmd $clist {
# puts "executing: $cmd"
# 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 { $tirri_interactive } {
::tclreadline::Loop
} else {
tirri_exit 0
}
return 0
Go to most recent revision | Compare with Previous | Blame | View Log