local-lib5/lib/perl5/CGI/Simple/Util.pm

   1 package CGI::Simple::Util;
   2 use strict;
   3 use vars qw( $VERSION @EXPORT_OK @ISA $UTIL );
   4 $VERSION = '1.112';
   5 require Exporter;
   6 @ISA       = qw( Exporter );
   7 @EXPORT_OK = qw(
   8  rearrange make_attributes expires
   9  escapeHTML unescapeHTML escape unescape
  10 );
  11
  12 sub rearrange {
  13   my ( $order, @params ) = @_;
  14   my ( %pos, @result, %leftover );
  15   return () unless @params;
  16   if ( ref $params[0] eq 'HASH' ) {
  17     @params = %{ $params[0] };
  18   }
  19   else {
  20     return @params unless $params[0] =~ m/^-/;
  21   }
  22
  23   # map parameters into positional indices
  24   my $i = 0;
  25   for ( @$order ) {
  26     for ( ref( $_ ) eq 'ARRAY' ? @$_ : $_ ) { $pos{ lc( $_ ) } = $i; }
  27     $i++;
  28   }
  29   $#result = $#$order;    # preextend
  30   while ( @params ) {
  31     my $key = lc( shift( @params ) );
  32     $key =~ s/^\-//;
  33     if ( exists $pos{$key} ) {
  34       $result[ $pos{$key} ] = shift( @params );
  35     }
  36     else {
  37       $leftover{$key} = shift( @params );
  38     }
  39   }
  40   push @result, make_attributes( \%leftover, 1 ) if %leftover;
  41   return @result;
  42 }
  43
  44 sub make_attributes {
  45   my $attref = shift;
  46   my $escape = shift || 0;
  47   return () unless $attref && ref $attref eq 'HASH';
  48   my @attrib;
  49   for my $key ( keys %{$attref} ) {
  50     ( my $mod_key = $key ) =~ s/^-//;  # get rid of initial - if present
  51     $mod_key = lc $mod_key;            # parameters are lower case
  52     $mod_key =~ tr/_/-/;               # use dashes
  53     my $value
  54      = $escape ? escapeHTML( $attref->{$key} ) : $attref->{$key};
  55     push @attrib, defined $value ? qq/$mod_key="$value"/ : $mod_key;
  56   }
  57   return @attrib;
  58 }
  59
  60 # This internal routine creates date strings suitable for use in
  61 # cookies and HTTP headers.  (They differ, unfortunately.)
  62 # Thanks to Mark Fisher for this.
  63 sub expires {
  64   my ( $time, $format ) = @_;
  65   $format ||= 'http';
  66   my @MON  = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  67   my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat );
  68
  69   # pass through preformatted dates for the sake of expire_calc()
  70   $time = _expire_calc( $time );
  71   return $time unless $time =~ /^\d+$/;
  72
  73   # make HTTP/cookie date string from GMT'ed time
  74   # (cookies use '-' as date separator, HTTP uses ' ')
  75   my $sc = $format eq 'cookie' ? '-' : ' ';
  76   my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime( $time );
  77   $year += 1900;
  78   return sprintf( "%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
  79     $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec );
  80 }
  81
  82 # This internal routine creates an expires time exactly some number of
  83 # hours from the current time.  It incorporates modifications from Mark Fisher.
  84 # format for time can be in any of the forms...
  85 #   "now"   -- expire immediately
  86 #   "+180s" -- in 180 seconds
  87 #   "+2m"   -- in 2 minutes
  88 #   "+12h"  -- in 12 hours
  89 #   "+1d"   -- in 1 day
  90 #   "+3M"   -- in 3 months
  91 #   "+2y"   -- in 2 years
  92 #   "-3m"   -- 3 minutes ago(!)
  93 # If you don't supply one of these forms, we assume you are specifying
  94 # the date yourself
  95 sub _expire_calc {
  96   my ( $time ) = @_;
  97   my %mult = (
  98     's' => 1,
  99     'm' => 60,
 100     'h' => 60 * 60,
 101     'd' => 60 * 60 * 24,
 102     'M' => 60 * 60 * 24 * 30,
 103     'y' => 60 * 60 * 24 * 365
 104   );
 105   my $offset;
 106   if ( !$time or lc $time eq 'now' ) {
 107     $offset = 0;
 108   }
 109   elsif ( $time =~ /^\d+/ ) {
 110     return $time;
 111   }
 112   elsif ( $time =~ /^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/ ) {
 113     $offset = ( $mult{$2} || 1 ) * $1;
 114   }
 115   else {
 116     return $time;
 117   }
 118   return ( time + $offset );
 119 }
 120
 121 sub escapeHTML {
 122   my ( $escape, $text ) = @_;
 123   return undef unless defined $escape;
 124   $escape =~ s/&/&amp;/g;
 125   $escape =~ s/"/&quot;/g;
 126   $escape =~ s/</&lt;/g;
 127   $escape =~ s/>/&gt;/g;
 128
 129 # these next optional escapes make text look the same when rendered in HTML
 130   if ( $text ) {
 131     $escape =~ s/\t/    /g;                         # tabs to 4 spaces
 132     $escape =~ s/( {2,})/"&nbsp;" x length $1/eg;   # whitespace escapes
 133     $escape =~ s/\n/<br>\n/g;                       # newlines to <br>
 134   }
 135   return $escape;
 136 }
 137
 138 sub unescapeHTML {
 139   my ( $unescape ) = @_;
 140   return undef unless defined( $unescape );
 141   my $latin = $UTIL->{'charset'} =~ /^(?:ISO-8859-1|WINDOWS-1252)$/i;
 142   my $ebcdic = $UTIL->{'ebcdic'};
 143
 144   # credit to Randal Schwartz for original version of this
 145   $unescape =~ s[&(.*?);]{
 146         local $_ = $1;
 147         /^amp$/i           ? "&" :
 148         /^quot$/i          ? '"' :
 149         /^gt$/i            ? ">" :
 150         /^lt$/i            ? "<" :
 151         /^#(\d+)$/         && $latin  ? chr($1) :
 152         /^#(\d+)$/         && $ebcdic ? chr($UTIL->{'a2e'}->[$1]) :
 153         /^#x([0-9a-f]+)$/i && $latin  ? chr(hex($1)) :
 154         /^#x([0-9a-f]+)$/i && $ebcdic ? chr($UTIL->{'a2e'}->[hex $1]) :
 155         "\&$_;"
 156     }gex;
 157   return $unescape;
 158 }
 159
 160 # URL-encode data
 161 sub escape {
 162   my ( $toencode ) = @_;
 163   return undef unless defined $toencode;
 164   if ( $UTIL->{'ebcdic'} ) {
 165     $toencode
 166      =~ s/([^a-zA-Z0-9_.-])/uc sprintf "%%%02x", $UTIL->{'e2a'}->[ord $1]/eg;
 167   }
 168   else {
 169     $toencode =~ s/([^a-zA-Z0-9_.-])/uc sprintf "%%%02x", ord $1 /eg;
 170   }
 171   return $toencode;
 172 }
 173
 174 # unescape URL-encoded data
 175 sub unescape {
 176   my ( $todecode ) = @_;
 177   return undef unless defined $todecode;
 178   $todecode =~ tr/+/ /;
 179   if ( $UTIL->{'ebcdic'} ) {
 180     $todecode =~ s/%([0-9a-fA-F]{2})/chr $UTIL->{'a2e'}->[hex $1]/ge;
 181   }
 182   else {
 183     $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
 184         defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
 185   }
 186   return $todecode;
 187 }
 188
 189 sub utf8_chr ($) {
 190   my $c = shift;
 191   if ( $c < 0x80 ) {
 192     return sprintf( "%c", $c );
 193   }
 194   elsif ( $c < 0x800 ) {
 195     return sprintf( "%c%c", 0xc0 | ( $c >> 6 ), 0x80 | ( $c & 0x3f ) );
 196   }
 197   elsif ( $c < 0x10000 ) {
 198     return sprintf( "%c%c%c",
 199       0xe0 | ( $c >> 12 ),
 200       0x80 | ( ( $c >> 6 ) & 0x3f ),
 201       0x80 | ( $c & 0x3f ) );
 202   }
 203   elsif ( $c < 0x200000 ) {
 204     return sprintf( "%c%c%c%c",
 205       0xf0 | ( $c >> 18 ),
 206       0x80 | ( ( $c >> 12 ) & 0x3f ),
 207       0x80 | ( ( $c >> 6 ) & 0x3f ),
 208       0x80 | ( $c & 0x3f ) );
 209   }
 210   elsif ( $c < 0x4000000 ) {
 211     return sprintf( "%c%c%c%c%c",
 212       0xf8 | ( $c >> 24 ),
 213       0x80 | ( ( $c >> 18 ) & 0x3f ),
 214       0x80 | ( ( $c >> 12 ) & 0x3f ),
 215       0x80 | ( ( $c >> 6 ) & 0x3f ),
 216       0x80 | ( $c & 0x3f ) );
 217
 218   }
 219   elsif ( $c < 0x80000000 ) {
 220     return sprintf(
 221       "%c%c%c%c%c%c",
 222       0xfc | ( $c >> 30 ),           # was 0xfe patch Thomas L. Shinnick
 223       0x80 | ( ( $c >> 24 ) & 0x3f ),
 224       0x80 | ( ( $c >> 18 ) & 0x3f ),
 225       0x80 | ( ( $c >> 12 ) & 0x3f ),
 226       0x80 | ( ( $c >> 6 ) & 0x3f ),
 227       0x80 | ( $c & 0x3f )
 228     );
 229   }
 230   else {
 231     return utf8( 0xfffd );
 232   }
 233 }
 234
 235 # We need to define a number of things about the operating environment so
 236 # we do this on first initialization and store the results in in an object
 237 BEGIN {
 238
 239   $UTIL = new CGI::Simple::Util;    # initialize our $UTIL object
 240
 241   sub new {
 242     my $class = shift;
 243     $class = ref( $class ) || $class;
 244     my $self = {};
 245     bless $self, $class;
 246     $self->init;
 247     return $self;
 248   }
 249
 250   sub init {
 251     my $self = shift;
 252     $self->charset;
 253     $self->os;
 254     $self->ebcdic;
 255   }
 256
 257   sub charset {
 258     my ( $self, $charset ) = @_;
 259     $self->{'charset'} = $charset if $charset;
 260     $self->{'charset'}
 261      ||= 'ISO-8859-1';    # set to the safe ISO-8859-1 if not defined
 262     return $self->{'charset'};
 263   }
 264
 265   sub os {
 266     my ( $self, $OS ) = @_;
 267     $self->{'os'} = $OS if $OS;    # allow value to be set manually
 268     $OS = $self->{'os'};
 269     unless ( $OS ) {
 270       unless ( $OS = $^O ) {
 271         require Config;
 272         $OS = $Config::Config{'osname'};
 273       }
 274       if ( $OS =~ /Win/i ) {
 275         $OS = 'WINDOWS';
 276       }
 277       elsif ( $OS =~ /vms/i ) {
 278         $OS = 'VMS';
 279       }
 280       elsif ( $OS =~ /bsdos/i ) {
 281         $OS = 'UNIX';
 282       }
 283       elsif ( $OS =~ /dos/i ) {
 284         $OS = 'DOS';
 285       }
 286       elsif ( $OS =~ /^MacOS$/i ) {
 287         $OS = 'MACINTOSH';
 288       }
 289       elsif ( $OS =~ /os2/i ) {
 290         $OS = 'OS2';
 291       }
 292       else {
 293         $OS = 'UNIX';
 294       }
 295     }
 296     return $self->{'os'} = $OS;
 297   }
 298
 299   sub ebcdic {
 300     my $self = shift;
 301     return $self->{'ebcdic'} if exists $self->{'ebcdic'};
 302     $self->{'ebcdic'} = "\t" ne "\011" ? 1 : 0;
 303     if ( $self->{'ebcdic'} ) {
 304
 305       # (ord('^') == 95) for codepage 1047 as on os390, vmesa
 306       my @A2E = (
 307         0,   1,   2,   3,   55,  45,  46,  47,  22,  5,   21,  11,
 308         12,  13,  14,  15,  16,  17,  18,  19,  60,  61,  50,  38,
 309         24,  25,  63,  39,  28,  29,  30,  31,  64,  90,  127, 123,
 310         91,  108, 80,  125, 77,  93,  92,  78,  107, 96,  75,  97,
 311         240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 122, 94,
 312         76,  126, 110, 111, 124, 193, 194, 195, 196, 197, 198, 199,
 313         200, 201, 209, 210, 211, 212, 213, 214, 215, 216, 217, 226,
 314         227, 228, 229, 230, 231, 232, 233, 173, 224, 189, 95,  109,
 315         121, 129, 130, 131, 132, 133, 134, 135, 136, 137, 145, 146,
 316         147, 148, 149, 150, 151, 152, 153, 162, 163, 164, 165, 166,
 317         167, 168, 169, 192, 79,  208, 161, 7,   32,  33,  34,  35,
 318         36,  37,  6,   23,  40,  41,  42,  43,  44,  9,   10,  27,
 319         48,  49,  26,  51,  52,  53,  54,  8,   56,  57,  58,  59,
 320         4,   20,  62,  255, 65,  170, 74,  177, 159, 178, 106, 181,
 321         187, 180, 154, 138, 176, 202, 175, 188, 144, 143, 234, 250,
 322         190, 160, 182, 179, 157, 218, 155, 139, 183, 184, 185, 171,
 323         100, 101, 98,  102, 99,  103, 158, 104, 116, 113, 114, 115,
 324         120, 117, 118, 119, 172, 105, 237, 238, 235, 239, 236, 191,
 325         128, 253, 254, 251, 252, 186, 174, 89,  68,  69,  66,  70,
 326         67,  71,  156, 72,  84,  81,  82,  83,  88,  85,  86,  87,
 327         140, 73,  205, 206, 203, 207, 204, 225, 112, 221, 222, 219,
 328         220, 141, 142, 223
 329       );
 330       my @E2A = (
 331         0,   1,   2,   3,   156, 9,   134, 127, 151, 141, 142, 11,
 332         12,  13,  14,  15,  16,  17,  18,  19,  157, 10,  8,   135,
 333         24,  25,  146, 143, 28,  29,  30,  31,  128, 129, 130, 131,
 334         132, 133, 23,  27,  136, 137, 138, 139, 140, 5,   6,   7,
 335         144, 145, 22,  147, 148, 149, 150, 4,   152, 153, 154, 155,
 336         20,  21,  158, 26,  32,  160, 226, 228, 224, 225, 227, 229,
 337         231, 241, 162, 46,  60,  40,  43,  124, 38,  233, 234, 235,
 338         232, 237, 238, 239, 236, 223, 33,  36,  42,  41,  59,  94,
 339         45,  47,  194, 196, 192, 193, 195, 197, 199, 209, 166, 44,
 340         37,  95,  62,  63,  248, 201, 202, 203, 200, 205, 206, 207,
 341         204, 96,  58,  35,  64,  39,  61,  34,  216, 97,  98,  99,
 342         100, 101, 102, 103, 104, 105, 171, 187, 240, 253, 254, 177,
 343         176, 106, 107, 108, 109, 110, 111, 112, 113, 114, 170, 186,
 344         230, 184, 198, 164, 181, 126, 115, 116, 117, 118, 119, 120,
 345         121, 122, 161, 191, 208, 91,  222, 174, 172, 163, 165, 183,
 346         169, 167, 182, 188, 189, 190, 221, 168, 175, 93,  180, 215,
 347         123, 65,  66,  67,  68,  69,  70,  71,  72,  73,  173, 244,
 348         246, 242, 243, 245, 125, 74,  75,  76,  77,  78,  79,  80,
 349         81,  82,  185, 251, 252, 249, 250, 255, 92,  247, 83,  84,
 350         85,  86,  87,  88,  89,  90,  178, 212, 214, 210, 211, 213,
 351         48,  49,  50,  51,  52,  53,  54,  55,  56,  57,  179, 219,
 352         220, 217, 218, 159
 353       );
 354       if ( ord( '^' ) == 106 )
 355       {    # as in the BS2000 posix-bc coded character set
 356         $A2E[91]  = 187;
 357         $A2E[92]  = 188;
 358         $A2E[94]  = 106;
 359         $A2E[96]  = 74;
 360         $A2E[123] = 251;
 361         $A2E[125] = 253;
 362         $A2E[126] = 255;
 363         $A2E[159] = 95;
 364         $A2E[162] = 176;
 365         $A2E[166] = 208;
 366         $A2E[168] = 121;
 367         $A2E[172] = 186;
 368         $A2E[175] = 161;
 369         $A2E[217] = 224;
 370         $A2E[219] = 221;
 371         $A2E[221] = 173;
 372         $A2E[249] = 192;
 373
 374         $E2A[74]  = 96;
 375         $E2A[95]  = 159;
 376         $E2A[106] = 94;
 377         $E2A[121] = 168;
 378         $E2A[161] = 175;
 379         $E2A[173] = 221;
 380         $E2A[176] = 162;
 381         $E2A[186] = 172;
 382         $E2A[187] = 91;
 383         $E2A[188] = 92;
 384         $E2A[192] = 249;
 385         $E2A[208] = 166;
 386         $E2A[221] = 219;
 387         $E2A[224] = 217;
 388         $E2A[251] = 123;
 389         $E2A[253] = 125;
 390         $E2A[255] = 126;
 391       }
 392       elsif ( ord( '^' ) == 176 ) {    # as in codepage 037 on os400
 393         $A2E[10]  = 37;
 394         $A2E[91]  = 186;
 395         $A2E[93]  = 187;
 396         $A2E[94]  = 176;
 397         $A2E[133] = 21;
 398         $A2E[168] = 189;
 399         $A2E[172] = 95;
 400         $A2E[221] = 173;
 401
 402         $E2A[21]  = 133;
 403         $E2A[37]  = 10;
 404         $E2A[95]  = 172;
 405         $E2A[173] = 221;
 406         $E2A[176] = 94;
 407         $E2A[186] = 91;
 408         $E2A[187] = 93;
 409         $E2A[189] = 168;
 410       }
 411       $self->{'a2e'} = \@A2E;
 412       $self->{'e2a'} = \@E2A;
 413     }
 414   }
 415 }
 416
 417 1;
 418
 419 __END__
 420
 421 =head1 NAME
 422
 423 CGI::Simple::Util - Internal utilities used by CGI::Simple module
 424
 425 =head1 SYNOPSIS
 426
 427     $escaped     = escapeHTML('In HTML you need to escape < > " and & chars');
 428     $unescaped   = unescapeHTML('&lt;&gt;&quot;&amp;');
 429     $url_encoded = escape($string);
 430     $decoded     = unescape($url_encoded);
 431
 432 =head1 DESCRIPTION
 433
 434 CGI::Simple::Util contains essentially non public subroutines used by
 435 CGI::Simple. There are HTML and URL escape and unescape routines that may
 436 be of some use.
 437
 438 An internal object is used to store a number of system specific details to
 439 enable the escape routines to be accurate.
 440
 441 =head1 AUTHOR INFORMATION
 442
 443 Original version copyright 1995-1998, Lincoln D. Stein.  All rights reserved.
 444 Originally copyright 2001 Dr James Freeman E<lt>jfreeman@tassie.net.auE<gt>
 445 This release by Andy Armstrong <andy@hexten.net>
 446
 447 This library is free software; you can redistribute it and/or modify
 448 it under the same terms as Perl itself.
 449
 450 Address bug reports and comments to: andy@hexten.net
 451
 452 =head1 SEE ALSO
 453
 454 L<CGI::Simple>
 455
 456 =cut