status.pm

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

            my $link = qq(<a href="$script/$package\::$1/$2?data_dump">);
            $r->printf("$link%-${nlen}s</a> %${slen}d bytes\n", 
                       $name, $stats->{size});
        }
        else {
            my $link = 
                qq(<a href="$script/slow/$package\::$name?noh_b_terse_size">);
            $r->printf("$link%-${nlen}s</a> %${slen}d bytes | %${clen}d OPs\n",
                       $name, $stats->{size}, $stats->{count});
        }
    }
}

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

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

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

sub noh_b_deparse {
    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");
    my $deparse = B::Deparse->new(split /\s+/, 
                                  $r->dir_config('StatusDeparseOptions')||"");
    my $body = $deparse->coderef2text(\&{$name});
    $r->print("sub $name $body");
}

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

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

    my $script = $r->location;
    return qq(\n<a href="$script/$name?noh_b_fathom">Fathom Score</a>\n);
}

sub noh_b_fathom {
    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");
    my $fathom = B::Fathom->new(split /\s+/, 
                                $r->dir_config('StatusFathomOptions')||"");
    $r->print($fathom->fathom(\&{$name}));
}

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

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

    my $script = $r->location;
    return qq(\n<a href="$script/$name/$type?noh_peek">Peek Dump</a>\n);
}

sub noh_peek {
    my $r = shift;

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

    no strict 'refs';
    my ($name, $type) = (split "/", $r->uri)[-2,-1];
    $type =~ s/^FUNCTION$/CODE/;
    $r->print("Peek Dump of $name $type\n\n");
    Apache::Peek::Dump(*{$name}{$type});
}

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

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

    my $script = $r->location;
    return qq(\n<a href="$script/$name?noh_xref">Cross Reference Report</a>\n);
}

sub noh_xref {
    my $r = shift;

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

    (my $thing = $r->path_info) =~ s:^/::;
    $r->print("Xref of $thing\n");
    B::Xref::compile($thing)->();
}

$Apache2::Status::BGraphCache ||= 0;
if ($Apache2::Status::BGraphCache) {
    Apache2->server->push_handlers(PerlChildExitHandler => sub {
        unlink keys %Apache2::Status::BGraphCache;
    });
}

sub b_graph_link {
    my ($r, $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;

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

    untie *STDOUT;

    my $dir = File::Spec->catfile(Apache2::ServerUtil::server_root(),
        ($r->dir_config("GraphDir") || "logs/b_graphs"));

    mkdir $dir, 0755 unless -d $dir;

    (my $thing = $r->path_info) =~ s:^/::;
    $thing =~ s{::}{-}g; # :: is not allowed in the filename on some OS
    my $type = "dot";
    my $file = "$dir/$thing.$$.gif";

    unless (-e $file) {
        my $rv = tie *STDOUT, "B::Graph", $r, $file;
        unless ($rv) {
            $r->content_type("text/plain");
            $r->print("dot not found\n");
        }
        else {
            B::Graph::compile("-$type", $thing)->();
            (tied *STDOUT)->{graph}->close;
        }
    }

    if (-s $file) {
        $r->content_type("image/gif");
        $r->sendfile($file);
    }
    else {
        $r->content_type("text/plain");
        $r->print("Graph of $thing failed!\n");
    }
    if ($Apache2::Status::BGraphCache) {
        $Apache2::Status::BGraphCache{$file}++;
    }
    else {
        unlink $file;
    }

    0;
}

sub B::Graph::TIEHANDLE {
    my ($class, $r, $file) = @_;

    if ($file =~ /^([^<>|;]+)$/) {
        $file = $1;
    }
    else {
        die "TAINTED data in THING=> ($file)";
    }

    $ENV{PATH} = join ":", qw{/usr/bin /usr/local/bin};
    my $dot = $r->dir_config("Dot") || "dot";

    require IO::File;
    my $pipe = IO::File->new("|$dot -Tgif -o $file");
    $pipe && $pipe->autoflush(1);

    if ($pipe) {
        return bless {
            graph => $pipe,
            r     => $r,
        }, $class;
    }
    else {
        return;
    }
}

sub B::Graph::PRINT {
    my $self = shift;

    $self->{graph}->print(@_);
}

my %can_dump = map {$_,1} qw(scalars arrays hashes);

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

    my @m = qw(<table>);
    my $uri = $r->uri;
    my $is_main = $package eq "main";

    my $do_dump = has($r, "dumper");

    my @methods = sort keys %{$self->{'AUTOLOAD'}};

    if ($is_main) { 
        @methods = grep { $_ ne "packages" } @methods;
        unshift @methods, "packages";
    }

    for my $type (@methods) {
        (my $dtype = uc $type) =~ s/E?S$//;
        push @m, "<tr><td valign=\"top\"><b>$type</b></td>";
        my @line = ();

        for (sort $self->_partdump(uc $type)) {
            s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64)/eg; 

            if ($type eq "scalars") {
                no strict 'refs';
                next unless defined eval { $$_ };
            }

            if ($type eq "packages") {
                push @line, qq(<a href="$uri?$_">$_</a>);
            }
            elsif ($type eq "functions") {
                if (has($r, "b")) {
                    push @line, qq(<a href="$uri/$_/$dtype?cv_dump">$_</a>);
                }
                else {
                    push @line, $_;
                }
            }
            elsif ($do_dump and $can_dump{$type}) {
                next if /_</;
                push @line, qq(<a href="$uri/$_/$dtype?data_dump">$_</a>);
            }
            else {
                push @line, $_;
            }
        }
        push @m, "<td>" . join(", ", @line) . "</td></tr>\n";
    }
    push @m, "</table>";

    return join "\n", @m, "<hr>", b_package_size_link($r, $package);
}

sub escape_html {
    my $str = shift;

    $str =~ s/&/&amp;/g;
    $str =~ s/</&lt;/g;
    $str =~ s/>/&gt;/g;

    return $str;
}

sub myconfig {
    require Config;
    # Config::myconfig(); fails under threads with (5.8.0 < perl < 5.8.3)
    # "Modification of a read-only value attempted"
    # provide a workaround
    if ($Config::Config{useithreads} and $] > 5.008 and $] < 5.008003) {
        return $Config::summary_expanded if $Config::summary_expanded;
        ($Config::summary_expanded = $Config::summary) =~
            s{\$(\w+)}
             { my $c = $Config::Config{$1}; defined($c) ? $c : 'undef' }ge;
        return $Config::summary_expanded;
    }
    else {
        return Config::myconfig();
  }
}

# mp2 modules have to deal with situations where a binary incompatible
# mp1 version of the same module is installed in the same
# tree. therefore when checking for a certain version, one wants to
# check the version of the module 'require()' will find without
# loading that module. this function partially adopted from
# ExtUtils::MM_Unix does just that. it returns the version number of
# the first module that it finds, forcing numerical context, making
# the return value suitable for immediate numerical comparison
# operation. (i.e. 2.03-dev will be returned as 2.03,  0 will be
# returned when the parsing has failed or a module wasn't found).
sub parse_version {
    my $name = shift;
    die "no module name passed" unless $name;
    my $file = File::Spec->catfile(split /::/, $name) . '.pm';
    for my $dir (@INC) {
        next if ref $dir; # skip code refs

        my $pmfile = File::Spec->catfile($dir, $file);
        next unless -r $pmfile;

        open my $fh, $pmfile or die "can't open $pmfile: $!";

        my $inpod = 0;
        my $version;
        while (<$fh>) {
            $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
            next if $inpod || /^\s*#/;

            chomp;
            next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
            { local($1, $2); ($_ = $_) = /(.*)/; } # untaint
            my $eval = qq{
                package Apache2::Status::_version;
                no strict;

                local $1$2;
                \$$2=undef; do {
                    $_
                }; \$$2
            };
            no warnings;
            $version = eval $eval;
            warn "Could not eval '$eval' in $pmfile: $@" if $@;
            last;
        }

        close $fh;

        # avoid situations like "2.03-dev" and return a numerical
        # version
        if (defined $version) {
            no warnings;
            $version += 0; # force number
            return $version;
        }
    }

    return 0; # didn't find the file or the version number
}

1;

__END__


=head1 NAME

Apache2::Status - Embedded interpreter status information




=head1 Synopsis

  <Location /perl-status>
      SetHandler modperl
      PerlOptions +GlobalRequest
      PerlResponseHandler Apache2::Status
  </Location>

  or

  <Location /perl-status>
      SetHandler perl-script
      PerlResponseHandler Apache2::Status
  </Location>




=head1 Description

The C<Apache2::Status> module provides some information
about the status of the Perl interpreter embedded in the server.

Configure like so:

  <Location /perl-status>
      SetHandler modperl
      PerlOptions +GlobalRequest
      PerlResponseHandler Apache2::Status
  </Location>

Notice that under the
C<L<"modperl"|docs::2.0::user::config::config/C_modperl_>> core
handler the I<Environment> menu option will show only the environment
under that handler. To see the environment seen by handlers running
under the
C<L<"perl-script"|docs::2.0::user::config::config/C_perl_script_>>
core handler, configure C<Apache2::Status> as:

  <Location /perl-status>
      SetHandler perl-script
      PerlResponseHandler Apache2::Status
  </Location>

Other modules can "plugin" a menu item like so:

  require Apache2::Module;
  Apache2::Status->menu_item(
      'DBI' => "DBI connections", #item for Apache::DBI module
      sub {
          my ($r, $q) = @_; #request and CGI objects
          my (@strings);
          push @strings,  "blobs of html";
          return \@strings;     #return an array ref
      }
  ) if Apache2::Module::loaded('Apache2::Status');

B<WARNING>: C<Apache2::Status> must be loaded before these modules via
the C<PerlModule> or C<PerlRequire> directives (or from
F<startup.pl>).

A very common setup might be:
  Perl Module B::TerseSize

  <Location /perl-status>
      SetHandler perl-script
      PerlResponseHandler Apache2::Status
      PerlSetVar StatusOptionsAll On
      PerlSetVar StatusDeparseOptions "-p -sC"
  </Location>

due to the implementation of Apache2::Status::noh_fileline in B::TerseSize,
you must load B::TerseSize first.

=head1 Options

=head2 C<StatusOptionsAll>

This single directive will enable all of the options described below.

  PerlSetVar StatusOptionsAll On

=head2 C<StatusDumper>

When browsing symbol tables, the values of arrays, hashes and scalars
can be viewed via C<Data::Dumper> if this configuration variable is
set to C<On>:

  PerlSetVar StatusDumper On

=head2 C<StatusPeek>

With this option C<On> and the C<Apache::Peek> module installed,
functions and variables can be viewed ala C<Devel::Peek> style:

  PerlSetVar StatusPeek On

=head2 C<StatusLexInfo>

With this option C<On> and the C<B::LexInfo> module installed,
subroutine lexical variable information can be viewed.

  PerlSetVar StatusLexInfo On

=head2 C<StatusDeparse>

With this option C<On> subroutines can be "deparsed".

  PerlSetVar StatusDeparse On

Options can be passed to C<B::Deparse::new> like so:

  PerlSetVar StatusDeparseOptions "-p -sC"

See the C<B::Deparse> manpage for details.

=head2 C<StatusTerse>

With this option C<On>, text-based op tree graphs of subroutines can
be displayed, thanks to C<B::Terse>.

  PerlSetVar StatusTerse On

=head2 C<StatusTerseSize>

With this option C<On> and the C<B::TerseSize> module installed,
text-based op tree graphs of subroutines and their size can be
displayed.  See the C<B::TerseSize> docs for more info.

  PerlSetVar StatusTerseSize On

=head2 C<StatusTerseSizeMainSummary>

With this option C<On> and the C<B::TerseSize> module installed, a
I<"Memory Usage"> will be added to the C<Apache2::Status> main menu.
This option is disabled by default, as it can be rather cpu intensive
to summarize memory usage for the entire server.  It is strongly
suggested that this option only be used with a development server
running in C<-X> mode, as the results will be cached.

  PerlSetVar StatusTerseSizeMainSummary On

=head2 C<StatusGraph>

When C<StatusDumper> is enabled, another link I<"OP Tree Graph"> will
be present with the dump if this configuration variable is set to
C<On>:

  PerlSetVar StatusGraph

This requires the B module (part of the Perl compiler kit) and
C<B::Graph> (version 0.03 or higher) module to be installed along with
the C<dot> program.

Dot is part of the graph visualization toolkit from AT&T:
http://www.graphviz.org/.

B<WARNING>: Some graphs may produce very large images, some graphs may
produce no image if C<B::Graph>'s output is incorrect.

=head2 C<Dot>

Location of the dot program for C<StatusGraph>,
if other than I</usr/bin> or I</usr/local/bin>

=head2 C<GraphDir>

Directory where C<StatusGraph> should write it's temporary image
files.  Default is C<$ServerRoot/logs/b_graphs>.






=head1 Prerequisites

The C<Devel::Symdump> module, version C<2.00> or higher.

Other optional functionality requirements: C<B::Deparse> - 0.59,
C<B::Fathom> - 0.05, C<C<B::Graph>> - 0.03.



=head1 Copyright

mod_perl 2.0 and its core modules are copyrighted under
The Apache Software License, Version 2.0.




=head1 See Also

perl(1), Apache(3), Devel::Symdump(3), Data::Dumper(3), B(3),
C<B::Graph>(3), L<mod_perl 2.0 documentation|docs::2.0::index>.




=head1 Authors

Doug MacEachern with contributions from Stas Bekman

=cut