← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:24 2010

File/wise/base/deliv/dev/lib/perl/WISE/IOUtils.pm
Statements Executed158550
Total Time0.954855999999724 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1110.615940.86730WISE::IOUtils::sort_cols
17518110.182760.18276WISE::IOUtils::lex_key_a
8759110.068600.06860WISE::IOUtils::lex_key_d
2210.023810.06709WISE::IOUtils::make_ipac_tbl
1110.008120.04208WISE::IOUtils::make_ipac_rows_fast
2210.000710.00071WISE::IOUtils::make_ipac_hdr
1110.000360.00036WISE::IOUtils::make_ipac_keys
1117.4e-57.4e-5WISE::IOUtils::make_ipac_coms
00000WISE::IOUtils::_parse_key_line
00000WISE::IOUtils::_raw_tbl_read
00000WISE::IOUtils::add_ipac_cols
00000WISE::IOUtils::clean_dir
00000WISE::IOUtils::copy_ipac_hdr
00000WISE::IOUtils::del_ipac_cols
00000WISE::IOUtils::dir_list
00000WISE::IOUtils::fast_fits_hdr
00000WISE::IOUtils::fast_tail
00000WISE::IOUtils::fitin
00000WISE::IOUtils::fits_coltype_to_ipac
00000WISE::IOUtils::fits_fmt_to_ipac
00000WISE::IOUtils::fits_hdr
00000WISE::IOUtils::fits_keytype_to_ipac
00000WISE::IOUtils::fits_to_ipac
00000WISE::IOUtils::fitsmeta_to_ipac
00000WISE::IOUtils::get_log_proc_id
00000WISE::IOUtils::get_time_skew
00000WISE::IOUtils::gulp_ipac_tbl
00000WISE::IOUtils::ipac_coltype_to_fits
00000WISE::IOUtils::ipac_keytype_to_fits
00000WISE::IOUtils::ipac_to_fits
00000WISE::IOUtils::ipaccol
00000WISE::IOUtils::ipacmeta_to_fits
00000WISE::IOUtils::ipacval
00000WISE::IOUtils::log_trace_str
00000WISE::IOUtils::make_ipac_row
00000WISE::IOUtils::make_ipac_rows
00000WISE::IOUtils::merge_ipac_hdrs
00000WISE::IOUtils::merge_ipac_tbls
00000WISE::IOUtils::parse_ipac_hdr
00000WISE::IOUtils::parse_log_file
00000WISE::IOUtils::print_log_tree_depth
00000WISE::IOUtils::slurp_ipac_tbl
00000WISE::IOUtils::slurp_log_file
00000WISE::IOUtils::splitipac
00000WISE::IOUtils::trace_log_file
00000WISE::IOUtils::type_pack_templates
00000WISE::IOUtils::write_ds9_regions

LineStmts.Exclusive
Time		Avg.Code
1#! /usr/bin/env perl
2
334.3e-51.4e-5use strict;
# spent 10µs making 1 call to strict::import
434.3e-51.4e-5use warnings;
# spent 37µs making 1 call to warnings::import
5
634.5e-51.5e-5use WISE::Env (cfglib=>'/wise/base/deliv/dev/lib/perl');
# spent 495µs making 1 call to WISE::Env::import, max recursion depth 1
7
8package WISE::IOUtils;
9
1032.9e-59.7e-6use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
# spent 67µs making 1 call to vars::import
11
1237.1e-52.4e-5use Exporter;
# spent 30µs making 1 call to Exporter::import
1311.0e-61.0e-6$VERSION = 1.00;
1411.3e-51.3e-5@ISA = qw(Exporter);
15
1611.0e-61.0e-6@EXPORT = qw();
1718.0e-68.0e-6@EXPORT_OK = qw(fitin parse_log_file slurp_log_file print_log_tree_depth
18 write_ds9_regions
19 fits_hdr fast_fits_hdr fast_tail get_time_skew
20 slurp_ipac_tbl gulp_ipac_tbl make_ipac_tbl
21 slurp_sex_tbl
22 del_ipac_col add_ipac_col copy_ipac_hdr
23 fits_to_ipac ipac_to_fits merge_ipac_tbls
24 clean_dir
25 );
2611.5e-51.5e-5%EXPORT_TAGS = ();
27
28# Extension modules
2933.3e-51.1e-5use File::Basename;
# spent 54µs making 1 call to Exporter::import
3032.7e-59.0e-6use Text::ParseWords;
# spent 51µs making 1 call to Exporter::import
3132.6e-58.7e-6use IO::Handle;
# spent 26µs making 1 call to Exporter::import
3233.1e-51.0e-5use Cwd;
# spent 51µs making 1 call to Exporter::import
3333.4e-51.1e-5use Fcntl ':seek';
# spent 147µs making 1 call to Exporter::import
3430.000750.00025use File::Slurp;
# spent 58µs making 1 call to Exporter::import
3530.000258.3e-5use Compress::Zlib;
# spent 401µs making 1 call to Exporter::import
36
3732.8e-59.3e-6use WISE::Time; # For time fomatting
# spent 92µs making 1 call to Exporter::import
3830.000690.00023use WISE::FITSIO; # For FITS tables and images.
# spent 56µs making 1 call to Exporter::import
3933.8e-51.3e-5use WISE::Utils qw/def undefize fpre/;
# spent 171µs making 1 call to Exporter::import
4033.1e-51.0e-5use WISE::Dumper qw/Dumper/;
# spent 46µs making 1 call to Exporter::import
4130.018240.00608use WISE::IPACTblXS;
# spent 43µs making 1 call to Exporter::import
42
43#no warnings qw/redefine/;
44
45# CVS revision ID
4611.0e-61.0e-6my $version = '$Id: IOUtils.pm 7858 2010-05-07 01:25:11Z tim $ ';
47
48# =========================================================================
49#
50# Bunch of routines for manipulating IPAC table files.
51
5213.0e-53.0e-5my %blank_type= (r => 'NaN', f => 'NaN', d => 'NaN',
53 i => 0, l => 0,
54 c => '');
55
56sub slurp_ipac_tbl {
57 my $file = shift;
58 my $opts = shift || {};
59 my (@tkcols,@cols,%cols,@comments,$incremental);
60 my $err = "*** $0/SLURPTBL";
61 my $warn = "=== $0/SLURPTBL";
62 my %pack_type = type_pack_templates();
63 local $_;
64
65 # Parse options
66 my ($lc,$hdronly,$tkcols,$data,$noclose,$skipoverflow,$fast,
67 $packed,$nanblank,$nrowstoread,$meta)
68 = (map { defined $opts->{$_} ? $opts->{$_} : undef; }
69 qw(lc hdronly cols data noclose skip_overflow fast
70 packed nanblank nrows meta)
71 );
72
73 print "SLURP: Raw OPTS(lc hdronly cols noclose skipoverflow fast ".
74 "packed nanblank nrowstoread)=".
75 join(",", undefize($lc,$hdronly,$tkcols,$noclose,
76 $skipoverflow,$fast,$packed,$nanblank,
77 $nrowstoread))."\n"
78 if $opts->{debug};
79
80 my ($fh);
81
82 my $unpacked = ! $packed;
83
84 $tkcols ||= [];
85 $data ||= {};
86 $nrowstoread = 0 if $nrowstoread && $nrowstoread < 0;
87 $noclose = 1 if $nrowstoread;
88
89 if($meta) {
90 $incremental = 1;
91 $packed = $meta->{packed};
92 @cols = @tkcols = @$tkcols = @{ $meta->{cols} };
93 %cols = %{ $meta->{ix} };
94 $fh = $meta->{fh};
95 } else {
96 @tkcols = map {lc $_} @$tkcols;
97 }
98
99 my %tkcols = map {($_=>1)} @tkcols;
100
101 print "SLURP: Fixed OPTS(lc hdronly cols noclose skipoverflow fast ".
102 "packed nanblank nrowstoread)=".
103 join(",", undefize($lc,$hdronly,$tkcols,$noclose,
104 $skipoverflow,$fast,$packed,$nanblank,
105 $nrowstoread))."\n"
106 if $opts->{debug};
107
108
109 my ($comre,$hdrre,$hdrsep,$keyre) = ('[\\\\\|]', '\|', '\|', '\\\\');
110
111 my $data_in;
112 if(! $fh && ! ref $file) {
113 if($file ne "-" && (! -e $file || -z _ || ! -f _)) {
114 warn "$err: '$file' does not exist, is empty or is not a ".
115 "plain file.\n";
116 return;
117 }
118 print "SLURP: Opening '$file' ...\n" if $opts->{debug};
119 my $use;
120 if($file =~ /\.gz$/) {
121 $use = "gzip -dc |";
122 } else {
123 $use = $file;
124 }
125 if(! open($fh,"<$use")) {
126 warn "$err: Error opening '$file'; $!\n";
127 return;
128 }
129 } elsif($fh || ref($file) =~ /glob/i) {
130 $fh = $file if ! $fh;
131 $file = $meta ? $meta->{file} : '<Unknown>';
132 } elsif(ref($file) =~ /scalar/i) {
133 $data_in = $file;
134 $file = '<Internal>';
135 open $fh,"<",$data_in
136 or die "$err: Unable to read from reference; $!.\n";
137 } else {
138 die "$err: Don't know how to handle 'file' of ref type '".ref($file).
139 "'.\n"
140 }
141
142 if(($fh && eof($fh)) || ($data_in && ! length($$data_in))) {
143 # Got nothin'
144 if(! $meta || ! $meta->{done}) {
145 $meta->{done} = 1 if $meta;
146 return (0,$meta);
147 } else {
148 warn "$err: Attempt to read after EOF for '$file'.\n";
149 return;
150 }
151 }
152
153 my $keys = []; # For accumulated key storage
154 my %keys; # For easy key lookup; dup keys lost
155
156 my $nk = 0;
157 my $n = 0;
158
159 LINES: while(<$fh>) {
160
161 chomp; # Strip newlines.
162
163 next if ! /\S/;
164 next if $fast && /^$comre/; # Skip comment lines
165
166 # If keyword, read it (already skipped in fast mode)
167 if(/^$keyre/i) {
168 # Read key=val pair
169 my ($k,$v,$t) = _parse_key_line($_);
170 # If the keyword line doesn't match the RE above,
171 # I can't handle it, so skip it.
172 if(defined $k) {
173 push @$keys, {name=>$k,value=>$v,type=>$t,ix=>$nk++};
174 $keys{lc $k} = $v;
175 # If found a keyword, skip further reading.
176 next LINES;
177 }
178 }
179
180 #print "/".join("/",undefize($n,$hdrsep,$hdrre))."/ =? $. : $_\n";
181
182 # If header and header not already read, read it
183 if(! $meta && /^$hdrre/) {
184
185 # Read rest of header lines
186 my $c;
187 my @hdr = ($_);
188 while(defined ($c = getc($fh)) && $c =~ /^$hdrre/) {
189 $fh->ungetc(ord $c);
190 push @hdr, scalar( <$fh> );
191 }
192 chomp(@hdr);
193 $fh->ungetc(ord $c) if defined $c;
194
195 # Get data structure describing this table
196 $meta = parse_ipac_hdr(\@hdr,{cols=>\%tkcols}) or
197 die "$err: Could not parse header of '$file'.\n";
198 # All cols
199 @cols = map { lc $_ } @{ $meta->{names} };
200 # Order requested tkcols right
201 @tkcols = grep { ! %tkcols || $tkcols{$_} } @cols;
202 %cols = map {($_=>$meta->{ix}{$_})} @tkcols;
203
204 if(%tkcols && ! @tkcols) {
205 warn "$warn: Requested cols have no match in '$file': @cols\n";
206 return wantarray ? ({},$meta) : {};
207 }
208
209 if($nanblank) {
210 # Use nan-oriented blanks as for packing or PDLfying
211 $meta->{blankvals}[$cols{$_}] =
212 $blank_type{$meta->{types}[$cols{$_}]}
213 for @cols;
214 print "SLURP: ",join(",",@{$meta->{blankvals}}),"\n"
215 if $opts->{debug};
216 }
217
218 # For efficiency in splitipac(), reduce some meta-data to desired columns
219 for my $col (@tkcols) {
220 my $ix = $cols{$col};
221 push @{$meta->{blanks_cols}}, $meta->{blanks}[$ix];
222 push @{$meta->{blankvals_cols}}, $meta->{blankvals}[$ix];
223 }
224
225 # We only want the header
226 last LINES if $hdronly;
227
228 # Pre-fill data structure with empty arrays
229 if($unpacked) {
230 $data->{$_} = [] for @tkcols;
231 } else {
232 $data->{$_} = "" for @tkcols;
233 }
234
235 # For ipac tables, we're positioned at the next line, so go on.
236 $_ = <$fh>;
237 last LINES if ! defined $_; # Only the header was present
238 chomp;
239
240 } # Header
241
242 # Skip comment lines (already skipped in fast mode)
243 if(! $fast && /^$comre/) {
244 s/^$comre\s*//;
245 s/\s*$//;
246 push @comments,$_ if length $_;
247 next LINES;
248 }
249
250 die "$err: No header found for '$file'.\n"
251 if ! $meta;
252
253 if($skipoverflow) {
254 if(/\*\*+/){
255 warn "$err: Skipping overflowed row $n of '$file':\n$_\n";
256 next LINES;
257 }
258 }
259
260 # Read ipac table columns by column number
261 my $mycols = splitipac($_,$meta,\@tkcols) or
262 die "$err: Could not parse row $n of '$file'.\n";
263
264 # One array (or packed string) per column
265 if($unpacked) {
266 push @{ $data->{$_} }, $mycols->{$_}
267 for @tkcols;
268 } else {
269 $data->{$_} .= pack("$pack_type{$meta->{types}[$cols{$_}]}",
270 $mycols->{$_}
271 // $blank_type{$meta->{types}[$cols{$_}]}
272 )
273 for @tkcols;
274 }
275
276 ++$n;
277
278 last LINES if $nrowstoread && $n >= $nrowstoread;
279
280 } # LINES
281
282 my $eof = eof($fh);
283
284 if(! $noclose || $eof) {
285 print "SLURP: Closing.\n" if $opts->{debug};
286 if(! defined close $fh) {
287 warn "$err: Error reading(close) '$file' data: $!.\n";
288 return;
289 }
290 }
291
292 if($incremental && $eof && $n == 0 && ! @comments && ! @$keys) {
293 # We're done and we got nothing new, so return empty
294 $meta->{done} = 1;
295 return (0,$meta);
296 }
297
298 if(! $incremental) {
299 # First read; initialize
300 print "SLURP: Initializing meta.\n" if $opts->{debug};
301 $meta->{cols} = \@tkcols;
302 $meta->{comments} = \@comments;
303 $meta->{keys} = $keys;
304 $meta->{file} = $file;
305 $meta->{nrows} = $n;
306 $meta->{keyhash} = \%keys;
307 $meta->{packed} = $packed;
308 $meta->{fh} = $fh;
309 $meta->{nanblank} = $nanblank;
310 } else {
311 # Extend with new info
312 push @{ $meta->{comments} }, @comments;
313 push @{ $meta->{keys} }, @$keys;
314 $meta->{keyhash} = { %{ $meta->{keyhash} }, %keys };
315 }
316
317 $meta->{nrows} = $n;
318 $meta->{totrows} += $n;
319 $meta->{eof} = $eof;
320
321 wantarray ? ($data,$meta,$keys,\@comments,\@tkcols) : $data;
322}
323
324# Hyper-optimized version of the one above where
325# - no comment reading/saving is done
326# - the whole file is read at once
327# - there are many fewer options (no packed, pdl, etc.)
328# - numbers might have leading spaces
329sub gulp_ipac_tbl {
330 my $file = shift;
331 my $opts = shift || {};
332 my @cols = map {lc} @{ $opts->{cols} || [] };
333 my %cols = map {($_=>1)} @cols;
334 my (@keys,%keys,@comments);
335 my $err = "*** $0/GULPTBL";
336 my $warn = "=== $0/GULPTBL";
337 local $_;
338
339 my $lines = _raw_tbl_read($file) or return;
340
341 my @hdr = grep {/^[\\|]/} @$lines;
342 my @kvcom = grep {/^\\/} @hdr;
343 my @def = grep {/^\|/} @hdr;
344
345 die "$err: No column definitions found for '$file'.\n" if ! @def;
346
347 my $meta = parse_ipac_hdr(\@def, {cols=>\%cols}) or
348 die "$err: Could not parse header of '$file'.\n";
349
350 $meta->{file} = $file;
351 $meta->{packed} = 0;
352 $meta->{fh} = undef;
353
354 return wantarray ? (undef,$meta) : $meta
355 if $opts->{hdronly};
356
357 my $nk=0;
358 for (@kvcom) {
359 my ($k,$v,$t,$c) = _parse_key_line($_);
360 if(defined $k) {
361 push @keys, {name=>$k,value=>$v,type=>$t,ix=>$nk++};
362 $keys{lc $k} = $v;
363 } elsif(defined $c) {
364 push @comments, $c;
365 }
366 }
367
368 my @tkcols = grep {! %cols || $cols{$_} }
369 map { lc $_ }
370 @{ $meta->{names} };
371
372 if(%cols && ! @tkcols) {
373 warn "$warn: Requested cols have no match in '$file': @cols\n";
374 return wantarray ? ({},$meta) : {};
375 }
376
377 my @tkix = map { $meta->{ix}{$_} } @tkcols;
378
379 # Here's where it all happens. Isn't this exciting?
380
381 my $cols = WISE::IPACTblXS::extract_ipac_cols($lines,
382 [@{$meta->{start}}[@tkix]],
383 [@{$meta->{lens}}[@tkix]],
384 [@{$meta->{blanks}}[@tkix]]);
385
386 my $data = {};
387 @{$data}{@tkcols} = @$cols;
388 my $n = @{$data->{$tkcols[0]}};
389
390 # Done
391
392 $meta->{cols} = \@tkcols;
393 $meta->{comments} = \@comments;
394 $meta->{keys} = \@keys;
395 $meta->{keyhash} = \%keys;
396 $meta->{nrows} = $n;
397 $meta->{totrows} += $n;
398 $meta->{eof} = 1;
399
400 return wantarray ? ($data,$meta) : $data;
401}
402
403sub _raw_tbl_read {
404 my $file = shift;
405 my $err = "*** $0/GULPTBL";
406 my $lines;
407 if(! ref $file) {
408 my $use;
409 if($file =~ /\.gz$/) {
410 my $pipe = "gzip -dc $file |";
411 open($use,$pipe)
412 or die "$err: Unable to open pipe '$pipe'; $!.\n";
413 } else {
414 if($file eq '-') {
415 $use = \*STDIN;
416 } else {
417 $use = $file;
418 }
419 }
420 $lines = File::Slurp::read_file($use, array_ref=>1);
421 } else {
422 $lines = [<$file>];
423 }
424 chomp(@$lines);
425 return $lines;
426}
427
428sub _parse_key_line {
429 my $line = shift;
430 my ($re,$k,$v) = $line =~ m/^ \\
431 (?:(char(?:acter)?|int(?:eger)?
432 |real|doub(?:le)?|dbl|float)\s+)?([-()\w]+)
433 \s*=\s*
434 (\S.*?)\s*
435 $ /xi;
436 # If the keyword line doesn't match the RE above, it's a comment
437 if(! defined $k) {
438 $line =~ s/^\\\s*//;
439 $line =~ s/\s*$//;
440 return (undef,undef,undef,$line);
441 }
442 $v =~ s/^[""''](.*)[""'']$/$1/; # Strip quotes from value
443 my $t = "";
444 if($re) {
445 $t = lc substr($re,0,1);
446 $t = 'r' if $t =~ /^[fd]/;
447 } else {
448 $t = ($v =~ /^\s*[-+]?\d+\s*$/
449 ? 'i'
450 : $v =~ /^\s*([-+.]\d|\d)[-+\d.e]*\s*$/i
451 ? 'r'
452 : 'c');
453 }
454
455 return ($k, $v, $t);
456}
457
458sub type_pack_templates {
459 my %pack_type = (r => 'd', f => 'd', d => 'd',
460 i => 'l', l => 'l',
461 c => 'Z');
462 return wantarray ? %pack_type : \%pack_type;
463}
464
465 # Parse an ipac table file header
466sub parse_ipac_hdr {
467 my $hdrlines = shift;
468 my $opts = shift || {};
469 my ($names,$types,$units,$blanks,$fmts) = @$hdrlines;
470 my %cols = %{ $opts->{cols} || {} };
471 local $_;
472
473 $_ ||= "" for ($types,$units,$blanks,$fmts);
474
475 if(! $names) {
476 warn "*** PARSEIPAC: Missing NAME line from header.\n";
477 return;
478 }
479 # Trim stuff at and after the last delimiter, and remove the leading
480 # delimiter all fields have the same relation to the delimiters.
481 s/\|[^\|]*$//, s/^\|// for ($names,$types,$units,$blanks,$fmts);
482 #print "'$names'\n'$types'\n'$units'\n'$blanks'\n'$fmts'\n";
483 # Get fields from raw (untrimmed) line so we get the field sizes right
484 my @fields = split(/\|/,$names);
485 # Trim leading and trailing "white" space so the split produces proper
486 # identifiers
487 s/^[-\s]*//, s/[-\s]*$// for ($names,$types,$units,$fmts);
488 s/^[\s]*//, s/[\s]*$// for ($blanks);
489 my @names = split(/[-\s]*\|[-\s]*/,$names);
490 my $n = scalar(@names);
491
492 {
493 my %seen;
494 if(my @seen = grep { $seen{lc $_}++ } @names) {
495 warn "*** PARSEIPAC: Column names repeated: @seen.\n";
496 return;
497 }
498 }
499
500 my @types = split(/[-\s]*\|[-\s]*/,$types,$n);
501 if(! @types) { @types = ("r") x scalar(@names); } # default to real columns
502 my @units = split(/[-\s]*\|[-\s]*/,$units,$n);
503 if(! @units) { @units = ("") x scalar(@names); } # default units to ""
504 my @blanks = split(/[\s]*\|[\s]*/,$blanks,$n);
505 if(! @blanks) { @blanks = ("") x scalar(@names); } # default blank to ""
506 @blanks = map { $_ //= ''; s/^\s+//; s/\s+$//; $_; } @blanks;
507 my @fmts = split(/[-\s]*\|[-\s]*/,$fmts,$n);
508 if(! @fmts) { @fmts = ("") x scalar(@names); } # default formats to ""
509 my @blankvals = (undef) x scalar(@names); # default blank replace to undef
510
511 # Find the starting columns, field widths, and pack/unpack template
512 my (@start,@len);
513 my %ix;
514 my $start = 0;
515 my $unpack = '';
516 my $pack = '';
517 my $nullpack = '';
518 my $i = 0;
519 for (@fields) {
520 my $len = length($_)+1;
521 push @len, $len;
522 push @start,$start;
523 if(! %cols || $cols{lc $names[$i]}) {
524 $unpack .= "A$len";
525 $pack .= "A$len";
526 $nullpack .= "A${len}x";
527 } else {
528 # Don't want this column
529 $unpack .= "x$len";
530 }
531 $start += $len;
532 ++$i;
533 }
534 my $width = $start;
535
536 my @percol_unpack;
537 push @percol_unpack, "x$start[$_]A$len[$_]x".($width-$start[$_]-$len[$_])
538 for 0..$#fields;
539
540 @ix{map {lc $_} @names} = (0..$#names);
541
542# print "'".join("','",@names)."'\n";
543# print "'".join("','",@types)."'\n";
544
545 return {
546 names=>\@names, types=>\@types, blanks=>\@blanks,
547 units=>\@units, start=>\@start, lens=>\@len,
548 fmts=>\@fmts, blankvals=>\@blankvals,
549 ix=>\%ix, width=>$width,
550 row_unpack => $unpack,
551 col_unpack => \@percol_unpack,
552 row_pack => $pack,
553 row_nullpack => $nullpack,
554 };
555}
556
557 # Split an ipac-table row based on its header structure
558sub splitipac {
559 my ($line,$ipac,$cols) = @_;
560
561 my $blank = $ipac->{blanks_cols};
562 my $blankvals = $ipac->{blankvals_cols};
563 my %out;
564 my $i = -1;
565 s/^\s+//, s/\s+$//, ++$i, $_ eq $blank->[$i] && ($_=$blankvals->[$i]),
566 $out{$cols->[$i]} = $_
567 for unpack($ipac->{row_unpack},$line);
568
569 return \%out;
570}
571
572 # For a given output width, fit in a real number maintaining max. precision
573 # Still imperfect.
574sub fitin {
575 my $x = shift;
576 my $width = shift;
577 my ($y,$prec) = ($x,$width);
578 # print "/$x/$width/",length($x),"\n";
579 --$prec if $x<0; # For the minus sign
580 $prec -= 4 if $x>=10**$width || $x<=10**-$width; # for the exponent
581 ($y=sprintf("%-*.*g",$width,$prec,$x)),--$prec
582 while length($y)>$width && $prec >= 0;
583 return $y;
584}
585
586
# spent 710µs within WISE::IOUtils::make_ipac_hdr which was called 2 times, avg 355µs/call: # once (416µs+0) by WISE::IOUtils::make_ipac_tbl at line 1567 # once (294µs+0) by WISE::IOUtils::make_ipac_tbl at line 1563
sub make_ipac_hdr {
5875500.000691.3e-6 my $ipac = shift;
588 my ($last,$hdr,$len,$lbl,$bl,$first,$n,$thissep);
589 my $sep = '|';
590 my $sep1st = '|';
591 my $seplast = '|';
592 local $_;
593
594 if(! $ipac || ! ref $ipac) {
595 warn "*** WRTIPACHDR: No column names or improper hdr.\n";
596 return;
597 }
598
599 #if($ipac->{nohdr}) { return ""; }
600
601 $hdr = "";
602 if(! defined $ipac->{names} || ! @{$ipac->{names}}) { return $hdr; }
603 $last = $#{$ipac->{names}};
604 $ipac->{lens} ||= [];
605 $ipac->{fmts} ||= [];
606 for (0..$last) {
607 $len = $ipac->{lens}[$_];
608 $ipac->{lens}[$_] = $len = 4 if ! $len || $len < 4;
609 my ($fmtlen) = ($ipac->{fmts}[$_] || '') =~ /(\d+)/;
610 $fmtlen+=3 if $fmtlen;
611 $ipac->{lens}[$_] = $len = $fmtlen if $fmtlen && $fmtlen > $len;
612 $ipac->{lens}[$_] = $len = length($ipac->{units}[$_])+1
613 if $ipac->{units}[$_] && length($ipac->{units}[$_]) > $len-1;
614 $lbl = $ipac->{names}[$_];
615 $len = $ipac->{lens}[$_] = length($lbl)+1 if length($lbl)> $len-1;
616 $bl = $ipac->{blanks}[$_]||'';
617 $len = $ipac->{lens}[$_] = length($bl)+1 if length($bl) > $len-1;
618 $thissep = $_==0 ? $sep1st : $sep;
619# print "$_ $ipac->{start}[$_] $len '$lbl' ";
620
621 $ipac->{start}[$_] = length($hdr);
622# print "$ipac->{start}[$_] $len\n";
623 if(length($lbl) < $len-2) { $lbl = " $lbl"; }
624 $hdr .= sprintf("$thissep%-*.*s",$len-1,$len-1,$lbl);
625 }
626 my %has = (
627 types => scalar(grep(defined $_ && length $_,
628 @{$ipac->{types} || []})),
629 blanks => scalar(grep(defined $_ && length $_,
630 @{$ipac->{blanks} || []})),
631 units => scalar(grep(defined $_ && length $_,
632 @{$ipac->{units} || []})),
633 );
634 if($has{types} || $has{blanks} || $has{units}) {
635 $hdr .= "$seplast\n";
636 for (0..$last) {
637 $len = $ipac->{lens}[$_];
638 $lbl = substr((@{ $ipac->{types} || [] })[$_]||"r",0,1);
639 $thissep = $_==0 ? $sep1st : $sep;
640 if(length($lbl) < $len-2) { $lbl = " $lbl"; }
641 $hdr .= sprintf("$thissep%-*.*s",$len-1,$len-1,$lbl);
642 }
643 }
644 if($has{blanks} || $has{units}) {
645 $hdr .= "$seplast\n";
646 for (0..$last) {
647 $len = $ipac->{lens}[$_];
648 $lbl = (@{ $ipac->{units} || [] })[$_] || " ";
649 $thissep = $_==0 ? $sep1st : $sep;
650 if(length($lbl) > $len-1) {
651 warn "*** WRTIPACHDR: Unit string '$lbl' too wide ".
652 "for column '$ipac->{names}[$_]'\n";
653 return;
654 }
655 if(length($lbl) < $len-2) { $lbl = " $lbl"; }
656 $hdr .= sprintf("$thissep%-*.*s",$len-1,$len-1,$lbl);
657 }
658 }
659 if($has{blanks}) {
660 $hdr .= "$seplast\n";
661 for (0..$last) {
662 $len = $ipac->{lens}[$_];
663 $lbl = (@{ $ipac->{blanks} || [] })[$_] // " ";
664 $thissep = $_==0 ? $sep1st : $sep;
665 if(length($lbl) > $len-1) {
666 $first = substr($lbl,0,1);
667 $n = $lbl =~ tr/$first/$first/;
668 if($n == length($lbl)) { $lbl = substr($lbl,0,$len-1); }
669 else {
670 warn "*** WRTIPACHDR: Blank string '$lbl' too wide ".
671 "for column '$ipac->{names}[$_]'\n";
672 return;
673 }
674 }
675 if(length($lbl) < $len-2) { $lbl = " $lbl"; }
676 $hdr .= sprintf("$thissep%-*.*s",$len-1,$len-1,$lbl);
677 }
678 }
679
680 $ipac->{ix}{lc $ipac->{names}[$_]} = $_ for 0..$#{$ipac->{names}};
681
682 $hdr .= "$seplast\n";
683
684 return $hdr;
685}
686
687
# spent 355µs within WISE::IOUtils::make_ipac_keys which was called # once (355µs+0) by WISE::IOUtils::make_ipac_tbl at line 1567
sub make_ipac_keys {
6881720.000342.0e-6 my $keys = shift;
689 my $ttype = shift || 'ipac'; # Doesn't really affect anything right now
690 my ($name,$ref,$type,$val,%keys);
691 my $char = '\\';
692 my $lines = "";
693 local $_;
694 if(! $keys) { return ""; }
695 die "*** $0/MKIPACKEYS: Header keys not an array ref.\n"
696 if ref($keys) !~ /array/i;
697 #eval { %keys = @$keys; }; # local copy, check for pairing
698 #confess "*** $0/MKIPACKEYS: Header keys not paired.\n"
699 # if $@;
700 if(! @$keys) { return ""; }
701 my @keys = @$keys;
702 for my $ref (@keys) {
703 $name = $ref->{name} || '';
704 if($name eq '*BLANK*') { $lines .= "\\\n" x ($ref->{value}||1);
705 next; }
706 if(! $ref->{type}) { $type = ""; }
707 else { $type = $ref->{type}; }
708 $val = defined $ref->{value} ? $ref->{value} :
709 ($type =~ /^c/i ? '<undef>' : -1e+30) ;
710 $val = $type =~ /^c/i ? "'$val'" : $val;
711 $lines .= "\\$name = $val\n";
712 }
713
714 return $lines;
715}
716
717sub make_ipac_row {
718 my $ipac = shift;
719 my $row = shift;
720 my $type = shift || 'ipac';
721 my ($line,$i,$val,$isipac,$name,$n);
722 local $_;
723
724 $line = "";
725 $n = @{$ipac->{names}};
726 for $i (0..$n-1) {
727 $name = lc $ipac->{names}[$i];
728 # Save possible array suffix
729 my ($elem) = $name =~ /\[(.*)\]$/ if $name =~ /\[/;
730 $val = $row->[$i];
731 #print "--- /$i/$name/$elem/$val/\n";
732 if(ref $val) {
733 # If it's a vector column (i.e. if it ends with '[<digits>]') ...
734 if(! $elem) {
735 # Inconsistency
736 warn "*** WRTIPACROW: Inconsistency detected in ".
737 "vectorness of column '$name' ".
738 "(".ref($val).").\n";
739 return;
740 }
741 #print ".1\n";
742 $val = $val->[$elem-1];
743 }
744 #print ".2 /$ipac,$i,$val/\n";
745 if($ipac->{csv}) {
746 $val = ($val//"").$ipac->{csv} ;
747 } else {
748 $val = ipacval($ipac,$i,$val);
749 }
750 #print ".3 /$val/\n";
751 $line .= $val;
752 #print ".4 /".length($line)."/\n";
753 }
754
755 #print ".5\n";
756 return "$line\n";
757}
758
759
# spent 42.1ms (8.12+34.0) within WISE::IOUtils::make_ipac_rows_fast which was called # once (8.12ms+34.0ms) by WISE::IOUtils::make_ipac_tbl at line 1589
sub make_ipac_rows_fast {
760130.042080.00324 my $ipac = shift;
761 my $rows = shift;
762 my $type = shift; # Disregarded
763 my $out = shift || \*STDOUT;
764 my $opts = shift || {};
765 my @cols = map { $rows->{lc $_} || [] } @{ $ipac->{names} };
766 my $lines;
767 if(! $ipac->{csv}) {
768 # Check header
769 if(! $ipac->{types} || ! ref $ipac->{types} ||
770 ! $ipac->{start} || ! ref $ipac->{start} ||
771 ! $ipac->{lens} || ! ref $ipac->{lens} ||
772 (defined $ipac->{blanks} && ! ref $ipac->{blanks}) ||
773 @{$ipac->{types}} != @{$ipac->{start}} ||
774 @{$ipac->{types}} != @{$ipac->{lens}}) {
775 die "*** $0/MKIPACROWSFAST: Improper header.\n",
776 Dumper {map {($_=>$ipac->{$_})}
777 qw/types start lens blanks/};
778 }
779 # Add blanks if necessary
780 if(! $ipac->{blanks} || @{$ipac->{blanks}} != @{$ipac->{types}}) {
781 $ipac->{blanks} = [('') x @{$ipac->{types}}] if ! $ipac->{blanks};
782 push @{$ipac->{blanks}},
783 ('') x (@{$ipac->{types}}-@{$ipac->{blanks}})
784 if @{$ipac->{types}}>@{$ipac->{blanks}};
785 }
786 # Call XS construction routine
787 $lines = WISE::IPACTblXS::construct_ipac_lines(\@cols,
# spent 34.0ms making 1 call to WISE::IPACTblXS::construct_ipac_lines
788 $ipac->{types},
789 $ipac->{start},
790 $ipac->{lens},
791 $ipac->{blanks});
792 } else {
793 $lines = WISE::IPACTblXS::construct_csv_lines(\@cols,$ipac->{csv});
794 }
795 print $out @$lines;
796 return 1;
797}
798
799sub make_ipac_rows {
800 my $ipac = shift;
801 my $rows = shift;
802 my $type = shift;
803 my $out = shift || \*STDOUT;
804 my $opts = shift || {};
805 my $n;
806 local $_;
807 if(! ref $rows) { return 0; }
808 if(ref($rows) =~ /array/i && ! ref $rows->[0]) {
809 # 1 row
810 my $line = make_ipac_row($ipac,$rows,$type);
811 return if ! defined $line;
812 return 0 if ! length $line;
813 print $out $line or return;
814 ++$n;
815 } else {
816 # Many rows or by column
817 if(ref($rows) =~ /hash/i) { # by column
818 # Downcase columns names
819 my $rowslc = { map { (lc($_) => $rows->{$_} ) } keys %$rows };
820 #print "----- /$ipac->{names}[0]/ =? ".
821 # join(",",map{$_."=>/".$rowslc->{lc$_}."/"}keys%$rows).
822 # "\n";
823 my $nlines = 0;
824 for my $col (@{$ipac->{names}}) {
825 my $nincol = keys %$rowslc
826 ? @{ $rowslc->{lc $col} || [] }
827 : 0;
828 $nlines = $nincol if $nincol>$nlines;
829 }
830 # (We want repeats from multiple col[1]-type cols)
831 my @cols = map { /^([^[]+)/; lc($1); } # filter out vector suffix
832 @{$ipac->{names}}; # all names
833 my @row;
834 # Step through each row
835 $n = 0;
836 for my $i (0..($nlines-1)) {
837 # Assemble a row by adding all columns to the row array
838 @row = map { $rowslc->{$_} ? $rowslc->{$_}[$i] : undef } @cols;
839 #select($out); $|=1; select(STDOUT);
840 #print "--- ".@row." cols:\n@{$ipac->{names}}\n@row\n";
841 my $line = make_ipac_row($ipac,\@row,$type);
842 #print " --- length = ".length($line)."\n";
843 #print " --- $line";
844 if(! defined $line) {
845 warn "*** MKIPACROWS: Unable to make output line; $!.\n";
846 return;
847 }
848 return 0 if ! length $line;
849 if(! defined
850 print $out $line
851 ) {
852 warn "*** MKIPACROWS: Unable to print output line; $!.\n";
853 return;
854 }
855 ++$n;
856 #print " --- done: $n\n";
857 }
858 } else { # by row
859 for (@$rows) {
860 my $line = make_ipac_row($ipac,$_,$type) or return;
861 print $out $line or return;
862 ++$n;
863 }
864 }
865 }
866
867 return $n;
868
869}
870
871sub ipacval {
872 my $ipac = shift;
873 my $i = shift;
874 my $val = shift;
875 my $name = $ipac->{names}[$i];
876 my $len = $ipac->{lens}[$i];
877 my $trunc = $ipac->{trunc}[$i];
878 #print "--- /$name/$val/$len/$trunc/$ipac->{fmts}[$i]/".
879 # "$ipac->{types}[$i]/\n";
880 if(defined $val) {
881 if($ipac->{fmts}[$i]) {
882 $val = sprintf($ipac->{fmts}[$i],$val);
883 #print "\tsprintf: /$val/\n";
884 }
885 if(($ipac->{types}[$i]||"r") =~ /^[rfd]/i && length($val) > $len-1) {
886 $val = fitin($val,$len-1);
887 #print "\tfitin: /$val/\n";
888 }
889 if(length($val) > $len-1) {
890 warn "=== $0/IPACVAL: $ipac->{types}[$i] value '$val' too wide ".
891 "for column '$ipac->{names}[$i]: truncated.'\n";
892 $val = substr($val,0,$len-1);
893 }
894 } else {
895 $val = $ipac->{blanks}[$i] // '';
896 }
897 #print "\tsprintf2: /$len/$val/\n";
898 #$val = sprintf("%*.*s",$len,$len,$val);
899 $val = pack("A".($len-1),$val); # Space fill
900 #print "\treturn: /$val/\n";
901 return " $val";
902}
903
904
# spent 74µs within WISE::IOUtils::make_ipac_coms which was called # once (74µs+0) by WISE::IOUtils::make_ipac_tbl at line 1567
sub make_ipac_coms {
90573.5e-55.0e-6 my $ipac = shift;
906 my $coms = shift;
907 my $type = shift || 'ipac'; # Doesn't really affect anything
908 my $char = '\\';
909 my $lines = "";
910 local $_;
911 if(! $coms) { return ""; }
912 for (@{$coms}) {
913 $lines .= "$char ".$_."\n";
914 }
915 return $lines;
916}
917
918sub ipaccol {
919 my $c = shift;
920 my $ipac = shift;
921 my $ix = shift;
922 my $comchar = '#';
923 my @cols = @{$ipac->{names}};
924 my $ic;
925 if($c =~ /^(?:$comchar|@)(\d+)$/) {
926 $ic = $1 - 1;
927 if($ic < 0 || $ic > $#cols) {
928 warn "*** RMCOLS: Column number '$c' out of range.\n";
929 return;
930 }
931 } else {
932 $ic = $ipac->{ix}{lc $c};
933 if(! defined $ic) {
934 warn "*** RMCOLS: Column name '$c' not known.\n";
935 return;
936 }
937 }
938
939 return $ix ? $ic : lc $cols[$ic];
940}
941
942
943sub del_ipac_cols {
944 my $ipac = shift;
945 my @delcols = @_;
946 my $comchar = '#';
947 local $_;
948
949 if(! ref $ipac) { warn "*** DELIPACCOLS: Ipac hdr structure is bad.\n";
950 return; }
951
952 my @rm;
953 my $rm = 0;
954 for (@delcols) {
955 my @cols = @{$ipac->{names}};
956 #print "--- '$_': /@delcols/, /@cols/\n";
957 my $i = ipaccol($_,$ipac,1) // next;
958 #print "want to delete $_:$i:$ipac->{names}[$i]\n";
959 $rm[$i] = 1; # This is how I mark col.s to delete
960 ++$rm;
961 }
962
963 my $i = 0;
964 while($i < @{$ipac->{names}}) {
965 #print "looking at $i/$ipac->{names}[$i]/$ipac->{start}[$i]\n";
966 if(! $rm[$i]) { ++$i; next; }
967 #print "deleting $ipac->{names}[$i]\n";
968 if($ipac->{start}) {
969 my $len = $ipac->{lens}[$i];
970 for (($i+1)..$#{$ipac->{names}}) {
971 if(defined $ipac->{start}[$_]) { $ipac->{start}[$_] -= $len; }
972 }
973 }
974 splice @rm, $i,1;
975 splice @{$ipac->{names}}, $i,1;
976 splice @{$ipac->{types}}, $i,1 if $ipac->{types} && $i<@{$ipac->{types}};
977 splice @{$ipac->{blanks}},$i,1 if $ipac->{blanks} && $i<@{$ipac->{blanks}};
978 splice @{$ipac->{units}}, $i,1 if $ipac->{units} && $i<@{$ipac->{units}};
979 splice @{$ipac->{fmts}}, $i,1 if $ipac->{fmts} && $i<@{$ipac->{fmts}};
980 splice @{$ipac->{start}}, $i,1 if $ipac->{start} && $i<@{$ipac->{start}};
981 splice @{$ipac->{lens}}, $i,1 if $ipac->{lens} && $i<@{$ipac->{lens}};
982 }
983
984 $ipac->{ix} = ();
985 @{$ipac->{ix}}{map { lc $_ } @{$ipac->{names}}} = (0..$#{$ipac->{names}});
986
987 return $rm;
988}
989
990
991sub copy_ipac_hdr {
992 my $ipac = shift;
993
994 return {
995 names => [@{$ipac->{names}}],
996 types => [@{$ipac->{types}}],
997 blanks => [@{$ipac->{blanks}}],
998 units => [@{$ipac->{units}}],
999 fmts => [@{$ipac->{fmts}}],
1000 start => [@{$ipac->{start}}],
1001 lens => [@{$ipac->{lens}}],
1002 ix => {%{$ipac->{ix}}},
1003 file => $ipac->{file},
1004 comments=> [@{$ipac->{comments}}]
1005 }
1006}
1007
1008sub merge_ipac_hdrs {
1009 my $ipac1 = shift;
1010 my $ipac2 = shift;
1011 my $opts = shift || {};
1012 my $joincol = $opts->{joincol};
1013 my $nodups= $opts->{nodups};
1014 my @joincol;
1015 if($joincol) {
1016 if(! ref $joincol) {
1017 $joincol = [$joincol,$joincol];
1018 }
1019 @joincol = @$joincol;
1020 $_ = lc($_) for @joincol;
1021 }
1022 my $rows1 = $opts->{rows1};
1023 my $rows2 = $opts->{rows2};
1024
1025 my @ix1 = (grep {! $rows1 || $rows1->{lc $ipac1->{names}[$_]}}
1026 0..$#{$ipac1->{names}});
1027 my @names1 = map {lc} @{$ipac1->{names}}[@ix1];
1028 my %in1 = map { ($_=>1) } @names1;
1029 my @ix2 = (grep {
1030 (# Keep if in row data (or there's no row data)
1031 ! $rows2 || $rows2->{lc $ipac2->{names}[$_]}) &&
1032 (# Keep if not a dup and not the join col.
1033 # (or don't care about dups)
1034 ! $nodups ||
1035 (! $in1{lc $ipac2->{names}[$_]} &&
1036 lc $ipac2->{names}[$_] ne $joincol[1]))
1037 }
1038 0..$#{$ipac2->{names}});
1039 my @names2 = map {lc} @{$ipac2->{names}}[@ix2];
1040
1041 if(! @names2) {
1042 warn "*** MRGIPACHDRS: All columns in ".
1043 "file 1 (".($ipac1->{file}//"?").") also in ".
1044 "file 2 (".($ipac2->{file}//"?").").\n";
1045 return;
1046 }
1047
1048 # Rename common columns
1049 for my $col (@names2) {
1050 $col .= "_2" if $in1{lc $col};
1051 }
1052
1053 my $mrgipac = {
1054 names => [@names1, @names2],
1055 types => [@{$ipac1->{types}}[@ix1], @{$ipac2->{types}}[@ix2]],
1056 blanks => [@{$ipac1->{blanks}}[@ix1], @{$ipac2->{blanks}}[@ix2]],
1057 units => [@{$ipac1->{units}}[@ix1], @{$ipac2->{units}}[@ix2] ],
1058 fmts => [@{$ipac1->{fmts}}[@ix1], @{$ipac2->{fmts}}[@ix2] ],
1059 lens => [@{$ipac1->{lens}}[@ix1], @{$ipac2->{lens}}[@ix2] ],
1060 file => ($ipac1->{file}//"?")."+".($ipac2->{file}//"?"),
1061 nrows => $ipac1->{nrows},
1062 };
1063 {
1064 my $s = 0;
1065 $mrgipac->{start} = [0, (map { $s+=$_; $s; }
1066 @{$mrgipac->{lens}}[0..$#{$mrgipac->{lens}}-1])];
1067 }
1068 @{$mrgipac->{ix}}{@{$mrgipac->{names}}} = 0..$#{$mrgipac->{names}};
1069
1070 return $mrgipac;
1071}
1072
1073sub merge_ipac_tbls {
1074 my $rows1 = shift;
1075 my $ipac1 = shift;
1076 my $rows2 = shift;
1077 my $ipac2 = shift;
1078 my $opts = shift || {};
1079 my $joincol = $opts->{joincol};
1080 my @joincol;
1081 if($joincol) {
1082 if(! ref $joincol) {
1083 $joincol = [$joincol,$joincol];
1084 }
1085 @joincol = @$joincol;
1086 $_ = lc($_) for @joincol;
1087 }
1088
1089 my $ipac = merge_ipac_hdrs($ipac1,$ipac2,
1090 {rows1=>$rows1, rows2=>$rows2,
1091 joincol=>\@joincol})
1092 or return;
1093 my %rows;
1094 # Join on a column?
1095 if($rows1 && $rows2 && @joincol &&
1096 $rows1->{$joincol[0]} && $rows2->{$joincol[1]}) {
1097 my @cols2 = keys %$rows2;
1098 @cols2 = grep { $_ ne $joincol[1] } @cols2
1099 if $joincol[0] eq $joincol[1];
1100 my %new;
1101 my %joinval2;
1102 # Cache join locations in file 2; last entry wins for common keys
1103 for my $j (0..$#{$rows2->{$joincol[1]}}) {
1104 if(defined $rows2->{$joincol[1]}[$j] && length $rows2->{$joincol[1]}[$j]) {
1105 $joinval2{lc $rows2->{$joincol[1]}[$j]} = $j;
1106 }
1107 }
1108 for my $i (0..$ipac1->{nrows}-1) {
1109 my $joinval1 = $rows1->{$joincol[0]}[$i];
1110 my $match;
1111 if(defined $joinval1 && length $joinval1) {
1112 $match = $joinval2{lc $joinval1};
1113 }
1114 if(defined $match && length $match) {
1115 push @{$new{$_}}, $rows2->{$_}[$match] for @cols2;
1116 } else {
1117 push @{$new{$_}}, undef for @cols2;
1118 }
1119 }
1120 $rows2 = \%new;
1121 $ipac2->{nrows} = $ipac1->{nrows};
1122 }
1123 if($rows1) {
1124 if($ipac1->{nrows} != $ipac2->{nrows}) {
1125 warn "=== MRGIPACTBLS: Row counts differ between ".
1126 "'$ipac1->{file}' and '$ipac2->{file}'.\n";
1127 return;
1128 }
1129 %rows = (%$rows1, %$rows2);
1130 }
1131 $ipac->{nrows} = $ipac1->{nrows};
1132 return %rows ? (wantarray ? (\%rows,$ipac) : \%rows) : $ipac;
1133}
1134
1135sub add_ipac_cols {
1136 my $ipac = shift;
1137 my $cols = shift;
1138 my ($name,$type,$blank,$unit,$fmt,$after,$nmlen);
1139 my $added = 0;
1140 my $comchar = '#';
1141 my (@toadd,$start,$len);
1142
1143 if(defined $ipac && ! ref $ipac) {
1144 warn "*** ADDIPACCOLS: Ipac hdr structure is bad.\n";
1145 return;
1146 }
1147
1148 if(! defined $ipac) {
1149 $ipac = { names=>[],
1150 types=>[],
1151 blanks=>[],
1152 units=>[],
1153 fmts=>[],
1154 start=>[],
1155 len=>[],
1156 ix=>{},
1157 file=>"",
1158 comments=>[]
1159 };
1160 }
1161
1162 if(! ref $cols) { $cols = [[$cols]]; }
1163 elsif (! ref $cols->[0]) { $cols = [$cols]; }
1164
1165 for (@$cols) {
1166 ++$added;
1167 ($name,$type,$fmt,$after,$blank,$unit) = @$_;
1168 if(! defined $name) {
1169 warn "*** ADDIPACCOLS: Unknown column name '$name'.\n";
1170 return;
1171 }
1172 if(! defined $type || $type eq "") { $type = "r"; }
1173 if(! defined $fmt) { $fmt = ""; }
1174 if(! defined $after || $after eq "") { $after = $#{$ipac->{names}} }
1175 elsif($after =~ /^[$comchar@](\d+)$/) {
1176 $after = $1 - 1;
1177 } else {
1178 if(! defined $ipac->{ix}{lc $after}) {
1179 warn "*** ADDIPACCOLS: After-col '$after' not known.\n";
1180 return;
1181 }
1182 $after = $ipac->{ix}{lc $after};
1183 }
1184 if(! defined $blank) { $blank = ""; }
1185 if(! defined $unit) { $unit = ""; }
1186# print "Adding $name,$type,$fmt,$after,$blank,$unit\n";
1187 push @toadd,[$name,$type,$fmt,$after,$blank,$unit];
1188 }
1189 @toadd = sort { $a->[3] <=> $b->[3] } @toadd;
1190 for my $i (0..$#toadd) {
1191 $len = undef;
1192 ($name,$type,$fmt,$after,$blank,$unit) = @{$toadd[$i]};
1193# print "Adding $name,$type,$fmt,$after,$blank,$unit\n";
1194 splice @{$ipac->{names}},$after+1,0,$name;
1195 splice @{$ipac->{types}},$after+1,0,$type;
1196 splice @{$ipac->{blanks}},$after+1,0,$blank;
1197 splice @{$ipac->{units}},$after+1,0,$unit;
1198 if($fmt =~ /^[+-]?\d+$/) { $len = $fmt; $fmt = ""; }
1199 elsif($fmt =~ /^%[+-]?(\d+)/) { $len = $1+1; }
1200 if($ipac->{fmts}) {
1201 splice @{$ipac->{fmts}},$after+1,0,$fmt;
1202 }
1203 $nmlen = length($name);
1204 $len = $len ? $len : ($nmlen>=8 ? $nmlen : 8 );
1205 $len = $len>0 ? $len+1 : max(-$len,$nmlen)+1;
1206 if($ipac->{lens} && $ipac->{start}) {
1207 splice @{$ipac->{lens}},$after+1,0,$len;
1208 $start = $after>=0
1209 ? $ipac->{start}[$after]+$ipac->{lens}[$after] : 0;
1210 splice @{$ipac->{start}},$after+1,0,$start;
1211 for (($after+1)..$#{$ipac->{start}}) {
1212 $ipac->{start}[$_] += $len;
1213 }
1214 }
1215 for (($i+1)..$#toadd) { ++$toadd[$_][3]; }
1216 }
1217 @{$ipac->{ix}}{map { lc $_ } @{$ipac->{names}}} = (0..$#{$ipac->{names}});
1218
1219 return $ipac;
1220}
1221
1222sub fits_to_ipac {
1223 my $infits = shift;
1224 my $outipac = shift;
1225 my $opts = shift || {};
1226 my $nohdr = $opts->{nohdr};
1227 my $nokeys = $opts->{nokeys};
1228 print "Converting '$infits' to IPAC table '$outipac' ...\n"
1229 if $opts->{verbose};
1230 my $meta = fitsmeta_to_ipac($infits,$opts) or return;
1231 #print Dumper $meta;
1232 my $data = $opts->{data};
1233 if(! $opts->{hdronly}) {
1234 my @ipaccols = @{ $meta->{ipac}{names} };
1235 my @fitscols = @{ $meta->{ipac}{fitscols} };
1236 if(! $data) {
1237 print " Reading rows ...\n" if $opts->{verbose};
1238 $data = $meta->{fits}->readcols(\@fitscols,
1239 {hdunum=>$opts->{hdunum}||2});
1240 } else {
1241 $data = { map { ($_ => $data->{$_}) } @fitscols };
1242 }
1243 }
1244 print " Writing table ...\n" if $opts->{verbose};
1245 my $rc = make_ipac_tbl($outipac,
1246 $meta->{ipac},
1247 ($nokeys?undef:$meta->{keys}),
1248 $data
1249 );
1250
1251 print "Convertion complete.\n"
1252 if $opts->{verbose};
1253
1254 return $rc;
1255}
1256
1257sub fitsmeta_to_ipac {
1258 my $fitsfile = shift;
1259 my $opts = shift || {};
1260 my $hdunum = $opts->{hdunum} || 2;
1261 my $keyhdunum= $opts->{keyhdunum} || 1;
1262 my $cols = $opts->{cols} || '*';
1263 my $not = $opts->{not} || [];
1264 my $keys = $opts->{keys};
1265 my $err = "*** $0/FITSTOIPAC";
1266 my $warn = "=== $0/FITSTOIPAC";
1267 $not = [$not] if $not && ! ref $not;
1268 my %not = map { (lc($_) => 1) } @$not;
1269 my $fits;
1270 if(ref $fitsfile) {
1271 $fits = $fitsfile;
1272 $fitsfile = $fits->file();
1273 } else {
1274 $fits = WISE::FITSIO->new($fitsfile,{mode=>'r'})
1275 or warn("$err: Error opening FITS file '$fitsfile'.\n"),
1276 return;
1277 }
1278 $fits->hdunum($hdunum);
1279 $cols = '*' if ref($cols) && ! @$cols;
1280 my $colinfo = $fits->colinfo($cols);
1281 $colinfo->{lc $_} = $colinfo->{$_} for keys %$colinfo;
1282 my @cols = (map { $colinfo->{lc $_}{name} }
1283 map { $fits->colnames($_) }
1284 (ref $cols ? @$cols : $cols) );
1285 #print "---- /@cols/\n";
1286 my (@badcols,@newcols);
1287 {
1288 for my $col (@cols) {
1289 my $collc = lc $col;
1290 next if $not{$collc};
1291 #print "/$col/$collc/ => ",Dumper $colinfo->{$collc};
1292 $colinfo->{$collc}{ipactype} =
1293 fits_coltype_to_ipac($colinfo->{$collc}{type});
1294 if(! $colinfo->{$collc}{ipactype}) {
1295 push @badcols, $col;
1296 next;
1297 }
1298 my @add;
1299 if($colinfo->{$collc}{repeat} && $colinfo->{$collc}{repeat} > 1
1300 &&
1301 lc($colinfo->{$collc}{type}) ne 'a') {
1302 @add = map { "$col\[$_\]" } 1..$colinfo->{$collc}{repeat};
1303 } else {
1304 @add = ($col);
1305 }
1306 for my $addcol (@add) {
1307 my $addlc = lc $addcol;
1308 push @newcols, $addcol;
1309 if($addcol ne $col) {
1310 $colinfo->{$addlc} = { %{$colinfo->{lc $col}} };
1311 $colinfo->{$addlc}{name} = $addcol;
1312 }
1313 ($colinfo->{$addlc}{len})
1314 = (lc($colinfo->{$addlc}{type}) eq 'a'
1315 ? ($colinfo->{$addlc}{repeat} || 1)
1316 : ($colinfo->{$addlc}{disp} =~ /(\d+)/));
1317 $colinfo->{$addlc}{len}+=3 if $colinfo->{$addlc}{len};
1318 $colinfo->{$addlc}{fmt} =
1319 fits_fmt_to_ipac($colinfo->{$addlc}{ipactype},
1320 $colinfo->{$addlc}{disp});
1321 }
1322 if(@add > 1) {
1323 delete $colinfo->{$collc};
1324 }
1325 }
1326 warn "$warn: Cannot convert these columns: @badcols.\n"
1327 if @badcols;
1328 warn("$warn: No columns selected.\n"), return
1329 if ! @newcols;
1330 }
1331 # Fix weird bug in sextractor output
1332 if(($colinfo->{ERRA_IMAGE}{unit}||'') =~ /stat\.max/) {
1333 $colinfo->{ERRA_IMAGE}{unit} = $colinfo->{erra_image}{unit} = 'pixel';
1334 }
1335 my $ipac = {
1336 fitscols=>\@cols,
1337 names => [map {$colinfo->{lc $_}{name}} @newcols],
1338 types => [map {$colinfo->{lc $_}{ipactype}} @newcols],
1339 lens => [map {$colinfo->{lc $_}{len}} @newcols],
1340 fmts => [map {lc ($colinfo->{lc $_}{fmt}||'')} @newcols],
1341 units => [map {$colinfo->{lc $_}{unit}} @newcols],
1342 };
1343 my $hdr = $fits->key(["*"],{hdunum=>$keyhdunum,full=>1});
1344 my @keys;
1345 my %keysok;
1346 @keysok{@$keys} = (1) x @$keys if $keys;
1347 for my $key (@$hdr) {
1348 next if grep {$key->{name} =~ /^$_$/i}
1349 qw(simple bitpix naxis naxis1 naxis2 end extend xtension
1350 longstrn extname);
1351 next if ! defined $key->{value} || $key->{value} =~ /^\s*$/;
1352 next if $keys && ! $keysok{lc $key};
1353 push @keys, {name=>$key->{name},value=>$key->{value},
1354 type=>fits_keytype_to_ipac($key->{type})};
1355 }
1356
1357 return wantarray ? ($ipac,\@keys) : {ipac=>$ipac, keys=>\@keys,
1358 fits=>$fits, cols=>\@newcols};
1359}
1360
1361sub fits_coltype_to_ipac {
1362 my $ftype = shift;
1363 my ($n,$type,$form) = $ftype =~ /^\s*(\d*)(\D+)([\d.]*)\s*$/;
1364 die "*** $0/FITSTYPE: Can't parse FITS type '$ftype'.\n"
1365 if ! $type;
1366 my $itype = {d=>'r', e=>'r', f=>'r', g=>'r',
1367 b=>'i', i=>'i', j=>'i', k=>'i', u=>'i', v=>'i', 's'=>'i',
1368 a=>'c'}->{lc $type};
1369 return if ! $itype;
1370 return $itype;
1371}
1372
1373sub ipac_to_fits {
1374 my $inipac = shift;
1375 my $outfits = shift;
1376 my $opts = shift || {};
1377 my $infile = $inipac->{file}//"<unknown>";
1378 print "Converting '$infile' to FITS table '$outfits' ...\n"
1379 if $opts->{verbose};
1380 my ($meta,$keys) = ipacmeta_to_fits($inipac,$opts) or return;
1381 #print Dumper $meta;
1382 my $data = $opts->{data};
1383 print " Creating FITS file ...\n" if $opts->{verbose};
1384 # Add some header data
1385 push @$keys, ({name=>'IPACNAME', value=>$infile, type=>'C'},
1386 {name=>'CNVDATE' , value=>scalar(localtime()), type=>'C'},
1387 );
1388 my $hdudef = [
1389 $keys, # HDU #1
1390 [ # HDU #2
1391 {name => 'XTENSION',
1392 value=> 'BINTABLE',
1393 type => 'C'},
1394 @$meta,
1395 ]
1396 ];
1397 print "HDUdef=",Dumper $hdudef if $opts->{debug};
1398 my $fits = WISE::FITSIO->new($outfits,
1399 {
1400 mode=>'new',
1401 hdudef=>$hdudef,
1402 }
1403 )
1404 or die;
1405 my @fitscols = $fits->colnames('*',{hdunum=>$opts->{hdunum}||2});
1406 if(! $opts->{hdronly} ) {
1407 if(! $data) {
1408 print " Reading rows ...\n" if $opts->{verbose};
1409 ($data) = slurp_ipac_tbl($inipac) or die;
1410 #print "Read rows ",join(",",keys%$data),"\n";
1411 }
1412 $data = { map { ($_ => $data->{$_}) } @fitscols };
1413 print " Writing rows ...\n" if $opts->{verbose};
1414 $fits->writecols($data,{hdunum=>$opts->{hdunum}||2}) or die;
1415 }
1416
1417 print "Convertion complete.\n"
1418 if $opts->{verbose};
1419
1420 return $fits;
1421}
1422
1423sub ipacmeta_to_fits {
1424 my $ipacfile = shift;
1425 my $opts = shift || {};
1426 my $not = $opts->{not} || [];
1427 my $cols = $opts->{cols};
1428 my $keys = $opts->{keys};
1429 my $err = "*** $0/IPACTOFITS";
1430 my $warn = "=== $0/IPACTOFITS";
1431 $not = [$not] if $not && ! ref $not;
1432 my %not = map { (lc($_) => 1) } @$not;
1433 my ($meta,$hdrkeys);
1434 if(ref $ipacfile) {
1435 $meta = $ipacfile;
1436 $ipacfile = $meta->{file};
1437 } else {
1438 (undef,$meta,$hdrkeys) = WISE::IOUtils::slurp_ipac_tbl($ipacfile,
1439 {hdronly=>1})
1440 or warn("$err: Error opening IPAC file '$ipacfile'.\n"),
1441 return;
1442 }
1443 my %names = map { (lc($_) => $_) } @{ $meta->{names} };
1444 my %types = map { (lc($meta->{names}[$_]) => $meta->{types}[$_]) }
1445 0..$#{ $meta->{names} };
1446 my %lens = map { (lc($meta->{names}[$_]) => $meta->{lens}[$_]) }
1447 0..$#{ $meta->{names} };
1448 my @cols = (map { $names{lc $_} }
1449 ($cols ? @$cols : @{ $meta->{names} }) );
1450 my @fitshdu;
1451 my $colnum = 0;
1452 for my $col (@cols) {
1453 ++$colnum;
1454 my $itype = $types{lc $col};
1455 my $ftype = ipac_coltype_to_fits($itype)
1456 or die "$err: IPAC column type '$itype' is unknown.\n";
1457 my $len = $ftype eq 'A' ? $lens{lc $col} : '1';
1458 push @fitshdu, {name=>"TTYPE$colnum", value=>$col, type=>'C'},
1459 {name=>"TFORM$colnum", value=>$len.$ftype, type=>'C'};
1460 }
1461
1462 my %keysok;
1463 if($keys) {
1464 $keys = [$keys] if ! ref $keys;
1465 @keysok{map {lc $_} @$keys} = @$keys;
1466 }
1467 my @keys;
1468 for my $key (@$hdrkeys) {
1469 next if grep {$key->{name} =~ /^$_$/i}
1470 qw(simple bitpix naxis naxis1 naxis2 end extend xtension
1471 longstrn extname);
1472 next if ! defined $key->{value} || $key->{value} =~ /^\s*$/;
1473 next if $keys && ! $keysok{lc $key};
1474 push @keys, {name=>$key->{name},value=>$key->{value},
1475 type=>ipac_keytype_to_fits($key->{value},
1476 $key->{type}),
1477 };
1478 }
1479
1480 return ([{name=>'TFIELDS',value=>$colnum, type=>'I'},@fitshdu],\@keys);
1481}
1482
1483sub fits_keytype_to_ipac {
1484 my $ftype = shift;
1485 return '' if ! $ftype;
1486 return {'c'=>'CHAR', 'l'=>'CHAR', 'i'=>'INT', 'f'=>'REAL', 'x'=>'CHAR'}
1487 ->{lc $ftype} || '';
1488}
1489sub fits_fmt_to_ipac {
1490 my $ipactype= shift;
1491 my $ffmt = shift;
1492 return if ! $ffmt && (! $ipactype || lc($ipactype) eq 'c'); # !!!!
1493 if($ffmt) {
1494 my ($f,$sz,$dp) = $ffmt =~ /^([EFGIA])(\d+)(?:\.(\d+))?$/;
1495 warn("=== FITSFMT: Format '$ffmt' not known.\n"), return if ! $f;
1496 return "%".($sz+2).(defined $dp && length $dp?".$dp":"").lc($f);
1497 } else {
1498 return $ipactype=~/[r]/i ? "%14.8g" : "%10d";
1499 }
1500}
1501
1502sub ipac_coltype_to_fits {
1503 my $itype = shift;
1504 return 'a' if $itype =~ /date/i;
1505 ($itype) = $itype =~ /^\s*(\S)/;
1506 my $ftype = {r=>'D', d=>'D', f=>'F', i=>'J', c=>'A'}->{lc $itype};
1507 return if ! $ftype;
1508 return $ftype;
1509}
1510sub ipac_keytype_to_fits {
1511 my $val = shift;
1512 my $itype = shift;
1513 my $ftype;
1514 if($itype) {
1515 ($itype) = $itype =~ /^\s*(\S)/;
1516 $ftype = {'c'=>'C', 'i'=>'I', 'r'=>'F', 'f'=>'F', 'd'=>'F'}
1517 ->{lc $itype} || '';
1518 }
1519 #print "/$val/$itype/$ftype/\n";
1520 if(defined $val && ! $ftype) {
1521 my $fpre = fpre(1);
1522 if($val=~/^[-+]?\d+$/) { return 'I'; }
1523 elsif($val=~/^$fpre$/) { return 'F'; }
1524 else { return 'C'; }
1525 } else {
1526 return '' if ! $ftype;
1527 return $ftype;
1528 }
1529}
1530
1531
# spent 67.1ms (23.8+43.3) within WISE::IOUtils::make_ipac_tbl which was called 2 times, avg 33.5ms/call: # once (19.4ms+42.4ms) by WISE::IPACTbl::data_out at line 642 of /wise/base/deliv/dev/lib/perl/WISE/IPACTbl.pm # once (4.39ms+898µs) by WISE::IPACTbl::new at line 203 of /wise/base/deliv/dev/lib/perl/WISE/IPACTbl.pm
sub make_ipac_tbl {
1532520.023930.00046 my $file = shift;
1533 my $ipac = shift;
1534 my $keys = shift;
1535 my $data = shift;
1536 my $opts = shift || {};
1537 my $noclose = $opts->{noclose};
1538 my $type = $opts->{type};
1539 my $com = $opts->{com};
1540 my $nohdr = $opts->{nohdr} || $opts->{append};
1541 my $lc = $opts->{lc};
1542 my $fast = $opts->{fast};
1543 my ($out,$rc,$n,$ref);
1544
1545 if(! defined $file) { return 0; } # No o/p defined
1546 elsif(ref $file) { $out = $file; } # A filehandle glob was passed
1547 elsif($file eq "-") { $out = \*STDOUT; } # o/p to stdout
1548 else { # open a file for o/p
1549 my $ap = $opts->{append} ? '>>' : '>';
1550 if(! open($out,"$ap$file")) {
1551 warn "*** MKTBL: Couldn't open '$ap$file'; $!\n";
1552 return;
1553 }
1554 }
1555 my $stdout = 1
1556 if fileno($out) == fileno(\*STDOUT) ||
1557 fileno($out) == fileno(\*STDERR);
1558 $noclose ||= $stdout || $opts->{append};
1559
1560 if(! $ipac) { return $out; } # Just open and return
1561 # Always need to finish construction the header info unless
1562 # appending or CSV'ing
1563 if($nohdr && ! $opts->{csv} && ! $opts->{append}) {
# spent 294µs making 1 call to WISE::IOUtils::make_ipac_hdr
1564 make_ipac_hdr($ipac,$type);
1565 }
1566 if(! $nohdr) {
1567 if(! ( (defined ($rc=make_ipac_coms($ipac,$com,$type)) &&
# spent 416µs making 1 call to WISE::IOUtils::make_ipac_hdr # spent 355µs making 1 call to WISE::IOUtils::make_ipac_keys # spent 74µs making 1 call to WISE::IOUtils::make_ipac_coms
1568 print $out $rc ) &&
1569 (defined ($rc=make_ipac_keys($keys,$type)) &&
1570 print $out $rc ) &&
1571 (defined ($rc=make_ipac_hdr($ipac,$type)) &&
1572 print $out $rc )
1573 )
1574 ) {
1575 warn "*** MKTBL: Hdr write failure for o/p table '$file'; $!\n";
1576 return;
1577 }
1578 }
1579 if($data && ref($data) !~ /hash/i) {
1580 warn "*** MKTBL: Don't know what to do with data of ".
1581 (ref($data) ? "$data" : "scalar").".\n";
1582 return;
1583 }
1584 if($data && keys %$data) {
1585 # Only try to write data if there is any
1586 if(! $fast) {
1587 $rc = make_ipac_rows($ipac,$data,$type,$out);
1588 } else {
1589 $rc = make_ipac_rows_fast($ipac,$data,$type,$out);
# spent 42.1ms making 1 call to WISE::IOUtils::make_ipac_rows_fast
1590 }
1591 if(! defined $rc) {
1592 warn "*** MKTBL: Row creation failure for o/p table '$file'; $!\n";
1593 return;
1594 }
1595 }
1596 if($noclose) {
1597 # Flush and return
1598 $out->flush(); # Don't know why I can't do this to stdout
# spent 53µs making 1 call to IO::Handle::flush
1599 return $out;
1600 } else {
1601 close $out or
1602 warn "*** MKTBL: Write failure (on close) for o/p table '$file'; $!\n";
1603 return 1;
1604 }
1605
1606}
1607
1608
1609# =========================================================================
1610#
1611# Some routines to read and organize a standard pipeline log file
1612
1613sub slurp_log_file {
1614 my $log = shift;
1615 my $opts = shift||{};
1616 my $fh;
1617
1618 if(! open($fh,"<$log")) {
1619 warn "*** $0/SLURPLOG: Can't read $log; $!" if ! $opts->{quiet};
1620 return;
1621 }
1622 local $/=undef;
1623 return parse_log_file(scalar(<$fh>),{file=>$log, %$opts});
1624}
1625
1626
1627sub parse_log_file {
1628 my $log = shift;
1629 my $opts= shift || {};
1630 my $tag = $opts->{tag} || ">>>>";
1631 my $debug = $opts->{debug} || 0;
1632 my $tagre = quotemeta $tag;
1633 my ($warn,$fix,$save); # options
1634 my ($up);
1635 local $.;
1636
1637 $warn = ! $opts->{quiet};
1638 $fix = ! $opts->{nofix};
1639 $save = $opts->{save_out};
1640
1641 # First pre-filter by inserting a newline if the tag occurs in the
1642 # middle of a line (due to asynchronous stdout/stderr output)
1643 $log =~ s/(?<=[^\n])($tagre\s[^\n]+iam=>)/\n$1/g;
1644 $log =~ s/(?<=[^\n])($tagre\+\s)/\n$1/g;
1645 # Next, join lines prefixed with $tag+ into one
1646 # long line
1647 $log =~ s/\n+$tagre\+\s//sg;
1648 # Now break the log into chunks separated by $tag
1649 my @chunks = split(/\n$tagre\s+/,$log);
1650 # Now match up start/end chunks and eval the embedded data
1651 my (@ids,@stack);
1652 @stack = (0);
1653 $ids[0] = {lines=>[], seq=>0, depth=>0, up=>undef, pid=>-1, ppid=>-1,
1654 host=>"<none>",starttime=>"",id=>"Top",
1655 endtime=>"", status=>0, retcode=>0, signal=>0};
1656 my $n = 0;
1657 $. = 0;
1658 print "Nchunks = ".@chunks."\n" if $debug;
1659 for (@chunks) {
1660 ++$.;
1661 my (@lines) = split /\n/;
1662 print "Line $. = '$lines[0]'\n" if $debug;
1663 my ($metastr,$meta,$state);
1664 shift @lines while @lines && ! $lines[0];
1665 $metastr = $lines[0];
1666 next if ! @lines;
1667 print "\tMetastr line $. = '$metastr'\n" if $debug;
1668 $metastr =~ s/^(START|END|STEP)\s// && ($state = $1);
1669 if(! $state) {
1670 if($n == 0) {
1671 push @{$ids[0]{lines}},$metastr;
1672 push @{$ids[0]{lines}},@lines if $save;
1673 next;
1674 } else {
1675 die "*** $0/PARSELOG: State not recognized from '".
1676 substr($metastr,0,20)."'\n";
1677 }
1678 } else { # Nothing to do here really
1679 #print "$state -- /$metastr/\n";
1680 }
1681 # Get meta-data
1682 $meta = eval "{ $metastr }";
1683 die "*** $0/PARSELOG: Unable to parse chunk $n.\n$@".
1684 " chunk='$metastr'\n" if $@;
1685 # Get process identifier
1686 my $id = get_log_proc_id($meta);
1687 if($state eq "START") {
1688 # Found a start tag
1689 # Consistency check and optional repair
1690 ++$n;
1691 if(@stack>1 &&
1692 ($ids[$stack[-1]]{host} ne $meta->{host} ||
1693 int($ids[$stack[-1]]{pid}) != int($meta->{ppid}))
1694 ) {
1695 # Consistency check failed
1696 warn "=== $0/PARSELOG: No end tag for item $stack[-1] ".
1697 "($ids[$stack[-1]]{id}) in file '".($opts->{file}||'?').
1698 "'; now=$id.\n",
1699 if $warn && ! $ids[$stack[-1]]{noend};
1700 $ids[$stack[-1]]{noend} = 1;
1701 if($fix) { # Let's fix it up
1702 # Pretend we did find an end tag
1703 @{$ids[$stack[-1]]}{qw/endtime status signal retcode/} =
1704 ($meta->{starttime},-999,-999,-999);
1705 pop @stack; # Pop stack
1706 }
1707 }
1708 $ids[$n] = $meta;
1709 # Robustly find parent
1710 ($up) = grep(int($ids[$_]{pid}) == int($meta->{ppid}) &&
1711 $ids[$_]{host} eq $meta->{host},
1712 reverse @stack);
1713 $up //= 0;
1714 warn "=== $0/PARSELOG: No parent found for item $n ".
1715 "($id) in file '".($opts->{file}||'?').".\n",
1716 if $warn && $up == 0 && $n > 1;
1717 # There might be handling if this is a spawn tag
1718 my $spawn = $meta->{iam} =~ /^spawn_/i;
1719 # Save more info
1720 @{$meta}{qw/id depth seq up kids n state spawn/} =
1721 ($id,scalar(@stack),$n,$up,[],$n,$state,$spawn);
1722 push @{$meta->{lines}},@lines if $save;
1723 push @{$ids[$up]{kids}},$n if $up >= 0;
1724 push @stack,$n;
1725 } elsif($state eq 'END') { # END
1726 # Found an end tag
1727 my $start = $stack[-1];
1728 die "*** $0/PARSELOG: No entry for $start at END tag\n"
1729 if ! $ids[$start];
1730 if($ids[$start]{id} eq $id) {
1731 # Matched our parent
1732 #print "Pop $stack[-1]!\n";
1733 pop @stack;
1734 $up = $stack[-1];
1735 } else {
1736 # ... otherwise another error message should catch the problem.
1737 # But we must assign the lines to the correct parent anyway
1738 ($up) = grep($ids[$_]{pid} == $ids[$start]{ppid} &&
1739 $ids[$_]{host} eq $ids[$start]{host},
1740 reverse @stack);
1741 $up ||= 0;
1742 # ... and we must try to find the right start tag
1743 ($start) = grep {$id eq $ids[$_]{id}} reverse @stack;
1744 }
1745 if(defined $start) {
1746 # Add new meta info not in the START tag, but don't allow
1747 # override of start tag info
1748 %{$ids[$start]} = (%$meta,%{$ids[$start]});
1749 # Override certain values
1750 @{$ids[$start]}{qw/endtime status signal retcode/} =
1751 (@{$meta}{qw/endtime status/},
1752 (defined $meta->{signal}
1753 ? $meta->{signal}
1754 : ($meta->{status}&255)),
1755 (defined $meta->{retcode}
1756 ? $meta->{retcode}
1757 : ($meta->{status}>>8))
1758 );
1759 }
1760 # Save new o/p lines, maybe
1761 push @{$ids[$up]{lines}},@lines if $save;
1762 } elsif($state eq 'STEP') {
1763 # Add (or nullify) step name to previous START block
1764 my $start = $stack[-1];
1765 die "*** $0/PARSELOG: No entry for $start at STEP tag\n"
1766 if ! $ids[$start];
1767 $ids[$start]{step} = $meta->{step};
1768 }
1769 }
1770
1771 # Integrity check
1772 if(@stack) {
1773 if($warn) {
1774 warn "=== $0/PARSELOG: Unterminated START tag for item ",
1775 "$_->{n} ($_->{id}) in file '".($opts->{file}||'?')."'.\n"
1776 for grep {! defined $_->{endtime}} @ids;
1777 }
1778 }
1779
1780 return \@ids;
1781}
1782
1783sub get_log_proc_id {
1784 return "" if ! $_[0]{iam};
1785 return join("-",@{$_[0]}{qw/iam host pid starttime/});
1786}
1787
1788# Walk log process tree depth first
1789sub print_log_tree_depth {
1790 my $ids = shift;
1791 my $top = shift || 0;
1792 my $opts = shift || {};
1793 my $out = $opts->{out}; # Print o/p
1794 my $lines= ! $opts->{nolines}; # Don't print guide lines
1795 my ($ls,$le,$p,$d,$e,$lt);
1796 if(! ref $ids) {
1797 # As a convenience feature, take a non-ref as a file name to parse
1798 $ids = slurp_log_file($ids,$opts);
1799 }
1800 my @kids = @{$ids->[$top]{kids}};
1801 if($lines) { $ls = $top ? "|" : " "; $le = "\\"; $lt = "\\";
1802 $p = @kids ? "+" : "_"; $d = "_"; }
1803 else { $ls = $le = " "; $p = " "; $d = " "; $lt = " "; }
1804 my $indent = "$ls "x$ids->[$top]{depth};
1805 print "$indent$ls$d$p start $ids->[$top]{id}($top)";
1806 if($top > 0) {
1807 print ": ",
1808 "Errcode=", ($ids->[$top]{retcode} // "?"), ", ",
1809 "Signal=", ($ids->[$top]{signal} // "?"), ", ",
1810 "Elapsed=", ($ids->[$top]{elapt} // "?"), ", ",
1811 "Util=", ($ids->[$top]{util} // "?"), ", ",
1812 "RSS(KB)=", ($ids->[$top]{rssk} // "?"), ", ",
1813 (defined $ids->[$top]{rdmb}
1814 ? ("Rd(MB)=", ($ids->[$top]{rdmb} // "?"), ", ",
1815 "Wt(MB)=", ($ids->[$top]{wtmb} // "?"), ", ",
1816 "Tx(MB)=", ($ids->[$top]{txmb} // "?"), ", ",
1817 "Rx(MB)=", ($ids->[$top]{rxmb} // "?"), ", ")
1818 : ()),
1819 }
1820 print "\n";
1821 if($out) {
1822 my (@lines) = @{$ids->[$top]{lines}};
1823 # Trim off blank lines at top and bottom (then add one back in)
1824 shift @lines while @lines && $lines[0] =~/^\s*$/;
1825 pop @lines while @lines && $lines[-1]=~/^\s*$/;
1826 print "$indent$ls $ls ".join("\n$indent$ls $ls ","",@lines,"")."\n"
1827 if @lines;
1828 }
1829 print_log_tree_depth($ids,$_,$opts) for @kids;
1830 print "$indent$le$d$d end ",$ids->[$top]{endtime}//"?","\n";
1831 return $ids;
1832}
1833
1834sub trace_log_file {
1835 my $ids = shift;
1836 my $top = shift || 0;
1837 my $trace= shift || [];
1838 my $opts = shift || {};
1839 my $first= $opts->{first};
1840 if(! ref $ids) {
1841 # As a convenience feature, take a non-ref as a file name to parse
1842 $ids = slurp_log_file($ids,$opts);
1843 }
1844 #print "|$top/$ids->[$top]{id}|$ids->[$top]{status}|\n";
1845 #if(defined $ids->[$top]{up}) { # this is not the dummy top node
1846 # return $trace if $ids->[$top]{status} == 0;
1847 # push @$trace,$ids->[$top] if defined $ids->[$top]{up};
1848 #}
1849 my $haderr;
1850 if($ids->[$top]{status} && $ids->[$top]{status} != -999) {
1851 if(! @$trace) {
1852 # Put in the parent
1853 my $parent = $ids->[$top]{up};
1854 push @$trace,$ids->[$parent] if $parent;
1855 }
1856 push @$trace,$ids->[$top];
1857 $haderr = 1;
1858 }
1859 # (-999 means an end tag wasn't found)
1860 my @kids;
1861 if($haderr && $first) {
1862 # Take just first first child to show an error
1863 my ($kid) = (grep { $ids->[$_]{status} &&
1864 $ids->[$_]{status} != -999 }
1865 @{$ids->[$top]{kids}});
1866 @kids = ($kid) if $kid;
1867 } else {
1868 @kids = @{$ids->[$top]{kids}};
1869 }
1870 #print " |@kids|\n";
1871 for my $kid (@kids) {
1872 trace_log_file($ids,$kid,$trace,$opts);
1873 if($first && @$trace) {
1874 # We found a branch with errors and only want the first
1875 # one we find, so stop looking
1876 last;
1877 }
1878 }
1879 return $trace;
1880}
1881
1882sub log_trace_str {
1883 my $ids = shift;
1884 my $opts = shift || {};
1885 my $trace = trace_log_file($ids,0,undef,{first=>1,%$opts});
1886 my $str = "";
1887 # Skip intervening spawn blocks (except the last one)
1888 if(@$trace && ! $opts->{spawns}) {
1889 my @pre = grep { $_->{iam} !~ /^Spawn_/ } @{$trace}[0..$#{$trace}-1];
1890 $trace = [ (@pre, $trace->[$#{$trace}]) ];
1891 }
1892 $str = join("->",
1893 map { $_->{iam}.($_->{step}?"$_->{step}:":""); } # Prefix steps
1894 map { $_->{iam} =~ s/^Spawn_//; $_; } # Trim off 'Spawn_' tags
1895 grep { $_ && $_->{iam} }
1896 @$trace);
1897 return $str;
1898}
1899
1900# ====================================================
1901# Write a ds9 region file from the rows of a FITS table
1902sub write_ds9_regions {
1903 my $file = shift;
1904 my $cat = shift;
1905 my $opts = shift || {};
1906 my $maglim = $opts->{maglim};
1907 my $racol = $opts->{racol} || $opts->{loncol}|| $opts->{ra} ||
1908 $opts->{lon} || 'ra';
1909 my $deccol = $opts->{deccol} || $opts->{latcol}|| $opts->{dec} ||
1910 $opts->{lat} || 'dec';
1911 my $magcol = $opts->{magcol} || $opts->{mag} || 'none';
1912 my $acol = $opts->{acol} || $opts->{a};
1913 my $bcol = $opts->{bcol} || $opts->{b};
1914 my $thetacol= $opts->{thetacol} || $opts->{theta};
1915 my $scale = $opts->{scale} || $opts->{scl} || 2.35482; # A->FWHM
1916 my $offset = $opts->{offset} || $opts->{off} || 0;
1917 my $thetaoff= $opts->{thetaoff} || $opts->{thoff} || 0;
1918 my $thetascl= $opts->{thetascl} || $opts->{thscl} || 1;
1919 my $coord = $opts->{coordsys} || $opts->{coord} || "J2000";
1920 my $sym = $opts->{symbol} || $opts->{sym} || "circle";
1921 my $color = $opts->{color} || "green";
1922 my $hdunum = $opts->{hdunum} || 2;
1923 my $limits = $opts->{limits} || "";
1924 my $a0 = $opts->{a0};
1925 my $b0 = $opts->{b0};
1926 my $pa0 = $opts->{pa0} || $opts->{theta0};
1927 my $ra0 = $opts->{ra0};
1928 my $dec0 = $opts->{dec0};
1929 my $radius = $opts->{radius};
1930 my $append = $opts->{append};
1931 my $noclose = $opts->{noclose} || $opts->{keepopen};
1932 my $verbose = $opts->{verbose};
1933 my $minpix = 8;
1934 my $minasecs= 12;
1935 my $maxpix = 200;
1936 my $maxasecs= 300;
1937 if($sym =~ /^ellipse|circle$/i) { $minpix/=2; $minasecs/=2; } # Radii
1938 my $err = "*** $0/DS9reg";
1939 my $warn= "=== $0/DS9reg";
1940
1941 warn("$err: Radius test requested but center RA,Dec not supplied"),return
1942 if $radius && $radius>0 && (! defined $ra0 || ! defined $dec0);
1943
1944 my $ds9;
1945 if(ref $file) {
1946 $ds9 = $file;
1947 $noclose = 1;
1948 } else {
1949 my $app = $append ? ">" : "";
1950 my $tmp = $file eq '-' ? ">&STDOUT" : "$app>$file";
1951 print "DS9reg: Opening region ouput file '$tmp' ...\n" if $verbose;
1952 open($ds9,"$tmp")
1953 or warn("$err: Failed top open $tmp; $!"),return;
1954 }
1955
1956 if(! $append) {
1957 print $ds9 "# Region file format: DS9 version 3.0\n";
1958 print $ds9 "global color=$color font=\"helvetica 10 normal\" ".
1959 "edit=1 move=0 delete=1 include=1 fixed=0\n";
1960 }
1961
1962 ($racol,$deccol,$magcol,$acol,$bcol,$thetacol) =
1963 map {$_ && !/none/i ? $_ : undef}
1964 ($racol,$deccol,$magcol,$acol,$bcol,$thetacol);
1965
1966 my @cols = ($racol,$deccol);
1967 push @cols, $magcol
1968 if defined $maglim;
1969 push @cols, $acol
1970 if ! $a0 && ($sym eq 'ellipse' || $sym eq 'box' || $sym eq 'circle');
1971 push @cols, $bcol
1972 if ! $b0 && ($sym eq 'ellipse' || $sym eq 'box');
1973 push @cols, $thetacol
1974 if ! $pa0 && ($sym eq 'ellipse' || $sym eq 'box');
1975 @cols = grep {$_} @cols;
1976
1977 my $rows;
1978 if(ref($cat) eq 'HASH') { # Already has data in it
1979 $rows = $cat;
1980 } else {
1981 my ($tbl);
1982 if(ref $cat) {
1983 $tbl = $cat;
1984 } else {
1985 print "DS9reg: Opening IPAC tbl '$cat$limits' ...\n" if $verbose;
1986 $tbl = WISE::IPACTbl->new($cat,{cols=>\@cols,fast=>1})
1987 or return;
1988 }
1989 print "DS9reg: Reading columns @cols ...\n" if $verbose;
1990 $rows = $tbl->data() or return;
1991 }
1992
1993 {
1994 my @missing = grep { ! defined $rows->{$_} } @cols;
1995 warn("$err: Missing columns; @missing"),return if @missing;
1996 }
1997
1998
1999 ! $noclose && close($ds9), return if ! $rows || ! ref $rows;
2000
2001 my $nrows = @{$rows->{$racol}};
2002
2003 print "DS9reg: Writing regions from $nrows rows ...\n" if $verbose;
2004
2005 my $n = 0;
2006 for my $i (0..($nrows-1)) {
2007 next if $magcol && defined $maglim && $rows->{$magcol}[$i] > $maglim;
2008 my $ra = $rows->{$racol}[$i];
2009 my $dec= $rows->{$deccol}[$i];
2010 if(defined $radius && $radius>0) {
2011 next if angdist($ra,$dec,$ra0,$dec0)*3600 > $radius;
2012 }
2013 my $a = (defined $a0 ? $a0
2014 : $acol ? $rows->{$acol}[$i]*$scale + $offset
2015 : 15/3600 );
2016 my $b = (defined $b0 ? $b0
2017 : $bcol ? $rows->{$bcol}[$i]*$scale + $offset
2018 : $a );
2019 my $pa = (defined $pa0? $pa0
2020 : $thetacol ? $rows->{$thetacol}[$i]*$thetascl + $thetaoff
2021 : 0 );
2022 if($coord =~ /phyisical|image/i) {
2023 # Pixel coords
2024 $a = $a && $a >= $minpix ? $a : $minpix;
2025 $b = $b && $b >= $minpix ? $b : $minpix;
2026 $a = $a && $a <= $maxpix ? $a : $maxpix;
2027 $b = $b && $b <= $maxpix ? $b : $maxpix;
2028 } else {
2029 # Assume sky coords in degrees
2030 # Apply max/min
2031 $a = $a && $a*3600 >= $minasecs ? $a : $minasecs/3600;
2032 $b = $b && $b*3600 >= $minasecs ? $b : $minasecs/3600;
2033 $a = $a && $a*3600 <= $maxasecs ? $a : $maxasecs/3600;
2034 $b = $b && $b*3600 <= $maxasecs ? $b : $maxasecs/3600;
2035 }
2036 if($sym eq 'ellipse' || $sym eq 'box') {
2037 print $ds9 "$coord ; +$sym($ra,$dec,$a,$b,$pa)\n";
2038 } elsif($sym eq 'circle') {
2039 print $ds9 "$coord ; +$sym($ra,$dec,$a)\n";
2040 } elsif($sym =~ /^p(?:nt|oint)?[-=\s_]*(.+)|(diamond|cross|x|arrow)/) {
2041 print $ds9 "$coord ; +point($ra,$dec) # point=".($1||$2)."\n";
2042 } else {
2043 warn "$err: Don't know what to do with symbol '$sym'";
2044 close $ds9 if ! $noclose;
2045 return;
2046 }
2047 ++$n;
2048 }
2049
2050 close $ds9 if ! $noclose;
2051
2052 print "DS9reg: Write $n regions.\n" if $verbose;
2053
2054 return $n;
2055}
2056
2057
2058# ====================================================
2059# Read a primary HDU FITS header, fast and sloppy. Only simple cards will work.
2060sub fast_fits_hdr {
2061 my $file = shift;
2062 my $n = shift || 10;
2063 my (%cards,$top);
2064 local $_;
2065
2066 $n *= 2880;
2067
2068 if($file =~ /\.gz$/) {
2069 my $gz = Compress::Zlib::gzopen($file,"rb") or return \%cards;
2070 my $rc = $gz->gzread($top,$n);
2071 return \%cards if $rc<=0;
2072 } else {
2073 open(my $fits,"<$file") or return \%cards;
2074 read($fits,$top,$n) or return \%cards;
2075 }
2076
2077 while($_ = substr($top,0,80,"")) {
2078 my ($k,$v) = m%^(\S{1,8})\s*=\s*(\S+)%;
2079 next if ! $k;
2080 $v =~ s%^\s*'(.*)'\s*$%$1%;
2081 $cards{$k} = $v;
2082 }
2083
2084 return \%cards;
2085}
2086
2087# Read any header card of any valid FITS file, of any HDU.
2088sub fits_hdr {
2089 my $file = shift;
2090 my $n = shift; # Does nothing. For compatability with fast_fits_hdr
2091 my $hdunum = shift || 1;
2092
2093 return {} if ! defined $file;
2094
2095 my $fits = WISE::FITSIO->new($file, {silent=>1}) or return {};
2096
2097 my $hdr = $fits->gethdu($hdunum) or return {};
2098
2099 return { map { $_->{name}=>$_->{value} } @$hdr };
2100}
2101
2102# Read the end of a file
2103sub fast_tail {
2104 my $file = shift;
2105 my $n = shift || 2048;
2106 my $str;
2107
2108 my $sz = -s $file;
2109 $n = $sz if $n > $sz;
2110
2111 open(my $fh,"<$file") or warn("open:$!\n"),return "";
2112 seek($fh,-$n,SEEK_END) or warn("seek:$!\n"),return "";
2113 read($fh,$str,$n) or warn("read:$!\n"),return "";
2114
2115 return $str;
2116}
2117
2118
2119# ====================================================
2120# Check for machine time skew
2121
2122sub get_time_skew {
2123 my $t0 = shift || time();
2124 my $testfile = shift || "./.skewcheck";
2125 my $opts = shift || {};
2126 my $shhh = $opts->{silent};
2127 my $warn = "$0/SKEW";
2128 open(my $test,">$testfile")
2129 or (! $shhh and
2130 warn("$warn: Can't open time skew test file '$testfile'; $!\n".
2131 "$warn: Skew set to zero.\n")),
2132 return 0;
2133 print $test "$t0\n"
2134 or (! $shhh and
2135 warn("$warn: Can't write time skew test file '$testfile'; $!\n".
2136 "$warn: Skew set to zero.\n")),
2137 unlink($testfile),
2138 return 0;
2139 close $test
2140 or (! $shhh and
2141 warn("$warn: Can't close time skew test file '$testfile'; $!\n".
2142 "$warn: Skew set to zero.\n")),
2143 unlink($testfile),
2144 return 0;
2145 my $modtime;
2146 my $n = 0;
2147 while(! $modtime && $n < 10) {
2148 $modtime = (stat($testfile))[9];
2149 sleep 1 if ! $modtime;
2150 ++$n;
2151 }
2152 if(! $modtime) {
2153 warn "$warn: Can't stat test file '$testfile'; $!\n".
2154 "$warn: Skew set to zero.\n"
2155 if ! $shhh;
2156 unlink($testfile);
2157 return 0;
2158 }
2159
2160 my $skew = $t0 - $modtime;
2161
2162 warn "$warn: Found time skew = $skew seconds for mod times ".
2163 "of '$testfile'.\n"
2164 if ! $shhh && $skew > 10;
2165
2166 unlink($testfile);
2167
2168 return $skew;
2169}
2170
2171# ====================================================
2172# Simple, multi-column sorting of io data structures
2173
2174
# spent 867ms (616+251) within WISE::IOUtils::sort_cols which was called # once (616ms+251ms) at line 1104 of /wise/base/deliv/dev/bin/getfix
sub sort_cols {
2175613490.703341.1e-5 my $rows = shift;
2176 die "*** $0/SORTCOLS: No rows supplied or data structure is wrong.\n"
2177 if ! $rows || ref($rows) !~ /hash/i ||
2178 $rows->{(keys %$rows)[0]} !~ /array/i;
2179 my $cols = shift;
2180 ($cols) = keys %$rows if ! $cols && keys %$rows == 1;
2181 die "*** $0/SORTCOLS: No columns supplied.\n" if ! $cols;
2182 $cols = [$cols] if ! ref $cols;
2183 my $types= shift || {};
2184 my $opts = shift || {};
2185 my $ixonly = $opts->{ix};
2186 my $lc = $opts->{lc};
2187 my $maxlen = $opts->{maxlen};
2188 my %desc;
2189 my @sortcols = map { my$c=$lc?lc($_):$_; $c=~s/^-// and $desc{$c}=1;
2190 $c=~s/^\+//; $c; } @$cols;
2191 ! $rows->{$_} and die "*** $0/SORTCOLS: No column '$_'.\n"
2192 for @sortcols;
2193 my $n = @{ $rows->{$sortcols[0]} };
2194 $types = {map { ($_=>$types) } @sortcols } if ! ref $types;
2195 %$types = (map { (lc($_)=>$types->{$_}) } keys %$types );
2196 my %ix;
2197 my @ix = (map { $ix{$_} }
2198 sort
2199 map { my $ix=$_;
2200 my $k =
# spent 183ms making 17518 calls to WISE::IOUtils::lex_key_a, avg 10µs/call # spent 68.6ms making 8759 calls to WISE::IOUtils::lex_key_d, avg 8µs/call
2201 join(",",
2202 map { ($types->{$_}||'a') =~ /^[acs]/i
2203 ? lex_key_a($rows->{$_}[$ix],$desc{$_},
2204 $maxlen)
2205 : lex_key_d($rows->{$_}[$ix],$desc{$_}) }
2206 @sortcols).
2207 sprintf("%09d",$ix); # tiebreaker
2208 #print "--- $ix: '$k'\n";
2209 $ix{$k} = $ix;
2210 $k;
2211 }
2212 0..$n-1);
2213 #print "--- @ix\n";
2214 return wantarray ? @ix : \@ix if $ixonly;
2215 $rows->{$_} = [ @{ $rows->{$_} }[@ix] ] for keys %$rows;
2216 return $rows;
2217}
2218
2219
# spent 68.6ms within WISE::IOUtils::lex_key_d which was called 8759 times, avg 8µs/call: # 8759 times (68.6ms+0) by WISE::IOUtils::sort_cols at line 2200, avg 8µs/call
sub lex_key_d {
2220262770.040351.5e-6 my $x = $_[1] && $_[0]!=0 ? -$_[0] : $_[0];
2221 # for little-endian, 8-byte floats
2222 my $p = reverse pack("d", $x);
2223 $p ^ ($x < 0 ? "\xff" x 8 : "\x80");
2224}
2225
2226
# spent 183ms within WISE::IOUtils::lex_key_a which was called 17518 times, avg 10µs/call: # 17518 times (183ms+0) by WISE::IOUtils::sort_cols at line 2200, avg 10µs/call
sub lex_key_a {
2227700720.123611.8e-6 my $maxlen = $_[2] || 256;
2228 (my $x = $_[0]) =~ s/^\s+//;
2229 $x = sprintf("%-${maxlen}s",$_[0]);
2230 $_[1] ? ~$x : $x;
2231}
2232
2233#sub lex_key_d {
2234# my $mask = "\0".("\x7f" x 329);
2235# my$x=sprintf("%+0330.16f",$_[0]);
2236# $x=~s/\./0/;
2237# $x=~s/^\+/1/;
2238# $x=~s/^-/0/ and $x ^= $mask;
2239# $_[1] ? ~$x : $x;
2240#}
2241
2242# =========================================
2243# Directory cleaning routine
2244
2245sub clean_dir {
2246 my $dir = shift;
2247 my $opts = shift || {};
2248 my $indir = $opts->{in_dir} || ".";
2249 my $outdir= $opts->{out_dir} || $indir;
2250 my $trashdir = $opts->{trashdir};
2251 my $trash = $opts->{trash};
2252 my $recurse=$opts->{recurse};
2253 my $robust = $opts->{robust};
2254 my $maxup = $opts->{maxup} || 2;
2255 my $warn = "=== $0/clean_dir";
2256 my $err = "*** $0/clean_dir";
2257 my @matching = $opts->{matching}
2258 ? (ref $opts->{matching}
2259 ? (@{$opts->{matching}})
2260 : ($opts->{matching})
2261 )
2262 : ();
2263 my @not_matching = $opts->{not_matching}
2264 ? (ref $opts->{not_matching}
2265 ? (@{$opts->{not_matching}})
2266 : ($opts->{not_matching})
2267 )
2268 : ();
2269
2270 die "$err: Trashing requested, but trashdir not defined.\n"
2271 if $trash && ! $trashdir;
2272
2273 die "$err: Asked to clean illegal area '$dir'.\n"
2274 if $dir =~ m%^/+wise/+base% ||
2275 $dir =~ m%^/+wise/+(ref|cal)% ||
2276 $dir =~ m%(svn|roundup)%;
2277
2278 my ($n,$nrm) = (0,0);
2279
2280 return 1 if ! -e $dir;
2281
2282 my $contents = dir_list($dir,{verbose=>$opts->{verbose}})
2283 or return;
2284
2285 my @contents = @$contents;
2286 my %contents;
2287 @contents{@contents} = (1) x @contents;
2288
2289 FILE: for my $file (@contents) {
2290 ++$n;
2291 # Match any supplied 'matching' pattern
2292 next if @matching &&
2293 grep($file =~ m%/$_$%, @matching) == 0;
2294 # Do NOT match ANY supplied 'not_matching' pattern
2295 next if @not_matching &&
2296 grep($file =~ m%/$_$%, @not_matching) > 0;
2297 if(-d $file && ! -l $file) {
2298 if(! $recurse) {
2299 warn "$warn: Skipping directory '$file' while cleaning.\n";
2300 } else {
2301 print "Recursing into '$file' ...\n" if $opts->{verbose};
2302 clean_dir($file,{%$opts, dir_too=>1, parents_too=>0});
2303 $contents{$file} = 0;
2304 print "Done recursing into '$file'.\n" if $opts->{verbose};
2305 }
2306 next FILE;
2307 }
2308 print "... removing '$file' ...\n" if $opts->{verbose};
2309 my $rc = unlink $file;
2310 if(! $rc) {
2311 if($! && $! =~ /no such file/i) {
2312 warn "$warn: Cannot remove '$file'; $!.\n";
2313 } else {
2314 if(! $robust || File::Basename::basename($file) !~ /^\.nfs/) {
2315 die "$err: Cannot remove '$file'; $!.\n";
2316 } else {
2317 warn "$warn: Cannot remove '$file'; $!.\n";
2318 }
2319 }
2320 }
2321 $contents{$file} = 0;
2322 ++$nrm;
2323 } # FILE
2324
2325 if($opts->{dir_too}) { DIR: {
2326
2327 if($n != $nrm) { # Dir was NOT empty
2328 my @left = grep { $contents{$_} } @contents;
2329 if(@left) {
2330 warn "$warn: Cannot remove '$dir' since files remain: @left\n";
2331 last DIR;
2332 }
2333 }
2334
2335 $dir = WISE::Utils::normalizepath($dir,{resolve=>1});
2336
2337 if(-l $dir) {
2338 # No target dir or normalize would return the real path name, so
2339 # all we have is a symlink
2340 my $symlink = $dir;
2341 print "Removing symlink '$symlink' ...\n" if $opts->{verbose};
2342 unlink($symlink)
2343 or die "$err: Cannot remove symlink '$symlink'; $!.\n";
2344 last DIR;
2345 }
2346
2347 # Safety first
2348 last DIR if $dir =~ m%(?<!work)/+fr/*$% ||
2349 $dir =~ m%/(scans|ql|coadds|l0)/*$% ||
2350 $dir =~ m%/fops/*$% ||
2351 $dir =~ m%/tops/*$% ||
2352 $dir =~ m%^/wise/*$% ||
2353 $dir =~ m%^/+$% ||
2354 WISE::Utils::samefile($dir,".") ||
2355 WISE::Utils::samefile($dir,$outdir) ||
2356 WISE::Utils::samefile($dir,$indir) ;
2357
2358 print "Removing directory '$dir' ...\n" if $opts->{verbose};
2359 my $rc = rmdir $dir;
2360
2361 if(! $rc) {
2362 if($trash && $! =~ /not empty/i) {
2363 # Move dir to the trashdir because files remain
2364 # (probably NFS stubs)
2365 warn "$warn: Remove of directory '$dir' failed: $!.\n";
2366 if($trashdir eq 'default' || ! -d $trashdir) {
2367 if($trashdir eq 'default') {
2368 # Add a 'Trash' file at the fops/tops root
2369 ($trashdir = $dir) =~ s%(.*/wise/[ft]ops(/|$)).*%$1%
2370 or die "$err: Can't create default trashdir ".
2371 "because dir '$dir' has the wrong form.\n";
2372 }
2373 if(! -d $trashdir) {
2374 WISE::Utils::mymkpath($trashdir,
2375 {verbose=>$opts->{verbose}})
2376 or die "$err: Unable to make trash directory ".
2377 "'$trashdir'; $!.\n";
2378 }
2379 }
2380 (my $dirfile = $dir) =~ s|(?<=.)/+|-|g;
2381 my $newfile = "$trashdir/$dirfile";
2382 warn "$warn: Trashing '$dir' as '$newfile' ...\n";
2383 rename($dir,$newfile)
2384 or die "$err: Unable to trash directory '$dir' as ".
2385 "'$newfile'; $!.\n";
2386 } else {
2387 die "$err: Cannot remove directory '$dir'; $!.\n";
2388 }
2389 }
2390
2391 if($opts->{parents_too}) { PARENTS: {
2392
2393 my $uplevel = 0;
2394
2395 while(1) {
2396 # Go up a level
2397 $dir = WISE::Utils::normalizepath("$dir/..",{resolve=>1});
2398
2399 ++$uplevel;
2400
2401 # Safety first; don't go too high and stop and
2402 # various backstops
2403 last DIR if $uplevel > $maxup ||
2404 ! -d $dir ||
2405 $dir =~ m%/fr/*$% ||
2406 $dir =~ m%/fops/*$% ||
2407 $dir =~ m%/tops/*$% ||
2408 $dir =~ m%^/wise/*$% ||
2409 $dir =~ m%^/+$% ||
2410 WISE::Utils::samefile($dir,".") ||
2411 WISE::Utils::samefile($dir,$outdir) ||
2412 WISE::Utils::samefile($dir,$indir) ;
2413
2414 my $contents = dir_list($dir,{verbose=>$opts->{verbose}})
2415 or return;
2416 my @contents = @$contents;
2417
2418 if(! @contents) {
2419 print "Removing parent directory '$dir' ...\n"
2420 if $opts->{verbose};
2421 if(! rmdir $dir) {
2422 # Protect against race condition: a dir
2423 # could be populated just as it was being
2424 # deleted as new concurrent processes
2425 # start adding files
2426 if($! !~ /not empty/i) {
2427 die "$err: Could not remove parent ".
2428 "directory '$dir'; $!.\n";
2429 } else {
2430 last PARENTS;
2431 }
2432 }
2433 } else {
2434 print "Stopping parent removal at dir '$dir' since ".
2435 "other files are still present: @contents\n"
2436 if $opts->{verbose};
2437 last PARENTS;
2438 }
2439
2440 }
2441
2442 } } # PARENTS
2443
2444 } } # DIR
2445
2446 return 1;
2447}
2448
2449sub dir_list {
2450 my $dir = shift // '.';
2451 my $opts = shift || {};
2452 my $verbose = $opts->{verbose};
2453 my $dots = $opts->{dots};
2454 my $take = $opts->{take_re};
2455 my $not = $opts->{not_re};
2456 my $dir_orig = $dir;
2457 my $dirtarg;
2458 $dirtarg = readlink($dir) if -l $dir;
2459 $dir = $dirtarg if $dirtarg;
2460 $dir = WISE::Utils::normalizepath($dir,{resolve=>1});
2461 print " Getting contents of '$dir_orig' ".
2462 ($dirtarg ? "(->'$dirtarg') " : "").", ".
2463 "AKA '$dir' ...\n"
2464 if $verbose;
2465 my $dh;
2466 # Force the automounter
2467 #symlink("$$","$dir/.force") && unlink("$dir/.force");
2468 opendir($dh, $dir)
2469 or warn("*** $0/dir: Unable to open dir '$dir' ('$dir_orig'); $!.\n"),
2470 return;
2471 my @list;
2472 push @list, $_ while $_=readdir($dh);
2473 closedir($dh)
2474 or warn("*** $0/dir: Unable to close dir '$dir' ('$dir_orig'); $!.\n"),
2475 return;
2476 @list = grep{ ! /^\.\.?$/ } @list if ! $dots;
2477 @list = grep{ /$take/ } @list if defined $take;
2478 @list = grep{ ! /$not/ } @list if defined $not;
2479 # Attach dir to filename
2480 @list = map { "$dir/$_" } @list;
2481 return \@list;
2482}

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.