generic/tclcurl.tcl

   1 ################################################################################
   2 ################################################################################
   3 ####                                  tclcurl.tcl
   4 ################################################################################
   5 ################################################################################
   6 ## Includes the tcl part of TclCurl
   7 ################################################################################
   8 ################################################################################
   9 ## (c) 2001-2011 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.22.0
  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     if {[llength $args]==0} {
  72         puts "No transfer configured"
  73         return
  74     }
  75
  76     foreach {option value} $args {
  77         set noPassOption 0
  78         set block        1
  79         switch -regexp -- $option {
  80             -info.* {
  81                 set noPassOption 1
  82                 regsub -- {-info} $option {} option
  83                 set getInfo($option) $value
  84             }
  85             -block {
  86                 set noPassOption 1
  87                 set block $value
  88             }
  89             -bodyvar {
  90                 upvar $value curlBodyVar
  91                 set    value curlBodyVar
  92             }
  93             -headervar {
  94                 upvar $value curlHeaderVar
  95                 set    value curlHeaderVar
  96             }
  97             -errorbuffer {
  98                 upvar $value curlErrorVar
  99                 set    value curlErrorVar
 100             }
 101         }
 102         if {$noPassOption==0} {
 103             lappend newArgs $option $value
 104         }
 105     }
 106
 107     if {[catch {::curl::init} curlHandle]} {
 108         error "Could not init a curl session: $curlHandle"
 109     }
 110
 111     if {[catch {eval $curlHandle configure $newArgs} result]} {
 112         $curlHandle  cleanup
 113         error $result
 114     }
 115
 116     if {$block==1} {
 117         if {[catch {$curlHandle perform} result]} {
 118            $curlHandle cleanup
 119            error $result
 120         }
 121         if {[info exists getInfo]} {
 122             foreach {option var} [array get getInfo] {
 123                 upvar $var info
 124                 set info [eval $curlHandle getinfo $option]
 125             }
 126         }
 127         if {[catch {$curlHandle cleanup} result]} {
 128             error $result
 129         }
 130     } else {
 131         # We create a multiHandle
 132         set multiHandle [curl::multiinit]
 133
 134         # We add the easy handle to the multi handle.
 135         $multiHandle addhandle $curlHandle
 136
 137         # So now we create the event source passing the multiHandle as a parameter.
 138         curl::createEventSource $multiHandle
 139
 140         # And we return, it is non blocking after all.
 141     }
 142     return 0
 143 }
 144
 145 }