home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / base64 / base64.tcl next >
Encoding:
Text File  |  2001-08-17  |  8.8 KB  |  319 lines
  1. # base64.tcl --
  2. #
  3. # Encode/Decode base64 for a string
  4. # Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems
  5. # The decoder was done for exmh by Chris Garrigues
  6. #
  7. # Copyright (c) 1998-2000 by Ajuba Solutions.
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. # 
  11. # RCS: @(#) $Id: base64.tcl,v 1.12 2001/08/02 16:38:06 andreas_kupries Exp $
  12.  
  13. # Version 1.0 implemented Base64_Encode, Bae64_Decode
  14. # Version 2.0 uses the base64 namespace
  15. # Version 2.1 fixes various decode bugs and adds options to encode
  16. # Version 2.2 is much faster, Tcl8.0 compatible
  17.  
  18. package require Tcl 8
  19. namespace eval base64 {
  20. }
  21.  
  22. if {![catch {package require Trf 2.0}]} {
  23.     # Trf is available, so implement the functionality provided here
  24.     # in terms of calls to Trf for speed.
  25.  
  26.     # base64::encode --
  27.     #
  28.     #    Base64 encode a given string.
  29.     #
  30.     # Arguments:
  31.     #    args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
  32.     #    
  33.     #        If maxlen is 0, the output is not wrapped.
  34.     #
  35.     # Results:
  36.     #    A Base64 encoded version of $string, wrapped at $maxlen characters
  37.     #    by $wrapchar.
  38.     
  39.     proc base64::encode {args} {
  40.     # Set the default wrapchar and maximum line length to match the output
  41.     # of GNU uuencode 4.2.  Various RFC's allow for different wrapping 
  42.     # characters and wraplengths, so these may be overridden by command line
  43.     # options.
  44.     set wrapchar "\n"
  45.     set maxlen 60
  46.  
  47.     if { [llength $args] == 0 } {
  48.         error "wrong # args: should be \"[lindex [info level 0] 0]\
  49.             ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
  50.     }
  51.  
  52.     set optionStrings [list "-maxlen" "-wrapchar"]
  53.     for {set i 0} {$i < [llength $args] - 1} {incr i} {
  54.         set arg [lindex $args $i]
  55.         set index [lsearch -glob $optionStrings "${arg}*"]
  56.         if { $index == -1 } {
  57.         error "unknown option \"$arg\": must be -maxlen or -wrapchar"
  58.         }
  59.         incr i
  60.         if { $i >= [llength $args] - 1 } {
  61.         error "value for \"$arg\" missing"
  62.         }
  63.         set val [lindex $args $i]
  64.  
  65.         # The name of the variable to assign the value to is extracted
  66.         # from the list of known options, all of which have an
  67.         # associated variable of the same name as the option without
  68.         # a leading "-". The [string range] command is used to strip
  69.         # of the leading "-" from the name of the option.
  70.         #
  71.         # FRINK: nocheck
  72.         set [string range [lindex $optionStrings $index] 1 end] $val
  73.     }
  74.     
  75.     # [string is] requires Tcl8.2; this works with 8.0 too
  76.     if {[catch {expr {$maxlen % 2}}]} {
  77.         error "expected integer but got \"$maxlen\""
  78.     }
  79.  
  80.     set string [lindex $args end]
  81.     set result [::base64 -mode encode -- $string]
  82.     regsub -all -- \n $result {} result
  83.  
  84.     if {$maxlen > 0} {
  85.         set res ""
  86.         set edge [expr {$maxlen - 1}]
  87.         while {[string length $result] > $maxlen} {
  88.         append res [string range $result 0 $edge]$wrapchar
  89.         set result [string range $result $maxlen end]
  90.         }
  91.         if {[string length $result] > 0} {
  92.         append res $result
  93.         }
  94.         set result $res
  95.     }
  96.  
  97.     return $result
  98.     }
  99.  
  100.     # base64::decode --
  101.     #
  102.     #    Base64 decode a given string.
  103.     #
  104.     # Arguments:
  105.     #    string    The string to decode.  Characters not in the base64
  106.     #        alphabet are ignored (e.g., newlines)
  107.     #
  108.     # Results:
  109.     #    The decoded value.
  110.  
  111.     proc base64::decode {string} {
  112.     ::base64 -mode decode -- $string
  113.     }
  114.  
  115. } else {
  116.     # Without Trf use a pure tcl implementation
  117.  
  118.     namespace eval base64 {
  119.     variable base64 {}
  120.     variable base64_en {}
  121.  
  122.     # We create the auxiliary array base64_tmp, it will be unset later.
  123.  
  124.     set i 0
  125.     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 \
  126.         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 \
  127.         0 1 2 3 4 5 6 7 8 9 + /} {
  128.         set base64_tmp($char) $i
  129.         lappend base64_en $char
  130.         incr i
  131.     }
  132.  
  133.     #
  134.     # Create base64 as list: to code for instance C<->3, specify
  135.     # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
  136.     # ascii chars get a {}. we later use the fact that lindex on a
  137.     # non-existing index returns {}, and that [expr {} < 0] is true
  138.     #
  139.  
  140.     # the last ascii char is 'z'
  141.     scan z %c len
  142.     for {set i 0} {$i <= $len} {incr i} {
  143.         set char [format %c $i]
  144.         set val {}
  145.         if {[info exists base64_tmp($char)]} {
  146.         set val $base64_tmp($char)
  147.         } else {
  148.         set val {}
  149.         }
  150.         lappend base64 $val
  151.     }
  152.  
  153.     # code the character "=" as -1; used to signal end of message
  154.     scan = %c i
  155.     set base64 [lreplace $base64 $i $i -1]
  156.  
  157.     # remove unneeded variables
  158.     unset base64_tmp i char len val
  159.  
  160.     namespace export *
  161.     }
  162.  
  163.     # base64::encode --
  164.     #
  165.     #    Base64 encode a given string.
  166.     #
  167.     # Arguments:
  168.     #    args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
  169.     #    
  170.     #        If maxlen is 0, the output is not wrapped.
  171.     #
  172.     # Results:
  173.     #    A Base64 encoded version of $string, wrapped at $maxlen characters
  174.     #    by $wrapchar.
  175.     
  176.     proc base64::encode {args} {
  177.     set base64_en $::base64::base64_en
  178.     
  179.     # Set the default wrapchar and maximum line length to match the output
  180.     # of GNU uuencode 4.2.  Various RFC's allow for different wrapping 
  181.     # characters and wraplengths, so these may be overridden by command line
  182.     # options.
  183.     set wrapchar "\n"
  184.     set maxlen 60
  185.  
  186.     if { [llength $args] == 0 } {
  187.         error "wrong # args: should be \"[lindex [info level 0] 0]\
  188.             ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
  189.     }
  190.  
  191.     set optionStrings [list "-maxlen" "-wrapchar"]
  192.     for {set i 0} {$i < [llength $args] - 1} {incr i} {
  193.         set arg [lindex $args $i]
  194.         set index [lsearch -glob $optionStrings "${arg}*"]
  195.         if { $index == -1 } {
  196.         error "unknown option \"$arg\": must be -maxlen or -wrapchar"
  197.         }
  198.         incr i
  199.         if { $i >= [llength $args] - 1 } {
  200.         error "value for \"$arg\" missing"
  201.         }
  202.         set val [lindex $args $i]
  203.  
  204.         # The name of the variable to assign the value to is extracted
  205.         # from the list of known options, all of which have an
  206.         # associated variable of the same name as the option without
  207.         # a leading "-". The [string range] command is used to strip
  208.         # of the leading "-" from the name of the option.
  209.         #
  210.         # FRINK: nocheck
  211.         set [string range [lindex $optionStrings $index] 1 end] $val
  212.     }
  213.     
  214.     # [string is] requires Tcl8.2; this works with 8.0 too
  215.     if {[catch {expr {$maxlen % 2}}]} {
  216.         error "expected integer but got \"$maxlen\""
  217.     }
  218.  
  219.     set string [lindex $args end]
  220.  
  221.     set result {}
  222.     set state 0
  223.     set length 0
  224.  
  225.  
  226.     # Process the input bytes 3-by-3
  227.  
  228.     binary scan $string c* X
  229.     foreach {x y z} $X {
  230.         # Do the line length check before appending so that we don't get an
  231.         # extra newline if the output is a multiple of $maxlen chars long.
  232.         if {$maxlen && $length >= $maxlen} {
  233.         append result $wrapchar
  234.         set length 0
  235.         }
  236.     
  237.         append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] 
  238.         if {$y != {}} {
  239.         append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] 
  240.         if {$z != {}} {
  241.             append result \
  242.                 [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
  243.             append result [lindex $base64_en [expr {($z & 0x3F)}]]
  244.         } else {
  245.             set state 2
  246.             break
  247.         }
  248.         } else {
  249.         set state 1
  250.         break
  251.         }
  252.         incr length 4
  253.     }
  254.     if {$state == 1} {
  255.         append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== 
  256.     } elseif {$state == 2} {
  257.         append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]=  
  258.     }
  259.     return $result
  260.     }
  261.  
  262.     # base64::decode --
  263.     #
  264.     #    Base64 decode a given string.
  265.     #
  266.     # Arguments:
  267.     #    string    The string to decode.  Characters not in the base64
  268.     #        alphabet are ignored (e.g., newlines)
  269.     #
  270.     # Results:
  271.     #    The decoded value.
  272.  
  273.     proc base64::decode {string} {
  274.     set base64 $::base64::base64
  275.  
  276.     binary scan $string c* X
  277.     foreach x $X {
  278.         set bits [lindex $base64 $x]
  279.         if {$bits >= 0} {
  280.         if {[llength [lappend nums $bits]] == 4} {
  281.             foreach {v w z y} $nums break
  282.             set a [expr {($v << 2) | ($w >> 4)}]
  283.             set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
  284.             set c [expr {(($z & 0x3) << 6) | $y}]
  285.             append output [binary format ccc $a $b $c]
  286.             set nums {}
  287.         }        
  288.         } elseif {$bits == -1} {
  289.         # = indicates end of data.  Output whatever chars are left.
  290.         # The encoding algorithm dictates that we can only have 1 or 2
  291.         # padding characters.  If x=={}, we have 12 bits of input 
  292.         # (enough for 1 8-bit output).  If x!={}, we have 18 bits of
  293.         # input (enough for 2 8-bit outputs).
  294.         
  295.         foreach {v w z} $nums break
  296.         set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
  297.         
  298.         if {$z == {}} {
  299.             append output [binary format c $a ]
  300.         } else {
  301.             set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
  302.             append output [binary format cc $a $b]
  303.         }        
  304.         break
  305.         } else {
  306.         # RFC 2045 says that line breaks and other characters not part
  307.         # of the Base64 alphabet must be ignored, and that the decoder
  308.         # can optionally emit a warning or reject the message.  We opt
  309.         # not to do so, but to just ignore the character. 
  310.         continue
  311.         }
  312.     }
  313.     return $output
  314.     }
  315. }
  316.  
  317. package provide base64 2.2
  318.  
  319.