File: tclcurl.tcl

package info (click to toggle)
tclcurl 0.9.5-1
  • links: PTS
  • area: main
  • in suites: woody
  • size: 764 kB
  • ctags: 222
  • sloc: ansic: 1,804; tcl: 712; sh: 212; makefile: 42
file content (103 lines) | stat: -rw-r--r-- 3,687 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
################################################################################
################################################################################
####                                  tclcurl.tcl
################################################################################
################################################################################
## Includes the tcl part of TclCurl
################################################################################
################################################################################
## (c) 2001-2002 Andr�s Garc�a Garc�a. fandom@retemail.es
## See the file "license.terms" for information on usage and redistribution
## of this file and for a DISCLAIMER OF ALL WARRANTIES.
################################################################################
################################################################################

package provide TclCurl 0.9.5

namespace eval curl {

################################################################################
# configure
#    Invokes the 'curl-config' script to be able to know what features have
#    been compiled in the installed version of libcurl.
#    Possible options are '-prefix', '-feature' and 'vernum'
################################################################################
proc curlConfig {option} {

    if {$::tcl_platform(platform)=="windows"} {
        error "This command is not available in Windows"
    }

    switch -exact -- $option {
        -prefix {
            return [exec curl-config --prefix]
        }
        -feature {
            set featureList [exec curl-config --feature]
            regsub -all {\\n} $featureList { } featureList
            return $featureList
        }
        -vernum {
            return [exec curl-config --vernum]
        }
        default {
            return "bad option '$option': must be '-prefix', '-feature' or '-vernum'"
        }
    }
    return
}

################################################################################
# transfer
#    The transfer command is used for simple transfers in which you don't 
#    want to request more than one file and you are not going to need
#    the 'getinfo' command.
#
# Parameters:
#    Use the same parameters you would use in the 'configure' command.
################################################################################
proc transfer {args} {
 
    if {[catch {curl::init} curlHandle]} {
        error "Could not init a curl session: $curlHandle"
        return
    }

    set bodyVarIndex [lsearch $args -bodyvar]
    if {$bodyVarIndex!=-1} {
        incr bodyVarIndex
        upvar [lindex $args $bodyVarIndex] curlBodyVar
        set args [lreplace $args $bodyVarIndex $bodyVarIndex curlBodyVar]
    }
    set headerVarIndex [lsearch $args -headervar]
    if {$headerVarIndex!=-1} {
        incr headerVarIndex
        upvar [lindex $args $headerVarIndex] curlHeaderVar
        set args [lreplace $args $headerVarIndex $headerVarIndex curlHeaderVar]
    }
    set errorVarIndex [lsearch $args -errorbuffer]
    if {$errorVarIndex!=-1} {
        incr errorVarIndex
        upvar [lindex $args $errorVarIndex] curlErrorVar
        set args [lreplace $args $errorVarIndex $errorVarIndex curlErrorVar]
    }

    if {[catch {eval $curlHandle configure $args} result]} {
        $curlHandle cleanup
        error $result
        return
    }
    if {[catch {$curlHandle perform} result]} {
       $curlHandle cleanup
       error "Could not perform transfer: $result"
       return
    }

    if {[catch {$curlHandle cleanup} result]} {
        error $result
        return
    }
    return 0
}

}