view release on metacpan or  search on metacpan

lib/CGI/Util.pm  view on Meta::CPAN

        $leftover{$key} = $params_as_hash{$k};
    }
    }

    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 @attr_keys= sort keys %$attr;
    my(@att);
    foreach (@attr_keys) {
    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 sort @att;
}

sub simple_escape {
  return unless defined(my $toencode = shift);
  $toencode =~ s{&}{&}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(@_);
    my $u = chr($c);
    utf8::encode($u); # drop utf8 flag
    return $u;
}

# 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. Ref: http://unicode.org/faq/utf_bom.html#utf16-2
    $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. 
# 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 appropriate "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 {
  # If we being called in an OO-context, discard the first argument.
  shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  my $toencode = shift;
  return undef unless defined($toencode);
  utf8::encode($toencode) if 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 = shift;

    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+$/;

    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
    $year += 1900;