File Coverage

blib/lib/Pod/Tree/Pod.pm

Criterion	Covered	Total	%
statement	109	132	82.5
branch	30	40	75.0
condition			n/a
subroutine	23	24	95.8
pod	2	2	100.0
total	164	198	82.8

# Copyright (c) 2000-2003 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::Pod;
use 5.006;
use strict;
use warnings;

our $VERSION = '1.31';

use IO::File;
use Pod::Tree;

sub new {
	my ( $class, $tree, $dest ) = @_;
	defined $dest or die "Pod::Tree::Pod::new: not enough arguments\n";

	my $file = _resolve_dest($dest);

	my $pod = {
		tree     => $tree,
		root     => $tree->get_root,
		file     => $file,
		interior => 0,
		link     => 0
	};

	bless $pod, $class;
}

sub _resolve_dest {
	my $dest = shift;

	ref $dest and return $dest;

	my $fh = IO::File->new;
	$fh->open(">$dest") or die "Pod::Tree::Pod::new: Can't open $dest: $!\n";
	$fh;
}

sub translate {
	my $pod  = shift;
	my $root = $pod->{root};
	$pod->_emit_children($root);
}

sub _emit_children {
	my ( $pod, $node ) = @_;

	my $children = $node->get_children;

	for my $child (@$children) {
		$pod->_emit_node($child);
	}
}

sub _emit_siblings {
	my ( $pod, $node ) = @_;

	my $siblings = $node->get_siblings;

	for my $sibling (@$siblings) {
		$pod->_emit_node($sibling);
	}
}

sub _emit_node {
	my ( $pod, $node ) = @_;
	my $type = $node->{type};

	for ($type) {
		/code/     and $pod->_emit_code($node);
		/command/  and $pod->_emit_command($node);
		/for/      and $pod->_emit_for($node);
		/item/     and $pod->_emit_item($node);
		/list/     and $pod->_emit_list($node);
		/ordinary/ and $pod->_emit_ordinary($node);
		/sequence/ and $pod->_emit_sequence($node);
		/text/     and $pod->_emit_text($node);
		/verbatim/ and $pod->_emit_verbatim($node);
	}
}

sub _emit_code {
	my ( $pod, $node ) = @_;
	my $file = $pod->{file};
	my $text = $node->get_text;

	$file->print($text);
}

sub _emit_command {
	my ( $pod, $node ) = @_;
	my $file = $pod->{file};
	my $raw  = $node->get_raw;

	$file->print($raw);
}

sub _emit_for {
	my ( $pod, $node ) = @_;
	my $file     = $pod->{file};
	my $brackets = $node->get_brackets;

	$file->print( $brackets->[0] );
	$file->print( $node->get_text );
	$file->print( $brackets->[1] ) if $brackets->[1];
}

sub _emit_item {
	my ( $pod, $node ) = @_;
	my $file = $pod->{file};

	$file->print("=item ");
	$pod->_emit_children($node);

	$pod->_emit_siblings($node);
}

sub _emit_list {
	my ( $pod, $node ) = @_;
	my $file = $pod->{file};

	my $over = $node->get_raw;
	$file->print($over);

	$pod->_emit_children($node);

	my $back = $node->get_back;
	$back
		and $file->print( $back->get_raw );
}

sub _emit_ordinary {
	my ( $pod, $node ) = @_;

	$pod->_emit_children($node);
}

sub _emit_sequence {
	my ( $pod, $node ) = @_;

	$pod->{interior}++;

	for ( $node->get_letter ) {
		/I|B|C|E|F|S|X/ and $pod->_emit_element($node), last;
		/L/             and $pod->_emit_link($node),    last;
	}

	$pod->{interior}--;
}

sub _emit_element {
	my ( $pod, $node ) = @_;

	my $letter = $node->get_letter;
	my $file   = $pod->{file};

	$file->print("$letter<");
	$pod->_emit_children($node);
	$file->print(">");
}

sub _emit_link {
	my ( $pod, $node ) = @_;

	my $file = $pod->{file};

	$file->print("L<");

	my $children = $node->get_raw_kids;
	for my $child (@$children) {
		$pod->_emit_node($child);
	}

	$file->print(">");
}

sub _emit_link_hide {
	my ( $pod, $node ) = @_;

	my $file    = $pod->{file};
	my $target  = $node->get_target;
	my $page    = $target->get_page;
	my $section = $target->get_section;
	my $slash   = $section ? '/' : '';
	my $link    = "$page$slash$section";

	if ( $link eq $node->get_deep_text ) {
		$file->print("L<");
		$pod->_emit_children($node);
		$file->print(">");
	}
	else {
		$pod->{link}++;

		$file->print("L<");
		$pod->_emit_children($node);

		$page    = $pod->_escape($page);
		$section = $pod->_escape($section);
		$file->print("|$page$slash$section>");

		$pod->{link}--;
	}
}

sub _emit_text {
	my ( $pod, $node ) = @_;
	my $file = $pod->{file};
	my $text = $node->get_text;

	$text = $pod->_escape($text);
	$file->print($text);
}

sub _escape {
	my ( $pod, $text ) = @_;

	$text =~ s/^=(\w)/=Z<>$1/;

	if ( $pod->{interior} ) {
		$text =~ s/([A-Z])/g;
		$text =~ s/>/E/g;
	}

	if ( $pod->{link} ) {
		$text =~ s(\|)(E)g;
		$text =~ s(/)(E)g;
	}

	$text =~ s/([\x80-\xff])/sprintf("E<%d>", ord($1))/eg;

	$text;
}

sub _emit_verbatim {
	my ( $pod, $node ) = @_;
	my $file = $pod->{file};
	my $text = $node->get_text;

	$file->print($text);
}

1

__END__