Version 28 of telnet

Updated 2005-08-04 23:47:24 by dkf

A standards'-based telnet client is at the end of this page. It operates with "telnet" servers. -TDC

--- This is telnet as remote-execution protocol, and not as specified in the RFC 854 [L1 ]. These two scripts have been tested against each other, and work nicely with Solaris. No idea if they will function correctly on other Unix machines (though they ought to) and limitations in Windows reduce the power of the server on that platform...

Have fun! -DKF


Q & A

Why not a real telnet?
Because implementing a real telnet client is a lot of work and requires services that Tcl does not provide (like receipt and transmission of out-of-band TCP/IP messages.) This is sufficiently painful and awkward that I'd simply advise not bothering.
Why is this all so boring?
Because you've not read the RFCs in great detail. For a fun example, try the following: TELNET SUBLIMINAL-MESSAGE Option [L2 ] This place is a real bag-o-laughs! :^) Another favorite is RFC 748 [L3 ].

DKF

Is it possible to reuse an existing telnet client?
You bet. If you've got the Expect extension, you can just 'spawn telnet' and you get the telnet client-side for free.
So how about the server side?
There is no way to reuse telnetd, alas. An alternative implementation of a telnet server is available in the example directory of the Expect distribution. It's useful if you need your telnet server to run an interactive program like, say, telnet (which sounds peculiar at first but solves a number of scenarios), passwd, etc . . . This whole area is described further in the Expect book.

DL


If you came here looking for a real telnet

Download plink from http://www.chiark.greenend.org.uk/~sgtatham/putty/

  set f [open "|plink -telnet 10.0.7.16" w+]
  fconfigure $f -blocking 0 -buffering none
  read $f
  puts $f "help\n"
  read $f

Tested on windows only.

LEM


SERVER

  • The server logs all events it deems interesting.
  • Setting up the id/password mapping is easy enough, especially if you do it by using [array get].
  • The server will handle incoming connections on several sockets at once, and you can have a different core service routine for each socket.
  • If you want to write your own service routine, then it is easiest to do this by studying the routine execCommand which implements both prompt handling and command handling in quite a compact space.

I give a demonstration of this with an admin service which offers the standard operations, but also permits a bunch of special operations:

shutdown
Closes down the whole server (all services.)
denied
Lists IP addresses that are prohibited from connecting.
deny hostIP
Adds an IP address to the deny list.
allow hostIP
Removes an IP address from the deny list.
connections
Lists all currently active connections, including which service they have connected to and what the host and port of the client socket is.
close clientName
Closes an open client connection.
services
Lists all services (port number and handler procedure) hosted by this server.
addService port ?passwordMapping? ?handlerCommand?
Adds a new service and reports what service was created.
removeService serviceId
Removes a service and any unauthorized connections attached to that service (which is needed because the authentication map is stored on a per-service basis, and once it has been erased for a particular service, it is impossible to become authorized.)
 #!/usr/bin/env tclsh
 # Pseudo-telnet server.  Includes basic auth, but no separate identities
 # or proper multi-threaded operation, so whoever runs this had better
 # trust those he gives identities/passwords to and they had better trust
 # each other too.  Note this script does not support command-line arguments.

 ## The names of this array are IP addresses of hosts that are not permitted
 ## to connect to any of our services.  Admin account(s) can change this
 ## at run-time, though this info is not maintained across whole-server shutdowns.
 array set denyHosts {}

 ## Create a server on the given port with the given name/password map
 ## and the given core interaction handler.
 proc telnetServer {port {passmap {foo bar spong wibble}} {handlerCmd execCommand}} {
     if {$port == 0} {
         return -code error "Only non-zero port numbers are supported"
     }
     set server [socket -server [list connect $port $handlerCmd] $port]
     global passwords services
     foreach {id pass} $passmap {set passwords($port,$id) $pass}
     set services($server) $handlerCmd
     return $server
 }

 ## Removes the server on the given port, cleaning up the extra state too.
 proc closedownServer {server} {
     global services passwords connections auth
     set port [lindex [fconfigure $server -sockname] 2]
     catch {close $server}
     unset services($server)
     foreach passmap [array names passwords $port,*] {
         unset passwords($passmap)
     }
     # Hmph!  Have to remove unauthorized connections too, though any
     # connection which has been authorized can continue safely.
     foreach {client data} [array get connections] {
         if {$port == [lindex $data 0] && !$auth($client)} {
             disconnect $client
         }
     }
 }

 ## Handle an incoming connection to the given server
 proc connect {serverport handlerCmd client clienthost clientport} {
     global auth cmd denyHosts connections
     if {[info exist denyHosts($clienthost)]} {
         puts stdout "${clienthost}:${clientport} attempted connection"
         catch {puts $client "Connection denied"}
         catch {close $client}
         return
     }
     puts stdout "${clienthost}:${clientport} connected on $client"
     fileevent $client readable "handle $serverport $client"
     set auth($client) 0
     set cmd($client) $handlerCmd
     set connections($client) [list $serverport $clienthost $clientport]
     fconfigure $client -buffering none
     catch {puts -nonewline $client "Login: "}
 }

 ## Disconnect the given client, cleaning up any connection-specific data
 proc disconnect {client} {
     catch {close $client}
     global auth cmd connections
     unset auth($client)
     unset cmd($client)
     unset connections($client)
     puts stdout "$client disconnected"
 }

 ## Handle data sent from the client.  Log-in is handled directly by this
 ## procedure, and requires the name and password on the same line
 proc handle {serverport client} {
     global passwords auth cmd
     if {[gets $client line] < 0} {
         disconnect $client
         return
     }
     if {[string equal $line "quit"] || [string equal $line "exit"]} {
         disconnect $client
         return
     }
     if {$auth($client)} {
         eval $cmd($client) [list $client $line 0]
         eval $cmd($client) [list $client $line 1]
         return
     }
     foreach {id pass} [split $line] {break}
     if {![info exist pass]} {
         catch {puts -nonewline $client "Login: "}
         return
     }
     if {
         [info exist passwords($serverport,$id)] &&
         [string equal $passwords($serverport,$id) $pass]
     } then {
         set auth($client) 1
         puts stdout "$id logged in on $client"
         catch {puts $client "Welcome, $id!"}
         eval $cmd($client) [list $client $line 1]
         return
     }
     puts stdout "AUTH FAILURE ON $client"
     catch {puts $client "Unknown name or password"}
     disconnect $client
 }

 ## Standard handler for logged-in conversations and prompt-generation.
 proc execCommand {client line prompt} {
     global tcl_platform
     if {$prompt} {
         catch {puts -nonewline $client "\$ "}
         return
     }
     switch $tcl_platform(platform) {
         unix {
             catch {exec sh -c $line <@$client >@$client 2>@$client}
         }
         default {
             catch {exec $line} data
             puts $client $data
         }
     }
 }

 telnetServer 12345 ;# DEFAULT NAMES/PASSWORDS
 telnetServer 12346 {aleph alpha beth beta}

 ## Administration service handler.  Chains to the normal handler for
 ## everything it doesn't recognise itself.
 proc admin {client line prompt} {
     if {$prompt} {
         catch {puts -nonewline $client "# "}
         return
     }
     set cmd [split $line]
     global denyHosts connections services
     if {[string equal $line "shutdown"]} {
         set ::termination 1
         puts stdout "Shutdown requested on $client"
         catch {puts $client "System will shut down as soon as possible"}
         return -code return "SHUTTING DOWN"
     } elseif {[string equal [lindex $cmd 0] "deny"]} {
         set denyHosts([lindex $cmd 1]) 1
     } elseif {[string equal [lindex $cmd 0] "allow"]} {
         catch {unset denyHosts([lindex $cmd 1])}
     } elseif {[string equal $line "denied"]} {
         foreach host [array names denyHosts] {
             catch {puts $client $host}
         }
     } elseif {[string equal $line "connections"]} {
         set len 0
         foreach conn [array names connections] {
             if {$len < [string length $conn]} {
                 set len [string length $conn]
             }
         }
         foreach {conn details} [array get connections] {
             catch {puts $client [format "%-*s = %s" $len $conn $details]}
         }
     } elseif {[string equal [lindex $cmd 0] "close"]} {
         set sock [lindex $cmd 1]
         if {[info exist connections($sock)]} {
             disconnect $sock
         }
     } elseif {[string equal $line "services"]} {
         set len 0
         foreach serv [array names services] {
             if {$len < [string length $serv]} {
                 set len [string length $serv]
             }
         }
         foreach {serv handler} [array get services] {
             set port [lindex [fconfigure $serv -sockname] 2]
             catch {puts $client [format "%-*s (port %d) = handler %s" $len $serv $port $handler]}
         }
     } elseif {[string equal [lindex $cmd 0] "addService"]} {
         set service [eval telnetServer [lrange $cmd 1 end]]
         catch {puts $client "Created service as $service"}
     } elseif {[string equal [lindex $cmd 0] "removeService"]} {
         set service [lindex $cmd 1]
         if {[info exist services($service)]} {
             closedownServer $service
         }
     } else {
         # CHAIN TO DEFAULT
         execCommand $client $line 0
     }
 }
 telnetServer 12347 {root OfAllEvil} admin

 puts stdout "Ready for service"

 vwait termination
 exit

CLIENT

This client is great for interactively accessing simple internet protocols (like SMTP, NNTP, POP and even HTTP) though it is not up to being a real TELNET client, and it lacks the additional support needed for being an FTP client.

 #!/usr/bin/env tclsh
 # Pseudo-telnet client.

 proc telnet {{server localhost} {port telnet}} {
     set sock [socket $server $port]
     fconfigure $sock -buffering none -blocking 0 \
             -encoding binary -translation crlf -eofchar {}
     fconfigure stdout -buffering none
     #fileevent $sock readable [list initEvents $sock]
     fileevent $sock readable [list fromServer $sock]
     fileevent stdin readable [list toServer $sock]
     global closed
     vwait closed($sock)
     unset closed($sock)
 }
 proc initEvents {sock} {
     puts -nonewline [read $sock 4096]
     fileevent $sock readable [list fromServer $sock]
     fileevent stdin readable [list toServer $sock]
 }
 proc toServer {sock} {
     if {[gets stdin line] >= 0} {
         puts $sock $line
     } else {
         disconnect $sock
     }
 }
 proc fromServer {sock} {
     set data x
     while {[string length $data]} {
         set data [read $sock 4096]
         if {[eof $sock]} {
             disconnect $sock
             return
         }
         if {[string length $data]} {
             while 1 {
                 set idx [string first \xff $data]
                 if {$idx < 0} {
                     break
                 }
                 write [string range $data 0 [expr {$idx-1}]]
                 set byte [string index $data [expr {$idx+1}]]
                 incr idx 2
                 if {$byte < "\xf0"} {
                     write \xf0$byte
                 } elseif {$byte == "\xff"} {
                     write \xf0
                 } else {
                     binary scan $byte H2 op
                     protocol $sock $op
                 }
                 set data [string range $data $idx end]
             }
             puts -nonewline stdout $data
         }
     }
 }
 proc disconnect {sock} {
     global closed
     close $sock
     set closed($sock) 1
 }
 proc write string {
     puts -nonewline stdout [encoding convertfrom iso8859-1 $string]
 }
 proc protocol {sock op} {
     upvar 1 data data idx idx
     switch $byte {
         f0 {# SE
         }
         f1 {# NOP
             return
         }
         f2 {# DATA MARK
         }
         f3 {# BRK
         }
         f4 {# IP
         }
         f5 {# AO
         }
         f6 {# AYT
             puts $sock {[YES]}
         }
         f7 {# EC
             write \u007f
         }
         f8 {# EL
             write \u0019
         }
         f9 {# GA
         }
         fa {# SB
             # Should search forward for IAC SE (\xff\xf0) but since
             # we refuse to turn on any extension features, we should
             # never encounter any such things.
         }
         fb {# WILL
             # Attempt to negotiate; refuse!
             set byte [string index $data $idx]
             puts -nonewline $sock \xff\xfe$byte
             incr idx
         }
         fc {# WON'T
             incr idx
         }
         fd {# DO
             # Attempt to negotiate; refuse!
             set byte [string index $data $idx]
             puts -nonewline $sock \xff\xfc$byte
             incr idx
         }
         fe {# DON'T
             incr idx
         }
     }
 }

 if {[llength $argv] > 2} {
     puts stderr "wrong # args: should be \"telnet ?hostname? ?port?\""
     puts stderr "\thostname defaults to \"localhost\""
     puts stderr "\tport defaults to the telnet port, and may be specified"
     puts stderr "\teither by name or by number"
 } else {
     eval telnet $argv
 }
 exit

[ CL intends to illustrate use of this telnet with interesting examples in summer 2002.] - Apparently your plans have changed? -FW Wow. Apparently. A lot. And now, in January 2003, I frankly don't plan to get back to this soon; I've got too many other unfinished projects that are more compelling/urgent/...

CL summarizes: if someone's truly desperate for new ideas on telnet, I'll work to make sense out of my notes. For the most part, I'd think folks are best off starting fresh, without regard to what I was thinking almost a year ago.


VI 2003-09-23: See Poor Man's Expect for a Tcl-only telnet (subset) client implementation


TJM I have made available a tclTelnet package which implements a telnet client in pure Tcl. It can be downloaded from http://www.tmartin.org/tcltelnet


TDC Below is a collection of functions that sit in a library I created. I've successfully used it on Linux and Windows, and since it's native TCL it should work anywhere else. dTelnetInit instantiates a standards-based telnet session with a normal telnet server. Tested on TCL>=8.3.

I don't use the hunt mode much, so it probably has some latent bugs. The standard connection (mask 32) works for me against telnet servers I've tried: Linux (RH 9), a terminal server, and a couple other hosts. YMMV. Since I've only included a couple of options, it's pretty simple to confuse it... Feel free to add telnet options, it should be fairly obvious.

To Do: get it to work only in event mode. Most of the overhead is done, but I've never had cause to do it since it works fine in file buffer mode.

There's a lot of overhead that's probably not useful outside my library... but I know if I change it I'll break it. I've munged a few things to eliminate the more specific features, but it should work 'off the page.'

This particular code is in the public domain... obviously.

 ###############################################################################
 #
 # Procedure : dTelnetInit
 #
 # Purpose   : Instantiates a telnet session
 #
 # Arguments : ip      : [In] IP address to be telnetted
 #             mask    : [In] Subnet Mask, addresses to be attempted sequentially
 #                       Default Value - 32
 #             port    : [In] Port Number to establish
 #                       Default Value - 23
 #             timeout : [In] Timeout
 #                       Default Value - 250
 #
 # Author    : tcrone
 #
 # Returns   : Handles the Telnet session
 #
 ###############################################################################

proc dTelnetInit {ip {port 23} {mask 32} {timeout 250}} {

 # From RFC 854:
 set GA 249
 set WILL 251
 set WONT 252
 set DO 253
 set DONT 254
 set IAC 255

 set OPTIONS [list 3 1] ;# SuppressGoAhead (RFC 858), Echo (RFC 857)

 set telnetSocket [dSocketInit $ip $port $mask $timeout]
 if {$telnetSocket=="Err"} {
  return Err
 }
 set initOutput [dEventRead $telnetSocket 1000 0 1] ;# No errcheck, binary
 set textOutput ""
 set servOutput ""
 for {set i 0} {$i<[string length $initOutput]} {incr i} {
  if {[scan [string index $initOutput $i] %c]==$IAC} {
   incr i
   if {[lsearch [list $WILL $WONT] [scan [string index $initOutput $i] %c]]!=-1} { ;# The option handling routines have another byte
    incr i
    set OptionValue [scan [string index $initOutput $i] %c]
    if {[lsearch $OPTIONS $OptionValue]==-1} { ;# Option not found, DONT
     append servOutput [binary format ccc $IAC $DONT $OptionValue]
     puts "Rejecting Telnet Option $OptionValue"
    } else { ;# Option was found, DO
     append servOutput [binary format ccc $IAC $DO $OptionValue]
     puts "Accepting Telnet Option $OptionValue"
    }
   } elseif {[lsearch [list $DO $DONT] [scan [string index $initOutput $i] %c]]!=-1} {
    incr i
    set OptionValue [scan [string index $initOutput $i] %c]
    if {[lsearch $OPTIONS $OptionValue]==-1} { ;# Option not found, WONT
     append servOutput [binary format ccc $IAC $WONT $OptionValue]
     puts "Requesting Reject of Telnet Option $OptionValue"
    } else { ;# Option was found, WILL
     append servOutput [binary format ccc $IAC $WILL $OptionValue]
     puts "Requesting Telnet Option $OptionValue"
    }
   } else {
    puts "Ignoring unknown telnet server command" ;# Just a miscellaneous telnet server command
   }
  } else { ;# A non-command, add to output buffer
   append textOutput [string index $initOutput $i]
  }
 } ;# Loop over string
 dBufferWrite $telnetSocket $servOutput 1
 return $telnetSocket ;# In so doing we lose the initial output from the telnet session, if it's not properly negotiated.

}

proc dEventRead {buffer {timeout 250} {errcheck 0} {binary 0}} {

    global connectState

    set afterId [after $timeout {set connectState Err}]

    fileevent $buffer readable "dHandleRead $afterId $buffer $errcheck $binary"

    #
    # Wait until the previously scheduled delayed command or
    # the file event handler sets the variable connectState
    #
    vwait connectState

    return $connectState

}

proc dHandleRead {afterId buffer {errcheck 0} {binary 0}} {

    after cancel $afterId
    fileevent $buffer readable ""
    global connectState

    set connectState [dBufferRead $buffer $errcheck $binary]

}

 ###############################################################################
 #
 # Procedure : dSocketInit
 #
 # Purpose   : Establishes a socket connection to the IP address
 #
 # Arguments : ip      : [In] IP address of the host
 #             mask    : [In] Subnet Mask
 #                       Default Value - 32
 #             port    : [In] Port Number to establish
 #             timeout : [In] Timeout
 #                       Default Value - 250
 #
 # Author    : tcrone
 #
 # Returns   : Err / Handler of the socket connection
 #
 ###############################################################################

proc dSocketInit {ip port {mask 32} {timeout 250}} {

 #####
 # Initializes the socket session to the passed ip and port, or browses the
 #  network _up_ based on the mask.  If 1.1.1.1/0 is passed, for example,
 #  1.1.1.1 will be the first attempt.  If 1.1.1.2/0, 1.1.1.2 will be the
 #  first attempt, and 1.1.1.3 the next.  The function will stop at the
 #  first successful telnet session regardless.  The calling function should
 #  verify that the correct machine has been found.
 # Additionally, if the ip is 5 or 7 octets long, the final octet is stripped
 #  and used in place of the port, regardless of what that happens to be or
 #  where it was set.  This could potentially yield unexpected results, but
 #  the long and short of it is that "port" is treated as a general passed
 #  default for the application and that the extended IP form is the actual
 #  destination port, where available.
 # Pass the ip address, port, an optional mask integer, and a timeout setting in milliseconds.
 #####

 set ipvalue 0.
 set lastindex 0

 set splitIP [split $ip .]
 if {[llength $splitIP]==5 || [llength $splitIP]==7} { ;# with 5 or 7 octets, the last octet is interpreted as the port number.
  set nport [string range $ip [expr [string last . $ip] + 1] [string length $ip]]
  if {$nport!=""} {
    set port $nport
  }
  set ip [string range $ip 0 [expr [string last . $ip] - 1]]
 }

 for {set x 0} {$x<[string length $ip]} {incr x} {
  if [expr [string equal "[string index $ip $x]" "."] || \
     [expr $x==[expr [string length $ip]-1]]] {
   set ipvalue [expr $ipvalue*256]
   set ipvalue [expr $ipvalue+ \
       [string range $ip $lastindex \
       [expr $x-[string equal "[string index $ip $x]" "."]]]]
   set lastindex [expr $x+1]
  }
 }
 set ipmax [expr $ipvalue / [expr pow(2,[expr 31-$mask])] * [expr pow(2,[expr 31-$mask])]] ;# Remove the masked part
 for {set x $mask} {$x<32} {set x [expr $x + 1]} {
  set ipmax [expr $ipmax + [expr pow(2,[expr 31-$x])]] ;# Add the maximum mask back in
 }
 for {set x $ipvalue} {$x<=$ipmax} {set x [expr $x + 1]} {
  set curip "[expr int([expr $x / 256 / 256 / 256])].[expr int([expr $x / 256 / 256]) % 256].[expr int([expr $x / 256]) % 256].[expr int(fmod($x,256))]"
  set dTelnetLocal [dClientSocket $curip $port $timeout]
  if {$dTelnetLocal=={Err}} {
   puts "Cannot open $curip for telnet to port $port.  Moving on."
  } else {
   puts "Connected to $curip on port $port."
   if [catch {fconfigure $dTelnetLocal -blocking false -buffering none}] {
    puts "Cannot configure $curip."
    dBufferClose $dTelnetLocal
    return Err
   }
   return $dTelnetLocal
  }
 }
 return Err

}

 #####
 # dClientSocket and dGetErrorStatus: based on code by Csaba Nemethi
 #####

set connectState false

proc dClientSocket {host port timeout} {

    global connectState
    set connectState ""

    #
    # Create a client socket and connect
    # it to the server asynchronously
    #
    set channel [socket -async $host $port]
    #
    # Schedule a command for execution timeout milliseconds later
    #
    set afterId [after $timeout {set connectState "timeout"}]

    #
    # Create a file event handler to be called when the
    # connection attempt is either completed or fails
    #
    fileevent $channel writable "dGetErrorStatus $channel $afterId"

    #
    # Wait until the previously scheduled delayed command or
    # the file event handler sets the variable connectState
    #
    vwait connectState

    if {[string compare $connectState ""] == 0} {
        return $channel
    } else {
        close $channel
        return Err
    }

}

proc dGetErrorStatus {channel afterId} {

    #
    # Assign the current error status of the socket (an
    # error message or an empty string) to connectState
    #
    global connectState
    set connectState [fconfigure $channel -error]

    #
    # Cancel the execution of the peviously scheduled
    # delayed command and delete the file event handler
    #
    after cancel $afterId
    fileevent $channel writable ""

}

 ###############################################################################
 #
 # Procedure : dBufferRead
 #
 # Purpose   : Reads the new in-buffer of BufferIn
 #
 # Arguments : BufferIn : [In] Handler of the file / connection
 #             errcheck : [In] error checking condition value
 #             binary   : [In] Forces the channel to binary mode for the read
 #
 # Author    : tcrone
 #
 # Returns   : Value read from handler
 #
 ###############################################################################

proc dBufferRead {BufferIn {errcheck 0} {binary 0}} {

 #####
 # Reads the new in-buffer of BufferIn.
 # Returns Err on a read error, or the input buffer.
 #####
 set bufferSize 1024
 set DataIn ""

 if {$binary!=0} {
  set oldEnc [fconfigure $BufferIn -translation]
  fconfigure $BufferIn -translation binary
  do {
   if [catch {read $BufferIn $bufferSize} dataTemp] {
    puts "Cannot read input buffer $BufferIn"
    return Err
   } else {
    set DataIn $DataIn$dataTemp ;# append problems on 8.3?
   }
  } until {[string length $dataTemp]==0}
  fconfigure $BufferIn -translation $oldEnc
 } else {
  if [catch {read $BufferIn} dataTemp] {
   puts "Cannot read input buffer $BufferIn"
   return Err
  } else {
   regexp -all -- {[\001-\177]+} $dataTemp DataIn
  }
 }
 return $DataIn

}

 ###############################################################################
 #
 # Procedure : dBufferWrite
 #
 # Purpose   : Writes the DataOut buffer to BufferOut
 #
 # Arguments : BufferOut : [In] Handler of the connection / file
 #             DataOut   : [In] Data to be written to output
 #             binary    : [In] Forces the channel to binary mode for the write
 #
 # Author    : tcrone
 #
 # Returns   : Err / Success
 #
 ###############################################################################

proc dBufferWrite {BufferOut DataOut {binary 0}} {

 #####
 # Writes the DataOut buffer to BufferOut.
 # Returns Err on a write error, or Success.
 #####

 if {$binary!=0} {
  set oldEnc [fconfigure $BufferOut -encoding]
  fconfigure $BufferOut -encoding binary
 }
 if [catch {puts -nonewline $BufferOut $DataOut}] {
  puts "Cannot write to output buffer."
  return Err
 }

# if catch {flush $BufferOut} { # puts "Cannot flush output buffer." # return Err # }

 if {$binary!=0} {
  fconfigure $BufferOut -encoding $oldEnc
 }
 return Success

}

 ###############################################################################
 #
 # Procedure : dBufferOpen
 #
 # Purpose   : Opens the Name for Mode access
 #
 # Arguments : Name       : [In] Name of the file or the serial port
 #             Mode       : [In] Mode of connection
 #             searchPath : [In] path of the file or serial port
 #                          Default Value - 0
 #
 # Author    : tcrone
 #
 # Returns   : Err / Success
 #
 ###############################################################################
 proc dBufferOpen {Name Mode {searchPath 0}} {
    #####
    # Opens the Name for Mode access
    #####
    global auto_path

    if {$searchPath==0} {
       if {[catch {open $Name $Mode} Buffer]} {
          puts "Cannot open $Name for $Mode access."
          return Err
       }
       return $Buffer
    } elseif {$searchPath==1} { ;# search known paths
       if {![catch {open $Name $Mode} Buffer]} {
          return $Buffer
       }
       for {set x 0} {$x<[llength $auto_path]} {incr x} {
          set tempName [format "%s/%s" [lindex $auto_path $x] $Name]
          if {![catch {open $tempName $Mode} Buffer]} {
             return $Buffer
          }
       } ;# searched base tcl_pkgPath
       for {set x 0} {$x<[llength $auto_path]} {incr x} {
          if {![catch {glob -directory [lindex $auto_path $x] *} pathFiles]} {
             for {set y 0} {$y<[llength $pathFiles]} {incr y} {
                if {[file isdirectory [lindex $pathFiles $y]]} {
                   set tempName [format "%s/%s" [lindex $pathFiles $y] $Name]
                   if {![catch {open $tempName $Mode} Buffer]} {
                      return $Buffer
                   }
                }
             }
          }
       } ;# searched tcl_pkgPath subdirectories (one level)
    } else { ;# search passed paths
       if {![catch {open $Name $Mode} Buffer]} {
          return $Buffer
       }
       for {set x 0} {$x<[llength $searchPath]} {incr x} {
          set tempName [format "%s/%s" [lindex $searchPath $x] $Name]
          if {![catch {open $tempName $Mode} Buffer]} {
             return $Buffer
          }
       }
    }
    puts "Cannot open $Name for $Mode access."
    return Err
 }

 ###############################################################################
 #
 # Procedure : dBufferClose
 #
 # Purpose   : Closed the buffer
 #
 # Arguments : Buffer : [In] Handler of the connection / file
 #
 # Author    : tcrone
 #
 # Returns   : Err / Success
 #
 ###############################################################################
 proc dBufferClose {Buffer} {
    #####
    # Closes the Buffer
    #####
    if [catch {close $Buffer}] {
       puts "Could not close the buffer $Buffer."
       return Err
    }
    return Success
 }

 # Done by Reinhard Max
 # at the Texas Tcl Shoot-Out 2000
 # in Austin, Texas.
 proc do {script arg2 {arg3 {}}} {
    #
    # Implements a "do <script> until <expression>" loop
    # The "until" keyword ist optional
    #
    # It is as fast as builtin "while" command for loops with
    # more than just a few iterations.
    #

    if {[string compare $arg3 {}]} {
        if {[string compare $arg2 until]} {
            return -code 1 "Error: do script ?until? expression"
        }
    } else {
        # copy the expression to arg3, if only
        # two arguments are supplied
        set arg3 $arg2
    }

    set ret [catch { uplevel $script } result]
    switch $ret {

        0 -
        4 {}
        3 {return}
        default {

            return -code $ret $result
        }
    }

    set ret [catch {uplevel [list while "!($arg3)" $script]} result]
    return -code $ret $result
 }

---

Category Internet