| Line 1... |
Line 1... |
#! /usr/bin/env tclsh
|
#! /usr/bin/env tclsh
|
# -*- tcl -*-
|
# -*- tcl -*-
|
# $Id: ti_rri 467 2013-01-02 19:49:05Z mueller $
|
# $Id: ti_rri 504 2013-04-13 15:37:24Z mueller $
|
#
|
#
|
# Copyright 2011-2013 by Walter F.J. Mueller
|
# Copyright 2011-2013 by Walter F.J. Mueller
|
#
|
#
|
# This program is free software; you may redistribute and/or modify it under
|
# 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
|
# the terms of the GNU General Public License as published by the Free
|
| Line 13... |
Line 13... |
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
# for complete details.
|
# for complete details.
|
#
|
#
|
# Revision History:
|
# Revision History:
|
# Date Rev Version Comment
|
# Date Rev Version Comment
|
|
# 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
|
# 2013-01-02 467 1.1.1 call rlc close only when really open
|
# 2012-12-27 465 1.1 add --cuff support
|
# 2012-12-27 465 1.1 add --cuff support
|
# 2012-02-09 457 1.0.4 disable autoexec
|
# 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-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-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-22 379 1.0.1 check for RETROBASE; proper exit handling; help text
|
# 2011-04-17 376 1.0 Initial version
|
# 2011-04-17 376 1.0 Initial version
|
# 2011-03-19 371 0.1 First draft
|
# 2011-03-19 371 0.1 First draft
|
#
|
#
|
#
|
#
|
|
# --pack=pname,...
|
# --fifo[=name,opts,...]
|
# --fifo[=name,opts,...]
|
# --term[=name,baud,opts,...]
|
# --term[=name,baud,opts,...]
|
# --cuff[=name,...]
|
# --cuff[=name,...]
|
# --run=command
|
# --run=command
|
# --log=filename ; default "-"
|
# --log=filename ; default "-"
|
| Line 39... |
Line 43... |
# tcl cmds
|
# tcl cmds
|
# @...tcl
|
# @...tcl
|
#
|
#
|
|
|
array set opts {
|
array set opts {
|
|
pack_ ""
|
fifo 0
|
fifo 0
|
fifo_ ""
|
fifo_ ""
|
term 0
|
term 0
|
term_ ""
|
term_ ""
|
cuff 0
|
cuff 0
|
| Line 70... |
Line 75... |
#
|
#
|
proc exit_cleanup {} {
|
proc exit_cleanup {} {
|
global opts
|
global opts
|
global runpid
|
global runpid
|
|
|
|
# check for rlink server, stop it
|
|
if { [info commands rls] eq "rls" } { rls server -stop }
|
|
|
# now close rlink connection
|
# now close rlink connection
|
if { $opts(fifo) || $opts(term) || $opts(cuff) } {
|
if { $opts(fifo) || $opts(term) || $opts(cuff) } {
|
if { [rlc open] ne "" } { rlc close }
|
if { [rlc open] ne "" } { rlc close }
|
}
|
}
|
|
|
| Line 89... |
Line 97... |
if { $optsendseen } {
|
if { $optsendseen } {
|
lappend clist $arg
|
lappend clist $arg
|
continue
|
continue
|
}
|
}
|
switch -regexp -- $arg {
|
switch -regexp -- $arg {
|
|
^--?pack=.+$ { regexp -- {=(.*)} $arg dummy opts(pack_) }
|
^--?fifo=?.*$ { set opts(fifo) 1; regexp -- {=(.*)} $arg dummy opts(fifo_) }
|
^--?fifo=?.*$ { set opts(fifo) 1; regexp -- {=(.*)} $arg dummy opts(fifo_) }
|
^--?term=?.*$ { set opts(term) 1; regexp -- {=(.*)} $arg dummy opts(term_) }
|
^--?term=?.*$ { set opts(term) 1; regexp -- {=(.*)} $arg dummy opts(term_) }
|
^--?cuff=?.*$ { set opts(cuff) 1; regexp -- {=(.*)} $arg dummy opts(cuff_) }
|
^--?cuff=?.*$ { set opts(cuff) 1; regexp -- {=(.*)} $arg dummy opts(cuff_) }
|
^--?run=.+$ { regexp -- {=(.*)} $arg dummy opts(run_) }
|
^--?run=.+$ { regexp -- {=(.*)} $arg dummy opts(run_) }
|
^--?log=.+$ { regexp -- {=(.*)} $arg dummy opts(log_) }
|
^--?log=.+$ { regexp -- {=(.*)} $arg dummy opts(log_) }
|
| Line 107... |
Line 116... |
}
|
}
|
default { lappend clist $arg }
|
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) } {
|
if { $opts(help) } {
|
# use {} as defimiter here to avoid that escaping of all []
|
# use {} as defimiter here to avoid that escaping of all []
|
puts {usage: ti_rri [OPTION]... [COMMAND]...}
|
puts {usage: ti_rri [OPTION]... [COMMAND]...}
|
puts {}
|
puts {}
|
puts {Options:}
|
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 { --run=CMD exec's CMD as subprocess before the rlink port opened}
|
puts { useful to start test benches, usually via 'tbw'}
|
puts { useful to start test benches, usually via 'tbw'}
|
puts { --fifo[=ARGS] open fifo type rlink port. Optional arguments are:}
|
puts { --fifo[=ARGS] open fifo type rlink port. Optional arguments are:}
|
puts { --fifo=[NAME[,OPTS]]}
|
puts { --fifo=[NAME[,OPTS]]}
|
puts { NAME fifo name prefix, default 'rlink_cext_fifo'}
|
puts { NAME fifo name prefix, default 'rlink_cext_fifo'}
|
| Line 171... |
Line 190... |
if {![info exists env(RETROBASE)]} {
|
if {![info exists env(RETROBASE)]} {
|
puts "-E: RETROBASE environment variable not defined"
|
puts "-E: RETROBASE environment variable not defined"
|
return 1
|
return 1
|
}
|
}
|
|
|
|
# check consistency of connection open options
|
set nopen 0;
|
set nopen 0;
|
if { $opts(fifo) } { incr nopen }
|
if { $opts(fifo) } { incr nopen }
|
if { $opts(term) } { incr nopen }
|
if { $opts(term) } { incr nopen }
|
if { $opts(cuff) } { incr nopen }
|
if { $opts(cuff) } { incr nopen }
|
|
|
| Line 189... |
Line 209... |
package require rlink
|
package require rlink
|
package require rutiltpp
|
package require rutiltpp
|
package require rlinktpp
|
package require rlinktpp
|
|
|
rlinkconnect rlc
|
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
|
# setup logging
|
if { $opts(log_) ne "-" } {
|
if { $opts(log_) ne "-" } {
|
rlc config -logfile $opts(log_)
|
rlc config -logfile $opts(log_)
|
}
|
}
|
rlc config -logprintlevel $opts(logl_)
|
rlc config -logprintlevel $opts(logl_)
|
rlc config -logdumplevel $opts(dmpl_)
|
rlc config -logdumplevel $opts(dmpl_)
|
rlc config -logtracelevel $opts(tiol_)
|
rlc config -logtracelevel $opts(tiol_)
|
|
|
# first start, if specified with --run, the test bench
|
# 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 { $opts(run_) ne "" } {
|
if { [catch {eval "exec $opts(run_) &" } runpid] } {
|
if { [catch {exec sh -c $opts(run_) &} runpid] } {
|
puts "-E: failed to execute \"$opts(run_)\" with error message\n $runpid"
|
puts "-E: failed to execute \"$opts(run_)\" with error message\n $runpid"
|
puts "aborting..."
|
puts "aborting..."
|
return 1
|
return 1
|
}
|
}
|
}
|
}
|
