perl

ATTRIBUTES

Attribute	Pos.	Req.	Default	Description
tables \| table	Yes	No
subs			0	imports subroutines defined by `Sub`
short_errors			0	log error message only
no_return			0	store result into session key `mv_perl_result` instead of returning it
interpolate			0	interpolate input?
reparse			1	interpolate output?
hide			0	Hide the tag return value?

DESCRIPTION

Evaluate embedded Perl code and return the result.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

The [calc] tag is lower-overhead variant of [perl], because it does not accept arguments, does not try to interpolate tag body, does not pre-open any database tables, and it doesn't do any extra wrapping.

The [calc] tag will remember variable values inside the page, so you can do the equivalent of a memory store and memory recall for a loop. In other words, variables you initialize or set in one [calc] block are also visible in all further [calc] blocks on the same page.

There is no reason to ever use this tag inside [perl] or [mvasp].

AVAILABILITY

perl is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/perl.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: perl.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag perl                Order        tables
UserTag perl                addAttr
UserTag perl                attrAlias    table tables
UserTag perl                hasEndTag
UserTag perl                PosNumber    1
UserTag perl                Version      $Revision: 1.5 $
UserTag perl                MapRoutine   Vend::Interpolate::tag_perl

Source: lib/Vend/Interpolate.pm
Lines: 1743

sub tag_perl {
my ($tables, $opt,$body) = @_;
my ($result,@share);
#::logDebug("tag_perl MVSAFE=$MVSAFE::Safe opts=" . uneval($opt));

if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
  return undef;
}

if ($MVSAFE::Safe) {
#::logDebug("tag_perl: Attempt to call perl from within Safe.");
  return undef;
}

#::logDebug("tag_perl: tables=$tables opt=" . uneval($opt) . " body=$body");
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));
if($opt->{subs} or $opt->{arg} =~ /\bsub\b/) {
  no strict 'refs';
  for(keys %{$Global::GlobalSub}) {
#::logDebug("tag_perl share subs: GlobalSub=$_");
    next if defined $Global::AdminSub->{$_}
      and ! $Global::AllowGlobal->{$Vend::Cat};
    *$_ = \&{$Global::GlobalSub->{$_}};
    push @share, "&$_";
  }
  for(keys %{$Vend::Cfg->{Sub} || {}}) {
#::logDebug("tag_perl share subs: Sub=$_");
    *$_ = \&{$Vend::Cfg->{Sub}->{$_}};
    push @share, "&$_";
  }
}

if($tables) {
  my (@tab) = grep /\S/, split /\s+/, $tables;
  foreach my $tab (@tab) {
    next if $Db{$tab};
    my $db = database_exists_ref($tab);
    next unless $db;
    my $dbh;
    $db = $db->ref();
    if($db->config('type') == 10) {
      my @extra_tabs = $db->_shared_databases();
      push (@tab, @extra_tabs);
      $dbh = $db->dbh();
    } elsif ($db->can('dbh')) {
      $dbh = $db->dbh();
    }

    if($hole) {
      if ($dbh) {
        $Sql{$tab} = $hole->wrap($dbh);
      }
      $Db{$tab} = $hole->wrap($db);
      if($db->config('name') ne $tab) {
        $Db{$db->config('name')} = $Db{$tab};
      }
    }
    else {
      $Sql{$tab} = $db->[$Vend::Table::DBI::DBI]
        if $db =~ /::DBI/;
      $Db{$tab} = $db;
    }
  }
}

$Tag = $hole->wrap($Tag) if $hole and ! $Vend::TagWrapped++;

init_calc() if ! $Vend::Calc_initialized;
$ready_safe->share(@share) if @share;

if($Vend::Cfg->{Tie_Watch}) {
  eval {
    for(@{$Vend::Cfg->{Tie_Watch}}) {
      logGlobal("touching $_");
      my $junk = $Config->{$_};
    }
  };
}

$Items = $Vend::Items;

$body = readfile($opt->{file}) . $body
  if $opt->{file};

# Skip costly eval of code entirely if perl tag was called with no code,
# likely used only for the side-effect of opening database handles
return if $body !~ /\S/;

$body =~ tr/\r//d if $Global::Windows;

$MVSAFE::Safe = 1;
if (
  ( $opt->{global} or (! defined $opt->{global} and $Global::PerlAlwaysGlobal->{$Vend::Cat} ) )
    and
  $Global::AllowGlobal->{$Vend::Cat}
  )
{
  $MVSAFE::Safe = 0 unless $MVSAFE::Unsafe;
}

if(! $MVSAFE::Safe) {
  if ($Global::PerlNoStrict->{$Vend::Cat} || $opt->{no_strict}) {
    no strict;
    $result = eval($body);
  }
  else {
    $result = eval($body);
  }
}
else {
  $result = $ready_safe->reval($body);
}

undef $MVSAFE::Safe;

if ($@) {
#::logDebug("tag_perl failed $@");
  my $msg = $@;
  if($Vend::Try) {
    $Vend::Session->{try}{$Vend::Try} .= "\n" 
      if $Vend::Session->{try}{$Vend::Try};
    $Vend::Session->{try}{$Vend::Try} .= $@;
  }
      if($opt->{number_errors}) {
          my @lines = split("\n",$body);
          my $counter = 1;
          map { $_ = sprintf("% 4d %s",$counter++,$_); } @lines;
          $body = join("\n",@lines);
      }
      if($opt->{trim_errors}) {
          if($msg =~ /line (\d+)\.$/) {
              my @lines = split("\n",$body);
              my $start = $1 - $opt->{trim_errors} - 1;
              my $length = (2 * $opt->{trim_errors}) + 1;
              @lines = splice(@lines,$start,$length);
              $body = join("\n",@lines);
          }
      }
      if($opt->{eval_label}) {
          $msg =~ s/\(eval \d+\)/($opt->{eval_label})/g;
      }
      if($opt->{short_errors}) {
          chomp($msg);
          logError( "Safe: %s" , $msg );
          logGlobal({ level => 'debug' }, "Safe: %s" , $msg );
      } else {
          logError( "Safe: %s\n%s\n" , $msg, $body );
          logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body );
      }
  return $opt->{failure};
}
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));

if ($opt->{no_return}) {
  $Vend::Session->{mv_perl_result} = $result;
  $result = join "", @Vend::Document::Out;
  @Vend::Document::Out = ();
}
#::logDebug("tag_perl succeeded result=$result\nEND");
return $result;
}

Source: lib/Vend/Interpolate.pm
Lines: 1743

sub tag_perl {
my ($tables, $opt,$body) = @_;
my ($result,@share);
#::logDebug("tag_perl MVSAFE=$MVSAFE::Safe opts=" . uneval($opt));

if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
  return undef;
}

if ($MVSAFE::Safe) {
#::logDebug("tag_perl: Attempt to call perl from within Safe.");
  return undef;
}

#::logDebug("tag_perl: tables=$tables opt=" . uneval($opt) . " body=$body");
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));
if($opt->{subs} or $opt->{arg} =~ /\bsub\b/) {
  no strict 'refs';
  for(keys %{$Global::GlobalSub}) {
#::logDebug("tag_perl share subs: GlobalSub=$_");
    next if defined $Global::AdminSub->{$_}
      and ! $Global::AllowGlobal->{$Vend::Cat};
    *$_ = \&{$Global::GlobalSub->{$_}};
    push @share, "&$_";
  }
  for(keys %{$Vend::Cfg->{Sub} || {}}) {
#::logDebug("tag_perl share subs: Sub=$_");
    *$_ = \&{$Vend::Cfg->{Sub}->{$_}};
    push @share, "&$_";
  }
}

if($tables) {
  my (@tab) = grep /\S/, split /\s+/, $tables;
  foreach my $tab (@tab) {
    next if $Db{$tab};
    my $db = database_exists_ref($tab);
    next unless $db;
    my $dbh;
    $db = $db->ref();
    if($db->config('type') == 10) {
      my @extra_tabs = $db->_shared_databases();
      push (@tab, @extra_tabs);
      $dbh = $db->dbh();
    } elsif ($db->can('dbh')) {
      $dbh = $db->dbh();
    }

    if($hole) {
      if ($dbh) {
        $Sql{$tab} = $hole->wrap($dbh);
      }
      $Db{$tab} = $hole->wrap($db);
      if($db->config('name') ne $tab) {
        $Db{$db->config('name')} = $Db{$tab};
      }
    }
    else {
      $Sql{$tab} = $db->[$Vend::Table::DBI::DBI]
        if $db =~ /::DBI/;
      $Db{$tab} = $db;
    }
  }
}

$Tag = $hole->wrap($Tag) if $hole and ! $Vend::TagWrapped++;

init_calc() if ! $Vend::Calc_initialized;
$ready_safe->share(@share) if @share;

if($Vend::Cfg->{Tie_Watch}) {
  eval {
    for(@{$Vend::Cfg->{Tie_Watch}}) {
      logGlobal("touching $_");
      my $junk = $Config->{$_};
    }
  };
}

$Items = $Vend::Items;

$body = readfile($opt->{file}) . $body
  if $opt->{file};

# Skip costly eval of code entirely if perl tag was called with no code,
# likely used only for the side-effect of opening database handles
return if $body !~ /\S/;

$body =~ tr/\r//d if $Global::Windows;

$MVSAFE::Safe = 1;
if (
  ( $opt->{global} or (! defined $opt->{global} and $Global::PerlAlwaysGlobal->{$Vend::Cat} ) )
    and
  $Global::AllowGlobal->{$Vend::Cat}
  )
{
  $MVSAFE::Safe = 0 unless $MVSAFE::Unsafe;
}

if(! $MVSAFE::Safe) {
  if ($Global::PerlNoStrict->{$Vend::Cat} || $opt->{no_strict}) {
    no strict;
    $result = eval($body);
  }
  else {
    $result = eval($body);
  }
}
else {
  $result = $ready_safe->reval($body);
}

undef $MVSAFE::Safe;

if ($@) {
#::logDebug("tag_perl failed $@");
  my $msg = $@;
  if($Vend::Try) {
    $Vend::Session->{try}{$Vend::Try} .= "\n" 
      if $Vend::Session->{try}{$Vend::Try};
    $Vend::Session->{try}{$Vend::Try} .= $@;
  }
      if($opt->{number_errors}) {
          my @lines = split("\n",$body);
          my $counter = 1;
          map { $_ = sprintf("% 4d %s",$counter++,$_); } @lines;
          $body = join("\n",@lines);
      }
      if($opt->{trim_errors}) {
          if($msg =~ /line (\d+)\.$/) {
              my @lines = split("\n",$body);
              my $start = $1 - $opt->{trim_errors} - 1;
              my $length = (2 * $opt->{trim_errors}) + 1;
              @lines = splice(@lines,$start,$length);
              $body = join("\n",@lines);
          }
      }
      if($opt->{eval_label}) {
          $msg =~ s/\(eval \d+\)/($opt->{eval_label})/g;
      }
      if($opt->{short_errors}) {
          chomp($msg);
          logError( "Safe: %s" , $msg );
          logGlobal({ level => 'debug' }, "Safe: %s" , $msg );
      } else {
          logError( "Safe: %s\n%s\n" , $msg, $body );
          logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body );
      }
  return $opt->{failure};
}
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));

if ($opt->{no_return}) {
  $Vend::Session->{mv_perl_result} = $result;
  $result = join "", @Vend::Document::Out;
  @Vend::Document::Out = ();
}
#::logDebug("tag_perl succeeded result=$result\nEND");
return $result;
}

AUTHORS

Interchange Development Group

Name