# Copyright 2000 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;

require 5.6.0;

use strict;
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 = new IO::File;
    $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)
    {
	/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_command
{
    my($pod, $node) = @_;
    my $file = $pod->{file};

    my $command  = $node->get_command;
    $file->print("=$command ");

    $pod->_emit_children($node);

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


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

    $file->print("=begin $interpreter\n\n$text\n\n=end\n\n");
}


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

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

    $pod->_emit_siblings($node);
}


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

    $file->print("=over $arg\n\n");

    $pod->_emit_children($node);

    $file->print("=back\n\n");
}


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

    $pod->_emit_children($node);
    $pod->{file}->print("\n\n");
}


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};
    my $target   = $node->get_target;
    my $page     = $target->get_page;
    my $section  = $target->get_section;
    my $slash    = $section ? '/' : '';

    $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])</$1E<lt>/g;
	$text =~ s/>/E<gt>/g;
    }

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

    $text
}


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

    $file->print("$text\n\n");
}

__END__

=head1 NAME

Pod::Tree::Pod - Convert a Pod::Tree back to a POD

=head1 SYNOPSIS

  use Pod::Tree::Pod;

  $tree =  new Pod::Tree;
    
  $dest =  new IO::File;
  $dest = "file.pod";

  $pod  =  new Pod:::Tree::HTML $tree, $dest;

  $pod->translate;

=head1 DESCRIPTION

C<Pod::Tree::Pod> converts a Pod::Tree back to a POD.
The destination is fixed when the object is created.
The C<translate> method does the actual translation.

For convenience, 
Pod::Tree::Pod can write the POD to a variety of destinations.
The C<new> method resolves the I<$dest> argument.

=head2 Destination resolution

C<Pod::Tree::Pod> can write HTML to either of 2 destinations.
C<new> resolves I<$dest> by checking these things,
in order:

=over 4

=item 1

If I<$dest> is a reference,
then it is taken to be an C<IO::File> object
that is already open on the file where the POD will be written.

=item 2

If I<$dest> is not a reference,
then it is taken to be the name of the file where the POD will be written.

=back

=head1 METHODS

=over 4

=item I<$pod> = C<new> C<Pod::Tree::Pod> I<$tree>, I<$dest>

Creates a new C<Pod::Tree::Pod> object.

I<$tree> is a C<Pod::Tree> object that represents a POD.
I<$pod> writes the POD to I<$dest>.
See L</Destination resolution> for details.

=item I<$pod>->C<translate>

Writes the text of the POD.
This method should only be called once.

=back

=head1 DIAGNOSTICS

=over 4

=item C<Pod::Tree::Pod::new: not enough arguments>

(F) C<new> called with fewer than 2 arguments.

=item C<Pod::Tree::HTML::new: Can't open $dest: $!>

(F) The destination file couldn't be opened.

=back

=head1 NOTES

=over 4

=item *

The destination doesn't actually have to be an C<IO::File> object.
It may be any object that has a C<print> method.

=back

=head1 SEE ALSO

perl(1), L<C<Pod::Tree>>, L<C<Pod::Tree::Node>>

=head1 AUTHOR

Steven McDougall, swmcd@world.std.com

=head1 COPYRIGHT

Copyright 2000 by Steven McDougall. This module is free
software; you can redistribute it and/or modify it under the same
terms as Perl itself.

