A Pure Tcl self-extracting archive

A single remark from Pat Thoyts made me do this:

Save this file as tclsfx and make it executable.

Usage

 tclsfx file1 ?file2 fileN?

this will create a file named file1-sfx.tcl.

Extraction

 tclsh file1-sfx.tcl 

Will write the archived files to the original file names.

This is a ten minute hack, no sophisticated directory handling is included.

-- PS 03Mar04


    #!/bin/sh
    # This line continues for Tcl, but is a single line for 'sh' \
       exec tclsh "$0" ${1+"$@"}

       catch { package require Trf } 
       package require base64

       set decoder_part1 {
           package require Tcl 8.2
           namespace eval ::base64 {
               namespace export encode decode
           }

           if {![catch {package require Trf 2.0}]} {
               # Trf is available, so implement the functionality provided here
               # in terms of calls to Trf for speed.

               # ::base64::encode --
               #
               #        Base64 encode a given string.
               #
               # Arguments:
               #        args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
               #        args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
               #                If maxlen is 0, the output is not wrapped.
               #
               # Results:
               #        A Base64 encoded version of $string, wrapped at $maxlen characters
               #        by $wrapchar.
               
               proc ::base64::encode {args} {
                   # Set the default wrapchar and maximum line length to match the output
                   # of GNU uuencode 4.2.  Various RFC's allow for different wrapping 
                   # characters and wraplengths, so these may be overridden by command line
                   # options.
                   set wrapchar "\n"
                   set maxlen 60

                   if { [llength $args] == 0 } {
                       error "wrong # args: should be \"[lindex [info level 0] 0]\
                    ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
                   }

                   set optionStrings [list "-maxlen" "-wrapchar"]
                   for {set i 0} {$i < [llength $args] - 1} {incr i} {
                       set arg [lindex $args $i]
                       set index [lsearch -glob $optionStrings "${arg}*"]
                       if { $index == -1 } {
                           error "unknown option \"$arg\": must be -maxlen or -wrapchar"
                       }
                       incr i
                       if { $i >= [llength $args] - 1 } {
                           error "value for \"$arg\" missing"
                       }
                       set val [lindex $args $i]

                       # The name of the variable to assign the value to is extracted
                       # from the list of known options, all of which have an
                       # associated variable of the same name as the option without
                       # a leading "-". The [string range] command is used to strip
                       # of the leading "-" from the name of the option.
                       #
                       # FRINK: nocheck
                       set [string range [lindex $optionStrings $index] 1 end] $val
                   }
                   
                   # [string is] requires Tcl8.2; this works with 8.0 too
                   if {[catch {expr {$maxlen % 2}}]} {
                       error "expected integer but got \"$maxlen\""
                   }

                   set string [lindex $args end]
                   set result [::base64 -mode encode -- $string]
                   set result [string map [list \n ""] $result]

                   if {$maxlen > 0} {
                       set res ""
                       set edge [expr {$maxlen - 1}]
                       while {[string length $result] > $maxlen} {
                           append res [string range $result 0 $edge]$wrapchar
                           set result [string range $result $maxlen end]
                       }
                       if {[string length $result] > 0} {
                           append res $result
                       }
                       set result $res
                   }

                   return $result
               }

               # ::base64::decode --
               #
               #        Base64 decode a given string.
               #
               # Arguments:
               #        string  The string to decode.  Characters not in the base64
               #                alphabet are ignored (e.g., newlines)
               #
               # Results:
               #        The decoded value.

               proc ::base64::decode {string} {
                   ::base64 -mode decode -- $string
               }

           } else {
               # Without Trf use a pure tcl implementation

               namespace eval base64 {
                   variable base64 {}
                   variable base64_en {}

                   # We create the auxiliary array base64_tmp, it will be unset later.

                   set i 0
                   foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
                                     a b c d e f g h i j k l m n o p q r s t u v w x y z \
                                     0 1 2 3 4 5 6 7 8 9 + /} {
                       set base64_tmp($char) $i
                       lappend base64_en $char
                       incr i
                   }

                   #
                   # Create base64 as list: to code for instance C<->3, specify
                   # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
                   # ascii chars get a {}. we later use the fact that lindex on a
                   # non-existing index returns {}, and that [expr {} < 0] is true
                   #

                   # the last ascii char is 'z'
                   scan z %c len
                   for {set i 0} {$i <= $len} {incr i} {
                       set char [format %c $i]
                       set val {}
                       if {[info exists base64_tmp($char)]} {
                           set val $base64_tmp($char)
                       } else {
                           set val {}
                       }
                       lappend base64 $val
                   }

                   # code the character "=" as -1; used to signal end of message
                   scan = %c i
                   set base64 [lreplace $base64 $i $i -1]

                   # remove unneeded variables
                   unset base64_tmp i char len val

                   namespace export encode decode
               }

               # ::base64::encode --
               #
               #        Base64 encode a given string.
               #
               # Arguments:
               #        args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
               #        args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
               #                If maxlen is 0, the output is not wrapped.
               #
               # Results:
               #        A Base64 encoded version of $string, wrapped at $maxlen characters
               #        by $wrapchar.
               
               proc ::base64::encode {args} {
                   set base64_en $::base64::base64_en
                   
                   # Set the default wrapchar and maximum line length to match the output
                   # of GNU uuencode 4.2.  Various RFC's allow for different wrapping 
                   # characters and wraplengths, so these may be overridden by command line
                   # options.
                   set wrapchar "\n"
                   set maxlen 60

                   if { [llength $args] == 0 } {
                       error "wrong # args: should be \"[lindex [info level 0] 0]\
                    ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
                   }

                   set optionStrings [list "-maxlen" "-wrapchar"]
                   for {set i 0} {$i < [llength $args] - 1} {incr i} {
                       set arg [lindex $args $i]
                       set index [lsearch -glob $optionStrings "${arg}*"]
                       if { $index == -1 } {
                           error "unknown option \"$arg\": must be -maxlen or -wrapchar"
                       }
                       incr i
                       if { $i >= [llength $args] - 1 } {
                           error "value for \"$arg\" missing"
                       }
                       set val [lindex $args $i]

                       # The name of the variable to assign the value to is extracted
                       # from the list of known options, all of which have an
                       # associated variable of the same name as the option without
                       # a leading "-". The [string range] command is used to strip
                       # of the leading "-" from the name of the option.
                       #
                       # FRINK: nocheck
                       set [string range [lindex $optionStrings $index] 1 end] $val
                   }
                   
                   # [string is] requires Tcl8.2; this works with 8.0 too
                   if {[catch {expr {$maxlen % 2}}]} {
                       error "expected integer but got \"$maxlen\""
                   }

                   set string [lindex $args end]

                   set result {}
                   set state 0
                   set length 0


                   # Process the input bytes 3-by-3

                   binary scan $string c* X
                   foreach {x y z} $X {
                       # Do the line length check before appending so that we don't get an
                       # extra newline if the output is a multiple of $maxlen chars long.
                       if {$maxlen && $length >= $maxlen} {
                           append result $wrapchar
                           set length 0
                       }
                       
                       append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] 
                       if {$y != {}} {
                           append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] 
                           if {$z != {}} {
                               append result \
                                   [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
                               append result [lindex $base64_en [expr {($z & 0x3F)}]]
                           } else {
                               set state 2
                               break
                           }
                       } else {
                           set state 1
                           break
                       }
                       incr length 4
                   }
                   if {$state == 1} {
                       append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== 
                   } elseif {$state == 2} {
                       append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]=  
                   }
                   return $result
               }

               # ::base64::decode --
               #
               #        Base64 decode a given string.
               #
               # Arguments:
               #        string  The string to decode.  Characters not in the base64
               #                alphabet are ignored (e.g., newlines)
               #
               # Results:
               #        The decoded value.

               proc ::base64::decode {string} {
                   if {[string length $string] == 0} {return ""}

                   set base64 $::base64::base64

                   binary scan $string c* X
                   foreach x $X {
                       set bits [lindex $base64 $x]
                       if {$bits >= 0} {
                           if {[llength [lappend nums $bits]] == 4} {
                               foreach {v w z y} $nums break
                               set a [expr {($v << 2) | ($w >> 4)}]
                               set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
                               set c [expr {(($z & 0x3) << 6) | $y}]
                               append output [binary format ccc $a $b $c]
                               set nums {}
                           }            {}
                       } elseif {$bits == -1} {
                           # = indicates end of data.  Output whatever chars are left.
                           # The encoding algorithm dictates that we can only have 1 or 2
                           # padding characters.  If x=={}, we have 12 bits of input 
                           # (enough for 1 8-bit output).  If x!={}, we have 18 bits of
                           # input (enough for 2 8-bit outputs).
                           
                           foreach {v w z} $nums break
                           set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
                           
                           if {$z == {}} {
                               append output [binary format c $a ]
                           } else {
                               set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
                               append output [binary format cc $a $b]
                           }            tput [binary format cc $a $b]
                           break
                       } else {
                           # RFC 2045 says that line breaks and other characters not part
                           # of the Base64 alphabet must be ignored, and that the decoder
                           # can optionally emit a warning or reject the message.  We opt
                           # not to do so, but to just ignore the character. 
                           continue
                       }
                   }
                   return $output
               }
           }

           package provide base64 2.2.2


       }

       set decoder_part2 {
           foreach {file data} $files {
               set out [open $file w]
               fconfigure $out -translation binary 
               puts -nonewline $out [base64::decode $data]
               close $out
           }
       }

       set out [open [lindex $argv 0]-sfx.tcl w]
       puts $out $decoder_part1

       puts $out "set files {"

       foreach file $argv {
           set in [open $file r]
           fconfigure $in -translation binary 
           
           set data [base64::encode [read $in]]

           puts $out [list $file $data]
           close $in
           
       }

       puts $out "}"

       puts $out $decoder_part2

RS wonders whether Tcllib's base64 could not also be used here?