Tcl Library Source Code

    set pad [expr {56 - ($len % 64)}]
    if {$len % 64 > 56} {
        incr pad 64
    }
    if {$pad == 0} {
        incr pad 64
    }

    puts "P $pad|bits=[expr {8 * $state(n)}]"

    append state(i) [binary format a$pad \x80]

    # RFC1321:3.2 - Append length in bits as little-endian wide int.
    append state(i) [binary format ii [expr {8 * $state(n)}] 0]

puts DATA=[Hex $state(i)]([string length $state(i)])

    # Calculate the hash for the remaining block.
    set len [string length $state(i)]
    for {set n 0} {($n + 64) <= $len} {} {
        MD5Hash $token [string range $state(i) $n [incr n 64]]
    }

    puts md5-post__________________________________________
    parray ::${token}

    # RFC1321:3.5 - Output
    set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)]
    unset state

    puts HASH=[Hex $r]
    return $r
}

# -------------------------------------------------------------------------
# HMAC Hashed Message Authentication (RFC 2104)
#
# hmac = H(K xor opad, H(K xor ipad, text))

# Note:
#  This function body is substituted later on to inline some of the 
#  procedures and to make is a bit more comprehensible.
#
set ::md5::MD5Hash_body {
    variable $token
    upvar 0 $token state

    puts TR__=[Hex $msg]([string length $msg])

    # RFC1321:3.4 - Process Message in 16-Word Blocks
    binary scan $msg i* blocks
    foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
        puts BL

        set A $state(A)
        set B $state(B)
        set C $state(C)
        set D $state(D)

        # Round 1
        # Let [abcd k s i] denote the operation

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

        if {[llength $args] != 1} {
            return -code error "wrong # args:\
                should be \"md5 ?-hex? -filename file | string\""
        }
        set tok [MD5Init]

        puts md5_______________________________________________
        parray ::${tok}

        puts IN=(([lindex $args 0]))
        MD5Update $tok [lindex $args 0]

        puts md5-final_________________________________________
        parray ::${tok}

        set r [MD5Final $tok]

    } else {

        set tok [MD5Init]
        # FRINK: nocheck
        set [subst $tok](reading) 1

    "F96B697D7CB7938D525A2F31AAF161D0"
    5    "abcdefghijklmnopqrstuvwxyz"
    "C3FCD3D76192E4007DFB496CCA67E13B"
    6    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
    "D174AB98D277D9F5A5611C2C9F419D9F"
    7    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
    "57EDF4A22BE3C955AC49DA2E2107B67A"
    8    "a\$apr1\$a"
    "020C3DD6931F7E94ECC99A1F4E4C53E2"
}
foreach impl [implementations] {
    select_implementation $impl
    foreach {n msg expected} $tests {
        test md5-v2-$impl-2.$n "md5 ($impl impl)" {
            list [catch {::md5::md5 -hex -- $msg} msg] $msg
        } [list 0 $expected]

[comment {-*- tcl -*-}][vset VERSION 2.4.1]
[manpage_begin struct::graph n [vset VERSION]]
[keywords adjacent]
[keywords arc]
[keywords cgraph]
[keywords degree]
[keywords edge]
[keywords graph]
[keywords loop]
[keywords neighbour]
[keywords node]
[keywords serialization]
[keywords subgraph]
[keywords vertex]
[copyright {2002-2009 Andreas Kupries <[email protected]>}]
[moddesc   {Tcl Data Structures}]
[titledesc {Create and manipulate directed graph objects}]
[category  {Data structures}]
[require Tcl 8.4]
[require struct::graph [opt  [vset VERSION]]]
[require struct::list  [opt 1.5]]
[require struct::set   [opt 2.2.3]]
[description]
[para]

A directed graph is a structure containing two collections of
elements, called [term nodes] and [term arcs] respectively, together

## Ready

namespace eval ::struct {
    # Export the constructor command.
    namespace export graph
}

package provide struct::graph 2.4.1

# -*- tcl -*-
# graph.test:  tests for the graph structure.
#
# 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.
# Copyright (c) 2017-2017 Andreas Kupries
# All rights reserved.
#
# RCS: @(#) $Id: graph.test,v 1.27 2007/04/12 03:01:54 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \

# -*- tcl -*-
# Graph tests - walk
# Copyright (c) 2006-2017 Andreas Kupries <[email protected]>
# All rights reserved.


# Syntax: graph walk NODE ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd

# -------------------------------------------------------------------------
# Wrong # args: Missing, Too many

test graph-${impl}-${setimpl}-walk-1.0 {walk, wrong#args, missing} {} {

    SETUPwalk
    set t [list ]
    mygraph walk ix -dir backward -order both -command record
    mygraph destroy
    set t
} [tmE  {enter ix enter i enter viii enter vi enter v enter iv enter iii enter ii leave ii leave iii leave iv leave v enter vii leave vii leave vi leave viii leave i leave ix} \
	{enter ix enter i enter viii enter vi enter vii leave vii enter v enter iv enter iii enter ii leave ii leave iii leave iv leave v leave vi leave viii leave i leave ix}]

# -------------------------------------------------------------------------

test graph-${impl}-${setimpl}-tkt.39ab616d8f-walk-4.0 {Ticket 39ab616d8f, dfs pre-order} -setup {
    SETUP
    mygraph node insert a
    mygraph node insert b
    mygraph node insert c
    mygraph arc insert a b ab
    mygraph arc insert b c bc
    mygraph arc insert a c ac
    #  /-> b -\
    # a -----> c
    set t {}    
} -body {
    mygraph walk a -command record -dir forward -order pre -type dfs
    set t
} -cleanup {
    mygraph destroy
    unset t
} -result [tmE {enter a enter b enter c} {enter a enter c enter b}]

test graph-${impl}-${setimpl}-tkt.39ab616d8f-walk-4.1 {Ticket 39ab616d8f, dfs pre-order} -setup {
    # This is like 4.0, with arcs ab, ac inserted in reverse
    # order. This forces the Critcl implementation into the same
    # situation as 4.0 does for Tcl, having c in the work stack as
    # neighbour of a and then getting visited from b before reahed
    # again. Passes.
    SETUP
    mygraph node insert a
    mygraph node insert b
    mygraph node insert c
    mygraph arc insert a c ac
    mygraph arc insert a b ab
    mygraph arc insert b c bc
    #  /-> b -\
    # a -----> c
    set t {}    
} -body {
    mygraph walk a -command record -dir forward -order pre -type dfs
    set t
} -cleanup {
    mygraph destroy
    unset t
} -result [tmE {enter a enter c enter b} {enter a enter b enter c}]

# -------------------------------------------------------------------------

rename record {}

# -------------------------------------------------------------------------

	if { [string equal $order "pre"] } {
	    # Pre-order Depth-first search

	    while { [llength $st] > 0 } {
		set node [lindex   $st end]
		ldelete st end

		# Skip all nodes already visited via some other path
		# through the graph.
		if {[info exists visited($node)]} continue
		
		# Evaluate the command at this node
		set cmdcpy $cmd
		lappend cmdcpy enter $name $node
		uplevel 1 $cmdcpy

		set visited($node) .

package ifneeded struct::graph     1.2.1 [list source [file join $dir graph1.tcl]]
package ifneeded struct::tree      1.2.2 [list source [file join $dir tree1.tcl]]
package ifneeded struct::matrix    1.2.1 [list source [file join $dir matrix1.tcl]]

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded struct::list      1.8.3  [list source [file join $dir list.tcl]]
package ifneeded struct::graph     2.4.1  [list source [file join $dir graph.tcl]]
package ifneeded struct::graph::op 0.11.3 [list source [file join $dir graphops.tcl]]