# run.tcl
 # Copyright 2001 by Larry Smith
 # Wild Open Source, Inc
 # For license terms GPL
 #
 # replacement for "source" but expands macros
 # and allows a preprocessing pass for commands
 # delimited by <<< and >>>.  It even provides
 # for "real" comments #...<eol> that are removed
 # before processing.

 proc run { filename { macrolist "" } } {
   if { "$macrolist" != "" } {
     upvar $macrolist macros
   }
   if [catch { set f [ open $filename r ] } err ] { return -code $err }
   set src [ read $f ]
   foreach key [array names macros] {
     regsub -all -linestop $key $src $macros($key) src
   }
   set exp ""
   while 1 {
     if [regexp "(.*)(<<<.*>>>)(.*)" $src -> head exp tail] {
       regsub <<< $exp "" exp
       regsub >>> $exp "" exp
       set result [ uplevel eval $exp ]
       set src "$head$result$tail"
     } else {
       break
     }
   }
   uplevel eval $src
 }

 # here's an example:


 # source run.tcl
 proc compute { args } {
   set exp ""
   set id ""
   regsub "''" [ string trim $args ] "@@@" args
   while 1 {
     regexp "(\[^a-zA-Z_'\]*)(\[a-zA-Z0-9_'\]*)(.*)" $args -> head id tail
     if ![ string length $id ] {
       set exp "$exp$head"
       break
     }
     set dollar ""
     if ![ string equal [ string index $id 0 ] "'" ] {
       if ![ string equal [info commands $id] "" ] {
	 set id "\[ $id"
	 regexp {[^\(]*\(([^\)]*)\)(.*)} $tail -> params tail
	 set tail " $params \]$tail"
       } else { set dollar "\$" }
     }
     append exp "$head$dollar$id"
     set args $tail
   }
   regsub -all "'" $exp "\"" exp
   set map "@@@ ' and && or || not ! <> != true 1 false 0 on 1 off 0 yes 1 no 0 pi 3.1415926535"
   foreach { from to } $map {
     regsub $from $exp $to exp
   }
   set exp [ uplevel subst -novariable \{$exp\} ]
   return "\{ $exp \}"
 }

 set xlate(IF) "if <<< compute "
 set xlate(THEN) ">>> \{"
 set xlate(ELSE) "\} else \{"
 set xlate(ELSIF) "\} elseif \[ compute "
 set xlate(END) "\}"
 set xlate(WHILE) "while \{ \[ compute "
 set xlate(DO) "\] \} \{"
 set xlate(#.*\\n) "\\n"

 run foo.tcl xlate


 # foo.tcl is:

 # This is a real comment

 set x 1

 IF x <> 1 THEN
   puts "x is NOT 1"
 ELSE
   puts "x IS 1"
 END

if 0 {
  results in:

  x IS 1
}

[Category Application] | [Category Dev. Tools]