[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

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