view release on metacpan or  search on metacpan

DebugInfo.pm  view on Meta::CPAN

  my $file              = $r->dir_config('DebugFile');
  
  $self{fh}             = Apache::File->new(">>$file") if $file;

  if ($self{fh}) {
    $log->info("\tusing $file for output") 
      if $Apache::DebugInfo::DEBUG;
  }
  elsif ($file) {
    $r->log_error("Can't open $file - $! - using STDERR instead");
    $self{fh} = *STDERR;
  }
  else {
    $log->info("\tno file specified - using STDERR for output")
      if $Apache::DebugInfo::DEBUG;
    $self{fh} = *STDERR;
  }

  return bless \%self, $class;
}

sub headers_in {
#---------------------------------------------------------------------
# dump all of the incoming request headers
#---------------------------------------------------------------------
  
  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::headers_in")
     if $Apache::DebugInfo::DEBUG;

#---------------------------------------------------------------------
# if there are arguments, push the routine onto the handler stack
#---------------------------------------------------------------------

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

#---------------------------------------------------------------------
# otherwise, just print in a neat and tidy format
#---------------------------------------------------------------------

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

  $r->headers_in->do(sub {
    my ($field, $value) = @_;
    if ($field =~ m/Cookie/) {
      my @values = split /; /, $value;
      foreach my $cookie (@values) {
        print $fh "\t$field => $cookie\n";
      }
    }
    else { 
      print $fh "\t$field => $value\n";
    }
    1;
  });   

#---------------------------------------------------------------------
# wrap up...
#---------------------------------------------------------------------

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

  # return declined so that Apache::DebugInfo doesn't short circuit
  # Perl*Handlers that stop the chain after the first OK (like
  # PerlTransHandler and PerlTypeHandler)

  return DECLINED;
}

sub headers_out {
#---------------------------------------------------------------------
# dump all of the outbound response headers
#---------------------------------------------------------------------

  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::headers_out")
     if $Apache::DebugInfo::DEBUG;

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

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

  $r->headers_out->do(sub {
    my ($field, $value) = @_;
    if ($field =~ m/Cookie/) {
      my @values = split /;/, $value;
      print $fh "\t$field => $values[0]\n";
      for (my $i=1;$i < @values; $i++) {
        print $fh "\t\t=> $values[$i]\n";
      }
    }
    else { 
      print $fh "\t$field => $value\n";
    }
    1;
  });   

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

  return DECLINED;
}

sub notes {
#---------------------------------------------------------------------
# dump all the notes 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::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 {
#---------------------------------------------------------------------