Subversion Repositories w11

#! /usr/bin/env tclsh

# -*- tcl -*-

# $Id: ti_rri 386 2011-07-01 17:31:03Z mueller $

#

# Copyright 2011- by Walter F.J. Mueller 

#

# 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-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,keep]

# --term[=name,baud,break]

# --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 {                     KEEP  if non-empty the fifo is kept open on exit}

  puts {  --term[=ARGS]  open term type rlink port. Optional arguments are:}

  puts {                   --term=[NAME,[BAUD,[BREAK]]]}

  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 {                             9600, 19200, 19k, 38400, 38k, 57600, 57k}

  puts {                             115200, 115k, 230400, 230k, 460800, 460k}

  puts {                             500000, 500k, 921600, 921k, 1000000, 1M}

  puts {                             2000000, 2M, 3000000, 3M}

  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 '@.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]

  set keep [lindex $nlist 1]

  if {$path eq ""} {set path "rlink_cext_fifo"}

  set url "fifo:$path"

  if {$keep ne ""} {append url "?keep"}

  rlc open $url

}

# handle --term

if { $opts(term) } {

  set nlist [split $opts(term_) ","]

  set dev  [lindex $nlist 0]

  set baud [lindex $nlist 1]

  set brk  [lindex $nlist 2]

  if {$dev  eq ""} {set dev  "USB0"}

  if {$baud eq ""} {set baud "115k"}

  if {! [regexp -- {^/} $dev]} {

    set dev "/dev/tty$dev"

  }

  set url "term:$dev?baud=$baud"

  if {$brk ne ""} {append url ";break"}

  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