tclsfx file1 ?file2 fileN?this will create a file named file1-sfx.tcl.Extraction
tclsh file1-sfx.tclWill 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_part2RS wonders whether Tcllib's base64 could not also be used here?
