Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Pod::Tree dump for the stealing

by crazyinsomniac (Prior)
on May 31, 2002 at 15:03 UTC ( #170738=sourcecode: print w/ replies, xml ) Need Help??

Category: Text Processing
Author/Contact Info /msg crazyinsomniac
Description: ever use Pod::Tree; ?
ever my $tree = new Pod::Tree; ?
ever $tree->load_file(__FILE__); ?
ever print $tree->dump; ?
Wanna do it yourself?
Here is goood skeleton code (care of the Pod::Tree authors)
#!/usr/bin/perl -w

=head1 What is this?

THIS is basically what C<Pod::Tree::dump> does for you, but not
embedded in and spread accross Pod::Tree and Pod::Tree::Node;

Writing your own pod interpreter ought to be easy with this
example.

Enjoy

Sincerely, I<B<crazyinsomniac>>

P.S. you ought to look at some I<comments> i have below, before C<__DA
+TA__>

=cut

use Pod::Tree;
use Pod::Tree::Node;

use vars qw( $String $Indent );

my $tree = new Pod::Tree;
$tree->load_file(__FILE__);
print DumpTree($tree);

# Pod::Tree::Node::DumpList()
sub DumpList {
    my($nodes, $open, $close) = @_;

    $String .= ' ' x $Indent . "$open\n";
    $Indent += 3;

    for my $node (@$nodes) {
        _dump($node);
    }

    $Indent -= 3;
    return $String .= ' ' x $Indent . "$close\n";
}

#Pod::Tree::Node::SplitBar()
sub SplitBar {
    my $children = shift;
    my(@text, @link);

    while (@$children)
    {
    my $child = shift @$children;

    is_text $child or do 
    {
        push @text, $child;
        next;
    };
    
    my($text, $link) = split m(\|), $child->{'text'}, 2;
    $link and do
    {
        push @text,  text Pod::Tree::Node $text if $text;
        push @link, (text Pod::Tree::Node $link), @$children;
        return (\@text, \@link)
    };

    push @text, $child;
    }

    return (\@text, \@text);
}

#Pod::Tree::Node::SplitTarget()
sub SplitTarget {
    my $text = shift;
    my($page, $section);

    if ($text =~ /^"(.*)"$/s) { # L<"sec">;
        $page    = '';
        $section = $1;
    } else {                          # all other cases

        ($page, $section) = split m(/), $text, 2;   

        # to quiet -w
        defined $page    or $page    = '';
        defined $section or $section = '';

        $page    =~ s/\s*\(\d\)$//;    # ls (1) -> ls
        $section =~ s( ^" | "$ )()xg;  # lose the quotes

        # L<section in this man page> (without quotes)
        if ($page !~ /^[\w.-]+(::[\w.-]+)*$/ and $section eq '') {
            $section = $page;
            $page = '';
        }
    }

    $section =~ s(   \s*\n\s*   )( )xg;  # close line breaks
    $section =~ s( ^\s+ | \s+$  )()xg;   # clip leading and trailing W
+S
    
    return ($page, $section);
}

#Pod::Tree::Node::_dump()
sub _dump {
    my $node = shift;
    my $type = $node->get_type;

    $String .=  ' ' x $Indent .  uc $type . " ";

    for ($type) {
        /command/  and $String .= _dump_command($node);
        /code/     and $String .= _dump_code($node);
        /for/      and $String .= _dump_for($node);
        /item/     and $String .= _dump_item($node);
        /list/     and $String .= _dump_list($node);
        /ordinary/ and $String .= "\n";
        /root/     and $String .= "\n";
        /sequence/ and $String .= _dump_sequence($node);
        /text/     and $String .= _dump_text($node);
        /verbatim/ and $String .= _dump_verbatim($node);
    }

    _dump_children($node);
    return _dump_siblings($node);
}

#Pod::Tree::Node::_dump_command()
sub _dump_command {
    my $node    = shift;
    my $command = $node->get_command;
    my $arg     = $node->get_arg;

    return "$command $arg\n";
}

#Pod::Tree::Node::_dump_code()
sub _dump_code {
    my $node  = shift;

    my $text  = _indent($node->get_text, 3);
    my $block = "\n{\n$text}\n";

    return _indent($block, $Indent);
}

#Pod::Tree::Node::_dump_for()
sub _dump_for {
    my $node = shift;
    my $arg  = $node->get_arg;
    my $text = _indent($node->get_text, $Indent+3);

    return "$arg\n$text\n";
}


#Pod::Tree::Node::_dump_item()
sub _dump_item {
    my $node = shift;
    return uc $node->get_item_type . "\n";
}

#Pod::Tree::Node::_dump_list()
sub _dump_list {
    my $node = shift;
    return uc $node->get_list_type . "\n";
}

#Pod::Tree::Node::_dump_sequence()
sub _dump_sequence {
    my $node   = shift;
    my $letter = $node->get_letter;
    my $link   = $node->is_link ? _dump_target($node) : '';

    return "$letter$link\n";
}

#Pod::Tree::Node::_dump_text()
sub _dump_text {
    my $node = shift;
    my $text = $node->get_text;

    my $indent = ' ' x ($Indent+5);
    $text =~ s( (?<=\n) (?=.) )($indent)xg;
    return "$text\n";
}

#Pod::Tree::Node::_dump_verbatim()
sub _dump_verbatim {
    my $node = shift;
    "\n" . $node->get_text . "\n"
}

#Pod::Tree::Node::_dump_target()
sub _dump_target {
    my $node    = shift;
    my $target  = $node->get_target;
    my $page    = $target->{page};
    my $section = $target->{section};
    return " $page / $section";
}

#Pod::Tree::Node::_dump_children()
sub _dump_children {
    my $node     = shift;
    my $children = $node->get_children;
    $children and DumpList($children, '{', '}');
}

#Pod::Tree::Node::_dump_siblings()
sub _dump_siblings {
    my $node     = shift;
    my $siblings = $node->get_siblings;
    $siblings and DumpList($siblings, '[', ']');
}

#Pod::Tree::Node::_indent()
sub _indent {
    my($text, $spaces) = @_;
    my $indent = ' ' x $spaces;
    $text =~ s( (?<=\n) (?=.) )($indent)xg;
    $indent . $text
}

#Pod::Tree::Node::_make_item();
sub _make_item {
    my($item, $old) = @_;
    my $siblings = [];

    while (@$old) {
        my $sibling = $old->[0];
        is_c_item $sibling and last;
        is_c_back $sibling and last;
        shift @$old;

        is_c_over $sibling and do {
            $sibling->_make_lists($old);
        };
        push @$siblings, $sibling;
    }

    $item->{type    } = 'item';
    $item->{siblings} = $siblings;

    return $item->_set_item_type;
}


#Pod::Tree::Node::make_lists();
sub make_lists {
    my $root  = shift;
    my $nodes = $root->{children};

    return $root->_make_lists($nodes);
}

#Pod::Tree::Node::_make_lists()
sub _make_lists {
    my($node, $old) = @_;
    my $new = [];
    my $back;

    while (@$old) {
        my $child = shift @$old;
        is_c_over $child and _make_lists($child, $old);
        is_c_item $child and _make_item($child, $old);
        is_c_back $child and $back = $child, last;
        push @$new, $child;
    }

    $node->{children} = $new;

    is_root $node and return;

    $node->{type} = 'list';
    $node->{back} = $back;
    return $node->_set_list_type;
}

#Pod::Tree::Node::parse_links()
sub parse_links {
    my $node = shift;

    is_link $node and _parse_link($node); ## my _parse_link

    my $children = $node->{children};
    for my $child (@$children) {
        parse_links($child); ## my parse_links
    }
}

#Pod::Tree::Node::_parse_link()
sub _parse_link {
    my $node = shift;

    $node->{raw_kids} = $node->clone->{children};

    my $children = $node->{children};
    my($text_kids, $target_kids) = SplitBar($children);

    $node->{ children } = $text_kids;
    $node->{'target'  } = target Pod::Tree::Node $target_kids;
    return $node->{'target'  };
}


#Pod::Tree::Node::_parse_text()
sub _parse_text {
    my $tokens = shift;
    my(@stack, @width);

    while (@$tokens) {
        my $token = shift @$tokens;
        length $token or next;

        $token =~ /^[A-Z]</ and do {
            my $width = $token =~ tr/</</;
            push @width, $width;
            my $node = letter Pod::Tree::Node $token;
            push @stack, $node;
            next;
        };

        @width and $token =~ />{$width[-1],}$/ and do {
            my $width = pop @width;
            my($letter, $interior) = _pop_sequence(\@stack, $width);
            my $node = sequence Pod::Tree::Node $letter, $interior;
            push @stack, $node;
            $token =~ s/^\s*>{$width}//;
            my @tokens = split //, $token;
            unshift @$tokens, @tokens;
            next;
        };

        my $node = text Pod::Tree::Node $token;
        push @stack, $node;
    }

    if (@width) {
        my @text = map { $_->get_deep_text } @stack;
        Pod::Tree::Node->_warn("Missing '>' delimiter in\n@text");
    }

    return \@stack;
}


#Pod::Tree::Node::_pop_sequence()
sub _pop_sequence {
    my($stack, $width) = @_;
    my($node, @interior);

    while (@$stack)
    {
    $node = pop @$stack;
    is_letter $node and $node->{width} == $width and 
        return ($node, \@interior);
    unshift @interior, $node;
    }

    my @text = map { $_->get_deep_text } @interior;
    $node->_warn("Mismatched sequence delimiters around\n@text");

    $node = letter Pod::Tree::Node  ' ';
    return $node, \@interior;
}

#Pod::Tree::Node::unescape()
sub unescape {
    my $node = shift;

    my $children = $node->{children};

    for my $child (@$children) {
        unescape($child);
    }

    is_sequence $node and _unescape_sequence($node);
}

## Pod::Tree::Node::_unescape_sequence()
sub _unescape_sequence {
    my $node = shift;

    for ($node->{'letter'}) {
        /Z/ and $node->force_text(''), last;
        /E/ and do {
            my $child = $node->{children}[0];
            $child or last;
            my $text = _unescape_text($child);
            $text and $node->force_text($text);
            last;
        };
    }
}

my %EscapeMap = ('lt'    => '<',
         'gt'    => '>',
          sol    => '/',
          verbar => '|');

#Pod::Tree::Node::_unescape_text()
sub _unescape_text {
    my $node  = shift;

    my $text   = $node->{'text'};
    my $escape = $EscapeMap{$text};
    $escape and return $escape;

    $text =~ /^\d+$/ and return chr($text);

    return '';
}

#Pod::Tree::Node::dump()
sub DumpTree {
    my $tree = shift;

    $Indent = 0;
    $String = '';

    _dump($tree->{root});  # my _dump

    return $String;
}


## using any of these would just complicate things without any reason
## (more logic than i need or care to reinvent/modify )
## all of the get_* do should be left alone
## same goes for force_*
## same goes for is_*
## same goes for /^[a-z]+/
#Pod::Tree::Node::_set_item_type(); # we let the original handle it
#Pod::Tree::Node::_set_list_type(); # we let the original handle it
#Pod::Tree::Node::clone(); # HEEEEL NO
#Pod::Tree::Node::code(); # HEEEEL NO
#Pod::Tree::Node::command(); # HEEEEL NO
#Pod::Tree::Node::consolidate();# HEEEEL NO
#Pod::Tree::Node::force_for();
#Pod::Tree::Node::force_text();
#Pod::Tree::Node::get_arg();
#Pod::Tree::Node::get_children();
#Pod::Tree::Node::get_command();
#Pod::Tree::Node::get_deep_text();
#Pod::Tree::Node::get_item_type();
#Pod::Tree::Node::get_letter();
#Pod::Tree::Node::get_list_type();
#Pod::Tree::Node::get_siblings();
#Pod::Tree::Node::get_target();
#Pod::Tree::Node::get_text();
#Pod::Tree::Node::get_type();
#Pod::Tree::Node::is_c_back();
#Pod::Tree::Node::is_c_begin();
#Pod::Tree::Node::is_c_end();
#Pod::Tree::Node::is_c_for();
#Pod::Tree::Node::is_c_item();
#Pod::Tree::Node::is_c_over();
#Pod::Tree::Node::is_code();
#Pod::Tree::Node::is_for();
#Pod::Tree::Node::is_letter();
#Pod::Tree::Node::is_link();
#Pod::Tree::Node::is_root();
#Pod::Tree::Node::is_sequence();
#Pod::Tree::Node::is_text();
#Pod::Tree::Node::is_verbatim();
#Pod::Tree::Node::letter();
#Pod::Tree::Node::make_sequences(); ######
#Pod::Tree::Node::ordinary();
#Pod::Tree::Node::parse_begin();
#Pod::Tree::Node::sequence();
#Pod::Tree::Node::target();
#Pod::Tree::Node::text();
#Pod::Tree::Node::verbatim();

#Pod::Tree::dump() # essentially $tree->{root}->dump


__DATA__

Not in pod.

=pod

In pod.

=cut

Not in pod.

=head1 POD

More in pod.

=pod

=head1 HEAD

=for html Line 1<br> &lt;<em>Line 2</em>&gt;

=for html <a href="http://world.std.com/~swmcd/steven/index.html">Stev
+en</a>

    VERBATIM
    VERBATIM
    VERBATIM

Fee, Fie, Foe, Fum
Foo, Bar, Baz, Buz

=begin text

=head2 Not really a command

    VERBATIM
    VERBATIM
    VERBATIM

Fee, Fie, Foe, Fum
Foo, Bar, Baz, Buz



=end text

=head2 Really a commmand.
=head1 NAME

Links

=head2 Original

A  L<name> manual page.

An L<name/ident> item in manual page. 

A  L<name/"sec"> section in other manual page.

A  L<"sec">      section in this manual page (the quotes are B<not> op
+tional).

A  L< sec >      section in this manual page

A  L<sec tion >   section in this manual page

A  L<mod::ule.foo>  link to a module POD

A  L</"sec">     section in this manual page (the quotes are optional)
+.


=head2 Total Control

A  L<text|name> manual page.

An L<text|name/ident> item in manual page. 

A  L<text|name/"sec"> section in other manual page.

A  L<text|"sec">      section in this manual page (quotes are B<not> o
+ptional).

A  L<text| sec >      section in this manual page 

A  L<text|sec tion>   section in this manual page 

A  L<text|bar-mod::ule>   link to a module POD

A  L<text|/"sec">     section in this manual page (quotes are optional
+).


=head2 Targets

X<target>

X<target with spaces>

X<target w/spaces>

X<I<italic> target>


=head2 Links

L</target>

L<"target with spaces">

L<" target w/spaces ">

L<"target with
line 
breaks">

L</I<italic> B<target>>

L<I<page>/I<section>>

L<target|c|foo.html> This probably won't do what you want

L<fooE<sol>bar|blort>

L<fooE<verbar>bar|blort>

L<fooE<sol>barE<verbar>baz|blort>
=head1 NAME

Lists

=head2 Bullet

=over 4

=item *

foo

=item *

bar

=item *

baz

=back

=head2 Number

=over 4

=item 1

foo

=item 2

bar

=item 3

baz

=back

=head2 Text

=over 4

=item do

a deer, a female deer

=item ray

a drop of goden sun

=item me

me, a name, I call myself

=item fa

a long, long way to run

=back

=over 4

=item * do

a deer, a female deer

=item * ray

a drop of goden sun

=back

=over 4

=item 3 me

me, a name, I call myself

=item 4 fa

a long, long way to run

=back

=head2 Siblings

=over 4

=item *

Star 1 Para 1

Star 1 Para 2

Star 1 Para 3

=item *

Star 2

    Star 2 Verbatim 1
    Star 2 Verbatim 2
    Star 2 Verbatim 3

=item *

Star 3

=back

=head2 Markups

=over 4

=item term 1

definition 1

=item I<term 2>

C<definition 2>

=item I<term B<3>>

S<definition 3>

=back

=head2 Nested

=over 4

=item *

Level 1, Star 1 of 2


=over 4

=item *

Level 2, Star 1 of 2

=item *

Level 2, Star 2 of 2

=back


=item *


=over 4

=item 1

Level 2, Number 1 of 2

=item 2

Level 2, Number 2 of 2

=back


=back



=over 4

=item Level 1, term 1 of 2


=over 4

=item *

Level 2, Star 1 of 3

=item *

Level 2, Star 2 of 3

=item *

Level 2, Star 3 of 3

=back


=item Level 1, term 2 of 2


=over 4

=item *

Level 2, Star 1 of 3


=over 4

=item 1

Level 3, Number 1 of 2

=item 2

Level 3, Number 2 of 2

=back


=item *

Level 2, Star 2 of 3

=item *

Level 2, Star 3 of 3

=back


=back



=head2 Pathological

=over 8

=item *

Over 8

=back


=over 4

=item *

Star 1

=item 2

Number 2

=item Term 3

Definition 3

=back

Empty

=over 4

=back

=over 4

No Items

=back


=over 4

=item *

Star 1

=item *

No =back


=head1 HEAD1

Head 1 text

=head2 HEADI<2>

Head2 B<text>

    +------------------------------+
    | This is a verbatim paragraph |
    +------------------------------+

=head1 NAME

B<print> [-n] I<file>

=head1 DESCRIPTION

=Z<>head1 introduces a 1st level heading.
B<print> sends I<file> to a printer.
B<bold>, I<italic>, zero, B<bold, I<bold italic>, bold> normal.
S<Non-breaking space>, C<0>.

C<code>, B<bold C<code>>, F<file>, X<index>
<, >, /, |, A, E<Agrave>
B<<, E<gt>, /, |, A, E<Agrave>>
I<B<<, E<gt>, /, |, A, E<Agrave>>>

E<copy> E<deg> E<divide> E<frac12> E<micro> E<middot> E<not> E<reg> E<
+times>

C<$a <=E<gt> $b>

C<B<$foo-E<gt>bar>>,
I<C<B<$foo-E<gt>bar>>>,

An C<L<page/section>> markup.

C<$a << $b>,
B<C<$a E<gt>E<gt>$b>>;

Comment on Pod::Tree dump for the stealing
Select or Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://170738]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (12)
As of 2015-07-02 08:37 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (31 votes), past polls