home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Stash.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-30  |  35.0 KB  |  1,041 lines
  1. #============================================================= -*-Perl-*-
  2. #
  3. # Template::Stash
  4. #
  5. # DESCRIPTION
  6. #   Definition of an object class which stores and manages access to 
  7. #   variables for the Template Toolkit. 
  8. #
  9. # AUTHOR
  10. #   Andy Wardley   <abw@wardley.org>
  11. #
  12. # COPYRIGHT
  13. #   Copyright (C) 1996-2003 Andy Wardley.  All Rights Reserved.
  14. #   Copyright (C) 1998-2000 Canon Research Centre Europe Ltd.
  15. #
  16. #   This module is free software; you can redistribute it and/or
  17. #   modify it under the same terms as Perl itself.
  18. #
  19. #----------------------------------------------------------------------------
  20. #
  21. # $Id: Stash.pm,v 2.85 2004/01/30 17:51:01 abw Exp $
  22. #
  23. #============================================================================
  24.  
  25. package Template::Stash;
  26.  
  27. require 5.004;
  28.  
  29. use strict;
  30. use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS );
  31.  
  32. $VERSION = sprintf("%d.%02d", q$Revision: 2.85 $ =~ /(\d+)\.(\d+)/);
  33.  
  34.  
  35. #========================================================================
  36. #                    -- PACKAGE VARIABLES AND SUBS --
  37. #========================================================================
  38.  
  39. #------------------------------------------------------------------------
  40. # Definitions of various pseudo-methods.  ROOT_OPS are merged into all
  41. # new Template::Stash objects, and are thus default global functions.
  42. # SCALAR_OPS are methods that can be called on a scalar, and ditto 
  43. # respectively for LIST_OPS and HASH_OPS
  44. #------------------------------------------------------------------------
  45.  
  46. $ROOT_OPS = {
  47.     'inc'  => sub { local $^W = 0; my $item = shift; ++$item }, 
  48.     'dec'  => sub { local $^W = 0; my $item = shift; --$item }, 
  49. #    import => \&hash_import,
  50.     defined $ROOT_OPS ? %$ROOT_OPS : (),
  51. };
  52.  
  53. $SCALAR_OPS = {
  54.     'item'    => sub {   $_[0] },
  55.     'list'    => sub { [ $_[0] ] },
  56.     'hash'    => sub { { value => $_[0] } },
  57.     'length'  => sub { length $_[0] },
  58.     'size'    => sub { return 1 },
  59.     'defined' => sub { return 1 },
  60.     'repeat'  => sub { 
  61.         my ($str, $count) = @_;
  62.         $str = '' unless defined $str;  
  63.         return '' unless $count;
  64.         $count ||= 1;
  65.         return $str x $count;
  66.     },
  67.     'search'  => sub { 
  68.         my ($str, $pattern) = @_;
  69.         return $str unless defined $str and defined $pattern;
  70.         return $str =~ /$pattern/;
  71.     },
  72.     'replace'  => sub { 
  73.         my ($str, $search, $replace) = @_;
  74.         $replace = '' unless defined $replace;
  75.         return $str unless defined $str and defined $search;
  76.         $str =~ s/$search/$replace/g;
  77. #       print STDERR "s [ $search ] [ $replace ] g\n";
  78. #       eval "\$str =~ s$search$replaceg";
  79.         return $str;
  80.     },
  81.     'match' => sub {
  82.         my ($str, $search) = @_;
  83.         return $str unless defined $str and defined $search;
  84.         my @matches = ($str =~ /$search/);
  85.         return @matches ? \@matches : '';
  86.     },
  87.     'split'   => sub { 
  88.         my ($str, $split, @args) = @_;
  89.         $str = '' unless defined $str;
  90.         return [ defined $split ? split($split, $str, @args)
  91.                                 : split(' ', $str, @args) ];
  92.     },
  93.     'chunk' => sub {
  94.         my ($string, $size) = @_;
  95.         my @list;
  96.         $size ||= 1;
  97.         if ($size < 0) {
  98.             # sexeger!  It's faster to reverse the string, search
  99.             # it from the front and then reverse the output than to 
  100.             # search it from the end, believe it nor not!
  101.             $string = reverse $string;
  102.             $size = -$size;
  103.             unshift(@list, scalar reverse $1) 
  104.                 while ($string =~ /((.{$size})|(.+))/g);
  105.         }
  106.         else {
  107.             push(@list, $1) while ($string =~ /((.{$size})|(.+))/g);
  108.         }
  109.         return \@list;
  110.     },
  111.     
  112.  
  113.     defined $SCALAR_OPS ? %$SCALAR_OPS : (),
  114. };
  115.  
  116. $HASH_OPS = {
  117.     'item'   => sub { 
  118.         my ($hash, $item) = @_; 
  119.         $item = '' unless defined $item;
  120.         return if $item =~ /^[_.]/;
  121.         $hash->{ $item };
  122.     },
  123.     'hash'   => sub { $_[0] },
  124.     'size'   => sub { scalar keys %{$_[0]} },
  125.     'keys'   => sub { [ keys   %{ $_[0] } ] },
  126.     'values' => sub { [ values %{ $_[0] } ] },
  127.     'each'   => sub { [        %{ $_[0] } ] },
  128.     'list'   => sub { 
  129.         my ($hash, $what) = @_;  $what ||= '';
  130.         return ($what eq 'keys')   ? [   keys %$hash ]
  131.             : ($what eq 'values') ? [ values %$hash ]
  132.             : ($what eq 'each')   ? [        %$hash ]
  133.             : [ map { { key => $_ , value => $hash->{ $_ } } }
  134.                 keys %$hash ];
  135.     },
  136.     'exists'  => sub { exists $_[0]->{ $_[1] } },
  137.     'defined' => sub { defined $_[0]->{ $_[1] } },
  138.     'import'  => \&hash_import,
  139.     'sort'    => sub {
  140.         my ($hash) = @_;
  141.         [ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ];
  142.     },
  143.     'nsort'    => sub {
  144.         my ($hash) = @_;
  145.         [ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ];
  146.     },
  147.     defined $HASH_OPS ? %$HASH_OPS : (),
  148. };
  149.  
  150. $LIST_OPS = {
  151.     'item'    => sub { $_[0]->[ $_[1] || 0 ] },
  152.     'list'    => sub { $_[0] },
  153.     'hash'    => sub { my $list = shift; my $n = 0; 
  154.                        return { map { ($n++, $_) } @$list }; },
  155.     'push'    => sub { my $list = shift; push(@$list, shift); return '' },
  156.     'pop'     => sub { my $list = shift; pop(@$list) },
  157.     'unshift' => sub { my $list = shift; unshift(@$list, shift); return '' },
  158.     'shift'   => sub { my $list = shift; shift(@$list) },
  159.     'max'     => sub { local $^W = 0; my $list = shift; $#$list; },
  160.     'size'    => sub { local $^W = 0; my $list = shift; $#$list + 1; },
  161.     'first'   => sub {
  162.         my $list = shift;
  163.         return $list->[0] unless @_;
  164.         return [ @$list[0..$_[0]-1] ];
  165.     },
  166.     'last'    => sub {
  167.         my $list = shift;
  168.         return $list->[-1] unless @_;
  169.         return [ @$list[-$_[0]..-1] ];
  170.     },
  171.     'reverse' => sub { my $list = shift; [ reverse @$list ] },
  172.     'grep'    => sub { 
  173.         my ($list, $pattern) = @_;
  174.         $pattern ||= '';
  175.         return [ grep /$pattern/, @$list ];
  176.     },
  177.     'join'    => sub { 
  178.         my ($list, $joint) = @_; 
  179.         join(defined $joint ? $joint : ' ', 
  180.              map { defined $_ ? $_ : '' } @$list) 
  181.         },
  182.     'sort'    => sub {
  183.         $^W = 0;
  184.         my ($list, $field) = @_;
  185.         return $list unless @$list > 1;     # no need to sort 1 item lists
  186.         return $field                       # Schwartzian Transform 
  187.             ?  map  { $_->[0] }             # for case insensitivity
  188.                sort { $a->[1] cmp $b->[1] }
  189.                map  { [ $_, lc(ref($_) eq 'HASH' 
  190.                    ? $_->{ $field } : 
  191.                    UNIVERSAL::can($_, $field)
  192.                    ? $_->$field() : $_) ] } 
  193.                @$list 
  194.             :  map  { $_->[0] }
  195.                sort { $a->[1] cmp $b->[1] }
  196.                map  { [ $_, lc $_ ] } 
  197.                @$list
  198.    },
  199.    'nsort'    => sub {
  200.         my ($list, $field) = @_;
  201.         return $list unless $#$list;        # no need to sort 1 item lists
  202.         return $field                       # Schwartzian Transform 
  203.             ?  map  { $_->[0] }             # for case insensitivity
  204.                sort { $a->[1] <=> $b->[1] }
  205.                map  { [ $_, lc(ref($_) eq 'HASH' 
  206.                    ? $_->{ $field } : 
  207.                    UNIVERSAL::can($_, $field)
  208.                    ? $_->$field() : $_) ] } 
  209.                @$list 
  210.             :  map  { $_->[0] }
  211.                sort { $a->[1] <=> $b->[1] }
  212.                map  { [ $_, lc $_ ] } 
  213.                @$list
  214.     },
  215.     'unique'  => sub { my %u; [ grep { ++$u{$_} == 1 } @{$_[0]} ] },
  216.     'merge'   => sub {
  217.         my $list = shift;
  218.         return [ @$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_ ];
  219.     },
  220.     'slice' => sub {
  221.         my ($list, $from, $to) = @_;
  222.         $from ||= 0;
  223.         $to = $#$list unless defined $to;
  224.         return [ @$list[$from..$to] ];
  225.     },
  226.     'splice'  => sub {
  227.         my ($list, $offset, $length, @replace) = @_;
  228.         if (@replace) {
  229.             # @replace can contain a list of multiple replace items, or 
  230.             # be a single reference to a list
  231.             @replace = @{ $replace[0] }
  232.             if @replace == 1 && ref $replace[0] eq 'ARRAY';
  233.             return [ splice @$list, $offset, $length, @replace ];
  234.         }
  235.         elsif (defined $length) {
  236.             return [ splice @$list, $offset, $length ];
  237.         }
  238.         elsif (defined $offset) {
  239.             return [ splice @$list, $offset ];
  240.         }
  241.         else {
  242.             return [ splice(@$list) ];
  243.         }
  244.     },
  245.  
  246.     defined $LIST_OPS ? %$LIST_OPS : (),
  247. };
  248.  
  249. sub hash_import { 
  250.     my ($hash, $imp) = @_;
  251.     $imp = {} unless ref $imp eq 'HASH';
  252.     @$hash{ keys %$imp } = values %$imp;
  253.     return '';
  254. }
  255.  
  256.  
  257. #------------------------------------------------------------------------
  258. # define_vmethod($type, $name, \&sub)
  259. #
  260. # Defines a virtual method of type $type (SCALAR, HASH, or LIST), with
  261. # name $name, that invokes &sub when called.  It is expected that &sub
  262. # be able to handle the type that it will be called upon.
  263. #------------------------------------------------------------------------
  264.  
  265. sub define_vmethod {
  266.     my ($class, $type, $name, $sub) = @_;
  267.     my $op;
  268.     $type = lc $type;
  269.  
  270.     if ($type =~ /^scalar|item$/) {
  271.         $op = $SCALAR_OPS;
  272.     }
  273.     elsif ($type eq 'hash') {
  274.         $op = $HASH_OPS;
  275.     }
  276.     elsif ($type =~ /^list|array$/) {
  277.         $op = $LIST_OPS;
  278.     }
  279.     else {
  280.         die "invalid vmethod type: $type\n";
  281.     }
  282.  
  283.     $op->{ $name } = $sub;
  284.  
  285.     return 1;
  286. }
  287.  
  288.  
  289. #========================================================================
  290. #                      -----  CLASS METHODS -----
  291. #========================================================================
  292.  
  293. #------------------------------------------------------------------------
  294. # new(\%params)
  295. #
  296. # Constructor method which creates a new Template::Stash object.
  297. # An optional hash reference may be passed containing variable 
  298. # definitions that will be used to initialise the stash.
  299. #
  300. # Returns a reference to a newly created Template::Stash.
  301. #------------------------------------------------------------------------
  302.  
  303. sub new {
  304.     my $class  = shift;
  305.     my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };
  306.  
  307.     my $self   = {
  308.         global  => { },
  309.         %$params,
  310.         %$ROOT_OPS,
  311.         '_PARENT' => undef,
  312.     };
  313.  
  314.     bless $self, $class;
  315. }
  316.  
  317.  
  318. #========================================================================
  319. #                   -----  PUBLIC OBJECT METHODS -----
  320. #========================================================================
  321.  
  322. #------------------------------------------------------------------------
  323. # clone(\%params)
  324. #
  325. # Creates a copy of the current stash object to effect localisation 
  326. # of variables.  The new stash is blessed into the same class as the 
  327. # parent (which may be a derived class) and has a '_PARENT' member added
  328. # which contains a reference to the parent stash that created it
  329. # ($self).  This member is used in a successive declone() method call to
  330. # return the reference to the parent.
  331. # 
  332. # A parameter may be provided which should reference a hash of 
  333. # variable/values which should be defined in the new stash.  The 
  334. # update() method is called to define these new variables in the cloned
  335. # stash.
  336. #
  337. # Returns a reference to a cloned Template::Stash.
  338. #------------------------------------------------------------------------
  339.  
  340. sub clone {
  341.     my ($self, $params) = @_;
  342.     $params ||= { };
  343.  
  344.     # look out for magical 'import' argument which imports another hash
  345.     my $import = $params->{ import };
  346.     if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
  347.         delete $params->{ import };
  348.     }
  349.     else {
  350.         undef $import;
  351.     }
  352.  
  353.     my $clone = bless { 
  354.         %$self,         # copy all parent members
  355.         %$params,       # copy all new data
  356.         '_PARENT' => $self,     # link to parent
  357.     }, ref $self;
  358.     
  359.     # perform hash import if defined
  360.     &{ $HASH_OPS->{ import }}($clone, $import)
  361.         if defined $import;
  362.  
  363.     return $clone;
  364. }
  365.  
  366.     
  367. #------------------------------------------------------------------------
  368. # declone($export) 
  369. #
  370. # Returns a reference to the PARENT stash.  When called in the following
  371. # manner:
  372. #    $stash = $stash->declone();
  373. # the reference count on the current stash will drop to 0 and be "freed"
  374. # and the caller will be left with a reference to the parent.  This 
  375. # contains the state of the stash before it was cloned.  
  376. #------------------------------------------------------------------------
  377.  
  378. sub declone {
  379.     my $self = shift;
  380.     $self->{ _PARENT } || $self;
  381. }
  382.  
  383.  
  384. #------------------------------------------------------------------------
  385. # get($ident)
  386. # 
  387. # Returns the value for an variable stored in the stash.  The variable
  388. # may be specified as a simple string, e.g. 'foo', or as an array 
  389. # reference representing compound variables.  In the latter case, each
  390. # pair of successive elements in the list represent a node in the 
  391. # compound variable.  The first is the variable name, the second a 
  392. # list reference of arguments or 0 if undefined.  So, the compound 
  393. # variable [% foo.bar('foo').baz %] would be represented as the list
  394. # [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ].  Returns the value of the
  395. # identifier or an empty string if undefined.  Errors are thrown via
  396. # die().
  397. #------------------------------------------------------------------------
  398.  
  399. sub get {
  400.     my ($self, $ident, $args) = @_;
  401.     my ($root, $result);
  402.     $root = $self;
  403.  
  404.     if (ref $ident eq 'ARRAY'
  405.         || ($ident =~ /\./) 
  406.         && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) {
  407.         my $size = $#$ident;
  408.  
  409.         # if $ident is a list reference, then we evaluate each item in the 
  410.         # identifier against the previous result, using the root stash 
  411.         # ($self) as the first implicit 'result'...
  412.         
  413.         foreach (my $i = 0; $i <= $size; $i += 2) {
  414.             $result = $self->_dotop($root, @$ident[$i, $i+1]);
  415.             last unless defined $result;
  416.             $root = $result;
  417.         }
  418.     }
  419.     else {
  420.         $result = $self->_dotop($root, $ident, $args);
  421.     }
  422.  
  423.     return defined $result ? $result : $self->undefined($ident, $args);
  424. }
  425.  
  426.  
  427. #------------------------------------------------------------------------
  428. # set($ident, $value, $default)
  429. #
  430. # Updates the value for a variable in the stash.  The first parameter
  431. # should be the variable name or array, as per get().  The second 
  432. # parameter should be the intended value for the variable.  The third,
  433. # optional parameter is a flag which may be set to indicate 'default'
  434. # mode.  When set true, the variable will only be updated if it is
  435. # currently undefined or has a false value.  The magical 'IMPORT'
  436. # variable identifier may be used to indicate that $value is a hash
  437. # reference whose values should be imported.  Returns the value set,
  438. # or an empty string if not set (e.g. default mode).  In the case of 
  439. # IMPORT, returns the number of items imported from the hash.
  440. #------------------------------------------------------------------------
  441.  
  442. sub set {
  443.     my ($self, $ident, $value, $default) = @_;
  444.     my ($root, $result, $error);
  445.  
  446.     $root = $self;
  447.  
  448.     ELEMENT: {
  449.         if (ref $ident eq 'ARRAY'
  450.             || ($ident =~ /\./) 
  451.             && ($ident = [ map { s/\(.*$//; ($_, 0) }
  452.                            split(/\./, $ident) ])) {
  453.             
  454.             # a compound identifier may contain multiple elements (e.g. 
  455.             # foo.bar.baz) and we must first resolve all but the last, 
  456.             # using _dotop() with the $lvalue flag set which will create 
  457.             # intermediate hashes if necessary...
  458.             my $size = $#$ident;
  459.             foreach (my $i = 0; $i < $size - 2; $i += 2) {
  460.                 $result = $self->_dotop($root, @$ident[$i, $i+1], 1);
  461.                 last ELEMENT unless defined $result;
  462.                 $root = $result;
  463.             }
  464.             
  465.             # then we call _assign() to assign the value to the last element
  466.             $result = $self->_assign($root, @$ident[$size-1, $size], 
  467.                                      $value, $default);
  468.         }
  469.         else {
  470.             $result = $self->_assign($root, $ident, 0, $value, $default);
  471.         }
  472.     }
  473.     
  474.     return defined $result ? $result : '';
  475. }
  476.  
  477.  
  478. #------------------------------------------------------------------------
  479. # getref($ident)
  480. # 
  481. # Returns a "reference" to a particular item.  This is represented as a 
  482. # closure which will return the actual stash item when called.  
  483. # WARNING: still experimental!
  484. #------------------------------------------------------------------------
  485.  
  486. sub getref {
  487.     my ($self, $ident, $args) = @_;
  488.     my ($root, $item, $result);
  489.     $root = $self;
  490.  
  491.     if (ref $ident eq 'ARRAY') {
  492.         my $size = $#$ident;
  493.         
  494.         foreach (my $i = 0; $i <= $size; $i += 2) {
  495.             ($item, $args) = @$ident[$i, $i + 1]; 
  496.             last if $i >= $size - 2;  # don't evaluate last node
  497.             last unless defined 
  498.                 ($root = $self->_dotop($root, $item, $args));
  499.         }
  500.     }
  501.     else {
  502.         $item = $ident;
  503.     }
  504.     
  505.     if (defined $root) {
  506.         return sub { my @args = (@{$args||[]}, @_);
  507.                      $self->_dotop($root, $item, \@args);
  508.                  }
  509.     }
  510.     else {
  511.         return sub { '' };
  512.     }
  513. }
  514.  
  515.  
  516.  
  517.  
  518. #------------------------------------------------------------------------
  519. # update(\%params)
  520. #
  521. # Update multiple variables en masse.  No magic is performed.  Simple
  522. # variable names only.
  523. #------------------------------------------------------------------------
  524.  
  525. sub update {
  526.     my ($self, $params) = @_;
  527.  
  528.     # look out for magical 'import' argument to import another hash
  529.     my $import = $params->{ import };
  530.     if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
  531.         @$self{ keys %$import } = values %$import;
  532.         delete $params->{ import };
  533.     }
  534.  
  535.     @$self{ keys %$params } = values %$params;
  536. }
  537.  
  538.  
  539. #------------------------------------------------------------------------
  540. # undefined($ident, $args)
  541. #
  542. # Method called when a get() returns an undefined value.  Can be redefined
  543. # in a subclass to implement alternate handling.
  544. #------------------------------------------------------------------------
  545.  
  546. sub undefined {
  547.     my ($self, $ident, $args);
  548.     return '';
  549. }
  550.  
  551.  
  552. #========================================================================
  553. #                  -----  PRIVATE OBJECT METHODS -----
  554. #========================================================================
  555.  
  556. #------------------------------------------------------------------------
  557. # _dotop($root, $item, \@args, $lvalue)
  558. #
  559. # This is the core 'dot' operation method which evaluates elements of 
  560. # variables against their root.  All variables have an implicit root 
  561. # which is the stash object itself (a hash).  Thus, a non-compound 
  562. # variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is
  563. # '(stash.)foo.bar'.  The first parameter is a reference to the current
  564. # root, initially the stash itself.  The second parameter contains the 
  565. # name of the variable element, e.g. 'foo'.  The third optional
  566. # parameter is a reference to a list of any parenthesised arguments 
  567. # specified for the variable, which are passed to sub-routines, object 
  568. # methods, etc.  The final parameter is an optional flag to indicate 
  569. # if this variable is being evaluated on the left side of an assignment
  570. # (e.g. foo.bar.baz = 10).  When set true, intermediated hashes will 
  571. # be created (e.g. bar) if necessary.  
  572. #
  573. # Returns the result of evaluating the item against the root, having
  574. # performed any variable "magic".  The value returned can then be used
  575. # as the root of the next _dotop() in a compound sequence.  Returns
  576. # undef if the variable is undefined.
  577. #------------------------------------------------------------------------
  578.  
  579. sub _dotop {
  580.     my ($self, $root, $item, $args, $lvalue) = @_;
  581.     my $rootref = ref $root;
  582.     my $atroot  = ($root eq $self);
  583.     my ($value, @result);
  584.  
  585.     $args ||= [ ];
  586.     $lvalue ||= 0;
  587.  
  588. #    print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n"
  589. #   if $DEBUG;
  590.  
  591.     # return undef without an error if either side of the dot is unviable
  592.     # or if an attempt is made to access a private member, starting _ or .
  593.     return undef
  594.         unless defined($root) and defined($item) and $item !~ /^[\._]/;
  595.  
  596.     if ($atroot || $rootref eq 'HASH') {
  597.         # if $root is a regular HASH or a Template::Stash kinda HASH (the 
  598.         # *real* root of everything).  We first lookup the named key 
  599.         # in the hash, or create an empty hash in its place if undefined
  600.         # and the $lvalue flag is set.  Otherwise, we check the HASH_OPS
  601.         # pseudo-methods table, calling the code if found, or return undef.
  602.         
  603.         if (defined($value = $root->{ $item })) {
  604.             return $value unless ref $value eq 'CODE';      ## RETURN
  605.             @result = &$value(@$args);                      ## @result
  606.         }
  607.         elsif ($lvalue) {
  608.             # we create an intermediate hash if this is an lvalue
  609.             return $root->{ $item } = { };                  ## RETURN
  610.         }
  611.         # ugly hack: only allow import vmeth to be called on root stash
  612.         elsif (($value = $HASH_OPS->{ $item })
  613.                && ! $atroot || $item eq 'import') {
  614.             @result = &$value($root, @$args);               ## @result
  615.         }
  616.         elsif ( ref $item eq 'ARRAY' ) {
  617.             # hash slice
  618.             return [@$root{@$item}];                        ## RETURN
  619.         }
  620.     }
  621.     elsif ($rootref eq 'ARRAY') {    
  622.         # if root is an ARRAY then we check for a LIST_OPS pseudo-method 
  623.         # (except for l-values for which it doesn't make any sense)
  624.         # or return the numerical index into the array, or undef
  625.         
  626.         if (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
  627.             @result = &$value($root, @$args);               ## @result
  628.         }
  629.         elsif ($item =~ /^-?\d+$/) {
  630.             $value = $root->[$item];
  631.             return $value unless ref $value eq 'CODE';      ## RETURN
  632.             @result = &$value(@$args);                      ## @result
  633.         }
  634.         elsif ( ref $item eq 'ARRAY' ) {
  635.             # array slice
  636.             return [@$root[@$item]];                        ## RETURN
  637.         }
  638.     }
  639.     
  640.     # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL')
  641.     # doesn't appear to work with CGI, returning true for the first call
  642.     # and false for all subsequent calls. 
  643.     
  644.     elsif (ref($root) && UNIVERSAL::can($root, 'can')) {
  645.  
  646.         # if $root is a blessed reference (i.e. inherits from the 
  647.         # UNIVERSAL object base class) then we call the item as a method.
  648.         # If that fails then we try to fallback on HASH behaviour if 
  649.         # possible.
  650.         eval { @result = $root->$item(@$args); };       
  651.         
  652.         if ($@) {
  653.             # temporary hack - required to propogate errors thrown
  654.             # by views; if $@ is a ref (e.g. Template::Exception
  655.             # object then we assume it's a real error that needs
  656.             # real throwing
  657.             
  658.             die $@ if ref($@) || ($@ !~ /Can't locate object method/);
  659.  
  660.             # failed to call object method, so try some fallbacks
  661. # patch from Stephen Howard
  662. # -- remove from here... --
  663.             if (UNIVERSAL::isa($root, 'HASH')
  664.                 && defined($value = $root->{ $item })) {
  665.                 return $value unless ref $value eq 'CODE';      ## RETURN
  666.                 @result = &$value(@$args);
  667.             }
  668. # -- and replace with this... --
  669. #            if (UNIVERSAL::isa($root, 'HASH') ) {
  670. #                if( defined($value = $root->{ $item })) {
  671. #                    return $value unless ref $value eq 'CODE';      ## RETURN
  672. #                    @result = &$value(@$args);
  673. #                }
  674. #                elsif ($value = $HASH_OPS->{ $item }) {
  675. #                    @result = &$value($root, @$args);
  676. #                }
  677. #            }
  678. # -- remove from here... --
  679.             elsif (UNIVERSAL::isa($root, 'ARRAY') 
  680.                && ($value = $LIST_OPS->{ $item })) {
  681.                 @result = &$value($root, @$args);
  682.             }
  683. # -- and replace with this... --
  684. #            elsif (UNIVERSAL::isa($root, 'ARRAY') ) {
  685. #                if( $value = $LIST_OPS->{ $item }) {
  686. #                   @result = &$value($root, @$args);
  687. #                }
  688. #                elsif( $item =~ /^-?\d+$/ ) {
  689. #                   $value = $root->[$item];
  690. #                   return $value unless ref $value eq 'CODE';      ## RETURN
  691. #                   @result = &$value(@$args);                      ## @result
  692. #                }
  693. #                elsif ( ref $item eq 'ARRAY' ) {
  694. #                    # array slice
  695. #                    return [@$root[@$item]];                        ## RETURN
  696. #                }
  697. #            }
  698. # -- end --
  699.             elsif ($value = $SCALAR_OPS->{ $item }) {
  700.                 @result = &$value($root, @$args);
  701.             }
  702.             elsif ($value = $LIST_OPS->{ $item }) {
  703.                 @result = &$value([$root], @$args);
  704.             }
  705.             elsif ($self->{ _DEBUG }) {
  706.                 @result = (undef, $@);
  707.             }
  708.         }
  709.     }
  710.     elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
  711.         # at this point, it doesn't look like we've got a reference to
  712.         # anything we know about, so we try the SCALAR_OPS pseudo-methods
  713.         # table (but not for l-values)
  714.         @result = &$value($root, @$args);           ## @result
  715.     }
  716.     elsif (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
  717.         # last-ditch: can we promote a scalar to a one-element
  718.         # list and apply a LIST_OPS virtual method?
  719.         @result = &$value([$root], @$args);
  720.     }
  721.     elsif ($self->{ _DEBUG }) {
  722.         die "don't know how to access [ $root ].$item\n";   ## DIE
  723.     }
  724.     else {
  725.         @result = ();
  726.     }
  727.  
  728.     # fold multiple return items into a list unless first item is undef
  729.     if (defined $result[0]) {
  730.         return                              ## RETURN
  731.         scalar @result > 1 ? [ @result ] : $result[0];
  732.     }
  733.     elsif (defined $result[1]) {
  734.         die $result[1];                     ## DIE
  735.     }
  736.     elsif ($self->{ _DEBUG }) {
  737.         die "$item is undefined\n";         ## DIE
  738.     }
  739.  
  740.     return undef;
  741. }
  742.  
  743.  
  744. #------------------------------------------------------------------------
  745. # _assign($root, $item, \@args, $value, $default)
  746. #
  747. # Similar to _dotop() above, but assigns a value to the given variable
  748. # instead of simply returning it.  The first three parameters are the
  749. # root item, the item and arguments, as per _dotop(), followed by the 
  750. # value to which the variable should be set and an optional $default
  751. # flag.  If set true, the variable will only be set if currently false
  752. # (undefined/zero)
  753. #------------------------------------------------------------------------
  754.  
  755. sub _assign {
  756.     my ($self, $root, $item, $args, $value, $default) = @_;
  757.     my $rootref = ref $root;
  758.     my $atroot  = ($root eq $self);
  759.     my $result;
  760.     $args ||= [ ];
  761.     $default ||= 0;
  762.  
  763. #    print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n",
  764. #                         "value=$value, default=$default)\n")
  765. #   if $DEBUG;
  766.     
  767.     # return undef without an error if either side of the dot is unviable
  768.     # or if an attempt is made to update a private member, starting _ or .
  769.     return undef                        ## RETURN
  770.     unless $root and defined $item and $item !~ /^[\._]/;
  771.     
  772.     if ($rootref eq 'HASH' || $atroot) {
  773. #   if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) {
  774. #       # import hash entries into root hash
  775. #       @$root{ keys %$value } = values %$value;
  776. #       return '';                      ## RETURN
  777. #   }
  778.         # if the root is a hash we set the named key
  779.         return ($root->{ $item } = $value)          ## RETURN
  780.             unless $default && $root->{ $item };
  781.     }
  782.     elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) {
  783.         # or set a list item by index number
  784.         return ($root->[$item] = $value)            ## RETURN
  785.             unless $default && $root->{ $item };
  786.     }
  787.     elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) {
  788.         # try to call the item as a method of an object
  789.         
  790.         return $root->$item(@$args, $value)         ## RETURN
  791.             unless $default && $root->$item();
  792.         
  793. # 2 issues:
  794. #   - method call should be wrapped in eval { }
  795. #   - fallback on hash methods if object method not found
  796. #
  797. #     eval { $result = $root->$item(@$args, $value); };     
  798. # 
  799. #     if ($@) {
  800. #         die $@ if ref($@) || ($@ !~ /Can't locate object method/);
  801. # 
  802. #         # failed to call object method, so try some fallbacks
  803. #         if (UNIVERSAL::isa($root, 'HASH') && exists $root->{ $item }) {
  804. #         $result = ($root->{ $item } = $value)
  805. #             unless $default && $root->{ $item };
  806. #         }
  807. #     }
  808. #     return $result;                       ## RETURN
  809.  
  810.     }
  811.     else {
  812.         die "don't know how to assign to [$root].[$item]\n";    ## DIE
  813.     }
  814.  
  815.     return undef;
  816. }
  817.  
  818.  
  819. #------------------------------------------------------------------------
  820. # _dump()
  821. #
  822. # Debug method which returns a string representing the internal state
  823. # of the object.  The method calls itself recursively to dump sub-hashes.
  824. #------------------------------------------------------------------------
  825.  
  826. sub _dump {
  827.     my $self   = shift;
  828.     return "[Template::Stash] " . $self->_dump_frame(2);
  829. }
  830.  
  831. sub _dump_frame {
  832.     my ($self, $indent) = @_;
  833.     $indent ||= 1;
  834.     my $buffer = '    ';
  835.     my $pad    = $buffer x $indent;
  836.     my $text   = "{\n";
  837.     local $" = ', ';
  838.  
  839.     my ($key, $value);
  840.  
  841.     return $text . "...excessive recursion, terminating\n"
  842.         if $indent > 32;
  843.     
  844.     foreach $key (keys %$self) {
  845.         $value = $self->{ $key };
  846.         $value = '<undef>' unless defined $value;
  847.         next if $key =~ /^\./;
  848.         if (ref($value) eq 'ARRAY') {
  849.             $value = '[ ' . join(', ', map { defined $_ ? $_ : '<undef>' }
  850.                                  @$value) . ' ]';
  851.         }
  852.         elsif (ref $value eq 'HASH') {
  853.             $value = _dump_frame($value, $indent + 1);
  854.         }
  855.         
  856.         $text .= sprintf("$pad%-16s => $value\n", $key);
  857.     }
  858.     $text .= $buffer x ($indent - 1) . '}';
  859.     return $text;
  860. }
  861.  
  862.  
  863. 1;
  864.  
  865. __END__
  866.  
  867.  
  868. #------------------------------------------------------------------------
  869. # IMPORTANT NOTE
  870. #   This documentation is generated automatically from source
  871. #   templates.  Any changes you make here may be lost.
  872. # 
  873. #   The 'docsrc' documentation source bundle is available for download
  874. #   from http://www.template-toolkit.org/docs.html and contains all
  875. #   the source templates, XML files, scripts, etc., from which the
  876. #   documentation for the Template Toolkit is built.
  877. #------------------------------------------------------------------------
  878.  
  879. =head1 NAME
  880.  
  881. Template::Stash - Magical storage for template variables
  882.  
  883. =head1 SYNOPSIS
  884.  
  885.     use Template::Stash;
  886.  
  887.     my $stash = Template::Stash->new(\%vars);
  888.  
  889.     # get variable values
  890.     $value = $stash->get($variable);
  891.     $value = $stash->get(\@compound);
  892.  
  893.     # set variable value
  894.     $stash->set($variable, $value);
  895.     $stash->set(\@compound, $value);
  896.  
  897.     # default variable value
  898.     $stash->set($variable, $value, 1);
  899.     $stash->set(\@compound, $value, 1);
  900.  
  901.     # set variable values en masse
  902.     $stash->update(\%new_vars)
  903.  
  904.     # methods for (de-)localising variables
  905.     $stash = $stash->clone(\%new_vars);
  906.     $stash = $stash->declone();
  907.  
  908. =head1 DESCRIPTION
  909.  
  910. The Template::Stash module defines an object class which is used to store
  911. variable values for the runtime use of the template processor.  Variable
  912. values are stored internally in a hash reference (which itself is blessed 
  913. to create the object) and are accessible via the get() and set() methods.
  914.  
  915. Variables may reference hash arrays, lists, subroutines and objects
  916. as well as simple values.  The stash automatically performs the right
  917. magic when dealing with variables, calling code or object methods,
  918. indexing into lists, hashes, etc.
  919.  
  920. The stash has clone() and declone() methods which are used by the
  921. template processor to make temporary copies of the stash for
  922. localising changes made to variables.
  923.  
  924. =head1 PUBLIC METHODS
  925.  
  926. =head2 new(\%params)
  927.  
  928. The new() constructor method creates and returns a reference to a new
  929. Template::Stash object.  
  930.  
  931.     my $stash = Template::Stash->new();
  932.  
  933. A hash reference may be passed to provide variables and values which
  934. should be used to initialise the stash.
  935.  
  936.     my $stash = Template::Stash->new({ var1 => 'value1', 
  937.                        var2 => 'value2' });
  938.  
  939. =head2 get($variable)
  940.  
  941. The get() method retrieves the variable named by the first parameter.
  942.  
  943.     $value = $stash->get('var1');
  944.  
  945. Dotted compound variables can be retrieved by specifying the variable
  946. elements by reference to a list.  Each node in the variable occupies
  947. two entries in the list.  The first gives the name of the variable
  948. element, the second is a reference to a list of arguments for that 
  949. element, or 0 if none.
  950.  
  951.     [% foo.bar(10).baz(20) %]
  952.  
  953.     $stash->get([ 'foo', 0, 'bar', [ 10 ], 'baz', [ 20 ] ]);
  954.  
  955. =head2 set($variable, $value, $default)
  956.  
  957. The set() method sets the variable name in the first parameter to the 
  958. value specified in the second.
  959.  
  960.     $stash->set('var1', 'value1');
  961.  
  962. If the third parameter evaluates to a true value, the variable is
  963. set only if it did not have a true value before.
  964.  
  965.     $stash->set('var2', 'default_value', 1);
  966.  
  967. Dotted compound variables may be specified as per get() above.
  968.  
  969.     [% foo.bar = 30 %]
  970.  
  971.     $stash->set([ 'foo', 0, 'bar', 0 ], 30);
  972.  
  973. The magical variable 'IMPORT' can be specified whose corresponding
  974. value should be a hash reference.  The contents of the hash array are
  975. copied (i.e. imported) into the current namespace.
  976.  
  977.     # foo.bar = baz, foo.wiz = waz
  978.     $stash->set('foo', { 'bar' => 'baz', 'wiz' => 'waz' });
  979.  
  980.     # import 'foo' into main namespace: foo = baz, wiz = waz
  981.     $stash->set('IMPORT', $stash->get('foo'));
  982.  
  983. =head2 clone(\%params)
  984.  
  985. The clone() method creates and returns a new Template::Stash object which
  986. represents a localised copy of the parent stash.  Variables can be
  987. freely updated in the cloned stash and when declone() is called, the
  988. original stash is returned with all its members intact and in the
  989. same state as they were before clone() was called.
  990.  
  991. For convenience, a hash of parameters may be passed into clone() which 
  992. is used to update any simple variable (i.e. those that don't contain any 
  993. namespace elements like 'foo' and 'bar' but not 'foo.bar') variables while 
  994. cloning the stash.  For adding and updating complex variables, the set() 
  995. method should be used after calling clone().  This will correctly resolve
  996. and/or create any necessary namespace hashes.
  997.  
  998. A cloned stash maintains a reference to the stash that it was copied 
  999. from in its '_PARENT' member.
  1000.  
  1001. =head2 declone()
  1002.  
  1003. The declone() method returns the '_PARENT' reference and can be used to
  1004. restore the state of a stash as described above.
  1005.  
  1006. =head1 AUTHOR
  1007.  
  1008. Andy Wardley E<lt>abw@andywardley.comE<gt>
  1009.  
  1010. L<http://www.andywardley.com/|http://www.andywardley.com/>
  1011.  
  1012.  
  1013.  
  1014.  
  1015. =head1 VERSION
  1016.  
  1017. 2.85, distributed as part of the
  1018. Template Toolkit version 2.13, released on 30 January 2004.
  1019.  
  1020. =head1 COPYRIGHT
  1021.  
  1022.   Copyright (C) 1996-2004 Andy Wardley.  All Rights Reserved.
  1023.   Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
  1024.  
  1025. This module is free software; you can redistribute it and/or
  1026. modify it under the same terms as Perl itself.
  1027.  
  1028. =head1 SEE ALSO
  1029.  
  1030. L<Template|Template>, L<Template::Context|Template::Context>
  1031.  
  1032. =cut
  1033.  
  1034. # Local Variables:
  1035. # mode: perl
  1036. # perl-indent-level: 4
  1037. # indent-tabs-mode: nil
  1038. # End:
  1039. #
  1040. # vim: expandtab shiftwidth=4:
  1041.