r8135 - in /trunk/libterm-shell-perl: ./ current/ debian/ lib/Term/ t/
makholm at users.alioth.debian.org
makholm at users.alioth.debian.org
Tue Oct 9 16:39:05 UTC 2007
Author: makholm
Date: Tue Oct 9 16:39:05 2007
New Revision: 8135
URL: http://svn.debian.org/wsvn/?sc=1&rev=8135
Log:
[svn-inject] Applying Debian modifications to trunk
Added:
trunk/libterm-shell-perl/META.yml
trunk/libterm-shell-perl/debian/compat
trunk/libterm-shell-perl/t/03catchsmry.t
Removed:
trunk/libterm-shell-perl/Makefile.old
trunk/libterm-shell-perl/current/
trunk/libterm-shell-perl/debian/dirs
trunk/libterm-shell-perl/debian/docs
trunk/libterm-shell-perl/debian/libterm-shell-perl.files
Modified:
trunk/libterm-shell-perl/Changes
trunk/libterm-shell-perl/MANIFEST
trunk/libterm-shell-perl/Shell.pm
trunk/libterm-shell-perl/debian/changelog
trunk/libterm-shell-perl/debian/control
trunk/libterm-shell-perl/debian/copyright
trunk/libterm-shell-perl/debian/rules
trunk/libterm-shell-perl/lib/Term/Shell.pod
trunk/libterm-shell-perl/t/02default.t
trunk/libterm-shell-perl/test.pl
Modified: trunk/libterm-shell-perl/Changes
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/Changes?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/Changes (original)
+++ trunk/libterm-shell-perl/Changes Tue Oct 9 16:39:05 2007
@@ -1,3 +1,6 @@
+0.02 Fri Feb 23 06:36:03 PST 2007
+ - Fix CPAN bug id 2463: help now unconditionally calls $o->summary()
+
0.01 Fri Jan 25 12:15:25 PST 2002 @67
- Documentation updates
- Read the README
Modified: trunk/libterm-shell-perl/MANIFEST
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/MANIFEST?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/MANIFEST (original)
+++ trunk/libterm-shell-perl/MANIFEST Tue Oct 9 16:39:05 2007
@@ -8,3 +8,5 @@
test.pl
t/01require.t
t/02default.t
+t/03catchsmry.t
+META.yml Module meta-data (added by MakeMaker)
Added: trunk/libterm-shell-perl/META.yml
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/META.yml?rev=8135&op=file
==============================================================================
--- trunk/libterm-shell-perl/META.yml (added)
+++ trunk/libterm-shell-perl/META.yml Tue Oct 9 16:39:05 2007
@@ -1,0 +1,10 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Term-Shell
+version: 0.02
+version_from: Shell.pm
+installdirs: site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Modified: trunk/libterm-shell-perl/Shell.pm
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/Shell.pm?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/Shell.pm (original)
+++ trunk/libterm-shell-perl/Shell.pm Tue Oct 9 16:39:05 2007
@@ -1,9 +1,11 @@
package Term::Shell;
-$VERSION = '0.01';
use strict;
+use warnings;
use Data::Dumper;
use Term::ReadLine;
+
+our $VERSION = '0.02';
#=============================================================================
# Term::Shell API methods
@@ -11,10 +13,13 @@
sub new {
my $cls = shift;
my $o = bless {
- term => do {
- #local $^W;
+ term => eval {
+ # Term::ReadKey throws ugliness all over the place if we're not
+ # running in a terminal, which we aren't during "make test", at
+ # least on FreeBSD. Suppress warnings here.
+ local $SIG{__WARN__} = sub { };
Term::ReadLine->new('shell');
- },
+ } || undef,
}, ref($cls) || $cls;
# Set up the API hash:
@@ -25,10 +30,12 @@
check_idle => 0, # changing this isn't supported
class => $cls,
command => $o->{command},
+ cmd => $o->{command}, # shorthand
match_uniq => 1,
- readline => $o->term->ReadLine,
+ pager => $ENV{PAGER} || 'internal',
+ readline => eval { $o->{term}->ReadLine } || 'none',
script => (caller(0))[1],
- version => $Term::Shell::VERSION,
+ version => $VERSION,
};
# Note: the rl_completion_function doesn't pass an object as the first
@@ -37,18 +44,15 @@
my $completion_handler = sub {
$o->rl_complete(@_);
};
- if ($o->term->ReadLine eq 'Term::ReadLine::Gnu') {
- my $attribs = $o->term->Attribs;
+ if ($o->{API}{readline} eq 'Term::ReadLine::Gnu') {
+ my $attribs = $o->{term}->Attribs;
$attribs->{completion_function} = $completion_handler;
}
- elsif ($o->term->ReadLine eq 'Term::ReadLine::Perl') {
+ elsif ($o->{API}{readline} eq 'Term::ReadLine::Perl') {
$readline::rl_completion_function =
$readline::rl_completion_function = $completion_handler;
}
-
- # Read the namespace and find the action handlers.
$o->find_handlers;
-
$o->init;
$o;
}
@@ -65,8 +69,8 @@
my ($cmd, @args) = $o->line_parsed;
$o->run($cmd, @args);
unless ($o->{command}{run}{found}) {
- my @c = sort $o->possible_actions($cmd, 'run', 1);
- if (@c) {
+ my @c = sort $o->possible_actions($cmd, 'run');
+ if (@c and $o->{API}{match_uniq}) {
print $o->msg_ambiguous_cmd($cmd, @c);
}
else {
@@ -79,6 +83,7 @@
}
}
+sub stoploop { $_[0]->{stop}++ }
sub cmdloop {
my $o = shift;
$o->{stop} = 0;
@@ -94,9 +99,9 @@
sub readline {
my $o = shift;
my $prompt = shift;
- return $o->term->readline($prompt)
+ return $o->{term}->readline($prompt)
if $o->{API}{check_idle} == 0
- or not defined $o->term->IN;
+ or not defined $o->{term}->IN;
# They've asked for idle-time running of some user command.
local $Term::ReadLine::toloop = 1;
@@ -120,11 +125,9 @@
$o->idle;
}
};
- return $o->term->readline($prompt);
-}
-
-sub page { shift; print @_ }
-sub stoploop { $_[0]->{stop}++ }
+ $o->{term}->readline($prompt);
+}
+
sub term { $_[0]->{term} }
# These are likely candidates for overriding in subclasses
@@ -140,6 +143,90 @@
sub cmd_suffix { '' }
#=============================================================================
+# The pager
+#=============================================================================
+sub page {
+ my $o = shift;
+ my $text = shift;
+ my $maxlines = shift || $o->termsize->{rows};
+ my $pager = $o->{API}{pager};
+
+ # First, count the number of lines in the text:
+ my $lines = ($text =~ tr/\n//);
+
+ # If there are fewer lines than the page-lines, just print it.
+ if ($lines < $maxlines or $maxlines == 0 or $pager eq 'none') {
+ print $text;
+ }
+ # If there are more, page it, either using the external pager...
+ elsif ($pager and $pager ne 'internal') {
+ require File::Temp;
+ my ($handle, $name) = File::Temp::tempfile();
+ select((select($handle), $| = 1)[0]);
+ print $handle $text;
+ close $handle;
+ system($pager, $name) == 0
+ or print <<END;
+Warning: can't run external pager '$pager': $!.
+END
+ unlink $name;
+ }
+ # ... or the internal one
+ else {
+ my $togo = $lines;
+ my $line = 0;
+ my @lines = split '^', $text;
+ while ($togo > 0) {
+ my @text = @lines[$line .. $#lines];
+ my $ret = $o->page_internal(\@text, $maxlines, $togo, $line);
+ last if $ret == -1;
+ $line += $ret;
+ $togo -= $ret;
+ }
+ return $line;
+ }
+ return $lines
+}
+
+sub page_internal {
+ my $o = shift;
+ my $lines = shift;
+ my $maxlines = shift;
+ my $togo = shift;
+ my $start = shift;
+
+ my $line = 1;
+ while ($_ = shift @$lines) {
+ print;
+ last if $line >= ($maxlines - 1); # leave room for the prompt
+ $line++;
+ }
+ my $lines_left = $togo - $line;
+ my $current_line = $start + $line;
+ my $total_lines = $togo + $start;
+
+ my $instructions;
+ if ($o->have_readkey) {
+ $instructions = "any key for more, or q to quit";
+ }
+ else {
+ $instructions = "enter for more, or q to quit";
+ }
+
+ if ($lines_left > 0) {
+ local $| = 1;
+ my $l = "---line $current_line/$total_lines ($instructions)---";
+ my $b = ' ' x length($l);
+ print $l;
+ my $ans = $o->readkey;
+ print "\r$b\r" if $o->have_readkey;
+ print "\n" if $ans =~ /q/i or not $o->have_readkey;
+ $line = -1 if $ans =~ /q/i;
+ }
+ $line;
+}
+
+#=============================================================================
# Run actions
#=============================================================================
sub run {
@@ -171,21 +258,205 @@
$o->do_action($topic, [], 'smry')
}
+#=============================================================================
+# Manually add & remove handlers
+#=============================================================================
+sub add_handlers {
+ my $o = shift;
+ for my $hnd (@_) {
+ next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
+ my $t = $1;
+ my $a = substr($hnd, length($t) + 1);
+ # Add on the prefix and suffix if the command is defined
+ if (length $a) {
+ substr($a, 0, 0) = $o->cmd_prefix;
+ $a .= $o->cmd_suffix;
+ }
+ $o->{handlers}{$a}{$t} = $hnd;
+ if ($o->has_aliases($a)) {
+ my @a = $o->get_aliases($a);
+ for my $alias (@a) {
+ substr($alias, 0, 0) = $o->cmd_prefix;
+ $alias .= $o->cmd_suffix;
+ $o->{handlers}{$alias}{$t} = $hnd;
+ }
+ }
+ }
+}
+
+sub add_commands {
+ my $o = shift;
+ while (@_) {
+ my ($cmd, $hnd) = (shift, shift);
+ $o->{handlers}{$cmd} = $hnd;
+ }
+}
+
+sub remove_handlers {
+ my $o = shift;
+ for my $hnd (@_) {
+ next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
+ my $t = $1;
+ my $a = substr($hnd, length($t) + 1);
+ # Add on the prefix and suffix if the command is defined
+ if (length $a) {
+ substr($a, 0, 0) = $o->cmd_prefix;
+ $a .= $o->cmd_suffix;
+ }
+ delete $o->{handlers}{$a}{$t};
+ }
+}
+
+sub remove_commands {
+ my $o = shift;
+ for my $name (@_) {
+ delete $o->{handlers}{$name};
+ }
+}
+
+*add_handler = \&add_handlers;
+*add_command = \&add_commands;
+*remove_handler = \&remove_handlers;
+*remove_command = \&remove_commands;
+
+#=============================================================================
+# Utility methods
+#=============================================================================
+sub termsize {
+ my $o = shift;
+ my ($rows, $cols) = (24, 78);
+
+ # Try several ways to get the terminal size
+ TERMSIZE:
+ {
+ my $TERM = $o->{term};
+ last TERMSIZE unless $TERM;
+
+ my $OUT = $TERM->OUT;
+
+ if ($TERM and $o->{API}{readline} eq 'Term::ReadLine::Gnu') {
+ ($rows, $cols) = $TERM->get_screen_size;
+ last TERMSIZE;
+ }
+
+ if ($^O eq 'MSWin32' and eval { require Win32::Console }) {
+ Win32::Console->import;
+ # Win32::Console's DESTROY does a CloseHandle(), so save the object:
+ $o->{win32_stdout} ||= Win32::Console->new(STD_OUTPUT_HANDLE());
+ my @info = $o->{win32_stdout}->Info;
+ $cols = $info[7] - $info[5] + 1; # right - left + 1
+ $rows = $info[8] - $info[6] + 1; # bottom - top + 1
+ last TERMSIZE;
+ }
+
+ if (eval { require Term::Size }) {
+ my @x = Term::Size::chars($OUT);
+ if (@x == 2 and $x[0]) {
+ ($cols, $rows) = @x;
+ last TERMSIZE;
+ }
+ }
+
+ if (eval { require Term::Screen }) {
+ my $screen = Term::Screen->new;
+ ($rows, $cols) = @$screen{qw(ROWS COLS)};
+ last TERMSIZE;
+ }
+
+ if (eval { require Term::ReadKey }) {
+ ($cols, $rows) = eval {
+ local $SIG{__WARN__} = sub {};
+ Term::ReadKey::GetTerminalSize($OUT);
+ };
+ last TERMSIZE unless $@;
+ }
+
+ if ($ENV{LINES} or $ENV{ROWS} or $ENV{COLUMNS}) {
+ $rows = $ENV{LINES} || $ENV{ROWS} || $rows;
+ $cols = $ENV{COLUMNS} || $cols;
+ last TERMSIZE;
+ }
+
+ {
+ local $^W;
+ local *STTY;
+ if (open (STTY, "stty size |")) {
+ my $l = <STTY>;
+ ($rows, $cols) = split /\s+/, $l;
+ close STTY;
+ }
+ }
+ }
+
+ return { rows => $rows, cols => $cols};
+}
+
+sub readkey {
+ my $o = shift;
+ $o->have_readkey unless $o->{readkey};
+ $o->{readkey}->();
+}
+
+sub have_readkey {
+ my $o = shift;
+ return 1 if $o->{have_readkey};
+ my $IN = $o->{term}->IN;
+ if (eval { require Term::InKey }) {
+ $o->{readkey} = \&Term::InKey::ReadKey;
+ }
+ elsif ($^O eq 'MSWin32' and eval { require Win32::Console }) {
+ $o->{readkey} = sub {
+ my $c;
+ # from Term::InKey:
+ eval {
+ # Win32::Console's DESTROY does a CloseHandle(), so save it:
+ Win32::Console->import;
+ $o->{win32_stdin} ||= Win32::Console->new(STD_INPUT_HANDLE());
+ my $mode = my $orig = $o->{win32_stdin}->Mode or die $^E;
+ $mode &= ~(ENABLE_LINE_INPUT() | ENABLE_ECHO_INPUT());
+ $o->{win32_stdin}->Mode($mode) or die $^E;
+
+ $o->{win32_stdin}->Flush or die $^E;
+ $c = $o->{win32_stdin}->InputChar(1);
+ die $^E unless defined $c;
+ $o->{win32_stdin}->Mode($orig) or die $^E;
+ };
+ die "Not implemented on $^O: $@" if $@;
+ $c;
+ };
+ }
+ elsif (eval { require Term::ReadKey }) {
+ $o->{readkey} = sub {
+ Term::ReadKey::ReadMode(4, $IN);
+ my $c = getc($IN);
+ Term::ReadKey::ReadMode(0, $IN);
+ $c;
+ };
+ }
+ else {
+ $o->{readkey} = sub { scalar <$IN> };
+ return $o->{have_readkey} = 0;
+ }
+ return $o->{have_readkey} = 1;
+}
+*has_readkey = \&have_readkey;
+
sub prompt {
my $o = shift;
my ($prompt, $default, $completions, $casei) = @_;
+ my $term = $o->{term};
# A closure to read the line.
my $line;
my $readline = sub {
- my ($sh, $gh) = @{$o->term->Features}{qw(setHistory getHistory)};
- my @history = $o->term->GetHistory if $gh;
- $o->term->SetHistory() if $sh;
+ my ($sh, $gh) = @{$term->Features}{qw(setHistory getHistory)};
+ my @history = $term->GetHistory if $gh;
+ $term->SetHistory() if $sh;
$line = $o->readline($prompt);
$line = $default
if ((not defined $line or $line =~ /^\s*$/) and defined $default);
# Restore the history
- $o->term->SetHistory(@history) if $sh;
+ $term->SetHistory(@history) if $sh;
$line;
};
# A closure to complete the line.
@@ -193,12 +464,13 @@
my ($word, $line, $start) = @_;
return $o->completions($word, $completions, $casei);
};
- if ($o->term->ReadLine eq 'Term::ReadLine::Gnu') {
- my $attribs = $o->term->Attribs;
+
+ if ($term and $term->ReadLine eq 'Term::ReadLine::Gnu') {
+ my $attribs = $term->Attribs;
local $attribs->{completion_function} = $complete;
&$readline;
}
- elsif ($o->term->ReadLine eq 'Term::ReadLine::Perl') {
+ elsif ($term and $term->ReadLine eq 'Term::ReadLine::Perl') {
local $readline::rl_completion_function = $complete;
&$readline;
}
@@ -208,7 +480,7 @@
$line;
}
-sub print_pairs {
+sub format_pairs {
my $o = shift;
my @keys = @{shift(@_)};
my @vals = @{shift(@_)};
@@ -218,41 +490,48 @@
my $len = shift || 0;
my $wrap = shift || 0;
if ($wrap) {
- eval { require Text::Autoformat };
+ eval {
+ require Text::Autoformat;
+ Text::Autoformat->import(qw(autoformat));
+ };
if ($@) {
warn (
- "Term::Shell::print_pairs(): Text::Autoformat is required " .
+ "Term::Shell::format_pairs(): Text::Autoformat is required " .
"for wrapping. Wrapping disabled"
) if $^W;
$wrap = 0;
}
}
- my $cols = shift || $ENV{COLUMNS} || 78;
+ my $cols = shift || $o->termsize->{cols};
$len < length($_) and $len = length($_) for @keys;
+ my @text;
for my $i (0 .. $#keys) {
next unless defined $vals[$i];
my $sz = ($len - length($keys[$i]));
my $lpad = $left ? "" : " " x $sz;
my $rpad = $left ? " " x $sz : "";
my $l = "$ind$lpad$keys[$i]$rpad$sep";
- my $wrap = $wrap & ($vals[$i] =~ /\s/ and $vals[$i] !~ /\d/);
+ my $wrap = $wrap & ($vals[$i] =~ /\s/ and $vals[$i] !~ /^\d/);
my $form = (
$wrap
? autoformat(
- $vals[$i],
+ "$vals[$i]", # force stringification
{ left => length($l)+1, right => $cols, all => 1 },
)
: "$l$vals[$i]\n"
);
substr($form, 0, length($l), $l);
- print $form;
- }
+ push @text, $form;
+ }
+ my $text = join '', @text;
+ return wantarray ? ($text, $len) : $text;
+}
+
+sub print_pairs {
+ my $o = shift;
+ my ($text, $len) = $o->format_pairs(@_);
+ $o->page($text);
return $len;
-}
-
-sub line {
- my $o = shift;
- $o->{line}
}
# Handle backslash translation; doesn't do anything complicated yet.
@@ -266,41 +545,52 @@
return "\\$c";
}
+# Parse a quoted string
+sub parse_quoted {
+ my $o = shift;
+ my $raw = shift;
+ my $quote = shift;
+ my $i=1;
+ my $string = '';
+ my $c;
+ while($i <= length($raw) and ($c=substr($raw, $i, 1)) ne $quote) {
+ if ($c eq '\\') {
+ $string .= $o->process_esc(substr($raw, $i+1, 1), $quote);
+ $i++;
+ }
+ else {
+ $string .= substr($raw, $i, 1);
+ }
+ $i++;
+ }
+ return ($string, $i);
+};
+
+sub line {
+ my $o = shift;
+ $o->{line}
+}
+sub line_args {
+ my $o = shift;
+ my $line = shift || $o->line;
+ $o->line_parsed($line);
+ $o->{line_args} || '';
+}
sub line_parsed {
my $o = shift;
- my $args = shift || $o->line;
+ my $args = shift || $o->line || return ();
my @args;
-
- # Parse a quoted string
- my $parse_quoted = sub {
- my $raw = shift;
- my $quote = shift;
- my $i=1;
- my $string = '';
- my $c;
- while($i <= length($raw) and ($c=substr($raw, $i, 1)) ne $quote) {
- if ($c eq '\\') {
- $string .= $o->process_esc(substr($raw, $i+1, 1), $quote);
- $i++;
- }
- else {
- $string .= substr($raw, $i, 1);
- }
- $i++;
- }
- return ($string, $i);
- };
# Parse an array of arguments. Whitespace separates, unless quoted.
my $arg = undef;
- my $raw = undef;
+ $o->{line_args} = undef;
for(my $i=0; $i<length($args); $i++) {
my $c = substr($args, $i, 1);
if ($c =~ /\S/ and @args == 1) {
- $raw ||= substr($args, $i);
+ $o->{line_args} ||= substr($args, $i);
}
if ($c =~ /['"]/) {
- my ($str, $n) = $parse_quoted->(substr($args,$i),$c);
+ my ($str, $n) = $o->parse_quoted(substr($args,$i),$c);
$i += $n;
$arg = (defined($arg) ? $arg : '') . $str;
}
@@ -322,6 +612,48 @@
return @args;
}
+sub handler {
+ my $o = shift;
+ my ($command, $type, $args, $preserve_args) = @_;
+
+ # First try finding the standard handler, then fallback to the
+ # catch_$type method. The columns represent "action", "type", and "push",
+ # which control whether the name of the command should be pushed onto the
+ # args.
+ my @tries = (
+ [$command, $type, 0],
+ [$o->cmd_prefix . $type . $o->cmd_suffix, 'catch', 1],
+ );
+
+ # The user can control whether or not to search for "unique" matches,
+ # which means calling $o->possible_actions(). We always look for exact
+ # matches.
+ my @matches = qw(exact_action);
+ push @matches, qw(possible_actions) if $o->{API}{match_uniq};
+
+ for my $try (@tries) {
+ my ($cmd, $type, $add_cmd_name) = @$try;
+ for my $match (@matches) {
+ my @handlers = $o->$match($cmd, $type);
+ next unless @handlers == 1;
+ unshift @$args, $command
+ if $add_cmd_name and not $preserve_args;
+ return $o->unalias($handlers[0], $type)
+ }
+ }
+ return undef;
+}
+
+sub completions {
+ my $o = shift;
+ my $action = shift;
+ my $compls = shift || [];
+ my $casei = shift;
+ $casei = $o->{API}{case_ignore} unless defined $casei;
+ $casei = $casei ? '(?i)' : '';
+ return grep { $_ =~ /$casei^\Q$action\E/ } @$compls;
+}
+
#=============================================================================
# Term::Shell error messages
#=============================================================================
@@ -349,10 +681,13 @@
my $cmd = shift;
my $args = shift || [];
my $type = shift || 'run';
- my $handler = $o->handler($cmd, $type, $args);
+ my ($fullname, $cmdname, $handler) = $o->handler($cmd, $type, $args);
$o->{command}{$type} = {
+ cmd => $cmd,
name => $cmd,
found => defined $handler ? 1 : 0,
+ cmdfull => $fullname,
+ cmdreal => $cmdname,
handler => $handler,
};
if (defined $handler) {
@@ -367,38 +702,6 @@
}
}
-sub handler {
- my $o = shift;
- my ($command, $type, $args, $preserve_args) = @_;
-
- # First try finding the standard handler, then fallback to the
- # catch_$type method. The columns represent "action", "type", and "push",
- # which control whether the name of the command should be pushed onto the
- # args.
- my @tries = (
- [$command, $type, 0],
- [$o->cmd_prefix . $type . $o->cmd_suffix, 'catch', 1],
- );
-
- # The user can control whether or not to search for "unique" matches,
- # which means calling $o->possible_actions(). We always look for exact
- # matches.
- my @matches = qw(exact_action);
- push @matches, qw(possible_actions) if $o->{API}{match_uniq};
-
- for my $try (@tries) {
- my ($cmd, $type, $add_cmd_name) = @$try;
- for my $match (@matches) {
- my @handlers = $o->$match($cmd, $type);
- next unless @handlers;
- unshift @$args, $command
- if $add_cmd_name and not $preserve_args;
- return $o->unalias($handlers[0], $type)
- }
- }
- return undef;
-}
-
sub uniq {
my $o = shift;
my %seen;
@@ -408,41 +711,27 @@
@ret;
}
-sub completions {
- my $o = shift;
- my $action = shift;
- my $compls = shift || [];
- my $casei = shift;
- $casei = $o->{API}{case_ignore} unless defined $casei;
- $casei = $casei ? '(?i)' : '';
- return grep { $_ =~ /$casei^\Q$action\E/ } @$compls;
-}
-
sub possible_actions {
my $o = shift;
my $action = shift;
my $type = shift;
- my $strip = shift || 0;
my $casei = $o->{API}{case_ignore} ? '(?i)' : '';
my @keys = grep { $_ =~ /$casei^\Q$action\E/ }
grep { exists $o->{handlers}{$_}{$type} }
keys %{$o->{handlers}};
- return @keys if $strip;
- return map { "${type}_$_" } @keys;
+ return @keys;
}
sub exact_action {
my $o = shift;
my $action = shift;
my $type = shift;
- my $strip = shift || 0;
my $casei = $o->{API}{case_ignore} ? '(?i)' : '';
- my @key = grep { $action =~ /$casei^\Q$_\E$/ } keys %{$o->{handlers}};
+ my @key = grep { $action =~ /$casei^\Q$_\E$/ }
+ grep { exists $o->{handlers}{$_}{$type} }
+ keys %{$o->{handlers}};
return () unless @key == 1;
- return () unless exists $o->{handlers}{$key[0]}{$type};
- my $handler = $o->{handlers}{$key[0]}{$type};
- $handler =~ s/\Q${type}_\E// if $strip;
- return $handler;
+ return $key[0];
}
sub is_alias {
@@ -472,14 +761,18 @@
sub unalias {
my $o = shift;
- my $alias = shift;
- my $type = shift;
- return $alias unless $type;
- my @stuff = split '_', $alias;
- $stuff[1] ||= '';
- return $alias unless $stuff[0] eq $type;
- return $alias unless exists $o->{aliases}{$stuff[1]};
- return $type . '_' . $o->{aliases}{$stuff[1]};
+ my $cmd = shift; # i.e 'foozle'
+ my $type = shift; # i.e 'run'
+ return () unless $type;
+ return ($cmd, $cmd, $o->{handlers}{$cmd}{$type})
+ unless exists $o->{aliases}{$cmd};
+ my $alias = $o->{aliases}{$cmd};
+ # I'm allowing aliases to call handlers which have been removed. This
+ # means I can set up an alias of '!' for 'shell', then delete the 'shell'
+ # command, so that you can only access it through '!'. That's why I'm
+ # checking the {handlers} entry _and_ building a string.
+ my $handler = $o->{handlers}{$alias}{$type} || "${type}_${alias}";
+ return ($cmd, $alias, $handler);
}
sub find_handlers {
@@ -526,54 +819,6 @@
}
#=============================================================================
-# Manually add & remove handlers
-#=============================================================================
-sub add_handlers {
- my $o = shift;
- for my $hnd (@_) {
- next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
- my $t = $1;
- my $a = substr($hnd, length($t) + 1);
- # Add on the prefix and suffix if the command is defined
- if (length $a) {
- substr($a, 0, 0) = $o->cmd_prefix;
- $a .= $o->cmd_suffix;
- }
- $o->{handlers}{$a}{$t} = $hnd;
- if ($o->has_aliases($a)) {
- my @a = $o->get_aliases($a);
- for my $alias (@a) {
- substr($alias, 0, 0) = $o->cmd_prefix;
- $alias .= $o->cmd_suffix;
- $o->{handlers}{$alias}{$t} = $hnd;
- }
- }
- }
-}
-
-sub remove_handlers {
- my $o = shift;
- for my $hnd (@_) {
- next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
- my $t = $1;
- my $a = substr($hnd, length($t) + 1);
- # Add on the prefix and suffix if the command is defined
- if (length $a) {
- substr($a, 0, 0) = $o->cmd_prefix;
- $a .= $o->cmd_suffix;
- }
- delete $o->{handlers}{$a}{$t};
- }
-}
-
-sub remove_commands {
- my $o = shift;
- for my $name (@_) {
- delete $o->{handlers}{$name};
- }
-}
-
-#=============================================================================
# Two action handlers provided by default: help and exit.
#=============================================================================
sub smry_exit { "exits the program" }
@@ -598,7 +843,7 @@
my @words = $o->line_parsed($line);
return []
if (@words > 2 or @words == 2 and $start == length($line));
- sort $o->possible_actions($word, 'help', 1);
+ sort $o->possible_actions($word, 'help');
}
sub run_help {
my $o = shift;
@@ -609,8 +854,8 @@
$o->page($txt)
}
else {
- my @c = sort $o->possible_actions($cmd, 'help', 1);
- if (@c) {
+ my @c = sort $o->possible_actions($cmd, 'help');
+ if (@c and $o->{API}{match_uniq}) {
local $" = "\n\t";
print <<END;
Ambiguous help topic '$cmd': possible help topics:
@@ -633,9 +878,7 @@
next unless length($h);
next unless grep{defined$o->{handlers}{$h}{$_}} qw(run smry help);
my $dest = exists $o->{handlers}{$h}{run} ? \%cmds : \%docs;
- my $smry = exists $o->{handlers}{$h}{smry}
- ? $o->summary($h)
- : "undocumented";
+ my $smry = do { my $x = $o->summary($h); $x ? $x : "undocumented" };
my $help = exists $o->{handlers}{$h}{help}
? (exists $o->{handlers}{$h}{smry}
? ""
@@ -643,20 +886,23 @@
: " - no help available";
$dest->{" $h"} = "$smry$help";
}
- print " Commands:\n" if %cmds;
- $o->print_pairs(
+ my @t;
+ push @t, " Commands:\n" if %cmds;
+ push @t, scalar $o->format_pairs(
[sort keys %cmds], [map {$cmds{$_}} sort keys %cmds], ' - ', 1
);
- print " Extra Help Topics: (not commands)\n" if %docs;
- $o->print_pairs(
+ push @t, " Extra Help Topics: (not commands)\n" if %docs;
+ push @t, scalar $o->format_pairs(
[sort keys %docs], [map {$docs{$_}} sort keys %docs], ' - ', 1
);
- }
-}
-
+ $o->page(join '', @t);
+ }
+}
+
+sub run_ { }
sub comp_ {
my ($o, $word, $line, $start) = @_;
- my @comp = grep { length($_) } sort $o->possible_actions($word, 'run', 1);
+ my @comp = grep { length($_) } sort $o->possible_actions($word, 'run');
return @comp;
}
Modified: trunk/libterm-shell-perl/debian/changelog
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/debian/changelog?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/debian/changelog (original)
+++ trunk/libterm-shell-perl/debian/changelog Tue Oct 9 16:39:05 2007
@@ -1,3 +1,18 @@
+libterm-shell-perl (0.02-2) unstable; urgency=low
+
+ * New maintainer: Debian Perl Group
+ * minor packaging clean ups, linda and lintian clean
+
+ -- Peter Makholm <peter at makholm.net> Tue, 09 Oct 2007 16:36:58 +0000
+
+libterm-shell-perl (0.02-1) unstable; urgency=low
+
+ * New upstream (Closes: #433830)
+ Fixes CPAN bug #2463 (Closes: #438389)
+ * build with cdbs
+
+ -- Peter Makholm <peter at makholm.net> Fri, 31 Aug 2007 16:58:35 +0000
+
libterm-shell-perl (0.01-3) unstable; urgency=low
* Acknowleding NMU, thanks to Aurelien Jarno for making it.
Added: trunk/libterm-shell-perl/debian/compat
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/debian/compat?rev=8135&op=file
==============================================================================
--- trunk/libterm-shell-perl/debian/compat (added)
+++ trunk/libterm-shell-perl/debian/compat Tue Oct 9 16:39:05 2007
@@ -1,0 +1,1 @@
+5
Modified: trunk/libterm-shell-perl/debian/control
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/debian/control?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/debian/control (original)
+++ trunk/libterm-shell-perl/debian/control Tue Oct 9 16:39:05 2007
@@ -1,15 +1,19 @@
Source: libterm-shell-perl
-Section: interpreters
+Section: perl
Priority: optional
-Maintainer: Peter Makholm <peter at makholm.net>
-Build-Depends-Indep: debhelper (>> 3.0.0), perl (>= 5.6.0-16)
-Standards-Version: 3.5.2
+Maintainer: Debian Perl Group <pkg-perl-maintainers at lists.alioth.debian.org>
+Uploaders: Peter Makholm <peter at makholm.net>
+Build-Depends: debhelper (>> 5), cdbs
+Build-Depends-Indep: perl (>= 5.6.0-16)
+Standards-Version: 3.7.2
+XS-Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libterm-shell-perl/
+XS-Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libterm-shell-perl/
Package: libterm-shell-perl
Architecture: all
Depends: ${perl:Depends}
Recommends: libterm-readline-perl-perl | libterm-readline-gnu-perl
-Description: Perl module for writing shell-like interfaces.
+Description: Perl module for writing shell-like interfaces
Term::Shell makes it joyfully easy to write command-line interfaces in Perl.
All the boring details like command-line parsing and terminal handling are
done for you.
Modified: trunk/libterm-shell-perl/debian/copyright
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/debian/copyright?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/debian/copyright (original)
+++ trunk/libterm-shell-perl/debian/copyright Tue Oct 9 16:39:05 2007
@@ -3,7 +3,7 @@
It was downloaded from http://www.cpan.org/CPAN/modules/by-name/Term/
-Upstream Author(s): Neil Watkiss (NEILW at cpan.org)
+Upstream Author: Neil Watkiss (NEILW at cpan.org)
Copyright:
Modified: trunk/libterm-shell-perl/debian/rules
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/debian/rules?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/debian/rules (original)
+++ trunk/libterm-shell-perl/debian/rules Tue Oct 9 16:39:05 2007
@@ -1,67 +1,8 @@
#!/usr/bin/make -f
-# Sample debian/rules that uses debhelper.
-# GNU copyright 1997 to 1999 by Joey Hess.
-# Uncomment this to turn on verbose mode.
-#export DH_VERBOSE=1
+export LC_ALL=C
-# This is the debhelper compatability version to use.
-export DH_COMPAT=3
+# Put perlmodule.mk last to dh_clean temporary files not in MANIFEST
+include /usr/share/cdbs/1/rules/debhelper.mk
+include /usr/share/cdbs/1/class/perlmodule.mk
-configure: configure-stamp
-configure-stamp:
- dh_testdir
- # Add here commands to configure the package.
-
-
- touch configure-stamp
-
-build: build-stamp
-
-build-stamp: configure-stamp
- dh_testdir
-
- perl Makefile.PL INSTALLDIRS=vendor
- $(MAKE) OPTIMIZE="-O2 -g -Wall"
-
-clean:
- dh_testdir
- dh_testroot
- rm -f build-stamp configure-stamp
-
- # Add here commands to clean up after the build process.
- -$(MAKE) clean
-
- dh_clean
-
-install: build
- dh_testdir
- dh_testroot
- dh_clean -k
- dh_installdirs
-
- $(MAKE) install PREFIX=$(CURDIR)/debian/tmp/usr
-
-# Build architecture-dependent files here.
-binary-arch: build install
- dh_testdir
- dh_testroot
- dh_installdocs
- dh_installexamples
- dh_installman
- dh_installchangelogs Changes
- dh_movefiles
- dh_compress
- dh_fixperms
- dh_installdeb
- dh_perl
- dh_shlibdeps
- dh_gencontrol
- dh_md5sums
- dh_builddeb
-
-# Build architecture-independent files here.
-binary-indep: build install
-
-binary: binary-indep binary-arch
-.PHONY: build clean binary-indep binary-arch binary install configure
Modified: trunk/libterm-shell-perl/lib/Term/Shell.pod
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/lib/Term/Shell.pod?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/lib/Term/Shell.pod (original)
+++ trunk/libterm-shell-perl/lib/Term/Shell.pod Tue Oct 9 16:39:05 2007
@@ -618,10 +618,6 @@
Prints C<$txt> through a pager, prompting the user to press a key for the next
screen full of text.
-Currently, this just prints out the text without any paging at all. The next
-version will have an internal pager, plus the ability to use an external
-pager. See L<BUGS AND DEFICIENCIES>.
-
=item 13
line()
@@ -976,19 +972,7 @@
=head1 BUGS AND DEFICIENCIES
-There are bound to be some bugs lurking about. Here are the things I know I
-haven't done:
-
-=over 4
-
-=item 1
-
-page()
-
-Currently page() just prints its text to the screen. This should really, um,
-page the text, either through an external program or by itself.
-
-=back
+There are bound to be some bugs lurking about.
If you find bugs, please send them to C<NEILW at cpan.org>.
Modified: trunk/libterm-shell-perl/t/02default.t
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/t/02default.t?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/t/02default.t (original)
+++ trunk/libterm-shell-perl/t/02default.t Tue Oct 9 16:39:05 2007
@@ -24,11 +24,11 @@
$cmds = [$shell->possible_actions('e', 'run')];
ok(ref($cmds), 'ARRAY');
ok($#$cmds, 0);
-ok($cmds->[0], 'run_exit');
+ok($cmds->[0], 'exit');
$cmds = [$shell->possible_actions('h', 'run')];
ok($#$cmds, 0);
-ok($cmds->[0], 'run_help');
+ok($cmds->[0], 'help');
$cmds = [$shell->possible_actions('c', 'run')];
ok($#$cmds, 1);
@@ -38,12 +38,12 @@
#=============================================================================
$cmds = [$shell->possible_actions('e', 'help')];
ok($#$cmds, 0);
-ok($cmds->[0], 'help_exit');
+ok($cmds->[0], 'exit');
$cmds = [$shell->possible_actions('h', 'help')];
ok($#$cmds, 0);
-ok($cmds->[0], 'help_help');
+ok($cmds->[0], 'help');
$cmds = [$shell->possible_actions('c', 'help')];
ok($#$cmds, 0);
-ok($cmds->[0], 'help_command1');
+ok($cmds->[0], 'command1');
Added: trunk/libterm-shell-perl/t/03catchsmry.t
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/t/03catchsmry.t?rev=8135&op=file
==============================================================================
--- trunk/libterm-shell-perl/t/03catchsmry.t (added)
+++ trunk/libterm-shell-perl/t/03catchsmry.t Tue Oct 9 16:39:05 2007
@@ -1,0 +1,39 @@
+use strict;
+use Test::More tests => 1;
+
+require Term::Shell;
+
+{
+ package Term::Shell::Test;
+ use base 'Term::Shell';
+ sub summary {
+ my $self = shift;
+ $::called = 1;
+ $self->SUPER::summary(@_);
+ };
+ sub run_fuzz { }
+};
+
+my $sh = Term::Shell::Test->new;
+
+{
+ $sh->run_help;
+};
+
+unless (is($::called, 1, "catch_smry gets called for unknown methods"))
+{
+ diag "Term::Shell did not call a custom catch_smry handler";
+ diag "This is most likely because your version of Term::Shell";
+ diag "has a bug. Please upgrade to v0.02 or higher, which";
+ diag "should close this bug.";
+ diag "If that is no option, patch sub help() in Term/Shell.pm, line 641ff.";
+ diag "to:";
+ diag ' #my $smry = exists $o->{handlers}{$h}{smry};';
+ diag ' #? $o->summary($h);';
+ diag ' #: "undocumented";';
+ diag ' my $smry = $o->summary($h);';
+ diag 'Fixing this is not necessary - you will get no online help';
+ diag 'but the shell will otherwise work fine. Help is still';
+ diag 'available through ``perldoc WWW::Mechanize::Shell``';
+};
+
Modified: trunk/libterm-shell-perl/test.pl
URL: http://svn.debian.org/wsvn/trunk/libterm-shell-perl/test.pl?rev=8135&op=diff
==============================================================================
--- trunk/libterm-shell-perl/test.pl (original)
+++ trunk/libterm-shell-perl/test.pl Tue Oct 9 16:39:05 2007
@@ -92,7 +92,8 @@
package main;
-if ($ENV{TEST_INTERACTIVE} or not exists $ENV{MAKELEVEL}) {
+if ($ENV{TEST_INTERACTIVE} or not (exists $ENV{MAKELEVEL} or exists $ENV{__MKLVL__}))
+{
print <<END;
==============================================================================
Type 'help' to see a list of commands or help topics. If your terminal
@@ -102,7 +103,10 @@
Have fun!
==============================================================================
END
- 'app'->new('default')->cmdloop;
+ my $app = app->new('default');
+ my $term = $app->term;
+ warn "Using term $term\n";
+ $app->cmdloop;
}
else {
print <<END;
More information about the Pkg-perl-cvs-commits
mailing list