perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0/lib/Apache Status.pm
Date Tue, 28 Jan 2003 06:50:59 GMT
stas        2003/01/27 22:50:59

  Modified:    lib/Apache Status.pm
  Log:
  - refactor the run-time requirement lookup and require code
  - cleanup to work under the "modperl" handler
  - die if CGI and Apache::Request aren't available
  - use CPAN search for hints to install a missing module
  
  Revision  Changes    Path
  1.3       +103 -80   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.2
  retrieving revision 1.3
  diff -u -r1.2 -r1.3
  --- Status.pm	28 Jan 2003 04:53:15 -0000	1.2
  +++ Status.pm	28 Jan 2003 06:50:59 -0000	1.3
  @@ -21,38 +21,24 @@
   $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"}) {
  +if (eval {require Apache::Request}) {
       $newQ ||= sub { Apache::Request->new(@_) };
   }
  -else {
  -    $is_installed{"CGI"} = eval("require CGI") || 0;
  +elsif (eval {require CGI}) {
       $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
  +else {
  +    die "Need CGI.pm or Apache::Request to operate";
  +}
   
   my %status = (
       script    => "PerlRequire'd Files",
       inc       => "Loaded Modules",
       rgysubs   => "Compiled Registry Scripts",
  -    'symdump' => "Symbol Table Dump",
  +    symdump   => "Symbol Table Dump",
       inh_tree  => "Inheritance Tree",
       isa_tree  => "ISA Tree",	
       env       => "Environment",
  @@ -69,6 +55,53 @@
       $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        => ["",                  "B::Xref",        0,    ],
  +    terse       => ["StatusTerse",       "B::Terse",       0,    ],
  +    tersesize   => ["StatusTerseSize",   "B::TerseSize",   0,    ],
  +    packagesize => ["StatusPackageSize", "B::TerseSize",   0,    ],
  +    peek        => ["StatusPeek",        "Apache::Peek",   0,    ], # XXX: version?
  +);
  +
  +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 };
  +    return 0 unless $module->VERSION >= $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{<a href="@{[CPAN_SEARCH]}=$module">$module</a> 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;
  @@ -124,10 +157,10 @@
   sub symdump {
       my($r, $q, $package) = @_;
   
  -    return $install_symdump unless $is_installed{"Devel::Symdump"};
  +    return install_hint("Devel::Symdump") unless has($r, "symdump");
   
  -    my $meth = "new";
  -    $meth = "rnew" if lc($r->dir_config("StatusRdump")) eq "on";
  +    my $meth = lc($r->dir_config("StatusRdump")) eq "on" 
  +        ? "rnew" : "new";
       my $sob = Devel::Symdump->$meth($package);
       return $sob->Apache::Status::as_HTML($package, $r, $q);
   }
  @@ -281,6 +314,7 @@
        (map {
   	 my $val = $SIG{$_} || "";
   	 if ($val and ref $val eq "CODE") {
  +             # XXX: 2.0 doesn't have Apache::Symbol
   	     if (my $cv = Apache::Symbol->can('sv_name')) {
   		 $val = "\\&".  $cv->($val);
   	     }
  @@ -297,20 +331,22 @@
   
   
   sub status_inh_tree {
  -    return $is_installed{"Devel::Symdump"}
  +    return has(shift, "symdump")
           ? ["<pre>", Devel::Symdump->inh_tree, "</pre>"]
  -        : $install_symdump;
  +        : install_hint("Devel::Symdump");
   }
   
  -sub status_isa_tree { 
  -    return $is_installed{"Devel::Symdump"}
  +sub status_isa_tree {
  +    return has(shift, "symdump")
           ? ["<pre>", Devel::Symdump->isa_tree, "</pre>"]
  -        : $install_symdump;
  +        : install_hint("Devel::Symdump");
   }
   
  -sub status_data_dump { 
  +sub status_data_dump {
       my($r, $q) = @_;
   
  +    return install_hint('Data::Dumper') unless has($r, "dumper");
  +
       my($name, $type) = (split "/", $r->uri)[-2,-1];
   
       no strict 'refs';
  @@ -331,7 +367,7 @@
   
   sub status_cv_dump { 
       my($r, $q) = @_;
  -    return [] unless $is_installed{B};
  +    return [] unless has($r, "b");
   
       no strict 'refs';
       my($name, $type) = (split "/", $r->uri)[-2,-1];
  @@ -366,28 +402,10 @@
       \@retval;
   }
   
  -sub status_config {
  -    my($r, $key) = @_;
  -    return (lc($r->dir_config($key)) eq "on") ||
  -        (lc($r->dir_config('StatusOptionsAll')) eq "on");
  -}
  -
  -sub b_graph_link {
  -    my($r, $q, $name) = @_;
  -
  -    return unless status_config($r, "StatusGraph");
  -    return unless eval { require B::Graph };
  -
  -    B::Graph->UNIVERSAL::VERSION('0.03');
  -    my $script = $r->location;
  -    return qq(\n<a href="$script/$name?noh_b_graph">OP Tree Graph</a>\n);
  -}
  -
   sub b_lexinfo_link {
       my($r, $q, $name) = @_;
   
  -    return unless status_config($r, "StatusLexInfo");
  -    return unless eval { require B::LexInfo };
  +    return unless has($r, "lexinfo");
   
       my $script = $q->location;
       return qq(\n<a href="$script/$name?noh_b_lexinfo">Lexical Info</a>\n);
  @@ -397,6 +415,7 @@
       my $r = shift;
   
       $r->content_type("text/plain");
  +    return unless has($r, "lexinfo");
   
       no strict 'refs';
       my($name) = (split "/", $r->uri)[-1];
  @@ -411,8 +430,7 @@
   sub b_terse_link {
       my($r, $q, $name) = @_;
   
  -    return unless status_config($r, "StatusTerse");
  -    return unless eval { require B::Terse };
  +    return unless has($r, "terse");
   
       my $script = $r->location;
       my @retval;
  @@ -427,21 +445,22 @@
   sub noh_b_terse {
       my $r = shift;
   
  -    return unless eval { require B::Terse };
  -
       $r->content_type("text/plain");
  +    return unless has($r, "terse");
   
       no strict 'refs';
       my($arg, $name) = (split "/", $r->uri)[-2,-1];
       $r->print("Syntax Tree Dump ($b_terse_exp{$arg}) for $name\n\n");
  +
  +    # XXX: blead perl dumps things to STDERR, though the same version
  +    # works fine with 1.27
       B::Terse::compile($arg, $name)->();
   }
   
   sub b_terse_size_link {
       my($r, $q, $name) = @_;
   
  -    return unless status_config($r, "StatusTerseSize");
  -    return unless eval { require B::TerseSize };
  +    return unless has($r, "tersesize");
   
       my $script = $r->location;
       my @retval;
  @@ -456,9 +475,8 @@
   sub noh_b_terse_size {
       my $r = shift;
   
  -    return unless eval { require B::TerseSize };
  -
       $r->content_type("text/html");
  +    return unless has($r, "tersesize");
   
       $r->print('<pre>');
       my($arg, $name) = (split "/", $r->uri)[-2,-1];
  @@ -471,8 +489,7 @@
   sub b_package_size_link {
       my($r, $q, $name) = @_;
   
  -    return unless status_config($r, "StatusPackageSize");
  -    return unless eval { require B::TerseSize };
  +    return unless has($r, "packagesize");
   
       my $script = $r->location;
       qq(<a href="$script/$name?noh_b_package_size">Memory Usage</a>\n);
  @@ -481,9 +498,9 @@
   sub noh_b_package_size {
       my($r, $q) = @_;
   
  -    return unless eval { require B::TerseSize };
  -
       $r->content_type("text/html");
  +    return unless has($r, "packagesize");
  +
       $r->print('<pre>');
   
       no strict 'refs';
  @@ -524,9 +541,7 @@
   sub b_deparse_link {
       my($r, $q, $name) = @_;
   
  -    return unless status_config($r, "StatusDeparse");
  -    return unless eval { require B::Deparse };
  -    return unless $B::Deparse::VERSION >= 0.59;
  +    return unless has($r, "deparse");
   
       my $script = $r->location;
       return qq(\n<a href="$script/$name?noh_b_deparse">Deparse</a>\n);
  @@ -536,6 +551,7 @@
       my $r = shift;
   
       $r->content_type("text/plain");
  +    return unless has($r, "deparse");
   
       my $name = (split "/", $r->uri)[-1];
       $r->print("Deparse of $name\n\n");
  @@ -548,9 +564,7 @@
   sub b_fathom_link {
       my($r, $q, $name) = @_;
   
  -    return unless status_config($r, "StatusFathom");
  -    return unless eval { require B::Fathom };
  -    return unless $B::Fathom::VERSION >= 0.05;
  +    return unless has($r, "fathom");
   
       my $script = $r->location;
       return qq(\n<a href="$script/$name?noh_b_fathom">Fathom Score</a>\n);
  @@ -560,6 +574,7 @@
       my $r = shift;
   
       $r->content_type("text/plain");
  +    return unless has($r, "fathom");
   
       my $name = (split "/", $r->uri)[-1];
       $r->print("Fathom Score of $name\n\n");
  @@ -571,8 +586,7 @@
   sub peek_link {
       my($r, $q, $name, $type) = @_;
   
  -    return unless status_config($r, "StatusPeek");
  -    return unless $is_installed{"Apache::Peek"};
  +    return unless has($r, "peek");
   
       my $script = $r->location;
       return qq(\n<a href="$script/$name/$type?noh_peek">Peek Dump</a>\n);
  @@ -582,6 +596,7 @@
       my $r = shift;
   
       $r->content_type("text/plain");
  +    return unless has($r, "peek");
   
       no strict 'refs';
       my($name, $type) = (split "/", $r->uri)[-2,-1];
  @@ -593,7 +608,7 @@
   sub xref_link {
       my($r, $q, $name) = @_;
   
  -    return unless $is_installed{"B::Xref"};
  +    return unless has($r, "xref");
   
       my $script = $r->location;
       return qq(\n<a href="$script/$name?noh_xref">Cross Reference Report</a>\n);
  @@ -603,10 +618,10 @@
       my $r = shift;
   
       $r->content_type("text/plain");
  +    return unless has($r, "xref");
   
  -    require B::Xref;
       (my $thing = $r->path_info) =~ s:^/::;
  -    print "Xref of $thing\n";
  +    $r->print("Xref of $thing\n");
       B::Xref::compile($thing)->();
   }
   
  @@ -617,10 +632,19 @@
   			  });
   }
   
  +sub b_graph_link {
  +    my($r, $q, $name) = @_;
  +
  +    return unless has($r, "graph");
  +
  +    my $script = $r->location;
  +    return qq(\n<a href="$script/$name?noh_b_graph">OP Tree Graph</a>\n);
  +}
  +
   sub noh_b_graph {
       my $r = shift;
   
  -    require B::Graph;
  +    return unless has($r, "graph");
   
       untie *STDOUT;
   
  @@ -699,7 +723,7 @@
       my $uri = $r->uri;
       my $is_main = $package eq "main";
   
  -    my $do_dump = status_config($r, "StatusDumper");
  +    my $do_dump = has($r, "dumper");
   
       my @methods = sort keys %{$self->{'AUTOLOAD'}};
   
  @@ -725,15 +749,14 @@
   		push @line, qq(<a href="$uri?$_">$_</a>);
   	    }
   	    elsif ($type eq "functions") {
  -		if ($is_installed{B}) {
  +		if (has($r, "b")) {
   		    push @line, qq(<a href="$uri/$_/$dtype?cv_dump">$_</a>);
   		}
   		else {
   		    push @line, $_;
   		}
   	    }
  -	    elsif ($do_dump and $can_dump{$type} and 
  -		  $is_installed{"Data::Dumper"}) {
  +	    elsif ($do_dump and $can_dump{$type}) {
   		next if /_</;
   		push @line, qq(<a href="$uri/$_/$dtype?data_dump">$_</a>);
   	    }
  @@ -759,7 +782,7 @@
   =head1 SYNOPSIS
   
     <Location /perl-status>
  -      SetHandler  perl-script
  +      SetHandler modperl
         PerlResponseHandler Apache::Status
     </Location>
   
  @@ -771,7 +794,7 @@
   Configure like so:
   
     <Location /perl-status>
  -       SetHandler  perl-script
  +       SetHandler modperl
          PerlResponseHandler Apache::Status
     </Location>
   
  @@ -802,7 +825,7 @@
   
   =item StatusDumper
   
  -When browsing symbol tables, the values of arrays, hashes ans calars
  +When browsing symbol tables, the values of arrays, hashes and scalars
   can be viewed via B<Data::Dumper> if this configuration variable is set
   to On:
   
  
  
  

Mime
View raw message