home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / tcl / tcl_1 / !tclnew_tclnew < prev    next >
Encoding:
Text File  |  1995-02-06  |  1.7 KB  |  78 lines
  1. # Create a new tcl application directory
  2.  
  3. w_init tclnew
  4.  
  5. w_box progInfo create "About this program"\
  6.  { vlist {info Name tclnew}
  7.          {info Purpose "Create tcl Applications"}
  8.          {info Author C.T.Stretch}
  9.          {info Version 0.00}
  10.  }
  11.  
  12. w_bar -menu { TclNew {Info -dbox progInfo}
  13.                      {Quit -click exit}
  14.             }\
  15.       -click {w_box newbox open}
  16.  
  17. set outdir !
  18.  
  19. w_box newbox create tclnew\
  20.  { vlist {save application outdir {savedrag $w_file }}
  21.          {hlist {action Cancel} {default Save {saveclick }}}
  22.  }
  23.  
  24. proc savedrag {f}\
  25.  { global outdir
  26.    set outdir $f
  27.    doit
  28.    return 0
  29.  }
  30.  
  31. proc saveclick {}\
  32.  { global outdir
  33.    if [string match *.* $outdir] \
  34.    { doit
  35.      return 0
  36.    }
  37.    w_error "To save, drag the icon to a directory display"
  38.    return 0
  39.  }
  40.  
  41. proc doit {}\
  42.  {  global prog outdir
  43.     set indir [getenv tclnew\$dir].model
  44.     set n [string last . $outdir]
  45.     set prog [string range $outdir [expr $n+2] end]
  46.     if {[file exists $outdir]}\
  47.     { if {[file type $outdir]!=8192}\
  48.          { w_error "!$prog exists as a file"
  49.            return 1
  50.          }
  51.       if {![w_error "Overwrite current !$prog" -ok -cancel]} {return 1}
  52.     }
  53.     system "cdir $outdir"
  54.     process $indir.!Boot $outdir.!Boot Obey
  55.     process $indir.!Run $outdir.!Run   Obey
  56.     process $indir.XXXXX $outdir.$prog Text
  57.     system "<TclNew\$Dir>.newsprites $prog $outdir >null:"
  58.     system "run $outdir.!Boot"
  59.     return 0
  60.  }
  61.  
  62. proc process {in out type}\
  63.  { global prog
  64.    set fin  [open $in r]
  65.    set fout [open $out w]
  66.    while {![eof $fin]}\
  67.    { set p [gets $fin]
  68.      regsub -all XXXXX $p $prog p
  69.      puts $fout $p
  70.    }
  71.    close $fin
  72.    close $fout
  73.    system "settype $out $type"
  74.  }
  75.  
  76.  
  77.  
  78.