File Coverage

blib/lib/Pod/Tree.pm

Criterion	Covered	Total	%
statement	112	149	75.1
branch	21	32	65.6
condition	1	3	33.3
subroutine	20	26	76.9
pod	13	13	100.0
total	167	223	74.8

# Copyright (c) 1999-2009 by Steven McDougall.  This module is free
# software; you can redistribute it and/or modify it under the same
# terms as Perl itself.

package Pod::Tree;
use 5.006;

use strict;
use warnings;
use IO::File;
use Pod::Tree::Node;
use Pod::Tree::Stream;

our $VERSION = '1.30';

sub new {
    my $class = shift;
    my $tree  = {
    	loaded     => 0,
    	paragraphs => []
    };
    bless $tree, $class;
}

sub load_file {
    my ( $tree, $file, %options ) = @_;

    Pod::Tree::Node->set_filename($file);

    my $fh = IO::File->new;
    $fh->open($file) or return '';
    $tree->load_fh( $fh, %options );

    Pod::Tree::Node->set_filename("");
    1;
}

sub load_fh {
    my ( $tree, $fh, %options ) = @_;

    $tree->{in_pod} = 0;
    $tree->_load_options(%options);
    my $limit = $tree->{limit};

    my $stream = Pod::Tree::Stream->new($fh);
    my $paragraph;
    my @paragraphs;
    while ( $paragraph = $stream->get_paragraph ) {
    	push @paragraphs, $paragraph;
    	$limit and $limit == @paragraphs and last;
    }

    $tree->{paragraphs} = \@paragraphs;
    $tree->_parse;
}

sub load_string {
    my ( $tree, $string, %options ) = @_;

    my @chunks = split /( \n\s*\n | \r\s*\r | \r\n\s*\r\n )/x, $string;

    my (@paragraphs);
    while (@chunks) {
    	push @paragraphs, join '', splice @chunks, 0, 2;
    }

    $tree->load_paragraphs( \@paragraphs, %options );
}

sub load_paragraphs {
    my ( $tree, $paragraphs, %options ) = @_;

    $tree->{in_pod} = 1;
    $tree->_load_options(%options);

    my $limit      = $tree->{limit};
    my @paragraphs = @$paragraphs;
    $limit and splice @paragraphs, $limit;

    $tree->{paragraphs} = \@paragraphs;
    $tree->_parse;
}

sub loaded { shift->{'loaded'} }

sub _load_options {
    my ( $tree, %options ) = @_;

    my ( $key, $value );
    while ( ( $key, $value ) = each %options ) {
    	$tree->{$key} = $value;
    }
}

sub _parse {
    my $tree = shift;

    $tree->_make_nodes;
    $tree->_make_for;
    $tree->_make_sequences;

    my $root = $tree->{root};

    $root->parse_links;
    $root->unescape;
    $root->consolidate;
    $root->make_lists;

    $tree->{'loaded'} = 1;
}

sub _add_paragraph {
    my ( $tree, $paragraph ) = @_;

    for ($paragraph) {
    	/^=cut/ and do {
    		$tree->{in_pod} = 0;
    		last;
    	};
    	$tree->{in_pod} and do {
    		push @{ $tree->{paragraphs} }, $paragraph;
    		last;
    	};
    	/^=\w/ and do {
    		$tree->{in_pod} = 1;
    		push @{ $tree->{paragraphs} }, $paragraph;
    		last;
    	};
    }
}

my %Command = map { $_ => 1 } qw(=pod =cut
    =head1 =head2 =head3 =head4
    =over =item =back
    =for =begin =end);

sub _make_nodes {
    my $tree       = shift;
    my $paragraphs = $tree->{paragraphs};
    my $in_pod     = $tree->{in_pod};
    my @children;

    for my $paragraph (@$paragraphs) {
    	my ($word) = split( /\s/, $paragraph );
    	my $node;

    	if ($in_pod) {
    		if ( $paragraph =~ /^\s/ ) {
    			$node = Pod::Tree::Node->verbatim($paragraph);
    		}
    		elsif ( $Command{$word} ) {
    			$node   = Pod::Tree::Node->command($paragraph);
    			$in_pod = $word ne '=cut';
    		}
    		else {
    			$node = Pod::Tree::Node->ordinary($paragraph);
    		}
    	}
    	else {
    		if ( $Command{$word} ) {
    			$node   = Pod::Tree::Node->command($paragraph);
    			$in_pod = $word ne '=cut';
    		}
    		else {
    			$node = Pod::Tree::Node->code($paragraph);
    		}
    	}

    	push @children, $node;
    }

    $tree->{root} = Pod::Tree::Node->root( \@children );
}

sub _make_for {
    my $tree = shift;
    my $root = $tree->{root};
    my $old  = $root->get_children;

    my @new;
    while (@$old) {
    	my $node = shift @$old;
    	$node->is_c_for   and $node->force_for;
    	$node->is_c_begin and $node->parse_begin($old);
    	push @new, $node;
    }

    $root->set_children( \@new );
}

sub _make_sequences {
    my $tree  = shift;
    my $root  = $tree->{root};
    my $nodes = $root->get_children;

    for my $node (@$nodes) {
    	$node->is_code     and next;
    	$node->is_verbatim and next;
    	$node->is_for      and next;
    	$node->make_sequences;
    }
}

sub dump {
    my $tree = shift;
    $tree->{root}->dump;
}

sub get_root { shift->{root} }

sub set_root {
    my ( $tree, $root ) = @_;
    $tree->{root} = $root;
}

sub push {
    my ( $tree, @nodes ) = @_;
    my $root     = $tree->{root};
    my $children = $root->get_children;
    push @$children, @nodes;
}

sub pop {
    my $tree     = shift;
    my $root     = $tree->get_root;
    my $children = $root->get_children;
    pop @$children;
}

sub walk {
    my ( $tree, $sub ) = @_;

    my $root = $tree->get_root;
    _walk( $root, $sub );
}

sub _walk {
    my ( $tree, $sub ) = @_;

    my $descend = &$sub($tree);    # :TRICKY: sub can modify node
    $descend or return;

    my $node = $tree;

    my $children = $node->get_children;
    for my $child (@$children) {
    	_walk( $child, $sub );
    }

    my $siblings = $node->get_siblings;
    for my $sibling (@$siblings) {
    	_walk( $sibling, $sub );
    }
}

sub has_pod {
    my $tree     = shift;
    my $root     = $tree->get_root;
    my $children = $root->get_children;

    scalar grep { $_->get_type ne 'code' } @$children;
}

1

__END__