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 package GenericPrepTemplate;
  36
  37 #BEGIN {
  38 #    use Exporter ();
  39 #    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  40 #    $VERSION= 1.00;
  41 #    @ISA= qw(Exporter);
  42 #    @EXPORT= qw(&process_input);
  43 #    %EXPORT_TAGS= ();
  44 #    @EXPORT_OK= qw();
  45 #}
  46 #use vars @EXPORT_OK;
  47 #use vars qw($fh);
  48
  49 use IO::Handle;
  50 use IO::File;
  51
  52 open DEBUG, ">/dev/null" or die "gpt: /dev/null: $!\n";
  53
  54 while ($main::ARGV[0] =~ m/^-/) {
  55     $_= shift @main::ARGV;
  56     next if m/^--$/;
  57     while (m/^-./) {
  58         if (s/^-d/-/) {
  59             open DEBUG, ">&2" or die "gpt: debug to stderr: $!\n";
  60         } else {
  61             die "gpt: unknown option \`$_'\n";
  62         }
  63     }
  64 }
  65
  66 $fn= '<command line>';
  67 if (!@main::ARGV) {
  68     $lno= '<empty>';
  69     $fh= new IO::Handle;
  70     $fh->fdopen(fileno(STDIN),'r') or err("fdopen stdin: $!");
  71     process_fh($fh,'<standard input>');
  72     $fh->close or err("close stdin: $!\n");
  73 } else {
  74     for ($i=0; $i<@main::ARGV; $i++) {
  75         $lno= '<arg#'.($i+1).'>';
  76         process_file($main::ARGV[$i]);
  77     }
  78 }
  79 close STDOUT or die "gpt: close stdout: $!\n";
  80 exit 0;
  81
  82 sub process_file ($) {
  83     my ($value) = @_;
  84     $fh= new IO::File $value,'r' or err("cannot open file \`$value': $!");
  85     process_fh($fh,$value);
  86     $fh->close or err("gpt: cannot close file \`$value': $!");
  87 }
  88
  89 sub err ($) { die "gpt: $fn:$lno: $_[0]\n"; }
  90
  91 sub add_perl ($) {
  92     my ($str) = @_;
  93     if (@oplist>1) { $substr.= $str; }
  94     else { $expr.= $str; }
  95 }
  96
  97 sub add_text ($) {
  98     my ($str) = @_;
  99     if (@oplist) { $substr.=$str; }
 100     else { output($str); }
 101 }
 102
 103 sub eval_expr () {
 104     my ($value);
 105     $@='';
 106     print DEBUG "E $fn:$lno:e\`$expr'\n";
 107     $value= do {
 108         package main;
 109         eval $GenericPrepTemplate::expr;
 110     };
 111     if (length $@) {
 112         chomp $@; err("error: $@");
 113     }
 114     print DEBUG "E $fn:$lno:v\`$value'\n";
 115     $value;
 116 }
 117
 118 sub process_input () {
 119     my ($esc,$top,$want,$fh,$value,$wasyes);
 120     while (length $l) {
 121         print DEBUG "L $fn:${lno}_",join('',@oplist),
 122                     "_`$l' e\`$expr' s\`$substr'\n";
 123         if (@oplist & 1) { # scanning perl
 124             if ($l =~ m/^()\@\@/ || $l =~ m/([^\000])\@\@/) {
 125                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
 126                 add_perl($to);
 127                 if ($op =~ m/[ \t\n0-9a-zA-Z_\;\)\}?]/ || $op eq '') {
 128                     $top= pop @oplist;
 129                     if ($top eq '?') {
 130                         $op eq '?' or err("expected ?\@\@, got \@\@");
 131                     } else {
 132                         $op ne '?' or err("found ?\@\@ not after \@\@?");
 133                     }
 134                     if (!@oplist) {
 135                         # And evaluate.
 136                         $expr.= $op unless $op eq '?';
 137                         $value= eval_expr();
 138                         if ($top eq '<') {
 139                             process_file($value);
 140                         } elsif ($top eq '?') {
 141                             push @oplist, '?',':;'.!!$value;
 142                         } elsif ($top ne '-') {
 143                             output($value);
 144                         }
 145                         $expr='';
 146                     } else {
 147                         $substr.= $esc;
 148                     }
 149                 } elsif ($op =~ m/[\(\{]/) {
 150                     if (@oplist>1) { $substr.= $esc; }
 151                     push @oplist, $op;
 152                 } else {
 153                     err("bad escape sequence $op\@\@ in perl part");
 154                 }
 155             } else {
 156                 add_perl($l);
 157                 $l= '';
 158             }
 159         } else { # scanning text
 160             if ($l =~ m/\@\@(.|\n)/) {
 161                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
 162                 add_text($to);
 163                 if ($op =~ m/[-< \$?\n]/) {
 164                     if (!@oplist) {
 165                         add_perl($op) if $op =~ m/[\$]/;
 166                     } else {
 167                         $substr.= $esc;
 168                     }
 169                     push @oplist, $op;
 170                 } elsif ($op =~ m/[\)\}\;\:]/) {
 171                     err("unmatched closing \@\@$op") unless @oplist;
 172                     $want= pop @oplist;
 173                     if ($want =~ y/({/)}/) {
 174                         $wasyes=-1;
 175                         err("found \@\@$op but wanted \@\@$want")
 176                             unless $want eq $op;
 177                     } elsif ($want =~ m/^([:;]+)(1?)$/) {
 178                         ($want,$wasyes)=($1,$2);
 179                         err("found \@\@$op where not expected (wanted ".
 180                             join(' or ', map { "\@\@$_" } split //, $want).")")
 181                             unless $op =~ m/^[$want]$/;
 182                         '?' eq pop @oplist or die;
 183                         if ($wasyes) {
 184                             local ($l) = ($substr);
 185                             local ($substr,$expr,$to,$op);
 186                             process_input();
 187                         };
 188                         $substr='';
 189                         $esc='';
 190                         if ($op eq ':') {
 191                             push @oplist, '?',';'.!$wasyes;
 192                         }
 193                     } else {
 194                         die "internal /$want/ /$op/";
 195                     }
 196                     if (@oplist==1) {
 197                         # Just finished a substr.
 198                         $substri++;
 199                         $substrs[$substri]= $substr;
 200                         print DEBUG "S $fn:$lno:S$substri\`$substr'\n";
 201                         $expr.= ' GenericPrepTemplate::output(' if $op eq '}';
 202                         $expr.= " GenericPrepTemplate::process_i($substri) ";
 203                         $expr.= " );\n" if $op eq '}';
 204                         $substr='';
 205                     } else {
 206                         $substr.= $esc;
 207                     }
 208                 } elsif ($op eq '#') {
 209                     $l =~ s/^[^\n]*//; $l =~ s/^\n//;
 210                 } else {
 211                     err("bad escape sequence \@\@$op in text part");
 212                 }
 213             } else {
 214                 add_text($l);
 215                 $l= '';
 216             }
 217         }
 218     }
 219 }
 220
 221 sub close_nesteds () {
 222     my ($op);
 223     while (@oplist) {
 224         $op= $oplist[$#oplist];
 225         if (@oplist & 1) {
 226             err("unterminated \@\@?") if $op eq '?';
 227             $l=' @@';
 228         } else {
 229             if ($op =~ y/({/)}/) {
 230                 $l= '@@'.$op;
 231             } elsif ($op =~ m/^[;:]+/) {
 232                 $l= '@@;';
 233             } else {
 234                 die "intern /@oplist/";
 235             }
 236         }
 237         process_input();
 238     }
 239 }
 240
 241 sub process_fh ($$) {
 242     local ($fh,$fn) = @_;
 243     local ($l,$lno, @oplist,$substr,$expr,$to,$op);
 244
 245     while (defined ($l= $fh->getline)) {
 246         next if $l =~ m,^\#\! ?/\S+/gpt\b, && $.==1;
 247         $lno= $.;
 248         process_input();
 249     }
 250
 251     die "gpt: $fn: read error: $!" if $fh->error;
 252     close_nesteds();
 253 }
 254
 255 sub output ($) {
 256     if (defined $outbuf) {
 257         print DEBUG "O \`$outbuf'+\`$_[0]'\n";
 258         $outbuf.= $_[0];
 259     } else {
 260         print DEBUG "O w\`$_[0]'\n";
 261         print STDOUT $_[0] or err("write stdout: $!");
 262     }
 263 }
 264
 265 sub process_i ($) {
 266     my ($i) = @_;
 267     local ($l,$fn,$lno) = ($substrs[$i], "$fn<sub#$i>", '');
 268     local ($outbuf, @oplist,$substr,$expr,$to,$op);
 269     $outbuf='';
 270     process_input();
 271     close_nesteds();
 272     return $outbuf;
 273 }