sum.tcl

Go to the documentation of this file.

/*  sum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>*/
/* */
/*  Provides a Tcl only implementation of the unix sum(1) command. There are*/
/*  a number of these and they use differing algorithms to get a checksum of*/
/*  the input data. We provide two: one using the BSD algorithm and the other*/
/*  using the SysV algorithm. More consistent results across multiple*/
/*  implementations can be obtained by using cksum(1).*/
/* */
/*  These commands have been checked against the GNU sum program from the GNU*/
/*  textutils package version 2.0 to ensure the same results.*/
/* */
/*  -------------------------------------------------------------------------*/
/*  See the file "license.terms" for information on usage and redistribution*/
/*  of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/*  -------------------------------------------------------------------------*/
/*  $Id: sum.tcl,v 1.7 2004/01/15 06:36:12 andreas_kupries Exp $*/

package require Tcl 8.2;                /*  tcl minimum version*/

catch {package require tcllibc};        /*  critcl enhancements to tcllib*/
/* catch {package require crcc};           # critcl enhanced crc module*/

namespace ::crc {
    variable sum_version 1.1.0
    namespace export sum

    variable uid
    if {![info exists uid]} {
         uid =  0
    }
}

/*  -------------------------------------------------------------------------*/
/*  Description:*/
/*   The SysV algorithm is fairly naive. The byte values are summed and any*/
/*   overflow is discarded. The lowest 16 bits are returned as the checksum.*/
/*  Notes:*/
/*   Input with the same content but different ordering will give the same */
/*   result.*/
/* */
ret  ::crc::SumSysV (type s , optional seed =0) {
    set t $seed
    binary scan $s c* r
    foreach n $r {
        incr t [expr {$n & 0xFF}]
    }
    return [expr {$t % 0xFFFF}]
}

/*  -------------------------------------------------------------------------*/
/*  Description:*/
/*   This algorithm is similar to the SysV version but includes a bit rotation*/
/*   step which provides a dependency on the order of the data values.*/
/* */
ret  ::crc::SumBsd (type s , optional seed =0) {
    set t $seed
    binary scan $s c* r
    foreach n $r {
        set t [expr {($t & 1) ? (($t >> 1) + 0x8000) : ($t >> 1)}]
        set t [expr {($t + ($n & 0xFF)) & 0xFFFF}]
    }
    return $t
}

/*  -------------------------------------------------------------------------*/

if {[package provide critcl] != {}} {
    namespace ::crc {
        critcl::ccommand SumSysV_c {dummy interp objc objv} {
            int r = TCL_OK;
            unsigned int t = 0;

            if (objc < 2 || objc > 3) {
                Tcl_WrongNumArgs(interp, 1, objv, "data ?seed?");
                return TCL_ERROR;
            }
            
            if (objc == 3)
                r = Tcl_GetIntFromObj(interp, objv[2], (int *)&t);

            if (r == TCL_OK) {
                int cn, size;
                unsigned char *data;

                data = Tcl_GetByteArrayFromObj(objv[1], &size);
                for (cn = 0; cn < size; cn++)
                    t += data[cn];
            }

            Tcl_SetIntObj(Tcl_GetObjResult(interp), t & 0xFFFF);
            return r;
        }

        critcl::ccommand SumBsd_c {dummy interp objc objv} {
            int r = TCL_OK;
            unsigned int t = 0;

            if (objc < 2 || objc > 3) {
                Tcl_WrongNumArgs(interp, 1, objv, "data ?seed?");
                return TCL_ERROR;
            }
            
            if (objc == 3)
                r = Tcl_GetIntFromObj(interp, objv[2], (int *)&t);

            if (r == TCL_OK) {
                int cn, size;
                unsigned char *data;

                data = Tcl_GetByteArrayFromObj(objv[1], &size);
                for (cn = 0; cn < size; cn++) {
                    t = (t & 1) ? ((t >> 1) + 0x8000) : (t >> 1);
                    t = (t + data[cn]) & 0xFFFF;
                }
            }

            Tcl_SetIntObj(Tcl_GetObjResult(interp), t & 0xFFFF);
            return r;
        }
    }
}

/*  -------------------------------------------------------------------------*/
/*  Switch from pure tcl to compiled if available.*/
/* */
if {[info command ::crc::SumBsd_c] == {}} {
    interp alias {} ::crc::sum-bsd  {} ::crc::SumBsd
} else {
    interp alias {} ::crc::sum-bsd  {} ::crc::SumBsd_c
}

if {[info command ::crc::SumSysV_c] == {}} {
    interp alias {} ::crc::sum-sysv {} ::crc::SumSysV
} else {
    interp alias {} ::crc::sum-sysv {} ::crc::SumSysV_c
}

/*  -------------------------------------------------------------------------*/
/*  Description:*/
/*   Pop the nth element off a list. Used in options processing.*/
/* */
ret  ::crc::Pop (type varname , optional nth =0) {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

/*  -------------------------------------------------------------------------*/
/*  timeout handler for the chunked file handling*/
/*  This avoids us waiting for ever*/
/* */
ret  ::crc::SumTimeout (type token) {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    set state(error) "operation timed out"
    set state(reading) 0
}

/*  -------------------------------------------------------------------------*/
/*  fileevent handler for chunked file handling.*/
/* */
ret  ::crc::SumChunk (type token , type channel) {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    
    if {[eof $channel]} {
        fileevent $channel readable {}
        set state(reading) 0
    }
    
    after cancel $state(after)
    set state(after) [after $state(timeout) \
                          [list [namespace origin SumTimeout] $token]]
    set state(result) [$state(algorithm) \
                           [read $channel $state(chunksize)] \
                           $state(result)]
}

/*  -------------------------------------------------------------------------*/
/*  Description:*/
/*   Provide a Tcl equivalent of the unix sum(1) command. We default to the*/
/*   BSD algorithm and return a checkum for the input string unless a filename*/
/*   has been provided. Using sum on a file should give the same results as*/
/*   the unix sum command with equivalent algorithm.*/
/*  Options:*/
/*   -bsd           - use the BSD algorithm to calculate the checksum (default)*/
/*   -sysv          - use the SysV algorithm to calculate the checksum*/
/*   -filename name - return a checksum for the specified file*/
/*   -format string - return the checksum using this format string*/
/* */
ret  ::crc::sum (type args) {
    array set opts [list -filename {} -channel {} -chunksize 4096 \
                        -timeout 30000 -bsd 1 -sysv 0 -format %u \
                        algorithm [namespace origin sum-bsd]]
    while {[string match -* [set option [lindex $args 0]]]} {
        switch -glob -- $option {
            -bsd    { set opts(-bsd) 1 ; set opts(-sysv) 0 }
            -sysv   { set opts(-bsd) 0 ; set opts(-sysv) 1 }
            -file*  { set opts(-filename) [Pop args 1] }
            -for*   { set opts(-format) [Pop args 1] }
            -chan*  { set opts(-channel) [Pop args 1] }
            -chunk* { set opts(-chunksize) [Pop args 1] }
            -time*  { set opts(-timeout) [Pop args 1] }
            --      { Pop args ; break }
            default {
                set err [join [lsort [array names opts -*]] ", "]
                return -code error "bad option $option:\
                    must be one of $err"
            }
        }
        Pop args
    }

    # Set the correct sum algorithm
    if {$opts(-sysv)} {
        set opts(algorithm) [namespace origin sum-sysv]
    }

    # If a file was given - open it for binary reading.
    if {$opts(-filename) != {}} {
        set opts(-channel) [open $opts(-filename) r]
        fconfigure $opts(-channel) -translation binary
    }

    if {$opts(-channel) == {}} {

        if {[llength $args] != 1} {
            return -code error "wrong # args: should be \
                 \"sum ?-bsd|-sysv? ?-format string? ?-chunksize size? \
                 ?-timeout ms? -file name | -channel chan | data\""
        }
        set r [$opts(algorithm) [lindex $args 0]]

    } else {

        # Create a unique token for the event handling
        variable uid
        set token [namespace current]::[incr uid]
        upvar #0 $token tok
        array set tok [list reading 1 result 0 timeout $opts(-timeout) \
                           chunksize $opts(-chunksize) \
                           algorithm $opts(algorithm)]
        set tok(after) [after $tok(timeout) \
                            [list [namespace origin SumTimeout] $token]]

        fileevent $opts(-channel) readable \
            [list [namespace origin SumChunk] $token $opts(-channel)]
        vwait [subst $token](reading)

        # If we opened the channel we must close it too.
        if {$opts(-filename) != {}} {
            close $opts(-channel)
        }

        # Extract the result or error message if there was a problem.
        set r $tok(result)
        if {[info exists tok(error)]} {
            return -code error $tok(error)
        }

        unset tok
    }

    return [format $opts(-format) $r]
}

/*  -------------------------------------------------------------------------*/

package provide sum $::crc::sum_version

/*  -------------------------------------------------------------------------    */
/*  Local Variables:*/
/*    mode: tcl*/
/*    indent-tabs-mode: nil*/
/*  End:*/