home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / CGI / Util.pm < prev   
Encoding:
Perl POD Document  |  2002-06-19  |  10.8 KB  |  304 lines
  1. package CGI::Util;
  2.  
  3. use strict;
  4. use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
  5. require Exporter;
  6. @ISA = qw(Exporter);
  7. @EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
  8.  
  9. $VERSION = '1.3';
  10.  
  11. $EBCDIC = "\t" ne "\011";
  12. if ($EBCDIC) {
  13.   # (ord('^') == 95) for codepage 1047 as on os390, vmesa
  14.   @A2E = (
  15.    0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
  16.   16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
  17.   64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
  18.  240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
  19.  124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
  20.  215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
  21.  121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
  22.  151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161,  7,
  23.   32, 33, 34, 35, 36, 37,  6, 23, 40, 41, 42, 43, 44,  9, 10, 27,
  24.   48, 49, 26, 51, 52, 53, 54,  8, 56, 57, 58, 59,  4, 20, 62,255,
  25.   65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
  26.  144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
  27.  100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
  28.  172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
  29.   68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
  30.  140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
  31.      );
  32.   @E2A = (
  33.    0,  1,  2,  3,156,  9,134,127,151,141,142, 11, 12, 13, 14, 15,
  34.   16, 17, 18, 19,157, 10,  8,135, 24, 25,146,143, 28, 29, 30, 31,
  35.  128,129,130,131,132,133, 23, 27,136,137,138,139,140,  5,  6,  7,
  36.  144,145, 22,147,148,149,150,  4,152,153,154,155, 20, 21,158, 26,
  37.   32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
  38.   38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
  39.   45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
  40.  248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
  41.  216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
  42.  176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
  43.  181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
  44.  172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
  45.  123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
  46.  125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
  47.   92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
  48.   48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
  49.      );
  50.   if (ord('^') == 106) { # as in the BS2000 posix-bc coded character set
  51.      $A2E[91] = 187;   $A2E[92] = 188;  $A2E[94] = 106;  $A2E[96] = 74;
  52.      $A2E[123] = 251;  $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
  53.      $A2E[162] = 176;  $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
  54.      $A2E[175] = 161;  $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
  55.      $A2E[249] = 192;
  56.  
  57.      $E2A[74] = 96;   $E2A[95] = 159;  $E2A[106] = 94;  $E2A[121] = 168;
  58.      $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
  59.      $E2A[187] = 91;  $E2A[188] = 92;  $E2A[192] = 249; $E2A[208] = 166;
  60.      $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
  61.      $E2A[255] = 126;
  62.  }
  63.   elsif (ord('^') == 176) { # as in codepage 037 on os400
  64.      $A2E[10] = 37;  $A2E[91] = 186;  $A2E[93] = 187; $A2E[94] = 176;
  65.      $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
  66.  
  67.      $E2A[21] = 133; $E2A[37] = 10;  $E2A[95] = 172; $E2A[173] = 221;
  68.      $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
  69.    }
  70. }
  71.  
  72. # Smart rearrangement of parameters to allow named parameter
  73. # calling.  We do the rearangement if:
  74. # the first parameter begins with a -
  75. sub rearrange {
  76.     my($order,@param) = @_;
  77.     return () unless @param;
  78.  
  79.     if (ref($param[0]) eq 'HASH') {
  80.     @param = %{$param[0]};
  81.     } else {
  82.     return @param 
  83.         unless (defined($param[0]) && substr($param[0],0,1) eq '-');
  84.     }
  85.  
  86.     # map parameters into positional indices
  87.     my ($i,%pos);
  88.     $i = 0;
  89.     foreach (@$order) {
  90.     foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
  91.     $i++;
  92.     }
  93.  
  94.     my (@result,%leftover);
  95.     $#result = $#$order;  # preextend
  96.     while (@param) {
  97.     my $key = lc(shift(@param));
  98.     $key =~ s/^\-//;
  99.     if (exists $pos{$key}) {
  100.         $result[$pos{$key}] = shift(@param);
  101.     } else {
  102.         $leftover{$key} = shift(@param);
  103.     }
  104.     }
  105.  
  106.     push (@result,make_attributes(\%leftover,1)) if %leftover;
  107.     @result;
  108. }
  109.  
  110. sub make_attributes {
  111.     my $attr = shift;
  112.     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
  113.     my $escape = shift || 0;
  114.     my(@att);
  115.     foreach (keys %{$attr}) {
  116.     my($key) = $_;
  117.     $key=~s/^\-//;     # get rid of initial - if present
  118.  
  119.     # old way: breaks EBCDIC!
  120.     # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
  121.  
  122.     ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
  123.  
  124.     my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
  125.     push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
  126.     }
  127.     return @att;
  128. }
  129.  
  130. sub simple_escape {
  131.   return unless defined(my $toencode = shift);
  132.   $toencode =~ s{&}{&}gso;
  133.   $toencode =~ s{<}{<}gso;
  134.   $toencode =~ s{>}{>}gso;
  135.   $toencode =~ s{\"}{"}gso;
  136. # Doesn't work.  Can't work.  forget it.
  137. #  $toencode =~ s{\x8b}{‹}gso;
  138. #  $toencode =~ s{\x9b}{›}gso;
  139.   $toencode;
  140. }
  141.  
  142. sub utf8_chr ($) {
  143.         my $c = shift(@_);
  144.  
  145.         if ($c < 0x80) {
  146.                 return sprintf("%c", $c);
  147.         } elsif ($c < 0x800) {
  148.                 return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
  149.         } elsif ($c < 0x10000) {
  150.                 return sprintf("%c%c%c",
  151.                                            0xe0 |  ($c >> 12),
  152.                                            0x80 | (($c >>  6) & 0x3f),
  153.                                            0x80 | ( $c          & 0x3f));
  154.         } elsif ($c < 0x200000) {
  155.                 return sprintf("%c%c%c%c",
  156.                                            0xf0 |  ($c >> 18),
  157.                                            0x80 | (($c >> 12) & 0x3f),
  158.                                            0x80 | (($c >>  6) & 0x3f),
  159.                                            0x80 | ( $c          & 0x3f));
  160.         } elsif ($c < 0x4000000) {
  161.                 return sprintf("%c%c%c%c%c",
  162.                                            0xf8 |  ($c >> 24),
  163.                                            0x80 | (($c >> 18) & 0x3f),
  164.                                            0x80 | (($c >> 12) & 0x3f),
  165.                                            0x80 | (($c >>  6) & 0x3f),
  166.                                            0x80 | ( $c          & 0x3f));
  167.  
  168.         } elsif ($c < 0x80000000) {
  169.                 return sprintf("%c%c%c%c%c%c",
  170.                                            0xfe |  ($c >> 30),
  171.                                            0x80 | (($c >> 24) & 0x3f),
  172.                                            0x80 | (($c >> 18) & 0x3f),
  173.                                            0x80 | (($c >> 12) & 0x3f),
  174.                                            0x80 | (($c >> 6)  & 0x3f),
  175.                                            0x80 | ( $c          & 0x3f));
  176.         } else {
  177.                 return utf8(0xfffd);
  178.         }
  179. }
  180.  
  181. # unescape URL-encoded data
  182. sub unescape {
  183.   shift() if @_ > 1 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  184.   my $todecode = shift;
  185.   return undef unless defined($todecode);
  186.   $todecode =~ tr/+/ /;       # pluses become spaces
  187.     $EBCDIC = "\t" ne "\011";
  188.     if ($EBCDIC) {
  189.       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
  190.     } else {
  191.       $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
  192.     defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
  193.     }
  194.   return $todecode;
  195. }
  196.  
  197. # URL-encode data
  198. sub escape {
  199.   shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  200.   my $toencode = shift;
  201.   return undef unless defined($toencode);
  202.     if ($EBCDIC) {
  203.       $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
  204.     } else {
  205.       $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
  206.     }
  207.   return $toencode;
  208. }
  209.  
  210. # This internal routine creates date strings suitable for use in
  211. # cookies and HTTP headers.  (They differ, unfortunately.)
  212. # Thanks to Mark Fisher for this.
  213. sub expires {
  214.     my($time,$format) = @_;
  215.     $format ||= 'http';
  216.  
  217.     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
  218.     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
  219.  
  220.     # pass through preformatted dates for the sake of expire_calc()
  221.     $time = expire_calc($time);
  222.     return $time unless $time =~ /^\d+$/;
  223.  
  224.     # make HTTP/cookie date string from GMT'ed time
  225.     # (cookies use '-' as date separator, HTTP uses ' ')
  226.     my($sc) = ' ';
  227.     $sc = '-' if $format eq "cookie";
  228.     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
  229.     $year += 1900;
  230.     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
  231.                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
  232. }
  233.  
  234. # This internal routine creates an expires time exactly some number of
  235. # hours from the current time.  It incorporates modifications from 
  236. # Mark Fisher.
  237. sub expire_calc {
  238.     my($time) = @_;
  239.     my(%mult) = ('s'=>1,
  240.                  'm'=>60,
  241.                  'h'=>60*60,
  242.                  'd'=>60*60*24,
  243.                  'M'=>60*60*24*30,
  244.                  'y'=>60*60*24*365);
  245.     # format for time can be in any of the forms...
  246.     # "now" -- expire immediately
  247.     # "+180s" -- in 180 seconds
  248.     # "+2m" -- in 2 minutes
  249.     # "+12h" -- in 12 hours
  250.     # "+1d"  -- in 1 day
  251.     # "+3M"  -- in 3 months
  252.     # "+2y"  -- in 2 years
  253.     # "-3m"  -- 3 minutes ago(!)
  254.     # If you don't supply one of these forms, we assume you are
  255.     # specifying the date yourself
  256.     my($offset);
  257.     if (!$time || (lc($time) eq 'now')) {
  258.         $offset = 0;
  259.     } elsif ($time=~/^\d+/) {
  260.         return $time;
  261.     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
  262.         $offset = ($mult{$2} || 1)*$1;
  263.     } else {
  264.         return $time;
  265.     }
  266.     return (time+$offset);
  267. }
  268.  
  269. 1;
  270.  
  271. __END__
  272.  
  273. =head1 NAME
  274.  
  275. CGI::Util - Internal utilities used by CGI module
  276.  
  277. =head1 SYNOPSIS
  278.  
  279. none
  280.  
  281. =head1 DESCRIPTION
  282.  
  283. no public subroutines
  284.  
  285. =head1 AUTHOR INFORMATION
  286.  
  287. Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.  
  288.  
  289. This library is free software; you can redistribute it and/or modify
  290. it under the same terms as Perl itself.
  291.  
  292. Address bug reports and comments to: lstein@cshl.org.  When sending
  293. bug reports, please provide the version of CGI.pm, the version of
  294. Perl, the name and version of your Web server, and the name and
  295. version of the operating system you are using.  If the problem is even
  296. remotely browser dependent, please provide information about the
  297. affected browers as well.
  298.  
  299. =head1 SEE ALSO
  300.  
  301. L<CGI>
  302.  
  303. =cut
  304.