1#============================================================= -*-perl-*- 2# t/object.t 3# 4# Template script testing code bindings to objects. 5# 6# Written by Andy Wardley <abw@kfs.org> 7# 8# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. 9# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. 10# 11# This is free software; you can redistribute it and/or modify it 12# under the same terms as Perl itself. 13# 14# $Id$ 15# 16#======================================================================== 17 18use strict; 19use lib qw( ./lib ../lib ); 20use Template::Exception; 21use Template::Test; 22$^W = 1; 23 24$Template::Test::DEBUG = 0; 25 26 27#------------------------------------------------------------------------ 28# definition of test object class 29#------------------------------------------------------------------------ 30 31package T1; 32sub new { 33 my $class = shift; 34 bless { @_ }, $class; 35} 36 37sub die { 38 die "barfed up\n"; 39} 40 41package TestObject; 42 43use vars qw( $AUTOLOAD ); 44 45sub new { 46 my ($class, $params) = @_; 47 $params ||= {}; 48 49 bless { 50 PARAMS => $params, 51 DAYS => [ qw( Monday Tuesday Wednesday Thursday 52 Friday Saturday Sunday ) ], 53 DAY => 0, 54 'public' => 314, 55 '.private' => 425, 56 '_hidden' => 537, 57 }, $class; 58} 59 60sub yesterday { 61 my $self = shift; 62 return "Love was such an easy game to play..."; 63} 64 65sub today { 66 my $self = shift; 67 return "Live for today and die for tomorrow."; 68} 69 70sub tomorrow { 71 my ($self, $dayno) = @_; 72 $dayno = $self->{ DAY }++ 73 unless defined $dayno; 74 $dayno %= 7; 75 return $self->{ DAYS }->[$dayno]; 76} 77 78sub belief { 79 my $self = shift; 80 my $b = join(' and ', @_); 81 $b = '<nothing>' unless length $b; 82 return "Oh I believe in $b."; 83} 84 85sub concat { 86 my $self = shift; 87 local $" = ', '; 88 $self->{ PARAMS }->{ args } = "ARGS: @_"; 89} 90 91sub _private { 92 my $self = shift; 93 die "illegal call to private method _private()\n"; 94} 95 96 97sub AUTOLOAD { 98 my ($self, @params) = @_; 99 my $name = $AUTOLOAD; 100 $name =~ s/.*:://; 101 return if $name eq 'DESTROY'; 102 103 my $value = $self->{ PARAMS }->{ $name }; 104 if (ref($value) eq 'CODE') { 105 return &$value(@params); 106 } 107 elsif (@params) { 108 return $self->{ PARAMS }->{ $name } = shift @params; 109 } 110 else { 111 return $value; 112 } 113} 114 115#------------------------------------------------------------------------ 116# another object for testing auto-stringification 117#------------------------------------------------------------------------ 118 119package Stringy; 120 121use overload '""' => 'stringify', fallback => 1; 122 123sub new { 124 my ($class, $text) = @_; 125 bless \$text, $class; 126} 127 128sub stringify { 129 my $self = shift; 130 return "stringified '$$self'"; 131} 132 133#------------------------------------------------------------------------ 134# Another object for tracking down a bug with DBIx::Class where TT is 135# causing the numification operator to be called. Matt S Trout suggests 136# we've got a truth test somewhere that should be a defined but that 137# doesn't appear to be the case... 138# http://rt.cpan.org/Ticket/Display.html?id=23763 139#------------------------------------------------------------------------ 140 141package Numbersome; 142 143use overload 144 '""' => 'stringify', 145 '0+' => 'numify', 146 fallback => 1; 147 148sub new { 149 my ($class, $text) = @_; 150 bless \$text, $class; 151} 152 153sub numify { 154 my $self = shift; 155 return "FAIL: numified $$self"; 156} 157 158sub stringify { 159 my $self = shift; 160 return "PASS: stringified $$self"; 161} 162 163sub things { 164 return [qw( foo bar baz )]; 165} 166 167package GetNumbersome; 168 169sub new { 170 my ($class, $text) = @_; 171 bless { }, $class; 172} 173 174sub num { 175 Numbersome->new("from GetNumbersome"); 176} 177 178#------------------------------------------------------------------------ 179# main 180#------------------------------------------------------------------------ 181 182package main; 183 184sub new { 185 my ($class, $text) = @_; 186 bless \$text, $class; 187} 188 189my $objconf = { 190 'a' => 'alpha', 191 'b' => 'bravo', 192 'w' => 'whisky', 193}; 194 195my $replace = { 196 thing => TestObject->new($objconf), 197 string => Stringy->new('Test String'), 198 t1 => T1->new(a => 10), 199 num => Numbersome->new("Numbersome"), 200 getnum => GetNumbersome->new, 201 %{ callsign() }, 202}; 203 204test_expect(\*DATA, { INTERPOLATE => 1 }, $replace); 205 206 207 208#------------------------------------------------------------------------ 209# test input 210#------------------------------------------------------------------------ 211 212__DATA__ 213# test method calling via autoload to get parameters 214[% thing.a %] [% thing.a %] 215[% thing.b %] 216$thing.w 217-- expect -- 218alpha alpha 219bravo 220whisky 221 222# ditto to set parameters 223-- test -- 224[% thing.c = thing.b -%] 225[% thing.c %] 226-- expect -- 227bravo 228 229-- test -- 230[% thing.concat = thing.b -%] 231[% thing.args %] 232-- expect -- 233ARGS: bravo 234 235-- test -- 236[% thing.concat(d) = thing.b -%] 237[% thing.args %] 238-- expect -- 239ARGS: delta, bravo 240 241-- test -- 242[% thing.yesterday %] 243[% thing.today %] 244[% thing.belief(thing.a thing.b thing.w) %] 245-- expect -- 246Love was such an easy game to play... 247Live for today and die for tomorrow. 248Oh I believe in alpha and bravo and whisky. 249 250-- test -- 251Yesterday, $thing.yesterday 252$thing.today 253${thing.belief('yesterday')} 254-- expect -- 255Yesterday, Love was such an easy game to play... 256Live for today and die for tomorrow. 257Oh I believe in yesterday. 258 259-- test -- 260[% thing.belief('fish' 'chips') %] 261[% thing.belief %] 262-- expect -- 263Oh I believe in fish and chips. 264Oh I believe in <nothing>. 265 266-- test -- 267${thing.belief('fish' 'chips')} 268$thing.belief 269-- expect -- 270Oh I believe in fish and chips. 271Oh I believe in <nothing>. 272 273-- test -- 274[% thing.tomorrow %] 275$thing.tomorrow 276-- expect -- 277Monday 278Tuesday 279 280-- test -- 281[% FOREACH [ 1 2 3 4 5 ] %]$thing.tomorrow [% END %]. 282-- expect -- 283Wednesday Thursday Friday Saturday Sunday . 284 285 286#------------------------------------------------------------------------ 287# test private methods do not get exposed 288#------------------------------------------------------------------------ 289-- test -- 290before[% thing._private %] mid [% thing._hidden %]after 291-- expect -- 292before mid after 293 294-- test -- 295[% key = '_private' -%] 296[[% thing.$key %]] 297-- expect -- 298[] 299 300-- test -- 301[% key = '.private' -%] 302[[% thing.$key = 'foo' %]] 303[[% thing.$key %]] 304-- expect -- 305[] 306[] 307 308#------------------------------------------------------------------------ 309# test auto-stringification 310#------------------------------------------------------------------------ 311 312-- test -- 313[% string.stringify %] 314-- expect -- 315stringified 'Test String' 316 317-- test -- 318[% string %] 319-- expect -- 320stringified 'Test String' 321 322-- test -- 323[% "-> $string <-" %] 324-- expect -- 325-> stringified 'Test String' <- 326 327-- test -- 328[% "$string" %] 329-- expect -- 330stringified 'Test String' 331 332-- test -- 333foo $string bar 334-- expect -- 335foo stringified 'Test String' bar 336 337-- test -- 338.[% t1.dead %]. 339-- expect -- 340.. 341 342-- test -- 343.[% TRY; t1.die; CATCH; error; END %]. 344-- expect -- 345.undef error - barfed up 346. 347 348 349#----------------------------------------------------------------------- 350# try and pin down the numification bug 351#----------------------------------------------------------------------- 352 353-- test -- 354[% FOREACH item IN num.things -%] 355* [% item %] 356[% END -%] 357-- expect -- 358* foo 359* bar 360* baz 361 362-- test -- 363[% num %] 364-- expect -- 365PASS: stringified Numbersome 366 367-- test -- 368[% getnum.num %] 369-- expect -- 370PASS: stringified from GetNumbersome 371 372