lib/Vend/Parse.pm

   1 # Vend::Parse - Parse Interchange tags
   2 #
   3 # $Id: Parse.pm,v 2.44 2007-12-19 12:33:44 pajamian Exp $
   4 #
   5 # Copyright (C) 2002-2007 Interchange Development Group
   6 # Copyright (C) 1996-2002 Red Hat, Inc.
   7 #
   8 # This program was originally based on Vend 0.2 and 0.3
   9 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
  10 #
  11 # This program is free software; you can redistribute it and/or modify
  12 # it under the terms of the GNU General Public License as published by
  13 # the Free Software Foundation; either version 2 of the License, or
  14 # (at your option) any later version.
  15 #
  16 # This program is distributed in the hope that it will be useful,
  17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 # GNU General Public License for more details.
  20 #
  21 # You should have received a copy of the GNU General Public
  22 # License along with this program; if not, write to the Free
  23 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  24 # MA  02110-1301  USA.
  25
  26 package Vend::Parse;
  27 require Vend::Parser;
  28
  29 use Vend::Safe;
  30 use Vend::Util;
  31 use Vend::Interpolate;
  32 use Text::ParseWords;
  33 use Vend::Data qw/product_field/;
  34
  35 require Exporter;
  36
  37 @ISA = qw(Exporter Vend::Parser);
  38
  39 $VERSION = substr(q$Revision: 2.44 $, 10);
  40
  41 @EXPORT = ();
  42 @EXPORT_OK = qw(find_matching_end);
  43
  44 use strict;
  45 no warnings qw(uninitialized numeric);
  46
  47 use vars qw($VERSION);
  48
  49 my($CurrentSearch, $CurrentCode, $CurrentDB, $CurrentWith, $CurrentItem);
  50 my(@SavedSearch, @SavedCode, @SavedDB, @SavedWith, @SavedItem);
  51
  52 my %PosNumber = ( qw!
  53
  54                                 bounce           2
  55                                 label            1
  56                                 if               1
  57                                 unless           1
  58                                 and              1
  59                                 or               1
  60
  61                         ! );
  62
  63 my %Order =     (
  64                                 bounce                  => [qw( href if )],
  65                                 goto                    => [qw( name if)],
  66                                 label                   => [qw( name )],
  67                                 if                              => [qw( type term op compare )],
  68                                 unless                  => [qw( type term op compare )],
  69                                 or                              => [qw( type term op compare )],
  70                                 and                             => [qw( type term op compare )],
  71                                 restrict                => [qw( enable )],
  72                         );
  73
  74 my %addAttr = (
  75                                 qw(
  76                                         restrict                1
  77                                 )
  78                         );
  79
  80 my %hasEndTag = (
  81
  82                                 qw(
  83                                         if              1
  84                                         unless          1
  85                                         restrict                1
  86                                 )
  87                         );
  88
  89
  90 my %Implicit = (
  91
  92                         unless =>               { qw(
  93                                                                 !=              op
  94                                                                 !~              op
  95                                                                 <=              op
  96                                                                 ==              op
  97                                                                 =~              op
  98                                                                 >=              op
  99                                                                 eq              op
 100                                                                 gt              op
 101                                                                 lt              op
 102                                                                 ne              op
 103                                            )},
 104                         if =>           { qw(
 105                                                                 !=              op
 106                                                                 !~              op
 107                                                                 <=              op
 108                                                                 ==              op
 109                                                                 =~              op
 110                                                                 >=              op
 111                                                                 eq              op
 112                                                                 gt              op
 113                                                                 lt              op
 114                                                                 ne              op
 115                                            )},
 116
 117                         and =>          { qw(
 118                                                                 !=              op
 119                                                                 !~              op
 120                                                                 <=              op
 121                                                                 ==              op
 122                                                                 =~              op
 123                                                                 >=              op
 124                                                                 eq              op
 125                                                                 gt              op
 126                                                                 lt              op
 127                                                                 ne              op
 128                                            )},
 129
 130                         or =>           { qw(
 131                                                                 !=              op
 132                                                                 !~              op
 133                                                                 <=              op
 134                                                                 ==              op
 135                                                                 =~              op
 136                                                                 >=              op
 137                                                                 eq              op
 138                                                                 gt              op
 139                                                                 lt              op
 140                                                                 ne              op
 141                                            )},
 142
 143                         );
 144
 145 my %PosRoutine = (
 146                                 or                      => sub { return &Vend::Interpolate::tag_if(@_, 1) },
 147                                 and                     => sub { return &Vend::Interpolate::tag_if(@_, 1) },
 148                                 if                      => \&Vend::Interpolate::tag_if,
 149                                 unless          => \&Vend::Interpolate::tag_unless,
 150                         );
 151
 152 my %Special = qw/
 153                                 goto    1
 154                                 bounce  1
 155                                 output  1
 156                           /;
 157 my %Routine = (
 158
 159                                 output          => sub { return '' },
 160                                 bounce          => sub { return '' },
 161                                 if                              => \&Vend::Interpolate::tag_self_contained_if,
 162                                 unless                  => \&Vend::Interpolate::tag_unless,
 163                                 or                              => sub { return &Vend::Interpolate::tag_self_contained_if(@_, 1) },
 164                                 and                             => sub { return &Vend::Interpolate::tag_self_contained_if(@_, 1) },
 165                                 goto                    => sub { return '' },
 166                                 label                   => sub { return '' },
 167
 168                         );
 169
 170 ## Put here because we need to call keys %Routine
 171 ## Restricts execution of tags by tagname
 172 $Routine{restrict} = sub {
 173         my ($enable, $opt, $body) = @_;
 174         my $save = $Vend::Cfg->{AdminSub};
 175
 176         my $save_restrict = $Vend::restricted;
 177
 178         $opt->{log} ||= 'all';
 179
 180         my $default;
 181         if("\L$opt->{policy}" eq 'allow') {
 182                 # Accept all, deny only ones defined in disable
 183                 $default = undef;
 184                 $opt->{policy} = 'allow';
 185         }
 186         else {
 187                 # This is default, deny all except enabled
 188                 $default = 1;
 189                 $opt->{policy} = 'deny';
 190         }
 191         my @enable;
 192         my @disable;
 193         $enable                 and @enable  = split /[\s,\0]+/, $enable;
 194         $opt->{disable} and @disable = split /[\s,\0]+/, $opt->{disable};
 195
 196         for(@enable, @disable) {
 197                 $_ = lc $_;
 198                 tr/-/_/;
 199         }
 200
 201         my %restrict;
 202         for(keys %Routine) {
 203                 $restrict{$_} = $default;
 204         }
 205
 206         $restrict{$_} = undef for @enable;
 207         $restrict{$_} = 1     for @disable;
 208         $restrict{$_} = 1     for keys %$save;
 209
 210         $Vend::Cfg->{AdminSub} = \%restrict;
 211         $Vend::restricted = join " ",
 212                         'default=' . $opt->{policy},
 213                         'enable=' . join(",", @enable),
 214                         'disable=' . join(",", @disable),
 215                         'log=' . $opt->{log},
 216                         ;
 217         my $out;
 218         eval {
 219                 $out = Vend::Interpolate::interpolate_html($body);
 220         };
 221         $Vend::restricted = $save_restrict;
 222         $Vend::Cfg->{AdminSub} = $save;
 223         return $out;
 224 };
 225
 226 my %attrAlias = (
 227          'or'                   => {
 228                                                         'comp' => 'compare',
 229                                                         'operator' => 'op',
 230                                                         'base' => 'type',
 231                                                 },
 232          'and'                  => {
 233                                                         'comp' => 'compare',
 234                                                         'operator' => 'op',
 235                                                         'base' => 'type',
 236                                                 },
 237          'unless'                       => {
 238                                                         'comp' => 'compare',
 239                                                         'condition' => 'compare',
 240                                                         'operator' => 'op',
 241                                                         'base' => 'type',
 242                                                 },
 243          'if'                   => {
 244                                                         'comp' => 'compare',
 245                                                         'condition' => 'compare',
 246                                                         'operator' => 'op',
 247                                                         'base' => 'type',
 248                                                 },
 249 );
 250
 251 my %attrDefault = ();
 252
 253 my %Alias = (
 254         getlocale       => 'setlocale get=1',
 255         process_search  => 'area href=search',
 256 );
 257
 258 my %Interpolate = ();
 259
 260 my %NoReparse = ( qw/
 261                                         restrict                1
 262                                 / );
 263
 264 my %Gobble = ( qw/
 265                                         timed_build             1
 266                                         mvasp                   1
 267                                 / );
 268
 269 my $Initialized;
 270
 271 sub global_init {
 272                 add_tags($Global::UserTag);
 273                 my $tag;
 274                 foreach $tag (keys %Routine) {
 275                         $Order{$tag} = []
 276                                 if ! defined $Order{$tag};
 277                         next if defined $PosNumber{$tag};
 278                         $PosNumber{$tag} = scalar @{$Order{$tag}};
 279                 }
 280 }
 281
 282 sub new {
 283     my $class = shift;
 284         my $opt = shift;
 285     my $self = new Vend::Parser;
 286
 287         add_tags($Vend::Cfg->{UserTag})
 288                 unless $Vend::Tags_added++;
 289
 290     bless $self, $class;
 291
 292         if($opt) {
 293                 $self->destination('');
 294         }
 295         else {
 296                 my $string = '';
 297                 $self->{OUT} = $self->{DEFAULT_OUT} = \$string;
 298         }
 299 #::logDebug("OUT=$self->{OUT}");
 300
 301         if (! $Initialized) {
 302                 $Initialized = $self;
 303                 $self->{TOPLEVEL} = 1;
 304         }
 305
 306         return $self;
 307 }
 308
 309 sub destination {
 310         my ($s, $name, $attr) = @_;
 311         $s->{_outname} ||= [];
 312
 313         if(! defined $name) {
 314                 pop @{$s->{_outname}};
 315                 $name = pop  @{$s->{_outname}};
 316         }
 317         else {
 318                 $name = lc $name;
 319                 push @{$s->{_outname}}, $name;
 320         }
 321
 322 #::logDebug("destination set to '$name'");
 323         $name ||= '';
 324
 325         my $string = '';
 326         $s->{OUT} = \$string;
 327         push @Vend::Output, $s->{OUT};
 328
 329         my $nary = $Vend::OutPtr{$name} ||= [];
 330         push @$nary, $#Vend::Output;
 331
 332         return unless $attr;
 333 #::logDebug("destination extended output settings");
 334
 335         my $fary = $Vend::OutFilter{$name};
 336
 337         if ($name) {
 338                 $Vend::MultiOutput = 1;
 339                 if(! $Vend::OutFilter{''}) {
 340                         my $ary = [];
 341                         push @$ary, \&Vend::Interpolate::substitute_image
 342                                 unless $::Pragma->{no_image_rewrite};
 343                         $Vend::OutFilter{''} = $ary;
 344                 }
 345
 346                 if(! $fary) {
 347                         $fary = $Vend::OutFilter{$name} = [];
 348                         if($attr->{output_filter}) {
 349                                 my $filt = $attr->{output_filter};
 350                                 push @$fary, sub {
 351                                         my $ref = shift;
 352                                         $$ref = Vend::Interpolate::filter_value($filt, $$ref);
 353                                         return;
 354                                 };
 355                         }
 356                         if (! $attr->{no_image_parse} and ! $::Pragma->{no_image_rewrite}) {
 357                                 push @$fary, \&Vend::Interpolate::substitute_image;
 358                         }
 359                         if ($attr->{output_extended}) {
 360                                 $Vend::OutExtended{$name} = $attr;
 361                         }
 362                 }
 363         }
 364         return $s->{OUT};
 365 }
 366
 367 my %noRearrange = qw//;
 368
 369 my %Documentation;
 370 use vars '%myRefs';
 371
 372 %myRefs = (
 373      Alias           => \%Alias,
 374      addAttr         => \%addAttr,
 375      attrAlias       => \%attrAlias,
 376      attrDefault     => \%attrDefault,
 377          Documentation   => \%Documentation,
 378          hasEndTag       => \%hasEndTag,
 379          NoReparse       => \%NoReparse,
 380          noRearrange     => \%noRearrange,
 381          Implicit        => \%Implicit,
 382          Interpolate     => \%Interpolate,
 383          Order           => \%Order,
 384          PosNumber       => \%PosNumber,
 385          PosRoutine      => \%PosRoutine,
 386          Routine         => \%Routine,
 387 );
 388
 389 my @myRefs = keys %myRefs;
 390
 391 sub do_tag {
 392         my $tag = shift;
 393 #::logDebug("Parse-do_tag: tag=$tag caller=" . caller() . " args=" . ::uneval_it(\@_) );
 394         if (defined $Vend::Cfg->{AdminSub}{$tag}) {
 395
 396                 if($Vend::restricted) {
 397                         die errmsg(
 398                                         "Tag '%s' in execution-restricted area: %s",
 399                                         $tag,
 400                                         $Vend::restricted,
 401                                 );
 402                 }
 403                 elsif (! $Vend::admin) {
 404                         die errmsg("Unauthorized for admin tag %s", $tag)
 405                 }
 406
 407         }
 408
 409         if (! defined $Routine{$tag} and $Global::AccumulateCode) {
 410 #::logDebug("missing $tag, trying code_from_file");
 411                 if($Alias{$tag}) {
 412                         $tag = $Alias{$tag};
 413 #::logDebug("missing $tag found alias=$tag");
 414                 }
 415                 else {
 416                         $Routine{$tag} = Vend::Config::code_from_file('UserTag', $tag)
 417                                 if ! $Routine{$tag};
 418                 }
 419         }
 420
 421         if (! defined $Routine{$tag}) {
 422 #::logDebug("missing $tag, but didn't try code_from_file?");
 423         if (! $Alias{$tag}) {
 424             ::logError("Tag '$tag' not defined.");
 425             return undef;
 426         }
 427         $tag = $Alias{$tag};
 428         };
 429
 430         if($Special{$tag}) {
 431                 my $ref = pop(@_);
 432                 my @args = @$ref{ @{$Order{$tag}} };
 433                 push @args, $ref if $addAttr{$tag};
 434 #::logDebug("Parse-do_tag: args now=" . ::uneval_it(\@args) );
 435                 $Initialized->start($tag, $ref);
 436                 return;
 437         }
 438         elsif(
 439                 ( ref($_[-1]) && scalar @{$Order{$tag}} > scalar @_ and ! $noRearrange{$tag})
 440         )
 441         {
 442                 my $text;
 443                 my $ref = pop(@_);
 444                 $text = shift if $hasEndTag{$tag};
 445                 my @args = @$ref{ @{$Order{$tag}} };
 446                 push @args, $ref if $addAttr{$tag};
 447 #::logDebug("Parse-do_tag: args now=" . ::uneval_it(\@args) );
 448                 return &{$Routine{$tag}}(@args, $text || undef);
 449         }
 450         else {
 451 #::logDebug("Parse-do_tag tag=$tag: args now=" . ::uneval_it(\@_) );
 452                 return &{$Routine{$tag}}(@_);
 453         }
 454 }
 455
 456 sub resolve_args {
 457         my $tag = shift;
 458 #::logDebug("resolving args for $tag, attrAlias = $attrAlias{$tag}");
 459         if (! defined $Routine{$tag} and $Global::AccumulateCode) {
 460 #::logDebug("missing $tag, trying code_from_file");
 461                 $Routine{$tag} = Vend::Config::code_from_file('UserTag', $tag);
 462         }
 463
 464         return @_ unless defined $Routine{$tag};
 465         my $ref = shift;
 466         my @list;
 467         if(defined $attrAlias{$tag}) {
 468                 my ($k, $v);
 469                 while (($k, $v) = each %{$attrAlias{$tag}} ) {
 470 #::logDebug("checking alias $k -> $v");
 471                         next unless defined $ref->{$k};
 472                         $ref->{$v} = $ref->{$k};
 473                 }
 474         }
 475         if (defined $attrDefault{$tag}) {
 476                 my ($k, $v);
 477                 while (($k, $v) = each %{$attrDefault{$tag}}) {
 478                         next if defined $ref->{$k};
 479 #::logDebug("using default $k = $v");
 480                         $ref->{$k} = $v;
 481                 }
 482         }
 483         @list = @{$ref}{@{$Order{$tag}}};
 484         push @list, $ref if defined $addAttr{$tag};
 485         push @list, (shift || (defined $ref->{body} ? $ref->{body} : '')) if $hasEndTag{$tag};
 486         return @list;
 487 }
 488
 489 sub add_tags {
 490         return unless @_;
 491         my $ref = shift;
 492         return unless $ref->{Routine} or $ref->{Alias};
 493         my $area;
 494         no strict 'refs';
 495         foreach $area (@myRefs) {
 496                 next unless $ref->{$area};
 497                 if($area eq 'Routine') {
 498                         for (keys %{$ref->{$area}}) {
 499                                 $myRefs{$area}->{$_} = $ref->{$area}->{$_};
 500                         }
 501                         next;
 502                 }
 503                 elsif ($area =~ /HTML$/) {
 504                         for (keys %{$ref->{$area}}) {
 505                                 $myRefs{$area}->{$_} =
 506                                         defined $myRefs{$area}->{$_}
 507                                         ? $ref->{$area}->{$_} .'|'. $myRefs{$area}->{$_}
 508                                         : $ref->{$area}->{$_};
 509                         }
 510                 }
 511                 else {
 512                         Vend::Util::copyref $ref->{$area}, $myRefs{$area};
 513                 }
 514         }
 515         for (keys %{$ref->{Routine}}) {
 516                 $Order{$_} = [] if ! $Order{$_};
 517                 next if defined $PosNumber{$_};
 518                 $PosNumber{$_} = scalar @{$Order{$_}};
 519         }
 520 }
 521
 522 sub eof {
 523     shift->parse(undef);
 524 }
 525
 526 sub text {
 527     my($self, $text) = @_;
 528         ${$self->{OUT}} .= $text;
 529 }
 530
 531 my %Monitor = ( qw( tag_ary 1 ) );
 532
 533 sub build_html_tag {
 534         my ($orig, $attr, $attrseq) = @_;
 535         $orig =~ s/\s+.*//s;
 536         for (@$attrseq) {
 537                 $orig .= qq{ \U$_="} ; # syntax color "
 538                 $attr->{$_} =~ s/"/\\"/g;
 539                 $orig .= $attr->{$_};
 540                 $orig .= '"';
 541         }
 542         $orig .= ">";
 543 }
 544
 545 my %implicitHTML = (qw/checked CHECKED selected SELECTED/);
 546
 547 sub format_html_attribute {
 548         my($attr, $val) = @_;
 549         if(defined $implicitHTML{$attr}) {
 550                 return $implicitHTML{$attr};
 551         }
 552         $val =~ s/"/&quot;/g;
 553         return qq{$attr="$val"};
 554 }
 555
 556 sub resolve_if_unless {
 557         my $attr = shift;
 558         if(defined $attr->{'unless'}) {
 559                 return '' if $attr->{'unless'} =~ /^\s*0?\s*$/;
 560                 return '' if ! $attr->{'unless'};
 561                 return 1;
 562         }
 563         elsif (defined $attr->{'if'}) {
 564                 return '' if
 565                         ($attr->{'if'} and $attr->{'if'} !~ /^\s*0?\s*$/);
 566                 return 1;
 567         }
 568         return '';
 569 }
 570
 571 sub goto_buf {
 572         my ($name, $buf) = @_;
 573         if(! $name) {
 574                 $$buf = '';
 575                 return;
 576         }
 577         $$buf =~ s!.*?\[label\s+(?:name\s*=\s*(?:["'])?)?($name)['"]*\s*\]!!is
 578                 and return;
 579         $$buf =~ s:.*?</body\s*>::is
 580                 and return;
 581         $$buf = '';
 582         return;
 583         # syntax color "'
 584 }
 585
 586 sub eval_die {
 587         my $msg = shift;
 588         $msg =~ s/\(eval\s+\d+/(tag '$Vend::CurrentTag'/;
 589         die($msg, @_);
 590 }
 591
 592 # syntax color '"
 593
 594 sub start {
 595     my($self, $tag, $attr, $attrseq, $origtext, $empty_container) = @_;
 596         $tag =~ tr/-/_/;   # canonical
 597         $Vend::CurrentTag = $tag = lc $tag;
 598 #::logDebug("start tag=$tag");
 599         my $buf = \$self->{_buf};
 600
 601         my($tmpbuf);
 602         if (defined $Vend::Cfg->{AdminSub}{$tag}) {
 603
 604                 if($Vend::restricted) {
 605                         my $log = 'all';
 606                         $Vend::restricted =~ /\blog=(\w+)/ and $log = lc $1;
 607                         undef $log if $log eq 'none' or
 608                                 ($log eq 'once' and $Vend::restricted_err{$origtext}++);
 609                         if ($log) {
 610                                 ::logError(
 611                                         "Restricted tag (%s) attempted during restriction '%s'",
 612                                         $origtext,
 613                                         $Vend::restricted,
 614                                 );
 615                         }
 616                         ${$self->{OUT}} .= $origtext;
 617                         return 1;
 618                 }
 619                 elsif (! $Vend::admin) {
 620                         ::response(
 621                                                 get_locale_message (
 622                                                         403,
 623                                                         "Unauthorized for admin tag %s",
 624                                                         $tag,
 625                                                         )
 626                                                 );
 627                         return ($self->{ABORT} = 1);
 628                 }
 629
 630         }
 631
 632     # $attr is reference to a HASH, $attrseq is reference to an ARRAY
 633         my $aliasname = '';
 634         if (! defined $Routine{$tag} and $Global::AccumulateCode) {
 635                 my $newtag;
 636                 if($newtag = $Alias{$tag}) {
 637                         $newtag =~ s/\s+.*//s;
 638                         Vend::Config::code_from_file('UserTag', $newtag)
 639                                 unless $Routine{$newtag};
 640                 }
 641                 else {
 642                         Vend::Config::code_from_file('UserTag', $tag);
 643                 }
 644         }
 645
 646         unless (defined $Routine{$tag}) {
 647                 if(defined $Alias{$tag}) {
 648                         $aliasname = $tag;
 649                         my $alias = $Alias{$tag};
 650                         $alias =~ tr/-/_/;
 651                         $tag =~ s/_/[-_]/g;
 652 #::logDebug("origtext: $origtext tag=$tag alias=$alias");
 653                         $origtext =~ s/$tag/$alias/i
 654                                 or return 0;
 655                         if ($alias =~ /\s/) {
 656                                 # keep old behaviour for aliases like
 657                                 # process_search => 'area href=search'
 658                                 # otherwise we process it like any other tag
 659                                 $$buf = $origtext . $$buf;
 660                                 return 1;
 661                         }
 662                         $tag = $alias;
 663                 }
 664                 else {
 665 #::logDebug("no alias. origtext: $origtext");
 666                         ${$self->{OUT}} .= $origtext;
 667                         return 1;
 668                 }
 669         }
 670
 671         my $trib;
 672         foreach $trib (@$attrseq) {
 673                 # Attribute aliases
 674                 if(defined $attrAlias{$tag} and $attrAlias{$tag}{$trib}) {
 675                         my $new = $attrAlias{$tag}{$trib} ;
 676                         $attr->{$new} = delete $attr->{$trib};
 677                         $trib = $new;
 678                 }
 679                 # Parse tags within tags, only works if the [ is the
 680                 # first character.
 681                 next unless $attr->{$trib} =~ /\[\w+[-\w]*\s*(?s:.)*\]/;
 682
 683                 my $p = new Vend::Parse;
 684                 $p->parse($attr->{$trib});
 685                 $attr->{$trib} = ${$p->{OUT}};
 686         }
 687
 688         if (defined $attrDefault{$tag}) {
 689                 my ($k, $v);
 690                 while (($k, $v) = each %{$attrDefault{$tag}}) {
 691                         next if defined $attr->{$k};
 692 #::logDebug("using default $k = $v");
 693                         $attr->{$k} = $v;
 694                 }
 695         }
 696
 697         $attr->{enable_html} = 1 if $Vend::Cfg->{Promiscuous};
 698         $attr->{reparse} = 1
 699                 unless (
 700                         defined $NoReparse{$tag}
 701                         || defined $attr->{reparse}
 702                         || $::Pragma->{no_default_reparse}
 703                 );
 704
 705         my ($routine,@args);
 706
 707 #::logDebug("tag=$tag order=$Order{$tag}");
 708         # Check for old-style positional tag
 709         if(!@$attrseq and $origtext =~ s/\[[-\w]+\s+//i) {
 710                         $origtext =~ s/\]$//;
 711                         $attr->{interpolate} = 1 if defined $Interpolate{$tag};
 712                         if(defined $PosNumber{$tag}) {
 713                                 if($PosNumber{$tag} > 1) {
 714                                         @args = split /\s+/, $origtext, $PosNumber{$tag};
 715                                         push(@args, undef) while @args < $PosNumber{$tag};
 716                                 }
 717                                 elsif ($PosNumber{$tag}) {
 718                                         @args = $origtext;
 719                                 }
 720                         }
 721                         @{$attr}{ @{ $Order{$tag} } } = @args;
 722                         $routine =  $PosRoutine{$tag} || $Routine{$tag};
 723         }
 724         else {
 725                 $routine = $Routine{$tag};
 726                 $attr->{interpolate} = 1
 727                         if  defined $Interpolate{$tag} && ! defined $attr->{interpolate};
 728                 @args = @{$attr}{ @{ $Order{$tag} } };
 729         }
 730         $args[scalar @{$Order{$tag}}] = $attr if $addAttr{$tag};
 731
 732 #::logDebug("Interpolate value now='$attr->{interpolate}'") if$Monitor{$tag};
 733
 734
 735 #::logDebug(<<EOF) if $Monitor{$tag};
 736 #tag=$tag
 737 #routine=$routine
 738 #has_end=$hasEndTag{$tag}
 739 #attributes=@args
 740 #interpolate=$attr->{interpolate}
 741 #EOF
 742
 743         if($Special{$tag}) {
 744                 if($tag eq 'output') {
 745                         $self->destination($attr->{name}, $attr);
 746                         return 1;
 747                 }
 748                 elsif($tag eq 'bounce') {
 749 #::logDebug("bouncing...options=" . ::uneval($attr));
 750                         return 1 if resolve_if_unless($attr);
 751                         if(! $attr->{href} and $attr->{page}) {
 752                                 $attr->{href} = Vend::Interpolate::tag_area($attr->{page});
 753                         }
 754
 755                         $attr->{href} = header_data_scrub($attr->{href});
 756
 757                         $Vend::StatusLine = '' if ! $Vend::StatusLine;
 758                         $Vend::StatusLine .= "\n" if $Vend::StatusLine !~ /\n$/;
 759                         $Vend::StatusLine .= <<EOF if $attr->{target};
 760 Window-Target: $attr->{target}
 761 EOF
 762                         $attr->{status} ||= '302 moved';
 763                         $Vend::StatusLine .= <<EOF;
 764 Status: $attr->{status}
 765 Location: $attr->{href}
 766 EOF
 767 #::logDebug("bouncing...status line=\n$Vend::StatusLine");
 768                         $$buf = '';
 769                         $Initialized->{_buf} = '';
 770
 771             my $body = qq{Redirecting to <a href="%s">%s</a>.};
 772             $body = errmsg($body, $attr->{href}, $attr->{href});
 773 #::logDebug("bouncing...body=$body");
 774                         $::Pragma->{download} = 1;
 775                         ::response($body);
 776                         $Vend::Sent = 1;
 777                         $self->{SEND} = 1;
 778                         return 1;
 779                 }
 780                 elsif($tag eq 'goto') {
 781                         return 1 if resolve_if_unless($attr);
 782                         if(! $args[0]) {
 783                                 $$buf = '';
 784                                 $Initialized->{_buf} = '';
 785                                 $self->{ABORT} = 1
 786                                         if $attr->{abort};
 787                                 return ($self->{SEND} = 1);
 788                         }
 789                         goto_buf($args[0], $buf);
 790                         $self->{ABORT} = 1;
 791                         $self->{SEND} = 1 if ! $$buf;
 792                         return 1;
 793                 }
 794         }
 795
 796         local($SIG{__DIE__}) = \&eval_die;
 797
 798 #::logDebug("output attr=$attr->{_output}");
 799         $self->destination($attr->{_output}) if $attr->{_output};
 800
 801         if($hasEndTag{$tag}) {
 802                 # Handle embedded tags, but only if interpolate is
 803                 # defined (always if using old tags)
 804 #::logDebug("look end for $tag, buf=" . length($$buf) );
 805                 $tmpbuf = $empty_container ? '' : find_matching_end($aliasname || $tag, $buf);
 806 #::logDebug("FOUND end for $tag\nBuf " . length($$buf) . ":\n" . $$buf . "\nTmpbuf:\n$tmpbuf\n");
 807                 if ($attr->{interpolate} and !$empty_container) {
 808                         my $p = new Vend::Parse;
 809                         my $tagsave = $Vend::CurrentTag;
 810                         $p->parse($tmpbuf);
 811                         $Vend::CurrentTag = $tagsave;
 812                         $tmpbuf = $p->{ABORT} ? '' : ${$p->{OUT}};
 813                 }
 814                 if ($attr->{'hide'}) {
 815                         $routine->(@args,$tmpbuf);
 816                 }
 817                 elsif($attr->{reparse} ) {
 818                         $$buf = ($routine->(@args,$tmpbuf)) . $$buf;
 819                 }
 820                 else {
 821                         ${$self->{OUT}} .= $routine->(@args,$tmpbuf);
 822                 }
 823         }
 824         elsif ($attr->{'hide'}) {
 825                 $routine->(@args);
 826         }
 827         elsif($attr->{interpolate}) {
 828                 $$buf = $routine->(@args) . $$buf;
 829         }
 830         else {
 831                 ${$self->{OUT}} .= $routine->(@args);
 832         }
 833
 834         $self->{SEND} = $attr->{'send'} || undef;
 835 #::logDebug("Returning from $tag");
 836         $self->destination() if $attr->{_output};
 837         return 1;
 838 }
 839
 840 sub end {
 841     my($self, $tag) = @_;
 842         my $save = $tag;
 843         $tag =~ tr/-/_/;   # canonical
 844         ${$self->{OUT}} .= "[/$save]";
 845 }
 846
 847 sub find_html_end {
 848     my($tag, $buf) = @_;
 849     my $out;
 850         my $canon;
 851
 852     my $open  = "<$tag ";
 853     my $close = "</$tag>";
 854         ($canon = $tag) =~ s/_/[-_]/g;
 855
 856     $$buf =~ s!<$canon\s!<$tag !ig;
 857     $$buf =~ s!</$canon\s*>!</$tag>!ig;
 858     my $first = index($$buf, $close);
 859     return undef if $first < 0;
 860     my $int = index($$buf, $open);
 861     my $pos = 0;
 862 #::logDebug("find_html_end: tag=$tag open=$open close=$close $first=$first pos=$pos int=$int");
 863     while( $int > -1 and $int < $first) {
 864         $pos   = $int + 1;
 865         $first = index($$buf, $close, $first + 1);
 866         $int   = index($$buf, $open, $pos);
 867 #::logDebug("find_html_end: tag=$tag open=$open close=$close $first=$first pos=$pos int=$int");
 868     }
 869 #::logDebug("find_html_end: tag=$tag open=$open close=$close $first=$first pos=$pos int=$int");
 870         return undef if $first < 0;
 871     $first += length($close);
 872 #::logDebug("find_html_end (add close): tag=$tag open=$open close=$close $first=$first pos=$pos int=$int");
 873     $out = substr($$buf, 0, $first);
 874     substr($$buf, 0, $first) = '';
 875     return $out;
 876 }
 877
 878 sub find_matching_end {
 879     my($tag, $buf) = @_;
 880     my $out;
 881         my $canon;
 882
 883     my $open  = "[$tag ";
 884     my $close = "[/$tag]";
 885         ($canon = $tag) =~ s/_/[-_]/g;
 886
 887     $$buf =~ s!\[$canon\s![$tag !ig;
 888         # Syntax color ]
 889     $$buf =~ s!\[/$canon\]![/$tag]!ig;
 890     my $first = index($$buf, $close);
 891     if ($first < 0) {
 892                 if($Gobble{$tag}) {
 893                         $out = $$buf;
 894                         $$buf = '';
 895                         return $out;
 896                 }
 897                 return undef;
 898         }
 899     my $int = index($$buf, $open);
 900     my $pos = 0;
 901     while( $int > -1 and $int < $first) {
 902         $pos   = $int + 1;
 903         $first = index($$buf, $close, $first + 1);
 904         $int   = index($$buf, $open, $pos);
 905     }
 906     $out = substr($$buf, 0, $first);
 907     $first = $first < 0 ? $first : $first + length($close);
 908     substr($$buf, 0, $first) = '';
 909     return $out;
 910 }
 911
 912 # Passed some string that might be HTML-style attributes
 913 # or might be positional parameters, does the right thing
 914 sub _find_tag {
 915         my ($buf, $attrhash, $attrseq) = (@_);
 916         return '' if ! $$buf;
 917         my $old = 0;
 918         my $eaten = '';
 919         my %attr;
 920         my @attrseq;
 921         while ($$buf =~ s|^(([a-zA-Z][-a-zA-Z0-9._]*)\s*)||) {
 922                 $eaten .= $1;
 923                 my $attr = lc $2;
 924                 $attr =~ tr/-/_/;
 925                 my $val;
 926                 $old = 0;
 927                 # The attribute might take an optional value (first we
 928                 # check for an unquoted value)
 929                 if ($$buf =~ s|(^=\s*([^\"\'\]\s][^\]\s]*)\s*)||) {
 930                         $eaten .= $1;
 931                         $val = $2;
 932                         HTML::Entities::decode($val);
 933                 # or quoted by " or '
 934                 } elsif ($$buf =~ s~(^=\s*([\"\'\`\|])(.*?)\2\s*)~~s) {
 935                         $eaten .= $1;
 936                         my $q = $2;
 937                         $val = $3;
 938                         HTML::Entities::decode($val);
 939                         if ($q eq "`") {
 940                                 $val = Vend::Interpolate::tag_calc($val);
 941                         }
 942                         else {
 943                                 $q eq '|'
 944                                 and do {
 945                                                 $val =~ s/^\s+//;
 946                                                 $val =~ s/\s+$//;
 947                                         };
 948                                 $val =~ /__[A-Z]\w*[A-Za-z]__|\[.*\]/s
 949                                         and do {
 950                                                 my $p = new Vend::Parse;
 951                                                 $p->parse($val);
 952                                                 $val = ${$p->{OUT}};
 953                                         };
 954                         }
 955                 # truncated just after the '=' or inside the attribute
 956                 } elsif ($$buf =~ m|^(=\s*)$| or
 957                                  $$buf =~ m|^(=\s*[\"\'].*)|s) {
 958                         $eaten = "$eaten$1";
 959                         last;
 960                 } else {
 961                         # assume attribute with implicit value, which
 962                         # means in Interchange no value is set and the
 963                         # eaten value is grown. Note that you should
 964                         # never use an implicit tag when setting up an Alias.
 965                         $old = 1;
 966                 }
 967                 next if $old;
 968                 $attrhash->{$attr} = $val;
 969                 push(@attrseq, $attr);
 970         }
 971         unshift(@$attrseq, @attrseq);
 972         return ($eaten);
 973 }
 974
 975 # Implicit tag attributes
 976 # These are deprecated. Please do not document them,
 977 # as they may go away in the future.
 978 sub implicit {
 979         my($self, $tag, $attr) = @_;
 980         # 'int' is special in that it doesn't get pushed on @attrseq
 981         return ('interpolate', 1, 1) if $attr eq 'int';
 982         return ($attr, undef) unless defined $Implicit{$tag} and $Implicit{$tag}{$attr};
 983         my $imp = $Implicit{$tag}{$attr};
 984         return ($attr, $imp) if $imp =~ s/^$attr=//i;
 985         return ( $Implicit{$tag}{$attr}, $attr );
 986 }
 987
 988 1;
 989 __END__