File Coverage

lib/Template/Plugin/URL.pm

Criterion	Covered	Total	%
statement	32	32	100.0
branch	10	12	83.3
condition	9	9	100.0
subroutine	7	7	100.0
pod	1	3	33.3
total	59	63	93.6

#============================================================= -*-Perl-*-
#
# Template::Plugin::URL
#
# DESCRIPTION
#   Template Toolkit Plugin for constructing URL's from a base stem
#   and adaptable parameters.
#
# AUTHOR
#   Andy Wardley
#
# COPYRIGHT
#   Copyright (C) 2000-2007 Andy Wardley.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#============================================================================

package Template::Plugin::URL;

use strict;
use warnings;
use base 'Template::Plugin';

our $VERSION = 2.74;
our $JOINT   = '&';


#------------------------------------------------------------------------
# new($context, $baseurl, \%url_params)
#
# Constructor method which returns a sub-routine closure for constructing
# complex URL's from a base part and hash of additional parameters.
#------------------------------------------------------------------------

sub new {
    my ($class, $context, $base, $args) = @_;
    $args ||= { };

    return sub {
        my $newbase = shift unless ref $_[0] eq 'HASH';
        my $newargs = shift || { };
        my $combo   = { %$args, %$newargs };
        my $urlargs = join($JOINT,
                           map  { args($_, $combo->{ $_ }) }
                           grep { defined $combo->{ $_ } && length $combo->{ $_ } }
                           sort keys %$combo);

        my $query = $newbase || $base || '';
        $query .= '?' if length $query && length $urlargs;
        $query .= $urlargs if length $urlargs;

        return $query
    }
}


sub args {
    my ($key, $val) = @_;
    $key = escape($key);

    return map {
        "$key=" . escape($_);
    } ref $val eq 'ARRAY' ? @$val : $val;

}

#------------------------------------------------------------------------
# escape($url)
#
# URL-encode data.  Borrowed with minor modifications from CGI.pm.
# Kudos to Lincold Stein.
#------------------------------------------------------------------------

sub escape {
    my $toencode = shift;
    return undef unless defined($toencode);
    utf8::encode($toencode);
    $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
    return $toencode;
}

1;

__END__