chiark / gitweb /
.gitignore emacs ian-local
[ian-dotfiles.git] / from-cvs / 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 }