perl5db.pl

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

=pod

Third, C<%optionAction> defines the subroutine to be called to process each
option.

=cut 

%optionAction = (
    compactDump   => \&dumpvar::compactDump,
    veryCompact   => \&dumpvar::veryCompact,
    quote         => \&dumpvar::quote,
    TTY           => \&TTY,
    noTTY         => \&noTTY,
    ReadLine      => \&ReadLine,
    NonStop       => \&NonStop,
    LineInfo      => \&LineInfo,
    recallCommand => \&recallCommand,
    ShellBang     => \&shellBang,
    pager         => \&pager,
    signalLevel   => \&signalLevel,
    warnLevel     => \&warnLevel,
    dieLevel      => \&dieLevel,
    tkRunning     => \&tkRunning,
    ornaments     => \&ornaments,
    RemotePort    => \&RemotePort,
    DollarCaretP  => \&DollarCaretP,
);

=pod

Last, the C<%optionRequire> notes modules that must be C<require>d if an
option is used.

=cut

# Note that this list is not complete: several options not listed here
# actually require that dumpvar.pl be loaded for them to work, but are
# not in the table. A subsequent patch will correct this problem; for
# the moment, we're just recommenting, and we are NOT going to change
# function.
%optionRequire = (
    compactDump => 'dumpvar.pl',
    veryCompact => 'dumpvar.pl',
    quote       => 'dumpvar.pl',
);

=pod

There are a number of initialization-related variables which can be set
by putting code to set them in a BEGIN block in the C<PERL5DB> environment
variable. These are:

=over 4

=item C<$rl> - readline control XXX needs more explanation

=item C<$warnLevel> - whether or not debugger takes over warning handling

=item C<$dieLevel> - whether or not debugger takes over die handling

=item C<$signalLevel> - whether or not debugger takes over signal handling

=item C<$pre> - preprompt actions (array reference)

=item C<$post> - postprompt actions (array reference)

=item C<$pretype>

=item C<$CreateTTY> - whether or not to create a new TTY for this debugger

=item C<$CommandSet> - which command set to use (defaults to new, documented set)

=back

=cut

# These guys may be defined in $ENV{PERL5DB} :
$rl          = 1     unless defined $rl;
$warnLevel   = 1     unless defined $warnLevel;
$dieLevel    = 1     unless defined $dieLevel;
$signalLevel = 1     unless defined $signalLevel;
$pre         = []    unless defined $pre;
$post        = []    unless defined $post;
$pretype     = []    unless defined $pretype;
$CreateTTY   = 3     unless defined $CreateTTY;
$CommandSet  = '580' unless defined $CommandSet;

share($rl);
share($warnLevel);
share($dieLevel);
share($signalLevel);
share($pre);
share($post);
share($pretype);
share($rl);
share($CreateTTY);
share($CommandSet);

=pod

The default C<die>, C<warn>, and C<signal> handlers are set up.

=cut

warnLevel($warnLevel);
dieLevel($dieLevel);
signalLevel($signalLevel);

=pod

The pager to be used is needed next. We try to get it from the
environment first.  If it's not defined there, we try to find it in
the Perl C<Config.pm>.  If it's not there, we default to C<more>. We
then call the C<pager()> function to save the pager name.

=cut

# This routine makes sure $pager is set up so that '|' can use it.
pager(

    # If PAGER is defined in the environment, use it.
    defined $ENV{PAGER}
    ? $ENV{PAGER}

      # If not, see if Config.pm defines it.
    : eval { require Config }
      && defined $Config::Config{pager}
    ? $Config::Config{pager}

      # If not, fall back to 'more'.
    : 'more'
  )
  unless defined $pager;

=pod

We set up the command to be used to access the man pages, the command
recall character (C<!> unless otherwise defined) and the shell escape
character (C<!> unless otherwise defined). Yes, these do conflict, and
neither works in the debugger at the moment.

=cut

setman();

# Set up defaults for command recall and shell escape (note:
# these currently don't work in linemode debugging).
&recallCommand("!") unless defined $prc;
&shellBang("!")     unless defined $psh;

=pod

We then set up the gigantic string containing the debugger help.
We also set the limit on the number of arguments we'll display during a
trace.

=cut

sethelp();

# If we didn't get a default for the length of eval/stack trace args,
# set it here.
$maxtrace = 400 unless defined $maxtrace;

=head2 SETTING UP THE DEBUGGER GREETING

The debugger I<greeting> helps to inform the user how many debuggers are
running, and whether the current debugger is the primary or a child.

If we are the primary, we just hang onto our pid so we'll have it when
or if we start a child debugger. If we are a child, we'll set things up
so we'll have a unique greeting and so the parent will give us our own
TTY later.

We save the current contents of the C<PERLDB_PIDS> environment variable
because we mess around with it. We'll also need to hang onto it because
we'll need it if we restart.

Child debuggers make a label out of the current PID structure recorded in
PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
yet so the parent will give them one later via C<resetterm()>.

=cut

# Save the current contents of the environment; we're about to
# much with it. We'll need this if we have to restart.
$ini_pids = $ENV{PERLDB_PIDS};

if ( defined $ENV{PERLDB_PIDS} ) {

    # We're a child. Make us a label out of the current PID structure
    # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
    # a term yet so the parent will give us one later via resetterm().

    my $env_pids = $ENV{PERLDB_PIDS};
    $pids = "[$env_pids]";

    # Unless we are on OpenVMS, all programs under the DCL shell run under
    # the same PID.

    if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) {
        $term_pid         = $$;
    }
    else {
        $ENV{PERLDB_PIDS} .= "->$$";
        $term_pid = -1;
    }

} ## end if (defined $ENV{PERLDB_PIDS...
else {

    # We're the parent PID. Initialize PERLDB_PID in case we end up with a
    # child debugger, and mark us as the parent, so we'll know to set up
    # more TTY's is we have to.
    $ENV{PERLDB_PIDS} = "$$";
    $pids             = "[pid=$$]";
    $term_pid         = $$;
}

$pidprompt = '';

# Sets up $emacs as a synonym for $slave_editor.
*emacs = $slave_editor if $slave_editor;    # May be used in afterinit()...

=head2 READING THE RC FILE

The debugger will read a file of initialization options if supplied. If    
running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.

=cut      

# As noted, this test really doesn't check accurately that the debugger
# is running at a terminal or not.

if ( -e "/dev/tty" ) {                      # this is the wrong metric!
    $rcfile = ".perldb";
}
else {
    $rcfile = "perldb.ini";
}

=pod

The debugger does a safety test of the file to be read. It must be owned
either by the current user or root, and must only be writable by the owner.

=cut

# This wraps a safety test around "do" to read and evaluate the init file.
#
# This isn't really safe, because there's a race
# between checking and opening.  The solution is to
# open and fstat the handle, but then you have to read and
# eval the contents.  But then the silly thing gets
# your lexical scope, which is unfortunate at best.
sub safe_do {
    my $file = shift;

    # Just exactly what part of the word "CORE::" don't you understand?
    local $SIG{__WARN__};
    local $SIG{__DIE__};

    unless ( is_safe_file($file) ) {
        CORE::warn <<EO_GRIPE;
perldb: Must not source insecure rcfile $file.
        You or the superuser must be the owner, and it must not 
        be writable by anyone but its owner.
EO_GRIPE
        return;
    } ## end unless (is_safe_file($file...

    do $file;
    CORE::warn("perldb: couldn't parse $file: $@") if $@;
} ## end sub safe_do

# This is the safety test itself.
#
# Verifies that owner is either real user or superuser and that no
# one but owner may write to it.  This function is of limited use
# when called on a path instead of upon a handle, because there are
# no guarantees that filename (by dirent) whose file (by ino) is
# eventually accessed is the same as the one tested.
# Assumes that the file's existence is not in doubt.
sub is_safe_file {
    my $path = shift;
    stat($path) || return;    # mysteriously vaporized
    my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_);

    return 0 if $uid != 0 && $uid != $<;
    return 0 if $mode & 022;
    return 1;
} ## end sub is_safe_file

# If the rcfile (whichever one we decided was the right one to read)
# exists, we safely do it.
if ( -f $rcfile ) {
    safe_do("./$rcfile");
}

# If there isn't one here, try the user's home directory.
elsif ( defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile" ) {
    safe_do("$ENV{HOME}/$rcfile");
}

# Else try the login directory.
elsif ( defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile" ) {
    safe_do("$ENV{LOGDIR}/$rcfile");
}

# If the PERLDB_OPTS variable has options in it, parse those out next.
if ( defined $ENV{PERLDB_OPTS} ) {
    parse_options( $ENV{PERLDB_OPTS} );
}

=pod

The last thing we do during initialization is determine which subroutine is
to be used to obtain a new terminal when a new debugger is started. Right now,
the debugger only handles X Windows, OS/2, and Mac OS X (darwin).

=cut

# Set up the get_fork_TTY subroutine to be aliased to the proper routine.
# Works if you're running an xterm or xterm-like window, or you're on
# OS/2, or on Mac OS X. This may need some expansion.

if (not defined &get_fork_TTY)       # only if no routine exists
{
    if (defined $ENV{TERM}                       # If we know what kind
                                                 # of terminal this is,
        and $ENV{TERM} eq 'xterm'                # and it's an xterm,
        and defined $ENV{DISPLAY}                # and what display it's on,
      )
    {
        *get_fork_TTY = \&xterm_get_fork_TTY;    # use the xterm version
    }
    elsif ( $^O eq 'os2' ) {                     # If this is OS/2,
        *get_fork_TTY = \&os2_get_fork_TTY;      # use the OS/2 version
    }
    elsif ( $^O eq 'darwin'                      # If this is Mac OS X
            and defined $ENV{TERM_PROGRAM}       # and we're running inside
            and $ENV{TERM_PROGRAM}
                eq 'Apple_Terminal'              # Terminal.app
            )
    {
        *get_fork_TTY = \&macosx_get_fork_TTY;   # use the Mac OS X version
    }
} ## end if (not defined &get_fork_TTY...

# untaint $^O, which may have been tainted by the last statement.
# see bug [perl #24674]
$^O =~ m/^(.*)\z/;
$^O = $1;

# Here begin the unreadable code.  It needs fixing.

=head2 RESTART PROCESSING

This section handles the restart command. When the C<R> command is invoked, it
tries to capture all of the state it can into environment variables, and
then sets C<PERLDB_RESTART>. When we start executing again, we check to see
if C<PERLDB_RESTART> is there; if so, we reload all the information that
the R command stuffed into the environment variables.

  PERLDB_RESTART   - flag only, contains no restart data itself.       
  PERLDB_HIST      - command history, if it's available
  PERLDB_ON_LOAD   - breakpoints set by the rc file
  PERLDB_POSTPONE  - subs that have been loaded/not executed, and have actions
  PERLDB_VISITED   - files that had breakpoints
  PERLDB_FILE_...  - breakpoints for a file
  PERLDB_OPT       - active options
  PERLDB_INC       - the original @INC
  PERLDB_PRETYPE   - preprompt debugger actions
  PERLDB_PRE       - preprompt Perl code
  PERLDB_POST      - post-prompt Perl code
  PERLDB_TYPEAHEAD - typeahead captured by readline()