1# uuencode - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# Provide a Tcl only implementation of uuencode and uudecode. 4# 5# ------------------------------------------------------------------------- 6# See the file "license.terms" for information on usage and redistribution 7# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 8# ------------------------------------------------------------------------- 9# @(#)$Id: uuencode.tcl,v 1.22 2009/05/07 01:10:37 patthoyts Exp $ 10 11package require Tcl 8.2; # tcl minimum version 12 13# Try and get some compiled helper package. 14if {[catch {package require tcllibc}]} { 15 catch {package require Trf} 16} 17 18namespace eval ::uuencode { 19 variable version 1.1.5 20 21 namespace export encode decode uuencode uudecode 22} 23 24proc ::uuencode::Enc {c} { 25 return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] 26} 27 28proc ::uuencode::Encode {s} { 29 set r {} 30 binary scan $s c* d 31 foreach {c1 c2 c3} $d { 32 if {$c1 == {}} {set c1 0} 33 if {$c2 == {}} {set c2 0} 34 if {$c3 == {}} {set c3 0} 35 append r [Enc [expr {$c1 >> 2}]] 36 append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]] 37 append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] 38 append r [Enc [expr {($c3 & 077)}]] 39 } 40 return $r 41} 42 43 44proc ::uuencode::Decode {s} { 45 if {[string length $s] == 0} {return ""} 46 set r {} 47 binary scan [pad $s] c* d 48 49 foreach {c0 c1 c2 c3} $d { 50 append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF 51 | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]] 52 append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF 53 | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]] 54 append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF 55 | (($c3-0x20)&0x3F) & 0xFF}]] 56 } 57 return $r 58} 59 60# ------------------------------------------------------------------------- 61# C coded version of the Encode/Decode functions for base64c package. 62# ------------------------------------------------------------------------- 63if {[package provide critcl] != {}} { 64 namespace eval ::uuencode { 65 critcl::ccode { 66 #include <string.h> 67 static unsigned char Enc(unsigned char c) { 68 return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; 69 } 70 } 71 critcl::ccommand CEncode {dummy interp objc objv} { 72 Tcl_Obj *inputPtr, *resultPtr; 73 int len, rlen, xtra; 74 unsigned char *input, *p, *r; 75 76 if (objc != 2) { 77 Tcl_WrongNumArgs(interp, 1, objv, "data"); 78 return TCL_ERROR; 79 } 80 81 inputPtr = objv[1]; 82 input = Tcl_GetByteArrayFromObj(inputPtr, &len); 83 if ((xtra = (3 - (len % 3))) != 3) { 84 if (Tcl_IsShared(inputPtr)) 85 inputPtr = Tcl_DuplicateObj(inputPtr); 86 input = Tcl_SetByteArrayLength(inputPtr, len + xtra); 87 memset(input + len, 0, xtra); 88 len += xtra; 89 } 90 91 rlen = (len / 3) * 4; 92 resultPtr = Tcl_NewObj(); 93 r = Tcl_SetByteArrayLength(resultPtr, rlen); 94 memset(r, 0, rlen); 95 96 for (p = input; p < input + len; p += 3) { 97 char a, b, c; 98 a = *p; b = *(p+1), c = *(p+2); 99 *r++ = Enc(a >> 2); 100 *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); 101 *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); 102 *r++ = Enc(c & 077); 103 } 104 Tcl_SetObjResult(interp, resultPtr); 105 return TCL_OK; 106 } 107 108 critcl::ccommand CDecode {dummy interp objc objv} { 109 Tcl_Obj *inputPtr, *resultPtr; 110 int len, rlen, xtra; 111 unsigned char *input, *p, *r; 112 113 if (objc != 2) { 114 Tcl_WrongNumArgs(interp, 1, objv, "data"); 115 return TCL_ERROR; 116 } 117 118 /* if input is not mod 4, extend it with nuls */ 119 inputPtr = objv[1]; 120 input = Tcl_GetByteArrayFromObj(inputPtr, &len); 121 if ((xtra = (4 - (len % 4))) != 4) { 122 if (Tcl_IsShared(inputPtr)) 123 inputPtr = Tcl_DuplicateObj(inputPtr); 124 input = Tcl_SetByteArrayLength(inputPtr, len + xtra); 125 memset(input + len, 0, xtra); 126 len += xtra; 127 } 128 129 /* output will be 1/3 smaller than input and a multiple of 3 */ 130 rlen = (len / 4) * 3; 131 resultPtr = Tcl_NewObj(); 132 r = Tcl_SetByteArrayLength(resultPtr, rlen); 133 memset(r, 0, rlen); 134 135 for (p = input; p < input + len; p += 4) { 136 char a, b, c, d; 137 a = *p; b = *(p+1), c = *(p+2), d = *(p+3); 138 *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); 139 *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); 140 *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); 141 } 142 Tcl_SetObjResult(interp, resultPtr); 143 return TCL_OK; 144 } 145 } 146} 147 148# ------------------------------------------------------------------------- 149 150# Description: 151# Permit more tolerant decoding of invalid input strings by padding to 152# a multiple of 4 bytes with nulls. 153# Result: 154# Returns the input string - possibly padded with uuencoded null chars. 155# 156proc ::uuencode::pad {s} { 157 if {[set mod [expr {[string length $s] % 4}]] != 0} { 158 append s [string repeat "`" [expr {4 - $mod}]] 159 } 160 return $s 161} 162 163# ------------------------------------------------------------------------- 164 165# If the Trf package is available then we shall use this by default but the 166# Tcllib implementations are always visible if needed (ie: for testing) 167if {[info command ::uuencode::CDecode] != {}} { 168 # tcllib critcl package 169 interp alias {} ::uuencode::encode {} ::uuencode::CEncode 170 interp alias {} ::uuencode::decode {} ::uuencode::CDecode 171} elseif {[package provide Trf] != {}} { 172 proc ::uuencode::encode {s} { 173 return [::uuencode -mode encode -- $s] 174 } 175 proc ::uuencode::decode {s} { 176 return [::uuencode -mode decode -- [pad $s]] 177 } 178} else { 179 # pure-tcl then 180 interp alias {} ::uuencode::encode {} ::uuencode::Encode 181 interp alias {} ::uuencode::decode {} ::uuencode::Decode 182} 183 184# ------------------------------------------------------------------------- 185 186proc ::uuencode::uuencode {args} { 187 array set opts {mode 0644 filename {} name {}} 188 set wrongargs "wrong \# args: should be\ 189 \"uuencode ?-name string? ?-mode octal?\ 190 (-file filename | ?--? string)\"" 191 while {[string match -* [lindex $args 0]]} { 192 switch -glob -- [lindex $args 0] { 193 -f* { 194 if {[llength $args] < 2} { 195 return -code error $wrongargs 196 } 197 set opts(filename) [lindex $args 1] 198 set args [lreplace $args 0 0] 199 } 200 -m* { 201 if {[llength $args] < 2} { 202 return -code error $wrongargs 203 } 204 set opts(mode) [lindex $args 1] 205 set args [lreplace $args 0 0] 206 } 207 -n* { 208 if {[llength $args] < 2} { 209 return -code error $wrongargs 210 } 211 set opts(name) [lindex $args 1] 212 set args [lreplace $args 0 0] 213 } 214 -- { 215 set args [lreplace $args 0 0] 216 break 217 } 218 default { 219 return -code error "bad option [lindex $args 0]:\ 220 must be -file, -mode, or -name" 221 } 222 } 223 set args [lreplace $args 0 0] 224 } 225 226 if {$opts(name) == {}} { 227 set opts(name) $opts(filename) 228 } 229 if {$opts(name) == {}} { 230 set opts(name) "data.dat" 231 } 232 233 if {$opts(filename) != {}} { 234 set f [open $opts(filename) r] 235 fconfigure $f -translation binary 236 set data [read $f] 237 close $f 238 } else { 239 if {[llength $args] != 1} { 240 return -code error $wrongargs 241 } 242 set data [lindex $args 0] 243 } 244 245 set r {} 246 append r [format "begin %o %s" $opts(mode) $opts(name)] "\n" 247 for {set n 0} {$n < [string length $data]} {incr n 45} { 248 set s [string range $data $n [expr {$n + 44}]] 249 append r [Enc [string length $s]] 250 append r [encode $s] "\n" 251 } 252 append r "`\nend" 253 return $r 254} 255 256# ------------------------------------------------------------------------- 257# Description: 258# Perform uudecoding of a file or data. A file may contain more than one 259# encoded data section so the result is a list where each element is a 260# three element list of the provided filename, the suggested mode and the 261# data itself. 262# 263proc ::uuencode::uudecode {args} { 264 array set opts {mode 0644 filename {}} 265 set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" 266 while {[string match -* [lindex $args 0]]} { 267 switch -glob -- [lindex $args 0] { 268 -f* { 269 if {[llength $args] < 2} { 270 return -code error $wrongargs 271 } 272 set opts(filename) [lindex $args 1] 273 set args [lreplace $args 0 0] 274 } 275 -- { 276 set args [lreplace $args 0 0] 277 break 278 } 279 default { 280 return -code error "bad option [lindex $args 0]:\ 281 must be -file" 282 } 283 } 284 set args [lreplace $args 0 0] 285 } 286 287 if {$opts(filename) != {}} { 288 set f [open $opts(filename) r] 289 set data [read $f] 290 close $f 291 } else { 292 if {[llength $args] != 1} { 293 return -code error $wrongargs 294 } 295 set data [lindex $args 0] 296 } 297 298 set state false 299 set result {} 300 301 foreach {line} [split $data "\n"] { 302 switch -exact -- $state { 303 false { 304 if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \ 305 -> opts(mode) opts(name)]} { 306 set state true 307 set r {} 308 } 309 } 310 311 true { 312 if {[string match "end" $line]} { 313 set state false 314 lappend result [list $opts(name) $opts(mode) $r] 315 } else { 316 scan $line %c c 317 set n [expr {($c - 0x21)}] 318 append r [string range \ 319 [decode [string range $line 1 end]] 0 $n] 320 } 321 } 322 } 323 } 324 325 return $result 326} 327 328# ------------------------------------------------------------------------- 329 330package provide uuencode $::uuencode::version 331 332# ------------------------------------------------------------------------- 333# 334# Local variables: 335# mode: tcl 336# indent-tabs-mode: nil 337# End: 338 339