re-work coupons to allow multiple coupon types
[bse.git] / site / cgi-bin / modules / Squirrel / Template / Expr / WrapScalar.pm
1 package Squirrel::Template::Expr::WrapScalar;
2 use strict;
3 use base qw(Squirrel::Template::Expr::WrapBase);
4
5 our $VERSION = "1.011";
6
7 sub _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
16 sub _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
25 sub _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
34 sub _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
43 sub _do_trim {
44   my ($self, $args) = @_;
45
46   @$args == 0
47     or die [ error => "scalar.trim takes no parameters" ];
48
49   my $copy = $self->[0];
50   $copy =~ s/\A\s+//;
51   $copy =~ s/\s+\z//;
52
53   return $copy;
54 }
55
56 sub _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
67 sub _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
76 sub _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
85 sub _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
96 sub _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
105 sub _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
114 sub _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
123 sub _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
134 sub _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
143 sub _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
152 sub _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
161 sub _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
170 sub _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
181 sub _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
192 sub _do_is_list {
193   return 0;
194 }
195
196 sub _do_is_hash {
197   return 0;
198 }
199
200 sub _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
207 sub _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];
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     };
232
233   if ($global) {
234     $str =~ s{$re}{ $with_code->() }ge;
235   }
236   else {
237     $str =~ s{$re}{ $with_code->() }e;
238   }
239
240   return $str;
241 }
242
243 sub _do_match {
244   my ($self, $args) = @_;
245
246   @$args == 1
247     or die [ error => "scalar.match requires one parameter" ];
248
249   $self->[0] =~ $args->[0]
250     or return undef;
251
252   return _make_match($self->[0]);
253 }
254
255 sub _make_match {
256   my %match;
257   tie %match, 'Squirrel::Template::Expr::WrapScalar::Match', $_[0], \@-, \@+, \%-, \%+;
258
259   \%match;
260 }
261
262 sub _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
270 sub 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
280 package Squirrel::Template::Expr::WrapScalar::Match;
281 use base 'Tie::Hash';
282
283 sub 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
297 sub 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
319 sub EXISTS {
320   my ($self, $name) = @_;
321
322   return exists $self->{keys}{$name};
323 }
324
325 sub FIRSTKEY {
326   my ($self) = @_;
327
328   keys %{$self->{keys}};
329
330   each %{$self->{keys}};
331 }
332
333 sub NEXTKEY {
334   my ($self) = @_;
335
336   each %{$self->{keys}};
337 }
338
339 package Squirrel::Template::Expr::WrapScalar::Match::Subexpr;
340 use base 'Tie::Array';
341
342 sub TIEARRAY {
343   my ($class, $starts, $ends, $text) = @_;
344
345   bless [ $starts, $ends, $text ], $class;
346 }
347
348 sub 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
364 sub EXISTS {
365   my ($self, $index) = @_;
366
367   $index >= 0 && $index < $#{$self->[0]}
368     or return !1;
369
370   return !0;
371 }
372
373 sub FETCHSIZE {
374   my ($self) = @_;
375
376   return @{$self->[0]} - 1;
377 }
378
379 package Squirrel::Template::Expr::WrapScalar::Match::Named;
380 use base 'Tie::Hash';
381
382 sub TIEHASH {
383   my ($class, $nstarts, $nends) = @_;
384
385   bless [ $nstarts, $nends ], $class;
386 }
387
388 sub 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
400 sub EXISTS {
401   my ($self, $name) = @_;
402
403   defined $self->[0]{$name}
404     or return !1;
405
406   return !0;
407 }
408
409 sub FIRSTKEY {
410   my ($self) = @_;
411
412   keys %{$self->[0]}; # reset
413
414   each %{$self->[0]};
415 }
416
417 sub NEXTKEY {
418   my ($self) = @_;
419
420   each %{$self->[0]};
421 }
422
423 1;
424
425 =head1 NAME
426
427 Squirrel::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");
440   value = somescalar.evaltag
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
453   somescalar.is_list # always false
454   somescalar.is_hash # always false
455
456 =head1 DESCRIPTION
457
458 Provides virtual methods for scalars in L<Squirrel::Template>
459 expressions.
460
461 =head1 SCALAR METHODS
462
463 =over
464
465 =item length
466
467 Return the length of the string in characters.
468
469 =item upper
470
471 Return the string in upper case
472
473 =item lower
474
475 Return the string in lower case.
476
477 =item defined
478
479 Return true if the string has a defined value.
480
481 =item split
482
483 =item split(sep)
484
485 =item split(sep, count)
486
487 Return a list object of the string split on the regular expression
488 C<sep>, returning up to C<count> objects.  C<sep> defaults to C<" ">,
489 C<count> defaults to C<0>.  A count of C<0> returns as many elements
490 as are found but removes any trailing empty length elements.  A
491 negative C<count> returns all elements.
492
493 =item format(format)
494
495 Formats the scalar using a sprintf() format code.
496
497   (10.123).format("%.2f") # "10.12"
498
499 =item escape(type)
500
501 Escape the scalar with the template defined escape method, eg. "html",
502 "uri".
503
504   "a&b".escape("html") # "a&amp;b"
505
506 =item evaltag
507
508 Evalulate the value of string as if processed as a tag.  The string
509 must not include the surrounding <: ... :>.
510
511 =item quotemeta
512
513 Return the string with regular expression metacharacters quoted with
514 C<\>.
515
516 =item contains(substring)
517
518 Returns true if the subject contains the given substring.
519
520 =item index(substring)
521
522 =item index(substring, start)
523
524 Return the position of C<substring> within the subject, searching
525 forward from C<start> or from the beginning of the string.  Returns -1
526 if C<substring> isn't found.
527
528 =item rindex(substring)
529
530 =item rindex(substring, start)
531
532 Return the position of C<substring> within the subject, searching
533 backward from C<start> or from the end of the string.  Returns -1 if
534 C<substring> isn't found.
535
536 =item replace(regexp, replacement)
537
538 =item replace(regexp, replacement, global)
539
540 Replace the given C<regexp> in the string with C<replacement>.
541
542 If C<replacement> is a block, call the block with a match object (see
543 L</match(regexp)> below), and use the result as the replacement text.
544
545 If C<replacement> isn't a block it's treated as a string and C<$1> etc
546 are replaced with what the corresponding parenthesized expression in
547 the regexp matched.  C<$$> is replaced with C<$>.
548
549 If C<global> is present and true, replace every instance.
550
551 Does not modify the source, simply returns the modified text.
552
553 =item match(regexp)
554
555 Matches the string against C<regexp> returning undef on no match, or
556 returning a hash:
557
558   {
559     "start":start of whole match,
560     "length":length of whole match,
561     "end":end of whole match,
562     "text":matching text of whole match,
563     "subexpr": [
564        {
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,
569        },
570        ...
571     ],
572     "named": {
573       "name": {
574         "text": matching text of named match,
575       },
576     }
577   }
578
579 Note: C<subexpr> includes named matches.
580
581 =item substring(start)
582
583 =item substring(start, length)
584
585 Return the sub-string the scalar starting from C<start> for up to the
586 end of the string (or up to C<length> characters.)
587
588 Supports negative C<start> to count from the end of the end of the
589 string, and similarly for C<length>.
590
591 =item chr
592
593 Convert a character code into a character.
594
595   (65).chr # "A"
596
597 =item int
598
599 Convert a number to an integer.
600
601   (10.1).int # 10
602
603 =item rand
604
605 Produce a floating point random number greater or equal to 0 and less
606 than the subject.
607
608   (10).rand # 0 <= result < 10
609
610 =item abs
611
612 Return the absolute value of the subject.
613
614 =item floor
615
616 Return 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
624 Return 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
630 =item is_list
631
632 Test if this object is a list.  Always true for a list.
633
634 =item is_hash
635
636 Test if this object is a hash.  Always false for a list.
637
638 =item is_code
639
640 Test if this object is a code object.
641
642 =back
643
644 =head1 SEE ALSO
645
646 L<Squirrel::Template::Expr>, L<Squirrel::Template>
647
648 =head1 AUTHOR
649
650 Tony Cook <tony@develop-help.com>
651
652 =back