code/SystemTag/catch.coretag

   1 # Copyright 2002-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: catch.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $
   9
  10 UserTag catch               Order        label
  11 UserTag catch               addAttr
  12 UserTag catch               hasEndTag
  13 UserTag catch               Version      $Revision: 1.7 $
  14 UserTag catch               Routine      <<EOR
  15 sub {
  16         my ($label, $opt, $body) = @_;
  17         $label = 'default' unless $label;
  18         my $patt;
  19         my $error;
  20         return pull_else($body)
  21                 unless $error = $Vend::Session->{try}{$label};
  22
  23         $body = pull_if($body);
  24
  25         if ( $opt->{exact} ) {
  26                 #----------------------------------------------------------------
  27                 # Convert multiple errors to 'or' list and compile it.
  28                 # Note also the " at (eval ...)" kludge to strip the line numbers
  29                 $patt = $error;
  30                 $patt =~ s/(?: +at +\(eval .+\).+)?\n\s*/|/g;
  31                 $patt =~ s/^\s*//;
  32                 $patt =~ s/\|$//;
  33                 $patt = qr($patt);
  34                 #----------------------------------------------------------------
  35         }
  36
  37         my @found;
  38         while ($body =~ s{
  39                                                 \[/
  40                                                         (.+?)
  41                                                 /\]
  42                                                 (.*?)
  43                                                 \[/
  44                                                 (?:\1)?/?
  45                                                 \]}{}sx ) {
  46                 my $re;
  47                 my $emsg = $2;
  48                 eval {
  49                         $re = qr{$1}
  50                 };
  51                 next if $@;
  52                 if($emsg =~ $patt) {
  53                         push @found, $emsg;
  54                 }
  55                 next unless $error =~ $re;
  56                 push @found, $emsg;
  57                 last;
  58         }
  59
  60         if(@found) {
  61                 $body = join $opt->{joiner} || "\n", @found;
  62         }
  63         else {
  64                 $body =~ s/\$ERROR\$/$error/g;
  65         }
  66
  67         $body =~ s/\s+$//;
  68         $body =~ s/^\s+//;
  69
  70         if($opt->{error_set}) {
  71                 set_error($body, $opt->{error_set});
  72         }
  73         if($opt->{error_scratch}) {
  74                 $::Scratch->{$opt->{error_scratch}} = 1;
  75         }
  76
  77         return '' if $opt->{hide};
  78         return $body;
  79 }
  80 EOR