Mini Shell

#============================================================= -*-perl-*-
#
# t/stash.t
#
# Template script testing (some elements of) the Template::Stash
#
# Written by Andy Wardley <abw@wardley.org>
#
# Copyright (C) 1996-2000 Andy Wardley.  All Rights Reserved.
# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd.
#
# This is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# $Id$
#
#========================================================================

use strict;
use lib qw( ./lib ../lib );
use Template::Constants qw( :status :debug );
use Template;
use Template::Stash;
use Template::Config;
use Template::Test;
$^W = 1;

my $DEBUG = grep(/-d/, @ARGV);
#$Template::Parser::DEBUG     = $DEBUG;
#$Template::Directive::PRETTY = $DEBUG;

#------------------------------------------------------------------------
# define some simple objects for testing
#------------------------------------------------------------------------

package ListObject;
package HashObject;

sub hello {
    my $self = shift;
    return "Hello $self->{ planet }";
}

sub goodbye {
    my $self = shift;
    return $self->no_such_method();
}

#------------------------------------------------------------------------
# Another object for tracking down a bug with DBIx::Class where TT is 
# causing the numification operator to be called.  Matt S Trout suggests
# we've got a truth test somewhere that should be a defined but that 
# doesn't appear to be the case...
# http://rt.cpan.org/Ticket/Display.html?id=23763
#------------------------------------------------------------------------

package Numbersome;

use overload 
    '""' => 'stringify',
    '0+' => 'numify', 
    fallback => 1;

sub new {
    my ($class, $text) = @_;
    bless \$text, $class;
}

sub numify {
    my $self = shift;
    return "FAIL: numified $$self";
}

sub stringify {
    my $self = shift;
    return "PASS: stringified $$self";
}

sub things {
    return [qw( foo bar baz )];
}

package GetNumbersome;

sub new {
    my ($class, $text) = @_;
    bless { }, $class;
}

sub num {
    Numbersome->new("from GetNumbersome");
}

#-----------------------------------------------------------------------
# another object without overloaded comparison.
# http://rt.cpan.org/Ticket/Display.html?id=24044
#-----------------------------------------------------------------------

package CmpOverloadObject;

use overload ('cmp' => 'compare_overload', '<=>', 'compare_overload');

sub new { bless {}, shift };

sub hello {
    return "Hello";
}

sub compare_overload {
    die "Mayhem!";
}

package main;
    

$Template::Config::STASH = 'Template::Stash';

my $count = 20;
my $data = {
    foo => 10,
    bar => {
        baz => 20,
    },
    baz => sub {
        return {
            boz => ($count += 10),
            biz => (shift || '<undef>'),
        };
    },
    obj => bless({
        name => 'an object',
    }, 'AnObject'),
    bop => sub { return ( bless ({ name => 'an object' }, 'AnObject') ) }, 
    hashobj => bless({ planet => 'World' }, 'HashObject'),
    listobj => bless([10, 20, 30], 'ListObject'),
    num     => Numbersome->new("Numbersome"),
    getnum  => GetNumbersome->new,
    cmp_ol  => CmpOverloadObject->new(),
    clean   => sub {
        my $error = shift;
        $error =~ s/(\s*\(.*?\))?\s+at.*$//;
        return $error;
    },
};

my $stash = Template::Stash->new($data);

match( $stash->get('foo'), 10 );
match( $stash->get([ 'bar', 0, 'baz', 0 ]), 20 );
match( $stash->get('bar.baz'), 20 );
match( $stash->get('bar(10).baz'), 20 );
match( $stash->get('baz.boz'), 30 );
match( $stash->get('baz.boz'), 40 );
match( $stash->get('baz.biz'), '<undef>' );
match( $stash->get('baz(50).biz'), '<undef>' );   # args are ignored

$stash->set( 'bar.buz' => 100 );
match( $stash->get('bar.buz'), 100 );

# test the dotop() method
match( $stash->dotop({ foo => 10 }, 'foo'), 10 );


my $ttlist = [
    'default' => Template->new(),
    'warn'    => Template->new(DEBUG => DEBUG_UNDEF, DEBUG_FORMAT => ''),
];

test_expect(\*DATA, $ttlist, $data);

__DATA__
-- test --
a: [% a %]
-- expect --
a: 

-- test --
-- use warn --
[% TRY; a; CATCH; "ERROR: $error"; END %]
-- expect --
ERROR: undef error - a is undefined

-- test --
-- use default --
[% myitem = 'foo' -%]
1: [% myitem %]
2: [% myitem.item %]
3: [% myitem.item.item %]
-- expect --
1: foo
2: foo
3: foo

-- test --
[% myitem = 'foo' -%]
[% "* $item\n" FOREACH item = myitem -%]
[% "+ $item\n" FOREACH item = myitem.list %]
-- expect --
* foo
+ foo

-- test --
[% myitem = 'foo' -%]
[% myitem.hash.value %]
-- expect --
foo

-- test --
[% myitem = 'foo'
   mylist = [ 'one', myitem, 'three' ]
   global.mylist = mylist
-%]
[% mylist.item %]
0: [% mylist.item(0) %]
1: [% mylist.item(1) %]
2: [% mylist.item(2) %]
-- expect --
one
0: one
1: foo
2: three

-- test --
[% "* $item\n" FOREACH item = global.mylist -%]
[% "+ $item\n" FOREACH item = global.mylist.list -%]
-- expect --
* one
* foo
* three
+ one
+ foo
+ three

-- test --
[% global.mylist.push('bar');
   "* $item.key => $item.value\n" FOREACH item = global.mylist.hash -%]
-- expect --
* one => foo
* three => bar

-- test --
[% myhash = { msg => 'Hello World', things => global.mylist, a => 'alpha' };
   global.myhash = myhash 
-%]
* [% myhash.item('msg') %]
-- expect --
* Hello World

-- test --
[% global.myhash.delete('things') -%]
keys: [% global.myhash.keys.sort.join(', ') %]
-- expect --
keys: a, msg

-- test --
[% "* $item\n" 
    FOREACH item IN global.myhash.items.sort -%]
-- expect --
* a
* alpha
* Hello World
* msg

-- test --
[% items = [ 'foo', 'bar', 'baz' ];
   take  = [ 0, 2 ];
   slice = items.$take;
   slice.join(', ');
%]
-- expect --
foo, baz

-- test --
[% items = {
    foo = 'one',
    bar = 'two',
    baz = 'three'
   }
   take  = [ 'foo', 'baz' ];
   slice = items.$take;
   slice.join(', ');
%]
-- expect --
one, three

-- test --
[% items = {
    foo = 'one',
    bar = 'two',
    baz = 'three'
   }
   keys = items.keys.sort;
   items.${keys}.join(', ');
%]
-- expect --
two, three, one


-- test --
[% obj.name %]
-- expect --
an object

-- test --
[% obj.name.list.first %]
-- expect --
an object

-- test --
[% obj.items.first %]
-- expect --
name

-- test --
[% obj.items.1 %]
-- expect --
an object

-- test --
[% bop.first.name %]
-- expect --
an object

-- test --
[% listobj.0 %] / [% listobj.first %]
-- expect --
10 / 10

-- test --
[% listobj.2 %] / [% listobj.last %]
-- expect --
30 / 30

-- test --
[% listobj.join(', ') %]
-- expect --
10, 20, 30

-- test --
=[% size %]=
-- expect --
==

-- test --
[% foo = { "one" = "bar" "" = "empty" } -%]
foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]}
setting foo.one to baz
[% fookey = "one" foo.$fookey = "baz" -%]
foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]}
setting foo."" to quux
[% fookey = "" foo.$fookey = "full" -%]
foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]}
--expect --
foo is { "" = "empty" "one" = "bar" }
setting foo.one to baz
foo is { "" = "empty" "one" = "baz" }
setting foo."" to quux
foo is { "" = "full" "one" = "baz" }


# test Dave Howorth's patch (v2.15) which makes the stash more strict
# about what it considers to be a missing method error

-- test --
[% hashobj.hello %]
-- expect --
Hello World

-- test --
[% TRY; hashobj.goodbye; CATCH; "ERROR: "; clean(error); END %]
-- expect --
ERROR: undef error - Can't locate object method "no_such_method" via package "HashObject"


#-----------------------------------------------------------------------
# try and pin down the numification bug
#-----------------------------------------------------------------------

-- test --
[% FOREACH item IN num.things -%]
* [% item %]
[% END -%]
-- expect --
* foo
* bar
* baz

-- test --
[% num %]
-- expect --
PASS: stringified Numbersome

-- test --
[% getnum.num %]
-- expect --
PASS: stringified from GetNumbersome


# Exercise the object with the funky overloaded comparison

-- test --
[% cmp_ol.hello %]
-- expect --
Hello