[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.4';

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