mirror of
https://github.com/wfjm/w11.git
synced 2026-04-25 20:01:57 +00:00
381 lines
11 KiB
Tcl
Executable File
381 lines
11 KiB
Tcl
Executable File
#! /usr/bin/env tclshcpp
|
|
# -*- tcl -*-
|
|
# $Id: ti_rri 1172 2019-06-29 07:27:24Z mueller $
|
|
# SPDX-License-Identifier: GPL-3.0-or-later
|
|
# Copyright 2011-2019 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
|
|
#
|
|
# Revision History:
|
|
# Date Rev Version Comment
|
|
# 2017-06-28 918 1.4.5 adopt Digilent autodetect for CmodA7
|
|
# 2017-04-22 883 1.4.4 setup rbus monitor if detected
|
|
# 2017-01-08 843 1.4.3 allow --term=USBD for Digilent autodetect
|
|
# 2015-01-09 776 1.2.2 add --tout option to setup rlc timeout before connect
|
|
# 2015-01-09 631 1.2.1 use rlc get/set rather config
|
|
# 2014-11-07 601 1.2 use tclshcpp (C++ based) rather tclsh
|
|
# 2013-05-19 521 1.1.6 setup proper interactive handling; add --run reap
|
|
# 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
|
|
# --tout=n ; default 1.
|
|
# --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
|
|
tout_ 1.
|
|
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
|
|
rutil::waitpid $runpid
|
|
}
|
|
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_) }
|
|
^--?tout=.+$ { regexp -- {=(.*)} $arg dummy opts(tout_) }
|
|
^--?int$ { set opts(int) 1 }
|
|
^--?help$ { set opts(help) 1 }
|
|
^--$ { set optsendseen 1 }
|
|
^--?.+$ { puts "-E: bad option $arg, see --help for proper usage"
|
|
exit 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 delimiter here to avoid 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 { --term[=ARGS] open term type rlink port. Optional arguments are:}
|
|
puts { --term=[NAME[,BAUD[,OPTS]]]}
|
|
puts { --cuff[=ARGS] open cuff type rlink port. Optional arguments are:}
|
|
puts { --cuff=[NAME[,OPTS]]}
|
|
puts { --log=FILE set log file name. Default is to write to stdout}
|
|
puts { --logl=LVL set log level, default is '2' allowed values 0-3}
|
|
puts { --dmpl=LVL set dump level, default is '0', values like logl}
|
|
puts { --tiol=LVL set i/o trace level, default is '0', allowed 0-2}
|
|
puts { --tout=dt set timeout, default is '1.', must be >0.}
|
|
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.}
|
|
exit 0
|
|
}
|
|
|
|
if {![info exists env(RETROBASE)]} {
|
|
puts "-E: RETROBASE environment variable not defined"
|
|
exit 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"
|
|
exit 1
|
|
}
|
|
|
|
# setup auto path
|
|
lappend auto_path [file join $env(RETROBASE) tools tcl]
|
|
lappend auto_path [file join $env(RETROBASE) tools lib]
|
|
|
|
# setup default packages
|
|
package require rutiltpp
|
|
package require rlinktpp
|
|
package require rlink
|
|
|
|
# setup signal handling
|
|
rutil::sigaction -init
|
|
|
|
# setup connect and server objects
|
|
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 set logfile $opts(log_)
|
|
}
|
|
rlc set printlevel $opts(logl_)
|
|
rlc set dumplevel $opts(dmpl_)
|
|
rlc set tracelevel $opts(tiol_)
|
|
rlc set timeout $opts(tout_)
|
|
|
|
# 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 "-E: aborting..."
|
|
exit 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"}
|
|
|
|
# autodetect Digilent usb device look to udev signature
|
|
# E: ID_SERIAL=Digilent_Digilent_USB_Device_<serial_number>
|
|
# E: ID_USB_INTERFACE_NUM=01
|
|
# Note on INTERFACE_NUM: '00' is configuration, '01' is communication EP
|
|
#
|
|
if {$dev eq "USBD" || $dev eq "/dev/ttyUSBD"} {
|
|
set dev_usbd {}
|
|
foreach udev [lsort [glob -nocomplain "/dev/ttyUSB*"]] {
|
|
set path [exec udevadm info -q path -n $udev]
|
|
set text [exec udevadm info --export -p $path]
|
|
set id_id {}
|
|
set id_sn {}
|
|
set id_in {}
|
|
foreach line [split $text "\n"] {
|
|
set line [string trim $line]
|
|
regexp -- {^E: ID_SERIAL=(.*)_([0-9a-fA-F]+)$} $line matched id_id id_sn
|
|
regexp -- {^E: ID_USB_INTERFACE_NUM=(.*)$} $line matched id_in
|
|
}
|
|
if {($id_id eq "Digilent_Digilent_USB_Device" || \
|
|
$id_id eq "Digilent_Digilent_Adept_USB_Device" ) \
|
|
&& $id_in eq "01"} {
|
|
set dev_usbd $udev
|
|
break
|
|
}
|
|
}
|
|
if {$dev_usbd ne ""} {
|
|
set dev $dev_usbd
|
|
# puts "-I: Digilent USB interface detected: $dev_usbd"
|
|
} else {
|
|
puts "-E: no Digilent USB interface detected"
|
|
exit 1
|
|
}
|
|
}
|
|
|
|
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
|
|
|
|
set tcl_interactive [rutil::isatty STDIN]
|
|
|
|
# determine whether interactive mode, if yes, initialize readline
|
|
if {$tcl_interactive && ($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 "-E: aborting..."
|
|
break
|
|
}
|
|
# handle @file.dat ect --> not yet supported
|
|
} else {
|
|
puts "-E: only tcl supported but $filename found"
|
|
puts "-E: 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 "-E: aborting..."
|
|
break
|
|
}
|
|
}
|
|
}
|
|
|
|
# setup rbus monitor if detected
|
|
# must be done after all command line commands are processed to allow
|
|
# defered initialization and 'rlc init' hacks.
|
|
if {[rlc get hasrbmon]} {
|
|
package require rbmoni
|
|
rbmoni::setup
|
|
}
|
|
|
|
if { $tcl_interactive && $tirri_interactive } {
|
|
::tclreadline::Loop
|
|
} else {
|
|
tirri_exit 0
|
|
}
|
|
|
|
exit 0
|