File Coverage

blib/lib/URI/Encode.pm

Criterion	Covered	Total	%
statement	67	71	94.3
branch	20	28	71.4
condition			n/a
subroutine	14	14	100.0
pod	5	5	100.0
total	106	118	89.8

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.0.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, $')}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;
    if ( $post =~ m{^([a-fA-F0-9]{2})}x ) {
      return $self->_get_encoded_char($char)
          unless exists $self->{dec_map}->{$1};
      return $char;
    } ## end if ( $post =~ m{^([a-fA-F0-9]{2})}x)
  return $self->_get_encoded_char($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__