diff options
Diffstat (limited to 'tcllib/modules/base64')
24 files changed, 3185 insertions, 0 deletions
diff --git a/tcllib/modules/base64/ChangeLog b/tcllib/modules/base64/ChangeLog new file mode 100644 index 0000000..c182107 --- /dev/null +++ b/tcllib/modules/base64/ChangeLog @@ -0,0 +1,428 @@ +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2013-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.man: [Bug 3581373]: Document behaviour for -maxlen 0. + +2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-11-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.test: [Bug 2976290]: Disable new test when Trf is + available. It actually performs a decoding. + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2010-07-06 Andreas Kupries <andreask@activestate.com> + + * base64.tcl (::base64::decode): [Bug 2976290]: Throw a proper + * base64.man: error when trying to decode padding with not enough + * base64.test: data in front of it. Extended testsuite. Bumped to + * pkgIndex.tcl: version 2.4.2. + +2010-05-04 Andreas Kupries <andreask@activestate.com> + + * base64.man:: Fix small typo, default for -maxlen changed to 76. + +2010-05-03 Andreas Kupries <andreask@activestate.com> + + * ascii85.man: [FR 2993200]: Added new package ascii85, + * ascii85.tcl: provided by Emiliano + * ascii85.test: <egavilan@users.sourceforge.net> + * pkgIndex.tcl: + +2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-05-07 Pat Thoyts <patthoyts@users.sourceforge.net> + + * uuencode.tcl: Changed poor idiom for setting interp result. + * yencode.tcl: + +2009-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.tcl: Define a number of transient variables in the + namespace, to avoid creative-writing. Fixes [Bug 2538424]. + + * pkgIndex.tcl: Bumped version to 2.4.1. + * base64.man: + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-12-11 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * yencode.tcl: Fixed bug in the yencoder. Escaped characters + * yencode.man: have to be rotated by 64 according to the yEnc + * yencode.test: specification v1.3, not 42. Bumped version to + * pkgIndex.tcl: 1.1.2. Updated tests. + + * uuencode.test: Better handling of loading 'tcllibc'. + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.pcx: New files. Syntax definitions for the public + * uuencode.pcx: commands of the packages base74, uuencode, + * yencode.pcx: and yencode. + +2008-05-28 Andreas Kupries <andreask@activestate.com> + + * base64.tcl: Changed the default setting for -maxlen to 76 to + * base64.man: coincide with MIME definitions and Trf, making + * base64.test: the very fast path default, with no output reflow + * pkgIndex.tcl: required at all. Bumped version to 2.4. + + ** POTENTIAL INCOMPATIBILITY ** for all users depending on the + default setting to be 60. + +2008-05-22 Andreas Kupries <andreask@activestate.com> + + * base64.test: Extended with tests using bogus values of -maxchar, + * base64.tcl: and non-standard values. Fixed bugs in the maxlen + * base64.man: handling of the pure Tcl implementation which + * pkgIndex.tcl: allowed the output to have more than maxlen + characters per line. Performance fix: Replaced Miguel's O(n^2) + reflow algorithm (maxlen handling after Trf) with Gustaf + Neumann's O(n) algorithm. Minor changes to the guarding + conditions by myself, and fixes for the fast cases. Bumped the + version to 2.3.3. + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.man: Fixed all warnings due to use of now deprecated + * uuencode.man: commands. Added a section about how to give + * yencode.man: feedback. + +2006-11-04 Pat Thoyts <patthoyts@users.sourceforge.net> + + * base64c.tcl: Silence critcl warning. + +2006-10-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * uuencode.test: Documentation and code (error messages) disagreed + * uuencode.man: about the accepted options, and tests were + * uuencode.tcl: missing entirely. The code additionally missed + some checks regarding the proper number of arguments, nor had it + tests checking that either. Added tests and synchronized code + and documentation. + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * yencode.test: More boilerplate simplified via use of test support. + * uuencode.test: + * base64.test: + +2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * yencode.test: Hooked into the new common test support code. + * uuencode.test: + * base64.test: + +2005-10-18 Andreas Kupries <andreask@activestate.com> + + * base64.bench: Basic benchmarks for base64, uuencode, + * uuencode.bench: and yencode. Encode/decode of strings + * yencode.bench: only. + +2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-08-26 Andreas Kupries <andreask@activestate.com> + + * uuencode.test: Deconfused the testsuite's belief of which + accelerators is in use. Removed superfluous output, and added a + flag variable for actual use of Trf, not only presence. Changed + definition of test 1.4 to use this flag. This is for [Tcllib SF + Bug 1273537]. + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.man: Cleaned the doc up a bit. Especially highlighted the + recently added note recording binary by separating it from the + general description a bit (same location, new paragraph). + +2005-02-17 Pat Thoyts <patthoyts@users.sourceforge.net> + + * base64.man: Added some examples and attempted to point out that + proper string encoding may be needed for unicode strings. + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-08-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.tcl: Typo police. + * uuencode.tcl: + * uuencode.man: + * yencode.man: + +2004-07-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * uuencode.man: Polished a bit (options, keywords). + * yencode.man: + +2004-07-19 Andreas Kupries <andreask@activestate.com> + + * base64.man: Added copyright notes for the early authors, as far + as I am aware of them. + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * uuencode.tcl: Updated version number to sync with 1.6.1 + * uuencode.man: release + * pkgIndex.tcl: + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * uuencode.tcl: Rel. engineering. Updated version number + * uuencode.man: of uuencode to reflect its changes, to 1.1.1. + * pkgIndex.tcl: + +2004-03-09 Jeff Hobbs <jeffh@ActiveState.com> + + * uuencode.tcl (::uuencode::pad): don't use log package + +2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2003-10-24 Andreas Kupries <andreask@activestate.com> + + * base64.test: + * base64.tcl: Applied patch fixing [Bug 821126]. Variable 'output' + is now initialized to empty to have it defined at all + times. Extended testsuite to cover the fixed cases. + +2003-10-21 Andreas Kupries <andreask@activestate.com> + + * base64.tcl: Added code to the Trf supported 'decode'r to ignore + whitespace in hte encoded input. [Bug 736900]. + +2003-07-24 Pat Thoyts <patthoyts@users.sourceforge.net> + + * base64c.tcl: Added the placeholder package. + +2003-05-14 Pat Thoyts <patthoyts@users.sourceforge.net> + + * Merged DEVELOPMENT branch from DEVELOPMENT-root to + DEVELOPMENT-merge-1 This brings in the critcl enhancements for + uuencode and yencode along with a few extra tests for yencode. + +2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-04-22 Pat Thoyts <patthoyts@users.sourceforge.net> + + * base64c.tcl: Added file to define the base64c C coded package. + * uuencode.tcl: Added critcl code into the package. + * yencode.tcl: Added critcl code into the package. + +2003-04-22 Pat Thoyts <patthoyts@users.sourceforge.net> + + * all: Created DEVELOPMENT branch - tagged root-DEVELOPMENT. + This branch contains criticl-based C code to speed up some of the + computationally expensive functions - generates a base64c package. + +2003-04-21 Andreas Kupries <andreask@pliers.activestate.com> + + * uuencode.test: Added code to suppress output from the log + package during the test. + +2003-04-11 Andreas Kupries <andreask@activestate.com> + + * uuencode.man: + * base64.tcl: + * base64.man: + * pkgIndex.tcl: Fixed bug #614591. Set version of the base64 + package to to 2.2.2. uuencode is now at version 1.0.2 + throughout. + +2003-03-24 Andreas Kupries <andreask@activestate.com> + + * uuencode.test: + * uuencode.tcl: Fixed bug #700327, reported by Roger Niva + <rniva@users.sourceforge.net>. Added '--' before actual data + argument to prevent mishandling of data beginning with a dash + ('-'). Extended the testsuite to cover these cases. + +2003-02-23 David N. Welton <davidw@dedasys.com> + + * base64.tcl: Bumped base64.tcl Tcl requirement to 8.2, swapped + out regsub for string map. + +2003-01-25 Pat Thoyts <patthoyts@users.sourceforge.net> + + * yencode.tcl: + * uuencode.tcl: Added Tcl 8.2 version requirement, bumped versions + and added copyright to man pages. Fixed uuencode to work with Tcl 8.2 + +2002-06-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: + * base64.tcl: + * base64.n: + * base64.man: Bumped base64 to version 2.2.1. + + * pkgIndex.tcl: + * uuencode.tcl: + * uuencode.n: + * uuencode.man: Bumped uuencode to version 1.0.1. + +2002-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * yencode.test: Fixed SF Tcllib Bug #548354 so that the datafile + used by the test is found even if the build directory is outside + of the tcllib directory hierarchy. Original patch provided by Larry + Virden <lvirden@users.sourceforge.net>, changed by me to work in + my configuration too. + +2002-04-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * uuencode.tcl: + * yencode.tcl: + * base64.tcl: Fixed decoding of empty string in tcl + implementation. Fixes bug #548112. + +2002-04-17 Pat Thoyts <patthoyts@users.sourceforge.net> + + * yencode.tcl, yencode.test, yencode.man, yencode.test.data, + * yencode.test.out: initial import of yEnc encode/decode package + plus man page and test. + +2002-04-17 Pat Thoyts <patthoyts@users.sourceforge.net> + + * uuencode.tcl: fixed bug #544452 to handle DOS input files and + tolerate incorrect uuencoded line lengths. + * uuencode.test: added tests for the above bug conditions. + +2002-01-17 Pat Thoyts <patthoyts@users.sourceforge.net> + + * uuencode.tcl: added support for Trf and fixed length bug + +2002-01-16 Pat Thoyts <patthoyts@users.sourceforge.net> + + * uuencode.tcl: initial import of uuencode package + * pkgIndex.tcl: added uuencode package + +2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.tcl: Restricted export list to public API. + [456255]. Patch by Hemang Lavana + <hemanglavana@users.sourceforge.net> + +2001-07-31 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.n: Added manpage [446584]. + +2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base64.tcl: Frink 2.2 run, fixed dubious code. + +2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net + + * base64.tcl: Fixed dubious code reported by frink. + +2001-06-02 Miguel Sofer <mig@utdt.edu> + + * base64.tcl: Greatly increased speed, obtained by: using lists + instead of arrays, splitting the input with [binary scan], + taking the bytes to be encoded three at a time, and + reformulating the decoding algorithm to be purely + arithmetic. Improved backwards compatibility, now runs with + Tcl8.0. + + Nudged version to 2.2 + +2000-10-11 Brent Welch <welch@ajubasolutions.com> + + * base64.tcl: Fixed bug in base64::decode where trailing + bytes were not always decoded correctly (!). This only + shows up with low-valued characters (less than 0x10) near + the end of a string that was padded with = + + Nudged version to 2.1 so we can distinquish this version + that has bug fixes and new features. + +2000-10-10 Eric Melski <ericm@ajubasolutions.com> + + * base64.tcl: Extending base64::encode to accept optional + arguments ?-maxlen maxlen? and ?-wrapchar wrapchar?, to control + the line wrapping and the character(s) used to cause the + wrapping. Based on work by Joel Saunier. + +2000-03-09 Eric Melski <ericm@scriptics.com> + + * base64.test: Adapted tests to work in tcllib test framework. + +2000-03-04 Eric Melski <ericm@scriptics.com> + + * base64.test: Added tests for decoding data that was padded with ='s + + * base64.tcl: Fixed a bug with line wrapping in the encoder -- it + was not properly counting the number of characters emitted, so it + was not wrapping when it should. Changed the chars/line to 60, so + the output would be identical to that produced by GNU uuecode 4.2, + for easy testing purposes. Fixed a bug in the decoder with + newlines -- it was not ignoring them as it should according to RFC + 2045. + Fixed a bug in decoder dealing with data that was padded with ='s. + + + * base64.test: Some rudimentary tests for the encoder/decoder. + +2000-03-02 Eric Melski <ericm@scriptics.com> + + * pkgIndex.tcl: added pkgIndex file. diff --git a/tcllib/modules/base64/ascii85.man b/tcllib/modules/base64/ascii85.man new file mode 100644 index 0000000..aab71a1 --- /dev/null +++ b/tcllib/modules/base64/ascii85.man @@ -0,0 +1,75 @@ +[manpage_begin ascii85 n 1.0] +[keywords ascii85] +[keywords encoding] +[copyright "2010, Emiliano Gavil\u00e1n"] +[moddesc {Text encoding & decoding binary data}] +[titledesc {ascii85-encode/decode binary data}] +[category {Text processing}] +[require Tcl 8.4] +[require ascii85 [opt 1.0]] +[description] +[para] + +This package provides procedures to encode binary data into ascii85 and back. + +[list_begin definitions] + +[call [cmd ::ascii85::encode] [opt "[option -maxlen] [arg maxlen]"] [opt "[option -wrapchar] [arg wrapchar]"] [arg string]] + +Ascii85 encodes the given binary [arg string] and returns the encoded +result. Inserts the character [arg wrapchar] every [arg maxlen] +characters of output. [arg wrapchar] defaults to newline. [arg maxlen] +defaults to [const 76]. + +[para] + +[emph {Note well}]: If your string is not simple ascii you should fix +the string encoding before doing ascii85 encoding. See the examples. + +[para] + +The command will throw an error for negative values of [arg maxlen], +or if [arg maxlen] is not an integer number. + +[call [cmd ::ascii85::decode] [arg "string"]] + +Ascii85 decodes the given [arg "string"] and returns the binary data. +The decoder ignores whitespace in the string, as well as tabs and +newlines. + +[list_end] + +[section {EXAMPLES}] + +[example { +% ascii85::encode "Hello, world" +87cURD_*#TDfTZ) +}] + +[example { +% ascii85::encode [string repeat xyz 24] +G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G +^4U[H$X^\H?a^] +% ascii85::encode -wrapchar "" [string repeat xyz 24] +G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^] +}] + +[example { +# NOTE: ascii85 encodes BINARY strings. +% set chemical [encoding convertto utf-8 "C\u2088H\u2081\u2080N\u2084O\u2082"] +% set encoded [ascii85::encode $chemical] +6fN]R8E,5Pidu\UiduhZidua +% set caffeine [encoding convertfrom utf-8 [ascii85::decode $encoded]] +}] + +[section References] + +[list_begin enum] +[enum] [uri http://en.wikipedia.org/wiki/Ascii85] +[enum] Postscript Language Reference Manual, 3rd Edition, page 131. + [uri http://www.adobe.com/devnet/postscript/pdfs/PLRM.pdf] +[list_end] + +[vset CATEGORY base64] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/base64/ascii85.pcx b/tcllib/modules/base64/ascii85.pcx new file mode 100644 index 0000000..a300ccd --- /dev/null +++ b/tcllib/modules/base64/ascii85.pcx @@ -0,0 +1,65 @@ +# -*- tcl -*- ascii85.pcx +# Syntax of the commands provided by package ascii85. +# +# For use by TclDevKit's static syntax checker. +# See http://www.activestate.com/solutions/tcl/ +# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api +# for the documentation describing the format of the code contained in this file +# + +package require pcx +pcx::register ascii85 +pcx::tcldep 1.0 needs tcl 8.4 + +namespace eval ::ascii85 {} + +# Using the indirections below looks to be quite pointless, given that +# they simply substitute the commands for others. I am doing this for +# two reasons. + +# First, the rules coming after become self-commenting, i.e. a +# maintainer can immediately see what an argument is supposed to be, +# instead of having to search elsewhere (like the documentation and +# implementation). In this manner our definitions here are a type of +# semantic markup. + +# The second reason is that while we have no special checks now we +# cannot be sure if such will (have to) be added in the future. With +# all checking routed through our definitions we now already have the +# basic infrastructure (i.e. hooks) in place in which we can easily +# add any new checks by simply redefining the relevant command, and +# all the rules update on their own. Mostly. This should cover 90% of +# the cases. Sometimes new checks will require to create deeper +# distinctions between different calls of the same thing. For such we +# may have to update the rules as well, to provide the necessary +# information to the checker. + +interp alias {} ascii85::checkLineLength {} checkInt ; # +interp alias {} ascii85::checkWrapChar {} checkWord ; # +interp alias {} ascii85::checkData {} checkWord ; # + +#pcx::message FOO {... text ...} type +#pcx::scan <VERSION> <NAME> <RULE> + +pcx::check 1.0 std ::ascii85::decode \ + {checkSimpleArgs 1 1 { + ascii85::checkData + }} + +# NOTE: Is '-maxlen' < 0 allowed? +# Doc doesn't forbid it, code doesn't catch it. +# May crash it however, i.e be a bug. +# Check testsuite. +pcx::check 1.0 std ::ascii85::encode \ + {checkSimpleArgs 1 -1 { + {checkSwitches 1 { + {-maxlen ascii85::checkLineLength} + {-wrapchar ascii85::checkWrapChar} + } {checkSimpleArgs 1 1 { + ascii85::checkData + }}} + }} + +# Initialization via pcx::init. +# Use a ::ascii85::init procedure for non-standard initialization. +pcx::complete diff --git a/tcllib/modules/base64/ascii85.tcl b/tcllib/modules/base64/ascii85.tcl new file mode 100644 index 0000000..9a1cd04 --- /dev/null +++ b/tcllib/modules/base64/ascii85.tcl @@ -0,0 +1,271 @@ +# ascii85.tcl -- +# +# Encode/Decode ascii85 for a string +# +# Copyright (c) Emiliano Gavilan +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.4 + +namespace eval ascii85 { + namespace export encode encodefile decode + # default values for encode options + variable options + array set options [list -wrapchar \n -maxlen 76] +} + +# ::ascii85::encode -- +# +# Ascii85 encode a given string. +# +# Arguments: +# args ?-maxlen maxlen? ?-wrapchar wrapchar? string +# +# If maxlen is 0, the output is not wrapped. +# +# Results: +# A Ascii85 encoded version of $string, wrapped at $maxlen characters +# by $wrapchar. + +proc ascii85::encode {args} { + variable options + + set alen [llength $args] + if {$alen != 1 && $alen != 3 && $alen != 5} { + return -code error "wrong # args:\ + should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen?\ + ?-wrapchar wrapchar? string\"" + } + + set data [lindex $args end] + array set opts [array get options] + array set opts [lrange $args 0 end-1] + foreach key [array names opts] { + if {[lsearch -exact [array names options] $key] == -1} { + return -code error "unknown option \"$key\":\ + must be -maxlen or -wrapchar" + } + } + + if {![string is integer -strict $opts(-maxlen)] + || $opts(-maxlen) < 0} { + return -code error "expected positive integer but got\ + \"$opts(-maxlen)\"" + } + + # perform this check early + if {[string length $data] == 0} { + return "" + } + + # shorten the names + set ml $opts(-maxlen) + set wc $opts(-wrapchar) + + # if maxlen is zero, don't wrap the output + if {$ml == 0} { + set wc "" + } + + set encoded {} + + binary scan $data c* X + set len [llength $X] + set rest [expr {$len % 4}] + set lastidx [expr {$len - $rest - 1}] + + foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] { + # calculate the 32 bit value + # this is an inlined version of the [encode4bytes] proc + # included here for performance reasons + set val [expr { + ( (($b1 & 0xff) << 24) + |(($b2 & 0xff) << 16) + |(($b3 & 0xff) << 8) + | ($b4 & 0xff) + ) & 0xffffffff }] + + if {$val == 0} { + # four \0 bytes encodes as "z" instead of "!!!!!" + append current "z" + } else { + # no magic numbers here. + # 52200625 -> 85 ** 4 + # 614125 -> 85 ** 3 + # 7225 -> 85 ** 2 + append current [binary format ccccc \ + [expr { ( $val / 52200625) + 33 }] \ + [expr { (($val % 52200625) / 614125) + 33 }] \ + [expr { (($val % 614125) / 7225) + 33 }] \ + [expr { (($val % 7225) / 85) + 33 }] \ + [expr { ( $val % 85) + 33 }]] + } + + if {[string length $current] >= $ml} { + append encoded [string range $current 0 [expr {$ml - 1}]] $wc + set current [string range $current $ml end] + } + } + + if { $rest } { + # there are remaining bytes. + # pad with \0 and encode not using the "z" convention. + # finally, add ($rest + 1) chars. + set val 0 + foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break + append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest] + } + append encoded [regsub -all -- ".{$ml}" $current "&$wc"] + + return $encoded +} + +proc ascii85::encode4bytes {b1 b2 b3 b4} { + set val [expr { + ( (($b1 & 0xff) << 24) + |(($b2 & 0xff) << 16) + |(($b3 & 0xff) << 8) + | ($b4 & 0xff) + ) & 0xffffffff }] + return [binary format ccccc \ + [expr { ( $val / 52200625) + 33 }] \ + [expr { (($val % 52200625) / 614125) + 33 }] \ + [expr { (($val % 614125) / 7225) + 33 }] \ + [expr { (($val % 7225) / 85) + 33 }] \ + [expr { ( $val % 85) + 33 }]] +} + +# ::ascii85::encodefile -- +# +# Ascii85 encode the contents of a file using default values +# for maxlen and wrapchar parameters. +# +# Arguments: +# fname The name of the file to encode. +# +# Results: +# An Ascii85 encoded version of the contents of the file. +# This is a convenience command + +proc ascii85::encodefile {fname} { + set fd [open $fname] + fconfigure $fd -encoding binary -translation binary + return [encode [read $fd]][close $fd] +} + +# ::ascii85::decode -- +# +# Ascii85 decode a given string. +# +# Arguments: +# string The string to decode. +# Leading spaces and tabs are removed, along with trailing newlines +# +# Results: +# The decoded value. + +proc ascii85::decode {data} { + # get rid of leading spaces/tabs and trailing newlines + set data [string map [list \n {} \t {} { } {}] $data] + set len [string length $data] + + # perform this ckeck early + if {! $len} { + return "" + } + + set decoded {} + set count 0 + set group [list] + binary scan $data c* X + + foreach char $X { + # we must check that every char is in the allowed range + if {$char < 33 || $char > 117 } { + # "z" is an exception + if {$char == 122} { + if {$count == 0} { + # if a "z" char appears at the beggining of a group, + # it decodes as four null bytes + append decoded \x00\x00\x00\x00 + continue + } else { + # if not, is an error + return -code error \ + "error decoding data: \"z\" char misplaced" + } + } + # char is not in range and not a "z" at the beggining of a group + return -code error \ + "error decoding data: chars outside the allowed range" + } + + lappend group $char + incr count + if {$count == 5} { + # this is an inlined version of the [decode5chars] proc + # included here for performance reasons + set val [expr { + ([lindex $group 0] - 33) * wide(52200625) + + ([lindex $group 1] - 33) * 614125 + + ([lindex $group 2] - 33) * 7225 + + ([lindex $group 3] - 33) * 85 + + ([lindex $group 4] - 33) }] + if {$val > 0xffffffff} { + return -code error "error decoding data: decoded group overflow" + } else { + append decoded [binary format I $val] + incr count -5 + set group [list] + } + } + } + + set len [llength $group] + switch -- $len { + 0 { + # all input has been consumed + # do nothing + } + 1 { + # a single char is a condition error, there should be at least 2 + return -code error \ + "error decoding data: trailing char" + } + default { + # pad with "u"s, decode and add ($len - 1) bytes + append decoded [string range \ + [decode5chars [pad $group 5 122]] \ + 0 \ + [expr {$len - 2}]] + } + } + + return $decoded +} + +proc ascii85::decode5chars {group} { + set val [expr { + ([lindex $group 0] - 33) * wide(52200625) + + ([lindex $group 1] - 33) * 614125 + + ([lindex $group 2] - 33) * 7225 + + ([lindex $group 3] - 33) * 85 + + ([lindex $group 4] - 33) }] + if {$val > 0xffffffff} { + return -code error "error decoding data: decoded group overflow" + } + + return [binary format I $val] +} + +proc ascii85::pad {chars len padchar} { + while {[llength $chars] < $len} { + lappend chars $padchar + } + + return $chars +} + +package provide ascii85 1.0 diff --git a/tcllib/modules/base64/ascii85.test b/tcllib/modules/base64/ascii85.test new file mode 100644 index 0000000..7b249d9 --- /dev/null +++ b/tcllib/modules/base64/ascii85.test @@ -0,0 +1,189 @@ +# Tests for the base64 module. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: ascii85.test,v 1.1 2010/05/03 21:48:39 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +package require tcltest + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 1.0 + +testing { + useLocal ascii85.tcl ascii85 +} + +# ------------------------------------------------------------------------- +# Encoding tests +# ------------------------------------------------------------------------- + +test ascii85-1.1 {ascii85::encode} { + ascii85::encode "this is a test\n" +} {FD,B0+DGm>@3BZ'F*%`} + +test ascii85-1.2 {ascii85::encode wraps lines at 76 characters} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + ascii85::encode $str +} {<+ohcF(fK4F<GU8A0>K>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D +/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} + +test ascii85-1.3 {ascii85::encode with wrap length set to 60} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + ascii85::encode -maxlen 60 $str +} {<+ohcF(fK4F<GU8A0>K>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a% +AnbgmA0>;uA0>W0D/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} + +test ascii85-1.4 {ascii85::encode with wrap length set to 0} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + ascii85::encode -maxlen 0 $str +} {<+ohcF(fK4F<GU8A0>K>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} + +test ascii85-1.5 {ascii85::encode with wrap length set to 76, wrapchar to newline+space} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + ascii85::encode -maxlen 76 -wrapchar "\n " $str +} {<+ohcF(fK4F<GU8A0>K>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D + /a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} + +test ascii85-1.6 {ascii85::encode, errors} { + list [catch {ascii85::encode} msg] $msg +} [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""] + +test ascii85-1.7 {ascii85::encode, errors} { + list [catch {ascii85::encode -maxlen foo} msg] $msg +} [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""] + +# changed form the original. ascii85 checks for correct # args before +# checking for valid options. Now this test is duplicate of 1.12 +test ascii85-1.8 {ascii85::encode, errors} { + list [catch {ascii85::encode -maxlen foo bar} msg] $msg +} [list 1 {expected positive integer but got "foo"}] + +test ascii85-1.9 {ascii85::encode, errors} { + list [catch {ascii85::encode -maxlen foo -wrapchar bar} msg] $msg +} [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""] + +test ascii85-1.10 {ascii85::encode, errors} { + list [catch {ascii85::encode -foo bar baz} msg] $msg +} [list 1 "unknown option \"-foo\": must be -maxlen or -wrapchar"] + +test ascii85-1.11 {ascii85::encode with bogus wrap length (< 0)} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + list [catch { ascii85::encode -maxlen -3 $str } msg] $msg +} {1 {expected positive integer but got "-3"}} + +# dulicate of 1.8 +test ascii85-1.12 {ascii85::encode with bogus wrap length (non-numeric)} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + list [catch { ascii85::encode -maxlen foo $str } msg] $msg +} {1 {expected positive integer but got "foo"}} + +test ascii85-1.13 {ascii85::encode with bogus wrap length (non-integer)} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + list [catch { ascii85::encode -maxlen 1.5 $str } msg] $msg +} {1 {expected positive integer but got "1.5"}} + +test ascii85-1.14 {ascii85::encode with wrap length set to 20} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + ascii85::encode -maxlen 20 $str +} {<+ohcF(fK4F<GU8A0>K& +GT_$8DBNqABk(ppGp%3B +Ec6)5BHVD1AKYW+AS#a% +AnbgmA0>;uA0>W0D/a&s ++E)F7EZfI;AKZ)'Cht5' +Ec6/>+C\njEXD} + +test ascii85-1.15 {ascii85::encode with wrap length set to 23 (prime)} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + ascii85::encode -maxlen 23 $str +} {<+ohcF(fK4F<GU8A0>K>_ +$8DBNqABk(ppGp%3BEc6)5B +HVD1AKYW+AS#a%AnbgmA0>; +uA0>W0D/a&s+E)F7EZfI;AK +Z)'Cht5'Ec6/>+C\njEXD} + +test ascii85-1.16 {ascii85::encode string of length zero} { + ascii85::encode "" +} "" + +# ------------------------------------------------------------------------- +# Decoding tests +# ------------------------------------------------------------------------- + +test ascii85-2.1 {ascii85::decode} { + ascii85::decode {FD,B0+DGm>@3BZ'F*%`} +} "this is a test\n" + +test ascii85-2.2 {ascii85::decode ignores newlines} { + set str {<+ohcF(fK4F<GU8A0>K>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D} + append str \n + append str {/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} + ascii85::decode $str +} "The short red fox ran quickly through the green field and jumped over the tall brown bear\n" + +test ascii85-2.3 {ascii85::decode error chars not in range} { + list [catch {ascii85::decode "ab~cd"} msg] $msg +} {1 {error decoding data: chars outside the allowed range}} + +test ascii85-2.4 {ascii85::decode error "z" char misplaced} { + list [catch {ascii85::decode "abczd"} msg] $msg +} {1 {error decoding data: "z" char misplaced}} + +test ascii85-2.5 {ascii85::decode error trailing char} { + list [catch {ascii85::decode "abcde5"} msg] $msg +} {1 {error decoding data: trailing char}} + +test ascii85-2.6 {ascii85::decode decoding of null chars} { + foreach enc [list !! !!! !!!! z z!!] { + lappend res [ascii85::decode $enc] + } + set res +} [list \x00 \x00\x00 \x00\x00\x00 \x00\x00\x00\x00 \x00\x00\x00\x00\x00] + +test ascii85-2.7 {ascii85::decode integer range limit} { + ascii85::decode s8W-! +} "\xff\xff\xff\xff" + +test ascii85-2.8 {ascii85::decode integer range overflow} { + list [catch {ascii85::decode {s8W-"}} msg] $msg +} {1 {error decoding data: decoded group overflow}} + +test ascii85-2.9 {ascii85::decode of empty string} { + ascii85::decode "" +} "" + +# ------------------------------------------------------------------------- +# Identity tests +# ------------------------------------------------------------------------- + +test ascii85-3.1 {ascii85 identity test} { + ascii85::decode [ascii85::encode "this is a test"] +} "this is a test" + +test ascii85-3.2 {base64 identity test} { + set x \f\xee + set y [ascii85::decode [ascii85::encode $x]] + string compare $x $y +} 0 + +testsuiteCleanup +return diff --git a/tcllib/modules/base64/base64.bench b/tcllib/modules/base64/base64.bench new file mode 100644 index 0000000..edfc2ef --- /dev/null +++ b/tcllib/modules/base64/base64.bench @@ -0,0 +1,61 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'base64' module. +# This allow developers to monitor/gauge/track package performance. +# +# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> + +# We need at least version 8.2 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.2]} { + return +} + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +set moddir [file dirname [file dirname [info script]]] +lappend auto_path $moddir + +package forget base64 +catch {namespace delete ::base64} +source [file join [file dirname [info script]] base64.tcl] + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + + +foreach n {10 100 1000 10000} { + bench -desc "BASE64 encode ${n}X" -pre { + set str [string repeat X $n] + } -body { + base64::encode $str + } -post { + unset str + } + + bench -desc "BASE64 decode ${n}X" -pre { + set str [base64::encode [string repeat X $n]] + } -body { + base64::decode $str + } -post { + unset str + } +} + +foreach wrap {1 10 60 100} { + foreach n {10 100 1000 10000} { + bench -desc "BASE64 encode ${n}X -wrap $wrap" -pre { + set str [string repeat X $n] + } -body { + base64::encode -wrap $wrap $str + } -post { + unset str + } + } +} + +# ### ### ### ######### ######### ######### ########################### +## Complete diff --git a/tcllib/modules/base64/base64.man b/tcllib/modules/base64/base64.man new file mode 100644 index 0000000..c20274c --- /dev/null +++ b/tcllib/modules/base64/base64.man @@ -0,0 +1,70 @@ +[manpage_begin base64 n 2.4.2] +[keywords base64] +[keywords encoding] +[copyright {2000, Eric Melski}] +[copyright {2001, Miguel Sofer}] +[moddesc {Text encoding & decoding binary data}] +[titledesc {base64-encode/decode binary data}] +[category {Text processing}] +[require Tcl 8] +[require base64 [opt 2.4.2]] +[description] +[para] + +This package provides procedures to encode binary data into base64 and back. + +[list_begin definitions] + +[call [cmd ::base64::encode] [opt "[option -maxlen] [arg maxlen]"] [opt "[option -wrapchar] [arg wrapchar]"] [arg string]] + +Base64 encodes the given binary [arg string] and returns the encoded +result. Inserts the character [arg wrapchar] every [arg maxlen] +characters of output. [arg wrapchar] defaults to newline. [arg maxlen] +defaults to [const 76]. + +[para] [emph Note] that if [arg maxlen] is set to [const 0], the +output will not be wrapped at all. + +[para] + +[emph {Note well}]: If your string is not simple ascii you should fix +the string encoding before doing base64 encoding. See the examples. + +[para] + +The command will throw an error for negative values of [arg maxlen], +or if [arg maxlen] is not an integer number. + +[call [cmd ::base64::decode] [arg "string"]] + +Base64 decodes the given [arg "string"] and returns the binary data. +The decoder ignores whitespace in the string. + +[list_end] + +[section {EXAMPLES}] + +[example { +% base64::encode "Hello, world" +SGVsbG8sIHdvcmxk +}] + +[example { +% base64::encode [string repeat xyz 20] +eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6 +eHl6eHl6eHl6 +% base64::encode -wrapchar "" [string repeat xyz 20] +eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6 +}] + +[example { +# NOTE: base64 encodes BINARY strings. +% set chemical [encoding convertto utf-8 "C\u2088H\u2081\u2080N\u2084O\u2082"] +% set encoded [base64::encode $chemical] +Q+KCiEjigoHigoBO4oKET+KCgg== +% set caffeine [encoding convertfrom utf-8 [base64::decode $encoded]] +}] + +[vset CATEGORY base64] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/base64/base64.pcx b/tcllib/modules/base64/base64.pcx new file mode 100644 index 0000000..f61f4c0 --- /dev/null +++ b/tcllib/modules/base64/base64.pcx @@ -0,0 +1,65 @@ +# -*- tcl -*- base64.pcx +# Syntax of the commands provided by package base64. +# +# For use by TclDevKit's static syntax checker. +# See http://www.activestate.com/solutions/tcl/ +# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api +# for the documentation describing the format of the code contained in this file +# + +package require pcx +pcx::register base64 +pcx::tcldep 2.3.2 needs tcl 8.2 + +namespace eval ::base64 {} + +# Using the indirections below looks to be quite pointless, given that +# they simply substitute the commands for others. I am doing this for +# two reasons. + +# First, the rules coming after become self-commenting, i.e. a +# maintainer can immediately see what an argument is supposed to be, +# instead of having to search elsewhere (like the documentation and +# implementation). In this manner our definitions here are a type of +# semantic markup. + +# The second reason is that while we have no special checks now we +# cannot be sure if such will (have to) be added in the future. With +# all checking routed through our definitions we now already have the +# basic infrastructure (i.e. hooks) in place in which we can easily +# add any new checks by simply redefining the relevant command, and +# all the rules update on their own. Mostly. This should cover 90% of +# the cases. Sometimes new checks will require to create deeper +# distinctions between different calls of the same thing. For such we +# may have to update the rules as well, to provide the necessary +# information to the checker. + +interp alias {} base64::checkLineLength {} checkInt ; # +interp alias {} base64::checkWrapChar {} checkWord ; # +interp alias {} base64::checkData {} checkWord ; # + +#pcx::message FOO {... text ...} type +#pcx::scan <VERSION> <NAME> <RULE> + +pcx::check 2.3.2 std ::base64::decode \ + {checkSimpleArgs 1 1 { + base64::checkData + }} + +# NOTE: Is '-maxlen' < 0 allowed? +# Doc doesn't forbid it, code doesn't catch it. +# May crash it however, i.e be a bug. +# Check testsuite. +pcx::check 2.3.2 std ::base64::encode \ + {checkSimpleArgs 1 -1 { + {checkSwitches 1 { + {-maxlen base64::checkLineLength} + {-wrapchar base64::checkWrapChar} + } {checkSimpleArgs 1 1 { + base64::checkData + }}} + }} + +# Initialization via pcx::init. +# Use a ::base64::init procedure for non-standard initialization. +pcx::complete diff --git a/tcllib/modules/base64/base64.tcl b/tcllib/modules/base64/base64.tcl new file mode 100644 index 0000000..5d3d538 --- /dev/null +++ b/tcllib/modules/base64/base64.tcl @@ -0,0 +1,387 @@ +# base64.tcl -- +# +# Encode/Decode base64 for a string +# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems +# The decoder was done for exmh by Chris Garrigues +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: base64.tcl,v 1.32 2010/07/06 19:15:40 andreas_kupries Exp $ + +# Version 1.0 implemented Base64_Encode, Base64_Decode +# Version 2.0 uses the base64 namespace +# Version 2.1 fixes various decode bugs and adds options to encode +# Version 2.2 is much faster, Tcl8.0 compatible +# Version 2.2.1 bugfixes +# Version 2.2.2 bugfixes +# Version 2.3 bugfixes and extended to support Trf + +# @mdgen EXCLUDE: base64c.tcl + +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 + # + # 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 settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. + set wrapchar "\n" + set maxlen 76 + + 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}}]} { + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" + } + + set string [lindex $args end] + set result [::base64 -mode encode -- $string] + + # Trf's encoder implicitly uses the settings -maxlen 76, + # -wrapchar \n for its output. We may have to reflow this for + # the settings chosen by the user. A second difference is that + # Trf closes the output with the wrap char sequence, + # always. The code here doesn't. Therefore 'trimright' is + # needed in the fast cases. + + if {($maxlen == 76) && [string equal $wrapchar \n]} { + # Both maxlen and wrapchar are identical to Trf's + # settings. This is the super-fast case, because nearly + # nothing has to be done. Only thing to do is strip a + # terminating wrapchar. + set result [string trimright $result] + } elseif {$maxlen == 76} { + # wrapchar has to be different here, length is the + # same. We can use 'string map' to transform the wrap + # information. + set result [string map [list \n $wrapchar] \ + [string trimright $result]] + } elseif {$maxlen == 0} { + # Have to reflow the output to no wrapping. Another fast + # case using only 'string map'. 'trimright' is not needed + # here. + + set result [string map [list \n ""] $result] + } else { + # Have to reflow the output from 76 to the chosen maxlen, + # and possibly change the wrap sequence as well. + + # Note: After getting rid of the old wrap sequence we + # extract the relevant segments from the string without + # modifying the string. Modification, i.e. removal of the + # processed part, means 'shifting down characters in + # memory', making the algorithm O(n^2). By avoiding the + # modification we stay in O(n). + + set result [string map [list \n ""] $result] + set l [expr {[string length $result]-$maxlen}] + for {set off 0} {$off < $l} {incr off $maxlen} { + append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar + } + append res [string range $result $off end] + 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} { + regsub -all {\s} $string {} 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. + variable base64_tmp + variable i + + 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' + variable char + variable len + variable val + + 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 + # + # 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 settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. + set wrapchar "\n" + set maxlen 76 + + 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}}]} { + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive 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 { + ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] + if {$y != {}} { + ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] + if {$z != {}} { + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] + ADD [lindex $base64_en [expr {($z & 0x3F)}]] + } else { + set state 2 + break + } + } else { + set state 1 + break + } + } + if {$state == 1} { + ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] + ADD = + ADD = + } elseif {$state == 2} { + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] + ADD = + } + return $result + } + + proc ::base64::ADD {x} { + # The line length check is always done before appending so + # that we don't get an extra newline if the output is a + # multiple of $maxlen chars long. + + upvar 1 maxlen maxlen length length result result wrapchar wrapchar + if {$maxlen && $length >= $maxlen} { + append result $wrapchar + set length 0 + } + append result $x + incr length + return + } + + # ::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 + set output "" ; # Fix for [Bug 821126] + + 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 must (*) 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). + # + # (*) If we don't then the input is broken (bug 2976290). + + foreach {v w z} $nums break + + # Bug 2976290 + if {$w == {}} { + return -code error "Not enough data to process padding" + } + + 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] + } + 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.4.2 diff --git a/tcllib/modules/base64/base64.test b/tcllib/modules/base64/base64.test new file mode 100644 index 0000000..926a16d --- /dev/null +++ b/tcllib/modules/base64/base64.test @@ -0,0 +1,162 @@ +# Tests for the base64 module. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: base64.test,v 1.17 2011/11/09 04:31:24 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal base64.tcl base64 +} + +# ------------------------------------------------------------------------- + +if {[catch {package present Trf}]} { + puts "> pure Tcl" + tcltest::testConstraint trf 0 +} else { + puts "> Trf based" + tcltest::testConstraint trf 1 +} + +# ------------------------------------------------------------------------- + +test base64-1.1 {base64::encode} { + base64::encode "this is a test\n" +} "dGhpcyBpcyBhIHRlc3QK" +test base64-1.2 {base64::encode wraps lines at 76 characters} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + base64::encode $str +} "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5k +IGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" +test base64-1.3 {base64::encode with wrap length set to 60} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + base64::encode -maxlen 60 $str +} "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3Jl +ZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" +test base64-1.4 {base64::encode with wrap length set to 0} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + base64::encode -maxlen 0 $str +} "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" +test base64-1.5 {base64::encode with wrap length set to 76, wrapchar to newline+space} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + base64::encode -maxlen 76 -wrapchar "\n " $str +} "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5k + IGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" +test base64-1.6 {base64::encode, errors} { + list [catch {base64::encode} msg] $msg +} [list 1 "wrong # args: should be \"base64::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""] +test base64-1.7 {base64::encode, errors} { + list [catch {base64::encode -maxlen foo} msg] $msg +} [list 1 "value for \"-maxlen\" missing"] +test base64-1.8 {base64::encode, errors} { + list [catch {base64::encode -maxlen foo bar} msg] $msg +} [list 1 "expected integer but got \"foo\""] +test base64-1.9 {base64::encode, errors} { + list [catch {base64::encode -maxlen foo -wrapchar bar} msg] $msg +} [list 1 "value for \"-wrapchar\" missing"] +test base64-1.10 {base64::encode, errors} { + list [catch {base64::encode -foo bar} msg] $msg +} [list 1 "unknown option \"-foo\": must be -maxlen or -wrapchar"] +test base64-1.11 {base64::encode with bogus wrap length (< 0)} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + list [catch { base64::encode -maxlen -3 $str } msg] $msg +} {1 {expected positive integer but got "-3"}} +test base64-1.12 {base64::encode with bogus wrap length (non-numeric)} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + list [catch { base64::encode -maxlen foo $str } msg] $msg +} {1 {expected integer but got "foo"}} +test base64-1.13 {base64::encode with bogus wrap length (non-integer)} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + list [catch { base64::encode -maxlen 1.5 $str } msg] $msg +} {1 {expected integer but got "1.5"}} +test base64-1.14 {base64::encode with wrap length set to 20} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + base64::encode -maxlen 20 $str +} "VGhlIHNob3J0IHJlZCBm +b3ggcmFuIHF1aWNrbHkg +dGhyb3VnaCB0aGUgZ3Jl +ZW4gZmllbGQgYW5kIGp1 +bXBlZCBvdmVyIHRoZSB0 +YWxsIGJyb3duIGJlYXIK" +test base64-1.15 {base64::encode with wrap length set to 23 (prime)} { + set str "The short red fox ran quickly through the green field " + append str "and jumped over the tall brown bear\n" + base64::encode -maxlen 23 $str +} "VGhlIHNob3J0IHJlZCBmb3g +gcmFuIHF1aWNrbHkgdGhyb3 +VnaCB0aGUgZ3JlZW4gZmllb +GQgYW5kIGp1bXBlZCBvdmVy +IHRoZSB0YWxsIGJyb3duIGJ +lYXIK" + + +test base64-2.1 {base64::decode} { + base64::decode "dGhpcyBpcyBhIHRlc3QK" +} "this is a test\n" +test base64-2.2 {base64::decode ignores newlines} { + set str "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3Jl\n" + append str "ZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" + base64::decode $str +} "The short red fox ran quickly through the green field and jumped over the tall brown bear\n" +test base64-2.3 {base64::decode handles equal sign padding} { + # decode the encoding of a string that will be padded in the encoding with + # one padding char + base64::decode [base64::encode "01234"] +} "01234" +test base64-2.4 {base64::decode handles equal sign padding} { + # decode the encoding of a string that will be padded in the encoding with + # two padding chars + base64::decode [base64::encode "0123"] +} "0123" + + +test base64-2.5 {base64::decode} { + base64::decode "" +} "" +test base64-2.6 {base64::decode} { + base64::decode " " +} "" + + +test base64-3.1 {base64 identity test} { + base64::decode [base64::encode "this is a test"] +} "this is a test" +test base64-3.2 {base64 identity test} { + # This test fails on version 1.5 because of the format %04x bug + # when handling the last characters + set x \f\xee + set y [base64::decode [base64::encode $x]] + string compare $x $y +} 0 + +# For trf a known bug. +test base64-4.0 {base64 -- sf bug 2976290} {!trf} { + list [catch { + ::base64::decode s=GQMRAk5WXhsABh0NEx4RXBocBVgBHQMXHRgEFltMQENQXEFOExJVQ0RAQERUQ0dAEhYEExVIRRVVFENWKxMKABsPGBI6LRoYLhsEFhsXGFkXEwZXGQMIHg== + } msg] $msg +} {1 {Not enough data to process padding}} + +testsuiteCleanup +return diff --git a/tcllib/modules/base64/base64c.tcl b/tcllib/modules/base64/base64c.tcl new file mode 100644 index 0000000..29e501d --- /dev/null +++ b/tcllib/modules/base64/base64c.tcl @@ -0,0 +1,19 @@ +# base64c - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# This package is a place-holder for the critcl enhanced code present in +# the tcllib base64 module. +# +# Normally this code will become part of the tcllibc library. +# + +# @sak notprovided base64c +package require critcl +package provide base64c 0.1.0 + +namespace eval ::base64c { + variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} + + critcl::ccode { + /* no code required in this file */ + } +} diff --git a/tcllib/modules/base64/pkgIndex.tcl b/tcllib/modules/base64/pkgIndex.tcl new file mode 100644 index 0000000..c23b090 --- /dev/null +++ b/tcllib/modules/base64/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded base64 2.4.2 [list source [file join $dir base64.tcl]] +package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] +package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] +package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] diff --git a/tcllib/modules/base64/uuencode.bench b/tcllib/modules/base64/uuencode.bench new file mode 100644 index 0000000..714cfe9 --- /dev/null +++ b/tcllib/modules/base64/uuencode.bench @@ -0,0 +1,46 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'uuencode' module. +# This allow developers to monitor/gauge/track package performance. +# +# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> + +# We need at least version 8.2 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.2]} { + return +} + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +package forget uuencode +catch {namespace delete ::uuencode} +source [file join [file dirname [info script]] uuencode.tcl] + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + + +foreach n {10 100 1000 10000} { + bench -desc "UUENCODE encode ${n}X" -pre { + set str [string repeat X $n] + } -body { + uuencode::encode $str + } -post { + unset str + } + + bench -desc "UUENCODE decode ${n}X" -pre { + set str [uuencode::encode [string repeat X $n]] + } -body { + uuencode::decode $str + } -post { + unset str + } +} + +# ### ### ### ######### ######### ######### ########################### +## Complete diff --git a/tcllib/modules/base64/uuencode.man b/tcllib/modules/base64/uuencode.man new file mode 100644 index 0000000..c701a56 --- /dev/null +++ b/tcllib/modules/base64/uuencode.man @@ -0,0 +1,97 @@ +[manpage_begin uuencode n 1.1.4] +[keywords encoding] +[keywords uuencode] +[copyright {2002, Pat Thoyts}] +[moddesc {Text encoding & decoding binary data}] +[titledesc {UU-encode/decode binary data}] +[category {Text processing}] +[require Tcl 8] +[require uuencode [opt 1.1.4]] +[description] +[para] + +This package provides a Tcl-only implementation of the +[syscmd uuencode(1)] and [syscmd uudecode(1)] commands. This encoding +packs binary data into printable ASCII characters. + +[list_begin definitions] + +[call [cmd ::uuencode::encode] [arg string]] + +returns the uuencoded data. This will encode all the data passed in +even if this is longer than the uuencode maximum line length. If the +number of input bytes is not a multiple of 3 then additional 0 bytes +are added to pad the string. + +[call [cmd ::uuencode::decode] [arg string]] + +Decodes the given encoded data. This will return any padding +characters as well and it is the callers responsibility to deal with +handling the actual length of the encoded data. (see uuencode). + +[call [cmd ::uuencode::uuencode] [opt "[option -name] [arg string]"] [opt "[option -mode] [arg octal]"] "([option -file] [arg filename] | [opt [option --]] [arg string])"] + +[call [cmd ::uuencode::uudecode] "([option -file] [arg filename] | [opt [option --]] [arg string])"] + +UUDecode a file or block of data. A file may contain more than one +embedded file so the result is a list where each element is a three +element list of filename, mode value and data. + +[list_end] + +[section OPTIONS] + +[list_begin definitions] + +[def "-filename name"] + +Cause the uuencode or uudecode commands to read their data from the +named file rather that taking a string parameter. + +[def "-name string"] + +The uuencoded data header line contains the suggested file name to be +used when unpacking the data. Use this option to change this from the +default of "data.dat". + +[def "-mode octal"] + +The uuencoded data header line contains a suggested permissions bit +pattern expressed as an octal string. To change the default of 0644 +you can set this option. For instance, 0755 would be suitable for an +executable. See [syscmd chmod(1)]. + +[list_end] + +[section EXAMPLES] + +[para] +[example { +% set d [uuencode::encode "Hello World!"] +2&5L;&\\@5V]R;&0A +}] + +[para] +[example { +% uuencode::uudecode $d +Hello World! +}] + +[para] +[example { +% set d [uuencode::uuencode -name hello.txt "Hello World"] +begin 644 hello.txt ++2&5L;&\@5V]R;&0` +` +end +}] + +[para] +[example { +% uuencode::uudecode $d +{hello.txt 644 {Hello World}} +}] + +[vset CATEGORY base64] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/base64/uuencode.pcx b/tcllib/modules/base64/uuencode.pcx new file mode 100644 index 0000000..13e122d --- /dev/null +++ b/tcllib/modules/base64/uuencode.pcx @@ -0,0 +1,74 @@ +# -*- tcl -*- uuencode.pcx +# Syntax of the commands provided by package uuencode. +# +# For use by TclDevKit's static syntax checker. +# See http://www.activestate.com/solutions/tcl/ +# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api +# for the documentation describing the format of the code contained in this file +# + +package require pcx +pcx::register uuencode +pcx::tcldep 1.1.4 needs tcl 8.2 + +namespace eval ::uuencode {} + +# Using the indirections below looks to be quite pointless, given that +# they simply substitute the commands for others. I am doing this for +# two reasons. + +# First, the rules coming after become self-commenting, i.e. a +# maintainer can immediately see what an argument is supposed to be, +# instead of having to search elsewhere (like the documentation and +# implementation). In this manner our definitions here are a type of +# semantic markup. + +# The second reason is that while we have no special checks now we +# cannot be sure if such will (have to) be added in the future. With +# all checking routed through our definitions we now already have the +# basic infrastructure (i.e. hooks) in place in which we can easily +# add any new checks by simply redefining the relevant command, and +# all the rules update on their own. Mostly. This should cover 90% of +# the cases. Sometimes new checks will require to create deeper +# distinctions between different calls of the same thing. For such we +# may have to update the rules as well, to provide the necessary +# information to the checker. + +interp alias {} uuencode::checkMode {} checkWord ; # +interp alias {} uuencode::checkDstFilename {} checkWord ; # +interp alias {} uuencode::checkData {} checkWord ; # + +#pcx::message FOO {... text ...} type +#pcx::scan <VERSION> <NAME> <RULE> + +pcx::check 1.1.4 std ::uuencode::uudecode \ + {checkConstrained {checkSimpleArgs 1 -1 { + {checkSwitches 1 { + {-filename {checkSetConstraint hasfilename checkFileName}} + -- + } {checkConstraint { + {hasfilename {checkSimpleArgs 0 0 {}}} + {!hasfilename {checkSimpleArgs 1 1 { + uuencode::checkData + }}} + } {}}} + }}} +# TODO: Limit -mode to a octal numbers (file permissions) +pcx::check 1.1.4 std ::uuencode::uuencode \ + {checkConstrained {checkSimpleArgs 1 -1 { + {checkSwitches 1 { + {-filename {checkSetConstraint hasfilename checkFileName}} + {-mode uuencode::checkMode} + {-name uuencode::checkDstFilename} + -- + } {checkConstraint { + {hasfilename {checkSimpleArgs 0 0 {}}} + {!hasfilename {checkSimpleArgs 1 1 { + uuencode::checkData + }}} + } {}}} + }}} + +# Initialization via pcx::init. +# Use a ::uuencode::init procedure for non-standard initialization. +pcx::complete diff --git a/tcllib/modules/base64/uuencode.tcl b/tcllib/modules/base64/uuencode.tcl new file mode 100644 index 0000000..e0e9862 --- /dev/null +++ b/tcllib/modules/base64/uuencode.tcl @@ -0,0 +1,335 @@ +# uuencode - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Provide a Tcl only implementation of uuencode and uudecode. +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +package require Tcl 8.2; # tcl minimum version + +# Try and get some compiled helper package. +if {[catch {package require tcllibc}]} { + catch {package require Trf} +} + +namespace eval ::uuencode { + namespace export encode decode uuencode uudecode +} + +proc ::uuencode::Enc {c} { + return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] +} + +proc ::uuencode::Encode {s} { + set r {} + binary scan $s c* d + foreach {c1 c2 c3} $d { + if {$c1 == {}} {set c1 0} + if {$c2 == {}} {set c2 0} + if {$c3 == {}} {set c3 0} + append r [Enc [expr {$c1 >> 2}]] + append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]] + append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] + append r [Enc [expr {($c3 & 077)}]] + } + return $r +} + + +proc ::uuencode::Decode {s} { + if {[string length $s] == 0} {return ""} + set r {} + binary scan [pad $s] c* d + + foreach {c0 c1 c2 c3} $d { + append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF + | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]] + append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF + | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]] + append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF + | (($c3-0x20)&0x3F) & 0xFF}]] + } + return $r +} + +# ------------------------------------------------------------------------- +# C coded version of the Encode/Decode functions for base64c package. +# ------------------------------------------------------------------------- +if {[package provide critcl] != {}} { + namespace eval ::uuencode { + critcl::ccode { + #include <string.h> + static unsigned char Enc(unsigned char c) { + return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; + } + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (3 - (len % 3))) != 3) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + rlen = (len / 3) * 4; + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 3) { + char a, b, c; + a = *p; b = *(p+1), c = *(p+2); + *r++ = Enc(a >> 2); + *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); + *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); + *r++ = Enc(c & 077); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* if input is not mod 4, extend it with nuls */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (4 - (len % 4))) != 4) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + /* output will be 1/3 smaller than input and a multiple of 3 */ + rlen = (len / 4) * 3; + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 4) { + char a, b, c, d; + a = *p; b = *(p+1), c = *(p+2), d = *(p+3); + *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); + *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); + *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } +} + +# ------------------------------------------------------------------------- + +# Description: +# Permit more tolerant decoding of invalid input strings by padding to +# a multiple of 4 bytes with nulls. +# Result: +# Returns the input string - possibly padded with uuencoded null chars. +# +proc ::uuencode::pad {s} { + if {[set mod [expr {[string length $s] % 4}]] != 0} { + append s [string repeat "`" [expr {4 - $mod}]] + } + return $s +} + +# ------------------------------------------------------------------------- + +# If the Trf package is available then we shall use this by default but the +# Tcllib implementations are always visible if needed (ie: for testing) +if {[info commands ::uuencode::CDecode] != {}} { + # tcllib critcl package + interp alias {} ::uuencode::encode {} ::uuencode::CEncode + interp alias {} ::uuencode::decode {} ::uuencode::CDecode +} elseif {[package provide Trf] != {}} { + proc ::uuencode::encode {s} { + return [::uuencode -mode encode -- $s] + } + proc ::uuencode::decode {s} { + return [::uuencode -mode decode -- [pad $s]] + } +} else { + # pure-tcl then + interp alias {} ::uuencode::encode {} ::uuencode::Encode + interp alias {} ::uuencode::decode {} ::uuencode::Decode +} + +# ------------------------------------------------------------------------- + +proc ::uuencode::uuencode {args} { + array set opts {mode 0644 filename {} name {}} + set wrongargs "wrong \# args: should be\ + \"uuencode ?-name string? ?-mode octal?\ + (-file filename | ?--? string)\"" + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(filename) [lindex $args 1] + set args [lreplace $args 0 0] + } + -m* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(mode) [lindex $args 1] + set args [lreplace $args 0 0] + } + -n* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(name) [lindex $args 1] + set args [lreplace $args 0 0] + } + -- { + set args [lreplace $args 0 0] + break + } + default { + return -code error "bad option [lindex $args 0]:\ + must be -file, -mode, or -name" + } + } + set args [lreplace $args 0 0] + } + + if {$opts(name) == {}} { + set opts(name) $opts(filename) + } + if {$opts(name) == {}} { + set opts(name) "data.dat" + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + fconfigure $f -translation binary + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error $wrongargs + } + set data [lindex $args 0] + } + + set r {} + append r [format "begin %o %s" $opts(mode) $opts(name)] "\n" + for {set n 0} {$n < [string length $data]} {incr n 45} { + set s [string range $data $n [expr {$n + 44}]] + append r [Enc [string length $s]] + append r [encode $s] "\n" + } + append r "`\nend" + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Perform uudecoding of a file or data. A file may contain more than one +# encoded data section so the result is a list where each element is a +# three element list of the provided filename, the suggested mode and the +# data itself. +# +proc ::uuencode::uudecode {args} { + array set opts {mode 0644 filename {}} + set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(filename) [lindex $args 1] + set args [lreplace $args 0 0] + } + -- { + set args [lreplace $args 0 0] + break + } + default { + return -code error "bad option [lindex $args 0]:\ + must be -file" + } + } + set args [lreplace $args 0 0] + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error $wrongargs + } + set data [lindex $args 0] + } + + set state false + set result {} + + foreach {line} [split $data "\n"] { + switch -exact -- $state { + false { + if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \ + -> opts(mode) opts(name)]} { + set state true + set r {} + } + } + + true { + if {[string match "end" $line]} { + set state false + lappend result [list $opts(name) $opts(mode) $r] + } else { + scan $line %c c + set n [expr {($c - 0x21)}] + append r [string range \ + [decode [string range $line 1 end]] 0 $n] + } + } + } + } + + return $result +} + +# ------------------------------------------------------------------------- + +package provide uuencode 1.1.5 + +# ------------------------------------------------------------------------- +# +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + diff --git a/tcllib/modules/base64/uuencode.test b/tcllib/modules/base64/uuencode.test new file mode 100644 index 0000000..1e968da --- /dev/null +++ b/tcllib/modules/base64/uuencode.test @@ -0,0 +1,193 @@ +# uuencode.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Tests for the Tcllib uuencode package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: uuencode.test,v 1.15 2008/12/12 04:57:46 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useTcllibC + useLocalKeep uuencode.tcl uuencode +} + +# ------------------------------------------------------------------------- + +set trf 0 +if {[llength [info commands ::uuencode::CEncode]]} { + puts "> critcl based" +} elseif {[package provide Trf] != {}} { + puts "> Trf based" + set trf 1 +} else { + puts "> pure tcl" +} + +package require log +log::lvSuppress notice + +# ------------------------------------------------------------------------- + +test uuencode-1.0 {encode string} { + catch {::uuencode::encode ABC} result + set result +} "04)#" + +test uuencode-1.1 {decode string} { + catch {::uuencode::decode "04)#"} result + set result +} "ABC" + +test uuencode-1.2 {encode longer string} { + catch {::uuencode::encode [string repeat x 102]} result + set result +} [string repeat ">'AX" 34] + +test uuencode-1.3 {decode longer string} { + catch {::uuencode::decode [string repeat ">'AX" 34]} result + set result +} [string repeat x 102] + +# Trf uses a different padding character. +if {!$trf} { + # critcl / pure tcl based + set testdata {begin 644 data.dat +75&AE(&-A="!S870@;VX@=&AE(&UA="X` +` +end} +} else { + set testdata {begin 644 data.dat +75&AE(&-A="!S870@;VX@=&AE(&UA="X~ +` +end} +} + +test uuencode-1.4 {uuencode string} { + catch {::uuencode::uuencode "The cat sat on the mat."} result + set result +} $testdata + +test uuencode-1.5 {uudecode string} { + catch {::uuencode::uudecode $testdata} result + set result +} [list [list data.dat 644 "The cat sat on the mat."]] + +test uuencode-1.6 {encode dash-string} { + catch {::uuencode::encode -BC} result + set result +} "+4)#" + +test uuencode-1.7 {decode dash-string} { + catch {::uuencode::decode "-4)#"} result + set result +} "5BC" + +# ------------------------------------------------------------------------- + +set testdata [list \ + "begin 644 data.dat" \ + "75&AE(&-A=\"!S870@;VX@=&AE(&UA=\"X" \ + "`" \ + "end" ] + +test uuencode-2.1 {uudecode unpadded lines} { + catch {::uuencode::uudecode [join $testdata "\n"]} result + set result +} [list [list data.dat 644 "The cat sat on the mat."]] + +test uuencode-2.2 {uudecode DOS line endings} { + set f [open uuencode.test.data w] + fconfigure $f -translation binary + puts -nonewline $f [join $testdata "\r\n"] + close $f + catch {::uuencode::uudecode -file uuencode.test.data} result + set result +} [list [list data.dat 644 "The cat sat on the mat."]] + +foreach {n in out} { + 0 a {80``} + 1 abc {86)C} + 2 \0 {````} + 3 "\r\n\t" {#0H)} + 4 "hello world" {:&5L;&\@=V]R;&0`} +} { + test uuencode-3.$n {check the pure tcl encoder} { + list [catch {::uuencode::Encode $in} r] $r + } [list 0 $out] +} + +# ------------------------------------------------------------------------- + +test uuencode-4.0 {encode bad args} { + catch {::uuencode::uuencode -bogus} result + set result +} {bad option -bogus: must be -file, -mode, or -name} + +test uuencode-4.1 {encode wrong#args} { + catch {::uuencode::uuencode -file} result + set result +} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} + +test uuencode-4.2 {encode wrong#args} { + catch {::uuencode::uuencode -name} result + set result +} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} + +test uuencode-4.3 {encode wrong#args} { + catch {::uuencode::uuencode -mode} result + set result +} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} + +test uuencode-4.4 {encode wrong#args} { + catch {::uuencode::uuencode -mode 1} result + set result +} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} + +test uuencode-4.5 {encode wrong#args} { + catch {::uuencode::uuencode -name foo} result + set result +} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} + +test uuencode-4.6 {encode wrong#args} { + catch {::uuencode::uuencode --} result + set result +} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} + + + +test uuencode-5.0 {decode bad args} { + catch {::uuencode::uudecode -bogus} result + set result +} {bad option -bogus: must be -file} + +test uuencode-5.1 {decode wrong#args} { + catch {::uuencode::uudecode -file} result + set result +} {wrong # args: should be "uudecode (-file filename | ?--? string)"} + +test uuencode-5.2 {decode wrong#args} { + catch {::uuencode::uudecode --} result + set result +} {wrong # args: should be "uudecode (-file filename | ?--? string)"} + + +# ------------------------------------------------------------------------- + +file delete -force uuencode.test.data +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/base64/yencode.bench b/tcllib/modules/base64/yencode.bench new file mode 100644 index 0000000..706acb5 --- /dev/null +++ b/tcllib/modules/base64/yencode.bench @@ -0,0 +1,46 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'yencode' module. +# This allow developers to monitor/gauge/track package performance. +# +# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> + +# We need at least version 8.2 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.2]} { + return +} + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +package forget yencode +catch {namespace delete ::yencode} +source [file join [file dirname [info script]] yencode.tcl] + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + + +foreach n {10 100 1000 10000} { + bench -desc "YENCODE encode ${n}X" -pre { + set str [string repeat X $n] + } -body { + yencode::encode $str + } -post { + unset str + } + + bench -desc "YENCODE decode ${n}X" -pre { + set str [yencode::encode [string repeat X $n]] + } -body { + yencode::decode $str + } -post { + unset str + } +} + +# ### ### ### ######### ######### ######### ########################### +## Complete diff --git a/tcllib/modules/base64/yencode.man b/tcllib/modules/base64/yencode.man new file mode 100644 index 0000000..575d441 --- /dev/null +++ b/tcllib/modules/base64/yencode.man @@ -0,0 +1,96 @@ +[manpage_begin yencode n 1.1.2] +[keywords encoding] +[keywords ydecode] +[keywords yEnc] +[keywords yencode] +[copyright {2002, Pat Thoyts}] +[moddesc {Text encoding & decoding binary data}] +[titledesc {Y-encode/decode binary data}] +[category {Text processing}] +[require Tcl 8.2] +[require yencode [opt 1.1.2]] +[description] +[para] + +This package provides a Tcl-only implementation of the yEnc file +encoding. This is a recently introduced method of encoding binary +files for transmission through Usenet. This encoding packs binary data +into a format that requires an 8-bit clean transmission layer but that +escapes characters special to the [term NNTP] posting protocols. See +[uri http://www.yenc.org/] for details concerning the algorithm. + +[list_begin definitions] + +[call [cmd ::yencode::encode] [arg string]] + +returns the yEnc encoded data. + +[call [cmd ::yencode::decode] [arg "string"]] + +Decodes the given yEnc encoded data. + +[call [cmd ::yencode::yencode] \ + [opt "[option -name] [arg string]"] \ + [opt "[option -line] [arg integer]"] \ + [opt "[option -crc32] [arg boolean]"] \ + "([option -file] [arg filename] | [opt [option --]] [arg string])"] + +Encode a file or block of data. + +[call [cmd ::yencode::ydecode] \ + "([option -file] [arg filename] | [opt [option --]] [arg string])"] + +Decode a file or block of data. A file may contain more than one +embedded file so the result is a list where each element is a three +element list of filename, file size and data. + +[list_end] + +[section OPTIONS] + +[list_begin definitions] + +[def "-filename name"] + +Cause the yencode or ydecode commands to read their data from the +named file rather that taking a string parameter. + +[def "-name string"] + +The encoded data header line contains the suggested file name to be +used when unpacking the data. Use this option to change this from the +default of "data.dat". + +[def "-line integer"] + +The yencoded data header line contains records the line length used +during the encoding. Use this option to select a line length other +that the default of 128. Note that NNTP imposes a 1000 character line +length limit and some gateways may have trouble with more than 255 +characters per line. + +[def "-crc32 boolean"] + +The yEnc specification recommends the inclusion of a cyclic redundancy +check value in the footer. Use this option to change the default from +[arg true] to [arg false]. + +[list_end] + +[para] +[example { +% set d [yencode::yencode -file testfile.txt] +=ybegin line=128 size=584 name=testfile.txt + -o- data not shown -o- +=yend size=584 crc32=ded29f4f +}] + +[section References] + +[list_begin enum] +[enum] [uri http://www.yenc.org/yenc-draft.1.3.txt] +[list_end] + +[vset CATEGORY base64] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/base64/yencode.pcx b/tcllib/modules/base64/yencode.pcx new file mode 100644 index 0000000..e38499f --- /dev/null +++ b/tcllib/modules/base64/yencode.pcx @@ -0,0 +1,78 @@ +# -*- tcl -*- yencode.pcx +# Syntax of the commands provided by package yencode. +# +# For use by TclDevKit's static syntax checker. +# See http://www.activestate.com/solutions/tcl/ +# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api +# for the documentation describing the format of the code contained in this file +# + +package require pcx +pcx::register yencode +pcx::tcldep 1.1.1 needs tcl 8.2 + +namespace eval ::yencode {} + +# Using the indirections below looks to be quite pointless, given that +# they simply substitute the commands for others. I am doing this for +# two reasons. + +# First, the rules coming after become self-commenting, i.e. a +# maintainer can immediately see what an argument is supposed to be, +# instead of having to search elsewhere (like the documentation and +# implementation). In this manner our definitions here are a type of +# semantic markup. + +# The second reason is that while we have no special checks now we +# cannot be sure if such will (have to) be added in the future. With +# all checking routed through our definitions we now already have the +# basic infrastructure (i.e. hooks) in place in which we can easily +# add any new checks by simply redefining the relevant command, and +# all the rules update on their own. Mostly. This should cover 90% of +# the cases. Sometimes new checks will require to create deeper +# distinctions between different calls of the same thing. For such we +# may have to update the rules as well, to provide the necessary +# information to the checker. + +interp alias {} yencode::checkMode {} checkWord ; # +interp alias {} yencode::checkDstFilename {} checkWord ; # +interp alias {} yencode::checkData {} checkWord ; # +interp alias {} yencode::checkLineLength {} checkInt ; # +interp alias {} yencode::checkCrc32Flag {} checkBoolean ; # + +#pcx::message FOO {... text ...} type +#pcx::scan <VERSION> <NAME> <RULE> + +pcx::check 1.1.1 std ::yencode::ydecode \ + {checkConstrained {checkSimpleArgs 1 -1 { + {checkSwitches 1 { + {-filename {checkSetConstraint hasfilename checkFileName}} + -- + } {checkConstraint { + {hasfilename {checkSimpleArgs 0 0 {}}} + {!hasfilename {checkSimpleArgs 1 1 { + yencode::checkData + }}} + } {}}} + }}} +# TODO: Limit -mode to a octal numbers (file permissions) +pcx::check 1.1.1 std ::yencode::yencode \ + {checkConstrained {checkSimpleArgs 1 -1 { + {checkSwitches 1 { + {-crc32 yencode::checkCrc32Flag} + {-line yencode::checkLineLength} + {-mode yencode::checkMode} + {-name yencode::checkDstFilename} + {-filename {checkSetConstraint hasfilename checkFileName}} + -- + } {checkConstraint { + {hasfilename {checkSimpleArgs 0 0 {}}} + {!hasfilename {checkSimpleArgs 1 1 { + yencode::checkData + }}} + } {}}} + }}} + +# Initialization via pcx::init. +# Use a ::yencode::init procedure for non-standard initialization. +pcx::complete diff --git a/tcllib/modules/base64/yencode.tcl b/tcllib/modules/base64/yencode.tcl new file mode 100644 index 0000000..5d2c035 --- /dev/null +++ b/tcllib/modules/base64/yencode.tcl @@ -0,0 +1,307 @@ +# yencode.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Provide a Tcl only implementation of yEnc encoding algorithm +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +# FUTURE: Rework to allow switching between the tcl/critcl implementations. + +package require Tcl 8.2; # tcl minimum version +catch {package require crc32}; # tcllib 1.1 +catch {package require tcllibc}; # critcl enhancements for tcllib + +namespace eval ::yencode { + namespace export encode decode yencode ydecode +} + +# ------------------------------------------------------------------------- + +proc ::yencode::Encode {s} { + set r {} + binary scan $s c* d + foreach {c} $d { + set v [expr {($c + 42) % 256}] + if {$v == 0x00 || $v == 0x09 || $v == 0x0A + || $v == 0x0D || $v == 0x3D} { + append r "=" + set v [expr {($v + 64) % 256}] + } + append r [format %c $v] + } + return $r +} + +proc ::yencode::Decode {s} { + if {[string length $s] == 0} {return ""} + set r {} + set esc 0 + binary scan $s c* d + foreach c $d { + if {$c == 61 && $esc == 0} { + set esc 1 + continue + } + set v [expr {($c - 42) % 256}] + if {$esc} { + set v [expr {($v - 64) % 256}] + set esc 0 + } + append r [format %c $v] + } + return $r +} + +# ------------------------------------------------------------------------- +# C coded versions for critcl built base64c package +# ------------------------------------------------------------------------- + +if {[package provide critcl] != {}} { + namespace eval ::yencode { + critcl::ccode { + #include <string.h> + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* calculate the length of the encoded result */ + rlen = len; + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) + rlen++; + } + + /* allocate the output buffer */ + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + + /* encode the input */ + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) { + *r++ = '='; + v = (v + 64) % 256; + } + *r++ = v; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, esc; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* allocate the output buffer */ + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, len); + + /* encode the input */ + for (p = input, esc = 0, rlen = 0; p < input + len; p++) { + if (*p == 61 && esc == 0) { + esc = 1; + continue; + } + v = (*p - 42) % 256; + if (esc) { + v = (v - 64) % 256; + esc = 0; + } + *r++ = v; + rlen++; + } + Tcl_SetByteArrayLength(resultPtr, rlen); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } +} + +if {[info commands ::yencode::CEncode] != {}} { + interp alias {} ::yencode::encode {} ::yencode::CEncode + interp alias {} ::yencode::decode {} ::yencode::CDecode +} else { + interp alias {} ::yencode::encode {} ::yencode::Encode + interp alias {} ::yencode::decode {} ::yencode::Decode +} + +# ------------------------------------------------------------------------- +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::yencode::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- + +proc ::yencode::yencode {args} { + array set opts {mode 0644 filename {} name {} line 128 crc32 1} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(filename) [Pop args 1] } + -m* { set opts(mode) [Pop args 1] } + -n* { set opts(name) [Pop args 1] } + -l* { set opts(line) [Pop args 1] } + -c* { set opts(crc32) [Pop args 1] } + -- { Pop args ; break } + default { + set options [join [lsort [array names opts]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be -$options" + } + } + Pop args + } + + if {$opts(name) == {}} { + set opts(name) $opts(filename) + } + if {$opts(name) == {}} { + set opts(name) "data.dat" + } + if {! [string is boolean $opts(crc32)]} { + return -code error "bad option -crc32: argument must be true or false" + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + fconfigure $f -translation binary + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be\ + \"yencode ?options? -file name | data\"" + } + set data [lindex $args 0] + } + + set opts(size) [string length $data] + + set r {} + append r [format "=ybegin line=%d size=%d name=%s" \ + $opts(line) $opts(size) $opts(name)] "\n" + + set ndx 0 + while {$ndx < $opts(size)} { + set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]] + set enc [encode $pln] + incr ndx [string length $pln] + append r $enc "\r\n" + } + + append r [format "=yend size=%d" $ndx] + if {$opts(crc32)} { + append r " crc32=" [crc::crc32 -format %x $data] + } + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Perform ydecoding of a file or data. A file may contain more than one +# encoded data section so the result is a list where each element is a +# three element list of the provided filename, the file size and the +# data itself. +# +proc ::yencode::ydecode {args} { + array set opts {mode 0644 filename {} name default.bin} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(filename) [Pop args 1] } + -- { Pop args ; break; } + default { + set options [join [lsort [array names opts]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be -$opts" + } + } + Pop args + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be\ + \"ydecode ?options? -file name | data\"" + } + set data [lindex $args 0] + } + + set state false + set result {} + + foreach {line} [split $data "\n"] { + set line [string trimright $line "\r\n"] + switch -exact -- $state { + false { + if {[string match "=ybegin*" $line]} { + regexp {line=(\d+)} $line -> opts(line) + regexp {size=(\d+)} $line -> opts(size) + regexp {name=(\d+)} $line -> opts(name) + + if {$opts(name) == {}} { + set opts(name) default.bin + } + + set state true + set r {} + } + } + + true { + if {[string match "=yend*" $line]} { + set state false + lappend result [list $opts(name) $opts(size) $r] + } else { + append r [decode $line] + } + } + } + } + + return $result +} + +# ------------------------------------------------------------------------- + +package provide yencode 1.1.3 + +# ------------------------------------------------------------------------- +# +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + diff --git a/tcllib/modules/base64/yencode.test b/tcllib/modules/base64/yencode.test new file mode 100644 index 0000000..9d1813b --- /dev/null +++ b/tcllib/modules/base64/yencode.test @@ -0,0 +1,99 @@ +# yencode.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Tests for the Tcllib yencode package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: yencode.test,v 1.11 2008/12/12 04:57:46 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + # FUTURE: Switch tcl/critcl implementations + useTcllibC + useLocalKeep yencode.tcl yencode +} + +# ------------------------------------------------------------------------- + +if {[llength [info commands ::yencode::CEncode]]} { + puts "> critcl based" +} else { + puts "> pure tcl" +} + +proc ::yencode::loaddata {filename {translation auto}} { + set f [open $filename r] + fconfigure $f -translation $translation + set data [read $f] + close $f + return $data +} + +# ------------------------------------------------------------------------- + +set datafile [localPath yencode.test.data] + +test yencode-1.0 {yencode yEnc test file} { + set enc [::yencode::yencode -file $datafile] + set dec [::yencode::ydecode $enc] + set chk [::yencode::loaddata $datafile] + string equal $dec $chk +} {0} + + +# ------------------------------------------------------------------------- + +foreach {n in out} { + 0 A {k} + 1 ABC {klm} + 2 \0\1\2 {*+,} + 3 "\r\n\t" {743} + 4 "\xd6\xe0\xe3" {=@=J=M} +} { + test yencode-2.$n.a {check the pure tcl encode} { + list [catch {::yencode::Encode $in} r] $r + } [list 0 $out] + test yencode-2.$n.b {check the pure tcl decode} { + list [catch {::yencode::Decode $out} r] $r + } [list 0 $in] +} + +if {[llength [info commands ::yencode::CEncode]]} { + foreach {n in out} { + 0 A {k} + 1 ABC {klm} + 2 \0\1\2 {*+,} + 3 "\r\n\t" {743} + 4 "\xd6\xe0\xe3" {=@=J=M} + } { + test yencode-3.$n.a {check the critcl encode} { + list [catch {::yencode::Encode $in} r] $r + } [list 0 $out] + test yencode-3.$n.b {check the critcl decode} { + list [catch {::yencode::Decode $out} r] $r + } [list 0 $in] + } +} + +# ------------------------------------------------------------------------- + +catch { + unset datafile + rename ::yencode::loaddata {} +} +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/base64/yencode.test.data b/tcllib/modules/base64/yencode.test.data Binary files differnew file mode 100644 index 0000000..ebadc2c --- /dev/null +++ b/tcllib/modules/base64/yencode.test.data diff --git a/tcllib/modules/base64/yencode.test.out b/tcllib/modules/base64/yencode.test.out new file mode 100644 index 0000000..f17da90 --- /dev/null +++ b/tcllib/modules/base64/yencode.test.out @@ -0,0 +1,17 @@ +From: develop@winews.net +Newsgroups: yenc +Date: 27 Oct 2001 15:07:44 +0200 +Subject: yEnc-Prefix: "testfile.txt" 584 yEnc bytes - yEnc test (1) +Message-ID: <4407f.ra1200@liebchen.winews.net> +Path: liebchen.winews.net!not-for-mail +Lines: 16 +X-Newsreader: MyNews + +-- +=ybegin line=128 size=584 name=testfile.txt +oJWJ~JR[S74k}mssdJ\__XXZ74)('&%$#"! =M =J=I=@ +~}|{zyxwvutsrqponmlkjihgfedcba`_^]\[ZYXWVUTSR +QPONMLKJIHGFEDCBA@?>=}<;:9876543210/=n-,+*74k}mssdJZXX\__74*+,-=n/0123456789:;<=}>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl +mnopqrstuvwxyz{|}~ +=@=I=J =M !"#$%&'()74oJJ~74 +=yend size=584 crc32=ded29f4f |