File Coverage

blib/lib/CGI/Application/Plugin/TT.pm

Criterion	Covered	Total	%
statement	186	204	91.1
branch	72	96	75.0
condition	29	47	61.7
subroutine	25	29	86.2
pod	9	9	100.0
total	321	385	83.3

package CGI::Application::Plugin::TT;

use Template 2.0;
use CGI::Application 4.0;
use Carp;
use File::Spec ();
use Scalar::Util ();

use strict;
use vars qw($VERSION @EXPORT);

$VERSION = '1.05';

require Exporter;

@EXPORT = qw(
    tt_obj
    tt_config
    tt_params
    tt_clear_params
    tt_process
    tt_include_path
    tt_template_name
);
sub import {
    my $pkg = shift;
    my $callpkg = caller;
    no strict 'refs';
    foreach my $sym (@EXPORT) {
        *{"${callpkg}::$sym"} = \&{$sym};
    }
    $callpkg->tt_config(@_) if @_;
    if ($callpkg->isa('CGI::Application')) {
        $callpkg->new_hook('tt_pre_process');
        $callpkg->new_hook('tt_post_process');
    } else {
        warn "Calling package is not a CGI::Application module so not installing tt_pre_process and tt_post_process hooks.  If you are using \@ISA instead of 'use base', make sure it is in a BEGIN { } block, and make sure these statements appear before the plugin is loaded";
    }

}

##############################################
###
###   tt_obj
###
##############################################
#
# Get a Template Toolkit object.  The same object
# will be returned everytime this method is called
# during a request cycle.
#
sub tt_obj {
    my $self = shift;

    my ($tt, $options, $frompkg) = _get_object_or_options($self);

    if (!$tt) {
        my $tt_options = $options->{TEMPLATE_OPTIONS};
        if (keys %{$options->{TEMPLATE_OPTIONS}}) {
          $tt = Template->new( $options->{TEMPLATE_OPTIONS} ) || carp "Can't load Template";
        } else {
          $tt = Template->new || carp "Can't load Template";
        }
        _set_object($frompkg||$self, $tt);
    }
    return $tt;
}

##############################################
###
###   tt_config
###
##############################################
#
# Configure the Template Toolkit object
#
sub tt_config {
    my $self = shift;
    my $class = ref $self ? ref $self : $self;

    my $tt_config;
    if (ref $self) {
        die "Calling tt_config after the tt object has already been created" if @_ && defined $self->{__TT};
        $tt_config = $self->{__TT_CONFIG} ||= {};
    } else {
        no strict 'refs';
        ${$class.'::__TT_CONFIG'} ||= {};
        $tt_config = ${$class.'::__TT_CONFIG'};
    }

    if (@_) {
      my $props;
      if (ref($_[0]) eq 'HASH') {
          my $rthash = %{$_[0]};
          $props = CGI::Application->_cap_hash($_[0]);
      } else {
          $props = CGI::Application->_cap_hash({ @_ });
      }

      my %options;
      # Check for TEMPLATE_OPTIONS
      if ($props->{TEMPLATE_OPTIONS}) {
          carp "tt_config error:  parameter TEMPLATE_OPTIONS is not a hash reference"
              if Scalar::Util::reftype($props->{TEMPLATE_OPTIONS}) ne 'HASH';
          $tt_config->{TEMPLATE_OPTIONS} = delete $props->{TEMPLATE_OPTIONS};
      }

      # Check for TEMPLATE_NAME_GENERATOR
      if ($props->{TEMPLATE_NAME_GENERATOR}) {
          carp "tt_config error:  parameter TEMPLATE_NAME_GENERATOR is not a subroutine reference"
              if Scalar::Util::reftype($props->{TEMPLATE_NAME_GENERATOR}) ne 'CODE';
          $tt_config->{TEMPLATE_NAME_GENERATOR} = delete $props->{TEMPLATE_NAME_GENERATOR};
      }

      # Check for TEMPLATE_PRECOMPILE_FILETEST
      if ($props->{TEMPLATE_PRECOMPILE_FILETEST}) {
          carp "tt_config error:  parameter TEMPLATE_PRECOMPILE_FILETEST is not a subroutine reference or regexp or string"
              if defined Scalar::Util::reftype($props->{TEMPLATE_PRECOMPILE_FILETEST})
              && Scalar::Util::reftype($props->{TEMPLATE_PRECOMPILE_FILETEST}) ne 'CODE'
              && overload::StrVal($props->{TEMPLATE_PRECOMPILE_FILETEST}) !~ /^Regexp=/;
          $tt_config->{TEMPLATE_PRECOMPILE_FILETEST} = delete $props->{TEMPLATE_PRECOMPILE_FILETEST};
      }

      # This property must be tested last, since it creates the TT object in order to
      # preload all the templates.
      #
      # Check for TEMPLATE_PRECOMPILE_DIR
      if( $props->{TEMPLATE_PRECOMPILE_DIR} ) {
          my $type = Scalar::Util::reftype($props->{TEMPLATE_PRECOMPILE_DIR});
          carp "tt_config error: parameter TEMPLATE_PRECOMPILE_DIR must be a SCALAR or an ARRAY ref"
            unless( !defined($type) or $type eq 'ARRAY' );

          # now look at each file and
          my @dirs = ($type && $type eq 'ARRAY') ? @{$props->{TEMPLATE_PRECOMPILE_DIR}}
            : ($props->{TEMPLATE_PRECOMPILE_DIR});
          delete $props->{TEMPLATE_PRECOMPILE_DIR};
          my $tt = $self->tt_obj;
          my $junk = '';
          my $filetester = sub { 1 };
          if ($tt_config->{TEMPLATE_PRECOMPILE_FILETEST}) {
              if (! defined Scalar::Util::reftype($tt_config->{TEMPLATE_PRECOMPILE_FILETEST})) {
                  $filetester = sub { $_[0] =~ /\.$tt_config->{TEMPLATE_PRECOMPILE_FILETEST}$/ };
              } elsif (Scalar::Util::reftype($tt_config->{TEMPLATE_PRECOMPILE_FILETEST}) eq 'CODE') {
                  $filetester = $tt_config->{TEMPLATE_PRECOMPILE_FILETEST};
              } elsif (overload::StrVal($tt_config->{TEMPLATE_PRECOMPILE_FILETEST}) =~ /^Regexp=/) {
                  $filetester = sub { $_[0] =~ $tt_config->{TEMPLATE_PRECOMPILE_FILETEST} };
              }
          }
          require File::Find;
          File::Find::find(
            sub {
                my $file = $File::Find::name;
                return unless $filetester->($file);
                if( !-d $file ) {
                    $tt->process( $file, {}, \$junk );
                }
            },
            map { File::Spec->rel2abs($_) } @dirs,
          );

      }

      # If there are still entries left in $props then they are invalid
      carp "Invalid option(s) (".join(', ', keys %$props).") passed to tt_config" if %$props;
    }

    $tt_config;
}

##############################################
###
###   tt_params
###
##############################################
#
# Set some parameters that will be added to
# any template object we process in this
# request cycle.
#
sub tt_params {
    my $self = shift;
    my @data = @_;

    # Define the params stash if it doesn't exist
    $self->{__TT_PARAMS} ||= {};

    if (@data) {
        my $params    = $self->{__TT_PARAMS};
        my $newparams = {};
        if (ref $data[0] eq 'HASH') {
            # hashref
            %$newparams = %{ $data[0] };
        } elsif ( (@data % 2) == 0 ) {
            %$newparams = @data;
        } else {
            carp "tt_params requires a hash or hashref!";
        }

        # merge the new values into our stash of parameters
        @$params{keys %$newparams} = values %$newparams;
    }

    return $self->{__TT_PARAMS};
}

##############################################
###
###   tt_clear_params
###
##############################################
#
# Clear any template parameters that may have
# been set during this request cycle.
#
sub tt_clear_params {
    my $self = shift;

    my $params = $self->{__TT_PARAMS};
    $self->{__TT_PARAMS} = {};

    return $params;
}

##############################################
###
###   tt_pre_process
###
##############################################
#
# Sample method that is called just before
# a Template is processed.
# Useful for setting global template params.
# It is passed the template filename and the hashref
# of template data
#
sub tt_pre_process {
    my $self = shift;
    my $file = shift;
    my $vars = shift;

    # Do your pre-processing here
}

##############################################
###
###   tt_post_process
###
##############################################
#
# Sample method that is called just after
# a Template is processed.
# Useful for post processing the HTML.
# It is passed a scalar reference to the HTML code.
#
# Note:  This could also be accomplished using the
#        cgiapp_postrun method, except that this
#        method is called after every template is
#        processed (you could process multiple
#        templates in one request), whereas
#        cgiapp_postrun is only called once after
#        the runmode has completed.
#
sub tt_post_process {
    my $self    = shift;
    my $htmlref = shift;

    # Do your post-processing here
}

##############################################
###
###   tt_process
###
##############################################
#
# Process a Template Toolkit template and return
#  the resulting html as a scalar ref
#
sub tt_process {
    my $self = shift;
    my $file = shift;
    my $vars = shift;
    my $html = '';

    my $can_call_hook = UNIVERSAL::can($self, 'call_hook') ? 1 : 0;

    if (! defined($vars) && (Scalar::Util::reftype($file)||'') eq 'HASH') {
        $vars = $file;
        $file = undef;
    }
    $file ||= $self->tt_template_name(1);
    $vars ||= {};
    my $template_name = $file;

    # Call the load_tmpl hook that is part of CGI::Application
    $self->call_hook(
        'load_tmpl',
        {}, # template options are ignored
        $vars,
        $file,
    ) if $can_call_hook;

    # Call tt_pre_process hook
    $self->tt_pre_process($file, $vars) if $self->can('tt_pre_process');
    $self->call_hook('tt_pre_process', $file, $vars) if $can_call_hook;

    # Include any parameters that may have been
    # set with tt_params
    my %params = ( %{ $self->tt_params() }, %$vars );

    # Add c => $self in as a param for convenient access to sessions and such
    $params{c} ||= $self;

    $self->tt_obj->process($file, \%params, \$html) || croak $self->tt_obj->error();

    # Call tt_post_process hook
    $self->tt_post_process(\$html) if $self->can('tt_post_process');
    $self->call_hook('tt_post_process', \$html) if $can_call_hook;

    _tt_add_devpopup_info($self, $template_name, \%params);

    return \$html;
}

##############################################
###
###   tt_include_path
###
##############################################
#
# Change the include path after the template object
# has already been created
#
sub tt_include_path {
    my $self = shift;

    return $self->tt_obj->context->load_templates->[0]->include_path unless(@_);
    $self->tt_obj->context->load_templates->[0]->include_path(ref($_[0]) ? $_[0] : [@_]);

    return;
}

##############################################
###
###   tt_template_name
###
##############################################
#
# Auto-generate the filename of a template based on
# the current module, and the name of the
# function that called us.
#
sub tt_template_name {
    my $self = shift;

    my ($tt, $options, $frompkg) = _get_object_or_options($self);

    my $func = $options->{TEMPLATE_NAME_GENERATOR} || \&__tt_template_name;
    return $self->$func(@_);
}

##############################################
###
###   __tt_template_name
###
##############################################
#
# Generate the filename of a template based on
# the current module, and the name of the
# function that called us.
#
# example:
#   module $self is blessed into:  My::Module
#   function name that called us:  my_function
#
#   generates:  My/Module/my_function.tmpl
#
sub __tt_template_name {
    my $self    = shift;
    my $uplevel = shift || 0;

    # the directory is based on the object's package name
    my $dir = File::Spec->catdir(split(/::/, ref($self)));

    # the filename is the method name of the caller plus
    # whatever offset the user asked for
    (caller(2+$uplevel))[3] =~ /([^:]+)$/;
    my $name = $1;

    return File::Spec->catfile($dir, $name.'.tmpl');
}

##
## Private methods
##
sub _set_object {
    my $self = shift;
    my $tt  = shift;
    my $class = ref $self ? ref $self : $self;

    if (ref $self) {
        $self->{__TT_OBJECT} = $tt;
    } else {
        no strict 'refs';
        ${$class.'::__TT_OBJECT'} = $tt;
    }
}

sub _get_object_or_options {
    my $self = shift;
    my $class = ref $self ? ref $self : $self;

    # Handle the simple case by looking in the object first
    if (ref $self) {
        return ($self->{__TT_OBJECT}, $self->{__TT_CONFIG}) if $self->{__TT_OBJECT};
        return (undef, $self->{__TT_CONFIG}) if $self->{__TT_CONFIG};
    }

    # See if we can find them in the class hierarchy
    #  We look at each of the modules in the @ISA tree, and
    #  their parents as well until we find either a tt
    #  object or a set of configuration parameters
    require Class::ISA;
    foreach my $super ($class, Class::ISA::super_path($class)) {
        no strict 'refs';
        return (${$super.'::__TT_OBJECT'}, ${$super.'::__TT_CONFIG'}, $super) if ${$super.'::__TT_OBJECT'};
        return (undef, ${$super.'::__TT_CONFIG'}, $super) if ${$super.'::__TT_CONFIG'};
    }
    return;
}

##############################################
###
###   _tt_add_devpopup_info
###
##############################################
#
# This method will look to see if the devpopup
# plugin is being used, and will display all the
# parameters that were passed to the template.
#
sub _tt_add_devpopup_info {
    my $self = shift;
    my $name = shift;
    my $params = shift;

    return unless UNIVERSAL::can($self, 'devpopup');

    my %params = %$params;
    foreach my $key (keys %params) {
        if (my $class = Scalar::Util::blessed($params{$key})) {
            $params{$key} = "Object:$class";
        }
    }

    require Data::Dumper;
    my $dumper = Data::Dumper->new([\%params]);
    $dumper->Varname('Params');
    $dumper->Indent(2);
    my $dump = $dumper->Dump();

    # Entity encode the output since it will be displayed on a webpage and we
    # want all HTML content rendered as text (borrowed from HTML::Entities)
    $dump =~ s/([^\n\r\t !\#\$%\(-;=?-~])/sprintf "&#x%X;", ord($1)/ge;

    $self->devpopup->add_report(
        title   => "TT params for $name",
        summary => "All template parameters passed to template $name",
        report  => qq{$dump},
    );

    return;
}


1;
__END__