File Coverage

blib/lib/Text/Starfish.pm
Criterion Covered Total %
statement 39 942 4.1
branch 8 476 1.6
condition 0 72 0.0
subroutine 10 81 12.3
pod 31 60 51.6
total 88 1631 5.4


line stmt bran cond sub pod time code
1             # Starfish - Perl-based System for Preprocessing and Text-Embedded Programming
2             #
3             # (c) 2001-2020 Vlado Keselj http://web.cs.dal.ca/~vlado vlado@dnlp.ca
4             # and contributing authors
5             #
6             # See the documentation following the code. You can also use the
7             # command "perldoc Starfish.pm".
8              
9             package Text::Starfish;
10 1     1   813 use vars qw($NAME $ABSTRACT $VERSION); use strict;
  1     1   2  
  1         52  
  1         5  
  1         1  
  1         31  
11             $NAME = 'Text::Starfish';
12             $ABSTRACT = 'Perl-based System for Preprocessing and Text-Embedded Programming';
13             $VERSION = '1.38';
14              
15 1     1   404 use POSIX;
  1         5252  
  1         5  
16 1     1   2450 use Carp;
  1         2  
  1         61  
17 1     1   6 use Cwd qw(cwd);
  1         2  
  1         37  
18 1     1   5 use Exporter;
  1         2  
  1         35  
19 1     1   6 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); # Exporter vars
  1         1  
  1         104  
20              
21             @ISA = qw(Exporter);
22             %EXPORT_TAGS = ( 'all' => [qw(
23             add_hook appendfile echo file_modification_date
24             file_modification_time getfile getmakefilelist get_verbatim_file
25             getinclude htmlquote include
26             last_update putfile read_records read_starfish_conf rm_hook set_out_delimiters
27             sfish_add_tag sfish_ignore_outer starfish_cmd make_gen_dirs_to_generate
28             make_add_dirs_to_generate_if_needed
29             ) ] );
30             @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
31             @EXPORT = @{ $EXPORT_TAGS{'all'} };
32              
33             # Used in starfishing Makefiles
34 1     1   5 use vars qw(@DirGenerateIfNeeded);
  1         2  
  1         38  
35              
36             # non-exported package globals
37 1     1   5 use vars qw($GlobalREPLACE);
  1         2  
  1         9057  
38              
39             sub appendfile($@);
40             sub getfile($ );
41             sub getmakefilelist($$);
42             sub htmlquote($ );
43             sub putfile($@);
44             sub read_records($ );
45             sub starfish_cmd(@);
46              
47             sub new($@) {
48 0     0 1 0 my $proto = shift;
49 0   0     0 my $class = ref($proto) || $proto;
50 0         0 my $self = {};
51 0         0 bless($self, $class);
52              
53 0         0 $self->{Loops} = 1;
54 0         0 my $copyhooks = '';
55 0         0 foreach (@_) {
56 0 0       0 if (/^-infile=(.*)$/) { $self->{INFILE} = $1 }
  0 0       0  
57 0         0 elsif (/^-copyhooks$/) { $copyhooks = 1 }
58 0         0 else { _croak("unknown new option: $_") }
59             }
60              
61 0 0       0 if ($copyhooks) {
62 0 0       0 _croak("new: cannot copyhooks if Star is not there") unless
63             ref($::Star) eq 'Text::Starfish';
64 0         0 $self->{Style} = $::Star->{Style};
65 0         0 $self->{CodePreparation} = $::Star->{CodePreparation};
66 0         0 $self->{LineComment} = $::Star->{LineComment};
67 0         0 $self->{OutDelimiters} = $::Star->{OutDelimiters};
68 0         0 $self->{IgnoreOuter} = $::Star->{IgnoreOuter};
69 0         0 $self->{hook} = [ @{ $::Star->{hook} } ];
  0         0  
70             }
71              
72 0 0       0 $self->set_style() unless $copyhooks;
73              
74 0         0 return $self;
75             }
76              
77             sub starfish_cmd(@) {
78 0     0 1 0 my $sf = Text::Starfish->new();
79 0         0 my @tmp = ();
80 0         0 foreach (@_) {
81 0 0       0 if (/^-e=?/) { $sf->{INITIAL_CODE} = $' }
  0 0       0  
    0          
    0          
    0          
82 0         0 elsif (/^-mode=/) { $sf->{NEW_FILE_MODE} = $' }
83 0         0 elsif (/^-o=/) { $sf->{OUTFILE} = $' }
84 0         0 elsif (/^-replace$/) { $sf->{REPLACE} = $GlobalREPLACE = 1; }
85 0         0 elsif (/^-v$/) { print "$NAME, version $VERSION, $ABSTRACT\n"; exit 0; }
  0         0  
86 0         0 else { push @tmp, $_ }
87             }
88              
89 0 0 0     0 if (defined $sf->{NEW_FILE_MODE} and $sf->{NEW_FILE_MODE} =~ /^0/)
90 0         0 { $sf->{NEW_FILE_MODE} = oct($sf->{NEW_FILE_MODE}) }
91              
92 0         0 $sf->process_files(@tmp);
93 0         0 return $sf;
94             }
95              
96 0     0 1 0 sub include($@) { $::O .= getinclude(@_); return 1; }
  0         0  
97              
98             sub getinclude($@) {
99 0     0 1 0 my $sf = loadinclude(@_);
100 0 0       0 return '' unless defined $sf;
101 0         0 $sf->_digest();
102 0         0 return $sf->{Out};
103             }
104              
105             sub loadinclude($@) {
106 0     0 1 0 my $infile = '';
107 0         0 my @args = ();
108 0         0 my $replace = 1;
109 0         0 my $require = '';
110 0         0 foreach (@_) {
111 0 0 0     0 if (/^-replace$/) { $replace = 1 }
  0 0       0  
    0          
    0          
112 0         0 elsif (/^-noreplace$/) { $replace = '' }
113 0         0 elsif (/^-require$/) { $require = 1 }
114 0         0 elsif (!/^-/ && $infile eq '') { $infile = $_ }
115 0         0 else { push @args, $_ }
116             }
117              
118 0         0 my $sf = Text::Starfish->new("-infile=$infile", @args);
119 0         0 $sf->{REPLACE} = $replace;
120              
121 0 0 0     0 if ($sf->{INFILE} eq '' or ! -r $sf->{INFILE} ) {
122 0 0       0 if ($require) { _croak("cannot getinclude file: ($sf->{INFILE})") }
  0         0  
123 0         0 return undef;
124             }
125              
126 0         0 $sf->{data} = getfile $sf->{INFILE};
127 0         0 return $sf;
128             }
129              
130             sub process_files {
131 0     0 1 0 my $self = shift;
132 0         0 my @args = @_;
133              
134 0 0 0     0 if (defined $self->{REPLACE} and !defined $self->{OUTFILE})
135 0         0 { _croak("Starfish:output file required for replace") }
136              
137 0         0 my $FileCount=0;
138 0         0 $self->eval1($self->{INITIAL_CODE}, 'initial');
139              
140 0         0 while (@args) {
141 0         0 $self->{INFILE} = shift @args;
142 0         0 ++$FileCount;
143 0         0 $self->set_style();
144 0         0 $self->{data} = getfile $self->{INFILE};
145              
146             # *123* we need to forbid defining an outfile externally as well as
147             # internally:
148 0 0       0 my $outfileExternal = exists($self->{OUTFILE}) ? $self->{OUTFILE} : '';
149              
150 0         0 my $ExistingText = '';
151 0 0       0 if (! defined $self->{OUTFILE}) {
    0          
    0          
152 0         0 $ExistingText = $self->{data};
153 0         0 $self->{LastUpdateTime} = (stat $self->{INFILE})[9];
154             }
155             elsif ($FileCount > 1) {
156 0         0 $ExistingText = '';
157 0         0 $self->{LastUpdateTime} = time;
158             }
159             elsif (! -f $self->{OUTFILE}) {
160 0         0 $ExistingText = '';
161 0         0 $self->{LastUpdateTime} = time;
162             }
163             else {
164 0         0 $ExistingText = getfile $self->{OUTFILE};
165 0         0 $self->{LastUpdateTime} = (stat $self->{OUTFILE})[9];
166             }
167              
168 0         0 $self->_digest();
169              
170             # see *123* above
171 0 0 0     0 if ($outfileExternal ne '' and $outfileExternal ne $self->{OUTFILE})
172 0         0 { _croak("OUTFILE defined externally ($outfileExternal) and ".
173             "internally ($self->{OUTFILE})") }
174              
175 0         0 my $InFile = $self->{INFILE};
176 0 0 0     0 if ($FileCount==1 && defined $self->{OUTFILE}) {
177             # touch the outfile if it does not exist
178 0 0       0 if ( ! -f $self->{OUTFILE} ) {
    0          
179 0         0 putfile $self->{OUTFILE};
180 0         0 my $infile_mode = (stat $InFile)[2];
181 0 0       0 if (defined $self->{NEW_FILE_MODE}) {
182 0         0 chmod $self->{NEW_FILE_MODE}, $self->{OUTFILE}}
183 0         0 else { chmod $infile_mode, $self->{OUTFILE} }
184             }
185             elsif (defined $self->{NEW_FILE_MODE}) {
186 0         0 chmod $self->{NEW_FILE_MODE}, $self->{OUTFILE} }
187             }
188              
189             # write the text if changed
190 0 0       0 if ($ExistingText ne $self->{Out}) {
    0          
191 0 0       0 if (defined $self->{OUTFILE}) {
192             # If the OutFile is defined, we may have to play with
193             # permissions in order to write. Be careful! Allow
194             # unallowed write only on outfile and if -mode is
195             # specified
196 0         0 my $mode = ((stat $self->{OUTFILE})[2]);
197 0 0 0     0 if (($mode & 0200) == 0 and defined $self->{NEW_FILE_MODE}) {
198 0         0 chmod $mode|0200, $self->{OUTFILE};
199 0 0       0 if ($FileCount==1) { putfile $self->{OUTFILE}, $self->{Out} }
  0         0  
200 0         0 else { appendfile $self->{OUTFILE}, $self->{Out} }
201 0         0 chmod $mode, $self->{OUTFILE};
202             } else {
203 0 0       0 if ($FileCount==1) { putfile $self->{OUTFILE}, $self->{Out} }
  0         0  
204 0         0 else { appendfile $self->{OUTFILE}, $self->{Out} }
205             }
206             }
207             else {
208 0         0 putfile $InFile, $self->{Out};
209 0 0       0 chmod $self->{NEW_FILE_MODE}, $InFile if defined $self->{NEW_FILE_MODE};
210             }
211             }
212             elsif (defined $self->{NEW_FILE_MODE}) {
213 0 0       0 if (defined $self->{OUTFILE}) {
214 0         0 chmod $self->{NEW_FILE_MODE}, $self->{OUTFILE} }
215 0         0 else { chmod $self->{NEW_FILE_MODE}, $InFile }
216             }
217             } # end of while (@args)
218              
219             } # end of method process_files
220              
221             sub _digest {
222 0     0   0 my $self = shift;
223 0         0 $self->{CurrentLoop} = 1;
224 0         0 my $savedcontent = $self->{data};
225            
226             START: # The main scanning loop
227 0         0 $self->{Out} = '';
228 0         0 $self->_scan();
229 0         0 while ($self->{ttype} != -1) {
230 0 0       0 if ($self->{ttype} > -1) {
231 0         0 $self->{Out} .= $self->_eval_dispatch;
232             } # else $ttype < -1 (outer text)
233 0         0 else { $self->_process_outer( $self->{currenttoken} ) }
234 0         0 $self->_scan(); }
235            
236 0 0       0 if ($self->{CurrentLoop} < $self->{Loops}) {
237 0         0 ++$self->{CurrentLoop};
238 0 0       0 if ($self->{REPLACE}) { # in replace mode interate with
239 0         0 $self->{data} = $savedcontent; # original input
240 0         0 goto START; }
241 0         0 $self->{data} = $self->{Out};
242 0 0       0 if ($savedcontent ne $self->{Out})
243 0         0 { $self->{LastUpdateTime} = time }
244 0         0 putfile 'sfish.debug', $self->{data};
245 0         0 goto START; }
246              
247             # Final routines, if defined
248 0 0       0 if (defined($self->{Final})) {
249 0         0 my @a = @{ $self->{Final} };
  0         0  
250 0         0 local $::Star = $self;
251 0         0 for my $f (@a) {
252 0         0 $self->{Out} = &{$f}($self->{Out}); }}
  0         0  
253            
254             # Related to the macro concept (e.g. code folding)
255 0 0       0 if (defined $self->{macrosdefined}) {
256 0         0 my ($m, $s);
257 0         0 for $m (sort keys %{$self->{Macros}}) {
  0         0  
258 0         0 $s = $self->{Macros}->{$m};
259 0 0       0 if ($s =~ /\n/) {
260 0         0 my $p1 = "$`$&"; $s = $';
  0         0  
261 0 0       0 if ($s) { $s = $p1.wrap($s) }
  0         0  
262 0         0 else { $s = $p1 }
263             }
264 0         0 $self->{Out}.= $self->{MprefAuxDefine}.$s.$self->{MsufAuxDefine};
265             }
266             }
267             } # end of sub _digest
268              
269             # process outer text; by default, it should be appended to $self->{Out}
270             sub _process_outer {
271 0     0   0 my $self = shift; my $outer = shift;
  0         0  
272 0 0 0     0 if ($self->{REPLACE} && $self->{IgnoreOuter}) { }
273 0         0 else { $self->{Out} .= $outer }
274             # Comment: something should be done if IgnoreOuter is true and
275             # not in REPLACE mode; maybe comment-out outer text? (todo?)
276             }
277              
278             # _index($str,$substr) or _index($str, qr/../)
279             # returns index and length of found match, index==-1 for not found
280             # third argument is an optional offset
281             sub _index {
282 6     6   3953 my $str = shift; my $subs = shift; my $off = shift;
  6         9  
  6         7  
283 6 100       19 if (ref($subs) eq 'Regexp') {
    100          
284 3 100       7 if ($off < 1) {
285 1 50       7 if ($str =~ $subs) { return (length($`),length($&)) }
  1         14  
286 0         0 else { return (-1,0) }
287             } else {
288 2         12 pos($str) = $off;
289 2 50       15 if ($str =~ /$subs/g) { return (length($`),length($&)) }
  2         8  
290 0         0 else { return (-1,0) }
291             }
292             }
293 2         7 elsif ($off < 1) { return (index($str, $subs), length($subs)) }
294 1         4 else { return (index($str, $subs, $off), length($subs)) }
295             }
296              
297             # Scanning for the best hook match
298             sub _scan_for_hook_match {
299 0     0     my $self = shift;
300 0           $self->{prefix} = $self->{suffix} = '';
301 0           $self->{args} = [];
302            
303 0           my $i1 = length($self->{data}) + 1; # distance to starting anchor
304 0           my $i2 = $i1; # distance to ending anchor
305 0           my $pl=0; my $sl=0; # prefix and suffix lengths
  0            
306 0           $self->{ttype} = -2; # token type == hook id
307 0           foreach my $ttype (0 .. $#{ $self->{hook} }) {
  0            
308 0           my $hook = $self->{hook}->[$ttype];
309 0           my ($j, $pl2, $j2, $sl2); # current token under consideration,
310             # $j dist to candidate starting achor
311             # $j2 dist to candidate ending anchor
312             # pl2 and sl2 - lengths of prefix and suffix
313 0           my $ht = $hook->{ht};
314 0 0         if ($ht eq '') { # guessing hook type if not defined
315 0 0         if (exists($hook->{begin})) { $ht = $hook->{ht} = 'be' }
  0            
316 0           else { $ht = $hook->{ht} = 'regex' } }
317              
318 0 0         if ($ht eq 'string') {
    0          
    0          
    0          
319 0           ($j,$pl2) = _index($self->{data}, $hook->{s});
320 0 0 0       next unless $j != -1 && $j <= $i1;
321 0 0 0       next if $j==$i1 and $i2<=$j+$pl2;
322 0           $i1 = $j; $pl = $pl2; $self->{ttype} = $ttype; $self->{args} = [];
  0            
  0            
  0            
323 0           $i2 = $i1+$pl; $sl = 0;
  0            
324             } elsif ($ht eq 'be') {
325 0           ($j,$pl2) = _index($self->{data}, $hook->{'begin'});
326 0 0 0       next unless $j != -1 && $j <= $i1;
327 0 0         if ($hook->{'end'} ne '') {
328 0           ($j2, $sl2) = _index($self->{data}, $hook->{'end'}, $j);
329 0 0         next if -1 == $j2;
330 0           } else { $j2 = length($self->{data}) + 1; $sl2 = 0; }
  0            
331 0 0 0       next if ($j==$i1 and $i2<=$j2);
332 0           $i1 = $j; $pl = $pl2; $i2 = $j2; $sl = $sl2;
  0            
  0            
  0            
333 0           $self->{ttype} = $ttype; $self->{args} = [];
  0            
334             } elsif ($ht eq 'regex') {
335 0           my @args = ($self->{data} =~ /$hook->{regex}/m);
336 0 0         next unless @args;
337 0           my $j = length($`);
338 0 0         next unless $j < $i1;
339 0           $i1 = $j; $i2 = $i1+length($&); $sl=$pl=0;
  0            
  0            
340 0           unshift @args, $&; # could be removed
341 0           $self->{ttype} = $ttype;
342 0           $self->{args} = \@args;
343             } elsif ($ht eq 'ht:re2') {
344 0           my @args = ($self->{data} =~ /$hook->{regex}/m);
345 0 0         next unless @args;
346 0           my $j = length($`);
347 0 0         next unless $j < $i1;
348 0           $i1 = $j; $i2 = $i1+length($&); $sl=$pl=0;
  0            
  0            
349 0           unshift @args, $&; # full match is prepended to @args !?to remove?
350 0           $self->{ttype} = $ttype;
351 0           $self->{args} = \@args;
352 0           } else { _croak("Unknown hook type: ($ht)"); }
353             }
354 0           $self->{match_ij} = [$i1,$i2,$pl,$sl];
355             }
356              
357             # $self->{ttype}: -1 EOF
358             # -2 outer text (but also handled directly)
359             sub _scan {
360 0     0     my $self = shift;
361 0           $self->{prefix} = $self->{suffix} = ''; $self->{args} = [];
  0            
362 0 0         if ($self->{data} eq '') { # no more data, EOF
363 0           $self->{ttype} = -1; # ttype==-1 is EOF
364 0           $self->{currenttoken} = '';
365             }
366             else {
367 0           $self->_scan_for_hook_match();
368 0           my ($i1,$i2,$pl,$sl) = @{ $self->{match_ij} };
  0            
369 0 0         if ($self->{ttype}==-2) {
370 0           $self->{currenttoken}=$self->{data}; $self->{data}='' }
  0            
371             else { # live code
372             # just copy type -2
373             # instead of returning as earlier, to
374             # support negative look-back for prefix
375             # $self->{Out} .= substr($self->{data}, 0, $i1);
376 0           $self->_process_outer( substr($self->{data}, 0, $i1) );
377 0           $self->{prefix} = substr($self->{data}, $i1, $pl);
378 0           $self->{currenttoken} = substr($self->{data}, $i1+$pl, $i2-$i1-$pl);
379 0           $self->{suffix} = substr($self->{data}, $i2, $sl);
380 0           $self->{data} = substr($self->{data}, $i2+$sl);
381             # Remove old output if it is there:
382 0 0         if (defined($self->{OutDelimiters})) {
383 0           my ($b1,$b2,$e1,$e2) = @{ $self->{OutDelimiters} };
  0            
384 0 0         if ($self->{data} =~ /^\Q$b1\E(\d*)\Q$b2\E.*?\Q$e1\E\1\Q$e2\E/s) {
385 0           $self->{data} = $'; }
386             }
387             }
388             }
389 0           return $self->{ttype};
390             }
391              
392             # _eval_dispatch should decide how to properly call the evaluator, or just
393             # apply replacement. It should eventually be used for string-based evaluators.
394             sub _eval_dispatch {
395 0     0     my $self = shift;
396 0           my $hook = $self->{hook}->[$self->{ttype}]; #!!! hook evaluation
397 0           local $::Star = $self;
398 0           local $::O = '';
399 0 0         if ($hook->{ht} eq 'string') { $::O .= $hook->{replace}; #!!!
  0 0          
    0          
    0          
400             } elsif ($hook->{ht} eq 'regex') {
401 0           $::O .= &{ $hook->{replace} } ( $self, @{ $self->{args} } ); #!!!
  0            
  0            
402             } elsif ($hook->{ht} eq 'ht:re2') { #!!! python/make style eval
403             # evaluation function uses its own output
404             # wrap and attachement.
405 0           return &{$hook->{replace}}( $self, @{ $self->{args} } );
  0            
  0            
406 0           } elsif ( @{$self->{args}} ) { # guessing regex hook type
407 0           return &{$hook->{replace}}( $self, @{ $self->{args} } );
  0            
  0            
408             } else {
409 0           return &{$hook->{f}}
410 0           ( $self, $self->{prefix}, $self->{currenttoken}, $self->{suffix});
411             }
412              
413 0 0         return $::O if $self->{REPLACE};
414 0 0         return $self->{currenttoken} if $::O eq '';
415             return $self->{currenttoken}.
416 0           $self->_output_wrap( $::O );
417             }
418              
419             # eval wrapper for string code
420             sub eval1 {
421 0     0 0   my $self = shift;
422 0 0         my $code = shift; $code = '' unless defined $code;
  0            
423 0           my $comment = shift;
424 0           eval("package main; no strict; $code");
425 0 0         if ($@) {
426 0           my ($code1, $linecnt);
427 0           foreach (split(/\n/, $code))
428 0           { ++$linecnt; $code1 .= sprintf("%03d %s\n", $linecnt, $_); }
  0            
429 0           _croak("$comment code error:$@\ncode:\n$code1");
430             }
431             }
432              
433             # The main subroutine for evaluating a snippet of string
434             sub _evaluate {
435 0     0     my $self = shift;
436              
437 0           my $pref = shift;
438 0           my $code = shift; my $c = $code;
  0            
439 0           my $suf = shift;
440 0 0 0       if (defined($self->{CodePreparation}) && $self->{CodePreparation}) {
441 0           local $_=$code;
442 0           $self->eval1($self->{CodePreparation},'preprocessing');
443 0           $code = $_; }
444              
445             # Evaluate code, first final preparation and then eval1
446 0           local $::Star = $self;
447 0           local $::O = '';
448 0           $self->eval1($code, 'snippet');
449            
450 0 0         if ($self->{REPLACE}) { return $::O }
  0            
451 0 0         if ($::O ne '') { $suf.= $self->_output_wrap($::O); }
  0            
452 0           return "$pref$c$suf"; }
453              
454             # Wrap output with output delimiters
455             sub _output_wrap {
456 0     0     my $self = shift; my $out = shift; my @d = ("#","+\n","#","-");
  0            
  0            
457 0 0         @d = @{ $self->{OutDelimiters} } if defined( $self->{OutDelimiters} );
  0            
458 0           my ($b,$e) = ($d[0].$d[1], $d[2].$d[3]); my $i;
  0            
459 0 0         if (index($out, $e) != -1) {
460 0 0         while(1) { $i++; $e=$d[2].$i.$d[3]; last if index($out, $e)==-1;
  0            
  0            
  0            
461 0 0         _croak("Problem finding ending delimiter!\n(O=$out)") if $i > 1000000;}
462 0           $b = $d[0].$i.$d[1]; }
463 0           return $b.$out.$e; }
464              
465             # Python-specific evaluator (used also for makefile style)
466             # used with hook type ht:re2
467             sub evaluate_py1 { #!!!py
468 0     0 0   my $self = shift;
469 0           my $allmatch = shift; #!!!py maybe to remove it!?
470 0           my $indent = shift;
471 0           my $prefix = shift;
472 0           my $code = shift; my $c = $code;
  0            
473 0           my $oldout = shift; #!?to remove it
474              
475 0 0 0       if (defined($self->{CodePreparation}) && $self->{CodePreparation}) {
476 0           local $_=$code;
477 0           $self->eval1($self->{CodePreparation},'preprocessing');
478 0           $code = $_;
479             }
480              
481             # Evaluate code, first final preparation and then eval1
482 0           local $::O = '';
483 0           local $::Star = $self;
484 0           $self->eval1($code, 'snippet');
485              
486 0 0         if ($self->{REPLACE}) { return $indent.$::O }
  0 0          
487 0           elsif ($::O eq '') { return "$indent#$prefix$c!>" }
488             else {
489 0           $::O =~ s/^/$indent/gmx;
490 0           my $r;
491 0           my ($b,$e); my @d = @{ $self->{OutDelimiters} };
  0            
  0            
492 0           $b = $d[0].$d[1]; my $i; $e = $d[2].$d[3];
  0            
  0            
493 0 0         if (index($::O, $e) != -1) {
494 0 0         while(1) { $i++; $e=$d[2].$i.$d[3]; last if index($::O, $e)==-1;
  0            
  0            
  0            
495 0 0         _croak("Problem finding ending delimiter!\n(O=$::O)")
496             if $i > 1000000; }
497 0           $b = $d[0].$i.$d[1];
498             }
499 0           $r= "$indent#$prefix$c!>$b".$::O;
500 0           $r =~ s/\n?$/\n/; $r.="$indent$e"; # no extra \n
  0            
501             }
502             }
503              
504             # predefined evaluator: echo
505             sub eval_echo {
506 0     0 0   my $self = shift;
507 0           my $pref = shift;
508 0           my $cont = shift;
509 0           my $suff = shift;
510 0           $::O = $cont;
511              
512             # to update OutDelimiters
513 0 0         return $::O if $self->{REPLACE};
514 0 0         return $pref.$cont.$suff if $::O eq '';
515 0           $suff.=$self->_output_wrap($::O);
516 0           return $pref.$cont.$suff;
517             }
518              
519             # predefined evaluator: ignore
520             sub eval_ignore {
521 0     0 0   my $self = shift;
522 0 0         return '' if $self->{REPLACE};
523              
524 0           my $pref = shift;
525 0           my $code = shift;
526 0           my $suf = shift;
527 0           return $pref.$code.$suf;
528             }
529              
530             # predefined ignore evaluator for regex hooks
531             sub repl_comment {
532 0     0 0   my $self = shift;
533 0 0         if ($self->{REPLACE}) { return '' }
  0            
534 0           return $self->{currenttoken};
535             }
536              
537             sub define {
538 0     0 0   my $self = shift;
539              
540 0           my $pref = shift;
541 0           my $data = shift;
542 0           my $suf = shift;
543              
544 0 0         if ($self->{CurrentLoop} > 1) { return "$pref$data$suf"; }
  0            
545              
546 0 0         $data =~ /^.+/ or _croak("expected macro spec");
547 0 0         _croak("no macro spec") unless $&;
548 0 0         _croak("double macro def (forbidden):$&") if ($self->{ForbidMacro}->{$&});
549 0           $self->{Macros}->{$&} = $data;
550 0           return '';
551             }
552              
553             sub MCdefine {
554 0     0 0   my $self = shift;
555 0           my $pref = shift;
556 0           my $data = shift;
557 0           my $suf = shift;
558              
559 0 0         if ($self->{CurrentLoop} > 1) { die "define in loop > 1 !?" }
  0            
560              
561 0 0         $data =~ /^.+/ or die "expected macro spec";
562 0 0         die "no macro spec" unless $&;
563 0 0         die "double macro def (forbidden):$&" if ($self->{ForbidMacro}->{$&});
564 0           $self->{Macros}->{$&} = $data;
565 0           return '';
566             }
567              
568             sub MCdefe {
569 0     0 0   my $self = shift;
570 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
571              
572 0           my $pref = shift;
573 0           my $data = shift;
574 0           my $suf = shift;
575              
576 0 0         if ($self->{CurrentLoop} > 1) { die "defe in a loop >1!?" }
  0            
577              
578 0 0         $data =~ /^.+/ or die "expected macro spec";
579 0 0         die "no macro spec" unless $&;
580 0 0         die "def macro forbidden:$&\n" if (defined $self->{ForbidMacro}->{$&});
581 0           $self->{Macros}->{$&} = $data;
582 0           return $self->{MacroKey}->{'expand'}.$&.$self->{MacroKey}->{'/expand'};
583             }
584              
585             sub MCnewdefe {
586 0 0   0 0   my $self = shift; die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
  0            
587              
588 0           my $pref = shift;
589 0           my $data = shift;
590 0           my $suf = shift;
591              
592 0 0         if ($self->{CurrentLoop} > 1) { die "newdefe in second loop!?" }
  0            
593              
594 0 0         $data =~ /^.+/ or die "expected macro spec";
595 0 0         die "no macro spec" unless $&;
596 0 0 0       if (defined $self->{Macros}->{$&} || $self->{ForbidMacro}->{$&}) {
597 0           die "double def:$&" }
598 0           $self->{Macros}->{$&} = $data;
599 0           $self->{ForbidMacro}->{$&} = 1;
600 0           return $self->{MprefExpand}.$&.$self->{MsufExpand};
601             }
602              
603             sub expand {
604 0     0 0   my $self = shift;
605 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
606              
607 0           my $pref = shift;
608 0           my $data = shift;
609 0           my $suf = shift;
610              
611 0 0 0       if ($self->{CurrentLoop} < 2 || $self->{HideMacros})
612 0           { return $self->{MacroKey}->{'expand'}.$data.$self->{MacroKey}->{'/expand'} }
613            
614 0 0         $data =~ /^.+/ or die "expected macro spec";
615 0 0         die "no macro spec" unless $&;
616             return $self->{MacroKey}->{'expanded'}.$self->{Macros}->{$&}.
617 0           $self->{MacroKey}->{'/expanded'};
618             }
619              
620             sub MCexpand {
621 0     0 0   my $self = shift;
622 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
623              
624 0           my $pref = shift;
625 0           my $data = shift;
626 0           my $suf = shift;
627              
628 0 0 0       if ($self->{CurrentLoop} < 2 || $self->{HideMacros}) {
629 0           return "$pref$data$suf"; }
630            
631 0 0         $data =~ /^.+/ or die "expected macro spec";
632 0 0         die "no macro spec" unless $&;
633 0 0         die "macro not defined" unless defined $self->{Macros}->{$&};
634 0           return $self->{MprefExpanded}.$self->{Macros}->{$&}.$self->{MsufExpanded};
635             }
636              
637             sub fexpand {
638 0     0 0   my $self = shift;
639 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
640              
641 0           my $pref = shift;
642 0           my $data = shift;
643 0           my $suf = shift;
644              
645 0 0         if ($self->{CurrentLoop} < 2) { return "$pref$data$suf"; }
  0            
646            
647 0 0         $data =~ /^.+/ or die "expected macro spec";
648 0 0         die "no macro spec" unless $&;
649 0 0         die "macro not defined:$&" unless defined $self->{Macros}->{$&};
650 0           return $self->{MpreffExpanded} . $self->{Macros}->{$&}.$self->{MsuffExpanded};
651             }
652              
653             sub MCfexpand {
654 0     0 0   my $self = shift;
655 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
656              
657 0           my $pref = shift;
658 0           my $data = shift;
659 0           my $suf = shift;
660              
661 0 0         if ($self->{CurrentLoop} < 2) { return "$pref$data$suf"; }
  0            
662            
663 0 0         $data =~ /^.+/ or die "expected macro spec";
664 0 0         die "no macro spec" unless $&;
665 0 0         die "macro not defined:$&" unless defined $self->{Macros}->{$&};
666             return $self->{MacroKey}->{'fexpanded'}.$self->{Macros}->{$&}.
667 0           $self->{MacroKey}->{'/fexpanded'};
668             }
669              
670             sub expanded {
671 0     0 0   my $self = shift;
672 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
673              
674 0           my $pref = shift;
675 0           my $data = shift;
676 0           my $suf = shift;
677            
678 0 0         $data =~ /^.+/ or die "expected macro name";
679 0 0         die "no macro spec" unless $&;
680 0           return $self->{MprefExpand}.$&.$self->{MsufExpand};
681             }
682              
683             sub MCexpanded {
684 0     0 0   my $self = shift;
685 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
686              
687 0           my $pref = shift;
688 0           my $data = shift;
689 0           my $suf = shift;
690            
691 0 0         $data =~ /^.+/ or die "expected macro name";
692 0 0         die "no macro spec" unless $&;
693 0           return $self->{MacroKey}->{'expand'}.$&.$self->{MacroKey}->{'/expand'};
694             }
695              
696             sub fexpanded {
697 0     0 0   my $self = shift;
698 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
699              
700 0           my $pref = shift;
701 0           my $data = shift;
702 0           my $suf = shift;
703            
704 0 0         $data =~ /^.+/ or die "expected macro name";
705 0 0         die "no macro spec" unless $&;
706 0           return $self->{MpreffExpand}.$&.$self->{MsuffExpand};
707             }
708              
709             sub MCfexpanded {
710 0     0 0   my $self = shift;
711 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
712              
713 0           my $pref = shift;
714 0           my $data = shift;
715 0           my $suf = shift;
716            
717 0 0         if ($self->{CurrentLoop} < 2) { return "$pref$data$suf"; }
  0            
718 0 0         $data =~ /^.+/ or die "expected macro name";
719 0 0         die "no macro spec" unless $&;
720 0 0         die "Macro not defined:$&" unless defined $self->{Macros}->{$&};
721             return $self->{MacroKey}->{'fexpanded'}.$self->{Macros}->{$&}.
722 0           $self->{MacroKey}->{'/fexpanded'};
723             }
724              
725             sub MCauxdefine {
726 0     0 0   my $self = shift;
727 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
728              
729 0           my $pref = shift;
730 0           my $data = shift;
731 0           my $suf = shift;
732            
733 0 0         $data =~ /^.+/ or die "expected macro name";
734 0 0         die "no macro spec" unless $&;
735 0           my $mn = $&;
736 0           $data = unwrap($data);
737 0 0         die "double macro def (forbidden):$mn\n" if ($self->{ForbidMacro}->{$mn});
738 0 0         if (! defined($self->{Macros}->{$mn}) ) { $self->{Macros}->{$mn}=$data }
  0            
739 0           return '';
740             }
741              
742             sub auxDefine {
743 0     0 0   my $self = shift;
744 0 0         die "(".ref($self).")" unless ref($self) eq 'Text::Starfish';
745              
746 0           my $pref = shift;
747 0           my $data = shift;
748 0           my $suf = shift;
749            
750 0 0         $data =~ /^.+/ or die "expected macro name";
751 0 0         die "no macro spec" unless $&; my $mn = $&;
  0            
752 0           $data = unwrap($data);
753 0 0         die "double macro def (forbidden):$mn\n" if ($self->{ForbidMacro}->{$mn});
754 0 0         if (! defined($self->{Macros}->{$mn}) ) { $self->{Macros}->{$mn}=$data }
  0            
755 0           return '';
756             }
757              
758             sub wrap {
759 0     0 0   my $d = shift;
760 0           $d =~ s/^/\/\/ /mg;
761 0           return $d;
762             }
763              
764             sub unwrap {
765 0     0 0   my $d = shift;
766 0           $d =~ s/^\/\/ //mg;
767 0           return $d;
768             }
769              
770             sub setGlobStyle {
771 0     0 0   my $self = shift;
772 0           my $s = shift;
773 0           $self->{STYLE} = $s;
774 0           $self->set_style($s);
775             }
776              
777             sub clearStyle {
778 0     0 0   my $self = shift;
779 0           foreach my $k (qw(Style CodePreparation LineComment OutDelimiters
780             IgnoreOuter)) {
781 0           delete $self->{$k} }
782 0           $self->{hook} = [];
783             }
784              
785 0     0 1   sub setStyle { return &set_style }
786              
787             # List of fields typically set in set_style:
788             # $self->{Style} = string, style
789             # $self->{CodePreparation} = scalar
790             # $self->{LineComment} = string, line comment
791             # $self->{OutDelimiters} = [] eg: "//" "+\n" "//" "-\n"
792             # $self->{IgnoreOuter} = 1 or ''
793             # $self->{hook} = [], list of hooks
794             sub set_style {
795 0     0 1   my $self = shift;
796 0 0         if (ref($self) ne 'Text::Starfish') { unshift @_, $self; $self = $::Star; }
  0            
  0            
797              
798 0 0         if ($#_ == -1) {
799 0 0 0       if (defined $self->{STYLE} && $self->{STYLE} ne '')
800 0           { $self->set_style($self->{STYLE}) }
801             else {
802 0           my $f = $self->{INFILE};
803              
804 0 0         if ($f =~ /\.(html\.sfish|sf)$/i) { $self->set_style('html.sfish') }
  0            
805             else {
806 0           $f =~ s/\.s(tar)?fish$//;
807 0 0         if ($f =~ /\.html?/i) { $self->set_style('html') }
  0 0          
    0          
    0          
    0          
    0          
808 0           elsif ($f =~ /\.(?:la)?tex$/i) { $self->set_style('tex') }
809 0           elsif ($f =~ /\.java$/i) { $self->set_style('java') }
810 0           elsif ($f =~ /^[Mm]akefile/) { $self->set_style('makefile') }
811 0           elsif ($f =~ /\.ps$/i) { $self->set_style('ps') }
812 0           elsif ($f =~ /\.py$/i) { $self->set_style('python') }
813 0           else { $self->set_style('perl') }
814             }
815             }
816 0           return;
817             }
818              
819 0           my $s = shift;
820 0 0 0       if ($s eq 'latex' or $s eq 'TeX') { $s = 'tex' }
  0            
821 0 0 0       if (defined $self->{Style} and $s eq $self->{Style}) { return }
  0            
822            
823             # default
824 0           $self->clearStyle();
825 0           $self->{'LineComment'} = '#';
826 0           $self->{'IgnoreOuter'} = '';
827 0           $self->{OutDelimiters} = [ "#", "+\n", "#", "-" ];
828 0           $self->{CodePreparation} = 's/\\n(?:#|%|\/\/+)/\\n/g';
829 0           $self->{hook} = [];
830 0           $self->add_hook('be','#');
831 0           $self->add_hook('be','');
832 0           $self->add_hook('be','');
833              
834             #!!!py
835             # Used for Python and Makefile with &evaluate_py1
836             # matched with hook type ht:re2
837 0           my $re_py1 = qr/([\ \t]*)\#(\ *<\?)([\000-\377]*?)!>/x;
838             # extension below was a bug for ...#+...#-
839             # ([\ \t]*\#+\n[\000-\377]*?\n[\ \t]*\#-\n)?/x;
840              
841 0 0         if ($s eq 'perl') { }
    0          
    0          
    0          
    0          
    0          
    0          
    0          
842             elsif ($s eq 'makefile') {
843 0           $self->{CodePreparation} = 's/\\n\\s*#/\\n/g';
844 0           $self->{hook} = [ ];
845 0           $self->add_hook('ht:re2', $re_py1, \&evaluate_py1); #!!!
846             }
847             elsif ($s eq 'python') {
848 0           $self->{hook} = [ ];
849 0           $self->{CodePreparation} = 's/\\n\\s*#/\\n/g';
850 0           $self->add_hook('ht:re2', $re_py1, \&evaluate_py1); #!!!
851             }
852             elsif ($s eq 'java') {
853 0           $self->{LineComment} = '//';
854 0           $self->{OutDelimiters} = [ "//", "+\n", "//", "-" ];
855 0           $self->{hook} = [{begin => '// '!>', f => \&_evaluate },
856             {begin => ' '!>', f => \&_evaluate }];
857 0           $self->{CodePreparation} = 's/^\s*\/\/+//mg';
858             }
859             elsif ($s eq 'tex') {
860 0           $self->{LineComment} = '%';
861             # change OutDelimiters ?
862             # $self->{OutDelimiters} = [ "%", "+\n", "%", "-\n" ];
863 0           $self->{OutDelimiters} = [ "%", "+\n", "\n%", "-\n" ];
864 0           $self->{hook}=[{ht=>'be', begin=>'%"!>\n", f=>\&_evaluate },
865             # change to this one?
866             #{ht=>'be', begin=>'%"!>", f=>\&_evaluate },
867             {ht=>'be', begin=>'"!>\n", f=>\&_evaluate },
868             {ht=>'be', begin=>'"!>", f=>\&_evaluate }];
869              
870 0           $self->{CodePreparation} = 's/^[ \t]*%//mg';
871             }
872             elsif ($s eq 'html.sfish') {
873 0           undef $self->{LineComment};
874 0           $self->{OutDelimiters} = [ "", "" ];
875 0           $self->{CodePreparation} = '';
876 0           $self->{hook}=[];
877 0           $self->add_hook('be', '');
878 0           $self->add_hook('be', '');
879 0           $self->add_hook('be', qr/<\?sf\s/, qr/!>/);
880 0           $self->add_hook('regex', qr/^#.*\n/m, 'comment');
881             }
882             elsif ($s eq 'html') {
883 0           undef $self->{LineComment}; # Changes
884 0           $self->{OutDelimiters} = [ "", "" ];
885             $self->{hook}=[
886 0           {ht=>'be', begin => '', f => \&_evaluate },
887             {ht=>'be', begin=>''?>', f=>\&_evaluate } ];
888 0           $self->{CodePreparation} = '';
889             }
890             elsif ($s eq 'ps') {
891 0           $self->{LineComment} = '%';
892 0           $self->{OutDelimiters} = [ "% ", "+\n", "% ", "-" ];
893             $self->{hook}=[
894 0           {ht=>'be', begin => ' '!>', f => \&_evaluate }];
895 0           $self->{CodePreparation} = 's/\\n%/\\n/g';
896             }
897 0           else { _croak("set_style:unknown style:$s") }
898 0           $self->{Style} = $s;
899             }
900              
901             # to be deprecated? Used only to make it available in name space
902 0     0 1   sub sfish_add_tag($$) { $::Star->add_tag(@_) }
903 0     0 1   sub sfish_ignore_outer { $::Star->ignore_outer(@_) }
904              
905             # adds tags such as %slide:.* and % by adding appropriate hooks
906             # eg: add_tag('slide', 'ignore')
907             # eg: add_tag('sl,l', 'echo')
908             sub add_tag {
909 0     0 1   my $self = shift;
910 0 0         if (ref($self) ne 'Text::Starfish')
911 0           { unshift @_, $self; $self = $::Star; }
  0            
912 0           my $tag = shift; my $fun = shift;
  0            
913 0           my $lc = $self->{LineComment};
914             #die "tag=($tag) fun=($fun) ref(fun)=".ref($fun);
915 0 0         if (ref($fun) eq '') {
916 0 0   0     if ( $fun eq 'ignore') { $fun = sub{''} }
  0 0          
  0            
917 0     0     elsif ( $fun eq 'echo') { $fun = sub{$_[2]} }
  0            
918             }
919 0 0         my $lc1 = ($lc eq '') ? $lc : "$lc?"; #!!!
920 0           $self->add_hook('regex', qr/$lc1<$tag>\n?((?:.|\n)*?)$lc1<\/$tag>\n?/, $fun);
921 0           $self->add_hook('regex', qr/$lc$tag:(.*\n)/, $fun);
922             }
923              
924             sub ignore_outer {
925 0     0 1   my $self = shift;
926 0 0         if (ref($self) ne 'Text::Starfish')
927 0           { unshift @_, $self; $self = $::Star; }
  0            
928 0           my $newignoreouter = 1;
929 0 0         $newignoreouter = $_[1] if $#_ > 0;
930 0           $self->{IgnoreOuter} = $newignoreouter;
931             }
932              
933             sub set_out_delimiters {
934 0     0 0   my $self = shift;
935 0 0         if (ref($self) ne 'Text::Starfish')
936 0           { unshift @_, $self; $self = $::Star; }
  0            
937 0 0         _croak("OutDelimiters must be array of 4 elements:(@_)") if scalar(@_)!=4;
938 0           $self->{OutDelimiters} = [ $_[0], $_[1], $_[2], $_[3] ]; }
939              
940             # eg: add_hook('string','somestring','replacement')
941             # add_hook('be', '');
942             sub add_hook { #!!! adding hooks
943 0     0 1   my $self = shift;
944 0 0         if (ref($self) ne 'Text::Starfish')
945 0           { unshift @_, $self; $self = $::Star; }
  0            
946              
947 0           my $ht = shift;
948 0           my $hooks = $self->{hook}; my $hook = { ht=>$ht };
  0            
949 0 0         if ($ht eq 'string') {
    0          
    0          
    0          
950 0           my $s=shift; my $replace = shift;
  0            
951 0           $hook->{s} = $s; $hook->{replace} = $replace;
  0            
952 0           push @{$hooks}, $hook;
  0            
953             } elsif ($ht eq 'be') {
954 0           my $b = shift; my $e = shift; my $f='default';
  0            
  0            
955 0 0         if ($#_>-1) { $f = shift }
  0            
956 0           $hook->{begin} = $b; $hook->{end} = $e;
  0            
957 0 0         if ($f eq 'default') { $hook->{f} = \&_evaluate;
  0 0          
    0          
    0          
958 0           push @{$hooks}, $hook; return;
  0            
  0            
959 0           } elsif ($f eq 'ignore') { $hook->{f} = \&eval_ignore;
960 0           push @{$hooks}, $hook; return;
  0            
  0            
961 0           } elsif ($f eq 'echo') { $hook->{f} = \&eval_echo;
962 0           push @{$hooks}, $hook; return;
  0            
  0            
963             } elsif (ref($f) eq 'CODE') {
964 0     0     $hook->{f} = sub { local $_; my $self=shift;
  0            
965 0           my $p=shift; $_=shift; my $s=shift;
  0            
  0            
966 0           &$f($p,$_,$s);
967 0 0         if ($self->{REPLACE}) { return $_ }
  0            
968 0           return "$p$_$s";
969 0           };
970 0           push @{$hooks}, $hook; return;
  0            
  0            
971             } else {
972 0           $hook->{ht} = '';
973 0           eval("\$hook->{f} = sub {\n".
974             "local \$_;\n".
975             "my \$self = shift;\n".
976             "my \$p = shift; \$_ = shift; my \$s = shift;\n".
977             "$f;\n".
978             'if ($self->{REPLACE}) { return $_ }'."\n".
979             "return \"\$p\$_\$s\"; };");
980 0 0         _croak("add_hook error:$@") if $@;
981 0           push @{$hooks}, $hook; return;
  0            
  0            
982             }
983             } elsif ($ht eq 'regex') {
984 0           my $regex=shift; my $replace = shift;
  0            
985 0           $hook->{regex} = $regex;
986 0 0 0       if (ref($replace) eq '' && $replace eq 'comment')
    0          
987 0           { $hook->{replace} = \&repl_comment }
988             elsif (ref($replace) eq 'CODE')
989 0           { $hook->{replace} = $replace }
990 0           else { _croak("add_hook, undefined regex format input ".
991             "(TODO?): ref regex(".ref($regex).
992             "), ref replace(".ref($replace).")" ) }
993 0           push @{$hooks}, $hook;
  0            
994             } elsif ($ht eq 'ht:re2') {
995 0           my $regex=shift; my $replace=shift;
  0            
996 0 0         die unless ref($replace) eq 'CODE';
997 0           $hook->{regex} = $regex; $hook->{replace} = $replace;
  0            
998 0           push @{$hooks}, $hook;
  0            
999 0           } else { _croak("add_hook error, unknown hook type `$ht'") }
1000             }
1001              
1002             # addHook is deprecated. Use add_hook, which contains the hook type
1003             # as the second argument, after $self.
1004             sub addHook {
1005 0     0 1   my $self = shift;
1006 0 0 0       if ($#_ == 2) {
    0          
1007 0           $self->add_hook('be', @_); return;
  0            
1008             } elsif ($#_ == 1 and ref($_[0]) eq 'Regexp') {
1009 0           my $regex=shift; my $replace = shift;
  0            
1010 0           $self->add_hook('regex', $regex, $replace); return;
  0            
1011 0           } else { _croak("addHook parameter error") }}
1012              
1013             sub rm_hook {
1014 0     0 1   my $self = shift;
1015 0 0         if (ref($self) ne 'Text::Starfish')
1016 0           { unshift @_, $self; $self = $::Star; }
  0            
1017              
1018 0           my $ht = shift; # hook type: be (begin-end)
1019 0 0         if ($ht eq 'be') {
1020 0           my $b=shift; my $e=shift;
  0            
1021 0           my @Hooks = @{ $self->{hook} }; my @Hooks1;
  0            
  0            
1022 0           foreach my $h (@Hooks) {
1023 0 0 0       if ($h->{begin} eq $b and $h->{end} eq $e) {}
1024 0           else { push @Hooks1, $h }
1025             }
1026 0           $self->{hook} = \@Hooks1;
1027             } else {
1028 0           _croak("rm_hook not implemented for type ht=($ht)") }
1029             }
1030              
1031             # rmHook to be deprecated. Needs to be replaced with rm_hook
1032             sub rmHook {
1033 0     0 1   my $self = shift; my $p = shift; my $s = shift;
  0            
  0            
1034 0           $self->rm_hook('be', $p, $s); return; }
  0            
1035              
1036 0     0 1   sub rmAllHooks { my $self = shift; $self->{hook} = []; }
  0            
1037              
1038 0     0 0   sub resetHooks { my $self = shift; $self->rmAllHooks(); $self->set_style(); }
  0            
  0            
1039              
1040             sub add_final {
1041 0     0 1   my $self = shift;
1042 0 0         my $f = shift; die "$f not a function" unless ref($f) eq 'CODE';
  0            
1043 0 0         if (!defined($self->{Final})) { $self->{Final} = [] }
  0            
1044 0           push @{ $self->{Final} }, $f;
  0            
1045             }
1046              
1047             sub defineMacros {
1048 0     0 0   my $self = shift;
1049              
1050 0 0         return if $self->{CurrentLoop} > 1;
1051 0 0         $self->{Loops} = 2 if $self->{Loops} < 2;
1052 0           $self->{MprefDefine} = '//define ';
1053 0           $self->{MsufDefine} = "//enddefine\n";
1054 0           $self->{MprefExpand} = '//expand ';
1055 0           $self->{MsufExpand} = "\n";
1056 0           $self->{MacroKey}->{'expand'} = '//m!expand ';
1057 0           $self->{MacroKey}->{'/expand'} = "\n";
1058 0           $self->{MacroKey}->{'expanded'} = '//m!expanded ';
1059 0           $self->{MacroKey}->{'/expanded'} = "//m!end\n";
1060 0           $self->{MpreffExpand} = '//fexpand ';
1061 0           $self->{MsuffExpand} = "\n";
1062 0           $self->{MacroKey}->{'fexpand'} = '//m!fexpand ';
1063 0           $self->{MacroKey}->{'/fexpand'} = "\n";
1064 0           $self->{MprefExpanded} = '//expanded ';
1065 0           $self->{MsufExpanded} = "//endexpanded\n";
1066 0           $self->{MpreffExpanded} = '//fexpanded ';
1067 0           $self->{MsuffExpanded} = "//endexpanded\n";
1068 0           $self->{MacroKey}->{'fexpanded'} = '//m!fexpanded ';
1069 0           $self->{MacroKey}->{'/fexpanded'} = "//m!end\n";
1070 0           $self->{MprefAuxDefine}='//auxdefine ';
1071 0           $self->{MsufAuxDefine}="//endauxdefine\n";
1072 0           $self->{MacroKey}->{'auxdefine'}='//m!auxdefine ';
1073 0           $self->{MacroKey}->{'/auxdefine'}="//m!endauxdefine\n";
1074 0           $self->{MacroKey}->{'define'} = '//m!define ';
1075 0           $self->{MacroKey}->{'/define'} = "//m!end\n";
1076 0           $self->{MacroKey}->{'defe'} = '//m!defe ';
1077 0           $self->{MacroKey}->{'/defe'} = "//m!end\n";
1078 0           $self->{MacroKey}->{'newdefe'} = '//m!newdefe ';
1079 0           $self->{MacroKey}->{'/newdefe'} = "//m!end\n";
1080 0           push @{$self->{hook}}, #!!!
1081             {begin=>$self->{MprefDefine}, end=>$self->{MsufDefine}, f=>\&define},
1082             {begin=>$self->{MprefExpand}, end=>$self->{MsufExpand}, f=>\&expand},
1083             {begin=>$self->{MpreffExpand}, end=>$self->{MsuffExpand}, f=>\&fexpand},
1084             {begin=>$self->{MprefExpanded}, end=>$self->{MsufExpanded}, f=>\&expanded},
1085             {begin=>$self->{MpreffExpanded},
1086             end=>$self->{MsuffExpanded},f=>\&fexpanded},
1087             {begin=>$self->{MprefAuxDefine},
1088             end=>$self->{MsufAuxDefine},f=>\&auxDefine},
1089             {begin=>$self->{MacroKey}->{'auxdefine'},
1090             end=>$self->{MacroKey}->{'/auxdefine'},f=>\&MCauxdefine},
1091             {begin=>$self->{MacroKey}->{'define'},
1092             end=>$self->{MacroKey}->{'/define'}, f=>\&MCdefine},
1093             {begin=>$self->{MacroKey}->{'expand'},
1094             end=>$self->{MacroKey}->{'/expand'}, f=>\&MCexpand},
1095             {begin=>$self->{MacroKey}->{'fexpand'},
1096             end=>$self->{MacroKey}->{'/fexpand'}, f=>\&MCfexpand},
1097             {begin=>$self->{MacroKey}->{'expanded'},
1098             end=>$self->{MacroKey}->{'/expanded'},f=>\&MCexpanded},
1099             {begin=>$self->{MacroKey}->{'fexpanded'},
1100             end=>$self->{MacroKey}->{'/fexpanded'},f=>\&MCfexpanded},
1101             {begin=>$self->{MacroKey}->{'defe'},
1102             end=>$self->{MacroKey}->{'/defe'}, f=>\&MCdefe},
1103             {begin=>$self->{MacroKey}->{'newdefe'},
1104 0           end=>$self->{MacroKey}->{'/newdefe'}, f=>\&MCnewdefe};
1105 0           $self->{macrosdefined} = 1;
1106             }
1107              
1108             sub getmakefilelist ($$) {
1109 0     0 1   my $f = getfile($_[0]); shift;
  0            
1110 0           my $l = shift;
1111 0 0         $f =~ /\b$l=(.*(?:(?<=\\)\n.*)*)/ or
1112             die "starfish:getmakefilelist:no list:$l";
1113 0           $f=$1; $f=~s/\\\n/ /g;
  0            
1114 0           $f =~ s/^\s+//; $f =~ s/\s+$//;
  0            
1115 0           return split(/\s+/, $f);
1116             }
1117              
1118 0     0 1   sub echo(@) { $::O .= join('', @_) }
1119              
1120             # used in LaTeX mode to include verbatim textual files
1121             sub get_verbatim_file {
1122 0     0 1   my $f = shift;
1123 0           return "\\begin{verbatim}\n".
1124             untabify(scalar(getfile($f))).
1125             "\\end{verbatim}\n";
1126             }
1127              
1128             sub untabify {
1129 0     0 0   local $_ = shift;
1130 0           my ($r, $l);
1131 0           while (/[\t\n]/) {
1132 0 0         if ($& eq "\n") { $r.="$l$`\n"; $l=''; $_ = $'; }
  0            
  0            
  0            
1133             else {
1134 0           $l .= $`;
1135 0           $l .= ' ' x (8 - (length($l) & 7));
1136 0           $_ = $';
1137             }
1138             }
1139 0           return $r.$l.$_;
1140             }
1141              
1142             sub getfile($) {
1143 0     0 1   my $f = shift;
1144 0           local *F;
1145 0 0         open(F, "<$f") or die "starfish:getfile:cannot open $f:$!";
1146 0           my @r = ;
1147 0           close(F);
1148 0 0         return wantarray ? @r : join ('', @r);
1149             }
1150              
1151             sub putfile($@) {
1152 0     0 1   my $f = shift;
1153 0           local *F;
1154 0 0         open(F, ">$f") or die "starfish:putfile:cannot open $f:$!";
1155 0 0         print F '' unless @_;
1156 0           while (@_) { print F shift(@_) }
  0            
1157 0           close(F);
1158             }
1159              
1160             sub appendfile($@) {
1161 0     0 1   my $f = shift;
1162 0           local *F;
1163 0 0         open(F, ">>$f") or die "starfish:appendfile:cannot open $f:$!";
1164 0 0         print F '' unless @_;
1165 0           while (@_) { print F shift(@_) }
  0            
1166 0           close(F);
1167             }
1168              
1169             sub htmlquote($) {
1170 0     0 1   local $_ = shift;
1171 0           s/&/&/g;
1172 0           s/
1173 0           s/\"/"/g;
1174 0           return $_;
1175             }
1176              
1177             sub read_records($ ) {
1178 0     0 1   my $arg = shift;
1179 0 0         if ($arg =~ /^file=/) {
1180 0 0         my $f = $'; local *F; open(F, $f) or croak "cannot open $f:$!";
  0            
  0            
1181 0           $arg = join('', );
1182 0           close(F);
1183             }
1184              
1185 0           my $db = [];
1186 0           while ($arg) {
1187 0 0         if ($arg =~ /^([ \t\r]*(#.*)?\n)+/) { $arg = $'; }
  0            
1188 0 0         last if $arg eq ''; my $record;
  0            
1189 0 0         if ($arg =~ /([ \t\r]*\n){2,}/) { $record = "$`\n"; $arg = $'; }
  0            
  0            
1190 0           else { $record = $arg; $arg = ''; }
  0            
1191 0           my $r = {}; my $recordsave = $record;
  0            
1192 0           while ($record) {
1193 0 0         if ($record =~ /^[ \t]*#.*\n/) { $record=$'; next; } # allow
  0            
  0            
1194             # comments in records
1195 0 0         $record =~ /^[ \t]*([^\n:]*?)[ \t]*:/ or
1196             croak "db8: no attribute in record: ($recordsave)";
1197 0           my $k = $1; $record = $'; my $v;
  0            
  0            
1198 0 0         croak "empty key in ($recordsave)" if $k eq '';
1199 0           while (1) { # .................... line continuation
1200 0 0         if ($record =~ /^(.*?)\\(\r?\n)/) { $v .= $1.$2; $record = $'; }
  0 0          
  0 0          
1201 0           elsif ($record =~ /^.*?\r?\n[ \t]/) { $v .= $&; $record = $'; }
  0            
1202 0           elsif ($record =~ /^(.*?)\r?\n/) { $v .= $1; $record = $'; last; }
  0            
  0            
1203 0           else { $v .= $record; $record = ''; last }
  0            
  0            
1204             }
1205 0 0         if (exists($r->{$k})) {
1206 0           my $c = 0;
1207 0           while (exists($r->{"$k-$c"})) { ++$c }
  0            
1208 0           $k = "$k-$c";
1209             }
1210 0           $r->{$k} = $v;
1211             }
1212 0           push @{ $db }, $r;
  0            
1213             }
1214 0 0         return wantarray ? @{$db} : $db;
  0            
1215             }
1216              
1217 0     0 1   sub current_year { return POSIX::strftime("%Y", localtime(time)) }
1218              
1219             sub last_update() {
1220 0 0   0 1   my $self = @_ ? shift : $::Star;
1221 0 0         if ($self->{Loops} < 2) { $self->{Loops} = 2 }
  0            
1222 0           return POSIX::strftime("%d-%b-%Y", localtime($self->{LastUpdateTime}));
1223             }
1224              
1225             sub file_modification_time() {
1226 0 0   0 1   my $self = @_ ? shift : $::Star;
1227 0           return (stat $self->{INFILE})[9];
1228             }
1229              
1230             sub file_modification_date() {
1231 0 0   0 1   my $self = @_ ? shift : $::Star;
1232              
1233 0           my $t = $self->file_modification_time();
1234 0           my @a = localtime($t); $a[5] += 1900;
  0            
1235 0           return qw/January February March April May June July
1236             August September October November December/
1237             [$a[4]]." $a[3], $a[5]";
1238             }
1239              
1240             sub read_starfish_conf() {
1241 0 0   0 1   return unless -e "starfish.conf";
1242 0           my @dirs = ( '.' );
1243 0           while ( -e "$dirs[0]/../starfish.conf" )
1244 0           { unshift @dirs, "$dirs[0]/.." }
1245              
1246 0           my $currdir = cwd();
1247 0           foreach my $d (@dirs) {
1248 0 0         chdir $d or die "cannot chdir to $d";
1249             package main;
1250 0           require "$currdir/$d/starfish.conf";
1251             package Text::Starfish;
1252 0 0         chdir $currdir or die "cannot chdir to $currdir";
1253             }
1254             }
1255              
1256             sub _croak {
1257 0     0     my $m = shift;
1258 0           require Carp;
1259 0           Carp::croak($m);
1260             }
1261              
1262             # used in makefile mode
1263             #kw:makefile
1264             sub make_add_dirs_to_generate_if_needed {
1265 0     0 0   for my $d (@_) {
1266 0 0         next if grep { $_ eq $d } @DirGenerateIfNeeded;
  0            
1267 0           push @DirGenerateIfNeeded, $d;
1268             } }
1269             sub make_gen_dirs_to_generate {
1270 0     0 0   foreach my $d (@DirGenerateIfNeeded) {
1271 0           echo "$d:; mkdir -p \$\@\n" } }
1272              
1273             1;
1274              
1275             __END__