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

package CGI::Util;

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

$VERSION = '1.1';

$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
	$key=~tr/A-Z_/a-z-/; # 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;
}

# unescape URL-encoded data
sub unescape {
  shift() if 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})/chr hex($1)/ge;
    }
  return $todecode;
}

# URL-encode data
sub escape {
  shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
  my $toencode = shift;
  return undef unless defined($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);
}

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;
92dffb52	4	use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E','@E2A';
3d1a2ec4	5	require Exporter;
	6	@ISA = qw(Exporter);
	7	@EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
	8
	9	$VERSION = '1.1';
	10
	11	$EBCDIC = "\t" ne "\011";
	12	if ($EBCDIC) {
92dffb52	13	# (ord('^') == 95) for codepage 1047 as on os390, vmesa
3d1a2ec4	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	);
92dffb52	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	}
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
6b4ac661	106	push (@result,make_attributes(\%leftover,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';
	113	my $escape = shift \|\| 0;
	114	my(@att);
	115	foreach (keys %{$attr}) {
	116	my($key) = $_;
	117	$key=~s/^\-//; # get rid of initial - if present
6b4ac661	118	$key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
3d1a2ec4	119	my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
	120	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
	121	}
	122	return @att;
	123	}
	124
	125	sub simple_escape {
6b4ac661	126	return unless defined(my $toencode = shift);
	127	$toencode =~ s{&}{&}gso;
	128	$toencode =~ s{<}{<}gso;
	129	$toencode =~ s{>}{>}gso;
	130	$toencode =~ s{\"}{"}gso;
	131	# Doesn't work. Can't work. forget it.
	132	# $toencode =~ s{\x8b}{}gso;
	133	# $toencode =~ s{\x9b}{}gso;
3d1a2ec4	134	$toencode;
	135	}
	136
	137	# unescape URL-encoded data
	138	sub unescape {
	139	shift() if ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass);
	140	my $todecode = shift;
	141	return undef unless defined($todecode);
	142	$todecode =~ tr/+/ /; # pluses become spaces
ba056755	143	$EBCDIC = "\t" ne "\011";
3d1a2ec4	144	if ($EBCDIC) {
	145	$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
	146	} else {
	147	$todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
	148	}
	149	return $todecode;
	150	}
	151
	152	# URL-encode data
	153	sub escape {
	154	shift() if ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass);
	155	my $toencode = shift;
	156	return undef unless defined($toencode);
92dffb52	157	if ($EBCDIC) {
	158	$toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
	159	} else {
	160	$toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
	161	}
3d1a2ec4	162	return $toencode;
	163	}
	164
	165	# This internal routine creates date strings suitable for use in
	166	# cookies and HTTP headers. (They differ, unfortunately.)
	167	# Thanks to Mark Fisher for this.
	168	sub expires {
	169	my($time,$format) = @_;
	170	$format \|\|= 'http';
	171
	172	my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
	173	my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
	174
	175	# pass through preformatted dates for the sake of expire_calc()
	176	$time = expire_calc($time);
	177	return $time unless $time =~ /^\d+$/;
	178
	179	# make HTTP/cookie date string from GMT'ed time
	180	# (cookies use '-' as date separator, HTTP uses ' ')
	181	my($sc) = ' ';
	182	$sc = '-' if $format eq "cookie";
	183	my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
	184	$year += 1900;
	185	return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
	186	$WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
	187	}
	188
	189	# This internal routine creates an expires time exactly some number of
	190	# hours from the current time. It incorporates modifications from
	191	# Mark Fisher.
	192	sub expire_calc {
	193	my($time) = @_;
	194	my(%mult) = ('s'=>1,
	195	'm'=>60,
	196	'h'=>60*60,
	197	'd'=>606024,
	198	'M'=>606024*30,
	199	'y'=>606024*365);
	200	# format for time can be in any of the forms...
	201	# "now" -- expire immediately
	202	# "+180s" -- in 180 seconds
	203	# "+2m" -- in 2 minutes
	204	# "+12h" -- in 12 hours
	205	# "+1d" -- in 1 day
	206	# "+3M" -- in 3 months
	207	# "+2y" -- in 2 years
	208	# "-3m" -- 3 minutes ago(!)
	209	# If you don't supply one of these forms, we assume you are
	210	# specifying the date yourself
	211	my($offset);
	212	if (!$time \|\| (lc($time) eq 'now')) {
	213	$offset = 0;
	214	} elsif ($time=~/^\d+/) {
	215	return $time;
	216	} elsif ($time=~/^([+-]?(?:\d+\|\d\.\d))([mhdMy]?)/) {
	217	$offset = ($mult{$2} \|\| 1)*$1;
	218	} else {
	219	return $time;
	220	}
	221	return (time+$offset);
	222	}
	223
	224	1;
ba056755	225
	226	__END__
	227
	228	=head1 NAME
	229
	230	CGI::Util - Internal utilities used by CGI module
	231
	232	=head1 SYNOPSIS
	233
	234	none
	235
	236	=head1 DESCRIPTION
	237
	238	no public subroutines
	239
	240	=head1 AUTHOR INFORMATION
	241
	242	Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
	243
	244	This library is free software; you can redistribute it and/or modify
	245	it under the same terms as Perl itself.
	246
	247	Address bug reports and comments to: lstein@cshl.org. When sending
	248	bug reports, please provide the version of CGI.pm, the version of
	249	Perl, the name and version of your Web server, and the name and
	250	version of the operating system you are using. If the problem is even
	251	remotely browser dependent, please provide information about the
	252	affected browers as well.
	253
	254	=head1 SEE ALSO
	255
	256	L<CGI>
	257
	258	=cut