source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/base64/base64.tcl @ 8597867d

# 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.27 2005/12/09 18:27:15 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 output
        # of GNU uuencode 4.2.  Various RFCs allow for different wrapping 
        # characters and wraplengths, so these may be overridden by command line
        # options.
        set wrapchar "\n"
        set maxlen 60

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

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

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

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

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

        return $result
    }

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

    proc ::base64::decode {string} {
        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.

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

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

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

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

        # remove unneeded variables
        unset base64_tmp i char len val

        namespace export encode decode
    }

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

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

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

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

        set string [lindex $args end]

        set result {}
        set state 0
        set length 0


        # Process the input bytes 3-by-3

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

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

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

        set base64 $::base64::base64
        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 have 12 bits of input 
                # (enough for 1 8-bit output).  If x!={}, we have 18 bits of
                # input (enough for 2 8-bit outputs).
                
                foreach {v w z} $nums break
                set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
                if {$z == {}} {
                    append output [binary format c $a ]
                } else {
                    set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
                    append output [binary format cc $a $b]
                }               
                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.3.2