source: proiecte/pmake3d/make3d_original/Make3dSingleImageStanford_version0.1/third_party/vrippack-0.31/src/vrip/lib/tcl/http2.3/http.tcl @ 37

Last change on this file since 37 was 37, checked in by (none), 14 years ago

Added original make3d
File size: 21.7 KB
Line 
1# http.tcl --
2#
3#       Client-side HTTP for GET, POST, and HEAD commands.
4#       These routines can be used in untrusted code that uses
5#       the Safesock security policy.  These procedures use a
6#       callback interface to avoid using vwait, which is not
7#       defined in the safe base.
8#
9# See the file "license.terms" for information on usage and
10# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11#
12# RCS: @(#) $Id: http.tcl,v 1.32.2.1 2000/05/31 01:28:57 sandeep Exp $
13
14# Rough version history:
15# 1.0   Old http_get interface
16# 2.0   http:: namespace and http::geturl
17# 2.1   Added callbacks to handle arriving data, and timeouts
18# 2.2   Added ability to fetch into a channel
19# 2.3   Added SSL support, and ability to post from a channel
20#       This version also cleans up error cases and eliminates the
21#       "ioerror" status in favor of raising an error
22
23package provide http 2.3
24
25namespace eval http {
26    variable http
27    array set http {
28        -accept */*
29        -proxyhost {}
30        -proxyport {}
31        -useragent {Tcl http client package 2.3}
32        -proxyfilter http::ProxyRequired
33    }
34
35    variable formMap
36    variable alphanumeric a-zA-Z0-9
37    variable c
38    variable i 0
39    for {} {$i <= 256} {incr i} {
40        set c [format %c $i]
41        if {![string match \[$alphanumeric\] $c]} {
42            set formMap($c) %[format %.2x $i]
43        }
44    }
45    # These are handled specially
46    array set formMap {
47        " " +   \n %0d%0a
48    }
49
50    variable urlTypes
51    array set urlTypes {
52        http    {80 ::socket}
53    }
54
55    namespace export geturl config reset wait formatQuery register unregister
56    # Useful, but not exported: data size status code
57}
58
59# http::register --
60#
61#     See documentaion for details.
62#
63# Arguments:
64#     proto           URL protocol prefix, e.g. https
65#     port            Default port for protocol
66#     command         Command to use to create socket
67# Results:
68#     list of port and command that was registered.
69
70proc http::register {proto port command} {
71    variable urlTypes
72    set urlTypes($proto) [list $port $command]
73}
74
75# http::unregister --
76#
77#     Unregisters URL protocol handler
78#
79# Arguments:
80#     proto           URL protocol prefix, e.g. https
81# Results:
82#     list of port and command that was unregistered.
83
84proc http::unregister {proto} {
85    variable urlTypes
86    if {![info exists urlTypes($proto)]} {
87        return -code error "unsupported url type \"$proto\""
88    }
89    set old $urlTypes($proto)
90    unset urlTypes($proto)
91    return $old
92}
93
94# http::config --
95#
96#       See documentaion for details.
97#
98# Arguments:
99#       args            Options parsed by the procedure.
100# Results:
101#        TODO
102
103proc http::config {args} {
104    variable http
105    set options [lsort [array names http -*]]
106    set usage [join $options ", "]
107    if {[llength $args] == 0} {
108        set result {}
109        foreach name $options {
110            lappend result $name $http($name)
111        }
112        return $result
113    }
114    regsub -all -- - $options {} options
115    set pat ^-([join $options |])$
116    if {[llength $args] == 1} {
117        set flag [lindex $args 0]
118        if {[regexp -- $pat $flag]} {
119            return $http($flag)
120        } else {
121            return -code error "Unknown option $flag, must be: $usage"
122        }
123    } else {
124        foreach {flag value} $args {
125            if {[regexp -- $pat $flag]} {
126                set http($flag) $value
127            } else {
128                return -code error "Unknown option $flag, must be: $usage"
129            }
130        }
131    }
132}
133
134# http::Finish --
135#
136#       Clean up the socket and eval close time callbacks
137#
138# Arguments:
139#       token       Connection token.
140#       errormsg    (optional) If set, forces status to error.
141#       skipCB      (optional) If set, don't call the -command callback.  This
142#                   is useful when geturl wants to throw an exception instead
143#                   of calling the callback.  That way, the same error isn't
144#                   reported to two places.
145#
146# Side Effects:
147#        Closes the socket
148
149proc http::Finish { token {errormsg ""} {skipCB 0}} {
150    variable $token
151    upvar 0 $token state
152    global errorInfo errorCode
153    if {[string length $errormsg] != 0} {
154        set state(error) [list $errormsg $errorInfo $errorCode]
155        set state(status) error
156    }
157    catch {close $state(sock)}
158    catch {after cancel $state(after)}
159    if {[info exists state(-command)] && !$skipCB} {
160        if {[catch {eval $state(-command) {$token}} err]} {
161            if {[string length $errormsg] == 0} {
162                set state(error) [list $err $errorInfo $errorCode]
163                set state(status) error
164            }
165        }
166        if {[info exist state(-command)]} {
167            # Command callback may already have unset our state
168            unset state(-command)
169        }
170    }
171}
172
173# http::reset --
174#
175#       See documentaion for details.
176#
177# Arguments:
178#       token   Connection token.
179#       why     Status info.
180#
181# Side Effects:
182#       See Finish
183
184proc http::reset { token {why reset} } {
185    variable $token
186    upvar 0 $token state
187    set state(status) $why
188    catch {fileevent $state(sock) readable {}}
189    catch {fileevent $state(sock) writable {}}
190    Finish $token
191    if {[info exists state(error)]} {
192        set errorlist $state(error)
193        unset state
194        eval error $errorlist
195    }
196}
197
198# http::geturl --
199#
200#       Establishes a connection to a remote url via http.
201#
202# Arguments:
203#       url             The http URL to goget.
204#       args            Option value pairs. Valid options include:
205#                               -blocksize, -validate, -headers, -timeout
206# Results:
207#       Returns a token for this connection.
208#       This token is the name of an array that the caller should
209#       unset to garbage collect the state.
210
211proc http::geturl { url args } {
212    variable http
213    variable urlTypes
214
215    # Initialize the state variable, an array.  We'll return the
216    # name of this array as the token for the transaction.
217
218    if {![info exists http(uid)]} {
219        set http(uid) 0
220    }
221    set token [namespace current]::[incr http(uid)]
222    variable $token
223    upvar 0 $token state
224    reset $token
225
226    # Process command options.
227
228    array set state {
229        -blocksize      8192
230        -queryblocksize 8192
231        -validate       0
232        -headers        {}
233        -timeout        0
234        -type           application/x-www-form-urlencoded
235        -queryprogress  {}
236        state           header
237        meta            {}
238        currentsize     0
239        totalsize       0
240        querylength     0
241        queryoffset     0
242        type            text/html
243        body            {}
244        status          ""
245        http            ""
246    }
247    set options {-blocksize -channel -command -handler -headers \
248            -progress -query -queryblocksize -querychannel -queryprogress\
249            -validate -timeout -type}
250    set usage [join $options ", "]
251    regsub -all -- - $options {} options
252    set pat ^-([join $options |])$
253    foreach {flag value} $args {
254        if {[regexp $pat $flag]} {
255            # Validate numbers
256            if {[info exists state($flag)] && \
257                    [string is integer -strict $state($flag)] && \
258                    ![string is integer -strict $value]} {
259                unset $token
260                return -code error "Bad value for $flag ($value), must be integer"
261            }
262            set state($flag) $value
263        } else {
264            unset $token
265            return -code error "Unknown option $flag, can be: $usage"
266        }
267    }
268
269    # Make sure -query and -querychannel aren't both specified
270
271    set isQueryChannel [info exists state(-querychannel)]
272    set isQuery [info exists state(-query)]
273    if {$isQuery && $isQueryChannel} {
274        unset $token
275        return -code error "Can't combine -query and -querychannel options!"
276    }
277
278    # Validate URL, determine the server host and port, and check proxy case
279
280    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
281            x prefix proto host y port srvurl]} {
282        unset $token
283        return -code error "Unsupported URL: $url"
284    }
285    if {[string length $proto] == 0} {
286        set proto http
287        set url ${proto}://$url
288    }
289    if {![info exists urlTypes($proto)]} {
290        unset $token
291        return -code error "Unsupported URL type \"$proto\""
292    }
293    set defport [lindex $urlTypes($proto) 0]
294    set defcmd [lindex $urlTypes($proto) 1]
295
296    if {[string length $port] == 0} {
297        set port $defport
298    }
299    if {[string length $srvurl] == 0} {
300        set srvurl /
301    }
302    if {[string length $proto] == 0} {
303        set url http://$url
304    }
305    set state(url) $url
306    if {![catch {$http(-proxyfilter) $host} proxy]} {
307        set phost [lindex $proxy 0]
308        set pport [lindex $proxy 1]
309    }
310
311    # If a timeout is specified we set up the after event
312    # and arrange for an asynchronous socket connection.
313
314    if {$state(-timeout) > 0} {
315        set state(after) [after $state(-timeout) \
316                [list http::reset $token timeout]]
317        set async -async
318    } else {
319        set async ""
320    }
321
322    # If we are using the proxy, we must pass in the full URL that
323    # includes the server name.
324
325    if {[info exists phost] && [string length $phost]} {
326        set srvurl $url
327        set conStat [catch {eval $defcmd $async {$phost $pport}} s]
328    } else {
329        set conStat [catch {eval $defcmd $async {$host $port}} s]
330    }
331    if {$conStat} {
332
333        # something went wrong while trying to establish the connection
334        # Clean up after events and such, but DON'T call the command callback
335        # (if available) because we're going to throw an exception from here
336        # instead.
337        Finish $token "" 1
338        cleanup $token
339        return -code error $s
340    }
341    set state(sock) $s
342
343    # Wait for the connection to complete
344
345    if {$state(-timeout) > 0} {
346        fileevent $s writable [list http::Connect $token]
347        http::wait $token
348
349        if {[string equal $state(status) "error"]} {
350            # something went wrong while trying to establish the connection
351            # Clean up after events and such, but DON'T call the command
352            # callback (if available) because we're going to throw an
353            # exception from here instead.
354            set err [lindex $state(error) 0]
355            cleanup $token
356            return -code error $err
357        } elseif {![string equal $state(status) "connect"]} {
358            # Likely to be connection timeout
359            return $token
360        }
361        set state(status) ""
362    }
363
364    # Send data in cr-lf format, but accept any line terminators
365
366    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
367
368    # The following is disallowed in safe interpreters, but the socket
369    # is already in non-blocking mode in that case.
370
371    catch {fconfigure $s -blocking off}
372    set how GET
373    if {$isQuery} {
374        set state(querylength) [string length $state(-query)]
375        if {$state(querylength) > 0} {
376            set how POST
377            set contDone 0
378        } else {
379            # there's no query data
380            unset state(-query)
381            set isQuery 0
382        }
383    } elseif {$state(-validate)} {
384        set how HEAD
385    } elseif {$isQueryChannel} {
386        set how POST
387        # The query channel must be blocking for the async Write to
388        # work properly.
389        fconfigure $state(-querychannel) -blocking 1 -translation binary
390        set contDone 0
391    }
392
393    if {[catch {
394        puts $s "$how $srvurl HTTP/1.0"
395        puts $s "Accept: $http(-accept)"
396        puts $s "Host: $host"
397        puts $s "User-Agent: $http(-useragent)"
398        foreach {key value} $state(-headers) {
399            regsub -all \[\n\r\]  $value {} value
400            set key [string trim $key]
401            if {[string equal $key "Content-Length"]} {
402                set contDone 1
403                set state(querylength) $value
404            }
405            if {[string length $key]} {
406                puts $s "$key: $value"
407            }
408        }
409        if {$isQueryChannel && $state(querylength) == 0} {
410            # Try to determine size of data in channel
411            # If we cannot seek, the surrounding catch will trap us
412
413            set start [tell $state(-querychannel)]
414            seek $state(-querychannel) 0 end
415            set state(querylength) \
416                    [expr {[tell $state(-querychannel)] - $start}]
417            seek $state(-querychannel) $start
418        }
419
420        # Flush the request header and set up the fileevent that will
421        # either push the POST data or read the response.
422        #
423        # fileevent note:
424        #
425        # It is possible to have both the read and write fileevents active
426        # at this point.  The only scenario it seems to affect is a server
427        # that closes the connection without reading the POST data.
428        # (e.g., early versions TclHttpd in various error cases).
429        # Depending on the platform, the client may or may not be able to
430        # get the response from the server because of the error it will
431        # get trying to write the post data.  Having both fileevents active
432        # changes the timing and the behavior, but no two platforms
433        # (among Solaris, Linux, and NT)  behave the same, and none
434        # behave all that well in any case.  Servers should always read thier
435        # POST data if they expect the client to read their response.
436               
437        if {$isQuery || $isQueryChannel} {
438            puts $s "Content-Type: $state(-type)"
439            if {!$contDone} {
440                puts $s "Content-Length: $state(querylength)"
441            }
442            puts $s ""
443            fconfigure $s -translation {auto binary}
444            fileevent $s writable [list http::Write $token]
445        } else {
446            puts $s ""
447            flush $s
448            fileevent $s readable [list http::Event $token]
449        }
450
451        if {! [info exists state(-command)]} {
452
453            # geturl does EVERYTHING asynchronously, so if the user
454            # calls it synchronously, we just do a wait here.
455
456            wait $token
457            if {[string equal $state(status) "error"]} {
458                # Something went wrong, so throw the exception, and the
459                # enclosing catch will do cleanup.
460                return -code error [lindex $state(error) 0]
461            }           
462        }
463    } err]} {
464        # The socket probably was never connected,
465        # or the connection dropped later.
466
467        # Clean up after events and such, but DON'T call the command callback
468        # (if available) because we're going to throw an exception from here
469        # instead.
470       
471        # if state(status) is error, it means someone's already called Finish
472        # to do the above-described clean up.
473        if {[string equal $state(status) "error"]} {
474            Finish $token $err 1
475        }
476        cleanup $token
477        return -code error $err
478    }
479
480    return $token
481}
482
483# Data access functions:
484# Data - the URL data
485# Status - the transaction status: ok, reset, eof, timeout
486# Code - the HTTP transaction code, e.g., 200
487# Size - the size of the URL data
488
489proc http::data {token} {
490    variable $token
491    upvar 0 $token state
492    return $state(body)
493}
494proc http::status {token} {
495    variable $token
496    upvar 0 $token state
497    return $state(status)
498}
499proc http::code {token} {
500    variable $token
501    upvar 0 $token state
502    return $state(http)
503}
504proc http::ncode {token} {
505    variable $token
506    upvar 0 $token state
507    if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
508        return $numeric_code
509    } else {
510        return $state(http)
511    }
512}
513proc http::size {token} {
514    variable $token
515    upvar 0 $token state
516    return $state(currentsize)
517}
518
519proc http::error {token} {
520    variable $token
521    upvar 0 $token state
522    if {[info exists state(error)]} {
523        return $state(error)
524    }
525    return ""
526}
527
528# http::cleanup
529#
530#       Garbage collect the state associated with a transaction
531#
532# Arguments
533#       token   The token returned from http::geturl
534#
535# Side Effects
536#       unsets the state array
537
538proc http::cleanup {token} {
539    variable $token
540    upvar 0 $token state
541    if {[info exist state]} {
542        unset state
543    }
544}
545
546# http::Connect
547#
548#       This callback is made when an asyncronous connection completes.
549#
550# Arguments
551#       token   The token returned from http::geturl
552#
553# Side Effects
554#       Sets the status of the connection, which unblocks
555#       the waiting geturl call
556
557proc http::Connect {token} {
558    variable $token
559    upvar 0 $token state
560    global errorInfo errorCode
561    if {[eof $state(sock)] ||
562        [string length [fconfigure $state(sock) -error]]} {
563            Finish $token "connect failed [fconfigure $state(sock) -error]" 1
564    } else {
565        set state(status) connect
566        fileevent $state(sock) writable {}
567    }
568    return
569}
570
571# http::Write
572#
573#       Write POST query data to the socket
574#
575# Arguments
576#       token   The token for the connection
577#
578# Side Effects
579#       Write the socket and handle callbacks.
580
581proc http::Write {token} {
582    variable $token
583    upvar 0 $token state
584    set s $state(sock)
585   
586    # Output a block.  Tcl will buffer this if the socket blocks
587   
588    set done 0
589    if {[catch {
590       
591        # Catch I/O errors on dead sockets
592
593        if {[info exists state(-query)]} {
594           
595            # Chop up large query strings so queryprogress callback
596            # can give smooth feedback
597
598            puts -nonewline $s \
599                    [string range $state(-query) $state(queryoffset) \
600                    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
601            incr state(queryoffset) $state(-queryblocksize)
602            if {$state(queryoffset) >= $state(querylength)} {
603                set state(queryoffset) $state(querylength)
604                set done 1
605            }
606        } else {
607           
608            # Copy blocks from the query channel
609
610            set outStr [read $state(-querychannel) $state(-queryblocksize)]
611            puts -nonewline $s $outStr
612            incr state(queryoffset) [string length $outStr]
613            if {[eof $state(-querychannel)]} {
614                set done 1
615            }
616        }
617    } err]} {
618        # Do not call Finish here, but instead let the read half of
619        # the socket process whatever server reply there is to get.
620
621        set state(posterror) $err
622        set done 1
623    }
624    if {$done} {
625        catch {flush $s}
626        fileevent $s writable {}
627        fileevent $s readable [list http::Event $token]
628    }
629
630    # Callback to the client after we've completely handled everything
631
632    if {[string length $state(-queryprogress)]} {
633        eval $state(-queryprogress) [list $token $state(querylength)\
634                $state(queryoffset)]
635    }
636}
637
638# http::Event
639#
640#       Handle input on the socket
641#
642# Arguments
643#       token   The token returned from http::geturl
644#
645# Side Effects
646#       Read the socket and handle callbacks.
647
648 proc http::Event {token} {
649    variable $token
650    upvar 0 $token state
651    set s $state(sock)
652
653     if {[eof $s]} {
654        Eof $token
655        return
656    }
657    if {[string equal $state(state) "header"]} {
658        if {[catch {gets $s line} n]} {
659            Finish $token $n
660        } elseif {$n == 0} {
661            set state(state) body
662            if {![regexp -nocase ^text $state(type)]} {
663                # Turn off conversions for non-text data
664                fconfigure $s -translation binary
665                if {[info exists state(-channel)]} {
666                    fconfigure $state(-channel) -translation binary
667                }
668            }
669            if {[info exists state(-channel)] &&
670                    ![info exists state(-handler)]} {
671                # Initiate a sequence of background fcopies
672                fileevent $s readable {}
673                CopyStart $s $token
674            }
675        } elseif {$n > 0} {
676            if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
677                set state(type) [string trim $type]
678            }
679            if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
680                set state(totalsize) [string trim $length]
681            }
682            if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
683                lappend state(meta) $key [string trim $value]
684            } elseif {[regexp ^HTTP $line]} {
685                set state(http) $line
686            }
687        }
688    } else {
689        if {[catch {
690            if {[info exists state(-handler)]} {
691                set n [eval $state(-handler) {$s $token}]
692            } else {
693                set block [read $s $state(-blocksize)]
694                set n [string length $block]
695                if {$n >= 0} {
696                    append state(body) $block
697                }
698            }
699            if {$n >= 0} {
700                incr state(currentsize) $n
701            }
702        } err]} {
703            Finish $token $err
704        } else {
705            if {[info exists state(-progress)]} {
706                eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
707            }
708        }
709    }
710}
711
712# http::CopyStart
713#
714#       Error handling wrapper around fcopy
715#
716# Arguments
717#       s       The socket to copy from
718#       token   The token returned from http::geturl
719#
720# Side Effects
721#       This closes the connection upon error
722
723 proc http::CopyStart {s token} {
724    variable $token
725    upvar 0 $token state
726    if {[catch {
727        fcopy $s $state(-channel) -size $state(-blocksize) -command \
728            [list http::CopyDone $token]
729    } err]} {
730        Finish $token $err
731    }
732}
733
734# http::CopyDone
735#
736#       fcopy completion callback
737#
738# Arguments
739#       token   The token returned from http::geturl
740#       count   The amount transfered
741#
742# Side Effects
743#       Invokes callbacks
744
745 proc http::CopyDone {token count {error {}}} {
746    variable $token
747    upvar 0 $token state
748    set s $state(sock)
749    incr state(currentsize) $count
750    if {[info exists state(-progress)]} {
751        eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
752    }
753    # At this point the token may have been reset
754    if {[string length $error]} {
755        Finish $token $error
756    } elseif {[catch {eof $s} iseof] || $iseof} {
757        Eof $token
758    } else {
759        CopyStart $s $token
760    }
761}
762
763# http::Eof
764#
765#       Handle eof on the socket
766#
767# Arguments
768#       token   The token returned from http::geturl
769#
770# Side Effects
771#       Clean up the socket
772
773 proc http::Eof {token} {
774    variable $token
775    upvar 0 $token state
776    if {[string equal $state(state) "header"]} {
777        # Premature eof
778        set state(status) eof
779    } else {
780        set state(status) ok
781    }
782    set state(state) eof
783    Finish $token
784}
785
786# http::wait --
787#
788#       See documentaion for details.
789#
790# Arguments:
791#       token   Connection token.
792#
793# Results:
794#        The status after the wait.
795
796proc http::wait {token} {
797    variable $token
798    upvar 0 $token state
799
800    if {![info exists state(status)] || [string length $state(status)] == 0} {
801        # We must wait on the original variable name, not the upvar alias
802        vwait $token\(status)
803    }
804
805    return $state(status)
806}
807
808# http::formatQuery --
809#
810#       See documentaion for details.
811#       Call http::formatQuery with an even number of arguments, where
812#       the first is a name, the second is a value, the third is another
813#       name, and so on.
814#
815# Arguments:
816#       args    A list of name-value pairs.
817#
818# Results:
819#        TODO
820
821proc http::formatQuery {args} {
822    set result ""
823    set sep ""
824    foreach i $args {
825        append result $sep [mapReply $i]
826        if {[string compare $sep "="]} {
827            set sep =
828        } else {
829            set sep &
830        }
831    }
832    return $result
833}
834
835# http::mapReply --
836#
837#       Do x-www-urlencoded character mapping
838#
839# Arguments:
840#       string  The string the needs to be encoded
841#
842# Results:
843#       The encoded string
844
845 proc http::mapReply {string} {
846    variable formMap
847
848    # The spec says: "non-alphanumeric characters are replaced by '%HH'"
849    # 1 leave alphanumerics characters alone
850    # 2 Convert every other character to an array lookup
851    # 3 Escape constructs that are "special" to the tcl parser
852    # 4 "subst" the result, doing all the array substitutions
853
854    set alphanumeric    a-zA-Z0-9
855    regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
856    regsub -all \n $string {\\n} string
857    regsub -all \t $string {\\t} string
858    regsub -all {[][{})\\]\)} $string {\\&} string
859    return [subst $string]
860}
861
862# http::ProxyRequired --
863#       Default proxy filter.
864#
865# Arguments:
866#       host    The destination host
867#
868# Results:
869#       The current proxy settings
870
871 proc http::ProxyRequired {host} {
872    variable http
873    if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
874        if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
875            set http(-proxyport) 8080
876        }
877        return [list $http(-proxyhost) $http(-proxyport)]
878    } else {
879        return {}
880    }
881}
Note: See TracBrowser for help on using the repository browser.