view release on metacpan or  search on metacpan

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

        }
        return undef;
    }

    # added for v0.07
    sub _getHttpHeader {
        my $self = shift;
        my $header = shift;
        if ($self->_isModPerl) {
            my $r = $self->_getApacheRequest;
            if ($r) {
                return $r->headers_in()->{$header};
            }
        } elsif ($self->_isCgi) {
            $header =~ s/-/_/g;
            return $ENV{'HTTP_' . uc($header)};
        }
        return undef;
    }

=pod

=head2 urlEncode($str)

Returns the fully URL-encoded version of the given string.  It
does not convert space characters to '+' characters.

Aliases: url_encode()

=cut
BEGIN {
    if ($] >= 5.006) {
        eval q{
    sub urlEncode {
        my ($self, $str) = @_;
                
        use bytes;
        $str =~ s{([^A-Za-z0-9_])}{sprintf("%%%02x", ord($1))}eg;
        return $str;
    }
    *url_encode = \&urlEncode;
};
    } else {
        eval q{
    sub urlEncode {
        my ($self, $str) = @_;

        $str =~ s{([^A-Za-z0-9_])}{sprintf("%%%02x", ord($1))}eg;
        return $str;
    }
    *url_encode = \&urlEncode;
};
    }
}

=pod

=head2 urlUnicodeEncode($str)

Returns the fully URL-encoded version of the given string as
unicode characters.  It does not convert space characters to '+'
characters.

Aliases: url_unicode_encode()

=cut
    sub urlUnicodeEncode {
        my ($self, $str) = @_;
        $str =~ s{([^A-Za-z0-9_])}{sprintf("%%u%04x", ord($1))}eg;
        return $str;
    }
    *url_unicode_encode = \&urlUnicodeEncode;

=pod

=head2 urlDecode($url_encoded_str)

Returns the decoded version of the given URL-encoded string.

Aliases: url_decode()

=cut
    sub urlDecode {
        my ($self, $str) = @_;
        $str =~ tr/+/ /;
        $str =~ s|%([A-Fa-f0-9]{2})|chr(hex($1))|eg;
        return $str;
    }
    *url_decode = \&urlDecode;

=pod

=head2 urlUnicodeDecode($url_encoded_str)

Returns the decoded version of the given URL-encoded string,
with unicode support.

Aliases: url_unicode_decode()

=cut
    sub urlUnicodeDecode {
        my ($self, $str) = @_;
        $str =~ tr/+/ /;
        $str =~ s|%([A-Fa-f0-9]{2})|chr(hex($1))|eg;
        $str =~ s|%u([A-Fa-f0-9]{2,4})|chr(hex($1))|eg;
        return $str;
    }
    *url_unicode_decode = \&urlUnicodeDecode;

=pod

=head2 urlEncodeVars($var_hash, $sep)

Takes a hash of name/value pairs and returns a fully URL-encoded
query string suitable for passing in a URL.  By default, uses
the newer separator, a semicolon, as recommended by the W3C.  If
you pass in a second argument, it is used as the separator
between key/value pairs.

Aliases: url_encode_vars()

=cut
    sub urlEncodeVars {
        my ($self, $var_hash, $sep) = @_;
        $sep = ';' unless defined $sep;
        my @pairs;
        foreach my $key (sort keys %$var_hash) {
            my $val = $$var_hash{$key};
            my $ref = ref($val);
            if ($ref eq 'ARRAY' or $ref =~ /=ARRAY/) {
                push @pairs, map { $self->urlEncode($key) . "=" . $self->urlEncode($_) } @$val;
            } else {
                push @pairs, $self->urlEncode($key) . "=" . $self->urlEncode($val);
            }
        }

        return join($sep, @pairs);
    }
    *url_encode_vars = \&urlEncodeVars;

=pod

=head2 urlDecodeVars($query_string)

Takes a URL-encoded query string, decodes it, and returns a
reference to a hash of name/value pairs.  For multivalued
fields, the value is an array of values.  If called in array
context, it returns a reference to a hash of name/value pairs,
and a reference to an array of field names in the order they
appear in the query string.

Aliases: url_decode_vars()

=cut
    sub urlDecodeVars {
        my ($self, $query) = @_;
        my $var_hash = {};
        my @pairs = split /[;&]/, $query;
        my $var_order = [];
        
        foreach my $pair (@pairs) {
            my ($name, $value) = map { $self->urlDecode($_) } split /=/, $pair, 2;
            if (exists($$var_hash{$name})) {
                my $this_val = $$var_hash{$name};
                if (ref($this_val) eq 'ARRAY') {
                    push @$this_val, $value;
                } else {
                    $$var_hash{$name} = [ $this_val, $value ];