From 298bdc032f0e1d7084fcdfbe22e78381064ca846 Mon Sep 17 00:00:00 2001 From: Florian Ragwitz Date: Thu, 7 Jul 2011 16:25:15 +0200 Subject: Dual-life Term::ReadLine --- MANIFEST | 4 +- Porting/Maintainers.pl | 9 +- dist/Term-ReadLine/lib/Term/ReadLine.pm | 401 ++++++++++++++++++++++++++++++++ dist/Term-ReadLine/t/ReadLine.t | 32 +++ lib/.gitignore | 1 + lib/Term/ReadLine.pm | 401 -------------------------------- lib/Term/ReadLine.t | 39 ---- t/porting/known_pod_issues.dat | 2 +- 8 files changed, 445 insertions(+), 444 deletions(-) create mode 100644 dist/Term-ReadLine/lib/Term/ReadLine.pm create mode 100644 dist/Term-ReadLine/t/ReadLine.t delete mode 100644 lib/Term/ReadLine.pm delete mode 100644 lib/Term/ReadLine.t diff --git a/MANIFEST b/MANIFEST index d48876e957..842daa3d8c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3266,6 +3266,8 @@ dist/Storable/t/tied.t See if Storable works dist/Storable/t/utf8hash.t See if Storable works dist/Storable/t/utf8.t See if Storable works dist/Storable/t/weak.t Can Storable store weakrefs +dist/Term-ReadLine/lib/Term/ReadLine.pm Stub readline library +dist/Term-ReadLine/t/ReadLine.t See if Term::ReadLine works dist/Text-Abbrev/lib/Text/Abbrev.pm An abbreviation table builder dist/Text-Abbrev/t/Abbrev.t Test Text::Abbrev dist/Thread-Queue/lib/Thread/Queue.pm Thread-safe queues @@ -3995,8 +3997,6 @@ lib/Symbol.pm Symbol table manipulation routines lib/Symbol.t See if Symbol works lib/Term/Complete.pm A command completion subroutine lib/Term/Complete.t See if Term::Complete works -lib/Term/ReadLine.pm Stub readline library -lib/Term/ReadLine.t See if Term::ReadLine works lib/Thread.pm Thread extensions frontend lib/Thread.t Thread extensions frontend tests lib/Tie/Array.pm Base class for tied arrays diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 1b330d29cd..9d1c3a7104 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1718,6 +1718,14 @@ use File::Glob qw(:case); 'UPSTREAM' => undef, }, + 'Term::ReadLine' => + { + 'MAINTAINER' => 'p5p', + 'DISTRIBUTION' => 'FLORA/Term-ReadLine-1.07.tar.gz', + 'FILES' => q[dist/Term-ReadLine], + 'UPSTREAM' => 'blead', + }, + 'Term::UI' => { 'MAINTAINER' => 'kane', @@ -2126,7 +2134,6 @@ use File::Glob qw(:case); lib/SelectSaver.{pm,t} lib/Symbol.{pm,t} lib/Term/Complete.{pm,t} - lib/Term/ReadLine.{pm,t} lib/Thread.{pm,t} lib/Tie/Array.pm lib/Tie/Array/ diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm new file mode 100644 index 0000000000..0121cdfd06 --- /dev/null +++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm @@ -0,0 +1,401 @@ +=head1 NAME + +Term::ReadLine - Perl interface to various C packages. +If no real package is found, substitutes stubs instead of basic functions. + +=head1 SYNOPSIS + + use Term::ReadLine; + my $term = Term::ReadLine->new('Simple Perl calc'); + my $prompt = "Enter your arithmetic expression: "; + my $OUT = $term->OUT || \*STDOUT; + while ( defined ($_ = $term->readline($prompt)) ) { + my $res = eval($_); + warn $@ if $@; + print $OUT $res, "\n" unless $@; + $term->addhistory($_) if /\S/; + } + +=head1 DESCRIPTION + +This package is just a front end to some other packages. It's a stub to +set up a common interface to the various ReadLine implementations found on +CPAN (under the C namespace). + +=head1 Minimal set of supported functions + +All the supported functions should be called as methods, i.e., either as + + $term = Term::ReadLine->new('name'); + +or as + + $term->addhistory('row'); + +where $term is a return value of Term::ReadLine-Enew(). + +=over 12 + +=item C + +returns the actual package that executes the commands. Among possible +values are C, C, +C. + +=item C + +returns the handle for subsequent calls to following +functions. Argument is the name of the application. Optionally can be +followed by two arguments for C and C filehandles. These +arguments should be globs. + +=item C + +gets an input line, I with actual C +support. Trailing newline is removed. Returns C on C. + +=item C + +adds the line to the history of input, from where it can be used if +the actual C is present. + +=item C, C + +return the filehandles for input and output or C if C +input and output cannot be used for Perl. + +=item C + +If argument is specified, it is an advice on minimal size of line to +be included into history. C means do not include anything into +history. Returns the old value. + +=item C + +returns an array with two strings that give most appropriate names for +files for input and output using conventions C<"E$in">, C<"Eout">. + +=item Attribs + +returns a reference to a hash which describes internal configuration +of the package. Names of keys in this hash conform to standard +conventions with the leading C stripped. + +=item C + +Returns a reference to a hash with keys being features present in +current implementation. Several optional features are used in the +minimal interface: C should be present if the first argument +to C is recognized, and C should be present if +C method is not dummy. C should be present if +lines are put into history automatically (maybe subject to +C), and C if C method is not dummy. + +If C method reports a feature C as present, the +method C is not dummy. + +=back + +=head1 Additional supported functions + +Actually C can use some other package, that will +support a richer set of commands. + +All these commands are callable via method interface and have names +which conform to standard conventions with the leading C stripped. + +The stub package included with the perl distribution allows some +additional methods: + +=over 12 + +=item C + +makes Tk event loop run when waiting for user input (i.e., during +C method). + +=item C + +makes the command line stand out by using termcap data. The argument +to C should be 0, 1, or a string of a form +C<"aa,bb,cc,dd">. Four components of this string should be names of +I, first two will be issued to make the prompt +standout, last two to make the input line standout. + +=item C + +takes two arguments which are input filehandle and output filehandle. +Switches to use these filehandles. + +=back + +One can check whether the currently loaded ReadLine package supports +these methods by checking for corresponding C. + +=head1 EXPORTS + +None + +=head1 ENVIRONMENT + +The environment variable C governs which ReadLine clone is +loaded. If the value is false, a dummy interface is used. If the value +is true, it should be tail of the name of the package to use, such as +C or C. + +As a special case, if the value of this variable is space-separated, +the tail might be used to disable the ornaments by setting the tail to +be C or C. The head should be as described above, say + +If the variable is not set, or if the head of space-separated list is +empty, the best available package is loaded. + + export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments + export "PERL_RL= o=0" # Use best available ReadLine without ornaments + +(Note that processing of C for ornaments is in the discretion of the +particular used C package). + +=cut + +use strict; + +package Term::ReadLine::Stub; +our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; + +$DB::emacs = $DB::emacs; # To peacify -w +our @rl_term_set; +*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; + +sub PERL_UNICODE_STDIN () { 0x0001 } + +sub ReadLine {'Term::ReadLine::Stub'} +sub readline { + my $self = shift; + my ($in,$out,$str) = @$self; + my $prompt = shift; + print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; + $self->register_Tk + if not $Term::ReadLine::registered and $Term::ReadLine::toloop + and defined &Tk::DoOneEvent; + #$str = scalar <$in>; + $str = $self->get_line; + utf8::upgrade($str) + if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) && + utf8::valid($str); + print $out $rl_term_set[3]; + # bug in 5.000: chomping empty string creats length -1: + chomp $str if defined $str; + $str; +} +sub addhistory {} + +sub findConsole { + my $console; + my $consoleOUT; + + if (-e "/dev/tty") { + $console = "/dev/tty"; + } elsif (-e "con" or $^O eq 'MSWin32') { + $console = 'CONIN$'; + $consoleOUT = 'CONOUT$'; + } else { + $console = "sys\$command"; + } + + if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) { + $console = undef; + } + elsif ($^O eq 'os2') { + if ($DB::emacs) { + $console = undef; + } else { + $console = "/dev/con"; + } + } + + $consoleOUT = $console unless defined $consoleOUT; + $console = "&STDIN" unless defined $console; + if ($console eq "/dev/tty" && !open(my $fh, "<", $console)) { + $console = "&STDIN"; + undef($consoleOUT); + } + if (!defined $consoleOUT) { + $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT"; + } + ($console,$consoleOUT); +} + +sub new { + die "method new called with wrong number of arguments" + unless @_==2 or @_==4; + #local (*FIN, *FOUT); + my ($FIN, $FOUT, $ret); + if (@_==2) { + my($console, $consoleOUT) = $_[0]->findConsole; + + + # the Windows CONIN$ needs GENERIC_WRITE mode to allow + # a SetConsoleMode() if we end up using Term::ReadKey + open FIN, ( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" : + "<$console"; + open FOUT,">$consoleOUT"; + + #OUT->autoflush(1); # Conflicts with debugger? + my $sel = select(FOUT); + $| = 1; # for DB::OUT + select($sel); + $ret = bless [\*FIN, \*FOUT]; + } else { # Filehandles supplied + $FIN = $_[2]; $FOUT = $_[3]; + #OUT->autoflush(1); # Conflicts with debugger? + my $sel = select($FOUT); + $| = 1; # for DB::OUT + select($sel); + $ret = bless [$FIN, $FOUT]; + } + if ($ret->Features->{ornaments} + and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) { + local $Term::ReadLine::termcap_nowarn = 1; + $ret->ornaments(1); + } + return $ret; +} + +sub newTTY { + my ($self, $in, $out) = @_; + $self->[0] = $in; + $self->[1] = $out; + my $sel = select($out); + $| = 1; # for DB::OUT + select($sel); +} + +sub IN { shift->[0] } +sub OUT { shift->[1] } +sub MinLine { undef } +sub Attribs { {} } + +my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1); +sub Features { \%features } + +sub get_line { + my $self = shift; + my $in = $self->IN; + local ($/) = "\n"; + return scalar <$in>; +} + +package Term::ReadLine; # So late to allow the above code be defined? + +our $VERSION = '1.07'; + +my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; +if ($which) { + if ($which =~ /\bgnu\b/i){ + eval "use Term::ReadLine::Gnu;"; + } elsif ($which =~ /\bperl\b/i) { + eval "use Term::ReadLine::Perl;"; + } elsif ($which =~ /^(Stub|TermCap|Tk)$/) { + # it is already in memory to avoid false exception as seen in: + # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine' + } else { + eval "use Term::ReadLine::$which;"; + } +} elsif (defined $which and $which ne '') { # Defined but false + # Do nothing fancy +} else { + eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1"; +} + +#require FileHandle; + +# To make possible switch off RL in debugger: (Not needed, work done +# in debugger). +our @ISA; +if (defined &Term::ReadLine::Gnu::readline) { + @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub); +} elsif (defined &Term::ReadLine::Perl::readline) { + @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub); +} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) { + @ISA = "Term::ReadLine::$which"; +} else { + @ISA = qw(Term::ReadLine::Stub); +} + +package Term::ReadLine::TermCap; + +# Prompt-start, prompt-end, command-line-start, command-line-end +# -- zero-width beautifies to emit around prompt and the command line. +our @rl_term_set = ("","","",""); +# string encoded: +our $rl_term_set = ',,,'; + +our $terminal; +sub LoadTermCap { + return if defined $terminal; + + require Term::Cap; + $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. +} + +sub ornaments { + shift; + return $rl_term_set unless @_; + $rl_term_set = shift; + $rl_term_set ||= ',,,'; + $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1'; + my @ts = split /,/, $rl_term_set, 4; + eval { LoadTermCap }; + unless (defined $terminal) { + warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn; + $rl_term_set = ',,,'; + return; + } + @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts; + return $rl_term_set; +} + + +package Term::ReadLine::Tk; + +our($count_handle, $count_DoOne, $count_loop); +$count_handle = $count_DoOne = $count_loop = 0; + +our($giveup); +sub handle {$giveup = 1; $count_handle++} + +sub Tk_loop { + # Tk->tkwait('variable',\$giveup); # needs Widget + $count_DoOne++, Tk::DoOneEvent(0) until $giveup; + $count_loop++; + $giveup = 0; +} + +sub register_Tk { + my $self = shift; + $Term::ReadLine::registered++ + or Tk->fileevent($self->IN,'readable',\&handle); +} + +sub tkRunning { + $Term::ReadLine::toloop = $_[1] if @_ > 1; + $Term::ReadLine::toloop; +} + +sub get_c { + my $self = shift; + $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; + return getc $self->IN; +} + +sub get_line { + my $self = shift; + $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; + my $in = $self->IN; + local ($/) = "\n"; + return scalar <$in>; +} + +1; + diff --git a/dist/Term-ReadLine/t/ReadLine.t b/dist/Term-ReadLine/t/ReadLine.t new file mode 100644 index 0000000000..6c21deac5c --- /dev/null +++ b/dist/Term-ReadLine/t/ReadLine.t @@ -0,0 +1,32 @@ +#!./perl -w +use strict; + +package Term::ReadLine::Mock; +our @ISA = 'Term::ReadLine::Stub'; +sub ReadLine {'Term::ReadLine::Mock'}; +sub readline { "a line" } +sub new { bless {} } + +package main; + +use Test::More tests => 15; + +BEGIN { + $ENV{PERL_RL} = 'Mock'; # test against our instrumented class + use_ok('Term::ReadLine'); +} + +my $t = new Term::ReadLine 'test term::readline'; + +ok($t, "made something"); + +isa_ok($t, 'Term::ReadLine::Mock'); + +for my $method (qw( ReadLine readline addhistory IN OUT MinLine + findConsole Attribs Features new ) ) { + can_ok($t, $method); +} + +is($t->ReadLine, 'Term::ReadLine::Mock', "\$object->ReadLine"); +is($t->readline, 'a line', "\$object->readline"); + diff --git a/lib/.gitignore b/lib/.gitignore index 96884a3164..bf848f29d2 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -346,6 +346,7 @@ /Term/Cap.pm /Term/UI.pm /Term/UI/History.pm +/Term/ReadLine.pm /Test.pm /Test/Builder /Test/Builder.pm diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm deleted file mode 100644 index 0121cdfd06..0000000000 --- a/lib/Term/ReadLine.pm +++ /dev/null @@ -1,401 +0,0 @@ -=head1 NAME - -Term::ReadLine - Perl interface to various C packages. -If no real package is found, substitutes stubs instead of basic functions. - -=head1 SYNOPSIS - - use Term::ReadLine; - my $term = Term::ReadLine->new('Simple Perl calc'); - my $prompt = "Enter your arithmetic expression: "; - my $OUT = $term->OUT || \*STDOUT; - while ( defined ($_ = $term->readline($prompt)) ) { - my $res = eval($_); - warn $@ if $@; - print $OUT $res, "\n" unless $@; - $term->addhistory($_) if /\S/; - } - -=head1 DESCRIPTION - -This package is just a front end to some other packages. It's a stub to -set up a common interface to the various ReadLine implementations found on -CPAN (under the C namespace). - -=head1 Minimal set of supported functions - -All the supported functions should be called as methods, i.e., either as - - $term = Term::ReadLine->new('name'); - -or as - - $term->addhistory('row'); - -where $term is a return value of Term::ReadLine-Enew(). - -=over 12 - -=item C - -returns the actual package that executes the commands. Among possible -values are C, C, -C. - -=item C - -returns the handle for subsequent calls to following -functions. Argument is the name of the application. Optionally can be -followed by two arguments for C and C filehandles. These -arguments should be globs. - -=item C - -gets an input line, I with actual C -support. Trailing newline is removed. Returns C on C. - -=item C - -adds the line to the history of input, from where it can be used if -the actual C is present. - -=item C, C - -return the filehandles for input and output or C if C -input and output cannot be used for Perl. - -=item C - -If argument is specified, it is an advice on minimal size of line to -be included into history. C means do not include anything into -history. Returns the old value. - -=item C - -returns an array with two strings that give most appropriate names for -files for input and output using conventions C<"E$in">, C<"Eout">. - -=item Attribs - -returns a reference to a hash which describes internal configuration -of the package. Names of keys in this hash conform to standard -conventions with the leading C stripped. - -=item C - -Returns a reference to a hash with keys being features present in -current implementation. Several optional features are used in the -minimal interface: C should be present if the first argument -to C is recognized, and C should be present if -C method is not dummy. C should be present if -lines are put into history automatically (maybe subject to -C), and C if C method is not dummy. - -If C method reports a feature C as present, the -method C is not dummy. - -=back - -=head1 Additional supported functions - -Actually C can use some other package, that will -support a richer set of commands. - -All these commands are callable via method interface and have names -which conform to standard conventions with the leading C stripped. - -The stub package included with the perl distribution allows some -additional methods: - -=over 12 - -=item C - -makes Tk event loop run when waiting for user input (i.e., during -C method). - -=item C - -makes the command line stand out by using termcap data. The argument -to C should be 0, 1, or a string of a form -C<"aa,bb,cc,dd">. Four components of this string should be names of -I, first two will be issued to make the prompt -standout, last two to make the input line standout. - -=item C - -takes two arguments which are input filehandle and output filehandle. -Switches to use these filehandles. - -=back - -One can check whether the currently loaded ReadLine package supports -these methods by checking for corresponding C. - -=head1 EXPORTS - -None - -=head1 ENVIRONMENT - -The environment variable C governs which ReadLine clone is -loaded. If the value is false, a dummy interface is used. If the value -is true, it should be tail of the name of the package to use, such as -C or C. - -As a special case, if the value of this variable is space-separated, -the tail might be used to disable the ornaments by setting the tail to -be C or C. The head should be as described above, say - -If the variable is not set, or if the head of space-separated list is -empty, the best available package is loaded. - - export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments - export "PERL_RL= o=0" # Use best available ReadLine without ornaments - -(Note that processing of C for ornaments is in the discretion of the -particular used C package). - -=cut - -use strict; - -package Term::ReadLine::Stub; -our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; - -$DB::emacs = $DB::emacs; # To peacify -w -our @rl_term_set; -*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; - -sub PERL_UNICODE_STDIN () { 0x0001 } - -sub ReadLine {'Term::ReadLine::Stub'} -sub readline { - my $self = shift; - my ($in,$out,$str) = @$self; - my $prompt = shift; - print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; - $self->register_Tk - if not $Term::ReadLine::registered and $Term::ReadLine::toloop - and defined &Tk::DoOneEvent; - #$str = scalar <$in>; - $str = $self->get_line; - utf8::upgrade($str) - if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) && - utf8::valid($str); - print $out $rl_term_set[3]; - # bug in 5.000: chomping empty string creats length -1: - chomp $str if defined $str; - $str; -} -sub addhistory {} - -sub findConsole { - my $console; - my $consoleOUT; - - if (-e "/dev/tty") { - $console = "/dev/tty"; - } elsif (-e "con" or $^O eq 'MSWin32') { - $console = 'CONIN$'; - $consoleOUT = 'CONOUT$'; - } else { - $console = "sys\$command"; - } - - if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) { - $console = undef; - } - elsif ($^O eq 'os2') { - if ($DB::emacs) { - $console = undef; - } else { - $console = "/dev/con"; - } - } - - $consoleOUT = $console unless defined $consoleOUT; - $console = "&STDIN" unless defined $console; - if ($console eq "/dev/tty" && !open(my $fh, "<", $console)) { - $console = "&STDIN"; - undef($consoleOUT); - } - if (!defined $consoleOUT) { - $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT"; - } - ($console,$consoleOUT); -} - -sub new { - die "method new called with wrong number of arguments" - unless @_==2 or @_==4; - #local (*FIN, *FOUT); - my ($FIN, $FOUT, $ret); - if (@_==2) { - my($console, $consoleOUT) = $_[0]->findConsole; - - - # the Windows CONIN$ needs GENERIC_WRITE mode to allow - # a SetConsoleMode() if we end up using Term::ReadKey - open FIN, ( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" : - "<$console"; - open FOUT,">$consoleOUT"; - - #OUT->autoflush(1); # Conflicts with debugger? - my $sel = select(FOUT); - $| = 1; # for DB::OUT - select($sel); - $ret = bless [\*FIN, \*FOUT]; - } else { # Filehandles supplied - $FIN = $_[2]; $FOUT = $_[3]; - #OUT->autoflush(1); # Conflicts with debugger? - my $sel = select($FOUT); - $| = 1; # for DB::OUT - select($sel); - $ret = bless [$FIN, $FOUT]; - } - if ($ret->Features->{ornaments} - and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) { - local $Term::ReadLine::termcap_nowarn = 1; - $ret->ornaments(1); - } - return $ret; -} - -sub newTTY { - my ($self, $in, $out) = @_; - $self->[0] = $in; - $self->[1] = $out; - my $sel = select($out); - $| = 1; # for DB::OUT - select($sel); -} - -sub IN { shift->[0] } -sub OUT { shift->[1] } -sub MinLine { undef } -sub Attribs { {} } - -my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1); -sub Features { \%features } - -sub get_line { - my $self = shift; - my $in = $self->IN; - local ($/) = "\n"; - return scalar <$in>; -} - -package Term::ReadLine; # So late to allow the above code be defined? - -our $VERSION = '1.07'; - -my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; -if ($which) { - if ($which =~ /\bgnu\b/i){ - eval "use Term::ReadLine::Gnu;"; - } elsif ($which =~ /\bperl\b/i) { - eval "use Term::ReadLine::Perl;"; - } elsif ($which =~ /^(Stub|TermCap|Tk)$/) { - # it is already in memory to avoid false exception as seen in: - # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine' - } else { - eval "use Term::ReadLine::$which;"; - } -} elsif (defined $which and $which ne '') { # Defined but false - # Do nothing fancy -} else { - eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1"; -} - -#require FileHandle; - -# To make possible switch off RL in debugger: (Not needed, work done -# in debugger). -our @ISA; -if (defined &Term::ReadLine::Gnu::readline) { - @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub); -} elsif (defined &Term::ReadLine::Perl::readline) { - @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub); -} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) { - @ISA = "Term::ReadLine::$which"; -} else { - @ISA = qw(Term::ReadLine::Stub); -} - -package Term::ReadLine::TermCap; - -# Prompt-start, prompt-end, command-line-start, command-line-end -# -- zero-width beautifies to emit around prompt and the command line. -our @rl_term_set = ("","","",""); -# string encoded: -our $rl_term_set = ',,,'; - -our $terminal; -sub LoadTermCap { - return if defined $terminal; - - require Term::Cap; - $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. -} - -sub ornaments { - shift; - return $rl_term_set unless @_; - $rl_term_set = shift; - $rl_term_set ||= ',,,'; - $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1'; - my @ts = split /,/, $rl_term_set, 4; - eval { LoadTermCap }; - unless (defined $terminal) { - warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn; - $rl_term_set = ',,,'; - return; - } - @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts; - return $rl_term_set; -} - - -package Term::ReadLine::Tk; - -our($count_handle, $count_DoOne, $count_loop); -$count_handle = $count_DoOne = $count_loop = 0; - -our($giveup); -sub handle {$giveup = 1; $count_handle++} - -sub Tk_loop { - # Tk->tkwait('variable',\$giveup); # needs Widget - $count_DoOne++, Tk::DoOneEvent(0) until $giveup; - $count_loop++; - $giveup = 0; -} - -sub register_Tk { - my $self = shift; - $Term::ReadLine::registered++ - or Tk->fileevent($self->IN,'readable',\&handle); -} - -sub tkRunning { - $Term::ReadLine::toloop = $_[1] if @_ > 1; - $Term::ReadLine::toloop; -} - -sub get_c { - my $self = shift; - $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; - return getc $self->IN; -} - -sub get_line { - my $self = shift; - $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; - my $in = $self->IN; - local ($/) = "\n"; - return scalar <$in>; -} - -1; - diff --git a/lib/Term/ReadLine.t b/lib/Term/ReadLine.t deleted file mode 100644 index a3d57564f6..0000000000 --- a/lib/Term/ReadLine.t +++ /dev/null @@ -1,39 +0,0 @@ -#!./perl -w -use strict; - -BEGIN { - if ( $ENV{PERL_CORE} ) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -package Term::ReadLine::Mock; -our @ISA = 'Term::ReadLine::Stub'; -sub ReadLine {'Term::ReadLine::Mock'}; -sub readline { "a line" } -sub new { bless {} } - -package main; - -use Test::More tests => 15; - -BEGIN { - $ENV{PERL_RL} = 'Mock'; # test against our instrumented class - use_ok('Term::ReadLine'); -} - -my $t = new Term::ReadLine 'test term::readline'; - -ok($t, "made something"); - -isa_ok($t, 'Term::ReadLine::Mock'); - -for my $method (qw( ReadLine readline addhistory IN OUT MinLine - findConsole Attribs Features new ) ) { - can_ok($t, $method); -} - -is($t->ReadLine, 'Term::ReadLine::Mock', "\$object->ReadLine"); -is($t->readline, 'a line', "\$object->readline"); - diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index 7d8cb0389f..4b85fe6edb 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -170,6 +170,7 @@ dist/safe/safe.pm Verbatim line length including indents exceeds 80 by 1 dist/safe/safe.pm empty section in previous paragraph 1 dist/selfloader/lib/selfloader.pm Verbatim line length including indents exceeds 80 by 14 dist/storable/storable.pm Verbatim line length including indents exceeds 80 by 4 +dist/term-readline/lib/term/readline.pm Verbatim line length including indents exceeds 80 by 1 dist/thread-queue/lib/thread/queue.pm Verbatim line length including indents exceeds 80 by 4 dist/threads/lib/threads.pm Verbatim line length including indents exceeds 80 by 3 ext/b/b.pm Verbatim line length including indents exceeds 80 by 1 @@ -336,7 +337,6 @@ lib/file/find.pm Verbatim line length including indents exceeds 80 by 1 lib/getopt/std.pm Verbatim line length including indents exceeds 80 by 1 lib/perlio.pm Verbatim line length including indents exceeds 80 by 2 lib/pod/text/overstrike.pm Verbatim line length including indents exceeds 80 by 1 -lib/term/readline.pm Verbatim line length including indents exceeds 80 by 1 lib/tie/array.pm Verbatim line length including indents exceeds 80 by 1 lib/tie/hash.pm Verbatim line length including indents exceeds 80 by 3 lib/tie/scalar.pm Verbatim line length including indents exceeds 80 by 1 -- cgit v1.2.1