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 (!@oplist) {
 130                         # And evaluate.
 131                         $expr.= $op unless $op =~ m/[?]/;
 132                         $value= eval_expr();
 133                         if ($top eq '<') {
 134                             process_file($value);
 135                         } elsif ($top eq '?') {
 136                             push @oplist, '?',':;'.!!$value;
 137                         } elsif ($top ne '-') {
 138                             output($value);
 139                         }
 140                         $expr='';
 141                     } else {
 142                         $substr.= $esc;
 143                     }
 144                 } elsif ($op =~ m/[\(\{]/) {
 145                     if (@oplist>1) { $substr.= $esc; }
 146                     push @oplist, $op;
 147                 } else {
 148                     err("bad escape sequence $op\@\@ in perl part");
 149                 }
 150             } else {
 151                 add_perl($l);
 152                 $l= '';
 153             }
 154         } else { # scanning text
 155             if ($l =~ m/\@\@(.|\n)/) {
 156                 ($to,$op,$esc,$l) = ($`,$1,$&,$');
 157                 add_text($to);
 158                 if ($op =~ m/[-< \$?\n]/) {
 159                     if (!@oplist) {
 160                         add_perl($op) if $op =~ m/[\$]/;
 161                     } else {
 162                         $substr.= $esc;
 163                     }
 164                     push @oplist, $op;
 165                 } elsif ($op =~ m/[\)\}\;\:]/) {
 166                     err("unmatched closing \@\@$op") unless @oplist;
 167                     $want= pop @oplist;
 168                     if ($want =~ y/({/)}/) {
 169                         $wasyes=-1;
 170                         err("found \@\@$op but wanted \@\@$want")
 171                             unless $want eq $op;
 172                     } elsif ($want =~ m/^([:;]+)(1?)$/) {
 173                         ($want,$wasyes)=($1,$2);
 174                         err("found \@\@$op where not expected (wanted ".
 175                             join(' or ', map { "\@\@$_" } split //, $want).")")
 176                             unless $op =~ m/^[$want]$/;
 177                         '?' eq pop @oplist or die;
 178                         if ($wasyes) {
 179                             local ($l) = ($substr);
 180                             local ($substr,$expr,$to,$op);
 181                             process_input();
 182                         };
 183                         $substr='';
 184                         $esc='';
 185                         if ($op eq ':') {
 186                             push @oplist, '?',';'.!$wasyes;
 187                         }
 188                     } else {
 189                         die "internal /$want/ /$op/";
 190                     }
 191                     if (@oplist==1) {
 192                         # Just finished a substr.
 193                         $substri++;
 194                         $substrs[$substri]= $substr;
 195                         print DEBUG "S $fn:$lno:S$substri\`$substr'\n";
 196                         $expr.= ' GenericPrepTemplate::output(' if $op eq '}';
 197                         $expr.= " GenericPrepTemplate::process_i($substri) ";
 198                         $expr.= " );\n" if $op eq '}';
 199                         $substr='';
 200                     } else {
 201                         $substr.= $esc;
 202                     }
 203                 } elsif ($op eq '#') {
 204                     $l =~ s/^[^\n]*//; $l =~ s/^\n//;
 205                 } else {
 206                     err("bad escape sequence \@\@$op in text part");
 207                 }
 208             } else {
 209                 add_text($l);
 210                 $l= '';
 211             }
 212         }
 213     }
 214 }
 215
 216 sub close_nesteds () {
 217     my ($op);
 218     while (@oplist) {
 219         $op= $oplist[$#oplist];
 220         if (@oplist & 1) {
 221             err("unterminated \@\@?") if $op eq '?';
 222             $l=' @@';
 223         } else {
 224             if ($op =~ y/({/)}/) {
 225                 $l= '@@'.$op;
 226             } elsif ($op =~ m/^[;:]+/) {
 227                 $l= '@@;';
 228             } else {
 229                 die "intern /@oplist/";
 230             }
 231         }
 232         process_input();
 233     }
 234 }
 235
 236 sub process_fh ($$) {
 237     local ($fh,$fn) = @_;
 238     local ($l,$lno, @oplist,$substr,$expr,$to,$op);
 239
 240     while (defined ($l= $fh->getline)) {
 241         next if $l =~ m,^\#\! ?/\S+/gpt\b, && $.==1;
 242         $lno= $.;
 243         process_input();
 244     }
 245
 246     die "gpt: $fn: read error: $!" if $fh->error;
 247     close_nesteds();
 248 }
 249
 250 sub output ($) {
 251     if (defined $outbuf) {
 252         print DEBUG "O \`$outbuf'+\`$_[0]'\n";
 253         $outbuf.= $_[0];
 254     } else {
 255         print DEBUG "O w\`$_[0]'\n";
 256         print STDOUT $_[0] or err("write stdout: $!");
 257     }
 258 }
 259
 260 sub process_i ($) {
 261     my ($i) = @_;
 262     local ($l,$fn,$lno) = ($substrs[$i], "$fn<sub#$i>", '');
 263     local ($outbuf, @oplist,$substr,$expr,$to,$op);
 264     $outbuf='';
 265     process_input();
 266     close_nesteds();
 267     return $outbuf;
 268 }