In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/0d36d0d16019b19d12916066a99b75d5a59dd3dd?hp=a6bf7a5c6762f0da58cf810c3e2dd2949dd4fa92>
- Log ----------------------------------------------------------------- commit 0d36d0d16019b19d12916066a99b75d5a59dd3dd Author: Ricardo Signes <[email protected]> Date: Sat Mar 10 16:21:49 2012 -0500 avoid some long-line errors in podcheck of Term-Readline M dist/Term-ReadLine/lib/Term/ReadLine.pm M t/porting/known_pod_issues.dat commit de6726c1fe3fc629fd22244082eae5f5b8552283 Author: Ricardo Signes <[email protected]> Date: Sat Mar 10 12:14:42 2012 -0500 new patch for Term::ReadLine event loop support https://rt.perl.org/rt3/Ticket/Display.html?id=108470 This is more work from Darin McBride and Rocco Caputo to get the event loop code offered earlier working, tested, and documented. M MANIFEST M dist/Term-ReadLine/lib/Term/ReadLine.pm A dist/Term-ReadLine/t/AE.t A dist/Term-ReadLine/t/AETk.t D dist/Term-ReadLine/t/TkExternal.t ----------------------------------------------------------------------- Summary of changes: MANIFEST | 3 +- dist/Term-ReadLine/lib/Term/ReadLine.pm | 170 ++++++++++++++++++------------- dist/Term-ReadLine/t/AE.t | 43 ++++++++ dist/Term-ReadLine/t/AETk.t | 52 ++++++++++ dist/Term-ReadLine/t/TkExternal.t | 59 ----------- ext/Pod-Html/lib/Pod/Html.pm | 9 ++ ext/Pod-Html/t/pod2html-lib.pl | 10 +- t/porting/known_pod_issues.dat | 3 +- 8 files changed, 211 insertions(+), 138 deletions(-) create mode 100644 dist/Term-ReadLine/t/AE.t create mode 100644 dist/Term-ReadLine/t/AETk.t delete mode 100644 dist/Term-ReadLine/t/TkExternal.t diff --git a/MANIFEST b/MANIFEST index 92efe61..449b590 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3479,8 +3479,9 @@ dist/Storable/t/weak.t Can Storable store weakrefs dist/Term-Complete/lib/Term/Complete.pm A command completion subroutine dist/Term-Complete/t/Complete.t See if Term::Complete works dist/Term-ReadLine/lib/Term/ReadLine.pm Stub readline library +dist/Term-ReadLine/t/AE.t See if Term::ReadLine works +dist/Term-ReadLine/t/AETk.t See if Term::ReadLine works dist/Term-ReadLine/t/ReadLine.t See if Term::ReadLine works -dist/Term-ReadLine/t/TkExternal.t Test Tk dist/Term-ReadLine/t/Tk.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 diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm index 7262596..f1b1419 100644 --- a/dist/Term-ReadLine/lib/Term/ReadLine.pm +++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm @@ -111,12 +111,48 @@ additional methods: =item C<tkRunning> -makes Tk's event loop run when waiting for user input (i.e., during -the C<readline> method). +makes Tk event loop run when waiting for user input (i.e., during +C<readline> method). -Term::ReadLine supports any event loop, including unpubished ones and -simple IO::Select loops without the need to rewrite existing code for -any particular framework. See IN(), print_prompt(), and get_line(). +=item C<event_loop> + +Registers call-backs to wait for user input (i.e., during C<readline> +method). This supercedes tkRunning. + +The first call-back registered is the call back for waiting. It is +expected that the callback will call the current event loop until +there is something waiting to get on the input filehandle. The parameter +passed in is the return value of the second call back. + +The second call-back registered is the call back for registration. The +input filehandle (often STDIN, but not necessarily) will be passed in. + +For example, with AnyEvent: + + $term->event_loop(sub { + my $data = shift; + $data->[1] = AE::cv(); + $data->[1]->recv(); + }, sub { + my $fh = shift; + my $data = []; + $data->[0] = AE::io($fh, 0, sub { $data->[1]->send() }); + $data; + }); + +The second call-back is optional if the call back is registered prior to +the call to $term-E<gt>readline. + +Deregistration is done in this case by calling event_loop with C<undef> +as its parameter: + + $term->event_loop(undef); + +This will cause the data array ref to be removed, allowing normal garbage +collection to clean it up. With AnyEvent, that will cause $data->[0] to +be cleaned up, and AnyEvent will automatically cancel the watcher at that +time. If another loop requires more than that to clean up a file watcher, +that will be up to the caller to handle. =item C<ornaments> @@ -131,59 +167,11 @@ standout, last two to make the input line standout. takes two arguments which are input filehandle and output filehandle. Switches to use these filehandles. -=item C<print_prompt> - -prints a prompt and returns immediately. readline() uses it to print -its prompt before calling get_line(). See L</"Using Event Loops"> for -an example of its use. - -=item C<get_line> - -gets a line of input from the terminal. If Tk is used and tkRunning() -has been set, then get_line() will dispatch Tk events while waiting -for a line of input. The full readline() API is a print_prompt() call -followed immediately by get_input(). See L</"Using Event Loops">. - =back One can check whether the currently loaded ReadLine package supports these methods by checking for corresponding C<Features>. -=head1 Using Event Loops - -Term::ReadLine provides IN(), print_prompt(), and get_line() so that -it may be used by any event loop that can watch for input on a file -handle. This includes most event loops including ones that haven't -been published. - -Term::ReadLine's readline() method prints a prompt and returns a line -of input got from its input filehandle: - - sub readline { - my ($self,$prompt) = @_; - $self->print_prompt($prompt); - $self->get_line(); - } - -A Tk readline function may be implemented by having Tk dispatch its -own events between the time the prompt is printed and the line is got. -This example function dispatches Tk events while Term::ReadLine waits -for console input. It can completely replace Term::ReadLine's -existing Tk support. - - sub tk_read_line { - my ($term, $prompt) = @_; - $term->print_prompt($prompt); - - my $got_input; - Tk->fileevent($term->IN, 'readable', sub { $got_input = 1 }); - Tk::DoOneEvent(0) until $got_input; - - return $term->get_line(); - } - -Other event loops are equally possible. - =head1 EXPORTS None @@ -202,8 +190,8 @@ be C<o=0> or C<ornaments=0>. 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 + export "PERL_RL=Perl o=0" # Use Perl ReadLine sans ornaments + export "PERL_RL= o=0" # Use best available ReadLine sans ornaments (Note that processing of C<PERL_RL> for ornaments is in the discretion of the particular used C<Term::ReadLine::*> package). @@ -219,17 +207,25 @@ $DB::emacs = $DB::emacs; # To peacify -w our @rl_term_set; *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; -sub print_prompt { - my ($self, $prompt) = @_; - my $out = $self->[1]; - print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; -} +sub PERL_UNICODE_STDIN () { 0x0001 } sub ReadLine {'Term::ReadLine::Stub'} sub readline { - my ($self,$prompt) = @_; - $self->print_prompt($prompt); - $self->get_line(); + 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; + #$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 {} @@ -331,7 +327,7 @@ sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? -our $VERSION = '1.08'; +our $VERSION = '1.09'; my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; if ($which) { @@ -407,22 +403,35 @@ package Term::ReadLine::Tk; # the$term->IN() accessor becomes ready for reading. It's assumed # that the diamond operator will return a line of input immediately at # that point. -# -# Any event loop can use $term-IN() and $term->readline() directly -# without adding code for any event loop specifically to this. my ($giveup); # maybe in the future the Tk-specific aspects will be removed. sub Tk_loop{ - Tk::DoOneEvent(0) until $giveup; - $giveup = 0; + if (ref $Term::ReadLine::toloop) + { + $Term::ReadLine::toloop->[0]->($Term::ReadLine::toloop->[2]); + } + else + { + Tk::DoOneEvent(0) until $giveup; + $giveup = 0; + } }; sub register_Tk { my $self = shift; - $Term::ReadLine::registered++ - or Tk->fileevent($self->IN,'readable',sub { $giveup = 1}); + unless ($Term::ReadLine::registered++) + { + if (ref $Term::ReadLine::toloop) + { + $Term::ReadLine::toloop->[2] = $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1]; + } + else + { + Tk->fileevent($self->IN,'readable',sub { $giveup = 1}); + } + } }; sub tkRunning { @@ -430,6 +439,25 @@ sub tkRunning { $Term::ReadLine::toloop; } +sub event_loop { + shift; + + # T::RL::Gnu and T::RL::Perl check that this exists, if not, + # it doesn't call the loop. Those modules will need to be + # fixed before this can be removed. + if (not defined &Tk::DoOneEvent) + { + *Tk::DoOneEvent = sub { + die "what?"; # this shouldn't be called. + } + } + + # store the callback in toloop, again so that other modules will + # recognise it and call us for the loop. + $Term::ReadLine::toloop = [ @_ ] if @_ > 1; + $Term::ReadLine::toloop; +} + sub PERL_UNICODE_STDIN () { 0x0001 } sub get_line { diff --git a/dist/Term-ReadLine/t/AE.t b/dist/Term-ReadLine/t/AE.t new file mode 100644 index 0000000..8fccecb --- /dev/null +++ b/dist/Term-ReadLine/t/AE.t @@ -0,0 +1,43 @@ +#!perl + +use Test::More; + +eval "use AnyEvent; 1" or + plan skip_all => "AnyEvent is not installed."; + +# seeing as the entire point of this test is to test the event handler, +# we need to mock as little as possible. To keep things tightly controlled, +# we'll use the Stub directly. +BEGIN { + $ENV{PERL_RL} = 'Stub o=0'; +} +plan tests => 3; + +# need to delay this so that AE is loaded first. +require Term::ReadLine; +use File::Spec; + +my $t = Term::ReadLine->new('AE'); +ok($t, "Created object"); +is($t->ReadLine, 'Term::ReadLine::Stub', 'Correct type'); + +my ($cv, $fe); +$t->event_loop( + sub { + $cv = AE::cv(); + $cv->recv(); + }, sub { + my $fh = shift; + $fe ||= AE::io($fh, 0, sub { $cv->send() }); + } + ); + +my $text = 'some text'; +my $T = $text . "\n"; +my $w = AE::timer(0,1,sub { +pass("Event loop called"); +exit 0; +}); + +my $result = $t->readline('Do not press enter>'); +fail("Should not get here."); diff --git a/dist/Term-ReadLine/t/AETk.t b/dist/Term-ReadLine/t/AETk.t new file mode 100644 index 0000000..80bab63 --- /dev/null +++ b/dist/Term-ReadLine/t/AETk.t @@ -0,0 +1,52 @@ +#!perl + +use Test::More; + +eval "use Tk; use AnyEvent; 1" or + plan skip_all => "AnyEvent and/or Tk is not installed."; + +# seeing as the entire point of this test is to test the event handler, +# we need to mock as little as possible. To keep things tightly controlled, +# we'll use the Stub directly. +BEGIN { + $ENV{PERL_RL} = 'Stub o=0'; + # ensure AE uses Tk. + $ENV{PERL_ANYEVENT_MODEL} = 'Tk'; +} + +eval { + use File::Spec; + my $mw = MainWindow->new(); $mw->withdraw(); + 1; +} or plan skip_all => "Tk can't start. DISPLAY not set?"; + +plan tests => 3; + +# need to delay this so that AE is loaded first. +require Term::ReadLine; +use File::Spec; + +my $t = Term::ReadLine->new('AE/Tk'); +ok($t, "Created object"); +is($t->ReadLine, 'Term::ReadLine::Stub', 'Correct type'); +my ($cv, $fe); +$t->event_loop( + sub { + $cv = AE::cv(); + $cv->recv(); + }, sub { + my $fh = shift; + $fe ||= AE::io($fh, 0, sub { $cv->send() }); + } + ); + + +my $text = 'some text'; +my $T = $text . "\n"; +my $w = AE::timer(0,1,sub { +pass("Event loop called"); +exit 0; +}); + +my $result = $t->readline('Do not press enter>'); +fail("Should not get here."); diff --git a/dist/Term-ReadLine/t/TkExternal.t b/dist/Term-ReadLine/t/TkExternal.t deleted file mode 100644 index 7c4cf69..0000000 --- a/dist/Term-ReadLine/t/TkExternal.t +++ /dev/null @@ -1,59 +0,0 @@ -#!perl - -use Test::More; - -eval "use Tk; 1" or - plan skip_all => "Tk is not installed."; - -# seeing as the entire point of this test is to test the event handler, -# we need to mock as little as possible. To keep things tightly controlled, -# we'll use the Stub directly. -BEGIN { - $ENV{PERL_RL} = 'Stub o=0'; -} - -my $mw; -eval { - use File::Spec; - $mw = MainWindow->new(); $mw->withdraw(); - 1; -} or plan skip_all => "Tk can't start. DISPLAY not set?"; - -# need to delay this so that Tk is loaded first. -require Term::ReadLine; - -plan tests => 3; - -my $t = Term::ReadLine->new('Tk'); -ok($t, "Created object"); -is($t->ReadLine, 'Term::ReadLine::Stub', 'Correct type'); - -# This test will dispatch Tk events externally. -$t->tkRunning(0); - -my $text = 'some text'; -my $T = $text . "\n"; - -my $w = Tk::after($mw,0, - sub { - pass("Event loop called"); - exit 0; - }); - -my $result = tk_readline($t, 'Do not press enter>'); -fail("Should not get here."); - -# A Tk-dispatching readline that doesn't require Tk (or any other -# event loop) support to be hard-coded into Term::ReadLine. - -sub tk_readline { - my ($term, $prompt) = @_; - - $term->print_prompt($prompt); - - my $got_input; - Tk->fileevent($term->IN, 'readable', sub { $got_input = 1 }); - Tk::DoOneEvent(0) until $got_input; - - return $term->get_line(); -} diff --git a/ext/Pod-Html/lib/Pod/Html.pm b/ext/Pod-Html/lib/Pod/Html.pm index 8fc74a4..c16b657 100644 --- a/ext/Pod-Html/lib/Pod/Html.pm +++ b/ext/Pod-Html/lib/Pod/Html.pm @@ -325,7 +325,16 @@ sub pod2html { or die "$0: error open $Dircache for writing: $!\n"; print $cache join(":", @Podpath) . "\n$Podroot\n"; + my $_updirs_only = ($Podroot =~ /\.\./) && !($Podroot =~ /[^\.\\\/]/); foreach my $key (keys %Pages) { + if($_updirs_only) { + my $_dirlevel = $Podroot; + while($_dirlevel =~ /\.\./) { + $_dirlevel =~ s/\.\.//; + # Assume $Pages{$key} has '/' separators (html dir separators). + $Pages{$key} =~ s/^[\w\s\-]+\///; + } + } print $cache "$key $Pages{$key}\n"; } diff --git a/ext/Pod-Html/t/pod2html-lib.pl b/ext/Pod-Html/t/pod2html-lib.pl index 0327e2b..b7067da 100644 --- a/ext/Pod-Html/t/pod2html-lib.pl +++ b/ext/Pod-Html/t/pod2html-lib.pl @@ -33,11 +33,11 @@ sub convert_n_test { my $cwd = Cwd::cwd(); my ($vol, $dir) = splitpath($cwd, 1); my $relcwd = substr($dir, length(File::Spec->rootdir())); - - my $new_dir = catdir $cwd, "t"; - my $infile = catfile $new_dir, "$podfile.pod"; - my $outfile = catfile $new_dir, "$podfile.html"; - + + my $new_dir = catdir $dir, "t"; + my $infile = catpath $vol, $new_dir, "$podfile.pod"; + my $outfile = catpath $vol, $new_dir, "$podfile.html"; + # To add/modify args to p2h, use @p2h_args Pod::Html::pod2html( "--infile=$infile", diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index 4046d3a..2270d9f 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -1,4 +1,4 @@ -# This file is the data file for t/porting/podcheck.t. +# This file is the data file for porting/podcheck.t. # There are three types of lines. # Comment lines are white-space only or begin with a '#', like this one. Any # changes you make to the comment lines will be lost when the file is @@ -172,7 +172,6 @@ dist/safe/safe.pm Verbatim line length including indents exceeds 79 by 1 dist/safe/safe.pm empty section in previous paragraph 1 dist/selfloader/lib/selfloader.pm Verbatim line length including indents exceeds 79 by 13 dist/storable/storable.pm Verbatim line length including indents exceeds 79 by 4 -dist/term-readline/lib/term/readline.pm Verbatim line length including indents exceeds 79 by 1 dist/thread-queue/lib/thread/queue.pm Verbatim line length including indents exceeds 79 by 4 dist/threads/lib/threads.pm Verbatim line length including indents exceeds 79 by 3 dist/tie-file/lib/tie/file.pm Verbatim line length including indents exceeds 79 by 3 -- Perl5 Master Repository
