API tools faq
paste
Advertisement
Guest User

egghttp.tcl

a guest
May 30th, 2012
423
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
TCL 10.22 KB | None | 0 0
raw download clone embed print report
  1. ##
  2. #
  3. # egghttp.tcl v1.0.6 - by strikelight ([sL] @ EFNet) (05/14/04)
  4. #
  5. # Contact:
  6. # - E-Mail: [email protected]
  7. # - WWW   : http://www.TCLScript.com
  8. # - IRC   : #Scripting @ EFNet
  9. #
  10. ##
  11. #
  12. # Description:
  13. #
  14. # This is a TCL for other scripters to use for true asynchronous
  15. # webpage connections.
  16. #
  17. # I noticed the need when using the http package for tcl,
  18. # and it would not, for some reason or other, properly
  19. # use asynchronous connections or not do anything at all when
  20. # trying to use async connections.
  21. # ^- As it turns out, eggdrop1.1.5 (and I believe 1.3.x) does
  22. #    not have Tcl_DoOneEvent in the source, so the http package fails
  23. #    for async connections, thus the need for this script.
  24. #
  25. # Realizing eggdrop already had the ability to make async connections,
  26. # I created this considerably smaller tcl (in comparison to the http
  27. # package).
  28. #
  29. # So, no more fighting with the http package for async connections,
  30. # and no more freezes when trying to connect to a page. Enjoy!
  31. #
  32. ##
  33. #
  34. # History:
  35. #
  36. # (05/14/04) - v1.1.0 - Added "-crlf 0/1" option to address a problem with
  37. #                       performing requests on certain http servers
  38. #                       (Call egghttp:geturl with -crlf 1 if the server you are
  39. #                       connecting to expects CRLF's)
  40. #                     - Due to some users' confusion, Added a putlog to show the
  41. #                       script being loaded
  42. # (11/17/02) - v1.0.5 - Added -useragent (ie. Mozilla/5.0) and
  43. #                       -protocol (ie. HTTP/1.1) options to egghttp:geturl
  44. # (10/06/02) - v1.0.4 - Fixed bug with egghttp:errormsg
  45. #                     - Added egghttp:code -> returns numerical code reply received from server
  46. # (07/24/02) - v1.0.3 - Fixed a regexp issue with TCL higher than 8.0 (reported by Sebastian)
  47. # (06/18/02) - v1.0.2 - Fixed bug with specifying port to connect to
  48. # (05/30/02) - v1.0.1 - Fixed bugs with script not working on higher eggdrop versions
  49. # (05/13/02) - v1.0.0 - Initial Release
  50. #
  51. ##
  52. #
  53. # Usage:
  54. #
  55. # See description before each procedure, and also
  56. # see bottom of script for example usage.
  57. #
  58. # Note: Load this script BEFORE any other script that requires this tcl.
  59. #
  60. ##
  61.  
  62. # Check for this variable to see if this TCL is loaded
  63. set egghttp(version) "1.1.0"
  64.  
  65. ####
  66. #
  67. # Procedure: egghttp:geturl
  68. #
  69. # Description: Used to download the contents of a webpage
  70. #
  71. # Arguments: url        = webpage to download
  72. #            command    = command to execute when transaction is
  73. #                         complete.  This command is called with
  74. #                         one parameter, the sockID
  75. #            options    = -timeout   -> Seconds before conection times out.
  76. #                                       (Default = 60 seconds)
  77. #                         -query     -> Query a webpage script (ie. cgi's)
  78. #                         -headers   -> Send header information to server
  79. #                                       (ie. Cookies)
  80. #                         -protocol  -> Protocol to use (Default = HTTP/1.0)
  81. #                         -useragent -> Useragent to reply with to server
  82. #                                       (Default = Mozilla/5.0)
  83. #                         -crlf      -> 0 or 1, Use CRLF's with query
  84. #                                       (Default = 0, no)
  85. #
  86. # Returns: sockID
  87. #
  88. ####
  89. proc egghttp:geturl {url command args} {
  90.   global egghttp
  91.   if {![regexp -nocase {^(http://)?([^:/]+)(:([0-9]+))?(/.*)?$} $url x protocol server y port path]} {
  92.     return -code error "bogus URL: $url"
  93.   }
  94.   if {[string length $port] == 0} {
  95.     set port 80
  96.   }
  97.   proc isint {num} {
  98.     if {($num == "") || ([string trim $num "0123456789"] != "")} {return 0}
  99.     return 1
  100.   }
  101.  
  102.   set state(-timeout) 60
  103.   set state(-query) ""
  104.   set state(-headers) ""
  105.   set state(-protocol) "HTTP/1.0"
  106.   set state(-useragent) "Mozilla/5.0"
  107.   set state(-crlf) 0
  108.  
  109.   set options {-timeout -query -headers -protocol -useragent -crlf}
  110.   set usage [join $options ", "]
  111.   regsub -all -- - $options {} options
  112.   set pat ^-([join $options |])$
  113.   foreach {item value} $args {
  114.     if {[regexp $pat $item]} {
  115.       if {[info exists state($item)] && [isint $state($item)] && ![isint $value]} {
  116.         return -code error "Bad value for $item ($value), must be integer"
  117.       }
  118.       set state($item) $value
  119.     } else {
  120.       return -code error "Unknown option $item, can be: $usage"
  121.     }
  122.   }
  123.   if {$state(-crlf)} {
  124.     set cr "\r"
  125.   } else {
  126.     set cr ""
  127.   }
  128.   if {![catch {set sock [connect $server $port]}]} {
  129.     if {$state(-query) == ""} {
  130.       putdcc $sock "GET $path $state(-protocol)$cr"
  131.       putdcc $sock "Accept: */*$cr"
  132.       putdcc $sock "Host: $server$cr"
  133.       putdcc $sock "User-Agent: $state(-useragent)$cr"
  134.       if {$state(-headers) != ""} {
  135.         putdcc $sock "$state(-headers)$cr"
  136.       }
  137.       putdcc $sock "$cr"
  138.     } else {
  139.       set length [string length $state(-query)]
  140.       putdcc $sock "POST $path $state(-protocol)$cr"
  141.       putdcc $sock "Accept: */*$cr"
  142.       putdcc $sock "Host: $server$cr"
  143.       putdcc $sock "User-Agent: $state(-useragent)$cr"
  144.       if {$state(-headers) != ""} {
  145.         putdcc $sock "$state(-headers)$cr"
  146.       }
  147.       putdcc $sock "Content-Type: application/x-www-form-urlencoded$cr"
  148.       putdcc $sock "Content-Length: $length$cr"
  149.       putdcc $sock "$cr"
  150.       putdcc $sock "$state(-query)$cr"
  151.     }
  152.     set egghttp($sock,url) "$url"
  153.     set egghttp($sock,headers) ""
  154.     set egghttp($sock,body) ""
  155.     set egghttp($sock,error) "Ok"
  156.     set egghttp($sock,command) $command
  157.     set egghttp($sock,code) ""
  158.     set egghttp($sock,timer) [utimer $state(-timeout) "egghttp:timeout $sock"]
  159.     control $sock egghttp:control
  160.     return $sock
  161.   }
  162.   return -1
  163. }
  164.  
  165. ####
  166. #
  167. # Procedure: egghttp:cleanup
  168. #
  169. # Description: Used to clean up variables that are no longer needed
  170. #
  171. # Arguments: sockID     = the sockID of the connection to clean up
  172. #
  173. # Returns: nothing
  174. #
  175. ####
  176. proc egghttp:cleanup {sock} {
  177.   global egghttp
  178. # blah.. would normally just do "array unset egghttp $sock,*"
  179. # but earlier tcl versions don't support it...
  180.   foreach blah [array names egghttp $sock,*] {
  181.     catch {unset egghttp($blah)}
  182.   }
  183. }
  184.  
  185. ####
  186. #
  187. # Procedure: egghttp:timeout
  188. #
  189. # Description: Used to timeout a connection. Do NOT call this manually
  190. #
  191. # Arguments: sockID     = sockID to timeout
  192. #
  193. # Returns: nothing
  194. #
  195. ####
  196. proc egghttp:timeout {sock} {
  197.   global egghttp
  198.   catch {killdcc $sock}
  199.   set egghttp($sock,error) "Timeout or Connection Refused"
  200.   catch {eval $egghttp($sock,command) $sock}
  201. }
  202.  
  203. ####
  204. #
  205. # Procedure: egghttp:data
  206. #
  207. # Description: Used to return the contents of the downloaded page
  208. #
  209. # Arguments: sockID     = sockID of the data to return
  210. #
  211. # Returns: contents of webpage
  212. #
  213. ####
  214. proc egghttp:data {sock} {
  215.   global egghttp
  216.   if {[info exists egghttp($sock,body)]} {
  217.     return "$egghttp($sock,body)"
  218.   }
  219.   return ""
  220. }
  221.  
  222. ####
  223. #
  224. # Procedure: egghttp:headers
  225. #
  226. # Description: Used to return the header content of the downloaded page
  227. #
  228. # Arguments: sockID     = sockID of the data to return
  229. #
  230. # Returns: header contents of webpage
  231. #
  232. ####
  233. proc egghttp:headers {sock} {
  234.   global egghttp
  235.   if {[info exists egghttp($sock,headers)]} {
  236.     return "$egghttp($sock,headers)"
  237.   }
  238.   return ""
  239. }
  240.  
  241. ####
  242. #
  243. # Procedure: egghttp:errormsg
  244. #
  245. # Description: Used to return any errors while getting page
  246. #
  247. # Arguments: sockID     = sockID of the data to return
  248. #
  249. # Returns: error message, or "Ok" if no error.
  250. #
  251. ####
  252. proc egghttp:errormsg {sock} {
  253.   global egghttp
  254.   if {[info exists egghttp($sock,error)]} {
  255.     return "$egghttp($sock,error)"
  256.   }
  257.   return "Ok"
  258. }
  259.  
  260. ####
  261. #
  262. # Procedure: egghttp:code
  263. #
  264. # Description: Used to return the code received from the server while getting page
  265. #
  266. # Arguments: sockID     = sockID of the data to return
  267. #
  268. # Returns: code received by server, or "" if no code was received/found.
  269. #
  270. ####
  271. proc egghttp:code {sock} {
  272.   global egghttp
  273.   if {[info exists egghttp($sock,code)]} {
  274.     return "$egghttp($sock,code)"
  275.   }
  276.   return ""
  277. }
  278.  
  279. ####
  280. #
  281. # Procedure: egghttp:control
  282. #
  283. # Description: Used to control incoming traffic from page. Do NOT call
  284. #              this manually.
  285. #
  286. # Arguments: sockID     = sockID of connection
  287. #            input      = incoming data
  288. #
  289. # Returns: 1 to relinquish control, 0 to retain control
  290. #
  291. ####
  292. proc egghttp:control {sock input} {
  293.   global egghttp
  294.   if {$input == ""} {
  295.     catch {killutimer $egghttp($sock,timer)}
  296.     if {[info exists egghttp($sock,headers)]} {
  297.       set egghttp($sock,headers) "[string range $egghttp($sock,headers) 0 [expr [string length $egghttp($sock,headers)] - 2]]"
  298.     } else {
  299.       set egghttp($sock,headers) ""
  300.     }
  301.     if {[info exists egghttp($sock,body)]} {
  302.       set egghttp($sock,body) "[string range $egghttp($sock,body) 0 [expr [string length $egghttp($sock,body)] - 2]]"
  303.     } else {
  304.       set egghttp($sock,body) ""
  305.     }
  306.     catch {eval $egghttp($sock,command) $sock}
  307.     return 1
  308.   }
  309.   if {![string match "*<*" $input] && ($egghttp($sock,body) == "")} {
  310.     append egghttp($sock,headers) "$input\n"
  311.     if {[string match "*HTTP/*" $input] && ($egghttp($sock,code) == "")} {
  312.       set egghttp($sock,code) [lindex [split $input] 1]
  313.     }
  314.     if {[string match "*content-type*" [string tolower $input]] && ![string match "*text*" [string tolower $input]]} {
  315.       set egghttp($sock,error) "Non-Text file content type."
  316.       catch {killdcc $sock}
  317.       catch {eval $egghttp($sock,command) $sock}
  318.       return 1
  319.     }
  320.   } else {
  321.     append egghttp($sock,body) "$input\n"
  322.   }
  323.   return 0
  324. }
  325.  
  326. putlog "egghttp.tcl API v$egghttp(version) by strikelight now loaded."
  327.  
  328. ###
  329. #
  330. # Example 1:
  331. #
  332. # proc connect_callback {sock} {
  333. #   set buffer [egghttp:data $sock]
  334. #   egghttp:cleanup $sock
  335. #   .. whatever else you want to do with the data ..
  336. # }
  337. #
  338. # set sock [egghttp:geturl www.test.com/ connect_callback]
  339. #
  340. # Example 2: (Query a cgi script)
  341. #
  342. # same proc connect_callback
  343. #
  344. # set sock [egghttp:geturl www.test.com/test.cgi connect_callback -query input=blah]
  345. #
  346. # Example 3: (Send header information, such as cookies)
  347. #
  348. # same proc connect_callback
  349. #
  350. # set sock [egghttp:geturl www.test.com/ connect_callback -headers "Cookie: uNF=unf"]
  351. #
  352. ###
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!