0
|
1 |
#!/usr/bin/perl
|
|
2 |
#======================================================================
|
|
3 |
# A N T S U T I L S . P L
|
|
4 |
# doc: Fri Jun 19 23:25:50 1998
|
3
|
5 |
# dlm: Wed Oct 24 09:56:52 2012
|
0
|
6 |
# (c) 1998 A.M. Thurnherr
|
3
|
7 |
# uE-Info: 259 43 NIL 0 0 70 10 2 4 NIL ofnI
|
0
|
8 |
#======================================================================
|
|
9 |
|
|
10 |
# Miscellaneous auxillary functions
|
|
11 |
|
|
12 |
# HISTORY:
|
|
13 |
# Mar 08, 1999: - added &antsFunUsage()
|
|
14 |
# Mar 20, 1999: - added &fnr()
|
|
15 |
# - BUG &numberp() returned TRUE on "sigma2"
|
|
16 |
# Mar 21, 1999: - added semantics of &antsFunUsage() to specify min
|
|
17 |
# args on negative number
|
|
18 |
# Mar 22, 1999: - added round(); NB: there's a BUG:
|
|
19 |
# int(2.155*10**2+0.5)/100 returns 215!!!
|
|
20 |
# Jul 31, 1999: - added &cardinalp() and plugged into &fnr()
|
|
21 |
# - change &numberp() to conform with &antsFloatArg()
|
|
22 |
# Sep 13, 1999: - added &SQR()
|
|
23 |
# - removed "" from valid numbers
|
|
24 |
# Sep 18, 1999: - added &integerp()
|
|
25 |
# - added typechecking to &antsFunUsage()
|
|
26 |
# Sep 20, 1999: - cosmetics
|
|
27 |
# Aug 24, 2000: - added #include directive to Description files
|
|
28 |
# - added stringlengths to &antsFunUsage()
|
|
29 |
# Aug 28, 2000: - added str2num to remove leading 0es & lead/trail spcs
|
|
30 |
# - changed opt_P to opt_A
|
|
31 |
# Aug 29, 2000: - added &antsRequireParam()
|
|
32 |
# Sep 01, 2000: - added prefix as 2nd arg to #include directive
|
|
33 |
# - disallow <> in #include directive
|
|
34 |
# - debugged &str2num()
|
|
35 |
# Sep 03, 2000: - allowed for %param to pass through fnr w/o error check
|
|
36 |
# Sep 05, 2000: - str2num always kills leading/trailing spaces
|
|
37 |
# Sep 19, 2000: - added interpretation to ./ to #include
|
|
38 |
# - inherit prefix for chained inclusion (do not chain, however)
|
|
39 |
# Nov 25, 2000: - backslashed leading + in regexp to increase portability
|
|
40 |
# May 29, 2001: - adapted &antsNumbers() to handle %PARAMs
|
|
41 |
# - added &antsVal()
|
|
42 |
# Jul 6, 2001: - added degree notation to str2num()
|
|
43 |
# Jul 12, 2001: - made $# notation 1-relative (awk, shell)
|
|
44 |
# Jul 15, 2001: - added field name to Description open error
|
|
45 |
# Jul 16, 2001: - added &localFnr()
|
|
46 |
# Jul 19, 2001: - added &croak()
|
|
47 |
# Aug 1, 2001: - BUG: numberp() returned false on "-.360"
|
|
48 |
# May 7, 2002: - BUG: numberp() returned true on "."
|
|
49 |
# Mar 8, 2003: - changed Description to Layout
|
|
50 |
# Dec 7, 2005: - antsFName -> antsLayout (not tested)
|
|
51 |
# Dec 8, 2005: - Version 3.2 (see [HISTORY])
|
|
52 |
# Dec 12, 2005: - BUG: &outFnr() was broken
|
|
53 |
# - BUG: [Layout] overrode local #FIELDS#
|
|
54 |
# Dec 23, 2005: - replaced defined(@array) (c.f. perlfunc(1))
|
|
55 |
# Jan 2, 2006: - changed numberp to allow for multiple args
|
|
56 |
# - changed right back
|
|
57 |
# Jan 9, 2006: - BUG: fnrNoErr() had not increased $antsBufNFields on
|
|
58 |
# import of an externally defined field
|
|
59 |
# Jan 10, 2006: - added &antsLoadModel()
|
|
60 |
# Jan 12, 2006: - removed -A support
|
|
61 |
# Jan 13: 2006: - BUG: str2num(3.00) did not yield 3
|
|
62 |
# Jul 1, 2006: - added isNaN (from perlfunc(1))
|
|
63 |
# - changed numberp() according to perldata(1)
|
|
64 |
# Jul 24, 2006: - added $PRACTICALLY_ZERO, &equal()
|
|
65 |
# Aug 23, 2006: - improved model loading (& added model w. params)
|
|
66 |
# Aug 24, 2006: - made 2nd argument of round() optional
|
|
67 |
# - added frac()
|
|
68 |
# May 11, 2007: - added Floor(), Ceil()
|
|
69 |
# Oct 17, 2007: - added default field names (w. caching) to &antsFunUsage()
|
|
70 |
# Oct 18, 2007: - added support for optional parameters
|
|
71 |
# Oct 19, 2007: - generalized antsFunUsage to allow default %PARAMs
|
|
72 |
# - BUG: make sure usage is printed in abc when called with
|
|
73 |
# wrong # of args
|
|
74 |
# Nov 14, 2007: - made optional arguments to round, Floor, Ceil more intuitive
|
|
75 |
# Dec 19, 2007: - added &numbersp()
|
|
76 |
# Mar 2, 2008: - adapted fnr to partial matches
|
|
77 |
# Mar 4, 2008: - added $antsFnrExactMatch flag
|
|
78 |
# - BUG: couldn't select f1 if there is also an f10
|
|
79 |
# Mar 26, 2008: - BUG: abbreviated field names were imported from external
|
|
80 |
# Layout
|
|
81 |
# Mar 27, 2008: - added %pi
|
|
82 |
# Mar 28, 2008: - move %pi to [argtest]; when set here filediff -e bombs
|
|
83 |
# Apr 15, 2008: - added &log10()
|
|
84 |
# Apr 16, 2008: - MAJOR CHANGE: suppress croak() STDOUT error output on -Q
|
|
85 |
# Apr 29, 2008: - added &ismember()
|
|
86 |
# Jun 11, 2008: - adder perl 5.8.8 bug workaround (0*-0.1 = -0)
|
|
87 |
# Nov 12, 2008: - added opt_T
|
|
88 |
# Mar 21, 2009: - added debug()
|
|
89 |
# Nov 17, 2009: - added listAllRecs flag for list(1)
|
|
90 |
# May 12, 2010: - BUG: round() did not work correctly for -ve numbers
|
|
91 |
# May 21, 2011: - added support for $antsFnrNegative
|
|
92 |
# Nov 11, 2011: - added exact flag to fnrNoErr()
|
|
93 |
# Feb 13, 2012: - BUG: failure to specify exact flag resulted in ignoring antsFnrExactMatch
|
|
94 |
# - BUG: fnrNoErr disregarded exact flag for external layouts
|
1
|
95 |
# May 16, 2012: - adapted to V5.0
|
|
96 |
# May 31, 2012: - changed ismember() semantics for use in psSamp
|
3
|
97 |
# Jun 12, 2012: - added &compactList()
|
0
|
98 |
|
|
99 |
# fnr notes:
|
|
100 |
# - matches field names starting with the string given, i.e. "sig" is
|
|
101 |
# really "^sig"
|
|
102 |
# - if exact match is desired, a $ can be appended to the field name
|
|
103 |
# - following regexp meta chars are auto-quoted: .
|
|
104 |
|
|
105 |
#----------------------------------------------------------------------
|
|
106 |
# Flags
|
|
107 |
#----------------------------------------------------------------------
|
|
108 |
|
|
109 |
$antsFnrExactMatch = 0; # set to force exact match, e.g. for antsNewField* [antsutils.pl]
|
|
110 |
$antsFnrNegativeOk = 0; # set to allow, e.g., $-1 in [list]
|
|
111 |
|
|
112 |
#----------------------------------------------------------------------
|
|
113 |
# Error-Exit
|
|
114 |
#----------------------------------------------------------------------
|
|
115 |
|
|
116 |
sub croak($)
|
|
117 |
{
|
|
118 |
print("#ANTS#ERROR# @_[0]") unless (-t 1 || $opt_Q);
|
|
119 |
die(@_[0]);
|
|
120 |
}
|
|
121 |
|
|
122 |
#----------------------------------------------------------------------
|
|
123 |
# Number-related funs
|
|
124 |
#----------------------------------------------------------------------
|
|
125 |
|
|
126 |
$PRACTICALLY_ZERO = 1e-9;
|
|
127 |
$SMALL_AMOUNT = 1e-6;
|
|
128 |
|
|
129 |
sub numberp(@)
|
|
130 |
{ return $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; }
|
|
131 |
|
|
132 |
sub numbersp(@)
|
|
133 |
{
|
|
134 |
foreach my $n (@_) {
|
|
135 |
return undef unless numberp($n);
|
|
136 |
}
|
|
137 |
return 1;
|
|
138 |
}
|
|
139 |
|
|
140 |
sub equal($$)
|
|
141 |
{ return (@_ >= 2) && (abs($_[0]-$_[1]) < $PRACTICALLY_ZERO); }
|
|
142 |
|
1
|
143 |
#----------------------------------------------------------------------
|
0
|
144 |
# check whether given val is member of a set
|
1
|
145 |
# - set can either be an array or a comma-separated string
|
|
146 |
#----------------------------------------------------------------------
|
|
147 |
|
0
|
148 |
sub ismember($@)
|
|
149 |
{
|
|
150 |
my($val,@set) = @_;
|
1
|
151 |
@set = split(',',$set[0])
|
|
152 |
if (@set == 1 && !numberp($set[0]));
|
0
|
153 |
for (my($i)=0; $i<@set; $i++) {
|
1
|
154 |
if (numberp($val) && numberp($set[$i])) {
|
|
155 |
return 1 if ($val == $set[$i]);
|
|
156 |
} else {
|
|
157 |
return 1 if ($val eq $set[$i]);
|
|
158 |
}
|
0
|
159 |
}
|
|
160 |
return undef;
|
|
161 |
}
|
|
162 |
|
|
163 |
sub isnan($) # perlfunc(1)
|
|
164 |
{ return $_[0] != $_[0]; }
|
|
165 |
|
|
166 |
sub cardinalp($)
|
|
167 |
{ return $_[0] =~ /^\+?\d+$/; }
|
|
168 |
|
|
169 |
sub integerp($)
|
|
170 |
{ return $_[0] =~ /^[+-]?\d+$/; }
|
|
171 |
|
|
172 |
sub antsNumbers(@)
|
|
173 |
{
|
|
174 |
my($n);
|
|
175 |
foreach $n (@_) {
|
|
176 |
return 0 unless (&numberp(&antsVal($n)));
|
|
177 |
}
|
|
178 |
return 1;
|
|
179 |
}
|
|
180 |
|
|
181 |
sub round(@)
|
|
182 |
{
|
|
183 |
my($accuracy) = defined($_[1]) ? $_[1] : 1;
|
|
184 |
return $_[0] >= 0 ? int($_[0] / $accuracy + 0.5) * $accuracy
|
|
185 |
: int($_[0] / $accuracy - 0.5) * $accuracy;
|
|
186 |
}
|
|
187 |
|
|
188 |
sub Ceil(@)
|
|
189 |
{
|
|
190 |
my($accuracy) = defined($_[1]) ? $_[1] : 1;
|
|
191 |
return int($_[0]/$accuracy + 1 - $PRACTICALLY_ZERO) * $accuracy;
|
|
192 |
}
|
|
193 |
|
|
194 |
sub Floor(@)
|
|
195 |
{
|
|
196 |
my($accuracy) = defined($_[1]) ? $_[1] : 1;
|
|
197 |
return int($_[0]/$accuracy) * $accuracy;
|
|
198 |
}
|
|
199 |
|
|
200 |
sub frac($) { return $_[0] - int($_[0]); }
|
|
201 |
|
|
202 |
sub SQR($) { return $_[0] * $_[0]; }
|
|
203 |
|
|
204 |
sub str2num($)
|
|
205 |
{
|
|
206 |
my($num) = @_;
|
|
207 |
$num =~ s/^\s*//; # kill leading spaces
|
|
208 |
$num =~ s/\s*$//; # kill trailing spaces
|
|
209 |
$num = (substr($1,0,1) eq '-') ? $1-$2/60 : $1+$2/60 # degrees
|
|
210 |
if ($num =~ /^([+-]?\d*):(\d*\.?\d*)$/);
|
|
211 |
return $num unless (numberp($num));
|
|
212 |
$num =~ s/^(-?)0*/\1/; # kill leading 0es
|
|
213 |
$num =~ s/(\.\d*[1-9])0*$/\1/; # kill trailing fractional 0es
|
|
214 |
$num =~ s/^\./0./; # ensure digit before decimal pnt
|
|
215 |
$num =~ s/^-\./-0./; # ditto
|
|
216 |
$num =~ s/\.$/.0/; # ensure digit after decimal pnt
|
|
217 |
$num =~ s/^-0(\.0?)$/0/; # 0 is positive
|
|
218 |
$num =~ s/\.0+$//; # kill trailing fractional 0es
|
|
219 |
return ($num eq "") ? 0 : $num;
|
|
220 |
}
|
|
221 |
|
|
222 |
sub fmtNum($$) # format number for output
|
|
223 |
{
|
|
224 |
my($num,$fname) = @_;
|
|
225 |
|
|
226 |
$num = 0 if ($num eq '-0'); # perl 5.8.8: 0*-0.1 = -0, which is
|
|
227 |
# not handled correctly by all progs
|
|
228 |
$num = str2num($num) if ($opt_C);
|
|
229 |
if ($opt_G && numberp($num)) {
|
|
230 |
$num = sprintf("%d:%04.1f%s",
|
|
231 |
abs(int($num)),
|
|
232 |
(abs($num)-abs(int($num)))*60,
|
|
233 |
$num>=0 ? "N" : "S")
|
|
234 |
if (lc($fname) =~ /lat/);
|
|
235 |
$num = sprintf("%d:%04.1f%s",
|
|
236 |
abs(int($num)),
|
|
237 |
(abs($num)-abs(int($num)))*60,
|
|
238 |
$num>=0 ? "E" : "W")
|
|
239 |
if (lc($fname) =~ /lon/);
|
|
240 |
}
|
|
241 |
if ($opt_T && numberp($num)) {
|
|
242 |
$num = sprintf("\\lat%s{%d}{%04.1f}",
|
|
243 |
$num>=0 ? "N" : "S",
|
|
244 |
abs(int($num)),
|
|
245 |
(abs($num)-abs(int($num)))*60)
|
|
246 |
if (lc($fname) =~ /lat/);
|
|
247 |
$num = sprintf("\\lon%s{%d}{%04.1f}",
|
|
248 |
$num>=0 ? "E" : "W",
|
|
249 |
abs(int($num)),
|
|
250 |
(abs($num)-abs(int($num)))*60)
|
|
251 |
if (lc($fname) =~ /lon/);
|
|
252 |
}
|
|
253 |
$num = sprintf($opt_M,$num)
|
|
254 |
if defined($opt_M) && numberp($num);
|
|
255 |
|
|
256 |
return $num;
|
|
257 |
}
|
|
258 |
|
3
|
259 |
sub log10 { my $n = shift; return ($n>0) ? log($n)/log(10) : nan; } # c.v. perlfunc(1)
|
0
|
260 |
|
|
261 |
|
|
262 |
#----------------------------------------------------------------------
|
|
263 |
# Layout-related funs
|
|
264 |
#----------------------------------------------------------------------
|
|
265 |
|
|
266 |
sub fname_match($$) # modified regexp match
|
|
267 |
{
|
|
268 |
my($pat,$trg) = @_;
|
|
269 |
return ($pat eq $trg) if ($antsFnrExactMatch); # exact match (pre 3.4 behavior)
|
|
270 |
# print(STDERR "pattern: $pat -> ");
|
|
271 |
$pat =~ s/\./\\\./g; # may want more of these
|
|
272 |
$pat =~ s/^/\^/;
|
|
273 |
# print(STDERR "$pat\n");
|
|
274 |
return $trg =~ /$pat/;
|
|
275 |
}
|
|
276 |
|
|
277 |
sub fnrInFile(...)
|
|
278 |
{
|
|
279 |
my($fname,$file,$pref,$found) = @_;
|
|
280 |
my($fullName);
|
|
281 |
local(*D);
|
|
282 |
open(D,$file) || return (undef,$fname);
|
|
283 |
while (<D>) {
|
|
284 |
s/\s\b/ $pref/g if m/^#\d+/;
|
|
285 |
my(@fn) = split;
|
|
286 |
if (/^#\s*include\s*([^\s]+)\s*([^\s]+)?/) {
|
|
287 |
my($npref) = ($2 eq "") ? $pref : $2;
|
|
288 |
if (substr($1,0,2) eq "./") {
|
|
289 |
my($dirname) = $file;
|
|
290 |
$file = $1;
|
|
291 |
$dirname =~ s@[^/]+$@@;
|
|
292 |
$file = $dirname . $file;
|
|
293 |
} else {
|
|
294 |
$file = $1;
|
|
295 |
}
|
|
296 |
($found,$fullName) = &fnrInFile($fname,$file,$npref,$found);
|
|
297 |
}
|
|
298 |
next unless ($fn[0] =~ /^#\d+$/);
|
|
299 |
for (my($i)=1; $i<=$#fn; $i++) {
|
|
300 |
close(D),return ($1,$fname)
|
|
301 |
if (/^#(\d+)\b.*\b$fname\b/);
|
|
302 |
}
|
|
303 |
for (my($i)=1; $i<=$#fn; $i++) {
|
|
304 |
next unless fname_match($fname,$fn[$i]);
|
|
305 |
croak("$0: $fname matches multiple fields in Layout files\n")
|
|
306 |
if defined($found);
|
|
307 |
$fullName = $fn[$i];
|
|
308 |
($found) = ($fn[0] =~ /^#(\d+)/);
|
|
309 |
}
|
|
310 |
}
|
|
311 |
close(D);
|
|
312 |
return ($found,$fullName);
|
|
313 |
}
|
|
314 |
|
|
315 |
sub localFnr($@)
|
|
316 |
{
|
|
317 |
my($fnm,@layout) = @_;
|
|
318 |
my($i,$fnr);
|
|
319 |
|
|
320 |
# print(STDERR "finding $fnm...\n");
|
|
321 |
croak("$0: illegal 0-length field name\n")
|
|
322 |
if ($fnm eq "");
|
|
323 |
return $fnm if ($fnm =~ /^%/);
|
|
324 |
if ($fnm =~ /^\$/) {
|
|
325 |
croak("$0: invalid field identifier \$$'\n")
|
|
326 |
unless (cardinalp($'));
|
|
327 |
return $' - 1;
|
|
328 |
}
|
|
329 |
my($i,$found);
|
|
330 |
if (@layout) {
|
|
331 |
for ($i=0; $i<=$#layout; $i++) {
|
|
332 |
return $i if ($layout[$i] eq $fnm);
|
|
333 |
}
|
|
334 |
for ($i=0; $i<=$#layout; $i++) {
|
|
335 |
next unless fname_match($fnm,$layout[$i]);
|
|
336 |
croak("$0: $fnm matches multiple fields ($layout[$found],$layout[$i],...)\n")
|
|
337 |
if defined($found);
|
|
338 |
$found = $i;
|
|
339 |
}
|
|
340 |
} else {
|
|
341 |
for ($i=0; $i<=$#antsLayout; $i++) {
|
|
342 |
return $i if ($antsLayout[$i] eq $fnm);
|
|
343 |
}
|
|
344 |
for ($i=0; $i<=$#antsLayout; $i++) {
|
|
345 |
next unless fname_match($fnm,$antsLayout[$i]);
|
|
346 |
croak("$0: $fnm matches multiple fields ($antsLayout[$found],$antsLayout[$i],...)\n")
|
|
347 |
if defined($found);
|
|
348 |
$found = $i;
|
|
349 |
}
|
|
350 |
}
|
|
351 |
return $found;
|
|
352 |
}
|
|
353 |
|
|
354 |
sub fnrNoErr($)
|
|
355 |
{
|
|
356 |
my($fnm,$exact) = @_;
|
|
357 |
|
|
358 |
my($tmp) = $antsFnrExactMatch;
|
|
359 |
$antsFnrExactMatch = $exact if defined($exact);
|
|
360 |
my($fnr) = &localFnr($fnm);
|
|
361 |
$antsFnrExactMatch = $tmp;
|
|
362 |
|
|
363 |
my($fullName);
|
|
364 |
|
|
365 |
return $fnr if defined($fnr); # internal layout
|
|
366 |
return $fnm if ($fnm < 0 && $antsFnrNegativeOk); # e.g. for $-1 in [list]
|
|
367 |
|
|
368 |
my($tmp) = $antsFnrExactMatch;
|
|
369 |
$antsFnrExactMatch = $exact if defined($exact);
|
|
370 |
($fnr,$fullName) = &fnrInFile($fnm,"Layout",""); # external [Layout]
|
|
371 |
$antsFnrExactMatch = $tmp;
|
|
372 |
|
|
373 |
return undef unless defined($fnr);
|
|
374 |
return undef # [Layout] cannod override
|
|
375 |
if (defined($antsLayout[$fnr]) && # local definition
|
|
376 |
!fname_match($fnm,$antsLayout[$fnr]));
|
|
377 |
|
|
378 |
$antsLayout[$fnr] = $fullName if defined($fullName);# found -> add to local
|
|
379 |
$antsBufNFields = $fnr+1 # can happen on externally
|
|
380 |
if ($antsBufNFields < $fnr+1); # ... defined fields
|
|
381 |
return($fnr);
|
|
382 |
}
|
|
383 |
|
|
384 |
sub fnr(@)
|
|
385 |
{
|
|
386 |
my(@fnm) = @_;
|
|
387 |
my($f,@fnr);
|
|
388 |
for ($f=0; $f<=$#fnm; $f++) {
|
|
389 |
$fnr[$f] = &fnrNoErr($fnm[$f]);
|
|
390 |
next if defined($fnr[$f]); # normal case -> done
|
|
391 |
croak("$0: Unknown field $fnm[$f]\n")
|
|
392 |
unless defined($fnr[$f]);
|
|
393 |
}
|
|
394 |
return(@fnr>1 ? @fnr : $fnr[0]);
|
|
395 |
}
|
|
396 |
|
|
397 |
# fnr()-equivalent but checks in output format
|
|
398 |
# - only used for -F processing => single argument only
|
|
399 |
|
|
400 |
sub outFnr($)
|
|
401 |
{
|
|
402 |
my($fnm) = @_;
|
|
403 |
my($f,$fnr,$fullName);
|
|
404 |
|
|
405 |
$fnr = &localFnr($fnm,@antsNewLayout);
|
|
406 |
return $fnr if defined($fnr); # normal case -> done
|
|
407 |
|
|
408 |
($fnr,$fullName) = &fnrInFile($fnm,"Layout",""); # look in [Layout]
|
|
409 |
croak("$0: Unknown field $fnm\n")
|
|
410 |
unless defined($fnr);
|
|
411 |
|
|
412 |
$antsNewLayout[$fnr] = $fullName;
|
|
413 |
return $fnr;
|
|
414 |
}
|
|
415 |
|
|
416 |
#----------------------------------------------------------------------
|
|
417 |
# model-loading funs
|
|
418 |
#----------------------------------------------------------------------
|
|
419 |
|
|
420 |
sub antsLoadModel($$)
|
|
421 |
{
|
|
422 |
my($opt,$pref) = @_;
|
|
423 |
my($name);
|
|
424 |
|
|
425 |
for ($a=0; # find model name
|
|
426 |
$a<=$#ARGV && !($ARGV[$a] =~ m/^-\S*$opt$/);
|
|
427 |
$a++) { }
|
|
428 |
if ($a < $#ARGV) { # found
|
|
429 |
$name = $ARGV[$a+1]; # load it
|
|
430 |
if (-r "$pref.$name") { # local
|
|
431 |
&antsInfo("loading local $pref.$name...");
|
|
432 |
require "$pref.$name";
|
|
433 |
return $name;
|
|
434 |
} else {
|
1
|
435 |
my($path) = ($0 =~ m{^(.*)/[^/]*$});
|
|
436 |
require "$path/$pref.$name";
|
0
|
437 |
return $name;
|
|
438 |
}
|
|
439 |
}
|
|
440 |
return undef;
|
|
441 |
}
|
|
442 |
|
|
443 |
sub antsLoadModelWithArgs($$)
|
|
444 |
{
|
|
445 |
my($opt,$pref) = @_;
|
|
446 |
|
|
447 |
for ($a=0; # find model name
|
|
448 |
$a<=$#ARGV && !($ARGV[$a] =~ m/^-\S*$opt$/);
|
|
449 |
$a++) { }
|
|
450 |
if ($a < $#ARGV) { # found
|
|
451 |
my($name,$args) = ($ARGV[$a+1] =~ /([^\(]+)\(([^\)]*)\)$/);
|
|
452 |
$name = $ARGV[$a+1] unless defined($name);
|
|
453 |
if (-r "$pref.$name") { # local
|
|
454 |
&antsInfo("loading local $pref.$name...");
|
|
455 |
require "$pref.$name";
|
|
456 |
return ($name,split(',',$args));
|
|
457 |
} else {
|
1
|
458 |
my($path) = ($0 =~ m{^(.*)/[^/]*$});
|
|
459 |
require "$path/$pref.$name";
|
0
|
460 |
return ($name,split(',',$args));
|
|
461 |
}
|
|
462 |
}
|
|
463 |
return undef;
|
|
464 |
}
|
|
465 |
|
|
466 |
#----------------------------------------------------------------------
|
3
|
467 |
# deal with lists of numbers
|
|
468 |
#----------------------------------------------------------------------
|
|
469 |
|
|
470 |
sub compactList(@)
|
|
471 |
{
|
|
472 |
my(@out);
|
|
473 |
my($seqStart);
|
|
474 |
my($lv) = -9e99;
|
|
475 |
|
|
476 |
foreach my $v (@_) {
|
|
477 |
if (numberp($v)) {
|
|
478 |
if ($v == $lv+1) { # we're in a sequence
|
|
479 |
$seqStart = $lv # record beginning value
|
|
480 |
unless defined($seqStart);
|
|
481 |
} elsif (defined($seqStart)) { # we've just completed a sequence
|
|
482 |
pop(@out);
|
|
483 |
push(@out,"$seqStart-$lv");
|
|
484 |
push(@out,$v);
|
|
485 |
undef($seqStart);
|
|
486 |
} else { # not in a sequence
|
|
487 |
push(@out,$v);
|
|
488 |
}
|
|
489 |
$lv = $v;
|
|
490 |
} else {
|
|
491 |
push(@out,$v);
|
|
492 |
$lv = -9e99;
|
|
493 |
}
|
|
494 |
}
|
|
495 |
if (defined($seqStart)) { # list ends with a sequence
|
|
496 |
pop(@out);
|
|
497 |
push(@out,"$seqStart-$lv");
|
|
498 |
}
|
|
499 |
|
|
500 |
return @out;
|
|
501 |
}
|
|
502 |
|
|
503 |
#----------------------------------------------------------------------
|
0
|
504 |
# Misc funs
|
|
505 |
#----------------------------------------------------------------------
|
|
506 |
|
|
507 |
# return either current field value or PARAM
|
|
508 |
sub antsVal($)
|
|
509 |
{ return ($_[0] =~ /^%/) ? $P{$'} : $ants_[$ants_][$_[0]]; }
|
|
510 |
|
|
511 |
# USAGE:
|
|
512 |
# OLD: argc, type-string, errmesg, params to parse
|
|
513 |
# NEW: adds between errmesg & params:
|
|
514 |
# 1) reference to static array for caching fnrs
|
|
515 |
# 2) list (argc elts) of field names
|
|
516 |
|
|
517 |
# NOTES:
|
|
518 |
# - backward compatible
|
|
519 |
# - fnr_caching only works with fixed-argc funs
|
|
520 |
# - undef field names denote required arguments that must be
|
|
521 |
# supplied by the user, e.g. for dn2date
|
|
522 |
|
|
523 |
sub antsFunUsage($$$@)
|
|
524 |
{
|
|
525 |
my($argc,$types,$msg,@params) = @_;
|
|
526 |
|
|
527 |
if (ref($params[0]) && @antsLayout>0 && @params<2*$argc+1) { # default params
|
|
528 |
my(@newparams); # 2nd test is for abc
|
|
529 |
my($npi) = $argc+1;
|
|
530 |
|
|
531 |
$listAllRecs = 1; # special flag for list(1)
|
|
532 |
|
|
533 |
if (@{$params[0]} > 0) { # fnrs already in cache
|
|
534 |
for (my($i)=0; $i<@{$params[0]}; $i++) {
|
|
535 |
push(@newparams,defined($params[0]->[$i]) ?
|
|
536 |
&antsVal($params[0]->[$i]) :
|
|
537 |
$params[$npi++]);
|
|
538 |
}
|
|
539 |
return(@newparams);
|
|
540 |
}
|
|
541 |
|
|
542 |
for (my($i)=1; $i<=$argc; $i++) { # fill cache & do tests
|
|
543 |
if (defined($params[$i])) {
|
|
544 |
push(@{$params[0]},&fnr($params[$i]));
|
|
545 |
push(@newparams,&antsVal($params[0]->[$#{$params[0]}]));
|
|
546 |
} else {
|
|
547 |
croak("usage: $msg\n") unless ($npi <= $#params);
|
|
548 |
push(@{$params[0]},undef);
|
|
549 |
push(@newparams,$params[$npi++]);
|
|
550 |
}
|
|
551 |
}
|
|
552 |
croak("usage: $msg\n") unless ($npi > $#params);
|
|
553 |
|
|
554 |
@params = @newparams;
|
|
555 |
} elsif (ref($params[0])) {
|
|
556 |
splice(@params,0,$argc+1);
|
|
557 |
}
|
|
558 |
|
|
559 |
if ($argc >= 0) { # argument count
|
|
560 |
croak("usage: $msg\n") unless (@params == $argc);
|
|
561 |
} else {
|
|
562 |
croak("usage: $msg\n") unless (@params >= -$argc);
|
|
563 |
}
|
|
564 |
|
|
565 |
for (my($i)=0; $i<length($types); $i++) { # type checking
|
|
566 |
$_ = substr($types,$i,1);
|
|
567 |
SWITCH: {
|
|
568 |
last unless defined($params[$i]);
|
|
569 |
&antsNoCardErr("",$params[$i]),last SWITCH if (/c/);
|
|
570 |
&antsNoIntErr("",$params[$i]),last SWITCH if (/i/);
|
|
571 |
&antsNoFloatErr("",$params[$i]),last SWITCH if (/f/);
|
|
572 |
&antsNoFileErr("",$params[$i]),last SWITCH if (/F/);
|
|
573 |
if (/\d/) {
|
|
574 |
croak("$0: $params[$i] is not a string of length $_\n")
|
|
575 |
unless ($_ == length($params[$i]));
|
|
576 |
last SWITCH;
|
|
577 |
}
|
|
578 |
last SWITCH if (/\./);
|
|
579 |
croak("&antsFunUsage: illegal type specifier $_\n");
|
|
580 |
}
|
|
581 |
}
|
|
582 |
|
|
583 |
return @params;
|
|
584 |
} # sub antsfunusage()
|
|
585 |
|
|
586 |
sub antsRequireParam($)
|
|
587 |
{
|
|
588 |
my($pn) = @_;
|
|
589 |
croak("$0: required PARAM $pn not set\n")
|
|
590 |
unless (defined($P{$pn}));
|
|
591 |
return $P{$pn};
|
|
592 |
}
|
|
593 |
|
|
594 |
|
|
595 |
{ my($term); # STATIC
|
|
596 |
|
|
597 |
sub debug($)
|
|
598 |
{
|
|
599 |
my($prompt) = @_;
|
|
600 |
unless (defined($term)) { # initialize
|
|
601 |
use Term::ReadLine;
|
|
602 |
$term = new Term::ReadLine $ARGV0;
|
|
603 |
}
|
|
604 |
do {
|
|
605 |
my($expr) = $term->readline("$prompt>");
|
|
606 |
return if ($expr eq 'return');
|
|
607 |
$res = eval($expr);
|
|
608 |
if (defined($res)) { # no error
|
|
609 |
print(STDERR "$res\n");
|
|
610 |
} else { # error
|
|
611 |
print(STDERR "$@");
|
|
612 |
}
|
|
613 |
} while (1);
|
|
614 |
}
|
|
615 |
|
|
616 |
} # STATIC SCOPE
|
|
617 |
|
|
618 |
1;
|