status.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

# Copyright 2003-2005 The Apache Software Foundation
#
# Licensed 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,    ],
    packagesize => ["StatusPackageSize", "B::TerseSize",   0,    ],
    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{<p>Please install the } .
           qq{<a href="@{[CPAN_SEARCH]}=$module">$module</a> module.</p>};
}

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('<p>');
        $r->print(
            map { qq[<a href="$uri?$_">$status{$_}</a><br />\n] } sort { lc $a cmp lc $b } keys %status
        );
        $r->print('</p>');
    }
    $r->print("</body></html>");

    Apache2::Const::OK;
}

sub header {
    my $r = shift;
    my $start = scalar localtime $^T;
    my $srv = Apache2::ServerUtil::get_server_version();
    $r->content_type("text/html");
    my $v = $^V ? sprintf "v%vd", $^V : $];
    $r->print(<<"EOF");
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">

<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
  <head>
    <title>Apache2::Status $Apache2::Status::VERSION</title>
    <style type="text/css">
      body {
        color: #000;
        background-color: #fff;
      }
      p.hdr {
        background-color: #ddd;
        border: 2px outset;
        padding: 3px;
        width: 99%;
     }
   </style>
  </head>
  <body>
    <p class="hdr">
      Embedded Perl version <b>$v</b> for <b>$srv</b> process <b>$$</b>,<br />
      running since $start
    </p>
EOF

}

sub symdump {
    my ($r, $package) = @_;

    return install_hint("Devel::Symdump") unless has($r, "symdump");

    my $meth = lc($r->dir_config("StatusRdump")) eq "on"
        ? "rnew" : "new";
    my $sob = Devel::Symdump->$meth($package);
    return $sob->Apache2::Status::as_HTML($package, $r);
}

sub status_symdump {
    my ($r) = @_;
    [symdump($r, 'main')];
}

sub status_section_config {
    my ($r) = @_;
    require Apache2::PerlSections;
    ["<pre>", Apache2::PerlSections->dump, "</pre>"];
}

sub status_inc {
    my ($r) = @_;

    my $uri = $r->uri;
    my @retval = (
        '<table border="1">',
        "<tr>", 
        (map "<td><b>$_</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 Apache2/TieHandle.pm

        no strict 'refs';
        (my $module = $file) =~ s,/,::,g;
        $module =~ s,\.pm$,,;
        next if $module eq 'mod_perl';
        my $v = ${"$module\:\:VERSION"} || '0.00';
        push @retval, (
            "<tr>", 
            (map "<td>$_</td>", 
                qq(<a href="$uri?$module">$module</a>),
                $v, scalar localtime((stat $INC{$file})[9]), $INC{$file}),
            "</tr>\n"
        );
    }
    push @retval, "</table>\n";
    push @retval, "<p><b>\@INC</b> = <br />", join "<br />\n", @INC, "";
    \@retval;
}

sub status_script {
    my ($r) = @_;

    my @retval = (
        '<table border="1">',
        "<tr><td><b>PerlRequire</b></td><td><b>Location</b></td></tr>\n",
    );

    foreach my $file (sort keys %INC) {
        next if $file =~ m:\.(pm|al|ix)$:;
        push @retval, 
            qq(<tr><td>$file</td><td>$INC{$file}</td></tr>\n);
    }
    push @retval, "</table>";
    \@retval;
}

my $RegistryCache;

sub registry_cache {
    my ($self, $cache) = @_;

    # XXX: generalize

    $RegistryCache = $cache if $cache;
    $RegistryCache || $Apache2::Registry;
}

sub get_packages_per_handler {
    my ($root, $stash) = @_;

    my %handlers = ();
    my @packages = get_packages($stash);
    for (@packages) {
        /^\*${root}::([\w:]+)::(\w+)::$/ && push @{ $handlers{$1} }, $2;
    }

    return %handlers;
}

sub get_packages {
    my ($stash) = @_;

    no strict 'refs';
    my @packages = ();
    for (keys %$stash) {
        return $stash unless $stash->{$_} =~ /::$/;
        push @packages, get_packages($stash->{$_});
    }
    return @packages;
}

sub status_rgysubs {
    my ($r) = @_;

    local $_;
    my $uri = $r->uri;
    my $cache = __PACKAGE__->registry_cache;

    my @retval = "<h2>Compiled registry scripts grouped by their handler</h2>";

    push @retval,
      "<p><b>Click on package name to see its symbol table</b></p>\n";

    my $root = "ModPerl::ROOT";
    no strict 'refs';
    my %handlers = get_packages_per_handler($root, *{$root . "::"});
    for my $handler (sort keys %handlers) {
        push @retval, "<h4>$handler:</h4>\n<p>\n";
        for (sort @{ $handlers{$handler} }) {
            my $full = join '::', $root, $handler, $_;
            push @retval, qq(<a href="$uri?$full">$_</a>\n), "<br />";
        }
        push @retval, "</p>\n";
    }

    \@retval;
}

sub status_env {
    my ($r) = shift;

    my @retval = ("<p>\n");

    if ($r->handler eq 'modperl') {
        # the handler can be executed under the "modperl" handler
        push @retval,
            qq{<b>Under the "modperl" handler, the environment is</b>:};
        # XXX: I guess we could call $r->subprocess_env; and show how
        # would it look like under the 'perl-script' environment, but
        # under the 'modperl' handler %ENV doesn't get reset,
        # therefore on the first reload it'll see the bloated %ENV in
        # first place.
    } else {
        # the handler can be executed under the "perl-script" handler
        push @retval,
            qq{<b>Under the "perl-script" handler, the environment is</b>:};
    }
    push @retval, "\n</p>\n";
    push @retval, "<pre>",
        (map "$_ = " . escape_html($ENV{$_}||'') . "\n",
            sort keys %ENV), "</pre>";

    \@retval;
}

sub status_sig {
    ["<pre>",
     (map {
         my $val = $SIG{$_} || "";
         if ($val and ref $val eq "CODE") {
             # XXX: 2.0 doesn't have Apache2::Symbol
             if (my $cv = Apache2::Symbol->can('sv_name')) {
                 $val = "\\&".  $cv->($val);
             }
         }
         "$_ = $val\n" }
      sort keys %SIG),
     "</pre>"];
}

sub status_myconfig {
    ["<pre>", myconfig(), "</pre>"];
}

sub status_inh_tree {
    return has(shift, "symdump")
        ? ["<pre>", Devel::Symdump->inh_tree, "</pre>"]
        : install_hint("Devel::Symdump");
}

sub status_isa_tree {
    return has(shift, "symdump")
        ? ["<pre>", Devel::Symdump->isa_tree, "</pre>"]
        : install_hint("Devel::Symdump");
}

sub status_data_dump {
    my ($r) = @_;

    return install_hint('Data::Dumper') unless has($r, "dumper");

    my ($name, $type) = (split "/", $r->uri)[-2,-1];

    no strict 'refs';
    my @retval = "<p>\nData Dump of $name $type\n</p>\n<pre>\n";
    my $str = Data::Dumper->Dump([*$name{$type}], ['*'.$name]);
    $str = escape_html($str);
    $str =~ s/= \\/= /; #whack backwack
    push @retval, $str, "\n";
    push @retval, peek_link($r, $name, $type);
    push @retval, b_graph_link($r, $name);
    push @retval, "</pre>";
    \@retval;
}

sub cv_file {
    my $obj = shift;
    $obj->can('FILEGV') ? $obj->FILEGV->SV->PV : $obj->FILE;
}

sub status_cv_dump { 
    my ($r) = @_;
    return [] unless has($r, "b");

    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 = "<p>Subroutine info for <b>$name</b></p>\n<pre>\n";
    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";
    push @retval, "XSUB: ",      $obj->XSUB ? "yes" : "no", "\n";
    push @retval, peek_link($r, $name, $type);
    push @retval, b_graph_link($r, $name);
    push @retval, xref_link($r, $name);
    push @retval, b_lexinfo_link($r, $name);
    push @retval, b_terse_link($r, $name);
    push @retval, b_terse_size_link($r, $name);
    push @retval, b_deparse_link($r, $name);
    push @retval, b_fathom_link($r, $name);
    push @retval, "</pre>";
    \@retval;
}

sub b_lexinfo_link {
    my ($r, $name) = @_;

    return unless has($r, "lexinfo");

    my $script = $r->location;
    return qq(\n<a href="$script/$name?noh_b_lexinfo">Lexical Info</a>\n);
}

sub noh_b_lexinfo {
    my $r = shift;

    $r->content_type("text/plain");
    return unless has($r, "lexinfo");

    no strict 'refs';
    my ($name) = (split "/", $r->uri)[-1];
    $r->print("Lexical Info for $name\n\n");
    my $lexi = B::LexInfo->new;
    my $info = $lexi->cvlexinfo($name);
    $r->print(${ $lexi->dumper($info) });
}

my %b_terse_exp = ('slow' => 'syntax', 'exec' => 'execution', basic => 'syntax');

sub b_terse_link {
    my ($r, $name) = @_;

    return unless has($r, "terse");

    my $script = $r->location;
    my @retval;
    for (qw(exec basic)) {
        my $exp = "$b_terse_exp{$_} order";
        push @retval,
            qq(\n<a href="$script/$_/$name?noh_b_terse">Syntax Tree Dump ($exp)</a>\n);
    }
    join '', @retval;
}

sub noh_b_terse {
    my $r = shift;

    $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::Concise couldn't parse XS code before perl patch 24681 (perl 5.9.3)
    # B::Terse is deprecated and just a wrapper around B::Concise now adays
    eval { B::Concise::compile("-terse", "-$arg", $name)->() };
    if ($@) {
        $r->print("B::Concise has failed: $@");
    }
}

sub b_terse_size_link {
    my ($r, $name) = @_;

    return unless has($r, "tersesize");

    my $script = $r->location;
    my @retval;
    for (qw(exec slow)) {
        my $exp = "$b_terse_exp{$_} order";
        push @retval,
            qq(\n<a href="$script/$_/$name?noh_b_terse_size">Syntax Tree Size ($exp)</a>\n);
    }
    join '', @retval;
}

sub noh_b_terse_size {
    my $r = shift;

    $r->content_type("text/html");
    return unless has($r, "tersesize");

    $r->print('<pre>');
    my ($arg, $name) = (split "/", $r->uri)[-2,-1];
    my $uri = $r->location;
    my $link = qq{<a href="$uri/$name/CODE?cv_dump">$name</a>};
    $r->print("Syntax Tree Size ($b_terse_exp{$arg} order) for $link\n\n");
    B::TerseSize::compile($arg, $name)->();
}

sub b_package_size_link {
    my ($r, $name) = @_;

    return unless has($r, "packagesize");

    my $script = $r->location;
    qq(<a href="$script/$name?noh_b_package_size">Memory Usage</a>\n);
}

sub noh_b_package_size {
    my ($r) = @_;

    $r->content_type("text/html");
    return unless has($r, "packagesize");

    $r->print('<pre>');

    no strict 'refs';
    my ($package) = (split "/", $r->uri)[-1];
    my $script = $r->location;
    $r->print("Memory Usage for package $package\n\n");
    my ($subs, $opcount, $opsize) = B::TerseSize::package_size($package);
    my $Kb = sprintf "%.2f", $opsize / 1024;
    my $Mb = sprintf "%.2f", $Kb / 1000;
    $r->print("Totals: $opsize bytes, $Kb Kb, $Mb Mb | $opcount OPs\n\n");

    my $nlen = 0;
    my @keys = map {
        $nlen = length > $nlen ? length : $nlen;
        $_;
    } (sort { $subs->{$b}->{size} <=> $subs->{$a}->{size} } keys %$subs);

    my $clen = length $subs->{$keys[0]}->{count};
    my $slen = length $subs->{$keys[0]}->{size};

    for my $name (@keys) {
        my $stats = $subs->{$name};
        if ($name =~ /^my /) {
            $r->printf("%-${nlen}s %${slen}d bytes\n", $name, $stats->{size});
        }
        elsif ($name =~ /^\*(\w+)\{(\w+)\}/) {