summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/ftpd
diff options
context:
space:
mode:
Diffstat (limited to 'tcllib/modules/ftpd')
-rw-r--r--tcllib/modules/ftpd/ChangeLog249
-rw-r--r--tcllib/modules/ftpd/ftpd.man279
-rw-r--r--tcllib/modules/ftpd/ftpd.tcl2064
-rw-r--r--tcllib/modules/ftpd/pkgIndex.tcl2
4 files changed, 2594 insertions, 0 deletions
diff --git a/tcllib/modules/ftpd/ChangeLog b/tcllib/modules/ftpd/ChangeLog
new file mode 100644
index 0000000..a95e00f
--- /dev/null
+++ b/tcllib/modules/ftpd/ChangeLog
@@ -0,0 +1,249 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-08-09 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.man: Bumped version to 1.2.6.
+ * ftpd.tcl:
+ * pkgIndex.tcl:
+
+ * ftpd.tcl (::ftpd::command::CWD): [Bug 3312900]: Accepted patch
+ by Roy Keene, adding basic checks to the CWD command.
+
+ * ftpd.tcl (::ftpd::command::RNTO, ::ftpd::command::RNFR):
+ [Bug 3312880, 3325229]: Fixed issues with the rename command
+ found by Roy Keene.
+
+ * ftpd.tcl: [Bug 3357765]: Accepted patch by Roy Keene
+ <rkeene@users.sourceforge.net> fixing issues with the handling
+ of passive connections by the server, with modifications (Moved
+ the replicated checking code into a procedure shared by the
+ modified commands).
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-01-20 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl (::ftpd::command::RNTO): [Bug 2928355]: Fixed the
+ missing import of the server's state array, reported by Martin
+ <martinao@users.sourceforge.net>.
+
+ * ftpd.tcl (::ftpd::config): [Bug 2935339] [Patch 2935347]:
+ * ftpd.man: Applied the patch by Keith Vetter
+ * pkgIndex.tcl: <keithv@users.sourceforge.net>, fixing the
+ non-idempotency of the config command. Bumped the package
+ version to 1.2.5.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-02-29 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl: Renamed ::ftpd::read -> ftp::Read to prevent clash
+ * ftpd.man: with Tcl's builtin command. Version bumped to 1.2.4.
+ * pkgIndex.tcl:
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl: Fix for [SF Tcllib Bug 1720144]. Version
+ * ftpd.man: of the package bumped to 1.2.3.
+ * pkgIndex.tcl:
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl: Fixed [Tcllib SF Bug 1006157] reported by Stephen
+ Huntley <blacksqr@users.sourceforge.net>. Using fake user/group
+ information when on Windows.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Updated version number to sync with 1.6.1
+ * ftpd.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Rel. engineering. Updated version number
+ * ftpd.man: of ftpd to reflect its changes, to 1.2.1.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bugfixes by Gerald Lester. No details available. Gerald is asked
+ to replace this entry with one describing his changes.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.man: Updated documentation to explain the new features (Two
+ additional callbacks, and the variable 'CurrentSocket').
+ * ftpd.tcl (Finish): Replaced string compare with canonical
+ 'hasCallback'.
+ (GetDone): Ditto for 'xferDoneCmd'.
+ (command::REIN): Closing passive data server port,
+ reinitializing to empty as well.
+ (read): Reverted call of Finish to relative addressing of the
+ command.
+
+2004-02-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl
+ * ftpd.tcl: Imported changes made by "Gerald W. Lester"
+ <Gerald.Lester@ShowMaster.com>. Bugfixes, more callbacks (close,
+ transfer done), and implementation of passive mode data
+ connection. Version up to 1.2.
+
+2003-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl (Fs): Fixed SF tcllib bug [766112]. Copied code from
+ style 'nslt' to exclude . and .. from the list.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl:
+ * ftpd.man:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the package to
+ to 1.1.3.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.man: More semantic markup, less visual one.
+
+2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Updated 'info exist' to 'info exists'.
+
+2002-06-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * ftpd.tcl:
+ * ftpd.n:
+ * ftpd.man: Bumped to version 1.1.2.
+
+2002-03-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.man: New, doctools manpage.
+
+2002-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * ftpd.n: Changed to require tcl version 8.3. Code uses -unique
+ option of [lsort], introduced in that version. This fixes SF bug
+ #531799.
+
+2001-09-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Applied patch [459197] from Hemang to fix more
+ 'namespace export *'. Patch modified before application as some
+ export command are actually private (Implementations of the ftp
+ commands).
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Restricted export list to public API.
+ [456255]. Patch by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Fixed dubious code reported by frink.
+
+2000-11-22 Eric Melski <ericm@interwoven.com>
+
+ * Integrated patch from Mark O'Conner. Patch fixed file translation
+ mode bug (ie, binary vs. ascii) that prevented proper retrieval
+ of binary files. [SFBUG: 122664]
+
+2000-11-01 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * Integrated patch from Keith Vetter <keith@softbook.com>
+ Patch fixed several bugs. Allowed users to log in as
+ both 'anonymous' and 'ftp' by default instead of just anonymous.
+ Fixed syntax error with the 'socket -server' line in ftpd::server when
+ 'myaddr' is specified. Fixed the argument specifications for
+ cmdline:getoptions in ftpd::config so that arguments are required for
+ the -logCmd and the -fsCmd.
+
+2000-10-30 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * Made some fixes to better support windows.
+
+2000-10-27 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * Initial revision of tcllib ftpd. Based off of the ftpd in
+ the stdtcl distribution.
+
diff --git a/tcllib/modules/ftpd/ftpd.man b/tcllib/modules/ftpd/ftpd.man
new file mode 100644
index 0000000..e50b24c
--- /dev/null
+++ b/tcllib/modules/ftpd/ftpd.man
@@ -0,0 +1,279 @@
+[vset VERSION 1.3]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin ftpd n [vset VERSION]]
+[keywords ftp]
+[keywords ftpd]
+[keywords ftpserver]
+[keywords {rfc 959}]
+[keywords services]
+[moddesc {Tcl FTP Server Package}]
+[titledesc {Tcl FTP server implementation}]
+[category Networking]
+[require Tcl 8.3]
+[require ftpd [opt [vset VERSION]]]
+[description]
+
+The [package ftpd] package provides a simple Tcl-only server library
+for the FTP protocol as specified in
+RFC 959 ([uri http://www.rfc-editor.org/rfc/rfc959.txt]).
+It works by listening on the standard FTP socket. Most server errors
+are returned as error messages with the appropriate code attached to
+them. Since the server code for the ftp daemon is executed in the
+event loop, it is possible that a
+
+[cmd bgerror] will be thrown on the server if there are problems with
+the code in the module.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::ftpd::server] [opt [arg myaddr]]]
+
+Open a listening socket to listen to and accept ftp connections.
+myaddr is an optional argument. [arg myaddr] is the domain-style name
+or numerical IP address of the client-side network interface to use
+for the connection.
+
+[call [cmd ::ftpd::config] [opt [arg {option value}]] [opt [arg {option value ...}]]]
+
+The value is always the name of the command to call as the
+callback. The option specifies which callback should be configured.
+See section [sectref CALLBACKS] for descriptions of the arguments and
+return values for each of the callbacks.
+
+[list_begin definitions]
+
+[def "-authIpCmd [arg proc]"]
+
+Callback to authenticate new connections based on the ip-address of
+the peer.
+
+[def "-authUsrCmd [arg proc]"]
+
+Callback to authenticate new connections based on the user logging in
+(and the users password).
+
+[def "-authFileCmd [arg proc]"]
+
+Callback to accept or deny a users access to read and write to a
+specific path or file.
+
+[def "-logCmd [arg proc]"]
+
+Callback for log information generated by the FTP engine.
+
+[def "-fsCmd [arg proc]"]
+
+Callback to connect the engine to the filesystem it operates on.
+
+[def "-closeCmd [arg proc]"]
+
+Callback to be called when a connection is closed. This allows the
+embedding application to perform its own cleanup operations.
+
+[def "-xferDoneCmd [arg proc]"]
+
+Callback for transfer completion notification. In other words, it is
+called whenever a transfer of data to or from the client has
+completed.
+
+[list_end]
+[list_end]
+
+[section CALLBACKS]
+
+[list_begin definitions]
+
+[def "[cmd authIpCmd] callback"]
+
+The authIpCmd receives the ip-address of the peer attempting to
+connect to the ftp server as its argument. It returns a 1 to allow
+users from the specified IP to attempt to login and a 0 to reject the
+login attempt from the specified IP.
+
+[def "[cmd authUsrCmd] callback"]
+
+The authUsrCmd receives the username and password as its two
+arguments. It returns a 1 to accept the attempted login to the ftpd
+and a 0 to reject the attempted login.
+
+[def "[cmd authFileCmd] callback"]
+
+The authFileCmd receives the user (that is currently logged in), the
+path or filename that is about to be read or written, and
+
+[const read] or [const write] as its three arguments. It returns a
+1 to allow the path or filename to be read or written, and a 0 to
+reject the attempted read or write with a permissions error code.
+
+[def "[cmd logCmd] callback"]
+
+The logCmd receives a severity and a message as its two arguments.
+The severities used within the ftpd package are [const note],
+
+[const debug], and [const error]. The logCmd doesn't return
+anything.
+
+[def "[cmd fsCmd] callback"]
+
+The fsCmd receives a subcommand, a filename or path, and optional
+additional arguments (depending on the subcommand).
+
+[para]
+The subcommands supported by the fsCmd are:
+
+[list_begin definitions]
+
+[call [arg fsCmd] [method append] [arg path]]
+
+The append subcommand receives the filename to append to as its
+argument. It returns a writable tcl channel as its return value.
+
+[call [arg fsCmd] [method delete] [arg path] [arg channel]]
+
+The delete subcommand receives the filename to delete, and a channel
+to write to as its two arguments. The file specified is deleted and
+the appropriate ftp message is written to the channel that is passed
+as the second argument. The delete subcommand returns nothing.
+
+[call [arg fsCmd] [method dlist] [arg path] [arg style] [arg channel]]
+
+The dlist subcommand receives the path that it should list the files
+that are in, the style in which the files should be listed which is
+either [const nlst] or [const list], and a channel to write to as
+its three arguments. The files in the specified path are printed to
+the specified channel one per line. If the style is [const nlst]
+only the name of the file is printed to the channel. If the style is
+[const list] then the file permissions, number of links to the file,
+the name of the user that owns the file, the name of the group that
+owns the file, the size (in bytes) of the file, the modify time of the
+file, and the filename are printed out to the channel in a formatted
+space separated format. The [method dlist] subcommand returns
+nothing.
+
+[call [arg fsCmd] [method exists] [arg path]]
+
+The exists subcommand receives the name of a file to check the
+existence of as its only argument. The exists subcommand returns a 1
+if the path specified exists and the path is not a directory.
+
+[call [arg fsCmd] [method mkdir] [arg path] [arg channel]]
+
+The mkdir subcommand receives the path of a directory to create and a
+channel to write to as its two arguments. The mkdir subcommand
+creates the specified directory if necessary and possible. The mkdir
+subcommand then prints the appropriate success or failure message to
+the channel. The mkdir subcommand returns nothing.
+
+[call [arg fsCmd] [method mtime] [arg path] [arg channel]]
+
+The mtime subcommand receives the path of a file to check the modify
+time on and a channel as its two arguments. If the file exists the
+mtime is printed to the channel in the proper FTP format, otherwise an
+appropriate error message and code are printed to the channel. The
+mtime subcommand returns nothing.
+
+[call [arg fsCmd] [method permissions] [arg path]]
+
+The permissions subcommand receives the path of a file to retrieve the
+permissions of. The permissions subcommand returns the octal file
+permissions of the specified file. The file is expected to exist.
+
+[call [arg fsCmd] [method rename] [arg path] [arg newpath] [arg channel]]
+
+The rename subcommand receives the path of the current file, the new
+file path, and a channel to write to as its three arguments. The
+rename subcommand renames the current file to the new file path if the
+path to the new file exists, and then prints out the appropriate
+message to the channel. If the new file path doesn't exist the
+appropriate error message is printed to the channel. The rename
+subcommand returns nothing.
+
+[call [arg fsCmd] [method retr] [arg path]]
+
+The retr subcommand receives the path of a file to read as its only
+argument. The retr subcommand returns a readable channel that the
+specified file can be read from.
+
+[call [arg fsCmd] [method rmdir] [arg path] [arg channel]]
+
+The rmdir subcommand receives the path of a directory to remove and a
+channel to write to as its two arguments. The rmdir subcommand
+removes the specified directory (if possible) and prints the
+appropriate message to the channel (which may be an error if the
+specified directory does not exist or is not empty). The rmdir
+subcommand returns nothing.
+
+[call [arg fsCmd] [method size] [arg path] [arg channel]]
+
+The size subcommand receives the path of a file to get the size (in
+bytes) of and a channel to write to as its two arguments. The size
+subcommand prints the appropriate code and the size of the file if the
+specified path is a file, otherwise an appropriate error code and
+message are printed to the channel. The size subcommand returns
+nothing.
+
+[call [arg fsCmd] [method store] [arg path]]
+
+The store subcommand receives the path of a file to write as its only
+argument. The store subcommand returns a writable channel.
+
+[list_end]
+
+[def "[cmd closeCmd]"]
+
+The [cmd closeCmd] receives no arguments when it is invoked, and any
+return value it may generate is discarded.
+
+[def "[cmd xferDoneCmd] sock sock2 file bytes filename err"]
+
+The [cmd xferDoneCmd] receives six arguments when invoked. These are,
+in this order, the channel handle of the control socket for the
+connection, the channel handle of the data socket used for the
+transfer (already closed), the handle of the channel containing the
+transfered file, the number of bytes transfered, the path of the file
+which was transfered, and a (possibly empty) error message.
+
+Any return value it may generate is discarded.
+
+[list_end]
+
+[section VARIABLES]
+
+[list_begin definitions]
+
+[def [var ::ftpd::cwd]]
+
+The current working directory for a session when someone first
+connects to the FTPD or when the [cmd REIN] ftp command is received.
+
+[def [var ::ftpd::contact]]
+
+The e-mail address of the person that is the contact for the ftp
+server. This address is printed out as part of the response to the
+[cmd {FTP HELP}] command.
+
+[def [var ::ftpd::port]]
+
+The port that the ftp server should listen on.
+If port is specified as zero, the operating system will allocate an
+unused port for use as a server socket; afterwards, the variable will
+contain the port number that was allocated.
+
+[def [var ::ftpd::welcome]]
+
+The message that is printed out when the user first connects to the
+ftp server.
+
+[def [var ::ftpd::CurrentSocket]]
+
+Accessible to all callbacks and all filesystem commands (which are a
+special form of callback) and contains the handle of the socket
+channel which was active when the callback was invoked.
+
+[list_end]
+
+[vset CATEGORY ftpd]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ftpd/ftpd.tcl b/tcllib/modules/ftpd/ftpd.tcl
new file mode 100644
index 0000000..7e93f8e
--- /dev/null
+++ b/tcllib/modules/ftpd/ftpd.tcl
@@ -0,0 +1,2064 @@
+# ftpd.tcl --
+#
+# This file contains Tcl/Tk package to create a ftp daemon.
+# I believe it was originally written by Matt Newman (matt@sensus.org).
+# Modified by Dan Kuchler (kuchler@ajubasolutions.com) to handle
+# more ftp commands and to fix some bugs in the original implementation
+# that was found in the stdtcl module.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: ftpd.tcl,v 1.34 2011/08/09 20:55:38 andreas_kupries Exp $
+#
+
+# Define the ftpd package version 1.2.5
+
+package require Tcl 8.2
+namespace eval ::ftpd {
+
+ # The listening port.
+
+ variable port 21
+
+ variable contact
+ if {![info exists contact]} {
+ global tcl_platform
+ set contact "$tcl_platform(user)@[info hostname]"
+ }
+
+ variable cwd
+ if {![info exists cwd]} {
+ set cwd ""
+ }
+
+ variable welcome
+ if {![info exists welcome]} {
+ set welcome "[info hostname] FTP server ready."
+ }
+
+ # Global configuration.
+
+ variable cfg
+ if {![info exists cfg]} {
+ array set cfg [list \
+ closeCmd {} \
+ authIpCmd {} \
+ authUsrCmd {::ftpd::anonAuth} \
+ authFileCmd {::ftpd::fileAuth} \
+ logCmd {::ftpd::logStderr} \
+ fsCmd {::ftpd::fsFile::fs} \
+ xferDoneCmd {}]
+ }
+
+ variable commands
+ if {![info exists commands]} {
+ array set commands [list \
+ ABOR {ABOR (abort operation)} \
+ ACCT {(specify account); unimplemented.} \
+ ALLO {(allocate storage - vacuously); unimplemented.} \
+ APPE {APPE <sp> file-name} \
+ CDUP {CDUP (change to parent directory)} \
+ CWD {CWD [ <sp> directory-name ]} \
+ DELE {DELE <sp> file-name} \
+ HELP {HELP [ <sp> <string> ]} \
+ LIST {LIST [ <sp> path-name ]} \
+ NLST {NLST [ <sp> path-name ]} \
+ MAIL {(mail to user); unimplemented.} \
+ MDTM {MDTM <sp> path-name} \
+ MKD {MKD <sp> path-name} \
+ MLFL {(mail file); unimplemented.} \
+ MODE {(specify transfer mode); unimplemented.} \
+ MRCP {(mail recipient); unimplemented.} \
+ MRSQ {(mail recipient scheme question); unimplemented.} \
+ MSAM {(mail send to terminal and mailbox); unimplemented.} \
+ MSND {(mail send to terminal); unimplemented.} \
+ MSOM {(mail send to terminal or mailbox); unimplemented.} \
+ NOOP {NOOP} \
+ PASS {PASS <sp> password} \
+ PASV {(set server in passive mode); unimplemented.} \
+ PORT {PORT <sp> b0, b1, b2, b3, b4, b5} \
+ PWD {PWD (return current directory)} \
+ QUIT {QUIT (terminate service)} \
+ REIN {REIN (reinitialize server state)} \
+ REST {(restart command); unimplemented.} \
+ RETR {RETR <sp> file-name} \
+ RMD {RMD <sp> path-name} \
+ RNFR {RNFR <sp> file-name} \
+ RNTO {RNTO <sp> file-name} \
+ SIZE {SIZE <sp> path-name} \
+ SMNT {(structure mount); unimplemented.} \
+ STOR {STOR <sp> file-name} \
+ STOU {STOU <sp> file-name} \
+ STRU {(specify file structure); unimplemented.} \
+ SYST {SYST (get type of operating system)} \
+ TYPE {TYPE <sp> [ A | E | I | L ]} \
+ USER {USER <sp> username} \
+ XCUP {XCUP (change to parent directory)} \
+ XCWD {XCWD [ <sp> directory-name ]} \
+ XMKD {XMKD <sp> path-name} \
+ XPWD {XPWD (return current directory)} \
+ XRMD {XRMD <sp> path-name}]
+ }
+
+ variable passwords [list ]
+
+ # Exported procedures
+
+ namespace export config hasCallback logStderr
+ namespace export fileAuth anonAuth unixAuth server accept read
+}
+
+
+# ::ftpd::config --
+#
+# Configure the configurable parameters of the ftp daemon.
+#
+# Arguments:
+# options - -authIpCmd proc procedure that accepts or rejects an
+# incoming connection. A value of 0 or
+# an error causes the connection to be
+# rejected. There is no default.
+# -authUsrCmd proc procedure that accepts or rejects a
+# login. Defaults to ::ftpd::anonAuth
+# -authFileCmd proc procedure that accepts or rejects
+# access to read or write a certain
+# file or path. Defaults to
+# ::ftpd::userAuth
+# -logCmd proc procedure that logs information from
+# the ftp engine. Default is
+# ::ftpd::logStderr
+# -fsCmd proc procedure to connect the ftp engine
+# to the file system it operates on.
+# Default is ::ftpd::fsFile::fs
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Changes the value of the specified configurables.
+
+proc ::ftpd::config {args} {
+
+ # Processing of global configuration changes.
+
+ package require cmdline
+
+ variable cfg
+
+ # Make default value be the current value so we can call this
+ # command multiple times without resetting already set values
+
+ array set cfg [cmdline::getoptions args [list \
+ [list closeCmd.arg $cfg(closeCmd) {Callback when a connection is closed.}] \
+ [list authIpCmd.arg $cfg(authIpCmd) {Callback to authenticate new connections based on the ip-address of the peer. Optional}] \
+ [list authUsrCmd.arg $cfg(authUsrCmd) {Callback to authenticate new connections based on the user logging in.}] \
+ [list authFileCmd.arg $cfg(authFileCmd) {Callback to accept or deny a users access to read and write to a specific path or file.}] \
+ [list logCmd.arg $cfg(logCmd) {Callback for log information generated by the FTP engine.}] \
+ [list xferDoneCmd.arg $cfg(xferDoneCmd) {Callback for transfer completion notification. Optional}] \
+ [list fsCmd.arg $cfg(fsCmd) {Callback to connect the engine to the filesystem it operates on.}]]]
+ return
+}
+
+
+# ::ftpd::hasCallback --
+#
+# Determines whether or not a non-NULL callback has been defined for one
+# of the callback types.
+#
+# Arguments:
+# callbackType - One of authIpCmd, authUsrCmd, logCmd, or fsCmd
+#
+# Results:
+# Returns 1 if a non-NULL callback has been specified for the
+# callbackType that is passed in.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::hasCallback {callbackType} {
+ variable cfg
+
+ return [expr {[info exists cfg($callbackType)] && [string length $cfg($callbackType)]}]
+}
+
+
+# ::ftpd::logStderr --
+#
+# Outputs a message with the specified severity to stderr. The default
+# logCmd callback.
+#
+# Arguments:
+# severity - The severity of the error. One of debug, error,
+# or note.
+# text - The error message.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A message is written to the stderr channel.
+
+proc ::ftpd::logStderr {severity text} {
+
+ # Standard log handler. Prints to stderr.
+
+ puts stderr "\[$severity\] $text"
+ return
+}
+
+
+# ::ftpd::Log --
+#
+# Used for all ftpd logging.
+#
+# Arguments:
+# severity - The severity of the error. One of debug, error,
+# or note.
+# text - The error message.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The ftpd logCmd callback is called with the specified severity and
+# text if there is a non-NULL ftpCmd.
+
+proc ::ftpd::Log {severity text} {
+
+ # Central call out to log handlers.
+
+ variable cfg
+
+ if {[hasCallback logCmd]} {
+ set cmd $cfg(logCmd)
+ lappend cmd $severity $text
+ eval $cmd
+ }
+ return
+}
+
+
+# ::ftpd::fileAuth --
+#
+# Given a username, path, and operation- decides whether or not to accept
+# the attempted read or write operation.
+#
+# Arguments:
+# user - The name of the user that is attempting to
+# connect to the ftpd.
+# path - The path or filename that the user is attempting
+# to read or write.
+# operation - read or write.
+#
+# Results:
+# Returns 0 if it rejects access and 1 if it accepts access.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::fileAuth {user path operation} {
+ # Standard authentication handler
+
+ if {(![Fs exists $path]) && ([string equal $operation "write"])} {
+ if {[Fs exists [file dirname $path]]} {
+ set path [file dirname $path]
+ }
+ } elseif {(![Fs exists $path]) && ([string equal $operation "read"])} {
+ return 0
+ }
+
+ if {[Fs exists $path]} {
+ set mode [Fs permissions $path]
+ if {([string equal $operation "read"] && (($mode & 00004) > 0)) || \
+ ([string equal $operation "write"] && (($mode & 00002) > 0))} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# ::ftpd::anonAuth --
+#
+# Given a username and password, decides whether or not to accept the
+# attempted login. This is the default ftpd authUsrCmd callback. By
+# default it accepts the annonymous user and does some basic checking
+# checking on the form of the password to see if it has the form of an
+# email address.
+#
+# Arguments:
+# user - The name of the user that is attempting to
+# connect to the ftpd.
+# pass - The password of the user that is attempting to
+# connect to the ftpd.
+#
+# Results:
+# Returns 0 if it rejects the login and 1 if it accepts the login.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::anonAuth {user pass} {
+ # Standard authentication handler
+ #
+ # Accept user 'anonymous' if a password was
+ # provided which is at least similar to an
+ # fully qualified email address.
+
+ if {(![string equal $user anonymous]) && (![string equal $user ftp])} {
+ return 0
+ }
+
+ set pass [split $pass @]
+ if {[llength $pass] != 2} {
+ return 0
+ }
+
+ set domain [split [lindex $pass 1] .]
+ if {[llength $domain] < 2} {
+ return 0
+ }
+
+ return 1
+}
+
+# ::ftpd::unixAuth --
+#
+# Given a username and password, decides whether or not to accept the
+# attempted login. This is an alternative to the default ftpd
+# authUsrCmd callback. By default it accepts the annonymous user and does
+# some basic checking checking on the form of the password to see if it
+# has the form of an email address.
+#
+# Arguments:
+# user - The name of the user that is attempting to
+# connect to the ftpd.
+# pass - The password of the user that is attempting to
+# connect to the ftpd.
+#
+# Results:
+# Returns 0 if it rejects the login and 1 if it accepts the login.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::unixAuth {user pass} {
+
+ variable passwords
+ array set password $passwords
+
+ # Standard authentication handler
+ #
+ # Accept user 'anonymous' if a password was
+ # provided which is at least similar to an
+ # fully qualified email address.
+
+ if {([llength $passwords] == 0) && (![catch {package require crypt}])} {
+ foreach file [list /etc/passwd /etc/shadow] {
+ if {([file exists $file]) && ([file readable $file])} {
+ set fh [open $file r]
+ set data [read $fh [file size $file]]
+ foreach line [split $data \n] {
+ foreach {username passwd uid gid dir sh} [split $line :] {
+ if {[string length $passwd] > 2} {
+ set password($username) $passwd
+ } elseif {$passwd == ""} {
+ set password($username) ""
+ }
+ break
+ }
+ }
+ }
+ }
+ set passwords [array get password]
+ }
+
+ ::ftpd::Log debug $passwords
+
+ if {[string equal $user anonymous] || [string equal $user ftp]} {
+
+ set pass [split $pass @]
+ if {[llength $pass] != 2} {
+ return 0
+ }
+
+ set domain [split [lindex $pass 1] .]
+ if {[llength $domain] < 2} {
+ return 0
+ }
+
+ return 1
+ }
+
+ if {[info exists password($user)]} {
+ if {$password($user) == ""} {
+ return 1
+ }
+ if {[string equal $password($user) [::crypt $pass $password($user)]]} {
+ return 1
+ }
+ }
+
+ return 0
+}
+
+# ::ftpd::server --
+#
+# Creates a server socket at the specified port.
+#
+# Arguments:
+# myaddr - The domain-style name or numerical IP address of
+# the client-side network interface to use for the
+# connection. The name of the user that is
+# attempting to connect to the ftpd.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A listener is setup on the specified port which will call
+# ::ftpd::accept when it is connected to.
+
+proc ::ftpd::server {{myaddr {}}} {
+ variable port
+ variable serviceSock
+ if {[string length $myaddr]} {
+ set serviceSock [socket -server ::ftpd::accept -myaddr $myaddr $port]
+ } else {
+ set serviceSock [socket -server ::ftpd::accept $port]
+ }
+ set port [lindex [fconfigure $serviceSock -sockname] 2]
+ return
+}
+
+
+# ::ftpd::accept --
+#
+# Checks if the connecting IP is authorized to connect or not. If not
+# the socket is closed and failure is logged. Otherwise, a welcome is
+# printed out, and a ftpd::Read filevent is placed on the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# ipaddr - The client's IP address.
+# client_port - The client's port number.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Sets up a ftpd::Read fileevent to trigger whenever the channel is
+# readable. Logs an error and closes the connection if the IP is
+# not authorized to connect.
+
+proc ::ftpd::accept {sock ipaddr client_port} {
+ upvar #0 ::ftpd::$sock data
+ variable welcome
+ variable cfg
+ variable cwd
+ variable CurrentSocket
+
+ set CurrentSocket $sock
+ if {[info exists data]} {
+ unset data
+ }
+
+ if {[hasCallback authIpCmd]} {
+ # Call out to authenticate the peer. A return value of 0 or an
+ # error causes the system to reject the connection. Everything
+ # else (with 1 prefered) leads to acceptance.
+
+ set cmd $cfg(authIpCmd)
+ lappend cmd $ipaddr
+
+ set fail [catch {eval $cmd} res]
+
+ if {$fail} {
+ Log error "AuthIp error: $res"
+ }
+ if {$fail || ($res == 0)} {
+ Log note "AuthIp: Access denied to $ipaddr"
+
+ # Now: Close the connection. (Is there a standard response
+ # before closing down to signal the peer that we don't want
+ # to talk to it ? -> read RFC).
+
+ close $sock
+ return
+ }
+
+ # Accept the connection (for now, 'authUsrCmd' may revoke this
+ # decision).
+ }
+
+ array set data [list \
+ access 0 \
+ ip $ipaddr \
+ state command \
+ buffering line \
+ cwd "$cwd" \
+ mode binary \
+ sock2a "" \
+ sock2 ""]
+
+ fconfigure $sock -buffering line
+ fileevent $sock readable [list ::ftpd::Read $sock]
+ puts $sock "220 $welcome"
+
+ Log debug "Accept $ipaddr"
+ return
+}
+
+# ::ftpd::Read --
+#
+# Checks the state of a channel and then reads a command from the
+# channel if it is not at end of file yet. If there is a command named
+# ftpd::command::* where '*' is the all upper case name of the command,
+# then that proc is called to handle the command with the remaining parts
+# of the command that was read from the channel as arguments.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Runs the appropriate command depending on the state in the state
+# machine, and the command that is specified.
+
+proc ::ftpd::Read {sock} {
+ upvar #0 ::ftpd::$sock data
+ variable CurrentSocket
+
+ set CurrentSocket $sock
+ if {[eof $sock]} {
+ Finish $sock
+ return
+ }
+ switch -exact -- $data(state) {
+ command {
+ gets $sock command
+ set argument ""
+ if {![regexp {^([^ ]+) (.*)$} $command -> cmd argument]} {
+ if {![regexp {^([^ ]+)$} $command -> cmd]} {
+ # Very bad command syntax.
+ puts $sock "500 Command not understood."
+ return
+ }
+ }
+ set cmd [string toupper $cmd]
+ auto_load ::ftpd::command::$cmd
+ if {($data(access) == 0) && ((![info exists data(user)]) || \
+ ($data(user) == "")) && (![string equal $cmd "USER"])} {
+ if {[string equal $cmd "PASS"]} {
+ puts $sock "503 Login with USER first."
+ } else {
+ puts $sock "530 Please login with USER and PASS."
+ }
+ } elseif {($data(access) == 0) && (![string equal $cmd "PASS"]) \
+ && (![string equal $cmd "USER"]) \
+ && (![string equal $cmd "QUIT"])} {
+ puts $sock "530 Please login with USER and PASS."
+ } elseif {[info commands ::ftpd::command::$cmd] != ""} {
+ Log debug $command
+ ::ftpd::command::$cmd $sock $argument
+ catch {flush $sock}
+ } else {
+ Log error "Unknown command: $cmd"
+ puts $sock "500 Unknown command $cmd"
+ }
+ }
+ default {
+ error "Unknown state \"$data(state)\""
+ }
+ }
+ return
+}
+
+# ::ftpd::Finish --
+#
+# Closes the socket connection between the ftpd and client.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The channel is closed.
+
+proc ::ftpd::Finish {sock} {
+ upvar #0 ::ftpd::$sock data
+ variable cfg
+
+ if {[hasCallback closeCmd]} then {
+ ##
+ ## User specified a close command so invoke it
+ ##
+ uplevel #0 $cfg(closeCmd)
+ }
+ close $sock
+ if {[info exists data]} {
+ unset data
+ }
+ return
+}
+
+# ::ftpd::FinishData --
+#
+# Closes the data socket connection that is created when the 'PORT'
+# command is recieved.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data channel is closed.
+
+proc ::ftpd::FinishData {sock} {
+ upvar #0 ::ftpd::$sock data
+ catch {close $data(sock2)}
+ set data(sock2) {}
+ return
+}
+
+# ::ftpd::Fs --
+#
+# The general filesystem command. Used as an intermediary for filesystem
+# access to allow alternate (virtual, etc.) filesystems to be used. The
+# ::ftpd::Fs command will call out to the fsCmd callback with the
+# subcommand and arguments that are passed to it.
+#
+# The fsCmd callback is called in the following ways:
+#
+# <cmd> append <path>
+# <cmd> delete <path> <channel-to-write-to>
+# <cmd> dlist <path> <style> <channel-to-write-dir-list-to>
+# <cmd> exists <path>
+# <cmd> mkdir <path> <channel-to-write-to>
+# <cmd> mtime <path> <channel-to-write-mtime-to>
+# <cmd> permissions <path>
+# <cmd> rename <path> <newpath> <channel-to-write-to>
+# <cmd> retr <path>
+# <cmd> rmdir <path> <channel-to-write-to>
+# <cmd> size <path> <channel-to-write-size-to>
+# <cmd> store <path>
+#
+# Arguments:
+# command - The filesystem command (one of dlist, retr, or
+# store). 'dlist' will list files in a
+# directory, 'retr' will get a channel to
+# to read the specified file from, 'store'
+# will return the channel to write to, and
+# 'mtime' will print the modification time.
+# path - The file name or directory to read, write, or
+# list.
+# args - Additional arguments for filesystem commands.
+# Currently this is used by 'dlist' which
+# has two additional arguments 'style' and
+# 'channel-to-write-dir-list-to'. It is also
+# used by 'size' and 'mtime' which have one
+# additional argument 'channel-to-write-to'.
+#
+# Results:
+# For a 'appe', 'retr', or 'stor' a channel is returned. For 'exists'
+# a 1 is returned if the path exists, and is not a directory. Otherwise
+# a 0 is returned. For 'permissions' the octal file permissions (i.e.
+# the 'file stat' mode) are returned.
+#
+# Side Effects:
+# For 'dlist' a directory listing for the specified path is written to
+# the specified channel. For 'mtime' the modification time is written
+# or an error is thrown. An error is thrown if there is no fsCmd
+# callback configured for the ftpd.
+
+proc ::ftpd::Fs {command path args} {
+ variable cfg
+
+ if {![hasCallback fsCmd]} {
+ error "-fsCmd must not be empty, need a way to access files."
+ }
+
+ return [eval [list $cfg(fsCmd) $command $path] $args]
+}
+
+# Create a namespace to hold one proc for each ftp command (in upper case
+# letters) that is supported by the ftp daemon. The existance of a proc
+# in this namespace is the way that the list of supported commands is
+# determined, and the procs in this namespace are invoked to handle the
+# ftp commands with the same name as the procs.
+
+namespace eval ::ftpd::command {
+ # All commands in this namespace are private, no export.
+}
+
+# ::ftpd::command::ABOR --
+#
+# Handle the ABOR ftp command. Closes the data socket if it
+# is open, and then prints the appropriate success message.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the APPE command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data is copied to from the socket data(sock2) to the
+# writable channel to create a file.
+
+proc ::ftpd::command::ABOR {sock list} {
+
+ ::ftpd::FinishData $sock
+ puts $sock "225 ABOR command successful."
+
+ return
+}
+
+# ::ftpd::command::APPE --
+#
+# Handle the APPE ftp command. Gets a writable channel for the file
+# specified from ::ftpd::Fs and copies the data from data(sock2) to
+# the writable channel. If the filename already exists the data is
+# appended, otherwise the file is created and then written.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the APPE command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data is copied to from the socket data(sock2) to the
+# writable channel to create a file.
+
+proc ::ftpd::command::APPE {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ #
+ # Patched Mark O'Connor
+ #
+ if {![catch {::ftpd::Fs append $path $data(mode)} f]} {
+ puts $sock "150 Copy Started ($data(mode))"
+ ::ftpd::PasvCheckAndWait $sock
+ fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
+ } else {
+ puts $sock "500 Copy Failed: $path $f"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::CDUP --
+#
+# Handle the CDUP ftp command. Change the current working directory to
+# the directory above the current working directory.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the CDUP command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Changes the data(cwd) to the appropriate directory.
+
+proc ::ftpd::command::CDUP {sock list} {
+ upvar #0 ::ftpd::$sock data
+
+ set data(cwd) [file dirname $data(cwd)]
+ puts $sock "200 CDUP command successful."
+ return
+}
+
+# ::ftpd::command::CWD --
+#
+# Handle the CWD ftp command. Change the current working directory.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the CWD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Changes the data(cwd) to the appropriate directory.
+
+proc ::ftpd::command::CWD {sock relativepath} {
+ upvar #0 ::ftpd::$sock data
+
+ if {[string equal $relativepath .]} {
+ puts $sock "250 CWD command successful."
+ return
+ }
+
+ if {[string equal $relativepath ..]} {
+ set data(cwd) [file dirname $data(cwd)]
+ puts $sock "250 CWD command successful."
+ return
+ }
+
+ set path [file join $data(cwd) $relativepath]
+
+ if {[::ftpd::Fs exists $path]} {
+ puts $sock "550 not a directory"
+ return
+ }
+
+ set data(cwd) $path
+ puts $sock "250 CWD command successful."
+ return
+}
+
+# ::ftpd::command::DELE --
+#
+# Handle the DELE ftp command. Delete the specified file.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the DELE command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The specified file is deleted.
+
+proc ::ftpd::command::DELE {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ if {[catch {::ftpd::Fs delete $path $sock} msg]} {
+ puts $sock "500 DELE Failed: $path $msg"
+ }
+ return
+}
+
+# ::ftpd::command::HELP --
+#
+# Handle the HELP ftp command. Display a list of commands
+# or syntax information about the supported commands.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the HELP command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Displays a helpful message.
+
+proc ::ftpd::command::HELP {sock command} {
+ upvar #0 ::ftpd::$sock data
+
+ if {$command != ""} {
+ set command [string toupper $command]
+ if {![info exists ::ftpd::commands($command)]} {
+ puts $sock "502 Unknown command '$command'."
+ } elseif {[info commands ::ftpd::command::$command] == ""} {
+ puts $sock "214 $command\t$::ftpd::commands($command)"
+ } else {
+ puts $sock "214 Syntax: $::ftpd::commands($command)"
+ }
+ } else {
+ set commandList [lsort [array names ::ftpd::commands]]
+ puts $sock "214-The following commands are recognized (* =>'s unimplemented)."
+ set i 1
+ foreach commandName $commandList {
+ if {[info commands ::ftpd::command::$commandName] == ""} {
+ puts -nonewline $sock [format " %-7s" "${commandName}*"]
+ } else {
+ puts -nonewline $sock [format " %-7s" $commandName]
+ }
+ if {($i % 8) == 0} {
+ puts $sock ""
+ }
+ incr i
+ }
+ incr i -1
+ if {($i % 8) != 0} {
+ puts $sock ""
+ }
+ puts $sock "214 Direct comments to $::ftpd::contact."
+ }
+
+ return
+}
+
+# ::ftpd::command::LIST --
+#
+# Handle the LIST ftp command. Lists the names of the files in the
+# specified path.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the LIST command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A listing of files is written to the socket.
+
+proc ::ftpd::command::LIST {sock filename} {
+ ::ftpd::List $sock $filename list
+ return
+}
+
+# ::ftpd::command::MDTM --
+#
+# Handle the MDTM ftp command. Prints the modification time of the
+# specified file to the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the MDTM command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the modification time of the specified file to the socket.
+
+proc ::ftpd::command::MDTM {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[catch {::ftpd::Fs mtime $path $sock} msg]} {
+ puts $sock "500 MDTM Failed: $path $msg"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::MKD --
+#
+# Handle the MKD ftp command. Create the specified directory.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the MKD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The directory specified by $path (if it exists) is deleted.
+
+proc ::ftpd::command::MKD {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ if {[catch {::ftpd::Fs mkdir $path $sock} f]} {
+ puts $sock "500 MKD Failed: $path $f"
+ }
+ return
+}
+
+# ::ftpd::command::NOOP --
+#
+# Handle the NOOP ftp command. Do nothing.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the NOOP command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the proper NOOP response.
+
+proc ::ftpd::command::NOOP {sock list} {
+
+ puts $sock "200 NOOP command successful."
+ return
+}
+
+# ::ftpd::command::NLST --
+#
+# Handle the NLST ftp command. Lists the full file stat of all of the
+# files that are in the specified path.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the NLST command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A listing of file stats is written to the socket.
+
+proc ::ftpd::command::NLST {sock filename} {
+ ::ftpd::List $sock $filename nlst
+ return
+}
+
+# ::ftpd::command::PASS --
+#
+# Handle the PASS ftp command. Check whether the specified user
+# and password are allowed to log in (using the authUsrCmd). If
+# they are allowed to log in, they are allowed to continue. If
+# not ::ftpd::Log is used to log and error, and an "Access Denied"
+# error is sent back.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the PASS command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The user is accepted, or an error is logged and the user/password is
+# denied..
+
+proc ::ftpd::command::PASS {sock password} {
+ upvar #0 ::ftpd::$sock data
+
+ if {$password == ""} {
+ puts $sock "530 Please login with USER and PASS."
+ return
+ }
+ set data(pass) $password
+
+ ::ftpd::Log debug "pass <$data(pass)>"
+
+ if {![::ftpd::hasCallback authUsrCmd]} {
+ error "-authUsrCmd must not be empty, need a way to authenticate the user."
+ }
+
+ # Call out to authenticate the user. A return value of 0 or an
+ # error causes the system to reject the connection. Everything
+ # else (with 1 prefered) leads to acceptance.
+
+ set cmd $::ftpd::cfg(authUsrCmd)
+ lappend cmd $data(user) $data(pass)
+
+ set fail [catch {eval $cmd} res]
+
+ if {$fail} {
+ ::ftpd::Log error "AuthUsr error: $res"
+ }
+ if {$fail || ($res == 0)} {
+ ::ftpd::Log note "AuthUsr: Access denied to <$data(user)> <$data(pass)>."
+ unset data(user)
+ unset data(pass)
+ puts $sock "551 Access Denied"
+ } else {
+ puts $sock "230 OK"
+ set data(access) 1
+ }
+ return
+}
+
+# ::ftpd::command::PORT --
+#
+# Handle the PORT ftp command. Create a new socket with the specified
+# paramaters.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the PORT command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A new socket, data(sock2), is opened.
+
+proc ::ftpd::command::PORT {sock numbers} {
+ upvar #0 ::ftpd::$sock data
+ set x [split $numbers ,]
+
+ ::ftpd::FinishData $sock
+
+ set data(sock2) [socket [join [lrange $x 0 3] .] \
+ [expr {([lindex $x 4] << 8) | [lindex $x 5]}]]
+ fconfigure $data(sock2) -translation $data(mode)
+ puts $sock "200 PORT OK"
+ return
+}
+
+# ::ftpd::command::PWD --
+#
+# Handle the PWD ftp command. Prints the current working directory to
+# the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the PWD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the current working directory to the socket.
+
+proc ::ftpd::command::PWD {sock list} {
+ upvar #0 ::ftpd::$sock data
+ ::ftpd::Log debug $data(cwd)
+ puts $sock "257 \"$data(cwd)\" is current directory."
+ return
+}
+
+# ::ftpd::command::QUIT --
+#
+# Handle the QUIT ftp command. Closes the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the PWD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Closes the connection.
+
+proc ::ftpd::command::QUIT {sock list} {
+ ::ftpd::Log note "Closed $sock"
+ puts $sock "221 Goodbye."
+ ::ftpd::Finish $sock
+ # FRINK: nocheck
+ #unset ::ftpd::$sock
+ return
+}
+
+# ::ftpd::command::REIN --
+#
+# Handle the REIN ftp command. This command terminates a USER, flushing
+# all I/O and account information, except to allow any transfer in
+# progress to be completed. All parameters are reset to the default
+# settings and the control connection is left open.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the REIN command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The file specified by $path (if it exists) is copied to the socket
+# data(sock2) otherwise a 'Copy Failed' message is output.
+
+proc ::ftpd::command::REIN {sock list} {
+ upvar #0 ::ftpd::$sock data
+
+ ::ftpd::FinishData $sock
+ catch {close $data(sock2a)}
+
+ # Reinitialize the user and connection data.
+
+ array set data [list \
+ access 0 \
+ state command \
+ buffering line \
+ cwd "$::ftpd::cwd" \
+ mode binary \
+ sock2a "" \
+ sock2 ""]
+
+ return
+}
+
+# ::ftpd::command::RETR --
+#
+# Handle the RETR ftp command. Gets a readable channel for the file
+# specified from ::ftpd::Fs and copies the file to second socket
+# data(sock2).
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the RETR command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The file specified by $path (if it exists) is copied to the socket
+# data(sock2) otherwise a 'Copy Failed' message is output.
+
+proc ::ftpd::command::RETR {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path read
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ #
+ # Patched Mark O'Connor
+ #
+ if {![catch {::ftpd::Fs retr $path $data(mode)} f]} {
+ puts $sock "150 Copy Started ($data(mode))"
+ ::ftpd::PasvCheckAndWait $sock
+ fcopy $f $data(sock2) -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
+ } else {
+ puts $sock "500 Copy Failed: $path $f"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::RMD --
+#
+# Handle the RMD ftp command. Remove the specified directory.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the RMD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The directory specified by $path (if it exists) is deleted.
+
+proc ::ftpd::command::RMD {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+ if {[catch {::ftpd::Fs rmdir $path $sock} f]} {
+ puts $sock "500 RMD Failed: $path $f"
+ }
+ return
+}
+
+# ::ftpd::command::RNFR --
+#
+# Handle the RNFR ftp command. Stores the name of the file to rename
+# from.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the RNFR command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# If the file specified by $path exists, then store the name and request
+# the next name.
+
+proc ::ftpd::command::RNFR {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {[::ftpd::Fs exists $path]} {
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ puts $sock "350 File exists, ready for destination name"
+ set data(renameFrom) $path
+ } else {
+ puts $sock "550 $path: No such file or directory."
+ }
+ return
+}
+
+# ::ftpd::command::RNTO --
+#
+# Handle the RNTO ftp command. Renames the file specified by 'RNFR' if
+# one was specified.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the RNTO command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The specified file is renamed.
+
+proc ::ftpd::command::RNTO {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ if {$filename == ""} {
+ puts $sock "500 'RNTO': command not understood."
+ return
+ }
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {![info exists data(renameFrom)]} {
+ puts $sock "503 Bad sequence of commands."
+ return
+ }
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+
+ if {![catch {::ftpd::Fs rename $data(renameFrom) $path $sock} msg]} {
+ unset data(renameFrom)
+ } else {
+ unset data(renameFrom)
+ puts $sock "500 'RNTO': command not understood."
+ }
+ return
+}
+
+# ::ftpd::command::SIZE --
+#
+# Handle the SIZE ftp command. Prints the modification time of the
+# specified file to the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the MDTM command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the size of the specified file to the socket.
+
+proc ::ftpd::command::SIZE {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[catch {::ftpd::Fs size $path $sock} msg]} {
+ puts $sock "500 SIZE Failed: $path $msg"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::STOR --
+#
+# Handle the STOR ftp command. Gets a writable channel for the file
+# specified from ::ftpd::Fs and copies the data from data(sock2) to
+# the writable channel.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the STOR command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data is copied to from the socket data(sock2) to the
+# writable channel to create a file.
+
+proc ::ftpd::command::STOR {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ #
+ # Patched Mark O'Connor
+ #
+ if {![catch {::ftpd::Fs store $path $data(mode)} f]} {
+ puts $sock "150 Copy Started ($data(mode))"
+ ::ftpd::PasvCheckAndWait $sock
+ fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
+ } else {
+ puts $sock "500 Copy Failed: $path $f"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::STOU --
+#
+# Handle the STOR ftp command. Gets a writable channel for the file
+# specified from ::ftpd::Fs and copies the data from data(sock2) to
+# the writable channel.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the STOU command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data is copied to from the socket data(sock2) to the
+# writable channel to create a file.
+
+proc ::ftpd::command::STOU {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ set file $path
+ set i 0
+ while {[::ftpd::Fs exists $file]} {
+ set file "$path.$i"
+ incr i
+ }
+
+ #
+ # Patched Mark O'Connor
+ #
+ if {![catch {::ftpd::Fs store $file $data(mode)} f]} {
+ puts $sock "150 Copy Started ($data(mode))"
+ ::ftpd::PasvCheckAndWait $sock
+ fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f $file]
+ } else {
+ puts $sock "500 Copy Failed: $path $f"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::SYST --
+#
+# Handle the SYST ftp command. Print the system information.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the SYST command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the system information.
+
+proc ::ftpd::command::SYST {sock list} {
+ upvar #0 ::ftpd::$sock data
+
+ global tcl_platform
+
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ set platform UNIX
+ } elseif {[string equal $tcl_platform(platform) "windows"]} {
+ set platform WIN32
+ } elseif {[string equal $tcl_platform(platform) "macintosh"]} {
+ set platform MACOS
+ } else {
+ set platform UNKNOWN
+ }
+ set version [string toupper $tcl_platform(os)]
+ puts $sock "215 $platform Type: L8 Version: $version"
+
+ return
+}
+
+# ::ftpd::command::TYPE --
+#
+# Handle the TYPE ftp command. Sets up the proper translation mode on
+# the data socket data(sock2)
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the TYPE command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The translation mode of the data channel is changed to the appropriate
+# mode.
+
+proc ::ftpd::command::TYPE {sock type} {
+ upvar #0 ::ftpd::$sock data
+
+ if {[string compare i [string tolower $type]] == 0} {
+ set data(mode) binary
+ } else {
+ set data(mode) auto
+ }
+
+ if {$data(sock2) != {}} {
+ fconfigure $data(sock2) -translation $data(mode)
+ }
+ puts $sock "200 Type set to $type."
+ return
+}
+
+# ::ftpd::command::USER --
+#
+# Handle the USER ftp command. Store the username, and request a
+# password.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the USER command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A message is printed asking for the password.
+
+proc ::ftpd::command::USER {sock username} {
+ upvar #0 ::ftpd::$sock data
+
+ if {$username == ""} {
+ puts $sock "530 Please login with USER and PASS."
+ return
+ }
+ set data(user) $username
+ puts $sock "331 Password Required"
+
+ ::ftpd::Log debug "user <$data(user)>"
+ return
+}
+
+# ::ftpd::GetDone --
+#
+# The fcopy command callback for both the RETR and STOR calls. Called
+# after the fcopy completes.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# sock2 - The data socket data(sock2).
+# f - The file channel.
+# filename - The name of the unique file (if a unique
+# transfer was requested), and the empty string
+# otherwise
+# bytes - The number of bytes that were copied.
+# err - Passed if an error occurred during the fcopy.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The open file channel is closed and a 'complete' message is printed to
+# the socket.
+
+proc ::ftpd::GetDone {sock sock2 f filename bytes {err {}}} {
+ upvar #0 ::ftpd::$sock data
+ variable cfg
+
+ close $f
+ FinishData $sock
+
+ if {[string length $err]} {
+ puts $sock "226- $err"
+ } elseif {$filename == ""} {
+ puts $sock "226 Transfer complete ($bytes bytes)"
+ } else {
+ puts $sock "226 Transfer complete (unique file name: $filename)."
+ }
+ if {[hasCallback xferDoneCmd]} then {
+ catch {$cfg(xferDoneCmd) $sock $sock2 $f $bytes $filename $err}
+ }
+ Log debug "GetDone $f $sock2 $bytes bytes filename: $filename"
+ return
+}
+
+# ::ftpd::List --
+#
+# Handle the NLST and LIST ftp commands. Shared command to do the
+# actual listing of files.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# filename - The path/filename to list.
+# style - The type of listing -- nlst or list.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A listing of file stats is written to the socket.
+
+proc ::ftpd::List {sock filename style} {
+ upvar #0 ::ftpd::$sock data
+ puts $sock "150 Opening data channel"
+
+ set path [file join $data(cwd) $filename]
+
+ PasvCheckAndWait $sock
+ Fs dlist $path $style $data(sock2)
+
+ FinishData $sock
+ puts $sock "226 Listing complete"
+ return
+}
+
+# Standard filesystem - Assume the files are held on a standard disk. This
+# namespace contains the commands to act as the default fsCmd callback for the
+# ftpd.
+
+namespace eval ::ftpd::fsFile {
+ # Our document root directory
+
+ variable docRoot
+ if {![info exists docRoot]} {
+ set docRoot /
+ }
+
+ namespace export docRoot fs
+}
+
+# ::ftpd::fsFile::docRoot --
+#
+# Set or query the root of the ftpd file system. If no 'dir' argument
+# is passed, or if the 'dir' argument is the null string, then the
+# current docroot is returned. If a non-NULL 'dir' argument is passed
+# in it is set as the docRoot.
+#
+# Arguments:
+# dir - The directory to set as the ftp docRoot.
+# (optional. If unspecified, the current docRoot
+# is returned).
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Sets the docRoot to the specified directory if a directory is
+# specified.
+
+proc ::ftpd::fsFile::docRoot {{dir {}}} {
+ variable docRoot
+ if {[string length $dir] == 0} {
+ return $docRoot
+ } else {
+ set docRoot $dir
+ }
+ return ""
+}
+
+# ::ftpd::fsFile::fs --
+#
+# Handles the a standard file systems file system requests and is the
+# default fsCmd callback.
+#
+# Arguments:
+# command - The filesystem command (one of dlist, retr, or
+# store). 'dlist' will list files in a
+# directory, 'retr' will get a channel to
+# to read the specified file from, and 'store'
+# will return the channel to write to.
+# path - The file name or directory to read, write or
+# list.
+# args - Additional arguments for filesystem commands.
+# Currently this is used by 'dlist' which
+# has two additional arguments 'style' and
+# 'channel-to-write-dir-list-to'. It is also
+# used by 'size' and 'mtime' which have one
+# additional argument 'channel-to-write-to'.
+#
+# Results:
+# For a 'appe', 'retr', or 'stor' a channel is returned. For 'exists' a 1
+# is returned if the path exists, and is not a directory. Otherwise a
+# 0 is returned. For 'permissions' the octal file permissions (i.e.
+# the 'file stat' mode) are returned.
+#
+# Side Effects:
+# For 'dlist' a directory listing for the specified path is written to
+# the specified channel. For 'mtime' the modification time is written
+# or an error is thrown. An error is thrown if there is no fsCmd
+# callback configured for the ftpd.
+
+proc ::ftpd::fsFile::fs {command path args} {
+ # append <path>
+ # delete <path> <channel-to-write-to>
+ # dlist <path> <style> <channel-to-write-dir-list-to>
+ # exists <path>
+ # mkdir <path> <channel-to-write-to>
+ # mtime <path> <channel-to-write-mtime-to>
+ # permissions <path>
+ # rename <path> <newpath> <channel-to-write-to>
+ # retr <path>
+ # rmdir <path> <channel-to-write-to>
+ # size <path> <channel-to-write-size-to>
+ # store <path>
+
+ global tcl_platform
+
+ variable docRoot
+
+ set path [file join $docRoot $path]
+
+ switch -exact -- $command {
+ append {
+ #
+ # Patched Mark O'Connor
+ #
+ set fhandle [open $path a]
+ if {[lindex $args 0] == "binary"} {
+ fconfigure $fhandle -translation binary -encoding binary
+ }
+ return $fhandle
+ }
+ retr {
+ #
+ # Patched Mark O'Connor
+ #
+ set fhandle [open $path r]
+ if {[lindex $args 0] == "binary"} {
+ fconfigure $fhandle -translation binary -encoding binary
+ }
+ return $fhandle
+ }
+ store {
+ #
+ # Patched Mark O'Connor
+ #
+ set fhandle [open $path w]
+ if {[lindex $args 0] == "binary"} {
+ fconfigure $fhandle -translation binary -encoding binary
+ }
+ return $fhandle
+ }
+ dlist {
+ foreach {style outchan} $args break
+ ::ftpd::Log debug "at dlist {$style} {$outchan} {$path}"
+ #set path [glob -nocomplain $path]
+ #::ftpd::Log debug "at dlist2 {$style} {$outchan} {$path}"
+
+ # Attempt to get a list of all files (even ones that start with .)
+
+ if {[file isdirectory $path]} {
+ set path1 [file join $path *]
+ set path2 [file join $path .*]
+ } else {
+ set path1 $path
+ set path2 $path
+ }
+
+ # Get a list of all files that match the glob pattern
+
+ set fileList [lsort -unique [concat [glob -nocomplain $path1] \
+ [glob -nocomplain $path2]]]
+
+ ::ftpd::Log debug "File list is {$fileList}"
+
+ switch -- $style {
+ nlst {
+ ::ftpd::Log debug "In nlist"
+ foreach f [lsort $fileList] {
+ if {[string equal [file tail $f] "."] || \
+ [string equal [file tail $f] ".."]} {
+ continue
+ }
+ if {[string equal {} $f]} then continue
+ ::ftpd::Log debug [file tail $f]
+ puts $outchan [file tail $f]
+ }
+ }
+ list {
+ # [ 766112 ] report . and .. directories (linux)
+ # Copied the code from 'nlst' above to handle this.
+
+ foreach f [lsort $fileList] {
+ if {[string equal [file tail $f] "."] || \
+ [string equal [file tail $f] ".."]} {
+ continue
+ }
+ file stat $f stat
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ set user [file attributes $f -owner]
+ set group [file attributes $f -group]
+ } else {
+ set user owner
+ set group group
+ }
+ puts $outchan [format "%s %3d %s %8s %11s %s %s" \
+ [PermBits $f $stat(mode)] $stat(nlink) \
+ $user $group $stat(size) \
+ [FormDate $stat(mtime)] [file tail $f]]
+ }
+ }
+ default {
+ error "Unknown list style <$style>"
+ }
+ }
+ }
+ delete {
+ foreach {outchan} $args break
+
+ if {![file exists $path]} {
+ puts $outchan "550 $path: No such file or directory."
+ } elseif {![file isfile $path]} {
+ puts $outchan "550 $path: File exists."
+ } else {
+ file delete $path
+ puts $outchan "250 DELE command successful."
+ }
+ }
+ exists {
+ if {[file isdirectory $path]} {
+ return 0
+ } else {
+ return [file exists $path]
+ }
+ }
+ mkdir {
+ foreach {outchan} $args break
+
+ set path [string trimright $path /]
+ if {[file exists $path]} {
+ if {[file isdirectory $path]} {
+ puts $outchan "521 \"$path\" directory exists"
+ } else {
+ puts $outchan "521 \"$path\" already exists"
+ }
+ } elseif {[file exists [file dirname $path]]} {
+ file mkdir $path
+ puts $outchan "257 \"$path\" new directory created."
+ } else {
+ puts $outchan "550 $path: No such file or directory."
+ }
+ }
+ mtime {
+ foreach {outchan} $args break
+
+ if {![file exists $path]} {
+ puts $outchan "550 $path: No such file or directory"
+ } elseif {![file isfile $path]} {
+ puts $outchan "550 $path: not a plain file."
+ } else {
+ set time [file mtime $path]
+ puts $outchan [clock format $time -format "213 %Y%m%d%H%M%S"]
+ }
+ }
+ permissions {
+ file stat $path stat
+ return $stat(mode)
+ }
+ rename {
+ foreach {newname outchan} $args break
+
+ if {![file isdirectory [file dirname $newname]]} {
+ puts $outchan "550 rename: No such file or directory."
+ }
+ file rename $path $newname
+ puts $outchan "250 RNTO command successful."
+ }
+ rmdir {
+ foreach {outchan} $args break
+
+ if {![file isdirectory $path]} {
+ puts $outchan "550 $path: Not a directory."
+ } elseif {[llength [glob -nocomplain [file join $path *]]] != 0} {
+ puts $outchan "550 $path: Directory not empty."
+ } else {
+ file delete $path
+ puts $outchan "250 RMD command successful."
+ }
+ }
+ size {
+ foreach {outchan} $args break
+
+ if {![file exists $path]} {
+ puts $outchan "550 $path: No such file or directory"
+ } elseif {![file isfile $path]} {
+ puts $outchan "550 $path: not a plain file."
+ } else {
+ puts $outchan "213 [file size $path]"
+ }
+ }
+ default {
+ error "Unknown command \"$command\""
+ }
+ }
+ return ""
+}
+
+# ::ftpd::fsFile::PermBits --
+#
+# Returns the file permissions for the specified file.
+#
+# Arguments:
+# file - The file to return the permissions of.
+#
+# Results:
+# The permissions for the specified file are returned.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::fsFile::PermBits {file mode} {
+
+ array set s {
+ 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
+ }
+
+ set type [file type $file]
+ if {[string equal $type "file"]} {
+ set permissions "-"
+ } else {
+ set permissions [string index $type 0]
+ }
+ foreach j [split [format %03o [expr {$mode&0777}]] {}] {
+ append permissions $s($j)
+ }
+
+ return $permissions
+}
+
+# ::ftpd::fsFile::FormDate --
+#
+# Returns the file permissions for the specified file.
+#
+# Arguments:
+# seconds - The number of seconds returned by 'file mtime'.
+#
+# Results:
+# A formatted date is returned.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::fsFile::FormDate {seconds} {
+
+ set currentTime [clock seconds]
+ set oldTime [clock scan "6 months ago" -base $currentTime]
+ if {$seconds <= $oldTime} {
+ set time [clock format $seconds -format "%Y"]
+ } else {
+ set time [clock format $seconds -format "%H:%M"]
+ }
+ set day [string trimleft [clock format $seconds -format "%d"] 0]
+ set month [clock format $seconds -format "%b"]
+ return [format "%3s %2s %5s" $month $day $time]
+}
+
+# Only provide the package if it has been successfully
+# sourced into the interpreter.
+
+#
+# Patched Mark O'Connor
+#
+package provide ftpd 1.3
+
+
+##
+## Implementation of passive command
+##
+proc ::ftpd::command::PASV {sock argument} {
+ upvar #0 ::ftpd::$sock data
+
+ set data(sock2a) [socket -server [list ::ftpd::PasvAccept $sock] 0]
+ set list1 [fconfigure $sock -sockname]
+ set ip [lindex $list1 0]
+ set list2 [fconfigure $data(sock2a) -sockname]
+ set port [lindex $list2 2]
+ ::ftpd::Log debug "PASV on {$list1} {$list2} $ip $port"
+ set ans [split $ip {.}]
+ lappend ans [expr {($port >> 8) & 0xff}] [expr {$port & 0xff}]
+ set ans [join $ans {,}]
+ puts $sock "227 Entering Passive Mode ($ans)."
+ set data(sock2) ""
+ return
+}
+
+
+proc ::ftpd::PasvAccept {sock sock2 ip port} {
+ upvar #0 ::ftpd::$sock data
+
+ ::ftpd::Log debug "In Pasv Accept with {$sock} {$sock2} {$ip} {$port}"
+ ##
+ ## Verify this is from who it should be
+ ##
+ if {![string equal $ip $data(ip)]} then {
+ ##
+ ## Nope, so close it and wait some more
+ ##
+ close $sock2
+ return
+ }
+ ::ftpd::FinishData $sock
+
+ set data(sock2) $sock2 ; # (*), see ::ftpd::PasvCheckAndWait
+ fconfigure $data(sock2) -translation $data(mode)
+ close $data(sock2a)
+ set data(sock2a) ""
+ return
+}
+
+proc ::ftpd::PasvCheckAndWait {sock} {
+ upvar #0 ::ftpd::$sock data
+
+ # Check if we are in passive mode, with the data connection not
+ # yet established. If so, wait for the data connection to be
+ # made. This vwait is unlocked by (*) in ::ftpd::PasvAccept above.
+
+ if {$data(sock2) != ""} return
+ vwait ::ftpd::${sock}(sock2)
+ return
+}
diff --git a/tcllib/modules/ftpd/pkgIndex.tcl b/tcllib/modules/ftpd/pkgIndex.tcl
new file mode 100644
index 0000000..68aa204
--- /dev/null
+++ b/tcllib/modules/ftpd/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded ftpd 1.3 [list source [file join $dir ftpd.tcl]]
generated by cgit v0.12 at 2025-04-17 08:20:31 (GMT)