#!/usr/local/bin/perl -w

# $Id: prest 6245 2010-03-01 20:55:12Z mnodine $

=pod
=begin reST
=begin Id
Id: ${TOOL_ID}.
Copyright (C) 2002-2005 Freescale Semiconductor
Distributed under terms of the Perl license, which is the disjunction of
the GNU General Public License (GPL) and the Artistic License.
=end Id

=begin Description
Description of ${TOOL_NAME}
===========================
This program converts the DocUtils reStructuredText or
Document Object Model (DOM) (aka pseudo-XML) formats into an output
format.  The default output format is HTML, but different formats can
be specified by using different writer schemas.

=end Description
=begin Usage
Usage: ${TOOL_NAME} [options] file(s)

Options:
  -d             Print debugging info on STDERR.  May be used multiple
                 times to get more information.
  -e <encoding>  Specifies an encoding to use for I/O (default 'utf8')
  -h             Print full usage help
  -w <writer>    Process the writer schema from <writer>.wrt (default 'html')
  -D var[=val]   Define a variable that affects parsing (may be multiple)
  -W var[=val]   Define a variable that affects a writer (may be multiple)
  -V             Print version info

Available writers: ${\WriterList()}.
Available encodings: ${\EncodingList()}.
=end Usage
=end reST
=cut

# See comments in DOM.pm for DOM structure.
#
# Data structures:
#   _`Handler`: Hash reference with the following 
#     keys:
#       ``tag``:  Regular expression for tag matching
#       ``line``: Line number where function is defined
#       ``text``: Textual representation of the code to run on tag match
#       ``code``: Code reference for the code to run on tag match.
#                 The code is a subroutine with two arguments:
#
#                   the matching DOM object
#
#                   the string returned recursively from the content
#                   of this DOM.
#
#                 It needs to return a string.  Any string returned by the
#                 top level is printed to STDOUT.
#   _`Handler array`:    Reference to array of handler objects.

# Global variables:
#   ``$main::TOP_FILE``: Name of the top-level file being processed.
#   ``$main::MY_DIR``:   The real directory in which the prest script lives
#   ``$main::TOOL_ID``:  The tool name and release number
#   ``$main::VERSION``:  The prest version

use strict;

use vars qw($TOOL_NAME $YEAR $TOP_FILE $SVNID $SVNNAME $VERSION
	    $TOOL_ID);

main();

BEGIN {
    use Text::Restructured::PrestConfig;
    $SVNID = '$Id: prest 6245 2010-03-01 20:55:12Z mnodine $ ';
    $SVNNAME = '$URL: https://mnodine@svn.berlios.de/svnroot/repos/docutils/trunk/prest/prest $ ';
    my $version = $Text::Restructured::PrestConfig::VERSION;
    $version =~ s/(\d\d\d)(?=\d)/$1./g;
    $version =~ s/(\d+)/$1+0/ge;
    $VERSION = $version;
    $SVNID =~ /Id: (\S+?) \S+ (\d+)/;
    $TOOL_ID = "$1 release $VERSION";
    $YEAR = $2;
    ($TOOL_NAME = $1) =~ s/\..*//;
}

# The main entry point.  Parses command-line options, preprocesses the
# writer schema, causes the document(s) to be read, and calls the writer.
sub main {
    use Getopt::Long;
    # Set default option values
    my %opt = (w=>'html', d=>0, D=>{}, e=>'utf8');

    # Parse options
    Getopt::Long::config('no_ignore_case');
    Usage() unless GetOptions \%opt, qw(d+ e:s h w=s D:s% W:s% V);
    # Give usage information
    Usage('Description') if $opt{h};
    Usage('Id') if $opt{V};
    Usage() unless @ARGV;

    # May need to specify an encoding for STDOUT
    if (($opt{e} || '') =~ /(.+)/) { # Sanitize for -T flag
	binmode STDOUT, ":encoding($1)" ;
    }

    use Text::Restructured::Writer;
    my $writer = new Text::Restructured::Writer($opt{w}, \%opt);

    use Text::Restructured::DOM;

    # Handle all the documents
    my $rst_parser;
    foreach $TOP_FILE (@ARGV) {
	# uncoverable branch true note:Bug in Devel::Cover
	open F,$TOP_FILE or die "Cannot open $TOP_FILE";
	if (($opt{e} || '') =~ /(.+)/) { # Sanitize for -T flag
	    binmode F, ":encoding($1)" ;
	}
 	my $dom;
	my $doc = do { local $/; <F> };
	if ($doc =~ /^<document/) {
	    # We have a DOM for input rather than an reST file
	    $dom = Text::Restructured::DOM::Parse($doc, \%opt);
	}
	else {
	    use Text::Restructured;
	    $rst_parser = new Text::Restructured(\%opt, $TOOL_ID)
		unless $rst_parser;
	    $dom = $rst_parser->Parse($doc, $TOP_FILE);
	}
	# Now compute the output string
	eval { print $writer->ProcessDOM($dom); };
	print STDERR $@ if $@;
    }
    $^W = 0;			# Turn off warnings; we're done
}

# Gets list of encodings
# Arguments: none
# Returns: list of writers
sub EncodingList {
    my @encodings;

    use Encode;
    @encodings = Encode->encodings(':all');
    return join(', ', @encodings);
}

# Gets list of writers
# Arguments: none
# Returns: list of writers
sub WriterList {
    my ($dir,@writers);
    my %writer_seen;
    foreach $dir (@INC) {
	push @writers, glob("$dir/Text/Restructured/Writer/*.wrt")
    }
    @writers = grep(! $writer_seen{$_}++,
		    grep(s|.*/([^/]+)\.wrt$|$1|, @writers));
    return join(', ', @writers);
}

# Extracts and prints usage information
# Arguments: type of usage, end marker for usage (optional)
sub Usage {
    my ($what) = @_;
    $what = "Usage" if ! $what;
    my $mark = $what eq 'Description' ? "($what|Usage)" : $what;
    # uncoverable branch false not:Assert I can open myself
    if (open(ME,$0)) {
	while (<ME>) {
	    if ((/^=begin $mark/ .. /^=end $mark/) &&
		! /^=(begin|end) $mark/) {
		s/(\$\{[^\}]+\})/eval($1)/ge;
		print;
	    }
	}
	close(ME);

	if ($what =~ /Description/) {
	    my @used = qw(Text/Restructured Text/Restructured/Transforms);
	    my %used;
	    @used{@used} = (1) x @used;
	    my $use;
	    foreach $use (@used) {
		my @rst_dir = grep (-r "$_/$use.pm", @INC);
		# uncoverable branch false note:Assert I can find my modules
		if (@rst_dir) {
		    my $newline_done;
		    my $file = "$rst_dir[0]/$use.pm";
		    # uncoverable branch true note:Assert I can open my modules
		    open(USE, $file) or die "Cannot open $file";
		    while (<USE>) {
			print "\n" unless $newline_done++;
			if ((/^=begin $mark/ .. /^=end $mark/) &&
			    ! /^=(begin|end) $mark/) {
			    s/(\$\{[^\}]+\}+)/eval $1/ge;
			    print;
			}
		    }
		    close USE;
		}
	    }
	    my (@directives, %directives);
	    my $dir;
	    foreach $dir (@INC) {
		grep(m|([^/]+)$| && ($directives{$1} = $_),
		     glob "$dir/Text/Restructured/Directive/*.pm");
	    }
	    @directives = map($directives{$_}, sort keys %directives);
	    # uncoverable branch false note:Assert I have directives
	    print << 'EOS' if @directives;

Descriptions of Plug-in Directives
==================================
EOS
	    foreach my $directive (@directives) {
		$directive =~ m|([^/]+)\.pm|;
		my $fname = $1;
		# uncoverable branch true note:Assert directive unique/readable
		next if $used{$fname} || ! -r $directive;
		my $output = 0;
		# uncoverable branch true note:Assert I can open directives
		open(DIRECTIVE, $directive) or die "Cannot open $directive";
		while (<DIRECTIVE>) {
		    if ((/^=begin $mark/ .. /^=end $mark/) &&
			    ! /^=(begin|end) $mark/) {
			if (! $output++) {
			    my $title = "Documentation for plug-in directive '$fname'";
			    print "\n$title\n",('-' x length($title)),"\n";
			}
			s/(\$\{[^\}]+\})/eval $1/ge;
			print;
		    }
		}
		close DIRECTIVE;
	    }

	    my @writers;
	    foreach $dir (@INC) {
		push(@writers, glob("$dir/Text/Restructured/Writer/*.wrt"));
	    }
	    my $writer;
	    # uncoverable branch false note:Assert I have writers
	    print << 'EOS' if @writers;

Descriptions of Writers
=======================
EOS
	;
	    my %done_writer;
	    foreach $writer (@writers) {
		my ($writer_name) = $writer =~ m|([^/]+)\.wrt$|;
		next if $done_writer{$writer_name}++;
		my $output = 0;
		# uncoverable branch true note:Assert I can open writers
		open(WRITER, $writer) or die "Cannot open $writer";
		while (<WRITER>) {
		    if ((/^=begin $mark/ .. /^=end $mark/) &&
			    ! /^=(begin|end) $mark/) {
			if (! $output++) {
			    my $title =
				"Documentation for writer '$writer_name'";
			    print "\n$title\n",('-' x length($title)),"\n";
			}
			s/(\$\{[^\}]+\})/eval $1/ge;
			print;
		    }
		}
		close WRITER;
	    }
	}
    }
    else {
	# uncoverable statement note:Defensive programming
	print STDERR "Usage not available.\n";
    }
    exit (1);
}