path: root/tests/examplefiles/perl_perl5db

=head1 NAME 

perl5db.pl - the perl debugger

=head1 SYNOPSIS

    perl -d  your_Perl_script

=head1 DESCRIPTION

After this routine is over, we don't have user code executing in the debugger's
context, so we can use C<my> freely.

=cut

############################################## Begin lexical danger zone

# 'my' variables used here could leak into (that is, be visible in)
# the context that the code being evaluated is executing in. This means that
# the code could modify the debugger's variables.
#
# Fiddling with the debugger's context could be Bad. We insulate things as
# much as we can.

sub eval {

    # 'my' would make it visible from user code
    #    but so does local! --tchrist
    # Remember: this localizes @DB::res, not @main::res.
    local @res;
    {

        # Try to keep the user code from messing  with us. Save these so that
        # even if the eval'ed code changes them, we can put them back again.
        # Needed because the user could refer directly to the debugger's
        # package globals (and any 'my' variables in this containing scope)
        # inside the eval(), and we want to try to stay safe.
        local $otrace  = $trace;
        local $osingle = $single;
        local $od      = $^D;

        # Untaint the incoming eval() argument.
        { ($evalarg) = $evalarg =~ /(.*)/s; }

        # $usercontext built in DB::DB near the comment
        # "set up the context for DB::eval ..."
        # Evaluate and save any results.
        @res = eval "$usercontext $evalarg;\n";  # '\n' for nice recursive debug

        # Restore those old values.
        $trace  = $otrace;
        $single = $osingle;
        $^D     = $od;
    }

    # Save the current value of $@, and preserve it in the debugger's copy
    # of the saved precious globals.
    my $at = $@;

    # Since we're only saving $@, we only have to localize the array element
    # that it will be stored in.
    local $saved[0];    # Preserve the old value of $@
    eval { &DB::save };

    # Now see whether we need to report an error back to the user.
    if ($at) {
        local $\ = '';
        print $OUT $at;
    }

    # Display as required by the caller. $onetimeDump and $onetimedumpDepth
    # are package globals.
    elsif ($onetimeDump) {
        if ( $onetimeDump eq 'dump' ) {
            local $option{dumpDepth} = $onetimedumpDepth
              if defined $onetimedumpDepth;
            dumpit( $OUT, \@res );
        }
        elsif ( $onetimeDump eq 'methods' ) {
            methods( $res[0] );
        }
    } ## end elsif ($onetimeDump)
    @res;
} ## end sub eval

############################################## End lexical danger zone

# After this point it is safe to introduce lexicals.
# The code being debugged will be executing in its own context, and
# can't see the inside of the debugger.
#
# However, one should not overdo it: leave as much control from outside as
# possible. If you make something a lexical, it's not going to be addressable
# from outside the debugger even if you know its name.

# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
#
# Before venturing further into these twisty passages, it is
# wise to read the perldebguts man page or risk the ire of dragons.
#
# (It should be noted that perldebguts will tell you a lot about
# the underlying mechanics of how the debugger interfaces into the
# Perl interpreter, but not a lot about the debugger itself. The new
# comments in this code try to address this problem.)

# Note that no subroutine call is possible until &DB::sub is defined
# (for subroutines defined outside of the package DB). In fact the same is
# true if $deep is not defined.

# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)

# modified Perl debugger, to be run from Emacs in perldb-mode
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
# Johan Vromans -- upgrade to 4.0 pl 10
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)

# (We have made efforts to  clarify the comments in the change log
# in other places; some of them may seem somewhat obscure as they
# were originally written, and explaining them away from the code
# in question seems conterproductive.. -JM)

=head1 DEBUGGER INITIALIZATION

The debugger starts up in phases.

=head2 BASIC SETUP

First, it initializes the environment it wants to run in: turning off
warnings during its own compilation, defining variables which it will need
to avoid warnings later, setting itself up to not exit when the program
terminates, and defaulting to printing return values for the C<r> command.

=cut

# Needed for the statement after exec():
#
# This BEGIN block is simply used to switch off warnings during debugger
# compiliation. Probably it would be better practice to fix the warnings,
# but this is how it's done at the moment.

BEGIN {
    $ini_warn = $^W;
    $^W       = 0;
}    # Switch compilation warnings off until another BEGIN.

# test if assertions are supported and actived:
BEGIN {
    $ini_assertion = eval "sub asserting_test : assertion {1}; 1";

    # $ini_assertion = undef => assertions unsupported,
    #        "       = 1     => assertions supported
    # print "\$ini_assertion=$ini_assertion\n";
}

local ($^W) = 0;    # Switch run-time warnings off during init.

=head2 THREADS SUPPORT

If we are running under a threaded Perl, we require threads and threads::shared
if the environment variable C<PERL5DB_THREADED> is set, to enable proper
threaded debugger control.  C<-dt> can also be used to set this.

Each new thread will be announced and the debugger prompt will always inform
you of each new thread created.  It will also indicate the thread id in which
we are currently running within the prompt like this:

	[tid] DB<$i>

Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
command prompt.  The prompt will show: C<[0]> when running under threads, but
not actually in a thread.  C<[tid]> is consistent with C<gdb> usage.

While running under threads, when you set or delete a breakpoint (etc.), this
will apply to all threads, not just the currently running one.  When you are 
in a currently executing thread, you will stay there until it completes.  With
the current implementation it is not currently possible to hop from one thread
to another.

The C<e> and C<E> commands are currently fairly minimal - see C<h e> and C<h E>.

Note that threading support was built into the debugger as of Perl version
C<5.8.6> and debugger version C<1.2.8>.

=cut

BEGIN {
  # ensure we can share our non-threaded variables or no-op
  if ($ENV{PERL5DB_THREADED}) {
	require threads;
	require threads::shared;
	import threads::shared qw(share);
	$DBGR;
	share(\$DBGR);
	lock($DBGR);
	print "Threads support enabled\n";
  } else {
	*lock  = sub(*) {};
	*share = sub(*) {};
  }
}

# This would probably be better done with "use vars", but that wasn't around
# when this code was originally written. (Neither was "use strict".) And on
# the principle of not fiddling with something that was working, this was
# left alone.
warn(               # Do not ;-)
    # These variables control the execution of 'dumpvar.pl'.
    $dumpvar::hashDepth,
    $dumpvar::arrayDepth,
    $dumpvar::dumpDBFiles,
    $dumpvar::dumpPackages,
    $dumpvar::quoteHighBit,
    $dumpvar::printUndef,
    $dumpvar::globPrint,
    $dumpvar::usageOnly,

    # used to save @ARGV and extract any debugger-related flags.
    @ARGS,

    # used to control die() reporting in diesignal()
    $Carp::CarpLevel,

    # used to prevent multiple entries to diesignal()
    # (if for instance diesignal() itself dies)
    $panic,

    # used to prevent the debugger from running nonstop
    # after a restart
    $second_time,
  )
  if 0;

foreach my $k (keys (%INC)) {
	&share(\$main::{'_<'.$filename});
};

# Command-line + PERLLIB:
# Save the contents of @INC before they are modified elsewhere.
@ini_INC = @INC;

# This was an attempt to clear out the previous values of various
# trapped errors. Apparently it didn't help. XXX More info needed!
# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!

# We set these variables to safe values. We don't want to blindly turn
# off warnings, because other packages may still want them.
$trace = $signal = $single = 0;    # Uninitialized warning suppression
                                   # (local $^W cannot help - other packages!).

# Default to not exiting when program finishes; print the return
# value when the 'r' command is used to return from a subroutine.
$inhibit_exit = $option{PrintRet} = 1;

=head1 OPTION PROCESSING

The debugger's options are actually spread out over the debugger itself and 
C<dumpvar.pl>; some of these are variables to be set, while others are 
subs to be called with a value. To try to make this a little easier to
manage, the debugger uses a few data structures to define what options
are legal and how they are to be processed.

First, the C<@options> array defines the I<names> of all the options that
are to be accepted.

=cut

@options = qw(
  CommandSet
  hashDepth    arrayDepth    dumpDepth
  DumpDBFiles  DumpPackages  DumpReused
  compactDump  veryCompact   quote
  HighBit      undefPrint    globPrint
  PrintRet     UsageOnly     frame
  AutoTrace    TTY           noTTY
  ReadLine     NonStop       LineInfo
  maxTraceLen  recallCommand ShellBang
  pager        tkRunning     ornaments
  signalLevel  warnLevel     dieLevel
  inhibit_exit ImmediateStop bareStringify
  CreateTTY    RemotePort    windowSize
  DollarCaretP OnlyAssertions WarnAssertions
);

@RememberOnROptions = qw(DollarCaretP OnlyAssertions);

=pod

Second, C<optionVars> lists the variables that each option uses to save its
state.

=cut

%optionVars = (
    hashDepth     => \$dumpvar::hashDepth,
    arrayDepth    => \$dumpvar::arrayDepth,
    CommandSet    => \$CommandSet,
    DumpDBFiles   => \$dumpvar::dumpDBFiles,
    DumpPackages  => \$dumpvar::dumpPackages,
    DumpReused    => \$dumpvar::dumpReused,
    HighBit       => \$dumpvar::quoteHighBit,
    undefPrint    => \$dumpvar::printUndef,
    globPrint     => \$dumpvar::globPrint,
    UsageOnly     => \$dumpvar::usageOnly,
    CreateTTY     => \$CreateTTY,
    bareStringify => \$dumpvar::bareStringify,
    frame         => \$frame,
    AutoTrace     => \$trace,
    inhibit_exit  => \$inhibit_exit,
    maxTraceLen   => \$maxtrace,
    ImmediateStop => \$ImmediateStop,
    RemotePort    => \$remoteport,
    windowSize    => \$window,
    WarnAssertions => \$warnassertions,
);

=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,
    OnlyAssertions=> \&OnlyAssertions,
);

=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().
    $pids = "[$ENV{PERLDB_PIDS}]";
    $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 and OS/2.

=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. This may need some expansion: for instance, this doesn't handle
# OS X Terminal windows.

if (
    not defined &get_fork_TTY    # no routine exists,
    and defined $ENV{TERM}       # and we know what kind
                                 # of terminal this is,
    and $ENV{TERM} eq 'xterm'    # and it's an xterm,
#   and defined $ENV{WINDOWID}   # and we know what window this is, <- wrong metric
    and defined $ENV{DISPLAY}    # and what display it's on,
  )
{
    *get_fork_TTY = \&xterm_get_fork_TTY;    # use the xterm version
} ## end if (not defined &get_fork_TTY...
elsif ( $^O eq 'os2' ) {                     # If this is OS/2,
    *get_fork_TTY = \&os2_get_fork_TTY;      # use the OS/2 version
}

# 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()

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 identiical 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;