perl5db.pl

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

We chug through all these variables and plug the values saved in them
back into the appropriate spots in the debugger.

=cut

if ( exists $ENV{PERLDB_RESTART} ) {

    # We're restarting, so we don't need the flag that says to restart anymore.
    delete $ENV{PERLDB_RESTART};

    # $restart = 1;
    @hist          = get_list('PERLDB_HIST');
    %break_on_load = get_list("PERLDB_ON_LOAD");
    %postponed     = get_list("PERLDB_POSTPONE");

	share(@hist);
	share(@truehist);
	share(%break_on_load);
	share(%postponed);

    # restore breakpoints/actions
    my @had_breakpoints = get_list("PERLDB_VISITED");
    for ( 0 .. $#had_breakpoints ) {
        my %pf = get_list("PERLDB_FILE_$_");
        $postponed_file{ $had_breakpoints[$_] } = \%pf if %pf;
    }

    # restore options
    my %opt = get_list("PERLDB_OPT");
    my ( $opt, $val );
    while ( ( $opt, $val ) = each %opt ) {
        $val =~ s/[\\\']/\\$1/g;
        parse_options("$opt'$val'");
    }

    # restore original @INC
    @INC     = get_list("PERLDB_INC");
    @ini_INC = @INC;

    # return pre/postprompt actions and typeahead buffer
    $pretype   = [ get_list("PERLDB_PRETYPE") ];
    $pre       = [ get_list("PERLDB_PRE") ];
    $post      = [ get_list("PERLDB_POST") ];
    @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead );
} ## end if (exists $ENV{PERLDB_RESTART...

=head2 SETTING UP THE TERMINAL

Now, we'll decide how the debugger is going to interact with the user.
If there's no TTY, we set the debugger to run non-stop; there's not going
to be anyone there to enter commands.

=cut

if ($notty) {
    $runnonstop = 1;
	share($runnonstop);
}

=pod

If there is a TTY, we have to determine who it belongs to before we can
proceed. If this is a slave editor or graphical debugger (denoted by
the first command-line switch being '-emacs'), we shift this off and
set C<$rl> to 0 (XXX ostensibly to do straight reads).

=cut

else {

    # Is Perl being run from a slave editor or graphical debugger?
    # If so, don't use readline, and set $slave_editor = 1.
    $slave_editor =
      ( ( defined $main::ARGV[0] ) and ( $main::ARGV[0] eq '-emacs' ) );
    $rl = 0, shift(@main::ARGV) if $slave_editor;

    #require Term::ReadLine;

=pod

We then determine what the console should be on various systems:

=over 4

=item * Cygwin - We use C<stdin> instead of a separate device.

=cut

    if ( $^O eq 'cygwin' ) {

        # /dev/tty is binary. use stdin for textmode
        undef $console;
    }

=item * Unix - use C</dev/tty>.

=cut

    elsif ( -e "/dev/tty" ) {
        $console = "/dev/tty";
    }

=item * Windows or MSDOS - use C<con>.

=cut

    elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
        $console = "con";
    }

=item * MacOS - use C<Dev:Console:Perl Debug> if this is the MPW version; C<Dev:
Console> if not.

Note that Mac OS X returns C<darwin>, not C<MacOS>. Also note that the debugger doesn't do anything special for C<darwin>. Maybe it should.

=cut

    elsif ( $^O eq 'MacOS' ) {
        if ( $MacPerl::Version !~ /MPW/ ) {
            $console =
              "Dev:Console:Perl Debug";    # Separate window for application
        }
        else {
            $console = "Dev:Console";
        }
    } ## end elsif ($^O eq 'MacOS')

=item * VMS - use C<sys$command>.

=cut

    else {

        # everything else is ...
        $console = "sys\$command";
    }

=pod

=back

Several other systems don't use a specific console. We C<undef $console>
for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
with a slave editor, Epoc).

=cut

    if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) {

        # /dev/tty is binary. use stdin for textmode
        $console = undef;
    }

    if ( $^O eq 'NetWare' ) {

        # /dev/tty is binary. use stdin for textmode
        $console = undef;
    }

    # In OS/2, we need to use STDIN to get textmode too, even though
    # it pretty much looks like Unix otherwise.
    if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) )
    {    # In OS/2
        $console = undef;
    }

    # EPOC also falls into the 'got to use STDIN' camp.
    if ( $^O eq 'epoc' ) {
        $console = undef;
    }

=pod

If there is a TTY hanging around from a parent, we use that as the console.

=cut

    $console = $tty if defined $tty;

=head2 SOCKET HANDLING   

The debugger is capable of opening a socket and carrying out a debugging
session over the socket.

If C<RemotePort> was defined in the options, the debugger assumes that it
should try to start a debugging session on that port. It builds the socket
and then tries to connect the input and output filehandles to it.

=cut

    # Handle socket stuff.

    if ( defined $remoteport ) {

        # If RemotePort was defined in the options, connect input and output
        # to the socket.
        require IO::Socket;
        $OUT = new IO::Socket::INET(
            Timeout  => '10',
            PeerAddr => $remoteport,
            Proto    => 'tcp',
        );
        if ( !$OUT ) { die "Unable to connect to remote host: $remoteport\n"; }
        $IN = $OUT;
    } ## end if (defined $remoteport)

=pod

If no C<RemotePort> was defined, and we want to create a TTY on startup,
this is probably a situation where multiple debuggers are running (for example,
a backticked command that starts up another debugger). We create a new IN and
OUT filehandle, and do the necessary mojo to create a new TTY if we know how
and if we can.

=cut

    # Non-socket.
    else {

        # Two debuggers running (probably a system or a backtick that invokes
        # the debugger itself under the running one). create a new IN and OUT
        # filehandle, and do the necessary mojo to create a new tty if we
        # know how, and we can.
        create_IN_OUT(4) if $CreateTTY & 4;
        if ($console) {

            # If we have a console, check to see if there are separate ins and
            # outs to open. (They are assumed identical if not.)

            my ( $i, $o ) = split /,/, $console;
            $o = $i unless defined $o;

            # read/write on in, or just read, or read on STDIN.
            open( IN,      "+<$i" )
              || open( IN, "<$i" )
              || open( IN, "<&STDIN" );

            # read/write/create/clobber out, or write/create/clobber out,
            # or merge with STDERR, or merge with STDOUT.
                 open( OUT, "+>$o" )
              || open( OUT, ">$o" )
              || open( OUT, ">&STDERR" )
              || open( OUT, ">&STDOUT" );    # so we don't dongle stdout

        } ## end if ($console)
        elsif ( not defined $console ) {

            # No console. Open STDIN.
            open( IN, "<&STDIN" );

            # merge with STDERR, or with STDOUT.
            open( OUT,      ">&STDERR" )
              || open( OUT, ">&STDOUT" );    # so we don't dongle stdout
            $console = 'STDIN/OUT';
        } ## end elsif (not defined $console)

        # Keep copies of the filehandles so that when the pager runs, it
        # can close standard input without clobbering ours.
        $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
    } ## end elsif (from if(defined $remoteport))

    # Unbuffer DB::OUT. We need to see responses right away.
    my $previous = select($OUT);
    $| = 1;                                  # for DB::OUT
    select($previous);

    # Line info goes to debugger output unless pointed elsewhere.
    # Pointing elsewhere makes it possible for slave editors to
    # keep track of file and position. We have both a filehandle
    # and a I/O description to keep track of.
    $LINEINFO = $OUT     unless defined $LINEINFO;
    $lineinfo = $console unless defined $lineinfo;
	# share($LINEINFO); # <- unable to share globs
	share($lineinfo);   # 

=pod

To finish initialization, we show the debugger greeting,
and then call the C<afterinit()> subroutine if there is one.

=cut

    # Show the debugger greeting.
    $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
    unless ($runnonstop) {
        local $\ = '';
        local $, = '';
        if ( $term_pid eq '-1' ) {
            print $OUT "\nDaughter DB session started...\n";
        }
        else {
            print $OUT "\nLoading DB routines from $header\n";
            print $OUT (
                "Editor support ",
                $slave_editor ? "enabled" : "available", ".\n"
            );
            print $OUT
"\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
        } ## end else [ if ($term_pid eq '-1')
    } ## end unless ($runnonstop)
} ## end else [ if ($notty)

# XXX This looks like a bug to me.
# Why copy to @ARGS and then futz with @args?
@ARGS = @ARGV;
for (@args) {
    # Make sure backslashes before single quotes are stripped out, and
    # keep args unless they are numeric (XXX why?)
    # s/\'/\\\'/g;                      # removed while not justified understandably
    # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto
}

# If there was an afterinit() sub defined, call it. It will get
# executed in our scope, so it can fiddle with debugger globals.
if ( defined &afterinit ) {    # May be defined in $rcfile
    &afterinit();
}

# Inform us about "Stack dump during die enabled ..." in dieLevel().
$I_m_init = 1;

############################################################ Subroutines

=head1 SUBROUTINES

=head2 DB

This gigantic subroutine is the heart of the debugger. Called before every
statement, its job is to determine if a breakpoint has been reached, and
stop if so; read commands from the user, parse them, and execute
them, and hen send execution off to the next statement.

Note that the order in which the commands are processed is very important;
some commands earlier in the loop will actually alter the C<$cmd> variable
to create other commands to be executed later. This is all highly I<optimized>
but can be confusing. Check the comments for each C<$cmd ... && do {}> to
see what's happening in any given command.

=cut

sub DB {

    # lock the debugger and get the thread id for the prompt
	lock($DBGR);
	my $tid;
	if ($ENV{PERL5DB_THREADED}) {
		$tid = eval { "[".threads->tid."]" };
	}

    # Check for whether we should be running continuously or not.
    # _After_ the perl program is compiled, $single is set to 1:
    if ( $single and not $second_time++ ) {

        # Options say run non-stop. Run until we get an interrupt.
        if ($runnonstop) {    # Disable until signal
                # If there's any call stack in place, turn off single
                # stepping into subs throughout the stack.
            for ( $i = 0 ; $i <= $stack_depth ; ) {
                $stack[ $i++ ] &= ~1;
            }

            # And we are now no longer in single-step mode.
            $single = 0;

            # If we simply returned at this point, we wouldn't get
            # the trace info. Fall on through.
            # return;
        } ## end if ($runnonstop)

        elsif ($ImmediateStop) {

            # We are supposed to stop here; XXX probably a break.
            $ImmediateStop = 0;    # We've processe