Tcl Library Source Code

    return $s
}

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

# If the Trf package is available then we shall use this by default but the
# Tcllib implementations are always visible if needed (ie: for testing)
if {[info commands ::uuencode::CDecode] != {}} {    
    # tcllib critcl package
    interp alias {} ::uuencode::encode {} ::uuencode::CEncode
    interp alias {} ::uuencode::decode {} ::uuencode::CDecode
} elseif {[package provide Trf] != {}} {
    proc ::uuencode::encode {s} {
        return [::uuencode -mode encode -- $s]
    }

            Tcl_SetByteArrayLength(resultPtr, rlen);
            Tcl_SetObjResult(interp, resultPtr);
            return TCL_OK;
        }
    }
}

if {[info commands ::yencode::CEncode] != {}} {
    interp alias {} ::yencode::encode {} ::yencode::CEncode
    interp alias {} ::yencode::decode {} ::yencode::CDecode
} else {
    interp alias {} ::yencode::encode {} ::yencode::Encode
    interp alias {} ::yencode::decode {} ::yencode::Decode
}

proc ::crc::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        critcl {
            if {![catch {package require tcllibc}]
                || ![catch {package require crcc}]} {
                set r [expr {[info commands ::crc::Crc32_c] != {}}]
            }
        }
        trf {
            if {![catch {package require Trf}]} {
                set r [expr {![catch {::crc-zlib aa} msg]}]
            }
        }

        }
    }
}

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

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

# -------------------------------------------------------------------------
# Description:

testing {
    useLocal sum.tcl sum ::crc
}

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

if {[info commands ::crc::SumBsd_c] == {}} {
    puts "> pure tcl"
} else {    
    puts "> critcl based"
}

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

        } else {
            set prefix "+"
        }

        set cmd [string tolower [lindex [split $directive {:/=}] 0]]
        set param [string range $directive [string length $cmd] end]

        if {[info commands ::spf::_$cmd] == {}} {
            # 6.1 Unrecognised directives terminate processing
            #     but unknown modifiers are ignored.
            if {[string match "=*" $param]} {
                continue
            } else {
                set result unknown
                break

# -------------------------------------------------------------------------
#
# DNS helper procedures.
#
# -------------------------------------------------------------------------

proc ::spf::Resolve {domain type resultproc} {
    if {[info commands $resultproc] == {}} {
        return -code error "invalid arg: \"$resultproc\" must be a command"
    }
    set tok [dns::resolve $domain -type $type]
    dns::wait $tok
    set errorcode NONE
    if {[string equal [dns::status $tok] "ok"]} {
        set result [$resultproc $tok]

    if { $result == 0 } {
	ftp::Close $fdc
	return -code error "Cannot reach directory of url \"$url\""
    }

    # Fix for the tkcon List enhancements in ftp.tcl
    set List ::ftp::List_org
    if {[info commands $List] == {}} {
        set List ::ftp::List 
    }

    # The result of List is a list of entries in the given directory.
    # Note that it is in 'ls -l format. We parse that into a more
    # readable array.

                } else {
                    puts $sock "530 Please login with USER and PASS."
		}
	    } elseif {($data(access) == 0) && (![string equal $cmd "PASS"]) \
                    && (![string equal $cmd "USER"]) \
                    && (![string equal $cmd "QUIT"])} {
                puts $sock "530 Please login with USER and PASS."
	    } elseif {[info commands ::ftpd::command::$cmd] != ""} {
		Log debug $command
		::ftpd::command::$cmd $sock $argument
		catch {flush $sock}
	    } else {
		Log error "Unknown command: $cmd"
		puts $sock "500 Unknown command $cmd"
	    }

proc ::md4::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        critcl {
            if {![catch {package require tcllibc}]
                || ![catch {package require md4c}]} {
                set r [expr {[info commands ::md4::md4c] != {}}]
            }
        }
        cryptkit {
            if {![catch {package require cryptkit}]} {
                set r [expr {![catch {cryptkit::cryptInit}]}]
            }
        }

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 commands ::md5::md5c] != {}}]
            }
        }
        cryptkit {
            if {![catch {package require cryptkit}]} {
                set r [expr {![catch {cryptkit::cryptInit}]}]
            }
        }

# -------------------------------------------------------------------------
# Setup any constraints

# Set this true if we have the critcl version.

::tcltest::testConstraint md5crypt_c \
        [llength [info commands ::md5crypt::md5crypt_c]]

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

if {[llength [info commands ::md5crypt::md5crypt_c]]} {
    puts "> critcl based"
    set impl critcl
} else {
    puts "> pure Tcl"
    set impl tcl
}

# @mdgen OWNER: generic.tcl
# @mdgen OWNER: available_ports.tcl
# @mdgen OWNER: locateport.tcl
# @mdgen OWNER: platform_*.tcl
package provide nettool 0.4

package require platform
# Uses the "ip" package from tcllib
package require ip

if {[info commands ::ladd] eq {}} {
  proc ::ladd {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        set var {}
    }
    foreach item $args {
      if {$item in $var} continue
      lappend var $item
    }
    return $var
  }
}
if {[info commands ::get] eq {}} {
  proc ::get varname {
    upvar 1 $varname var
    if {[info exists var]} {
      return [set var]
    }
    return {}
  }
}
if {[info commands ::cat] eq {}} {
  proc ::cat filename {
    set fin [open $filename r]
    set dat [read $fin]
    close $fin
    return $dat
  }
}

set body {}
if {[::twapi::get_ip_addresses] ne {}} {
  set body {
  set result [::twapi::get_ip_addresses]
  ldelete result 127.0.0.1
  return $result
} 
} elseif {[info commands ::twapi::get_system_ipaddrs] ne {}} {
# They changed commands names on me...
  set body {
  set result [::twapi::get_system_ipaddrs]
  ldelete result 127.0.0.1
  return $result
}
}

# 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 odie::processman 0.3 [list source [file join $dir processman.tcl]]
package ifneeded processman 0.3 [list source [file join $dir processman.tcl]]

###
# IRM External Process Manager
###


package require cron 1.1

::namespace eval ::processman {}

if { $::tcl_platform(platform) eq "windows" } {
  package require twapi
} else {
  ###
  # Try to utilize C level utilities that are bundled
  # with either TclX or Odielib
  ###
  if [catch {package require odielib}] {
    catch {package require Tclx}
  }
  if {[info commands subprocess_exists] eq {}} {
    proc ::processman::subprocess_exists pid {
      set dat [exec ps]
      foreach line [split $dat \n] {
        if {![scan $line "%d %s" thispid rest]} continue
        if { $thispid eq $pid} {
          return $thispid
        }
      }
      return 0
    }
  }
  if {[info commands kill_subprocess] eq {}} {
    proc ::processman::kill_subprocess pid {
      catch {exec kill $pid}
    }
  }
}
if {[info commands harvest_zombies] eq {}} {
  proc ::processman::harvest_zombies args {
  }
}

###
# topic: a0cdb7503872cd302756c732956cd5c3
# title: Periodic scan of the state of processes

if {![info exists process_binding]} {
  set process_binding {}
}
}

::cron::every processman 60 ::processman::events

package provide odie::processman 0.3
package provide processman 0.3

proc ::ripemd::ripemd128::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        #critcl {
        #    if {![catch {package require tcllibc}]
        #        || ![catch {package require sha1c}]} {
        #        set r [expr {[info commands ::sha1::sha1c] != {}}]
        #    }
        #}
        #cryptkit {
        #    if {![catch {package require cryptkit}]} {
        #        set r [expr {![catch {cryptkit::cryptInit}]}]
        #    }
        #}

proc ::ripemd::ripemd160::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        #critcl {
        #    if {![catch {package require tcllibc}]
        #        || ![catch {package require sha1c}]} {
        #        set r [expr {[info commands ::sha1::sha1c] != {}}]
        #    }
        #}
        cryptkit {
            if {![catch {package require cryptkit}]} {
                set r [expr {![catch {cryptkit::cryptInit}]}]
            }
        }

        tcl {
            # Already present (this file)
            set r 1
        }
        critcl {
            if {![catch {package require tcllibc}]
                || ![catch {package require sha1c}]} {
                set r [expr {[info commands ::sha1::sha1c] != {}}]
            }
        }
        cryptkit {
            if {![catch {package require cryptkit}]} {
                set r [expr {![catch {cryptkit::cryptInit}]}]
            }
        }

proc ::sha1::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        critcl {
            if {![catch {package require tcllibc}]
                || ![catch {package require sha1c}]} {
                set r [expr {[info commands ::sha1::sha1c] != {}}]
            }
        }
        cryptkit {
            if {![catch {package require cryptkit}]} {
                set r [expr {![catch {cryptkit::cryptInit}]}]
            }
        }

        tcl {
            # Already present (this file)
            set r 1
        }
        critcl {
            if {![catch {package require tcllibc}]
                || ![catch {package require sha256c}]} {
                set r [expr {[info commands ::sha2::sha256c_update] != {}}]
            }
        }
        default {
            return -code error "invalid accelerator $key:\
                must be one of [join [KnownImplementations] {, }]"
        }
    }

} -result {0}

test typedestruction-1.4 {type proc is destroyed on error} -body {
    catch {type dog {
        error "Error creating dog"
    }} result

    list [namespace exists ::dog] [info commands ::dog]
} -result {0 {}}

test typedestruction-1.5 {unrelated namespaces are deleted, bug 2898640} -body {
    type dog {}
    namespace eval dog::unrelated {}
    dog destroy
} -result {}

        type dog {
            typeconstructor {
                error "Error creating dog"
            }
        }
    } result

    list [namespace exists ::dog] [info commands ::dog]
} -result {0 {}}

#-----------------------------------------------------------------------
# Type components

test typecomponent-1.1 {typecomponent defines typevariable} -body {
    type dog {

            append ns "::"
        }
        
        set name "$ns$name"
    }

    # NEXT, Check the name
    if {"" != [info commands $name]} {
        return -code error "command name \"$name\" already exists"
    }

    # NEXT, Create the object.
    proc $name {method args} [format {
        if {[catch {::textutil::expander::Methods %s $method $args} result]} {
            return -code error $result

#
proc ::uuid::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        critcl {
            if {![catch {package require tcllibc}]} {
                set r [expr {[info commands ::uuid::generate_c] != {}}]
            }
        }
        default {
            return -code error "invalid accelerator package:\
                must be one of [join [array names accel] {, }]"
        }
    }