Initial Commit
This commit is contained in:
Riley Schneider
2436
database/perl/lib/Pod/Simple/BlackBox.pm
Normal file
2436
database/perl/lib/Pod/Simple/BlackBox.pm
Normal file
File diff suppressed because it is too large
Load Diff
196
database/perl/lib/Pod/Simple/Checker.pm
Normal file
196
database/perl/lib/Pod/Simple/Checker.pm
Normal file
@@ -0,0 +1,196 @@
|
||||
|
||||
# A quite dimwitted pod2plaintext that need only know how to format whatever
|
||||
# text comes out of Pod::BlackBox's _gen_errata
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::Checker;
|
||||
use strict;
|
||||
use Carp ();
|
||||
use Pod::Simple::Methody ();
|
||||
use Pod::Simple ();
|
||||
use vars qw( @ISA $VERSION );
|
||||
$VERSION = '3.42';
|
||||
@ISA = ('Pod::Simple::Methody');
|
||||
BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
|
||||
? \&Pod::Simple::DEBUG
|
||||
: sub() {0}
|
||||
}
|
||||
|
||||
use Text::Wrap 98.112902 (); # was 2001.0131, but I don't think we need that
|
||||
$Text::Wrap::wrap = 'overflow';
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub any_errata_seen { # read-only accessor
|
||||
return $_[1]->{'Errata_seen'};
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $new = $self->SUPER::new(@_);
|
||||
$new->{'output_fh'} ||= *STDOUT{IO};
|
||||
$new->nix_X_codes(1);
|
||||
$new->nbsp_for_S(1);
|
||||
$new->{'Thispara'} = '';
|
||||
$new->{'Indent'} = 0;
|
||||
$new->{'Indentstring'} = ' ';
|
||||
$new->{'Errata_seen'} = 0;
|
||||
return $new;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub handle_text { $_[0]{'Errata_seen'} and $_[0]{'Thispara'} .= $_[1] }
|
||||
|
||||
sub start_Para { $_[0]{'Thispara'} = '' }
|
||||
|
||||
sub start_head1 {
|
||||
if($_[0]{'Errata_seen'}) {
|
||||
$_[0]{'Thispara'} = '';
|
||||
} else {
|
||||
if($_[1]{'errata'}) { # start of errata!
|
||||
$_[0]{'Errata_seen'} = 1;
|
||||
$_[0]{'Thispara'} = $_[0]{'source_filename'} ?
|
||||
"$_[0]{'source_filename'} -- " : ''
|
||||
}
|
||||
}
|
||||
}
|
||||
sub start_head2 { $_[0]{'Thispara'} = '' }
|
||||
sub start_head3 { $_[0]{'Thispara'} = '' }
|
||||
sub start_head4 { $_[0]{'Thispara'} = '' }
|
||||
|
||||
sub start_Verbatim { $_[0]{'Thispara'} = '' }
|
||||
sub start_item_bullet { $_[0]{'Thispara'} = '* ' }
|
||||
sub start_item_number { $_[0]{'Thispara'} = "$_[1]{'number'}. " }
|
||||
sub start_item_text { $_[0]{'Thispara'} = '' }
|
||||
|
||||
sub start_over_bullet { ++$_[0]{'Indent'} }
|
||||
sub start_over_number { ++$_[0]{'Indent'} }
|
||||
sub start_over_text { ++$_[0]{'Indent'} }
|
||||
sub start_over_block { ++$_[0]{'Indent'} }
|
||||
|
||||
sub end_over_bullet { --$_[0]{'Indent'} }
|
||||
sub end_over_number { --$_[0]{'Indent'} }
|
||||
sub end_over_text { --$_[0]{'Indent'} }
|
||||
sub end_over_block { --$_[0]{'Indent'} }
|
||||
|
||||
|
||||
# . . . . . Now the actual formatters:
|
||||
|
||||
sub end_head1 { $_[0]->emit_par(-4) }
|
||||
sub end_head2 { $_[0]->emit_par(-3) }
|
||||
sub end_head3 { $_[0]->emit_par(-2) }
|
||||
sub end_head4 { $_[0]->emit_par(-1) }
|
||||
sub end_Para { $_[0]->emit_par( 0) }
|
||||
sub end_item_bullet { $_[0]->emit_par( 0) }
|
||||
sub end_item_number { $_[0]->emit_par( 0) }
|
||||
sub end_item_text { $_[0]->emit_par(-2) }
|
||||
|
||||
sub emit_par {
|
||||
return unless $_[0]{'Errata_seen'};
|
||||
my($self, $tweak_indent) = splice(@_,0,2);
|
||||
my $length = 2 * $self->{'Indent'} + ($tweak_indent||0);
|
||||
my $indent = ' ' x ($length > 0 ? $length : 0);
|
||||
# Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
|
||||
# 'Negative repeat count does nothing' since 5.22
|
||||
|
||||
$self->{'Thispara'} =~ s/$Pod::Simple::shy//g;
|
||||
my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
|
||||
$out =~ s/$Pod::Simple::nbsp/ /g;
|
||||
print {$self->{'output_fh'}} $out,
|
||||
#"\n"
|
||||
;
|
||||
$self->{'Thispara'} = '';
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# . . . . . . . . . . And then off by its lonesome:
|
||||
|
||||
sub end_Verbatim {
|
||||
return unless $_[0]{'Errata_seen'};
|
||||
my $self = shift;
|
||||
$self->{'Thispara'} =~ s/$Pod::Simple::nbsp/ /g;
|
||||
$self->{'Thispara'} =~ s/$Pod::Simple::shy//g;
|
||||
|
||||
my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
|
||||
|
||||
$self->{'Thispara'} =~ s/^/$i/mg;
|
||||
|
||||
print { $self->{'output_fh'} } '',
|
||||
$self->{'Thispara'},
|
||||
"\n\n"
|
||||
;
|
||||
$self->{'Thispara'} = '';
|
||||
return;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::Checker -- check the Pod syntax of a document
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MPod::Simple::Checker -e \
|
||||
"exit Pod::Simple::Checker->filter(shift)->any_errata_seen" \
|
||||
thingy.pod
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is for checking the syntactic validity of Pod.
|
||||
It works by basically acting like a simple-minded version of
|
||||
L<Pod::Simple::Text> that formats only the "Pod Errors" section
|
||||
(if Pod::Simple even generates one for the given document).
|
||||
|
||||
This is a subclass of L<Pod::Simple> and inherits all its methods.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Checker>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
177
database/perl/lib/Pod/Simple/Debug.pm
Normal file
177
database/perl/lib/Pod/Simple/Debug.pm
Normal file
@@ -0,0 +1,177 @@
|
||||
require 5;
|
||||
package Pod::Simple::Debug;
|
||||
use strict;
|
||||
use vars qw($VERSION );
|
||||
$VERSION = '3.42';
|
||||
|
||||
sub import {
|
||||
my($value,$variable);
|
||||
|
||||
if(@_ == 2) {
|
||||
$value = $_[1];
|
||||
} elsif(@_ == 3) {
|
||||
($variable, $value) = @_[1,2];
|
||||
|
||||
($variable, $value) = ($value, $variable)
|
||||
if defined $value and ref($value) eq 'SCALAR'
|
||||
and not(defined $variable and ref($variable) eq 'SCALAR')
|
||||
; # tolerate getting it backwards
|
||||
|
||||
unless( defined $variable and ref($variable) eq 'SCALAR') {
|
||||
require Carp;
|
||||
Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
|
||||
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
|
||||
}
|
||||
} else {
|
||||
require Carp;
|
||||
Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
|
||||
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
|
||||
}
|
||||
|
||||
if( defined &Pod::Simple::DEBUG ) {
|
||||
require Carp;
|
||||
Carp::croak("It's too late to call Pod::Simple::Debug -- "
|
||||
. "Pod::Simple has already loaded\nAborting");
|
||||
}
|
||||
|
||||
$value = 0 unless defined $value;
|
||||
|
||||
unless($value =~ m/^-?\d+$/) {
|
||||
require Carp;
|
||||
Carp::croak( "$value isn't a numeric value."
|
||||
. "\nUsage:\n use Pod::Simple::Debug (NUMVAL)\nor"
|
||||
. "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
|
||||
}
|
||||
|
||||
if( defined $variable ) {
|
||||
# make a not-really-constant
|
||||
*Pod::Simple::DEBUG = sub () { $$variable } ;
|
||||
$$variable = $value;
|
||||
print STDERR "# Starting Pod::Simple::DEBUG = non-constant $variable with val $value\n";
|
||||
} else {
|
||||
*Pod::Simple::DEBUG = eval " sub () { $value } ";
|
||||
print STDERR "# Starting Pod::Simple::DEBUG = $value\n";
|
||||
}
|
||||
|
||||
require Pod::Simple;
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::Debug -- put Pod::Simple into trace/debug mode
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Pod::Simple::Debug (5); # or some integer
|
||||
|
||||
Or:
|
||||
|
||||
my $debuglevel;
|
||||
use Pod::Simple::Debug (\$debuglevel, 0);
|
||||
...some stuff that uses Pod::Simple to do stuff, but which
|
||||
you don't want debug output from...
|
||||
|
||||
$debug_level = 4;
|
||||
...some stuff that uses Pod::Simple to do stuff, but which
|
||||
you DO want debug output from...
|
||||
|
||||
$debug_level = 0;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is an internal module for controlling the debug level (a.k.a. trace
|
||||
level) of Pod::Simple. This is of interest only to Pod::Simple
|
||||
developers.
|
||||
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Note that you should load this module I<before> loading Pod::Simple (or
|
||||
any Pod::Simple-based class). If you try loading Pod::Simple::Debug
|
||||
after &Pod::Simple::DEBUG is already defined, Pod::Simple::Debug will
|
||||
throw a fatal error to the effect that
|
||||
"It's too late to call Pod::Simple::Debug".
|
||||
|
||||
Note that the C<use Pod::Simple::Debug (\$x, I<somenum>)> mode will make
|
||||
Pod::Simple (et al) run rather slower, since &Pod::Simple::DEBUG won't
|
||||
be a constant sub anymore, and so Pod::Simple (et al) won't compile with
|
||||
constant-folding.
|
||||
|
||||
|
||||
=head1 GUTS
|
||||
|
||||
Doing this:
|
||||
|
||||
use Pod::Simple::Debug (5); # or some integer
|
||||
|
||||
is basically equivalent to:
|
||||
|
||||
BEGIN { sub Pod::Simple::DEBUG () {5} } # or some integer
|
||||
use Pod::Simple ();
|
||||
|
||||
And this:
|
||||
|
||||
use Pod::Simple::Debug (\$debug_level,0); # or some integer
|
||||
|
||||
is basically equivalent to this:
|
||||
|
||||
my $debug_level;
|
||||
BEGIN { $debug_level = 0 }
|
||||
BEGIN { sub Pod::Simple::DEBUG () { $debug_level }
|
||||
use Pod::Simple ();
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>
|
||||
|
||||
The article "Constants in Perl", in I<The Perl Journal> issue
|
||||
21. See L<http://interglacial.com/tpj/21/>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
156
database/perl/lib/Pod/Simple/DumpAsText.pm
Normal file
156
database/perl/lib/Pod/Simple/DumpAsText.pm
Normal file
@@ -0,0 +1,156 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::DumpAsText;
|
||||
$VERSION = '3.42';
|
||||
use Pod::Simple ();
|
||||
BEGIN {@ISA = ('Pod::Simple')}
|
||||
|
||||
use strict;
|
||||
|
||||
use Carp ();
|
||||
|
||||
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $new = $self->SUPER::new(@_);
|
||||
$new->{'output_fh'} ||= *STDOUT{IO};
|
||||
$new->accept_codes('VerbatimFormatted');
|
||||
$new->keep_encoding_directive(1);
|
||||
return $new;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
|
||||
sub _handle_element_start {
|
||||
# ($self, $element_name, $attr_hash_r)
|
||||
my $fh = $_[0]{'output_fh'};
|
||||
my($key, $value);
|
||||
DEBUG and print STDERR "++ $_[1]\n";
|
||||
|
||||
print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n";
|
||||
$_[0]{'indent'}++;
|
||||
while(($key,$value) = each %{$_[2]}) {
|
||||
unless($key =~ m/^~/s) {
|
||||
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
|
||||
_perly_escape($key);
|
||||
_perly_escape($value);
|
||||
printf $fh qq{%s \\ "%s" => "%s"\n},
|
||||
' ' x ($_[0]{'indent'} || 0), $key, $value;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_text {
|
||||
DEBUG and print STDERR "== \"$_[1]\"\n";
|
||||
|
||||
if(length $_[1]) {
|
||||
my $indent = ' ' x $_[0]{'indent'};
|
||||
my $text = $_[1];
|
||||
_perly_escape($text);
|
||||
$text =~ # A not-totally-brilliant wrapping algorithm:
|
||||
s/(
|
||||
[^\n]{55} # Snare some characters from a line
|
||||
[^\n\ ]{0,50} # and finish any current word
|
||||
)
|
||||
\ {1,10}(?!\n) # capture some spaces not at line-end
|
||||
/$1"\n$indent . "/gx # => line-break here
|
||||
;
|
||||
|
||||
print {$_[0]{'output_fh'}} $indent, '* "', $text, "\"\n";
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_element_end {
|
||||
DEBUG and print STDERR "-- $_[1]\n";
|
||||
print {$_[0]{'output_fh'}}
|
||||
' ' x --$_[0]{'indent'}, "--", $_[1], "\n";
|
||||
return;
|
||||
}
|
||||
|
||||
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
|
||||
|
||||
sub _perly_escape {
|
||||
foreach my $x (@_) {
|
||||
$x =~ s/([^\x00-\xFF])/sprintf'\x{%X}',ord($1)/eg;
|
||||
# Escape things very cautiously:
|
||||
$x =~ s/([^-\n\t \&\<\>\'!\#\%\(\)\*\+,\.\/\:\;=\?\~\[\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf'\x%02X',ord($1)/eg;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::DumpAsText -- dump Pod-parsing events as text
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MPod::Simple::DumpAsText -e \
|
||||
"exit Pod::Simple::DumpAsText->filter(shift)->any_errata_seen" \
|
||||
thingy.pod
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is for dumping, as text, the events gotten from parsing a Pod
|
||||
document. This class is of interest to people writing Pod formatters
|
||||
based on Pod::Simple. It is useful for seeing exactly what events you
|
||||
get out of some Pod that you feed in.
|
||||
|
||||
This is a subclass of L<Pod::Simple> and inherits all its methods.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple::DumpAsXML>
|
||||
|
||||
L<Pod::Simple>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
167
database/perl/lib/Pod/Simple/DumpAsXML.pm
Normal file
167
database/perl/lib/Pod/Simple/DumpAsXML.pm
Normal file
@@ -0,0 +1,167 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::DumpAsXML;
|
||||
$VERSION = '3.42';
|
||||
use Pod::Simple ();
|
||||
BEGIN {@ISA = ('Pod::Simple')}
|
||||
|
||||
use strict;
|
||||
|
||||
use Carp ();
|
||||
use Text::Wrap qw(wrap);
|
||||
|
||||
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $new = $self->SUPER::new(@_);
|
||||
$new->{'output_fh'} ||= *STDOUT{IO};
|
||||
$new->accept_codes('VerbatimFormatted');
|
||||
$new->keep_encoding_directive(1);
|
||||
return $new;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
|
||||
sub _handle_element_start {
|
||||
# ($self, $element_name, $attr_hash_r)
|
||||
my $fh = $_[0]{'output_fh'};
|
||||
my($key, $value);
|
||||
DEBUG and print STDERR "++ $_[1]\n";
|
||||
|
||||
print $fh ' ' x ($_[0]{'indent'} || 0), "<", $_[1];
|
||||
|
||||
foreach my $key (sort keys %{$_[2]}) {
|
||||
unless($key =~ m/^~/s) {
|
||||
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
|
||||
_xml_escape($value = $_[2]{$key});
|
||||
print $fh ' ', $key, '="', $value, '"';
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
print $fh ">\n";
|
||||
$_[0]{'indent'}++;
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_text {
|
||||
DEBUG and print STDERR "== \"$_[1]\"\n";
|
||||
if(length $_[1]) {
|
||||
my $indent = ' ' x $_[0]{'indent'};
|
||||
my $text = $_[1];
|
||||
_xml_escape($text);
|
||||
local $Text::Wrap::huge = 'overflow';
|
||||
$text = wrap('', $indent, $text);
|
||||
print {$_[0]{'output_fh'}} $indent, $text, "\n";
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_element_end {
|
||||
DEBUG and print STDERR "-- $_[1]\n";
|
||||
print {$_[0]{'output_fh'}}
|
||||
' ' x --$_[0]{'indent'}, "</", $_[1], ">\n";
|
||||
return;
|
||||
}
|
||||
|
||||
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
|
||||
|
||||
sub _xml_escape {
|
||||
foreach my $x (@_) {
|
||||
# Escape things very cautiously:
|
||||
if ($] ge 5.007_003) {
|
||||
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
|
||||
} else { # Is broken for non-ASCII platforms on early perls
|
||||
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
|
||||
}
|
||||
# Yes, stipulate the list without a range, so that this can work right on
|
||||
# all charsets that this module happens to run under.
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::DumpAsXML -- turn Pod into XML
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MPod::Simple::DumpAsXML -e \
|
||||
"exit Pod::Simple::DumpAsXML->filter(shift)->any_errata_seen" \
|
||||
thingy.pod
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Pod::Simple::DumpAsXML is a subclass of L<Pod::Simple> that parses Pod
|
||||
and turns it into indented and wrapped XML. This class is of
|
||||
interest to people writing Pod formatters based on Pod::Simple.
|
||||
|
||||
Pod::Simple::DumpAsXML inherits methods from
|
||||
L<Pod::Simple>.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple::XMLOutStream> is rather like this class.
|
||||
Pod::Simple::XMLOutStream's output is space-padded in a way
|
||||
that's better for sending to an XML processor (that is, it has
|
||||
no ignorable whitespace). But
|
||||
Pod::Simple::DumpAsXML's output is much more human-readable, being
|
||||
(more-or-less) one token per line, with line-wrapping.
|
||||
|
||||
L<Pod::Simple::DumpAsText> is rather like this class,
|
||||
except that it doesn't dump with XML syntax. Try them and see
|
||||
which one you like best!
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::DumpAsXML>
|
||||
|
||||
The older libraries L<Pod::PXML>, L<Pod::XML>, L<Pod::SAX>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
1161
database/perl/lib/Pod/Simple/HTML.pm
Normal file
1161
database/perl/lib/Pod/Simple/HTML.pm
Normal file
File diff suppressed because it is too large
Load Diff
1365
database/perl/lib/Pod/Simple/HTMLBatch.pm
Normal file
1365
database/perl/lib/Pod/Simple/HTMLBatch.pm
Normal file
File diff suppressed because it is too large
Load Diff
104
database/perl/lib/Pod/Simple/HTMLLegacy.pm
Normal file
104
database/perl/lib/Pod/Simple/HTMLLegacy.pm
Normal file
@@ -0,0 +1,104 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::HTMLLegacy;
|
||||
use strict;
|
||||
|
||||
use vars qw($VERSION);
|
||||
use Getopt::Long;
|
||||
|
||||
$VERSION = "5.01";
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
#
|
||||
# This class is meant to thinly emulate bad old Pod::Html
|
||||
#
|
||||
# TODO: some basic docs
|
||||
|
||||
sub pod2html {
|
||||
my @args = (@_);
|
||||
|
||||
my( $verbose, $infile, $outfile, $title );
|
||||
my $index = 1;
|
||||
|
||||
{
|
||||
my($help);
|
||||
|
||||
my($netscape); # dummy
|
||||
local @ARGV = @args;
|
||||
GetOptions(
|
||||
"help" => \$help,
|
||||
"verbose!" => \$verbose,
|
||||
"infile=s" => \$infile,
|
||||
"outfile=s" => \$outfile,
|
||||
"title=s" => \$title,
|
||||
"index!" => \$index,
|
||||
|
||||
"netscape!" => \$netscape,
|
||||
) or return bad_opts(@args);
|
||||
bad_opts(@args) if @ARGV; # it should be all switches!
|
||||
return help_message() if $help;
|
||||
}
|
||||
|
||||
for($infile, $outfile) { $_ = undef unless defined and length }
|
||||
|
||||
if($verbose) {
|
||||
warn sprintf "%s version %s\n", __PACKAGE__, $VERSION;
|
||||
warn "OK, processed args [@args] ...\n";
|
||||
warn sprintf
|
||||
" Verbose: %s\n Index: %s\n Infile: %s\n Outfile: %s\n Title: %s\n",
|
||||
map defined($_) ? $_ : "(nil)",
|
||||
$verbose, $index, $infile, $outfile, $title,
|
||||
;
|
||||
*Pod::Simple::HTML::DEBUG = sub(){1};
|
||||
}
|
||||
require Pod::Simple::HTML;
|
||||
Pod::Simple::HTML->VERSION(3);
|
||||
|
||||
die "No such input file as $infile\n"
|
||||
if defined $infile and ! -e $infile;
|
||||
|
||||
|
||||
my $pod = Pod::Simple::HTML->new;
|
||||
$pod->force_title($title) if defined $title;
|
||||
$pod->index($index);
|
||||
return $pod->parse_from_file($infile, $outfile);
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
sub bad_opts { die _help_message(); }
|
||||
sub help_message { print STDOUT _help_message() }
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
sub _help_message {
|
||||
|
||||
join '',
|
||||
|
||||
"[", __PACKAGE__, " version ", $VERSION, qq~]
|
||||
Usage: pod2html --help --infile=<name> --outfile=<name>
|
||||
--verbose --index --noindex
|
||||
|
||||
Options:
|
||||
--help - prints this message.
|
||||
--[no]index - generate an index at the top of the resulting html
|
||||
(default behavior).
|
||||
--infile - filename for the pod to convert (input taken from stdin
|
||||
by default).
|
||||
--outfile - filename for the resulting html file (output sent to
|
||||
stdout by default).
|
||||
--title - title that will appear in resulting html file.
|
||||
--[no]verbose - self-explanatory (off by default).
|
||||
|
||||
Note that pod2html is DEPRECATED, and this version implements only
|
||||
some of the options known to older versions.
|
||||
For more information, see 'perldoc pod2html'.
|
||||
~;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!!
|
||||
|
||||
366
database/perl/lib/Pod/Simple/JustPod.pm
Normal file
366
database/perl/lib/Pod/Simple/JustPod.pm
Normal file
@@ -0,0 +1,366 @@
|
||||
use 5;
|
||||
package Pod::Simple::JustPod;
|
||||
# ABSTRACT: Pod::Simple formatter that extracts POD from a file containing
|
||||
# other things as well
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Pod::Simple::Methody ();
|
||||
our @ISA = ('Pod::Simple::Methody');
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $new = $self->SUPER::new(@_);
|
||||
|
||||
$new->accept_targets('*');
|
||||
$new->keep_encoding_directive(1);
|
||||
$new->preserve_whitespace(1);
|
||||
$new->complain_stderr(1);
|
||||
$new->_output_is_for_JustPod(1);
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub check_that_all_is_closed {
|
||||
|
||||
# Actually checks that the things we depend on being balanced in fact are,
|
||||
# so that we can continue in spit of pod errors
|
||||
|
||||
my $self = shift;
|
||||
while ($self->{inL}) {
|
||||
$self->end_L(@_);
|
||||
}
|
||||
while ($self->{fcode_end} && @{$self->{fcode_end}}) {
|
||||
$self->_end_fcode(@_);
|
||||
}
|
||||
}
|
||||
|
||||
sub handle_text {
|
||||
|
||||
# Add text to the output buffer. This is skipped if within a L<>, as we use
|
||||
# the 'raw' attribute of that tag instead.
|
||||
|
||||
$_[0]{buffer} .= $_[1] unless $_[0]{inL} ;
|
||||
}
|
||||
|
||||
sub spacer {
|
||||
|
||||
# Prints the white space following things like =head1. This is normally a
|
||||
# blank, unless BlackBox has told us otherwise.
|
||||
|
||||
my ($self, $arg) = @_;
|
||||
return unless $arg;
|
||||
|
||||
my $spacer = ($arg->{'~orig_spacer'})
|
||||
? $arg->{'~orig_spacer'}
|
||||
: " ";
|
||||
$self->handle_text($spacer);
|
||||
}
|
||||
|
||||
sub _generic_start {
|
||||
|
||||
# Called from tags like =head1, etc.
|
||||
|
||||
my ($self, $text, $arg) = @_;
|
||||
$self->check_that_all_is_closed();
|
||||
$self->handle_text($text);
|
||||
$self->spacer($arg);
|
||||
}
|
||||
|
||||
sub start_Document { shift->_generic_start("=pod\n\n"); }
|
||||
sub start_head1 { shift->_generic_start('=head1', @_); }
|
||||
sub start_head2 { shift->_generic_start('=head2', @_); }
|
||||
sub start_head3 { shift->_generic_start('=head3', @_); }
|
||||
sub start_head4 { shift->_generic_start('=head4', @_); }
|
||||
sub start_head5 { shift->_generic_start('=head5', @_); }
|
||||
sub start_head6 { shift->_generic_start('=head6', @_); }
|
||||
sub start_encoding { shift->_generic_start('=encoding', @_); }
|
||||
# sub start_Para
|
||||
# sub start_Verbatim
|
||||
|
||||
sub start_item_bullet { # Handle =item *
|
||||
my ($self, $arg) = @_;
|
||||
$self->check_that_all_is_closed();
|
||||
$self->handle_text('=item');
|
||||
|
||||
# It can be that they said simply '=item', and it is inferred that it is to
|
||||
# be a bullet.
|
||||
if (! $arg->{'~orig_content'}) {
|
||||
$self->handle_text("\n\n");
|
||||
}
|
||||
else {
|
||||
$self->spacer($arg);
|
||||
if ($arg->{'~_freaky_para_hack'}) {
|
||||
|
||||
# See Message Id <87y3gtcwa2.fsf@hope.eyrie.org>
|
||||
my $item_text = $arg->{'~orig_content'};
|
||||
my $trailing = quotemeta $arg->{'~_freaky_para_hack'};
|
||||
$item_text =~ s/$trailing$//;
|
||||
$self->handle_text($item_text);
|
||||
}
|
||||
else {
|
||||
$self->handle_text("*\n\n");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub start_item_number { # Handle '=item 2'
|
||||
my ($self, $arg) = @_;
|
||||
$self->check_that_all_is_closed();
|
||||
$self->handle_text("=item");
|
||||
$self->spacer($arg);
|
||||
$self->handle_text("$arg->{'~orig_content'}\n\n");
|
||||
}
|
||||
|
||||
sub start_item_text { # Handle '=item foo bar baz'
|
||||
my ($self, $arg) = @_;
|
||||
$self->check_that_all_is_closed();
|
||||
$self->handle_text('=item');
|
||||
$self->spacer($arg);
|
||||
}
|
||||
|
||||
sub _end_item {
|
||||
my $self = shift;
|
||||
$self->check_that_all_is_closed();
|
||||
$self->emit;
|
||||
}
|
||||
|
||||
*end_item_bullet = *_end_item;
|
||||
*end_item_number = *_end_item;
|
||||
*end_item_text = *_end_item;
|
||||
|
||||
sub _start_over { # Handle =over
|
||||
my ($self, $arg) = @_;
|
||||
$self->check_that_all_is_closed();
|
||||
$self->handle_text("=over");
|
||||
|
||||
# The =over amount is optional
|
||||
if ($arg->{'~orig_content'}) {
|
||||
$self->spacer($arg);
|
||||
$self->handle_text("$arg->{'~orig_content'}");
|
||||
}
|
||||
$self->handle_text("\n\n");
|
||||
}
|
||||
|
||||
*start_over_bullet = *_start_over;
|
||||
*start_over_number = *_start_over;
|
||||
*start_over_text = *_start_over;
|
||||
*start_over_block = *_start_over;
|
||||
|
||||
sub _end_over {
|
||||
my $self = shift;
|
||||
$self->check_that_all_is_closed();
|
||||
$self->handle_text('=back');
|
||||
$self->emit;
|
||||
}
|
||||
|
||||
*end_over_bullet = *_end_over;
|
||||
*end_over_number = *_end_over;
|
||||
*end_over_text = *_end_over;
|
||||
*end_over_block = *_end_over;
|
||||
|
||||
sub end_Document {
|
||||
my $self = shift;
|
||||
$self->emit; # Make sure buffer gets flushed
|
||||
print {$self->{'output_fh'} } "=cut\n"
|
||||
}
|
||||
|
||||
sub _end_generic {
|
||||
my $self = shift;
|
||||
$self->check_that_all_is_closed();
|
||||
$self->emit;
|
||||
}
|
||||
|
||||
*end_head1 = *_end_generic;
|
||||
*end_head2 = *_end_generic;
|
||||
*end_head3 = *_end_generic;
|
||||
*end_head4 = *_end_generic;
|
||||
*end_head5 = *_end_generic;
|
||||
*end_head6 = *_end_generic;
|
||||
*end_encoding = *_end_generic;
|
||||
*end_Para = *_end_generic;
|
||||
*end_Verbatim = *_end_generic;
|
||||
|
||||
sub _start_fcode {
|
||||
my ($type, $self, $flags) = @_;
|
||||
|
||||
# How many brackets is set by BlackBox unless the count is 1
|
||||
my $bracket_count = (exists $flags->{'~bracket_count'})
|
||||
? $flags->{'~bracket_count'}
|
||||
: 1;
|
||||
$self->handle_text($type . ( "<" x $bracket_count));
|
||||
|
||||
my $rspacer = "";
|
||||
if ($bracket_count > 1) {
|
||||
my $lspacer = (exists $flags->{'~lspacer'})
|
||||
? $flags->{'~lspacer'}
|
||||
: " ";
|
||||
$self->handle_text($lspacer);
|
||||
|
||||
$rspacer = (exists $flags->{'~rspacer'})
|
||||
? $flags->{'~rspacer'}
|
||||
: " ";
|
||||
}
|
||||
|
||||
# BlackBox doesn't output things for for the ending code callbacks, so save
|
||||
# what we need.
|
||||
push @{$self->{'fcode_end'}}, [ $bracket_count, $rspacer ];
|
||||
}
|
||||
|
||||
sub start_B { _start_fcode('B', @_); }
|
||||
sub start_C { _start_fcode('C', @_); }
|
||||
sub start_E { _start_fcode('E', @_); }
|
||||
sub start_F { _start_fcode('F', @_); }
|
||||
sub start_I { _start_fcode('I', @_); }
|
||||
sub start_S { _start_fcode('S', @_); }
|
||||
sub start_X { _start_fcode('X', @_); }
|
||||
sub start_Z { _start_fcode('Z', @_); }
|
||||
|
||||
sub _end_fcode {
|
||||
my $self = shift;
|
||||
my $fcode_end = pop @{$self->{'fcode_end'}};
|
||||
my $bracket_count = 1;
|
||||
my $rspacer = "";
|
||||
|
||||
if (! defined $fcode_end) { # If BlackBox is working, this shouldn't
|
||||
# happen, but verify
|
||||
$self->whine($self->{line_count}, "Extra '>'");
|
||||
}
|
||||
else {
|
||||
$bracket_count = $fcode_end->[0];
|
||||
$rspacer = $fcode_end->[1];
|
||||
}
|
||||
|
||||
$self->handle_text($rspacer) if $bracket_count > 1;
|
||||
$self->handle_text(">" x $bracket_count);
|
||||
}
|
||||
|
||||
*end_B = *_end_fcode;
|
||||
*end_C = *_end_fcode;
|
||||
*end_E = *_end_fcode;
|
||||
*end_F = *_end_fcode;
|
||||
*end_I = *_end_fcode;
|
||||
*end_S = *_end_fcode;
|
||||
*end_X = *_end_fcode;
|
||||
*end_Z = *_end_fcode;
|
||||
|
||||
sub start_L {
|
||||
_start_fcode('L', @_);
|
||||
$_[0]->handle_text($_[1]->{raw});
|
||||
$_[0]->{inL}++
|
||||
}
|
||||
|
||||
sub end_L {
|
||||
my $self = shift;
|
||||
$self->{inL}--;
|
||||
if ($self->{inL} < 0) { # If BlackBox is working, this shouldn't
|
||||
# happen, but verify
|
||||
$self->whine($self->{line_count}, "Extra '>' ending L<>");
|
||||
$self->{inL} = 0;
|
||||
}
|
||||
|
||||
$self->_end_fcode(@_);
|
||||
}
|
||||
|
||||
sub emit {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->{buffer} ne "") {
|
||||
print { $self->{'output_fh'} } "",$self->{buffer} ,"\n\n";
|
||||
|
||||
$self->{buffer} = "";
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::JustPod -- just the Pod, the whole Pod, and nothing but the Pod
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $infile = "mixed_code_and_pod.pm";
|
||||
my $outfile = "just_the_pod.pod";
|
||||
open my $fh, ">$outfile" or die "Can't write to $outfile: $!";
|
||||
|
||||
my $parser = Pod::Simple::JustPod->new();
|
||||
$parser->output_fh($fh);
|
||||
$parser->parse_file($infile);
|
||||
close $fh or die "Can't close $outfile: $!";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class returns a copy of its input, translated into Perl's internal
|
||||
encoding (UTF-8), and with all the non-Pod lines removed.
|
||||
|
||||
This is a subclass of L<Pod::Simple::Methody> and inherits all its methods.
|
||||
And since, that in turn is a subclass of L<Pod::Simple>, you can use any of
|
||||
its methods. This means you can output to a string instead of a file, or
|
||||
you can parse from an array.
|
||||
|
||||
This class strives to return the Pod lines of the input completely unchanged,
|
||||
except for any necessary translation into Perl's internal encoding, and it makes
|
||||
no effort to return trailing spaces on lines; these likely will be stripped.
|
||||
If the input pod is well-formed with no warnings nor errors generated, the
|
||||
extracted pod should generate the same documentation when formatted by a Pod
|
||||
formatter as the original file does.
|
||||
|
||||
By default, warnings are output to STDERR
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::Methody>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
L<mailto:pod-people@perl.org> mail list. Send an empty email to
|
||||
L<mailto:pod-people-subscribe@perl.org> to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/theory/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
L<mailto:<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
Pod::Simple::JustPod was developed by John SJ Anderson
|
||||
C<genehack@genehack.org>, with contributions from Karl Williamson
|
||||
C<khw@cpan.org>.
|
||||
|
||||
=cut
|
||||
172
database/perl/lib/Pod/Simple/LinkSection.pm
Normal file
172
database/perl/lib/Pod/Simple/LinkSection.pm
Normal file
@@ -0,0 +1,172 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::LinkSection;
|
||||
# Based somewhat dimly on Array::Autojoin
|
||||
|
||||
use strict;
|
||||
use Pod::Simple::BlackBox;
|
||||
use vars qw($VERSION );
|
||||
$VERSION = '3.42';
|
||||
|
||||
use overload( # So it'll stringify nice
|
||||
'""' => \&Pod::Simple::BlackBox::stringify_lol,
|
||||
'bool' => \&Pod::Simple::BlackBox::stringify_lol,
|
||||
# '.=' => \&tack_on, # grudgingly support
|
||||
|
||||
'fallback' => 1, # turn on cleverness
|
||||
);
|
||||
|
||||
sub tack_on {
|
||||
$_[0] = ['', {}, "$_[0]" ];
|
||||
return $_[0][2] .= $_[1];
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
goto &Pod::Simple::BlackBox::stringify_lol;
|
||||
}
|
||||
sub stringify {
|
||||
goto &Pod::Simple::BlackBox::stringify_lol;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref($class) || $class;
|
||||
my $new;
|
||||
if(@_ == 1) {
|
||||
if (!ref($_[0] || '')) { # most common case: one bare string
|
||||
return bless ['', {}, $_[0] ], $class;
|
||||
} elsif( ref($_[0] || '') eq 'ARRAY') {
|
||||
$new = [ @{ $_[0] } ];
|
||||
} else {
|
||||
Carp::croak( "$class new() doesn't know to clone $new" );
|
||||
}
|
||||
} else { # misc stuff
|
||||
$new = [ '', {}, @_ ];
|
||||
}
|
||||
|
||||
# By now it's a treelet: [ 'foo', {}, ... ]
|
||||
foreach my $x (@$new) {
|
||||
if(ref($x || '') eq 'ARRAY') {
|
||||
$x = $class->new($x); # recurse
|
||||
} elsif(ref($x || '') eq 'HASH') {
|
||||
$x = { %$x };
|
||||
}
|
||||
# otherwise leave it.
|
||||
}
|
||||
|
||||
return bless $new, $class;
|
||||
}
|
||||
|
||||
# Not much in this class is likely to be link-section specific --
|
||||
# but it just so happens that link-sections are about the only treelets
|
||||
# that are exposed to the user.
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
# TODO: let it be an option whether a given subclass even wants little treelets?
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::LinkSection -- represent "section" attributes of L codes
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# a long story
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is not of interest to general users.
|
||||
|
||||
Pod::Simple uses this class for representing the value of the
|
||||
"section" attribute of "L" start-element events. Most applications
|
||||
can just use the normal stringification of objects of this class;
|
||||
they stringify to just the text content of the section,
|
||||
such as "foo" for
|
||||
C<< LZ<><Stuff/foo> >>, and "bar" for
|
||||
C<< LZ<><Stuff/bIZ<><ar>> >>.
|
||||
|
||||
However, anyone particularly interested in getting the full value of
|
||||
the treelet, can just traverse the content of the treeleet
|
||||
@$treelet_object. To wit:
|
||||
|
||||
|
||||
% perl -MData::Dumper -e
|
||||
"use base qw(Pod::Simple::Methody);
|
||||
sub start_L { print Dumper($_[1]{'section'} ) }
|
||||
__PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
|
||||
"
|
||||
Output:
|
||||
$VAR1 = bless( [
|
||||
'',
|
||||
{},
|
||||
'b',
|
||||
bless( [
|
||||
'I',
|
||||
{},
|
||||
'ar'
|
||||
], 'Pod::Simple::LinkSection' ),
|
||||
'baz'
|
||||
], 'Pod::Simple::LinkSection' );
|
||||
|
||||
But stringify it and you get just the text content:
|
||||
|
||||
% perl -MData::Dumper -e
|
||||
"use base qw(Pod::Simple::Methody);
|
||||
sub start_L { print Dumper( '' . $_[1]{'section'} ) }
|
||||
__PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
|
||||
"
|
||||
Output:
|
||||
$VAR1 = 'barbaz';
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2004 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
152
database/perl/lib/Pod/Simple/Methody.pm
Normal file
152
database/perl/lib/Pod/Simple/Methody.pm
Normal file
@@ -0,0 +1,152 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::Methody;
|
||||
use strict;
|
||||
use Pod::Simple ();
|
||||
use vars qw(@ISA $VERSION);
|
||||
$VERSION = '3.42';
|
||||
@ISA = ('Pod::Simple');
|
||||
|
||||
# Yes, we could use named variables, but I want this to be impose
|
||||
# as little an additional performance hit as possible.
|
||||
|
||||
sub _handle_element_start {
|
||||
$_[1] =~ tr/-:./__/;
|
||||
( $_[0]->can( 'start_' . $_[1] )
|
||||
|| return
|
||||
)->(
|
||||
$_[0], $_[2]
|
||||
);
|
||||
}
|
||||
|
||||
sub _handle_text {
|
||||
( $_[0]->can( 'handle_text' )
|
||||
|| return
|
||||
)->(
|
||||
@_
|
||||
);
|
||||
}
|
||||
|
||||
sub _handle_element_end {
|
||||
$_[1] =~ tr/-:./__/;
|
||||
( $_[0]->can( 'end_' . $_[1] )
|
||||
|| return
|
||||
)->(
|
||||
$_[0], $_[2]
|
||||
);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::Methody -- turn Pod::Simple events into method calls
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require 5;
|
||||
use strict;
|
||||
package SomePodFormatter;
|
||||
use base qw(Pod::Simple::Methody);
|
||||
|
||||
sub handle_text {
|
||||
my($self, $text) = @_;
|
||||
...
|
||||
}
|
||||
|
||||
sub start_head1 {
|
||||
my($self, $attrs) = @_;
|
||||
...
|
||||
}
|
||||
sub end_head1 {
|
||||
my($self) = @_;
|
||||
...
|
||||
}
|
||||
|
||||
...and start_/end_ methods for whatever other events you want to catch.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is of
|
||||
interest to people writing Pod formatters based on Pod::Simple.
|
||||
|
||||
This class (which is very small -- read the source) overrides
|
||||
Pod::Simple's _handle_element_start, _handle_text, and
|
||||
_handle_element_end methods so that parser events are turned into method
|
||||
calls. (Otherwise, this is a subclass of L<Pod::Simple> and inherits all
|
||||
its methods.)
|
||||
|
||||
You can use this class as the base class for a Pod formatter/processor.
|
||||
|
||||
=head1 METHOD CALLING
|
||||
|
||||
When Pod::Simple sees a "=head1 Hi there", for example, it basically does
|
||||
this:
|
||||
|
||||
$parser->_handle_element_start( "head1", \%attributes );
|
||||
$parser->_handle_text( "Hi there" );
|
||||
$parser->_handle_element_end( "head1" );
|
||||
|
||||
But if you subclass Pod::Simple::Methody, it will instead do this
|
||||
when it sees a "=head1 Hi there":
|
||||
|
||||
$parser->start_head1( \%attributes ) if $parser->can('start_head1');
|
||||
$parser->handle_text( "Hi there" ) if $parser->can('handle_text');
|
||||
$parser->end_head1() if $parser->can('end_head1');
|
||||
|
||||
If Pod::Simple sends an event where the element name has a dash,
|
||||
period, or colon, the corresponding method name will have a underscore
|
||||
in its place. For example, "foo.bar:baz" becomes start_foo_bar_baz
|
||||
and end_foo_bar_baz.
|
||||
|
||||
See the source for Pod::Simple::Text for an example of using this class.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::Subclassing>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
93
database/perl/lib/Pod/Simple/Progress.pm
Normal file
93
database/perl/lib/Pod/Simple/Progress.pm
Normal file
@@ -0,0 +1,93 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::Progress;
|
||||
$VERSION = '3.42';
|
||||
use strict;
|
||||
|
||||
# Objects of this class are used for noting progress of an
|
||||
# operation every so often. Messages delivered more often than that
|
||||
# are suppressed.
|
||||
#
|
||||
# There's actually nothing in here that's specific to Pod processing;
|
||||
# but it's ad-hoc enough that I'm not willing to give it a name that
|
||||
# implies that it's generally useful, like "IO::Progress" or something.
|
||||
#
|
||||
# -- sburke
|
||||
#
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
sub new {
|
||||
my($class,$delay) = @_;
|
||||
my $self = bless {'quiet_until' => 1}, ref($class) || $class;
|
||||
$self->to(*STDOUT{IO});
|
||||
$self->delay(defined($delay) ? $delay : 5);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub copy {
|
||||
my $orig = shift;
|
||||
bless {%$orig, 'quiet_until' => 1}, ref($orig);
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
sub reach {
|
||||
my($self, $point, $note) = @_;
|
||||
if( (my $now = time) >= $self->{'quiet_until'}) {
|
||||
my $goal;
|
||||
my $to = $self->{'to'};
|
||||
print $to join('',
|
||||
($self->{'quiet_until'} == 1) ? () : '... ',
|
||||
(defined $point) ? (
|
||||
'#',
|
||||
($goal = $self->{'goal'}) ? (
|
||||
' ' x (length($goal) - length($point)),
|
||||
$point, '/', $goal,
|
||||
) : $point,
|
||||
$note ? ': ' : (),
|
||||
) : (),
|
||||
$note || '',
|
||||
"\n"
|
||||
);
|
||||
$self->{'quiet_until'} = $now + $self->{'delay'};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
sub done {
|
||||
my($self, $note) = @_;
|
||||
$self->{'quiet_until'} = 1;
|
||||
return $self->reach( undef, $note );
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
# Simple accessors:
|
||||
|
||||
sub delay {
|
||||
return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] }
|
||||
sub goal {
|
||||
return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] }
|
||||
sub to {
|
||||
return $_[0]{'to' } if @_ == 1; $_[0]{'to' } = $_[1]; return $_[0] }
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
unless(caller) { # Simple self-test:
|
||||
my $p = __PACKAGE__->new->goal(5);
|
||||
$p->reach(1, "Primus!");
|
||||
sleep 1;
|
||||
$p->reach(2, "Secundus!");
|
||||
sleep 3;
|
||||
$p->reach(3, "Tertius!");
|
||||
sleep 5;
|
||||
$p->reach(4);
|
||||
$p->reach(5, "Quintus!");
|
||||
sleep 1;
|
||||
$p->done("All done");
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
1;
|
||||
__END__
|
||||
|
||||
852
database/perl/lib/Pod/Simple/PullParser.pm
Normal file
852
database/perl/lib/Pod/Simple/PullParser.pm
Normal file
@@ -0,0 +1,852 @@
|
||||
require 5;
|
||||
package Pod::Simple::PullParser;
|
||||
$VERSION = '3.42';
|
||||
use Pod::Simple ();
|
||||
BEGIN {@ISA = ('Pod::Simple')}
|
||||
|
||||
use strict;
|
||||
use Carp ();
|
||||
|
||||
use Pod::Simple::PullParserStartToken;
|
||||
use Pod::Simple::PullParserEndToken;
|
||||
use Pod::Simple::PullParserTextToken;
|
||||
|
||||
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
|
||||
|
||||
__PACKAGE__->_accessorize(
|
||||
'source_fh', # the filehandle we're reading from
|
||||
'source_scalar_ref', # the scalarref we're reading from
|
||||
'source_arrayref', # the arrayref we're reading from
|
||||
);
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
#
|
||||
# And here is how we implement a pull-parser on top of a push-parser...
|
||||
|
||||
sub filter {
|
||||
my($self, $source) = @_;
|
||||
$self = $self->new unless ref $self;
|
||||
|
||||
$source = *STDIN{IO} unless defined $source;
|
||||
$self->set_source($source);
|
||||
$self->output_fh(*STDOUT{IO});
|
||||
|
||||
$self->run; # define run() in a subclass if you want to use filter()!
|
||||
return $self;
|
||||
}
|
||||
|
||||
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
sub parse_string_document {
|
||||
my $this = shift;
|
||||
$this->set_source(\ $_[0]);
|
||||
$this->run;
|
||||
}
|
||||
|
||||
sub parse_file {
|
||||
my($this, $filename) = @_;
|
||||
$this->set_source($filename);
|
||||
$this->run;
|
||||
}
|
||||
|
||||
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
# In case anyone tries to use them:
|
||||
|
||||
sub run {
|
||||
use Carp ();
|
||||
if( __PACKAGE__ eq ref($_[0]) || $_[0]) { # I'm not being subclassed!
|
||||
Carp::croak "You can call run() only on subclasses of "
|
||||
. __PACKAGE__;
|
||||
} else {
|
||||
Carp::croak join '',
|
||||
"You can't call run() because ",
|
||||
ref($_[0]) || $_[0], " didn't define a run() method";
|
||||
}
|
||||
}
|
||||
|
||||
sub parse_lines {
|
||||
use Carp ();
|
||||
Carp::croak "Use set_source with ", __PACKAGE__,
|
||||
" and subclasses, not parse_lines";
|
||||
}
|
||||
|
||||
sub parse_line {
|
||||
use Carp ();
|
||||
Carp::croak "Use set_source with ", __PACKAGE__,
|
||||
" and subclasses, not parse_line";
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = $class->SUPER::new(@_);
|
||||
die "Couldn't construct for $class" unless $self;
|
||||
|
||||
$self->{'token_buffer'} ||= [];
|
||||
$self->{'start_token_class'} ||= 'Pod::Simple::PullParserStartToken';
|
||||
$self->{'text_token_class'} ||= 'Pod::Simple::PullParserTextToken';
|
||||
$self->{'end_token_class'} ||= 'Pod::Simple::PullParserEndToken';
|
||||
|
||||
DEBUG > 1 and print STDERR "New pullparser object: $self\n";
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
|
||||
|
||||
sub get_token {
|
||||
my $self = shift;
|
||||
DEBUG > 1 and print STDERR "\nget_token starting up on $self.\n";
|
||||
DEBUG > 2 and print STDERR " Items in token-buffer (",
|
||||
scalar( @{ $self->{'token_buffer'} } ) ,
|
||||
") :\n", map(
|
||||
" " . $_->dump . "\n", @{ $self->{'token_buffer'} }
|
||||
),
|
||||
@{ $self->{'token_buffer'} } ? '' : ' (no tokens)',
|
||||
"\n"
|
||||
;
|
||||
|
||||
until( @{ $self->{'token_buffer'} } ) {
|
||||
DEBUG > 3 and print STDERR "I need to get something into my empty token buffer...\n";
|
||||
if($self->{'source_dead'}) {
|
||||
DEBUG and print STDERR "$self 's source is dead.\n";
|
||||
push @{ $self->{'token_buffer'} }, undef;
|
||||
} elsif(exists $self->{'source_fh'}) {
|
||||
my @lines;
|
||||
my $fh = $self->{'source_fh'}
|
||||
|| Carp::croak('You have to call set_source before you can call get_token');
|
||||
|
||||
DEBUG and print STDERR "$self 's source is filehandle $fh.\n";
|
||||
# Read those many lines at a time
|
||||
for(my $i = Pod::Simple::MANY_LINES; $i--;) {
|
||||
DEBUG > 3 and print STDERR " Fetching a line from source filehandle $fh...\n";
|
||||
local $/ = $Pod::Simple::NL;
|
||||
push @lines, scalar(<$fh>); # readline
|
||||
DEBUG > 3 and print STDERR " Line is: ",
|
||||
defined($lines[-1]) ? $lines[-1] : "<undef>\n";
|
||||
unless( defined $lines[-1] ) {
|
||||
DEBUG and print STDERR "That's it for that source fh! Killing.\n";
|
||||
delete $self->{'source_fh'}; # so it can be GC'd
|
||||
last;
|
||||
}
|
||||
# but pass thru the undef, which will set source_dead to true
|
||||
|
||||
# TODO: look to see if $lines[-1] is =encoding, and if so,
|
||||
# do horribly magic things
|
||||
|
||||
}
|
||||
|
||||
if(DEBUG > 8) {
|
||||
print STDERR "* I've gotten ", scalar(@lines), " lines:\n";
|
||||
foreach my $l (@lines) {
|
||||
if(defined $l) {
|
||||
print STDERR " line {$l}\n";
|
||||
} else {
|
||||
print STDERR " line undef\n";
|
||||
}
|
||||
}
|
||||
print STDERR "* end of ", scalar(@lines), " lines\n";
|
||||
}
|
||||
|
||||
$self->SUPER::parse_lines(@lines);
|
||||
|
||||
} elsif(exists $self->{'source_arrayref'}) {
|
||||
DEBUG and print STDERR "$self 's source is arrayref $self->{'source_arrayref'}, with ",
|
||||
scalar(@{$self->{'source_arrayref'}}), " items left in it.\n";
|
||||
|
||||
DEBUG > 3 and print STDERR " Fetching ", Pod::Simple::MANY_LINES, " lines.\n";
|
||||
$self->SUPER::parse_lines(
|
||||
splice @{ $self->{'source_arrayref'} },
|
||||
0,
|
||||
Pod::Simple::MANY_LINES
|
||||
);
|
||||
unless( @{ $self->{'source_arrayref'} } ) {
|
||||
DEBUG and print STDERR "That's it for that source arrayref! Killing.\n";
|
||||
$self->SUPER::parse_lines(undef);
|
||||
delete $self->{'source_arrayref'}; # so it can be GC'd
|
||||
}
|
||||
# to make sure that an undef is always sent to signal end-of-stream
|
||||
|
||||
} elsif(exists $self->{'source_scalar_ref'}) {
|
||||
|
||||
DEBUG and print STDERR "$self 's source is scalarref $self->{'source_scalar_ref'}, with ",
|
||||
length(${ $self->{'source_scalar_ref'} }) -
|
||||
(pos(${ $self->{'source_scalar_ref'} }) || 0),
|
||||
" characters left to parse.\n";
|
||||
|
||||
DEBUG > 3 and print STDERR " Fetching a line from source-string...\n";
|
||||
if( ${ $self->{'source_scalar_ref'} } =~
|
||||
m/([^\n\r]*)((?:\r?\n)?)/g
|
||||
) {
|
||||
#print(">> $1\n"),
|
||||
$self->SUPER::parse_lines($1)
|
||||
if length($1) or length($2)
|
||||
or pos( ${ $self->{'source_scalar_ref'} })
|
||||
!= length( ${ $self->{'source_scalar_ref'} });
|
||||
# I.e., unless it's a zero-length "empty line" at the very
|
||||
# end of "foo\nbar\n" (i.e., between the \n and the EOS).
|
||||
} else { # that's the end. Byebye
|
||||
$self->SUPER::parse_lines(undef);
|
||||
delete $self->{'source_scalar_ref'};
|
||||
DEBUG and print STDERR "That's it for that source scalarref! Killing.\n";
|
||||
}
|
||||
|
||||
|
||||
} else {
|
||||
die "What source??";
|
||||
}
|
||||
}
|
||||
DEBUG and print STDERR "get_token about to return ",
|
||||
Pod::Simple::pretty( @{$self->{'token_buffer'}}
|
||||
? $self->{'token_buffer'}[-1] : undef
|
||||
), "\n";
|
||||
return shift @{$self->{'token_buffer'}}; # that's an undef if empty
|
||||
}
|
||||
|
||||
sub unget_token {
|
||||
my $self = shift;
|
||||
DEBUG and print STDERR "Ungetting ", scalar(@_), " tokens: ",
|
||||
@_ ? "@_\n" : "().\n";
|
||||
foreach my $t (@_) {
|
||||
Carp::croak "Can't unget that, because it's not a token -- it's undef!"
|
||||
unless defined $t;
|
||||
Carp::croak "Can't unget $t, because it's not a token -- it's a string!"
|
||||
unless ref $t;
|
||||
Carp::croak "Can't unget $t, because it's not a token object!"
|
||||
unless UNIVERSAL::can($t, 'type');
|
||||
}
|
||||
|
||||
unshift @{$self->{'token_buffer'}}, @_;
|
||||
DEBUG > 1 and print STDERR "Token buffer now has ",
|
||||
scalar(@{$self->{'token_buffer'}}), " items in it.\n";
|
||||
return;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
|
||||
# $self->{'source_filename'} = $source;
|
||||
|
||||
sub set_source {
|
||||
my $self = shift @_;
|
||||
return $self->{'source_fh'} unless @_;
|
||||
Carp::croak("Cannot assign new source to pull parser; create a new instance, instead")
|
||||
if $self->{'source_fh'} || $self->{'source_scalar_ref'} || $self->{'source_arrayref'};
|
||||
my $handle;
|
||||
if(!defined $_[0]) {
|
||||
Carp::croak("Can't use empty-string as a source for set_source");
|
||||
} elsif(ref(\( $_[0] )) eq 'GLOB') {
|
||||
$self->{'source_filename'} = '' . ($handle = $_[0]);
|
||||
DEBUG and print STDERR "$self 's source is glob $_[0]\n";
|
||||
# and fall thru
|
||||
} elsif(ref( $_[0] ) eq 'SCALAR') {
|
||||
$self->{'source_scalar_ref'} = $_[0];
|
||||
DEBUG and print STDERR "$self 's source is scalar ref $_[0]\n";
|
||||
return;
|
||||
} elsif(ref( $_[0] ) eq 'ARRAY') {
|
||||
$self->{'source_arrayref'} = $_[0];
|
||||
DEBUG and print STDERR "$self 's source is array ref $_[0]\n";
|
||||
return;
|
||||
} elsif(ref $_[0]) {
|
||||
$self->{'source_filename'} = '' . ($handle = $_[0]);
|
||||
DEBUG and print STDERR "$self 's source is fh-obj $_[0]\n";
|
||||
} elsif(!length $_[0]) {
|
||||
Carp::croak("Can't use empty-string as a source for set_source");
|
||||
} else { # It's a filename!
|
||||
DEBUG and print STDERR "$self 's source is filename $_[0]\n";
|
||||
{
|
||||
local *PODSOURCE;
|
||||
open(PODSOURCE, "<$_[0]") || Carp::croak "Can't open $_[0]: $!";
|
||||
$handle = *PODSOURCE{IO};
|
||||
}
|
||||
$self->{'source_filename'} = $_[0];
|
||||
DEBUG and print STDERR " Its name is $_[0].\n";
|
||||
|
||||
# TODO: file-discipline things here!
|
||||
}
|
||||
|
||||
$self->{'source_fh'} = $handle;
|
||||
DEBUG and print STDERR " Its handle is $handle\n";
|
||||
return 1;
|
||||
}
|
||||
|
||||
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
|
||||
|
||||
sub get_title_short { shift->get_short_title(@_) } # alias
|
||||
|
||||
sub get_short_title {
|
||||
my $title = shift->get_title(@_);
|
||||
$title = $1 if $title =~ m/^(\S{1,60})\s+--?\s+./s;
|
||||
# turn "Foo::Bar -- bars for your foo" into "Foo::Bar"
|
||||
return $title;
|
||||
}
|
||||
|
||||
sub get_title { shift->_get_titled_section(
|
||||
'NAME', max_token => 50, desperate => 1, @_)
|
||||
}
|
||||
sub get_version { shift->_get_titled_section(
|
||||
'VERSION',
|
||||
max_token => 400,
|
||||
accept_verbatim => 1,
|
||||
max_content_length => 3_000,
|
||||
@_,
|
||||
);
|
||||
}
|
||||
sub get_description { shift->_get_titled_section(
|
||||
'DESCRIPTION',
|
||||
max_token => 400,
|
||||
max_content_length => 3_000,
|
||||
@_,
|
||||
) }
|
||||
|
||||
sub get_authors { shift->get_author(@_) } # a harmless alias
|
||||
|
||||
sub get_author {
|
||||
my $this = shift;
|
||||
# Max_token is so high because these are
|
||||
# typically at the end of the document:
|
||||
$this->_get_titled_section('AUTHOR' , max_token => 10_000, @_) ||
|
||||
$this->_get_titled_section('AUTHORS', max_token => 10_000, @_);
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
sub _get_titled_section {
|
||||
# Based on a get_title originally contributed by Graham Barr
|
||||
my($self, $titlename, %options) = (@_);
|
||||
|
||||
my $max_token = delete $options{'max_token'};
|
||||
my $desperate_for_title = delete $options{'desperate'};
|
||||
my $accept_verbatim = delete $options{'accept_verbatim'};
|
||||
my $max_content_length = delete $options{'max_content_length'};
|
||||
my $nocase = delete $options{'nocase'};
|
||||
$max_content_length = 120 unless defined $max_content_length;
|
||||
|
||||
Carp::croak( "Unknown " . ((1 == keys %options) ? "option: " : "options: ")
|
||||
. join " ", map "[$_]", sort keys %options
|
||||
)
|
||||
if keys %options;
|
||||
|
||||
my %content_containers;
|
||||
$content_containers{'Para'} = 1;
|
||||
if($accept_verbatim) {
|
||||
$content_containers{'Verbatim'} = 1;
|
||||
$content_containers{'VerbatimFormatted'} = 1;
|
||||
}
|
||||
|
||||
my $token_count = 0;
|
||||
my $title;
|
||||
my @to_unget;
|
||||
my $state = 0;
|
||||
my $depth = 0;
|
||||
|
||||
Carp::croak "What kind of titlename is \"$titlename\"?!" unless
|
||||
defined $titlename and $titlename =~ m/^[A-Z ]{1,60}$/s; #sanity
|
||||
my $titlename_re = quotemeta($titlename);
|
||||
|
||||
my $head1_text_content;
|
||||
my $para_text_content;
|
||||
my $skipX;
|
||||
|
||||
while(
|
||||
++$token_count <= ($max_token || 1_000_000)
|
||||
and defined(my $token = $self->get_token)
|
||||
) {
|
||||
push @to_unget, $token;
|
||||
|
||||
if ($state == 0) { # seeking =head1
|
||||
if( $token->is_start and $token->tagname eq 'head1' ) {
|
||||
DEBUG and print STDERR " Found head1. Seeking content...\n";
|
||||
++$state;
|
||||
$head1_text_content = '';
|
||||
}
|
||||
}
|
||||
|
||||
elsif($state == 1) { # accumulating text until end of head1
|
||||
if( $token->is_text ) {
|
||||
unless ($skipX) {
|
||||
DEBUG and print STDERR " Adding \"", $token->text, "\" to head1-content.\n";
|
||||
$head1_text_content .= $token->text;
|
||||
}
|
||||
} elsif( $token->is_tagname('X') ) {
|
||||
# We're going to want to ignore X<> stuff.
|
||||
$skipX = $token->is_start;
|
||||
DEBUG and print STDERR +($skipX ? 'Start' : 'End'), 'ing ignoring of X<> tag';
|
||||
} elsif( $token->is_end and $token->tagname eq 'head1' ) {
|
||||
DEBUG and print STDERR " Found end of head1. Considering content...\n";
|
||||
$head1_text_content = uc $head1_text_content if $nocase;
|
||||
if($head1_text_content eq $titlename
|
||||
or $head1_text_content =~ m/\($titlename_re\)/s
|
||||
# We accept "=head1 Nomen Modularis (NAME)" for sake of i18n
|
||||
) {
|
||||
DEBUG and print STDERR " Yup, it was $titlename. Seeking next para-content...\n";
|
||||
++$state;
|
||||
} elsif(
|
||||
$desperate_for_title
|
||||
# if we're so desperate we'll take the first
|
||||
# =head1's content as a title
|
||||
and $head1_text_content =~ m/\S/
|
||||
and $head1_text_content !~ m/^[ A-Z]+$/s
|
||||
and $head1_text_content !~
|
||||
m/\((?:
|
||||
NAME | TITLE | VERSION | AUTHORS? | DESCRIPTION | SYNOPSIS
|
||||
| COPYRIGHT | LICENSE | NOTES? | FUNCTIONS? | METHODS?
|
||||
| CAVEATS? | BUGS? | SEE\ ALSO | SWITCHES | ENVIRONMENT
|
||||
)\)/sx
|
||||
# avoid accepting things like =head1 Thingy Thongy (DESCRIPTION)
|
||||
and ($max_content_length
|
||||
? (length($head1_text_content) <= $max_content_length) # sanity
|
||||
: 1)
|
||||
) {
|
||||
# Looks good; trim it
|
||||
($title = $head1_text_content) =~ s/\s+$//;
|
||||
DEBUG and print STDERR " It looks titular: \"$title\".\n\n Using that.\n";
|
||||
last;
|
||||
} else {
|
||||
--$state;
|
||||
DEBUG and print STDERR " Didn't look titular ($head1_text_content).\n",
|
||||
"\n Dropping back to seeking-head1-content mode...\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
elsif($state == 2) {
|
||||
# seeking start of para (which must immediately follow)
|
||||
if($token->is_start and $content_containers{ $token->tagname }) {
|
||||
DEBUG and print STDERR " Found start of Para. Accumulating content...\n";
|
||||
$para_text_content = '';
|
||||
++$state;
|
||||
} else {
|
||||
DEBUG and print
|
||||
" Didn't see an immediately subsequent start-Para. Reseeking H1\n";
|
||||
$state = 0;
|
||||
}
|
||||
}
|
||||
|
||||
elsif($state == 3) {
|
||||
# accumulating text until end of Para
|
||||
if( $token->is_text ) {
|
||||
DEBUG and print STDERR " Adding \"", $token->text, "\" to para-content.\n";
|
||||
$para_text_content .= $token->text;
|
||||
# and keep looking
|
||||
|
||||
} elsif( $token->is_end and $content_containers{ $token->tagname } ) {
|
||||
DEBUG and print STDERR " Found end of Para. Considering content: ",
|
||||
$para_text_content, "\n";
|
||||
|
||||
if( $para_text_content =~ m/\S/
|
||||
and ($max_content_length
|
||||
? (length($para_text_content) <= $max_content_length)
|
||||
: 1)
|
||||
) {
|
||||
# Some minimal sanity constraints, I think.
|
||||
DEBUG and print STDERR " It looks contentworthy, I guess. Using it.\n";
|
||||
$title = $para_text_content;
|
||||
last;
|
||||
} else {
|
||||
DEBUG and print STDERR " Doesn't look at all contentworthy!\n Giving up.\n";
|
||||
undef $title;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
else {
|
||||
die "IMPOSSIBLE STATE $state!\n"; # should never happen
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
# Put it all back!
|
||||
$self->unget_token(@to_unget);
|
||||
|
||||
if(DEBUG) {
|
||||
if(defined $title) { print STDERR " Returning title <$title>\n" }
|
||||
else { print STDERR "Returning title <>\n" }
|
||||
}
|
||||
|
||||
return '' unless defined $title;
|
||||
$title =~ s/^\s+//;
|
||||
return $title;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
#
|
||||
# Methods that actually do work at parse-time:
|
||||
|
||||
sub _handle_element_start {
|
||||
my $self = shift; # leaving ($element_name, $attr_hash_r)
|
||||
DEBUG > 2 and print STDERR "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n";
|
||||
|
||||
push @{ $self->{'token_buffer'} },
|
||||
$self->{'start_token_class'}->new(@_);
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_text {
|
||||
my $self = shift; # leaving ($text)
|
||||
DEBUG > 2 and print STDERR "== $_[0]\n";
|
||||
push @{ $self->{'token_buffer'} },
|
||||
$self->{'text_token_class'}->new(@_);
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_element_end {
|
||||
my $self = shift; # leaving ($element_name);
|
||||
DEBUG > 2 and print STDERR "-- $_[0]\n";
|
||||
push @{ $self->{'token_buffer'} },
|
||||
$self->{'end_token_class'}->new(@_);
|
||||
return;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::PullParser -- a pull-parser interface to parsing Pod
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $parser = SomePodProcessor->new;
|
||||
$parser->set_source( "whatever.pod" );
|
||||
$parser->run;
|
||||
|
||||
Or:
|
||||
|
||||
my $parser = SomePodProcessor->new;
|
||||
$parser->set_source( $some_filehandle_object );
|
||||
$parser->run;
|
||||
|
||||
Or:
|
||||
|
||||
my $parser = SomePodProcessor->new;
|
||||
$parser->set_source( \$document_source );
|
||||
$parser->run;
|
||||
|
||||
Or:
|
||||
|
||||
my $parser = SomePodProcessor->new;
|
||||
$parser->set_source( \@document_lines );
|
||||
$parser->run;
|
||||
|
||||
And elsewhere:
|
||||
|
||||
require 5;
|
||||
package SomePodProcessor;
|
||||
use strict;
|
||||
use base qw(Pod::Simple::PullParser);
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
Token:
|
||||
while(my $token = $self->get_token) {
|
||||
...process each token...
|
||||
}
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is for using Pod::Simple to build a Pod processor -- but
|
||||
one that uses an interface based on a stream of token objects,
|
||||
instead of based on events.
|
||||
|
||||
This is a subclass of L<Pod::Simple> and inherits all its methods.
|
||||
|
||||
A subclass of Pod::Simple::PullParser should define a C<run> method
|
||||
that calls C<< $token = $parser->get_token >> to pull tokens.
|
||||
|
||||
See the source for Pod::Simple::RTF for an example of a formatter
|
||||
that uses Pod::Simple::PullParser.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item my $token = $parser->get_token
|
||||
|
||||
This returns the next token object (which will be of a subclass of
|
||||
L<Pod::Simple::PullParserToken>), or undef if the parser-stream has hit
|
||||
the end of the document.
|
||||
|
||||
=item $parser->unget_token( $token )
|
||||
|
||||
=item $parser->unget_token( $token1, $token2, ... )
|
||||
|
||||
This restores the token object(s) to the front of the parser stream.
|
||||
|
||||
=back
|
||||
|
||||
The source has to be set before you can parse anything. The lowest-level
|
||||
way is to call C<set_source>:
|
||||
|
||||
=over
|
||||
|
||||
=item $parser->set_source( $filename )
|
||||
|
||||
=item $parser->set_source( $filehandle_object )
|
||||
|
||||
=item $parser->set_source( \$document_source )
|
||||
|
||||
=item $parser->set_source( \@document_lines )
|
||||
|
||||
=back
|
||||
|
||||
Or you can call these methods, which Pod::Simple::PullParser has defined
|
||||
to work just like Pod::Simple's same-named methods:
|
||||
|
||||
=over
|
||||
|
||||
=item $parser->parse_file(...)
|
||||
|
||||
=item $parser->parse_string_document(...)
|
||||
|
||||
=item $parser->filter(...)
|
||||
|
||||
=item $parser->parse_from_file(...)
|
||||
|
||||
=back
|
||||
|
||||
For those to work, the Pod-processing subclass of
|
||||
Pod::Simple::PullParser has to have defined a $parser->run method --
|
||||
so it is advised that all Pod::Simple::PullParser subclasses do so.
|
||||
See the Synopsis above, or the source for Pod::Simple::RTF.
|
||||
|
||||
Authors of formatter subclasses might find these methods useful to
|
||||
call on a parser object that you haven't started pulling tokens
|
||||
from yet:
|
||||
|
||||
=over
|
||||
|
||||
=item my $title_string = $parser->get_title
|
||||
|
||||
This tries to get the title string out of $parser, by getting some tokens,
|
||||
and scanning them for the title, and then ungetting them so that you can
|
||||
process the token-stream from the beginning.
|
||||
|
||||
For example, suppose you have a document that starts out:
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Hoo::Boy::Wowza -- Stuff B<wow> yeah!
|
||||
|
||||
$parser->get_title on that document will return "Hoo::Boy::Wowza --
|
||||
Stuff wow yeah!". If the document starts with:
|
||||
|
||||
=head1 Name
|
||||
|
||||
Hoo::Boy::W00t -- Stuff B<w00t> yeah!
|
||||
|
||||
Then you'll need to pass the C<nocase> option in order to recognize "Name":
|
||||
|
||||
$parser->get_title(nocase => 1);
|
||||
|
||||
In cases where get_title can't find the title, it will return empty-string
|
||||
("").
|
||||
|
||||
=item my $title_string = $parser->get_short_title
|
||||
|
||||
This is just like get_title, except that it returns just the modulename, if
|
||||
the title seems to be of the form "SomeModuleName -- description".
|
||||
|
||||
For example, suppose you have a document that starts out:
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Hoo::Boy::Wowza -- Stuff B<wow> yeah!
|
||||
|
||||
then $parser->get_short_title on that document will return
|
||||
"Hoo::Boy::Wowza".
|
||||
|
||||
But if the document starts out:
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Hooboy, stuff B<wow> yeah!
|
||||
|
||||
then $parser->get_short_title on that document will return "Hooboy,
|
||||
stuff wow yeah!". If the document starts with:
|
||||
|
||||
=head1 Name
|
||||
|
||||
Hoo::Boy::W00t -- Stuff B<w00t> yeah!
|
||||
|
||||
Then you'll need to pass the C<nocase> option in order to recognize "Name":
|
||||
|
||||
$parser->get_short_title(nocase => 1);
|
||||
|
||||
If the title can't be found, then get_short_title returns empty-string
|
||||
("").
|
||||
|
||||
=item $author_name = $parser->get_author
|
||||
|
||||
This works like get_title except that it returns the contents of the
|
||||
"=head1 AUTHOR\n\nParagraph...\n" section, assuming that that section
|
||||
isn't terribly long. To recognize a "=head1 Author\n\nParagraph\n"
|
||||
section, pass the C<nocase> option:
|
||||
|
||||
$parser->get_author(nocase => 1);
|
||||
|
||||
(This method tolerates "AUTHORS" instead of "AUTHOR" too.)
|
||||
|
||||
=item $description_name = $parser->get_description
|
||||
|
||||
This works like get_title except that it returns the contents of the
|
||||
"=head1 DESCRIPTION\n\nParagraph...\n" section, assuming that that section
|
||||
isn't terribly long. To recognize a "=head1 Description\n\nParagraph\n"
|
||||
section, pass the C<nocase> option:
|
||||
|
||||
$parser->get_description(nocase => 1);
|
||||
|
||||
=item $version_block = $parser->get_version
|
||||
|
||||
This works like get_title except that it returns the contents of
|
||||
the "=head1 VERSION\n\n[BIG BLOCK]\n" block. Note that this does NOT
|
||||
return the module's C<$VERSION>!! To recognize a
|
||||
"=head1 Version\n\n[BIG BLOCK]\n" section, pass the C<nocase> option:
|
||||
|
||||
$parser->get_version(nocase => 1);
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTE
|
||||
|
||||
You don't actually I<have> to define a C<run> method. If you're
|
||||
writing a Pod-formatter class, you should define a C<run> just so
|
||||
that users can call C<parse_file> etc, but you don't I<have> to.
|
||||
|
||||
And if you're not writing a formatter class, but are instead just
|
||||
writing a program that does something simple with a Pod::PullParser
|
||||
object (and not an object of a subclass), then there's no reason to
|
||||
bother subclassing to add a C<run> method.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>
|
||||
|
||||
L<Pod::Simple::PullParserToken> -- and its subclasses
|
||||
L<Pod::Simple::PullParserStartToken>,
|
||||
L<Pod::Simple::PullParserTextToken>, and
|
||||
L<Pod::Simple::PullParserEndToken>.
|
||||
|
||||
L<HTML::TokeParser>, which inspired this.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
JUNK:
|
||||
|
||||
sub _old_get_title { # some witchery in here
|
||||
my $self = $_[0];
|
||||
my $title;
|
||||
my @to_unget;
|
||||
|
||||
while(1) {
|
||||
push @to_unget, $self->get_token;
|
||||
unless(defined $to_unget[-1]) { # whoops, short doc!
|
||||
pop @to_unget;
|
||||
last;
|
||||
}
|
||||
|
||||
DEBUG and print STDERR "-Got token ", $to_unget[-1]->dump, "\n";
|
||||
|
||||
(DEBUG and print STDERR "Too much in the buffer.\n"),
|
||||
last if @to_unget > 25; # sanity
|
||||
|
||||
my $pattern = '';
|
||||
if( #$to_unget[-1]->type eq 'end'
|
||||
#and $to_unget[-1]->tagname eq 'Para'
|
||||
#and
|
||||
($pattern = join('',
|
||||
map {;
|
||||
($_->type eq 'start') ? ("<" . $_->tagname .">")
|
||||
: ($_->type eq 'end' ) ? ("</". $_->tagname .">")
|
||||
: ($_->type eq 'text' ) ? ($_->text =~ m<^([A-Z]+)$>s ? $1 : 'X')
|
||||
: "BLORP"
|
||||
} @to_unget
|
||||
)) =~ m{<head1>NAME</head1><Para>(X|</?[BCIFLS]>)+</Para>$}s
|
||||
) {
|
||||
# Whee, it fits the pattern
|
||||
DEBUG and print STDERR "Seems to match =head1 NAME pattern.\n";
|
||||
$title = '';
|
||||
foreach my $t (reverse @to_unget) {
|
||||
last if $t->type eq 'start' and $t->tagname eq 'Para';
|
||||
$title = $t->text . $title if $t->type eq 'text';
|
||||
}
|
||||
undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
|
||||
last;
|
||||
|
||||
} elsif ($pattern =~ m{<head(\d)>(.+)</head\d>$}
|
||||
and !( $1 eq '1' and $2 eq 'NAME' )
|
||||
) {
|
||||
# Well, it fits a fallback pattern
|
||||
DEBUG and print STDERR "Seems to match NAMEless pattern.\n";
|
||||
$title = '';
|
||||
foreach my $t (reverse @to_unget) {
|
||||
last if $t->type eq 'start' and $t->tagname =~ m/^head\d$/s;
|
||||
$title = $t->text . $title if $t->type eq 'text';
|
||||
}
|
||||
undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
|
||||
last;
|
||||
|
||||
} else {
|
||||
DEBUG and $pattern and print STDERR "Leading pattern: $pattern\n";
|
||||
}
|
||||
}
|
||||
|
||||
# Put it all back:
|
||||
$self->unget_token(@to_unget);
|
||||
|
||||
if(DEBUG) {
|
||||
if(defined $title) { print STDERR " Returning title <$title>\n" }
|
||||
else { print STDERR "Returning title <>\n" }
|
||||
}
|
||||
|
||||
return '' unless defined $title;
|
||||
return $title;
|
||||
}
|
||||
|
||||
120
database/perl/lib/Pod/Simple/PullParserEndToken.pm
Normal file
120
database/perl/lib/Pod/Simple/PullParserEndToken.pm
Normal file
@@ -0,0 +1,120 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::PullParserEndToken;
|
||||
use Pod::Simple::PullParserToken ();
|
||||
use strict;
|
||||
use vars qw(@ISA $VERSION);
|
||||
@ISA = ('Pod::Simple::PullParserToken');
|
||||
$VERSION = '3.42';
|
||||
|
||||
sub new { # Class->new(tagname);
|
||||
my $class = shift;
|
||||
return bless ['end', @_], ref($class) || $class;
|
||||
}
|
||||
|
||||
# Purely accessors:
|
||||
|
||||
sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
|
||||
sub tag { shift->tagname(@_) }
|
||||
|
||||
# shortcut:
|
||||
sub is_tagname { $_[0][1] eq $_[1] }
|
||||
sub is_tag { shift->is_tagname(@_) }
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::PullParserEndToken -- end-tokens from Pod::Simple::PullParser
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
(See L<Pod::Simple::PullParser>)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
|
||||
get an object of this class.
|
||||
|
||||
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
|
||||
and adds these methods:
|
||||
|
||||
=over
|
||||
|
||||
=item $token->tagname
|
||||
|
||||
This returns the tagname for this end-token object.
|
||||
For example, parsing a "=head1 ..." line will give you
|
||||
a start-token with the tagname of "head1", token(s) for its
|
||||
content, and then an end-token with the tagname of "head1".
|
||||
|
||||
=item $token->tagname(I<somestring>)
|
||||
|
||||
This changes the tagname for this end-token object.
|
||||
You probably won't need to do this.
|
||||
|
||||
=item $token->tag(...)
|
||||
|
||||
A shortcut for $token->tagname(...)
|
||||
|
||||
=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
|
||||
|
||||
These are shortcuts for C<< $token->tag() eq I<somestring> >>
|
||||
|
||||
=back
|
||||
|
||||
You're unlikely to ever need to construct an object of this class for
|
||||
yourself, but if you want to, call
|
||||
C<<
|
||||
Pod::Simple::PullParserEndToken->new( I<tagname> )
|
||||
>>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
161
database/perl/lib/Pod/Simple/PullParserStartToken.pm
Normal file
161
database/perl/lib/Pod/Simple/PullParserStartToken.pm
Normal file
@@ -0,0 +1,161 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::PullParserStartToken;
|
||||
use Pod::Simple::PullParserToken ();
|
||||
use strict;
|
||||
use vars qw(@ISA $VERSION);
|
||||
@ISA = ('Pod::Simple::PullParserToken');
|
||||
$VERSION = '3.42';
|
||||
|
||||
sub new { # Class->new(tagname, optional_attrhash);
|
||||
my $class = shift;
|
||||
return bless ['start', @_], ref($class) || $class;
|
||||
}
|
||||
|
||||
# Purely accessors:
|
||||
|
||||
sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
|
||||
sub tag { shift->tagname(@_) }
|
||||
|
||||
sub is_tagname { $_[0][1] eq $_[1] }
|
||||
sub is_tag { shift->is_tagname(@_) }
|
||||
|
||||
|
||||
sub attr_hash { $_[0][2] ||= {} }
|
||||
|
||||
sub attr {
|
||||
if(@_ == 2) { # Reading: $token->attr('attrname')
|
||||
${$_[0][2] || return undef}{ $_[1] };
|
||||
} elsif(@_ > 2) { # Writing: $token->attr('attrname', 'newval')
|
||||
${$_[0][2] ||= {}}{ $_[1] } = $_[2];
|
||||
} else {
|
||||
require Carp;
|
||||
Carp::croak(
|
||||
'usage: $object->attr("val") or $object->attr("key", "newval")');
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::PullParserStartToken -- start-tokens from Pod::Simple::PullParser
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
(See L<Pod::Simple::PullParser>)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When you do $parser->get_token on a L<Pod::Simple::PullParser> object, you might
|
||||
get an object of this class.
|
||||
|
||||
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
|
||||
and adds these methods:
|
||||
|
||||
=over
|
||||
|
||||
=item $token->tagname
|
||||
|
||||
This returns the tagname for this start-token object.
|
||||
For example, parsing a "=head1 ..." line will give you
|
||||
a start-token with the tagname of "head1", token(s) for its
|
||||
content, and then an end-token with the tagname of "head1".
|
||||
|
||||
=item $token->tagname(I<somestring>)
|
||||
|
||||
This changes the tagname for this start-token object.
|
||||
You probably won't need
|
||||
to do this.
|
||||
|
||||
=item $token->tag(...)
|
||||
|
||||
A shortcut for $token->tagname(...)
|
||||
|
||||
=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
|
||||
|
||||
These are shortcuts for C<< $token->tag() eq I<somestring> >>
|
||||
|
||||
=item $token->attr(I<attrname>)
|
||||
|
||||
This returns the value of the I<attrname> attribute for this start-token
|
||||
object, or undef.
|
||||
|
||||
For example, parsing a LZ<><Foo/"Bar"> link will produce a start-token
|
||||
with a "to" attribute with the value "Foo", a "type" attribute with the
|
||||
value "pod", and a "section" attribute with the value "Bar".
|
||||
|
||||
=item $token->attr(I<attrname>, I<newvalue>)
|
||||
|
||||
This sets the I<attrname> attribute for this start-token object to
|
||||
I<newvalue>. You probably won't need to do this.
|
||||
|
||||
=item $token->attr_hash
|
||||
|
||||
This returns the hashref that is the attribute set for this start-token.
|
||||
This is useful if (for example) you want to ask what all the attributes
|
||||
are -- you can just do C<< keys %{$token->attr_hash} >>
|
||||
|
||||
=back
|
||||
|
||||
|
||||
You're unlikely to ever need to construct an object of this class for
|
||||
yourself, but if you want to, call
|
||||
C<<
|
||||
Pod::Simple::PullParserStartToken->new( I<tagname>, I<attrhash> )
|
||||
>>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
134
database/perl/lib/Pod/Simple/PullParserTextToken.pm
Normal file
134
database/perl/lib/Pod/Simple/PullParserTextToken.pm
Normal file
@@ -0,0 +1,134 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::PullParserTextToken;
|
||||
use Pod::Simple::PullParserToken ();
|
||||
use strict;
|
||||
use vars qw(@ISA $VERSION);
|
||||
@ISA = ('Pod::Simple::PullParserToken');
|
||||
$VERSION = '3.42';
|
||||
|
||||
sub new { # Class->new(text);
|
||||
my $class = shift;
|
||||
return bless ['text', @_], ref($class) || $class;
|
||||
}
|
||||
|
||||
# Purely accessors:
|
||||
|
||||
sub text { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
|
||||
|
||||
sub text_r { \ $_[0][1] }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::PullParserTextToken -- text-tokens from Pod::Simple::PullParser
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
(See L<Pod::Simple::PullParser>)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
|
||||
get an object of this class.
|
||||
|
||||
This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
|
||||
and adds these methods:
|
||||
|
||||
=over
|
||||
|
||||
=item $token->text
|
||||
|
||||
This returns the text that this token holds. For example, parsing
|
||||
CZ<><foo> will return a C start-token, a text-token, and a C end-token. And
|
||||
if you want to get the "foo" out of the text-token, call C<< $token->text >>
|
||||
|
||||
=item $token->text(I<somestring>)
|
||||
|
||||
This changes the string that this token holds. You probably won't need
|
||||
to do this.
|
||||
|
||||
=item $token->text_r()
|
||||
|
||||
This returns a scalar reference to the string that this token holds.
|
||||
This can be useful if you don't want to memory-copy the potentially
|
||||
large text value (well, as large as a paragraph or a verbatim block)
|
||||
as calling $token->text would do.
|
||||
|
||||
Or, if you want to alter the value, you can even do things like this:
|
||||
|
||||
for ( ${ $token->text_r } ) { # Aliases it with $_ !!
|
||||
|
||||
s/ The / the /g; # just for example
|
||||
|
||||
if( 'A' eq chr(65) ) { # (if in an ASCII world)
|
||||
tr/\xA0/ /;
|
||||
tr/\xAD//d;
|
||||
}
|
||||
|
||||
...or however you want to alter the value...
|
||||
(Note that starting with Perl v5.8, you can use, e.g.,
|
||||
|
||||
my $nbsp = chr utf8::unicode_to_native(0xA0);
|
||||
s/$nbsp/ /g;
|
||||
|
||||
to handle the above regardless if it's an ASCII world or not)
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
You're unlikely to ever need to construct an object of this class for
|
||||
yourself, but if you want to, call
|
||||
C<<
|
||||
Pod::Simple::PullParserTextToken->new( I<text> )
|
||||
>>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
163
database/perl/lib/Pod/Simple/PullParserToken.pm
Normal file
163
database/perl/lib/Pod/Simple/PullParserToken.pm
Normal file
@@ -0,0 +1,163 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::PullParserToken;
|
||||
# Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token
|
||||
@ISA = ();
|
||||
$VERSION = '3.42';
|
||||
use strict;
|
||||
|
||||
sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway
|
||||
my $class = shift;
|
||||
return bless [@_], ref($class) || $class;
|
||||
}
|
||||
|
||||
sub type { $_[0][0] } # Can't change the type of an object
|
||||
sub dump { Pod::Simple::pretty( [ @{ $_[0] } ] ) }
|
||||
|
||||
sub is_start { $_[0][0] eq 'start' }
|
||||
sub is_end { $_[0][0] eq 'end' }
|
||||
sub is_text { $_[0][0] eq 'text' }
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
sub dump { '[' . _esc( @{ $_[0] } ) . ']' }
|
||||
|
||||
# JUNK:
|
||||
|
||||
sub _esc {
|
||||
return '' unless @_;
|
||||
my @out;
|
||||
foreach my $in (@_) {
|
||||
push @out, '"' . $in . '"';
|
||||
$out[-1] =~ s/([^- \:\:\.\,\'\>\<\"\/\=\?\+\|\[\]\{\}\_a-zA-Z0-9_\`\~\!\#\%\^\&\*\(\)])/
|
||||
sprintf( (ord($1) < 256) ? "\\x%02X" : "\\x{%X}", ord($1))
|
||||
/eg;
|
||||
}
|
||||
return join ', ', @out;
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::PullParserToken -- tokens from Pod::Simple::PullParser
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Given a $parser that's an object of class Pod::Simple::PullParser
|
||||
(or a subclass)...
|
||||
|
||||
while(my $token = $parser->get_token) {
|
||||
$DEBUG and print STDERR "Token: ", $token->dump, "\n";
|
||||
if($token->is_start) {
|
||||
...access $token->tagname, $token->attr, etc...
|
||||
|
||||
} elsif($token->is_text) {
|
||||
...access $token->text, $token->text_r, etc...
|
||||
|
||||
} elsif($token->is_end) {
|
||||
...access $token->tagname...
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
(Also see L<Pod::Simple::PullParser>)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When you do $parser->get_token on a L<Pod::Simple::PullParser>, you should
|
||||
get an object of a subclass of Pod::Simple::PullParserToken.
|
||||
|
||||
Subclasses will add methods, and will also inherit these methods:
|
||||
|
||||
=over
|
||||
|
||||
=item $token->type
|
||||
|
||||
This returns the type of the token. This will be either the string
|
||||
"start", the string "text", or the string "end".
|
||||
|
||||
Once you know what the type of an object is, you then know what
|
||||
subclass it belongs to, and therefore what methods it supports.
|
||||
|
||||
Yes, you could probably do the same thing with code like
|
||||
$token->isa('Pod::Simple::PullParserEndToken'), but that's not so
|
||||
pretty as using just $token->type, or even the following shortcuts:
|
||||
|
||||
=item $token->is_start
|
||||
|
||||
This is a shortcut for C<< $token->type() eq "start" >>
|
||||
|
||||
=item $token->is_text
|
||||
|
||||
This is a shortcut for C<< $token->type() eq "text" >>
|
||||
|
||||
=item $token->is_end
|
||||
|
||||
This is a shortcut for C<< $token->type() eq "end" >>
|
||||
|
||||
=item $token->dump
|
||||
|
||||
This returns a handy stringified value of this object. This
|
||||
is useful for debugging, as in:
|
||||
|
||||
while(my $token = $parser->get_token) {
|
||||
$DEBUG and print STDERR "Token: ", $token->dump, "\n";
|
||||
...
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
My subclasses:
|
||||
L<Pod::Simple::PullParserStartToken>,
|
||||
L<Pod::Simple::PullParserTextToken>, and
|
||||
L<Pod::Simple::PullParserEndToken>.
|
||||
|
||||
L<Pod::Simple::PullParser> and L<Pod::Simple>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
743
database/perl/lib/Pod/Simple/RTF.pm
Normal file
743
database/perl/lib/Pod/Simple/RTF.pm
Normal file
@@ -0,0 +1,743 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::RTF;
|
||||
|
||||
#sub DEBUG () {4};
|
||||
#sub Pod::Simple::DEBUG () {4};
|
||||
#sub Pod::Simple::PullParser::DEBUG () {4};
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA %Escape $WRAP %Tagmap);
|
||||
$VERSION = '3.42';
|
||||
use Pod::Simple::PullParser ();
|
||||
BEGIN {@ISA = ('Pod::Simple::PullParser')}
|
||||
|
||||
use Carp ();
|
||||
BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
|
||||
|
||||
sub to_uni ($) { # Convert native code point to Unicode
|
||||
my $x = shift;
|
||||
|
||||
# Broken for early EBCDICs
|
||||
$x = chr utf8::native_to_unicode(ord $x) if $] ge 5.007_003
|
||||
&& ord("A") != 65;
|
||||
return $x;
|
||||
}
|
||||
|
||||
# We escape out 'F' so that we can send RTF files thru the mail without the
|
||||
# slightest worry that paragraphs beginning with "From" will get munged.
|
||||
# We also escape '\', '{', '}', and '_'
|
||||
my $map_to_self = ' !"#$%&\'()*+,-./0123456789:;<=>?@ABCDEGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz|~';
|
||||
|
||||
$WRAP = 1 unless defined $WRAP;
|
||||
%Escape = (
|
||||
|
||||
# Start with every character mapping to its hex equivalent
|
||||
map( (chr($_) => sprintf("\\'%02x", $_)), 0 .. 0xFF),
|
||||
|
||||
# Override most ASCII printables with themselves (or on non-ASCII platforms,
|
||||
# their ASCII values. This is because the output is UTF-16, which is always
|
||||
# based on Unicode code points)
|
||||
map( ( substr($map_to_self, $_, 1)
|
||||
=> to_uni(substr($map_to_self, $_, 1))), 0 .. length($map_to_self) - 1),
|
||||
|
||||
# And some refinements:
|
||||
"\r" => "\n",
|
||||
"\cj" => "\n",
|
||||
"\n" => "\n\\line ",
|
||||
|
||||
"\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay)
|
||||
"\f" => "\n\\page\n", # Formfeed
|
||||
"-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen
|
||||
$Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space
|
||||
$Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen
|
||||
|
||||
# CRAZY HACKS:
|
||||
"\n" => "\\line\n",
|
||||
"\r" => "\n",
|
||||
"\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1
|
||||
"\cc" => "}",
|
||||
);
|
||||
|
||||
# Generate a string of all the characters in %Escape that don't map to
|
||||
# themselves. First, one without the hyphen, then one with.
|
||||
my $escaped_sans_hyphen = "";
|
||||
$escaped_sans_hyphen .= $_ for grep { $_ ne $Escape{$_} && $_ ne '-' }
|
||||
sort keys %Escape;
|
||||
my $escaped = "-$escaped_sans_hyphen";
|
||||
|
||||
# Then convert to patterns
|
||||
$escaped_sans_hyphen = qr/[\Q$escaped_sans_hyphen \E]/;
|
||||
$escaped= qr/[\Q$escaped\E]/;
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub _openclose {
|
||||
return map {;
|
||||
m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?";
|
||||
( $1, "{\\$2\n", "/$1", "}" );
|
||||
} @_;
|
||||
}
|
||||
|
||||
my @_to_accept;
|
||||
|
||||
%Tagmap = (
|
||||
# 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}')
|
||||
_openclose(
|
||||
'B=cs18\b',
|
||||
'I=cs16\i',
|
||||
'C=cs19\f1\lang1024\noproof',
|
||||
'F=cs17\i\lang1024\noproof',
|
||||
|
||||
'VerbatimI=cs26\i',
|
||||
'VerbatimB=cs27\b',
|
||||
'VerbatimBI=cs28\b\i',
|
||||
|
||||
map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
|
||||
qw[
|
||||
underline=ul smallcaps=scaps shadow=shad
|
||||
superscript=super subscript=sub strikethrough=strike
|
||||
outline=outl emboss=embo engrave=impr
|
||||
dotted-underline=uld dash-underline=uldash
|
||||
dot-dash-underline=uldashd dot-dot-dash-underline=uldashdd
|
||||
double-underline=uldb thick-underline=ulth
|
||||
word-underline=ulw wave-underline=ulwave
|
||||
]
|
||||
# But no double-strikethrough, because MSWord can't agree with the
|
||||
# RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!)
|
||||
),
|
||||
|
||||
# Bit of a hack here:
|
||||
'L=pod' => '{\cs22\i'."\n",
|
||||
'L=url' => '{\cs23\i'."\n",
|
||||
'L=man' => '{\cs24\i'."\n",
|
||||
'/L' => '}',
|
||||
|
||||
'Data' => "\n",
|
||||
'/Data' => "\n",
|
||||
|
||||
'Verbatim' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
|
||||
'/Verbatim' => "\n\\par}\n",
|
||||
'VerbatimFormatted' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
|
||||
'/VerbatimFormatted' => "\n\\par}\n",
|
||||
'Para' => "\n{\\pard\\li#rtfindent#\\sa180\n",
|
||||
'/Para' => "\n\\par}\n",
|
||||
'head1' => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n",
|
||||
'/head1' => "\n}\\par}\n",
|
||||
'head2' => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n",
|
||||
'/head2' => "\n}\\par}\n",
|
||||
'head3' => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n",
|
||||
'/head3' => "\n}\\par}\n",
|
||||
'head4' => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n",
|
||||
'/head4' => "\n}\\par}\n",
|
||||
# wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2
|
||||
|
||||
'item-bullet' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
|
||||
'/item-bullet' => "\n\\par}\n",
|
||||
'item-number' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
|
||||
'/item-number' => "\n\\par}\n",
|
||||
'item-text' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
|
||||
'/item-text' => "\n\\par}\n",
|
||||
|
||||
# we don't need any styles for over-* and /over-*
|
||||
);
|
||||
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
sub new {
|
||||
my $new = shift->SUPER::new(@_);
|
||||
$new->nix_X_codes(1);
|
||||
$new->nbsp_for_S(1);
|
||||
$new->accept_targets( 'rtf', 'RTF' );
|
||||
|
||||
$new->{'Tagmap'} = {%Tagmap};
|
||||
|
||||
$new->accept_codes(@_to_accept);
|
||||
$new->accept_codes('VerbatimFormatted');
|
||||
DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n";
|
||||
$new->doc_lang(
|
||||
( $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1
|
||||
: ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1)
|
||||
# yes, tolerate hex!
|
||||
: ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1)
|
||||
# yes, tolerate even more hex!
|
||||
: '1033'
|
||||
);
|
||||
|
||||
$new->head1_halfpoint_size(32);
|
||||
$new->head2_halfpoint_size(28);
|
||||
$new->head3_halfpoint_size(25);
|
||||
$new->head4_halfpoint_size(22);
|
||||
$new->codeblock_halfpoint_size(18);
|
||||
$new->header_halfpoint_size(17);
|
||||
$new->normal_halfpoint_size(25);
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
__PACKAGE__->_accessorize(
|
||||
'doc_lang',
|
||||
'head1_halfpoint_size',
|
||||
'head2_halfpoint_size',
|
||||
'head3_halfpoint_size',
|
||||
'head4_halfpoint_size',
|
||||
'codeblock_halfpoint_size',
|
||||
'header_halfpoint_size',
|
||||
'normal_halfpoint_size',
|
||||
'no_proofing_exemptions',
|
||||
);
|
||||
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
sub run {
|
||||
my $self = $_[0];
|
||||
return $self->do_middle if $self->bare_output;
|
||||
return
|
||||
$self->do_beginning && $self->do_middle && $self->do_end;
|
||||
}
|
||||
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
# Match something like an identifier. Prefer XID if available, then plain ID,
|
||||
# then just ASCII
|
||||
my $id_re = Pod::Simple::BlackBox::my_qr('[\'_\p{XIDS}][\'\p{XIDC}]+', "ab");
|
||||
$id_re = Pod::Simple::BlackBox::my_qr('[\'_\p{IDS}][\'\p{IDC}]+', "ab")
|
||||
unless $id_re;
|
||||
$id_re = qr/['_a-zA-Z]['a-zA-Z0-9_]+/ unless $id_re;
|
||||
|
||||
sub do_middle { # the main work
|
||||
my $self = $_[0];
|
||||
my $fh = $self->{'output_fh'};
|
||||
|
||||
my($token, $type, $tagname, $scratch);
|
||||
my @stack;
|
||||
my @indent_stack;
|
||||
$self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'};
|
||||
|
||||
while($token = $self->get_token) {
|
||||
|
||||
if( ($type = $token->type) eq 'text' ) {
|
||||
if( $self->{'rtfverbatim'} ) {
|
||||
DEBUG > 1 and print STDERR " $type " , $token->text, " in verbatim!\n";
|
||||
rtf_esc(0, $scratch = $token->text); # 0 => Don't escape hyphen
|
||||
print $fh $scratch;
|
||||
next;
|
||||
}
|
||||
|
||||
DEBUG > 1 and print STDERR " $type " , $token->text, "\n";
|
||||
|
||||
$scratch = $token->text;
|
||||
$scratch =~ tr/\t\cb\cc/ /d;
|
||||
|
||||
$self->{'no_proofing_exemptions'} or $scratch =~
|
||||
s/(?:
|
||||
^
|
||||
|
|
||||
(?<=[\r\n\t "\[\<\(])
|
||||
) # start on whitespace, sequence-start, or quote
|
||||
( # something looking like a Perl token:
|
||||
(?:
|
||||
[\$\@\:\<\*\\_]\S+ # either starting with a sigil, etc.
|
||||
)
|
||||
|
|
||||
# or starting alpha, but containing anything strange:
|
||||
(?:
|
||||
${id_re}[\$\@\:_<>\(\\\*]\S+
|
||||
)
|
||||
)
|
||||
/\cb$1\cc/xsg
|
||||
;
|
||||
|
||||
rtf_esc(1, $scratch); # 1 => escape hyphen
|
||||
$scratch =~
|
||||
s/(
|
||||
[^\r\n]{65} # Snare 65 characters from a line
|
||||
[^\r\n ]{0,50} # and finish any current word
|
||||
)
|
||||
(\ {1,10})(?![\r\n]) # capture some spaces not at line-end
|
||||
/$1$2\n/gx # and put a NL before those spaces
|
||||
if $WRAP;
|
||||
# This may wrap at well past the 65th column, but not past the 120th.
|
||||
|
||||
print $fh $scratch;
|
||||
|
||||
} elsif( $type eq 'start' ) {
|
||||
DEBUG > 1 and print STDERR " +$type ",$token->tagname,
|
||||
" (", map("<$_> ", %{$token->attr_hash}), ")\n";
|
||||
|
||||
if( ($tagname = $token->tagname) eq 'Verbatim'
|
||||
or $tagname eq 'VerbatimFormatted'
|
||||
) {
|
||||
++$self->{'rtfverbatim'};
|
||||
my $next = $self->get_token;
|
||||
next unless defined $next;
|
||||
my $line_count = 1;
|
||||
if($next->type eq 'text') {
|
||||
my $t = $next->text_r;
|
||||
while( $$t =~ m/$/mg ) {
|
||||
last if ++$line_count > 15; # no point in counting further
|
||||
}
|
||||
DEBUG > 3 and print STDERR " verbatim line count: $line_count\n";
|
||||
}
|
||||
$self->unget_token($next);
|
||||
$self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;
|
||||
|
||||
} elsif( $tagname =~ m/^item-/s ) {
|
||||
my @to_unget;
|
||||
my $text_count_here = 0;
|
||||
$self->{'rtfitemkeepn'} = '';
|
||||
# Some heuristics to stop item-*'s functioning as subheadings
|
||||
# from getting split from the things they're subheadings for.
|
||||
#
|
||||
# It's not terribly pretty, but it really does make things pretty.
|
||||
#
|
||||
while(1) {
|
||||
push @to_unget, $self->get_token;
|
||||
pop(@to_unget), last unless defined $to_unget[-1];
|
||||
# Erroneously used to be "unshift" instead of pop! Adds instead
|
||||
# of removes, and operates on the beginning instead of the end!
|
||||
|
||||
if($to_unget[-1]->type eq 'text') {
|
||||
if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
|
||||
DEBUG > 1 and print STDERR " item-* is too long to be keepn'd.\n";
|
||||
last;
|
||||
}
|
||||
} elsif (@to_unget > 1 and
|
||||
$to_unget[-2]->type eq 'end' and
|
||||
$to_unget[-2]->tagname =~ m/^item-/s
|
||||
) {
|
||||
# Bail out here, after setting rtfitemkeepn yea or nay.
|
||||
$self->{'rtfitemkeepn'} = '\keepn' if
|
||||
$to_unget[-1]->type eq 'start' and
|
||||
$to_unget[-1]->tagname eq 'Para';
|
||||
|
||||
DEBUG > 1 and printf STDERR " item-* before %s(%s) %s keepn'd.\n",
|
||||
$to_unget[-1]->type,
|
||||
$to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '',
|
||||
$self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
|
||||
last;
|
||||
} elsif (@to_unget > 40) {
|
||||
DEBUG > 1 and print STDERR " item-* now has too many tokens (",
|
||||
scalar(@to_unget),
|
||||
(DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (),
|
||||
") to be keepn'd.\n";
|
||||
last; # give up
|
||||
}
|
||||
# else keep while'ing along
|
||||
}
|
||||
# Now put it aaaaall back...
|
||||
$self->unget_token(@to_unget);
|
||||
|
||||
} elsif( $tagname =~ m/^over-/s ) {
|
||||
push @stack, $1;
|
||||
push @indent_stack,
|
||||
int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
|
||||
DEBUG and print STDERR "Indenting over $indent_stack[-1] twips.\n";
|
||||
$self->{'rtfindent'} += $indent_stack[-1];
|
||||
|
||||
} elsif ($tagname eq 'L') {
|
||||
$tagname .= '=' . ($token->attr('type') || 'pod');
|
||||
|
||||
} elsif ($tagname eq 'Data') {
|
||||
my $next = $self->get_token;
|
||||
next unless defined $next;
|
||||
unless( $next->type eq 'text' ) {
|
||||
$self->unget_token($next);
|
||||
next;
|
||||
}
|
||||
DEBUG and print STDERR " raw text ", $next->text, "\n";
|
||||
printf $fh "\n" . $next->text . "\n";
|
||||
next;
|
||||
}
|
||||
|
||||
defined($scratch = $self->{'Tagmap'}{$tagname}) or next;
|
||||
$scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
|
||||
print $fh $scratch;
|
||||
|
||||
if ($tagname eq 'item-number') {
|
||||
print $fh $token->attr('number'), ". \n";
|
||||
} elsif ($tagname eq 'item-bullet') {
|
||||
print $fh "\\'", ord("_"), "\n";
|
||||
#for funky testing: print $fh '', rtf_esc(1, "\x{4E4B}\x{9053}");
|
||||
}
|
||||
|
||||
} elsif( $type eq 'end' ) {
|
||||
DEBUG > 1 and print STDERR " -$type ",$token->tagname,"\n";
|
||||
if( ($tagname = $token->tagname) =~ m/^over-/s ) {
|
||||
DEBUG and print STDERR "Indenting back $indent_stack[-1] twips.\n";
|
||||
$self->{'rtfindent'} -= pop @indent_stack;
|
||||
pop @stack;
|
||||
} elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
|
||||
--$self->{'rtfverbatim'};
|
||||
}
|
||||
defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next;
|
||||
$scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
|
||||
print $fh $scratch;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
sub do_beginning {
|
||||
my $self = $_[0];
|
||||
my $fh = $self->{'output_fh'};
|
||||
return print $fh join '',
|
||||
$self->doc_init,
|
||||
$self->font_table,
|
||||
$self->stylesheet,
|
||||
$self->color_table,
|
||||
$self->doc_info,
|
||||
$self->doc_start,
|
||||
"\n"
|
||||
;
|
||||
}
|
||||
|
||||
sub do_end {
|
||||
my $self = $_[0];
|
||||
my $fh = $self->{'output_fh'};
|
||||
return print $fh '}'; # that should do it
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
|
||||
sub stylesheet {
|
||||
return sprintf <<'END',
|
||||
{\stylesheet
|
||||
{\snext0 Normal;}
|
||||
{\*\cs10 \additive Default Paragraph Font;}
|
||||
{\*\cs16 \additive \i \sbasedon10 pod-I;}
|
||||
{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;}
|
||||
{\*\cs18 \additive \b \sbasedon10 pod-B;}
|
||||
{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;}
|
||||
{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;}
|
||||
{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;}
|
||||
{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;}
|
||||
{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;}
|
||||
{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;}
|
||||
|
||||
{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;}
|
||||
{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;}
|
||||
{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;}
|
||||
{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;}
|
||||
|
||||
{\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;}
|
||||
{\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;}
|
||||
{\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;}
|
||||
{\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;}
|
||||
}
|
||||
|
||||
END
|
||||
|
||||
$_[0]->codeblock_halfpoint_size(),
|
||||
$_[0]->head1_halfpoint_size(),
|
||||
$_[0]->head2_halfpoint_size(),
|
||||
$_[0]->head3_halfpoint_size(),
|
||||
$_[0]->head4_halfpoint_size(),
|
||||
;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
# Override these as necessary for further customization
|
||||
|
||||
sub font_table {
|
||||
return <<'END'; # text font, code font, heading font
|
||||
{\fonttbl
|
||||
{\f0\froman Times New Roman;}
|
||||
{\f1\fmodern Courier New;}
|
||||
{\f2\fswiss Arial;}
|
||||
}
|
||||
|
||||
END
|
||||
}
|
||||
|
||||
sub doc_init {
|
||||
return <<'END';
|
||||
{\rtf1\ansi\deff0
|
||||
|
||||
END
|
||||
}
|
||||
|
||||
sub color_table {
|
||||
return <<'END';
|
||||
{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
|
||||
END
|
||||
}
|
||||
|
||||
|
||||
sub doc_info {
|
||||
my $self = $_[0];
|
||||
|
||||
my $class = ref($self) || $self;
|
||||
|
||||
my $tag = __PACKAGE__ . ' ' . $VERSION;
|
||||
|
||||
unless($class eq __PACKAGE__) {
|
||||
$tag = " ($tag)";
|
||||
$tag = " v" . $self->VERSION . $tag if defined $self->VERSION;
|
||||
$tag = $class . $tag;
|
||||
}
|
||||
|
||||
return sprintf <<'END',
|
||||
{\info{\doccomm
|
||||
%s
|
||||
using %s v%s
|
||||
under Perl v%s at %s GMT}
|
||||
{\author [see doc]}{\company [see doc]}{\operator [see doc]}
|
||||
}
|
||||
|
||||
END
|
||||
|
||||
# None of the following things should need escaping, I dare say!
|
||||
$tag,
|
||||
$ISA[0], $ISA[0]->VERSION(),
|
||||
$], scalar(gmtime($ENV{SOURCE_DATE_EPOCH} || time)),
|
||||
;
|
||||
}
|
||||
|
||||
sub doc_start {
|
||||
my $self = $_[0];
|
||||
my $title = $self->get_short_title();
|
||||
DEBUG and print STDERR "Short Title: <$title>\n";
|
||||
$title .= ' ' if length $title;
|
||||
|
||||
$title =~ s/ *$/ /s;
|
||||
$title =~ s/^ //s;
|
||||
$title =~ s/ $/, /s;
|
||||
# make sure it ends in a comma and a space, unless it's 0-length
|
||||
|
||||
my $is_obviously_module_name;
|
||||
$is_obviously_module_name = 1
|
||||
if $title =~ m/^\S+$/s and $title =~ m/::/s;
|
||||
# catches the most common case, at least
|
||||
|
||||
DEBUG and print STDERR "Title0: <$title>\n";
|
||||
$title = rtf_esc(1, $title); # 1 => escape hyphen
|
||||
DEBUG and print STDERR "Title1: <$title>\n";
|
||||
$title = '\lang1024\noproof ' . $title
|
||||
if $is_obviously_module_name;
|
||||
|
||||
return sprintf <<'END',
|
||||
\deflang%s\plain\lang%s\widowctrl
|
||||
{\header\pard\qr\plain\f2\fs%s
|
||||
%s
|
||||
p.\chpgn\par}
|
||||
\fs%s
|
||||
|
||||
END
|
||||
($self->doc_lang) x 2,
|
||||
$self->header_halfpoint_size,
|
||||
$title,
|
||||
$self->normal_halfpoint_size,
|
||||
;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
use integer;
|
||||
|
||||
my $question_mark_code_points =
|
||||
Pod::Simple::BlackBox::my_qr('([^\x00-\x{D7FF}\x{E000}-\x{10FFFF}])',
|
||||
"\x{110000}");
|
||||
my $plane0 =
|
||||
Pod::Simple::BlackBox::my_qr('([\x{100}-\x{FFFF}])', "\x{100}");
|
||||
my $other_unicode =
|
||||
Pod::Simple::BlackBox::my_qr('([\x{10000}-\x{10FFFF}])', "\x{10000}");
|
||||
|
||||
sub esc_uni($) {
|
||||
use if $] le 5.006002, 'utf8';
|
||||
|
||||
my $x = shift;
|
||||
|
||||
# The output is expected to be UTF-16. Surrogates and above-Unicode get
|
||||
# mapped to '?'
|
||||
$x =~ s/$question_mark_code_points/?/g if $question_mark_code_points;
|
||||
|
||||
# Non-surrogate Plane 0 characters get mapped to their code points. But
|
||||
# the standard calls for a 16bit SIGNED value.
|
||||
$x =~ s/$plane0/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg
|
||||
if $plane0;
|
||||
|
||||
# Use surrogate pairs for the rest
|
||||
$x =~ s/$other_unicode/'\\uc1\\u' . ((ord($1) >> 10) + 0xD7C0 - 65536) . '\\u' . (((ord$1) & 0x03FF) + 0xDC00 - 65536) . '?'/eg if $other_unicode;
|
||||
|
||||
return $x;
|
||||
}
|
||||
|
||||
sub rtf_esc ($$) {
|
||||
# The parameter is true if we should escape hyphens
|
||||
my $escape_re = ((shift) ? $escaped : $escaped_sans_hyphen);
|
||||
|
||||
# When false, it doesn't change "-" to hard-hyphen.
|
||||
# We don't want to change the "-" to hard-hyphen, because we want to
|
||||
# be able to paste this into a file and run it without there being
|
||||
# dire screaming about the mysterious hard-hyphen character (which
|
||||
# looks just like a normal dash character).
|
||||
# XXX The comments used to claim that when false it didn't apply computerese
|
||||
# style-smarts, but khw didn't see this actually
|
||||
|
||||
my $x; # scratch
|
||||
if(!defined wantarray) { # void context: alter in-place!
|
||||
for(@_) {
|
||||
s/($escape_re)/$Escape{$1}/g; # ESCAPER
|
||||
$_ = esc_uni($_);
|
||||
}
|
||||
return;
|
||||
} elsif(wantarray) { # return an array
|
||||
return map {; ($x = $_) =~
|
||||
s/($escape_re)/$Escape{$1}/g; # ESCAPER
|
||||
$x = esc_uni($x);
|
||||
$x;
|
||||
} @_;
|
||||
} else { # return a single scalar
|
||||
($x = ((@_ == 1) ? $_[0] : join '', @_)
|
||||
) =~ s/($escape_re)/$Escape{$1}/g; # ESCAPER
|
||||
# Escape \, {, }, -, control chars, and 7f-ff.
|
||||
$x = esc_uni($x);
|
||||
return $x;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::RTF -- format Pod as RTF
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MPod::Simple::RTF -e \
|
||||
"exit Pod::Simple::RTF->filter(shift)->any_errata_seen" \
|
||||
thingy.pod > thingy.rtf
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is a formatter that takes Pod and renders it as RTF, good for
|
||||
viewing/printing in MSWord, WordPad/write.exe, TextEdit, etc.
|
||||
|
||||
This is a subclass of L<Pod::Simple> and inherits all its methods.
|
||||
|
||||
=head1 FORMAT CONTROL ATTRIBUTES
|
||||
|
||||
You can set these attributes on the parser object before you
|
||||
call C<parse_file> (or a similar method) on it:
|
||||
|
||||
=over
|
||||
|
||||
=item $parser->head1_halfpoint_size( I<halfpoint_integer> );
|
||||
|
||||
=item $parser->head2_halfpoint_size( I<halfpoint_integer> );
|
||||
|
||||
=item $parser->head3_halfpoint_size( I<halfpoint_integer> );
|
||||
|
||||
=item $parser->head4_halfpoint_size( I<halfpoint_integer> );
|
||||
|
||||
These methods set the size (in half-points, like 52 for 26-point)
|
||||
that these heading levels will appear as.
|
||||
|
||||
=item $parser->codeblock_halfpoint_size( I<halfpoint_integer> );
|
||||
|
||||
This method sets the size (in half-points, like 21 for 10.5-point)
|
||||
that codeblocks ("verbatim sections") will appear as.
|
||||
|
||||
=item $parser->header_halfpoint_size( I<halfpoint_integer> );
|
||||
|
||||
This method sets the size (in half-points, like 15 for 7.5-point)
|
||||
that the header on each page will appear in. The header
|
||||
is usually just "I<modulename> p. I<pagenumber>".
|
||||
|
||||
=item $parser->normal_halfpoint_size( I<halfpoint_integer> );
|
||||
|
||||
This method sets the size (in half-points, like 26 for 13-point)
|
||||
that normal paragraphic text will appear in.
|
||||
|
||||
=item $parser->no_proofing_exemptions( I<true_or_false> );
|
||||
|
||||
Set this value to true if you don't want the formatter to try
|
||||
putting a hidden code on all Perl symbols (as best as it can
|
||||
notice them) that labels them as being not in English, and
|
||||
so not worth spellchecking.
|
||||
|
||||
=item $parser->doc_lang( I<microsoft_decimal_language_code> )
|
||||
|
||||
This sets the language code to tag this document as being in. By
|
||||
default, it is currently the value of the environment variable
|
||||
C<RTFDEFLANG>, or if that's not set, then the value
|
||||
1033 (for US English).
|
||||
|
||||
Setting this appropriately is useful if you want to use the RTF
|
||||
to spellcheck, and/or if you want it to hyphenate right.
|
||||
|
||||
Here are some notable values:
|
||||
|
||||
1033 US English
|
||||
2057 UK English
|
||||
3081 Australia English
|
||||
4105 Canada English
|
||||
1034 Spain Spanish
|
||||
2058 Mexico Spanish
|
||||
1031 Germany German
|
||||
1036 France French
|
||||
3084 Canada French
|
||||
1035 Finnish
|
||||
1044 Norwegian (Bokmal)
|
||||
2068 Norwegian (Nynorsk)
|
||||
|
||||
=back
|
||||
|
||||
If you are particularly interested in customizing this module's output
|
||||
even more, see the source and/or write to me.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>, L<RTF::Writer>, L<RTF::Cookbook>, L<RTF::Document>,
|
||||
L<RTF::Generator>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
1092
database/perl/lib/Pod/Simple/Search.pm
Normal file
1092
database/perl/lib/Pod/Simple/Search.pm
Normal file
File diff suppressed because it is too large
Load Diff
179
database/perl/lib/Pod/Simple/SimpleTree.pm
Normal file
179
database/perl/lib/Pod/Simple/SimpleTree.pm
Normal file
@@ -0,0 +1,179 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::SimpleTree;
|
||||
use strict;
|
||||
use Carp ();
|
||||
use Pod::Simple ();
|
||||
use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
|
||||
$VERSION = '3.42';
|
||||
BEGIN {
|
||||
@ISA = ('Pod::Simple');
|
||||
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
|
||||
}
|
||||
|
||||
__PACKAGE__->_accessorize(
|
||||
'root', # root of the tree
|
||||
);
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub _handle_element_start { # self, tagname, attrhash
|
||||
DEBUG > 2 and print STDERR "Handling $_[1] start-event\n";
|
||||
my $x = [$_[1], $_[2]];
|
||||
if($_[0]{'_currpos'}) {
|
||||
push @{ $_[0]{'_currpos'}[0] }, $x; # insert in parent's child-list
|
||||
unshift @{ $_[0]{'_currpos'} }, $x; # prefix to stack
|
||||
} else {
|
||||
DEBUG and print STDERR " And oo, it gets to be root!\n";
|
||||
$_[0]{'_currpos'} = [ $_[0]{'root'} = $x ];
|
||||
# first event! set to stack, and set as root.
|
||||
}
|
||||
DEBUG > 3 and print STDERR "Stack is now: ",
|
||||
join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_element_end { # self, tagname
|
||||
DEBUG > 2 and print STDERR "Handling $_[1] end-event\n";
|
||||
shift @{$_[0]{'_currpos'}};
|
||||
DEBUG > 3 and print STDERR "Stack is now: ",
|
||||
join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_text { # self, text
|
||||
DEBUG > 2 and print STDERR "Handling $_[1] text-event\n";
|
||||
push @{ $_[0]{'_currpos'}[0] }, $_[1];
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
# A bit of evil from the black box... please avert your eyes, kind souls.
|
||||
sub _traverse_treelet_bit {
|
||||
DEBUG > 2 and print STDERR "Handling $_[1] paragraph event\n";
|
||||
my $self = shift;
|
||||
push @{ $self->{'_currpos'}[0] }, [@_];
|
||||
return;
|
||||
}
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::SimpleTree -- parse Pod into a simple parse tree
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
% cat ptest.pod
|
||||
|
||||
=head1 PIE
|
||||
|
||||
I like B<pie>!
|
||||
|
||||
% perl -MPod::Simple::SimpleTree -MData::Dumper -e \
|
||||
"print Dumper(Pod::Simple::SimpleTree->new->parse_file(shift)->root)" \
|
||||
ptest.pod
|
||||
|
||||
$VAR1 = [
|
||||
'Document',
|
||||
{ 'start_line' => 1 },
|
||||
[
|
||||
'head1',
|
||||
{ 'start_line' => 1 },
|
||||
'PIE'
|
||||
],
|
||||
[
|
||||
'Para',
|
||||
{ 'start_line' => 3 },
|
||||
'I like ',
|
||||
[
|
||||
'B',
|
||||
{},
|
||||
'pie'
|
||||
],
|
||||
'!'
|
||||
]
|
||||
];
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is of interest to people writing a Pod processor/formatter.
|
||||
|
||||
This class takes Pod and parses it, returning a parse tree made just
|
||||
of arrayrefs, and hashrefs, and strings.
|
||||
|
||||
This is a subclass of L<Pod::Simple> and inherits all its methods.
|
||||
|
||||
This class is inspired by XML::Parser's "Tree" parsing-style, although
|
||||
it doesn't use exactly the same LoL format.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
At the end of the parse, call C<< $parser->root >> to get the
|
||||
tree's top node.
|
||||
|
||||
=head1 Tree Contents
|
||||
|
||||
Every element node in the parse tree is represented by an arrayref of
|
||||
the form: C<[ I<elementname>, \%attributes, I<...subnodes...> ]>.
|
||||
See the example tree dump in the Synopsis, above.
|
||||
|
||||
Every text node in the tree is represented by a simple (non-ref)
|
||||
string scalar. So you can test C<ref($node)> to see whether you have
|
||||
an element node or just a text node.
|
||||
|
||||
The top node in the tree is C<[ 'Document', \%attributes,
|
||||
I<...subnodes...> ]>
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>
|
||||
|
||||
L<perllol>
|
||||
|
||||
L<The "Tree" subsubsection in XML::Parser|XML::Parser/"Tree">
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
1094
database/perl/lib/Pod/Simple/Subclassing.pod
Normal file
1094
database/perl/lib/Pod/Simple/Subclassing.pod
Normal file
File diff suppressed because it is too large
Load Diff
184
database/perl/lib/Pod/Simple/Text.pm
Normal file
184
database/perl/lib/Pod/Simple/Text.pm
Normal file
@@ -0,0 +1,184 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::Text;
|
||||
use strict;
|
||||
use Carp ();
|
||||
use Pod::Simple::Methody ();
|
||||
use Pod::Simple ();
|
||||
use vars qw( @ISA $VERSION $FREAKYMODE);
|
||||
$VERSION = '3.42';
|
||||
@ISA = ('Pod::Simple::Methody');
|
||||
BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
|
||||
? \&Pod::Simple::DEBUG
|
||||
: sub() {0}
|
||||
}
|
||||
|
||||
use Text::Wrap 98.112902 ();
|
||||
$Text::Wrap::huge = 'overflow';
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $new = $self->SUPER::new(@_);
|
||||
$new->{'output_fh'} ||= *STDOUT{IO};
|
||||
$new->accept_target_as_text(qw( text plaintext plain ));
|
||||
$new->nix_X_codes(1);
|
||||
$new->nbsp_for_S(1);
|
||||
$new->{'Thispara'} = '';
|
||||
$new->{'Indent'} = 0;
|
||||
$new->{'Indentstring'} = ' ';
|
||||
return $new;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub handle_text { $_[0]{'Thispara'} .= $_[1] }
|
||||
|
||||
sub start_Para { $_[0]{'Thispara'} = '' }
|
||||
sub start_head1 { $_[0]{'Thispara'} = '' }
|
||||
sub start_head2 { $_[0]{'Thispara'} = '' }
|
||||
sub start_head3 { $_[0]{'Thispara'} = '' }
|
||||
sub start_head4 { $_[0]{'Thispara'} = '' }
|
||||
|
||||
sub start_Verbatim { $_[0]{'Thispara'} = '' }
|
||||
sub start_item_bullet { $_[0]{'Thispara'} = $FREAKYMODE ? '' : '* ' }
|
||||
sub start_item_number { $_[0]{'Thispara'} = $FREAKYMODE ? '' : "$_[1]{'number'}. " }
|
||||
sub start_item_text { $_[0]{'Thispara'} = '' }
|
||||
|
||||
sub start_over_bullet { ++$_[0]{'Indent'} }
|
||||
sub start_over_number { ++$_[0]{'Indent'} }
|
||||
sub start_over_text { ++$_[0]{'Indent'} }
|
||||
sub start_over_block { ++$_[0]{'Indent'} }
|
||||
|
||||
sub end_over_bullet { --$_[0]{'Indent'} }
|
||||
sub end_over_number { --$_[0]{'Indent'} }
|
||||
sub end_over_text { --$_[0]{'Indent'} }
|
||||
sub end_over_block { --$_[0]{'Indent'} }
|
||||
|
||||
|
||||
# . . . . . Now the actual formatters:
|
||||
|
||||
sub end_head1 { $_[0]->emit_par(-4) }
|
||||
sub end_head2 { $_[0]->emit_par(-3) }
|
||||
sub end_head3 { $_[0]->emit_par(-2) }
|
||||
sub end_head4 { $_[0]->emit_par(-1) }
|
||||
sub end_Para { $_[0]->emit_par( 0) }
|
||||
sub end_item_bullet { $_[0]->emit_par( 0) }
|
||||
sub end_item_number { $_[0]->emit_par( 0) }
|
||||
sub end_item_text { $_[0]->emit_par(-2) }
|
||||
sub start_L { $_[0]{'Link'} = $_[1] if $_[1]->{type} eq 'url' }
|
||||
sub end_L {
|
||||
if (my $link = delete $_[0]{'Link'}) {
|
||||
# Append the URL to the output unless it's already present.
|
||||
$_[0]{'Thispara'} .= " <$link->{to}>"
|
||||
unless $_[0]{'Thispara'} =~ /\b\Q$link->{to}/;
|
||||
}
|
||||
}
|
||||
|
||||
sub emit_par {
|
||||
my($self, $tweak_indent) = splice(@_,0,2);
|
||||
my $indent = ' ' x ( 2 * $self->{'Indent'} + 4 + ($tweak_indent||0) );
|
||||
# Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
|
||||
|
||||
$self->{'Thispara'} =~ s/$Pod::Simple::shy//g;
|
||||
my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
|
||||
$out =~ s/$Pod::Simple::nbsp/ /g;
|
||||
print {$self->{'output_fh'}} $out, "\n";
|
||||
$self->{'Thispara'} = '';
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# . . . . . . . . . . And then off by its lonesome:
|
||||
|
||||
sub end_Verbatim {
|
||||
my $self = shift;
|
||||
$self->{'Thispara'} =~ s/$Pod::Simple::nbsp/ /g;
|
||||
$self->{'Thispara'} =~ s/$Pod::Simple::shy//g;
|
||||
|
||||
my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
|
||||
#my $i = ' ' x (4 + $self->{'Indent'});
|
||||
|
||||
$self->{'Thispara'} =~ s/^/$i/mg;
|
||||
|
||||
print { $self->{'output_fh'} } '',
|
||||
$self->{'Thispara'},
|
||||
"\n\n"
|
||||
;
|
||||
$self->{'Thispara'} = '';
|
||||
return;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::Text -- format Pod as plaintext
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MPod::Simple::Text -e \
|
||||
"exit Pod::Simple::Text->filter(shift)->any_errata_seen" \
|
||||
thingy.pod
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is a formatter that takes Pod and renders it as
|
||||
wrapped plaintext.
|
||||
|
||||
Its wrapping is done by L<Text::Wrap>, so you can change
|
||||
C<$Text::Wrap::columns> as you like.
|
||||
|
||||
This is a subclass of L<Pod::Simple> and inherits all its methods.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::TextContent>, L<Pod::Text>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
110
database/perl/lib/Pod/Simple/TextContent.pm
Normal file
110
database/perl/lib/Pod/Simple/TextContent.pm
Normal file
@@ -0,0 +1,110 @@
|
||||
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::TextContent;
|
||||
use strict;
|
||||
use Carp ();
|
||||
use Pod::Simple ();
|
||||
use vars qw( @ISA $VERSION );
|
||||
$VERSION = '3.42';
|
||||
@ISA = ('Pod::Simple');
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $new = $self->SUPER::new(@_);
|
||||
$new->{'output_fh'} ||= *STDOUT{IO};
|
||||
$new->nix_X_codes(1);
|
||||
return $new;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub _handle_element_start {
|
||||
print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_text {
|
||||
$_[1] =~ s/$Pod::Simple::shy//g;
|
||||
$_[1] =~ s/$Pod::Simple::nbsp/ /g;
|
||||
print {$_[0]{'output_fh'}} $_[1];
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_element_end {
|
||||
print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
|
||||
return;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::TextContent -- get the text content of Pod
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
TODO
|
||||
|
||||
perl -MPod::Simple::TextContent -e \
|
||||
"exit Pod::Simple::TextContent->filter(shift)->any_errata_seen" \
|
||||
thingy.pod
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is that parses Pod and dumps just the text content. It is
|
||||
mainly meant for use by the Pod::Simple test suite, but you may find
|
||||
some other use for it.
|
||||
|
||||
This is a subclass of L<Pod::Simple> and inherits all its methods.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
105
database/perl/lib/Pod/Simple/TiedOutFH.pm
Normal file
105
database/perl/lib/Pod/Simple/TiedOutFH.pm
Normal file
@@ -0,0 +1,105 @@
|
||||
|
||||
use strict;
|
||||
package Pod::Simple::TiedOutFH;
|
||||
use Symbol ('gensym');
|
||||
use Carp ();
|
||||
use vars qw($VERSION );
|
||||
$VERSION = '3.42';
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub handle_on { # some horrible frightening things are encapsulated in here
|
||||
my $class = shift;
|
||||
$class = ref($class) || $class;
|
||||
|
||||
Carp::croak "Usage: ${class}->handle_on(\$somescalar)" unless @_;
|
||||
|
||||
my $x = (defined($_[0]) and ref($_[0]))
|
||||
? $_[0]
|
||||
: ( \( $_[0] ) )[0]
|
||||
;
|
||||
$$x = '' unless defined $$x;
|
||||
|
||||
#Pod::Simple::DEBUG and print STDERR "New $class handle on $x = \"$$x\"\n";
|
||||
|
||||
my $new = gensym();
|
||||
tie *$new, $class, $x;
|
||||
return $new;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub TIEHANDLE { # Ties to just a scalar ref
|
||||
my($class, $scalar_ref) = @_;
|
||||
$$scalar_ref = '' unless defined $$scalar_ref;
|
||||
return bless \$scalar_ref, ref($class) || $class;
|
||||
}
|
||||
|
||||
sub PRINT {
|
||||
my $it = shift;
|
||||
foreach my $x (@_) { $$$it .= $x }
|
||||
|
||||
#Pod::Simple::DEBUG > 10 and print STDERR " appended to $$it = \"$$$it\"\n";
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
return ${$_[0]};
|
||||
}
|
||||
|
||||
sub PRINTF {
|
||||
my $it = shift;
|
||||
my $format = shift;
|
||||
$$$it .= sprintf $format, @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub FILENO { ${ $_[0] } + 100 } # just to produce SOME number
|
||||
|
||||
sub CLOSE { 1 }
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
1;
|
||||
__END__
|
||||
|
||||
Chole
|
||||
|
||||
* 1 large red onion
|
||||
* 2 tomatillos
|
||||
* 4 or 5 roma tomatoes (optionally with the pulp discarded)
|
||||
* 1 tablespoons chopped ginger root (or more, to taste)
|
||||
* 2 tablespoons canola oil (or vegetable oil)
|
||||
|
||||
* 1 tablespoon garam masala
|
||||
* 1/2 teaspoon red chili powder, or to taste
|
||||
* Salt, to taste (probably quite a bit)
|
||||
* 2 (15-ounce) cans chick peas or garbanzo beans, drained and rinsed
|
||||
* juice of one smallish lime
|
||||
* a dash of balsamic vinegar (to taste)
|
||||
* cooked rice, preferably long-grain white rice (whether plain,
|
||||
basmati rice, jasmine rice, or even a mild pilaf)
|
||||
|
||||
In a blender or food processor, puree the onions, tomatoes, tomatillos,
|
||||
and ginger root. You can even do it with a Braun hand "mixer", if you
|
||||
chop things finer to start with, and work at it.
|
||||
|
||||
In a saucepan set over moderate heat, warm the oil until hot.
|
||||
|
||||
Add the puree and the balsamic vinegar, and cook, stirring occasionally,
|
||||
for 20 to 40 minutes. (Cooking it longer will make it sweeter.)
|
||||
|
||||
Add the Garam Masala, chili powder, and cook, stirring occasionally, for
|
||||
5 minutes.
|
||||
|
||||
Add the salt and chick peas and cook, stirring, until heated through.
|
||||
|
||||
Stir in the lime juice, and optionally one or two teaspoons of tahini.
|
||||
You can let it simmer longer, depending on how much softer you want the
|
||||
garbanzos to get.
|
||||
|
||||
Serve over rice, like a curry.
|
||||
|
||||
Yields 5 to 7 servings.
|
||||
|
||||
|
||||
36
database/perl/lib/Pod/Simple/Transcode.pm
Normal file
36
database/perl/lib/Pod/Simple/Transcode.pm
Normal file
@@ -0,0 +1,36 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::Transcode;
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
$VERSION = '3.42';
|
||||
|
||||
BEGIN {
|
||||
if(defined &DEBUG) {;} # Okay
|
||||
elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG; }
|
||||
else { *DEBUG = sub () {0}; }
|
||||
}
|
||||
|
||||
foreach my $class (
|
||||
'Pod::Simple::TranscodeSmart',
|
||||
'Pod::Simple::TranscodeDumb',
|
||||
'',
|
||||
) {
|
||||
$class or die "Couldn't load any encoding classes";
|
||||
DEBUG and print STDERR "About to try loading $class...\n";
|
||||
eval "require $class;";
|
||||
if($@) {
|
||||
DEBUG and print STDERR "Couldn't load $class: $@\n";
|
||||
} else {
|
||||
DEBUG and print STDERR "OK, loaded $class.\n";
|
||||
@ISA = ($class);
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
sub _blorp { return; } # just to avoid any "empty class" warning
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
86
database/perl/lib/Pod/Simple/TranscodeDumb.pm
Normal file
86
database/perl/lib/Pod/Simple/TranscodeDumb.pm
Normal file
@@ -0,0 +1,86 @@
|
||||
|
||||
require 5;
|
||||
## This module is to be use()'d only by Pod::Simple::Transcode
|
||||
|
||||
package Pod::Simple::TranscodeDumb;
|
||||
use strict;
|
||||
use vars qw($VERSION %Supported);
|
||||
$VERSION = '3.42';
|
||||
# This module basically pretends it knows how to transcode, except
|
||||
# only for null-transcodings! We use this when Encode isn't
|
||||
# available.
|
||||
|
||||
%Supported = (
|
||||
'ascii' => 1,
|
||||
'ascii-ctrl' => 1,
|
||||
'iso-8859-1' => 1,
|
||||
'cp1252' => 1,
|
||||
'null' => 1,
|
||||
'latin1' => 1,
|
||||
'latin-1' => 1,
|
||||
%Supported,
|
||||
);
|
||||
|
||||
sub is_dumb {1}
|
||||
sub is_smart {0}
|
||||
|
||||
sub all_encodings {
|
||||
return sort keys %Supported;
|
||||
}
|
||||
|
||||
sub encoding_is_available {
|
||||
return exists $Supported{lc $_[1]};
|
||||
}
|
||||
|
||||
sub encmodver {
|
||||
return __PACKAGE__ . " v" .($VERSION || '?');
|
||||
}
|
||||
|
||||
sub make_transcoder {
|
||||
my ($e) = $_[1];
|
||||
die "WHAT ENCODING!?!?" unless $e;
|
||||
# No-op for all but CP1252.
|
||||
return sub {;} if $e !~ /^cp-?1252$/i;
|
||||
|
||||
# Replace CP1252 nerbles with their ASCII equivalents.
|
||||
return sub {
|
||||
# Copied from Encode::ZapCP1252.
|
||||
my %ascii_for = (
|
||||
# http://en.wikipedia.org/wiki/Windows-1252
|
||||
"\x80" => 'e', # EURO SIGN
|
||||
"\x82" => ',', # SINGLE LOW-9 QUOTATION MARK
|
||||
"\x83" => 'f', # LATIN SMALL LETTER F WITH HOOK
|
||||
"\x84" => ',,', # DOUBLE LOW-9 QUOTATION MARK
|
||||
"\x85" => '...', # HORIZONTAL ELLIPSIS
|
||||
"\x86" => '+', # DAGGER
|
||||
"\x87" => '++', # DOUBLE DAGGER
|
||||
"\x88" => '^', # MODIFIER LETTER CIRCUMFLEX ACCENT
|
||||
"\x89" => '%', # PER MILLE SIGN
|
||||
"\x8a" => 'S', # LATIN CAPITAL LETTER S WITH CARON
|
||||
"\x8b" => '<', # SINGLE LEFT-POINTING ANGLE QUOTATION MARK
|
||||
"\x8c" => 'OE', # LATIN CAPITAL LIGATURE OE
|
||||
"\x8e" => 'Z', # LATIN CAPITAL LETTER Z WITH CARON
|
||||
"\x91" => "'", # LEFT SINGLE QUOTATION MARK
|
||||
"\x92" => "'", # RIGHT SINGLE QUOTATION MARK
|
||||
"\x93" => '"', # LEFT DOUBLE QUOTATION MARK
|
||||
"\x94" => '"', # RIGHT DOUBLE QUOTATION MARK
|
||||
"\x95" => '*', # BULLET
|
||||
"\x96" => '-', # EN DASH
|
||||
"\x97" => '--', # EM DASH
|
||||
"\x98" => '~', # SMALL TILDE
|
||||
"\x99" => '(tm)', # TRADE MARK SIGN
|
||||
"\x9a" => 's', # LATIN SMALL LETTER S WITH CARON
|
||||
"\x9b" => '>', # SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
|
||||
"\x9c" => 'oe', # LATIN SMALL LIGATURE OE
|
||||
"\x9e" => 'z', # LATIN SMALL LETTER Z WITH CARON
|
||||
"\x9f" => 'Y', # LATIN CAPITAL LETTER Y WITH DIAERESIS
|
||||
);
|
||||
|
||||
s{([\x80-\x9f])}{$ascii_for{$1} || $1}emxsg for @_;
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
||||
44
database/perl/lib/Pod/Simple/TranscodeSmart.pm
Normal file
44
database/perl/lib/Pod/Simple/TranscodeSmart.pm
Normal file
@@ -0,0 +1,44 @@
|
||||
|
||||
require 5;
|
||||
use 5.008;
|
||||
## Anything before 5.8.0 is GIMPY!
|
||||
## This module is to be use()'d only by Pod::Simple::Transcode
|
||||
|
||||
package Pod::Simple::TranscodeSmart;
|
||||
use strict;
|
||||
use Pod::Simple;
|
||||
require Encode;
|
||||
use vars qw($VERSION );
|
||||
$VERSION = '3.42';
|
||||
|
||||
sub is_dumb {0}
|
||||
sub is_smart {1}
|
||||
|
||||
sub all_encodings {
|
||||
return Encode::->encodings(':all');
|
||||
}
|
||||
|
||||
sub encoding_is_available {
|
||||
return Encode::resolve_alias($_[1]);
|
||||
}
|
||||
|
||||
sub encmodver {
|
||||
return "Encode.pm v" .($Encode::VERSION || '?');
|
||||
}
|
||||
|
||||
sub make_transcoder {
|
||||
my $e = Encode::find_encoding($_[1]);
|
||||
die "WHAT ENCODING!?!?" unless $e;
|
||||
my $x;
|
||||
return sub {
|
||||
foreach $x (@_) {
|
||||
$x = $e->decode($x) unless Encode::is_utf8($x);
|
||||
}
|
||||
return;
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
||||
883
database/perl/lib/Pod/Simple/XHTML.pm
Normal file
883
database/perl/lib/Pod/Simple/XHTML.pm
Normal file
@@ -0,0 +1,883 @@
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::XHTML -- format Pod as validating XHTML
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Pod::Simple::XHTML;
|
||||
|
||||
my $parser = Pod::Simple::XHTML->new();
|
||||
|
||||
...
|
||||
|
||||
$parser->parse_file('path/to/file.pod');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is a formatter that takes Pod and renders it as XHTML
|
||||
validating HTML.
|
||||
|
||||
This is a subclass of L<Pod::Simple::Methody> and inherits all its
|
||||
methods. The implementation is entirely different than
|
||||
L<Pod::Simple::HTML>, but it largely preserves the same interface.
|
||||
|
||||
=head2 Minimal code
|
||||
|
||||
use Pod::Simple::XHTML;
|
||||
my $psx = Pod::Simple::XHTML->new;
|
||||
$psx->output_string(\my $html);
|
||||
$psx->parse_file('path/to/Module/Name.pm');
|
||||
open my $out, '>', 'out.html' or die "Cannot open 'out.html': $!\n";
|
||||
print $out $html;
|
||||
|
||||
You can also control the character encoding and entities. For example, if
|
||||
you're sure that the POD is properly encoded (using the C<=encoding> command),
|
||||
you can prevent high-bit characters from being encoded as HTML entities and
|
||||
declare the output character set as UTF-8 before parsing, like so:
|
||||
|
||||
$psx->html_charset('UTF-8');
|
||||
$psx->html_encode_chars(q{&<>'"});
|
||||
|
||||
=cut
|
||||
|
||||
package Pod::Simple::XHTML;
|
||||
use strict;
|
||||
use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES );
|
||||
$VERSION = '3.42';
|
||||
use Pod::Simple::Methody ();
|
||||
@ISA = ('Pod::Simple::Methody');
|
||||
|
||||
BEGIN {
|
||||
$HAS_HTML_ENTITIES = eval "require HTML::Entities; 1";
|
||||
}
|
||||
|
||||
my %entities = (
|
||||
q{>} => 'gt',
|
||||
q{<} => 'lt',
|
||||
q{'} => '#39',
|
||||
q{"} => 'quot',
|
||||
q{&} => 'amp',
|
||||
);
|
||||
|
||||
sub encode_entities {
|
||||
my $self = shift;
|
||||
my $ents = $self->html_encode_chars;
|
||||
return HTML::Entities::encode_entities( $_[0], $ents ) if $HAS_HTML_ENTITIES;
|
||||
if (defined $ents) {
|
||||
$ents =~ s,(?<!\\)([]/]),\\$1,g;
|
||||
$ents =~ s,(?<!\\)\\\z,\\\\,;
|
||||
} else {
|
||||
$ents = join '', keys %entities;
|
||||
}
|
||||
my $str = $_[0];
|
||||
$str =~ s/([$ents])/'&' . ($entities{$1} || sprintf '#x%X', ord $1) . ';'/ge;
|
||||
return $str;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
Pod::Simple::XHTML offers a number of methods that modify the format of
|
||||
the HTML output. Call these after creating the parser object, but before
|
||||
the call to C<parse_file>:
|
||||
|
||||
my $parser = Pod::PseudoPod::HTML->new();
|
||||
$parser->set_optional_param("value");
|
||||
$parser->parse_file($file);
|
||||
|
||||
=head2 perldoc_url_prefix
|
||||
|
||||
In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
|
||||
to put before the "Foo%3a%3aBar". The default value is
|
||||
"https://metacpan.org/pod/".
|
||||
|
||||
=head2 perldoc_url_postfix
|
||||
|
||||
What to put after "Foo%3a%3aBar" in the URL. This option is not set by
|
||||
default.
|
||||
|
||||
=head2 man_url_prefix
|
||||
|
||||
In turning C<< L<crontab(5)> >> into http://whatever/man/1/crontab, what
|
||||
to put before the "1/crontab". The default value is
|
||||
"http://man.he.net/man".
|
||||
|
||||
=head2 man_url_postfix
|
||||
|
||||
What to put after "1/crontab" in the URL. This option is not set by default.
|
||||
|
||||
=head2 title_prefix, title_postfix
|
||||
|
||||
What to put before and after the title in the head. The values should
|
||||
already be &-escaped.
|
||||
|
||||
=head2 html_css
|
||||
|
||||
$parser->html_css('path/to/style.css');
|
||||
|
||||
The URL or relative path of a CSS file to include. This option is not
|
||||
set by default.
|
||||
|
||||
=head2 html_javascript
|
||||
|
||||
The URL or relative path of a JavaScript file to pull in. This option is
|
||||
not set by default.
|
||||
|
||||
=head2 html_doctype
|
||||
|
||||
A document type tag for the file. This option is not set by default.
|
||||
|
||||
=head2 html_charset
|
||||
|
||||
The character set to declare in the Content-Type meta tag created by default
|
||||
for C<html_header_tags>. Note that this option will be ignored if the value of
|
||||
C<html_header_tags> is changed. Defaults to "ISO-8859-1".
|
||||
|
||||
=head2 html_header_tags
|
||||
|
||||
Additional arbitrary HTML tags for the header of the document. The
|
||||
default value is just a content type header tag:
|
||||
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
|
||||
|
||||
Add additional meta tags here, or blocks of inline CSS or JavaScript
|
||||
(wrapped in the appropriate tags).
|
||||
|
||||
=head3 html_encode_chars
|
||||
|
||||
A string containing all characters that should be encoded as HTML entities,
|
||||
specified using the regular expression character class syntax (what you find
|
||||
within brackets in regular expressions). This value will be passed as the
|
||||
second argument to the C<encode_entities> function of L<HTML::Entities>. If
|
||||
L<HTML::Entities> is not installed, then any characters other than C<&<>"'>
|
||||
will be encoded numerically.
|
||||
|
||||
=head2 html_h_level
|
||||
|
||||
This is the level of HTML "Hn" element to which a Pod "head1" corresponds. For
|
||||
example, if C<html_h_level> is set to 2, a head1 will produce an H2, a head2
|
||||
will produce an H3, and so on.
|
||||
|
||||
=head2 default_title
|
||||
|
||||
Set a default title for the page if no title can be determined from the
|
||||
content. The value of this string should already be &-escaped.
|
||||
|
||||
=head2 force_title
|
||||
|
||||
Force a title for the page (don't try to determine it from the content).
|
||||
The value of this string should already be &-escaped.
|
||||
|
||||
=head2 html_header, html_footer
|
||||
|
||||
Set the HTML output at the beginning and end of each file. The default
|
||||
header includes a title, a doctype tag (if C<html_doctype> is set), a
|
||||
content tag (customized by C<html_header_tags>), a tag for a CSS file
|
||||
(if C<html_css> is set), and a tag for a Javascript file (if
|
||||
C<html_javascript> is set). The default footer simply closes the C<html>
|
||||
and C<body> tags.
|
||||
|
||||
The options listed above customize parts of the default header, but
|
||||
setting C<html_header> or C<html_footer> completely overrides the
|
||||
built-in header or footer. These may be useful if you want to use
|
||||
template tags instead of literal HTML headers and footers or are
|
||||
integrating converted POD pages in a larger website.
|
||||
|
||||
If you want no headers or footers output in the HTML, set these options
|
||||
to the empty string.
|
||||
|
||||
=head2 index
|
||||
|
||||
Whether to add a table-of-contents at the top of each page (called an
|
||||
index for the sake of tradition).
|
||||
|
||||
=head2 anchor_items
|
||||
|
||||
Whether to anchor every definition C<=item> directive. This needs to be
|
||||
enabled if you want to be able to link to specific C<=item> directives, which
|
||||
are output as C<< <dt> >> elements. Disabled by default.
|
||||
|
||||
=head2 backlink
|
||||
|
||||
Whether to turn every =head1 directive into a link pointing to the top
|
||||
of the page (specifically, the opening body tag).
|
||||
|
||||
=cut
|
||||
|
||||
__PACKAGE__->_accessorize(
|
||||
'perldoc_url_prefix',
|
||||
'perldoc_url_postfix',
|
||||
'man_url_prefix',
|
||||
'man_url_postfix',
|
||||
'title_prefix', 'title_postfix',
|
||||
'html_css',
|
||||
'html_javascript',
|
||||
'html_doctype',
|
||||
'html_charset',
|
||||
'html_encode_chars',
|
||||
'html_h_level',
|
||||
'title', # Used internally for the title extracted from the content
|
||||
'default_title',
|
||||
'force_title',
|
||||
'html_header',
|
||||
'html_footer',
|
||||
'index',
|
||||
'anchor_items',
|
||||
'backlink',
|
||||
'batch_mode', # whether we're in batch mode
|
||||
'batch_mode_current_level',
|
||||
# When in batch mode, how deep the current module is: 1 for "LWP",
|
||||
# 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
|
||||
);
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
If the standard options aren't enough, you may want to subclass
|
||||
Pod::Simple::XHMTL. These are the most likely candidates for methods
|
||||
you'll want to override when subclassing.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $new = $self->SUPER::new(@_);
|
||||
$new->{'output_fh'} ||= *STDOUT{IO};
|
||||
$new->perldoc_url_prefix('https://metacpan.org/pod/');
|
||||
$new->man_url_prefix('http://man.he.net/man');
|
||||
$new->html_charset('ISO-8859-1');
|
||||
$new->nix_X_codes(1);
|
||||
$new->{'scratch'} = '';
|
||||
$new->{'to_index'} = [];
|
||||
$new->{'output'} = [];
|
||||
$new->{'saved'} = [];
|
||||
$new->{'ids'} = { '_podtop_' => 1 }; # used in <body>
|
||||
$new->{'in_li'} = [];
|
||||
|
||||
$new->{'__region_targets'} = [];
|
||||
$new->{'__literal_targets'} = {};
|
||||
$new->accept_targets_as_html( 'html', 'HTML' );
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
sub html_header_tags {
|
||||
my $self = shift;
|
||||
return $self->{html_header_tags} = shift if @_;
|
||||
return $self->{html_header_tags}
|
||||
||= '<meta http-equiv="Content-Type" content="text/html; charset='
|
||||
. $self->html_charset . '" />';
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
=head2 handle_text
|
||||
|
||||
This method handles the body of text within any element: it's the body
|
||||
of a paragraph, or everything between a "=begin" tag and the
|
||||
corresponding "=end" tag, or the text within an L entity, etc. You would
|
||||
want to override this if you are adding a custom element type that does
|
||||
more than just display formatted text. Perhaps adding a way to generate
|
||||
HTML tables from an extended version of POD.
|
||||
|
||||
So, let's say you want to add a custom element called 'foo'. In your
|
||||
subclass's C<new> method, after calling C<SUPER::new> you'd call:
|
||||
|
||||
$new->accept_targets_as_text( 'foo' );
|
||||
|
||||
Then override the C<start_for> method in the subclass to check for when
|
||||
"$flags->{'target'}" is equal to 'foo' and set a flag that marks that
|
||||
you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the
|
||||
C<handle_text> method to check for the flag, and pass $text to your
|
||||
custom subroutine to construct the HTML output for 'foo' elements,
|
||||
something like:
|
||||
|
||||
sub handle_text {
|
||||
my ($self, $text) = @_;
|
||||
if ($self->{'in_foo'}) {
|
||||
$self->{'scratch'} .= build_foo_html($text);
|
||||
return;
|
||||
}
|
||||
$self->SUPER::handle_text($text);
|
||||
}
|
||||
|
||||
=head2 handle_code
|
||||
|
||||
This method handles the body of text that is marked up to be code.
|
||||
You might for instance override this to plug in a syntax highlighter.
|
||||
The base implementation just escapes the text.
|
||||
|
||||
The callback methods C<start_code> and C<end_code> emits the C<code> tags
|
||||
before and after C<handle_code> is invoked, so you might want to override these
|
||||
together with C<handle_code> if this wrapping isn't suitable.
|
||||
|
||||
Note that the code might be broken into multiple segments if there are
|
||||
nested formatting codes inside a C<< CE<lt>...> >> sequence. In between the
|
||||
calls to C<handle_code> other markup tags might have been emitted in that
|
||||
case. The same is true for verbatim sections if the C<codes_in_verbatim>
|
||||
option is turned on.
|
||||
|
||||
=head2 accept_targets_as_html
|
||||
|
||||
This method behaves like C<accept_targets_as_text>, but also marks the region
|
||||
as one whose content should be emitted literally, without HTML entity escaping
|
||||
or wrapping in a C<div> element.
|
||||
|
||||
=cut
|
||||
|
||||
sub __in_literal_xhtml_region {
|
||||
return unless @{ $_[0]{__region_targets} };
|
||||
my $target = $_[0]{__region_targets}[-1];
|
||||
return $_[0]{__literal_targets}{ $target };
|
||||
}
|
||||
|
||||
sub accept_targets_as_html {
|
||||
my ($self, @targets) = @_;
|
||||
$self->accept_targets(@targets);
|
||||
$self->{__literal_targets}{$_} = 1 for @targets;
|
||||
}
|
||||
|
||||
sub handle_text {
|
||||
# escape special characters in HTML (<, >, &, etc)
|
||||
my $text = $_[0]->__in_literal_xhtml_region
|
||||
? $_[1]
|
||||
: $_[0]->encode_entities( $_[1] );
|
||||
|
||||
if ($_[0]{'in_code'} && @{$_[0]{'in_code'}}) {
|
||||
# Intentionally use the raw text in $_[1], even if we're not in a
|
||||
# literal xhtml region, since handle_code calls encode_entities.
|
||||
$_[0]->handle_code( $_[1], $_[0]{'in_code'}[-1] );
|
||||
} else {
|
||||
if ($_[0]->{in_for}) {
|
||||
my $newlines = $_[0]->__in_literal_xhtml_region ? "\n\n" : '';
|
||||
if ($_[0]->{started_for}) {
|
||||
if ($text =~ /\S/) {
|
||||
delete $_[0]->{started_for};
|
||||
$_[0]{'scratch'} .= $text . $newlines;
|
||||
}
|
||||
# Otherwise, append nothing until we have something to append.
|
||||
} else {
|
||||
# The parser sometimes preserves newlines and sometimes doesn't!
|
||||
$text =~ s/\n\z//;
|
||||
$_[0]{'scratch'} .= $text . $newlines;
|
||||
}
|
||||
} else {
|
||||
# Just plain text.
|
||||
$_[0]{'scratch'} .= $text;
|
||||
}
|
||||
}
|
||||
|
||||
$_[0]{htext} .= $text if $_[0]{'in_head'};
|
||||
}
|
||||
|
||||
sub start_code {
|
||||
$_[0]{'scratch'} .= '<code>';
|
||||
}
|
||||
|
||||
sub end_code {
|
||||
$_[0]{'scratch'} .= '</code>';
|
||||
}
|
||||
|
||||
sub handle_code {
|
||||
$_[0]{'scratch'} .= $_[0]->encode_entities( $_[1] );
|
||||
}
|
||||
|
||||
sub start_Para {
|
||||
$_[0]{'scratch'} .= '<p>';
|
||||
}
|
||||
|
||||
sub start_Verbatim {
|
||||
$_[0]{'scratch'} = '<pre>';
|
||||
push(@{$_[0]{'in_code'}}, 'Verbatim');
|
||||
$_[0]->start_code($_[0]{'in_code'}[-1]);
|
||||
}
|
||||
|
||||
sub start_head1 { $_[0]{'in_head'} = 1; $_[0]{htext} = ''; }
|
||||
sub start_head2 { $_[0]{'in_head'} = 2; $_[0]{htext} = ''; }
|
||||
sub start_head3 { $_[0]{'in_head'} = 3; $_[0]{htext} = ''; }
|
||||
sub start_head4 { $_[0]{'in_head'} = 4; $_[0]{htext} = ''; }
|
||||
sub start_head5 { $_[0]{'in_head'} = 5; $_[0]{htext} = ''; }
|
||||
sub start_head6 { $_[0]{'in_head'} = 6; $_[0]{htext} = ''; }
|
||||
|
||||
sub start_item_number {
|
||||
$_[0]{'scratch'} = "</li>\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
|
||||
$_[0]{'scratch'} .= '<li><p>';
|
||||
push @{$_[0]{'in_li'}}, 1;
|
||||
}
|
||||
|
||||
sub start_item_bullet {
|
||||
$_[0]{'scratch'} = "</li>\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
|
||||
$_[0]{'scratch'} .= '<li><p>';
|
||||
push @{$_[0]{'in_li'}}, 1;
|
||||
}
|
||||
|
||||
sub start_item_text {
|
||||
# see end_item_text
|
||||
}
|
||||
|
||||
sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
|
||||
sub start_over_block { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
|
||||
sub start_over_number { $_[0]{'scratch'} = '<ol>'; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
|
||||
sub start_over_text {
|
||||
$_[0]{'scratch'} = '<dl>';
|
||||
$_[0]{'dl_level'}++;
|
||||
$_[0]{'in_dd'} ||= [];
|
||||
$_[0]->emit
|
||||
}
|
||||
|
||||
sub end_over_block { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit }
|
||||
|
||||
sub end_over_number {
|
||||
$_[0]{'scratch'} = "</li>\n" if ( pop @{$_[0]{'in_li'}} );
|
||||
$_[0]{'scratch'} .= '</ol>';
|
||||
pop @{$_[0]{'in_li'}};
|
||||
$_[0]->emit;
|
||||
}
|
||||
|
||||
sub end_over_bullet {
|
||||
$_[0]{'scratch'} = "</li>\n" if ( pop @{$_[0]{'in_li'}} );
|
||||
$_[0]{'scratch'} .= '</ul>';
|
||||
pop @{$_[0]{'in_li'}};
|
||||
$_[0]->emit;
|
||||
}
|
||||
|
||||
sub end_over_text {
|
||||
if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
|
||||
$_[0]{'scratch'} = "</dd>\n";
|
||||
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
|
||||
}
|
||||
$_[0]{'scratch'} .= '</dl>';
|
||||
$_[0]{'dl_level'}--;
|
||||
$_[0]->emit;
|
||||
}
|
||||
|
||||
# . . . . . Now the actual formatters:
|
||||
|
||||
sub end_Para { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
|
||||
sub end_Verbatim {
|
||||
$_[0]->end_code(pop(@{$_[0]->{'in_code'}}));
|
||||
$_[0]{'scratch'} .= '</pre>';
|
||||
$_[0]->emit;
|
||||
}
|
||||
|
||||
sub _end_head {
|
||||
my $h = delete $_[0]{in_head};
|
||||
|
||||
my $add = $_[0]->html_h_level;
|
||||
$add = 1 unless defined $add;
|
||||
$h += $add - 1;
|
||||
|
||||
my $id = $_[0]->idify($_[0]{htext});
|
||||
my $text = $_[0]{scratch};
|
||||
$_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0)
|
||||
# backlinks enabled && =head1
|
||||
? qq{<a href="#_podtop_"><h$h id="$id">$text</h$h></a>}
|
||||
: qq{<h$h id="$id">$text</h$h>};
|
||||
$_[0]->emit;
|
||||
push @{ $_[0]{'to_index'} }, [$h, $id, delete $_[0]{'htext'}];
|
||||
}
|
||||
|
||||
sub end_head1 { shift->_end_head(@_); }
|
||||
sub end_head2 { shift->_end_head(@_); }
|
||||
sub end_head3 { shift->_end_head(@_); }
|
||||
sub end_head4 { shift->_end_head(@_); }
|
||||
sub end_head5 { shift->_end_head(@_); }
|
||||
sub end_head6 { shift->_end_head(@_); }
|
||||
|
||||
sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
|
||||
sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
|
||||
|
||||
sub end_item_text {
|
||||
# idify and anchor =item content if wanted
|
||||
my $dt_id = $_[0]{'anchor_items'}
|
||||
? ' id="'. $_[0]->idify($_[0]{'scratch'}) .'"'
|
||||
: '';
|
||||
|
||||
# reset scratch
|
||||
my $text = $_[0]{scratch};
|
||||
$_[0]{'scratch'} = '';
|
||||
|
||||
if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
|
||||
$_[0]{'scratch'} = "</dd>\n";
|
||||
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
|
||||
}
|
||||
|
||||
$_[0]{'scratch'} .= qq{<dt$dt_id>$text</dt>\n<dd>};
|
||||
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
|
||||
$_[0]->emit;
|
||||
}
|
||||
|
||||
# This handles =begin and =for blocks of all kinds.
|
||||
sub start_for {
|
||||
my ($self, $flags) = @_;
|
||||
|
||||
push @{ $self->{__region_targets} }, $flags->{target_matching};
|
||||
$self->{started_for} = 1;
|
||||
$self->{in_for} = 1;
|
||||
|
||||
unless ($self->__in_literal_xhtml_region) {
|
||||
$self->{scratch} .= '<div';
|
||||
$self->{scratch} .= qq( class="$flags->{target}") if $flags->{target};
|
||||
$self->{scratch} .= ">\n\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub end_for {
|
||||
my ($self) = @_;
|
||||
delete $self->{started_for};
|
||||
delete $self->{in_for};
|
||||
|
||||
if ($self->__in_literal_xhtml_region) {
|
||||
# Remove trailine newlines.
|
||||
$self->{'scratch'} =~ s/\s+\z//s;
|
||||
} else {
|
||||
$self->{'scratch'} .= '</div>';
|
||||
}
|
||||
|
||||
pop @{ $self->{__region_targets} };
|
||||
$self->emit;
|
||||
}
|
||||
|
||||
sub start_Document {
|
||||
my ($self) = @_;
|
||||
if (defined $self->html_header) {
|
||||
$self->{'scratch'} .= $self->html_header;
|
||||
$self->emit unless $self->html_header eq "";
|
||||
} else {
|
||||
my ($doctype, $title, $metatags, $bodyid);
|
||||
$doctype = $self->html_doctype || '';
|
||||
$title = $self->force_title || $self->title || $self->default_title || '';
|
||||
$metatags = $self->html_header_tags || '';
|
||||
if (my $css = $self->html_css) {
|
||||
if ($css !~ /<link/) {
|
||||
# this is required to be compatible with Pod::Simple::BatchHTML
|
||||
$metatags .= '<link rel="stylesheet" href="'
|
||||
. $self->encode_entities($css) . '" type="text/css" />';
|
||||
} else {
|
||||
$metatags .= $css;
|
||||
}
|
||||
}
|
||||
if ($self->html_javascript) {
|
||||
$metatags .= qq{\n<script type="text/javascript" src="} .
|
||||
$self->html_javascript . '"></script>';
|
||||
}
|
||||
$bodyid = $self->backlink ? ' id="_podtop_"' : '';
|
||||
$self->{'scratch'} .= <<"HTML";
|
||||
$doctype
|
||||
<html>
|
||||
<head>
|
||||
<title>$title</title>
|
||||
$metatags
|
||||
</head>
|
||||
<body$bodyid>
|
||||
HTML
|
||||
$self->emit;
|
||||
}
|
||||
}
|
||||
|
||||
sub end_Document {
|
||||
my ($self) = @_;
|
||||
my $to_index = $self->{'to_index'};
|
||||
if ($self->index && @{ $to_index } ) {
|
||||
my @out;
|
||||
my $level = 0;
|
||||
my $indent = -1;
|
||||
my $space = '';
|
||||
my $id = ' id="index"';
|
||||
|
||||
for my $h (@{ $to_index }, [0]) {
|
||||
my $target_level = $h->[0];
|
||||
# Get to target_level by opening or closing ULs
|
||||
if ($level == $target_level) {
|
||||
$out[-1] .= '</li>';
|
||||
} elsif ($level > $target_level) {
|
||||
$out[-1] .= '</li>' if $out[-1] =~ /^\s+<li>/;
|
||||
while ($level > $target_level) {
|
||||
--$level;
|
||||
push @out, (' ' x --$indent) . '</li>' if @out && $out[-1] =~ m{^\s+<\/ul};
|
||||
push @out, (' ' x --$indent) . '</ul>';
|
||||
}
|
||||
push @out, (' ' x --$indent) . '</li>' if $level;
|
||||
} else {
|
||||
while ($level < $target_level) {
|
||||
++$level;
|
||||
push @out, (' ' x ++$indent) . '<li>' if @out && $out[-1]=~ /^\s*<ul/;
|
||||
push @out, (' ' x ++$indent) . "<ul$id>";
|
||||
$id = '';
|
||||
}
|
||||
++$indent;
|
||||
}
|
||||
|
||||
next unless $level;
|
||||
$space = ' ' x $indent;
|
||||
push @out, sprintf '%s<li><a href="#%s">%s</a>',
|
||||
$space, $h->[1], $h->[2];
|
||||
}
|
||||
# Splice the index in between the HTML headers and the first element.
|
||||
my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
|
||||
splice @{ $self->{'output'} }, $offset, 0, join "\n", @out;
|
||||
}
|
||||
|
||||
if (defined $self->html_footer) {
|
||||
$self->{'scratch'} .= $self->html_footer;
|
||||
$self->emit unless $self->html_footer eq "";
|
||||
} else {
|
||||
$self->{'scratch'} .= "</body>\n</html>";
|
||||
$self->emit;
|
||||
}
|
||||
|
||||
if ($self->index) {
|
||||
print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
|
||||
@{$self->{'output'}} = ();
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
# Handling code tags
|
||||
sub start_B { $_[0]{'scratch'} .= '<b>' }
|
||||
sub end_B { $_[0]{'scratch'} .= '</b>' }
|
||||
|
||||
sub start_C { push(@{$_[0]{'in_code'}}, 'C'); $_[0]->start_code($_[0]{'in_code'}[-1]); }
|
||||
sub end_C { $_[0]->end_code(pop(@{$_[0]{'in_code'}})); }
|
||||
|
||||
sub start_F { $_[0]{'scratch'} .= '<i>' }
|
||||
sub end_F { $_[0]{'scratch'} .= '</i>' }
|
||||
|
||||
sub start_I { $_[0]{'scratch'} .= '<i>' }
|
||||
sub end_I { $_[0]{'scratch'} .= '</i>' }
|
||||
|
||||
sub start_L {
|
||||
my ($self, $flags) = @_;
|
||||
my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'};
|
||||
my $url = $self->encode_entities(
|
||||
$type eq 'url' ? $to
|
||||
: $type eq 'pod' ? $self->resolve_pod_page_link($to, $section)
|
||||
: $type eq 'man' ? $self->resolve_man_page_link($to, $section)
|
||||
: undef
|
||||
);
|
||||
|
||||
# If it's an unknown type, use an attribute-less <a> like HTML.pm.
|
||||
$self->{'scratch'} .= '<a' . ($url ? ' href="'. $url . '">' : '>');
|
||||
}
|
||||
|
||||
sub end_L { $_[0]{'scratch'} .= '</a>' }
|
||||
|
||||
sub start_S { $_[0]{'scratch'} .= '<span style="white-space: nowrap;">' }
|
||||
sub end_S { $_[0]{'scratch'} .= '</span>' }
|
||||
|
||||
sub emit {
|
||||
my($self) = @_;
|
||||
if ($self->index) {
|
||||
push @{ $self->{'output'} }, $self->{'scratch'};
|
||||
} else {
|
||||
print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
|
||||
}
|
||||
$self->{'scratch'} = '';
|
||||
return;
|
||||
}
|
||||
|
||||
=head2 resolve_pod_page_link
|
||||
|
||||
my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL');
|
||||
my $url = $pod->resolve_pod_page_link('perlpodspec');
|
||||
my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS');
|
||||
|
||||
Resolves a POD link target (typically a module or POD file name) and section
|
||||
name to a URL. The resulting link will be returned for the above examples as:
|
||||
|
||||
https://metacpan.org/pod/Net::Ping#INSTALL
|
||||
https://metacpan.org/pod/perlpodspec
|
||||
#SYNOPSIS
|
||||
|
||||
Note that when there is only a section argument the URL will simply be a link
|
||||
to a section in the current document.
|
||||
|
||||
=cut
|
||||
|
||||
sub resolve_pod_page_link {
|
||||
my ($self, $to, $section) = @_;
|
||||
return undef unless defined $to || defined $section;
|
||||
if (defined $section) {
|
||||
$section = '#' . $self->idify($self->encode_entities($section), 1);
|
||||
return $section unless defined $to;
|
||||
} else {
|
||||
$section = ''
|
||||
}
|
||||
|
||||
return ($self->perldoc_url_prefix || '')
|
||||
. $self->encode_entities($to) . $section
|
||||
. ($self->perldoc_url_postfix || '');
|
||||
}
|
||||
|
||||
=head2 resolve_man_page_link
|
||||
|
||||
my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE');
|
||||
my $url = $pod->resolve_man_page_link('crontab');
|
||||
|
||||
Resolves a man page link target and numeric section to a URL. The resulting
|
||||
link will be returned for the above examples as:
|
||||
|
||||
http://man.he.net/man5/crontab
|
||||
http://man.he.net/man1/crontab
|
||||
|
||||
Note that the first argument is required. The section number will be parsed
|
||||
from it, and if it's missing will default to 1. The second argument is
|
||||
currently ignored, as L<man.he.net|http://man.he.net> does not currently
|
||||
include linkable IDs or anchor names in its pages. Subclass to link to a
|
||||
different man page HTTP server.
|
||||
|
||||
=cut
|
||||
|
||||
sub resolve_man_page_link {
|
||||
my ($self, $to, $section) = @_;
|
||||
return undef unless defined $to;
|
||||
my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
|
||||
return undef unless $page;
|
||||
return ($self->man_url_prefix || '')
|
||||
. ($part || 1) . "/" . $self->encode_entities($page)
|
||||
. ($self->man_url_postfix || '');
|
||||
|
||||
}
|
||||
|
||||
=head2 idify
|
||||
|
||||
my $id = $pod->idify($text);
|
||||
my $hash = $pod->idify($text, 1);
|
||||
|
||||
This method turns an arbitrary string into a valid XHTML ID attribute value.
|
||||
The rules enforced, following
|
||||
L<http://webdesign.about.com/od/htmltags/a/aa031707.htm>, are:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
The id must start with a letter (a-z or A-Z)
|
||||
|
||||
=item *
|
||||
|
||||
All subsequent characters can be letters, numbers (0-9), hyphens (-),
|
||||
underscores (_), colons (:), and periods (.).
|
||||
|
||||
=item *
|
||||
|
||||
The final character can't be a hyphen, colon, or period. URLs ending with these
|
||||
characters, while allowed by XHTML, can be awkward to extract from plain text.
|
||||
|
||||
=item *
|
||||
|
||||
Each id must be unique within the document.
|
||||
|
||||
=back
|
||||
|
||||
In addition, the returned value will be unique within the context of the
|
||||
Pod::Simple::XHTML object unless a second argument is passed a true value. ID
|
||||
attributes should always be unique within a single XHTML document, but pass
|
||||
the true value if you are creating not an ID but a URL hash to point to
|
||||
an ID (i.e., if you need to put the "#foo" in C<< <a href="#foo">foo</a> >>.
|
||||
|
||||
=cut
|
||||
|
||||
sub idify {
|
||||
my ($self, $t, $not_unique) = @_;
|
||||
for ($t) {
|
||||
s/<[^>]+>//g; # Strip HTML.
|
||||
s/&[^;]+;//g; # Strip entities.
|
||||
s/^\s+//; s/\s+$//; # Strip white space.
|
||||
s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
|
||||
s/^[^a-zA-Z]+//; # First char must be a letter.
|
||||
s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
|
||||
s/[-:.]+$//; # Strip trailing punctuation.
|
||||
}
|
||||
return $t if $not_unique;
|
||||
my $i = '';
|
||||
$i++ while $self->{ids}{"$t$i"}++;
|
||||
return "$t$i";
|
||||
}
|
||||
|
||||
=head2 batch_mode_page_object_init
|
||||
|
||||
$pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth);
|
||||
|
||||
Called by L<Pod::Simple::HTMLBatch> so that the class has a chance to
|
||||
initialize the converter. Internally it sets the C<batch_mode> property to
|
||||
true and sets C<batch_mode_current_level()>, but Pod::Simple::XHTML does not
|
||||
currently use those features. Subclasses might, though.
|
||||
|
||||
=cut
|
||||
|
||||
sub batch_mode_page_object_init {
|
||||
my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
|
||||
$self->batch_mode(1);
|
||||
$self->batch_mode_current_level($depth);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub html_header_after_title {
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2003-2005 Allison Randal.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 ACKNOWLEDGEMENTS
|
||||
|
||||
Thanks to L<Hurricane Electric|http://he.net/> for permission to use its
|
||||
L<Linux man pages online|http://man.he.net/> site for man page links.
|
||||
|
||||
Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
|
||||
site for Perl module links.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simpele::XHTML was created by Allison Randal <allison@perl.org>.
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
175
database/perl/lib/Pod/Simple/XMLOutStream.pm
Normal file
175
database/perl/lib/Pod/Simple/XMLOutStream.pm
Normal file
@@ -0,0 +1,175 @@
|
||||
|
||||
require 5;
|
||||
package Pod::Simple::XMLOutStream;
|
||||
use strict;
|
||||
use Carp ();
|
||||
use Pod::Simple ();
|
||||
use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
|
||||
$VERSION = '3.42';
|
||||
BEGIN {
|
||||
@ISA = ('Pod::Simple');
|
||||
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
|
||||
}
|
||||
|
||||
$ATTR_PAD = "\n" unless defined $ATTR_PAD;
|
||||
# Don't mess with this unless you know what you're doing.
|
||||
|
||||
$SORT_ATTRS = 0 unless defined $SORT_ATTRS;
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $new = $self->SUPER::new(@_);
|
||||
$new->{'output_fh'} ||= *STDOUT{IO};
|
||||
$new->keep_encoding_directive(1);
|
||||
#$new->accept_codes('VerbatimFormatted');
|
||||
return $new;
|
||||
}
|
||||
|
||||
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
sub _handle_element_start {
|
||||
# ($self, $element_name, $attr_hash_r)
|
||||
my $fh = $_[0]{'output_fh'};
|
||||
my($key, $value);
|
||||
DEBUG and print STDERR "++ $_[1]\n";
|
||||
print $fh "<", $_[1];
|
||||
if($SORT_ATTRS) {
|
||||
foreach my $key (sort keys %{$_[2]}) {
|
||||
unless($key =~ m/^~/s) {
|
||||
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
|
||||
_xml_escape($value = $_[2]{$key});
|
||||
print $fh $ATTR_PAD, $key, '="', $value, '"';
|
||||
}
|
||||
}
|
||||
} else { # faster
|
||||
while(($key,$value) = each %{$_[2]}) {
|
||||
unless($key =~ m/^~/s) {
|
||||
next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
|
||||
_xml_escape($value);
|
||||
print $fh $ATTR_PAD, $key, '="', $value, '"';
|
||||
}
|
||||
}
|
||||
}
|
||||
print $fh ">";
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_text {
|
||||
DEBUG and print STDERR "== \"$_[1]\"\n";
|
||||
if(length $_[1]) {
|
||||
my $text = $_[1];
|
||||
_xml_escape($text);
|
||||
print {$_[0]{'output_fh'}} $text;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _handle_element_end {
|
||||
DEBUG and print STDERR "-- $_[1]\n";
|
||||
print {$_[0]{'output_fh'}} "</", $_[1], ">";
|
||||
return;
|
||||
}
|
||||
|
||||
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
|
||||
sub _xml_escape {
|
||||
foreach my $x (@_) {
|
||||
# Escape things very cautiously:
|
||||
if ($] ge 5.007_003) {
|
||||
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
|
||||
} else { # Is broken for non-ASCII platforms on early perls
|
||||
$x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
|
||||
}
|
||||
# Yes, stipulate the list without a range, so that this can work right on
|
||||
# all charsets that this module happens to run under.
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Pod::Simple::XMLOutStream -- turn Pod into XML
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MPod::Simple::XMLOutStream -e \
|
||||
"exit Pod::Simple::XMLOutStream->filter(shift)->any_errata_seen" \
|
||||
thingy.pod
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Pod::Simple::XMLOutStream is a subclass of L<Pod::Simple> that parses
|
||||
Pod and turns it into XML.
|
||||
|
||||
Pod::Simple::XMLOutStream inherits methods from
|
||||
L<Pod::Simple>.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple::DumpAsXML> is rather like this class; see its
|
||||
documentation for a discussion of the differences.
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::DumpAsXML>, L<Pod::SAX>
|
||||
|
||||
L<Pod::Simple::Subclassing>
|
||||
|
||||
The older (and possibly obsolete) libraries L<Pod::PXML>, L<Pod::XML>
|
||||
|
||||
|
||||
=head1 ABOUT EXTENDING POD
|
||||
|
||||
TODO: An example or two of =extend, then point to Pod::Simple::Subclassing
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Questions or discussion about POD and Pod::Simple should be sent to the
|
||||
pod-people@perl.org mail list. Send an empty email to
|
||||
pod-people-subscribe@perl.org to subscribe.
|
||||
|
||||
This module is managed in an open GitHub repository,
|
||||
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
||||
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
||||
|
||||
Patches against Pod::Simple are welcome. Please send bug reports to
|
||||
<bug-pod-simple@rt.cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND DISCLAIMERS
|
||||
|
||||
Copyright (c) 2002-2004 Sean M. Burke.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
|
||||
But don't bother him, he's retired.
|
||||
|
||||
Pod::Simple is maintained by:
|
||||
|
||||
=over
|
||||
|
||||
=item * Allison Randal C<allison@perl.org>
|
||||
|
||||
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
||||
|
||||
=item * David E. Wheeler C<dwheeler@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user