[perl5.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,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(@_);

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