diff options
Diffstat (limited to 'tests/examplefiles/perl_perl5db')
| -rw-r--r-- | tests/examplefiles/perl_perl5db | 998 |
1 files changed, 0 insertions, 998 deletions
diff --git a/tests/examplefiles/perl_perl5db b/tests/examplefiles/perl_perl5db deleted file mode 100644 index ab9d5e30..00000000 --- a/tests/examplefiles/perl_perl5db +++ /dev/null @@ -1,998 +0,0 @@ - -=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; - - |