—

              
#!/usr/local/bin/perl -w
# $Id: prest 6245 2010-03-01 20:55:12Z mnodine $
HideShow 37 lines of Pod
=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);
}