chiark / gitweb /
Big comment with syntax diagram thingy.
[ian-dotfiles.git] / 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 }