[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
    $EBCDIC = "\t" ne "\011";
    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
sub escape {
  shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  my $toencode = shift;
  return undef unless defined($toencode);
  $toencode = eval { pack("C*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode));

  # force bytes while preserving backward compatibility -- dankogai
  # but commented out because it was breaking CGI::Compress -- lstein
  # $toencode = eval { pack("U*", unpack("U0C*", $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*))([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
ba056755	213	$EBCDIC = "\t" ne "\011";
3d1a2ec4	214	if ($EBCDIC) {
	215	$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
	216	} else {
8c32f149	217	# handle surrogate pairs first -- dankogai
	218	$todecode =~ s{
	219	%u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
	220	%u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
	221	}{
	222	utf8_chr(
	223	0x10000
	224	+ (hex($1) - 0xD800) * 0x400
	225	+ (hex($2) - 0xDC00)
	226	)
	227	}gex;
69c89ae7	228	$todecode =~ s/%(?:([0-9a-fA-F]{2})\|u([0-9a-fA-F]{4}))/
69c89ae7	229	defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
3d1a2ec4	230	}
	231	return $todecode;
	232	}
	233
	234	# URL-encode data
	235	sub escape {
ac734d8b	236	shift() if @_ > 1 and ( ref($_[0]) \|\| (defined $_[1] && $_[0] eq $CGI::DefaultClass));
3d1a2ec4	237	my $toencode = shift;
3d1a2ec4	238	return undef unless defined($toencode);
8c32f149	239	$toencode = eval { pack("C", unpack("U0C", $toencode))} \|\| pack("C", unpack("C", $toencode));
8c32f149	240
031444c2	241	# force bytes while preserving backward compatibility -- dankogai
8c32f149	242	# but commented out because it was breaking CGI::Compress -- lstein
	243	# $toencode = eval { pack("U", unpack("U0C", $toencode))} \|\| pack("C", unpack("C", $toencode));
	244
92dffb52	245	if ($EBCDIC) {
8869a4b7	246	$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
92dffb52	247	} else {
8869a4b7	248	$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
92dffb52	249	}
3d1a2ec4	250	return $toencode;
	251	}
	252
	253	# This internal routine creates date strings suitable for use in
	254	# cookies and HTTP headers. (They differ, unfortunately.)
	255	# Thanks to Mark Fisher for this.
	256	sub expires {
	257	my($time,$format) = @_;
	258	$format \|\|= 'http';
	259
	260	my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
	261	my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
	262
	263	# pass through preformatted dates for the sake of expire_calc()
	264	$time = expire_calc($time);
	265	return $time unless $time =~ /^\d+$/;
	266
	267	# make HTTP/cookie date string from GMT'ed time
	268	# (cookies use '-' as date separator, HTTP uses ' ')
	269	my($sc) = ' ';
	270	$sc = '-' if $format eq "cookie";
	271	my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
	272	$year += 1900;
	273	return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
	274	$WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
	275	}
	276
	277	# This internal routine creates an expires time exactly some number of
	278	# hours from the current time. It incorporates modifications from
	279	# Mark Fisher.
	280	sub expire_calc {
	281	my($time) = @_;
	282	my(%mult) = ('s'=>1,
	283	'm'=>60,
	284	'h'=>60*60,
	285	'd'=>606024,
	286	'M'=>606024*30,
	287	'y'=>606024*365);
	288	# format for time can be in any of the forms...
	289	# "now" -- expire immediately
	290	# "+180s" -- in 180 seconds
	291	# "+2m" -- in 2 minutes
	292	# "+12h" -- in 12 hours
	293	# "+1d" -- in 1 day
	294	# "+3M" -- in 3 months
	295	# "+2y" -- in 2 years
	296	# "-3m" -- 3 minutes ago(!)
	297	# If you don't supply one of these forms, we assume you are
	298	# specifying the date yourself
	299	my($offset);
	300	if (!$time \|\| (lc($time) eq 'now')) {
8869a4b7	301	$offset = 0;
3d1a2ec4	302	} elsif ($time=~/^\d+/) {
8869a4b7	303	return $time;
	304	} elsif ($time=~/^([+-]?(?:\d+\|\d\.\d))([smhdMy])/) {
	305	$offset = ($mult{$2} \|\| 1)*$1;
3d1a2ec4	306	} else {
8869a4b7	307	return $time;
3d1a2ec4	308	}
	309	return (time+$offset);
	310	}
	311
2ed511ec	312	sub ebcdic2ascii {
	313	my $data = shift;
	314	$data =~ s/(.)/chr $E2A[ord($1)]/ge;
	315	$data;
	316	}
	317
	318	sub ascii2ebcdic {
	319	my $data = shift;
	320	$data =~ s/(.)/chr $A2E[ord($1)]/ge;
	321	$data;
	322	}
	323
3d1a2ec4	324	1;
ba056755	325
	326	__END__
	327
	328	=head1 NAME
	329
	330	CGI::Util - Internal utilities used by CGI module
	331
	332	=head1 SYNOPSIS
	333
	334	none
	335
	336	=head1 DESCRIPTION
	337
	338	no public subroutines
	339
	340	=head1 AUTHOR INFORMATION
	341
	342	Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
	343
	344	This library is free software; you can redistribute it and/or modify
	345	it under the same terms as Perl itself.
	346
	347	Address bug reports and comments to: lstein@cshl.org. When sending
	348	bug reports, please provide the version of CGI.pm, the version of
	349	Perl, the name and version of your Web server, and the name and
	350	version of the operating system you are using. If the problem is even
	351	remotely browser dependent, please provide information about the
	352	affected browers as well.
	353
	354	=head1 SEE ALSO
	355
	356	L<CGI>
	357
	358	=cut