re-work coupons to allow multiple coupon types
[bse.git] / site / cgi-bin / modules / Squirrel / Template / Expr / WrapScalar.pm
CommitLineData
4d26c6e3
TC
1package Squirrel::Template::Expr::WrapScalar;
2use strict;
3use base qw(Squirrel::Template::Expr::WrapBase);
4
b55d4af1 5our $VERSION = "1.011";
4d26c6e3
TC
6
7sub _do_length {
8 my ($self, $args) = @_;
9
10 @$args == 0
11 or die [ error => "scalar.length takes no parameters" ];
12
13 return length $self->[0];
14}
15
16sub _do_upper {
17 my ($self, $args) = @_;
18
19 @$args == 0
20 or die [ error => "scalar.upper takes no parameters" ];
21
22 return uc $self->[0];
23}
24
25sub _do_lower {
26 my ($self, $args) = @_;
27
28 @$args == 0
29 or die [ error => "scalar.lower takes no parameters" ];
30
31 return lc $self->[0];
32}
33
34sub _do_defined {
35 my ($self, $args) = @_;
36
37 @$args == 0
38 or die [ error => "scalar.defined takes no parameters" ];
39
40 return defined $self->[0];
41}
42
43sub _do_trim {
44 my ($self, $args) = @_;
45
46 @$args == 0
7b4c11f9 47 or die [ error => "scalar.trim takes no parameters" ];
4d26c6e3
TC
48
49 my $copy = $self->[0];
50 $copy =~ s/\A\s+//;
51 $copy =~ s/\s+\z//;
52
53 return $copy;
54}
55
2470cfc2
TC
56sub _do_substring {
57 my ($self, $args) = @_;
58
59 @$args == 1 || @$args == 2
60 or die [ error => "scalar.substring takes 1 or 2 parameters" ];
61
62 return @$args == 1
63 ? substr($self->[0], $args->[0])
64 : substr($self->[0], $args->[0], $args->[1]);
65}
66
4d26c6e3
TC
67sub _do_split {
68 my ($self, $args) = @_;
69
70 my $split = @$args ? $args->[0] : " ";
71 my $limit = @$args >= 2 ? $args->[1] : 0;
72
73 return [ split $split, $self->[0], $limit ];
74}
75
76sub _do_format {
77 my ($self, $args) = @_;
78
79 @$args == 1
80 or die [ error => "scalar.format takes one parameter" ];
81
82 return sprintf($args->[0], $self->[0]);
83}
84
a96f9b25
TC
85sub _do_evaltag {
86 my ($self, $args) = @_;
87
88 @$args == 0
89 or die [ error => "scalar.evaltags takes no parameters" ];
90
91 my ($func, $tag_args) = split ' ', $self->[0], 2;
92
93 return $self->[1]->perform($self->[2], $func, $tag_args, $self->[0]);
94}
95
7b4c11f9
TC
96sub _do_quotemeta {
97 my ($self, $args) = @_;
98
99 @$args == 0
100 or die [ error => "scalar.quotemeta takes no parameters" ];
101
102 return quotemeta($self->[0]);
103}
104
105sub _do_contains {
106 my ($self, $args) = @_;
107
108 @$args == 1
109 or die [ error => "scalar.contains requires one parameter" ];
110
111 return index($self->[0], $args->[0], @$args > 1 ? $args->[1] : 0) >= 0;
112}
113
114sub _do_index {
115 my ($self, $args) = @_;
116
117 @$args == 1 || @$args == 2
118 or die [ error => "scalar.index requires one or two parameters" ];
119
120 return index($self->[0], $args->[0], @$args > 1 ? $args->[1] : 0);
121}
122
123sub _do_rindex {
124 my ($self, $args) = @_;
125
126 @$args == 1 || @$args == 2
127 or die [ error => "scalar.rindex requires one or two parameters" ];
128
129 return @$args > 1
130 ? rindex($self->[0], $args->[0], $args->[1])
131 : rindex($self->[0], $args->[0]);
132}
133
134sub _do_chr {
135 my ($self, $args) = @_;
136
137 @$args == 0
138 or die [ error => "scalar.chr takes no parameters" ];
139
140 return chr($self->[0]);
141}
142
143sub _do_int {
144 my ($self, $args) = @_;
145
146 @$args == 0
147 or die [ error => "scalar.int takes no parameters" ];
148
149 return int($self->[0]);
150}
151
152sub _do_rand {
153 my ($self, $args) = @_;
154
155 @$args == 0
156 or die [ error => "scalar.rand takes no parameters" ];
157
158 return rand($self->[0]);
159}
160
161sub _do_abs {
162 my ($self, $args) = @_;
163
164 @$args == 0
165 or die [ error => "scalar.abs takes no parameters" ];
166
167 return abs($self->[0]);
168}
169
170sub _do_floor {
171 my ($self, $args) = @_;
172
173 @$args == 0
174 or die [ error => "scalar.floor takes no parameters" ];
175
176 require POSIX;
177
178 return POSIX::floor($self->[0]);
179}
180
181sub _do_ceil {
182 my ($self, $args) = @_;
183
184 @$args == 0
185 or die [ error => "scalar.ceil takes no parameters" ];
186
187 require POSIX;
188
189 return POSIX::ceil($self->[0]);
190}
191
2d96abcc
TC
192sub _do_is_list {
193 return 0;
194}
195
196sub _do_is_hash {
197 return 0;
198}
199
dd94dd8e
TC
200sub _do_is_code {
201 my ($self) = @_;
202
203 require Scalar::Util;
204 return ref($self->[0]) && Scalar::Util::reftype($self->[0]) eq "CODE";
205}
206
d64aa8a6
TC
207sub _do_replace {
208 my ($self, $args) = @_;
209
210 @$args == 2 || @$args == 3
211 or die [ error => "scalar.replace takes two or three parameters" ];
212
213 my ($re, $with, $global) = @$args;
214 my $str = $self->[0];
105ac913
TC
215 my $eval = $self->expreval;
216 my $with_code =
217 ref $with
218 ? sub {
219 $eval->call_function($with, [ _make_match($str) ])
220 }
221 : sub {
222 # yes, this sucks
223 my @out = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
224 defined or $_ = '' for @out;
225 my $tmp = $with;
226 {
227 $tmp =~ s/\$([1-9\$])/
228 $1 eq '$' ? '$' : $out[$1-1] /ge;
229 }
230 $tmp;
231 };
d64aa8a6
TC
232
233 if ($global) {
105ac913 234 $str =~ s{$re}{ $with_code->() }ge;
d64aa8a6
TC
235 }
236 else {
105ac913 237 $str =~ s{$re}{ $with_code->() }e;
d64aa8a6
TC
238 }
239
240 return $str;
241}
242
2470cfc2
TC
243sub _do_match {
244 my ($self, $args) = @_;
245
246 @$args == 1
b55d4af1 247 or die [ error => "scalar.match requires one parameter" ];
2470cfc2
TC
248
249 $self->[0] =~ $args->[0]
250 or return undef;
251
105ac913
TC
252 return _make_match($self->[0]);
253}
254
255sub _make_match {
256 my %match;
257 tie %match, 'Squirrel::Template::Expr::WrapScalar::Match', $_[0], \@-, \@+, \%-, \%+;
258
259 \%match;
2470cfc2
TC
260}
261
1c78dcb4
TC
262sub _do_escape {
263 my ($self, $args) = @_;
264
265 @$args == 1
266 or die [ error => "scalar.escape requires one parameter" ];
267 return $self->[1]->format($self->[0], $args->[0]);
268}
269
4d26c6e3
TC
270sub call {
271 my ($self, $method, $args) = @_;
272
273 my $real_method = "_do_$method";
274 if ($self->can($real_method)) {
275 return $self->$real_method($args);
276 }
277 die [ error => "No method $method for scalars" ];
278}
279
105ac913
TC
280package Squirrel::Template::Expr::WrapScalar::Match;
281use base 'Tie::Hash';
282
283sub TIEHASH {
284 my ($class, $text, $starts, $ends, $nstarts, $nends) = @_;
285
286 bless
287 {
288 text => $text,
289 starts => [ @$starts ],
290 ends => [ @$ends ],
291 nstarts => +{ %$nstarts },
292 nends => +{ %$nends },
293 keys => +{ map {; $_ => 1 } qw(text start end length subexpr named) },
294 };
295}
296
297sub FETCH {
298 my ($self, $name) = @_;
299
300 return substr($self->{text}, $self->{starts}[0], $self->{ends}[0] - $self->{starts}[0])
301 if $name eq 'text';
302 return $self->{starts}[0] if $name eq 'start';
303 return $self->{ends}[0] if $name eq 'end';
304 return $self->{ends}[0] - $self->{starts}[0] if $name eq 'length';
305 if ($name eq 'subexpr') {
306 my @subexpr;
307 tie @subexpr, 'Squirrel::Template::Expr::WrapScalar::Match::Subexpr',
308 $self->{starts}, $self->{ends}, $self->{text};
309 return \@subexpr;
310 }
311 if ($name eq 'named') {
312 my %named;
313 tie %named, 'Squirrel::Template::Expr::WrapScalar::Match::Named', $self->{nstarts}, $self->{nends};
314 return \%named;
315 }
316 return undef;
317}
318
319sub EXISTS {
320 my ($self, $name) = @_;
321
322 return exists $self->{keys}{$name};
323}
324
325sub FIRSTKEY {
326 my ($self) = @_;
327
328 keys %{$self->{keys}};
329
330 each %{$self->{keys}};
331}
332
333sub NEXTKEY {
334 my ($self) = @_;
335
336 each %{$self->{keys}};
337}
338
339package Squirrel::Template::Expr::WrapScalar::Match::Subexpr;
340use base 'Tie::Array';
341
342sub TIEARRAY {
343 my ($class, $starts, $ends, $text) = @_;
344
345 bless [ $starts, $ends, $text ], $class;
346}
347
348sub FETCH {
349 my ($self, $index) = @_;
350
351 $index >= 0 && $index < $#{$self->[0]}
352 or return undef;
353
354 return
355 +{
356 start => $self->[0][$index+1],
357 end => $self->[1][$index+1],
358 length => $self->[1][$index+1] - $self->[0][$index+1],
359 text => substr($self->[2], $self->[0][$index+1],
360 $self->[1][$index+1] - $self->[0][$index+1]),
361 };
362}
363
364sub EXISTS {
365 my ($self, $index) = @_;
366
367 $index >= 0 && $index < $#{$self->[0]}
368 or return !1;
369
370 return !0;
371}
372
373sub FETCHSIZE {
374 my ($self) = @_;
375
376 return @{$self->[0]} - 1;
377}
378
379package Squirrel::Template::Expr::WrapScalar::Match::Named;
380use base 'Tie::Hash';
381
382sub TIEHASH {
383 my ($class, $nstarts, $nends) = @_;
384
385 bless [ $nstarts, $nends ], $class;
386}
387
388sub FETCH {
389 my ($self, $name) = @_;
390
391 defined $self->[0]{$name}
392 or return undef;
393
394 return
395 +{
396 text => $self->[1]{$name},
397 };
398}
399
400sub EXISTS {
401 my ($self, $name) = @_;
402
403 defined $self->[0]{$name}
404 or return !1;
405
406 return !0;
407}
408
409sub FIRSTKEY {
410 my ($self) = @_;
411
412 keys %{$self->[0]}; # reset
413
414 each %{$self->[0]};
415}
416
417sub NEXTKEY {
418 my ($self) = @_;
419
420 each %{$self->[0]};
421}
422
4d26c6e3 4231;
6c291231
TC
424
425=head1 NAME
426
427Squirrel::Template::Expr::WrapScalar - provide methods for scalars
428
429=head1 SYNOPSIS
430
431 len = somescalar.length;
432 upper = somescalar.upper;
433 lower = somescalar.lower;
434 defd = somescalar.defined;
435 trimmed = somescalar.trim;
436 split = somescalar.split;
437 split = somescalar.split(":");
438 split = somescalar.split(":", count);
439 formatted = somescalar.format("%05d");
e512ca55 440 value = somescalar.evaltag
7b4c11f9
TC
441 quoted = somescalar.quotemeta
442 contains = somescalar.contains("foo")
443 pos = somescalar.index("foo")
444 pos = somescalar.index("foo", 5)
445 pos = somescalar.rindex("foo")
446 pos = somescalar.rindex("foo", 5)
447 char = somenumber.chr
448 int = somenumber.int
449 random = somenumber.rand
450 abs = (-10).abs # 10
451 floor = (-10.1).floor # -11
452 ceil = (-10.1).ceil # -10
2d96abcc
TC
453 somescalar.is_list # always false
454 somescalar.is_hash # always false
6c291231
TC
455
456=head1 DESCRIPTION
457
458Provides virtual methods for scalars in L<Squirrel::Template>
459expressions.
460
461=head1 SCALAR METHODS
462
463=over
464
465=item length
466
467Return the length of the string in characters.
468
469=item upper
470
471Return the string in upper case
472
473=item lower
474
475Return the string in lower case.
476
477=item defined
478
479Return true if the string has a defined value.
480
481=item split
482
483=item split(sep)
484
485=item split(sep, count)
486
487Return a list object of the string split on the regular expression
488C<sep>, returning up to C<count> objects. C<sep> defaults to C<" ">,
489C<count> defaults to C<0>. A count of C<0> returns as many elements
490as are found but removes any trailing empty length elements. A
491negative C<count> returns all elements.
492
1c78dcb4
TC
493=item format(format)
494
495Formats the scalar using a sprintf() format code.
496
497 (10.123).format("%.2f") # "10.12"
498
499=item escape(type)
500
501Escape the scalar with the template defined escape method, eg. "html",
502"uri".
503
504 "a&b".escape("html") # "a&amp;b"
505
e512ca55
TC
506=item evaltag
507
508Evalulate the value of string as if processed as a tag. The string
509must not include the surrounding <: ... :>.
510
7b4c11f9
TC
511=item quotemeta
512
513Return the string with regular expression metacharacters quoted with
514C<\>.
515
516=item contains(substring)
517
518Returns true if the subject contains the given substring.
519
520=item index(substring)
521
522=item index(substring, start)
523
524Return the position of C<substring> within the subject, searching
525forward from C<start> or from the beginning of the string. Returns -1
526if C<substring> isn't found.
527
528=item rindex(substring)
529
530=item rindex(substring, start)
531
532Return the position of C<substring> within the subject, searching
533backward from C<start> or from the end of the string. Returns -1 if
534C<substring> isn't found.
535
d64aa8a6
TC
536=item replace(regexp, replacement)
537
538=item replace(regexp, replacement, global)
539
105ac913
TC
540Replace the given C<regexp> in the string with C<replacement>.
541
542If C<replacement> is a block, call the block with a match object (see
543L</match(regexp)> below), and use the result as the replacement text.
544
545If C<replacement> isn't a block it's treated as a string and C<$1> etc
546are replaced with what the corresponding parenthesized expression in
547the regexp matched. C<$$> is replaced with C<$>.
d64aa8a6
TC
548
549If C<global> is present and true, replace every instance.
550
551Does not modify the source, simply returns the modified text.
552
2470cfc2
TC
553=item match(regexp)
554
555Matches the string against C<regexp> returning undef on no match, or
556returning a hash:
557
558 {
559 "start":start of whole match,
560 "length":length of whole match,
561 "end":end of whole match,
105ac913 562 "text":matching text of whole match,
2470cfc2
TC
563 "subexpr": [
564 {
105ac913
TC
565 "start": start of first subexpr match,
566 "length": length of first subexpr match,
567 "end": end of first subexpr match,
568 "text": matching text of first subexpr,
2470cfc2
TC
569 },
570 ...
105ac913
TC
571 ],
572 "named": {
573 "name": {
574 "text": matching text of named match,
575 },
576 }
2470cfc2
TC
577 }
578
105ac913
TC
579Note: C<subexpr> includes named matches.
580
2470cfc2
TC
581=item substring(start)
582
583=item substring(start, length)
584
585Return the sub-string the scalar starting from C<start> for up to the
586end of the string (or up to C<length> characters.)
587
588Supports negative C<start> to count from the end of the end of the
589string, and similarly for C<length>.
590
7b4c11f9
TC
591=item chr
592
593Convert a character code into a character.
594
595 (65).chr # "A"
596
597=item int
598
599Convert a number to an integer.
600
601 (10.1).int # 10
602
603=item rand
604
605Produce a floating point random number greater or equal to 0 and less
606than the subject.
607
608 (10).rand # 0 <= result < 10
609
610=item abs
611
612Return the absolute value of the subject.
613
614=item floor
615
616Return the highest integer less than or equal to the subject
617
618 (10).floor # 10
619 (10.1).floor # 10
620 (-10.1).floor # -11
621
622=item ceil
623
624Return the lowest integer greater than or equal to the subject.
625
626 (10).ceil # 10
627 (10.1).ceil # 11
628 (-10.1).ceil # -10
629
2d96abcc
TC
630=item is_list
631
632Test if this object is a list. Always true for a list.
633
634=item is_hash
635
636Test if this object is a hash. Always false for a list.
637
dd94dd8e
TC
638=item is_code
639
640Test if this object is a code object.
641
7b4c11f9
TC
642=back
643
6c291231
TC
644=head1 SEE ALSO
645
646L<Squirrel::Template::Expr>, L<Squirrel::Template>
647
648=head1 AUTHOR
649
650Tony Cook <tony@develop-help.com>
651
652=back