[p5sagit/p5-mst-13.2.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 rearrange_header make_attributes unescape escape 
		expires ebcdic2ascii ascii2ebcdic);

$VERSION = '1.5_01';

$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 rearrangement if:
# the first parameter begins with a -

sub rearrange {
    my ($order,@param) = @_;
    my ($result, $leftover) = _rearrange_params( $order, @param );
    push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 ) 
	if keys %$leftover;
    @$result;
}

sub rearrange_header {
    my ($order,@param) = @_;

    my ($result,$leftover) = _rearrange_params( $order, @param );
    push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;

    @$result;
}

sub _rearrange_params {
    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);
	}
    }

    return \@result, \%leftover;
}

sub make_attributes {
    my $attr = shift;
    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
    my $escape =  shift || 0;
    my $do_not_quote = shift;

    my $quote = $do_not_quote ? '' : '"';

    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=$quote$value$quote/ : 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 ($] >= 5.006){
	    require utf8;
	    my $u = chr($c);
	    utf8::encode($u); # drop utf8 flag
	    return $u;
	}
        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
    if ($EBCDIC) {
      $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
    } else {
	# handle surrogate pairs first -- dankogai
	$todecode =~ s{
			%u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
		        %u([Dd][c-fC-F][0-9a-fA-F]{2})   # lo
		      }{
			  utf8_chr(
				   0x10000 
				   + (hex($1) - 0xD800) * 0x400 
				   + (hex($2) - 0xDC00)
				  )
		      }gex;
      $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
#
# We cannot use the %u escapes, they were rejected by W3C, so the official
# way is %XX-escaped utf-8 encoding.
# Naturally, Unicode strings have to be converted to their utf-8 byte
# representation.  (No action is required on 5.6.)
# Byte strings were traditionally used directly as a sequence of octets.
# This worked if they actually represented binary data (i.e. in CGI::Compress).
# This also worked if these byte strings were actually utf-8 encoded; e.g.,
# when the source file used utf-8 without the apropriate "use utf8;".
# This fails if the byte string is actually a Latin 1 encoded string, but it
# was always so and cannot be fixed without breaking the binary data case.
# -- Stepan Kasal <skasal@redhat.com>
#
sub escape {
  shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  my $toencode = shift;
  return undef unless defined($toencode);
  utf8::encode($toencode) if ($] > 5.007 && utf8::is_utf8($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*))([smhdMy])/) {
      $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	1	package CGI::Util;
	2
	3	use strict;
ac734d8b	4	use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
3d1a2ec4	5	require Exporter;
3d1a2ec4	6	@ISA = qw(Exporter);
f8a128a9	7	@EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
2ed511ec	8	expires ebcdic2ascii ascii2ebcdic);
3d1a2ec4	9
8c32f149	10	$VERSION = '1.5_01';
3d1a2ec4	11
3d1a2ec4	12	$EBCDIC = "\t" ne "\011";
13548fdf	13	# (ord('^') == 95) for codepage 1047 as on os390, vmesa
13548fdf	14	@A2E = (
ac734d8b	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	);
13548fdf	32	@E2A = (
ac734d8b	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	);
13548fdf	50
13548fdf	51	if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
ac734d8b	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;
13548fdf	57
ac734d8b	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;
ac734d8b	63	}
13548fdf	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;
3d1a2ec4	70	}
	71
	72	# Smart rearrangement of parameters to allow named parameter
f8a128a9	73	# calling. We do the rearrangement if:
3d1a2ec4	74	# the first parameter begins with a -
f8a128a9	75
3d1a2ec4	76	sub rearrange {
f8a128a9	77	my ($order,@param) = @_;
	78	my ($result, $leftover) = _rearrange_params( $order, @param );
	79	push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
	80	if keys %$leftover;
	81	@$result;
	82	}
	83
	84	sub rearrange_header {
	85	my ($order,@param) = @_;
	86
	87	my ($result,$leftover) = _rearrange_params( $order, @param );
	88	push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
	89
	90	@$result;
	91	}
	92
	93	sub _rearrange_params {
3d1a2ec4	94	my($order,@param) = @_;
f8a128a9	95	return [] unless @param;
3d1a2ec4	96
	97	if (ref($param[0]) eq 'HASH') {
	98	@param = %{$param[0]};
	99	} else {
f8a128a9	100	return \@param
3d1a2ec4	101	unless (defined($param[0]) && substr($param[0],0,1) eq '-');
	102	}
	103
	104	# map parameters into positional indices
	105	my ($i,%pos);
	106	$i = 0;
	107	foreach (@$order) {
6b4ac661	108	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
3d1a2ec4	109	$i++;
	110	}
	111
	112	my (@result,%leftover);
	113	$#result = $#$order; # preextend
	114	while (@param) {
6b4ac661	115	my $key = lc(shift(@param));
3d1a2ec4	116	$key =~ s/^\-//;
	117	if (exists $pos{$key}) {
	118	$result[$pos{$key}] = shift(@param);
	119	} else {
	120	$leftover{$key} = shift(@param);
	121	}
	122	}
	123
f8a128a9	124	return \@result, \%leftover;
3d1a2ec4	125	}
	126
	127	sub make_attributes {
	128	my $attr = shift;
	129	return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
29ddc2a4	130	my $escape = shift \|\| 0;
f8a128a9	131	my $do_not_quote = shift;
	132
	133	my $quote = $do_not_quote ? '' : '"';
	134
3d1a2ec4	135	my(@att);
	136	foreach (keys %{$attr}) {
	137	my($key) = $_;
	138	$key=~s/^\-//; # get rid of initial - if present
69c89ae7	139
	140	# old way: breaks EBCDIC!
	141	# $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
	142
	143	($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
	144
3d1a2ec4	145	my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
f8a128a9	146	push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
3d1a2ec4	147	}
	148	return @att;
	149	}
	150
	151	sub simple_escape {
6b4ac661	152	return unless defined(my $toencode = shift);
	153	$toencode =~ s{&}{&}gso;
	154	$toencode =~ s{<}{<}gso;
	155	$toencode =~ s{>}{>}gso;
	156	$toencode =~ s{\"}{"}gso;
	157	# Doesn't work. Can't work. forget it.
	158	# $toencode =~ s{\x8b}{}gso;
	159	# $toencode =~ s{\x9b}{}gso;
3d1a2ec4	160	$toencode;
	161	}
	162
13548fdf	163	sub utf8_chr {
69c89ae7	164	my $c = shift(@_);
8c32f149	165	if ($] >= 5.006){
	166	require utf8;
	167	my $u = chr($c);
	168	utf8::encode($u); # drop utf8 flag
	169	return $u;
	170	}
69c89ae7	171	if ($c < 0x80) {
	172	return sprintf("%c", $c);
	173	} elsif ($c < 0x800) {
	174	return sprintf("%c%c", 0xc0 \| ($c >> 6), 0x80 \| ($c & 0x3f));
	175	} elsif ($c < 0x10000) {
	176	return sprintf("%c%c%c",
	177	0xe0 \| ($c >> 12),
	178	0x80 \| (($c >> 6) & 0x3f),
	179	0x80 \| ( $c & 0x3f));
	180	} elsif ($c < 0x200000) {
	181	return sprintf("%c%c%c%c",
	182	0xf0 \| ($c >> 18),
	183	0x80 \| (($c >> 12) & 0x3f),
	184	0x80 \| (($c >> 6) & 0x3f),
	185	0x80 \| ( $c & 0x3f));
	186	} elsif ($c < 0x4000000) {
	187	return sprintf("%c%c%c%c%c",
	188	0xf8 \| ($c >> 24),
	189	0x80 \| (($c >> 18) & 0x3f),
	190	0x80 \| (($c >> 12) & 0x3f),
	191	0x80 \| (($c >> 6) & 0x3f),
	192	0x80 \| ( $c & 0x3f));
	193
	194	} elsif ($c < 0x80000000) {
	195	return sprintf("%c%c%c%c%c%c",
cff99809	196	0xfc \| ($c >> 30),
69c89ae7	197	0x80 \| (($c >> 24) & 0x3f),
	198	0x80 \| (($c >> 18) & 0x3f),
	199	0x80 \| (($c >> 12) & 0x3f),
	200	0x80 \| (($c >> 6) & 0x3f),
	201	0x80 \| ( $c & 0x3f));
	202	} else {
13548fdf	203	return utf8_chr(0xfffd);
69c89ae7	204	}
	205	}
	206
3d1a2ec4	207	# unescape URL-encoded data
3d1a2ec4	208	sub unescape {
29ddc2a4	209	shift() if @_ > 0 and (ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
3d1a2ec4	210	my $todecode = shift;
	211	return undef unless defined($todecode);
	212	$todecode =~ tr/+/ /; # pluses become spaces
	213	if ($EBCDIC) {
	214	$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
	215	} else {
8c32f149	216	# handle surrogate pairs first -- dankogai
	217	$todecode =~ s{
	218	%u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
	219	%u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
	220	}{
	221	utf8_chr(
	222	0x10000
	223	+ (hex($1) - 0xD800) * 0x400
	224	+ (hex($2) - 0xDC00)
	225	)
	226	}gex;
69c89ae7	227	$todecode =~ s/%(?:([0-9a-fA-F]{2})\|u([0-9a-fA-F]{4}))/
69c89ae7	228	defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
3d1a2ec4	229	}
	230	return $todecode;
	231	}
	232
	233	# URL-encode data
ad6402bd	234	#
	235	# We cannot use the %u escapes, they were rejected by W3C, so the official
	236	# way is %XX-escaped utf-8 encoding.
	237	# Naturally, Unicode strings have to be converted to their utf-8 byte
	238	# representation. (No action is required on 5.6.)
	239	# Byte strings were traditionally used directly as a sequence of octets.
	240	# This worked if they actually represented binary data (i.e. in CGI::Compress).
	241	# This also worked if these byte strings were actually utf-8 encoded; e.g.,
	242	# when the source file used utf-8 without the apropriate "use utf8;".
	243	# This fails if the byte string is actually a Latin 1 encoded string, but it
	244	# was always so and cannot be fixed without breaking the binary data case.
	245	# -- Stepan Kasal <skasal@redhat.com>
	246	#
3d1a2ec4	247	sub escape {
ac734d8b	248	shift() if @_ > 1 and ( ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
3d1a2ec4	249	my $toencode = shift;
3d1a2ec4	250	return undef unless defined($toencode);
ad6402bd	251	utf8::encode($toencode) if ($] > 5.007 && utf8::is_utf8($toencode));
92dffb52	252	if ($EBCDIC) {
8869a4b7	253	$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
92dffb52	254	} else {
8869a4b7	255	$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
92dffb52	256	}
3d1a2ec4	257	return $toencode;
	258	}
	259
	260	# This internal routine creates date strings suitable for use in
	261	# cookies and HTTP headers. (They differ, unfortunately.)
	262	# Thanks to Mark Fisher for this.
	263	sub expires {
	264	my($time,$format) = @_;
	265	$format \|\|= 'http';
	266
	267	my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
	268	my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
	269
	270	# pass through preformatted dates for the sake of expire_calc()
	271	$time = expire_calc($time);
	272	return $time unless $time =~ /^\d+$/;
	273
	274	# make HTTP/cookie date string from GMT'ed time
	275	# (cookies use '-' as date separator, HTTP uses ' ')
	276	my($sc) = ' ';
	277	$sc = '-' if $format eq "cookie";
	278	my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
	279	$year += 1900;
	280	return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
	281	$WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
	282	}
	283
	284	# This internal routine creates an expires time exactly some number of
	285	# hours from the current time. It incorporates modifications from
	286	# Mark Fisher.
	287	sub expire_calc {
	288	my($time) = @_;
	289	my(%mult) = ('s'=>1,
	290	'm'=>60,
	291	'h'=>60*60,
	292	'd'=>606024,
	293	'M'=>606024*30,
	294	'y'=>606024*365);
	295	# format for time can be in any of the forms...
	296	# "now" -- expire immediately
	297	# "+180s" -- in 180 seconds
	298	# "+2m" -- in 2 minutes
	299	# "+12h" -- in 12 hours
	300	# "+1d" -- in 1 day
	301	# "+3M" -- in 3 months
	302	# "+2y" -- in 2 years
	303	# "-3m" -- 3 minutes ago(!)
	304	# If you don't supply one of these forms, we assume you are
	305	# specifying the date yourself
	306	my($offset);
	307	if (!$time \|\| (lc($time) eq 'now')) {
8869a4b7	308	$offset = 0;
3d1a2ec4	309	} elsif ($time=~/^\d+/) {
8869a4b7	310	return $time;
	311	} elsif ($time=~/^([+-]?(?:\d+\|\d\.\d))([smhdMy])/) {
	312	$offset = ($mult{$2} \|\| 1)*$1;
3d1a2ec4	313	} else {
8869a4b7	314	return $time;
3d1a2ec4	315	}
	316	return (time+$offset);
	317	}
	318
2ed511ec	319	sub ebcdic2ascii {
	320	my $data = shift;
	321	$data =~ s/(.)/chr $E2A[ord($1)]/ge;
	322	$data;
	323	}
	324
	325	sub ascii2ebcdic {
	326	my $data = shift;
	327	$data =~ s/(.)/chr $A2E[ord($1)]/ge;
	328	$data;
	329	}
	330
3d1a2ec4	331	1;
ba056755	332
	333	__END__
	334
	335	=head1 NAME
	336
	337	CGI::Util - Internal utilities used by CGI module
	338
	339	=head1 SYNOPSIS
	340
	341	none
	342
	343	=head1 DESCRIPTION
	344
	345	no public subroutines
	346
	347	=head1 AUTHOR INFORMATION
	348
	349	Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
	350
	351	This library is free software; you can redistribute it and/or modify
	352	it under the same terms as Perl itself.
	353
	354	Address bug reports and comments to: lstein@cshl.org. When sending
	355	bug reports, please provide the version of CGI.pm, the version of
	356	Perl, the name and version of your Web server, and the name and
	357	version of the operating system you are using. If the problem is even
	358	remotely browser dependent, please provide information about the
	359	affected browers as well.
	360
	361	=head1 SEE ALSO
	362
	363	L<CGI>
	364
	365	=cut