ÿØÿà JFIF    ÿÛ „ ( %!1!%*+...983,7(-.- PullParser.pm000064400000062201152346134410007177 0ustar00require 5; package Pod::Simple::PullParser; $VERSION = '3.35'; 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] : "\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 and inherits all its methods. A subclass of Pod::Simple::PullParser should define a C 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), 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: =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 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 yeah! Then you'll need to pass the C 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 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 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 yeah! Then you'll need to pass the C 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 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 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 option: $parser->get_version(nocase => 1); =back =head1 NOTE You don't actually I to define a C method. If you're writing a Pod-formatter class, you should define a C just so that users can call C etc, but you don't I 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 method. =head1 SEE ALSO L L -- and its subclasses L, L, and L. L, 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. Feel free to fork and contribute, or to clone L and send patches! Patches against Pod::Simple are welcome. Please send bug reports to . =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 . But don't bother him, he's retired. Pod::Simple is maintained by: =over =item * Allison Randal C =item * Hans Dieter Pearcey C =item * David E. Wheeler C =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{NAME(X|)+$}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{(.+)$} 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; } TranscodeSmart.pm000064400000001313152346134410010034 0ustar00 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.35'; 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; LinkSection.pm000064400000010370152346134410007330 0ustar00 require 5; package Pod::Simple::LinkSection; # Based somewhat dimly on Array::Autojoin use vars qw($VERSION ); $VERSION = '3.35'; use strict; use Pod::Simple::BlackBox; use vars qw($VERSION ); $VERSION = '3.35'; 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<> >>, and "bar" for C<< LZ<>> >>. 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 Lbaz>>') " 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 Lbaz>>') " Output: $VAR1 = 'barbaz'; =head1 SEE ALSO L =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. Feel free to fork and contribute, or to clone L and send patches! Patches against Pod::Simple are welcome. Please send bug reports to . =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 . But don't bother him, he's retired. Pod::Simple is maintained by: =over =item * Allison Randal C =item * Hans Dieter Pearcey C =item * David E. Wheeler C =back =cut DumpAsXML.pm000064400000010720152346134410006657 0ustar00 require 5; package Pod::Simple::DumpAsXML; $VERSION = '3.35'; 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'}, "\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 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. =head1 SEE ALSO L 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 is rather like this class, except that it doesn't dump with XML syntax. Try them and see which one you like best! L, L The older libraries L, L, L =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. Feel free to fork and contribute, or to clone L and send patches! Patches against Pod::Simple are welcome. Please send bug reports to . =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 . But don't bother him, he's retired. Pod::Simple is maintained by: =over =item * Allison Randal C =item * Hans Dieter Pearcey C =item * David E. Wheeler C =back =cut HTMLBatch.pm000064400000116320152346134410006616 0ustar00 require 5; package Pod::Simple::HTMLBatch; use strict; use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA ); $VERSION = '3.35'; @ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML! # TODO: nocontents stylesheets. Strike some of the color variations? use Pod::Simple::HTML (); BEGIN {*esc = \&Pod::Simple::HTML::esc } use File::Spec (); use Pod::Simple::Search; $SEARCH_CLASS ||= 'Pod::Simple::Search'; BEGIN { if(defined &DEBUG) { } # no-op elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } else { *DEBUG = sub () {0}; } } $SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; # flag to occasionally sleep for $SLEEPY - 1 seconds. $HTML_RENDER_CLASS ||= "Pod::Simple::HTML"; # # Methods beginning with "_" are particularly internal and possibly ugly. # Pod::Simple::_accessorize( __PACKAGE__, 'verbose', # how verbose to be during batch conversion 'html_render_class', # what class to use to render 'search_class', # what to use to search for POD documents 'contents_file', # If set, should be the name of a file (in current directory) # to write the list of all modules to 'index', # will set $htmlpage->index(...) to this (true or false) 'progress', # progress object 'contents_page_start', 'contents_page_end', 'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad', 'no_contents_links', # set to true to suppress automatic adding of << links. '_contents', ); # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Just so we can run from the command line more easily sub go { @ARGV == 2 or die sprintf( "Usage: perl -M%s -e %s:go indirs outdir\n (or use \"\@INC\" for indirs)\n", __PACKAGE__, __PACKAGE__, ); if(defined($ARGV[1]) and length($ARGV[1])) { my $d = $ARGV[1]; -e $d or die "I see no output directory named \"$d\"\nAborting"; -d $d or die "But \"$d\" isn't a directory!\nAborting"; -w $d or die "Directory \"$d\" isn't writeable!\nAborting"; } __PACKAGE__->batch_convert(@ARGV); } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub new { my $new = bless {}, ref($_[0]) || $_[0]; $new->html_render_class($HTML_RENDER_CLASS); $new->search_class($SEARCH_CLASS); $new->verbose(1 + DEBUG); $new->_contents([]); $new->index(1); $new-> _css_wad([]); $new->css_flurry(1); $new->_javascript_wad([]); $new->javascript_flurry(1); $new->contents_file( 'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION) ); $new->contents_page_start( join "\n", grep $_, $Pod::Simple::HTML::Doctype_decl, "", "Perl Documentation", $Pod::Simple::HTML::Content_decl, "", "\n\n

Perl Documentation

\n" ); # override if you need a different title $new->contents_page_end( sprintf( "\n\n

Generated by %s v%s under Perl v%s\n
At %s GMT, which is %s local time.

\n\n\n", esc( ref($new), eval {$new->VERSION} || $VERSION, $], scalar(gmtime), scalar(localtime), ))); return $new; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub muse { my $self = shift; if($self->verbose) { print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n"; } return 1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub batch_convert { my($self, $dirs, $outdir) = @_; $self ||= __PACKAGE__; # tolerate being called as an optionless function $self = $self->new unless ref $self; # tolerate being used as a class method if(!defined($dirs) or $dirs eq '' or $dirs eq '@INC' ) { $dirs = ''; } elsif(ref $dirs) { # OK, it's an explicit set of dirs to scan, specified as an arrayref. } else { # OK, it's an explicit set of dirs to scan, specified as a # string like "/thing:/also:/whatever/perl" (":"-delim, as usual) # or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!) require Config; my $ps = quotemeta( $Config::Config{'path_sep'} || ":" ); $dirs = [ grep length($_), split qr/$ps/, $dirs ]; } $outdir = $self->filespecsys->curdir unless defined $outdir and length $outdir; $self->_batch_convert_main($dirs, $outdir); } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _batch_convert_main { my($self, $dirs, $outdir) = @_; # $dirs is either false, or an arrayref. # $outdir is a pathspec. $self->{'_batch_start_time'} ||= time(); $self->muse( "= ", scalar(localtime) ); $self->muse( "Starting batch conversion to \"$outdir\"" ); my $progress = $self->progress; if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) { require Pod::Simple::Progress; $progress = Pod::Simple::Progress->new( ($self->verbose < 2) ? () # Default omission-delay : ($self->verbose == 2) ? 1 # Reduce the omission-delay : 0 # Eliminate the omission-delay ); $self->progress($progress); } if($dirs) { $self->muse(scalar(@$dirs), " dirs to scan: @$dirs"); } else { $self->muse("Scanning \@INC. This could take a minute or two."); } my $mod2path = $self->find_all_pods($dirs ? $dirs : ()); $self->muse("Done scanning."); my $total = keys %$mod2path; unless($total) { $self->muse("No pod found. Aborting batch conversion.\n"); return $self; } $progress and $progress->goal($total); $self->muse("Now converting pod files to HTML.", ($total > 25) ? " This will take a while more." : () ); $self->_spray_css( $outdir ); $self->_spray_javascript( $outdir ); $self->_do_all_batch_conversions($mod2path, $outdir); $progress and $progress->done(sprintf ( "Done converting %d files.", $self->{"__batch_conv_page_count"} )); return $self->_batch_convert_finish($outdir); return $self; } sub _do_all_batch_conversions { my($self, $mod2path, $outdir) = @_; $self->{"__batch_conv_page_count"} = 0; foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) { $self->_do_one_batch_conversion($module, $mod2path, $outdir); sleep($SLEEPY - 1) if $SLEEPY; } return; } sub _batch_convert_finish { my($self, $outdir) = @_; $self->write_contents_file($outdir); $self->muse("Done with batch conversion. $$self{'__batch_conv_page_count'} files done."); $self->muse( "= ", scalar(localtime) ); $self->progress and $self->progress->done("All done!"); return; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _do_one_batch_conversion { my($self, $module, $mod2path, $outdir, $outfile) = @_; my $retval; my $total = scalar keys %$mod2path; my $infile = $mod2path->{$module}; my @namelets = grep m/\S/, split "::", $module; # this can stick around in the contents LoL my $depth = scalar @namelets; die "Contentless thingie?! $module $infile" unless @namelets; #sanity $outfile ||= do { my @n = @namelets; $n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION; $self->filespecsys->catfile( $outdir, @n ); }; my $progress = $self->progress; my $page = $self->html_render_class->new; if(DEBUG > 5) { $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ", ref($page), " render ($depth) $module => $outfile"); } elsif(DEBUG > 2) { $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile") } # Give each class a chance to init the converter: $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth) if $page->can('batch_mode_page_object_init'); # Init for the index (TOC), too. $self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth) if $self->can('batch_mode_page_object_init'); # Now get busy... $self->makepath($outdir => \@namelets); $progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module"); if( $retval = $page->parse_from_file($infile, $outfile) ) { ++ $self->{"__batch_conv_page_count"} ; $self->note_for_contents_file( \@namelets, $infile, $outfile ); } else { $self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false."); } $page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth) if $page->can('batch_mode_page_object_kill'); # The following isn't a typo. Note that it switches $self and $page. $self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth) if $self->can('batch_mode_page_object_kill'); DEBUG > 4 and printf STDERR "%s %sb < $infile %s %sb\n", $outfile, -s $outfile, $infile, -s $infile ; undef($page); return $retval; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub note_for_contents_file { my($self, $namelets, $infile, $outfile) = @_; # I think the infile and outfile parts are never used. -- SMB # But it's handy to have them around for debugging. if( $self->contents_file ) { my $c = $self->_contents(); push @$c, [ join("::", @$namelets), $infile, $outfile, $namelets ] # 0 1 2 3 ; DEBUG > 3 and print STDERR "Noting @$c[-1]\n"; } return; } #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- sub write_contents_file { my($self, $outdir) = @_; my $outfile = $self->_contents_filespec($outdir) || return; $self->muse("Preparing list of modules for ToC"); my($toplevel, # maps toplevelbit => [all submodules] $toplevel_form_freq, # ends up being 'foo' => 'Foo' ) = $self->_prep_contents_breakdown; my $Contents = eval { $self->_wopen($outfile) }; if( $Contents ) { $self->muse( "Writing contents file $outfile" ); } else { warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all"; return; } $self->_write_contents_start( $Contents, $outfile, ); $self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq ); $self->_write_contents_end( $Contents, $outfile, ); return $outfile; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _write_contents_start { my($self, $Contents, $outfile) = @_; my $starter = $self->contents_page_start || ''; { my $css_wad = $self->_css_wad_to_markup(1); if( $css_wad ) { $starter =~ s{()}{\n$css_wad\n$1}i; # otherwise nevermind } my $javascript_wad = $self->_javascript_wad_to_markup(1); if( $javascript_wad ) { $starter =~ s{()}{\n$javascript_wad\n$1}i; # otherwise nevermind } } unless(print $Contents $starter, "
\n" ) { warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; close($Contents); return 0; } return 1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _write_contents_middle { my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_; foreach my $t (sort keys %$toplevel2submodules) { my @downlines = sort {$a->[-1] cmp $b->[-1]} @{ $toplevel2submodules->{$t} }; printf $Contents qq[
%s
\n
\n], esc( $t, $toplevel_form_freq->{$t} ) ; my($path, $name); foreach my $e (@downlines) { $name = $e->[0]; $path = join( "/", '.', esc( @{$e->[3]} ) ) . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION); print $Contents qq{ }, esc($name), "  \n"; } print $Contents "
\n\n"; } return 1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _write_contents_end { my($self, $Contents, $outfile) = @_; unless( print $Contents "
\n", $self->contents_page_end || '', ) { warn "Couldn't write to $outfile: $!"; } close($Contents) or warn "Couldn't close $outfile: $!"; return 1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _prep_contents_breakdown { my($self) = @_; my $contents = $self->_contents; my %toplevel; # maps lctoplevelbit => [all submodules] my %toplevel_form_freq; # ends up being 'foo' => 'Foo' # (mapping anycase forms to most freq form) foreach my $entry (@$contents) { my $toplevel = $entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs' # group all the perlwhatever docs together : $entry->[3][0] # normal case ; ++$toplevel_form_freq{ lc $toplevel }{ $toplevel }; push @{ $toplevel{ lc $toplevel } }, $entry; push @$entry, lc($entry->[0]); # add a sort-order key to the end } foreach my $toplevel (sort keys %toplevel) { my $fgroup = $toplevel_form_freq{$toplevel}; $toplevel_form_freq{$toplevel} = ( sort { $fgroup->{$b} <=> $fgroup->{$a} or $a cmp $b } keys %$fgroup # This hash is extremely unlikely to have more than 4 members, so this # sort isn't so very wasteful )[0]; } return(\%toplevel, \%toplevel_form_freq) if wantarray; return \%toplevel; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _contents_filespec { my($self, $outdir) = @_; my $outfile = $self->contents_file; return unless $outfile; return $self->filespecsys->catfile( $outdir, $outfile ); } #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- sub makepath { my($self, $outdir, $namelets) = @_; return unless @$namelets > 1; for my $i (0 .. ($#$namelets - 1)) { my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] ); if(-e $dir) { die "$dir exists but not as a directory!?" unless -d $dir; next; } DEBUG > 3 and print STDERR " Making $dir\n"; mkdir $dir, 0777 or die "Can't mkdir $dir: $!\nAborting" ; } return; } #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- sub batch_mode_page_object_init { my $self = shift; my($page, $module, $infile, $outfile, $depth) = @_; # TODO: any further options to percolate onto this new object here? $page->default_title($module); $page->index( $self->index ); $page->html_css( $self-> _css_wad_to_markup($depth) ); $page->html_javascript( $self->_javascript_wad_to_markup($depth) ); $self->add_header_backlink($page, $module, $infile, $outfile, $depth); $self->add_footer_backlink($page, $module, $infile, $outfile, $depth); return $self; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub add_header_backlink { my $self = shift; return if $self->no_contents_links; my($page, $module, $infile, $outfile, $depth) = @_; $page->html_header_after_title( join '', $page->html_header_after_title || '', qq[

<<

\n], ) if $self->contents_file ; return; } sub add_footer_backlink { my $self = shift; return if $self->no_contents_links; my($page, $module, $infile, $outfile, $depth) = @_; $page->html_footer( join '', qq[

<<

\n], $page->html_footer || '', ) if $self->contents_file ; return; } sub url_up_to_contents { my($self, $depth) = @_; --$depth; return join '/', ('..') x $depth, esc($self->contents_file); } #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- sub find_all_pods { my($self, $dirs) = @_; # You can override find_all_pods in a subclass if you want to # do extra filtering or whatnot. But for the moment, we just # pass to modnames2paths: return $self->modnames2paths($dirs); } #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- sub modnames2paths { # return a hashref mapping modulenames => paths my($self, $dirs) = @_; my $m2p; { my $search = $self->search_class->new; DEBUG and print STDERR "Searching via $search\n"; $search->verbose(1) if DEBUG > 10; $search->progress( $self->progress->copy->goal(0) ) if $self->progress; $search->shadows(0); # don't bother noting shadowed files $search->inc( $dirs ? 0 : 1 ); $search->survey( $dirs ? @$dirs : () ); $m2p = $search->name2path; die "What, no name2path?!" unless $m2p; } $self->muse("That's odd... no modules found!") unless keys %$m2p; if( DEBUG > 4 ) { print STDERR "Modules found (name => path):\n"; foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) { print STDERR " $m $$m2p{$m}\n"; } print STDERR "(total ", scalar(keys %$m2p), ")\n\n"; } elsif( DEBUG ) { print STDERR "Found ", scalar(keys %$m2p), " modules.\n"; } $self->muse( "Found ", scalar(keys %$m2p), " modules." ); # return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref return $m2p; } #=========================================================================== sub _wopen { # this is abstracted out so that the daemon class can override it my($self, $outpath) = @_; require Symbol; my $out_fh = Symbol::gensym(); DEBUG > 5 and print STDERR "Write-opening to $outpath\n"; return $out_fh if open($out_fh, "> $outpath"); require Carp; Carp::croak("Can't write-open $outpath: $!"); } #========================================================================== sub add_css { my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_; return unless $url; unless($name) { # cook up a reasonable name based on the URL $name = $url; if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) { $name = $1; $name =~ s/\.css//i; } } $media ||= 'all'; $content_type ||= 'text/css'; my $bunch = [$url, $name, $content_type, $media, $_code]; if($is_default) { unshift @{ $self->_css_wad }, $bunch } else { push @{ $self->_css_wad }, $bunch } return; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _spray_css { my($self, $outdir) = @_; return unless $self->css_flurry(); $self->_gen_css_wad(); my $lol = $self->_css_wad; foreach my $chunk (@$lol) { my $url = $chunk->[0]; my $outfile; if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) { $outfile = $self->filespecsys->catfile( $outdir, "$1" ); DEBUG > 5 and print STDERR "Noting $$chunk[0] as a file I'll create.\n"; } else { DEBUG > 5 and print STDERR "OK, noting $$chunk[0] as an external CSS.\n"; # Requires no further attention. next; } #$self->muse( "Writing autogenerated CSS file $outfile" ); my $Cssout = $self->_wopen($outfile); print $Cssout ${$chunk->[-1]} or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; close($Cssout); DEBUG > 5 and print STDERR "Wrote $outfile\n"; } return; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _css_wad_to_markup { my($self, $depth) = @_; my @css = @{ $self->_css_wad || return '' }; return '' unless @css; my $rel = 'stylesheet'; my $out = ''; --$depth; my $uplink = $depth ? ('../' x $depth) : ''; foreach my $chunk (@css) { next unless $chunk and @$chunk; my( $url1, $url2, $title, $type, $media) = ( $self->_maybe_uplink( $chunk->[0], $uplink ), esc(grep !ref($_), @$chunk) ); $out .= qq{\n}; $rel = 'alternate stylesheet'; # alternates = all non-first iterations } return $out; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _maybe_uplink { # if the given URL looks relative, return the given uplink string -- # otherwise return emptystring my($self, $url, $uplink) = @_; ($url =~ m{^\./} or $url !~ m{[/\:]} ) ? $uplink : '' # qualify it, if/as needed } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub _gen_css_wad { my $self = $_[0]; my $css_template = $self->_css_template; foreach my $variation ( # Commented out for sake of concision: # # 011n=black_with_red_on_white # 001n=black_with_yellow_on_white # 101n=black_with_green_on_white # 110=white_with_yellow_on_black # 010=white_with_green_on_black # 011=white_with_blue_on_black # 100=white_with_red_on_black '110n=blkbluw', # black_with_blue_on_white '010n=blkmagw', # black_with_magenta_on_white '100n=blkcynw', # black_with_cyan_on_white '101=whtprpk', # white_with_purple_on_black '001=whtnavk', # white_with_navy_blue_on_black '010a=grygrnk', # grey_with_green_on_black '010b=whtgrng', # white_with_green_on_grey '101an=blkgrng', # black_with_green_on_grey '101bn=grygrnw', # grey_with_green_on_white ) { my $outname = $variation; my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3) if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s; @swap = () if '010' eq join '', @swap; # 010 is a swop-no-op! my $this_css = "/* This file is autogenerated. Do not edit. $variation */\n\n" . $css_template; # Only look at three-digitty colors, for now at least. if( $flipmode =~ m/n/ ) { $this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg; $this_css =~ s/\bthin\b/medium/g; } $this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b> < join '', '#', ($1,$2,$3)[@swap] >eg if @swap; if( $flipmode =~ m/a/) { $this_css =~ s/#fff\b/#999/gi } # black -> dark grey elsif($flipmode =~ m/b/) { $this_css =~ s/#000\b/#666/gi } # white -> light grey my $name = $outname; $name =~ tr/-_/ /; $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); } # Now a few indexless variations: foreach my $variation ( 'blkbluw', # black_with_blue_on_white 'whtpurk', # white_with_purple_on_black 'whtgrng', # white_with_green_on_grey 'grygrnw', # grey_with_green_on_white ) { my $outname = $variation; my $this_css = join "\n", "/* This file is autogenerated. Do not edit. $outname */\n", "\@import url(\"./_$variation.css\");", ".indexgroup { display: none; }", "\n", ; my $name = $outname; $name =~ tr/-_/ /; $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); } return; } sub _color_negate { my $x = lc $_[0]; $x =~ tr[0123456789abcdef] [fedcba9876543210]; return $x; } #=========================================================================== sub add_javascript { my($self, $url, $content_type, $_code) = @_; return unless $url; push @{ $self->_javascript_wad }, [ $url, $content_type || 'text/javascript', $_code ]; return; } sub _spray_javascript { my($self, $outdir) = @_; return unless $self->javascript_flurry(); $self->_gen_javascript_wad(); my $lol = $self->_javascript_wad; foreach my $script (@$lol) { my $url = $script->[0]; my $outfile; if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) { $outfile = $self->filespecsys->catfile( $outdir, "$1" ); DEBUG > 5 and print STDERR "Noting $$script[0] as a file I'll create.\n"; } else { DEBUG > 5 and print STDERR "OK, noting $$script[0] as an external JavaScript.\n"; next; } #$self->muse( "Writing JavaScript file $outfile" ); my $Jsout = $self->_wopen($outfile); print $Jsout ${$script->[-1]} or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; close($Jsout); DEBUG > 5 and print STDERR "Wrote $outfile\n"; } return; } sub _gen_javascript_wad { my $self = $_[0]; my $js_code = $self->_javascript || return; $self->add_javascript( "_podly.js", 0, \$js_code); return; } sub _javascript_wad_to_markup { my($self, $depth) = @_; my @scripts = @{ $self->_javascript_wad || return '' }; return '' unless @scripts; my $out = ''; --$depth; my $uplink = $depth ? ('../' x $depth) : ''; foreach my $s (@scripts) { next unless $s and @$s; my( $url1, $url2, $type, $media) = ( $self->_maybe_uplink( $s->[0], $uplink ), esc(grep !ref($_), @$s) ); $out .= qq{\n}; } return $out; } #=========================================================================== sub _css_template { return $CSS } sub _javascript { return $JAVASCRIPT } $CSS = <<'EOCSS'; /* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */ @media all { .hide { display: none; } } @media print { .noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none } * { border-color: black !important; color: black !important; background-color: transparent !important; background-image: none !important; } dl.superindex > dd { word-spacing: .6em; } } @media aural, braille, embossed { div.indexgroup { display: none; } /* Too noisy, don't you think? */ dl.superindex > dt:before { content: "Group "; } dl.superindex > dt:after { content: " contains:"; } .backlinktop a:before { content: "Back to contents"; } .backlinkbottom a:before { content: "Back to contents"; } } @media aural { dl.superindex > dt { pause-before: 600ms; } } @media screen, tty, tv, projection { .noscreen { display: none; } a:link { color: #7070ff; text-decoration: underline; } a:visited { color: #e030ff; text-decoration: underline; } a:active { color: #800000; text-decoration: underline; } body.contentspage a { text-decoration: none; } a.u { color: #fff !important; text-decoration: none; } body.pod { margin: 0 5px; color: #fff; background-color: #000; } body.pod h1, body.pod h2, body.pod h3, body.pod h4 { font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; font-weight: normal; margin-top: 1.2em; margin-bottom: .1em; border-top: thin solid transparent; /* margin-left: -5px; border-left: 2px #7070ff solid; padding-left: 3px; */ } body.pod h1 { border-top-color: #0a0; } body.pod h2 { border-top-color: #080; } body.pod h3 { border-top-color: #040; } body.pod h4 { border-top-color: #010; } p.backlinktop + h1 { border-top: none; margin-top: 0em; } p.backlinktop + h2 { border-top: none; margin-top: 0em; } p.backlinktop + h3 { border-top: none; margin-top: 0em; } p.backlinktop + h4 { border-top: none; margin-top: 0em; } body.pod dt { font-size: 105%; /* just a wee bit more than normal */ } .indexgroup { font-size: 80%; } .backlinktop, .backlinkbottom { margin-left: -5px; margin-right: -5px; background-color: #040; border-top: thin solid #050; border-bottom: thin solid #050; } .backlinktop a, .backlinkbottom a { text-decoration: none; color: #080; background-color: #000; border: thin solid #0d0; } .backlinkbottom { margin-bottom: 0; padding-bottom: 0; } .backlinktop { margin-top: 0; padding-top: 0; } body.contentspage { color: #fff; background-color: #000; } body.contentspage h1 { color: #0d0; margin-left: 1em; margin-right: 1em; text-indent: -.9em; font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; font-weight: normal; border-top: thin solid #fff; border-bottom: thin solid #fff; text-align: center; } dl.superindex > dt { font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; font-weight: normal; font-size: 90%; margin-top: .45em; /* margin-bottom: -.15em; */ } dl.superindex > dd { word-spacing: .6em; /* most important rule here! */ } dl.superindex > a:link { text-decoration: none; color: #fff; } .contentsfooty { border-top: thin solid #999; font-size: 90%; } } /* The End */ EOCSS #========================================================================== $JAVASCRIPT = <<'EOJAVASCRIPT'; // From http://www.alistapart.com/articles/alternate/ function setActiveStyleSheet(title) { var i, a, main; for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) { a.disabled = true; if(a.getAttribute("title") == title) a.disabled = false; } } } function getActiveStyleSheet() { var i, a; for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { if( a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title") && !a.disabled ) return a.getAttribute("title"); } return null; } function getPreferredStyleSheet() { var i, a; for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { if( a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("rel").indexOf("alt") == -1 && a.getAttribute("title") ) return a.getAttribute("title"); } return null; } function createCookie(name,value,days) { if (days) { var date = new Date(); date.setTime(date.getTime()+(days*24*60*60*1000)); var expires = "; expires="+date.toGMTString(); } else expires = ""; document.cookie = name+"="+value+expires+"; path=/"; } function readCookie(name) { var nameEQ = name + "="; var ca = document.cookie.split(';'); for(var i=0 ; i < ca.length ; i++) { var c = ca[i]; while (c.charAt(0)==' ') c = c.substring(1,c.length); if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length); } return null; } window.onload = function(e) { var cookie = readCookie("style"); var title = cookie ? cookie : getPreferredStyleSheet(); setActiveStyleSheet(title); } window.onunload = function(e) { var title = getActiveStyleSheet(); createCookie("style", title, 365); } var cookie = readCookie("style"); var title = cookie ? cookie : getPreferredStyleSheet(); setActiveStyleSheet(title); // The End EOJAVASCRIPT # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1; __END__ =head1 NAME Pod::Simple::HTMLBatch - convert several Pod files to several HTML files =head1 SYNOPSIS perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out =head1 DESCRIPTION This module is used for running batch-conversions of a lot of HTML documents This class is NOT a subclass of Pod::Simple::HTML (nor of bad old Pod::Html) -- although it uses Pod::Simple::HTML for doing the conversion of each document. The normal use of this class is like so: use Pod::Simple::HTMLBatch; my $batchconv = Pod::Simple::HTMLBatch->new; $batchconv->some_option( some_value ); $batchconv->some_other_option( some_other_value ); $batchconv->batch_convert( \@search_dirs, $output_dir ); =head2 FROM THE COMMAND LINE Note that this class also provides (but does not export) the function Pod::Simple::HTMLBatch::go. This is basically just a shortcut for C<< Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>. It's meant to be handy for calling from the command line. However, the shortcut requires that you specify exactly two command-line arguments, C and C. Example: % mkdir out_html % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html (to convert the pod from Perl's @INC files under the directory ./out_html) (Note that the command line there contains a literal atsign-I-N-C. This is handled as a special case by batch_convert, in order to save you having to enter the odd-looking "" as the first command-line parameter when you mean "just use whatever's in @INC".) Example: % mkdir ../seekrut % chmod og-rx ../seekrut % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../seekrut (to convert the pod under the current dir into HTML files under the directory ./seekrut) Example: % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs . (to convert all pod from happydocs into the current directory) =head1 MAIN METHODS =over =item $batchconv = Pod::Simple::HTMLBatch->new; This TODO =item $batchconv->batch_convert( I, I ); this TODO =item $batchconv->batch_convert( undef , ...); =item $batchconv->batch_convert( q{@INC}, ...); These two values for I specify that the normal Perl @INC =item $batchconv->batch_convert( \@dirs , ...); This specifies that the input directories are the items in the arrayref C<\@dirs>. =item $batchconv->batch_convert( "somedir" , ...); This specifies that the director "somedir" is the input. (This can be an absolute or relative path, it doesn't matter.) A common value you might want would be just "." for the current directory: $batchconv->batch_convert( "." , ...); =item $batchconv->batch_convert( 'somedir:someother:also' , ...); This specifies that you want the dirs "somedir", "someother", and "also" scanned, just as if you'd passed the arrayref C<[qw( somedir someother also)]>. Note that a ":"-separator is normal under Unix, but Under MSWin, you'll need C<'somedir;someother;also'> instead, since the pathsep on MSWin is ";" instead of ":". (And I is because ":" often comes up in paths, like C<"c:/perl/lib">.) (Exactly what separator character should be used, is gotten from C<$Config::Config{'path_sep'}>, via the L module.) =item $batchconv->batch_convert( ... , undef ); This specifies that you want the HTML output to go into the current directory. (Note that a missing or undefined value means a different thing in the first slot than in the second. That's so that C with no arguments (or undef arguments) means "go from @INC, into the current directory.) =item $batchconv->batch_convert( ... , 'somedir' ); This specifies that you want the HTML output to go into the directory 'somedir'. (This can be an absolute or relative path, it doesn't matter.) =back Note that you can also call C as a class method, like so: Pod::Simple::HTMLBatch->batch_convert( ... ); That is just short for this: Pod::Simple::HTMLBatch-> new-> batch_convert(...); That is, it runs a conversion with default options, for whatever inputdirs and output dir you specify. =head2 ACCESSOR METHODS The following are all accessor methods -- that is, they don't do anything on their own, but just alter the contents of the conversion object, which comprises the options for this particular batch conversion. We show the "put" form of the accessors below (i.e., the syntax you use for setting the accessor to a specific value). But you can also call each method with no parameters to get its current value. For example, C<< $self->contents_file() >> returns the current value of the contents_file attribute. =over =item $batchconv->verbose( I ); This controls how verbose to be during batch conversion, as far as notes to STDOUT (or whatever is C