ADDED build-process Index: build-process ================================================================== --- /dev/null +++ build-process @@ -0,0 +1,5 @@ +1. Create kernel +2. Create initrd +4. Create system image + a. Create apps + b. Tar up ADDED components/package-maker/bin/build Index: components/package-maker/bin/build ================================================================== --- /dev/null +++ components/package-maker/bin/build @@ -0,0 +1,906 @@ +#! /usr/bin/env tclsh + +set domain "appbox.rkeene.org" +set packages $argv + +lappend auto_path [file join [file dirname [info script]] .. lib] + +package require tax +package require csv +package require sha1 +package require md5 + +namespace eval ::cael::build { + variable pkgmap_fields [list name type owner group mode mtime size sha1 linkdest] + variable pkginfodir [file join [file dirname [info script]] .. pkginfo] + variable buildonlyvars [list destroot buildroot metadataroot extraroot] + variable have_tclx 0 + variable default_scripts { + compile { + /bin/sh { + ./configure "--prefix=${_APPBOX_PREFIX}" "--sysconfdir=${_APPBOX_SYSCONFDIR}" || exit 1 + + make || exit 1 + + exit 0 + } + } + install { + /bin/sh { + make "DESTDIR=${destroot}" install || exit 1 + + exit 0 + } + } + } +} + +catch { + package require Tclx + set ::cael::build::have_tclx 1 +} + +if {!$::cael::build::have_tclx} { + proc recursive_glob {dirlist globlist} { + set result {} + set recurse {} + + foreach dir $dirlist { + if ![file isdirectory $dir] { + error "\"$dir\" is not a directory" + } + + foreach pattern $globlist { + set result [concat $result [glob -nocomplain -- [file join $dir $pattern]]] + } + + foreach file [glob -nocomplain -tails -directory $dir * .*] { + set file [file join $dir $file] + if [file isdirectory $file] { + set fileTail [file tail $file] + if {$fileTail != "." && $fileTail != ".."} { + lappend recurse $file + } + } + } + } + + if {[llength $recurse] != 0} { + set result [concat $result [recursive_glob $recurse $globlist]] + } + + return $result + } +} + +proc ::cael::build::_parse_pkgXML {tag isClosing isSelfClosing props_list body} { + if {[string match "!--*" $tag]} { + return + } + + if {$isClosing} { + set lastOpened [lindex $::cael::build::_xml_stack end] + + if {$tag != $lastOpened} { + return -code error "XML Parsing Error: Got close for tag \"${tag}\", but last opened was \"${lastOpened}\"" + } + + set fulltag [join $::cael::build::_xml_stack .] + + switch -- $fulltag { + root.package.releases.release { + unset -nocomplain currversioninfo + + # Convert array-like list into an array + foreach {var val} $::cael::build::_currversion { + switch -- $var { + "urls" - "sigs" - "alt" { + # These elements form lists + lappend currversioninfo($var) $val + } + default { + # All other elements form strings + set currversioninfo($var) $val + } + } + } + + lappend ::cael::build::_parse_array(versions) [array get currversioninfo] + + unset ::cael::build::_currversion + } + root.package.variants.variant { + set ::cael::build::_ignoreTags_until_variant 0 + } + root.package.releases { + # If a default URL was specified, go back through every release and add an "urls" list if none are present + if {[info exists ::cael::build::_parse_array(urls)] && [info exists ::cael::build::_parse_array(versions)]} { + set newversions [list] + foreach version_ent_list $::cael::build::_parse_array(versions) { + array set tmpversinfo $version_ent_list + + if {![info exists tmpversinfo(urls)]} { + set tmpversinfo(urls) $::cael::build::_parse_array(urls) + } + + lappend newversions [array get tmpversinfo] + } + + set ::cael::build::_parse_array(versions) $newversions + } + } + root.package { + foreach {scriptname} [lsort -dictionary [array name ::cael::build::_script_array]] { + set script_frags $::cael::build::_script_array($scriptname) + set interp $::cael::build::_script_info($scriptname) + + set script_list [list] + foreach script_frag $script_frags { + foreach line [split $script_frag "\n"] { + lappend script_list $line + } + } + set script [join $script_list "\n"] + + lappend ::cael::build::_parse_array(scripts) $scriptname [list $interp $script] + } + } + } + + set ::cael::build::_xml_stack [lrange $::cael::build::_xml_stack 0 end-1] + + return + } + + regsub -all {\&ob;} $body \{ body + regsub -all {\&cb;} $body \} body + + lappend ::cael::build::_xml_stack $tag + + set fulltag [join $::cael::build::_xml_stack .] + array set props $props_list + + if {$::cael::build::_ignoreTags_until_variant} { + set fulltag "__IGNORED__" + } + + switch -- $fulltag { + __IGNORED__ {} + root.package { + set pkgname $props(name) + + set pkgname [string trim $pkgname] + + set ::cael::build::_parse_array(name) $pkgname + } + root.package.description { + set short_desc $props(short) + set long_desc $body + + set short_desc [string trim $short_desc] + set long_desc [string trim $long_desc] + + set ::cael::build::_parse_array(short_desc) $short_desc + set ::cael::build::_parse_array(long_desc) $long_desc + } + root.package.releases.release { + set ::cael::build::_currversion [list version $props(version)] + } + root.package.releases.release.alt { + lappend ::cael::build::_currversion alt $body + } + root.package.releases.release.source.url { + lappend ::cael::build::_currversion urls $body + } + root.package.releases.release.source.sig { + lappend ::cael::build::_currversion sigs $body + } + root.package.releases.release.sha1 { + lappend ::cael::build::_currversion sha1 [string trim $body] + } + root.package.releases.source.url { + lappend ::cael::build::_parse_array(urls) $body + } + root.package.releases.source.sig { + lappend ::cael::build::_parse_array(sigs) $body + } + root.package.variants.variant { + lappend ::cael::build::_parse_array(variants) $props(name) + + if {$props(name) != $::cael::build::_variant} { + set ::cael::build::_ignoreTags_until_variant 1 + } else { + set ::cael::build::_parse_array(variant) $props(name) + } + } + root.package.var - root.package.variants.variant.var { + lappend ::cael::build::_parse_array(env_vars) $props(name) $props(value) + } + root.package.script - root.package.variants.variant.script { + if {![info exists props(name)] && ![info exists props(names)]} { + set props(name) "immediate-$::cael::build::_script_num" + incr ::cael::build::_script_num + } + + if {[info exists props(names)]} { + if {[info exists props(name)]} { + return -code error "May not specify both the \"name\" and \"names\" properties for a script" + } + set script_names [split $props(names) ","] + } else { + set script_names [list $props(name)] + } + + foreach script_name $script_names { + set script_name [string trim $script_name] + + if {[info exists props(interp)]} { + set ::cael::build::_script_info($script_name) $props(interp) + } else { + if {![info exists ::cael::build::_script_info($script_name)]} { + # The first reference to a script must include the interp + return -code error "Script \"$script_name\" has no interpreter (first reference must include an \"interp\" property to specify the interpreter)" + } + } + + lappend ::cael::build::_script_array($script_name) $body + } + } + root.package.files.default { + set permslist [list] + foreach prop [list owner group filemode dirmode] { + lappend permslist $prop $props($prop) + } + set ::cael::build::_parse_array(default-file) $permslist + } + root.package.files.file { + set permslist [list] + foreach prop [list owner group mode] { + lappend permslist $prop $props($prop) + } + lappend ::cael::build::_parse_array(files) $props(name) $permslist + } + root.package.buildflags.static - root.package.variants.variant.buildflags.static { + lappend ::cael::build::_parse_array(buildflags) "static" + } + root - \ + root.package.releases - \ + root.package.releases.release.source - \ + root.package.releases.source - \ + root.package.variants - \ + root.package.buildflags - \ + root.package.variants.variant.buildflags - \ + root.package.files { + # We don't handle these tags + } + default { + puts stderr "Unhandled Tag: <${fulltag} props=$props_list, body=[string trim $body]>" + } + } + + if {$isSelfClosing} { + set ::cael::build::_xml_stack [lrange $::cael::build::_xml_stack 0 end-1] + } + + return +} + +proc ::cael::build::_parse_pkgXML_init {variant} { + set ::cael::build::_script_num 0 + set ::cael::build::_xml_stack "" + set ::cael::build::_variant $variant + set ::cael::build::_ignoreTags_until_variant 0 + + unset -nocomplain ::cael::build::_parse_array ::cael::build::_currversion + set ::cael::build::_parse_array(variant) default +} + +proc ::cael::build::_version_sort {a b} { + set foundval [lindex [lsort -dictionary [list $a $b]] 0] + + if {$foundval == "$a"} { + return -1 + } + + return 1 +} + +proc ::cael::build::_parse_pkg {pkgname {version "latest"} {variant "default"}} { + set file [file join $::cael::build::pkginfodir "${pkgname}.xml"] + + # Read in XML document + set fd [open $file r] + set document [read $fd] + close $fd + + # Cleanup internal XML structures + ::cael::build::_parse_pkgXML_init $variant + + # Parse XML Document + ::tax::parse ::cael::build::_parse_pkgXML $document root + + # Populate version information + ## Determine the latest version if it is requested + set versions [list] + array set allversinfo [list] + foreach versinfo_list $::cael::build::_parse_array(versions) { + unset -nocomplain versinfo + array set versinfo $versinfo_list + + set item_version $versinfo(version) + + lappend versions $item_version + set allversinfo($item_version) $versinfo_list + } + if {$version == "latest"} { + set version [lindex [lsort -decreasing -command ::cael::build::_version_sort $versions] 0] + } + set ::cael::build::_parse_array(versinfo) $allversinfo($version) + + # Generate return value + set retval [array get ::cael::build::_parse_array] + + # Cleanup + unset ::cael::build::_parse_array + + return $retval +} + +proc ::cael::build::_url_subst {url env version} { + # Create a safe interp to run the substitutions in + + set interp [interp create -safe] + + foreach {var val} $env { + $interp eval [list set $var $val] + } + + set retval [$interp eval [list subst $url]] + + interp delete $interp + + return $retval +} + +proc ::cael::build::script_gen_execute {shell args} { + # Determine the properties of this shell + switch -glob -- $shell { + "*/csh" { + lappend escapeMapping {'} {'"'"'} + set quoteOpen "'" + set quoteClose "'" + + set abortSuffix " || exit 1" + + set commentChar "#" + set execCmd "" + } + "*/tclsh" { + lappend escapeMapping "\\" "\\\\" "\"" "\\\"" "{" "\\\{" "}" "\\\}" "\$" "\\\$" "\[" "\\\[" "\]" "\\\]" + set quoteOpen "\"" + set quoteClose "\"" + + set abortSuffix "" + + set commentChar "#" + set execCmd "exec " + } + default { + # Bourne-like shells + lappend escapeMapping {'} {'"'"'} + set quoteOpen "'" + set quoteClose "'" + + set abortSuffix " || exit 1" + + set commentChar "#" + set execCmd "" + } + } + + # Set a default value if we are unable to emit usable actions + set ret "echo \"Unable to determine how to \\\"[join $args " "]\\\"\"\nexit 1" + + # Determine output + set cmd [lindex $args 0] + switch -- $cmd { + "set" { + set var [lindex $args 1] + set val [string map $escapeMapping [lindex $args 2]] + + switch -glob -- $shell { + "*/csh" { + set ret "setenv $var='$val'" + } + "*/tclsh" { + set ret "set $var \"$val\"" + } + default { + set ret "$var='$val'; export $var" + } + } + } + "mkdir" { + set dir [string map $escapeMapping [lindex $args 1]] + + switch -glob -- $shell { + "*/tclsh" { + set ret "file mkdir -- \"$dir\"" + } + default { + set ret "mkdir -p '$dir' || exit 1" + } + } + } + "mv" { + set src [string map $escapeMapping [lindex $args 1]] + set dst [string map $escapeMapping [lindex $args 2]] + + switch -glob -- $shell { + "*/tclsh" { + set ret "file rename -- \"$src\" \"$dst\"" + } + default { + set ret "mv '$src' '$dst' || exit 1" + } + } + } + "cd_one_dir" { + switch -glob -- $shell { + "*/csh" { + # XXX: TODO + } + "*/tclsh" { + # XXX: TODO + } + default { + set ret "_tmp_build_num_dirs=\"\`ls -1a | wc -l`\"\n" + append ret "if \[ \"x\${_tmp_build_num_dirs}\" = \"x3\" ]; then\n" + append ret "\tcd *\n" + append ret "fi\n" + append ret "unset _tmp_build_num_dirs\n" + } + } + } + "sha1check" { + set file [string map $escapeMapping [lindex $args 1]] + set sha1 [string map $escapeMapping [lindex $args 2]] + + switch -glob -- $shell { + "*/csh" { + # XXX: TODO + } + "*/tclsh" { + # XXX: TODO + } + default { + set ret "_tmp_sha1sum=\"`sha1sum '${file}' | awk '{ print \$1 }'`\"\n" + append ret "if \[ \"x\${_tmp_sha1sum}\" != 'x${sha1}' \]; then\n" + append ret "\techo 'Checksum of \"${file}\" failed. Aborting.\'\n" + append ret "\texit 1\n" + append ret "fi\n" + append ret "unset _tmp_sha1sum\n" + } + } + } + "wget" { + set file [string map $escapeMapping [lindex $args 1]] + set urls [lindex $args 2] + + switch -glob -- $shell { + "*/tclsh" { + # XXX: TODO + } + default { + set ret "wget -O '${file}' '[string map $escapeMapping [lindex $urls 0]]' || \\\n" + foreach url [lrange $urls 1 end] { + append ret "\twget -O '${file}' '[string map $escapeMapping $url]' || \\\n" + } + append ret "\texit 1\n" + } + } + } + "extract" { + set file [string map $escapeMapping [lindex $args 1]] + + switch -glob -- $shell { + "*/tclsh" { + # XXX: TODO + } + default { + set ret "${execCmd}tar -xf ${quoteOpen}${file}${quoteClose} || \\\n" + append ret "\t${execCmd}xz -dc ${quoteOpen}${file}${quoteClose} | tar -xf - || \\\n" + append ret "\t${execCmd}unzip ${quoteOpen}${file}${quoteClose}${abortSuffix}" + } + } + } + "cd" { + set dir [string map $escapeMapping [lindex $args 1]] + + set ret "cd ${quoteOpen}${dir}${quoteClose}${abortSuffix}" + } + } + + return $ret +} + +proc ::cael::build::gen_scripts {pkgname version variant workdir instrootdir versinfo_list pkginfo_list scripts_list} { + array set versinfo $versinfo_list + array set pkginfo $pkginfo_list + + set ret [list] + + set scriptdir [file join $workdir build-scripts] + set builddir [file join $workdir build] + set srcdir [file join $workdir src] + + file mkdir $scriptdir + file mkdir $srcdir + + foreach {script scriptval} $scripts_list { + # Sanitize script name to create script name + set script [file tail $script] + + # Determine script file name + set file [file join $scriptdir "${script}"] + + # Record script name and file for later use + lappend ret $script $file + + set init 0 + if {![file exists $file]} { + set init 1 + } + + set fd [open $file a+] + + if {$init} { + set shell [lindex $scriptval 0] + + # Create generic preamble + puts $fd "#!${shell}" + puts $fd "" + set export_vars [list] + foreach {var val} $pkginfo(env_vars) { + # Exclude build-related variables from + # non-build-related scripts + switch -- $script { + "compile" - "install" { + } + default { + if {[lsearch -exact $::cael::build::buildonlyvars $var] != -1} { + continue + } + } + } + + puts $fd [script_gen_execute $shell set $var $val] + } + + # Do script-specific preamble + switch -- $script { + "compile" - "install" { + puts $fd [script_gen_execute $shell mkdir $workdir] + puts $fd [script_gen_execute $shell cd $workdir] + puts $fd "" + } + } + + # Do script-specific stuff + switch -- $script { + "compile" { + puts $fd [script_gen_execute $shell mkdir $srcdir] + puts $fd "" + + set outfile [file join $srcdir "${pkgname}-$versinfo(version).src"] + + # Download archive + set urls [list] + foreach url $versinfo(urls) { + lappend urls [_url_subst $url $pkginfo(env_vars) $versinfo(version)] + } + puts $fd [script_gen_execute $shell wget "${outfile}.new" $urls] + puts $fd [script_gen_execute $shell sha1check "${outfile}.new" $versinfo(sha1)] + puts $fd "mv '${outfile}.new' '${outfile}'" + puts $fd "" + + # Extract archive + puts $fd [script_gen_execute $shell mkdir $builddir] + puts $fd [script_gen_execute $shell cd $builddir] + puts $fd [script_gen_execute $shell extract $outfile] + puts $fd "" + + # Change to working directory within archive, if available + puts $fd [script_gen_execute $shell cd_one_dir] + } + "install" { + # Change to working directory within archive + puts $fd [script_gen_execute $shell cd $builddir] + puts $fd [script_gen_execute $shell cd_one_dir] + puts $fd "" + + # Create the installation root directory + puts $fd [script_gen_execute $shell mkdir $instrootdir] + puts $fd "" + } + } + } + + foreach part [lrange $scriptval 1 end] { + puts $fd $part + } + + close $fd + } + + return $ret +} + +proc ::cael::build::gen_meta {pkgname pkgdomain version variant workdir instrootdir instmetadir versinfo_list pkginfo_list scripts_list} { + array set versinfo $versinfo_list + array set pkginfo $pkginfo_list + + array set fileinfo [list] + if {[info exists pkginfo_list(files)]} { + array set fileinfo $pkginfo_list(files) + } + + ## Create meta directory + file mkdir $instmetadir + + ## Create Description file + set pkgdescfile [file join $instmetadir desc] + set fd [open $pkgdescfile w] + puts $fd "[join [split $pkginfo(short_desc) "\n"] " "]" + puts $fd "$pkginfo(long_desc)" + close $fd + + ## Create Package Map file + ### Generate list of all files + set filelist [recursive_glob [list $instrootdir] [list *]] + + ### Determine how to modify the file name to be what is available + ### to the system + set strip_file_names [string length $instrootdir] + + ### Create default file information if it was not provided + if {![info exists pkginfo(default-file)]} { + set pkginfo(default-file) [list] + } + + ### Create mapping + set pkgmapfile [file join $instmetadir map] + set fd [open $pkgmapfile w] + foreach file $filelist { + #### Ensure that we do not get data from another file if we fail + #### to create a field + unset -nocomplain destfile + + #### Get current file information + file lstat $file srcfile + + #### Set reasonable defaults + set destfile(owner) 0 + set destfile(group) 0 + set destfile(mode) [expr {$srcfile(mode) & 0777}] + + #### Set derived parameters + set destfile(name) [string range $file $strip_file_names end] + set destfile(type) $srcfile(type) + set destfile(mtime) $srcfile(mtime) + + if {$destfile(type) == "file"} { + set destfile(size) $srcfile(size) + set destfile(sha1) [sha1::sha1 -hex -file $file] + } + + if {$destfile(type) == "link"} { + set linkdest [file link $file] + ##### If the link points inside the package directory, + ##### rewrite it + if {[string range $linkdest 0 [expr {$strip_file_names - 1}]] == [string range $file 0 [expr {$strip_file_names - 1}]]} { + set linkdest [string range $linkdest $strip_file_names end] + } + + set destfile(linkdest) $linkdest + } + + #### Set the default values + foreach {var val} $pkginfo(default-file) { + switch -- $var { + "owner" - "group" { + set destfile($var) $val + } + "filemode" { + if {$destfile(type) != "directory"} { + set destfile(mode) $val + } + } + "dirmode" { + if {$destfile(type) == "directory"} { + set destfile(mode) $val + } + } + } + } + + #### Set the values specified for this specific file + if {[info exists fileinfo($destfile(name))]} { + array set destfile $fileinfo($destfile(name)) + } + + #### Take the data and format it into a list in the order specified + set destline_data [list] + foreach field $::cael::build::pkgmap_fields { + if {![info exists destfile($field)]} { + lappend destline_data "" + + continue + } + + lappend destline_data $destfile($field) + } + + set destline [csv::join $destline_data] + + puts $fd $destline + } + close $fd + + ## Create package information file + ### XXX: TODO + set pkginfofile [file join $instmetadir info] + set fd [open $pkginfofile w] + + ### Domain + puts $fd "domain: $pkgdomain" + + ### Name + puts $fd "name: $pkgname" + + ### Version + puts $fd "version: $version" + + ### Variant + puts $fd "variant: $variant" + + ### Arch + #### XXX: TODO: Figure this out somehow + puts $fd "arch: ..." + + ### Release + #### XXX: TODO: Need to pull this from the build database + puts $fd "release: ..." + + ### Flags + #### XXX: TODO: Figure out how this will be formatted + puts $fd "flags: ..." + + ### Compiler (if not static) + #### XXX: TODO: Needed ? Could this be a flag (.e.g, compiler=blah) ? + close $fd + + ## Create Dependencies list file + ### XXX: TODO + + ## Create Conflict list file + ### XXX: TODO +} + +proc ::cael::build::build {pkgname pkgdomain {version "latest"} {variant "default"}} { + # Parse package data + array set pkginfo [_parse_pkg $pkgname $version $variant] + + if {[info exists pkginfo(scripts)]} { + array set scripts $pkginfo(scripts) + } else { + array set scripts [list] + } + + array set versinfo $pkginfo(versinfo) + + # Add missing values + if {![info exists pkginfo(env_vars)]} { + set pkginfo(env_vars) "" + } + + # Create working directory + set tmpdir "/tmp" + if {[info exists ::env(TMPDIR)]} { + set tmpdir $::env(TMPDIR) + } + + set random [string map [list "." ""] [expr {rand() * 10.0}][expr {rand() * 10.0}]] + set workdir [file join $tmpdir "build-${random}"] + set extradir [file join $workdir "extra"] + set pkgdir [file join $workdir "pkgroot"] + set instrootdir [file join $pkgdir "root"] + set instmetadir [file join $pkgdir "install"] + set instlogdir [file join $instmetadir "logs"] + + # Create extra data, if any + set extradir_src [file join $::cael::build::pkginfodir $pkgname] + if {[file isdirectory $extradir_src]} { + file mkdir $extradir + + foreach copyfile [glob -directory $extradir_src *] { + file copy -force -- $copyfile $extradir + } + + lappend pkginfo(env_vars) extraroot $extradir + } + + # Update package data + lappend pkginfo(env_vars) version $versinfo(version) destroot $instrootdir buildroot $workdir metadataroot $instmetadir + + # Update with paths to installation + lappend pkginfo(env_vars) _APPBOX_PREFIX /apps/${pkgname}/$versinfo(version) _APPBOX_SYSCONFDIR /system/config/apps/$pkgname + + # Include default scripts if needed + foreach {default_script_name default_script} $::cael::build::default_scripts { + if {![info exists scripts($default_script_name)]} { + set scripts($default_script_name) $default_script + } + } + + # Create build scripts + set scripts_files_list [gen_scripts $pkgname $version $variant $workdir $instrootdir [array get versinfo] [array get pkginfo] [array get scripts]] + array set scripts_files $scripts_files_list + + # Execute build scripts + ## Execute immediate scripts + ### XXX: TODO + + ## Execute scripts related to building and installing + foreach script [list compile install] { + if {![info exists scripts_files($script)]} { + continue + } + + file attributes $scripts_files($script) -permissions +x + set compile_ret [exec $scripts_files($script) 2>@1] + + ### Log script outputs + set logfile "$scripts_files($script).log" + set fd [open $logfile w] + puts $fd $compile_ret + close $fd + } + + # Create package metadata + gen_meta $pkgname $pkgdomain $version $variant $workdir $instrootdir $instmetadir [array get versinfo] [array get pkginfo] [array get scripts] + + # Put package scripts in package meta-data directory + foreach script [list post-install post-remove pre-install pre-remove] { + if {![info exists scripts_files($script)]} { + continue + } + + file attributes $scripts_files($script) -permissions +x + file copy $scripts_files($script) $instmetadir + } + + # Put package log files in package meta-data directory + file mkdir $instlogdir + foreach {script script_file} [array get scripts_files] { + set log_file "${script_file}.log" + + if {![file exists $log_file]} { + continue + } + + file copy -- $log_file $instlogdir + } + + # Create package file + ## Create tarball + set pkgfilename "${pkgname}-$versinfo(version).tgz" + exec tar -C $pkgdir -zcf $pkgfilename . + + # Cleanup + file delete -force -- $workdir +} + +foreach package $packages { + ::cael::build::build $package $domain +} ADDED components/package-maker/lib/csv0.7.2/csv.tcl Index: components/package-maker/lib/csv0.7.2/csv.tcl ================================================================== --- /dev/null +++ components/package-maker/lib/csv0.7.2/csv.tcl @@ -0,0 +1,812 @@ +# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*- +# -- Tcl Module + +# @@ Meta Begin +# Package csv 0.7.2 +# Meta as::build::date 2010-12-10 +# Meta as::origin http://sourceforge.net/projects/tcllib +# Meta category CSV processing +# Meta description Procedures to handle CSV data. +# Meta license BSD +# Meta platform tcl +# Meta require {Tcl 8.3} +# Meta subject package csv queue matrix tcllib +# Meta summary csv +# @@ Meta End + + +# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS + +package require Tcl 8.3 + +# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS + +# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE + +package provide csv 0.7.2 + +# ACTIVESTATE TEAPOT-PKG END DECLARE +# ACTIVESTATE TEAPOT-PKG END TM +# csv.tcl -- +# +# Tcl implementations of CSV reader and writer +# +# Copyright (c) 2001 by Jeffrey Hobbs +# Copyright (c) 2001-2008 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: csv.tcl,v 1.27 2010/01/19 20:21:57 andreas_kupries Exp $ + +package require Tcl 8.3 +package provide csv 0.7.2 + +namespace eval ::csv { + namespace export join joinlist read2matrix read2queue report + namespace export split split2matrix split2queue writematrix writequeue +} + +# ::csv::join -- +# +# Takes a list of values and generates a string in CSV format. +# +# Arguments: +# values A list of the values to join +# sepChar The separator character, defaults to comma +# +# Results: +# A string containing the values in CSV format. + +proc ::csv::join {values {sepChar ,} {delChar \"}} { + set out "" + set sep {} + foreach val $values { + if {[string match "*\[${delChar}$sepChar\]*" $val]} { + append out $sep${delChar}[string map [list $delChar ${delChar}${delChar}] $val]${delChar} + } else { + append out $sep${val} + } + set sep $sepChar + } + return $out +} + +# ::csv::joinlist -- +# +# Takes a list of lists of values and generates a string in CSV +# format. Each item in the list is made into a single CSV +# formatted record in the final string, the records being +# separated by newlines. +# +# Arguments: +# values A list of the lists of the values to join +# sepChar The separator character, defaults to comma +# +# Results: +# A string containing the values in CSV format, the records +# separated by newlines. + +proc ::csv::joinlist {values {sepChar ,} {delChar \"}} { + set out "" + foreach record $values { + # note that this is ::csv::join + append out "[join $record $sepChar $delChar]\n" + } + return $out +} + +# ::csv::joinmatrix -- +# +# Takes a matrix object following the API specified for the +# struct::matrix package. Each row of the matrix is converted +# into a single CSV formatted record in the final string, the +# records being separated by newlines. +# +# Arguments: +# matrix Matrix object command. +# sepChar The separator character, defaults to comma +# +# Results: +# A string containing the values in CSV format, the records +# separated by newlines. + +proc ::csv::joinmatrix {matrix {sepChar ,} {delChar \"}} { + return [joinlist [$matrix get rect 0 0 end end] $sepChar $delChar] +} + +# ::csv::iscomplete -- +# +# A predicate checking if the argument is a complete csv record. +# +# Arguments +# data The (partial) csv record to check. +# +# Results: +# A boolean flag indicating the completeness of the data. The +# result is true if the data is complete. + +proc ::csv::iscomplete {data} { + expr {1 - [regexp -all \" $data] % 2} +} + +# ::csv::read2matrix -- +# +# A wrapper around "Split2matrix" reading CSV formatted +# lines from the specified channel and adding it to the given +# matrix. +# +# Arguments: +# m The matrix to add the read data too. +# chan The channel to read from. +# sepChar The separator character, defaults to comma +# expand The expansion mode. The default is none +# +# Results: +# A list of the values in 'line'. + +proc ::csv::read2matrix {args} { + # FR #481023 + # See 'split2matrix' for the available expansion modes. + + # Argument syntax: + # + #2) chan m + #3) chan m sepChar + #3) -alternate chan m + #4) -alternate chan m sepChar + #4) chan m sepChar expand + #5) -alternate chan m sepChar expand + + set alternate 0 + set sepChar , + set expand none + + switch -exact -- [llength $args] { + 2 { + foreach {chan m} $args break + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set chan $b + set m $c + } else { + set chan $a + set m $b + set sepChar $c + } + } + 4 { + foreach {a b c d} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set chan $b + set m $c + set sepChar $d + } else { + set chan $a + set m $b + set sepChar $c + set expand $d + } + } + 5 { + foreach {a b c d e} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? chan m ?separator? ?expand?" + } + set alternate 1 + + set chan $b + set m $c + set sepChar $d + set expand $e + } + 0 - 1 - + default { + return -code error "wrong#args: Should be ?-alternate? chan m ?separator? ?expand?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character \"$sepChar\", is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character \"$sepChar\", is a string" + } + + set data "" + while {![eof $chan]} { + if {[gets $chan line] < 0} {continue} + + # Why skip empty lines? They may be in data. Except if the + # buffer is empty, i.e. we are between records. + if {$line == {} && $data == {}} {continue} + + append data $line + if {![iscomplete $data]} { + # Odd number of quotes - must have embedded newline + append data \n + continue + } + + Split2matrix $alternate $m $data $sepChar $expand + set data "" + } + return +} + +# ::csv::read2queue -- +# +# A wrapper around "::csv::split2queue" reading CSV formatted +# lines from the specified channel and adding it to the given +# queue. +# +# Arguments: +# q The queue to add the read data too. +# chan The channel to read from. +# sepChar The separator character, defaults to comma +# +# Results: +# A list of the values in 'line'. + +proc ::csv::read2queue {args} { + # Argument syntax: + # + #2) chan q + #3) chan q sepChar + #3) -alternate chan q + #4) -alternate chan q sepChar + + set alternate 0 + set sepChar , + + switch -exact -- [llength $args] { + 2 { + foreach {chan q} $args break + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set chan $b + set q $c + } else { + set chan $a + set q $b + set sepChar $c + } + } + 4 { + foreach {a b c d} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? chan q ?separator?" + } + set alternate 1 + set chan $b + set q $c + set sepChar $d + } + 0 - 1 - + default { + return -code error "wrong#args: Should be ?-alternate? chan q ?separator?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character \"$sepChar\", is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character \"$sepChar\", is a string" + } + + set data "" + while {![eof $chan]} { + if {[gets $chan line] < 0} {continue} + + # Why skip empty lines? They may be in data. Except if the + # buffer is empty, i.e. we are between records. + if {$line == {} && $data == {}} {continue} + + append data $line + if {![iscomplete $data]} { + # Odd number of quotes - must have embedded newline + append data \n + continue + } + + $q put [Split $alternate $data $sepChar] + set data "" + } + return +} + +# ::csv::report -- +# +# A report command which can be used by the matrix methods +# "format-via" and "format2chan-via". For the latter this +# command delegates the work to "::csv::writematrix". "cmd" is +# expected to be either "printmatrix" or +# "printmatrix2channel". The channel argument, "chan", has to +# be present for the latter and must not be present for the first. +# +# Arguments: +# cmd Either 'printmatrix' or 'printmatrix2channel' +# matrix The matrix to format. +# args 0 (chan): The channel to write to +# +# Results: +# None for 'printmatrix2channel', else the CSV formatted string. + +proc ::csv::report {cmd matrix args} { + switch -exact -- $cmd { + printmatrix { + if {[llength $args] > 0} { + return -code error "wrong # args:\ + ::csv::report printmatrix matrix" + } + return [joinlist [$matrix get rect 0 0 end end]] + } + printmatrix2channel { + if {[llength $args] != 1} { + return -code error "wrong # args:\ + ::csv::report printmatrix2channel matrix chan" + } + writematrix $matrix [lindex $args 0] + return "" + } + default { + return -code error "Unknown method $cmd" + } + } +} + +# ::csv::split -- +# +# Split a string according to the rules for CSV processing. +# This assumes that the string contains a single line of CSVs +# +# Arguments: +# line The string to split +# sepChar The separator character, defaults to comma +# +# Results: +# A list of the values in 'line'. + +proc ::csv::split {args} { + # Argument syntax: + # + # (1) line + # (2) line sepChar + # (2) -alternate line + # (3) -alternate line sepChar + + # (3) line sepChar delChar + # (4) -alternate line sepChar delChar + + set alternate 0 + set sepChar , + set delChar \" + + switch -exact -- [llength $args] { + 1 { + set line [lindex $args 0] + } + 2 { + foreach {a b} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set line $b + } else { + set line $a + set sepChar $b + } + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set line $b + set sepChar $c + } else { + set line $a + set sepChar $b + set delChar $c + } + } + 4 { + foreach {a b c d} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? line ?separator? ?delimiter?" + } + set alternate 1 + set line $b + set sepChar $c + set delChar $d + } + 0 - + default { + return -code error "wrong#args: Should be ?-alternate? line ?separator? ?delimiter?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character ${delChar}$sepChar${delChar}, is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character ${delChar}$sepChar${delChar}, is a string" + } + + if {[string length $delChar] < 1} { + return -code error "illegal separator character \"$delChar\", is empty" + } elseif {[string length $delChar] > 1} { + return -code error "illegal separator character \"$delChar\", is a string" + } + + return [Split $alternate $line $sepChar $delChar] +} + +proc ::csv::Split {alternate line sepChar {delChar \"}} { + # Protect the sepchar from special interpretation by + # the regex calls below. + + set sepRE \\$sepChar + set delRE \\$delChar + + if {$alternate} { + # The alternate syntax requires a different parser. + # A variation of the string map / regsub parser for the + # regular syntax was tried but does not handle embedded + # doubled " well (testcase csv-91.3 was 'knownBug', sole + # one, still a bug). Now we just tokenize the input into + # the primary parts (sep char, "'s and the rest) and then + # use an explicitly coded state machine (DFA) to parse + # and convert token sequences. + + ## puts 1->>$line<< + set line [string map [list \ + $sepChar \0$sepChar\0 \ + $delChar \0${delChar}\0 \ + ] $line] + + ## puts 2->>$line<< + set line [string map [list \0\0 \0] $line] + regsub "^\0" $line {} line + regsub "\0$" $line {} line + + ## puts 3->>$line<< + + set val "" + set res "" + set state base + + ## puts 4->>[::split $line \0] + foreach token [::split $line \0] { + + ## puts "\t*= $state\t>>$token<<" + switch -exact -- $state { + base { + if {[string equal $token "${delChar}"]} { + set state qvalue + continue + } + if {[string equal $token $sepChar]} { + lappend res $val + set val "" + continue + } + append val $token + } + qvalue { + if {[string equal $token "${delChar}"]} { + # May end value, may be a doubled " + set state endordouble + continue + } + append val $token + } + endordouble { + if {[string equal $token "${delChar}"]} { + # Doubled ", append to current value + append val ${delChar} + set state qvalue + continue + } + # Last " was end of quoted value. Close it. + # We expect current as $sepChar + + lappend res $val + set val "" + set state base + + if {[string equal $token $sepChar]} {continue} + + # Undoubled " in middle of text. Just assume that + # remainder is another qvalue. + set state qvalue + } + default { + return -code error "Internal error, illegal parsing state" + } + } + } + + ## puts "/= $state\t>>$val<<" + + lappend res $val + + ## puts 5->>$res<< + return $res + } else { + regsub -- "$sepRE${delRE}${delRE}$" $line $sepChar\0${delChar}${delChar}\0 line + regsub -- "^${delRE}${delRE}$sepRE" $line \0${delChar}${delChar}\0$sepChar line + regsub -all -- {(^${delChar}|${delChar}$)} $line \0 line + + set line [string map [list \ + $sepChar${delChar}${delChar}${delChar} $sepChar\0${delChar} \ + ${delChar}${delChar}${delChar}$sepChar ${delChar}\0$sepChar \ + ${delChar}${delChar} ${delChar} \ + ${delChar} \0 \ + ] $line] + + set end 0 + while {[regexp -indices -start $end -- {(\0)[^\0]*(\0)} $line \ + -> start end]} { + set start [lindex $start 0] + set end [lindex $end 0] + set range [string range $line $start $end] + if {[string first $sepChar $range] >= 0} { + set line [string replace $line $start $end \ + [string map [list $sepChar \1] $range]] + } + incr end + } + set line [string map [list $sepChar \0 \1 $sepChar \0 {} ] $line] + return [::split $line \0] + + } +} + +# ::csv::split2matrix -- +# +# Split a string according to the rules for CSV processing. +# This assumes that the string contains a single line of CSVs. +# The resulting list of values is appended to the specified +# matrix, as a new row. The code assumes that the matrix provides +# the same interface as the queue provided by the 'struct' +# module of tcllib, "add row" in particular. +# +# Arguments: +# m The matrix to write the resulting list to. +# line The string to split +# sepChar The separator character, defaults to comma +# expand The expansion mode. The default is none +# +# Results: +# A list of the values in 'line', written to 'q'. + +proc ::csv::split2matrix {args} { + # FR #481023 + + # Argument syntax: + # + #2) m line + #3) m line sepChar + #3) -alternate m line + #4) -alternate m line sepChar + #4) m line sepChar expand + #5) -alternate m line sepChar expand + + set alternate 0 + set sepChar , + set expand none + + switch -exact -- [llength $args] { + 2 { + foreach {m line} $args break + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set m $b + set line $c + } else { + set m $a + set line $b + set sepChar $c + } + } + 4 { + foreach {a b c d} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set m $b + set line $c + set sepChar $d + } else { + set m $a + set line $b + set sepChar $c + set expand $d + } + } + 4 { + foreach {a b c d e} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? m line ?separator? ?expand?" + } + set alternate 1 + + set m $b + set line $c + set sepChar $d + set expand $e + } + 0 - 1 - + default { + return -code error "wrong#args: Should be ?-alternate? m line ?separator? ?expand?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character \"$sepChar\", is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character \"$sepChar\", is a string" + } + + Split2matrix $alternate $m $line $sepChar $expand + return +} + +proc ::csv::Split2matrix {alternate m line sepChar expand} { + set csv [Split $alternate $line $sepChar] + + # Expansion modes + # - none : default, behaviour of original implementation. + # no expansion is done, lines are silently truncated + # to the number of columns in the matrix. + # + # - empty : A matrix without columns is expanded to the number + # of columns in the first line added to it. All + # following lines are handled as if "mode == none" + # was set. + # + # - auto : Full auto-mode. The matrix is expanded as needed to + # hold all columns of all lines. + + switch -exact -- $expand { + none {} + empty { + if {[$m columns] == 0} { + $m add columns [llength $csv] + } + } + auto { + if {[$m columns] < [llength $csv]} { + $m add columns [expr {[llength $csv] - [$m columns]}] + } + } + } + $m add row $csv + return +} + +# ::csv::split2queue -- +# +# Split a string according to the rules for CSV processing. +# This assumes that the string contains a single line of CSVs. +# The resulting list of values is appended to the specified +# queue, as a single item. IOW each item in the queue represents +# a single CSV record. The code assumes that the queue provides +# the same interface as the queue provided by the 'struct' +# module of tcllib, "put" in particular. +# +# Arguments: +# q The queue to write the resulting list to. +# line The string to split +# sepChar The separator character, defaults to comma +# +# Results: +# A list of the values in 'line', written to 'q'. + +proc ::csv::split2queue {args} { + # Argument syntax: + # + #2) q line + #3) q line sepChar + #3) -alternate q line + #4) -alternate q line sepChar + + set alternate 0 + set sepChar , + + switch -exact -- [llength $args] { + 2 { + foreach {q line} $args break + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set q $b + set line $c + } else { + set q $a + set line $b + set sepChar $c + } + } + 4 { + foreach {a b c d} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? q line ?separator?" + } + set alternate 1 + + set q $b + set line $c + set sepChar $d + } + 0 - 1 - + default { + return -code error "wrong#args: Should be ?-alternate? q line ?separator?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character \"$sepChar\", is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character \"$sepChar\", is a string" + } + + $q put [Split $alternate $line $sepChar] + return +} + +# ::csv::writematrix -- +# +# A wrapper around "::csv::join" taking the rows in a matrix and +# writing them as CSV formatted lines into the channel. +# +# Arguments: +# m The matrix to take the data to write from. +# chan The channel to write into. +# sepChar The separator character, defaults to comma +# +# Results: +# None. + +proc ::csv::writematrix {m chan {sepChar ,} {delChar \"}} { + set n [$m rows] + for {set r 0} {$r < $n} {incr r} { + puts $chan [join [$m get row $r] $sepChar $delChar] + } + + # Memory intensive alternative: + # puts $chan [joinlist [m get rect 0 0 end end] $sepChar $delChar] + return +} + +# ::csv::writequeue -- +# +# A wrapper around "::csv::join" taking the rows in a queue and +# writing them as CSV formatted lines into the channel. +# +# Arguments: +# q The queue to take the data to write from. +# chan The channel to write into. +# sepChar The separator character, defaults to comma +# +# Results: +# None. + +proc ::csv::writequeue {q chan {sepChar ,} {delChar \"}} { + while {[$q size] > 0} { + puts $chan [join [$q get] $sepChar $delChar] + } + + # Memory intensive alternative: + # puts $chan [joinlist [$q get [$q size]] $sepChar $delChar] + return +} + ADDED components/package-maker/lib/csv0.7.2/pkgIndex.tcl Index: components/package-maker/lib/csv0.7.2/pkgIndex.tcl ================================================================== --- /dev/null +++ components/package-maker/lib/csv0.7.2/pkgIndex.tcl @@ -0,0 +1,1 @@ +package ifneeded csv 0.7.2 [list source [file join $dir csv.tcl]] ADDED components/package-maker/lib/md52.0.7/md5.tcl Index: components/package-maker/lib/md52.0.7/md5.tcl ================================================================== --- /dev/null +++ components/package-maker/lib/md52.0.7/md5.tcl @@ -0,0 +1,749 @@ +# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*- +# -- Tcl Module + +# @@ Meta Begin +# Package md5 2.0.7 +# Meta as::build::date 2010-02-25 +# Meta as::origin http://sourceforge.net/projects/tcllib +# Meta category MD5 Message-Digest Algorithm +# Meta description MD5 Message-Digest Algorithm +# Meta license BSD +# Meta platform tcl +# Meta recommend Trf +# Meta recommend tcllibc +# Meta require {Tcl 8.2} +# Meta subject security {rfc 1320} {rfc 2104} {rfc 1321} +# Meta subject message-digest hashing md5 +# Meta summary md5 +# @@ Meta End + + +# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS + +package require Tcl 8.2 + +# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS + +# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE + +package provide md5 2.0.7 + +# ACTIVESTATE TEAPOT-PKG END DECLARE +# ACTIVESTATE TEAPOT-PKG END TM +# md5.tcl - Copyright (C) 2003 Pat Thoyts +# +# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm" +# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" +# +# This is an implementation of MD5 based upon the example code given in +# RFC 1321 and upon the tcllib MD4 implementation and taking some ideas +# from the earlier tcllib md5 version by Don Libes. +# +# This implementation permits incremental updating of the hash and +# provides support for external compiled implementations either using +# critcl (md5c) or Trf. +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# +# $Id: md5x.tcl,v 1.19 2008/07/04 18:27:00 andreas_kupries Exp $ + +package require Tcl 8.2; # tcl minimum version + +namespace eval ::md5 { + variable version 2.0.7 + variable rcsid {$Id: md5x.tcl,v 1.19 2008/07/04 18:27:00 andreas_kupries Exp $} + variable accel + array set accel {critcl 0 cryptkit 0 trf 0} + + namespace export md5 hmac MD5Init MD5Update MD5Final + + variable uid + if {![info exists uid]} { + set uid 0 + } +} + +# ------------------------------------------------------------------------- + +# MD5Init -- +# +# Create and initialize an MD5 state variable. This will be +# cleaned up when we call MD5Final +# +proc ::md5::MD5Init {} { + variable accel + variable uid + set token [namespace current]::[incr uid] + upvar #0 $token state + + # RFC1321:3.3 - Initialize MD5 state structure + array set state \ + [list \ + A [expr {0x67452301}] \ + B [expr {0xefcdab89}] \ + C [expr {0x98badcfe}] \ + D [expr {0x10325476}] \ + n 0 i "" ] + if {$accel(cryptkit)} { + cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD5 + } elseif {$accel(trf)} { + set s {} + switch -exact -- $::tcl_platform(platform) { + windows { set s [open NUL w] } + unix { set s [open /dev/null w] } + } + if {$s != {}} { + fconfigure $s -translation binary -buffering none + ::md5 -attach $s -mode write \ + -read-type variable \ + -read-destination [subst $token](trfread) \ + -write-type variable \ + -write-destination [subst $token](trfwrite) + array set state [list trfread 0 trfwrite 0 trf $s] + } + } + return $token +} + +# MD5Update -- +# +# This is called to add more data into the hash. You may call this +# as many times as you require. Note that passing in "ABC" is equivalent +# to passing these letters in as separate calls -- hence this proc +# permits hashing of chunked data +# +# If we have a C-based implementation available, then we will use +# it here in preference to the pure-Tcl implementation. +# +proc ::md5::MD5Update {token data} { + variable accel + upvar #0 $token state + + if {$accel(critcl)} { + if {[info exists state(md5c)]} { + set state(md5c) [md5c $data $state(md5c)] + } else { + set state(md5c) [md5c $data] + } + return + } elseif {[info exists state(ckctx)]} { + if {[string length $data] > 0} { + cryptkit::cryptEncrypt $state(ckctx) $data + } + return + } elseif {[info exists state(trf)]} { + puts -nonewline $state(trf) $data + return + } + + # Update the state values + incr state(n) [string length $data] + append state(i) $data + + # Calculate the hash for any complete blocks + set len [string length $state(i)] + for {set n 0} {($n + 64) <= $len} {} { + MD5Hash $token [string range $state(i) $n [incr n 64]] + } + + # Adjust the state for the blocks completed. + set state(i) [string range $state(i) $n end] + return +} + +# MD5Final -- +# +# This procedure is used to close the current hash and returns the +# hash data. Once this procedure has been called the hash context +# is freed and cannot be used again. +# +# Note that the output is 128 bits represented as binary data. +# +proc ::md5::MD5Final {token} { + upvar #0 $token state + + # Check for either of the C-compiled versions. + if {[info exists state(md5c)]} { + set r $state(md5c) + unset state + return $r + } elseif {[info exists state(ckctx)]} { + cryptkit::cryptEncrypt $state(ckctx) "" + cryptkit::cryptGetAttributeString $state(ckctx) \ + CRYPT_CTXINFO_HASHVALUE r 16 + cryptkit::cryptDestroyContext $state(ckctx) + # If nothing was hashed, we get no r variable set! + if {[info exists r]} { + unset state + return $r + } + } elseif {[info exists state(trf)]} { + close $state(trf) + set r $state(trfwrite) + unset state + return $r + } + + # RFC1321:3.1 - Padding + # + set len [string length $state(i)] + set pad [expr {56 - ($len % 64)}] + if {$len % 64 > 56} { + incr pad 64 + } + if {$pad == 0} { + incr pad 64 + } + 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] + + # 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]] + } + + # RFC1321:3.5 - Output + set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)] + unset state + return $r +} + +# ------------------------------------------------------------------------- +# HMAC Hashed Message Authentication (RFC 2104) +# +# hmac = H(K xor opad, H(K xor ipad, text)) +# + +# HMACInit -- +# +# This is equivalent to the MD5Init procedure except that a key is +# added into the algorithm +# +proc ::md5::HMACInit {K} { + + # Key K is adjusted to be 64 bytes long. If K is larger, then use + # the MD5 digest of K and pad this instead. + set len [string length $K] + if {$len > 64} { + set tok [MD5Init] + MD5Update $tok $K + set K [MD5Final $tok] + set len [string length $K] + } + set pad [expr {64 - $len}] + append K [string repeat \0 $pad] + + # Cacluate the padding buffers. + set Ki {} + set Ko {} + binary scan $K i16 Ks + foreach k $Ks { + append Ki [binary format i [expr {$k ^ 0x36363636}]] + append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]] + } + + set tok [MD5Init] + MD5Update $tok $Ki; # initialize with the inner pad + + # preserve the Ko value for the final stage. + # FRINK: nocheck + set [subst $tok](Ko) $Ko + + return $tok +} + +# HMACUpdate -- +# +# Identical to calling MD5Update +# +proc ::md5::HMACUpdate {token data} { + MD5Update $token $data + return +} + +# HMACFinal -- +# +# This is equivalent to the MD5Final procedure. The hash context is +# closed and the binary representation of the hash result is returned. +# +proc ::md5::HMACFinal {token} { + upvar #0 $token state + + set tok [MD5Init]; # init the outer hashing function + MD5Update $tok $state(Ko); # prepare with the outer pad. + MD5Update $tok [MD5Final $token]; # hash the inner result + return [MD5Final $tok] +} + +# ------------------------------------------------------------------------- +# Description: +# This is the core MD5 algorithm. It is a lot like the MD4 algorithm but +# includes an extra round and a set of constant modifiers throughout. +# +# 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 + + # 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 { + 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 + # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s). + # Do the following 16 operations. + # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4] + set A [expr {$B + (($A + [F $B $C $D] + $X0 + $T01) <<< 7)}] + set D [expr {$A + (($D + [F $A $B $C] + $X1 + $T02) <<< 12)}] + set C [expr {$D + (($C + [F $D $A $B] + $X2 + $T03) <<< 17)}] + set B [expr {$C + (($B + [F $C $D $A] + $X3 + $T04) <<< 22)}] + # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8] + set A [expr {$B + (($A + [F $B $C $D] + $X4 + $T05) <<< 7)}] + set D [expr {$A + (($D + [F $A $B $C] + $X5 + $T06) <<< 12)}] + set C [expr {$D + (($C + [F $D $A $B] + $X6 + $T07) <<< 17)}] + set B [expr {$C + (($B + [F $C $D $A] + $X7 + $T08) <<< 22)}] + # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12] + set A [expr {$B + (($A + [F $B $C $D] + $X8 + $T09) <<< 7)}] + set D [expr {$A + (($D + [F $A $B $C] + $X9 + $T10) <<< 12)}] + set C [expr {$D + (($C + [F $D $A $B] + $X10 + $T11) <<< 17)}] + set B [expr {$C + (($B + [F $C $D $A] + $X11 + $T12) <<< 22)}] + # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16] + set A [expr {$B + (($A + [F $B $C $D] + $X12 + $T13) <<< 7)}] + set D [expr {$A + (($D + [F $A $B $C] + $X13 + $T14) <<< 12)}] + set C [expr {$D + (($C + [F $D $A $B] + $X14 + $T15) <<< 17)}] + set B [expr {$C + (($B + [F $C $D $A] + $X15 + $T16) <<< 22)}] + + # Round 2. + # Let [abcd k s i] denote the operation + # a = b + ((a + G(b,c,d) + X[k] + Ti) <<< s) + # Do the following 16 operations. + # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20] + set A [expr {$B + (($A + [G $B $C $D] + $X1 + $T17) <<< 5)}] + set D [expr {$A + (($D + [G $A $B $C] + $X6 + $T18) <<< 9)}] + set C [expr {$D + (($C + [G $D $A $B] + $X11 + $T19) <<< 14)}] + set B [expr {$C + (($B + [G $C $D $A] + $X0 + $T20) <<< 20)}] + # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24] + set A [expr {$B + (($A + [G $B $C $D] + $X5 + $T21) <<< 5)}] + set D [expr {$A + (($D + [G $A $B $C] + $X10 + $T22) <<< 9)}] + set C [expr {$D + (($C + [G $D $A $B] + $X15 + $T23) <<< 14)}] + set B [expr {$C + (($B + [G $C $D $A] + $X4 + $T24) <<< 20)}] + # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28] + set A [expr {$B + (($A + [G $B $C $D] + $X9 + $T25) <<< 5)}] + set D [expr {$A + (($D + [G $A $B $C] + $X14 + $T26) <<< 9)}] + set C [expr {$D + (($C + [G $D $A $B] + $X3 + $T27) <<< 14)}] + set B [expr {$C + (($B + [G $C $D $A] + $X8 + $T28) <<< 20)}] + # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32] + set A [expr {$B + (($A + [G $B $C $D] + $X13 + $T29) <<< 5)}] + set D [expr {$A + (($D + [G $A $B $C] + $X2 + $T30) <<< 9)}] + set C [expr {$D + (($C + [G $D $A $B] + $X7 + $T31) <<< 14)}] + set B [expr {$C + (($B + [G $C $D $A] + $X12 + $T32) <<< 20)}] + + # Round 3. + # Let [abcd k s i] denote the operation + # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s) + # Do the following 16 operations. + # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36] + set A [expr {$B + (($A + [H $B $C $D] + $X5 + $T33) <<< 4)}] + set D [expr {$A + (($D + [H $A $B $C] + $X8 + $T34) <<< 11)}] + set C [expr {$D + (($C + [H $D $A $B] + $X11 + $T35) <<< 16)}] + set B [expr {$C + (($B + [H $C $D $A] + $X14 + $T36) <<< 23)}] + # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40] + set A [expr {$B + (($A + [H $B $C $D] + $X1 + $T37) <<< 4)}] + set D [expr {$A + (($D + [H $A $B $C] + $X4 + $T38) <<< 11)}] + set C [expr {$D + (($C + [H $D $A $B] + $X7 + $T39) <<< 16)}] + set B [expr {$C + (($B + [H $C $D $A] + $X10 + $T40) <<< 23)}] + # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44] + set A [expr {$B + (($A + [H $B $C $D] + $X13 + $T41) <<< 4)}] + set D [expr {$A + (($D + [H $A $B $C] + $X0 + $T42) <<< 11)}] + set C [expr {$D + (($C + [H $D $A $B] + $X3 + $T43) <<< 16)}] + set B [expr {$C + (($B + [H $C $D $A] + $X6 + $T44) <<< 23)}] + # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48] + set A [expr {$B + (($A + [H $B $C $D] + $X9 + $T45) <<< 4)}] + set D [expr {$A + (($D + [H $A $B $C] + $X12 + $T46) <<< 11)}] + set C [expr {$D + (($C + [H $D $A $B] + $X15 + $T47) <<< 16)}] + set B [expr {$C + (($B + [H $C $D $A] + $X2 + $T48) <<< 23)}] + + # Round 4. + # Let [abcd k s i] denote the operation + # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s) + # Do the following 16 operations. + # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52] + set A [expr {$B + (($A + [I $B $C $D] + $X0 + $T49) <<< 6)}] + set D [expr {$A + (($D + [I $A $B $C] + $X7 + $T50) <<< 10)}] + set C [expr {$D + (($C + [I $D $A $B] + $X14 + $T51) <<< 15)}] + set B [expr {$C + (($B + [I $C $D $A] + $X5 + $T52) <<< 21)}] + # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56] + set A [expr {$B + (($A + [I $B $C $D] + $X12 + $T53) <<< 6)}] + set D [expr {$A + (($D + [I $A $B $C] + $X3 + $T54) <<< 10)}] + set C [expr {$D + (($C + [I $D $A $B] + $X10 + $T55) <<< 15)}] + set B [expr {$C + (($B + [I $C $D $A] + $X1 + $T56) <<< 21)}] + # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60] + set A [expr {$B + (($A + [I $B $C $D] + $X8 + $T57) <<< 6)}] + set D [expr {$A + (($D + [I $A $B $C] + $X15 + $T58) <<< 10)}] + set C [expr {$D + (($C + [I $D $A $B] + $X6 + $T59) <<< 15)}] + set B [expr {$C + (($B + [I $C $D $A] + $X13 + $T60) <<< 21)}] + # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64] + set A [expr {$B + (($A + [I $B $C $D] + $X4 + $T61) <<< 6)}] + set D [expr {$A + (($D + [I $A $B $C] + $X11 + $T62) <<< 10)}] + set C [expr {$D + (($C + [I $D $A $B] + $X2 + $T63) <<< 15)}] + set B [expr {$C + (($B + [I $C $D $A] + $X9 + $T64) <<< 21)}] + + # Then perform the following additions. (That is, increment each + # of the four registers by the value it had before this block + # was started.) + incr state(A) $A + incr state(B) $B + incr state(C) $C + incr state(D) $D + } + + return +} + +proc ::md5::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} +proc ::md5::bytes {v} { + #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] + format %c%c%c%c \ + [expr {0xFF & $v}] \ + [expr {(0xFF00 & $v) >> 8}] \ + [expr {(0xFF0000 & $v) >> 16}] \ + [expr {((0xFF000000 & $v) >> 24) & 0xFF}] +} + +# 32bit rotate-left +proc ::md5::<<< {v n} { + return [expr {((($v << $n) \ + | (($v >> (32 - $n)) \ + & (0x7FFFFFFF >> (31 - $n))))) \ + & 0xFFFFFFFF}] +} + +# Convert our <<< pseudo-operator into a procedure call. +regsub -all -line \ + {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \ + $::md5::MD5Hash_body \ + {[expr {int(\1 + [<<< [expr {\2}] \3])}]} \ + ::md5::MD5Hash_body + +# RFC1321:3.4 - function F +proc ::md5::F {X Y Z} { + return [expr {($X & $Y) | ((~$X) & $Z)}] +} + +# Inline the F function +regsub -all -line \ + {\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ + $::md5::MD5Hash_body \ + {( (\1 \& \2) | ((~\1) \& \3) )} \ + ::md5::MD5Hash_body + +# RFC1321:3.4 - function G +proc ::md5::G {X Y Z} { + return [expr {(($X & $Z) | ($Y & (~$Z)))}] +} + +# Inline the G function +regsub -all -line \ + {\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ + $::md5::MD5Hash_body \ + {(((\1 \& \3) | (\2 \& (~\3))))} \ + ::md5::MD5Hash_body + +# RFC1321:3.4 - function H +proc ::md5::H {X Y Z} { + return [expr {$X ^ $Y ^ $Z}] +} + +# Inline the H function +regsub -all -line \ + {\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ + $::md5::MD5Hash_body \ + {(\1 ^ \2 ^ \3)} \ + ::md5::MD5Hash_body + +# RFC1321:3.4 - function I +proc ::md5::I {X Y Z} { + return [expr {$Y ^ ($X | (~$Z))}] +} + +# Inline the I function +regsub -all -line \ + {\[I (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ + $::md5::MD5Hash_body \ + {(\2 ^ (\1 | (~\3)))} \ + ::md5::MD5Hash_body + + +# RFC 1321:3.4 step 4: inline the set of constant modifiers. +namespace eval md5 { + foreach tName { + T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 + T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 + T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 + T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 + T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 + T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 + T61 T62 T63 T64 + } tVal { + 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee + 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501 + 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be + 0x6b901122 0xfd987193 0xa679438e 0x49b40821 + + 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa + 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8 + 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed + 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a + + 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c + 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70 + 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05 + 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665 + + 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039 + 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1 + 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1 + 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391 + } { + lappend map \$$tName $tVal + } + set ::md5::MD5Hash_body [string map $map $::md5::MD5Hash_body] + unset map tName tVal +} + +# Define the MD5 hashing procedure with inline functions. +proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_body +unset ::md5::MD5Hash_body + +# ------------------------------------------------------------------------- + +if {[package provide Trf] != {}} { + interp alias {} ::md5::Hex {} ::hex -mode encode -- +} else { + proc ::md5::Hex {data} { + binary scan $data H* result + return [string toupper $result] + } +} + +# ------------------------------------------------------------------------- + +# LoadAccelerator -- +# +# This package can make use of a number of compiled extensions to +# accelerate the digest computation. This procedure manages the +# use of these extensions within the package. During normal usage +# this should not be called, but the test package manipulates the +# list of enabled accelerators. +# +proc ::md5::LoadAccelerator {name} { + variable accel + set r 0 + switch -exact -- $name { + critcl { + if {![catch {package require tcllibc}] + || ![catch {package require md5c}]} { + set r [expr {[info command ::md5::md5c] != {}}] + } + } + cryptkit { + if {![catch {package require cryptkit}]} { + set r [expr {![catch {cryptkit::cryptInit}]}] + } + } + trf { + if {![catch {package require Trf}]} { + set r [expr {![catch {::md5 aa} msg]}] + } + } + default { + return -code error "invalid accelerator package:\ + must be one of [join [array names accel] {, }]" + } + } + set accel($name) $r +} + +# ------------------------------------------------------------------------- + +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::md5::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- + +# fileevent handler for chunked file hashing. +# +proc ::md5::Chunk {token channel {chunksize 4096}} { + upvar #0 $token state + + if {[eof $channel]} { + fileevent $channel readable {} + set state(reading) 0 + } + + MD5Update $token [read $channel $chunksize] +} + +# ------------------------------------------------------------------------- + +proc ::md5::md5 {args} { + array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} + while {[string match -* [set option [lindex $args 0]]]} { + switch -glob -- $option { + -hex { set opts(-hex) 1 } + -file* { set opts(-filename) [Pop args 1] } + -channel { set opts(-channel) [Pop args 1] } + -chunksize { set opts(-chunksize) [Pop args 1] } + default { + if {[llength $args] == 1} { break } + if {[string compare $option "--"] == 0} { Pop args; break } + set err [join [lsort [array names opts]] ", "] + return -code error "bad option $option:\ + must be one of $err\nlen: [llength $args]" + } + } + Pop args + } + + 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 \"md5 ?-hex? -filename file | string\"" + } + set tok [MD5Init] + MD5Update $tok [lindex $args 0] + set r [MD5Final $tok] + + } else { + + set tok [MD5Init] + # FRINK: nocheck + set [subst $tok](reading) 1 + fileevent $opts(-channel) readable \ + [list [namespace origin Chunk] \ + $tok $opts(-channel) $opts(-chunksize)] + vwait [subst $tok](reading) + set r [MD5Final $tok] + + # If we opened the channel - we should close it too. + if {$opts(-filename) != {}} { + close $opts(-channel) + } + } + + if {$opts(-hex)} { + set r [Hex $r] + } + return $r +} + +# ------------------------------------------------------------------------- + +proc ::md5::hmac {args} { + array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} + while {[string match -* [set option [lindex $args 0]]]} { + switch -glob -- $option { + -key { set opts(-key) [Pop args 1] } + -hex { set opts(-hex) 1 } + -file* { set opts(-filename) [Pop args 1] } + -channel { set opts(-channel) [Pop args 1] } + -chunksize { set opts(-chunksize) [Pop args 1] } + default { + if {[llength $args] == 1} { break } + if {[string compare $option "--"] == 0} { Pop args; break } + set err [join [lsort [array names opts]] ", "] + return -code error "bad option $option:\ + must be one of $err" + } + } + Pop args + } + + if {![info exists opts(-key)]} { + return -code error "wrong # args:\ + should be \"hmac ?-hex? -key key -filename file | string\"" + } + + 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 \"hmac ?-hex? -key key -filename file | string\"" + } + set tok [HMACInit $opts(-key)] + HMACUpdate $tok [lindex $args 0] + set r [HMACFinal $tok] + + } else { + + set tok [HMACInit $opts(-key)] + # FRINK: nocheck + set [subst $tok](reading) 1 + fileevent $opts(-channel) readable \ + [list [namespace origin Chunk] \ + $tok $opts(-channel) $opts(-chunksize)] + vwait [subst $tok](reading) + set r [HMACFinal $tok] + + # If we opened the channel - we should close it too. + if {$opts(-filename) != {}} { + close $opts(-channel) + } + } + + if {$opts(-hex)} { + set r [Hex $r] + } + return $r +} + +# ------------------------------------------------------------------------- + +# Try and load a compiled extension to help. +namespace eval ::md5 { + variable e + foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } } + unset e +} + +package provide md5 $::md5::version + +# ------------------------------------------------------------------------- +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + + ADDED components/package-maker/lib/md52.0.7/pkgIndex.tcl Index: components/package-maker/lib/md52.0.7/pkgIndex.tcl ================================================================== --- /dev/null +++ components/package-maker/lib/md52.0.7/pkgIndex.tcl @@ -0,0 +1,1 @@ +package ifneeded md5 2.0.7 [list source [file join $dir md5.tcl]] ADDED components/package-maker/lib/sha12.0.3/pkgIndex.tcl Index: components/package-maker/lib/sha12.0.3/pkgIndex.tcl ================================================================== --- /dev/null +++ components/package-maker/lib/sha12.0.3/pkgIndex.tcl @@ -0,0 +1,1 @@ +package ifneeded sha1 2.0.3 [list source [file join $dir sha1.tcl]] ADDED components/package-maker/lib/sha12.0.3/sha1.tcl Index: components/package-maker/lib/sha12.0.3/sha1.tcl ================================================================== --- /dev/null +++ components/package-maker/lib/sha12.0.3/sha1.tcl @@ -0,0 +1,850 @@ +# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*- +# -- Tcl Module + +# @@ Meta Begin +# Package sha1 2.0.3 +# Meta as::build::date 2010-12-10 +# Meta as::origin http://sourceforge.net/projects/tcllib +# Meta category SHA-x Message-Digest Algorithm +# Meta description SHA1 Message-Digest Algorithm +# Meta license BSD +# Meta platform tcl +# Meta recommend Trf +# Meta recommend tcllibc +# Meta require {Tcl 8.2} +# Meta subject security {FIPS 180-1} sha1 {rfc 2104} message-digest +# Meta subject hashing +# Meta summary sha1 +# @@ Meta End + + +# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS + +package require Tcl 8.2 + +# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS + +# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE + +package provide sha1 2.0.3 + +# ACTIVESTATE TEAPOT-PKG END DECLARE +# ACTIVESTATE TEAPOT-PKG END TM +# sha1.tcl - +# +# Copyright (C) 2001 Don Libes +# Copyright (C) 2003 Pat Thoyts +# +# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm" +# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" +# +# This is an implementation of SHA1 based upon the example code given in +# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas +# and methods from the earlier tcllib sha1 version by Don Libes. +# +# This implementation permits incremental updating of the hash and +# provides support for external compiled implementations either using +# critcl (sha1c) or Trf. +# +# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# +# $Id: sha1.tcl,v 1.22 2009/05/07 00:35:10 patthoyts Exp $ + +# @mdgen EXCLUDE: sha1c.tcl + +package require Tcl 8.2; # tcl minimum version + +namespace eval ::sha1 { + variable version 2.0.3 + variable rcsid {$Id: sha1.tcl,v 1.22 2009/05/07 00:35:10 patthoyts Exp $} + + variable accel + array set accel {tcl 0 critcl 0 cryptkit 0 trf 0} + variable loaded {} + variable active + array set active {tcl 0 critcl 0 cryptkit 0 trf 0} + + namespace export sha1 hmac SHA1Init SHA1Update SHA1Final + + variable uid + if {![info exists uid]} { + set uid 0 + } +} + +# ------------------------------------------------------------------------- +# Management of sha1 implementations. + +# LoadAccelerator -- +# +# This package can make use of a number of compiled extensions to +# accelerate the digest computation. This procedure manages the +# use of these extensions within the package. During normal usage +# this should not be called, but the test package manipulates the +# list of enabled accelerators. +# +proc ::sha1::LoadAccelerator {name} { + variable accel + set r 0 + switch -exact -- $name { + tcl { + # Already present (this file) + set r 1 + } + critcl { + if {![catch {package require tcllibc}] + || ![catch {package require sha1c}]} { + set r [expr {[info command ::sha1::sha1c] != {}}] + } + } + cryptkit { + if {![catch {package require cryptkit}]} { + set r [expr {![catch {cryptkit::cryptInit}]}] + } + } + trf { + if {![catch {package require Trf}]} { + set r [expr {![catch {::sha1 aa} msg]}] + } + } + default { + return -code error "invalid accelerator $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($name) $r + return $r +} + +# ::sha1::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::sha1::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::sha1::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::sha1::KnownImplementations {} { + return {critcl cryptkit trf tcl} +} + +proc ::sha1::Names {} { + return { + critcl {tcllibc based} + cryptkit {cryptkit based} + trf {Trf based} + tcl {pure Tcl} + } +} + +# ::sha1::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::sha1::SwitchTo {key} { + variable accel + variable active + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + if {![string equal $loaded ""]} { + set active($loaded) 0 + } + if {![string equal $key ""]} { + set active($key) 1 + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ------------------------------------------------------------------------- + +# SHA1Init -- +# +# Create and initialize an SHA1 state variable. This will be +# cleaned up when we call SHA1Final +# + +proc ::sha1::SHA1Init {} { + variable active + variable uid + set token [namespace current]::[incr uid] + upvar #0 $token state + + # FIPS 180-1: 7 - Initialize the hash state + array set state \ + [list \ + A [expr {int(0x67452301)}] \ + B [expr {int(0xEFCDAB89)}] \ + C [expr {int(0x98BADCFE)}] \ + D [expr {int(0x10325476)}] \ + E [expr {int(0xC3D2E1F0)}] \ + n 0 i "" ] + if {$active(cryptkit)} { + cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA + } elseif {$active(trf)} { + set s {} + switch -exact -- $::tcl_platform(platform) { + windows { set s [open NUL w] } + unix { set s [open /dev/null w] } + } + if {$s != {}} { + fconfigure $s -translation binary -buffering none + ::sha1 -attach $s -mode write \ + -read-type variable \ + -read-destination [subst $token](trfread) \ + -write-type variable \ + -write-destination [subst $token](trfwrite) + array set state [list trfread 0 trfwrite 0 trf $s] + } + } + return $token +} + +# SHA1Update -- +# +# This is called to add more data into the hash. You may call this +# as many times as you require. Note that passing in "ABC" is equivalent +# to passing these letters in as separate calls -- hence this proc +# permits hashing of chunked data +# +# If we have a C-based implementation available, then we will use +# it here in preference to the pure-Tcl implementation. +# +proc ::sha1::SHA1Update {token data} { + variable active + upvar #0 $token state + + if {$active(critcl)} { + if {[info exists state(sha1c)]} { + set state(sha1c) [sha1c $data $state(sha1c)] + } else { + set state(sha1c) [sha1c $data] + } + return + } elseif {[info exists state(ckctx)]} { + if {[string length $data] > 0} { + cryptkit::cryptEncrypt $state(ckctx) $data + } + return + } elseif {[info exists state(trf)]} { + puts -nonewline $state(trf) $data + return + } + + # Update the state values + incr state(n) [string length $data] + append state(i) $data + + # Calculate the hash for any complete blocks + set len [string length $state(i)] + for {set n 0} {($n + 64) <= $len} {} { + SHA1Transform $token [string range $state(i) $n [incr n 64]] + } + + # Adjust the state for the blocks completed. + set state(i) [string range $state(i) $n end] + return +} + +# SHA1Final -- +# +# This procedure is used to close the current hash and returns the +# hash data. Once this procedure has been called the hash context +# is freed and cannot be used again. +# +# Note that the output is 160 bits represented as binary data. +# +proc ::sha1::SHA1Final {token} { + upvar #0 $token state + + # Check for either of the C-compiled versions. + if {[info exists state(sha1c)]} { + set r $state(sha1c) + unset state + return $r + } elseif {[info exists state(ckctx)]} { + cryptkit::cryptEncrypt $state(ckctx) "" + cryptkit::cryptGetAttributeString $state(ckctx) \ + CRYPT_CTXINFO_HASHVALUE r 20 + cryptkit::cryptDestroyContext $state(ckctx) + # If nothing was hashed, we get no r variable set! + if {[info exists r]} { + unset state + return $r + } + } elseif {[info exists state(trf)]} { + close $state(trf) + set r $state(trfwrite) + unset state + return $r + } + + # Padding + # + set len [string length $state(i)] + set pad [expr {56 - ($len % 64)}] + if {$len % 64 > 56} { + incr pad 64 + } + if {$pad == 0} { + incr pad 64 + } + append state(i) [binary format a$pad \x80] + + # Append length in bits as big-endian wide int. + set dlen [expr {8 * $state(n)}] + append state(i) [binary format II 0 $dlen] + + # Calculate the hash for the remaining block. + set len [string length $state(i)] + for {set n 0} {($n + 64) <= $len} {} { + SHA1Transform $token [string range $state(i) $n [incr n 64]] + } + + # Output + set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)] + unset state + return $r +} + +# ------------------------------------------------------------------------- +# HMAC Hashed Message Authentication (RFC 2104) +# +# hmac = H(K xor opad, H(K xor ipad, text)) +# + +# HMACInit -- +# +# This is equivalent to the SHA1Init procedure except that a key is +# added into the algorithm +# +proc ::sha1::HMACInit {K} { + + # Key K is adjusted to be 64 bytes long. If K is larger, then use + # the SHA1 digest of K and pad this instead. + set len [string length $K] + if {$len > 64} { + set tok [SHA1Init] + SHA1Update $tok $K + set K [SHA1Final $tok] + set len [string length $K] + } + set pad [expr {64 - $len}] + append K [string repeat \0 $pad] + + # Cacluate the padding buffers. + set Ki {} + set Ko {} + binary scan $K i16 Ks + foreach k $Ks { + append Ki [binary format i [expr {$k ^ 0x36363636}]] + append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]] + } + + set tok [SHA1Init] + SHA1Update $tok $Ki; # initialize with the inner pad + + # preserve the Ko value for the final stage. + # FRINK: nocheck + set [subst $tok](Ko) $Ko + + return $tok +} + +# HMACUpdate -- +# +# Identical to calling SHA1Update +# +proc ::sha1::HMACUpdate {token data} { + SHA1Update $token $data + return +} + +# HMACFinal -- +# +# This is equivalent to the SHA1Final procedure. The hash context is +# closed and the binary representation of the hash result is returned. +# +proc ::sha1::HMACFinal {token} { + upvar #0 $token state + + set tok [SHA1Init]; # init the outer hashing function + SHA1Update $tok $state(Ko); # prepare with the outer pad. + SHA1Update $tok [SHA1Final $token]; # hash the inner result + return [SHA1Final $tok] +} + +# ------------------------------------------------------------------------- +# Description: +# This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but +# includes an extra round and a set of constant modifiers throughout. +# +set ::sha1::SHA1Transform_body { + upvar #0 $token state + + # FIPS 180-1: 7a: Process Message in 16-Word Blocks + binary scan $msg I* blocks + set blockLen [llength $blocks] + for {set i 0} {$i < $blockLen} {incr i 16} { + set W [lrange $blocks $i [expr {$i+15}]] + + # FIPS 180-1: 7b: Expand the input into 80 words + # For t = 16 to 79 + # let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1 + set t3 12 + set t8 7 + set t14 1 + set t16 -1 + for {set t 16} {$t < 80} {incr t} { + set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \ + [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}] + lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}] + } + + # FIPS 180-1: 7c: Copy hash state. + set A $state(A) + set B $state(B) + set C $state(C) + set D $state(D) + set E $state(E) + + # FIPS 180-1: 7d: Do permutation rounds + # For t = 0 to 79 do + # TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt; + # E = D; D = C; C = S30(B); B = A; A = TEMP; + + # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19) + for {set t 0} {$t < 20} {incr t} { + set TEMP [F1 $A $B $C $D $E [lindex $W $t]] + set E $D + set D $C + set C [rotl32 $B 30] + set B $A + set A $TEMP + } + + # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39) + for {} {$t < 40} {incr t} { + set TEMP [F2 $A $B $C $D $E [lindex $W $t]] + set E $D + set D $C + set C [rotl32 $B 30] + set B $A + set A $TEMP + } + + # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59) + for {} {$t < 60} {incr t} { + set TEMP [F3 $A $B $C $D $E [lindex $W $t]] + set E $D + set D $C + set C [rotl32 $B 30] + set B $A + set A $TEMP + } + + # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79) + for {} {$t < 80} {incr t} { + set TEMP [F4 $A $B $C $D $E [lindex $W $t]] + set E $D + set D $C + set C [rotl32 $B 30] + set B $A + set A $TEMP + } + + # Then perform the following additions. (That is, increment each + # of the four registers by the value it had before this block + # was started.) + incr state(A) $A + incr state(B) $B + incr state(C) $C + incr state(D) $D + incr state(E) $E + } + + return +} + +proc ::sha1::F1 {A B C D E W} { + expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ + + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff} +} + +proc ::sha1::F2 {A B C D E W} { + expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ + + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff} +} + +proc ::sha1::F3 {A B C D E W} { + expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ + + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff} +} + +proc ::sha1::F4 {A B C D E W} { + expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ + + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff} +} + +proc ::sha1::rotl32 {v n} { + return [expr {((($v << $n) \ + | (($v >> (32 - $n)) \ + & (0x7FFFFFFF >> (31 - $n))))) \ + & 0xFFFFFFFF}] +} + + +# ------------------------------------------------------------------------- +# +# In order to get this code to go as fast as possible while leaving +# the main code readable we can substitute the above function bodies +# into the transform procedure. This inlines the code for us an avoids +# a procedure call overhead within the loops. +# +# We can do some minor tweaking to improve speed on Tcl < 8.5 where we +# know our arithmetic is limited to 64 bits. On > 8.5 we may have +# unconstrained integer arithmetic and must avoid letting it run away. +# + +regsub -all -line \ + {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ + $::sha1::SHA1Transform_body \ + {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \ + ::sha1::SHA1Transform_body_tmp + +regsub -all -line \ + {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ + $::sha1::SHA1Transform_body_tmp \ + {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \ + ::sha1::SHA1Transform_body_tmp + +regsub -all -line \ + {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ + $::sha1::SHA1Transform_body_tmp \ + {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \ + ::sha1::SHA1Transform_body_tmp + +regsub -all -line \ + {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ + $::sha1::SHA1Transform_body_tmp \ + {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \ + ::sha1::SHA1Transform_body_tmp + +regsub -all -line \ + {rotl32\(\$A,5\)} \ + $::sha1::SHA1Transform_body_tmp \ + {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \ + ::sha1::SHA1Transform_body_tmp + +regsub -all -line \ + {\[rotl32 \$B 30\]} \ + $::sha1::SHA1Transform_body_tmp \ + {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \ + ::sha1::SHA1Transform_body_tmp +# +# Version 2 avoids a few truncations to 32 bits in non-essential places. +# +regsub -all -line \ + {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ + $::sha1::SHA1Transform_body \ + {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \ + ::sha1::SHA1Transform_body_tmp2 + +regsub -all -line \ + {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ + $::sha1::SHA1Transform_body_tmp2 \ + {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \ + ::sha1::SHA1Transform_body_tmp2 + +regsub -all -line \ + {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ + $::sha1::SHA1Transform_body_tmp2 \ + {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \ + ::sha1::SHA1Transform_body_tmp2 + +regsub -all -line \ + {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ + $::sha1::SHA1Transform_body_tmp2 \ + {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \ + ::sha1::SHA1Transform_body_tmp2 + +regsub -all -line \ + {rotl32\(\$A,5\)} \ + $::sha1::SHA1Transform_body_tmp2 \ + {(($A << 5) | (($A >> 27) \& 0x1f))} \ + ::sha1::SHA1Transform_body_tmp2 + +regsub -all -line \ + {\[rotl32 \$B 30\]} \ + $::sha1::SHA1Transform_body_tmp2 \ + {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \ + ::sha1::SHA1Transform_body_tmp2 + +if {[package vsatisfies [package provide Tcl] 8.5]} { + proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp +} else { + proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2 +} + +unset ::sha1::SHA1Transform_body +unset ::sha1::SHA1Transform_body_tmp +unset ::sha1::SHA1Transform_body_tmp2 + +# ------------------------------------------------------------------------- + +proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} +proc ::sha1::bytes {v} { + #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] + format %c%c%c%c \ + [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \ + [expr {(0xFF0000 & $v) >> 16}] \ + [expr {(0xFF00 & $v) >> 8}] \ + [expr {0xFF & $v}] +} + +# ------------------------------------------------------------------------- + +proc ::sha1::Hex {data} { + binary scan $data H* result + return $result +} + +# ------------------------------------------------------------------------- + +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::sha1::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- + +# fileevent handler for chunked file hashing. +# +proc ::sha1::Chunk {token channel {chunksize 4096}} { + upvar #0 $token state + + if {[eof $channel]} { + fileevent $channel readable {} + set state(reading) 0 + } + + SHA1Update $token [read $channel $chunksize] +} + +# ------------------------------------------------------------------------- + +proc ::sha1::sha1 {args} { + array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} + if {[llength $args] == 1} { + set opts(-hex) 1 + } else { + while {[string match -* [set option [lindex $args 0]]]} { + switch -glob -- $option { + -hex { set opts(-hex) 1 } + -bin { set opts(-hex) 0 } + -file* { set opts(-filename) [Pop args 1] } + -channel { set opts(-channel) [Pop args 1] } + -chunksize { set opts(-chunksize) [Pop args 1] } + default { + if {[llength $args] == 1} { break } + if {[string compare $option "--"] == 0} { Pop args; break } + set err [join [lsort [concat -bin [array names opts]]] ", "] + return -code error "bad option $option:\ + must be one of $err" + } + } + Pop args + } + } + + 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 \"sha1 ?-hex? -filename file | string\"" + } + set tok [SHA1Init] + SHA1Update $tok [lindex $args 0] + set r [SHA1Final $tok] + + } else { + + set tok [SHA1Init] + # FRINK: nocheck + set [subst $tok](reading) 1 + fileevent $opts(-channel) readable \ + [list [namespace origin Chunk] \ + $tok $opts(-channel) $opts(-chunksize)] + # FRINK: nocheck + vwait [subst $tok](reading) + set r [SHA1Final $tok] + + # If we opened the channel - we should close it too. + if {$opts(-filename) != {}} { + close $opts(-channel) + } + } + + if {$opts(-hex)} { + set r [Hex $r] + } + return $r +} + +# ------------------------------------------------------------------------- + +proc ::sha1::hmac {args} { + array set opts {-hex 1 -filename {} -channel {} -chunksize 4096} + if {[llength $args] != 2} { + while {[string match -* [set option [lindex $args 0]]]} { + switch -glob -- $option { + -key { set opts(-key) [Pop args 1] } + -hex { set opts(-hex) 1 } + -bin { set opts(-hex) 0 } + -file* { set opts(-filename) [Pop args 1] } + -channel { set opts(-channel) [Pop args 1] } + -chunksize { set opts(-chunksize) [Pop args 1] } + default { + if {[llength $args] == 1} { break } + if {[string compare $option "--"] == 0} { Pop args; break } + set err [join [lsort [array names opts]] ", "] + return -code error "bad option $option:\ + must be one of $err" + } + } + Pop args + } + } + + if {[llength $args] == 2} { + set opts(-key) [Pop args] + } + + if {![info exists opts(-key)]} { + return -code error "wrong # args:\ + should be \"hmac ?-hex? -key key -filename file | string\"" + } + + 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 \"hmac ?-hex? -key key -filename file | string\"" + } + set tok [HMACInit $opts(-key)] + HMACUpdate $tok [lindex $args 0] + set r [HMACFinal $tok] + + } else { + + set tok [HMACInit $opts(-key)] + # FRINK: nocheck + set [subst $tok](reading) 1 + fileevent $opts(-channel) readable \ + [list [namespace origin Chunk] \ + $tok $opts(-channel) $opts(-chunksize)] + # FRINK: nocheck + vwait [subst $tok](reading) + set r [HMACFinal $tok] + + # If we opened the channel - we should close it too. + if {$opts(-filename) != {}} { + close $opts(-channel) + } + } + + if {$opts(-hex)} { + set r [Hex $r] + } + return $r +} + +# ------------------------------------------------------------------------- + +# Try and load a compiled extension to help. +namespace eval ::sha1 { + variable e {} + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +package provide sha1 $::sha1::version + +# ------------------------------------------------------------------------- +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: ADDED components/package-maker/lib/tax0.2/pkgIndex.tcl Index: components/package-maker/lib/tax0.2/pkgIndex.tcl ================================================================== --- /dev/null +++ components/package-maker/lib/tax0.2/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded tax 0.2 [list source [file join $dir tax.tcl]] ADDED components/package-maker/lib/tax0.2/tax.tcl Index: components/package-maker/lib/tax0.2/tax.tcl ================================================================== --- /dev/null +++ components/package-maker/lib/tax0.2/tax.tcl @@ -0,0 +1,125 @@ +#! /usr/bin/env tclsh + +namespace eval ::tax {} + +# ::tax::__cleanprops -- Clean parsed XML properties +# +# This command cleans parsed XML properties by removing the +# trailing slash and replacing equals by spaces so as to produce +# a list that is suitable for an array set command. +# +# Arguments: +# props Parsed XML properties +# +# Results: +# Return an event list that is suitable for an array set +# +# Side Effects: +# None. +proc ::tax::__cleanprops { props } { + set name {([A-Za-z_:]|[^\x00-\x7F])([A-Za-z0-9_:.-]|[^\x00-\x7F])*} + set attval {"[^"]*"|'[^']*'|\w}; # "... Makes emacs happy + set ret [regsub -all -- "($name)\\s*=\\s*($attval)" \ + [regsub "/$" $props ""] "\\1 \\4"] + return $ret +} + +# ::tax::parse -- Low-level 10 lines magic parser +# +# This procedure is the core of the tiny XML parser and does its +# job in 10 lines of "hairy" code. The command will call the +# command passed as an argument for each XML tag that is found +# in the XML code passed as an argument. Error checking is less +# than minimum! The command will be called with the following +# respective arguments: name of the tag, boolean telling whether +# it is a closing tag or not, boolean telling whether it is a +# self-closing tag or not, list of property (array set-style) +# and body of tag, if available. +# +# Arguments: +# cmd Command to call for each tag found. +# xml String containing the XML to be parsed. +# start Name of the pseudo tag marking the beginning/ending of document +# +# Results: +# None. +# +# Side Effects: +# None. +proc ::tax::parse {cmd xml {start docstart}} { + # Convert CDATA sections to variable references to ensure that nothing + # modifies them along the way + set newxml "" + for {set idx 0} {1} {set idx $endidx} { + # Determine previous start index + set previdx $idx + + # Determine where CDATA section begins + set idx [string first {} $xml $idx] + if {$endidx == "-1"} { + set endidx [expr {[string length $xml] - 1}] + } + + # Determine where the the XML ends + set xmlendidx [expr {$idx - 1}] + + # Determine where the CDATA body begins + set idx [expr {$idx + 9}] + + # Determine where the CDATA body ends + set endidx [expr {$endidx - 1}] + + # Select the CDATA body from the XML + set data [string range $xml $idx $endidx] + + # Adjust the end index to include the end of the tag since it will be + # used for exclusion later + set endidx [expr {$endidx + 4}] + + # Store data associated with this start index + set key "@!@CDATA-${idx}@!@" + set cdata($key) $data + + # Remove the whole CDATA tag+body from the XML + append newxml [string range $xml $previdx $xmlendidx] + append newxml $key + } + + # Append the trailing data (if any) + append newxml [string range $xml $previdx end] + + # Put the redacted data back into place + set xml $newxml + unset newxml + + # Replace open and close braces with XML entities to prevent them from + # interfering with command formation + regsub -all \{ $xml {\&ob;} xml + regsub -all \} $xml {\&cb;} xml + + # Create regular expresion that matches tags and replaces them with valid + # Tcl commands + set exp {<(/?)([^\s/>]+)\s*([^>]*)>} + set sub "\}\n$cmd {\\2} \[expr \{{\\1} ne \"\"\}\] \[regexp \{/$\} {\\3}\] \ + \[::tax::__cleanprops \{\\3\}\] \{" + regsub -all $exp $xml $sub xml + + # Re-introduce CDATA sections into XML, which has been converted to a set + # of Tcl commands. This will fail if the CDATA contains unbalanced curly + # braces. + set xml [string map [array get cdata] $xml] + + # Evaluate generated commands + eval "$cmd {$start} 0 0 {} \{$xml\}" + + # Evaluate the document start close tag + eval "$cmd {$start} 1 0 {} {}" +} + +package provide tax 0.2 ADDED components/package-maker/pkginfo/glibc.xml Index: components/package-maker/pkginfo/glibc.xml ================================================================== --- /dev/null +++ components/package-maker/pkginfo/glibc.xml @@ -0,0 +1,33 @@ + + GNU C Library + + + + 2.16 + 9d4fffc9c4ac93e7919e124fa38bb51dcaff5216 + + + + http://ftp.gnu.org/gnu/glibc/glibc-$version.tar.xz + + + + + + +