home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 27 / IOPROG_27.ISO / SOFT / PERLPAD3.ZIP / PERLPAD3.CAB / util-lib.ppm < prev    next >
Encoding:
Text File  |  1999-02-06  |  7.7 KB  |  411 lines
  1. Util-Lib
  2. #Author: Josias L. de Santana Basilio
  3. #Do not change the lines of @headers. Add news headers to the final.
  4. #Sintax:     &headers([number[:value]],...);
  5. sub headers{
  6.  
  7. local(@in) = @_;
  8.  
  9. @in = sort {$a <=> $b} @in;
  10.  
  11. local($_,$name,$value,$age,$path,$num,@header);
  12.  
  13. @header = ('200 Ok',
  14. '201 Created',
  15. '202 Accepted',
  16. '203 Non-Authoritative',
  17. '204 Non Content',
  18. '300 Multiple Choice',
  19. '301 Moved Permanentely',
  20. '302 Moved Temporarily',
  21. '303 See Other',
  22. '304 Not Modified',
  23. '400 Bad Request',
  24. '401 Unauthorized',
  25. '402 Payment Required',
  26. '403 Forbidden',
  27. '404 Not Found',
  28. '405 Method Not Allowed',
  29. '406 None Acceptable',
  30. '407 Proxy Authentication(Unauthorized) Required',
  31. '408 Request Timeout',
  32. '409 Conflict',
  33. '410 Gone',
  34. '411 Authorization Required',
  35. 'Server:',
  36. 'Date:',
  37. 'Expires:',
  38. 'Location:',
  39. 'Last-modified:',
  40. 'Set-cookie:',
  41. 'Allow: Get, Post',
  42. 'text/html',
  43. 'image/gif',
  44. 'image/jpeg',
  45. 'text/plain',
  46. 'text/richtext',
  47. 'image/tiff',
  48. 'image/x-rgb',
  49. 'image/x-bitmap',
  50. 'audio/basic',
  51. 'audio/x-wav',
  52. 'video/mpeg',
  53. 'video/quicktime',
  54. 'video/x-msvideo');
  55.  
  56. foreach(@in)
  57. {
  58. #    STATUS
  59.     if($_<22)
  60.     {
  61.         if(!$num)
  62.         {
  63.             print "HTTP/1.0 $header[$_]\n";
  64.             $num++;
  65.         }
  66.     }
  67. #    SERVER
  68.     elsif($_==22)
  69.     {
  70.         print "Server: $ENV{'SERVER_SOFTWARE'}\n";
  71.     }
  72. #    DATE
  73.     elsif($_==23)
  74.     {
  75.         &date(0);
  76.         print "Date: $result\n";
  77.     }
  78.     elsif(/\:/)
  79.     {
  80. #        EXPIRES
  81.         if($`==24)
  82.         {
  83.             &date($');
  84.             print "Expires: $result\n";
  85.         }
  86. #        LOCATION
  87.         elsif($`==25)
  88.         {
  89.             print "Location: http:\/\/$'\n";
  90.         }
  91. #        LAST-MODIFIED
  92.         elsif($`==26)
  93.         {
  94.             $age = -M "$'";
  95.             $age *= 86400;
  96.             &date(-$age);
  97.             print "Last-modified: $result\n";
  98.         }
  99. #        SET-COOKIE
  100.         elsif($`==27)
  101.         {
  102.             ($name,$value,$age,$path) = split(/\&/,$',4);
  103.             if($age)
  104.             {
  105.                 $age = "\; expires=".&date($age);
  106.             }
  107.             else
  108.             {
  109.                 undef $age;
  110.             }
  111.             $path = "\; path=\/$path" if $path;
  112.             print "Set-Cookie: $name\=$value$age$path\n";
  113.         }
  114.     }
  115. #    CONTENT-TYPE
  116.     elsif($_>28&&$_<40)
  117.     {
  118.         print "Content-type: $header[$_]\n";
  119.     }
  120. #    OTHERS
  121.     else
  122.     {
  123.         print "$header[$_]\n";
  124.     }
  125. }
  126. #Blank line. End of headers
  127. print "\n";
  128.  
  129. return 1;
  130. }
  131. #---------------------------------------------------------------------------
  132. #By Steven Brenner. URL: http://cgi-lib.stanford.edu/cgi-lib/
  133. sub ReadParse {
  134.  
  135. local (*in) = @_ if @_;
  136.  
  137. local ($i, $loc, $key, $val);
  138.  
  139. if ($ENV{'REQUEST_METHOD'} eq "GET")
  140. {
  141.     $in = $ENV{'QUERY_STRING'};
  142. }
  143. elsif ($ENV{'REQUEST_METHOD'} eq "POST")
  144. {
  145.     read(STDIN,$in,$ENV{'CONTENT_LENGTH'});
  146. }
  147.  
  148. @in = split(/&/,$in);
  149.  
  150. foreach $i (0..$#in)
  151. {
  152.     $in[$i] =~s/\+/ /g;
  153.     ($key, $val) = split(/=/,$in[$i],2);
  154.  
  155.     $key =~s/%(..)/pack("c",hex($1))/ge;
  156.     $val =~s/%(..)/pack("c",hex($1))/ge;
  157.  
  158.     $in{$key} .= "\0" if (defined($in{$key}));
  159.     $in{$key} .= $val;
  160. }
  161. return 1;
  162. }
  163. #---------------------------------------------------------------------------
  164. #Sintax:     &parseVar(Scalar_to_be_parsed);
  165. sub parseVar{
  166.  
  167. local($in) = @_;
  168.  
  169. if($in=~/[\s]/g)
  170. {
  171.     $in=~s/\s//g;
  172. }
  173.  
  174. #Bad Characteres
  175. #if($in=~/\W/g)
  176. if($in=~/[\"\'\!\@\#\$\%\¿\&\*\(\)\_\+\=\\\<\>\:\?\/]/g)
  177. {
  178.     $_ = "Data with invalid character(s)!";
  179.     return 1;
  180. }
  181. elsif(not($in))
  182. {
  183.     $_ = "No Data!\n";
  184.     return 1;
  185. }
  186.  
  187. return 0;
  188. }
  189. #---------------------------------------------------------------------------
  190. #Based on the example at:
  191. #    http://www-frd.fsl.noaa.gov/~moninger/web101/4-lecture/big_code.cgi/
  192. #    1_expire_example.cgi.htm
  193. #Sintax:     &date[seconds_to_add];
  194. sub date{
  195.  
  196. $ENV{'TZ'}="GMT";
  197.  
  198. local($_)=@_;
  199.  
  200. local(@month,@day);
  201.  
  202. local($time)=time() + $_;
  203.  
  204. local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=gmtime($time);
  205.  
  206. @month=(Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
  207. @day=(Sun,Mon,Tue,Wed,Thu,Fri,Sat);
  208.  
  209. #@month e @day
  210. $wday_name=$day[$wday];
  211. $month_name=$month[$mon];
  212.  
  213. $exp_time = sprintf("$wday_name, "."%02.2d $month_name 19$year ".
  214. "%02.2d:%02.2d:%02.2d GMT",$mday,$hour,$min,$sec);
  215.  
  216. $result="$exp_time";
  217.  
  218. return ($result);
  219. }
  220. #---------------------------------------------------------------------------
  221. #Sintax:   &pass(current_password,[new_password],[repeated_new_password]);
  222. sub pass{
  223.  
  224. if($#_==2)
  225. {
  226.     local($current_password,$new_password,$rep_password) = @_;
  227.     if(($current_password eq "") && ($new_password eq "") && ($rep_password eq ""))
  228.     {
  229.         $_ = 'No password writen!';
  230.         return 0;
  231.     }
  232.     elsif(($current_password eq "") or ($new_password eq "") or ($rep_password eq ""))
  233.     {
  234.         $_ = 'Any required password not writen!';
  235.         return 0;
  236.     }
  237.     elsif($current_password =~ /\W/g)
  238.     {
  239.         $_ = 'Current Password with invalid character!';
  240.         return 0;
  241.     }
  242.     elsif($current_password eq $new_password)
  243.     {
  244.         $_ = 'Current password equal New Password!';
  245.         return 0;
  246.     }
  247.     elsif($new_password =~ /\W/g)
  248.     {
  249.         $_ = 'New password with invalid character!';
  250.         return 0;
  251.     }
  252.     elsif(length $new_password < 6)
  253.     {
  254.         $_ = "Length of New password less than 6 characters\!";
  255.         return 0;
  256.     }
  257.     elsif(length $new_password > 10)
  258.     {
  259.         $_ = 'Length of New password greater than 10 characters!';
  260.         return 0;
  261.     }
  262.     elsif($new_password ne $rep_password)
  263.     {
  264.         $_ = 'New password not equal to Repeated password!';
  265.         return 0;
  266.     }
  267. }
  268. elsif($#_)
  269. {
  270.     local($new_password,$rep_password) = @_;
  271.     if(($new_password eq "") or ($rep_password eq ""))
  272.     {
  273.         $_ = 'New/Repeated password not writen!';
  274.         return 0;
  275.     }
  276.     elsif($new_password =~ /\W/g)
  277.     {
  278.         $_ = 'New password with invalid character!';
  279.         return 0;
  280.     }
  281.     elsif(length $new_password < 6)
  282.     {
  283.         $_ = "Length of New password less than 6 characters\!";
  284.         return 0;
  285.     }
  286.     elsif(length $new_password > 10)
  287.     {
  288.         $_ = 'Length of New password greater than 10 characters!';
  289.         return 0;
  290.     }
  291.     elsif($new_password ne $rep_password)
  292.     {
  293.         $_ = 'New password not equal to Repeated password!';
  294.         return 0;
  295.     }
  296. }
  297. elsif($#_==0)
  298. {
  299.     local($current_password) = @_;
  300.     if($current_password eq "")
  301.     {
  302.         $_ = 'Current password not writen!';
  303.         return 0;
  304.     }
  305.     elsif($current_password =~ /\W/g)
  306.     {
  307.         $_ = 'Current password with invalid character!';
  308.         return 0;
  309.     }
  310. }
  311.  
  312. return 1;
  313. }
  314. #---------------------------------------------------------------------------
  315. #Sintax:     &email(email_to_be_parsed);
  316. sub email{
  317.  
  318. local($in) = @_;
  319.  
  320. #Most common mensage
  321. local($i) = "Invalid Email format!";
  322.  
  323. #Fin point(.)
  324. if($in=~/\./)
  325. {
  326. #    Find (.@), (@.),(.@.),(..), or (.) extremity
  327.     if(($in=~/\.\@/g) or ($in=~/\.\./g) or ($in=~/\@\./g) or ($in=~/\.$/) or ($in=~/^\./))
  328.     {
  329.         $_ = "$i";
  330.         return 0;
  331.     }
  332. #    If format OK, delete points
  333.     else
  334.     {
  335.         $in=~s/\.//g;
  336.     }
  337. }
  338.  
  339. #Remove first @
  340. if($in=~/\@/)
  341. {
  342. #if ()@(xx(@)xx) or (xx(@)xx)@() or (xx(@)xx)@(xx(@)xx)
  343.     if(($` eq "") or ($' eq "") or ($' =~/\@/g))
  344.     {
  345.         $_ = "$i";
  346.         return 0;
  347.     }
  348. #    Find invalid character
  349.     elsif(($` =~/\W/g) or ( $' =~/\W/g))
  350.     {
  351.         $_ = "Email with invalid character!";
  352.         return 0;
  353.     }
  354. }
  355. elsif($in)
  356. {
  357.     $_ = "$i";
  358.     return 0;
  359. }
  360. elsif(not $in)
  361. {
  362.     $_ = "0:No Email to be parsed!";
  363.     return 0;
  364. }
  365.  
  366. return 1;
  367. }
  368. #---------------------------------------------------------------------------
  369. #Sintax:   &browser[(1)- Return the complete borwser┤s name];
  370. sub browser{
  371.  
  372. local($in,$versao,$nome,$_);
  373.  
  374. $in = @_;
  375.  
  376. ($nome,$_) = split(/\//,$ENV{'HTTP_USER_AGENT'},2);
  377.  
  378. #Internet Explorer, Netscape Navigator or Opera
  379. if ($nome eq "Mozilla")
  380. {
  381. #    version (Nestscape and Explorer)
  382.     $ver  = substr($_,0,4);
  383.  
  384. #    MSIE
  385.     if(/MSIE/)
  386.     {
  387.         $result = $in ? "INTERNET EXPLORER $ver" : "MSIE $ver";
  388.     }
  389. #    Netscape
  390.     elsif(/Win95/)
  391.     {
  392.         $result = $in ? "NETSCAPE NAVIGATOR $ver" : "MOZILLA $ver";
  393.     }
  394. #    Opera
  395.     elsif(/Opera/)
  396.     {
  397. #        Opera┤s version
  398.         ($in,$ver) = split(/\)/,$_,2);
  399.         $result = "OPERA $ver";
  400.     }
  401. }
  402. #If not knew borwser
  403. else
  404. {
  405.     $result = "$nome";
  406. }
  407. return ($result);
  408. }
  409. #----------------------------------------------------------------------------
  410. return 1;
  411.