# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 0.98;
-$header = "perl5db.pl patch level $VERSION";
+$VERSION = 1.01;
+$header = "perl5db.pl version $VERSION";
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
# {require 'perl5db.pl'} before the first line.
#
# After each `require'd file is compiled, but before it is executed, a
-# call to DB::postponed(*{"_<$filename"}) is emulated. Here the
+# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
# $filename is the expanded name of the `require'd file (as found as
# value of %INC).
#
# if caller() is called from the package DB, it provides some
# additional data.
#
-# The array @{"_<$filename"} is the line-by-line contents of
+# The array @{$main::{'_<'.$filename} is the line-by-line contents of
# $filename.
#
-# The hash %{"_<$filename"} contains breakpoints and action (it is
+# The hash %{'_<'.$filename} contains breakpoints and action (it is
# keyed by line number), and individual entries are settable (as
# opposed to the whole hash). Only true/false is important to the
# interpreter, though the values used by perl5db.pl have the form
# "$break_condition\0$action". Values are magical in numeric context.
#
-# The scalar ${"_<$filename"} contains "_<$filename".
+# The scalar ${'_<'.$filename} contains "_<$filename".
#
# 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
# `b compile subname' implemented.
# Will not use $` any more.
# `-' behaves sane now.
+# Changes: 0.99: Completion for `f', `m'.
+# `m' will remove duplicate names instead of duplicate functions.
+# `b load' strips trailing whitespace.
+# completion ignores leading `|'; takes into account current package
+# when completing a subroutine name (same for `l').
####################################################################
$dumpvar::quoteHighBit,
$dumpvar::printUndef,
$dumpvar::globPrint,
- $readline::Tk_toloop,
$dumpvar::usageOnly,
@ARGS,
$Carp::CarpLevel,
compactDump veryCompact quote HighBit undefPrint
globPrint PrintRet UsageOnly frame AutoTrace
TTY noTTY ReadLine NonStop LineInfo maxTraceLen
- recallCommand ShellBang pager tkRunning
+ recallCommand ShellBang pager tkRunning ornaments
signalLevel warnLevel dieLevel inhibit_exit);
%optionVars = (
HighBit => \$dumpvar::quoteHighBit,
undefPrint => \$dumpvar::printUndef,
globPrint => \$dumpvar::globPrint,
- tkRunning => \$readline::Tk_toloop,
UsageOnly => \$dumpvar::usageOnly,
frame => \$frame,
AutoTrace => \$trace,
signalLevel => \&signalLevel,
warnLevel => \&warnLevel,
dieLevel => \&dieLevel,
+ tkRunning => \&tkRunning,
+ ornaments => \&ornaments,
);
%optionRequire = (
%postponed = get_list("PERLDB_POSTPONE");
my @had_breakpoints= get_list("PERLDB_VISITED");
for (0 .. $#had_breakpoints) {
- %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_");
+ my %pf = get_list("PERLDB_FILE_$_");
+ $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
}
my %opt = get_list("PERLDB_OPT");
my ($opt,$val);
}
@INC = get_list("PERLDB_INC");
@ini_INC = @INC;
+ $pretype = [get_list("PERLDB_PRETYPE")];
+ $pre = [get_list("PERLDB_PRE")];
+ $post = [get_list("PERLDB_POST")];
+ @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
}
if ($notty) {
if (-e "/dev/tty") {
$console = "/dev/tty";
- } elsif (-e "con") {
+ } elsif (-e "con" or $^O eq 'MSWin32') {
$console = "con";
} else {
$console = "sys\$command";
}
+ if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
+ $console = undef;
+ }
+
# Around a bug:
if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
$console = undef;
&afterinit();
}
+$I_m_init = 1;
+
############################################################ Subroutines
sub DB {
$filename_ini = $filename;
$usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
"package $package;"; # this won't let them modify, alas
- local(*dbline) = "::_<$filename";
+ local(*dbline) = $main::{'_<' . $filename};
$max = $#dbline;
if (($stop,$action) = split(/\0/,$dbline{$line})) {
if ($stop eq '1') {
$evalarg = $action, &eval if $action;
if ($single || $was_signal) {
local $level = $level + 1;
- map {$evalarg = $_, &eval} @$pre;
+ foreach $evalarg (@$pre) {
+ &eval;
+ }
print $OUT $#stack . " levels deep in subroutine calls!\n"
if $single & 4;
$start = $line;
@typeahead = @$pretype, @typeahead;
CMD:
while (($term || &setterm),
+ ($term_pid == $$ or &resetterm),
defined ($cmd=&readline(" DB" . ('<' x $level) .
($#hist+1) . ('>' x $level) .
" "))) {
$cmd .= &readline(" cont: ");
redo CMD;
};
- $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
$cmd =~ /^$/ && ($cmd = $laststep);
push(@hist,$cmd) if length($cmd) > 1;
PIPE: {
($i) = split(/\s+/,$cmd);
eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
+ $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
$cmd =~ /^h$/ && do {
print $OUT $help;
next CMD; };
$onetimeDump = 'methods'; };
$cmd =~ /^f\b\s*(.*)/ && do {
$file = $1;
+ $file =~ s/\s+$//;
if (!$file) {
print $OUT "The old f command is now the r command.\n";
print $OUT "The new f command switches filenames.\n";
}
if (!defined $main::{'_<' . $file}) {
if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
- $file = substr($try,2);
- print "\n$file:\n";
+ $try = substr($try,2);
+ print $OUT "Choosing $try matching `$file':\n";
+ $file = $try;
}}
}
if (!defined $main::{'_<' . $file}) {
print $OUT "No file matching `$file' is loaded.\n";
next CMD;
} elsif ($file ne $filename) {
- *dbline = "::_<$file";
+ *dbline = $main::{'_<' . $file};
$max = $#dbline;
$filename = $file;
$start = 1;
$cmd = "l";
- } };
+ } else {
+ print $OUT "Already in $file.\n";
+ next CMD;
+ }
+ };
$cmd =~ s/^l\s+-\s*$/-/;
$cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
$subname = $1;
$subname =~ s/\'/::/;
- $subname = "main::".$subname unless $subname =~ /::/;
+ $subname = $package."::".$subname
+ unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
@pieces = split(/:/,find_sub($subname));
$subrange = pop @pieces;
$file = join(':', @pieces);
if ($file ne $filename) {
- *dbline = "::_<$file";
+ *dbline = $main::{'_<' . $file};
$max = $#dbline;
$filename = $file;
}
$incr = -1; # for backward motion.
$start = $line;
$filename = $filename_ini;
- *dbline = "::_<$filename";
+ *dbline = $main::{'_<' . $filename};
$max = $#dbline;
print $LINEINFO $position;
next CMD };
print $OUT "Deleting all breakpoints...\n";
my $file;
for $file (keys %had_breakpoints) {
- local *dbline = "::_<$file";
+ local *dbline = $main::{'_<' . $file};
my $max = $#dbline;
my $was;
$cmd =~ /^L$/ && do {
my $file;
for $file (keys %had_breakpoints) {
- local *dbline = "::_<$file";
+ local *dbline = $main::{'_<' . $file};
my $max = $#dbline;
my $was;
print $OUT "Postponed breakpoints in files:\n";
my ($file, $line);
for $file (keys %postponed_file) {
- my %db = %{$postponed_file{$file}};
- next unless keys %db;
+ my $db = $postponed_file{$file};
print $OUT " $file:\n";
- for $line (sort {$a <=> $b} keys %db) {
- print $OUT " $i:\n";
- my ($stop,$action) = split(/\0/, $db{$line});
+ for $line (sort {$a <=> $b} keys %$db) {
+ print $OUT " $line:\n";
+ my ($stop,$action) = split(/\0/, $$db{$line});
print $OUT " break if (", $stop, ")\n"
if $stop;
print $OUT " action: ", $action, "\n"
}
next CMD; };
$cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
- my $file = $1;
+ my $file = $1; $file =~ s/\s+$//;
{
$break_on_load{$file} = 1;
$break_on_load{$::INC{$file}} = 1 if $::INC{$file};
$i += 0;
if ($i) {
$filename = $file;
- *dbline = "::_<$filename";
+ *dbline = $main::{'_<' . $filename};
$had_breakpoints{$filename} = 1;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
$cmd =~ /^A$/ && do {
my $file;
for $file (keys %had_breakpoints) {
- local *dbline = "::_<$file";
+ local *dbline = $main::{'_<' . $file};
my $max = $#dbline;
my $was;
last CMD; };
$cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
end_report(), next CMD if $finished and $level <= 1;
- $i = $1;
+ $subname = $i = $1;
if ($i =~ /\D/) { # subroutine name
- ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
+ $subname = $package."::".$subname
+ unless $subname =~ /::/;
+ ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
$i += 0;
if ($i) {
$filename = $file;
- *dbline = "::_<$filename";
+ *dbline = $main::{'_<' . $filename};
$had_breakpoints{$filename}++;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
my @hard;
for (0 .. $#had_breakpoints) {
my $file = $had_breakpoints[$_];
- *dbline = "::_<$file";
- next unless %dbline or %{$postponed_file{$file}};
+ *dbline = $main::{'_<' . $file};
+ next unless %dbline or $postponed_file{$file};
(push @hard, $file), next
if $file =~ /^\(eval \d+\)$/;
my @add;
@add = %{$postponed_file{$file}}
- if %{$postponed_file{$file}};
+ if $postponed_file{$file};
set_list("PERLDB_FILE_$_", %dbline, @add);
}
for (@hard) { # Yes, really-really...
# Find the subroutines in this eval
- *dbline = "::_<$_";
+ *dbline = $main::{'_<' . $_};
my ($quoted, $sub, %subs, $line) = quotemeta $_;
for $sub (keys %sub) {
next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
}
}
set_list("PERLDB_POSTPONE", %postponed);
+ set_list("PERLDB_PRETYPE", @$pretype);
+ set_list("PERLDB_PRE", @$pre);
+ set_list("PERLDB_POST", @$post);
+ set_list("PERLDB_TYPEAHEAD", @typeahead);
$ENV{PERLDB_RESTART} = 1;
#print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
$evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
if ($onetimeDump) {
$onetimeDump = undef;
- } else {
+ } elsif ($term_pid == $$) {
print $OUT "\n";
}
} continue { # CMD:
}
} # CMD:
$exiting = 1 unless defined $cmd;
- map {$evalarg = $_; &eval} @$post;
+ foreach $evalarg (@$post) {
+ &eval;
+ }
} # if ($single || $signal)
($@, $!, $,, $/, $\, $^W) = @saved;
();
sub sub {
my ($al, $ret, @ret) = "";
- if ($sub =~ /(.*)::AUTOLOAD$/) {
- $al = " for $ {$1 . '::AUTOLOAD'}";
+ if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
+ $al = " for $$sub";
}
push(@stack, $single);
$single &= 1;
if (wantarray) {
@ret = &$sub;
$single |= pop(@stack);
- print ($OUT "list context return from $sub:\n"), dumpit( \@ret ),
- $doret = -2 if $doret eq $#stack;
($frame & 4
? ( (print $LINEINFO ' ' x $#stack, "out "),
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
: print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
+ print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
+ "list context return from $sub:\n"), dumpit( \@ret ),
+ $doret = -2 if $doret eq $#stack or $frame & 16;
@ret;
} else {
- $ret = &$sub;
+ if (defined wantarray) {
+ $ret = &$sub;
+ } else {
+ &$sub; undef $ret;
+ };
$single |= pop(@stack);
- print ($OUT "scalar context return from $sub: "), dumpit( $ret ),
- $doret = -2 if $doret eq $#stack;
($frame & 4
? ( (print $LINEINFO ' ' x $#stack, "out "),
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
: print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
+ print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
+ "scalar context return from $sub: "), dumpit( $ret ),
+ $doret = -2 if $doret eq $#stack or $frame & 16;
$ret;
}
}
my $offset = $1 || 0;
# Filename below can contain ':'
my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
- $i += $offset;
if ($i) {
- local *dbline = "::_<$file";
+ $i += $offset;
+ local *dbline = $main::{'_<' . $file};
local $^W = 0; # != 0 is magical below
$had_breakpoints{$file}++;
my $max = $#dbline;
$signal = 1, print $OUT "'$filename' loaded...\n"
if $break_on_load{$filename};
print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
- return unless %{$postponed_file{$filename}};
+ return unless $postponed_file{$filename};
$had_breakpoints{$filename}++;
#%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
my $key;
for $key (keys %{$postponed_file{$filename}}) {
$dbline{$key} = $ {$postponed_file{$filename}}{$key};
}
- undef %{$postponed_file{$filename}};
+ delete $postponed_file{$filename};
}
sub dumpit {
} else {
$term = new Term::ReadLine 'perldb', $IN, $OUT;
- $readline::rl_basic_word_break_characters .= "[:"
- if defined $readline::rl_basic_word_break_characters
- and index($readline::rl_basic_word_break_characters, ":") == -1;
- $readline::rl_special_prefixes =
- $readline::rl_special_prefixes = '$@&%';
- $readline::rl_completer_word_break_characters =
- $readline::rl_completer_word_break_characters . '$@&%';
- $readline::rl_completion_function =
- $readline::rl_completion_function = \&db_complete;
+ $rl_attribs = $term->Attribs;
+ $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
+ if defined $rl_attribs->{basic_word_break_characters}
+ and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
+ $rl_attribs->{special_prefixes} = '$@&%';
+ $rl_attribs->{completer_word_break_characters} .= '$@&%';
+ $rl_attribs->{completion_function} = \&db_complete;
}
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
if ($term->Features->{setHistory} and "@hist" ne "?") {
$term->SetHistory(@hist);
}
+ ornaments($ornaments) if defined $ornaments;
+ $term_pid = $$;
+}
+
+sub resetterm { # We forked, so we need a different TTY
+ $term_pid = $$;
+ if (defined &get_fork_TTY) {
+ &get_fork_TTY;
+ } elsif (not defined $fork_TTY
+ and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
+ and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
+ # Possibly _inside_ XTERM
+ open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
+ sleep 10000000' |];
+ $fork_TTY = <XT>;
+ chomp $fork_TTY;
+ }
+ if (defined $fork_TTY) {
+ TTY($fork_TTY);
+ undef $fork_TTY;
+ } else {
+ print $OUT "Forked, but do not know how to change a TTY.\n",
+ "Define \$DB::fork_TTY or get_fork_TTY().\n";
+ }
}
sub readline {
}
sub TTY {
- if ($term) {
- &warn("Too late to set TTY!\n") if @_;
- } else {
- $tty = shift if @_;
- }
+ if (@_ and $term and $term->Features->{newTTY}) {
+ my ($in, $out) = shift;
+ if ($in =~ /,/) {
+ ($in, $out) = split /,/, $in, 2;
+ } else {
+ $out = $in;
+ }
+ open IN, $in or die "cannot open `$in' for read: $!";
+ open OUT, ">$out" or die "cannot open `$out' for write: $!";
+ $term->newTTY(\*IN, \*OUT);
+ $IN = \*IN;
+ $OUT = \*OUT;
+ return $tty = $in;
+ } elsif ($term and @_) {
+ &warn("Too late to set TTY, enabled on next `R'!\n");
+ }
+ $tty = shift if @_;
$tty or $console;
}
sub noTTY {
if ($term) {
- &warn("Too late to set noTTY!\n") if @_;
- } else {
- $notty = shift if @_;
+ &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
}
+ $notty = shift if @_;
$notty;
}
sub ReadLine {
if ($term) {
- &warn("Too late to set ReadLine!\n") if @_;
- } else {
- $rl = shift if @_;
+ &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
}
+ $rl = shift if @_;
$rl;
}
+sub tkRunning {
+ if ($ {$term->Features}{tkRunning}) {
+ return $term->tkRunning(@_);
+ } else {
+ print $OUT "tkRunning not supported by current ReadLine package.\n";
+ 0;
+ }
+}
+
sub NonStop {
if ($term) {
- &warn("Too late to set up NonStop mode!\n") if @_;
- } else {
- $runnonstop = shift if @_;
+ &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
}
+ $runnonstop = shift if @_;
$runnonstop;
}
$psh;
}
+sub ornaments {
+ if (defined $term) {
+ local ($warnLevel,$dieLevel) = (0, 1);
+ return '' unless $term->Features->{ornaments};
+ eval { $term->ornaments(@_) } || '';
+ } else {
+ $ornaments = shift;
+ }
+}
+
sub recallCommand {
if (@_) {
$rc = quotemeta shift;
frame affects printing messages on entry and exit from subroutines.
AutoTrace affects printing messages on every possible breaking point.
maxTraceLen gives maximal length of evals/args listed in stack trace.
+ ornaments affects screen appearance of the command line.
During startup options are initialized from \$ENV{PERLDB_OPTS}.
You can put additional initialization options TTY, noTTY,
- ReadLine, and NonStop there.
+ ReadLine, and NonStop there (or use `R' after you set them).
< command Define Perl command to run before each prompt.
<< command Add to the list of Perl commands to run before each prompt.
> command Define Perl command to run after each prompt.
local $doret = -2;
$SIG{'ABRT'} = 'DEFAULT';
kill 'ABRT', $$ if $panic++;
- print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
- local $SIG{__WARN__} = '';
- require Carp;
- local $Carp::CarpLevel = 2; # mydie + confess
- &warn(Carp::longmess("Signal @_"));
+ if (defined &Carp::longmess) {
+ local $SIG{__WARN__} = '';
+ local $Carp::CarpLevel = 2; # mydie + confess
+ &warn(Carp::longmess("Signal @_"));
+ }
+ else {
+ print $DB::OUT "Got signal @_\n";
+ }
kill 'ABRT', $$;
}
local $doret = -2;
local $SIG{__WARN__} = '';
local $SIG{__DIE__} = '';
- eval { require Carp }; # If error/warning during compilation,
- # require may be broken.
- warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
- unless defined &Carp::longmess;
- #&warn("Entering dbwarn\n");
+ eval { require Carp } if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+ warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
+ return unless defined &Carp::longmess;
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
my $mess = Carp::longmess(@_);
($single,$trace) = ($mysingle,$mytrace);
- #&warn("Warning in dbwarn\n");
&warn($mess);
- #&warn("Exiting dbwarn\n");
}
sub dbdie {
local $SIG{__DIE__} = '';
local $SIG{__WARN__} = '';
my $i = 0; my $ineval = 0; my $sub;
- #&warn("Entering dbdie\n");
- if ($dieLevel != 2) {
- while ((undef,undef,undef,$sub) = caller(++$i)) {
- $ineval = 1, last if $sub eq '(eval)';
- }
- {
+ if ($dieLevel > 2) {
local $SIG{__WARN__} = \&dbwarn;
- &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
- }
- #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
- die @_ if $ineval and $dieLevel < 2;
+ &warn(@_); # Yell no matter what
+ return;
+ }
+ if ($dieLevel < 2) {
+ die @_ if $^S; # in eval propagate
}
- eval { require Carp }; # If error/warning during compilation,
- # require may be broken.
- die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
+ eval { require Carp } if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+ die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
+ unless defined &Carp::longmess;
# We do not want to debug this chunk (automatic disabling works
# inside DB::DB, but not in Carp).
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
my $mess = Carp::longmess(@_);
($single,$trace) = ($mysingle,$mytrace);
- #&warn("dieing loudly in dbdie\n");
die $mess;
}
$SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
#$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
print $OUT "Stack dump during die enabled",
- ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
+ ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
+ if $I_m_init;
print $OUT "Dump printed too.\n" if $dieLevel > 2;
} else {
$SIG{__DIE__} = $prevdie;
my $name;
for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
sort keys %{"$ {class}::"}) {
- next if $seen{ \&{$ {"$ {class}::"}{$name}} }++;
+ next if $seen{ $name }++;
print $DB::OUT "$prepend$name\n";
}
return unless shift; # Recurse?
#use Carp; # This did break, left for debuggin
sub db_complete {
+ # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
my($text, $line, $start) = @_;
- my ($itext, $prefix, $pack) = $text;
+ my ($itext, $search, $prefix, $pack) =
+ ($text, "^\Q$ {'package'}::\E([^:]+)\$");
+ return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
+ (map { /$search/ ? ($1) : () } keys %sub)
+ if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
+ return sort grep /^\Q$text/, values %INC # files
+ if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
+ return sort map {($_, db_complete($_ . "::", "V ", 2))}
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
+ if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
+ return sort map {($_, db_complete($_ . "::", "V ", 2))}
+ grep !/^main::/,
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
+ # packages
+ if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
+ and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
+ if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
+ # We may want to complete to (eval 9), so $text may be wrong
+ $prefix = length($1) - length($text);
+ $text = $1;
+ return sort
+ map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
+ }
if ((substr $text, 0, 1) eq '&') { # subroutines
$text = substr $text, 1;
$prefix = "&";
- return map "$prefix$_", grep /^\Q$text/, keys %sub;
+ return sort map "$prefix$_",
+ grep /^\Q$text/,
+ (keys %sub),
+ (map { /$search/ ? ($1) : () }
+ keys %sub);
}
if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
$pack = ($1 eq 'main' ? '' : $1) . '::';
if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
return db_complete($out[0], $line, $start);
}
- return @out;
+ return sort @out;
}
if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
$pack = ($package eq 'main' ? '' : $package) . '::';
if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
return db_complete($out[0], $line, $start);
}
- return @out;
+ return sort @out;
}
- return grep /^\Q$text/, (keys %sub), qw(postpone load compile) # subroutines
- if (substr $line, 0, $start) =~ /^[bl]\s+((postpone|compile)\s+)?$/;
- return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages
- if (substr $line, 0, $start) =~ /^V\s+$/;
- if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space
+ if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
my @out = grep /^\Q$text/, @options;
my $val = option_val($out[0], undef);
my $out = '? ';
$out = "=$val ";
}
# Default to value if one completion, to question if many
- $readline::rl_completer_terminator_character
- = $readline::rl_completer_terminator_character
- = (@out == 1 ? $out : '? ');
- return @out;
+ $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
+ return sort @out;
}
- return &readline::rl_filename_list($text); # filenames
+ return $term->filename_list($text); # filenames
}
-sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
+sub end_report {
+ print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
+}
END {
$finished = $inhibit_exit; # So that some keys may be disabled.
package DB::fake;
sub at_exit {
- "Debuggee terminated. Use `q' to quit and `R' to restart.";
+ "Debugged program terminated. Use `q' to quit or `R' to restart.";
}
package DB; # Do not trace this 1; below!
projects / p5sagit/p5-mst-13.2.git / blobdiff