util_http_file

util_http_file_upload (public, deprecated)

 util_http_file_upload [ -file file ] [ -data data ] [ -binary ] \
    [ -filename filename ] [ -name name ] [ -mime_type mime_type ] \
    [ -mode mode ] [ -rqset rqset ] url [ formvars ] [ timeout ] \
    [ depth ] [ http_referer ]

Defined in packages/acs-tcl/tcl/deprecated-procs.tcl

Deprecated. Invoking this procedure generates a warning.

Implement client-side HTTP file uploads as multipart/form-data as per RFC 1867.

Similar to util_httppost, but enhanced to be able to upload a file as multipart/form-data. Also useful for posting to forms that require their input to be encoded as multipart/form-data instead of as application/x-www-form-urlencoded.

The switches -file /path/to/file and -data $raw_data are mutually exclusive. You can specify one or the other, but not both. NOTE: it is perfectly valid to not specify either, in which case no file is uploaded, but form variables are encoded using multipart/form-data instead of the usual encoding (as noted above).

If you specify either -file or -data you must supply a value for -name, which is the name of the <INPUT TYPE="file" NAME="..."> form tag.

Specify the -binary switch if the file (or data) needs to be base-64 encoded. Not all servers seem to be able to handle this. (For example, http://mol-stage.usps.com/mml.adp, which expects to receive an XML file doesn't seem to grok any kind of Content-Transfer-Encoding.)

If you specify -file then -filename is optional (it can be inferred from the name of the file). However, if you specify -data then it is mandatory.

If -mime_type is not specified then ns_guesstype is used to try and find a mime type based on the filename. If ns_guesstype returns */* the generic value of application/octet-stream will be used.

Any form variables may be specified in one of four formats:

array (list of key value pairs like what [array get] returns)
formvars (list of url encoded formvars, i.e. foo=bar&x=1)
ns_set (an ns_set containing key/value pairs)
vars (a list of Tcl vars to grab from the calling environment)

-rqset specifies an ns_set of extra headers to send to the server when doing the POST.

timeout, depth, and http_referer are optional, and are included as optional positional variables in the same order they are used in util_httppost. NOTE: util_http_file_upload does not (currently) follow any redirects, so depth is superfluous.

Switches:

-file (optional)
-data (optional)
-binary (optional, boolean)
-filename (optional)
-name (optional)
-mime_type (optional, defaults to "*/*")
-mode (optional, defaults to "formvars")
-rqset (optional)

Parameters:

url (required)
formvars (optional)
timeout (optional, defaults to "30")
depth (optional, defaults to "10")
http_referer (optional)

Author:

Michael A. Cleverly <michael@cleverly.com>

Created:

3 September 2002

See Also:

util::http::post

Testcases:

No testcase defined.

Source code:

ad_log_deprecated proc util_http_file_upload

    # sanity checks on switches given
    if {$mode ni {formvars array ns_set vars}} {
        error "Invalid mode \"$mode\"; should be one of: formvars, array, ns_set, vars"
    }

    if {[info exists file] && [info exists data]} {
        error "Both -file and -data are mutually exclusive; can't use both"
    }

    if {[info exists file]} {
        if {![ad_file exists $file]} {
            error "Error reading file: $file not found"
        }

        if {![ad_file readable $file]} {
            error "Error reading file: $file permission denied"
        }

        set fp [open $file]
        fconfigure $fp -translation binary
        set data [read $fp]
        close $fp

        if {![info exists filename]} {
            set filename [ad_file tail $file]
        }

        if {$mime_type eq "*/*" || $mime_type eq ""} {
            set mime_type [ns_guesstype $file]
        }
    }

    set boundary [ns_sha1 [list [clock clicks -milliseconds] [clock seconds]]]
    set payload {}

    if {[info exists data] && [string length $data]} {
        if {![info exists name]} {
            error "Cannot upload file without specifying form variable -name"
        }

        if {![info exists filename]} {
            error "Cannot upload file without specifying -filename"
        }

        if {$mime_type eq "*/*" || $mime_type eq ""} {
            set mime_type [ns_guesstype $filename]

            if {$mime_type eq "*/*" || $mime_type eq ""} {
                set mime_type application/octet-stream
            }
        }

        if {$binary_p} {
            set data [base64::encode base64]
            set transfer_encoding base64
        } else {
            set transfer_encoding binary
        }

        append payload --$boundary  \r\n  "Content-Disposition: form-data; "  "name=\"$name\"; filename=\"$filename\""  \r\n  "Content-Type: $mime_type"  \r\n  "Content-transfer-encoding: $transfer_encoding"  \r\n  \r\n  $data  \r\n
    }


    set variables [list]
    switch -- $mode {
        array {
            set variables $formvars
        }

        formvars {
            foreach formvar [split $formvars &] {
                set formvar [split $formvar  =]
                set key [lindex $formvar 0]
                set val [join [lrange $formvar 1 end] =]
                lappend variables $key $val
            }
        }

        ns_set {
            for {set i 0} {$i < [ns_set size $formvars]} {incr i} {
                set key [ns_set key $formvars $i]
                set val [ns_set value $formvars $i]
                lappend variables $key $val
            }
        }

        vars {
            foreach key $formvars {
                upvar 1 $key val
                lappend variables $key $val
            }
        }
    }

    foreach {key val} $variables {
        append payload --$boundary  \r\n  "Content-Disposition: form-data; name=\"$key\""  \r\n  \r\n  $val  \r\n
    }

    append payload --$boundary-- \r\n

    if { [catch {
        if {[incr depth -1] <= 0} {
            return -code error "util_http_file_upload: Recursive redirection: $url"
        }

        lassign [util_httpopen POST $url $rqset $timeout $http_referer] rfd wfd

        _ns_http_puts $timeout $wfd  "Content-type: multipart/form-data; boundary=$boundary\r"
        _ns_http_puts $timeout $wfd "Content-length: [string length $payload]\r"
        _ns_http_puts $timeout $wfd \r
        _ns_http_puts $timeout $wfd "$payload\r"
        flush $wfd
        close $wfd

        set rpset [ns_set create [_ns_http_gets $timeout $rfd]]
        while 1 {
            set line [_ns_http_gets $timeout $rfd]
            if { $line eq "" } break
            ns_parseheader $rpset $line
        }

        set headers $rpset
        set response [ns_set name $headers]
        set status [lindex $response 1]
        set length [ns_set iget $headers content-length]
        if { "" eq $length } { set length -1 }
        set type [ns_set iget $headers content-type]
        set_encoding $type $rfd
        set err [catch {
            while 1 {
                set buf [_ns_http_read $timeout $rfd $length]
                append page $buf
                if { "" eq $buf } break
                if {$length > 0} {
                    incr length -[string length $buf]
                    if {$length <= 0} break
                }
            }
        } errMsg]

        ns_set free $headers
        close $rfd

        if {$err} {
            return -code error -errorinfo $::errorInfo $errMsg
        }
    } errmsg] } {
        if {[info exists wfd] && $wfd in [file channels]} {
            close $wfd
        }

        if {[info exists rfd] && $rfd in [file channels]} {
            close $rfd
        }

        set page -1
    }

    return $page

XQL Not present:

PostgreSQL, Oracle

Generic XQL file:

packages/acs-tcl/tcl/deprecated-procs.xql

[ hide source ] | [ make this the default ]