# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements. See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License. You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package Apache2::Status;
use strict;
use warnings FATAL => 'all';
use mod_perl2;
use Apache2::RequestIO ();
use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use Apache2::ServerUtil ();
use File::Spec ();
use Apache2::Const -compile => qw(OK);
$Apache2::Status::VERSION = '4.00'; # mod_perl 2.0
use constant IS_WIN32 => ($^O eq "MSWin32");
my %status = (
script => "PerlRequire'd Files",
inc => "Loaded Modules",
rgysubs => "Compiled Registry Scripts",
symdump => "Symbol Table Dump",
inh_tree => "Inheritance Tree",
isa_tree => "ISA Tree",
env => "Environment",
sig => "Signal Handlers",
myconfig => "Perl Configuration",
);
delete $status{'sig'} if IS_WIN32;
if ($Apache2::PerlSections::Save) {
$status{"section_config"} = "Perl Section Configuration";
}
my %requires = (
deparse => ["StatusDeparse", "B::Deparse", 0.59, ],
fathom => ["StatusFathom", "B::Fathom", 0.05, ],
symdump => ["", "Devel::Symdump", 2.00, ],
dumper => ["StatusDumper", "Data::Dumper", 0, ],
b => ["", "B", 0, ],
graph => ["StatusGraph", "B::Graph", 0.03, ],
lexinfo => ["StatusLexInfo", "B::LexInfo", 0, ],
xref => ["StatusXref", "B::Xref", 1.01, ],
terse => ["StatusTerse", "B::Terse", 0, ],
tersesize => ["StatusTerseSize", "B::TerseSize", 0.09, ],
packagesize => ["StatusPackageSize", "B::TerseSize", 0.09, ],
peek => ["StatusPeek", "Apache::Peek", 1.03, ],
);
sub has {
my ($r, $what) = @_;
return 0 unless exists $requires{$what};
my ($opt, $module, $version) = @{ $requires{$what} };
(my $file = $module) =~ s|::|/|;
$file .= ".pm";
# if !$opt we skip the testing for the option
return 0 if $opt && !status_config($r, $opt);
return 0 unless eval { require $file };
my $mod_ver = $module->VERSION;
$mod_ver =~ s/_.*//; # handle dev versions like 2.121_02
return 0 unless $mod_ver && $mod_ver >= $version;
return 1;
}
use constant CPAN_SEARCH => 'http://search.cpan.org/search?mode=module;query';
sub install_hint {
my ($module) = @_;
return qq{Please install the } .
qq{$module module.
};
}
sub status_config {
my ($r, $key) = @_;
return (lc($r->dir_config($key)) eq "on") ||
(lc($r->dir_config('StatusOptionsAll')) eq "on");
}
sub menu_item {
my ($self, $key, $val, $sub) = @_;
$status{$key} = $val;
no strict;
no warnings 'redefine';
*{"status_${key}"} = $sub if $sub and ref $sub eq 'CODE';
}
sub handler {
my ($r) = @_;
my $qs = $r->args || "";
my $sub = "status_$qs";
no strict 'refs';
if ($qs =~ s/^(noh_\w+).*/$1/) {
&{$qs}($r);
return Apache2::Const::OK;
}
header($r);
if (defined &$sub) {
$r->print(@{ &{$sub}($r) });
}
elsif ($qs and %{$qs."::"}) {
$r->print(symdump($r, $qs));
}
else {
my $uri = $r->uri;
$r->print('');
$r->print(
map { qq[$status{$_}
\n] } sort { lc $a cmp lc $b } keys %status
);
$r->print('
');
}
$r->print("