[p5sagit/p5-mst-13.2.git] / lib / CGI / Util.pm

package CGI::Util;

use strict;
use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(rearrange make_attributes unescape escape 
		expires ebcdic2ascii ascii2ebcdic);

$VERSION = '1.5';

$EBCDIC = "\t" ne "\011";
# (ord('^') == 95) for codepage 1047 as on os390, vmesa
@A2E = (
   0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
  16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
  64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161,  7,
  32, 33, 34, 35, 36, 37,  6, 23, 40, 41, 42, 43, 44,  9, 10, 27,
  48, 49, 26, 51, 52, 53, 54,  8, 56, 57, 58, 59,  4, 20, 62,255,
  65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
  68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
	 );
@E2A = (
   0,  1,  2,  3,156,  9,134,127,151,141,142, 11, 12, 13, 14, 15,
  16, 17, 18, 19,157, 10,  8,135, 24, 25,146,143, 28, 29, 30, 31,
 128,129,130,131,132,133, 23, 27,136,137,138,139,140,  5,  6,  7,
 144,145, 22,147,148,149,150,  4,152,153,154,155, 20, 21,158, 26,
  32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
  38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
  45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
  92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
  48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
	 );

if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
     $A2E[91] = 187;   $A2E[92] = 188;  $A2E[94] = 106;  $A2E[96] = 74;
     $A2E[123] = 251;  $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
     $A2E[162] = 176;  $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
     $A2E[175] = 161;  $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
     $A2E[249] = 192;

     $E2A[74] = 96;   $E2A[95] = 159;  $E2A[106] = 94;  $E2A[121] = 168;
     $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
     $E2A[187] = 91;  $E2A[188] = 92;  $E2A[192] = 249; $E2A[208] = 166;
     $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
     $E2A[255] = 126;
   }
elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
  $A2E[10] = 37;  $A2E[91] = 186;  $A2E[93] = 187; $A2E[94] = 176;
  $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;

  $E2A[21] = 133; $E2A[37] = 10;  $E2A[95] = 172; $E2A[173] = 221;
  $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
}

# Smart rearrangement of parameters to allow named parameter
# calling.  We do the rearangement if:
# the first parameter begins with a -
sub rearrange {
    my($order,@param) = @_;
    return () unless @param;

    if (ref($param[0]) eq 'HASH') {
	@param = %{$param[0]};
    } else {
	return @param 
	    unless (defined($param[0]) && substr($param[0],0,1) eq '-');
    }

    # map parameters into positional indices
    my ($i,%pos);
    $i = 0;
    foreach (@$order) {
	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
	$i++;
    }

    my (@result,%leftover);
    $#result = $#$order;  # preextend
    while (@param) {
	my $key = lc(shift(@param));
	$key =~ s/^\-//;
	if (exists $pos{$key}) {
	    $result[$pos{$key}] = shift(@param);
	} else {
	    $leftover{$key} = shift(@param);
	}
    }

    push (@result,make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
    @result;
}

sub make_attributes {
    my $attr = shift;
    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
    my $escape =  shift || 0;
    my(@att);
    foreach (keys %{$attr}) {
	my($key) = $_;
	$key=~s/^\-//;     # get rid of initial - if present

	# old way: breaks EBCDIC!
	# $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes

	($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes

	my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
    }
    return @att;
}

sub simple_escape {
  return unless defined(my $toencode = shift);
  $toencode =~ s{&}{&amp;}gso;
  $toencode =~ s{<}{&lt;}gso;
  $toencode =~ s{>}{&gt;}gso;
  $toencode =~ s{\"}{&quot;}gso;
# Doesn't work.  Can't work.  forget it.
#  $toencode =~ s{\x8b}{&#139;}gso;
#  $toencode =~ s{\x9b}{&#155;}gso;
  $toencode;
}

sub utf8_chr {
        my $c = shift(@_);
	return chr($c) if $] >= 5.006;

        if ($c < 0x80) {
                return sprintf("%c", $c);
        } elsif ($c < 0x800) {
                return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
        } elsif ($c < 0x10000) {
                return sprintf("%c%c%c",
                                           0xe0 |  ($c >> 12),
                                           0x80 | (($c >>  6) & 0x3f),
                                           0x80 | ( $c          & 0x3f));
        } elsif ($c < 0x200000) {
                return sprintf("%c%c%c%c",
                                           0xf0 |  ($c >> 18),
                                           0x80 | (($c >> 12) & 0x3f),
                                           0x80 | (($c >>  6) & 0x3f),
                                           0x80 | ( $c          & 0x3f));
        } elsif ($c < 0x4000000) {
                return sprintf("%c%c%c%c%c",
                                           0xf8 |  ($c >> 24),
                                           0x80 | (($c >> 18) & 0x3f),
                                           0x80 | (($c >> 12) & 0x3f),
                                           0x80 | (($c >>  6) & 0x3f),
                                           0x80 | ( $c          & 0x3f));

        } elsif ($c < 0x80000000) {
                return sprintf("%c%c%c%c%c%c",
                                           0xfc |  ($c >> 30),
                                           0x80 | (($c >> 24) & 0x3f),
                                           0x80 | (($c >> 18) & 0x3f),
                                           0x80 | (($c >> 12) & 0x3f),
                                           0x80 | (($c >> 6)  & 0x3f),
                                           0x80 | ( $c          & 0x3f));
        } else {
                return utf8_chr(0xfffd);
        }
}

# unescape URL-encoded data
sub unescape {
  shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  my $todecode = shift;
  return undef unless defined($todecode);
  $todecode =~ tr/+/ /;       # pluses become spaces
    $EBCDIC = "\t" ne "\011";
    if ($EBCDIC) {
      $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
    } else {
      $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
	defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
    }
  return $todecode;
}

# URL-encode data
sub escape {
  shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  my $toencode = shift;
  return undef unless defined($toencode);
  # force bytes while preserving backward compatibility -- dankogai
#  $toencode = eval { pack("C*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode));
  $toencode = eval { pack("U*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode));
    if ($EBCDIC) {
      $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
    } else {
      $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
    }
  return $toencode;
}

# This internal routine creates date strings suitable for use in
# cookies and HTTP headers.  (They differ, unfortunately.)
# Thanks to Mark Fisher for this.
sub expires {
    my($time,$format) = @_;
    $format ||= 'http';

    my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
    my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;

    # pass through preformatted dates for the sake of expire_calc()
    $time = expire_calc($time);
    return $time unless $time =~ /^\d+$/;

    # make HTTP/cookie date string from GMT'ed time
    # (cookies use '-' as date separator, HTTP uses ' ')
    my($sc) = ' ';
    $sc = '-' if $format eq "cookie";
    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
    $year += 1900;
    return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
                   $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
}

# This internal routine creates an expires time exactly some number of
# hours from the current time.  It incorporates modifications from 
# Mark Fisher.
sub expire_calc {
    my($time) = @_;
    my(%mult) = ('s'=>1,
                 'm'=>60,
                 'h'=>60*60,
                 'd'=>60*60*24,
                 'M'=>60*60*24*30,
                 'y'=>60*60*24*365);
    # format for time can be in any of the forms...
    # "now" -- expire immediately
    # "+180s" -- in 180 seconds
    # "+2m" -- in 2 minutes
    # "+12h" -- in 12 hours
    # "+1d"  -- in 1 day
    # "+3M"  -- in 3 months
    # "+2y"  -- in 2 years
    # "-3m"  -- 3 minutes ago(!)
    # If you don't supply one of these forms, we assume you are
    # specifying the date yourself
    my($offset);
    if (!$time || (lc($time) eq 'now')) {
      $offset = 0;
    } elsif ($time=~/^\d+/) {
      return $time;
    } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
      $offset = ($mult{$2} || 1)*$1;
    } else {
      return $time;
    }
    return (time+$offset);
}

sub ebcdic2ascii {
  my $data = shift;
  $data =~ s/(.)/chr $E2A[ord($1)]/ge;
  $data;
}

sub ascii2ebcdic {
  my $data = shift;
  $data =~ s/(.)/chr $A2E[ord($1)]/ge;
  $data;
}

1;

__END__

=head1 NAME

CGI::Util - Internal utilities used by CGI module

=head1 SYNOPSIS

none

=head1 DESCRIPTION

no public subroutines

=head1 AUTHOR INFORMATION

Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.  

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

Address bug reports and comments to: lstein@cshl.org.  When sending
bug reports, please provide the version of CGI.pm, the version of
Perl, the name and version of your Web server, and the name and
version of the operating system you are using.  If the problem is even
remotely browser dependent, please provide information about the
affected browers as well.

=head1 SEE ALSO

L<CGI>

=cut
Commit	Line	Data
3d1a2ec4	1	package CGI::Util;
	2
	3	use strict;
ac734d8b	4	use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
3d1a2ec4	5	require Exporter;
3d1a2ec4	6	@ISA = qw(Exporter);
2ed511ec	7	@EXPORT_OK = qw(rearrange make_attributes unescape escape
2ed511ec	8	expires ebcdic2ascii ascii2ebcdic);
3d1a2ec4	9
bb8b3399	10	$VERSION = '1.5';
3d1a2ec4	11
3d1a2ec4	12	$EBCDIC = "\t" ne "\011";
13548fdf	13	# (ord('^') == 95) for codepage 1047 as on os390, vmesa
13548fdf	14	@A2E = (
ac734d8b	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	);
13548fdf	32	@E2A = (
ac734d8b	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	);
13548fdf	50
13548fdf	51	if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
ac734d8b	52	$A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
	53	$A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
	54	$A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
	55	$A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
	56	$A2E[249] = 192;
13548fdf	57
ac734d8b	58	$E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
	59	$E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
	60	$E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
	61	$E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
	62	$E2A[255] = 126;
ac734d8b	63	}
13548fdf	64	elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
	65	$A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
	66	$A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
	67
	68	$E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
	69	$E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
3d1a2ec4	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) {
6b4ac661	90	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
3d1a2ec4	91	$i++;
	92	}
	93
	94	my (@result,%leftover);
	95	$#result = $#$order; # preextend
	96	while (@param) {
6b4ac661	97	my $key = lc(shift(@param));
3d1a2ec4	98	$key =~ s/^\-//;
	99	if (exists $pos{$key}) {
	100	$result[$pos{$key}] = shift(@param);
	101	} else {
	102	$leftover{$key} = shift(@param);
	103	}
	104	}
	105
29ddc2a4	106	push (@result,make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
3d1a2ec4	107	@result;
	108	}
	109
	110	sub make_attributes {
	111	my $attr = shift;
	112	return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
29ddc2a4	113	my $escape = shift \|\| 0;
3d1a2ec4	114	my(@att);
	115	foreach (keys %{$attr}) {
	116	my($key) = $_;
	117	$key=~s/^\-//; # get rid of initial - if present
69c89ae7	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
3d1a2ec4	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 {
6b4ac661	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;
3d1a2ec4	139	$toencode;
	140	}
	141
13548fdf	142	sub utf8_chr {
69c89ae7	143	my $c = shift(@_);
29ddc2a4	144	return chr($c) if $] >= 5.006;
69c89ae7	145
	146	if ($c < 0x80) {
	147	return sprintf("%c", $c);
	148	} elsif ($c < 0x800) {
	149	return sprintf("%c%c", 0xc0 \| ($c >> 6), 0x80 \| ($c & 0x3f));
	150	} elsif ($c < 0x10000) {
	151	return sprintf("%c%c%c",
	152	0xe0 \| ($c >> 12),
	153	0x80 \| (($c >> 6) & 0x3f),
	154	0x80 \| ( $c & 0x3f));
	155	} elsif ($c < 0x200000) {
	156	return sprintf("%c%c%c%c",
	157	0xf0 \| ($c >> 18),
	158	0x80 \| (($c >> 12) & 0x3f),
	159	0x80 \| (($c >> 6) & 0x3f),
	160	0x80 \| ( $c & 0x3f));
	161	} elsif ($c < 0x4000000) {
	162	return sprintf("%c%c%c%c%c",
	163	0xf8 \| ($c >> 24),
	164	0x80 \| (($c >> 18) & 0x3f),
	165	0x80 \| (($c >> 12) & 0x3f),
	166	0x80 \| (($c >> 6) & 0x3f),
	167	0x80 \| ( $c & 0x3f));
	168
	169	} elsif ($c < 0x80000000) {
	170	return sprintf("%c%c%c%c%c%c",
cff99809	171	0xfc \| ($c >> 30),
69c89ae7	172	0x80 \| (($c >> 24) & 0x3f),
	173	0x80 \| (($c >> 18) & 0x3f),
	174	0x80 \| (($c >> 12) & 0x3f),
	175	0x80 \| (($c >> 6) & 0x3f),
	176	0x80 \| ( $c & 0x3f));
	177	} else {
13548fdf	178	return utf8_chr(0xfffd);
69c89ae7	179	}
	180	}
	181
3d1a2ec4	182	# unescape URL-encoded data
3d1a2ec4	183	sub unescape {
29ddc2a4	184	shift() if @_ > 0 and (ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
3d1a2ec4	185	my $todecode = shift;
	186	return undef unless defined($todecode);
	187	$todecode =~ tr/+/ /; # pluses become spaces
ba056755	188	$EBCDIC = "\t" ne "\011";
3d1a2ec4	189	if ($EBCDIC) {
	190	$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
	191	} else {
69c89ae7	192	$todecode =~ s/%(?:([0-9a-fA-F]{2})\|u([0-9a-fA-F]{4}))/
69c89ae7	193	defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
3d1a2ec4	194	}
	195	return $todecode;
	196	}
	197
	198	# URL-encode data
	199	sub escape {
ac734d8b	200	shift() if @_ > 1 and ( ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
3d1a2ec4	201	my $toencode = shift;
3d1a2ec4	202	return undef unless defined($toencode);
031444c2	203	# force bytes while preserving backward compatibility -- dankogai
bb8b3399	204	# $toencode = eval { pack("C", unpack("U0C", $toencode))} \|\| pack("C", unpack("C", $toencode));
bb8b3399	205	$toencode = eval { pack("U", unpack("U0C", $toencode))} \|\| pack("C", unpack("C", $toencode));
92dffb52	206	if ($EBCDIC) {
8869a4b7	207	$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
92dffb52	208	} else {
8869a4b7	209	$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
92dffb52	210	}
3d1a2ec4	211	return $toencode;
	212	}
	213
	214	# This internal routine creates date strings suitable for use in
	215	# cookies and HTTP headers. (They differ, unfortunately.)
	216	# Thanks to Mark Fisher for this.
	217	sub expires {
	218	my($time,$format) = @_;
	219	$format \|\|= 'http';
	220
	221	my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
	222	my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
	223
	224	# pass through preformatted dates for the sake of expire_calc()
	225	$time = expire_calc($time);
	226	return $time unless $time =~ /^\d+$/;
	227
	228	# make HTTP/cookie date string from GMT'ed time
	229	# (cookies use '-' as date separator, HTTP uses ' ')
	230	my($sc) = ' ';
	231	$sc = '-' if $format eq "cookie";
	232	my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
	233	$year += 1900;
	234	return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
	235	$WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
	236	}
	237
	238	# This internal routine creates an expires time exactly some number of
	239	# hours from the current time. It incorporates modifications from
	240	# Mark Fisher.
	241	sub expire_calc {
	242	my($time) = @_;
	243	my(%mult) = ('s'=>1,
	244	'm'=>60,
	245	'h'=>60*60,
	246	'd'=>606024,
	247	'M'=>606024*30,
	248	'y'=>606024*365);
	249	# format for time can be in any of the forms...
	250	# "now" -- expire immediately
	251	# "+180s" -- in 180 seconds
	252	# "+2m" -- in 2 minutes
	253	# "+12h" -- in 12 hours
	254	# "+1d" -- in 1 day
	255	# "+3M" -- in 3 months
	256	# "+2y" -- in 2 years
	257	# "-3m" -- 3 minutes ago(!)
	258	# If you don't supply one of these forms, we assume you are
	259	# specifying the date yourself
	260	my($offset);
	261	if (!$time \|\| (lc($time) eq 'now')) {
8869a4b7	262	$offset = 0;
3d1a2ec4	263	} elsif ($time=~/^\d+/) {
8869a4b7	264	return $time;
	265	} elsif ($time=~/^([+-]?(?:\d+\|\d\.\d))([smhdMy])/) {
	266	$offset = ($mult{$2} \|\| 1)*$1;
3d1a2ec4	267	} else {
8869a4b7	268	return $time;
3d1a2ec4	269	}
	270	return (time+$offset);
	271	}
	272
2ed511ec	273	sub ebcdic2ascii {
	274	my $data = shift;
	275	$data =~ s/(.)/chr $E2A[ord($1)]/ge;
	276	$data;
	277	}
	278
	279	sub ascii2ebcdic {
	280	my $data = shift;
	281	$data =~ s/(.)/chr $A2E[ord($1)]/ge;
	282	$data;
	283	}
	284
3d1a2ec4	285	1;
ba056755	286
	287	__END__
	288
	289	=head1 NAME
	290
	291	CGI::Util - Internal utilities used by CGI module
	292
	293	=head1 SYNOPSIS
	294
	295	none
	296
	297	=head1 DESCRIPTION
	298
	299	no public subroutines
	300
	301	=head1 AUTHOR INFORMATION
	302
	303	Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
	304
	305	This library is free software; you can redistribute it and/or modify
	306	it under the same terms as Perl itself.
	307
	308	Address bug reports and comments to: lstein@cshl.org. When sending
	309	bug reports, please provide the version of CGI.pm, the version of
	310	Perl, the name and version of your Web server, and the name and
	311	version of the operating system you are using. If the problem is even
	312	remotely browser dependent, please provide information about the
	313	affected browers as well.
	314
	315	=head1 SEE ALSO
	316
	317	L<CGI>
	318
	319	=cut