home *** CD-ROM | disk | FTP | other *** search
/ Komputer for Alle 2002 #8 / K-CD-8-2002.ISO / WatzNew / data.cab / http.lib < prev    next >
Encoding:
Text File  |  2000-07-02  |  14.0 KB  |  483 lines
  1. # ------------------------------------------------------------------------------
  2. # HTTP ROUTINES LIBRARY by A.I.Studio / Igor Afanasyev
  3. # ------------------------------------------------------------------------------
  4.  
  5. use Socket;
  6.  
  7. select(STDOUT); $| = 1; 
  8.  
  9. %COOKIES_VALUES = ();
  10. %COOKIES_DOMAINS = ();
  11. %COOKIES_PATHS = ();
  12.  
  13. $TRACE_PROGRESS = $ENV{'TRACE_PROGRESS'};
  14. $TRACE_HEADER = $ENV{'TRACE_HEADER'};
  15. $TRACE_BODY = $ENV{'TRACE_BODY'};
  16. $TRACE_COOKIES = $ENV{'TRACE_COOKIES'};
  17.  
  18. $Referer = $ENV{'HTTP_REFERER'};
  19. ($Referer eq '') && ($Referer = 'http://www.watznew.com/');
  20.  
  21. $UserAgent = $ENV{'HTTP_USER_AGENT'};
  22. ($UserAgent eq '') && ($UserAgent = 'WatzNew Agent Perl Script (www.watznew.com)'); # 'Mozilla/4.0 (compatible; MSIE 5.0; Win32)'
  23.  
  24. undef $HttpHeader; # this variable contains document header after HTTP request is done
  25. undef $HttpBody; # this variable contains document body after HTTP request is done
  26. undef $LastHost; # these variables contain the last used host, port and path
  27. undef $LastPort;
  28. undef $LastPath;
  29.  
  30. # ------------------------------------------------------------------------------
  31. sub INF {
  32. # ------------------------------------------------------------------------------
  33.   my ($s) = @_;
  34.   print "INF: $s\n";
  35. }
  36.  
  37. # ------------------------------------------------------------------------------
  38. sub MSG {
  39. # ------------------------------------------------------------------------------
  40.   my ($s) = @_;
  41.   print "MSG: $s\n";
  42. }
  43.  
  44. # ------------------------------------------------------------------------------
  45. sub ERR {
  46. # ------------------------------------------------------------------------------
  47.   my ($s) = @_;
  48.   print "ERR: $s\n";
  49.   exit;
  50. }
  51.  
  52. # ------------------------------------------------------------------------------
  53. sub Squeeze {
  54. # ------------------------------------------------------------------------------
  55.   my ($s) = @_;
  56.   $s =~ s/ / /gi;
  57.   $s =~ s/[\r\t\n ]+/ /gi;
  58.   $s =~ s/^[\r\t\n ]//gi;
  59.   $s =~ s/[\r\t\n ]$//gi;
  60.   return $s;
  61. }
  62.  
  63. # ------------------------------------------------------------------------------
  64. sub PrepareParam {
  65. # ------------------------------------------------------------------------------
  66.   my ($s) = @_;
  67.   $s =~ s/<.*?>/ /gi;
  68.   $s =~ s/"/"/gi;
  69.   $s = &Squeeze($s);
  70.   return $s;
  71. } # end of sub
  72.  
  73. # ------------------------------------------------------------------------------
  74. sub ConvertHtmlCodes {
  75. # ------------------------------------------------------------------------------
  76.   my ($s) = @_;
  77.   $s =~ s/ / /gi;
  78.   $s =~ s/"/"/gi;
  79.   $s =~ s/</</gi;
  80.   $s =~ s/>/>/gi;
  81.   return $s;
  82. } # end of sub
  83.  
  84. # ------------------------------------------------------------------------------
  85. sub SplitUrl { # splits url to ($Host,$Port,$Path) array
  86. # ------------------------------------------------------------------------------
  87.   my ($Url) = @_;
  88.  
  89.   my $Host,$Port,$Path;
  90.  
  91.   if ($Url =~ m|^http(s*?)://(.*)|i) {
  92.     $Secure = ($1 eq 's');
  93.     $Host = $2;
  94.     $Port = 80;
  95.     $Path = "/";
  96.     ($Host =~ s|^([^/]+)/(.*)$|$1|) && ($Path = $2);
  97.     ($Host =~ s/:(\d+)$//) && ($Port = $1);
  98.     ($Host =~ s/:(\D+)$//) && ($Port = 80);
  99.     $Path = '/'.$Path;
  100.   } else {
  101.     &ERR("Wrong url syntax: $Url");
  102.   }
  103.  
  104.   return ($Host,$Port,$Path);
  105. } # end of sub
  106.  
  107.  
  108. # ------------------------------------------------------------------------------
  109. sub ExpandUrl {
  110. # ------------------------------------------------------------------------------
  111.   my ($Url,$BaseUrl) = @_;
  112.   my $h,$p,$b;
  113.  
  114.   $b = $BaseUrl.'/';
  115.   $b =~ s|//$|/|g;
  116.  
  117.   if ($b =~ m|^(http[s]{0,1}://(.+?))/|i) {
  118.     $h = $1;
  119.   } else { # wrong base url syntax
  120.     return $Url;
  121.   }
  122.  
  123.   ($BaseUrl =~ m|(.+/)(.*?)$|) && ($p = $1);
  124.  
  125.   ($Url =~ m|^http[s]{0,1}://|i) && (return $Url);
  126.   ($Url =~ m|^/|) && (return $h.$Url);
  127.   return $p.$Url;
  128. } # end sub
  129.  
  130. # ------------------------------------------------------------------------------
  131. sub ExpandUrls {
  132. # ------------------------------------------------------------------------------
  133.   my ($Html,$BaseUrl) = @_;
  134.  
  135.   while ($Html =~ m/<A (.*?)HREF=["]*(.*?)["]*[> ]/gi) {
  136.     my $path = $2;
  137.     my $match = $&;
  138.     my $subst = '__A__HREF="'.&ExpandUrl($path,$BaseUrl).'">';
  139.     $Html =~ s/\Q$match\E/$subst/gi;
  140.   }
  141.  
  142.   $Html =~ s/__A__HREF/<A HREF/gi;
  143.  
  144.   return $Html;
  145. } # end sub
  146.  
  147. # ------------------------------------------------------------------------------
  148. sub MakeCookies { # sends COOKIES
  149. # ------------------------------------------------------------------------------
  150.   my ($Domain,$Path) = @_;
  151.   my $s = '';
  152.   
  153.   foreach $c (keys %COOKIES_VALUES) {
  154.     my $v = $COOKIES_VALUES{$c};
  155.     my $d = $COOKIES_DOMAINS{$c};
  156.     my $p = $COOKIES_PATHS{$c};
  157.     
  158.     if ($Domain =~ m/\Q$d\E$/) {
  159.       if ($Path =~ m/^\Q$p\E/) {
  160.         ($s ne '') && ($s .= '; ');
  161.         $s .= "$c=$v";
  162.         $TRACE_COOKIES && print "\t##  Cookie: [$c]=[$v]\n";
  163.       }
  164.     }
  165.   }
  166.  
  167.   if ($s ne '') {
  168.     $TRACE_COOKIES && print "\n";
  169.       return "Cookie: $s\n";
  170.   } else {
  171.     return '';
  172.   }  
  173. } # end sub
  174.  
  175. # ------------------------------------------------------------------------------
  176. sub HttpPost { # sends POST request and returns a page
  177. # ------------------------------------------------------------------------------
  178.   my ($Host,$Port,$Path,$PostData,$SkipBodyMode) = @_;
  179.   my $PostDataLength = length($PostData);
  180.  
  181.   $Path = '/' if ($Path eq '');
  182.  
  183.   $LastHost = $Host;
  184.   $LastPort = $Port;
  185.   $LastPath = $Path;
  186.  
  187.   $TRACE_PROGRESS && print "\n\t##  HttpPost [$Host] [$Port] [$Path]\n";
  188.   $TRACE_PROGRESS && print "\t##  Referer [$Referer]\n\n";
  189.  
  190.   &INF("Looking for $Host");
  191.  
  192.   $iaddr = inet_aton($Host) || &ERR("Can't locate host: $Host");
  193.   $paddr = sockaddr_in($Port, $iaddr);
  194.   $proto = getprotobyname('tcp');
  195.   socket(SOCK, PF_INET, SOCK_STREAM, $proto) || &ERR("$!");
  196.   connect(SOCK, $paddr) || &ERR("$!");
  197.  
  198.   select(SOCK); $| = 1; select(STDOUT);
  199.  
  200.   &INF("Sending request to server");
  201.  
  202.   my $headers =
  203.     "POST $Path HTTP/1.1\n".
  204.     "Host: $Host\n".
  205.     "Referer: $Referer\n".
  206.     "Cache-Control: no-cache\n".
  207.     "Accept: */*\n".
  208.     "Accept-Charset: windows-1251\n".
  209.     "User-Agent: $UserAgent\n".
  210.     "Content-type: application/x-www-form-urlencoded\n".
  211.     "Content-length: $PostDataLength\n".
  212.     "Connection: close\n";
  213.  
  214.   $headers .= &MakeCookies($Host,$Path);
  215.  
  216.   print SOCK $headers;
  217.   $headers =~ s/\n/\n\t>>  /g;
  218.   $TRACE_PROGRESS && print "\t>>  $headers\n\n";
  219.  
  220.   print SOCK "\n$PostData\n";
  221.  
  222.   $Referer = "http://$Host:$Port$Path";
  223.  
  224.   return &ProcessServerResponce($SkipBodyMode);
  225. } # end of sub
  226.  
  227. # ------------------------------------------------------------------------------
  228. sub HttpGet { # sends GET request and returns a page
  229. # ------------------------------------------------------------------------------
  230.   my ($Host,$Port,$Path,$SkipBodyMode) = @_;
  231.   
  232.   $TRACE_PROGRESS && print "\n\t##  HttpGet [$Host] [$Port] [$Path]\n";
  233.   $TRACE_PROGRESS && print "\t##  Referer [$Referer]\n\n";
  234.  
  235.   $Path = '/' if ($Path eq '');
  236.  
  237.   $LastHost = $Host;
  238.   $LastPort = $Port;
  239.   $LastPath = $Path;
  240.  
  241.   &INF("Looking for $Host");
  242.  
  243.   $iaddr = inet_aton($Host) || &ERR("Can't locate host: $Host");
  244.   $paddr = sockaddr_in($Port, $iaddr);
  245.   $proto = getprotobyname('tcp');
  246.   socket(SOCK, PF_INET, SOCK_STREAM, $proto) || &ERR("$!");
  247.   connect(SOCK, $paddr) || &ERR("$!");
  248.  
  249.   select(SOCK); $| = 1; select(STDOUT);
  250.  
  251.   &INF("Sending request to server");
  252.  
  253.   my $headers =
  254.     "GET $Path HTTP/1.1\n".
  255.     "Host: $Host\n".
  256.     "Referer: $Referer\n".
  257.     "Cache-Control: no-cache\n".
  258.     "Accept: */*\n".
  259.     "Accept-Charset: windows-1251\n".
  260.     "User-Agent: $UserAgent\n".
  261.     "Connection: close\n";
  262.  
  263.   $headers .= &MakeCookies($Host,$Path);
  264.  
  265.   print SOCK $headers;
  266.   $headers =~ s/\n/\n\t>>  /g;
  267.   $TRACE_PROGRESS && print "\t>>  $headers\n\n";
  268.  
  269.   print SOCK "\n";
  270.  
  271.   $Referer = "$Host:$Port$Path";
  272.  
  273.   return &ProcessServerResponce($SkipBodyMode);
  274. } # end sub
  275.  
  276. # ------------------------------------------------------------------------------
  277. sub _HttpProcessAutoRedirect { # handles automatic auto-redirection
  278. # ------------------------------------------------------------------------------
  279.   my ($c, $HaltOnError) = @_;
  280.   undef my $done;
  281.   undef my $Url;
  282.   
  283.   do {
  284.     while (($c == 301) || ($c == 302) || ($c == 303)) {
  285.       if ($HttpHeader =~ m/Location:[ ]*(.+?)\n/i) {
  286.         $Url = $1;
  287.         $c = &HttpGet(&SplitUrl($Url));
  288.       } else {  
  289.         &ERR("Can't find the address to redirect");
  290.       }
  291.     }
  292.  
  293.     $done = 1;
  294.  
  295.     if (($c == 200) && ($HttpBody =~ m/<META HTTP-EQUIV=["]*Refresh["]* CONTENT=["]*(.*?)URL=(.*?)["]*>/si)) {
  296.       my $u = $2;
  297.       if ($Url ne $u) {
  298.         undef $done;
  299.         $Url = $u;
  300.         $c = &HttpGet(&SplitUrl($Url));
  301.       }
  302.     }
  303.  
  304.   } until ($done);
  305.  
  306.   ($HaltOnError) && ($c ne 200) && &ERR("HTTP Error: $c");
  307.  
  308.   return ($c, $Url);
  309. } # end sub
  310.   
  311. # ------------------------------------------------------------------------------
  312. sub HttpGetUrl { # sends GET request
  313. # ------------------------------------------------------------------------------
  314.   my ($Url,$SkipBodyMode,$HaltOnError) = @_;
  315.   my $c = &HttpGet(&SplitUrl($Url),$SkipBodyMode);
  316.   ($HaltOnError) && ($c ne 200) && &ERR("HTTP Error: $c");
  317.   return $c;
  318. } # end sub
  319.  
  320. # ------------------------------------------------------------------------------
  321. sub HttpGetUrlAutoRedirect { # sends GET request and handles auto-redirection
  322. # ------------------------------------------------------------------------------
  323.   my ($Url,$SkipBodyMode,$HaltOnError) = @_;
  324.   return &_HttpProcessAutoRedirect(&HttpGet(&SplitUrl($Url),$SkipBodyMode),$HaltOnError);
  325. } # end sub
  326.  
  327. # ------------------------------------------------------------------------------
  328. sub HttpPostUrl { # sends POST request
  329. # ------------------------------------------------------------------------------
  330.   my ($Url,$PostData,$SkipBodyMode,$HaltOnError) = @_;
  331.   my $c = &HttpPost(&SplitUrl($Url),$PostData,$SkipBodyMode);
  332.   ($HaltOnError) && ($c ne 200) && &ERR("HTTP Error: $c");
  333.   return $c;
  334. } # end sub
  335.  
  336. # ------------------------------------------------------------------------------
  337. sub HttpPostUrlAutoRedirect { # sends POST request and handles auto-redirection
  338. # ------------------------------------------------------------------------------
  339.   my ($Url,$PostData,$SkipBodyMode,$HaltOnError) = @_;
  340.   return &_HttpProcessAutoRedirect(&HttpPost(&SplitUrl($Url),$PostData,$SkipBodyMode),$HaltOnError);
  341. } # end sub
  342.  
  343. # ------------------------------------------------------------------------------
  344. sub ProcessServerResponce {
  345. # ------------------------------------------------------------------------------
  346.   $HttpBody = '';
  347.   $HttpHeader = '';
  348.  
  349.   my $OldBytesRead = 0;
  350.   my $OldReadTime;
  351.  
  352.   my ($SkipBodyMode) = @_;
  353.  
  354.   $Code = -1;
  355.  
  356.   do {
  357.     do {
  358.       $Responce = <SOCK>;
  359.       $Responce =~ s/\r//g;
  360.       $HttpHeader .= $Responce;
  361.       $TRACE_HEADER && print "\t<<  $Responce";
  362.       $Responce =~ s/\n//g;
  363.     } until ($Responce eq '');
  364.  
  365.     ($Responce eq '') && ($Code = 0);
  366.     $HttpHeader =~ m/^HTTP\/\d+?\.\d+? (\d+)/ && ($Code = $1);
  367.  
  368.     $TRACE_PROGRESS && &INF("HTTP status code: $Code");
  369.  
  370.     if (($Code ge 100) && ($Code lt 200)) {
  371.       $Code = -1;
  372.       $HttpHeader = '';
  373.     }
  374.   } until ($Code ge 0);
  375.  
  376.   # extracting cookies
  377.   my %TMP_COOKIES_VALUES = ();
  378.   my %TMP_COOKIES_PATHS = ();
  379.   my %TMP_COOKIES_DOMAINS = ();
  380.  
  381.   pos $HttpHeader = 0;
  382.   while ($HttpHeader =~ m/Set-Cookie:[ ]*(.*?)=(.*?)\n/gi) {
  383.     my $c = $1;
  384.     my $v = $2.';';
  385.     my $expires, $path, $domain;
  386.   
  387.     $expires = '';
  388.     if ($v =~ m/; expires=(.*?);/i) {
  389.       $expires = $1;
  390.     }
  391.   
  392.     $path = '';
  393.     if ($v =~ m/; path=(.*?);/i) {
  394.       $path = $1;
  395.     }
  396.   
  397.     $domain = '';
  398.     if ($v =~ m/; domain=(.*?);/i) {
  399.       $domain = $1;
  400.     }
  401.   
  402.     $v =~ s/;.*//;
  403.   
  404.     my $e = 0;
  405.     if ($expires =~ m/^(\w+) (\w+) (\d+) (\d+):(\d+):(\d+) (\d+)$/i) { # i.e. 'Wed Dec 31 16:00:01 1969'
  406.       my($lsec,$lmin,$lhour,$lmday,$lmon,$lyear,$lwday,$lyday,$lisdst) = localtime(time);
  407.       $lyear += 1900;
  408.  
  409.       my $mname = $2;
  410.       my $day = $3;
  411.       my $hour = $4;
  412.       my $min = $5;
  413.       my $sec = $6;
  414.       my $year = $7;
  415.     
  416.       if ($year < $lyear) {
  417.         $e = 1;
  418.       }
  419.     }    
  420.   
  421.     if ($e == 1) {
  422.       $TRACE_COOKIES && print "\t--  Removing cookie: [$c]\n";
  423.  
  424.       delete $TMP_COOKIES_VALUES{$c};
  425.       delete $TMP_COOKIES_PATHS{$c};
  426.       delete $TMP_COOKIES_DOMAINS{$c};
  427.     
  428.       delete $COOKIES_VALUES{$c};
  429.       delete $COOKIES_PATHS{$c};
  430.       delete $COOKIES_DOMAINS{$c};
  431.     } else {
  432.       $TRACE_COOKIES && print "\t++  Cookie: [$c]=[$v], Path=[$path], Domain=[$domain]\n";
  433.   
  434.       $TMP_COOKIES_VALUES{$c} = $v;
  435.       $TMP_COOKIES_PATHS{$c} = $path;
  436.       $TMP_COOKIES_DOMAINS{$c} = $domain;
  437.     }  
  438.   }
  439.  
  440.   foreach $c (keys %TMP_COOKIES_VALUES) {
  441.     $COOKIES_VALUES{$c} = $TMP_COOKIES_VALUES{$c};
  442.     $COOKIES_PATHS{$c} = $TMP_COOKIES_PATHS{$c};
  443.     $COOKIES_DOMAINS{$c} = $TMP_COOKIES_DOMAINS{$c};
  444.   }
  445.   # end extracting cookies
  446.  
  447.   local $skip = ($SkipBodyMode eq always) || ($SkipBodyMode eq undef) && ($Code ne 200);
  448.   ($SkipBodyMode eq never) && ($skip = undef);
  449.  
  450.   $TRACE_PROGRESS && $skip && &INF("Body skipped");
  451.  
  452.   if (!$skip) {
  453.     $TRACE_PROGRESS && &INF("Loading document");
  454.  
  455.     $OldReadTime = time;
  456.  
  457.     while (my $Responce = <SOCK>) {
  458.       $Responce =~ s/\r//g;
  459.       $HttpBody .= $Responce;
  460.       $TRACE_BODY && print "\t::  $Responce";
  461.  
  462.       if ($TRACE_PROGRESS) {
  463.         my $read = length($HttpBody);
  464.         my $rtime = time;
  465.  
  466.         if (($rtime - $OldReadTime > 10) || ($read - $OldBytesRead >= 5000)) {
  467.           # Fire an event if 10+ seconds passed or 5000+ bytes read
  468.           &INF("$read bytes read");
  469.           $OldBytesRead = $read;
  470.           $OldReadTime = $rtime;
  471.         }
  472.       }
  473.     }
  474.   }
  475.  
  476.   close(SOCK) || &ERR("$!");
  477.  
  478.   return $Code;
  479. } # end sub
  480.  
  481. # ------------------------------------------------------------------------------
  482.  
  483. 1; # return true