archive/src/install.tcl

   1 #!/bin/sh
   2 # comment \
   3 exec wish8.0 "$0" "$@"
   4 # this file extracts a bunch of files at the end of it
   5 # files are marked by "\n>>>Begin filename length\n"
   6 # if the filename is *.doeval then it is evaluated as
   7 # a tcl script, at the time it is encoutered.
   8
   9 proc main { } {
  10     global argv0 argv files
  11     set done ""
  12     set fi [open $argv0 r]
  13     fconfigure $fi -translation binary
  14     set data [read $fi 2000]
  15     set outdir /tmp/jim
  16     assureExists $outdir directory
  17     while { [outputOneFile $fi $outdir] } { }
  18     if {[llength $done] > 0 } {
  19         puts "unpacked $done"
  20         exit 0
  21     } else {
  22         puts "failed"
  23         exit 1
  24     }
  25 }
  26
  27 proc outputOneFile {  stream outdir } {
  28     upvar 1 done done
  29     upvar 1 data data
  30     set exp  "\n>>>Begin (\[^ ]*) (\[0-9]+)\r?\n"
  31     puts "entering:[string length $data],[string range $data 0 200]"
  32     if { [regexp -indices $exp $data all] } {
  33         regexp $exp $data junk filename filesize
  34         set data [string range $data [expr 1 + [lindex $all 1]] end]
  35     } else { return 0 }
  36     if { [regexp {\.doeval$} $filename] } {
  37         eval $data
  38         return
  39     }
  40     set outfile [file join $outdir $filename]
  41     assureExists [file dirname $outfile] directory
  42     set ff [open $outfile w]
  43     fconfigure $ff -translation binary
  44     set remains $filesize
  45     while { 1 } {
  46         if { [string length $data] >= $remains } {
  47             puts -nonewline $ff [string range $data 0 [expr $remains -1]]
  48             set data [string range $data $remains end]
  49             lappend done [list $filename $filesize $outfile]
  50             close $ff
  51             return 1
  52         } else { puts -nonewline $ff $data
  53                  incr remains -[string length $data]
  54                   #puts "writing [string length $data]"
  55                  set data ""
  56         }
  57         set read [read $stream 5000]
  58         append data $read
  59         if { [string length $read] == 0 } {
  60             close $ff
  61             file delete $outfile
  62             error "Terminates in middle of reading $filename: remains $remains"
  63         }
  64     }
  65 }
  66
  67
  68
  69 proc assureExists { dir type } {
  70     if { [catch {file stat $dir stat} ] } {
  71         if { "$type" == "directory" } {
  72             file mkdir $dir
  73             return 1
  74         }
  75     }
  76     if { "$stat(type)" != "directory" }  {
  77         error "not a $type it is a $stat(type)"
  78 }   }
  79
  80
  81
  82 main
  83
  84
  85
  86
  87 >>>Begin xmcd.tgz 651163
  88 jimmy
  89
  90 >>>Begin billy 8
  91 hi there
  92
  93