local-lib5/lib/perl5/i486-linux-gnu-thread-multi/Template/VMethods.pm

   1 #============================================================= -*-Perl-*-
   2 #
   3 # Template::VMethods
   4 #
   5 # DESCRIPTION
   6 #   Module defining virtual methods for the Template Toolkit
   7 #
   8 # AUTHOR
   9 #   Andy Wardley   <abw@wardley.org>
  10 #
  11 # COPYRIGHT
  12 #   Copyright (C) 1996-2006 Andy Wardley.  All Rights Reserved.
  13 #
  14 #   This module is free software; you can redistribute it and/or
  15 #   modify it under the same terms as Perl itself.
  16 #
  17 # REVISION
  18 #   $Id: VMethods.pm 1245 2009-07-04 17:02:52Z abw $
  19 #
  20 #============================================================================
  21
  22 package Template::VMethods;
  23
  24 use strict;
  25 use warnings;
  26 use Scalar::Util 'blessed';
  27 require Template::Stash;
  28
  29 our $VERSION = 2.16;
  30 our $DEBUG   = 0 unless defined $DEBUG;
  31 our $PRIVATE = $Template::Stash::PRIVATE;
  32
  33 our $ROOT_VMETHODS = {
  34     inc     => \&root_inc,
  35     dec     => \&root_dec,
  36 };
  37
  38 our $TEXT_VMETHODS = {
  39     item    => \&text_item,
  40     list    => \&text_list,
  41     hash    => \&text_hash,
  42     length  => \&text_length,
  43     size    => \&text_size,
  44     defined => \&text_defined,
  45     match   => \&text_match,
  46     search  => \&text_search,
  47     repeat  => \&text_repeat,
  48     replace => \&text_replace,
  49     remove  => \&text_remove,
  50     split   => \&text_split,
  51     chunk   => \&text_chunk,
  52     substr  => \&text_substr,
  53 };
  54
  55 our $HASH_VMETHODS = {
  56     item    => \&hash_item,
  57     hash    => \&hash_hash,
  58     size    => \&hash_size,
  59     each    => \&hash_each,
  60     keys    => \&hash_keys,
  61     values  => \&hash_values,
  62     items   => \&hash_items,
  63     pairs   => \&hash_pairs,
  64     list    => \&hash_list,
  65     exists  => \&hash_exists,
  66     defined => \&hash_defined,
  67     delete  => \&hash_delete,
  68     import  => \&hash_import,
  69     sort    => \&hash_sort,
  70     nsort   => \&hash_nsort,
  71 };
  72
  73 our $LIST_VMETHODS = {
  74     item    => \&list_item,
  75     list    => \&list_list,
  76     hash    => \&list_hash,
  77     push    => \&list_push,
  78     pop     => \&list_pop,
  79     unshift => \&list_unshift,
  80     shift   => \&list_shift,
  81     max     => \&list_max,
  82     size    => \&list_size,
  83     defined => \&list_defined,
  84     first   => \&list_first,
  85     last    => \&list_last,
  86     reverse => \&list_reverse,
  87     grep    => \&list_grep,
  88     join    => \&list_join,
  89     sort    => \&list_sort,
  90     nsort   => \&list_nsort,
  91     unique  => \&list_unique,
  92     import  => \&list_import,
  93     merge   => \&list_merge,
  94     slice   => \&list_slice,
  95     splice  => \&list_splice,
  96 };
  97
  98
  99 #========================================================================
 100 # root virtual methods
 101 #========================================================================
 102
 103 sub root_inc {
 104     no warnings;
 105     my $item = shift;
 106     ++$item;
 107 }
 108
 109 sub root_dec {
 110     no warnings;
 111     my $item = shift;
 112     --$item;
 113 }
 114
 115
 116 #========================================================================
 117 # text virtual methods
 118 #========================================================================
 119
 120 sub text_item {
 121     $_[0];
 122 }
 123
 124 sub text_list {
 125     [ $_[0] ];
 126 }
 127
 128 sub text_hash {
 129     { value => $_[0] };
 130 }
 131
 132 sub text_length {
 133     length $_[0];
 134 }
 135
 136 sub text_size {
 137     return 1;
 138 }
 139
 140 sub text_defined {
 141     return 1;
 142 }
 143
 144 sub text_match {
 145     my ($str, $search, $global) = @_;
 146     return $str unless defined $str and defined $search;
 147     my @matches = $global ? ($str =~ /$search/g)
 148         : ($str =~ /$search/);
 149     return @matches ? \@matches : '';
 150 }
 151
 152 sub text_search {
 153     my ($str, $pattern) = @_;
 154     return $str unless defined $str and defined $pattern;
 155     return $str =~ /$pattern/;
 156 }
 157
 158 sub text_repeat {
 159     my ($str, $count) = @_;
 160     $str = '' unless defined $str;
 161     return '' unless $count;
 162     $count ||= 1;
 163     return $str x $count;
 164 }
 165
 166 sub text_replace {
 167     my ($text, $pattern, $replace, $global) = @_;
 168     $text    = '' unless defined $text;
 169     $pattern = '' unless defined $pattern;
 170     $replace = '' unless defined $replace;
 171     $global  = 1  unless defined $global;
 172
 173     if ($replace =~ /\$\d+/) {
 174         # replacement string may contain backrefs
 175         my $expand = sub {
 176             my ($chunk, $start, $end) = @_;
 177             $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{
 178                 $1 ? $1
 179                     : ($2 > $#$start || $2 == 0) ? ''
 180                     : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
 181             }exg;
 182             $chunk;
 183         };
 184         if ($global) {
 185             $text =~ s{$pattern}{ &$expand($replace, [@-], [@+]) }eg;
 186         }
 187         else {
 188             $text =~ s{$pattern}{ &$expand($replace, [@-], [@+]) }e;
 189         }
 190     }
 191     else {
 192         if ($global) {
 193             $text =~ s/$pattern/$replace/g;
 194         }
 195         else {
 196             $text =~ s/$pattern/$replace/;
 197         }
 198     }
 199     return $text;
 200 }
 201
 202 sub text_remove {
 203     my ($str, $search) = @_;
 204     return $str unless defined $str and defined $search;
 205     $str =~ s/$search//g;
 206     return $str;
 207 }
 208
 209 sub text_split {
 210     my ($str, $split, $limit) = @_;
 211     $str = '' unless defined $str;
 212
 213     # we have to be very careful about spelling out each possible
 214     # combination of arguments because split() is very sensitive
 215     # to them, for example C<split(' ', ...)> behaves differently
 216     # to C<$space=' '; split($space, ...)>
 217
 218     if (defined $limit) {
 219         return [ defined $split
 220                  ? split($split, $str, $limit)
 221                  : split(' ', $str, $limit) ];
 222     }
 223     else {
 224         return [ defined $split
 225                  ? split($split, $str)
 226                  : split(' ', $str) ];
 227     }
 228 }
 229
 230 sub text_chunk {
 231     my ($string, $size) = @_;
 232     my @list;
 233     $size ||= 1;
 234     if ($size < 0) {
 235         # sexeger!  It's faster to reverse the string, search
 236         # it from the front and then reverse the output than to
 237         # search it from the end, believe it nor not!
 238         $string = reverse $string;
 239         $size = -$size;
 240         unshift(@list, scalar reverse $1)
 241             while ($string =~ /((.{$size})|(.+))/g);
 242     }
 243     else {
 244         push(@list, $1) while ($string =~ /((.{$size})|(.+))/g);
 245     }
 246     return \@list;
 247 }
 248
 249 sub text_substr {
 250     my ($text, $offset, $length, $replacement) = @_;
 251     $offset ||= 0;
 252
 253     if(defined $length) {
 254         if (defined $replacement) {
 255             substr( $text, $offset, $length, $replacement );
 256             return $text;
 257         }
 258         else {
 259             return substr( $text, $offset, $length );
 260         }
 261     }
 262     else {
 263         return substr( $text, $offset );
 264     }
 265 }
 266
 267
 268 #========================================================================
 269 # hash virtual methods
 270 #========================================================================
 271
 272
 273 sub hash_item {
 274     my ($hash, $item) = @_;
 275     $item = '' unless defined $item;
 276     return if $PRIVATE && $item =~ /$PRIVATE/;
 277     $hash->{ $item };
 278 }
 279
 280 sub hash_hash {
 281     $_[0];
 282 }
 283
 284 sub hash_size {
 285     scalar keys %{$_[0]};
 286 }
 287
 288 sub hash_each {
 289     # this will be changed in TT3 to do what hash_pairs() does
 290     [ %{ $_[0] } ];
 291 }
 292
 293 sub hash_keys {
 294     [ keys   %{ $_[0] } ];
 295 }
 296
 297 sub hash_values {
 298     [ values %{ $_[0] } ];
 299 }
 300
 301 sub hash_items {
 302     [ %{ $_[0] } ];
 303 }
 304
 305 sub hash_pairs {
 306     [ map {
 307         { key => $_ , value => $_[0]->{ $_ } }
 308       }
 309       sort keys %{ $_[0] }
 310     ];
 311 }
 312
 313 sub hash_list {
 314     my ($hash, $what) = @_;
 315     $what ||= '';
 316     return ($what eq 'keys')   ? [   keys %$hash ]
 317         :  ($what eq 'values') ? [ values %$hash ]
 318         :  ($what eq 'each')   ? [        %$hash ]
 319         :  # for now we do what pairs does but this will be changed
 320            # in TT3 to return [ $hash ] by default
 321         [ map { { key => $_ , value => $hash->{ $_ } } }
 322           sort keys %$hash
 323           ];
 324 }
 325
 326 sub hash_exists {
 327     exists $_[0]->{ $_[1] };
 328 }
 329
 330 sub hash_defined {
 331     # return the item requested, or 1 if no argument
 332     # to indicate that the hash itself is defined
 333     my $hash = shift;
 334     return @_ ? defined $hash->{ $_[0] } : 1;
 335 }
 336
 337 sub hash_delete {
 338     my $hash = shift;
 339     delete $hash->{ $_ } for @_;
 340 }
 341
 342 sub hash_import {
 343     my ($hash, $imp) = @_;
 344     $imp = {} unless ref $imp eq 'HASH';
 345     @$hash{ keys %$imp } = values %$imp;
 346     return '';
 347 }
 348
 349 sub hash_sort {
 350     my ($hash) = @_;
 351     [ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ];
 352 }
 353
 354 sub hash_nsort {
 355     my ($hash) = @_;
 356     [ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ];
 357 }
 358
 359
 360 #========================================================================
 361 # list virtual methods
 362 #========================================================================
 363
 364
 365 sub list_item {
 366     $_[0]->[ $_[1] || 0 ];
 367 }
 368
 369 sub list_list {
 370     $_[0];
 371 }
 372
 373 sub list_hash {
 374     my $list = shift;
 375     if (@_) {
 376         my $n = shift || 0;
 377         return { map { ($n++, $_) } @$list };
 378     }
 379     no warnings;
 380     return { @$list };
 381 }
 382
 383 sub list_push {
 384     my $list = shift;
 385     push(@$list, @_);
 386     return '';
 387 }
 388
 389 sub list_pop {
 390     my $list = shift;
 391     pop(@$list);
 392 }
 393
 394 sub list_unshift {
 395     my $list = shift;
 396     unshift(@$list, @_);
 397     return '';
 398 }
 399
 400 sub list_shift {
 401     my $list = shift;
 402     shift(@$list);
 403 }
 404
 405 sub list_max {
 406     no warnings;
 407     my $list = shift;
 408     $#$list;
 409 }
 410
 411 sub list_size {
 412     no warnings;
 413     my $list = shift;
 414     $#$list + 1;
 415 }
 416
 417 sub list_defined {
 418     # return the item requested, or 1 if no argument to
 419     # indicate that the hash itself is defined
 420     my $list = shift;
 421     return @_ ? defined $list->[$_[0]] : 1;
 422 }
 423
 424 sub list_first {
 425     my $list = shift;
 426     return $list->[0] unless @_;
 427     return [ @$list[0..$_[0]-1] ];
 428 }
 429
 430 sub list_last {
 431     my $list = shift;
 432     return $list->[-1] unless @_;
 433     return [ @$list[-$_[0]..-1] ];
 434 }
 435
 436 sub list_reverse {
 437     my $list = shift;
 438     [ reverse @$list ];
 439 }
 440
 441 sub list_grep {
 442     my ($list, $pattern) = @_;
 443     $pattern ||= '';
 444     return [ grep /$pattern/, @$list ];
 445 }
 446
 447 sub list_join {
 448     my ($list, $joint) = @_;
 449     join(defined $joint ? $joint : ' ',
 450          map { defined $_ ? $_ : '' } @$list);
 451 }
 452
 453 sub _list_sort_make_key {
 454    my ($item, $fields) = @_;
 455    my @keys;
 456
 457    if (ref($item) eq 'HASH') {
 458        @keys = map { $item->{ $_ } } @$fields;
 459    }
 460    elsif (blessed $item) {
 461        @keys = map { $item->can($_) ? $item->$_() : $item } @$fields;
 462    }
 463    else {
 464        @keys = $item;
 465    }
 466
 467    # ugly hack to generate a single string using a delimiter that is
 468    # unlikely (but not impossible) to be found in the wild.
 469    return lc join('/*^UNLIKELY^*/', map { defined $_ ? $_ : '' } @keys);
 470 }
 471
 472 sub list_sort {
 473     my ($list, @fields) = @_;
 474     return $list unless @$list > 1;         # no need to sort 1 item lists
 475     return [
 476         @fields                          # Schwartzian Transform
 477         ?   map  { $_->[0] }                # for case insensitivity
 478             sort { $a->[1] cmp $b->[1] }
 479             map  { [ $_, _list_sort_make_key($_, \@fields) ] }
 480             @$list
 481         :  map  { $_->[0] }
 482            sort { $a->[1] cmp $b->[1] }
 483            map  { [ $_, lc $_ ] }
 484            @$list,
 485     ];
 486 }
 487
 488 sub list_nsort {
 489     my ($list, @fields) = @_;
 490     return $list unless @$list > 1;     # no need to sort 1 item lists
 491     return [
 492         @fields                         # Schwartzian Transform
 493         ?  map  { $_->[0] }             # for case insensitivity
 494            sort { $a->[1] <=> $b->[1] }
 495            map  { [ $_, _list_sort_make_key($_, \@fields) ] }
 496            @$list
 497         :  map  { $_->[0] }
 498            sort { $a->[1] <=> $b->[1] }
 499            map  { [ $_, lc $_ ] }
 500            @$list,
 501     ];
 502 }
 503
 504 sub list_unique {
 505     my %u;
 506     [ grep { ++$u{$_} == 1 } @{$_[0]} ];
 507 }
 508
 509 sub list_import {
 510     my $list = shift;
 511     push(@$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_);
 512     return $list;
 513 }
 514
 515 sub list_merge {
 516     my $list = shift;
 517     return [ @$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_ ];
 518 }
 519
 520 sub list_slice {
 521     my ($list, $from, $to) = @_;
 522     $from ||= 0;
 523     $to    = $#$list unless defined $to;
 524     $from += @$list if $from < 0;
 525     $to   += @$list if $to   < 0;
 526     return [ @$list[$from..$to] ];
 527 }
 528
 529 sub list_splice {
 530     my ($list, $offset, $length, @replace) = @_;
 531     if (@replace) {
 532         # @replace can contain a list of multiple replace items, or
 533         # be a single reference to a list
 534         @replace = @{ $replace[0] }
 535         if @replace == 1 && ref $replace[0] eq 'ARRAY';
 536         return [ splice @$list, $offset, $length, @replace ];
 537     }
 538     elsif (defined $length) {
 539         return [ splice @$list, $offset, $length ];
 540     }
 541     elsif (defined $offset) {
 542         return [ splice @$list, $offset ];
 543     }
 544     else {
 545         return [ splice(@$list) ];
 546     }
 547 }
 548
 549 1;
 550
 551 __END__
 552
 553 =head1 NAME
 554
 555 Template::VMethods - Virtual methods for variables
 556
 557 =head1 DESCRIPTION
 558
 559 The C<Template::VMethods> module implements the virtual methods
 560 that can be applied to variables.
 561
 562 Please see L<Template::Manual::VMethods> for further information.
 563
 564 =head1 AUTHOR
 565
 566 Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/>
 567
 568 =head1 COPYRIGHT
 569
 570 Copyright (C) 1996-2007 Andy Wardley.  All Rights Reserved.
 571
 572 This module is free software; you can redistribute it and/or
 573 modify it under the same terms as Perl itself.
 574
 575 =head1 SEE ALSO
 576
 577 L<Template::Stash>, L<Template::Manual::VMethods>
 578
 579 =cut
 580
 581 # Local Variables:
 582 # mode: perl
 583 # perl-indent-level: 4
 584 # indent-tabs-mode: nil
 585 # End:
 586 #
 587 # vim: expandtab shiftwidth=4: