# ************* Save to upfile.tcl *********
Direct_Url /upfile UpFile
proc UpFile {} {
global env
set html "You can upload files to the /hup directory. The files currently in the /hup directory are listed in the table below.\n"
append html "<FORM action=/upfile/filedelete method=post>\n\
<CENTER>\n\
<TABLE bgcolor=\"#cc3300\" bordercolor=\"#cc3300\" border=\"1\" cellpadding=\"3\" cellspacing=\"3\">\n\
<TH> Delete </TH> <TH> Files in /hup/ Directory </TH>\n"
set file ""
foreach f [glob -nocomplain -- [Doc_Root]/hup/*] {
set file [file tail $f]
append html "<TR><TD ALIGN=center><INPUT type=\"CHECKBOX\" name=\"$file\"></TD><TD> $file </TD></TR>\n"
}
append html "<TR><TD ALIGN=center COLSPAN=\"2\"><input type=submit value=\"Delete Files\"></TD></TR>\n\
</TABLE>\n\
</CENTRE>\n\
</FORM>"
append html "<form ENCtype=multipart/form-data action=/fileupload method=post>\n"
append html "File <input type=file name=the_file>\n"
append html "<p>\n"
append html "<input type=submit>\n"
append html "</form>\n"
return $html
}
proc UpFile/filedelete {args} {
global env
foreach {name value} $args {
file delete [Doc_Root]/hup/$name
}
set html "<Html>\n"
append html "<Head>\n"
append html "<SCRIPT LANGUAGE=\"JavaScript\">\n"
append html "function topWindow()\{\n"
append html "window.location.href=\"http://$env(HTTP_HOST)/upfile\";\n"
append html "\}\n"
append html "onLoad=topWindow();\n"
append html "</script>"
append html "</Head>"
append html "<Body>"
append html "</Body>"
append html "</Html>"
return $html
}
# **************** Save to fileupload.tcl *********************
package require httpd::upload
Upload_Url /fileupload [Doc_Root]/hup FileUpload
proc FileUpload {args} {
global env
# Generate Page Header
set html "<Html>\n"
append html "<Head>\n"
append html "<SCRIPT LANGUAGE=\"JavaScript\">\n"
append html "function topWindow()\{\n"
append html "window.location.href=\"http://$env(HTTP_HOST)/upfile\";\n"
append html "\}\n"
append html "onLoad=topWindow();\n"
append html "</script>\n"
append html "</Head>\n"
append html "<Body>\n"
append html "</Body>\n"
append html "</Html>\n"
return $html
}I just tried the procedures by pasting them directly in the server console (tclhttpd with some stuff stripped and my own additions, not a multithreading version), and after making the needed dir it works nicely, though I do wonder whether the obvious and less obvious hacks are possible to get in the Docroot or worse file system by using the
../or one could try to change the upload url parameters. I didn't check either; when I do, I'll inform the audience of this page.As an aside, for the potential malicious hacker who may come across these pages: don't bother all too much, I make backups regularly, even intermediate ones on a CD-ROM I can simply drop everything new on, so there is not too much to gain anyway. And downloading outside the Docroot tree (within which everything is public anyhow) is not enabled in the server.
Question about Upload_Url: The optional argument
-maxbytes nnndoesn't seem to work. So the webserver has to receive a whole file before seeing that it is too large and purging it. Although running a multithread-supporting version of tcl an tclhttpd, the optional parameter
-thread 1hangs the fileupload process. Can anyone help? mailto:[email protected]
.I don't think some of the arguments in the upload.tcl file are implemented. I had a similar experience with -maxfiles nnn. I posted the TclHttpd mailing list and Brent Welch the author confirmed it wasn't. He was very kind and wrote some code which helped me get the feature to work but I don't think the code made it into the production release. Search the TclHttpd mailing list archive http://sourceforge.net/mail/?group_id=12884
or join the list and ask, everyone is friendly and willing to help. Michael HankinsonCMCc Spurred by this page, I implemented -maxfiles, -maxbytes and -totalbytes. (They're in CVS HEAD)I also fixed upload domain's ability to handle redirection, so now the following version of the above upload file will work. It's a bit shorter.
# a file upload capability
package require httpd::upload
Upload_Url /fileupload [file join [Doc_Root] hup] FileUpload -totalbytes 10000000
proc FileUpload {args} {
return [Redirect_Self /upfile]
}
Direct_Url /upfile UpFile
proc UpFile {} {
append html {
<form ENCtype=multipart/form-data action=/fileupload method=post>
<input type=submit value="Upload">
<input type=file name=the_file>
</form>
}
set files [glob -nocomplain -- [file join [Doc_Root] hup *]]
if {$files != {}} {
append html {
<form action=/upfile/filedelete method=post>
<table border="1">
<th><input type=submit value="Delete"></th>
<th>Files</th>
<th>Size</th>
<th>Date</th>
}
set file ""
foreach f $files {
set file [file tail $f]
append html [subst {
<tr>
<td align="center">
<input type="checkbox" name="$file">
</td>
<td>$file</td>
<td>[file size $f]</td>
<td>[clock format [file mtime $f] -format "%x %X"]</td>
</tr>
}]
}
append html {
</table>
</form>
}
}
return $html
}
proc UpFile/filedelete {args} {
foreach {name value} $args {
set name [file tail [file normalize $name]]
file delete [file join [Doc_Root] hup $name]
}
return [Redirect_Self /upfile]
}How about the ability to control the target file name, and to register the file in a database or such? How would one go about doing this?Thanks![gg] - 2007-02-07
Just answered the question myself - edit upload.tcl[gg] - 2007-02-07
stevel - 2009-07-29 20:30:19There is a lurking bug in tclhttpd's lib/upload.tcl code that is triggered by WebKit-based browsers - Safari, Chrome, Konqueror.Occasionally they generate a + in the upload boundary (WebKitFormBoundary) line, and this causes the regexp in proc UploadFindBoundary to fail.To resolve, change the regexp in lib/upload.tcl proc UploadFindBoundary near line 441 from
if {[regexp ^--$upload(boundary) $line]} {to a string match like
if {[string match --$upload(boundary)* $line]} {