code/SystemTag/local.coretag

   1 # Copyright 2007 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7 #
   8 # $Id: local.coretag,v 1.2 2007-08-09 13:40:52 pajamian Exp $
   9
  10 UserTag local Order scratch
  11 UserTag local attrAlias scratches scratch
  12 UserTag local attrAlias value values
  13 UserTag local posNumber 1
  14 UserTag local hasEndTag
  15 UserTag local addAttr
  16 UserTag local Description Tag to localize scratch and/or values for block
  17 UserTag local Routine <<EOR
  18 sub {
  19         my ($scratch, $opt, $body) = @_;
  20
  21         use Storable qw/ dclone /;
  22         $Storable::forgive_me = 1;
  23
  24         ## It may seem simpler just to clone the top-level reference and
  25         ## be done with it, but we are going through all these gyrations
  26         ## to prevent the problem of overwriting code, which is not
  27         ## preserved with a cloning operation.
  28         ##
  29         ## Obviously (or maybe not) if you pass a top-level array which
  30         ## happens to contain a code reference, you are going to lose it.
  31         ## But code references which are in non-localized hash keys will
  32         ## survive.
  33
  34         my %delete_top;
  35         my %delete;
  36         my %settings;
  37
  38         # Perhaps {extra} is a bad option, but it has to be something. We
  39         # don't have the _ intro for a key, alas. Doubt it will often be
  40     # used, but discounts could be localized, I suppose.
  41
  42         my @extra = split /[,\s\0]+/, $opt->{extra};
  43
  44         for my $top (qw/ values scratch /, @extra) {
  45
  46                 exists $Vend::Session->{$top}
  47                         or do {
  48                                 $delete_top{$top} = 1;
  49                                 next;
  50                         };
  51
  52                 my $v = $Vend::Session->{$top};
  53
  54                 unless (ref($v) eq 'HASH') {
  55                         if(! ref $v) {
  56                                 $settings{$top} = $v;
  57                         }
  58                         else {
  59                                 $settings{$top} = dclone($v);
  60                         }
  61                         next;
  62                 }
  63
  64                 my @values = Text::ParseWords::shellwords($opt->{$top});
  65
  66                 for(@values) {
  67                         if( ! exists $v->{$_}) {
  68                                 $delete{$top}{$_} = 1;
  69                         }
  70                         elsif(! ref $v->{$_}) {
  71                                 $settings{$top}{$_} = $v->{$_};
  72                         }
  73                         else {
  74                                 $settings{$top}{$_} = dclone($v->{$_});
  75                         }
  76                 }
  77         }
  78
  79         my $result = interpolate_html($body);
  80
  81         for my $top (qw/ values scratch /, @extra) {
  82                 if(my $d = $delete_top{$top}) {
  83                         delete $Vend::Session->{$top};
  84                         next;
  85                 }
  86
  87                 unless (ref($settings{$top}) eq 'HASH') {
  88                         $Vend::Session->{$top} = $settings{$top};
  89                         next;
  90                 }
  91
  92                 my $s = $settings{$top};
  93                 my $d = $delete{$top};
  94                 my $v = $Vend::Session->{$top};
  95
  96                 for(keys %$d) {
  97                         delete $v->{$_};
  98                 }
  99
 100                 for(keys %$s) {
 101                         $v->{$_} = $settings{$top}{$_};
 102                 }
 103         }
 104
 105         return $result;
 106
 107 }
 108 EOR
 109
 110 UserTag local Documentation <<EOT
 111 =head1 NAME
 112
 113 local -- localize scratch, values, etc. for code block.
 114
 115 =head1 SYNOPSIS
 116
 117         [set foo]bar[/set]
 118
 119         [local scratch="foo"]
 120                 [set foo]nonbar[/set]
 121                 foo=[scratch foo]
 122         [/local]
 123
 124         [if scratch foo eq bar]
 125                 local worked.
 126         [else]
 127                 local did not work, kept at [scratch foo].
 128         [/else]
 129         [/if]
 130
 131 =head1 DESCRIPTION
 132
 133 The local tag allows you to drop some code using scratch or values settings
 134 in a page without the possibility of affecting the overall operation of the
 135 site.
 136
 137 EOT
 138