sics/mcstas/dmc/gumibatch.tcl

#-------------------------------------------------------------
# This is a set of Tcl procedures which try to convert an old 
# batch file into a batch file suitable for Mountaingum.
#
# copyright: GPL
#
# Mark Koennecke, February 2008
#-------------------------------------------------------------
if {[string first tmp $home] < 0} { 
    set tmppath $home/tmp
} else {
    set tmppath $home
}
#-------------------------------------------------------------
proc searchPathForDrivable {name} {
    set path [string trim [hmatchprop / sicsdev $name]]
    if {[string compare $path NONE] != 0} {
	return $path
    }
    set txt [findalias $name]
    if {[string compare $txt NONE] == 0} {
	return NONE
    }
    set l1 [split $txt =]
    set l [split [lindex $l1 1] ,]
    foreach alias $l {
	set alias [string trim $alias]
	set path [string trim [hmatchprop / sicsdev $alias]]
	if {[string compare $path NONE] != 0} {
	    return $path
	}
    }
    return NONE
} 
#----------------------------------------------------------------
proc searchForCommand {name} {
    return [string trim [hmatchprop / sicscommand $name]]
}
#----------------------------------------------------------------
proc treatsscan {scanpath command out} {
    set l [split $command]
    set len [llength $l]
    set noVar [expr ($len-2)/3]
    set np [lindex $l [expr $len -2]]
    set preset [lindex $l [expr $len -1]]
    for {set i 0} {$i < $noVar} {incr i} {
	set start [expr $i * 3]
	set scanVar [lindex $l [expr 1 + $start]]
	set scanStart [lindex $l [expr 2 + $start]]
	set scanEnd [lindex $l [expr 3 + $start]]
        set scanStep [expr ($scanEnd*1. - $scanStart*1.)/$np*1.]
	append hdbVar $scanVar ,
	append hdbStart $scanStart ,
	append hdbStep $scanStep ,
    }
    set hdbVar [string trim $hdbVar ,]
    set hdbStart [string trim $hdbStart ,]
    set hdbStep [string trim $hdbStep ,]
    puts $out "\#NODE: $scanpath"
    puts $out "clientput BatchPos = 1"
    puts $out "hdbscan $hdbVar $hdbStart $hdbStep $np monitor $preset"
}
#----------------------------------------------------------------
proc treatcscan {scanpath command out} {
    set l  [split $command]
    set scanVar [lindex $l 1]
    set scanCenter [lindex $l 2]
    set scanStep [lindex $l 3]
    set np [lindex $l 4]
    set preset [lindex $l 5]
    set hdbStart [expr $scanCenter - ($np*1.0)/2. * $scanStep*1.0]
    puts $out "\#NODE: $scanpath"
    puts $out "clientput BatchPos = 1"
    puts $out "hdbscan $scanVar $hdbStart $scanStep $np monitor $preset"
}
#----------------------------------------------------------------
proc translateCommand {command out} {
    set drivelist [list drive dr run]
    set textList [list for while source if]
#    clientput "Translating: $command"
    set command [string trim $command]
    if {[string length $command] < 2} {
	return
    }
    set l [split $command]
    set obj [string trim [lindex $l 0]]
#------- check for drive commands
    set idx [lsearch $drivelist $obj]
    if {$idx >= 0} {
	set dev [lindex $l 1]
	set path [searchPathForDrivable $dev]
	if {[string compare $path NONE] != 0} {
	    set realTxt [hgetprop $path sicsdev]
	    set realL [split $realTxt =]
	    set realDev [lindex $realL 1]
	    set mapList [list $dev $realDev]
	    set newCom [string map $mapList $command]
	    puts $out "\#NODE: $path"
	    puts $out "clientput BatchPos  = 1"
	    puts $out $newCom
	    return
        }
    }
#------ check for well known broken commands
    set idx [lsearch $textList $obj]
    if {$idx >= 0} {
	puts $out "\#NODE: /batch/commandtext"
	puts $out "clientput BatchPos = 1"
	set buffer [string map {\n @nl@} $command]
	puts $out "hset /batch/commandtext $buffer"
	return
    }
#--------- check for simple commands
    set path [searchForCommand $command]
    if {[string compare $path NONE] != 0} {
	    puts $out "\#NODE: $path"
	    puts $out "clientput BatchPos  = 1"
	    puts $out $command
	    return
    }
    set scancom [searchForCommand hdbscan]
#---------- deal with scans
    if {[string first sscan $obj] >= 0} {
	if {[catch {treatsscan $scancom $command $out}] == 0} {
	    return
        }
    }
    if {[string first cscan $obj] >= 0} {
	if {[catch {treatsscan $scancom $command $out}] == 0} {
	    return
	}
    }
#--------- give up: output as a text node
    puts $out "\#NODE: /batch/commandtext"
    puts $out "clientput BatchPos = 1"
    set buffer [string map {\n @nl@} $command]
    puts $out "hset /batch/commandtext $buffer"
}
#----------------------------------------------------------------
proc mgbatch {filename} {
    global tmppath
    set f [open $filename r]
    gets $f line
    close $f
    if {[string first MOUNTAINBATCH $line] > 0} {
#--------- This is a mountaingum batch file which does not need 
#          to be massaged
	return $filename
    }
    set f [open $filename r]
    set realfilename [file tail $filename]
    set out [open $tmppath/$realfilename w]
    puts $out \#MOUNTAINBATCH
    while {[gets $f line] >= 0} { 
	append buffer $line
	if {[info complete $buffer] == 1} {
	    translateCommand  $buffer $out
	    unset buffer
        } else {
	    append buffer \n
        }
    }
    close $out
    return $tmppath/$realfilename
}
#----------------------------------------------------------------
proc loadmgbatch {filename} {
    set txt [exe fullpath $filename]
    set l [split $txt =]
    set realf [lindex $l 1]
    set realf [mgbatch $realf]
    return [exe print $realf]
}