generic/tclcurl.tcl

   1 ################################################################################
   2 ################################################################################
   3 ####                                  tclcurl.tcl
   4 ################################################################################
   5 ################################################################################
   6 ## Includes the tcl part of TclCurl
   7 ################################################################################
   8 ################################################################################
   9 ## (c) 2001-2009 Andres Garcia Garcia. fandom@telefonica.net
  10 ## See the file "license.terms" for information on usage and redistribution
  11 ## of this file and for a DISCLAIMER OF ALL WARRANTIES.
  12 ################################################################################
  13 ################################################################################
  14
  15 package provide TclCurl 7.19.6
  16
  17 namespace eval curl {
  18
  19 ################################################################################
  20 # configure
  21 #    Invokes the 'curl-config' script to be able to know what features have
  22 #    been compiled in the installed version of libcurl.
  23 #    Possible options are '-prefix', '-feature' and 'vernum'
  24 ################################################################################
  25 proc ::curl::curlConfig {option} {
  26
  27     if {$::tcl_platform(platform)=="windows"} {
  28         error "This command is not available in Windows"
  29     }
  30
  31     switch -exact -- $option {
  32         -prefix {
  33             return [exec curl-config --prefix]
  34         }
  35         -feature {
  36             set featureList [exec curl-config --feature]
  37             regsub -all {\\n} $featureList { } featureList
  38             return $featureList
  39         }
  40         -vernum {
  41             return [exec curl-config --vernum]
  42         }
  43         -ca {
  44             return [exec curl-config --ca]
  45         }
  46         default {
  47             error "bad option '$option': must be '-prefix', '-feature', '-vernum' or '-ca'"
  48         }
  49     }
  50     return
  51 }
  52
  53 ################################################################################
  54 # transfer
  55 #    The transfer command is used for simple transfers in which you don't
  56 #    want to request more than one file.
  57 #
  58 # Parameters:
  59 #    Use the same parameters you would use in the 'configure' command to
  60 #    configure the download and the same as in 'getinfo' with a 'info'
  61 #    prefix to get info about the transfer.
  62 ################################################################################
  63 proc ::curl::transfer {args} {
  64     variable getInfo
  65     variable curlBodyVar
  66
  67     set i 0
  68     set newArgs ""
  69     catch {unset getInfo}
  70
  71     foreach {option value} $args {
  72         set noPassOption 0
  73         set block        1
  74         switch -regexp -- $option {
  75             -info.* {
  76                 set noPassOption 1
  77                 regsub -- {-info} $option {} option
  78                 set getInfo($option) $value
  79             }
  80             -block {
  81                 set noPassOption 1
  82                 set block $value
  83             }
  84             -bodyvar {
  85                 upvar $value curlBodyVar
  86                 set    value curlBodyVar
  87             }
  88             -headervar {
  89                 upvar $value curlHeaderVar
  90                 set    value curlHeaderVar
  91             }
  92             -errorbuffer {
  93                 upvar $value curlErrorVar
  94                 set    value curlErrorVar
  95             }
  96         }
  97         if {$noPassOption==0} {
  98             lappend newArgs $option $value
  99         }
 100     }
 101
 102     if {[catch {::curl::init} curlHandle]} {
 103         error "Could not init a curl session: $curlHandle"
 104     }
 105
 106     if {[catch {eval $curlHandle configure $newArgs} result]} {
 107         $curlHandle  cleanup
 108         error $result
 109     }
 110
 111     if {$block==1} {
 112         if {[catch {$curlHandle perform} result]} {
 113            $curlHandle cleanup
 114            error $result
 115         }
 116         if {[info exists getInfo]} {
 117             foreach {option var} [array get getInfo] {
 118                 upvar $var info
 119                 set info [eval $curlHandle getinfo $option]
 120             }
 121         }
 122         if {[catch {$curlHandle cleanup} result]} {
 123             error $result
 124         }
 125     } else {
 126         # We create a multiHandle
 127         set multiHandle [curl::multiinit]
 128
 129         # We add the easy handle to the multi handle.
 130         $multiHandle addhandle $curlHandle
 131
 132         # So now we create the event source passing the multiHandle as a parameter.
 133         curl::createEventSource $multiHandle
 134
 135         # And we return, it is non blocking after all.
 136     }
 137     return 0
 138 }
 139
 140 }