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,defined $CGI::Q ? $CGI::Q->{escape} : 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(@_);
        return chr($c) if $] >= 5.006;

        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 @_ > 0 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
Revision:	1.1
Committed:	Thu Jun 30 14:27:09 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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
8			expires ebcdic2ascii ascii2ebcdic);
9
10			$VERSION = '1.5';
11
12			$EBCDIC = "\t" ne "\011";
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
51			if ($EBCDIC && 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 ($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;
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,defined $CGI::Q ? $CGI::Q->{escape} : 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			return chr($c) if $] >= 5.006;
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",
171			0xfc \| ($c >> 30),
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_chr(0xfffd);
179			}
180			}
181
182			# unescape URL-encoded data
183			sub unescape {
184			shift() if @_ > 0 and (ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
185			my $todecode = shift;
186			return undef unless defined($todecode);
187			$todecode =~ tr/+/ /; # pluses become spaces
188			$EBCDIC = "\t" ne "\011";
189			if ($EBCDIC) {
190			$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
191			} else {
192			$todecode =~ s/%(?:([0-9a-fA-F]{2})\|u([0-9a-fA-F]{4}))/
193			defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
194			}
195			return $todecode;
196			}
197
198			# URL-encode data
199			sub escape {
200			shift() if @_ > 1 and ( ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
201			my $toencode = shift;
202			return undef unless defined($toencode);
203			# force bytes while preserving backward compatibility -- dankogai
204			$toencode = pack("C", unpack("C", $toencode));
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			}
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
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
284			1;
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