[David Easton] ''20 Oct 2004'' - Here is a simple [TFTP] server written purely in [Tcl] but requiring [TclUDP].  It supports octet (binary) and nearly supports netascii (ascii) - see limitations below.

It has been tested by running it on [Windows] (Tcl 8.4.6) and using an [HPUX] 11i tftp client.

'''Limitations:'''
   * '''Security''' - Update tftpd::securityCheckRead and tftpd::securityCheckWrite to add security checking based on hostname or filename.  The default is set to only allow the local machine (127.0.0.1).

   * '''netascii mode''' does not translate end of line characters when receiving - this is because it needs to read the socket in binary mode to determine the number of bytes of data sent, but could do with reading it with -translation auto to automatically translate end of line characters. 'Is there a way to determine how many bytes were read from a socket prior to translation of end-of-line characters?' Another solution would be to send the data through another socket to translate it.

'''See:'''
   * [TFTP Client]
   * [TFTP]

Feel free to fix/improve this and use it however you wish. 

[David Easton] ''21 Oct 2004'' - Updated to make it more resilient following testing with [TFTP Client]

[Craig French] '9 Feb 2005' - (Thanks for a great server David) Fixed error handler tftpd::tftpdReceive to look at the packet data.

[David Easton] '9 Feb 2005' - Thanks Craig, I'm glad it is of use to you.
----
package provide tftpd 1.0
 
 namespace eval tftpd {
 
     package require udp
     
     namespace export tftpd
 
     variable S
     set S(rexmt)    5000 ;# Per-packet timeout (ms)
     set S(timeout) 25000 ;# Total timeout (ms)
     set S(listenPort) 69 ;# TFTPD port
     set S(verbose)  2    ;# Print output (2=high, 1=medium, 0=low)
 }
 
 # Returns: 0 - Passed security check
 #          1 - Failed security check
 proc tftpd::securityCheckRead {host file} {
     verbose 1 "Running security check on sending $file to $host"
     if { $host != "127.0.0.1" } {
         return 1
     } else {
         return 0
     }
 }
 
 # Returns: 0 - Passed security check
 #          1 - Failed security check
 proc tftpd::securityCheckWrite {host file} {
     verbose 1 "Running security check on writing $file from $host"
     if { $host != "127.0.0.1" } {
         return 1
     } else {
         return 0
     }
 }
 
 proc tftpd::verbose {level message} {
     
     variable S
     
     if { $level <= $S(verbose) } {
         puts "$message"
     }
 }
 
 proc tftpd::tftpd {} {
     
     variable S
     
     # Open listening port
     set sock [udp_open $S(listenPort)]
     fconfigure $sock -buffering none -translation binary
     fileevent $sock readable [list tftpd::tftpdReceive $sock]
     
     verbose 1 "Listening on UDP port: [udp_conf $sock -myport], sock: $sock"
 }
 
 proc tftpd::tftpdReceive {sock} {
     
     set pkt [read $sock]
     foreach {host port} [udp_conf $sock -peer] {break}
     
     set type "???"
     # Get packet type from 2nd byte
     binary scan $pkt xc type
     
     verbose 2 "Received type $type packet from $host:$port on port [udp_conf $sock -myport]"
     
     if { $type == 1 || $type == 2 } {
         
         binary scan $pkt xxa* str
         
         if {[regexp {([^\000]+)\000([^\000]+)\000} $str - filename mode]} {
             
             if { $mode != "octet" && $mode != "netascii" } {
                 sendError $sock 0 "Unsupported mode $mode"
             } elseif { $type == 1 } {
                 verbose 2 "<-- RRQ $host:$port (file $filename, mode $mode)"
                 startRead $sock $filename $mode $host $port
             } else {
                 verbose 2 "<-- WRQ $host:$port (file $filename, mode $mode)"
                 startWrite $sock $filename $mode $host $port
             }
         } else {
             verbose 2 "<-- RRQ/WRQ $host:$port (Invalid packet)"
             sendError $sock 0 "Invalid packet format"
         }
     } else {
         verbose 2 "<-- Unexpected type $type $host:$port ([string length $pkt] bytes)"
         sendError $sock 4 "Illegal TFTP operation"
     }
 }
 
 proc tftpd::sockReceive {sock host port} {
     
     variable S
     
     set pkt [read $sock]
     
     # Check that host and port are as expected
     foreach {thishost thisport} [udp_conf $sock -peer] {break}
     if { "$thishost" != "$host" || "$thisport" != "$port" } {        
         sendError $sock 5 "Unknown transfer ID"
         return
     }
     
     cancelTimeout $sock
     set S($sock,timAfterId) [after $S(timeout) [list tftpd::timeout $sock]]
     
     # 1st 2 bytes determine the packet type
     set type ???
     binary scan $pkt xc type
         
     switch -- $type {
         
         1 -
         2 { # Error - should not get RRQ/WRQ here
             verbose2 "RRQ/WRQ received on port [udp_conf $sock -myport]"
             sendError $sock 4 "Illegal TFTP operation"
             closeSock $sock
         }        
         3 { # DATA
             binary scan $pkt xxSa* block data
             set size [string length $data]
             verbose 2 "<-- DATA (block $block, $size bytes)"
             
             if { $block == $S($sock,lastblock) } {
                 # Already received, resend ACK
                 sendAck $sock $block
             } elseif { $block == $S($sock,lastblock) + 1 } {
                 # New data, save to file and send ACK
                 puts -nonewline $S($sock,fid) $data
                 incr S($sock,lastblock)
                 sendAck $sock $block
             } else {
                 # Unexpected block, send error
                 sendError 4 "Illegal TFTP operation, incorrect block number: $block"
             }
             
             # Stop if $size < 512
             if { $size < 512 } {
                 verbose 1 "Receipt of $S($sock,file) complete"
                 closeSock $sock
             }
         }        
         4 { # ACK
             binary scan $pkt xxS block
             verbose 2 "<-- ACK (block $block)"
             # Send the next block of data
             incr block
             sendData $sock $block
         }        
         5 { # ERROR
             binary scan $pkt xxxca* errCode errMsg
             verbose 1 "<-- ERROR ($errCode $errMsg)"
             closeSock $sock
         }
         default {
             verbose 2 "<-- Unknown type ([string length $pkt] bytes) received on port [udp_conf $sock -myport]"
             closeSock $sock
         }
     }
 }
 
 proc tftpd::timeout {sock} {
     
     variable S
     
     if {[info exists S($sock,file)]} {
         verbose 1 "Timed out for file $S($sock,file)"
     } else {
         verbose 1 "Timed out"
     }
     closeSock $sock
 }
 
 proc tftpd::cancelTimeout {sock} {
     
     variable S
     
     catch {after cancel $S($sock,timAfterId)}
     catch {after cancel $S($sock,pktAfterId)}
 }
 
 proc tftpd::closeSock {sock} {
     
     variable S
 
     verbose 2 "Closing port [udp_conf $sock -myport]"
     cancelTimeout $sock
     catch {close $sock}
     catch {close $S($sock,fid)}
     array unset S "$sock,*"
 }
 
 proc tftpd::startRead {sock filename mode host port} {
     
     variable S
     
     if {[securityCheckRead $host $filename]} {
         sendError $sock 2 "Access violation"
     } elseif { ![file exists $filename] } {       
         sendError $sock 1 "File $filename not found"
     } elseif {[catch {open $filename r} fid]} {
         sendError $sock 0 "Error opening file: $fid"
     } else {
 
         verbose 1 "Sending $filename, mode $mode to $host:$port"
 
         if { $mode == "octet" } {
             fconfigure $fid -translation binary -buffersize 512
         }
         
         # Create our new sending port
         set newsock [udp_open]
         udp_conf $newsock $host $port
         fconfigure $newsock -buffering none -translation binary
         
         # Listen for more replies
         fileevent $newsock readable [list tftpd::sockReceive $newsock $host $port]
         
         set S($newsock,fid) $fid
         set S($newsock,file) $filename
         set S($newsock,lastblock) 65025 ;# This is 255*255
         
         set S($newsock,timAfterId) [after $S(timeout) [list tftpd::timeout $newsock]]
         sendData $newsock 1
     }
 }
 
 proc tftpd::startWrite {sock filename mode host port} {
     
     variable S
     
     if {[securityCheckWrite $host $filename]} {
         sendError $sock 2 "Access violation"
     } elseif { [file exists $filename] } {
         sendError $sock 6 "File $filename already exists"
     } elseif {[catch {open $filename w} fid]} {
         sendError $sock 0 "Error opening file: $fid"
     } else {
         
         verbose 1 "Receiving $filename, mode $mode from $host:$port"
         
         if { $mode == "octet" } {
             fconfigure $fid -translation binary -buffersize 512
         }
         
         # Create our new sending port
         set newsock [udp_open]
         udp_conf $newsock $host $port
         fconfigure $newsock -buffering none -translation binary
     
         # Listen for more replies
         fileevent $newsock readable [list tftpd::sockReceive $newsock $host $port]
         
         set S($newsock,fid)  $fid
         set S($newsock,file) $filename
         set S($newsock,lastblock) 0 ;# Record last block received
         
         set S($newsock,timAfterId) [after $S(timeout) [list tftpd::timeout $newsock]]
         sendAck $newsock 0
     }
 }
 
 proc tftpd::sendData {sock block} {
     
     variable S
     
     # See if all block have been sent
     if { $block > $S($sock,lastblock) } {
         verbose 1 "Send $S($sock,file) complete"
         closeSock $sock
         return
     }
     
     # This could be a resend, so seek to correct place in file
     seek $S($sock,fid) [expr {($block - 1) * 512}] start    
     set data [read $S($sock,fid) 512]
     set len [string length $data]
     
     # Mark as last block if less than 512 bytes
     if { $len < 512 } {
         set S($sock,lastblock) $block
     }
 
     verbose 2 "DATA --> (block $block, $len bytes)"
     puts $sock [binary format xcSa* 3 $block $data]
     
     set S($sock,pktAfterId) [after $S(rexmt) [list tftpd::sendData $sock $block]]
 }
 
 proc tftpd::sendAck {sock block} {
     
     variable S
     
     verbose 2 "ACK --> (block $block)"
     puts $sock [binary format xcS 4 $block]
     
     set S($sock,pktAfterId) [after $S(rexmt) [list tftpd::sendAck $sock $block]]
 }
 
 proc tftpd::sendError {sock errCode errMsg } {
     
     verbose 1 "ERROR --> ($errCode $errMsg)"
     puts $sock [binary format xcxca*x 5 $errCode $errMsg]
 }
 
----

To use it, ensure that TclUDP is available and then:

 package require tftpd
 tftpd::tftpd

----
[[
[Category Internet]
]]