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 I/O (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=>{}, e=>'utf8');
  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         if (($opt{e} || '') =~ /(.+)/) { # Sanitize for -T flag
 120             binmode F, ":encoding($1)" ;
 121         }
 122         my $dom;
 123         my $doc = do { local $/; <F> };
 124         if ($doc =~ /^<document/) {
 125             # We have a DOM for input rather than an reST file
 126             $dom = Text::Restructured::DOM::Parse($doc, \%opt);
 127         }
 128         else {
 129             use Text::Restructured;
 130             $rst_parser = new Text::Restructured(\%opt, $TOOL_ID)
 131                 unless $rst_parser;
 132             $dom = $rst_parser->Parse($doc, $TOP_FILE);
 133         }
 134         # Now compute the output string
 135         eval { print $writer->ProcessDOM($dom); };
 136         print STDERR $@ if $@;
 137     }
 138     $^W = 0;                    # Turn off warnings; we're done
 139 }
 140
 141 # Gets list of encodings
 142 # Arguments: none
 143 # Returns: list of writers
 144 sub EncodingList {
 145     my @encodings;
 146
 147     use Encode;
 148     @encodings = Encode->encodings(':all');
 149     return join(', ', @encodings);
 150 }
 151
 152 # Gets list of writers
 153 # Arguments: none
 154 # Returns: list of writers
 155 sub WriterList {
 156     my ($dir,@writers);
 157     my %writer_seen;
 158     foreach $dir (@INC) {
 159         push @writers, glob("$dir/Text/Restructured/Writer/*.wrt")
 160     }
 161     @writers = grep(! $writer_seen{$_}++,
 162                     grep(s|.*/([^/]+)\.wrt$|$1|, @writers));
 163     return join(', ', @writers);
 164 }
 165
 166 # Extracts and prints usage information
 167 # Arguments: type of usage, end marker for usage (optional)
 168 sub Usage {
 169     my ($what) = @_;
 170     $what = "Usage" if ! $what;
 171     my $mark = $what eq 'Description' ? "($what|Usage)" : $what;
 172     # uncoverable branch false not:Assert I can open myself
 173     if (open(ME,$0)) {
 174         while (<ME>) {
 175             if ((/^=begin $mark/ .. /^=end $mark/) &&
 176                 ! /^=(begin|end) $mark/) {
 177                 s/(\$\{[^\}]+\})/eval($1)/ge;
 178                 print;
 179             }
 180         }
 181         close(ME);
 182
 183         if ($what =~ /Description/) {
 184             my @used = qw(Text/Restructured Text/Restructured/Transforms);
 185             my %used;
 186             @used{@used} = (1) x @used;
 187             my $use;
 188             foreach $use (@used) {
 189                 my @rst_dir = grep (-r "$_/$use.pm", @INC);
 190                 # uncoverable branch false note:Assert I can find my modules
 191                 if (@rst_dir) {
 192                     my $newline_done;
 193                     my $file = "$rst_dir[0]/$use.pm";
 194                     # uncoverable branch true note:Assert I can open my modules
 195                     open(USE, $file) or die "Cannot open $file";
 196                     while (<USE>) {
 197                         print "\n" unless $newline_done++;
 198                         if ((/^=begin $mark/ .. /^=end $mark/) &&
 199                             ! /^=(begin|end) $mark/) {
 200                             s/(\$\{[^\}]+\}+)/eval $1/ge;
 201                             print;
 202                         }
 203                     }
 204                     close USE;
 205                 }
 206             }
 207             my (@directives, %directives);
 208             my $dir;
 209             foreach $dir (@INC) {
 210                 grep(m|([^/]+)$| && ($directives{$1} = $_),
 211                      glob "$dir/Text/Restructured/Directive/*.pm");
 212             }
 213             @directives = map($directives{$_}, sort keys %directives);
 214             # uncoverable branch false note:Assert I have directives
 215             print << 'EOS' if @directives;
 216
 217 Descriptions of Plug-in Directives
 218 ==================================
 219 EOS
 220             foreach my $directive (@directives) {
 221                 $directive =~ m|([^/]+)\.pm|;
 222                 my $fname = $1;
 223                 # uncoverable branch true note:Assert directive unique/readable
 224                 next if $used{$fname} || ! -r $directive;
 225                 my $output = 0;
 226                 # uncoverable branch true note:Assert I can open directives
 227                 open(DIRECTIVE, $directive) or die "Cannot open $directive";
 228                 while (<DIRECTIVE>) {
 229                     if ((/^=begin $mark/ .. /^=end $mark/) &&
 230                             ! /^=(begin|end) $mark/) {
 231                         if (! $output++) {
 232                             my $title = "Documentation for plug-in directive '$fname'";
 233                             print "\n$title\n",('-' x length($title)),"\n";
 234                         }
 235                         s/(\$\{[^\}]+\})/eval $1/ge;
 236                         print;
 237                     }
 238                 }
 239                 close DIRECTIVE;
 240             }
 241
 242             my @writers;
 243             foreach $dir (@INC) {
 244                 push(@writers, glob("$dir/Text/Restructured/Writer/*.wrt"));
 245             }
 246             my $writer;
 247             # uncoverable branch false note:Assert I have writers
 248             print << 'EOS' if @writers;
 249
 250 Descriptions of Writers
 251 =======================
 252 EOS
 253         ;
 254             my %done_writer;
 255             foreach $writer (@writers) {
 256                 my ($writer_name) = $writer =~ m|([^/]+)\.wrt$|;
 257                 next if $done_writer{$writer_name}++;
 258                 my $output = 0;
 259                 # uncoverable branch true note:Assert I can open writers
 260                 open(WRITER, $writer) or die "Cannot open $writer";
 261                 while (<WRITER>) {
 262                     if ((/^=begin $mark/ .. /^=end $mark/) &&
 263                             ! /^=(begin|end) $mark/) {
 264                         if (! $output++) {
 265                             my $title =
 266                                 "Documentation for writer '$writer_name'";
 267                             print "\n$title\n",('-' x length($title)),"\n";
 268                         }
 269                         s/(\$\{[^\}]+\})/eval $1/ge;
 270                         print;
 271                     }
 272                 }
 273                 close WRITER;
 274             }
 275         }
 276     }
 277     else {
 278         # uncoverable statement note:Defensive programming
 279         print STDERR "Usage not available.\n";
 280     }
 281     exit (1);
 282 }