view release on metacpan or  search on metacpan

lib/Apache2/Translation.pm  view on Meta::CPAN

    }
  } else {
    my $o;
    if( $o=tied(%{$I->{eval_cache}}) ) {
      $o->max_size($arg);
    } else {
      eval "use Tie::Cache::LRU";
      die "$@" if $@;
      tie %{$I->{eval_cache}}, 'Tie::Cache::LRU', $arg;
    }
  }
  $I->{eval_cache_def}=1;
}

sub SERVER_MERGE {
  my ($base, $add)=@_;
  my %merged;

  if( exists $add->{provider_param} ) {
    $merged{provider_param}=$add->{provider_param};
  } elsif( exists $base->{provider_param} ) {
    $merged{provider_param}='inherit';
  }

  if( $add->{eval_cache_def} ) {
    $merged{eval_cache}=$add->{eval_cache};
  } else {
    $merged{eval_cache}=$base->{eval_cache};
  }

  if( $add->{key_def} ) {
    $merged{key}=$add->{key};
  } else {
    $merged{key}=$base->{key};
  }

  return bless \%merged, ref($base);
}

sub SERVER_CREATE {
  my ($class, $parms)=@_;

  return bless {
		key=>'default',
		eval_cache=>{},
	       } => $class;
}

################################################################
# here begins the real stuff
################################################################

sub handle_eval {
  my ($eval)=@_;

  my $sub=$cf->{eval_cache}->{$eval};

  unless( $sub ) {
    $sub=<<"SUB";
sub {
# line 1 "code fragment"
  $eval
}
SUB

    $sub=eval $sub;
    if( $@ ) {
      (my $e=$@)=~s/\s*\Z//;
      $r->warn( __PACKAGE__.": $eval: $e" );
      return;
    }
    $cf->{eval_cache}->{$eval}=$sub;
  }

  my @rc;
  if( wantarray ) {
    @rc=eval {$sub->();};
  } else {
    $rc[0]=eval {$sub->();};
  }
  die $@ if( ref $@ );
  if( $@ ) {
    (my $e=$@)=~s/\s*\Z//;
    $r->warn( __PACKAGE__.": $eval: $e" );
  }

  return wantarray ? @rc : $rc[0];
}

sub add_note {
  $r->notes->add(__PACKAGE__."::".$_[0], $_[1]);
}

my %action_dispatcher;
%action_dispatcher=
  (
   do=>sub {
     my ($action, $what)=@_;
     handle_eval( $what );
     return 1;
   },

   perlhandler=>sub {
     my ($action, $what)=@_;
     add_note(response=>$what);
     $r->handler('modperl')
       unless( $r->handler=~/^(?:modperl|perl-script)$/ );

     # some perl handler use $r->location to get some "base path", e.g.
     # Catalyst. The only way to set this location is this.
     #add_note(config=>$MATCHED_URI."\t".'PerlResponseHandler '.$what);
     add_note(config=>$MATCHED_URI."\tPerlResponseHandler ".__PACKAGE__.'::response');
     add_note(shortcut_maptostorage=>" ".$MATCHED_PATH_INFO);
     $need_m2s++;

     # Translation done: return OK instead of DECLINED
     $RC=Apache2::Const::OK;
     return 1;
   },

   doc=>sub {