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 => '//', end => '!>', f => \&_evaluate }, |
856
|
|
|
|
|
|
|
{begin => '', end => '!>', 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=>'%', end=>"!>\n", f=>\&_evaluate }, |
865
|
|
|
|
|
|
|
# change to this one? |
866
|
|
|
|
|
|
|
#{ht=>'be', begin=>'%', end=>"!>", f=>\&_evaluate }, |
867
|
|
|
|
|
|
|
{ht=>'be', begin=>'', end=>"!>\n", f=>\&_evaluate }, |
868
|
|
|
|
|
|
|
{ht=>'be', begin=>'', end=>"!>", 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 => '', end => '!>', 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/</g; |
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__ |