home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / vcm_compat.tcl < prev    next >
Encoding:
Text File  |  1997-06-06  |  3.5 KB  |  137 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #      (c)     Cayenne Software Inc.    1997
  4. #
  5. #      File:           @(#)vcm_compat.tcl    /main/hindenburg/9
  6. #      Author:         Lex Warners
  7. #      Description:    VCM integration file
  8. #---------------------------------------------------------------------------
  9. # SccsId = @(#)vcm_compat.tcl    /main/hindenburg/9   6 Jun 1997 Copyright 1997 Cayenne Software Inc.
  10.  
  11. # proc to avoid extensive change in titanic code
  12. proc require_module_file {file {module ""}} {
  13.     require $file
  14. }
  15.  
  16. require platform.tcl
  17.  
  18. # old tcl version does not support file split and file join
  19.  
  20. proc file_split { path } {
  21.    if $win95 {
  22.     set pathSep "\\"
  23.     } else {
  24.     set pathSep "/"
  25.     }
  26.     if { [string index $path 0] == "$pathSep" } {
  27.     return [concat [list $pathSep] [split $path $pathSep]]
  28.     }
  29.     return [split $path $pathSep]
  30. }
  31.  
  32. proc file_join { path } {
  33.     if $win95 {
  34.     set pathSep "\\"
  35.     } else {
  36.     set pathSep "/"
  37.     }
  38.     if { [lindex $path 0] == "$pathSep" } {
  39.     return [join [lrange $path 1 end] $pathSep]
  40.     } 
  41.     return [join $path $pathSep]
  42. }
  43.  
  44. if $win95 {
  45.     # the following exec_simul does not like newlines in arguments
  46.     # translate in appropriate way: write multi line string to file
  47.     # and change argument
  48.     global commandOptionDict
  49.     set commandOptionDict [Dictionary new]
  50.     $commandOptionDict set "\-c" "-cfile"
  51.     $commandOptionDict set "/c" "/cf"
  52. }
  53.  
  54. # old tcl cannot do 'exec' on Windows
  55. proc exec_simul {args} {
  56.     global commandOptionDict
  57.     set tmpFile ""
  58.     foreach e $args {
  59.     # replace arguments with newlines with temporary file
  60.     # equivalent
  61.     if [regexp "\n" $e] {
  62.         set prevArgIndex [expr [llength $newargs] -1]
  63.         set newOpt [$commandOptionDict set [lindex $newargs $prevArgIndex]]
  64.         if { $newOpt != "" } {
  65.         set newargs [lreplace $newargs $prevArgIndex $prevArgIndex $newOpt]
  66.         set tmpFile [BasicFS::tmpFile]
  67.         append newargs " $tmpFile"
  68.         BasicFS::writeFile $tmpFile $e
  69.         continue
  70.         }
  71.     }
  72.  
  73.     # prevent loss of quotes
  74.     regsub -all {\"} $e "\\\"" e
  75.  
  76.     # quote arguments that would otherwise become lists:
  77.     # with spaces and backslashes
  78.     # also quote empty arguments 
  79.     if { [regexp {[     \\]} $e] || ($e == "") } {
  80.         append newargs " \"$e\""
  81.     } else {
  82.         append newargs " $e"
  83.     }
  84.     }
  85.     set file [BasicFS::tmpFile]
  86.     set errors [BasicFS::tmpFile]
  87.  
  88.     # command may already contain redirection
  89.     set destFile ""
  90.     if [regexp {(.*) > (.*)} $newargs dummy newCommand destFile] {
  91.     set newargs $newCommand
  92.     set file $destFile
  93.     }
  94.  
  95.     # redirect errors
  96.     global systemCommand
  97.     set status [$systemCommand "cmd.exe /c$newargs 2>$errors >$file"]
  98.  
  99.     if { $tmpFile != "" } {
  100.     BasicFS::removeFile $tmpFile
  101.     }
  102.  
  103.     set fd [open $errors]
  104.     set errorOutput [read -nonewline $fd]
  105.     close $fd
  106.     unlink $errors
  107.  
  108.     # if destFile is set the output is already in a safe place (redirection),
  109.     # otherwise put in command output
  110.     if { $destFile == "" } {
  111.     set fd [open $file]
  112.     set commandOutput [read -nonewline $fd]
  113.     close $fd
  114.     unlink $file
  115.     } else {
  116.     set commandOutput ""
  117.     }
  118.  
  119.     # check errors and throw an exception if errors occurred
  120.     # like tcl7.6 exec returns all output
  121.     if { $errorOutput != "" } {
  122.     set message "$errorOutput"
  123.     if { $commandOutput != "" } {
  124.         set message "$commandOutput$errorOutput"
  125.     }
  126.     error $message
  127.     }
  128.     return $commandOutput
  129. }
  130.  
  131. if $win95 {
  132.     rename exec exec_org
  133.     rename exec_simul exec
  134. }
  135.  
  136.  
  137.