home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / ftpd / ftpd.tcl next >
Encoding:
Text File  |  2001-08-17  |  55.5 KB  |  1,951 lines
  1. # ftpd.tcl --
  2. #
  3. #       This file contains Tcl/Tk package to create a ftp daemon.
  4. #       I believe it was originally written by Matt Newman (matt@sensus.org).  
  5. #       Modified by Dan Kuchler (kuchler@ajubasolutions.com) to handle
  6. #       more ftp commands and to fix some bugs in the original implementation
  7. #       that was found in the stdtcl module.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. # 
  12. # RCS: @(#) $Id: ftpd.tcl,v 1.9 2001/08/02 16:38:06 andreas_kupries Exp $
  13. #
  14.  
  15. # Define the ftpd package version 1.1.1
  16.  
  17. package require Tcl 8.2
  18. namespace eval ::ftpd {
  19.  
  20.     # The listening port.
  21.  
  22.     variable port 21
  23.  
  24.     variable contact
  25.     if {![info exist contact]} {
  26.         global tcl_platform
  27.     set contact "$tcl_platform(user)@[info hostname]"
  28.     }
  29.  
  30.     variable cwd
  31.     if {![info exist cwd]} {
  32.     set cwd ""
  33.     }
  34.     
  35.     variable welcome
  36.     if {![info exist welcome]} {
  37.     set welcome "[info hostname] FTP server ready."
  38.     }
  39.  
  40.     # Global configuration.
  41.  
  42.     variable cfg
  43.     if {![info exist cfg]} {
  44.     array set cfg [list \
  45.         authIpCmd  {} \
  46.         authUsrCmd {::ftpd::anonAuth} \
  47.             authFileCmd {::ftpd::fileAuth} \
  48.         logCmd     {::ftpd::logStderr} \
  49.         fsCmd      {::ftpd::fsFile::fs}]
  50.     }
  51.  
  52.     variable commands
  53.     if {![info exist commands]} {
  54.     array set commands [list \
  55.         ABOR       {ABOR (abort operation)} \
  56.         ACCT       {(specify account); unimplemented.} \
  57.         ALLO       {(allocate storage - vacuously); unimplemented.} \
  58.         APPE       {APPE <sp> file-name} \
  59.         CDUP       {CDUP (change to parent directory)} \
  60.         CWD        {CWD [ <sp> directory-name ]} \
  61.         DELE       {DELE <sp> file-name} \
  62.             HELP       {HELP [ <sp> <string> ]} \
  63.         LIST       {LIST [ <sp> path-name ]} \
  64.         NLST       {NLST [ <sp> path-name ]} \
  65.         MAIL       {(mail to user); unimplemented.} \
  66.             MDTM       {MDTM <sp> path-name} \
  67.         MKD        {MKD <sp> path-name} \
  68.         MLFL       {(mail file); unimplemented.} \
  69.         MODE       {(specify transfer mode); unimplemented.} \
  70.         MRCP       {(mail recipient); unimplemented.} \
  71.         MRSQ       {(mail recipient scheme question); unimplemented.} \
  72.         MSAM       {(mail send to terminal and mailbox); unimplemented.} \
  73.         MSND       {(mail send to terminal); unimplemented.} \
  74.         MSOM       {(mail send to terminal or mailbox); unimplemented.} \
  75.         NOOP       {NOOP} \
  76.         PASS       {PASS <sp> password} \
  77.             PASV       {(set server in passive mode); unimplemented.} \
  78.         PORT       {PORT <sp> b0, b1, b2, b3, b4, b5} \
  79.             PWD        {PWD (return current directory)} \
  80.         QUIT       {QUIT (terminate service)} \
  81.         REIN       {REIN (reinitialize server state)} \
  82.         REST       {(restart command); unimplemented.} \
  83.         RETR       {RETR <sp> file-name} \
  84.         RMD        {RMD <sp> path-name} \
  85.         RNFR       {RNFR <sp> file-name} \
  86.         RNTO       {RNTO <sp> file-name} \
  87.         SIZE       {SIZE <sp> path-name} \
  88.         SMNT       {(structure mount); unimplemented.} \
  89.         STOR       {STOR <sp> file-name} \
  90.         STOU       {STOU <sp> file-name} \
  91.         STRU       {(specify file structure); unimplemented.} \
  92.         SYST       {SYST (get type of operating system)} \
  93.         TYPE       {TYPE <sp> [ A | E | I | L ]} \
  94.         USER       {USER <sp> username} \
  95.         XCUP       {XCUP (change to parent directory)} \
  96.         XCWD       {XCWD [ <sp> directory-name ]} \
  97.         XMKD       {XMKD <sp> path-name} \
  98.         XPWD       {XPWD (return current directory)} \
  99.         XRMD       {XRMD <sp> path-name}]
  100.     }
  101.  
  102.     variable passwords [list ]
  103.  
  104.     # Exported procedures
  105.  
  106.     namespace export *
  107. }
  108.  
  109. # ::ftpd::config --
  110. #
  111. #       Configure the configurable parameters of the ftp daemon.
  112. #
  113. # Arguments:
  114. #       options -    -authIpCmd proc      procedure that accepts or rejects an
  115. #                                         incoming connection. A value of 0 or
  116. #                                         an error causes the connection to be
  117. #                                         rejected. There is no  default.
  118. #                    -authUsrCmd proc     procedure that accepts or rejects a
  119. #                                         login.  Defaults to ::ftpd::anonAuth
  120. #                    -authFileCmd proc    procedure that accepts or rejects
  121. #                                         access to read or write a certain
  122. #                                         file or path.  Defaults to
  123. #                                         ::ftpd::userAuth
  124. #                    -logCmd proc         procedure that logs information from
  125. #                                         the ftp engine.  Default is
  126. #                                         ::ftpd::logStderr
  127. #                    -fsCmd proc          procedure to connect the ftp engine
  128. #                                         to the file system it operates on.
  129. #                                         Default is ::ftpd::fsFile::fs
  130. #
  131. # Results:
  132. #       None.
  133. #
  134. # Side Effects:
  135. #       Changes the value of the specified configurables.
  136.  
  137. proc ::ftpd::config {args} {
  138.  
  139.     # Processing of global configuration changes.
  140.  
  141.     package require cmdline
  142.  
  143.     variable cfg
  144.  
  145.     array set cfg [cmdline::getoptions args [list \
  146.     {authIpCmd.arg  {} {Callback to authenticate new connections based on the ip-address of the peer. Optional}} \
  147.     {authUsrCmd.arg {::ftpd::anonAuth} {Callback to authenticate new connections based on the user logging in.}} \
  148.     {authFileCmd.arg {::ftpd::fileAuth} {Callback to accept or deny a users access to read and write to a specific path or file.}} \
  149.     {logCmd.arg {::ftpd::logStderr} {Callback for log information generated by the FTP engine.}} \
  150.     {fsCmd.arg {::ftpd::fsFile::fs} {Callback to connect the engine to the filesystem it operates on.}}]]
  151.     return
  152. }
  153.  
  154. # ::ftpd::hasCallback --
  155. #
  156. #       Determines whether or not a non-NULL callback has been defined for one
  157. #       of the callback types.
  158. #
  159. # Arguments:
  160. #       callbackType -        One of authIpCmd, authUsrCmd, logCmd, or fsCmd
  161. #
  162. # Results:
  163. #       Returns 1 if a non-NULL callback has been specified for the
  164. #       callbackType that is passed in.
  165. #
  166. # Side Effects:
  167. #       None.
  168.  
  169. proc ::ftpd::hasCallback {callbackType} {
  170.     variable cfg
  171.  
  172.     return [expr {[info exists cfg($callbackType)] && [string length $cfg($callbackType)]}]
  173. }
  174.  
  175. # ::ftpd::logStderr --
  176. #
  177. #       Outputs a message with the specified severity to stderr.  The default
  178. #       logCmd callback.
  179. #
  180. # Arguments:
  181. #       severity -            The severity of the error.  One of debug, error,
  182. #                             or note.
  183. #       text -                The error message.
  184. #
  185. # Results:
  186. #       None.
  187. #
  188. # Side Effects:
  189. #       A message is written to the stderr channel.
  190.  
  191. proc ::ftpd::logStderr {severity text} {
  192.  
  193.     # Standard log handler. Prints to stderr.
  194.  
  195.     puts stderr "\[$severity\] $text"
  196.     return
  197. }
  198.  
  199. # ::ftpd::Log --
  200. #
  201. #       Used for all ftpd logging.
  202. #
  203. # Arguments:
  204. #       severity -            The severity of the error.  One of debug, error,
  205. #                             or note.
  206. #       text -                The error message.
  207. #
  208. # Results:
  209. #       None.
  210. #
  211. # Side Effects:
  212. #       The ftpd logCmd callback is called with the specified severity and
  213. #       text if there is a non-NULL ftpCmd.
  214.  
  215. proc ftpd::Log {severity text} {
  216.  
  217.     # Central call out to log handlers.
  218.  
  219.     variable     cfg
  220.     
  221.     if {[hasCallback logCmd]} {
  222.         set cmd $cfg(logCmd)
  223.         lappend cmd $severity $text
  224.         eval $cmd
  225.     }
  226.     return
  227. }
  228.  
  229. # ::ftpd::fileAuth --
  230. #
  231. #       Given a username, path, and operation- decides whether or not to accept
  232. #       the attempted read or write operation.
  233. #
  234. # Arguments:
  235. #       user -                The name of the user that is attempting to
  236. #                             connect to the ftpd.
  237. #       path -                The path or filename that the user is attempting
  238. #                             to read or write.
  239. #       operation -           read or write.
  240. #
  241. # Results:
  242. #       Returns 0 if it rejects access and 1 if it accepts access.
  243. #
  244. # Side Effects:
  245. #       None.
  246.  
  247. proc ::ftpd::fileAuth {user path operation} {
  248.     # Standard authentication handler
  249.  
  250.     if {(![Fs exists $path]) && ([string equal $operation "write"])} {
  251.         if {[Fs exists [file dirname $path]]} {
  252.             set path [file dirname $path]
  253.     }
  254.     } elseif {(![Fs exists $path]) && ([string equal $operation "read"])} {
  255.         return 0
  256.     }
  257.  
  258.     if {[Fs exists $path]} {
  259.         set mode [Fs permissions $path]
  260.         if {([string equal $operation "read"] && (($mode & 00004) > 0)) || \
  261.                 ([string equal $operation "write"] && (($mode & 00002) > 0))} {
  262.             return 1
  263.         }
  264.     }
  265.     return 0
  266. }
  267.  
  268. # ::ftpd::anonAuth --
  269. #
  270. #       Given a username and password, decides whether or not to accept the
  271. #       attempted login.  This is the default ftpd authUsrCmd callback. By
  272. #       default it accepts the annonymous user and does some basic checking
  273. #       checking on the form of the password to see if it has the form of an
  274. #       email address.
  275. #
  276. # Arguments:
  277. #       user -                The name of the user that is attempting to
  278. #                             connect to the ftpd.
  279. #       pass -                The password of the user that is attempting to
  280. #                             connect to the ftpd.
  281. #
  282. # Results:
  283. #       Returns 0 if it rejects the login and 1 if it accepts the login.
  284. #
  285. # Side Effects:
  286. #       None.
  287.  
  288. proc ::ftpd::anonAuth {user pass} {
  289.     # Standard authentication handler
  290.     #
  291.     # Accept user 'anonymous' if a password was
  292.     # provided which is at least similar to an
  293.     # fully qualified email address.
  294.  
  295.     if {(![string equal $user anonymous]) && (![string equal $user ftp])} {
  296.     return 0
  297.     }
  298.  
  299.     set pass [split $pass @]
  300.     if {[llength $pass] != 2} {
  301.     return 0
  302.     }
  303.  
  304.     set domain [split [lindex $pass 1] .]
  305.     if {[llength $domain] < 2} {
  306.     return 0
  307.     }
  308.  
  309.     return 1
  310. }
  311.  
  312. # ::ftpd::unixAuth --
  313. #
  314. #       Given a username and password, decides whether or not to accept the
  315. #       attempted login.  This is an alternative to the default ftpd
  316. #       authUsrCmd callback. By default it accepts the annonymous user and does
  317. #       some basic checking checking on the form of the password to see if it
  318. #       has the form of an email address.
  319. #
  320. # Arguments:
  321. #       user -                The name of the user that is attempting to
  322. #                             connect to the ftpd.
  323. #       pass -                The password of the user that is attempting to
  324. #                             connect to the ftpd.
  325. #
  326. # Results:
  327. #       Returns 0 if it rejects the login and 1 if it accepts the login.
  328. #
  329. # Side Effects:
  330. #       None.
  331.  
  332. proc ::ftpd::unixAuth {user pass} {
  333.  
  334.     variable passwords
  335.     array set password $passwords
  336.  
  337.     # Standard authentication handler
  338.     #
  339.     # Accept user 'anonymous' if a password was
  340.     # provided which is at least similar to an
  341.     # fully qualified email address.
  342.  
  343.     if {([llength $passwords] == 0) && (![catch {package require crypt}])} {
  344.         foreach file [list /etc/passwd /etc/shadow] {
  345.             if {([file exists $file]) && ([file readable $file])} {
  346.                 set fh [open $file r]
  347.                 set data [read $fh [file size $file]]
  348.                 foreach line [split $data \n] {
  349.                     foreach {username passwd uid gid dir sh} [split $line :] {
  350.                         if {[string length $passwd] > 2} {
  351.                             set password($username) $passwd
  352.                 } elseif {$passwd == ""} {
  353.                             set password($username) ""
  354.                 }
  355.                         break
  356.             }
  357.         }
  358.         }
  359.     }
  360.         set passwords [array get password]
  361.     }
  362.  
  363.     ::ftpd::Log debug $passwords
  364.  
  365.     if {[string equal $user anonymous] || [string equal $user ftp]} {
  366.  
  367.         set pass [split $pass @]
  368.         if {[llength $pass] != 2} {
  369.         return 0
  370.         }
  371.  
  372.         set domain [split [lindex $pass 1] .]
  373.         if {[llength $domain] < 2} {
  374.         return 0
  375.         }
  376.  
  377.         return 1
  378.     }
  379.  
  380.     if {[info exists password($user)]} {
  381.         if {$password($user) == ""} {
  382.             return 1
  383.     }
  384.         if {[string equal $password($user) [::crypt $pass $password($user)]]} {
  385.         return 1
  386.         }
  387.     }
  388.  
  389.     return 0
  390. }
  391.  
  392. # ::ftpd::server --
  393. #
  394. #       Creates a server socket at the specified port.
  395. #
  396. # Arguments:
  397. #       myaddr -              The domain-style name or numerical IP address of
  398. #                             the client-side network interface to use for the
  399. #                             connection. The name of the user that is
  400. #                             attempting to connect to the ftpd.
  401. #
  402. # Results:
  403. #       None.
  404. #
  405. # Side Effects:
  406. #       A listener is setup on the specified port which will call
  407. #       ::ftpd::accept when it is connected to.
  408.  
  409. proc ::ftpd::server {{myaddr {}}} {
  410.     variable port
  411.     if {[string length $myaddr]} {
  412.     socket -server ::ftpd::accept -myaddr $myaddr $port
  413.     } else {
  414.     socket -server ::ftpd::accept $port
  415.     }
  416.     return
  417. }
  418.  
  419. # ::ftpd::accept --
  420. #
  421. #       Checks if the connecting IP is authorized to connect or not.  If not
  422. #       the socket is closed and failure is logged.  Otherwise, a welcome is
  423. #       printed out, and a ftpd::read filevent is placed on the socket.
  424. #
  425. # Arguments:
  426. #       sock -                   The channel for this connection to the ftpd.
  427. #       ipaddr -              The client's IP address.
  428. #       client_port -         The client's port number.
  429. #
  430. # Results:
  431. #       None.
  432. #
  433. # Side Effects:
  434. #       Sets up a ftpd::read fileevent to trigger whenever the channel is
  435. #       readable.  Logs an error and closes the connection if the IP is
  436. #       not authorized to connect.
  437.  
  438. proc ::ftpd::accept {sock ipaddr client_port} {
  439.     upvar #0 ::ftpd::$sock data
  440.     variable welcome
  441.     variable cfg
  442.     variable cwd
  443.  
  444.     if {[info exist data]} {
  445.     unset data
  446.     }
  447.  
  448.     if {[hasCallback authIpCmd]} {
  449.     # Call out to authenticate the peer. A return value of 0 or an
  450.     # error causes the system to reject the connection. Everything
  451.     # else (with 1 prefered) leads to acceptance.
  452.  
  453.     set     cmd $cfg(authIpCmd)
  454.     lappend cmd $ipaddr
  455.  
  456.     set fail [catch {eval $cmd} res]
  457.  
  458.     if {$fail} {
  459.         Log error "AuthIp error: $res"
  460.     }
  461.     if {$fail || ($res == 0)} {
  462.         Log note "AuthIp: Access denied to $ipaddr"
  463.  
  464.         # Now: Close the connection. (Is there a standard response
  465.         # before closing down to signal the peer that we don't want
  466.         # to talk to it ? -> read RFC).
  467.  
  468.         close $sock
  469.         return
  470.     }
  471.  
  472.     # Accept the connection (for now, 'authUsrCmd' may revoke this
  473.     # decision).
  474.     }
  475.  
  476.     array set data [list \
  477.         access          0 \
  478.     state        command \
  479.     buffering    line \
  480.     cwd        "$cwd" \
  481.     mode        binary \
  482.         sock2           ""]
  483.  
  484.     fconfigure $sock -buffering line
  485.     fileevent  $sock readable [list ::ftpd::read $sock]
  486.     puts       $sock "220 $welcome"
  487.  
  488.     Log debug "Accept $ipaddr"
  489.     return
  490. }
  491.  
  492. # ::ftpd::read --
  493. #
  494. #       Checks the state of a channel and then reads a command from the
  495. #       channel if it is not at end of file yet.  If there is a command named
  496. #       ftpd::command::* where '*' is the all upper case name of the command,
  497. #       then that proc is called to handle the command with the remaining parts
  498. #       of the command that was read from the channel as arguments.
  499. #
  500. # Arguments:
  501. #       sock -                   The channel for this connection to the ftpd.
  502. #
  503. # Results:
  504. #       None.
  505. #
  506. # Side Effects:
  507. #       Runs the appropriate command depending on the state in the state
  508. #       machine, and the command that is specified.
  509.  
  510. proc ::ftpd::read {sock} {
  511.     upvar #0 ::ftpd::$sock data
  512.  
  513.     if {[eof $sock]} {
  514.     Finish $sock
  515.     return
  516.     }
  517.     switch -exact -- $data(state) {
  518.     command {
  519.         gets $sock command
  520.         set parts [split $command]
  521.         set cmd [string toupper [lindex  $parts 0]]
  522.         auto_load ::ftpd::command::$cmd
  523.             if {($data(access) == 0) && ((![info exists data(user)]) || \
  524.                 ($data(user) == "")) && (![string equal $cmd "USER"])} {
  525.                 if {[string equal $cmd "PASS"]} {
  526.             puts $sock "503 Login with USER first."
  527.                 } else {
  528.                     puts $sock "530 Please login with USER and PASS."
  529.         }
  530.         } elseif {($data(access) == 0) && (![string equal $cmd "PASS"]) \
  531.                     && (![string equal $cmd "USER"]) \
  532.                     && (![string equal $cmd "QUIT"])} {
  533.                 puts $sock "530 Please login with USER and PASS."
  534.         } elseif {[info command ::ftpd::command::$cmd] != ""} {
  535.         Log debug $command
  536.         ::ftpd::command::$cmd $sock [lrange $parts 1 end]
  537.         catch {flush $sock}
  538.         } else {
  539.         Log error "Unknown command: $cmd"
  540.         puts $sock "500 Unknown command $cmd"
  541.         }
  542.     }
  543.     default {
  544.         error "Unknown state \"$data(state)\""
  545.     }
  546.     }
  547.     return
  548. }
  549.  
  550. # ::ftpd::Finish --
  551. #
  552. #       Closes the socket connection between the ftpd and client.
  553. #
  554. # Arguments:
  555. #       sock -                   The channel for this connection to the ftpd.
  556. #
  557. # Results:
  558. #       None.
  559. #
  560. # Side Effects:
  561. #       The channel is closed.
  562.  
  563. proc ::ftpd::Finish {sock} {
  564.     close $sock
  565.     return
  566. }
  567.  
  568. # ::ftpd::FinishData --
  569. #
  570. #       Closes the data socket connection that is created when the 'PORT'
  571. #       command is recieved.
  572. #
  573. # Arguments:
  574. #       sock -                   The channel for this connection to the ftpd.
  575. #
  576. # Results:
  577. #       None.
  578. #
  579. # Side Effects:
  580. #       The data channel is closed.
  581.  
  582. proc ::ftpd::FinishData {sock} {
  583.     upvar #0 ::ftpd::$sock data
  584.     catch {close $data(sock2)}
  585.     set   data(sock2) {}
  586.     return
  587. }
  588.  
  589. # ::ftpd::Fs --
  590. #
  591. #       The general filesystem command.  Used as an intermediary for filesystem
  592. #       access to allow alternate (virtual, etc.) filesystems to be used.  The
  593. #       ::ftpd::Fs command will call out to the fsCmd callback with the
  594. #       subcommand and arguments that are passed to it.
  595. #
  596. # The fsCmd callback is called in the following ways:
  597. #
  598. # <cmd> append <path>
  599. # <cmd> delete <path> <channel-to-write-to>
  600. # <cmd> dlist <path> <style> <channel-to-write-dir-list-to>
  601. # <cmd> exists <path>
  602. # <cmd> mkdir <path> <channel-to-write-to>
  603. # <cmd> mtime <path> <channel-to-write-mtime-to>
  604. # <cmd> permissions <path>
  605. # <cmd> rename <path> <newpath> <channel-to-write-to>
  606. # <cmd> retr  <path>
  607. # <cmd> rmdir <path> <channel-to-write-to>
  608. # <cmd> size  <path> <channel-to-write-size-to>
  609. # <cmd> store <path>
  610. #
  611. # Arguments:
  612. #       command -                The filesystem command (one of dlist, retr, or
  613. #                                store).  'dlist' will list files in a
  614. #                                directory, 'retr' will get a channel to
  615. #                                to read the specified file from, 'store'
  616. #                                will return the channel to write to, and
  617. #                                'mtime' will print the modification time.
  618. #       path -                   The file name or directory to read, write, or
  619. #                                list.
  620. #       args -                   Additional arguments for filesystem commands.
  621. #                                Currently this is used by 'dlist' which
  622. #                                has two additional arguments 'style' and
  623. #                                'channel-to-write-dir-list-to'. It is also
  624. #                                used by 'size' and 'mtime' which have one
  625. #                                additional argument 'channel-to-write-to'.
  626. #
  627. # Results:
  628. #       For a 'appe', 'retr', or 'stor' a channel is returned. For 'exists'
  629. #       a 1 is returned if the path exists, and is not a directory.  Otherwise
  630. #       a 0 is returned. For 'permissions' the octal file permissions (i.e.
  631. #       the 'file stat' mode) are returned.
  632. #
  633. # Side Effects:
  634. #       For 'dlist' a directory listing for the specified path is written to
  635. #       the specified channel.  For 'mtime' the modification time is written
  636. #       or an error is thrown.  An error is thrown if there is no fsCmd
  637. #       callback configured for the ftpd.
  638.  
  639. proc ::ftpd::Fs {command path args} {
  640.     variable cfg
  641.  
  642.     if {![hasCallback fsCmd]} {
  643.     error "-fsCmd must not be empty, need a way to access files."
  644.     }
  645.  
  646.     return [eval [list $cfg(fsCmd) $command $path] $args]
  647. }
  648.  
  649. # Create a namespace to hold one proc for each ftp command (in upper case
  650. # letters) that is supported by the ftp daemon.  The existance of a proc
  651. # in this namespace is the way that the list of supported commands is
  652. # determined, and the procs in this namespace are invoked to handle the
  653. # ftp commands with the same name as the procs.
  654.  
  655. namespace eval ::ftpd::command {
  656.     namespace export *
  657. }
  658.  
  659. # ::ftpd::command::ABOR --
  660. #
  661. #       Handle the ABOR ftp command.  Closes the data socket if it
  662. #       is open, and then prints the appropriate success message.
  663. #
  664. # Arguments:
  665. #       sock -                   The channel for this connection to the ftpd.
  666. #       list -                   The arguments to the APPE command.
  667. #
  668. # Results:
  669. #       None.
  670. #
  671. # Side Effects:
  672. #       The data is copied to from the socket data(sock2) to the
  673. #       writable channel to create a file.
  674.  
  675. proc ::ftpd::command::ABOR {sock list} {
  676.  
  677.     ::ftpd::FinishData $sock
  678.     puts $sock "225 ABOR command successful."
  679.  
  680.     return
  681. }
  682.  
  683. # ::ftpd::command::APPE --
  684. #
  685. #       Handle the APPE ftp command.  Gets a writable channel for the file
  686. #       specified from ::ftpd::Fs and copies the data from data(sock2) to
  687. #       the writable channel.  If the filename already exists the data is
  688. #       appended, otherwise the file is created and then written.
  689. #
  690. # Arguments:
  691. #       sock -                   The channel for this connection to the ftpd.
  692. #       list -                   The arguments to the APPE command.
  693. #
  694. # Results:
  695. #       None.
  696. #
  697. # Side Effects:
  698. #       The data is copied to from the socket data(sock2) to the
  699. #       writable channel to create a file.
  700.  
  701. proc ::ftpd::command::APPE {sock list} {
  702.     upvar #0 ::ftpd::$sock data
  703.  
  704.     set filename [lindex $list 0]
  705.     set path [file join $data(cwd) [string trimleft $filename /]]
  706.     if {[::ftpd::hasCallback authFileCmd]} {
  707.         set cmd $::ftpd::cfg(authFileCmd)
  708.         lappend cmd $data(user) $path write
  709.         if {[eval $cmd] == 0} {
  710.         puts $sock "550 $filename: Permission denied"
  711.             return
  712.         }
  713.     }
  714.  
  715. #
  716. # Patched Mark O'Connor
  717. #
  718.     if {![catch {::ftpd::Fs append $path $data(mode)} f]} {
  719.     puts $sock "150 Copy Started ($data(mode))"
  720.     fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
  721.     } else {
  722.     puts $sock "500 Copy Failed: $path\n$f"
  723.     ::ftpd::FinishData $sock
  724.     }
  725.     return
  726. }
  727.  
  728. # ::ftpd::command::CDUP --
  729. #
  730. #       Handle the CDUP ftp command.  Change the current working directory to
  731. #       the directory above the current working directory.
  732. #
  733. # Arguments:
  734. #       sock -                   The channel for this connection to the ftpd.
  735. #       list -                   The arguments to the CDUP command.
  736. #
  737. # Results:
  738. #       None.
  739. #
  740. # Side Effects:
  741. #       Changes the data(cwd) to the appropriate directory.
  742.  
  743. proc ::ftpd::command::CDUP {sock list} {
  744.     upvar #0 ::ftpd::$sock data
  745.  
  746.     set data(cwd) [file dirname $data(cwd)]
  747.     puts $sock "200 CDUP command successful."
  748.     return
  749. }
  750.  
  751. # ::ftpd::command::CWD --
  752. #
  753. #       Handle the CWD ftp command.  Change the current working directory.
  754. #
  755. # Arguments:
  756. #       sock -                   The channel for this connection to the ftpd.
  757. #       list -                   The arguments to the CWD command.
  758. #
  759. # Results:
  760. #       None.
  761. #
  762. # Side Effects:
  763. #       Changes the data(cwd) to the appropriate directory.
  764.  
  765. proc ::ftpd::command::CWD {sock list} {
  766.     upvar #0 ::ftpd::$sock data
  767.  
  768.     set relativepath [lindex $list 0]
  769.  
  770.     if {[string equal $relativepath .]} {
  771.     puts $sock "250 CWD command successful."
  772.     return
  773.     }
  774.  
  775.     if {[string equal $relativepath ..]} {
  776.     set data(cwd) [file dirname $data(cwd)]
  777.     puts $sock "250 CWD command successful."
  778.     return
  779.     }
  780.  
  781.     set data(cwd) [file join $data(cwd) $relativepath]
  782.     puts $sock "250 CWD command successful."
  783.     return
  784. }
  785.  
  786. # ::ftpd::command::DELE --
  787. #
  788. #       Handle the DELE ftp command.  Delete the specified file.
  789. #
  790. # Arguments:
  791. #       sock -                   The channel for this connection to the ftpd.
  792. #       list -                   The arguments to the DELE command.
  793. #
  794. # Results:
  795. #       None.
  796. #
  797. # Side Effects:
  798. #       The specified file is deleted.
  799.  
  800. proc ::ftpd::command::DELE {sock list} {
  801.     upvar #0 ::ftpd::$sock data
  802.  
  803.     set filename [lindex $list 0]
  804.     set path [file join $data(cwd) [string trimleft $filename /]]
  805.     if {[::ftpd::hasCallback authFileCmd]} {
  806.         set cmd $::ftpd::cfg(authFileCmd)
  807.         lappend cmd $data(user) $path write
  808.         if {[eval $cmd] == 0} {
  809.         puts $sock "550 $filename: Permission denied"
  810.             return
  811.         }
  812.     }
  813.  
  814.     if {[catch {::ftpd::Fs delete $path $sock} msg]} {
  815.     puts $sock "500 DELE Failed: $path $msg"
  816.     }
  817.     return
  818. }
  819.  
  820. # ::ftpd::command::HELP --
  821. #
  822. #       Handle the HELP ftp command.  Display a list of commands
  823. #       or syntax information about the supported commands.
  824. #
  825. # Arguments:
  826. #       sock -                   The channel for this connection to the ftpd.
  827. #       list -                   The arguments to the HELP command.
  828. #
  829. # Results:
  830. #       None.
  831. #
  832. # Side Effects:
  833. #       Displays a helpful message.
  834.  
  835. proc ::ftpd::command::HELP {sock list} {
  836.     upvar #0 ::ftpd::$sock data
  837.  
  838.     if {[llength $list] > 0} {
  839.         set command [string toupper [lindex $list 0]]
  840.         if {![info exists ::ftpd::commands($command)]} {
  841.             puts $sock "502 Unknown command '$command'."
  842.     } elseif {[info commands ::ftpd::command::$command] == ""} {
  843.             puts $sock "214 $command\t$::ftpd::commands($command)"
  844.     } else {
  845.         puts $sock "214 Syntax: $::ftpd::commands($command)"
  846.         }
  847.     } else {
  848.         set commandList [lsort [array names ::ftpd::commands]]
  849.         puts $sock "214-The following commands are recognized (* =>'s unimplemented)."
  850.         set i 1
  851.         foreach commandName $commandList {
  852.             if {[info commands ::ftpd::command::$commandName] == ""} {
  853.                 puts -nonewline $sock [format " %-7s" "${commandName}*"]
  854.         } else {
  855.                 puts -nonewline $sock [format " %-7s" $commandName]
  856.         }
  857.             if {($i % 8) == 0} {
  858.                 puts $sock ""
  859.         }
  860.             incr i
  861.     }
  862.         incr i -1
  863.         if {($i % 8) != 0} {
  864.             puts $sock ""
  865.     }
  866.         puts $sock "214 Direct comments to $::ftpd::contact."
  867.     }
  868.  
  869.     return
  870. }
  871.  
  872. # ::ftpd::command::LIST --
  873. #
  874. #       Handle the LIST ftp command.  Lists the names of the files in the
  875. #       specified path.
  876. #
  877. # Arguments:
  878. #       sock -                   The channel for this connection to the ftpd.
  879. #       list -                   The arguments to the LIST command.
  880. #
  881. # Results:
  882. #       None.
  883. #
  884. # Side Effects:
  885. #       A listing of files is written to the socket.
  886.  
  887. proc ::ftpd::command::LIST {sock list} {
  888.     set filename [lindex $list 0]
  889.     ::ftpd::List $sock $filename list
  890.     return
  891. }
  892.  
  893. # ::ftpd::command::MDTM --
  894. #
  895. #       Handle the MDTM ftp command.  Prints the modification time of the
  896. #       specified file to the socket.
  897. #
  898. # Arguments:
  899. #       sock -                   The channel for this connection to the ftpd.
  900. #       list -                   The arguments to the MDTM command.
  901. #
  902. # Results:
  903. #       None.
  904. #
  905. # Side Effects:
  906. #       Prints the modification time of the specified file to the socket.
  907.  
  908. proc ::ftpd::command::MDTM {sock list} {
  909.     upvar #0 ::ftpd::$sock data
  910.  
  911.     set filename [lindex $list 0]
  912.     set path [file join $data(cwd) [string trimleft $filename /]]
  913.     if {[catch {::ftpd::Fs mtime $path $sock} msg]} {
  914.     puts $sock "500 MDTM Failed: $path $msg"
  915.     ::ftpd::FinishData $sock
  916.     }
  917.     return
  918. }
  919.  
  920. # ::ftpd::command::MKD --
  921. #
  922. #       Handle the MKD ftp command.  Create the specified directory.
  923. #
  924. # Arguments:
  925. #       sock -                   The channel for this connection to the ftpd.
  926. #       list -                   The arguments to the MKD command.
  927. #
  928. # Results:
  929. #       None.
  930. #
  931. # Side Effects:
  932. #       The directory specified by $path (if it exists) is deleted.
  933.  
  934. proc ::ftpd::command::MKD {sock list} {
  935.     upvar #0 ::ftpd::$sock data
  936.  
  937.     set filename [lindex $list 0]
  938.     set path [file join $data(cwd) [string trimleft $filename /]]
  939.  
  940.     if {[::ftpd::hasCallback authFileCmd]} {
  941.         set cmd $::ftpd::cfg(authFileCmd)
  942.         lappend cmd $data(user) $path write
  943.         if {[eval $cmd] == 0} {
  944.         puts $sock "550 $filename: Permission denied"
  945.             return
  946.         }
  947.     }
  948.  
  949.     if {[catch {::ftpd::Fs mkdir $path $sock} f]} {
  950.     puts $sock "500 MKD Failed: $path $f"
  951.     }
  952.     return
  953. }
  954.  
  955. # ::ftpd::command::NOOP --
  956. #
  957. #       Handle the NOOP ftp command.  Do nothing.
  958. #
  959. # Arguments:
  960. #       sock -                   The channel for this connection to the ftpd.
  961. #       list -                   The arguments to the NOOP command.
  962. #
  963. # Results:
  964. #       None.
  965. #
  966. # Side Effects:
  967. #       Prints the proper NOOP response.
  968.  
  969. proc ::ftpd::command::NOOP {sock list} {
  970.  
  971.     puts $sock "200 NOOP command successful."
  972.     return
  973. }
  974.  
  975. # ::ftpd::command::NLST --
  976. #
  977. #       Handle the NLST ftp command.  Lists the full file stat of all of the
  978. #       files that are in the specified path.
  979. #
  980. # Arguments:
  981. #       sock -                   The channel for this connection to the ftpd.
  982. #       list -                   The arguments to the NLST command.
  983. #
  984. # Results:
  985. #       None.
  986. #
  987. # Side Effects:
  988. #       A listing of file stats is written to the socket.
  989.  
  990. proc ::ftpd::command::NLST {sock list} {
  991.     set filename [lindex $list 0]
  992.     ::ftpd::List $sock $filename nlst
  993.     return
  994. }
  995.  
  996. # ::ftpd::command::PASS --
  997. #
  998. #       Handle the PASS ftp command.  Check whether the specified user
  999. #       and password are allowed to log in (using the authUsrCmd).  If
  1000. #       they are allowed to log in, they are allowed to continue.  If
  1001. #       not ::ftpd::Log is used to log and error, and an "Access Denied"
  1002. #       error is sent back.
  1003. #
  1004. # Arguments:
  1005. #       sock -                   The channel for this connection to the ftpd.
  1006. #       list -                   The arguments to the PASS command.
  1007. #
  1008. # Results:
  1009. #       None.
  1010. #
  1011. # Side Effects:
  1012. #       The user is accepted, or an error is logged and the user/password is
  1013. #       denied..
  1014.  
  1015. proc ::ftpd::command::PASS {sock list} {
  1016.     upvar #0 ::ftpd::$sock data
  1017.  
  1018.     if {[llength $list] == 0} {
  1019.         puts $sock "530 Please login with USER and PASS."
  1020.         return
  1021.     }
  1022.     set data(pass) [lindex $list 0]
  1023.  
  1024.     ::ftpd::Log debug "pass <$data(pass)>"
  1025.  
  1026.     if {![::ftpd::hasCallback authUsrCmd]} {
  1027.     error "-authUsrCmd must not be empty, need a way to authenticate the user."
  1028.     }
  1029.  
  1030.     # Call out to authenticate the user. A return value of 0 or an
  1031.     # error causes the system to reject the connection. Everything
  1032.     # else (with 1 prefered) leads to acceptance.
  1033.     
  1034.     set cmd $::ftpd::cfg(authUsrCmd)
  1035.     lappend cmd $data(user) $data(pass)
  1036.  
  1037.     set fail [catch {eval $cmd} res]
  1038.  
  1039.     if {$fail} {
  1040.     ::ftpd::Log error "AuthUsr error: $res"
  1041.     }
  1042.     if {$fail || ($res == 0)} {
  1043.     ::ftpd::Log note "AuthUsr: Access denied to <$data(user)> <$data(pass)>."
  1044.     unset data(user)
  1045.         unset data(pass)
  1046.         puts $sock "551 Access Denied"
  1047.     } else {
  1048.     puts $sock "200 OK"
  1049.     set data(access) 1
  1050.     }
  1051.     return
  1052. }
  1053.  
  1054. # ::ftpd::command::PORT --
  1055. #
  1056. #       Handle the PORT ftp command.  Create a new socket with the specified
  1057. #       paramaters.
  1058. #
  1059. # Arguments:
  1060. #       sock -                   The channel for this connection to the ftpd.
  1061. #       list -                   The arguments to the PORT command.
  1062. #
  1063. # Results:
  1064. #       None.
  1065. #
  1066. # Side Effects:
  1067. #       A new socket, data(sock2), is opened.
  1068.  
  1069. proc ::ftpd::command::PORT {sock list} {
  1070.     upvar #0 ::ftpd::$sock data
  1071.     set x [split [lindex $list 0] ,]
  1072.  
  1073.     ::ftpd::FinishData $sock
  1074.  
  1075.     set data(sock2) [socket [join [lrange $x 0 3] .] \
  1076.     [expr {([lindex $x 4] << 8) | [lindex $x 5]}]]
  1077.     fconfigure $data(sock2) -translation $data(mode)
  1078.     puts $sock "200 PORT OK"
  1079.     return
  1080. }
  1081.  
  1082. # ::ftpd::command::PWD --
  1083. #
  1084. #       Handle the PWD ftp command.  Prints the current working directory to
  1085. #       the socket.
  1086. #
  1087. # Arguments:
  1088. #       sock -                   The channel for this connection to the ftpd.
  1089. #       list -                   The arguments to the PWD command.
  1090. #
  1091. # Results:
  1092. #       None.
  1093. #
  1094. # Side Effects:
  1095. #       Prints the current working directory to the socket.
  1096.  
  1097. proc ::ftpd::command::PWD {sock list} {
  1098.     upvar #0 ::ftpd::$sock data
  1099.     ::ftpd::Log debug $data(cwd)
  1100.     puts $sock "257 \"$data(cwd)\" is current directory."
  1101.     return
  1102. }
  1103.  
  1104. # ::ftpd::command::QUIT --
  1105. #
  1106. #       Handle the QUIT ftp command.  Closes the socket.
  1107. #
  1108. # Arguments:
  1109. #       sock -                   The channel for this connection to the ftpd.
  1110. #       list -                   The arguments to the PWD command.
  1111. #
  1112. # Results:
  1113. #       None.
  1114. #
  1115. # Side Effects:
  1116. #       Closes the connection.
  1117.  
  1118. proc ::ftpd::command::QUIT {sock list} {
  1119.     ::ftpd::Log note "Closed $sock"
  1120.     puts $sock "221 Goodbye."
  1121.     close $sock
  1122.     # FRINK: nocheck
  1123.     unset ::ftpd::$sock
  1124.     return
  1125. }
  1126.  
  1127. # ::ftpd::command::REIN --
  1128. #
  1129. #       Handle the REIN ftp command. This command terminates a USER, flushing
  1130. #       all I/O and account information, except to allow any transfer in
  1131. #       progress to be completed.  All parameters are reset to the default
  1132. #       settings and the control connection is left open.
  1133. #
  1134. # Arguments:
  1135. #       sock -                   The channel for this connection to the ftpd.
  1136. #       list -                   The arguments to the REIN command.
  1137. #
  1138. # Results:
  1139. #       None.
  1140. #
  1141. # Side Effects:
  1142. #       The file specified by $path (if it exists) is copied to the socket
  1143. #       data(sock2) otherwise a 'Copy Failed' message is output.
  1144.  
  1145. proc ::ftpd::command::REIN {sock list} {
  1146.     upvar #0 ::ftpd::$sock data
  1147.  
  1148.     ::ftpd::FinishData $sock
  1149.  
  1150.     # Reinitialize the user and connection data.
  1151.  
  1152.     array set data [list \
  1153.         access          0 \
  1154.     state        command \
  1155.     buffering    line \
  1156.     cwd        "$::ftpd::cwd" \
  1157.     mode        binary \
  1158.         sock2           ""]
  1159.  
  1160.     return
  1161. }
  1162.  
  1163. # ::ftpd::command::RETR --
  1164. #
  1165. #       Handle the RETR ftp command.  Gets a readable channel for the file
  1166. #       specified from ::ftpd::Fs and copies the file to second socket 
  1167. #       data(sock2).
  1168. #
  1169. # Arguments:
  1170. #       sock -                   The channel for this connection to the ftpd.
  1171. #       list -                   The arguments to the RETR command.
  1172. #
  1173. # Results:
  1174. #       None.
  1175. #
  1176. # Side Effects:
  1177. #       The file specified by $path (if it exists) is copied to the socket
  1178. #       data(sock2) otherwise a 'Copy Failed' message is output.
  1179.  
  1180. proc ::ftpd::command::RETR {sock list} {
  1181.     upvar #0 ::ftpd::$sock data
  1182.  
  1183.     set filename [lindex $list 0]
  1184.     set path [file join $data(cwd) [string trimleft $filename /]]
  1185.  
  1186.     if {[::ftpd::hasCallback authFileCmd]} {
  1187.         set cmd $::ftpd::cfg(authFileCmd)
  1188.         lappend cmd $data(user) $path read
  1189.         if {[eval $cmd] == 0} {
  1190.         puts $sock "550 $filename: Permission denied"
  1191.             return
  1192.         }
  1193.     }
  1194.  
  1195. #
  1196. # Patched Mark O'Connor
  1197. #
  1198.     if {![catch {::ftpd::Fs retr $path $data(mode)} f]} {
  1199.     puts $sock "150 Copy Started ($data(mode))"
  1200.     fcopy $f $data(sock2) -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
  1201.     } else {
  1202.     puts $sock "500 Copy Failed: $path\n$f"
  1203.     ::ftpd::FinishData $sock
  1204.     }
  1205.     return
  1206. }
  1207.  
  1208. # ::ftpd::command::RMD --
  1209. #
  1210. #       Handle the RMD ftp command.  Remove the specified directory.
  1211. #
  1212. # Arguments:
  1213. #       sock -                   The channel for this connection to the ftpd.
  1214. #       list -                   The arguments to the RMD command.
  1215. #
  1216. # Results:
  1217. #       None.
  1218. #
  1219. # Side Effects:
  1220. #       The directory specified by $path (if it exists) is deleted.
  1221.  
  1222. proc ::ftpd::command::RMD {sock list} {
  1223.     upvar #0 ::ftpd::$sock data
  1224.  
  1225.     set filename [lindex $list 0]
  1226.     set path [file join $data(cwd) [string trimleft $filename /]]
  1227.  
  1228.     if {[::ftpd::hasCallback authFileCmd]} {
  1229.         set cmd $::ftpd::cfg(authFileCmd)
  1230.         lappend cmd $data(user) $path write
  1231.         if {[eval $cmd] == 0} {
  1232.         puts $sock "550 $filename: Permission denied"
  1233.             return
  1234.         }
  1235.     }
  1236.     if {[catch {::ftpd::Fs rmdir $path $sock} f]} {
  1237.     puts $sock "500 RMD Failed: $path $f"
  1238.     }
  1239.     return
  1240. }
  1241.  
  1242. # ::ftpd::command::RNFR --
  1243. #
  1244. #       Handle the RNFR ftp command.  Stores the name of the file to rename
  1245. #       from.
  1246. #
  1247. # Arguments:
  1248. #       sock -                   The channel for this connection to the ftpd.
  1249. #       list -                   The arguments to the RNFR command.
  1250. #
  1251. # Results:
  1252. #       None.
  1253. #
  1254. # Side Effects:
  1255. #       If the file specified by $path exists, then store the name and request
  1256. #       the next name.
  1257.  
  1258. proc ::ftpd::command::RNFR {sock list} {
  1259.     upvar #0 ::ftpd::$sock data
  1260.  
  1261.     set filename [lindex $list 0]
  1262.     set path [file join $data(cwd) [string trimleft $filename /]]
  1263.  
  1264.     if {[file exists $path]} {
  1265.         if {[::ftpd::hasCallback authFileCmd]} {
  1266.             set cmd $::ftpd::cfg(authFileCmd)
  1267.             lappend cmd $data(user) $path write
  1268.             if {[eval $cmd] == 0} {
  1269.             puts $sock "550 $filename: Permission denied"
  1270.                 return
  1271.             }
  1272.     }
  1273.  
  1274.         puts $sock "350 File exists, ready for destination name"
  1275.         set data(renameFrom) $path
  1276.     } else {
  1277.         puts $sock "550 $path: No such file or directory."
  1278.     }
  1279.     return
  1280. }
  1281.  
  1282. # ::ftpd::command::RNTO --
  1283. #
  1284. #       Handle the RNTO ftp command.  Renames the file specified by 'RNFR' if
  1285. #       one was specified.
  1286. #
  1287. # Arguments:
  1288. #       sock -                   The channel for this connection to the ftpd.
  1289. #       list -                   The arguments to the RNTO command.
  1290. #
  1291. # Results:
  1292. #       None.
  1293. #
  1294. # Side Effects:
  1295. #       The specified file is renamed.
  1296.  
  1297. proc ::ftpd::command::RNTO {sock list} {
  1298.  
  1299.     if {[llength $list] == 0} {
  1300.         puts $sock "500 'RNTO': command not understood."
  1301.         return
  1302.     }
  1303.     set filename [lindex $list 0]
  1304.     set path [file join $data(cwd) [string trimleft $filename /]]
  1305.  
  1306.     if {![info exists data(renameFrom)]} {
  1307.         puts $sock "503 Bad sequence of commands."
  1308.         return
  1309.     }
  1310.     if {[::ftpd::hasCallback authFileCmd]} {
  1311.         set cmd $::ftpd::cfg(authFileCmd)
  1312.         lappend cmd $data(user) $path write
  1313.         if {[eval $cmd] == 0} {
  1314.             puts $sock "550 $filename: Permission denied"
  1315.             return
  1316.         }
  1317.     }
  1318.  
  1319.  
  1320.     if {![catch {::ftpd::Fs rename $data(renameFrom) $path} msg]} {
  1321.         unset data(renameFrom)
  1322.     } else {
  1323.         unset data(renameFrom)
  1324.         puts $sock "500 'RNTO': command not understood."
  1325.     }
  1326.     return
  1327. }
  1328.  
  1329. # ::ftpd::command::SIZE --
  1330. #
  1331. #       Handle the SIZE ftp command.  Prints the modification time of the
  1332. #       specified file to the socket.
  1333. #
  1334. # Arguments:
  1335. #       sock -                   The channel for this connection to the ftpd.
  1336. #       list -                   The arguments to the MDTM command.
  1337. #
  1338. # Results:
  1339. #       None.
  1340. #
  1341. # Side Effects:
  1342. #       Prints the size of the specified file to the socket.
  1343.  
  1344. proc ::ftpd::command::SIZE {sock list} {
  1345.     upvar #0 ::ftpd::$sock data
  1346.  
  1347.     set filename [lindex $list 0]
  1348.     set path [file join $data(cwd) [string trimleft $filename /]]
  1349.     if {[catch {::ftpd::Fs size $path $sock} msg]} {
  1350.     puts $sock "500 SIZE Failed: $path $msg"
  1351.     ::ftpd::FinishData $sock
  1352.     }
  1353.     return
  1354. }
  1355.  
  1356. # ::ftpd::command::STOR --
  1357. #
  1358. #       Handle the STOR ftp command.  Gets a writable channel for the file
  1359. #       specified from ::ftpd::Fs and copies the data from data(sock2) to
  1360. #       the writable channel.
  1361. #
  1362. # Arguments:
  1363. #       sock -                   The channel for this connection to the ftpd.
  1364. #       list -                   The arguments to the STOR command.
  1365. #
  1366. # Results:
  1367. #       None.
  1368. #
  1369. # Side Effects:
  1370. #       The data is copied to from the socket data(sock2) to the
  1371. #       writable channel to create a file.
  1372.  
  1373. proc ::ftpd::command::STOR {sock list} {
  1374.     upvar #0 ::ftpd::$sock data
  1375.  
  1376.     set filename [lindex $list 0]
  1377.     set path [file join $data(cwd) [string trimleft $filename /]]
  1378.     if {[::ftpd::hasCallback authFileCmd]} {
  1379.         set cmd $::ftpd::cfg(authFileCmd)
  1380.         lappend cmd $data(user) $path write
  1381.         if {[eval $cmd] == 0} {
  1382.         puts $sock "550 $filename: Permission denied"
  1383.             return
  1384.         }
  1385.     }
  1386.  
  1387. #
  1388. # Patched Mark O'Connor
  1389. #
  1390.     if {![catch {::ftpd::Fs store $path $data(mode)} f]} {
  1391.     puts $sock "150 Copy Started ($data(mode))"
  1392.     fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
  1393.     } else {
  1394.     puts $sock "500 Copy Failed: $path\n$f"
  1395.     ::ftpd::FinishData $sock
  1396.     }
  1397.     return
  1398. }
  1399.  
  1400. # ::ftpd::command::STOU --
  1401. #
  1402. #       Handle the STOR ftp command.  Gets a writable channel for the file
  1403. #       specified from ::ftpd::Fs and copies the data from data(sock2) to
  1404. #       the writable channel.
  1405. #
  1406. # Arguments:
  1407. #       sock -                   The channel for this connection to the ftpd.
  1408. #       list -                   The arguments to the STOU command.
  1409. #
  1410. # Results:
  1411. #       None.
  1412. #
  1413. # Side Effects:
  1414. #       The data is copied to from the socket data(sock2) to the
  1415. #       writable channel to create a file.
  1416.  
  1417. proc ::ftpd::command::STOU {sock list} {
  1418.     upvar #0 ::ftpd::$sock data
  1419.  
  1420.     set filename [lindex $list 0]
  1421.     set path [file join $data(cwd) [string trimleft $filename /]]
  1422.     if {[::ftpd::hasCallback authFileCmd]} {
  1423.         set cmd $::ftpd::cfg(authFileCmd)
  1424.         lappend cmd $data(user) $path write
  1425.         if {[eval $cmd] == 0} {
  1426.         puts $sock "550 $filename: Permission denied"
  1427.             return
  1428.         }
  1429.     }
  1430.     
  1431.     set file $path
  1432.     set i 0
  1433.     while {[::ftpd::Fs exists $file]} {
  1434.         set file "$path.$i"
  1435.         incr i
  1436.     }
  1437.  
  1438. #
  1439. # Patched Mark O'Connor
  1440. #
  1441.     if {![catch {::ftpd::Fs store $file $data(mode)} f]} {
  1442.     puts $sock "150 Copy Started ($data(mode))"
  1443.     fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f $file]
  1444.     } else {
  1445.     puts $sock "500 Copy Failed: $path\n$f"
  1446.     ::ftpd::FinishData $sock
  1447.     }
  1448.     return
  1449. }
  1450.  
  1451. # ::ftpd::command::SYST --
  1452. #
  1453. #       Handle the SYST ftp command.  Print the system information.
  1454. #
  1455. # Arguments:
  1456. #       sock -                   The channel for this connection to the ftpd.
  1457. #       list -                   The arguments to the SYST command.
  1458. #
  1459. # Results:
  1460. #       None.
  1461. #
  1462. # Side Effects:
  1463. #       Prints the system information.
  1464.  
  1465. proc ::ftpd::command::SYST {sock list} {
  1466.     upvar #0 ::ftpd::$sock data
  1467.  
  1468.     global tcl_platform
  1469.  
  1470.     if {[string equal $tcl_platform(platform) "unix"]} {
  1471.         set platform UNIX
  1472.     } elseif {[string equal $tcl_platform(platform) "windows"]} {
  1473.         set platform WIN32
  1474.     } elseif {[string equal $tcl_platform(platform) "macintosh"]} {
  1475.         set platform MACOS
  1476.     } else {
  1477.         set platform UNKNOWN
  1478.     }
  1479.     set version [string toupper $tcl_platform(os)]
  1480.     puts $sock "215 $platform Type: L8 Version: $version"
  1481.  
  1482.     return
  1483. }
  1484.  
  1485. # ::ftpd::command::TYPE --
  1486. #
  1487. #       Handle the TYPE ftp command.  Sets up the proper translation mode on
  1488. #       the data socket data(sock2)
  1489. #
  1490. # Arguments:
  1491. #       sock -                   The channel for this connection to the ftpd.
  1492. #       list -                   The arguments to the TYPE command.
  1493. #
  1494. # Results:
  1495. #       None.
  1496. #
  1497. # Side Effects:
  1498. #       The translation mode of the data channel is changed to the appropriate
  1499. #       mode.
  1500.  
  1501. proc ::ftpd::command::TYPE {sock list} {
  1502.     upvar #0 ::ftpd::$sock data
  1503.     set type [lindex $list 0]
  1504.     if {[string compare i [string tolower $type]] == 0} {
  1505.     set data(mode) binary
  1506.     } else {
  1507.     set data(mode) auto
  1508.     }
  1509.  
  1510.     if {$data(sock2) != {}} {
  1511.     fconfigure $data(sock2) -translation $data(mode)
  1512.     }
  1513.     puts $sock "200 Type set to $type."
  1514.     return
  1515. }
  1516.  
  1517. # ::ftpd::command::USER --
  1518. #
  1519. #       Handle the USER ftp command.  Store the username, and request a
  1520. #       password.
  1521. #
  1522. # Arguments:
  1523. #       sock -                   The channel for this connection to the ftpd.
  1524. #       list -                   The arguments to the USER command.
  1525. #
  1526. # Results:
  1527. #       None.
  1528. #
  1529. # Side Effects:
  1530. #       A message is printed asking for the password.
  1531.  
  1532. proc ::ftpd::command::USER {sock list} {
  1533.     upvar #0 ::ftpd::$sock data
  1534.  
  1535.     if {[llength $list] == 0} {
  1536.         puts $sock "530 Please login with USER and PASS."
  1537.         return
  1538.     }
  1539.     set data(user) [lindex $list 0]
  1540.     puts $sock "331 Password Required"
  1541.  
  1542.     ::ftpd::Log debug "user <$data(user)>"
  1543.     return
  1544. }
  1545.  
  1546. # ::ftpd::GetDone --
  1547. #
  1548. #       The fcopy command callback for both the RETR and STOR calls.  Called
  1549. #       after the fcopy completes.
  1550. #
  1551. # Arguments:
  1552. #       sock -                   The channel for this connection to the ftpd.
  1553. #       sock2 -                  The data socket data(sock2).
  1554. #       f -                      The file channel.
  1555. #       filename -               The name of the unique file (if a unique
  1556. #                                transfer was requested), and the empty string
  1557. #                                otherwise
  1558. #       bytes -                  The number of bytes that were copied.
  1559. #       err -                    Passed if an error occurred during the fcopy.
  1560. #
  1561. # Results:
  1562. #       None.
  1563. #
  1564. # Side Effects:
  1565. #       The open file channel is closed and a 'complete' message is printed to
  1566. #       the socket.
  1567.  
  1568. proc ::ftpd::GetDone {sock sock2 f filename bytes {err {}}} {
  1569.     upvar #0 ::ftpd::$sock data
  1570.     close $f
  1571.     FinishData $sock
  1572.  
  1573.     if {[string length $err]} {
  1574.     puts $sock "226- $err"
  1575.     } elseif {$filename == ""} {
  1576.         puts $sock "226 Transfer complete ($bytes bytes)"
  1577.     } else {
  1578.         puts $sock "226 Transfer complete (unique file name: $filename)."
  1579.     }
  1580.     Log debug "GetDone $f $sock2 $bytes bytes filename: $filename"
  1581.     return
  1582. }
  1583.  
  1584. # ::ftpd::List --
  1585. #
  1586. #       Handle the NLST and LIST ftp commands.  Shared command to do the
  1587. #       actual listing of files.
  1588. #
  1589. # Arguments:
  1590. #       sock -                   The channel for this connection to the ftpd.
  1591. #       filename -               The path/filename to list.
  1592. #       style -                  The type of listing -- nlst or list.
  1593. #
  1594. # Results:
  1595. #       None.
  1596. #
  1597. # Side Effects:
  1598. #       A listing of file stats is written to the socket.
  1599.  
  1600. proc ::ftpd::List {sock filename style} {
  1601.     upvar #0 ::ftpd::$sock data
  1602.     puts $sock "150 Opening data channel"
  1603.  
  1604.     set path [file join $data(cwd) $filename]
  1605.  
  1606.     Fs dlist $path $style $data(sock2)
  1607.  
  1608.     FinishData $sock
  1609.     puts $sock "226 Listing complete"
  1610.     return
  1611. }
  1612.  
  1613. # Standard filesystem - Assume the files are held on a standard disk.  This
  1614. # namespace contains the commands to act as the default fsCmd callback for the
  1615. # ftpd.
  1616.  
  1617. namespace eval ::ftpd::fsFile {
  1618.     # Our document root directory
  1619.  
  1620.     variable docRoot
  1621.     if {![info exist docRoot]} {
  1622.     set docRoot /
  1623.     }
  1624.  
  1625.     namespace export *
  1626. }
  1627.  
  1628. # ::ftpd::fsFile::docRoot --
  1629. #
  1630. #       Set or query the root of the ftpd file system.  If no 'dir' argument
  1631. #       is passed, or if the 'dir' argument is the null string, then the
  1632. #       current docroot is returned.  If a non-NULL 'dir' argument is passed
  1633. #       in it is set as the docRoot.
  1634. #
  1635. # Arguments:
  1636. #       dir  -                   The directory to set as the ftp docRoot.
  1637. #                                (optional. If unspecified, the current docRoot
  1638. #                                is returned).
  1639. #
  1640. # Results:
  1641. #       None.
  1642. #
  1643. # Side Effects:
  1644. #       Sets the docRoot to the specified directory if a directory is
  1645. #       specified.
  1646.  
  1647. proc ::ftpd::fsFile::docRoot {{dir {}}} {
  1648.     variable docRoot
  1649.     if {[string length $dir] == 0} {
  1650.     return $docRoot
  1651.     } else {
  1652.     set docRoot $dir
  1653.     }
  1654.     return ""
  1655. }
  1656.  
  1657. # ::ftpd::fsFile::fs --
  1658. #
  1659. #       Handles the a standard file systems file system requests and is the
  1660. #       default fsCmd callback.
  1661. #
  1662. # Arguments:
  1663. #       command -                The filesystem command (one of dlist, retr, or
  1664. #                                store).  'dlist' will list files in a
  1665. #                                directory, 'retr' will get a channel to
  1666. #                                to read the specified file from, and 'store'
  1667. #                                will return the channel to write to.
  1668. #       path -                   The file name or directory to read, write or
  1669. #                                list.
  1670. #       args -                   Additional arguments for filesystem commands.
  1671. #                                Currently this is used by 'dlist' which
  1672. #                                has two additional arguments 'style' and
  1673. #                                'channel-to-write-dir-list-to'. It is also
  1674. #                                used by 'size' and 'mtime' which have one
  1675. #                                additional argument 'channel-to-write-to'.
  1676. #
  1677. # Results:
  1678. #       For a 'appe', 'retr', or 'stor' a channel is returned. For 'exists' a 1
  1679. #       is returned if the path exists, and is not a directory.  Otherwise a
  1680. #       0 is returned.  For 'permissions' the octal file permissions (i.e.
  1681. #       the 'file stat' mode) are returned.
  1682. #
  1683. # Side Effects:
  1684. #       For 'dlist' a directory listing for the specified path is written to
  1685. #       the specified channel.  For 'mtime' the modification time is written
  1686. #       or an error is thrown.  An error is thrown if there is no fsCmd
  1687. #       callback configured for the ftpd.
  1688.  
  1689. proc ::ftpd::fsFile::fs {command path args} {
  1690.     # append <path>
  1691.     # delete <path> <channel-to-write-to>
  1692.     # dlist <path> <style> <channel-to-write-dir-list-to>
  1693.     # exists <path>
  1694.     # mkdir <path> <channel-to-write-to>
  1695.     # mtime <path> <channel-to-write-mtime-to>
  1696.     # permissions <path>
  1697.     # rename <path> <newpath> <channel-to-write-to>
  1698.     # retr  <path>
  1699.     # rmdir <path> <channel-to-write-to>
  1700.     # size  <path> <channel-to-write-size-to>
  1701.     # store <path>
  1702.  
  1703.     global tcl_platform
  1704.  
  1705.     variable docRoot
  1706.  
  1707.     set path [file join $docRoot $path]
  1708.  
  1709.     switch -exact -- $command {
  1710.         append {
  1711.           #
  1712.           # Patched Mark O'Connor
  1713.           #
  1714.         set fhandle [open $path a]
  1715.           if {[lindex $args 0] == "binary"} {
  1716.              fconfigure $fhandle -translation binary
  1717.           }
  1718.           return $fhandle
  1719.         }
  1720.     retr {
  1721.           #
  1722.           # Patched Mark O'Connor
  1723.           #
  1724.         set fhandle [open $path r]
  1725.           if {[lindex $args 0] == "binary"} {
  1726.              fconfigure $fhandle -translation binary
  1727.           }
  1728.           return $fhandle
  1729.     }
  1730.     store {
  1731.           #
  1732.           # Patched Mark O'Connor
  1733.           #
  1734.         set fhandle [open $path w]
  1735.           if {[lindex $args 0] == "binary"} {
  1736.              fconfigure $fhandle -translation binary
  1737.           }
  1738.           return $fhandle
  1739.     }
  1740.     dlist {
  1741.         foreach {style outchan} $args break
  1742.         set path [glob -nocomplain $path]
  1743.  
  1744.             # Attempt to get a list of all files (even ones that start with .)
  1745.  
  1746.         if {[file isdirectory $path]} {
  1747.         set path1 [file join $path *]
  1748.                 set path2 [file join $path .*]
  1749.         } else {
  1750.                 set path1 $path
  1751.                 set path2 $path
  1752.         }
  1753.  
  1754.             # Get a list of all files that match the glob pattern
  1755.  
  1756.             set fileList [lsort -unique [concat [glob -nocomplain $path1] \
  1757.                     [glob -nocomplain $path2]]]
  1758.  
  1759.         switch -- $style {
  1760.             nlst {
  1761.                 foreach f [lsort $fileList] {
  1762.                         if {[string equal [file tail $f] "."] || \
  1763.                                 [string equal [file tail $f] ".."]} {
  1764.                             continue
  1765.                         }
  1766.                 puts $outchan $f
  1767.                 }
  1768.             }
  1769.         list {
  1770.                 foreach f [lsort $fileList] {
  1771.             file stat $f stat
  1772.                         if {[string equal $tcl_platform(platform) "unix"]} {
  1773.                             set user [file attributes $f -owner]
  1774.                             set group [file attributes $f -group]
  1775.  
  1776.                 puts $outchan [format "%s %3d %s %8s %11s %s %s" \
  1777.                         [PermBits $f $stat(mode)] $stat(nlink) \
  1778.                                 $user $group $stat(size) \
  1779.                                     [FormDate $stat(mtime)] [file tail $f]]
  1780.                         } else {
  1781.                             puts $outchan [format "%s %3d %11s %s %s" \
  1782.                                     [PermBits $f $stat(mode)] $stat(nlink) \
  1783.                                     $stat(size) [FormDate $stat(mtime)] \
  1784.                                     [file tail $f]]
  1785.                         }
  1786.             }
  1787.         }
  1788.         default {
  1789.             error "Unknown list style <$style>"
  1790.         }
  1791.         }
  1792.     }
  1793.         delete {
  1794.         foreach {outchan} $args break
  1795.  
  1796.             if {![file exists $path]} {
  1797.                 puts $outchan "550 $path: No such file or directory."
  1798.         } elseif {![file isfile $path]} {
  1799.                 puts $outchan "550 $path: File exists."
  1800.         } else {
  1801.                 file delete $path
  1802.                 puts $outchan "250 DELE command successful."
  1803.         }
  1804.     }
  1805.         exists {
  1806.             if {[file isdirectory $path]} {
  1807.                 return 0
  1808.         } else {
  1809.                 return [file exists $path]
  1810.         }
  1811.     }
  1812.         mkdir {
  1813.         foreach {outchan} $args break
  1814.  
  1815.             set path [string trimright $path /]
  1816.             if {[file exists $path]} {
  1817.                 if {[file isdirectory $path]} {
  1818.                     puts $outchan "521 \"$path\" directory exists"
  1819.         } else {
  1820.             puts $outchan "521 \"$path\" already exists"
  1821.                 }
  1822.         } elseif {[file exists [file dirname $path]]} {
  1823.                 file mkdir $path
  1824.                 puts $outchan "257 \"$path\" new directory created."
  1825.         } else {
  1826.                 puts $outchan "550 $path: No such file or directory."
  1827.         }
  1828.     }
  1829.         mtime {
  1830.         foreach {outchan} $args break
  1831.  
  1832.             if {![file exists $path]} {
  1833.                 puts $outchan "550 $path: No such file or directory"
  1834.             } elseif {![file isfile $path]} {
  1835.             puts $outchan "550 $path: not a plain file."
  1836.             } else {
  1837.                 set time [file mtime $path]
  1838.                 puts $outchan [clock format $time -format "213 %Y%m%d%H%M%S"]
  1839.         }
  1840.         }
  1841.         permissions {
  1842.         file stat $path stat
  1843.             return $stat(mode)
  1844.         }
  1845.         rename {
  1846.             foreach {newname outchan} $args break
  1847.  
  1848.             if {![file isdirectory [file dirname $newname]]} {
  1849.             puts $outchan "550 rename: No such file or directory."
  1850.             }
  1851.             file rename $path $newname
  1852.             puts $sock "250 RNTO command successful."
  1853.     }
  1854.         rmdir {
  1855.         foreach {outchan} $args break
  1856.  
  1857.             if {![file isdirectory $path]} {
  1858.                 puts $outchan "550 $path: Not a directory."
  1859.         } elseif {[llength [glob -nocomplain [file join $path *]]] != 0} {
  1860.                 puts $outchan "550 $path: Directory not empty."
  1861.             } else {
  1862.                 file delete $path
  1863.                 puts $outchan "250 RMD command successful."
  1864.         }
  1865.     }
  1866.         size {
  1867.         foreach {outchan} $args break
  1868.  
  1869.             if {![file exists $path]} {
  1870.                 puts $outchan "550 $path: No such file or directory"
  1871.             } elseif {![file isfile $path]} {
  1872.             puts $outchan "550 $path: not a plain file."
  1873.             } else {
  1874.                 puts $outchan "213 [file size $path]"
  1875.         }
  1876.         }
  1877.     default {
  1878.         error "Unknown command \"$command\""
  1879.     }
  1880.     }
  1881.     return ""
  1882. }
  1883.  
  1884. # ::ftpd::fsFile::PermBits --
  1885. #
  1886. #       Returns the file permissions for the specified file.
  1887. #
  1888. # Arguments:
  1889. #       file  -                  The file to return the permissions of.
  1890. #
  1891. # Results:
  1892. #       The permissions for the specified file are returned.
  1893. #
  1894. # Side Effects:
  1895. #       None.
  1896.  
  1897. proc ftpd::fsFile::PermBits {file mode} {
  1898.  
  1899.     array set s {
  1900.         0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
  1901.     }
  1902.  
  1903.     set type [file type $file]
  1904.     if {[string equal $type "file"]} {
  1905.         set permissions "-"
  1906.     } else {
  1907.         set permissions [string index $type 0]
  1908.     }
  1909.     foreach j [split [format %03o [expr {$mode&0777}]] {}] {
  1910.         append permissions $s($j)
  1911.     }
  1912.  
  1913.     return $permissions
  1914. }
  1915.  
  1916. # ::ftpd::fsFile::FormDate --
  1917. #
  1918. #       Returns the file permissions for the specified file.
  1919. #
  1920. # Arguments:
  1921. #       seconds  -              The number of seconds returned by 'file mtime'.
  1922. #
  1923. # Results:
  1924. #       A formatted date is returned.
  1925. #
  1926. # Side Effects:
  1927. #       None.
  1928.  
  1929. proc ftpd::fsFile::FormDate {seconds} {
  1930.  
  1931.     set currentTime [clock seconds]
  1932.     set oldTime [clock scan "6 months ago" -base $currentTime]
  1933.     if {$seconds <= $oldTime} {
  1934.         set time [clock format $seconds -format "%Y"]
  1935.     } else {
  1936.         set time [clock format $seconds -format "%H:%M"]
  1937.     }
  1938.     set day [string trimleft [clock format $seconds -format "%d"] 0]
  1939.     set month [clock format $seconds -format "%b"]
  1940.     return [format "%3s %2s %5s" $month $day $time]
  1941. }
  1942.  
  1943. # Only provide the package if it has been successfully
  1944. # sourced into the interpreter.
  1945.  
  1946. #
  1947. # Patched Mark O'Connor
  1948. #
  1949. package provide ftpd 1.1.1
  1950.  
  1951.