Skip to content
Newer
Older
100644 372 lines (300 sloc) 7.24 KB
3ebfa07 @abw Initial revision
authored Jun 25, 2000
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.
3e45060 @abw *** empty log message ***
authored Aug 6, 2000
9 # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd.
3ebfa07 @abw Initial revision
authored Jun 25, 2000
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
18 use strict;
6c54b0a @abw 2.03b
authored Jun 25, 2001
19 use lib qw( ./lib ../lib );
3ebfa07 @abw Initial revision
authored Jun 25, 2000
20 use Template::Exception;
21 use Template::Test;
22 $^W = 1;
23
24 $Template::Test::DEBUG = 0;
25
26
27 #------------------------------------------------------------------------
28 # definition of test object class
29 #------------------------------------------------------------------------
30
6c54b0a @abw 2.03b
authored Jun 25, 2001
31 package T1;
32 sub new {
33 my $class = shift;
34 bless { @_ }, $class;
35 }
36
37 sub die {
38 die "barfed up\n";
39 }
40
3ebfa07 @abw Initial revision
authored Jun 25, 2000
41 package TestObject;
42
43 use vars qw( $AUTOLOAD );
44
45 sub new {
46 my ($class, $params) = @_;
47 $params ||= {};
48
49 bless {
c942c1b @abw Version 2.15
authored May 26, 2006
50 PARAMS => $params,
51 DAYS => [ qw( Monday Tuesday Wednesday Thursday
52 Friday Saturday Sunday ) ],
53 DAY => 0,
d52480d @abw *** empty log message ***
authored Sep 12, 2000
54 'public' => 314,
c942c1b @abw Version 2.15
authored May 26, 2006
55 '.private' => 425,
56 '_hidden' => 537,
3ebfa07 @abw Initial revision
authored Jun 25, 2000
57 }, $class;
58 }
59
60 sub yesterday {
61 my $self = shift;
62 return "Love was such an easy game to play...";
63 }
64
65 sub today {
66 my $self = shift;
67 return "Live for today and die for tomorrow.";
68 }
69
70 sub tomorrow {
71 my ($self, $dayno) = @_;
72 $dayno = $self->{ DAY }++
73 unless defined $dayno;
74 $dayno %= 7;
75 return $self->{ DAYS }->[$dayno];
76 }
77
78 sub 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
3e45060 @abw *** empty log message ***
authored Aug 6, 2000
85 sub concat {
86 my $self = shift;
87 local $" = ', ';
88 $self->{ PARAMS }->{ args } = "ARGS: @_";
89 }
90
3ebfa07 @abw Initial revision
authored Jun 25, 2000
91 sub _private {
92 my $self = shift;
93 die "illegal call to private method _private()\n";
94 }
95
96
97 sub 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') {
c942c1b @abw Version 2.15
authored May 26, 2006
105 return &$value(@params);
3ebfa07 @abw Initial revision
authored Jun 25, 2000
106 }
107 elsif (@params) {
c942c1b @abw Version 2.15
authored May 26, 2006
108 return $self->{ PARAMS }->{ $name } = shift @params;
3ebfa07 @abw Initial revision
authored Jun 25, 2000
109 }
110 else {
c942c1b @abw Version 2.15
authored May 26, 2006
111 return $value;
3ebfa07 @abw Initial revision
authored Jun 25, 2000
112 }
113 }
114
6ddeb78 @abw added leak.t
authored Mar 22, 2001
115 #------------------------------------------------------------------------
116 # another object for testing auto-stringification
117 #------------------------------------------------------------------------
118
119 package Stringy;
120
dfe8b14 @abw version 2.10
authored Jul 24, 2003
121 use overload '""' => 'stringify', fallback => 1;
6ddeb78 @abw added leak.t
authored Mar 22, 2001
122
123 sub new {
124 my ($class, $text) = @_;
125 bless \$text, $class;
126 }
127
128 sub stringify {
129 my $self = shift;
130 return "stringified '$$self'";
131 }
132
ba784d4 @abw Added some extra tests to t/object.t to see if we can track down the …
authored Aug 6, 2008
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
141 package Numbersome;
142
143 use overload
144 '""' => 'stringify',
145 '0+' => 'numify',
146 fallback => 1;
147
148 sub new {
149 my ($class, $text) = @_;
150 bless \$text, $class;
151 }
152
153 sub numify {
154 my $self = shift;
155 return "FAIL: numified $$self";
156 }
157
158 sub stringify {
159 my $self = shift;
160 return "PASS: stringified $$self";
161 }
162
163 sub things {
164 return [qw( foo bar baz )];
165 }
166
167 package GetNumbersome;
168
169 sub new {
170 my ($class, $text) = @_;
171 bless { }, $class;
172 }
173
174 sub num {
175 Numbersome->new("from GetNumbersome");
176 }
3ebfa07 @abw Initial revision
authored Jun 25, 2000
177
178 #------------------------------------------------------------------------
179 # main
180 #------------------------------------------------------------------------
181
182 package main;
183
ba784d4 @abw Added some extra tests to t/object.t to see if we can track down the …
authored Aug 6, 2008
184 sub new {
185 my ($class, $text) = @_;
186 bless \$text, $class;
187 }
188
3ebfa07 @abw Initial revision
authored Jun 25, 2000
189 my $objconf = {
190 'a' => 'alpha',
191 'b' => 'bravo',
192 'w' => 'whisky',
193 };
194
195 my $replace = {
6ddeb78 @abw added leak.t
authored Mar 22, 2001
196 thing => TestObject->new($objconf),
197 string => Stringy->new('Test String'),
ba784d4 @abw Added some extra tests to t/object.t to see if we can track down the …
authored Aug 6, 2008
198 t1 => T1->new(a => 10),
199 num => Numbersome->new("Numbersome"),
200 getnum => GetNumbersome->new,
3e45060 @abw *** empty log message ***
authored Aug 6, 2000
201 %{ callsign() },
3ebfa07 @abw Initial revision
authored Jun 25, 2000
202 };
203
204 test_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 --
218 alpha alpha
219 bravo
220 whisky
221
222 # ditto to set parameters
223 -- test --
224 [% thing.c = thing.b -%]
225 [% thing.c %]
226 -- expect --
227 bravo
228
229 -- test --
3e45060 @abw *** empty log message ***
authored Aug 6, 2000
230 [% thing.concat = thing.b -%]
231 [% thing.args %]
232 -- expect --
233 ARGS: bravo
234
235 -- test --
236 [% thing.concat(d) = thing.b -%]
237 [% thing.args %]
238 -- expect --
239 ARGS: delta, bravo
240
241 -- test --
3ebfa07 @abw Initial revision
authored Jun 25, 2000
242 [% thing.yesterday %]
243 [% thing.today %]
244 [% thing.belief(thing.a thing.b thing.w) %]
245 -- expect --
246 Love was such an easy game to play...
247 Live for today and die for tomorrow.
248 Oh I believe in alpha and bravo and whisky.
249
250 -- test --
251 Yesterday, $thing.yesterday
252 $thing.today
253 ${thing.belief('yesterday')}
254 -- expect --
255 Yesterday, Love was such an easy game to play...
256 Live for today and die for tomorrow.
257 Oh I believe in yesterday.
258
259 -- test --
260 [% thing.belief('fish' 'chips') %]
261 [% thing.belief %]
262 -- expect --
263 Oh I believe in fish and chips.
264 Oh I believe in <nothing>.
265
266 -- test --
267 ${thing.belief('fish' 'chips')}
268 $thing.belief
269 -- expect --
270 Oh I believe in fish and chips.
271 Oh I believe in <nothing>.
272
273 -- test --
274 [% thing.tomorrow %]
275 $thing.tomorrow
276 -- expect --
277 Monday
278 Tuesday
279
280 -- test --
281 [% FOREACH [ 1 2 3 4 5 ] %]$thing.tomorrow [% END %].
282 -- expect --
283 Wednesday Thursday Friday Saturday Sunday .
284
e39913f @abw *** empty log message ***
authored Jul 10, 2000
285
3ebfa07 @abw Initial revision
authored Jun 25, 2000
286 #------------------------------------------------------------------------
287 # test private methods do not get exposed
288 #------------------------------------------------------------------------
289 -- test --
d52480d @abw *** empty log message ***
authored Sep 12, 2000
290 before[% thing._private %] mid [% thing._hidden %]after
3ebfa07 @abw Initial revision
authored Jun 25, 2000
291 -- expect --
d52480d @abw *** empty log message ***
authored Sep 12, 2000
292 before mid after
3ebfa07 @abw Initial revision
authored Jun 25, 2000
293
294 -- test --
295 [% key = '_private' -%]
d52480d @abw *** empty log message ***
authored Sep 12, 2000
296 [[% thing.$key %]]
3ebfa07 @abw Initial revision
authored Jun 25, 2000
297 -- expect --
d52480d @abw *** empty log message ***
authored Sep 12, 2000
298 []
3ebfa07 @abw Initial revision
authored Jun 25, 2000
299
300 -- test --
301 [% key = '.private' -%]
d52480d @abw *** empty log message ***
authored Sep 12, 2000
302 [[% thing.$key = 'foo' %]]
303 [[% thing.$key %]]
3e45060 @abw *** empty log message ***
authored Aug 6, 2000
304 -- expect --
d52480d @abw *** empty log message ***
authored Sep 12, 2000
305 []
306 []
3ebfa07 @abw Initial revision
authored Jun 25, 2000
307
6ddeb78 @abw added leak.t
authored Mar 22, 2001
308 #------------------------------------------------------------------------
309 # test auto-stringification
310 #------------------------------------------------------------------------
311
312 -- test --
313 [% string.stringify %]
314 -- expect --
315 stringified 'Test String'
316
317 -- test --
318 [% string %]
319 -- expect --
320 stringified 'Test String'
321
322 -- test --
323 [% "-> $string <-" %]
324 -- expect --
325 -> stringified 'Test String' <-
326
327 -- test --
328 [% "$string" %]
329 -- expect --
330 stringified 'Test String'
331
332 -- test --
333 foo $string bar
334 -- expect --
335 foo stringified 'Test String' bar
336
6c54b0a @abw 2.03b
authored Jun 25, 2001
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 .
ba784d4 @abw Added some extra tests to t/object.t to see if we can track down the …
authored Aug 6, 2008
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 --
365 PASS: stringified Numbersome
366
367 -- test --
368 [% getnum.num %]
369 -- expect --
370 PASS: stringified from GetNumbersome
371
Something went wrong with that request. Please try again.