Beta Shell v2.0

File Manager

Name	Size	Perms	Modified	Actions
[ .. / .. ]
Encode.pm	8.25 KB	-rw-r--r--	2019-11-11 14:33:29	Edit Del
Find	-	drwxr-xr-x	2022-02-23 11:31:18	Del
Find.pm	14.18 KB	-rw-r--r--	2019-08-02 21:19:31	Edit Del
FromHash.pm	5.66 KB	-rw-r--r--	2015-10-17 20:32:46	Edit Del
cpan	-	drwxr-xr-x	2022-02-23 11:31:15	Del
cpan.pm	3.52 KB	-rw-r--r--	2015-04-17 09:22:07	Edit Del
Editing: Encode.pm (8.25 KB)

package URI::Encode;

#######################
# LOAD MODULES
#######################
use strict;
use warnings FATAL => 'all';

use 5.008001;
use Encode qw();
use Carp qw(croak carp);

#######################
# VERSION
#######################
our $VERSION = '1.1.1';

#######################
# EXPORT
#######################
use base qw(Exporter);
our (@EXPORT_OK);

@EXPORT_OK = qw(uri_encode uri_decode);

#######################
# SETTINGS
#######################

# Reserved characters
my $reserved_re
  = qr{([^a-zA-Z0-9\-\_\.\~\!\*\'\(\)\;\:\@\&\=\+\$\,\/\?\#\[\]\%])}x;

# Un-reserved characters
my $unreserved_re = qr{([^a-zA-Z0-9\Q-_.~\E\%])}x;

# Encoded character set
my $encoded_chars = qr{%([a-fA-F0-9]{2})}x;

#######################
# CONSTRUCTOR
#######################
sub new {
    my ( $class, @in ) = @_;

    # Check Input
    my $defaults = {

        #   this module, unlike URI::Escape,
        #   does not encode reserved characters
        encode_reserved => 0,

        #   Allow Double encoding?
        #   defaults to YES
        double_encode => 1,
    };

    my $input = {};
    if   ( ref $in[0] eq 'HASH' ) { $input = $in[0]; }
    else                          { $input = {@in}; }

    # Set options
    my $options = {

        # Defaults
        %{$defaults},

        # Input
        %{$input},

        # Encoding Map
        enc_map =>
          { ( map { chr($_) => sprintf( "%%%02X", $_ ) } ( 0 ... 255 ) ) },

        # Decoding Map
        dec_map =>
          { ( map { sprintf( "%02X", $_ ) => chr($_) } ( 0 ... 255 ) ), },
    };

    # Return
    my $self = bless $options, $class;
  return $self;
} ## end sub new

#######################
# ENCODE
#######################
sub encode {
    my ( $self, $data, $options ) = @_;

    # Check for data
    # Allow to be '0'
  return unless defined $data;

    my $enc_res       = $self->{encode_reserved};
    my $double_encode = $self->{double_encode};

    if ( defined $options ) {
        if ( ref $options eq 'HASH' ) {
            $enc_res = $options->{encode_reserved}
              if exists $options->{encode_reserved};
            $double_encode = $options->{double_encode}
              if exists $options->{double_encode};
        } ## end if ( ref $options eq 'HASH')
        else {
            $enc_res = $options;
        }
    } ## end if ( defined $options )

    # UTF-8 encode
    $data = Encode::encode( 'utf-8-strict', $data );

    # Encode a literal '%'
    if ($double_encode) { $data =~ s{(\%)}{$self->_get_encoded_char($1)}gex; }
    else { $data =~ s{(\%)(.*)}{$self->_encode_literal_percent($1, $2)}gex; }

    # Percent Encode
    if ($enc_res) {
        $data =~ s{$unreserved_re}{$self->_get_encoded_char($1)}gex;
    }
    else {
        $data =~ s{$reserved_re}{$self->_get_encoded_char($1)}gex;
    }

    # Done
  return $data;
} ## end sub encode

#######################
# DECODE
#######################
sub decode {
    my ( $self, $data ) = @_;

    # Check for data
    # Allow to be '0'
  return unless defined $data;

    # Percent Decode
    $data =~ s{$encoded_chars}{ $self->_get_decoded_char($1) }gex;

  return $data;
} ## end sub decode

#######################
# EXPORTED FUNCTIONS
#######################

# Encoder
sub uri_encode { return __PACKAGE__->new()->encode(@_); }

# Decoder
sub uri_decode { return __PACKAGE__->new()->decode(@_); }

#######################
# INTERNAL
#######################


sub _get_encoded_char {
    my ( $self, $char ) = @_;
  return $self->{enc_map}->{$char} if exists $self->{enc_map}->{$char};
  return $char;
} ## end sub _get_encoded_char


sub _encode_literal_percent {
    my ( $self, $char, $post ) = @_;

  return $self->_get_encoded_char($char) if not defined $post;

    my $return_char;
    if ( $post =~ m{^([a-fA-F0-9]{2})}x ) {
        if ( exists $self->{dec_map}->{$1} ) {
            $return_char = join( '', $char, $post );
        }
    } ## end if ( $post =~ m{^([a-fA-F0-9]{2})}x)

    $return_char ||= join( '', $self->_get_encoded_char($char), $post );
  return $return_char;
} ## end sub _encode_literal_percent


sub _get_decoded_char {
    my ( $self, $char ) = @_;
  return $self->{dec_map}->{ uc($char) }
      if exists $self->{dec_map}->{ uc($char) };
  return $char;
} ## end sub _get_decoded_char

#######################
1;

__END__

#######################
# POD SECTION
#######################
=pod

=head1 NAME

URI::Encode - Simple percent Encoding/Decoding

=for html <a href="https://travis-ci.org/mithun/perl-uri-encode"><img src="https://travis-ci.org/mithun/perl-uri-encode.svg?branch=master"></a>

=head1 SYNOPSIS

    # OOP Interface
    use URI::Encode;
    my $uri     = URI::Encode->new( { encode_reserved => 0 } );
    my $encoded = $uri->encode($data);
    my $decoded = $uri->decode($encoded);

    # Functional
    use URI::Encode qw(uri_encode uri_decode);
    my $encoded = uri_encode($data);
    my $decoded = uri_decode($encoded);


=head1 DESCRIPTION

This modules provides simple URI (Percent) encoding/decoding

The main purpose of this module (at least for me) was to provide an
easy method to encode strings (mainly URLs) into a format which can be
pasted into a plain text emails, and that those links are 'click-able'
by the person reading that email. This can be accomplished by NOT
encoding the reserved characters.

This module can also be useful when using L<HTTP::Tiny> to ensure the
URLs are properly escaped.

B<This module does not encode reserved characters by default>. If you
are looking for speed and want to encode reserved characters, use
L<URI::Escape::XS>

See L<this
script|https://github.com/mithun/perl-uri-encode/raw/master/.author/benchmark.pl>
for a comparison on encoding results and performance.

=head1 METHODS

=head2 new()

Creates a new object, no arguments are required

    my $encoder = URI::Encode->new(\%options);

The following options can be passed to the constructor

=over

=item encode_reserved

    my $encoder = URI::Encode->new({encode_reserved => 0});

If true, L</"Reserved Characters"> are also encoded. Defaults to false.

=item double_encode

    my $encoder = URI::Encode->new({double_encode => 1});

If false, characters that are already percent-encoded will not be
encoded again. Defaults to true.

    my $encoder = URI::Encode->new({double_encode => 0});
    print $encoder->encode('http://perl.com/foo%20bar'); # prints http://perl.com/foo%20bar

=back

=head2 C<encode($url, \%options)>

This method encodes the URL provided. The C<$url> provided is first
converted into UTF-8 before percent encoding. Options set in the
constructor, or defaults, can be overridden by passing them as the
(optional) second argument. Options passed must be a hashref.

    $uri->encode("http://perl.com/foo bar");
    $uri->encode( "http://perl.com/foo bar", { encode_reserved => 1 } );

=head2 C<decode($url)>

This method decodes a 'percent' encoded URL. If you had encoded the URL
using this module (or any other method), chances are that the URL was
converted to UTF-8 before 'percent' encoding. Be sure to check the
format and convert back if required.

    $uri->decode("http%3A%2F%2Fperl.com%2Ffoo%20bar");

=head1 EXPORTED FUNCTIONS

The following functions are exported upon request. This provides a
non-OOP interface

=over

=item C<uri_encode($url, \%options)>

=item C<uri_decode($url)>

=back

=head1 CHARACTER CLASSES

=head2 Reserved Characters

The following characters are considered as reserved (L<RFC
3986|http://tools.ietf.org/html/rfc3986>). They will be encoded only if
requested.

     ! * ' ( ) ; : @ & = + $ , / ? # [ ]

=head2 Unreserved Characters

The following characters are considered as Unreserved. They will not be
encoded

    a-z
    A-Z
    0-9
    - _ . ~

=head1 DEPENDENCIES

L<Encode>

=head1 ACKNOWLEDGEMENTS

Gisle Aas for L<URI::Escape>

David Nicol for L<Tie::UrlEncoder>

=head1 SEE ALSO

L<RFC 3986|http://tools.ietf.org/html/rfc3986>

L<URI::Escape>

L<URI::Escape::XS>

L<URI::Escape::JavaScript>

L<Tie::UrlEncoder>

=head1 BUGS AND LIMITATIONS

Please report any bugs or feature requests at
L<https://github.com/mithun/perl-uri-encode/issues>

=head1 AUTHOR

Mithun Ayachit C<mithun@cpan.org>

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2014, Mithun Ayachit. All rights reserved.

This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>.

=cut