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 / Context.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-30  |  26.3 KB  |  792 lines
  1. #============================================================= -*-Perl-*-
  2. #
  3. # Template::Stash::Context
  4. #
  5. # DESCRIPTION
  6. #   This is an alternate stash object which includes a patch from 
  7. #   Craig Barratt to implement various new virtual methods to allow
  8. #   dotted template variable to denote if object methods and subroutines
  9. #   should be called in scalar or list context.  It adds a little overhead
  10. #   to each stash call and I'm a little wary of doing that.  So for now,
  11. #   it's implemented as a separate stash module which will allow us to 
  12. #   test it out, benchmark it and switch it in or out as we require.
  13. #
  14. #   This is what Craig has to say about it:
  15. #   
  16. #   Here's a better set of features for the core.  Attached is a new version
  17. #   of Stash.pm (based on TT2.02) that:
  18. #   
  19. #     - supports the special op "scalar" that forces scalar context on
  20. #       function calls, eg:
  21. #   
  22. #           cgi.param("foo").scalar
  23. #   
  24. #       calls cgi.param("foo") in scalar context (unlike my wimpy
  25. #       scalar op from last night).  Array context is the default.
  26. #   
  27. #       With non-function operands, scalar behaves like the perl
  28. #       version (eg: no-op for scalar, size for arrays, etc).
  29. #   
  30. #     - supports the special op "ref" that behaves like the perl ref.
  31. #       If applied to a function the function is not called.  Eg:
  32. #   
  33. #           cgi.param("foo").ref
  34. #   
  35. #       does *not* call cgi.param and evaluates to "CODE".  Similarly,
  36. #       HASH.ref, ARRAY.ref return what you expect.
  37. #   
  38. #     - adds a new scalar and list op called "array" that is a no-op for
  39. #       arrays and promotes scalars to one-element arrays.
  40. #   
  41. #     - allows scalar ops to be applied to arrays and hashes in place,
  42. #       eg: ARRAY.repeat(3) repeats each element in place.
  43. #   
  44. #     - allows list ops to be applied to scalars by promoting the scalars
  45. #       to one-element arrays (like an implicit "array").  So you can
  46. #       do things like SCALAR.size, SCALAR.join and get a useful result.
  47. #   
  48. #       This also means you can now use x.0 to safely get the first element
  49. #       whether x is an array or scalar.
  50. #   
  51. #   The new Stash.pm passes the TT2.02 test suite.  But I haven't tested the
  52. #   new features very much.  One nagging implementation problem is that the
  53. #   "scalar" and "ref" ops have higher precedence than user variable names.
  54. #   
  55. # AUTHORS
  56. #   Andy Wardley  <abw@kfs.org>
  57. #   Craig Barratt <craig@arraycomm.com>
  58. #
  59. # COPYRIGHT
  60. #   Copyright (C) 1996-2001 Andy Wardley.  All Rights Reserved.
  61. #   Copyright (C) 1998-2001 Canon Research Centre Europe Ltd.
  62. #
  63. #   This module is free software; you can redistribute it and/or
  64. #   modify it under the same terms as Perl itself.
  65. #
  66. #----------------------------------------------------------------------------
  67. #
  68. # $Id: Context.pm,v 1.58 2004/01/13 16:21:52 abw Exp $
  69. #
  70. #============================================================================
  71.  
  72. package Template::Stash::Context;
  73.  
  74. require 5.004;
  75.  
  76. use strict;
  77. use Template::Stash;
  78. use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS );
  79.  
  80. $VERSION = sprintf("%d.%02d", q$Revision: 1.58 $ =~ /(\d+)\.(\d+)/);
  81.  
  82.  
  83. #========================================================================
  84. #                    -- PACKAGE VARIABLES AND SUBS --
  85. #========================================================================
  86.  
  87. #------------------------------------------------------------------------
  88. # copy virtual methods from those in the regular Template::Stash
  89. #------------------------------------------------------------------------
  90.  
  91. $ROOT_OPS = { 
  92.     %$Template::Stash::ROOT_OPS,
  93.     defined $ROOT_OPS ? %$ROOT_OPS : (),
  94. };
  95.  
  96. $SCALAR_OPS = { 
  97.     %$Template::Stash::SCALAR_OPS,
  98.     'array' => sub { return [$_[0]] },
  99.     defined $SCALAR_OPS ? %$SCALAR_OPS : (),
  100. };
  101.  
  102. $LIST_OPS = { 
  103.     %$Template::Stash::LIST_OPS,
  104.     'array' => sub { return $_[0] },
  105.     defined $LIST_OPS ? %$LIST_OPS : (),
  106. };
  107.             
  108. $HASH_OPS = { 
  109.     %$Template::Stash::HASH_OPS,
  110.     defined $HASH_OPS ? %$HASH_OPS : (),
  111. };
  112.  
  113.  
  114.  
  115. #========================================================================
  116. #                      -----  CLASS METHODS -----
  117. #========================================================================
  118.  
  119. #------------------------------------------------------------------------
  120. # new(\%params)
  121. #
  122. # Constructor method which creates a new Template::Stash object.
  123. # An optional hash reference may be passed containing variable 
  124. # definitions that will be used to initialise the stash.
  125. #
  126. # Returns a reference to a newly created Template::Stash.
  127. #------------------------------------------------------------------------
  128.  
  129. sub new {
  130.     my $class  = shift;
  131.     my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };
  132.  
  133.     my $self   = {
  134.     global  => { },
  135.     %$params,
  136.     %$ROOT_OPS,
  137.     '_PARENT' => undef,
  138.     };
  139.  
  140.     bless $self, $class;
  141. }
  142.  
  143.  
  144. #========================================================================
  145. #                   -----  PUBLIC OBJECT METHODS -----
  146. #========================================================================
  147.  
  148. #------------------------------------------------------------------------
  149. # clone(\%params)
  150. #
  151. # Creates a copy of the current stash object to effect localisation 
  152. # of variables.  The new stash is blessed into the same class as the 
  153. # parent (which may be a derived class) and has a '_PARENT' member added
  154. # which contains a reference to the parent stash that created it
  155. # ($self).  This member is used in a successive declone() method call to
  156. # return the reference to the parent.
  157. # 
  158. # A parameter may be provided which should reference a hash of 
  159. # variable/values which should be defined in the new stash.  The 
  160. # update() method is called to define these new variables in the cloned
  161. # stash.
  162. #
  163. # Returns a reference to a cloned Template::Stash.
  164. #------------------------------------------------------------------------
  165.  
  166. sub clone {
  167.     my ($self, $params) = @_;
  168.     $params ||= { };
  169.  
  170.     # look out for magical 'import' argument which imports another hash
  171.     my $import = $params->{ import };
  172.     if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
  173.     delete $params->{ import };
  174.     }
  175.     else {
  176.     undef $import;
  177.     }
  178.  
  179.     my $clone = bless { 
  180.     %$self,            # copy all parent members
  181.     %$params,        # copy all new data
  182.         '_PARENT' => $self,     # link to parent
  183.     }, ref $self;
  184.     
  185.     # perform hash import if defined
  186.     &{ $HASH_OPS->{ import }}($clone, $import)
  187.     if defined $import;
  188.  
  189.     return $clone;
  190. }
  191.  
  192.     
  193. #------------------------------------------------------------------------
  194. # declone($export) 
  195. #
  196. # Returns a reference to the PARENT stash.  When called in the following
  197. # manner:
  198. #    $stash = $stash->declone();
  199. # the reference count on the current stash will drop to 0 and be "freed"
  200. # and the caller will be left with a reference to the parent.  This 
  201. # contains the state of the stash before it was cloned.  
  202. #------------------------------------------------------------------------
  203.  
  204. sub declone {
  205.     my $self = shift;
  206.     $self->{ _PARENT } || $self;
  207. }
  208.  
  209.  
  210. #------------------------------------------------------------------------
  211. # get($ident)
  212. # 
  213. # Returns the value for an variable stored in the stash.  The variable
  214. # may be specified as a simple string, e.g. 'foo', or as an array 
  215. # reference representing compound variables.  In the latter case, each
  216. # pair of successive elements in the list represent a node in the 
  217. # compound variable.  The first is the variable name, the second a 
  218. # list reference of arguments or 0 if undefined.  So, the compound 
  219. # variable [% foo.bar('foo').baz %] would be represented as the list
  220. # [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ].  Returns the value of the
  221. # identifier or an empty string if undefined.  Errors are thrown via
  222. # die().
  223. #------------------------------------------------------------------------
  224.  
  225. sub get {
  226.     my ($self, $ident, $args) = @_;
  227.     my ($root, $result);
  228.     $root = $self;
  229.  
  230.     if (ref $ident eq 'ARRAY'
  231.     || ($ident =~ /\./) 
  232.     && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) {
  233.     my $size = $#$ident;
  234.  
  235.     # if $ident is a list reference, then we evaluate each item in the 
  236.     # identifier against the previous result, using the root stash 
  237.     # ($self) as the first implicit 'result'...
  238.  
  239.     foreach (my $i = 0; $i <= $size; $i += 2) {
  240.         if ( $i + 2 <= $size && ($ident->[$i+2] eq "scalar"
  241.                                     || $ident->[$i+2] eq "ref") ) {
  242.                 $result = $self->_dotop($root, @$ident[$i, $i+1], 0,
  243.                                         $ident->[$i+2]);
  244.                 $i += 2;
  245.         } else {
  246.                 $result = $self->_dotop($root, @$ident[$i, $i+1]);
  247.             }
  248.         last unless defined $result;
  249.         $root = $result;
  250.     }
  251.     }
  252.     else {
  253.     $result = $self->_dotop($root, $ident, $args);
  254.     }
  255.  
  256.     return defined $result ? $result : '';
  257. }
  258.  
  259.  
  260. #------------------------------------------------------------------------
  261. # set($ident, $value, $default)
  262. #
  263. # Updates the value for a variable in the stash.  The first parameter
  264. # should be the variable name or array, as per get().  The second 
  265. # parameter should be the intended value for the variable.  The third,
  266. # optional parameter is a flag which may be set to indicate 'default'
  267. # mode.  When set true, the variable will only be updated if it is
  268. # currently undefined or has a false value.  The magical 'IMPORT'
  269. # variable identifier may be used to indicate that $value is a hash
  270. # reference whose values should be imported.  Returns the value set,
  271. # or an empty string if not set (e.g. default mode).  In the case of 
  272. # IMPORT, returns the number of items imported from the hash.
  273. #------------------------------------------------------------------------
  274.  
  275. sub set {
  276.     my ($self, $ident, $value, $default) = @_;
  277.     my ($root, $result, $error);
  278.  
  279.     $root = $self;
  280.  
  281.     ELEMENT: {
  282.     if (ref $ident eq 'ARRAY'
  283.         || ($ident =~ /\./) 
  284.         && ($ident = [ map { s/\(.*$//; ($_, 0) }
  285.                split(/\./, $ident) ])) {
  286.  
  287.         # a compound identifier may contain multiple elements (e.g. 
  288.         # foo.bar.baz) and we must first resolve all but the last, 
  289.         # using _dotop() with the $lvalue flag set which will create 
  290.         # intermediate hashes if necessary...
  291.         my $size = $#$ident;
  292.         foreach (my $i = 0; $i < $size - 2; $i += 2) {
  293.         $result = $self->_dotop($root, @$ident[$i, $i+1], 1);
  294.         last ELEMENT unless defined $result;
  295.         $root = $result;
  296.         }
  297.  
  298.         # then we call _assign() to assign the value to the last element
  299.         $result = $self->_assign($root, @$ident[$size-1, $size], 
  300.                      $value, $default);
  301.     }
  302.     else {
  303.         $result = $self->_assign($root, $ident, 0, $value, $default);
  304.     }
  305.     }
  306.  
  307.     return defined $result ? $result : '';
  308. }
  309.  
  310.  
  311. #------------------------------------------------------------------------
  312. # getref($ident)
  313. # 
  314. # Returns a "reference" to a particular item.  This is represented as a 
  315. # closure which will return the actual stash item when called.  
  316. # WARNING: still experimental!
  317. #------------------------------------------------------------------------
  318.  
  319. sub getref {
  320.     my ($self, $ident, $args) = @_;
  321.     my ($root, $item, $result);
  322.     $root = $self;
  323.  
  324.     if (ref $ident eq 'ARRAY') {
  325.     my $size = $#$ident;
  326.  
  327.     foreach (my $i = 0; $i <= $size; $i += 2) {
  328.         ($item, $args) = @$ident[$i, $i + 1]; 
  329.         last if $i >= $size - 2;  # don't evaluate last node
  330.         last unless defined 
  331.         ($root = $self->_dotop($root, $item, $args));
  332.     }
  333.     }
  334.     else {
  335.     $item = $ident;
  336.     }
  337.  
  338.     if (defined $root) {
  339.         return sub { my @args = (@{$args||[]}, @_);
  340.              $self->_dotop($root, $item, \@args);
  341.          }
  342.     }
  343.     else {
  344.     return sub { '' };
  345.     }
  346. }
  347.  
  348.  
  349.  
  350.  
  351. #------------------------------------------------------------------------
  352. # update(\%params)
  353. #
  354. # Update multiple variables en masse.  No magic is performed.  Simple
  355. # variable names only.
  356. #------------------------------------------------------------------------
  357.  
  358. sub update {
  359.     my ($self, $params) = @_;
  360.  
  361.     # look out for magical 'import' argument to import another hash
  362.     my $import = $params->{ import };
  363.     if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
  364.     @$self{ keys %$import } = values %$import;
  365.     delete $params->{ import };
  366.     }
  367.  
  368.     @$self{ keys %$params } = values %$params;
  369. }
  370.  
  371.  
  372. #========================================================================
  373. #                  -----  PRIVATE OBJECT METHODS -----
  374. #========================================================================
  375.  
  376. #------------------------------------------------------------------------
  377. # _dotop($root, $item, \@args, $lvalue, $nextItem)
  378. #
  379. # This is the core 'dot' operation method which evaluates elements of 
  380. # variables against their root.  All variables have an implicit root 
  381. # which is the stash object itself (a hash).  Thus, a non-compound 
  382. # variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is
  383. # '(stash.)foo.bar'.  The first parameter is a reference to the current
  384. # root, initially the stash itself.  The second parameter contains the 
  385. # name of the variable element, e.g. 'foo'.  The third optional
  386. # parameter is a reference to a list of any parenthesised arguments 
  387. # specified for the variable, which are passed to sub-routines, object 
  388. # methods, etc.  The final parameter is an optional flag to indicate 
  389. # if this variable is being evaluated on the left side of an assignment
  390. # (e.g. foo.bar.baz = 10).  When set true, intermediated hashes will 
  391. # be created (e.g. bar) if necessary.  
  392. #
  393. # Returns the result of evaluating the item against the root, having
  394. # performed any variable "magic".  The value returned can then be used
  395. # as the root of the next _dotop() in a compound sequence.  Returns
  396. # undef if the variable is undefined.
  397. #------------------------------------------------------------------------
  398.  
  399. sub _dotop {
  400.     my ($self, $root, $item, $args, $lvalue, $nextItem) = @_;
  401.     my $rootref = ref $root;
  402.     my ($value, @result, $ret, $retVal);
  403.     $nextItem ||= "";
  404.     my $scalarContext = 1 if ( $nextItem eq "scalar" );
  405.     my $returnRef = 1     if ( $nextItem eq "ref" );
  406.  
  407.     $args ||= [ ];
  408.     $lvalue ||= 0;
  409.  
  410. #    print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n"
  411. #    if $DEBUG;
  412.  
  413.     # return undef without an error if either side of the dot is unviable
  414.     # or if an attempt is made to access a private member, starting _ or .
  415.     return undef
  416.     unless defined($root) and defined($item) and $item !~ /^[\._]/;
  417.  
  418.     if (ref(\$root) eq "SCALAR" && !$lvalue &&
  419.             (($value = $LIST_OPS->{ $item }) || $item =~ /^-?\d+$/) ) {
  420.         #
  421.         # Promote scalar to one element list, to be processed below.
  422.         #
  423.         $rootref = 'ARRAY';
  424.         $root = [$root];
  425.     }
  426.     if ($rootref eq __PACKAGE__ || $rootref eq 'HASH') {
  427.  
  428.     # if $root is a regular HASH or a Template::Stash kinda HASH (the 
  429.     # *real* root of everything).  We first lookup the named key 
  430.     # in the hash, or create an empty hash in its place if undefined
  431.     # and the $lvalue flag is set.  Otherwise, we check the HASH_OPS
  432.     # pseudo-methods table, calling the code if found, or return undef.
  433.  
  434.     if (defined($value = $root->{ $item })) {
  435.             ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
  436.                                                      $scalarContext);
  437.             return $retVal if ( $ret );                     ## RETURN
  438.         }
  439.     elsif ($lvalue) {
  440.         # we create an intermediate hash if this is an lvalue
  441.         return $root->{ $item } = { };            ## RETURN
  442.     }
  443.     elsif ($value = $HASH_OPS->{ $item }) {
  444.         @result = &$value($root, @$args);            ## @result
  445.     }
  446.     elsif (ref $item eq 'ARRAY') {
  447.         # hash slice
  448.         return [@$root{@$item}];                       ## RETURN
  449.     }
  450.     elsif ($value = $SCALAR_OPS->{ $item }) {
  451.         #
  452.         # Apply scalar ops to every hash element, in place.
  453.         #
  454.         foreach my $key ( keys %$root ) {
  455.                 $root->{$key} = &$value($root->{$key}, @$args);
  456.             }
  457.     }
  458.     }
  459.     elsif ($rootref eq 'ARRAY') {
  460.  
  461.     # if root is an ARRAY then we check for a LIST_OPS pseudo-method 
  462.     # (except for l-values for which it doesn't make any sense)
  463.     # or return the numerical index into the array, or undef
  464.  
  465.     if (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
  466.         @result = &$value($root, @$args);            ## @result
  467.     }
  468.     elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
  469.         #
  470.         # Apply scalar ops to every array element, in place.
  471.         #
  472.         for ( my $i = 0 ; $i < @$root ; $i++ ) {
  473.                 $root->[$i] = &$value($root->[$i], @$args); ## @result
  474.             }
  475.     }
  476.     elsif ($item =~ /^-?\d+$/) {
  477.         $value = $root->[$item];
  478.             ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
  479.                                                      $scalarContext);
  480.             return $retVal if ( $ret );                     ## RETURN
  481.     }
  482.         elsif (ref $item eq 'ARRAY' ) {
  483.             # array slice
  484.             return [@$root[@$item]];                        ## RETURN
  485.         }
  486.     }
  487.  
  488.     # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL')
  489.     # doesn't appear to work with CGI, returning true for the first call
  490.     # and false for all subsequent calls. 
  491.  
  492.     elsif (ref($root) && UNIVERSAL::can($root, 'can')) {
  493.  
  494.     # if $root is a blessed reference (i.e. inherits from the 
  495.     # UNIVERSAL object base class) then we call the item as a method.
  496.     # If that fails then we try to fallback on HASH behaviour if 
  497.     # possible.
  498.         return ref $root->can($item) if ( $returnRef );       ## RETURN
  499.     eval {
  500.             @result = $scalarContext ? scalar $root->$item(@$args)
  501.                                      : $root->$item(@$args);  ## @result
  502.         };
  503.  
  504.     if ($@) {
  505.         # failed to call object method, so try some fallbacks
  506.         if (UNIVERSAL::isa($root, 'HASH')
  507.                     && defined($value = $root->{ $item })) {
  508.                 ($ret, $retVal, @result) = _dotop_return($value, $args,
  509.                                                     $returnRef, $scalarContext);
  510.                 return $retVal if ( $ret );                     ## RETURN
  511.         }
  512.         elsif (UNIVERSAL::isa($root, 'ARRAY') 
  513.            && ($value = $LIST_OPS->{ $item })) {
  514.         @result = &$value($root, @$args);
  515.         }
  516.         else {
  517.         @result = (undef, $@);
  518.         }
  519.     }
  520.     }
  521.     elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
  522.  
  523.     # at this point, it doesn't look like we've got a reference to
  524.     # anything we know about, so we try the SCALAR_OPS pseudo-methods
  525.     # table (but not for l-values)
  526.  
  527.     @result = &$value($root, @$args);            ## @result
  528.     }
  529.     elsif ($self->{ _DEBUG }) {
  530.     die "don't know how to access [ $root ].$item\n";   ## DIE
  531.     }
  532.     else {
  533.     @result = ();
  534.     }
  535.  
  536.     # fold multiple return items into a list unless first item is undef
  537.     if (defined $result[0]) {
  538.     return ref(@result > 1 ? [ @result ] : $result[0])
  539.                                             if ( $returnRef );  ## RETURN
  540.     if ( $scalarContext ) {
  541.             return scalar @result if ( @result > 1 );           ## RETURN
  542.             return scalar(@{$result[0]}) if ( ref $result[0] eq "ARRAY" );
  543.             return scalar(%{$result[0]}) if ( ref $result[0] eq "HASH" );
  544.             return $result[0];                                  ## RETURN
  545.         } else {
  546.             return @result > 1 ? [ @result ] : $result[0];      ## RETURN
  547.         }
  548.     }
  549.     elsif (defined $result[1]) {
  550.     die $result[1];                        ## DIE
  551.     }
  552.     elsif ($self->{ _DEBUG }) {
  553.     die "$item is undefined\n";                ## DIE
  554.     }
  555.  
  556.     return undef;
  557. }
  558.  
  559. #------------------------------------------------------------------------
  560. # ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
  561. #                                          $scalarContext);
  562. #
  563. # Handle the various return processing for _dotop
  564. #------------------------------------------------------------------------
  565. sub _dotop_return
  566. {
  567.     my($value, $args, $returnRef, $scalarContext) = @_;
  568.     my(@result);
  569.  
  570.     return (1, ref $value) if ( $returnRef );                     ## RETURN
  571.     if ( $scalarContext ) {
  572.         return (1, scalar(@$value)) if ref $value eq 'ARRAY';     ## RETURN
  573.         return (1, scalar(%$value)) if ref $value eq 'HASH';      ## RETURN
  574.         return (1, scalar($value))  unless ref $value eq 'CODE';  ## RETURN;
  575.         @result = scalar &$value(@$args)                          ## @result;
  576.     } else {
  577.         return (1, $value) unless ref $value eq 'CODE';           ## RETURN
  578.         @result = &$value(@$args);                                ## @result
  579.     }
  580.     return (0, undef, @result);
  581. }
  582.  
  583.  
  584. #------------------------------------------------------------------------
  585. # _assign($root, $item, \@args, $value, $default)
  586. #
  587. # Similar to _dotop() above, but assigns a value to the given variable
  588. # instead of simply returning it.  The first three parameters are the
  589. # root item, the item and arguments, as per _dotop(), followed by the 
  590. # value to which the variable should be set and an optional $default
  591. # flag.  If set true, the variable will only be set if currently false
  592. # (undefined/zero)
  593. #------------------------------------------------------------------------
  594.  
  595. sub _assign {
  596.     my ($self, $root, $item, $args, $value, $default) = @_;
  597.     my $rootref = ref $root;
  598.     my $result;
  599.     $args ||= [ ];
  600.     $default ||= 0;
  601.  
  602. #    print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n",
  603. #                         "value=$value, default=$default)\n")
  604. #    if $DEBUG;
  605.  
  606.     # return undef without an error if either side of the dot is unviable
  607.     # or if an attempt is made to update a private member, starting _ or .
  608.     return undef                        ## RETURN
  609.     unless $root and defined $item and $item !~ /^[\._]/;
  610.     
  611.     if ($rootref eq 'HASH' || $rootref eq __PACKAGE__) {
  612. #    if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) {
  613. #        # import hash entries into root hash
  614. #        @$root{ keys %$value } = values %$value;
  615. #        return '';                        ## RETURN
  616. #    }
  617.     # if the root is a hash we set the named key
  618.     return ($root->{ $item } = $value)            ## RETURN
  619.         unless $default && $root->{ $item };
  620.     }
  621.     elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) {
  622.     # or set a list item by index number
  623.     return ($root->[$item] = $value)            ## RETURN
  624.         unless $default && $root->{ $item };
  625.     }
  626.     elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) {
  627.     # try to call the item as a method of an object
  628.     return $root->$item(@$args, $value);            ## RETURN
  629.     }
  630.     else {
  631.     die "don't know how to assign to [$root].[$item]\n";    ## DIE
  632.     }
  633.  
  634.     return undef;
  635. }
  636.  
  637.  
  638. #------------------------------------------------------------------------
  639. # _dump()
  640. #
  641. # Debug method which returns a string representing the internal state
  642. # of the object.  The method calls itself recursively to dump sub-hashes.
  643. #------------------------------------------------------------------------
  644.  
  645. sub _dump {
  646.     my $self   = shift;
  647.     my $indent = shift || 1;
  648.     my $buffer = '    ';
  649.     my $pad    = $buffer x $indent;
  650.     my $text   = '';
  651.     local $" = ', ';
  652.  
  653.     my ($key, $value);
  654.  
  655.  
  656.     return $text . "...excessive recursion, terminating\n"
  657.     if $indent > 32;
  658.  
  659.     foreach $key (keys %$self) {
  660.  
  661.     $value = $self->{ $key };
  662.     $value = '<undef>' unless defined $value;
  663.  
  664.     if (ref($value) eq 'ARRAY') {
  665.         $value = "$value [@$value]";
  666.     }
  667.     $text .= sprintf("$pad%-8s => $value\n", $key);
  668.     next if $key =~ /^\./;
  669.     if (UNIVERSAL::isa($value, 'HASH')) {
  670.         $text .= _dump($value, $indent + 1);
  671.     }
  672.     }
  673.     $text;
  674. }
  675.  
  676.  
  677. 1;
  678.  
  679. __END__
  680.  
  681.  
  682. #------------------------------------------------------------------------
  683. # IMPORTANT NOTE
  684. #   This documentation is generated automatically from source
  685. #   templates.  Any changes you make here may be lost.
  686. # 
  687. #   The 'docsrc' documentation source bundle is available for download
  688. #   from http://www.template-toolkit.org/docs.html and contains all
  689. #   the source templates, XML files, scripts, etc., from which the
  690. #   documentation for the Template Toolkit is built.
  691. #------------------------------------------------------------------------
  692.  
  693. =head1 NAME
  694.  
  695. Template::Stash::Context - Experimetal stash allowing list/scalar context definition
  696.  
  697. =head1 SYNOPSIS
  698.  
  699.     use Template;
  700.     use Template::Stash::Context;
  701.  
  702.     my $stash = Template::Stash::Context->new(\%vars);
  703.     my $tt2   = Template->new({ STASH => $stash });
  704.  
  705. =head1 DESCRIPTION
  706.  
  707. This is an alternate stash object which includes a patch from 
  708. Craig Barratt to implement various new virtual methods to allow
  709. dotted template variable to denote if object methods and subroutines
  710. should be called in scalar or list context.  It adds a little overhead
  711. to each stash call and I'm a little wary of applying that to the core
  712. default stash without investigating the effects first. So for now,
  713. it's implemented as a separate stash module which will allow us to 
  714. test it out, benchmark it and switch it in or out as we require.
  715.  
  716. This is what Craig has to say about it:
  717.  
  718. Here's a better set of features for the core.  Attached is a new version
  719. of Stash.pm (based on TT2.02) that:
  720.  
  721. * supports the special op "scalar" that forces scalar context on
  722. function calls, eg:
  723.  
  724.     cgi.param("foo").scalar
  725.  
  726. calls cgi.param("foo") in scalar context (unlike my wimpy
  727. scalar op from last night).  Array context is the default.
  728.  
  729. With non-function operands, scalar behaves like the perl
  730. version (eg: no-op for scalar, size for arrays, etc).
  731.  
  732. * supports the special op "ref" that behaves like the perl ref.
  733. If applied to a function the function is not called.  Eg:
  734.  
  735.     cgi.param("foo").ref
  736.  
  737. does *not* call cgi.param and evaluates to "CODE".  Similarly,
  738. HASH.ref, ARRAY.ref return what you expect.
  739.  
  740. * adds a new scalar and list op called "array" that is a no-op for
  741. arrays and promotes scalars to one-element arrays.
  742.  
  743. * allows scalar ops to be applied to arrays and hashes in place,
  744. eg: ARRAY.repeat(3) repeats each element in place.
  745.  
  746. * allows list ops to be applied to scalars by promoting the scalars
  747. to one-element arrays (like an implicit "array").  So you can
  748. do things like SCALAR.size, SCALAR.join and get a useful result.
  749.  
  750. This also means you can now use x.0 to safely get the first element
  751. whether x is an array or scalar.
  752.  
  753. The new Stash.pm passes the TT2.02 test suite.  But I haven't tested the
  754. new features very much.  One nagging implementation problem is that the
  755. "scalar" and "ref" ops have higher precedence than user variable names.
  756.  
  757. =head1 AUTHOR
  758.  
  759. Andy Wardley E<lt>abw@andywardley.comE<gt>
  760.  
  761. L<http://www.andywardley.com/|http://www.andywardley.com/>
  762.  
  763.  
  764.  
  765.  
  766. =head1 VERSION
  767.  
  768. 1.58, distributed as part of the
  769. Template Toolkit version 2.13, released on 30 January 2004.
  770.  
  771. =head1 COPYRIGHT
  772.  
  773.   Copyright (C) 1996-2004 Andy Wardley.  All Rights Reserved.
  774.   Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
  775.  
  776. This module is free software; you can redistribute it and/or
  777. modify it under the same terms as Perl itself.
  778.  
  779. =head1 SEE ALSO
  780.  
  781. L<Template::Stash|Template::Stash>
  782.  
  783. =cut
  784.  
  785. # Local Variables:
  786. # mode: perl
  787. # perl-indent-level: 4
  788. # indent-tabs-mode: nil
  789. # End:
  790. #
  791. # vim: expandtab shiftwidth=4:
  792.