prest/prest

   1 #!/usr/local/bin/perl -w
   2
   3 # $Id$
   4
   5 =pod
   6 =begin reST
   7 =begin Id
   8 Id: ${TOOL_ID}.
   9 Copyright (C) 2002-2005 Freescale Semiconductor
  10 Distributed under terms of the Perl license, which is the disjunction of
  11 the GNU General Public License (GPL) and the Artistic License.
  12 =end Id
  13
  14 =begin Description
  15 Description of ${TOOL_NAME}
  16 ===========================
  17 This program converts the DocUtils reStructuredText or
  18 Document Object Model (DOM) (aka pseudo-XML) formats into an output
  19 format.  The default output format is HTML, but different formats can
  20 be specified by using different writer schemas.
  21
  22 =end Description
  23 =begin Usage
  24 Usage: ${TOOL_NAME} [options] file(s)
  25
  26 Options:
  27   -d             Print debugging info on STDERR.  May be used multiple
  28                  times to get more information.
  29   -e <encoding>  Specifies an encoding to use for output (default 'utf8')
  30   -h             Print full usage help
  31   -w <writer>    Process the writer schema from <writer>.wrt (default 'html')
  32   -D var[=val]   Define a variable that affects parsing (may be multiple)
  33   -W var[=val]   Define a variable that affects a writer (may be multiple)
  34   -V             Print version info
  35
  36 Available writers: ${\WriterList()}.
  37 Available encodings: ${\EncodingList()}.
  38 =end Usage
  39 =end reST
  40 =cut
  41
  42 # See comments in DOM.pm for DOM structure.
  43 #
  44 # Data structures:
  45 #   _`Handler`: Hash reference with the following
  46 #     keys:
  47 #       ``tag``:  Regular expression for tag matching
  48 #       ``line``: Line number where function is defined
  49 #       ``text``: Textual representation of the code to run on tag match
  50 #       ``code``: Code reference for the code to run on tag match.
  51 #                 The code is a subroutine with two arguments:
  52 #
  53 #                   the matching DOM object
  54 #
  55 #                   the string returned recursively from the content
  56 #                   of this DOM.
  57 #
  58 #                 It needs to return a string.  Any string returned by the
  59 #                 top level is printed to STDOUT.
  60 #   _`Handler array`:    Reference to array of handler objects.
  61
  62 # Global variables:
  63 #   ``$main::TOP_FILE``: Name of the top-level file being processed.
  64 #   ``$main::MY_DIR``:   The real directory in which the prest script lives
  65 #   ``$main::TOOL_ID``:  The tool name and release number
  66 #   ``$main::VERSION``:  The prest version
  67
  68 use strict;
  69
  70 use vars qw($TOOL_NAME $YEAR $TOP_FILE $SVNID $SVNNAME $VERSION
  71             $TOOL_ID);
  72
  73 main();
  74
  75 BEGIN {
  76     use Text::Restructured::PrestConfig;
  77     $SVNID = '$Id$ ';
  78     $SVNNAME = '$URL$ ';
  79     my $version = $Text::Restructured::PrestConfig::VERSION;
  80     $version =~ s/(\d\d\d)(?=\d)/$1./g;
  81     $version =~ s/(\d+)/$1+0/ge;
  82     $VERSION = $version;
  83     $SVNID =~ /Id: (\S+?) \S+ (\d+)/;
  84     $TOOL_ID = "$1 release $VERSION";
  85     $YEAR = $2;
  86     ($TOOL_NAME = $1) =~ s/\..*//;
  87 }
  88
  89 # The main entry point.  Parses command-line options, preprocesses the
  90 # writer schema, causes the document(s) to be read, and calls the writer.
  91 sub main {
  92     use Getopt::Long;
  93     # Set default option values
  94     my %opt = (w=>'html', d=>0, D=>{});
  95
  96     # Parse options
  97     Getopt::Long::config('no_ignore_case');
  98     Usage() unless GetOptions \%opt, qw(d+ e:s h w=s D:s% W:s% V);
  99     # Give usage information
 100     Usage('Description') if $opt{h};
 101     Usage('Id') if $opt{V};
 102     Usage() unless @ARGV;
 103
 104     # May need to specify an encoding for STDOUT
 105     if (($opt{e} || '') =~ /(.+)/) { # Sanitize for -T flag
 106         binmode STDOUT, ":encoding($1)" ;
 107     }
 108
 109     use Text::Restructured::Writer;
 110     my $writer = new Text::Restructured::Writer($opt{w}, \%opt);
 111
 112     use Text::Restructured::DOM;
 113
 114     # Handle all the documents
 115     my $rst_parser;
 116     foreach $TOP_FILE (@ARGV) {
 117         # uncoverable branch true note:Bug in Devel::Cover
 118         open F,$TOP_FILE or die "Cannot open $TOP_FILE";
 119         my @doc = <F>;
 120         close F;
 121         my $dom;
 122         my $doc = join '', @doc;
 123         if ($doc =~ /^<document/) {
 124             # We have a DOM for input rather than an reST file
 125             $dom = Text::Restructured::DOM::Parse($doc, \%opt);
 126         }
 127         else {
 128             use Text::Restructured;
 129             $rst_parser = new Text::Restructured(\%opt, $TOOL_ID)
 130                 unless $rst_parser;
 131             $dom = $rst_parser->Parse($doc, $TOP_FILE);
 132         }
 133         # Now compute the output string
 134         eval { print $writer->ProcessDOM($dom); };
 135         print STDERR $@ if $@;
 136     }
 137     $^W = 0;                    # Turn off warnings; we're done
 138 }
 139
 140 # Gets list of encodings
 141 # Arguments: none
 142 # Returns: list of writers
 143 sub EncodingList {
 144     my @encodings;
 145
 146     use Encode;
 147     @encodings = Encode->encodings();
 148     return join(', ', @encodings);
 149 }
 150
 151 # Gets list of writers
 152 # Arguments: none
 153 # Returns: list of writers
 154 sub WriterList {
 155     my ($dir,@writers);
 156     my %writer_seen;
 157     foreach $dir (@INC) {
 158         push @writers, glob("$dir/Text/Restructured/Writer/*.wrt")
 159     }
 160     @writers = grep(! $writer_seen{$_}++,
 161                     grep(s|.*/([^/]+)\.wrt$|$1|, @writers));
 162     return join(', ', @writers);
 163 }
 164
 165 # Extracts and prints usage information
 166 # Arguments: type of usage, end marker for usage (optional)
 167 sub Usage {
 168     my ($what) = @_;
 169     $what = "Usage" if ! $what;
 170     my $mark = $what eq 'Description' ? "($what|Usage)" : $what;
 171     # uncoverable branch false not:Assert I can open myself
 172     if (open(ME,$0)) {
 173         while (<ME>) {
 174             if ((/^=begin $mark/ .. /^=end $mark/) &&
 175                 ! /^=(begin|end) $mark/) {
 176                 s/(\$\{[^\}]+\})/eval($1)/ge;
 177                 print;
 178             }
 179         }
 180         close(ME);
 181
 182         if ($what =~ /Description/) {
 183             my @used = qw(Text/Restructured Text/Restructured/Transforms);
 184             my %used;
 185             @used{@used} = (1) x @used;
 186             my $use;
 187             foreach $use (@used) {
 188                 my @rst_dir = grep (-r "$_/$use.pm", @INC);
 189                 # uncoverable branch false note:Assert I can find my modules
 190                 if (@rst_dir) {
 191                     my $newline_done;
 192                     my $file = "$rst_dir[0]/$use.pm";
 193                     # uncoverable branch true note:Assert I can open my modules
 194                     open(USE, $file) or die "Cannot open $file";
 195                     while (<USE>) {
 196                         print "\n" unless $newline_done++;
 197                         if ((/^=begin $mark/ .. /^=end $mark/) &&
 198                             ! /^=(begin|end) $mark/) {
 199                             s/(\$\{[^\}]+\}+)/eval $1/ge;
 200                             print;
 201                         }
 202                     }
 203                     close USE;
 204                 }
 205             }
 206             my (@directives, %directives);
 207             my $dir;
 208             foreach $dir (@INC) {
 209                 grep(m|([^/]+)$| && ($directives{$1} = $_),
 210                      glob "$dir/Text/Restructured/Directive/*.pm");
 211             }
 212             @directives = map($directives{$_}, sort keys %directives);
 213             # uncoverable branch false note:Assert I have directives
 214             print << 'EOS' if @directives;
 215
 216 Descriptions of Plug-in Directives
 217 ==================================
 218 EOS
 219             foreach my $directive (@directives) {
 220                 $directive =~ m|([^/]+)\.pm|;
 221                 my $fname = $1;
 222                 # uncoverable branch true note:Assert directive unique/readable
 223                 next if $used{$fname} || ! -r $directive;
 224                 my $output = 0;
 225                 # uncoverable branch true note:Assert I can open directives
 226                 open(DIRECTIVE, $directive) or die "Cannot open $directive";
 227                 while (<DIRECTIVE>) {
 228                     if ((/^=begin $mark/ .. /^=end $mark/) &&
 229                             ! /^=(begin|end) $mark/) {
 230                         if (! $output++) {
 231                             my $title = "Documentation for plug-in directive '$fname'";
 232                             print "\n$title\n",('-' x length($title)),"\n";
 233                         }
 234                         s/(\$\{[^\}]+\})/eval $1/ge;
 235                         print;
 236                     }
 237                 }
 238                 close DIRECTIVE;
 239             }
 240
 241             my @writers;
 242             foreach $dir (@INC) {
 243                 push(@writers, glob("$dir/Text/Restructured/Writer/*.wrt"));
 244             }
 245             my $writer;
 246             # uncoverable branch false note:Assert I have writers
 247             print << 'EOS' if @writers;
 248
 249 Descriptions of Writers
 250 =======================
 251 EOS
 252         ;
 253             my %done_writer;
 254             foreach $writer (@writers) {
 255                 my ($writer_name) = $writer =~ m|([^/]+)\.wrt$|;
 256                 next if $done_writer{$writer_name}++;
 257                 my $output = 0;
 258                 # uncoverable branch true note:Assert I can open writers
 259                 open(WRITER, $writer) or die "Cannot open $writer";
 260                 while (<WRITER>) {
 261                     if ((/^=begin $mark/ .. /^=end $mark/) &&
 262                             ! /^=(begin|end) $mark/) {
 263                         if (! $output++) {
 264                             my $title =
 265                                 "Documentation for writer '$writer_name'";
 266                             print "\n$title\n",('-' x length($title)),"\n";
 267                         }
 268                         s/(\$\{[^\}]+\})/eval $1/ge;
 269                         print;
 270                     }
 271                 }
 272                 close WRITER;
 273             }
 274         }
 275     }
 276     else {
 277         # uncoverable statement note:Defensive programming
 278         print STDERR "Usage not available.\n";
 279     }
 280     exit (1);
 281 }