Skip to content
Newer
Older
100644 272 lines (221 sloc) 5.02 KB
6eca530 @abw original version
authored Aug 21, 2001
1 #============================================================= -*-perl-*-
2 #
3 # t/tiedhash.t
4 #
5 # Template script testing variable via a tied hash.
6 #
7 # Written by Andy Wardley <abw@kfs.org>
8 #
9 # Copyright (C) 1996-2001 Andy Wardley. All Rights Reserved.
10 # Copyright (C) 1998-2001 Canon Research Centre Europe Ltd.
11 #
12 # This is free software; you can redistribute it and/or modify it
13 # under the same terms as Perl itself.
14 #
15 # $Id$
16 #
17 #========================================================================
18
19 use strict;
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
20 use warnings;
6eca530 @abw original version
authored Aug 21, 2001
21 use lib qw( blib/lib blib/arch lib ../blib/lib ../blib/arch ../lib );
22 use Template::Test;
5c224d1 @abw * applied Lyle's patch to not use XS Stash (load via require instead)
authored Jan 24, 2002
23 use Template::Stash;
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
24 our $DEBUG = grep(/-d/, @ARGV);
6eca530 @abw original version
authored Aug 21, 2001
25
92ccaa1 @abw developer release 2.05b
authored Aug 21, 2001
26 eval {
039bd37 @abw * fixed numerous tests to report proper reason for skipping via skip_…
authored Aug 12, 2002
27 require Template::Stash::XS;
92ccaa1 @abw developer release 2.05b
authored Aug 21, 2001
28 };
29 if ($@) {
039bd37 @abw * fixed numerous tests to report proper reason for skipping via skip_…
authored Aug 12, 2002
30 warn $@;
31 skip_all('cannot load Template::Stash::XS');
92ccaa1 @abw developer release 2.05b
authored Aug 21, 2001
32 }
33
6eca530 @abw original version
authored Aug 21, 2001
34 #print "stash: $Template::Config::STASH\n";
35 #$Template::Config::STASH = 'Template::Stash::XS';
36
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
37 our $STORE_PREFIX = '';
38 our $FETCH_PREFIX = '';
39
6eca530 @abw original version
authored Aug 21, 2001
40 #------------------------------------------------------------------------
41 package My::Tied::Hash;
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
42 use Tie::Hash;
43 use base 'Tie::StdHash';
44
45 sub FETCH {
46 my ($hash, $key) = @_;
47 print STDERR "FETCH($key)\n" if $main::DEBUG;
48 my $val = $hash->{ $key };
49 return $val ? (ref $val ? $val : "$main::FETCH_PREFIX$val") : undef;
6eca530 @abw original version
authored Aug 21, 2001
50 }
51
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
52 sub STORE {
53 my ($hash, $key, $val) = @_;
54 print STDERR "STORE($key, $val)\n" if $main::DEBUG;
55 $hash->{ $key } = ref $val ? $val : "$main::STORE_PREFIX$val";
6eca530 @abw original version
authored Aug 21, 2001
56 }
57
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
58 #------------------------------------------------------------------------
59 package My::Tied::List;
60 use Tie::Array;
61 use base 'Tie::StdArray';
62
6eca530 @abw original version
authored Aug 21, 2001
63 sub FETCH {
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
64 my ($list, $n) = @_;
65 print STDERR "FETCH from list [$n]\n" if $main::DEBUG;
66 my $val = $list->[ $n ];
67 return $val ? (ref $val ? $val : "$main::FETCH_PREFIX$val") : undef;
6eca530 @abw original version
authored Aug 21, 2001
68 }
69
70 sub STORE {
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
71 my ($list, $n, $val) = @_;
72 print STDERR "STORE to list [$n => $val]\n" if $main::DEBUG;
73 $list->[$n] = ref $val ? $val : "$main::STORE_PREFIX$val";
6eca530 @abw original version
authored Aug 21, 2001
74 }
75
76 #------------------------------------------------------------------------
77 package main;
78
79
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
80 # setup a tied hash and a tied list
81 my @list;
82 tie @list, 'My::Tied::List';
83 push(@list, 10, 20, 30);
84
85 my %hash = (a => 'alpha');
86 tie %hash, 'My::Tied::Hash';
87 $hash{ a } = 'alpha';
88 $hash{ b } = 'bravo';
89 $hash{ zero } = 0;
90 $hash{ one } = 1;
6eca530 @abw original version
authored Aug 21, 2001
91
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
92 # now turn on the prefixes so we can track items going in
93 # and out of the tied hash/list
94 $FETCH_PREFIX = 'FETCH:';
95 $STORE_PREFIX = 'STORE:';
96
97 my $data = {
98 hash => \%hash,
99 list => \@list,
100 };
101 my $stash_perl = Template::Stash->new($data);
102 my $stash_xs = Template::Stash::XS->new($data);
6eca530 @abw original version
authored Aug 21, 2001
103 my $tt = [
104 perl => Template->new( STASH => $stash_perl ),
105 xs => Template->new( STASH => $stash_xs ),
106 ];
107 test_expect(\*DATA, $tt);
108
109 __DATA__
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
110
111 #------------------------------------------------------------------------
112 # first try with the Perl stash
113 #------------------------------------------------------------------------
114
115 # hash tests
116
6eca530 @abw original version
authored Aug 21, 2001
117 -- test --
118 [% hash.a %]
119 -- expect --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
120 FETCH:alpha
6eca530 @abw original version
authored Aug 21, 2001
121
122 -- test --
123 [% hash.b %]
124 -- expect --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
125 FETCH:bravo
6eca530 @abw original version
authored Aug 21, 2001
126
127 -- test --
128 ready
129 set:[% hash.c = 'cosmos' %]
130 go:[% hash.c %]
131 -- expect --
132 ready
133 set:
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
134 go:FETCH:STORE:cosmos
6eca530 @abw original version
authored Aug 21, 2001
135
136 -- test --
137 [% hash.foo.bar = 'one' -%]
138 [% hash.foo.bar %]
139 -- expect --
140 one
141
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
142 # list tests
143
144 -- test --
145 [% list.0 %]
146 -- expect --
147 FETCH:10
148
149 -- test --
150 [% list.first %]-[% list.last %]
151 -- expect --
152 FETCH:10-FETCH:30
153
154 -- test --
155 [% list.push(40); list.last %]
156 -- expect --
157 FETCH:40
158
159 -- test --
160 [% list.4 = 50; list.4 %]
161 -- expect --
162 FETCH:STORE:50
163
164
165 #------------------------------------------------------------------------
166 # now try using the XS stash
167 #------------------------------------------------------------------------
168
169 # hash tests
170
6eca530 @abw original version
authored Aug 21, 2001
171 -- test --
172 -- use xs --
173 [% hash.a %]
174 -- expect --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
175 FETCH:alpha
6eca530 @abw original version
authored Aug 21, 2001
176
177 -- test --
178 [% hash.b %]
179 -- expect --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
180 FETCH:bravo
6eca530 @abw original version
authored Aug 21, 2001
181
182 -- test --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
183 [% hash.c = 'crazy'; hash.c %]
6eca530 @abw original version
authored Aug 21, 2001
184 -- expect --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
185 FETCH:STORE:crazy
186
187 -- test --
188 [% DEFAULT hash.c = 'more crazy'; hash.c %]
189 -- expect --
190 FETCH:STORE:crazy
6eca530 @abw original version
authored Aug 21, 2001
191
192 -- test --
193 [% hash.wiz = 'woz' -%]
194 [% hash.wiz %]
195 -- expect --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
196 FETCH:STORE:woz
6eca530 @abw original version
authored Aug 21, 2001
197
198 -- test --
199 [% DEFAULT hash.zero = 'nothing';
200 hash.zero
201 %]
202 -- expect --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
203 FETCH:STORE:nothing
6eca530 @abw original version
authored Aug 21, 2001
204
205 -- test --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
206 before: [% hash.one %]
207 after: [% DEFAULT hash.one = 'solitude';
6eca530 @abw original version
authored Aug 21, 2001
208 hash.one
209 %]
210 -- expect --
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
211 before: FETCH:1
212 after: FETCH:1
213
214 -- test --
215 [% hash.foo = 10; hash.foo = 20; hash.foo %]
216 -- expect --
217 FETCH:STORE:20
218
219 # this test should create an intermediate hash
220 -- test --
221 [% DEFAULT hash.person = { };
222 hash.person.name = 'Arthur Dent';
223 hash.person.email = 'dent@tt2.org';
224 -%]
225 name: [% hash.person.name %]
226 email: [% hash.person.email %]
227 -- expect --
228 name: Arthur Dent
229 email: dent@tt2.org
230
231
232 # list tests
233
234 -- test --
235 [% list.0 %]
236 -- expect --
237 FETCH:10
92ccaa1 @abw developer release 2.05b
authored Aug 21, 2001
238
96a8e36 @abw * added more tests for tied hashes and lists
authored Jan 29, 2006
239 -- test --
240 [% list.first %]-[% list.last %]
241 -- expect --
242 FETCH:10-FETCH:STORE:50
243
244 -- test --
245 [% list.push(60); list.last %]
246 -- expect --
247 FETCH:60
248
249 -- test --
250 [% list.5 = 70; list.5 %]
251 -- expect --
252 FETCH:STORE:70
253
254 -- test --
255 [% DEFAULT list.5 = 80; list.5 %]
256 -- expect --
257 FETCH:STORE:70
258
259 -- test --
260 [% list.10 = 100; list.10 %]
261 -- expect --
262 FETCH:STORE:100
263
264 -- test --
265 [% stuff = [ ];
266 stuff.0 = 'some stuff';
267 stuff.0
268 -%]
269 -- expect --
270 some stuff
92ccaa1 @abw developer release 2.05b
authored Aug 21, 2001
271
Something went wrong with that request. Please try again.