home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 January / dppcpro0199a.iso / January / Fp98 / SDK / WebBot / tcltest / tcltest.tcl < prev   
Encoding:
Text File  |  1997-09-18  |  2.8 KB  |  92 lines
  1. #!/usr/local/bin/tclsh
  2.  
  3. # tcltest.tcl: bot implementation in Tcl
  4.  
  5. # ----------------------------------------------------------
  6.  
  7. # Decode CGI/1.1 parameters, args, and environment variables
  8. # from tcl-cgi2.tcl
  9. #
  10. # Rewrite by dl@hplyot.obspm.fr - v2.2 - May 24th 1995
  11. # based on robert.bagwill@nist.gov's version
  12. #
  13. # news and latest version shall on http://hplyot.obspm.fr/~dl/wwwtools.html
  14. #
  15. # no warranty, no rights reserved
  16. #
  17.  
  18. # ----------------------------------------------------------
  19.  
  20. set envvars {SERVER_SOFTWARE SERVER_NAME GATEWAY_INTERFACE SERVER_PROTOCOL SERVER_PORT REQUEST_METHOD PATH_INFO PATH_TRANSLATED SCRIPT_NAME QUERY_STRING REMOTE_HOST REMOTE_ADDR REMOTE_USER AUTH_TYPE CONTENT_TYPE CONTENT_LENGTH HTTP_ACCEPT HTTP_REFERER HTTP_USER_AGENT}
  21.  
  22. # ----------------------------------------------------------
  23.  
  24. #
  25. # UnCgi Translation hack, in Tcl, v1.5 5/1995 by dl@hplyot.obspm.fr
  26. #
  27. proc uncgi {buf} {
  28. # ncsa httpd (at least) \ quotes some chars, including \ so :
  29. regsub -all {\\(.)} $buf {\1} buf ;
  30. regsub -all {\\} $buf {\\\\} buf ;
  31. regsub -all { }  $buf {\ } buf ;
  32. regsub -all {\+} $buf {\ } buf ;
  33. regsub -all {\$} $buf {\$} buf ;
  34. regsub -all \n   $buf {\n} buf ;
  35. regsub -all {;}  $buf {\;} buf ;
  36. regsub -all {\[} $buf {\[} buf ;
  37. regsub -all \" $buf \\\" buf ;
  38. # the next one can probably be skipped as the first char is prolly not
  39. # an \{, but, hey who knows... lets be safe...
  40. regsub  ^\{ $buf \\\{ buf ;
  41. # I think everything has been escaped, now the real work :
  42. regsub -all -nocase {%([a-fA-F0-9][a-fA-F0-9])} $buf {[format %c 0x\1]} buf
  43. # And now lets replace all those escaped back, along with excuting of
  44. # the format :
  45. eval return \"$buf\"
  46. # now everything is in buf, but translated, nice trick no ?
  47. }
  48.  
  49. # ----------------------------------------------------------
  50.  
  51. # returns in the 'cgi' array all the parameters sent to the script
  52. # through 'message' (each array cell is a list (ie if only one value
  53. # is expected through 'test' variable, use [lindex $cgi(test) 0] to get it)).
  54.  
  55. proc parse_cgi_message {message} {
  56. global cgi;
  57. set cgi() "";
  58. foreach pair [split $message &] {
  59.   set plst [split $pair =];
  60.   set name [uncgi [lindex $plst 0]];
  61.   set val  [uncgi [lindex $plst 1]];
  62.   lappend cgi($name) $val;
  63. }
  64. }
  65.  
  66. # ----------------------------------------------------------
  67.  
  68. # get the params, depending of method :
  69. if {[string compare $env(REQUEST_METHOD) "POST"]==0} {
  70. set message [read stdin $env(CONTENT_LENGTH)];
  71. } else {
  72. set message $env(QUERY_STRING)
  73. }
  74. parse_cgi_message $message;
  75.  
  76. # Show our attributes
  77.  
  78. puts "<UL>"
  79. puts "<LI><B>Bot Attributes</B>"
  80. foreach var [array names cgi] {
  81.   puts "<LI><I>$var</I>: $cgi($var)";
  82. }
  83. puts "<LI><B>Environment Variables</B>"
  84. foreach var $envvars {
  85.     if {[info exists env($var)]} {
  86.         puts "<LI><I>$var</I>: $env($var)"
  87.     }
  88. }
  89. puts "</UL>"
  90.  
  91.  
  92.