[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / 5.8.0 / 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);

$VERSION = '1.3';

$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 @_ > 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);
    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
86530b38 AT	1	package CGI::Util;
	2
	3	use strict;
	4	use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
	5	require Exporter;
	6	@ISA = qw(Exporter);
	7	@EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
	8
	9	$VERSION = '1.3';
	10
	11	$EBCDIC = "\t" ne "\011";
	12	if ($EBCDIC) {
	13	# (ord('^') == 95) for codepage 1047 as on os390, vmesa
	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	);
	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	}
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) {
90	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
91	$i++;
92	}
93
94	my (@result,%leftover);
95	$#result = $#$order; # preextend
96	while (@param) {
97	my $key = lc(shift(@param));
98	$key =~ s/^\-//;
99	if (exists $pos{$key}) {
100	$result[$pos{$key}] = shift(@param);
101	} else {
102	$leftover{$key} = shift(@param);
103	}
104	}
105
106	push (@result,make_attributes(\%leftover,1)) if %leftover;
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
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
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 {
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;
139	$toencode;
140	}
141
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
181	# unescape URL-encoded data
182	sub unescape {
183	shift() if @_ > 1 and (ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
184	my $todecode = shift;
185	return undef unless defined($todecode);
186	$todecode =~ tr/+/ /; # pluses become spaces
187	$EBCDIC = "\t" ne "\011";
188	if ($EBCDIC) {
189	$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
190	} else {
191	$todecode =~ s/%(?:([0-9a-fA-F]{2})\|u([0-9a-fA-F]{4}))/
192	defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
193	}
194	return $todecode;
195	}
196
197	# URL-encode data
198	sub escape {
199	shift() if @_ > 1 and ( ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
200	my $toencode = shift;
201	return undef unless defined($toencode);
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	}
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;
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