Pod-Abstract-0.20/0000755000076600000240000000000011317775162012534 5ustar benlstaffPod-Abstract-0.20/bin/0000755000076600000240000000000011317775162013304 5ustar benlstaffPod-Abstract-0.20/bin/paf0000644000076600000240000001421511317775144014000 0ustar benlstaff#!/usr/bin/perl package paf; use strict; use warnings; use Pod::Abstract; use Pod::Abstract::Filter; use File::Temp qw(tempfile tempdir); =head1 NAME paf - Pod Abstract Filter. Transform Pod documents from the command line. =head1 SYNOPSIS sh$> paf summary /usr/bin/paf paf add_podcmds SomeModule.pm paf sort -heading=METHODS Pod/Abstract/Node.pm # METHODS is default paf sort summary Pod/Abstract/Node.pm # See Pod::Abstract::Filter::overlay paf overlay sort cut clear_podcmds SomeClass.pm # -p will emit pod source, instead of spawning perldoc. paf -p sort Pod::Abstract::Node paf -p find hoist Pod::Abstract::Node =head1 DESCRIPTION Paf is a small but powerful, modular Pod filter and transformation tool. It allows full round-trip transformation of Pod documents using the Pod::Abstract library, with multiple filter chains without having to serialise/re-parse the document at each step. Paf comes with a small set of useful filters, but can be extended by simply writing new classes in the C namespace. =head1 FILTERS =head2 add_podcmds Add explicit =pod commands at the end of each cut section, so that all pod sections are started with an =pod command. =head2 clear_podcmds Remove all =pod commands that are not ending cut blocks. This will clean up documents that have been reduced using the C filter too. =head2 cut Remove all cut nodes, so that only the pod remains. =head2 overlay paf overlay Source.pm For overlay to work, there must be a C section in the Source file, with C<=overlay SECTION Module> definitions inside. The net effect is that any missing subheadings in SECTION are added from the same section in the specified Modules. Note that this will overlay the whole subheading, INCLUDING CUT NODES, so it can add code to the source document. Use C if you don't want this. Each overlaid section will include a C<=for overlay from> marker, so that it can be replaced by a subsequent overlay from the same file/module. These sections will be replaced in-place, so ordering of sections once first overlaid will be preserved. =head2 unoverlay paf unoverlay Source.pm Strips B sections marked as overlaid and matching the overlay spec from the source. =head2 sort paf sort [-heading=METHODS] Source.pm Sort all of the subheadings in the named heading (METHODS if not provided). This will move cut nodes around with their headings, so your code will mutate. Use C if you only want pod in the output. Alternatively, you can also cause sorting of headings to occur by including C<=for sorting> at the start of your section (before the first subheading). =head2 summary Provide an abbreviated summary of the document. If there is a verbatim node in the body of a heading containing the heading name, it will be considered an example and expanded as part of the summary. =head2 find paf find [-f=]name Source.pm Find specific sub-sections or list items mentioning name. Used to restrict a larger document down to a smaller set that you're interested in. If no -f is specified, then the word following find will be the search term. =head2 uncut paf uncut Source.pm Convert cut nodes in the source into verbatim text. Not the inverse of cut! =head2 number_sections paf number_sections Source.pm Applies simple multipart (3.1.2) section numbering to head1 through head4 headings. Note that number_sections will currently stuff up some of the cleverness in things like summary, as the section names won't match function names any more. =cut sub main { my $filter = undef; my %filter_flags = ( ); my %flags = ( ); my @filters = ( ); my @require_params = ( ); for( my $i = 0; $i < $#ARGV; $i ++ ) { # leave the last argument my $arg = $ARGV[$i]; if($arg =~ m/^-([^=]+)(=(.*))?$/) { if($filter) { if(defined $3) { $filter_flags{$1} = $3; } else { $filter_flags{$1} = 1; } @require_params = grep { $_ ne $1 } @require_params; } else { if(defined $3) { $flags{$1} = $3; } else { $flags{$1} = 1; } } } elsif( @require_params ) { # Allow positional params if they're asked for. my $p_name = shift @require_params; $filter_flags{$p_name} = $arg; } else { my $full_class = "Pod::Abstract::Filter::$arg"; eval "use $full_class;"; die "$arg: $@" if $@; if($filter) { push @filters, $filter->new(%filter_flags); %filter_flags = ( ); } $filter = $full_class; @require_params = $filter->require_params; } } # Push on the last filter if($filter) { push @filters, $filter->new(%filter_flags); %filter_flags = ( ); } my $filename = $ARGV[$#ARGV]; die "No filename or filters provided\nTry 'perldoc paf'\n" unless $filename; my $next = undef; if($filename eq '--') { $next = Pod::Abstract->load_filehandle(\*STDIN); } else { unless(-r $filename) { # Maybe a module name? $filename =~ s/::/\//g; $filename .= '.pm' unless $filename =~ m/.pm$/; foreach my $path (@INC) { if(-r "$path/$filename") { $filename = "$path/$filename"; last; } } } $next = Pod::Abstract->load_file($filename); } foreach my $filter (@filters) { $next = $filter->filter($next); } my $out = \*STDOUT; my $tmpfilename = undef; if(!($flags{p} || $flags{d})) { ($out, $tmpfilename) = tempfile; } if(eval { $next->isa( 'Pod::Abstract::Node' ) }) { if($flags{d}) { print $out $next->ptree; } else { print $out $next->pod; } } else { print $out $next; } if(!($flags{p} || $flags{d})) { system('perldoc', $tmpfilename); unlink $tmpfilename; } } main(); 1; Pod-Abstract-0.20/Changes0000644000076600000240000000365011317775144014033 0ustar benlstaffRevision history for Pod-Abstract 0.20 03/01/2010 Removed usage of UNIVERSAL isa and can as functions, will correct a deprecation warning with Perl 5.11. Fixed a bug with nodes->from_pod which did not work as documented. Corrected some minor errors with documentation formatting. Added test coverage for from_pod. 0.19 21/06/2009 Added =head1 NAME blocks to those modules missing them. Added some additional Pod. Added "Task::Weaken" dependancy to ensure that the target platform has a working "weaken" in their Scalar::Util 0.18 08/06/2009 Replaced "=" operator with "eq", added the full set of Perl compatible binary comparison operators (eq and friends, == and friends). This will break your code if you used the "=" operator in 0.17, you will need to change it to "eq". 0.17 26/05/2009 Added Union and Intersection operators to paths (conjunction of multiple simple paths). Support for multi-name selectors in paths. Fix for memory leak. Testing of pPath expressions. Added "=" operator with support for combinational matching (any node on left expression = any node on right expression) 0.16 11/05/2009 Changed constant declarations to allow older Perl 5.6 constants. Removed body components from heading and label attributes in BuildNode, which would cause ->select to behave incorrectly on newly added nodes. 0.15 12/03/2009 Improved documentation. Added some real documentation for Pod::Abstract::Path. Had an attempt at fixing the compile issues for Perl 5.6. No significant changes in function. 0.14 03/03/2009 Improved paf filter suite. Bug fixes. paf defaults to "load as perldoc". Allow mandatory positional arguments for filters. 0.10 28/02/2009 Package build with functional library and "paf" utility. Pod-Abstract-0.20/lib/0000755000076600000240000000000011317775162013302 5ustar benlstaffPod-Abstract-0.20/lib/Pod/0000755000076600000240000000000011317775162014024 5ustar benlstaffPod-Abstract-0.20/lib/Pod/Abstract/0000755000076600000240000000000011317775162015567 5ustar benlstaffPod-Abstract-0.20/lib/Pod/Abstract/BuildNode.pm0000644000076600000240000001737111317775144020003 0ustar benlstaffpackage Pod::Abstract::BuildNode; use strict; use Exporter; use Pod::Abstract; use Pod::Abstract::Parser; use Pod::Abstract::Node; use base qw(Exporter); our $VERSION = '0.20'; our @EXPORT_OK = qw(node nodes); sub node { 'Pod::Abstract::BuildNode' }; sub nodes { 'Pod::Abstract::BuildNode' }; =head1 NAME Pod::Abstract::BuildNode - Build new nodes for use in Pod::Abstract. =head1 SYNOPSIS use Pod::Abstract::BuildNode qw(node nodes); # shorthand my $root_doc = node->root; for(my $i = 1; $i < 10; $i ++) { $root_doc->push(node->head1("Heading number $i")); } print $root_doc->pod; =head1 DESCRIPTION For building a new Pod::Abstract document, or adding nodes to an existing one. This provides easy methods to generate correctly set nodes for most common Pod::Abstract elements. =head1 NOTES Pod::Abstract::BuildNode can export two functions, C and C. These are constant functions to provide a shorthand so instead of writing: use Pod::Abstract::BuildNode; # ... my @nodes = Pod::Abstract::BuildNode->from_pod( $pod ); You can instead write: use Pod::Abstract::BuildNode qw(node nodes); # ... my @nodes = nodes->from_pod($pod); Which is more readable, and less typing. C and C are both synonyms of C. This shorthand form is shown in all the method examples below. All methods operate on the class. =head1 METHODS =cut =head2 from_pod my @nodes = nodes->from_pod($pod_text); Given some literal Pod text, generate a full subtree of nodes. The returned array is all of the top level nodes. The full document tree will be populated under the returned nodes. =cut sub from_pod { my $class = shift; my $str = shift; my $root = Pod::Abstract->load_string($str); return undef unless $root; my @r = map { $_->detach; $_ } $root->children; return @r; } =head2 root my $root = node->root; Generate a root node. A root node generates no output, and is used to hold a document tree. Use this to make a new document. =cut sub root { my $class = shift; my $para = Pod::Abstract::Node->new( type => '[ROOT]', ); } =head2 begin my $begin_block = node->begin($command); Generates a begin/end block. Nodes nested inside the begin node will appear between the begin/end. Note that there is no corresponding C method - the end command belongs to it's corresponding begin. =cut sub begin { my $class = shift; my $cmd = shift; my $begin = Pod::Abstract::Node->new( type => 'begin', body => $cmd, close_element => Pod::Abstract::Node->new( type => 'end', body => $cmd, ), ); return $begin; } =head2 for my $for = node->for('overlay from '); Create a =for node. The argument is the literal body of the for node, no parsing will be performed. =cut sub for { my $class = shift; my $str = shift; return Pod::Abstract::Node->new( type => 'for', body => $str, ); } =head2 paragraph my $para = node->paragraph('Pod text'); Generates a Pod paragraph, possibly containing interior sequences. The argument will be parsed as Pod, and will generate text and sequence nodes inside the paragraph. =cut sub paragraph { my $class = shift; my $str = shift; my $para = Pod::Abstract::Node->new( type => ':paragraph', ); my $parser = Pod::Abstract::Parser->new; my $pt = $parser->parse_text($str); if($pt) { $parser->load_pt($para,$pt); } else { return undef; } } =head2 verbatim my $v = node->verbatim($text); Add the given text as a verbatim node to the document. All lines in the fiven C<$text> will be indented by one space to ensure they are treated as verbatim. =cut sub verbatim { my $class = shift; my $str = shift; my @strs = split "\n",$str; for(my $i = 0; $i < @strs; $i ++) { my $str_line = $strs[$i]; $strs[$i] = ' '.$str_line; } my $verbatim = Pod::Abstract::Node->new( type => ':verbatim', body => (join("\n", @strs) . "\n\n"), ); return $verbatim; } =head2 heading my $head2 = node->heading(2, $heading); Generate a heading node at the given level. Nodes that "belong" in the heading's section should be nested in the heading node. The C<$heading> text will be parsed for interior sequences. =cut sub heading { my $class = shift; my $level = shift; my $heading = shift; my $attr_node = Pod::Abstract::Node->new( type => '@attribute', ); my $parser = Pod::Abstract::Parser->new; my $pt = $parser->parse_text($heading); $parser->load_pt($attr_node, $pt); my $element_node = Pod::Abstract::Node->new( type => "head$level", heading => $attr_node, body_attr => 'heading', ); return $element_node; } =head2 head1 node->head1($heading); =cut sub head1 { my $class = shift; my $heading = shift; return $class->heading(1,$heading); } =head2 head2 node->head2($heading); =cut sub head2 { my $class = shift; my $heading = shift; return $class->heading(2,$heading); } =head2 head3 node->head3($heading); =cut sub head3 { my $class = shift; my $heading = shift; return $class->heading(3,$heading); } =head2 head4 node->head4($heading); =cut sub head4 { my $class = shift; my $heading = shift; return $class->heading(4,$heading); } =head2 over my $list = node->over([$num]); Generates an over/back block, to contain list items. The optional parameter C<$num> specifies the number of spaces to indent by. Note that the back node is part of the over, there is no separate back method. =cut sub over { my $class = shift; my $number = shift; $number = '' unless defined $number; return Pod::Abstract::Node->new( type => 'over', body => ($number ? $number : undef), close_element => Pod::Abstract::Node->new( type => 'back', ), ); } =head2 item my $item = node->item('*'); Generates an item with the specified label. To fill in the text of the item, nest paragraphs into the item. Items should be contained in over nodes. =cut sub item { my $class = shift; my $label = shift; my $attr_node = Pod::Abstract::Node->new( type => '@attribute', ); my $parser = Pod::Abstract::Parser->new; my $pt = $parser->parse_text($label); $parser->load_pt($attr_node, $pt); my $element_node = Pod::Abstract::Node->new( type => "item", label => $attr_node, body_attr => 'label', ); return $element_node; } =head2 text my $text = node->text('Literal text'); Generates a literal text node. You generally B want this, you probably want a paragraph. Use this if you want to, for example, append a word at the end of a paragraph. =cut sub text { my $class = shift; my $text = shift; my $attr_node = Pod::Abstract::Node->new( type => ':text', body => $text, ); return $attr_node; } =head2 pod my $n = node->pod; Generates an "=pod" command. Can be useful to force pod mode at the end of cut nodes. Do not confuse with L! =cut sub pod { my $class = shift; return Pod::Abstract::Node->new( type => 'pod', body => '', ); } =head1 my $cut = node->cut; Generates an explicit "=cut" command. =cut sub cut { my $class = shift; return Pod::Abstract::Node->new( type => '#cut', body => "=cut\n\n", ); } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/0000755000076600000240000000000011317775162017014 5ustar benlstaffPod-Abstract-0.20/lib/Pod/Abstract/Filter/add_podcmds.pm0000644000076600000240000000242311317775144021614 0ustar benlstaffpackage Pod::Abstract::Filter::add_podcmds; use strict; use base qw(Pod::Abstract::Filter); use Pod::Abstract::BuildNode qw(node); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::add_podcmds - paf command to insert explict =pod commands before each Pod block in a document. =head1 METHODS =head2 filter Add a =pod command after each block of cut nodes. This will cause explicit pod declarations wherever they are currently implicit. =cut sub filter { my $self = shift; my $pa = shift; my @cut_finals = $pa->select( "//#cut[!>>#cut][!>>pod]" ); # If the document ends with a cut, we don't want a new Pod section # - but if it ends with a pod, we do. my $last_cut = pop @cut_finals; my $ignore_last = 1; my $p = $last_cut; $ignore_last = 0 if $p->next; while($p && ($p = $p->parent) && $ignore_last) { $ignore_last = 0 if $p->next; } push @cut_finals, $last_cut unless $ignore_last; foreach my $n (@cut_finals) { node->pod->insert_after($n); } return $pa; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/clear_podcmds.pm0000644000076600000240000000166711317775144022163 0ustar benlstaffpackage Pod::Abstract::Filter::clear_podcmds; use strict; use base qw(Pod::Abstract::Filter); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::clear_podcmds - paf command to remove =pod commands from the begining of Pod blocks. =cut sub filter { my $self = shift; my $pa = shift; my ($first_node) = $pa->select("/(0)"); my @pod_cmds = $pa->select( "//pod[!<<#cut]" ); foreach my $pod_cmd (@pod_cmds) { # The start of the document is in cut mode, even if there is # no text there, so if the lead node is an =pod node don't # strip it. $pod_cmd->detach unless $pod_cmd->serial == $first_node->serial; } return $pa; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/cut.pm0000644000076600000240000000120711317775144020145 0ustar benlstaffpackage Pod::Abstract::Filter::cut; use strict; use warnings; use base qw(Pod::Abstract::Filter); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::cut - paf command to remove non-processed (cut) portions of a Pod document. =cut sub filter { my $self = shift; my $pa = shift; my @cut = $pa->select("//#cut"); foreach my $cut (@cut) { $cut->detach; } return $pa; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/find.pm0000644000076600000240000000520111317775144020270 0ustar benlstaffpackage Pod::Abstract::Filter::find; use strict; use warnings; use base qw(Pod::Abstract::Filter); use Pod::Abstract::BuildNode qw(node); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::find - paf command to find specific nodes that contain a string. =head1 DESCRIPTION The intention of this filter is to allow a reduction of large Pod documents to find a specific function or method. You call C, and you get a small subset of nodes matching "function". For this to work, there has to be some assumptions about Pod structure. I am presuming that find is not useful if it returns anything higher than a head2, so as long as your module wraps function doco in a head2, head3, head4 or list item, we're fine. If you use head1 then it won't be useful. In order to be useful as an end user tool, head1 nodes (...) are added between the found nodes. This stops perldoc from dying with no documentation. These can be easily stripped using: C<< $pa->select('/head1') >>, then hoist and detach, or reparent to other Node types. A good example of this working as intended is: paf find select Pod::Abstract::Node =cut sub require_params { return ( 'f' ); } sub filter { my $self = shift; my $pa = shift; my $find_string = $self->param('f'); unless($find_string && $find_string =~ m/^[a-zA-Z0-9_]+$/) { die "find: string must be specified with -f=str.\nMust be a simple string.\n"; } my $out_doc = node->root; $out_doc->nest(node->pod); # Don't select parent nodes, leaf nodes only my @targets = $pa->select("//[. =~ {$find_string}][!/]"); # Don't accept anything less specific than a head2 my @dest_ok = qw(head2 head3 head4 item); my %finals = ( ); foreach my $t (@targets) { while($t->parent && !( grep { $t->type eq $_ } @dest_ok )) { $t = $t->parent; } if(grep { $t->type eq $_ } @dest_ok) { unless($finals{$t->serial}) { my $head = node->head1('...'); if($t->type eq 'item') { my $over = node->over; $over->nest($t->duplicate); $head->nest($over); } else { $head->nest($t->duplicate); } $out_doc->push($head); $finals{$t->serial} = 1; } } } return $out_doc; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/number_sections.pm0000755000076600000240000000271311317775144022557 0ustar benlstaffpackage Pod::Abstract::Filter::number_sections; use strict; use warnings; use base qw( Pod::Abstract::Filter ); use Pod::Abstract::BuildNode qw(node); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::number_sections - paf command for basic multipart section numbering. =cut sub filter { my $self = shift; my $pa = shift; my $h1 = 0; my @h1 = $pa->select('/head1'); foreach my $hn1 (@h1) { $h1 ++; $hn1->param('heading')->unshift(node->text("$h1. ")); my @h2 = $hn1->select('/head2'); my $h2 = 0; foreach my $hn2 (@h2) { $h2 ++; $hn2->param('heading')->unshift(node->text("$h1.$h2 ")); my @h3 = $hn2->select('/head3'); my $h3 = 0; foreach my $hn3 (@h3) { $h3 ++; $hn3->param('heading')->unshift(node->text("$h1.$h2.$h3 ")); my @h4 = $hn3->select('/head4'); my $h4 = 0; foreach my $hn4 (@h4) { $h4 ++; $hn4->param('heading')-> unshift(node->text("$h1.$h2.$h3.$h4 ")); } } } } return $pa; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/overlay.pm0000644000076600000240000001043711317775144021040 0ustar benlstaffpackage Pod::Abstract::Filter::overlay; use strict; use warnings; use base qw(Pod::Abstract::Filter); use Pod::Abstract; use Pod::Abstract::BuildNode qw(node); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::overlay - paf command to perform a method documentation overlay on a Pod document. =begin :overlay =overlay METHODS Pod::Abstract::Filter =end :overlay =head1 METHODS =head2 filter Inspects the source document for a begin/end block named ":overlay". The overlay block will be inspected for "=overlay" commands, which should be structured like: =begin :overlay =overlay METHODS Some::Class::Or::File =end :overlay Each overlay is processed in order. It will add any headings for the matched sections in the current document from the named source, for any heading that is not already present in the given section. If that doesn't make sense just try it and it will! The main utility of this is to specify a superclass, so that all the methods that are not documented in your subclass become documented by the overlay. The C filter makes a good follow up. The start of overlaid sections will include: =for overlay from You can use these markers to set sections to be replaced by some other document, or to repeat an overlay on an already processed Pod file. Changes to existing marked sections are made in-place without changing document order. =cut sub filter { my $self = shift; my $pa = shift; my ($overlay_list) = $pa->select("//begin[. =~ {^:overlay}](0)"); unless($overlay_list) { die "No overlay defined in document\n"; } my @overlays = $overlay_list->select("/overlay"); foreach my $overlay (@overlays) { my $o_def = $overlay->body; my ($section, $module) = split " ", $o_def; # This should be factored into a method. my $ovr_module = $module; # Keep original value unless(-r $module) { # Maybe a module name? $module =~ s/::/\//g; $module .= '.pm' unless $module =~ m/.pm$/; foreach my $path (@INC) { if(-r "$path/$module") { $module = "$path/$module"; last; } } } my $ovr_doc = Pod::Abstract->load_file($module); my ($t) = $pa->select("//[\@heading =~ {$section}](0)"); my ($o) = $ovr_doc->select("//[\@heading =~ {$section}](0)"); my @t_headings = $t->select("/[\@heading]"); my @o_headings = $o->select("/[\@heading]"); my %t_heading = map { $_->param('heading')->pod => $_ } @t_headings; foreach my $hdg (@o_headings) { my $hdg_text = $hdg->param('heading')->pod; if($t_heading{$hdg_text}) { my @overlay_from = $t_heading{$hdg_text}->select( "/for[. =~ {^overlay from }]"); my @from_current = grep { substr($_->body, -(length $ovr_module)) eq $ovr_module } @overlay_from; if(@from_current) { my $dup = $hdg->duplicate; my @overlay_from = $hdg->select("/for[. =~ {^overlay from }]"); $_->detach foreach @overlay_from; $dup->unshift(node->for("overlay from $ovr_module")); $dup->insert_after($t_heading{$hdg_text}); $t_heading{$hdg_text}->detach; $t_heading{$hdg_text} = $dup; } } else { my $dup = $hdg->duplicate; # Remove existing overlay markers; my @overlay_from = $hdg->select("/for[. =~ {^overlay from }]"); $_->detach foreach @overlay_from; $dup->unshift(node->for("overlay from $ovr_module")); $t->push($dup); $t_heading{$hdg_text} = $dup; } } } return $pa; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/sort.pm0000644000076600000240000000242211317775144020341 0ustar benlstaffpackage Pod::Abstract::Filter::sort; use strict; use warnings; use Data::Dumper; use base qw(Pod::Abstract::Filter); =head1 NAME Pod::Abstract::Filter::sort - paf command to alphabetically sort sub-sections within a Pod section =cut our $VERSION = '0.20'; sub filter { my $self = shift; my $pa = shift; my $heading = $self->param('heading'); $heading = 'METHODS' unless defined $heading; my @targets = $pa->select("//[\@heading =~ {$heading}]"); my @spec_targets = $pa->select("//[/for =~ {^sorting}]"); if($self->param('heading')) { push @targets, @spec_targets; } else { @targets = @spec_targets if @spec_targets; } foreach my $t (@targets) { my @ignore = $t->select("/[!\@heading]"); my @to_sort = $t->select("/[\@heading]"); $t->clear; $t->nest(@ignore); $t->nest( sort { $a->param('heading')->pod cmp $b->param('heading')->pod } @to_sort ); } return $pa; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/summary.pm0000644000076600000240000000410611317775144021050 0ustar benlstaffpackage Pod::Abstract::Filter::summary; use strict; use base qw(Pod::Abstract::Filter); use Pod::Abstract::BuildNode qw(node); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::summary - paf command to show document outline, with short examples. =cut sub filter { my $self = shift; my $pa = shift; my $summary = node->root; my $summ_block = node->head1('Summary'); $summary->nest($summ_block); $self->summarise_headings($pa,$summ_block); $summ_block->nest(node->text("\n")); $summ_block->coalesce_body(':text'); return $summary; } sub summarise_headings { my $self = shift; my $pa = shift; my $summ_block = shift; my $depth = shift; $depth = 1 unless defined $depth; my @headings = $pa->select('/[@heading]'); my @items = $pa->select('/over/item[@label =~ {[a-zA-Z]+}]'); # Labels that have strings unshift @headings, @items; foreach my $head (@headings) { my ($hdg) = $head->select('@heading'); if($head->type eq 'item') { ($hdg) = $head->select('@label'); } my $hdg_text = $hdg->text; $summ_block->push( node->text((" " x $depth) . $hdg_text . "\n") ); if($hdg_text =~ m/^[0-9a-zA-Z_ ]+$/) { my ($synopsis) = $head->select("//:verbatim[. =~ {$hdg_text}](0)"); if($synopsis) { my $synop_body = $synopsis->body; $synop_body =~ s/[\r\n]//sg; $synop_body =~ s/[\t ]+/ /g; $synop_body =~ s/^ //g; $summ_block->push( node->text( (" " x $depth) . " \\ " . $synop_body . "\n" ) ); } } $self->summarise_headings($head, $summ_block, $depth + 1); } } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/uncut.pm0000644000076600000240000000237111317775144020513 0ustar benlstaffpackage Pod::Abstract::Filter::uncut; use strict; use warnings; use base qw(Pod::Abstract::Filter); use Pod::Abstract::BuildNode qw(node); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::uncut - paf command to turn source code into verbatim nodes. =head1 DESCRIPTION Takes all cut blocks from the source document, after the first Pod block starts, and converts them into inline verbatim Pod blocks. The effect of this is to allow viewing of source code inline with the formatted Pod documentation describing it. =cut sub filter { my $self = shift; my $pa = shift; my @cuts = $pa->select('//#cut[! << #cut]'); # First cut in each run foreach my $cut (@cuts) { next unless $cut->body =~ m/^=cut/; my $n = $cut->next; while( $n && $n->type eq '#cut' ) { $cut->push(node->verbatim($n->body)); $n->detach; $n = $cut->next; } $cut->coalesce_body(':verbatim'); $cut->hoist; $cut->detach; } return $pa; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter/unoverlay.pm0000755000076600000240000000341311317775144021402 0ustar benlstaffpackage Pod::Abstract::Filter::unoverlay; use strict; use warnings; use base qw(Pod::Abstract::Filter); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter::unoverlay - paf command to remove "overlay" blocks from a Pod document, as created by the paf overlay command. =begin :overlay =overlay METHODS Pod::Abstract::Filter =end :overlay =head1 METHODS =head2 new =for overlay from Pod::Abstract::Filter =head2 filter Strips any sections marked C<=for overlay> from the listed overlay specification from the target document. This will expunge everything that has been previously overlaid or marked for overlay from the specified documents. =cut sub filter { my $self = shift; my $pa = shift; my ($overlay_list) = $pa->select("//begin[. =~ {^:overlay}](0)"); unless($overlay_list) { die "No overlay defined in document\n"; } my @overlays = $overlay_list->select("/overlay"); foreach my $overlay (@overlays) { my $o_def = $overlay->body; my ($section, $module) = split " ", $o_def; my ($t) = $pa->select("//[\@heading =~ {$section}](0)"); my @t_headings = $t->select("/[\@heading]"); foreach my $hdg (@t_headings) { my @overlay_from = $hdg->select( "/for[. =~ {^overlay from }]"); my @from_current = grep { substr($_->body, -(length $module)) eq $module } @overlay_from; if(@from_current) { $hdg->detach; } } } return $pa; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Filter.pm0000644000076600000240000000473511317775144017363 0ustar benlstaffpackage Pod::Abstract::Filter; use strict; use warnings; use Pod::Abstract; our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Filter - Generic Pod-in to Pod-out filter. =head1 DESCRIPTION This is a superclass for filter modules using Pod::Abstract. Subclasses should override the C sub. Pod::Abstract::Filter classes in the Pod::Abstract::Filter namespace will be used by the C utility. To create a filter, you need to implement: =over =item filter Takes a Pod::Abstract::Node tree, and returns either another tree, or a string. If a string is returned, it will be re-parsed to be input to any following filter, or output directly if it is the last filter in the list. It is recommended your filter method produce a Node tree if you are able to, as this will improve interoperability with other C based software. =item require_params If you want positional arguments following your filter in the style of: paf find [thing] Pod::Abstract then override require_params to list the named arguments that are to be accepted after the filter name. =back =head1 METHODS =head2 new Create a new filter with the specified arguments. =cut sub new { my $class = shift; my %args = @_; return bless { %args }, $class; } =head2 require_params Override to return a list of parameters that must be provided. This will be accepted in order on the command line, unless they are first set using the C<-flag=xxx> notation. =cut sub require_params { return ( ); } =head2 param Get the named param. Read only. =cut sub param { my $self = shift; my $param_name = shift; return $self->{$param_name}; } =head2 filter Stub method. Does nothing, just returns the original tree. =cut sub filter { my $self = shift; my $pa = shift; return $pa; } =head2 run Run the filter. If $arg is a string, it will be parsed first. Otherwise, the Abstract tree will be used. Returns either a string or an abstract tree (which may be the original tree, modified). =cut sub run { my $self = shift; my $arg = shift; if( eval { $arg->isa( 'Pod::Abstract::Node' ) } ) { return $self->filter($arg); } else { my $pa = Pod::Abstract->load_string($arg); return $self->filter($pa); } } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Node.pm0000644000076600000240000004031711317775144017017 0ustar benlstaffpackage Pod::Abstract::Node; use strict; use warnings; use Pod::Abstract::Tree; use Pod::Abstract::Serial; use Scalar::Util qw(weaken); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Node - Pod Document Node. =head1 SYNOPSIS $node->nest( @list ); # Nests list as children of $node. If they # exist in a tree they will be detached. $node->clear; # Remove (detach) all children of $node $node->hoist; # Append all children of $node after $node. $node->detach; # Detaches intact subtree from parent $node->select( $path_exp ); # Selects the path expression under $node $node->select_into( $target, $path_exp ); # Selects into the children of the # target node. (copies) $node->insert_before($target); # Inserts $node in $target's tree # before $target $node->insert_after($target); $node->push($target); # Appends $target at the end of this node $node->unshift($target); # Prepends $target at the start of this node $node->path(); # List of nodes leading to this one $node->children(); # All direct child nodes of this one $node->next(); # Following sibling if present $node->previous(); # Preceding sibling if present $node->duplicate(); # Duplicate node and children in a new tree. $node->pod; # Convert node back into literal POD $node->ptree; # Show visual (abbreviated) parse tree =head1 METHODS =for sorting =cut =head2 new my $node = Pod::Abstract::Node->new( type => ':text', body => 'Some text', ); Creates a new, unattached Node object. This is NOT the recommended way to make nodes to add to a document, use Pod::Abstract::BuildNode for that. There are specific rules about how data must be set up for these nodes, and C lets you ignore them. Apart from type and body, all other hash arguments will be converted into "params", which may be internal data or node attributes. Type may be: =over =item * A plain word, which is taken to be a command name. =item * C<:paragraph>, C<:text>, C<:verbatim> or <:X> (where X is an inline format letter). These will be treated as you would expect. =item * C<#cut>, meaning this is literal, non-pod text. =back Note that these do not guarantee the resulting document structure will match your types - types are derived from the document, not the other way around. If your types do not match your document they will mutate when it is reloaded. See L if you want to make nodes easily for creating/modifying a document tree. =cut sub new { my $class = shift; my %args = @_; my $type = $args{type}; my $body = $args{body}; delete $args{type}; delete $args{body}; my $self = bless { tree => Pod::Abstract::Tree->new(), serial => Pod::Abstract::Serial->next, parent => undef, type => $type, body => $body, params => { %args }, }, $class; return $self; } =head2 ptree print $n->ptree; Produces a formatted, readable, parse tree. Shows node types, nesting structure, abbreviated text. Does NOT show all information, but shows enough to help debug parsing/traversal problems. =cut sub ptree { my $self = shift; my $indent = shift || 0; my $width = 72 - $indent; my $type = $self->type; my $body = $self->body; if(my $body_attr = $self->param('body_attr')) { $body = $self->param($body_attr)->pod; } $body =~ s/[\n\t]//g if $body; my $r = ' ' x $indent; if($body) { $r .= substr("[$type] $body",0,$width); } else { $r .= "[$type]"; } $r = sprintf("%3d %s",$self->serial, $r); $r .= "\n"; my @children = $self->children; foreach my $c (@children) { $r .= $c->ptree($indent + 2); } return $r; } =head2 text print $n->text; Returns the text subnodes only of the given node, concatenated together - i,e, the text only with no formatting at all. =cut my %escapes = ( 'gt' => '>', 'lt' => '<', 'sol' => '/', 'verbar' => '|', ); sub text { my $self = shift; my $r = ''; my $type = $self->type; my $body = $self->body; my @children = $self->children; if($type eq ':text') { $r .= $body; } elsif( $type eq ':E' ) { my $code = ''; foreach my $c (@children) { $code .= $c->text; } if($escapes{$code}) { $r .= $escapes{$code}; } return $r; } foreach my $c (@children) { $r .= $c->text; } return $r; } =head2 pod print $n->pod; Returns the node (and all subnodes) formatted as POD. A newly loaded node should produce the original POD text when pod is requested. =cut sub pod { my $self = shift; my $r = ''; my $body = $self->body; my $type = $self->type; my $should_para_break = 0; my $p_break = $self->param('p_break'); $p_break = "\n\n" unless defined $p_break; my $r_delim = undef; # Used if a interior sequence needs closing. if($type eq ':paragraph') { $should_para_break = 1; } elsif( $type eq ':text' or $type eq '#cut' or $type eq ':verbatim') { $r .= $body; } elsif( $type =~ m/^\:(.+)$/ ) { # Interior sequence my $cmd = $1; my $l_delim = $self->param('left_delimiter'); $r_delim = $self->param('right_delimiter'); $r .= "$cmd$l_delim"; } elsif( $type eq '[ROOT]' or $type =~ m/^@/) { # ignore } else { # command my $body_attr = $self->param('body_attr'); if($body_attr) { $body = $self->param($body_attr)->pod; } if(defined $body && $body ne '') { $r .= "=$type $body$p_break"; } else { $r .= "=$type$p_break"; } } my @children = $self->children; foreach my $c (@children) { $r .= $c->pod; } if($should_para_break) { $r .= $p_break; } elsif($r_delim) { $r .= $r_delim; } if($self->param('close_element')) { $r .= $self->param('close_element')->pod; } return $r; } =head2 select my @nodes = $n->select('/:paragraph[//:text =~ {TODO}]'); Select a pPath expression against this node. The above example will select all paragraphs in the document containing 'TODO' in any of their text nodes. The returned values are the real nodes from the document tree, and manipulating them will transform the document. =cut sub select { my $self = shift; my $path = shift; my $p_path = Pod::Abstract::Path->new($path); return $p_path->process($self); } =head2 select_into $node->select_into($target_node, $path) As with select, this will match a pPath expression against $node - but the resulting nodes will be copied and added as children to $target_node. The nodes that were added will be returned as a list. =cut sub select_into { my $self = shift; my $target = shift; my $path = shift; my @nodes = $self->select($path); my @dup_nodes = map { $_->duplicate } @nodes; return $target->nest(@dup_nodes); } =head2 type $node->type( [ $new_type ] ); Get or set the type of the node. =cut sub type { my $self = shift; if(@_) { my $new_val = shift; $self->{type} = $new_val; } return $self->{type}; } =head2 body $node->body( [ $new_body ] ); Get or set the node body text. This is NOT the child tree of the node, it is the literal text as used by text/verbatim nodes. =cut sub body { my $self = shift; if(@_) { my $new_val = shift; $self->{body} = $new_val; } return $self->{body}; } =head2 param $node->param( $p_name [, $p_value ] ); Get or set the named parameter. Any value can be used, but for document attributes a Pod::Abstract::Node should be set. =cut sub param { my $self = shift; my $param_name = shift; if(@_) { my $new_val = shift; $self->{params}{$param_name} = $new_val; } return $self->{params}{$param_name}; } =head2 duplicate my $new_node = $node->duplicate; Make a deep-copy of the node. The duplicate node returned has an identical document tree, but different node identifiers. =cut sub duplicate { my $self = shift; my $class = ref $self; # Implement the new() call with all the data needed. my $params = $self->{params}; my %new_params = ( ); foreach my $param (keys %$params) { my $pv = $params->{$param}; if(ref $pv && eval { $pv->can('duplicate') } ) { $new_params{$param} = $pv->duplicate; } elsif(! ref $pv) { $new_params{$param} = $pv; } else { die "Don't know how to copy a ", ref $pv; } } my $dup = $class->new( type => $self->type, body => $self->body, %new_params, ); my @children = $self->children; my @dup_children = map { $_->duplicate } @children; $dup->nest(@dup_children); return $dup; } =head2 insert_before $node->insert_before($target); Inserts $node before $target, as a sibling of $target. If $node is already in a document tree, it will be removed from it's existing position. =cut sub insert_before { my $self = shift; my $target = shift; my $target_tree = $target->parent->tree; die "Can't insert before a root node" unless $target_tree; if($target_tree->insert_before($target, $self)) { $self->parent($target->parent); } else { die "Could not insert before [$target]"; } } =head2 insert_after $node->insert_after($target); Inserts $node after $target, as a sibling of $target. If $node is already in a document tree, it will be removed from it's existing position. =cut sub insert_after { my $self = shift; my $target = shift; my $target_tree = $target->parent->tree; die "Can't insert after a root node" unless $target_tree; if($target_tree->insert_after($target, $self)) { $self->parent($target->parent); } else { die "Could not insert before [$target]"; } } =head2 hoist $node->hoist; Inserts all children of $node, in order, immediately after $node. After this operation, $node will have no children. In pictures: - a - b - c - d -f $a->hoist; # -> - a - b - c - d - f =cut sub hoist { my $self = shift; my @children = $self->children; my $parent = $self->parent; my $target = $self; foreach my $n(@children) { $n->detach; $n->insert_after($target); $target = $n; } return scalar @children; } =head2 clear $node->clear; Detach all children of $node. The detached nodes will be returned, and can be safely reused, but they will no longer be in the document tree. =cut sub clear { my $self = shift; my @children = $self->children; foreach my $n (@children) { $n->detach; } return @children; } =head2 push $node->push($target); Pushes $target at the end of $node's children. =cut sub push { my $self = shift; my $target = shift; my $target_tree = $self->tree; if($target_tree->push($target)) { $target->parent($self); } else { die "Could not push [$target]"; } } =head2 nest $node->nest(@new_children); Adds @new_children to $node's children. The new nodes will be added at the end of any existing children. This can be considered the inverse of hoist. =cut sub nest { my $self = shift; foreach my $target (@_) { $self->push($target); } return @_; } sub tree { my $self = shift; return $self->{tree}; } =head2 unshift $node->unshift($target); The reverse of push, add a node to the start of $node's children. =cut sub unshift { my $self = shift; my $target = shift; my $target_tree = $self->tree; if($target_tree->unshift($target)) { $target->parent($self); } else { die "Could not unshift [$target]"; } } =head2 serial $node->serial; The unique serial number of $node. This should never be modified. =cut sub serial { my $self = shift; return $self->{serial}; } =head2 attached $node->attached; Returns true if $node is attached to a document tree. =cut sub attached { my $self = shift; return defined $self->parent; } =head2 detach $node->detach; Removes a node from it's document tree. Returns true if the node was removed from a tree, false otherwise. After this operation, the node will be detached. Detached nodes can be reused safely. =cut sub detach { my $self = shift; if($self->parent) { $self->parent->tree->detach($self); return 1; } else { return 0; } } =head2 parent $node->parent; Returns the parent of $node if available. Returns undef if no parent. =cut sub parent { my $self = shift; if(@_) { my $new_parent = shift; if( defined $self->{parent} && $self->parent->tree->detach($self) ) { warn "Implicit detach when reparenting"; } $self->{parent} = $new_parent; # Parent nodes have to be weak - otherwise we leak. weaken $self->{parent} if defined $self->{parent}; } return $self->{parent}; } =head2 root $node->root Find the root node for the tree holding this node - this may be the original node if it has no parent. =cut sub root { my $n = shift; while(defined $n->parent) { $n = $n->parent; } return $n; } =head2 children my @children = $node->children; Returns the children of the node in document order. =cut sub children { my $self = shift; return $self->tree->children(); } =head2 next my $next = $node->next; Returns the following sibling of $node, if one exists. If there is no following node undef will be returned. =cut sub next { my $self = shift; my $parent = $self->parent; return undef unless $parent; # No following node for root nodes. return $parent->tree->index_relative($self,+1); } =head2 previous my $previous = $node->previous; Returns the preceding sibling of $node, if one exists. If there is no preceding node, undef will be returned. =cut sub previous { my $self = shift; my $parent = $self->parent; return undef unless $parent; # No preceding nodes for root nodes. return $parent->tree->index_relative($self,-1); } =head2 coalesce_body $node->coalesce_body(':verbatim'); This performs node coalescing as required by perlpodspec. Successive verbatim nodes can be merged into a single node. This is also done with text nodes, primarily for =begin/=end blocks. The named node type will be merged together in the child document wherever there are two or more successive nodes of that type. Don't use for anything except C<:text> and C<:verbatim> nodes unless you're really sure you know what you want. =cut sub coalesce_body { my $self = shift; my $node_type = shift; # Select all elements containing :verbatim nodes. my @candidates = $self->select("//[/$node_type]"); foreach my $c (@candidates) { my @children = $c->children; my $current_start = undef; foreach my $n (@children) { if($n->type eq $node_type) { if(defined $current_start) { my $p_break = $current_start->param('p_break'); $p_break = "" unless $p_break; my $body_start = $current_start->body; $current_start->body( $body_start . $p_break . $n->body ); $current_start->param('p_break', $n->param('p_break')); $n->detach or die; # node has been appended to prev. } else { $current_start = $n; } } else { $current_start = undef; } } } } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Parser.pm0000644000076600000240000002027311317775144017365 0ustar benlstaffpackage Pod::Abstract::Parser; use strict; use Pod::Parser; use Pod::Abstract::Node; use Data::Dumper; use base qw(Pod::Parser); our $VERSION = '0.20'; =head1 NAME Pod::Abstract::Parser - Internal Parser class of Pod::Abstract. =head1 DESCRIPTION This is a C subclass, used by C to convert Pod text into a Node tree. You do not need to use this class yourself, the C class will do the work of creating the parser and running it for you. =head1 METHODS =head2 new Pod::Abstract::Parser->new( $pod_abstract ); Requires a Pod::Abstract object to load Pod data into. Should only be called internally by Pod::Abstract. =cut sub new { my $class = shift; my $p_a = shift; # Always accept non-POD paras, so that the input document can # always be reproduced exactly as entered. These will be stored in # the tree but will be available through distinct methods. my $self = $class->SUPER::new(); $self->parseopts( -want_nonPODs => 1, -process_cut_cmd => 1, ); $self->{pod_abstract} = $p_a; my $root_node = Pod::Abstract::Node->new( type => "[ROOT]", ); $self->{cmd_stack} = [ $root_node ]; $self->{root} = $root_node; return $self; } sub root { my $self = shift; return $self->{root}; } # Automatically nest these items: A head1 section continues until the # next head1, list items continue until the next item or end of list, # etc. POD doesn't specify these relationships, but they are natural # and make sense in the whole document context. # # SPECIAL: Start node with < to pull the end node out of the tree and # into the opening node - e.g, pull a "back" into an "over", but not # into an "item". Pulling a command stops it from closing any more # elements, so begin/end style blocks need to use a pull, or one end # will close all begins. my %section_commands = ( 'head1' => [ 'head1' ], 'head2' => [ 'head2', 'head1' ], 'head3' => [ 'head3', 'head2', 'head1' ], 'head4' => [ 'head4', 'head3', 'head2', 'head1' ], 'over' => [ ' [ 'item', 'back' ], 'begin' => [ ' 1, 'for' => 1, ); my %attr_names = ( head1 => 'heading', head2 => 'heading', head3 => 'heading', head4 => 'heading', item => 'label', ); sub command { my ($self, $command, $paragraph, $line_num) = @_; my $cmd_stack = $self->{cmd_stack} || [ ]; my $p_break = "\n\n"; if($paragraph =~ s/([ \t]*\n[ \t]*\n)$//s) { $p_break = $1; } if($self->cutting) { # Treat as non-pod - i.e, verbatim program text block. my $element_node = Pod::Abstract::Node->new( type => "#cut", body => "=$command $paragraph$p_break", ); my $top = $cmd_stack->[$#$cmd_stack]; $top->push($element_node); } else { # Treat as command. my $pull = undef; while(@$cmd_stack > 0) { my $last = scalar(@$cmd_stack) - 1; my @should_end = ( ); @should_end = grep { $command eq $_ } @{$section_commands{$cmd_stack->[$last]->type}}; my @should_pull = ( ); @should_pull = grep { "<$command" eq $_ } @{$section_commands{$cmd_stack->[$last]->type}}; if(@should_end) { my $end_cmd = pop @$cmd_stack; } elsif(@should_pull) { $pull = pop @$cmd_stack; last; } else { last; } } # Don't do anything special if we're on a no_parse node my $top = $cmd_stack->[$#$cmd_stack]; if($no_parse{$top->type} && !$top->param('parse_me')) { my $t_node = Pod::Abstract::Node->new( type => ':text', body => ($paragraph ne '' ? "=$command $paragraph$p_break" : "=$command$p_break"), ); $top->push($t_node); return; } # Some commands have to get expandable interior sequences my $attr_node = undef; my $attr_name = $attr_names{$command}; my %attr = ( parse_me => 0 ); if($attr_name) { $attr_node = Pod::Abstract::Node->new( type => '@attribute', ); my $pt = $self->parse_text($paragraph); $self->load_pt($attr_node, $pt); $attr{$attr_name} = $attr_node; $attr{body_attr} = $attr_name; } elsif($paragraph =~ m/^\:/) { $attr{parse_me} = 1; } my $element_node = Pod::Abstract::Node->new( type => $command, body => ($attr_name ? undef : $paragraph), p_break => $p_break, %attr, ); if($pull) { $pull->param('close_element', $element_node); } else { $top->push($element_node); } if($section_commands{$command}) { push @$cmd_stack, $element_node; } else { # No push } } $self->{cmd_stack} = $cmd_stack; } sub verbatim { my ($self, $paragraph, $line_num) = @_; my $cmd_stack = $self->{cmd_stack}; my $top = $cmd_stack->[$#$cmd_stack]; my $type = ':verbatim'; if($no_parse{$top->type} && !$top->param('parse_me')) { $type = ':text'; } my $element_node = Pod::Abstract::Node->new( type => ':verbatim', body => $paragraph, ); $top->push($element_node); } sub preprocess_paragraph { my ($self, $text, $line_num) = @_; return $text unless $self->cutting; # This is a non-pod text segment my $element_node = Pod::Abstract::Node->new( type => "#cut", body => $text, ); my $cmd_stack = $self->{cmd_stack}; my $top = $cmd_stack->[$#$cmd_stack]; $top->push($element_node); } sub textblock { my ($self, $paragraph, $line_num) = @_; my $p_break = "\n\n"; if($paragraph =~ s/([ \t]*\n[ \t]*\n)$//s) { $p_break = $1; } my $cmd_stack = $self->{cmd_stack}; my $top = $cmd_stack->[$#$cmd_stack]; if($no_parse{$top->type} && !$top->param('parse_me')) { my $element_node = Pod::Abstract::Node->new( type => ':text', body => "$paragraph$p_break", ); $top->push($element_node); return; } my $element_node = Pod::Abstract::Node->new( type => ':paragraph', p_break => $p_break, ); my $pt = $self->parse_text($paragraph); $self->load_pt($element_node, $pt); $top->push($element_node); } # Recursive load sub load_pt { my $self = shift; my $elt = shift; my $pt = shift; my @c = $pt->children; foreach my $c(@c) { if(ref $c) { # Object; if($c->isa('Pod::InteriorSequence')) { my $cmd = $c->cmd_name; my $i_node = Pod::Abstract::Node->new( type => ":$cmd", left_delimiter => $c->left_delimiter, right_delimiter => $c->right_delimiter, ); $self->load_pt($i_node, $c->parse_tree); $elt->push($i_node); } else { die "$c not an interior sequence!"; } } else { # text my $t_node = Pod::Abstract::Node->new( type => ':text', body => $c, ); $elt->push($t_node); } } return $elt; } sub end_pod { my $self = shift; my $cmd_stack = $self->{cmd_stack}; my $end_cmd; while(defined $cmd_stack && @$cmd_stack) { $end_cmd = pop @$cmd_stack; } die "Last node was not root node" unless $end_cmd->type eq '[ROOT]'; # Replace the root node. push @$cmd_stack, $end_cmd; } =head1 AUTHOR Ben Lilburne =head1 COPYRIGHT AND LICENSE Copyright (C) 2009 Ben Lilburne This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Pod-Abstract-0.20/lib/Pod/Abstract/Path.pm0000644000076600000240000005646211317775144017036 0ustar benlstaffpackage Pod::Abstract::Path; use strict; use warnings; use Data::Dumper; use Pod::Abstract::BuildNode qw(node); $Data::Dumper::Indent = 1; our $VERSION = '0.20'; use constant CHILDREN => 1; # / use constant ALL => 2; # // use constant NAME => 3; # head1 use constant INDEX => 4; # (3) use constant L_SELECT => 5; # [ use constant ATTR => 6; # @label use constant N_CMP => 7; # == != < <= > >= use constant STRING => 8; # 'foobar' use constant R_SELECT => 9; # ] use constant NUM_OF => 10; # # use constant NOT => 15; # ! use constant PARENT => 16; # .. use constant MATCHES => 17; # =~ use constant REGEXP => 18; # {} use constant NOP => 19; # . use constant PREV => 20; # << use constant NEXT => 21; # >> use constant ROOT => 22; # ^ use constant UNION => 23; # | use constant INTERSECT => 24; # & use constant S_CMP => 25; # eq lt gt le ge ne =pod =head1 NAME Pod::Abstract::Path - Search for POD nodes matching a path within a document tree. =head1 SYNOPSIS /head1(1)/head2 # All head2 elements under # the 2nd head1 element //item # All items anywhere //item[@label =~ {^\*$}] # All items with '*' labels. //head2[/hilight] # All head2 elements containing # "hilight" elements # Top level head1s containing head2s that have headings matching # "NAME", and also have at least one list somewhere in their # contents. /head1[/head2[@heading =~ {NAME}]][//over] # Top level headings having the same title as the following heading. /head1[@heading = >>@heading] # Top level headings containing at least one subheading with the same # name. /head1[@heading = ./head2@heading] =head1 DESCRIPTION Pod::Abstract::Path is a path selection syntax that allows fast and easy traversal of Pod::Abstract documents. While it has a simple syntax, there is significant complexity in the queries that you can create. Not all of the designed features have yet been implemented, but it is currently quite useful, and all of the filters in C make use of Pod Paths. =head2 SYMBOLS: =over =item / Selects children of the left hand side. =item // Selects all descendants of the left hand side. =item . Selects the current node - this is a NOP that can be used in expressions. =item .. Selects the parrent node. If there are multiple nodes selected, all of their parents will be included. =item ^ Selects the root node of the tree for the current node. This allows you to escape from a nested expression. Note that this is the ROOT node, not the node that you started from. If you want to evaluate an expression from a node as though it were the root node, the easiest ways are to detach or dup it - otherwise the root operator will find the original root node. =item name, #cut, :text, :verbatim, :paragraph Any element name, or symbolic type name, will restrict the selection to only elements matching that type. e.g, "C" will select all descendants, anywhere, but then restrict that set to only C<:paragraph> type nodes. Names together separated by spaces will match all of those names - e.g: C will match all lists and all head1s. =item &, | (union and intersection) Union will take expressions on either side, and return all nodes that are members of either set. Intersection returns nodes that are members of BOTH sets. These can be used to extend expressions, and within [ expressions ] where a path is supported (left side of a match, left or right side of an = sign). These are NOT logical and/or, though a similar effect can be induced through these operators. =item @attrname The named attribute of the nodes on the left hand side. Current attributes are C<@heading> for head1 through head4, and C<@label> for list items. =item [ expression ] Select only the left hand elements that match the expression in the brackets. The expression will be evaluated from the point of view of each node in the current result set. Expressions can be: =over =item simple: C<[/head2]> Any regular path will be true if there are any nodes matched. The above example will be true if there are any head2 nodes as direct children of the selected node. =item regex match: C<[@heading =~ {FOO}]> A regex match will be true if the left hand expression has nodes that match the regular expression between the braces on the right hand side. The above example will match anything with a heading containing "FOO". Optionally, the right hand closing brace may have the C modifier to cause case-insensitive matching. i.e C<[@heading =~ {foo}i]> will match C or C. =item complement: C<[! /head2 ]> Reverses the remainder of the expression. The above example will match anything B a child head2 node. =item compare operators: eg. C<[ /node1 eq /node2 ]> Matches nodes where the operator is satistied for at least one pair of nodes. The right hand expression can be a constant string (single quoted: C<'string'>, or a second expression. If two expressions are used, they are matched combinationally - i.e, all result nodes on the left are matched against all result nodes on the right. Both sides may contain nested expressions. The following Perl compatible operators are supported: String: C< eq gt lt le ge ne > Numeric: C<<< == < > <= >= != >>> =back =back =head1 PERFORMANCE Pod::Abstract::Path is not designed to be fast. It is designed to be expressive and useful, but it involves sucessive expand/de-duplicate/linear search operations and doing this with large documents containing many nodes is not suitable for high performance systems. Simple expressions can be fast enough, but there is nothing to stop you from writing "//[]" and linear-searching all 10,000 nodes of your Pod document. Use with caution in interactive systems. =head1 INTERFACE It is recommended you use the C<select>> method to evaluate Path expressions. If you wish to generate paths for use in other modules, use C to generate a parse tree, pass that as an argument to C, then use C to evaluate the expression against a list of nodes. You can re-use the same parse tree to process multiple lists of nodes in this fashion. =cut sub new { my $class = shift; my $expression = shift; my $parse_tree = shift; if($parse_tree) { my $self = bless { expression => $expression, parse_tree => $parse_tree }, $class; return $self; } else { my $self = bless { expression => $expression }, $class; my @lexemes = $self->lex($expression); my $parse_tree = $self->parse_path(\@lexemes); $self->{parse_tree} = $parse_tree; return $self; } } sub lex { my $self = shift; my $expression = shift; my @l = ( ); # Digest expression into @l while($expression) { if($expression =~ m/^\/\//) { substr($expression,0,2) = ''; push @l, [ ALL, undef ]; } elsif($expression =~ m/^\//) { substr($expression,0,1) = ''; push @l, [ CHILDREN, undef ]; } elsif($expression =~ m/^\|/) { substr($expression,0,1) = ''; push @l, [ UNION, undef ]; } elsif($expression =~ m/^\&/) { substr($expression,0,1) = ''; push @l, [ INTERSECT, undef ]; } elsif($expression =~ m/^\[/) { substr($expression,0,1) = ''; push @l, [ L_SELECT, undef ]; } elsif($expression =~ m/^\]/) { substr($expression,0,1) = ''; push @l, [ R_SELECT, undef ]; } elsif($expression =~ m/^(eq|lt|gt|le|ge|ne)/) { push @l, [ S_CMP, $1 ]; substr($expression,0,2) = ''; } elsif($expression =~ m/^([#_\:a-zA-Z0-9]+)/) { push @l, [ NAME, $1 ]; substr($expression, 0, length $1) = ''; } elsif($expression =~ m/^\@([a-zA-Z0-9]+)/) { push @l, [ ATTR, $1 ]; substr($expression, 0, length( $1 ) + 1) = ''; } elsif($expression =~ m/^\(([0-9]+)\)/) { push @l, [ INDEX, $1 ]; substr($expression, 0, length( $1 ) + 2) = ''; } elsif($expression =~ m/^\{(([^\}]|\\\})+)\}([i]?)/) { my $case = $3 eq 'i' ? 0 : 1; push @l, [ REGEXP, $1, $case ]; substr($expression, 0, length( $1 ) + 2 + length($3)) = ''; } elsif($expression =~ m/^'(([^']|\\')+)'/) { push @l, [ STRING, $1 ]; substr($expression, 0, length( $1 ) + 2) = ''; } elsif($expression =~ m/^\=\~/) { push @l, [ MATCHES, undef ]; substr($expression, 0, 2) = ''; } elsif($expression =~ m/^\.\./) { push @l, [ PARENT, undef ]; substr($expression, 0, 2) = ''; } elsif($expression =~ m/^\^/) { push @l, [ ROOT, undef ]; substr($expression, 0, 1) = ''; } elsif($expression =~ m/^\./) { push @l, [ NOP, undef ]; substr($expression, 0, 1) = ''; } elsif($expression =~ m/^\<\\>/) { push @l, [ NEXT, undef ]; substr($expression, 0, 2) = ''; } elsif($expression =~ m/^(==|!=|<=|>=)/) { push @l, [ N_CMP, $1 ]; substr($expression,0,2) = ''; } elsif($expression =~ m/^(<|>)/) { push @l, [ N_CMP, $1 ]; substr($expression,0,1) = ''; } elsif($expression =~ m/^\!/) { push @l, [ NOT, undef ]; substr($expression, 0, 1) = ''; } elsif($expression =~ m/^\%/) { push @l, [ NUM_OF, undef ]; substr($expression, 0, 1) = ''; } elsif($expression =~ m/^'([\^']*)'/) { push @l, [ STRING, $1 ]; substr($expression, 0, length( $1 ) + 2) = ''; } elsif($expression =~ m/(\s+)/) { # Discard uncaptured whitespace substr($expression, 0, length($1)) = ''; } else { die "Invalid token encountered - remaining string is $expression"; } } return @l; } =head1 METHODS =head2 filter_unique It is possible during processing - especially using ^ or .. operators - to generate many duplicate matches of the same nodes. Each pass around the loop, we filter to unique nodes so that duplicates cannot inflate more than one time. This effectively means that C (however awful that is) will match one node only - just really inefficiently. =cut sub filter_unique { my $self = shift; my $ilist = shift; my $nlist = [ ]; my %seen = ( ); foreach my $node (@$ilist) { push @$nlist, $node unless $seen{$node->serial}; $seen{$node->serial} = 1; } return $nlist; } # Rec descent process of expression. sub process { my $self = shift; my @nodes = @_; my $pt = $self->{parse_tree}; my $ilist = [ @nodes ]; while($pt && $pt->{action} ne 'end_select') { my $action = $pt->{action}; my @args = ( ); if($pt->{arguments}) { @args = @{$pt->{arguments}}; } if($self->can($action)) { $ilist = $self->$action($ilist, @args); $ilist = $self->filter_unique($ilist); } else { warn "discarding '$action', can't do that"; } $pt = $pt->{'next'}; } return @$ilist; } sub select_name { my $self = shift; my $ilist = shift; my @names = @_; my $nlist = [ ]; my %names = map { $_ => 1 } @names; for(my $i = 0; $i < @$ilist; $i ++) { if($names{$ilist->[$i]->type}) { push @$nlist, $ilist->[$i]; }; } return $nlist; } sub select_union { my $self = shift; my $class = ref $self; my $ilist = shift; my $left = shift; my $right = shift; my $l_path = $class->new('union left', $left); my $r_path = $class->new('union right', $right); my @l_result = $l_path->process(@$ilist); my @r_result = $r_path->process(@$ilist); return [ @l_result, @r_result ]; } sub select_intersect { my $self = shift; my $class = ref $self; my $ilist = shift; my $left = shift; my $right = shift; my $l_path = $class->new("intersect left", $left); my $r_path = $class->new("intersect right", $right); my @l_result = $l_path->process(@$ilist); my @r_result = $r_path->process(@$ilist); my %seen = ( ); my $nlist = [ ]; foreach my $a (@l_result) { $seen{$a->serial} = 1; } foreach my $b (@r_result) { push @$nlist, $b if $seen{$b->serial}; } return $nlist; } sub select_attr { my $self = shift; my $ilist = shift; my $name = shift; my $nlist = [ ]; foreach my $i (@$ilist) { my $pv = $i->param($name); if($pv) { push @$nlist, $pv; } } return $nlist; } sub select_index { my $self = shift; my $ilist = shift; my $index = shift; if($index < scalar @$ilist) { return [ $ilist->[$index] ]; } else { return [ ]; } } sub match_expression { my $self = shift; my $ilist = shift; my $test_action = shift; my $invert = shift; my $exp = shift; my $r_exp = shift; my $op = shift; # Only for some operators my $nlist = [ ]; foreach my $n(@$ilist) { my @t_list = $exp->process($n); my $t_result; # Allow for r_exp to be another expression - generate both # node lists if required. if( eval { $r_exp->can('process') } ) { my @r_list = $r_exp->process($n); $t_result = $self->$test_action(\@t_list, \@r_list, $op); } else { $t_result = $self->$test_action(\@t_list, $r_exp, $op); } $t_result = !$t_result if $invert; if($t_result) { push @$nlist, $n; } } return $nlist; } sub test_cmp_op { my $self = shift; my $l_list = shift; my $r_exp = shift; my $op = shift; if(scalar(@$r_exp) == 0 || eval { $r_exp->[0]->isa('Pod::Abstract::Node') }) { # combination test my $match = 0; foreach my $l (@$l_list) { my $lb = $l->body; $lb = $l->pod unless $lb; foreach my $r (@$r_exp) { my $rb = $r->body; $rb = $r->pod unless $rb; eval "\$match++ if \$lb $op \$rb"; die $@ if $@; } } return $match; } elsif($r_exp->[0] == STRING) { # simple string test my $str = $r_exp->[1]; my $match = 0; foreach my $l (@$l_list) { my $lb = $l->body; $lb = $l->pod unless $lb; eval "\$match++ if \$lb $op \$str"; die $@ if $@; } return $match; } else { die "Don't know what to do with ", Dumper([$r_exp]); } } sub test_regexp { my $self = shift; my $t_list = shift; my $regexp_set = shift; my $regexp = $regexp_set->[0]; my $case = $regexp_set->[1]; if($case) { $regexp = qr/$regexp/; } else { $regexp = qr/$regexp/i; } my $match = 0; foreach my $t_n (@$t_list) { my $body = $t_n->body; $body = $t_n->pod unless defined $body; if($body =~ $regexp) { $match ++; } } return $match; } sub test_simple { my $self = shift; my $t_list = shift; return (scalar @$t_list) > 0; } sub select_children { my $self = shift; my $ilist = shift; my $nlist = [ ]; foreach my $n (@$ilist) { my @children = $n->children; push @$nlist, @children; } return $nlist; } sub select_next { my $self = shift; my $ilist = shift; my $nlist = [ ]; foreach my $n (@$ilist) { my $next = $n->next; if($next) { push @$nlist, $next; } } return $nlist; } sub select_prev { my $self = shift; my $ilist = shift; my $nlist = [ ]; foreach my $n (@$ilist) { my $prev = $n->previous; if($prev) { push @$nlist, $prev; } } return $nlist; } sub select_parents { my $self = shift; my $ilist = shift; my $nlist = [ ]; foreach my $n (@$ilist) { if($n->parent) { push @$nlist, $n->parent; } } return $nlist; } sub select_root { my $self = shift; my $ilist = shift; my $nlist = [ ]; foreach my $n (@$ilist) { push @$nlist, $n->root; # almost certainly all the same - not # efficient but consistent. } return $nlist; } sub select_current { my $self = shift; my $ilist = shift; return $ilist; } sub select_all { my $self = shift; my $ilist = shift; my $nlist = [ ]; foreach my $n (@$ilist) { push @$nlist, $self->expand_all($n); } return $nlist; } sub expand_all { my $self = shift; my $n = shift; my @children = $n->children; my @r = ( ); foreach my $c (@children) { push @r, $c; push @r, $self->expand_all($c); }; return @r; } =head2 parse_path Parse a list of lexemes and generate a driver tree for the process method. This is a simple recursive descent parser with one element of lookahead. =cut sub parse_path { my $self = shift; my $l = shift; my $left = $self->parse_l_path($l); # Handle UNION or INTERSECT operators my $next = shift @$l; if($next) { my $tok = $next->[0]; if($tok == UNION) { return { action => "select_union", arguments => [ $left, $self->parse_path($l) ], }; } elsif($tok == INTERSECT) { return { action => "select_intersect", arguments => [ $left, $self->parse_path($l) ], } } else { unshift @$l, $next; return $left; } } else { return $left; } } sub parse_l_path { my $self = shift; my $l = shift; my $next = shift @$l; my $tok = $next->[0] if $next; my $val = $next->[1] if $next; # Accept: / (children), // (all), name,