view release on metacpan or  search on metacpan

lib/Apache/Handlers.pm  view on Meta::CPAN

package Apache::Handlers;

# $Id: Handlers.pm,v 1.2 2002/01/07 15:28:35 jgsmith Exp $

use strict;
use Carp;
use Apache::Constants qw(OK SERVER_ERROR DECLINED);
use Perl::WhichPhase qw: in_BEGIN :;
use vars qw:$VERSION @EXPORT_OK @ISA:;

my $has_mod_perl = defined $INC{'Apache'};

eval {
  use Apache::Log ();
  Apache::ModuleConfig -> has_srv_config;
} if $has_mod_perl;

$VERSION = "0.02";
@ISA = qw!Exporter!;

my %code = ( );

sub dump {
  eval {
    use Data::Dumper;
    return Data::Dumper -> Dump([\%code]);
  };
}

my %phases = qw:
  CHILDINIT       PerlChildInitHandler
  POSTREADREQUEST PerlPostReadRequestHandler
  CHILDEXIT       PerlChildExitHandler
  CLEANUP         PerlCleanupHandler
  LOG             PerlLogHandler
  CONTENT         PerlHandler
  FIXUP           PerlFixupHandler
  TYPE            PerlTypeHandler
  AUTHZ           PerlAuthzHandler
  AUTHEN          PerlAuthenHandler
  ACCESS          PerlAccessHandler
  HEADERPARSER    PerlHeaderParserHandler
  TRANS           PerlTransHandler
  RESTART         PerlRestartHandler
:;

@EXPORT_OK = (qw:run_phase:, keys %phases);

my %sigil = qw:
  CODE   &
  ARRAY  @
  SCALAR $
  HASH   %
:;

sub _do_handler {
  my($method, $referent, $data) = @_;
  my($rsig, $dsig);

  foreach my $s (keys %sigil) {
    $rsig = $sigil{$s} if(UNIVERSAL::isa($referent, $s));
    $dsig = $sigil{$s} if(UNIVERSAL::isa($data, $s));
  }

  croak "Unknown referent type" if !defined $rsig;

  if(UNIVERSAL::isa($referent, 'CODE')) {
    $method->($referent);
  } elsif(!defined $data) {
    $method->(eval "sub { undef $rsig\$referent; }");
  } elsif(!defined $dsig and $rsig eq q+$+) {
    $method->(sub { $$referent = $data; });
  } else {
    croak "Potential referent and data mismatch" if !defined $dsig;
    if($dsig eq '&') {
      $method -> (eval "sub { $rsig\$referent = &\$data(\$referent); }");
    } else {
      $method -> (eval "sub { $rsig\$referent = $dsig\$data; }");
    }
  }
}

foreach my $p (keys %phases) {
  my($code, $keeper, $pusher);

  if($p eq 'ACCESS' || $p eq 'AUTHEN' || $p eq 'AUTHZ') {
    $pusher = "\$r -> push_handlers('$phases{$p}', sub { &\$c; return DECLINED; })";
  } else {
    $pusher = "\$r -> push_handlers('$phases{$p}', sub { &\$c; return OK; })";
  }

  if($p eq 'CLEANUP' || $p eq 'CHILDEXIT') {
    $keeper = "unshift \@{\$code{$p}}, shift";
  } else {
    $keeper = "push \@{\$code{$p}}, shift";
  }

  if($has_mod_perl) {
    eval qq{
      sub $p (&) {
        my \$r;
        if(!in_BEGIN && \$r = Apache->request) {
          my \$c = shift;
          $pusher;
        } else {
          \$code{$p} = [ ] if !ref \$code{$p};
          $keeper;
        }
      }
    };
  } else {
    eval qq{
      sub $p (&) {
        \$code{$p} = [ ] if !ref \$code{$p};
        $keeper;
      }
    };
  }
}

sub run_phase {
  my $r;
  foreach my $h (@_) {
    if(defined $code{$h}) {
      foreach my $c (@{$code{$h}}) {
        eval{ &$c };
        next unless $@;
        if($has_mod_perl && ($r = Apache -> request)) {
          $r -> log -> debug($@);
          return SERVER_ERROR;
        } else {
          die "$@\n";
        }
      }
    }
  }
}