## uploadlib.tcl v1.0 by Perki Sun 1st Nov 98 ## plegris@fbwww.epfl.ch (Pierre-Mikael Legris) ## if you find any bug please mail me ## all rights reserved to anyone ## ## Tested with Netscape4 under linux and winnt ## ## This lib allow to upload binary and non-binary files from a web page ## It also gets any INPUTS type that would comes with it such as ## 'radios' 'text' 'hiddens' ... ## all thoses values are stored in a global array called in_array ## the value in_array(null) is set to be sure nor to work with an empty or ## unexistant array (this can be unset using 'unset in_array(null)' ## ## ## the proc is called like this: ## 'set result [uploadbin ' ## path : path where to save the files ## overwrite if = 1 new files will overwrite the same named files ## if = 0 new files will be named file1.txt if file.txt exists ## the proc return a string of like this: " .. ## ##EXAMPLE-- ## HTML FILE: NAME upload.html ## ## ## ## script: receive.cgi ## #!/usr/local/bin/tclsh ## source uploadlib.tcl ## puts "Content-type: text/html\n\n" ## set result [uploadbin "./" 0] ## puts "[lindex $result 0] files reveived names: [lrange $result 1 end]
" ## unset in_array(null) ## puts "

INPUTS:
" ## foreach name [array names in_array] { ## puts "$name: $in_array($name)
" ## } ## puts "" if {[info commands "unsupported0"] == "unsupported0"} { rename unsupported0 copychannel } ## I don't know if fcopy support ?chunkSize? like copychannel ## If it does not then tell me I'll have to update some of my code if {[info commands "copychannel"] == ""} { proc copychannel {in out} { fcopy $in $out } } set in_array(null) "" proc uploadbin { path overwrite} { global env in_array ## Set the temporary directory here set tmp "/tmp" set result "" set filec 0 catch { ### this get the boundary regexp boundary=(.*) $env(CONTENT_TYPE) dummy bound regsub -all {\-} $bound "" bound ### use the first available "CGITCLup*" name set i 0 set tmpf "$tmp/CGIupload" while {[file exists "$tmpf$i"]} { incr i} set tmpf "$tmpf$i" ### copy the incoming stream to the temp file fconfigure stdin -translation binary set out [open "$tmpf" w] fconfigure $out -translation binary copychannel stdin $out close $out ### open the temp file set in [open "$tmpf" r] fconfigure $in -translation binary set line "" while {! [eof $in]} { set cont 1 ## check if this line is a bound if {[regexp $bound $line]} { ## read until It gets Content-Disposition while {! [regexp "Content-Disposition(.*)" $line dummy test] } { if {[eof $in]} { set cont 0 break } set line [gets $in] } ## get the filename set filename "" if {(0 == [regexp {filename="(.*)"} $test dummy filename]) && $cont} { ## ok this is an other type of input! let's get the content and ## continue the hard job .. if {(0 == [regexp {name="(.*)"} $test dummy fieldname]) && $cont} { ## well there is not even a valid input .. Error! :( set cont 0 } else { ## ok valid input, I admit that the next line is a return (lame) set line [gets $in] set value "" # now we are looking for the last bound while {(! [regexp $bound $line]) && $cont} { if {[eof $in]} { set cont 0 ; break } ## if the input was text with returns, it isn't anymore! set value "$value $line" set line [gets $in] } ## save this value in in_array if {[regexp $fieldname [array names in_array]]} { set in_array($fieldname) "$in_array($fieldname) $value" } else { set in_array($fieldname) $value } set cont 0 } } ## ferify if it's a real file if {([string length $filename] == 0) && $cont} { set cont 0 } set tmpl(name) $filename #seek the temp file until the start of data if {$cont} { set conts 1 if { [read $in 2] == "\r\n" } { set conts 0 } while { $conts } { if { [eof $in] } { set cont 0 break } set line [gets $in] if { [read $in 2] == "\r\n" } { set conts 0 } } } if {$cont} { # offset of data let's remmeber it set tmpl(start) [tell $in] # now we are looking for the last bound set line [gets $in] while {(! [regexp $bound $line]) && $cont} { if {[eof $in]} { set cont 0 break } # I just save the offset of each line to not count the boundary set tmpl(stop) [tell $in] set line [gets $in] } ## now that all tests are passed and I got the offsets, I can save them if {$cont && ([expr $tmpl(stop) - $tmpl(start)] > 2)} { incr filec set fl(n$filec) $tmpl(name) set fl(d$filec) $tmpl(start) ## I do a minus 2 on the last offset to not count the "\n\r" set fl(f$filec) [expr $tmpl(stop) -2] } } } else { set line [gets $in] } } for {set j 1} {$j < [expr $filec + 1]} {incr j} { ## if overwrite = 0 we have to choose a new name for this file if {$overwrite == 0} { set tmpn $fl(n$j) for {set k 1} {[file exists "$path$tmpn"]} {incr k} { if {! [regsub "\\." $fl(n$j) "$k." tmpn]} { set tmpn "$fl(n$j)$k" } } set fl(n$j) $tmpn } # now that we know the seeks to lets dump the files! if {$fl(f$j) > $fl(d$j)} { set out [open "$path$fl(n$j)" w] fconfigure $out -translation binary seek $in $fl(d$j) start copychannel $in $out [expr $fl(f$j) - $fl(d$j)] close $out set result "$result $fl(n$j)" } } close $in } msg ## I remove the temp file catch { exec rm $tmpf } msg return "$filec $result" }