File Coverage

blib/lib/Template/Replace.pm

Criterion	Covered	Total	%
statement	228	265	86.0
branch	102	156	65.3
condition	24	39	61.5
subroutine	25	31	80.6
pod	5	5	100.0
total	384	496	77.4

package Template::Replace;

use strict;
use warnings;
use 5.008;
use utf8;
use warnings qw( FATAL utf8 );
use Carp;
use Encode qw( encode decode );
use File::Spec::Functions qw( :ALL );
use open qw( :encoding(UTF-8) :std );

=head1 NAME

Template::Replace - PurePerl Push-Style Templating Module


=head1 VERSION

Version 0.04

=cut

our $VERSION = '0.04';

#
# TODO !!!!!
#
# . Changed var delimiter for HTML ({} collides with CSS and JS).
# . Changed include delimiter for HTML (






            ($ content_title_var $)

            ($ content_var | none $)


            Comments


                ($ name $):
                ($ comment $)




            No comments yet!








Data example:

    my $data = {
        html_title_var    => 'Template::Replace: An Example',
        content_title_var => 'An Example',
        content_var       => $html_content,
        Comments          => [
            {
                url       => $author[0]->{url},
                name      => $author[0]->{name},
                comment   => $author[0]->{comment},
            },
            {
                url       => $author[1]->{url},
                name      => $author[1]->{name},
                comment   => $author[1]->{comment},
            },
        ],
        NotRepeating      => { content => 'This is simple content.' },
    };


=head1 EXPORT

Nothing is exported. This module provides an object oriented interface.


=head1 DEPENDENCIES

Requires Perl 5.8 (best served above 5.8.2), L, L and
L (Perl 5.8 core modules).

This is a single file module that can be run without prior installation.


=head1 DESCRIPTION

#
# TODO !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#

Beware: This module's code is neither elegant nor ingenious! Au contraire -
it's ugly, it's a mess ... and it is doing what I wanted it to do. (Okay, not
as bad as stated, but don't complain when looking at it ;-)


=head1 METHODS

=head2 C

    my $tmpl = Template::Replace->new({
        path      => [ 'path1', 'path2' ],
        filename  => 'template_filename',
        delimiter => {
            include => [ '' ],
            section => [ '' ],
            var     => [ '($'   ,   '$)' ],
            test    => [ '' ],
            comment => [ '' ],
        },
        filter => {
            default => 'xml',
            special => \&my_special_filter_function,
        },
    });

Path can be a single string or an array reference of multiple strings; given
paths have to exist, and template files (and includes) can only be loaded from
these paths (for security reasons)!

Filename is an optional string; the template is loaded on object creation if
given.

Single delimiter pairs can be given (default delimiters shown), but they have
to be array references with exactly 2 strings; the delimiters are fixed after
object creation, so this is the only chance to change them!

Filters can be re-declared and custom filters attached; the default filter is
a pass-through filter; filters can be changed anytime before invoking
$tmpl->replace().

All options are optional, but at least one existing path has to be given to
load a template from file (either with filename on object creation or later
with the load method).

=cut

sub new {

    # Process arguments ...
    croak __PACKAGE__ . '->new(): Only one optional argument!'
        unless @_ < 3;

    my ($class, $conf) = (shift, shift || {});

    croak __PACKAGE__ . '->new(): Argument has to be a hash reference!'
        unless defined $conf && ref $conf eq 'HASH';

    croak __PACKAGE__ . '->new(): Filename has to be a string!'
        if $conf->{filename} && ref \$conf->{filename} ne 'SCALAR';

    # Create object hash with default values ...
    my $self = {
        template  => {},
        path      => [],
        filename  => '',
        encoding  => 'UTF-8',
        delimiter => {
            include => [ '' ],
            section => [ '' ],
            var     => [ '($'   ,   '$)' ],
            test    => [ '' ],
            comment => [ '' ],
        },
        is_block    => {
            include => 1,
            section => 1,
            test    => 1,
            comment => 1,
        },
        filter => {
            default    => \&_filter_none,
            none       => \&_filter_none,
            literal    => \&_filter_none,
            xml        => \&_filter_xml,
            html       => \&_filter_html,
            uri        => \&_filter_uri,
            url        => \&_filter_url,
            'uri+xml'  => sub {_filter_xml(_filter_uri(shift));},
            'uri+html' => sub {_filter_html(_filter_uri(shift));},
            'url+xml'  => sub {_filter_xml(_filter_url(shift));},
            'url+html' => sub {_filter_html(_filter_url(shift));},
        },
    };

    # Check for path or path array ...
    # croak __PACKAGE__ . '->new(): No path or path array given!'
    #    unless $conf->{path};
    if (defined $conf->{path}) {
        if (ref $conf->{path} eq 'ARRAY') {
            croak __PACKAGE__ . '->new(): Path array contains invalid path!'
                if grep { !-e $_ } @{$conf->{path}};
            $self->{path} = $conf->{path};
        }
        elsif (ref \$conf->{path} eq 'SCALAR') {
            croak __PACKAGE__ . '->new(): Path '
                . $conf->{path}
                . ' does not exist!'
                unless -e $conf->{path};
            my @path = ($conf->{path});
            $self->{path} = \@path;
        }
        else {
            croak __PACKAGE__ . '->new(): Path is no string or array_ref!';
        }
    }

    # Check for filename ...
    croak __PACKAGE__ . '->new(): No paths defined to load files from!'
        if $conf->{filename} && $#{$self->{path}} == -1;
    $self->{filename} = $conf->{filename};

    # Get delimiters from $conf ...
    croak __PACKAGE__ . '->new(): Argument for delimiters is no hash ref!'
        if $conf->{delimiter} && ref $conf->{delimiter} ne 'HASH';
    foreach my $key (keys %{$self->{delimiter}}) {
        if (defined $conf->{delimiter}{$key}) {
            croak __PACKAGE__ . '->new(): ARRAY reference'
                . " of two delimiter strings expected for $key!"
                unless ref $conf->{delimiter}{$key} eq 'ARRAY'
                    && scalar @{$conf->{delimiter}{$key}} == 2;
            $self->{delimiter}{$key} = $conf->{delimiter}{$key};
        }
    }

    # Create slicer and parser regexps ...
    my $regexp_ref= {};
    foreach my $key (keys %{$self->{delimiter}}) {
        #my $rx = ($self->{is_block}{$key} ? '[ \t]*' : '')
        #my $rx = ($self->{is_block}{$key} ? '\n?[ \t]*' : '')
        my $rx =
            ($self->{is_block}{$key} ? '(?(?<=\n)[ \t]*|(?:\A[ \t]*)?)' : '')
            . quotemeta($self->{delimiter}{$key}[0])
            . '\s*?(\S.*?)?\s*?'
            . quotemeta($self->{delimiter}{$key}[1])
            . ($self->{is_block}{$key} ? '(?:[ \t]*\n)?' : '')
            ;
        $regexp_ref->{$key} = qr/$rx/s;
    }

    $self->{regexp} = $regexp_ref;

    # Get filter from $conf ...
    if ($conf->{filter}) {
        croak __PACKAGE__ . '->new(): Argument for filters is no hash ref!'
            unless ref $conf->{filter} eq 'HASH';
        foreach my $key (keys %{$conf->{filter}}) {
            if (ref $conf->{filter}{$key} eq 'CODE') {
                $self->{filter}{$key} = $conf->{filter}{$key};
            }
            elsif (ref \$conf->{filter}{$key} eq 'SCALAR') {
                $self->{filter}{$key} = $self->{filter}{$conf->{filter}{$key}}
                    or croak __PACKAGE__ . '->new(): Unknown pre-defined'
                        . " filter '$conf->{filter}{$key}'!";
            }
            else {
                croak __PACKAGE__ . '->new(): Filter has to be '
                    . 'a pre-defined filter name or a CODE reference!';
            }
        }
    }

    # Bless object hash ...
    bless($self, $class);

    $self->load($self->{filename}) if $self->{filename};

    return $self;
}


=head2 C

    my $template_ref = $tmpl->parse($str);

Parses a template from $str. Stores the template structure reference in the
$tmpl object and returns it. No includes, because they are handled only on
reading from file (use $tmpl->load() instead)!

=cut

sub parse {
    my ($self, $str) = @_;
    $self->{template} = $self->_parse_slices($self->_slice_str($str));
    return $self->{template};
}


=head2 C

    my $template_ref = $tmpl->load($filename);

Loads a template from file $filename and parses it. Stores the template
structure reference in the $tmpl object and returns it.

=cut

sub load {
    my ($self, $filename) = @_;
    return $self->parse($self->_read_file($filename));
}


=head2 C

    my $txt = $tmpl->replace($data);

Replaces $data in $tmpl and returns the resulting string (text).

=cut

sub replace {
    my ($self, $data) = @_;
    return $self->_replace($self->{template}, $data);
}


=head2 C

    my $result = $tmpl->has($access_str);

Tries to access a template element and returns the usage count of a section (0
or 1 for now) or of a variable in the template structure. The access string
has the following form:

    'RootSection' (or '/RootSection')
    'RootSection/Subsection'
    'RootVariable'
    'RootSection/SectionVariable'
    'RootSection/Subsection/SubsectionVariable'
    etc.

=cut

# TODO: Adapt for new template structure (multiple same-name subsections),
# don't forget to change documentation!
#
sub has {
    my ($self, $access_str) = @_;
    return _access_template($access_str, $self->{template});
}


#
# Private methods ...
#

sub _replace {
    #
    #   my $txt = $self->_replace($sec_ref, @data_refs);
    #
    # Format of a data reference:
    #
    #   my $data_ref = {
    #       'GlobalVar' => GlobalVarString,
    #       'Section1Name' => { # section data for single invocation
    #           var1_name => var1_scalar,
    #           var2_name => var2_scalar,
    #           'SubSectionName' => ...,
    #       },
    #       'Section2Name' => [ # section data for iterated invocation
    #           { var1_name => var1_scalar, var2_name => var2_scalar },
    #           { var1_name => var1_scalar, var2_name => var2_scalar },
    #       ],
    #   };
    #
    my ($self, $sec_ref, @data_refs) = @_;
    my $sec_data_ref = $data_refs[$#data_refs];
    my $txt = '';
    my $skip = '';

    PART:
    foreach my $part (@{$sec_ref->{parts}}) {
        if ($skip) { # skip parts inside test
            $skip = '' if ref $part eq 'HASH'
                && $part->{test} && $part->{test} eq "/$skip";
        }
        elsif (ref $part eq 'HASH') { # subsection, test or var
            if (my $subsec_name = $part->{sec}) { # subsection
                my $subsec_idx = $part->{idx};
                my $subsec_data_ref = $sec_data_ref->{$subsec_name};
                next PART unless $subsec_data_ref;
                croak __PACKAGE__ . '->_replace(): Data for section'
                    . " $subsec_name has to be"
                    . " a HASH or ARRAY reference!"
                    unless ref $subsec_data_ref eq 'HASH'
                        || ref $subsec_data_ref eq 'ARRAY'
                    ;
                my @iterations = ref $subsec_data_ref eq 'HASH'
                               ? ($subsec_data_ref)
                               : @$subsec_data_ref
                               ;
                foreach my $iteration_data_ref (@iterations) {
                    $txt .= $self->_replace(
                        $sec_ref->{children}{$subsec_name}[$subsec_idx],
                        @data_refs,
                        $iteration_data_ref,
                    );
                }
            }
            elsif ($part->{test}) { # test
                next PART if $part->{test} =~ m{^/};
                my $test = $part->{test};
                if ($test =~ s/^!//) {
                    $skip = _access_data($test, @data_refs)
                          ? $part->{test} : '' ;
                }
                else {
                    $skip = _access_data($test, @data_refs)
                          ? '' : $part->{test} ;
                }
            }
            else { # var
                my $filter =  $self->{filter}{$part->{filter}}
                           || $self->{filter}{default};
                $txt .= &$filter(
                    _access_data($part->{var}, @data_refs) || ''
                );
            }
        }
        else { # string
            $txt .= $part;
        }
    }

    return $txt;
}

sub _parse_slices {
    #
    #   my $sec_ref = $self->_parse_slices(
    #       $slices_ref[, $sec_name[, $parent_sec_ref]]
    #   );
    #
    # The template's recursive structure is returned:
    #
    #   {
    #       name     => 'root',
    #       parent   => undef,
    #       children => {
    #           'var_name_1'    => count,
    #           'subsec_name_1' => [
    #               {
    #                   name     => 'subsec_name_1',
    #                   parent   => root_ref,
    #                   children => {...},
    #                   parts    => {...}
    #               },
    #               {
    #                   name     => 'subsec_name_1',
    #                   parent   => root_ref,
    #                   children => {...},
    #                   parts    => {...}
    #               }
    #           ],
    #           'var_name_2'    => count,
    #           'subsec_name_2' => [...],
    #       },
    #       parts    => [
    #           string,
    #           { var  => 'var_name_1', filter => 'default' },
    #           { test => 'test_name' },
    #           { sec  => 'subsec_name_1', idx => 0 },
    #           string,
    #           { var  => 'var_name_2', filter => 'xml' },
    #           string,
    #           { test => '/test_name' },
    #           { sec  => 'subsec_name_2', idx => 0 },
    #           { sec  => 'subsec_name_1', idx => 1 },
    #           ...
    #       ]
    #   }
    #
    # The 'children' hashref is for faster template inspection (convenience)
    # and (for subsections) to simplify the elements in the parts arrayref.
    #
    # Variables can be used more than once in a section, because they
    # are not defined in the template but only filled with their data.
    #
    # Sections can be used more than one also, e.g. for localization inside a
    # template (with language conditions - TODO). They will be processed with
    # the same data!
    #
    my ($self, $slices_ref, $sec_name, $parent_sec_ref) = @_;
    $sec_name ||= 'root';
    my $sec_ref = {
        name     => $sec_name,
        parent   => $parent_sec_ref,
        children => {},
        parts    => [],
    };
    my $regexp_comment = quotemeta($self->{delimiter}{comment}[0]);

    SLICE:
    while (my $slice = shift @$slices_ref) {
        if ($slice =~ m/$regexp_comment/) { # comment
            next;
        }
        elsif ($slice =~ m/$self->{regexp}{test}/) { # test
            push @{$sec_ref->{parts}}, { test => $1 };
        }
        elsif ($slice =~ m/$self->{regexp}{section}/) { # subsection
            my $subsec_name = $1;
            if ($subsec_name =~ m{^/(.+)$}) { # end of subsection
                croak __PACKAGE__
                    . '->_parse_slices(): Section ended with '
                    . "$1 instead of $sec_name!"
                        unless $1 eq $sec_name;
                last SLICE;
            }
            if (!$sec_ref->{children}{$subsec_name}) {
                $sec_ref->{children}{$subsec_name} = [];
            }
            my $subsec_array_ref = $sec_ref->{children}{$subsec_name};
            if (ref $subsec_array_ref ne 'ARRAY') {
                croak __PACKAGE__
                    . "->_parse_slices(): Section name '$subsec_name' "
                    . "already used for a variable in '$sec_name'!"
                    ;
            }
            my $subsec_ref = $self->_parse_slices(
                $slices_ref, $subsec_name, $sec_ref
            );
            push @{$subsec_array_ref}, $subsec_ref;
            push @{$sec_ref->{parts}}, {
                sec => $subsec_name,
                idx => $#$subsec_array_ref,
            };
        }
        elsif ($slice =~ m/$self->{regexp}{var}/) { # var
            my ($var, $filter) = $1 =~ m/^([^|\s]+)\s*\|?\s*([^\s]+)?$/;
            $filter = lc($filter || 'default');
            croak __PACKAGE__
                . "->_parse_slices(): Variable name '$var' "
                . "already used for a section in '$sec_name'!"
                    if ref $sec_ref->{children}{$var} eq 'ARRAY';
            push @{$sec_ref->{parts}}, { var => $var, filter => $filter, };
            $sec_ref->{children}{$var}++;
        }
        else { # string
            push @{$sec_ref->{parts}}, $slice;
        }
    }

    return $sec_ref;
}

sub _slice_str {
    #
    #   my $slices = $tmpl->_slice_str($str);
    #
    # This method returns the reference to a list of strings that represents
    # the found slices (the given string is cut to pieces - without any
    # characters removed or added).
    #
    my ($self, $str) = @_;
    croak __PACKAGE__ . '->_slice_str(): Missing string argument!'
        unless defined $str;
    croak __PACKAGE__ . '->_slice_str(): Not a string argument!'
        unless ref \$str eq 'SCALAR';

    my $rx = qr(
            $self->{regexp}{comment}
        |   $self->{regexp}{test}
        |   $self->{regexp}{section}
        |   $self->{regexp}{var}
    )x;
    my $dbldelim = '^[ \t]*(';
    foreach my $key (keys %{$self->{delimiter}}) {
        $dbldelim .= quotemeta($self->{delimiter}{$key}[0]) . '|';
    }
    $dbldelim = substr($dbldelim, 0, -1) . ').*?\1';
    $dbldelim = qr/$dbldelim/s;

    my @strings = ();
    my $last_pos = 0;

    while ($str =~ m/$rx/cg) {
        my $start = $-[0];
        my $end   = $+[0];
        if ($start > $last_pos) { # string slice before match
            push @strings, substr $str, $last_pos, $start - $last_pos;
        }
        my $slice =  substr $str, $start, $end - $start; # element slice
        # Check for doubled start delimiter (which breaks $rx) ...
        croak __PACKAGE__ . '->_slice_str(): Repeated start delimiter '
            . "in slice '$slice'!"
            if $slice =~ m/$dbldelim/;
        push @strings, $slice;
        $last_pos = $end;
    }

    if (length $str > $last_pos) { # remaining string slice
        push @strings, substr $str, $last_pos;
    }

    return \@strings;
}

sub _read_file {
    #
    #   my $str = $tmpl->_read_file($file_name[, @ancestors]);
    #
    # TODO:
    # - Restrict filenames to an ASCII subset
    # - Allways Unix path notation in Template::Replace?
    # - Use explicit file encoding when reading
    #
    my ($self, $file_name, @ancestors) = @_;

    # Cleanup of file name ...
    my @canon_path = splitpath(canonpath($file_name));
    my @canon_dir = grep {$_ !~ /\.\./} splitdir($canon_path[1]);
    my $canon_file_name = catfile(@canon_dir, $canon_path[2]);

    # Try to find file in paths ...
    my $canon_file_path = '';
    foreach my $path (@{$self->{path}}) {
        $canon_file_path = catfile($path, $canon_file_name);
        last if -e $canon_file_path;
        $canon_file_path = '';
    }
    croak __PACKAGE__ . "->read_file(): File $file_name not found!"
        . ' (Perhaps paths are wrong.)'
        unless $canon_file_path;

    croak __PACKAGE__ . '->read_file(): File recursion for '
        . "$canon_file_path detected!"
        if grep {$canon_file_path eq $_} @ancestors;

    open(my $fd, "<:encoding($self->{encoding})", $canon_file_path)
        or croak __PACKAGE__ . '->_read_file() can\'t open '
        . "$canon_file_path: $!";
    my $str = '';
    {
        local $/;
        defined ($str = readline $fd) or
            croak __PACKAGE__ . '->_read_file() can\'t read from '
            . "$file_name: $!";
    }
    $str =~ s/\x0D?\x0A/\n/g;
    push @ancestors, $canon_file_path;
    $str =~ s/$self->{regexp}{include}/$self->_read_file($1, @ancestors)/ogme;

    return $str;
}


#
# Private functions ...
#

sub _access_template {
    #
    #   my $result = _access_template($access_str, $template_ref);
    #
    # The $access_str starts always at the template root and uses the
    # following notation:
    #
    #   'bla', same as '/bla', is root element 'bla'
    #   'bla/blub' is element 'blub' of section 'bla'
    #   'bla/blub/blib' is element 'blib' of section 'blub',
    #     assuming the first section definition of 'blub',
    #   'bla/blub/0/blib' is the same as 'bla/blub/blib'
    #   'bla/blub/1 assumes 'blub' to be a section with a second definition
    #   etc.
    #
    # Elements can be sections or variables. For sections the array reference
    # that contains the references to the data structures defined by the
    # section name is returned (if no section count is given) or the section
    # hash reference, for variables the usage count inside of
    # their section.
    #
    # TODO: There's a problem with variable syntax (can contain '../Sec/Var')!
    #       (So variable references can't be detected.)
    #
    my ($access_str, $tmpl_ref) = @_;
    croak __PACKAGE__ . '::_access_template(): '
        . 'Template has to be a HASH reference!'
        unless ref $tmpl_ref eq 'HASH';
    croak __PACKAGE__ . '::_access_template(): '
        . 'Access string is no SCALAR!'
        unless ref \$access_str eq 'SCALAR';

    return unless $access_str;

    my $result = $tmpl_ref;
    $access_str =~ s/^\///;
    my @parts = split /\//, $access_str;

    foreach my $part (@parts) {
        return unless $result;
        if (ref $result eq 'HASH') {
            $result = $result->{children}{$part};
        }
        elsif (ref $result eq 'ARRAY') {
            $result = ($part =~ /^\d+$/) ? $result->[$part]
                                         : $result->[0]{children}{$part};
        }
        else {
            return;
        }
    }

    return $result;
}

sub _access_data {
    #
    #   my $data = _access_data($access_str, @data_refs);
    #
    #   'bla' is data in current section
    #   'bla/blub' is subsection data (same as 'bla/0/blub' = first iteration)
    #   'bla/2/blub' is third iteration data blub (iterations start w/ 0)
    #   '/bla' is root data
    #   '../bla' is parent data, '../../bla' is parent's parent data etc.
    #
    # and so on ...
    #
    # @data_refs is a stack of data references; topmost is the data ref of
    # the current section (respectively of its current iteration), below the
    # data ref of the parent section (respectively of its current iteration),
    # and so forth, with the root data reference at the bottom.
    #
    # Therefor it is possible to access another iteration of the parent's data
    # by going to the parent's parent data and down again from there ...
    #
    my ($access_str, @data_refs) = @_;
    #
    # Croak instead?
    #
    return unless scalar @data_refs;

    my $data = $access_str =~ s/^\/// ? $data_refs[0] : pop @data_refs ;
    my @parts = split /\//, $access_str;
    #
    # Croak instead?
    #
    return unless scalar @parts;

    foreach my $part (@parts) {
        next if $part eq '.'; # What if no parts left?
        if ($part eq '..') {
            $data = pop @data_refs;
        }
        elsif (ref $data eq 'ARRAY') {
            $data = ($part =~ /^\d+$/) ? $data->[$part] : $data->[0]{$part};
        }
        elsif (ref $data eq 'HASH') {
            $data = $data->{$part};
        }
        else {
            return; # Is that right?
        }
    }

    return $data;
}

#
# Pre-defined filter functions ...
#

sub _filter_none {
    local $_ = shift;
    return $_;
}

sub _filter_xml {
    local $_ = shift;
    croak __PACKAGE__ . "::_filter_xml: Undefined string not accepted!"
        unless defined $_;
    return '' unless length $_;
    s/&/&/g;
    s/
    s/>/>/g;
    s/'/'/g;
    s/"/"/g;
    return $_;
}

sub _filter_html {
    local $_ = shift;
    croak __PACKAGE__ . "::_filter_xml: Undefined string not accepted!"
        unless defined $_;
    return '' unless length $_;
    s/&/&/g;
    s/
    s/>/>/g;
    s/"/"/g;
    return $_;
}

our $URI_ESCAPES; # Cache of escaped characters

sub _filter_uri {
    # URI escape a string.  This code is borrowed from Gisle Aas' URI::Escape
    # module, copyright 1995-2004.  See RFC2396 for details.
    my $str = shift;
    return '' unless length $str;

    $URI_ESCAPES ||= {
        map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255),
    };

    if ($] >= 5.008002) {
        utf8::encode($str) if utf8::is_utf8($str);
        $str =~ s/([^A-Za-z0-9\-_.!~*'()])/$URI_ESCAPES->{$1}/eg;
    }
    else {
        # More reliable with older Perl versions, but complicated and slow ...
        # This particular implementation is not yet tested (used in the past)!
        use bytes;
        my @bytes = split '', $str;
        foreach my $byte (@bytes) {
            $byte = uc("%" . unpack('H*', $byte)) if /[^A-Za-z0-9\-_.!~*'()]/;
        };
        $str = join '', @bytes;
    }

    return $str;
}

sub _filter_url {
    # URI escape a string.  This code is borrowed from Gisle Aas' URI::Escape
    # module, copyright 1995-2004.  See RFC2396 for details.
    # Less agressive than _filter_uri().
    my $str = shift;
    return '' unless length $str;

    $URI_ESCAPES ||= {
        map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255),
    };

    if ($] >= 5.008002) {
        utf8::encode($str) if utf8::is_utf8($str);
        $str =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*'()])/$URI_ESCAPES->{$1}/eg;
    }
    else {
        # More reliable with older Perl versions, but complicated and slow ...
        # This particular implementation is not yet tested (used in the past)!
        use bytes;
        my @bytes = split '', $str;
        foreach my $byte (@bytes) {
            $byte = uc("%" . unpack('H*', $byte))
                        if /[^;\/?:@&=+\$,A-Za-z0-9\-_.!~*'()]/;
        };
        $str = join '', @bytes;
    }

    return $str;
}

1;

__END__