Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

3 files changed, 79 insertions, 0 deletions

diff --git a/tcllib/examples/ftpd/ftpd b/tcllib/examples/ftpd/ftpd
new file mode 100755
index 0000000..57f9298
--- /dev/null
+++ b/tcllib/examples/ftpd/ftpd
@@ -0,0 +1,18 @@
+#!/usr/bin/env tclsh
+## -*- tcl -*-
+# FTP daemon
+
+package require Tcl 8.3
+if {[catch {package require ftpd}]} {
+    set here [file dirname [info script]]
+    source [file join .. $here ftpd.tcl]
+}
+
+proc bgerror {args} {
+    global errorInfo
+    puts stderr "bgerror: [join $args]"
+    puts stderr $errorInfo
+}
+
+::ftpd::server
+vwait forever
diff --git a/tcllib/examples/ftpd/ftpd.test b/tcllib/examples/ftpd/ftpd.test
new file mode 100755
index 0000000..e599e54
--- /dev/null
+++ b/tcllib/examples/ftpd/ftpd.test
@@ -0,0 +1,42 @@
+#!/usr/bin/env tclsh
+## -*- tcl -*-
+# FTP daemon
+
+# This ftpd runs on port 7777, uses /tmp as root dir and does not do
+# any authentication at all. IOW, do not run this server for longer
+# periods of time or you create a security hole on your machine. This
+# server is strictly for short testing the implementation of the ftp
+# module over short periods of time.
+
+package require Tcl 8.3
+package require ftpd
+package require log
+
+proc bgerror {args} {
+    global errorInfo
+    puts stderr "bgerror: [join $args]"
+    puts stderr $errorInfo
+}
+
+proc ftplog {level text} {
+    if {[string equal $level note]} {set level notice}
+    log::log $level $text
+}
+
+proc noauth {args} {
+    return 1
+}
+
+proc fakefs {cmd path args} {
+    # Use the standard unix fs, i.e. "::ftpd::fsFile::fs", but rewrite the incoming path
+    # to stay in the /tmp directory.
+
+    set path [file join / tmp [file tail $path]]
+    eval [linsert $args 0 ::ftpd::fsFile::fs $cmd $path]
+}
+
+::ftpd::config -logCmd ftplog -authUsrCmd noauth -authFileCmd noauth -fsCmd fakefs
+set ::ftpd::port 7777 ; # Listen on user port
+
+::ftpd::server
+vwait forever
diff --git a/tcllib/examples/ftpd/ftpd.unix b/tcllib/examples/ftpd/ftpd.unix
new file mode 100755
index 0000000..03ef926
--- /dev/null
+++ b/tcllib/examples/ftpd/ftpd.unix
@@ -0,0 +1,19 @@
+#!/usr/bin/env tclsh
+## -*- tcl -*-
+# FTP daemon
+
+package require Tcl 8.3
+if {[catch {package require ftpd}]} {
+    set here [file dirname [info script]]
+    source [file join .. $here ftpd.tcl]
+}
+
+proc bgerror {args} {
+    global errorInfo
+    puts stderr "bgerror: [join $args]"
+    puts stderr $errorInfo
+}
+
+::ftpd::config -authUsrCmd ::ftpd::unixAuth
+::ftpd::server
+vwait forever