home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Status.pm < prev    next >
Encoding:
Perl POD Document  |  2004-09-17  |  28.5 KB  |  1,104 lines
  1. # Copyright 2003-2004 The Apache Software Foundation
  2. #
  3. # Licensed under the Apache License, Version 2.0 (the "License");
  4. # you may not use this file except in compliance with the License.
  5. # You may obtain a copy of the License at
  6. #
  7. #     http://www.apache.org/licenses/LICENSE-2.0
  8. #
  9. # Unless required by applicable law or agreed to in writing, software
  10. # distributed under the License is distributed on an "AS IS" BASIS,
  11. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  12. # See the License for the specific language governing permissions and
  13. # limitations under the License.
  14. #
  15. package Apache::Status;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19.  
  20. use mod_perl 1.99;
  21.  
  22. use Apache::RequestIO ();
  23. use Apache::RequestRec ();
  24. use Apache::RequestUtil ();
  25. use Apache::ServerUtil ();
  26.  
  27. use File::Spec ();
  28.  
  29. use Apache::Const -compile => qw(OK);
  30.  
  31. $Apache::Status::VERSION = '3.00'; # mod_perl 2.0
  32.  
  33. use constant IS_WIN32 => ($^O eq "MSWin32");
  34.  
  35. our $newQ;
  36.  
  37. if (parse_version("Apache::Request") > 2 &&
  38.     eval { require Apache::Request }) {
  39.     $newQ ||= sub { Apache::Request->new(@_) };
  40. }
  41. elsif (eval { require CGI }) {
  42.     if ($CGI::VERSION >= 2.93) {
  43.         $newQ ||= sub { CGI->new(@_) };
  44.     }
  45.     else {
  46.         $newQ ||= sub { CGI->new };
  47.     }
  48. }
  49. else {
  50.     die "Need CGI.pm or Apache::Request to operate";
  51. }
  52.  
  53. my %status = (
  54.     script    => "PerlRequire'd Files",
  55.     inc       => "Loaded Modules",
  56.     rgysubs   => "Compiled Registry Scripts",
  57.     symdump   => "Symbol Table Dump",
  58.     inh_tree  => "Inheritance Tree",
  59.     isa_tree  => "ISA Tree",
  60.     env       => "Environment",
  61.     sig       => "Signal Handlers",
  62.     myconfig  => "Perl Configuration",
  63.     hooks     => "Enabled mod_perl Hooks",
  64. );
  65.  
  66. delete $status{'hooks'} if $mod_perl::VERSION >= 1.9901;
  67. delete $status{'sig'} if IS_WIN32;
  68.  
  69. # XXX: needs porting
  70. if ($Apache::Server::SaveConfig) {
  71.     $status{"section_config"} = "Perl Section Configuration";
  72. }
  73.  
  74. my %requires = (
  75.     deparse     => ["StatusDeparse",     "B::Deparse",     0.59, ],
  76.     fathom      => ["StatusFathom",      "B::Fathom",      0.05, ],
  77.     symdump     => ["",                  "Devel::Symdump", 2.00, ],
  78.     dumper      => ["StatusDumper",      "Data::Dumper",   0,    ],
  79.     b           => ["",                  "B",              0,    ],
  80.     graph       => ["StatusGraph",       "B::Graph",       0.03, ],
  81.     lexinfo     => ["StatusLexInfo",     "B::LexInfo",     0,    ],
  82.     xref        => ["",                  "B::Xref",        0,    ],
  83.     terse       => ["StatusTerse",       "B::Terse",       0,    ],
  84.     tersesize   => ["StatusTerseSize",   "B::TerseSize",   0,    ],
  85.     packagesize => ["StatusPackageSize", "B::TerseSize",   0,    ],
  86.     peek        => ["StatusPeek",        "Apache::Peek",   0,    ], # XXX: version?
  87. );
  88.  
  89. sub has {
  90.     my($r, $what) = @_;
  91.  
  92.     return 0 unless exists $requires{$what};
  93.  
  94.     my($opt, $module, $version) = @{ $requires{$what} };
  95.  
  96.     (my $file = $module) =~ s|::|/|;
  97.     $file .= ".pm";
  98.  
  99.     # if !$opt we skip the testing for the option
  100.     return 0 if $opt && !status_config($r, $opt);
  101.     return 0 unless eval { require $file };
  102.     return 0 unless $module->VERSION >= $version;
  103.  
  104.     return 1;
  105. }
  106.  
  107. use constant CPAN_SEARCH => 'http://search.cpan.org/search?mode=module;query';
  108.  
  109. sub install_hint {
  110.     my ($module) = @_;
  111.     return qq{<p>Please install the } .
  112.            qq{<a href="@{[CPAN_SEARCH]}=$module">$module</a> module.</p>};
  113. }
  114.  
  115. sub status_config {
  116.     my($r, $key) = @_;
  117.     return (lc($r->dir_config($key)) eq "on") ||
  118.         (lc($r->dir_config('StatusOptionsAll')) eq "on");
  119. }
  120.  
  121. sub menu_item {
  122.     my($self, $key, $val, $sub) = @_;
  123.     $status{$key} = $val;
  124.     no strict;
  125.     no warnings 'redefine';
  126.     *{"status_${key}"} = $sub if $sub and ref $sub eq 'CODE';
  127. }
  128.  
  129. sub handler {
  130.     my($r) = @_;
  131.     #Apache->request($r); #for Apache::CGI
  132.     my $qs = $r->args || "";
  133.     my $sub = "status_$qs";
  134.     no strict 'refs';
  135.  
  136.     if ($qs =~ s/^(noh_\w+).*/$1/) {
  137.         &{$qs}($r, $newQ->($r));
  138.         return Apache::OK;
  139.     }
  140.  
  141.     header($r);
  142.     if (defined &$sub) {
  143.         $r->print(@{ &{$sub}($r, $newQ->($r)) });
  144.     }
  145.     elsif ($qs and %{$qs."::"}) {
  146.         $r->print(symdump($r, $newQ->($r), $qs));
  147.     }
  148.     else {
  149.         my $uri = $r->uri;
  150.         $r->print('<p>');
  151.         $r->print(
  152.             map { qq[<a href="$uri?$_">$status{$_}</a><br>\n] } keys %status
  153.         );
  154.         $r->print('</p>');
  155.     }
  156.     $r->print("</body></html>");
  157.  
  158.     Apache::OK;
  159. }
  160.  
  161. sub header {
  162.     my $r = shift;
  163.     my $start = scalar localtime $^T;
  164.     my $srv = Apache::ServerUtil::get_server_version();
  165.     $r->content_type("text/html");
  166.     my $v = $^V ? sprintf "v%vd", $^V : $];
  167.     $r->print(<<"EOF");
  168. <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN">
  169. <html lang="en">
  170. <head>
  171.   <title>Apache::Status</title>
  172.   <style type="text/css">
  173.   body {
  174.     color: #000;
  175.     background-color: #fff;
  176.   }
  177.   p.hdr {
  178.     background-color: #ddd;
  179.     border: 2px outset;
  180.     padding: 3px;
  181.     width: 99%;
  182.   }
  183.   </style>
  184. </head>
  185. <body>
  186. <p class="hdr">
  187.   Embedded Perl version <b>$v</b> for <b>$srv</b> process <b>$$</b>,<br>
  188.   running since $start
  189. </p>
  190. EOF
  191.  
  192. }
  193.  
  194. sub symdump {
  195.     my($r, $q, $package) = @_;
  196.  
  197.     return install_hint("Devel::Symdump") unless has($r, "symdump");
  198.  
  199.     my $meth = lc($r->dir_config("StatusRdump")) eq "on"
  200.         ? "rnew" : "new";
  201.     my $sob = Devel::Symdump->$meth($package);
  202.     return $sob->Apache::Status::as_HTML($package, $r, $q);
  203. }
  204.  
  205. sub status_symdump {
  206.     my($r, $q) = @_;
  207.     [symdump($r, $q, 'main')];
  208. }
  209.  
  210. sub status_section_config {
  211.     my($r, $q) = @_;
  212.     require Apache::PerlSections;
  213.     ["<pre>", Apache::PerlSections->dump, "</pre>"];
  214. }
  215.  
  216. sub status_hooks {
  217.     my($r, $q) = @_;
  218.     # XXX: hooks list access doesn't exist yet in 2.0
  219.     require mod_perl;
  220.     require mod_perl_hooks;
  221.     my @retval = qw(<table>);
  222.     my @list = mod_perl::hooks();
  223.     for my $hook (sort @list) {
  224.         my $on_off = 
  225.             mod_perl::hook($hook) ? "<b>Enabled</b>" : "<i>Disabled</i>";
  226.         push @retval, "<tr><td>$hook</td><td>$on_off</td></tr>\n";
  227.     }
  228.     push @retval, qw(</table>);
  229.     \@retval;
  230. }
  231.  
  232. sub status_inc {
  233.     my($r, $q) = @_;
  234.  
  235.     my $uri = $r->uri;
  236.     my @retval = (
  237.         '<table border="1">',
  238.         "<tr>", 
  239.         (map "<td><b>$_</b></td>", qw(Package Version Modified File)),
  240.         "</tr>\n"
  241.     );
  242.  
  243.     foreach my $file (sort keys %INC) {
  244.         local $^W = 0;
  245.         next if $file =~ m:^/:;
  246.         next unless $file =~ m:\.pm:;
  247.         next unless $INC{$file}; #e.g. fake Apache/TieHandle.pm
  248.  
  249.         no strict 'refs';
  250.         (my $module = $file) =~ s,/,::,g;
  251.         $module =~ s,\.pm$,,;
  252.         my $v = ${"$module\:\:VERSION"} || '0.00';
  253.         push @retval, (
  254.             "<tr>", 
  255.             (map "<td>$_</td>", 
  256.                 qq(<a href="$uri?$module">$module</a>),
  257.                 $v, scalar localtime((stat $INC{$file})[9]), $INC{$file}),
  258.             "</tr>\n"
  259.         );
  260.     }
  261.     push @retval, "</table>\n";
  262.     push @retval, "<p><b>\@INC</b> = <br>", join "<br>\n", @INC, "";
  263.     \@retval;
  264. }
  265.  
  266. sub status_script {
  267.     my($r, $q) = @_;
  268.  
  269.     my @retval = (
  270.         '<table border="1">',
  271.         "<tr><td><b>PerlRequire</b></td><td><b>Location</b></td></tr>\n",
  272.     );
  273.  
  274.     foreach my $file (sort keys %INC) {
  275.         next if $file =~ m:\.(pm|al|ix)$:;
  276.         push @retval, 
  277.             qq(<tr><td>$file</td><td>$INC{$file}</td></tr>\n);
  278.     }
  279.     push @retval, "</table>";
  280.     \@retval;
  281. }
  282.  
  283. my $RegistryCache;
  284.  
  285. sub registry_cache {
  286.     my($self, $cache) = @_;
  287.  
  288.     # XXX: generalize
  289.  
  290.     $RegistryCache = $cache if $cache;
  291.     $RegistryCache || $Apache::Registry;
  292. }
  293.  
  294. sub get_packages_per_handler {
  295.     my($root, $stash) = @_;
  296.  
  297.     my %handlers = ();
  298.     my @packages = get_packages($stash);
  299.     for (@packages) {
  300.         /^\*${root}::([\w:]+)::(\w+)::$/ && push @{ $handlers{$1} }, $2;
  301.     }
  302.  
  303.     return %handlers;
  304. }
  305.  
  306. sub get_packages {
  307.     my($stash) = @_;
  308.  
  309.     no strict 'refs';
  310.     my @packages = ();
  311.     for (keys %$stash) {
  312.         return $stash unless $stash->{$_} =~ /::$/;
  313.         push @packages, get_packages($stash->{$_});
  314.     }
  315.     return @packages;
  316. }
  317.  
  318. sub status_rgysubs {
  319.     my($r, $q) = @_;
  320.  
  321.     local $_;
  322.     my $uri = $r->uri;
  323.     my $cache = __PACKAGE__->registry_cache;
  324.  
  325.     my @retval = "<h2>Compiled registry scripts grouped by their handler</h2>";
  326.  
  327.     push @retval,
  328.       "<p><b>Click on package name to see its symbol table</b></p>\n";
  329.  
  330.     my $root = "ModPerl::ROOT";
  331.     no strict 'refs';
  332.     my %handlers = get_packages_per_handler($root, *{$root . "::"});
  333.     for my $handler (sort keys %handlers) {
  334.         push @retval, "<h4>$handler:</h4>\n<p>\n";
  335.         for (sort @{ $handlers{$handler} }) {
  336.             my $full = join '::', $root, $handler, $_;
  337.             push @retval, qq(<a href="$uri?$full">$_</a>\n), "<br>";
  338.         }
  339.         push @retval, "</p>\n";
  340.     }
  341.  
  342.     \@retval;
  343. }
  344.  
  345. sub status_env {
  346.     my ($r) = shift;
  347.  
  348.     my @retval = ("<p>\n");
  349.  
  350.     if ($r->handler eq 'modperl') {
  351.         # the handler can be executed under the "modperl" handler
  352.         push @retval,
  353.             qq{<b>Under the "modperl" handler, the environment is:</b>};
  354.         # XXX: I guess we could call $r->subprocess_env; and show how
  355.         # would it look like under the 'perl-script' environment, but
  356.         # under the 'modperl' handler %ENV doesn't get reset,
  357.         # therefore on the first reload it'll see the bloated %ENV in
  358.         # first place.
  359.     } else {
  360.         # the handler can be executed under the "perl-script" handler
  361.         push @retval,
  362.             qq{<b>Under the "perl-script" handler, the environment is</b>:};
  363.     }
  364.     push @retval, "\n</p>\n";
  365.     push @retval, "<pre>", (map "$_ = $ENV{$_}\n", sort keys %ENV), "</pre>";
  366.  
  367.     \@retval;
  368. }
  369.  
  370. sub status_sig {
  371.     ["<pre>",
  372.      (map {
  373.          my $val = $SIG{$_} || "";
  374.          if ($val and ref $val eq "CODE") {
  375.              # XXX: 2.0 doesn't have Apache::Symbol
  376.              if (my $cv = Apache::Symbol->can('sv_name')) {
  377.                  $val = "\\&".  $cv->($val);
  378.              }
  379.          }
  380.          "$_ = $val\n" }
  381.       sort keys %SIG),
  382.      "</pre>"];
  383. }
  384.  
  385. sub status_myconfig {
  386.     ["<pre>", myconfig(), "</pre>"];
  387. }
  388.  
  389. sub status_inh_tree {
  390.     return has(shift, "symdump")
  391.         ? ["<pre>", Devel::Symdump->inh_tree, "</pre>"]
  392.         : install_hint("Devel::Symdump");
  393. }
  394.  
  395. sub status_isa_tree {
  396.     return has(shift, "symdump")
  397.         ? ["<pre>", Devel::Symdump->isa_tree, "</pre>"]
  398.         : install_hint("Devel::Symdump");
  399. }
  400.  
  401. sub status_data_dump {
  402.     my($r, $q) = @_;
  403.  
  404.     return install_hint('Data::Dumper') unless has($r, "dumper");
  405.  
  406.     my($name, $type) = (split "/", $r->uri)[-2,-1];
  407.  
  408.     no strict 'refs';
  409.     my @retval = "<p>\nData Dump of $name $type\n</p>\n<pre>\n";
  410.     my $str = Data::Dumper->Dump([*$name{$type}], ['*'.$name]);
  411.     $str =~ s/= \\/= /; #whack backwack
  412.     push @retval, $str, "\n";
  413.     push @retval, peek_link($r, $q, $name, $type);
  414.     push @retval, b_graph_link($r, $q, $name);
  415.     push @retval, "</pre>";
  416.     \@retval;
  417. }
  418.  
  419. sub cv_file {
  420.     my $obj = shift;
  421.     $obj->can('FILEGV') ? $obj->FILEGV->SV->PV : $obj->FILE;
  422. }
  423.  
  424. sub status_cv_dump { 
  425.     my($r, $q) = @_;
  426.     return [] unless has($r, "b");
  427.  
  428.     no strict 'refs';
  429.     my($name, $type) = (split "/", $r->uri)[-2,-1];
  430.     # could be another child, which doesn't have this symbol table?
  431.     return unless *$name{CODE}; 
  432.  
  433.     my @retval = "<p>Subroutine info for <b>$name</b></p>\n<pre>\n";
  434.     my $obj    = B::svref_2object(*$name{CODE});
  435.     my $file   = cv_file($obj);
  436.     my $stash  = $obj->GV->STASH->NAME;
  437.     my $script = $r->location;
  438.  
  439.     push @retval, "File: ", 
  440.         (-e $file ? qq(<a href="file:$file">$file</a>) : $file), "\n";
  441.  
  442.     my $cv    = $obj->GV->CV;
  443.     my $proto = $cv->PV if $cv->can('PV');
  444.  
  445.     push @retval, qq(Package: <a href="$script?$stash">$stash</a>\n);
  446.     push @retval, "Line: ",      $obj->GV->LINE, "\n";
  447.     push @retval, "Prototype: ", $proto || "none", "\n";
  448.     push @retval, "XSUB: ",      $obj->XSUB ? "yes" : "no", "\n";
  449.     push @retval, peek_link($r, $q, $name, $type);
  450.     #push @retval, xref_link($r, $q, $name);
  451.     push @retval, b_graph_link($r, $q, $name);
  452.     push @retval, b_lexinfo_link($r, $q, $name);
  453.     push @retval, b_terse_link($r, $q, $name);
  454.     push @retval, b_terse_size_link($r, $q, $name);
  455.     push @retval, b_deparse_link($r, $q, $name);
  456.     push @retval, b_fathom_link($r, $q, $name);
  457.     push @retval, "</pre>";
  458.     \@retval;
  459. }
  460.  
  461. sub b_lexinfo_link {
  462.     my($r, $q, $name) = @_;
  463.  
  464.     return unless has($r, "lexinfo");
  465.  
  466.     my $script = $q->location;
  467.     return qq(\n<a href="$script/$name?noh_b_lexinfo">Lexical Info</a>\n);
  468. }
  469.  
  470. sub noh_b_lexinfo {
  471.     my $r = shift;
  472.  
  473.     $r->content_type("text/plain");
  474.     return unless has($r, "lexinfo");
  475.  
  476.     no strict 'refs';
  477.     my($name) = (split "/", $r->uri)[-1];
  478.     $r->print("Lexical Info for $name\n\n");
  479.     my $lexi = B::LexInfo->new;
  480.     my $info = $lexi->cvlexinfo($name);
  481.     $r->print(${ $lexi->dumper($info) });
  482. }
  483.  
  484. my %b_terse_exp = ('slow' => 'syntax', 'exec' => 'execution');
  485.  
  486. sub b_terse_link {
  487.     my($r, $q, $name) = @_;
  488.  
  489.     return unless has($r, "terse");
  490.  
  491.     my $script = $r->location;
  492.     my @retval;
  493.     for (qw(exec slow)) {
  494.         my $exp = "$b_terse_exp{$_} order";
  495.         push @retval,
  496.             qq(\n<a href="$script/$_/$name?noh_b_terse">Syntax Tree Dump ($exp)</a>\n);
  497.     }
  498.     join '', @retval;
  499. }
  500.  
  501. sub noh_b_terse {
  502.     my $r = shift;
  503.  
  504.     $r->content_type("text/plain");
  505.     return unless has($r, "terse");
  506.  
  507.     no strict 'refs';
  508.     my($arg, $name) = (split "/", $r->uri)[-2,-1];
  509.     $r->print("Syntax Tree Dump ($b_terse_exp{$arg}) for $name\n\n");
  510.  
  511.     # XXX: blead perl dumps things to STDERR, though the same version
  512.     # works fine with 1.27
  513.     B::Terse::compile($arg, $name)->();
  514. }
  515.  
  516. sub b_terse_size_link {
  517.     my($r, $q, $name) = @_;
  518.  
  519.     return unless has($r, "tersesize");
  520.  
  521.     my $script = $r->location;
  522.     my @retval;
  523.     for (qw(exec slow)) {
  524.         my $exp = "$b_terse_exp{$_} order";
  525.         push @retval,
  526.             qq(\n<a href="$script/$_/$name?noh_b_terse_size">Syntax Tree Size ($exp)</a>\n);
  527.     }
  528.     join '', @retval;
  529. }
  530.  
  531. sub noh_b_terse_size {
  532.     my $r = shift;
  533.  
  534.     $r->content_type("text/html");
  535.     return unless has($r, "tersesize");
  536.  
  537.     $r->print('<pre>');
  538.     my($arg, $name) = (split "/", $r->uri)[-2,-1];
  539.     my $uri = $r->location;
  540.     my $link = qq{<a href="$uri/$name/CODE?cv_dump">$name</a>};
  541.     $r->print("Syntax Tree Size ($b_terse_exp{$arg} order) for $link\n\n");
  542.     B::TerseSize::compile($arg, $name)->();
  543. }
  544.  
  545. sub b_package_size_link {
  546.     my($r, $q, $name) = @_;
  547.  
  548.     return unless has($r, "packagesize");
  549.  
  550.     my $script = $r->location;
  551.     qq(<a href="$script/$name?noh_b_package_size">Memory Usage</a>\n);
  552. }
  553.  
  554. sub noh_b_package_size {
  555.     my($r, $q) = @_;
  556.  
  557.     $r->content_type("text/html");
  558.     return unless has($r, "packagesize");
  559.  
  560.     $r->print('<pre>');
  561.  
  562.     no strict 'refs';
  563.     my($package) = (split "/", $r->uri)[-1];
  564.     my $script = $r->location;
  565.     $r->print("Memory Usage for package $package\n\n");
  566.     my($subs, $opcount, $opsize) = B::TerseSize::package_size($package);
  567.     $r->print("Totals: $opsize bytes | $opcount OPs\n\n");
  568.  
  569.     my $nlen = 0;
  570.     my @keys = map {
  571.         $nlen = length > $nlen ? length : $nlen;
  572.         $_;
  573.     } (sort { $subs->{$b}->{size} <=> $subs->{$a}->{size} } keys %$subs);
  574.  
  575.     my $clen = length $subs->{$keys[0]}->{count};
  576.     my $slen = length $subs->{$keys[0]}->{size};
  577.  
  578.     for my $name (@keys) {
  579.         my $stats = $subs->{$name};
  580.         if ($name =~ /^my /) {
  581.             $r->printf("%-${nlen}s %${slen}d bytes\n", $name, $stats->{size});
  582.         }
  583.         elsif ($name =~ /^\*(\w+)\{(\w+)\}/) {
  584.             my $link = qq(<a href="$script/$package\::$1/$2?data_dump">);
  585.             $r->printf("$link%-${nlen}s</a> %${slen}d bytes\n", 
  586.                        $name, $stats->{size});
  587.         }
  588.         else {
  589.             my $link = 
  590.                 qq(<a href="$script/slow/$package\::$name?noh_b_terse_size">);
  591.             $r->printf("$link%-${nlen}s</a> %${slen}d bytes | %${clen}d OPs\n",
  592.                        $name, $stats->{size}, $stats->{count});
  593.         }
  594.     }
  595. }
  596.  
  597. sub b_deparse_link {
  598.     my($r, $q, $name) = @_;
  599.  
  600.     return unless has($r, "deparse");
  601.  
  602.     my $script = $r->location;
  603.     return qq(\n<a href="$script/$name?noh_b_deparse">Deparse</a>\n);
  604. }
  605.  
  606. sub noh_b_deparse {
  607.     my $r = shift;
  608.  
  609.     $r->content_type("text/plain");
  610.     return unless has($r, "deparse");
  611.  
  612.     my $name = (split "/", $r->uri)[-1];
  613.     $r->print("Deparse of $name\n\n");
  614.     my $deparse = B::Deparse->new(split /\s+/, 
  615.                                   $r->dir_config('StatusDeparseOptions')||"");
  616.     my $body = $deparse->coderef2text(\&{$name});
  617.     $r->print("sub $name $body");
  618. }
  619.  
  620. sub b_fathom_link {
  621.     my($r, $q, $name) = @_;
  622.  
  623.     return unless has($r, "fathom");
  624.  
  625.     my $script = $r->location;
  626.     return qq(\n<a href="$script/$name?noh_b_fathom">Fathom Score</a>\n);
  627. }
  628.  
  629. sub noh_b_fathom {
  630.     my $r = shift;
  631.  
  632.     $r->content_type("text/plain");
  633.     return unless has($r, "fathom");
  634.  
  635.     my $name = (split "/", $r->uri)[-1];
  636.     $r->print("Fathom Score of $name\n\n");
  637.     my $fathom = B::Fathom->new(split /\s+/, 
  638.                                 $r->dir_config('StatusFathomOptions')||"");
  639.     $r->print($fathom->fathom(\&{$name}));
  640. }
  641.  
  642. sub peek_link {
  643.     my($r, $q, $name, $type) = @_;
  644.  
  645.     return unless has($r, "peek");
  646.  
  647.     my $script = $r->location;
  648.     return qq(\n<a href="$script/$name/$type?noh_peek">Peek Dump</a>\n);
  649. }
  650.  
  651. sub noh_peek {
  652.     my $r = shift;
  653.  
  654.     $r->content_type("text/plain");
  655.     return unless has($r, "peek");
  656.  
  657.     no strict 'refs';
  658.     my($name, $type) = (split "/", $r->uri)[-2,-1];
  659.     $type =~ s/^FUNCTION$/CODE/;
  660.     $r->print("Peek Dump of $name $type\n\n");
  661.     Apache::Peek::Dump(*{$name}{$type});
  662. }
  663.  
  664. sub xref_link {
  665.     my($r, $q, $name) = @_;
  666.  
  667.     return unless has($r, "xref");
  668.  
  669.     my $script = $r->location;
  670.     return qq(\n<a href="$script/$name?noh_xref">Cross Reference Report</a>\n);
  671. }
  672.  
  673. sub noh_xref {
  674.     my $r = shift;
  675.  
  676.     $r->content_type("text/plain");
  677.     return unless has($r, "xref");
  678.  
  679.     (my $thing = $r->path_info) =~ s:^/::;
  680.     $r->print("Xref of $thing\n");
  681.     B::Xref::compile($thing)->();
  682. }
  683.  
  684. $Apache::Status::BGraphCache ||= 0;
  685. if ($Apache::Status::BGraphCache) {
  686.     Apache->push_handlers(PerlChildExitHandler => sub {
  687.         unlink keys %Apache::Status::BGraphCache;
  688.     });
  689. }
  690.  
  691. sub b_graph_link {
  692.     my($r, $q, $name) = @_;
  693.  
  694.     return unless has($r, "graph");
  695.  
  696.     my $script = $r->location;
  697.     return qq(\n<a href="$script/$name?noh_b_graph">OP Tree Graph</a>\n);
  698. }
  699.  
  700. sub noh_b_graph {
  701.     my $r = shift;
  702.  
  703.     return unless has($r, "graph");
  704.  
  705.     untie *STDOUT;
  706.  
  707.     my $dir = File::Spec->catfile(Apache::ServerUtil::server_root,
  708.         ($r->dir_config("GraphDir") || "logs/b_graphs"));
  709.  
  710.     mkdir $dir, 0755 unless -d $dir;
  711.  
  712.     (my $thing = $r->path_info) =~ s:^/::;
  713.     $thing =~ s{::}{-}g; # :: is not allowed in the filename on some OS
  714.     my $type = "dot";
  715.     my $file = "$dir/$thing.$$.gif";
  716.  
  717.     unless (-e $file) {
  718.         tie *STDOUT, "B::Graph", $r, $file;
  719.         B::Graph::compile("-$type", $thing)->();
  720.         (tied *STDOUT)->{graph}->close;
  721.     }
  722.  
  723.     if (-s $file) {
  724.         local *FH;
  725.         open FH, $file or die "Can't open $file: $!";
  726.         $r->content_type("image/gif");
  727.         $r->send_fd(\*FH);
  728.     }
  729.     else {
  730.         $r->content_type("text/plain");
  731.         $r->print("Graph of $thing failed!\n");
  732.     }
  733.     if ($Apache::Status::BGraphCache) {
  734.         $Apache::Status::BGraphCache{$file}++;
  735.     }
  736.     else {
  737.         unlink $file;
  738.     }
  739.  
  740.     0;
  741. }
  742.  
  743. sub B::Graph::TIEHANDLE {
  744.     my($class, $r, $file) = @_;
  745.  
  746.     if ($file =~ /^([^<>|;]+)$/) {
  747.         $file = $1;
  748.     }
  749.     else {
  750.         die "TAINTED data in THING=> ($file)";
  751.     }
  752.  
  753.     $ENV{PATH} = join ":", qw{/usr/bin /usr/local/bin};
  754.     my $dot = $r->dir_config("Dot") || "dot";
  755.  
  756.     require IO::File;
  757.     my $pipe = IO::File->new("|$dot -Tgif -o $file");
  758.     $pipe or die "can't open pipe to dot $!";
  759.     $pipe->autoflush(1);
  760.  
  761.     return bless {
  762.                   graph => $pipe,
  763.                   r     => $r,
  764.     }, $class;
  765. }
  766.  
  767. sub B::Graph::PRINT {
  768.     my $self = shift;
  769.  
  770.     $self->{graph}->print(@_);
  771. }
  772.  
  773. my %can_dump = map {$_,1} qw(scalars arrays hashes);
  774.  
  775. sub as_HTML {
  776.     my($self, $package, $r, $q) = @_;
  777.  
  778.     my @m = qw(<table>);
  779.     my $uri = $r->uri;
  780.     my $is_main = $package eq "main";
  781.  
  782.     my $do_dump = has($r, "dumper");
  783.  
  784.     my @methods = sort keys %{$self->{'AUTOLOAD'}};
  785.  
  786.     if ($is_main) { 
  787.         @methods = grep { $_ ne "packages" } @methods;
  788.         unshift @methods, "packages";
  789.     }
  790.  
  791.     for my $type (@methods) {
  792.         (my $dtype = uc $type) =~ s/E?S$//;
  793.         push @m, "<tr><td valign=\"top\"><b>$type</b></td>";
  794.         my @line = ();
  795.  
  796.         for (sort $self->_partdump(uc $type)) {
  797.             s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64)/eg; 
  798.  
  799.             if ($type eq "scalars") {
  800.                 no strict 'refs';
  801.                 next unless defined eval { $$_ };
  802.             }
  803.  
  804.             if ($type eq "packages") {
  805.                 push @line, qq(<a href="$uri?$_">$_</a>);
  806.             }
  807.             elsif ($type eq "functions") {
  808.                 if (has($r, "b")) {
  809.                     push @line, qq(<a href="$uri/$_/$dtype?cv_dump">$_</a>);
  810.                 }
  811.                 else {
  812.                     push @line, $_;
  813.                 }
  814.             }
  815.             elsif ($do_dump and $can_dump{$type}) {
  816.                 next if /_</;
  817.                 push @line, qq(<a href="$uri/$_/$dtype?data_dump">$_</a>);
  818.             }
  819.             else {
  820.                 push @line, $_;
  821.             }
  822.         }
  823.         push @m, "<td>" . join(", ", @line) . "</td></tr>\n";
  824.     }
  825.     push @m, "</table>";
  826.  
  827.     return join "\n", @m, "<hr>", b_package_size_link($r, $q, $package);
  828. }
  829.  
  830. sub myconfig {
  831.     require Config;
  832.     # Config::myconfig(); fails under threads with (5.8.0 < perl < 5.8.3)
  833.     # "Modification of a read-only value attempted"
  834.     # provide a workaround
  835.     if ($Config::Config{useithreads} and $] > 5.008 and $] < 5.008003) {
  836.         return $Config::summary_expanded if $Config::summary_expanded;
  837.         ($Config::summary_expanded = $Config::summary) =~
  838.             s{\$(\w+)}
  839.              { my $c = $Config::Config{$1}; defined($c) ? $c : 'undef' }ge;
  840.         return $Config::summary_expanded;
  841.     }
  842.     else {
  843.         return Config::myconfig();
  844.   }
  845. }
  846.  
  847. # mp2 modules have to deal with situations where a binary incompatible
  848. # mp1 version of the same module is installed in the same
  849. # tree. therefore when checking for a certain version, one wants to
  850. # check the version of the module 'require()' will find without
  851. # loading that module. this function partially adopted from
  852. # ExtUtils::MM_Unix does just that. it returns the version number of
  853. # the first module that it finds, forcing numerical context, making
  854. # the return value suitable for immediate numerical comparison
  855. # operation. (i.e. 2.03-dev will be returned as 2.03,  0 will be
  856. # returned when the parsing has failed or a module wasn't found).
  857. sub parse_version {
  858.     my $name = shift;
  859.     die "no module name passed" unless $name;
  860.     my $file = File::Spec->catfile(split /::/, $name) . '.pm';
  861.     for my $dir (@INC) {
  862.         next if ref $dir; # skip code refs
  863.  
  864.         my $pmfile = File::Spec->catfile($dir, $file);
  865.         next unless -r $pmfile;
  866.  
  867.         open my $fh, $pmfile or die "can't open $pmfile: $!";
  868.  
  869.         my $inpod = 0;
  870.         my $version;
  871.         while (<$fh>) {
  872.             $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
  873.             next if $inpod || /^\s*#/;
  874.  
  875.             chomp;
  876.             next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
  877.             { local($1, $2); ($_ = $_) = /(.*)/; } # untaint
  878.             my $eval = qq{
  879.                 package Apache::Status::_version;
  880.                 no strict;
  881.  
  882.                 local $1$2;
  883.                 \$$2=undef; do {
  884.                     $_
  885.                 }; \$$2
  886.             };
  887.             no warnings;
  888.             $version = eval $eval;
  889.             warn "Could not eval '$eval' in $pmfile: $@" if $@;
  890.             last;
  891.         }
  892.  
  893.         close $fh;
  894.  
  895.         # avoid situations like "2.03-dev" and return a numerical
  896.         # version
  897.         if (defined $version) {
  898.             no warnings;
  899.             $version += 0; # force number
  900.             return $version;
  901.         }
  902.     }
  903.  
  904.     return 0; # didn't find the file or the version number
  905. }
  906.  
  907. 1;
  908.  
  909. __END__
  910.  
  911.  
  912. =head1 NAME
  913.  
  914. Apache::Status - Embedded interpreter status information
  915.  
  916.  
  917.  
  918.  
  919. =head1 Synopsis
  920.  
  921.   <Location /perl-status>
  922.       SetHandler modperl
  923.       PerlResponseHandler Apache::Status
  924.   </Location>
  925.  
  926.  
  927.  
  928.  
  929.  
  930. =head1 Description
  931.  
  932. The B<Apache::Status> module provides some information
  933. about the status of the Perl interpreter embedded in the server.
  934.  
  935. Configure like so:
  936.  
  937.   <Location /perl-status>
  938.        SetHandler modperl
  939.        PerlResponseHandler Apache::Status
  940.   </Location>
  941.  
  942. Notice that under the "modperl" core handler the I<Environment> menu
  943. option will show only the environment under that handler. To see the
  944. environment seen by handlers running under the "perl-script" core
  945. handler, configure C<Apache::Status> as:
  946.  
  947.   <Location /perl-status>
  948.        SetHandler perl-script
  949.        PerlResponseHandler Apache::Status
  950.   </Location>
  951.  
  952. Other modules can "plugin" a menu item like so:
  953.  
  954.   Apache::Status->menu_item(
  955.      'DBI' => "DBI connections", #item for Apache::DBI module
  956.      sub {
  957.          my($r,$q) = @_; #request and CGI objects
  958.          my(@strings);
  959.          push @strings,  "blobs of html";
  960.          return \@strings;     #return an array ref
  961.      }
  962.   ) if Apache->module("Apache::Status"); #only if Apache::Status is loaded
  963.  
  964. B<WARNING>: Apache::Status must be loaded before these modules via the 
  965. PerlModule or PerlRequire directives.
  966.  
  967.  
  968.  
  969.  
  970.  
  971. =head1 Options
  972.  
  973. =over 4
  974.  
  975. =item StatusOptionsAll
  976.  
  977. This single directive will enable all of the options described below.
  978.  
  979.   PerlSetVar StatusOptionsAll On
  980.  
  981. =item StatusDumper
  982.  
  983. When browsing symbol tables, the values of arrays, hashes and scalars
  984. can be viewed via B<Data::Dumper> if this configuration variable is set
  985. to On:
  986.  
  987.   PerlSetVar StatusDumper On
  988.  
  989. =item StatusPeek
  990.  
  991. With this option On and the B<Apache::Peek> module installed, 
  992. functions and variables can be viewed ala B<Devel::Peek> style:
  993.  
  994.   PerlSetVar StatusPeek On
  995.  
  996. =item StatusLexInfo
  997.  
  998. With this option On and the B<B::LexInfo> module installed,
  999. subroutine lexical variable information can be viewed.
  1000.  
  1001.   PerlSetVar StatusLexInfo On
  1002.  
  1003. =item StatusDeparse
  1004.  
  1005. With this option On and B<B::Deparse> version 0.59 or higher 
  1006. (included in Perl 5.005_59+), subroutines can be "deparsed".
  1007.  
  1008.   PerlSetVar StatusDeparse On
  1009.  
  1010. Options can be passed to B::Deparse::new like so:
  1011.  
  1012.   PerlSetVar StatusDeparseOptions "-p -sC"
  1013.  
  1014. See the B<B::Deparse> manpage for details.
  1015.  
  1016. =item StatusTerse
  1017.  
  1018. With this option On, text-based op tree graphs of subroutines can be 
  1019. displayed, thanks to B<B::Terse>.
  1020.  
  1021.   PerlSetVar StatusTerse On
  1022.  
  1023. =item StatusTerseSize
  1024.  
  1025. With this option On and the B<B::TerseSize> module installed,
  1026. text-based op tree graphs of subroutines and their size can be
  1027. displayed.  See the B<B::TerseSize> docs for more info.
  1028.  
  1029.   PerlSetVar StatusTerseSize On
  1030.  
  1031. =item StatusTerseSizeMainSummary
  1032.  
  1033. With this option On and the B<B::TerseSize> module installed, a
  1034. "Memory Usage" will be added to the Apache::Status main menu.  This
  1035. option is disabled by default, as it can be rather cpu intensive to
  1036. summarize memory usage for the entire server.  It is strongly
  1037. suggested that this option only be used with a development server
  1038. running in B<-X> mode, as the results will be cached.
  1039.  
  1040.   PerlSetVar StatusTerseSizeMainSummary On
  1041.  
  1042. =item StatusGraph
  1043.  
  1044. When B<StatusDumper> is enabled, another link "OP Tree Graph" will be
  1045. present with the dump if this configuration variable is set to On:
  1046.  
  1047.   PerlSetVar StatusGraph
  1048.  
  1049. This requires the B module (part of the Perl compiler kit) and
  1050. B::Graph (version 0.03 or higher) module to be installed along with
  1051. the B<dot> program.
  1052.  
  1053. Dot is part of the graph visualization toolkit from AT&T:
  1054. C<http://www.research.att.com/sw/tools/graphviz/>).
  1055.  
  1056. B<WARNING>: Some graphs may produce very large images, some graphs may
  1057. produce no image if B::Graph's output is incorrect.
  1058.  
  1059. =item Dot
  1060.  
  1061. Location of the dot program for StatusGraph,
  1062. if other than /usr/bin or /usr/local/bin
  1063.  
  1064. =item GraphDir
  1065.  
  1066. Directory where StatusGraph should write it's temporary image files.
  1067. Default is $ServerRoot/logs/b_graphs
  1068.  
  1069. =back
  1070.  
  1071.  
  1072.  
  1073.  
  1074.  
  1075. =head1 Prerequisites
  1076.  
  1077. The I<Devel::Symdump> module, version B<2.00> or higher.
  1078.  
  1079.  
  1080.  
  1081.  
  1082.  
  1083. =head1 Copyright
  1084.  
  1085. mod_perl 2.0 and its core modules are copyrighted under
  1086. The Apache Software License, Version 2.0.
  1087.  
  1088.  
  1089.  
  1090.  
  1091. =head1 See Also
  1092.  
  1093. perl(1), Apache(3), Devel::Symdump(3), Data::Dumper(3), B(3),
  1094. B::Graph(3), L<mod_perl 2.0 documentation|docs::2.0::index>.
  1095.  
  1096.  
  1097.  
  1098.  
  1099. =head1 Authors
  1100.  
  1101. Doug MacEachern with contributions from Stas Bekman
  1102.  
  1103. =cut
  1104.