Tk Library Source Code

Artifact 93ff586e97c23a8f89151712055ec7285e94d71a:

package require http
package require mime

#
# For output
#
proc debugMsg { msg } {
        tk_messageBox -type ok -icon error -message $msg
}

#
# HTTP Form Post functions
# From http://wiki.tcl.tk/13675
#
proc  form-data-compose {partv {type multipart/form-data}} {
     upvar 1 $partv parts

     set mime [mime::initialize -canonical $type -parts $parts]
     set packaged [mime::buildmessage $mime]
     foreach part $parts {
 	mime::finalize $part
     }
     mime::finalize $mime

     return $packaged
 }
proc  form-data-add_binary {partv name filename value type} {
     upvar 1 $partv parts
     set disposition "form-data; name=\"${name}\"; filename=\"$filename\""
     lappend parts [mime::initialize -canonical $type \
 		   -string $value \
 		   -encoding binary \
 		   -header [list Content-Disposition $disposition]]
 }

 proc  form-data-add_field {partv name value} {
     upvar 1 $partv parts
     set disposition "form-data; name=\"${name}\""
     lappend parts [mime::initialize -canonical text/plain -string $value \
 		       -header [list Content-Disposition $disposition]]
 }
 proc  form-data-format {name filename value type args} {
     set parts {}
     foreach {n v} $args {
 	add_field parts $n $v
     }
     form-data-add_binary parts $name $filename $value $type
     return [form-data-compose parts]
 }

# Get contents of the file

    set filePath "transferFile.txt";

    set fd [open $filePath r]
    fconfigure $fd -translation binary -encoding binary
    set content [read $fd]
    close $fd

    debugMsg "Original file length [file size $filePath]";

    # format the file and form
    set message [eval [list  form-data-format \
		   "file" [file tail $filePath] $content 'image/jpeg']]

    # parse the headers out of the message body
    set headerEnd [string first "\r\n\r\n" $message]
    incr headerEnd 1
    set bodystart [expr $headerEnd + 3]
    set headers_raw [string range $message 0 $headerEnd]
    set body [string range $message $bodystart end]
    set headers_raw [string map {"\r\n " " " "\r\n" "\n"} $headers_raw]
    regsub {  +} $headers_raw " " headers_raw

    foreach line [split $headers_raw "\n"] {
	regexp {^([^:]+): (.*)$} $line all label value
	lappend headers $label $value
    }

    # get the content-type
    array set ha $headers
    set content_type $ha(Content-Type)
    unset ha(Content-Type)
    set headers [array get ha]

    set token [::http::geturl "http://www.phogle.com/testmd5.php" -type $content_type -binary true \
                -headers $headers -query $body]

    set httpBody [::http::data $token]

    debugMsg "HTTP server says: $httpBody";