view release on metacpan or  search on metacpan

DebugInfo.pm  view on Meta::CPAN

package Apache::DebugInfo;

#---------------------------------------------------------------------
#
# usage: various - see the perldoc below
#
#---------------------------------------------------------------------

use 5.005;
use mod_perl 1.2401;
use Apache::Constants qw( OK DECLINED );
use Apache::File;
use Apache::Log;
use Data::Dumper;
use strict;

$Apache::DebugInfo::VERSION = '0.05';

# set debug level
#  0 - messages at info or debug log levels
#  1 - verbose output at info or debug log levels
$Apache::DebugInfo::DEBUG = 0;

sub handler {
#---------------------------------------------------------------------
# this is kinda clunky, but we have to build in some intelligence
# about where the various methods will do the most good
#---------------------------------------------------------------------
  
  my $r           = shift;

  my $log         = $r->server->log;

#  local $^W; # turn off annoying warnings here

  return OK unless $r->dir_config('DebugInfo') =~ m/On/i;
 
  $log->info("Using Apache::DebugInfo") 
    if $Apache::DebugInfo::DEBUG;

  my $object = Apache::DebugInfo->new($r);
  
  $object->timestamp 
    if $r->dir_config('DebugTimestamp');
  $object->mark_phases('All') 
    if $r->dir_config('DebugMarkPhases');

  $object->headers_in('PerlInitHandler')
    if $r->dir_config('DebugHeadersIn');
  $object->pid('PerlInitHandler')
    if $r->dir_config('DebugPID');
  $object->get_handlers('PerlInitHandler')
    if $r->dir_config('DebugGetHandlers');
  $object->dir_config('PerlInitHandler')
    if $r->dir_config('DebugDirConfig');

  $object->notes('PerlCleanupHandler')
    if $r->dir_config('DebugNotes');
  $object->pnotes('PerlCleanupHandler')
    if $r->dir_config('DebugPNotes');
  $object->headers_out('PerlCleanupHandler')
    if $r->dir_config('DebugHeadersOut');

  $log->info("Exiting Apache::DebugInfo") 
    if $Apache::DebugInfo::DEBUG;

  return OK;
}

sub new {
#---------------------------------------------------------------------
# create a new Apache::DebugInfo object
#---------------------------------------------------------------------
  

DebugInfo.pm  view on Meta::CPAN

  $log->info("Using Apache::DebugInfo::notes")
     if $Apache::DebugInfo::DEBUG;

  if (@phases) {
    _push_on_stack($self, @phases);
    $log->info("Exiting Apache::DebugInfo::notes") 
      if $Apache::DebugInfo::DEBUG;
    return;
  }

  print $fh "\nDebug notes for [$ip] $uri during " .
    $r->current_callback . "\n";

  $r->notes->do(sub {
    my ($field, $value) = @_;
    print $fh "\t$field => $value\n";
    1;
  });   

  $log->info("Exiting Apache::DebugInfo::notes") 
    if $Apache::DebugInfo::DEBUG;

  return DECLINED;
}

sub pnotes {
#---------------------------------------------------------------------
# dump all the pnotes for the request
#---------------------------------------------------------------------
  
  my $self              = shift;

  my @phases            = @_;

  my $r                 = $self->{request};
  my $log               = $self->{log};
  my $fh                = $self->{fh};
  my $ip                = $self->{ip};
  my $uri               = $self->{uri};

  $log->info("Using Apache::DebugInfo::pnotes")
     if $Apache::DebugInfo::DEBUG;

  if (@phases) {
    _push_on_stack($self, @phases);
    $log->info("Exiting Apache::DebugInfo::pnotes") 
      if $Apache::DebugInfo::DEBUG;
    return;
  }

  my $pnotes = $r->pnotes;

  print $fh "\nDebug pnotes for [$ip] $uri during " .
    $r->current_callback . "\n";

  my %hash = %$pnotes;

  foreach my $field (sort keys %hash) {

    my $value = $hash{$field};
    my $d = Data::Dumper->new([$value]);

    $d->Pad("\t\t");
    $d->Indent(1);
    $d->Quotekeys(0);
    $d->Terse(1);
    print $fh "\t$field => " . $d->Dump;
  }

  $log->info("Exiting Apache::DebugInfo::pnotes") 
    if $Apache::DebugInfo::DEBUG;

  return DECLINED;
}

sub dir_config {
#---------------------------------------------------------------------
# dump all the PerlSetVar and PerlAddVar variables for the request
#---------------------------------------------------------------------

  my $self              = shift;

  my @phases            = @_;

  my $r                 = $self->{request};
  my $log               = $self->{log};
  my $fh                = $self->{fh};
  my $ip                = $self->{ip};
  my $uri               = $self->{uri};

  $log->info("Using Apache::DebugInfo::dir_config")
     if $Apache::DebugInfo::DEBUG;

  if (@phases) {
    _push_on_stack($self, @phases);
    $log->info("Exiting Apache::DebugInfo::dir_config") 
      if $Apache::DebugInfo::DEBUG;
    return;
  }

  print $fh "\nDebug dir_config for [$ip] $uri during " .
    $r->current_callback . "\n";

  $r->dir_config->do(sub {
    my ($field, $value) = @_;
    print $fh "\t$field => $value\n";
    1;
  });   

  $log->info("Exiting Apache::DebugInfo::dir_config") 
    if $Apache::DebugInfo::DEBUG;

  return DECLINED;
}

sub pid {
#---------------------------------------------------------------------
# I know this is a waste of code for just printing $$, but I thought
# it would be nice to have a consistent interface.  whatever...
#---------------------------------------------------------------------