File Coverage

blib/lib/Apache/Handlers.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

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";
        }
      }
    }
  }
}

my $yet_initialized = 0;

sub reset {
  &run_phase( qw: RESTART :);
  %code = ( );
  $yet_initialized = 0;
}

sub handler($) {
  my($r) = @_;

  return SERVER_ERROR
    if not $yet_initialized and run_phase(qw: CHILDINIT :) == SERVER_ERROR;

  $yet_initialized = 1;

  return OK if $r -> current_callback() eq 'PerlChildInitHandler';

  # install handlers
  foreach my $p (keys %code) {
    my $count;
    next if $p eq 'CHILDINIT' or $p eq 'POSTREADREQUEST' or $p eq 'CHILDEXIT';
    $r -> push_handlers($phases{$p} => sub {
        my $ret;
        foreach my $c (@{$code{$p} || []}) {
          eval { &$c() };
          if($@) {
            $r -> log -> debug($@);
            return SERVER_ERROR;
          }
        }
        if($p eq 'AUTHZ' || $p eq 'AUTHEN' || $p eq 'ACCESS') {
          return DECLINED;
        }
        return OK;
    });
  }

  return SERVER_ERROR
      if run_phase(qw: POSTREADREQUEST :) == SERVER_ERROR;

}

INIT {
  run_phase(qw: CHILDINIT TRANS HEADERPARSER ACCESS
                AUTHEN AUTHZ TYPE FIXUP CONTENT :) unless $has_mod_perl;
}

END {
  run_phase(qw: LOG CLEANUP CHILDEXIT :) unless $has_mod_perl;
}

# the eval has an "uninitialized string" warning for some reason, but since
# this is the last bit and we don't care so much if it fails, we're turning
# off warnings through the end of this file...

no warnings;

eval {

use Attribute::Handlers;

sub UNIVERSAL::PerlChildInitHandler : ATTR(BEGIN)
  { _do_handler(\&CHILDINIT, $_[2], $_[4]); }

sub UNIVERSAL::PerlPostReadRequestHandler : ATTR(BEGIN)
  { _do_handler(\&POSTREADREQUEST, $_[2], $_[4]); }

sub UNIVERSAL::PerlTransHandler : ATTR(BEGIN)
  { _do_handler(\&TRANS, $_[2], $_[4]); }

sub UNIVERSAL::PerlHeaderParserHandler : ATTR(BEGIN)
  { _do_handler(\&HEADERPARSER, $_[2], $_[4]); }

sub UNIVERSAL::PerlAccessHandler : ATTR(BEGIN)
  { _do_handler(\&ACCESS, $_[2], $_[4]); }

sub UNIVERSAL::PerlAuthenHandler : ATTR(BEGIN)
  { _do_handler(\&AUTHEN, $_[2], $_[4]); }

sub UNIVERSAL::PerlAuthzHandler : ATTR(BEGIN)
  { _do_handler(\&AUTHZ, $_[2], $_[4]); }

sub UNIVERSAL::PerlTypeHandler : ATTR(BEGIN)
  { _do_handler(\&TYPE, $_[2], $_[4]); }

sub UNIVERSAL::PerlFixupHandler : ATTR(BEGIN)
  { _do_handler(\&FIXUP, $_[2], $_[4]); }

sub UNIVERSAL::PerlHandler : ATTR(BEGIN)
  { _do_handler(\&CONTENT, $_[2], $_[4]); }

sub UNIVERSAL::PerlLogHandler : ATTR(BEGIN)
  { _do_handler(\&LOG, $_[2], $_[4]); }

sub UNIVERSAL::PerlCleanupHandler : ATTR(BEGIN)
  { _do_handler(\&CLEANUP, $_[2], $_[4]); }

sub UNIVERSAL::PerlChildExitHandler : ATTR(BEGIN)
  { _do_handler(\&CHILDEXIT, $_[2], $_[4]); }

sub UNIVERSAL::PerlRestartHandler : ATTR(BEGIN)
  { _do_handler(\&RESTART, $_[2], $_[4]); }

};

1;

__END__