gpt

   1 #!/usr/bin/perl
   2
   3 #
   4 #                          =====deeper=nesting===>>
   5 #
   6 #                     end of Perl fragment
   7 #                      \n@@ \_@@  ;@@ )@@ }@@  \w@@
   8 #                   <------------------------------------
   9 #
  10 #                   ------------------------------------>
  11 #                      if    eval    eval+     eval+
  12 #                       @@?   @@\_   ignore    include
  13 #                             @@$     @@-      file
  14 #    ___                      @@\n              @@<
  15 #  ,'   `
  16 #  |      processing                                       processing
  17 #  `--->  as TEXT                                          as PERL
  18 #  endif
  19 #   @@;     vA      <------------------------------------
  20 #           ||         then
  21 #   comment ||          ?@@
  22 #       @@# ||
  23 #           ||       included text fragment as
  24 #      else ||         string value    code to write out
  25 #       @@: ||          (@@             {@@
  26 #           ||      <------------------------------------
  27 #           `'
  28 #                   ------------------------------------>
  29 #                     end of included text fragment
  30 #                       @@)  @@}
  31 #
  32 #                          <<====deeper=nesting====
  33 #
  34
  35 # gpt - a generic preprocessing tool
  36 #
  37 #  This file is
  38 #    Copyright (C) 2001 Ian Jackson <ian@davenant.greenend.org.uk>
  39 #
  40 #  This program is free software; you can redistribute it and/or modify
  41 #  it under the terms of the GNU General Public License as published by
  42 #  the Free Software Foundation; either version 2, or (at your option)
  43 #  any later version.
  44 #
  45 #  This program is distributed in the hope that it will be useful,
  46 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  47 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  48 #  GNU General Public License for more details.
  49 #
  50 #  You should have received a copy of the GNU General Public License
  51 #  along with this program; if not, write to the Free Software Foundation,
  52 #  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  53
  54 package GenericPrepTemplate;
  55
  56 #BEGIN {
  57 #    use Exporter ();
  58 #    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  59 #    $VERSION= 1.00;
  60 #    @ISA= qw(Exporter);
  61 #    @EXPORT= qw(&process_input);
  62 #    %EXPORT_TAGS= ();
  63 #    @EXPORT_OK= qw();
  64 #}
  65 #use vars @EXPORT_OK;
  66 #use vars qw($fh);
  67
  68 use IO::Handle;
  69 use IO::File;
  70
  71 open DEBUG, ">/dev/null" or die "gpt: /dev/null: $!\n";
  72
  73 while ($main::ARGV[0] =~ m/^-/) {
  74     $_= shift @main::ARGV;
  75     next if m/^--$/;
  76     while (m/^-./) {
  77         if (s/^-d/-/) {
  78             open DEBUG, ">&2" or die "gpt: debug to stderr: $!\n";
  79         } else {
  80             die "gpt: unknown option \`$_'\n";
  81         }
  82     }
  83 }
  84
  85 $fn= '<command line>';
  86 if (!@main::ARGV) {
  87     $lno= '<empty>';
  88     $fh= new IO::Handle;
  89     $fh->fdopen(fileno(STDIN),'r') or err("fdopen stdin: $!");
  90     process_fh($fh,'<standard input>');
  91     $fh->close or err("close stdin: $!\n");
  92 } else {
  93     for ($i=0; $i<@main::ARGV; $i++) {
  94         $lno= '<arg#'.($i+1).'>';
  95         process_file($main::ARGV[$i]);
  96     }
  97 }
  98 close STDOUT or die "gpt: close stdout: $!\n";
  99 exit 0;
 100
 101 sub process_file ($) {
 102     my ($value) = @_;
 103     $fh= new IO::File $value,'r' or err("cannot open file \`$value': $!");
 104     process_fh($fh,$value);
 105     $fh->close or err("gpt: cannot close file \`$value': $!");
 106 }
 107
 108 sub err ($) { die "gpt: $fn:$lno: $_[0]\n"; }
 109
 110 sub add_perl ($) {
 111     my ($str) = @_;
 112     if (@oplist>1) { $substr.= $str; }
 113     else { $expr.= $str; }
 114 }
 115
 116 sub add_text ($) {
 117     my ($str) = @_;
 118     if (@oplist) { $substr.=$str; }
 119     else { output($str); }
 120 }
 121
 122 sub eval_expr () {
 123     my ($value);
 124     $@='';
 125     print DEBUG "E $fn:$lno:e\`$expr'\n";
 126     $value= do {
 127         package main;
 128         eval $GenericPrepTemplate::expr;
 129     };
 130     if (length $@) {
 131         chomp $@; err("error: $@");
 132     }
 133     print DEBUG "E $fn:$lno:v\`$value'\n";
 134     $value;
 135 }
 136
 137 sub process_input () {
 138     my ($esc,$top,$want,$fh,$value,$wasyes);
 139     while (length $l) {
 140         print DEBUG "L $fn:${lno}_",join('',@oplist),
 141                     "_`$l' e\`$expr' s\`$substr'\n";
 142         if (@oplist & 1) { # scanning perl
 143             if ($l =~ m/^()\@\@/ || $l =~ m/([^\000])\@\@/) {
 144                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
 145                 add_perl($to);
 146                 if ($op =~ m/[ \t\n0-9a-zA-Z_\;\)\}?]/ || $op eq '') {
 147                     $top= pop @oplist;
 148                     if ($top eq '?') {
 149                         $op eq '?' or err("expected ?\@\@, got \@\@");
 150                     } else {
 151                         $op ne '?' or err("found ?\@\@ not after \@\@?");
 152                     }
 153                     if (!@oplist) {
 154                         # And evaluate.
 155                         $expr.= $op unless $op eq '?';
 156                         $value= eval_expr();
 157                         if ($top eq '<') {
 158                             process_file($value);
 159                         } elsif ($top eq '?') {
 160                             push @oplist, '?',':;'.!!$value;
 161                         } elsif ($top ne '-') {
 162                             output($value);
 163                         }
 164                         $expr='';
 165                     } else {
 166                         $substr.= $esc;
 167                     }
 168                 } elsif ($op =~ m/[\(\{]/) {
 169                     if (@oplist>1) { $substr.= $esc; }
 170                     push @oplist, $op;
 171                 } else {
 172                     err("bad escape sequence $op\@\@ in perl part");
 173                 }
 174             } else {
 175                 add_perl($l);
 176                 $l= '';
 177             }
 178         } else { # scanning text
 179             if ($l =~ m/\@\@(.|\n)/) {
 180                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
 181                 add_text($to);
 182                 if ($op =~ m/[-< \$?\n]/) {
 183                     if (!@oplist) {
 184                         add_perl($op) if $op =~ m/[\$]/;
 185                     } else {
 186                         $substr.= $esc;
 187                     }
 188                     push @oplist, $op;
 189                 } elsif ($op =~ m/[\)\}\;\:]/) {
 190                     err("unmatched closing \@\@$op") unless @oplist;
 191                     $want= pop @oplist;
 192                     if ($want =~ y/({/)}/) {
 193                         $wasyes=-1;
 194                         err("found \@\@$op but wanted \@\@$want")
 195                             unless $want eq $op;
 196                     } elsif ($want =~ m/^([:;]+)(1?)$/) {
 197                         ($want,$wasyes)=($1,$2);
 198                         err("found \@\@$op where not expected (wanted ".
 199                             join(' or ', map { "\@\@$_" } split //, $want).")")
 200                             unless $op =~ m/^[$want]$/;
 201                         '?' eq pop @oplist or die;
 202                         if ($wasyes) {
 203                             local ($l) = ($substr);
 204                             local ($substr,$expr,$to,$op);
 205                             process_input();
 206                         };
 207                         $substr='';
 208                         $esc='';
 209                         if ($op eq ':') {
 210                             push @oplist, '?',';'.!$wasyes;
 211                         }
 212                     } else {
 213                         die "internal /$want/ /$op/";
 214                     }
 215                     if (@oplist==1) {
 216                         # Just finished a substr.
 217                         $substri++;
 218                         $substrs[$substri]= $substr;
 219                         print DEBUG "S $fn:$lno:S$substri\`$substr'\n";
 220                         $expr.= ' GenericPrepTemplate::output(' if $op eq '}';
 221                         $expr.= " GenericPrepTemplate::process_i($substri) ";
 222                         $expr.= " );\n" if $op eq '}';
 223                         $substr='';
 224                     } else {
 225                         $substr.= $esc;
 226                     }
 227                 } elsif ($op eq '#') {
 228                     $l =~ s/^[^\n]*//; $l =~ s/^\n//;
 229                 } else {
 230                     err("bad escape sequence \@\@$op in text part");
 231                 }
 232             } else {
 233                 add_text($l);
 234                 $l= '';
 235             }
 236         }
 237     }
 238 }
 239
 240 sub close_nesteds () {
 241     my ($op);
 242     while (@oplist) {
 243         $op= $oplist[$#oplist];
 244         if (@oplist & 1) {
 245             err("unterminated \@\@?") if $op eq '?';
 246             $l=' @@';
 247         } else {
 248             if ($op =~ y/({/)}/) {
 249                 $l= '@@'.$op;
 250             } elsif ($op =~ m/^[;:]+/) {
 251                 $l= '@@;';
 252             } else {
 253                 die "intern /@oplist/";
 254             }
 255         }
 256         process_input();
 257     }
 258 }
 259
 260 sub process_fh ($$) {
 261     local ($fh,$fn) = @_;
 262     local ($l,$lno, @oplist,$substr,$expr,$to,$op);
 263
 264     while (defined ($l= $fh->getline)) {
 265         next if $l =~ m,^\#\! ?/\S+/gpt\b, && $.==1;
 266         $lno= $.;
 267         process_input();
 268     }
 269
 270     die "gpt: $fn: read error: $!" if $fh->error;
 271     close_nesteds();
 272 }
 273
 274 sub output ($) {
 275     if (defined $outbuf) {
 276         print DEBUG "O \`$outbuf'+\`$_[0]'\n";
 277         $outbuf.= $_[0];
 278     } else {
 279         print DEBUG "O w\`$_[0]'\n";
 280         print STDOUT $_[0] or err("write stdout: $!");
 281     }
 282 }
 283
 284 sub process_i ($) {
 285     my ($i) = @_;
 286     local ($l,$fn,$lno) = ($substrs[$i], "$fn<sub#$i>", '');
 287     local ($outbuf, @oplist,$substr,$expr,$to,$op);
 288     $outbuf='';
 289     process_input();
 290     close_nesteds();
 291     return $outbuf;
 292 }