view release on metacpan or  search on metacpan

t/7_template_00_base.t  view on Meta::CPAN

# -*- Mode: Perl; -*-

=head1 NAME

7_template_00_base.t - Test the basic language functionality of Template::Parse::CET - based on Template::Alloy

=cut

use strict;
use vars qw($module $is_tt);
use Template;
use Template::Parser::CET;

BEGIN {
    $module = 'Template';         #real    0m2.133s #user    0m1.108s #sys     0m0.024s
    $is_tt = 0;
    #$is_tt = 1;
    if ($is_tt) { Template::Parser::CET->deactivate } else { Template::Parser::CET->activate }
};

use Test::More tests => ! $is_tt ? 895 : 631;
use constant test_taint => 0 && eval { require Taint::Runtime };

Taint::Runtime::taint_start() if test_taint;

###----------------------------------------------------------------###

sub process_ok { # process the value and say if it was ok
    my $str  = shift;
    my $test = shift;
    my $vars = shift || {};
    my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || [];
    my $obj  = shift || $module->new(@$conf); # new object each time
    my $out  = '';
    my $line = (caller)[2];
    delete $vars->{'tt_config'};

    Taint::Runtime::taint(\$str) if test_taint;

    Template::Parser::CET->add_top_level_functions($vars);
    $obj->process(\$str, $vars, \$out);
    my $ok = ref($test) ? $out =~ $test : $out eq $test;
    if ($ok) {
        ok(1, "Line $line   \"$str\" => \"$out\"");
        return $obj;
    } else {
        ok(0, "Line $line   \"$str\"");
        warn "# Was:\n$out\n# Should've been:\n$test\n";
        print $obj->error if $obj->can('error');
        print Template::Alloy->dump_parse_tree(\$str) if ! $is_tt;
        exit;
    }
}

###----------------------------------------------------------------###

### set up some dummy packages for various tests
{
    package MyTestPlugin::Foo;
    $INC{'MyTestPlugin/Foo.pm'} = $0;
    sub load { $_[0] }
    sub new {
        my $class   = shift;
        my $context = shift;  # note the plugin style object that needs to shift off context
        my $args    = shift || {};
        return bless $args, $class;
    }
    sub bar { my $self = shift; return join('', map {"$_$self->{$_}"} sort keys %$self) }
    sub seven { 7 }
    sub many { return 1, 2, 3 }
    sub echo { my $self = shift; $_[0] }
}
{
    package Foo2;
    $INC{'Foo2.pm'} = $0;
    use base qw(MyTestPlugin::Foo);
    use vars qw($AUTOLOAD);
    sub new {
        my $class   = shift;
        my $args    = shift || {}; # note - no plugin context
        return bless $args, $class;
    }
    sub leave {}      # hacks to allow tt to do the plugins passed via PLUGINS
    sub delocalise {} # hacks to allow tt to do the plugins passed via PLUGINS
}

my $obj = Foo2->new;
my $vars;
my $stash = {foo => 'Stash', bingo => 'bango'};
$stash = Template::Stash->new($stash) if eval{require Template::Stash};

###----------------------------------------------------------------###
print "### GET ##############################################################\n";

process_ok("[% foo %]" => "");