1#! /bin/sh
2# -*- tcl -*- \
3exec tclsh "$0" ${1+"$@"}
4
5# FTP daemon
6
7# This ftpd runs on port 7777, uses /tmp as root dir and does not do
8# any authentication at all. IOW, do not run this server for longer
9# periods of time or you create a security hole on your machine. This
10# server is strictly for short testing the implementation of the ftp
11# module over short periods of time.
12
13package require Tcl 8.3
14package require ftpd
15package require log
16
17proc bgerror {args} {
18    global errorInfo
19    puts stderr "bgerror: [join $args]"
20    puts stderr $errorInfo
21}
22
23proc ftplog {level text} {
24    if {[string equal $level note]} {set level notice}
25    log::log $level $text
26}
27
28proc noauth {args} {
29    return 1
30}
31
32proc fakefs {cmd path args} {
33    # Use the standard unix fs, i.e. "::ftpd::fsFile::fs", but rewrite the incoming path
34    # to stay in the /tmp directory.
35
36    set path [file join / tmp [file tail $path]]
37    eval [linsert $args 0 ::ftpd::fsFile::fs $cmd $path]
38}
39
40::ftpd::config -logCmd ftplog -authUsrCmd noauth -authFileCmd noauth -fsCmd fakefs
41set ::ftpd::port 7777 ; # Listen on user port
42
43::ftpd::server
44vwait forever
45