cvs commit: modperl-2.0/lib/Apache Status.pm
stas2003/02/03 23:00:52 Modified:lib/Apache Status.pm Log: of course we don't have 2.00 yet, use 1.99 Revision ChangesPath 1.6 +1 -4 modperl-2.0/lib/Apache/Status.pm Index: Status.pm === RCS file: /home/cvs/modperl-2.0/lib/Apache/Status.pm,v retrieving revision 1.5 retrieving revision 1.6 diff -u -r1.5 -r1.6 --- Status.pm 28 Jan 2003 07:27:48 - 1.5 +++ Status.pm 4 Feb 2003 07:00:52 - 1.6 @@ -9,10 +9,7 @@ # when used with 'no warnings' it still barks on redefinining the # constants - - -# XXX -# use mod_perl 2.0; +use mod_perl 1.99; use Apache::RequestRec (); use Apache::RequestUtil ();
cvs commit: modperl-2.0/lib/Apache Status.pm
stas2003/01/27 20:53:15
Modified:lib/Apache Status.pm
Log:
- CGI.pm's script_name() appears to be broken, use $r-location instead
- handle gracefully the stash dump for a child that doesn't have that
stash
Revision ChangesPath
1.2 +15 -12modperl-2.0/lib/Apache/Status.pm
Index: Status.pm
===
RCS file: /home/cvs/modperl-2.0/lib/Apache/Status.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- Status.pm 25 Jan 2003 13:26:11 - 1.1
+++ Status.pm 28 Jan 2003 04:53:15 - 1.2
@@ -312,7 +312,6 @@
my($r, $q) = @_;
my($name, $type) = (split /, $r-uri)[-2,-1];
-my $script = $q-script_name;
no strict 'refs';
my @retval = Data Dump of $name $type pre\n;
@@ -336,17 +335,21 @@
no strict 'refs';
my($name, $type) = (split /, $r-uri)[-2,-1];
+# could be another child, which doesn't have this symbol table?
+return unless *$name{CODE};
+
my @retval = Subroutine info for b$name/b pre\n;
-my $script = $q-script_name;
my $obj= B::svref_2object(*$name{CODE});
my $file = cv_file($obj);
my $stash = $obj-GV-STASH-NAME;
+my $script = $r-location;
push @retval, File: ,
(-e $file ? qq(a href=file:$file$file/a) : $file), \n;
my $cv= $obj-GV-CV;
my $proto = $cv-PV if $cv-can('PV');
+
push @retval, qq(Package: a href=$script?$stash$stash/a\n);
push @retval, Line: , $obj-GV-LINE, \n;
push @retval, Prototype: , $proto || none, \n;
@@ -376,7 +379,7 @@
return unless eval { require B::Graph };
B::Graph-UNIVERSAL::VERSION('0.03');
-my $script = $q-script_name;
+my $script = $r-location;
return qq(\na href=$script/$name?noh_b_graphOP Tree Graph/a\n);
}
@@ -386,7 +389,7 @@
return unless status_config($r, StatusLexInfo);
return unless eval { require B::LexInfo };
-my $script = $q-script_name;
+my $script = $q-location;
return qq(\na href=$script/$name?noh_b_lexinfoLexical Info/a\n);
}
@@ -411,7 +414,7 @@
return unless status_config($r, StatusTerse);
return unless eval { require B::Terse };
-my $script = $q-script_name;
+my $script = $r-location;
my @retval;
for (qw(exec slow)) {
my $exp = $b_terse_exp{$_} order;
@@ -440,7 +443,7 @@
return unless status_config($r, StatusTerseSize);
return unless eval { require B::TerseSize };
-my $script = $q-script_name;
+my $script = $r-location;
my @retval;
for (qw(exec slow)) {
my $exp = $b_terse_exp{$_} order;
@@ -471,7 +474,7 @@
return unless status_config($r, StatusPackageSize);
return unless eval { require B::TerseSize };
-my $script = $q-script_name;
+my $script = $r-location;
qq(a href=$script/$name?noh_b_package_sizeMemory Usage/a\n);
}
@@ -485,7 +488,7 @@
no strict 'refs';
my($package) = (split /, $r-uri)[-1];
-my $script = $q-script_name;
+my $script = $r-location;
$r-print(Memory Usage for package $package\n\n);
my($subs, $opcount, $opsize) = B::TerseSize::package_size($package);
$r-print(Totals: $opsize bytes | $opcount OPs\n\n);
@@ -525,7 +528,7 @@
return unless eval { require B::Deparse };
return unless $B::Deparse::VERSION = 0.59;
-my $script = $q-script_name;
+my $script = $r-location;
return qq(\na href=$script/$name?noh_b_deparseDeparse/a\n);
}
@@ -549,7 +552,7 @@
return unless eval { require B::Fathom };
return unless $B::Fathom::VERSION = 0.05;
-my $script = $q-script_name;
+my $script = $r-location;
return qq(\na href=$script/$name?noh_b_fathomFathom Score/a\n);
}
@@ -571,7 +574,7 @@
return unless status_config($r, StatusPeek);
return unless $is_installed{Apache::Peek};
-my $script = $q-script_name;
+my $script = $r-location;
return qq(\na href=$script/$name/$type?noh_peekPeek Dump/a\n);
}
@@ -592,7 +595,7 @@
return unless $is_installed{B::Xref};
-my $script = $q-script_name;
+my $script = $r-location;
return qq(\na href=$script/$name?noh_xrefCross Reference Report/a\n);
}
cvs commit: modperl-2.0/lib/Apache Status.pm
stas2003/01/25 05:26:11
Added: lib/Apache Status.pm
Log:
started porting Apache::Status to 2.0:
- adjust style
- use mod_perl 2.0 api (trying to get away from using compat.pm)
- adjust the 'registry scripts' logic to work with the new registry cache
(present scripts by the handler they are compiled in)
Revision ChangesPath
1.1 modperl-2.0/lib/Apache/Status.pm
Index: Status.pm
===
package Apache::Status;
use strict;
#use warnings; #XXX FATAL = 'all';
no warnings; # 'redefine';
# XXX: something is wrong with bleadperl, it warns about redefine
# warnings, when no warnings 'redefine' is set (test with 5.8.0). even
# when used with 'no warnings' it still barks on redefinining the
# constants
# XXX
# use mod_perl 2.0;
use Apache::RequestRec ();
use Apache::RequestUtil ();
use Apache::ServerUtil ();
$Apache::Status::VERSION = '3.00'; # mod_perl 2.0
use constant IS_WIN32 = ($^O eq MSWin32);
my $Is_Win32 = ($^O eq MSWin32);
my %is_installed = ();
{
local $SIG{__DIE__};
%is_installed = map {
$_, (eval(require $_) || 0);
} qw (Data::Dumper Devel::Symdump B Apache::Request
Apache::Peek Apache::Symbol);
}
our $newQ;
if ($is_installed{Apache::Request}) {
$newQ ||= sub { Apache::Request-new(@_) };
}
else {
$is_installed{CGI} = eval(require CGI) || 0;
$newQ ||= sub { CGI-new; };
}
my $CPAN_base = http://cpan.org/modules/by-module/;;
my $install_symdump = EOF;
Please install the a href=$CPAN_base/Devel/Devel::Symdump/a module.
EOF
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,
hooks = Enabled mod_perl Hooks,
);
delete $status{'hooks'} if $mod_perl::VERSION = 1.9901;
delete $status{'sig'} if IS_WIN32;
# XXX: needs porting
if ($Apache::Server::SaveConfig) {
$status{section_config} = Perl Section Configuration;
}
sub menu_item {
my($self, $key, $val, $sub) = @_;
$status{$key} = $val;
no strict;
*{status_${key}} = $sub if $sub and ref $sub eq 'CODE';
}
sub handler {
my($r) = @_;
Apache-request($r); #for Apache::CGI
my $qs = $r-args || ;
my $sub = status_$qs;
no strict 'refs';
if ($qs =~ s/^(noh_\w+).*/$1/) {
return {$qs}($r, $newQ-($r));
}
header($r);
if (defined $sub) {
$r-print(@{ {$sub}($r, $newQ-($r)) });
}
elsif ($qs and %{$qs.::}) {
$r-print(symdump($r, $newQ-($r), $qs));
}
else {
my $uri = $r-uri;
$r-print(
map { qq[a href=$uri?$_$status{$_}/abr\n] } keys %status
);
}
$r-print(/body/html);
1;
}
sub header {
my $r = shift;
my $start = scalar localtime $^T;
my $srv = Apache::get_server_version();
$r-content_type(text/html);
my $v = $^V ? sprintf v%vd, $^V : $];
$r-print(EOF);
html
headtitleApache::Status/title/head
body
Embedded Perl version b$v/b for b$srv/b process b$$/b,
br running since $starthr
EOF
}
sub symdump {
my($r, $q, $package) = @_;
return $install_symdump unless $is_installed{Devel::Symdump};
my $meth = new;
$meth = rnew if lc($r-dir_config(StatusRdump)) eq on;
my $sob = Devel::Symdump-$meth($package);
return $sob-Apache::Status::as_HTML($package, $r, $q);
}
sub status_symdump {
my($r, $q) = @_;
[symdump($r, $q, 'main')];
}
sub status_section_config {
my($r, $q) = @_;
require Apache::PerlSections;
[pre, Apache::PerlSections-dump, /pre];
}
sub status_hooks {
my($r, $q) = @_;
# XXX: hooks list access doesn't exist yet in 2.0
require mod_perl;
require mod_perl_hooks;
my @retval = qw(table);
my @list = mod_perl::hooks();
for my $hook (sort @list) {
my $on_off =
mod_perl::hook($hook) ? bEnabled/b : iDisabled/i;
push @retval, trtd$hook/tdtd$on_off/td/tr\n;
}
push @retval, qw(/table);
\@retval;
}
sub status_inc {
my($r, $q) = @_;
my $uri = $r-uri;
my @retval = (
table border=1,
tr,
(map tdb$_/b/td, qw(Package Version Modified File)),
/tr\n
);
foreach my $file (sort keys %INC) {
local $^W = 0;
next if $file =~ m:^/:;
next unless $file =~ m:\.pm:;
next unless $INC{$file}; #e.g. fake Apache/TieHandle.pm
no strict 'refs';
(my $module = $file) =~
