← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/wdate
  Run on Fri Jun 4 15:13:22 2010
Reported on Fri Jun 4 15:14:16 2010

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

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

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