← 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:43 2010

File/wise/base/deliv/dev/lib/perl/WISE/IPACTbl.pm
Statements Executed210479
Total Time0.210701000000103 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1110.202090.20757WISE::IPACTbl::new
2214.2e-54.2e-5WISE::IPACTbl::_is_opt
2214.1e-54.1e-5WISE::IPACTbl::_rotate_data
1113.6e-50.06187WISE::IPACTbl::data_out
1113.2e-53.2e-5WISE::IPACTbl::_modes
1111.6e-50.06189WISE::IPACTbl::data
00000WISE::IPACTbl::BEGIN
00000WISE::IPACTbl::Meta::BEGIN
00000WISE::IPACTbl::Meta::_meta_unit
00000WISE::IPACTbl::Meta::meta_band_merge
00000WISE::IPACTbl::Meta::meta_hash
00000WISE::IPACTbl::Meta::meta_item
00000WISE::IPACTbl::Meta::meta_rotate
00000WISE::IPACTbl::Meta::meta_unit
00000WISE::IPACTbl::Meta::metafile_meta
00000WISE::IPACTbl::Meta::new
00000WISE::IPACTbl::_get_meta
00000WISE::IPACTbl::_init_as_null
00000WISE::IPACTbl::_read_tbl
00000WISE::IPACTbl::_unpack
00000WISE::IPACTbl::addcol
00000WISE::IPACTbl::col_pack_templates
00000WISE::IPACTbl::column_blanks
00000WISE::IPACTbl::column_index
00000WISE::IPACTbl::column_names
00000WISE::IPACTbl::column_types
00000WISE::IPACTbl::column_units
00000WISE::IPACTbl::columns
00000WISE::IPACTbl::columns_read
00000WISE::IPACTbl::comments
00000WISE::IPACTbl::done
00000WISE::IPACTbl::dump_tbl
00000WISE::IPACTbl::error
00000WISE::IPACTbl::keepcol
00000WISE::IPACTbl::keys
00000WISE::IPACTbl::last_row_nums
00000WISE::IPACTbl::meta
00000WISE::IPACTbl::meta_ipac
00000WISE::IPACTbl::mvcol
00000WISE::IPACTbl::rmcol
00000WISE::IPACTbl::rotate_data
00000WISE::IPACTbl::rows
00000WISE::IPACTbl::sort_tbl
00000WISE::IPACTbl::title
00000WISE::IPACTbl::totrows

LineStmts.Exclusive
Time		Avg.Code
1
233.5e-51.2e-5use strict;
# spent 14µs making 1 call to strict::import
335.4e-51.8e-5use warnings;
# spent 78µs making 1 call to warnings::import
4
5package WISE::IPACTbl;
6
760.000101.7e-5use 5.010;
# spent 47µs making 1 call to feature::import
8
911.0e-61.0e-6my $version = '$Id: IPACTbl.pm 7906 2010-05-20 00:56:04Z tim $ ';
10
1134.3e-51.4e-5use WISE::IOUtils;
# spent 35µs making 1 call to Exporter::import
12
1311.0e-51.0e-5use vars qw/&ncols &ncolumns &nrows &types &type &column_type
# spent 385µs making 1 call to vars::import
14 &names &name &tblrow &tblrows &key &ipac_meta
15 &write_tblrows &tblrows_out &addcols &rmcols &keepcols &cols
1620.006920.00346 &blank &blanks &unit &units &mvcols &colix/;
17
18
# spent 208ms (202+5.48) within WISE::IPACTbl::new which was called # once (202ms+5.48ms) at line 1199 of /wise/base/deliv/dev/bin/getfix
sub new {
1913.0e-63.0e-6 my $this = shift;
20 # The weird '@_&&$_[-1]' form is needed to avoid a mysterious
21 # "Modfication of non-creatable array value" error when 'new' is
22 # mistakenly called as a function instead of a method.
2311.5e-51.5e-5 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
# spent 26µs making 1 call to WISE::IPACTbl::_is_opt
2416.0e-66.0e-6 my $err = "*** $0/WISE::IPACTbl::new";
2512.0e-62.0e-6 my $warn = "=== $0/WISE::IPACTbl::new";
2612.0e-62.0e-6 my $file = shift || $opts->{file};
2711.0e-61.0e-6 die "$err: No input file specified (did you not call new as a method?).\n"
28 if ! defined $file;
2912.0e-62.0e-6 my $rawmode = shift || $opts->{mode} || 'r';
3011.5e-51.5e-5 my $mode = _modes($rawmode)
# spent 32µs making 1 call to WISE::IPACTbl::_modes
31 or die "$err: I/O mode '$rawmode' not recognized.\n";
3212.0e-62.0e-6 my $colnames = $opts->{colnames} || $opts->{cols};
33100 $colnames = undef if $colnames && $colnames eq '*';
3411.0e-61.0e-6 $colnames = [$colnames] if $colnames && ! ref $colnames;
3516.0e-66.0e-6 my @ok_mbrs = qw(packed nrows keys comments names types blanks units lens
36 start fmts ix read_pack_template);
3711.0e-61.0e-6 my $class = ref($this) || $this;
3812.0e-62.0e-6 my $fast = $opts->{fast} && ! $opts->{chunk};
39
40100 my ($obj);
41
42 # Options for read or write
4313.0e-63.0e-6 $obj->{packed} = $opts->{packed};
4412.0e-62.0e-6 $obj->{chunk} = $opts->{chunk};
4511.0e-61.0e-6 $obj->{file} = $file;
4612.0e-62.0e-6 $obj->{file_name} = ! ref($file) ? $file : '<Internal>';
4711.0e-61.0e-6 $obj->{debug} = $opts->{debug};
4811.0e-61.0e-6 $obj->{fast} = $fast;
4912.0e-62.0e-6 $obj->{robust} = $opts->{robust};
5012.0e-62.0e-6 $obj->{error} = 1; # Reset to 0 uppon success below
51
5212.0e-62.0e-6 if($mode eq 'r') {
53
54 # Read mode
55
56 $obj->{mode} = 'r';
57 $obj->{single} = $opts->{single};
58 $obj->{hashrow} = $opts->{hashrow};
59 $obj->{aryrow} = $opts->{aryrow};
60 $obj->{skip_overflow} = $opts->{skip_overflow};
61 $obj->{colnames}= $colnames;
62 $obj->{pdl} = $opts->{pdl};
63 $obj->{cat} = $opts->{cat};
64
65 if(! $obj->{robust} || ref $file || $file eq '-' ||
66 (-e $file && ! -z _)) {
67 # Normal error handling; undef return on error
68 _read_tbl($obj,{hdronly => $opts->{hdronly}})
69 or return;
70 } else {
71 # Robust handling.
72 # Return a null table entry so caller can continue processing
73 warn "$err: File '$file' ".(! -e _ ? "doesn't exist" : "is empty").
74 ".\n";
75 _init_as_null($obj,$opts);
76 return bless $obj,$class;
77 }
78
79 if($obj->{cat} && $opts->{data} && $obj->{rows}) {
80 my $new = $obj->{rows};
81 my $nnew = $obj->{nrows};
82 my $old = $opts->{data};
83 my $nold = 0;
84 if(keys %$old) {
85 ($nold) = grep {$_} # Count of first non-empty column
86 map { scalar @{$old->{$_}} } keys %$old;
87 }
88 my %seen;
89 my @cols = grep {! $seen{$_}++} (keys %$new, keys %$old);
90 for my $col (@cols) {
91 if($old->{$col} && $new->{$col}) {
92 push @{$old->{$col}}, @{$new->{$col}};
93 } elsif($old->{$col}) {
94 push @{$old->{$col}}, (undef) x $nnew;
95 } else {
96 $old->{$col} = [(undef) x $nold];
97 push @{$old->{$col}}, @{$new->{$col}};
98 }
99 }
100 }
101
102 } else {
103
104 # Write or append mode
105
10611.0e-61.0e-6 die "$err: Can't handle data ref as file in write mode.\n"
107 if ref $file;
108
10911.0e-61.0e-6 my $meta_in;
110
11111.2e-51.2e-5 my $append = $mode eq 'a' || $opts->{append};
112
113 # Inherit from object
114100 @{$meta_in}{@ok_mbrs} = @{$this}{@ok_mbrs} if ref $this;
115
11611.0e-61.0e-6 $meta_in = shift || $opts->{meta}; # Override
117
11812.0e-62.0e-6 if(($append && ! $opts->{csv}) || $opts->{meta_from}) {
119 # Get from existing table file
120 my $from = $append ? $file : $opts->{meta_from};
121 $meta_in = _get_meta($from)
122 or die "$err: Unable to get header meta info from '$from'.\n";
123 if($append && $opts->{data}) {
124 warn "$warn: Can't resize columns from data in append mode.\n"
125 if $opts->{data};
126 $opts->{data} = undef;
127 }
128 }
129
130 # Sterilize meta_in of unwanted members and make a copy
13111.0e-61.0e-6 my %meta_in;
13215.2e-55.2e-5 @meta_in{@ok_mbrs} = @{$meta_in}{@ok_mbrs};
13311.0e-61.0e-6 $meta_in = \%meta_in;
134
13512.0e-62.0e-6 $meta_in->{append} = $append;
13612.0e-62.0e-6 if($opts->{csv}) {
137 $meta_in->{csv} = $opts->{csv};
138 $meta_in->{nohdr} = 1;
139 $meta_in->{nokeys} = 1;
140 $meta_in->{nocoms} = 1;
141 } else {
14212.0e-62.0e-6 $meta_in->{nohdr} = $opts->{nohdr};
14312.0e-62.0e-6 $meta_in->{nokeys} = $opts->{nokeys};
14411.0e-61.0e-6 $meta_in->{nocoms} = $opts->{nocoms};
145 }
146
14711.0e-61.0e-6 my $keys = $meta_in->{nokeys}
148 ? undef
149 : $opts->{keys}//$meta_in->{keys};
15012.0e-62.0e-6 my $coms = $meta_in->{nocoms}
151 ? undef
152 : $opts->{comments}//$meta_in->{comments};
153
15412.0e-62.0e-6 if(! $meta_in->{csv}) {
155 # Regular IPAC table file; header data required
15613.0e-63.0e-6 my @need = qw(names types);
15713.0e-63.0e-6 my @missing = grep { ! $meta_in->{$_} } @need;
15811.0e-61.0e-6 die "$err: Missing mandatory meta keys '@missing'.\n" if @missing;
159 }
160
16111.0e-61.0e-6 my $data = $opts->{data};
16211.6e-51.6e-5 my @names = map {lc $_} @{$meta_in->{names}};
163
16412.0e-62.0e-6 if($data && ! $meta_in->{csv}) {
165 # Look for widest column values and widen the o/p column to suit
166 # if data is supplied
16711.0e-61.0e-6 my %lenix;
16811.1e-51.1e-5 @lenix{@names} = (0..$#names);
16911.1e-51.1e-5 $data = _rotate_data($meta_in,$data);
# spent 23µs making 1 call to WISE::IPACTbl::_rotate_data
17019.0e-69.0e-6 for my $col (@names) {
17181.6e-52.0e-6 next if ! $data->{$col};
17282.4e-53.0e-6 my $len = $meta_in->{lens}[$lenix{$col}] || length($col)+1;
17385.7e-57.1e-6 for my $i (0 .. $#{ $data->{$col} || [] }) {
174700720.101161.4e-6 my $val = $data->{$col}[$i]||'XX';
175700720.033714.8e-7 my $lenval = length($val);
176700720.065869.4e-7 $len = $lenval+1 if $lenval >= $len;
177 }
17885.0e-56.3e-6 $meta_in->{lens}[$lenix{$col}] = $len;
179 }
180 }
181
182 # Massage keys ...
18311.0e-61.0e-6 if($keys) {
18412.0e-62.0e-6 my($key,$val);
18513.0e-63.0e-6 my $newkeys = [];
18612.0e-62.0e-6 while (@$keys) {
187262.4e-59.2e-7 $key = shift @$keys;
188261.5e-55.8e-7 if(! ref $key) {
189 $val = shift @$keys;
190 $key = {name=>$key, value=>$val};
191 }
192262.7e-51.0e-6 push @$newkeys, $key;
193 }
19411.0e-61.0e-6 $keys = $newkeys;
195 }
19615.0e-65.0e-6 if(! $meta_in->{nokeys}) {
19711.0e-61.0e-6 $keys ||= [];
19815.3e-55.3e-5 push @$keys, {name=>'wsds_release',
# spent 100µs making 1 call to WISE::Release::new # spent 13µs making 1 call to WISE::Release::release
199 value=>WISE::Release->new()->release()//'NONE'};
200 }
201
202 # Just write the header and leave the file open
20312.6e-52.6e-5 my $fh = WISE::IOUtils::make_ipac_tbl(
# spent 5.28ms making 1 call to WISE::IOUtils::make_ipac_tbl
204 $file,
205 $meta_in,
206 $keys,
207 undef, # No data; wait for call to data() method
208 {
209 noclose => 1,
210 com => $coms,
211 nohdr => $meta_in->{nohdr},
212 append => $meta_in->{append},
213 })
214 or die "$err: Unable to create table '$file'.\n";
215 # Init meta
21613.4e-53.4e-5 $obj = {%$obj, %$meta_in};
217 # Fill out rest of object meta-data; cribbed from slurp_ipac_tbl().
218 # !!! Should be provided by a method or helper func.
21912.0e-62.0e-6 $obj->{obj_fh} = $fh;
22012.0e-62.0e-6 $obj->{mode} = 'w';
22111.2e-51.2e-5 $obj->{cols} = [map {lc $_} @names];
22211.0e-61.0e-6 $obj->{nrows} = 0;
22312.0e-62.0e-6 $obj->{totrows}= 0;
224100 $obj->{keys} = $keys;
22513.0e-63.0e-6 $obj->{comments} = $opts->{comments}||$meta_in->{comments};
22612.0e-62.0e-6 $obj->{fh} = $fh;
22719.0e-69.0e-6 $obj->{eof} = 0;
228 }
229
23012.0e-62.0e-6 $obj->{error} = 0;
231
23215.2e-55.2e-5 return bless $obj,$class;
233}
234
235sub rotate_data {
236 my $this = shift;
237 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
238 my $data = shift || $opts->{data};
239 return _rotate_data($this,$data);
240}
241
242sub meta {
243 return { %{$_[0]} }; # Unbless !!! Make deeper copy
244}
245
246sub meta_ipac {
247 my $meta = shift;
248 $meta = shift if ref $_[0];
249 return {
250 names => [ @{$meta->{names} || []} ],
251 types => [ @{$meta->{types} || []} ],
252 units => [ @{$meta->{units} || []} ],
253 blanks=> [ @{$meta->{blanks}|| []} ],
254 lens => [ @{$meta->{lens} || []} ],
255 start => [ @{$meta->{start} || []} ],
256 fmts => [ @{$meta->{fmts} || []} ],
257 ix => { %{$meta->{ix} || {}} },
258 };
259}
26014.0e-64.0e-6*ipac_meta = \&meta_ipac;
261
262sub _get_meta {
263 my $file = shift;
264 my $meta;
265 (undef,$meta) =
266 WISE::IOUtils::slurp_ipac_tbl($file, {lc => 1, hdronly => 1})
267 or return;
268
269 return $meta;
270}
271
272sub _read_tbl {
273 my $meta = shift;
274 my $opts = shift || {};
275 my $fast = $opts->{fast} || $meta->{fast};
276
277 my ($rows,$tmpmeta);
278 if(! $fast) {
279 ($rows,$tmpmeta) =
280 WISE::IOUtils::slurp_ipac_tbl($meta->{file},
281 {
282 meta => $opts->{meta},
283 nrows => $meta->{chunk},
284 lc => 1,
285 cols => $meta->{colnames},
286 skip_overflow =>
287 $meta->{skip_overflow},
288 packed => $meta->{packed},
289 ($meta->{pdl} ? (nanblank=>1) : ()),
290 hdronly => $opts->{hdronly},
291 debug => $opts->{debug} ||
292 $meta->{debug},
293 })
294 or return;
295 } else {
296 ($rows,$tmpmeta) =
297 WISE::IOUtils::gulp_ipac_tbl($meta->{file},
298 {
299 cols=>$meta->{colnames},
300 }
301 )
302 or return;
303 }
304
305 # $tmpmeta also contains 'file', 'ix', 'nrows', etc.
306 @{$meta}{CORE::keys %$tmpmeta} = values %$tmpmeta;
307
308 $meta->{rows} = $rows;
309
310 return 1;
311}
312
313sub col_pack_templates {
314 my $this = shift;
315 state $type_tmpl8s = WISE::IOUtils::type_pack_templates();
316 if(! @_) {
317 my $col_tmpl8s = { map { ( $_ =>
318 $type_tmpl8s->
319 {$this->{types}[$this->{ix}{$_}]} )
320 } map {lc} @{ $this->{names} }
321 };
322 return wantarray ? %$col_tmpl8s : $col_tmpl8s;
323 }
324 my @tmpl8s=@{$type_tmpl8s}{@{$this->{types}}[@{$this->{ix}}{map {lc} @_}]};
325 return wantarray
326 ? @tmpl8s
327 : join("",@tmpl8s);
328}
329
330sub error {
331 my $this = shift;
332 return $this->{error};
333}
334
335sub comments {
336 my $this = shift;
337 return @{$this->{comments}};
338}
339
340sub column_names {
341 my $this = shift;
342 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
343 my $name = shift || $opts->{name};
344 if(! defined $name) {
345 return wantarray ? @{$this->{names}} : [@{$this->{names}}];
346 } else {
347 return grep { lc($_) eq lc($name) } @{$this->{names}};
348 }
349}
35011.0e-61.0e-6*names = \&column_names;
35111.0e-61.0e-6*name = \&column_names;
352
353sub column_index {
354 my $this = shift;
355 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
356 my $name = shift || $opts->{name};
357 if(! defined $name) {
358 return wantarray ? %{$this->{ix}} : {%{$this->{ix}}};
359 } else {
360 return $this->{ix}{lc $name};
361 }
362}
36311.0e-61.0e-6*colix = \&column_index;
364
365sub column_types {
366 my $this = shift;
367 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
368 my $col = shift;
369 my %kv = map { (lc($this->{names}[$_]) => $this->{types}[$_]) }
370 0..$#{$this->{names}};
371 return $kv{lc $col} if defined $col;
372 if(! $opts->{kv}) {
373 return @{$this->{types}};
374 } else {
375 return wantarray ? %kv : \%kv;
376 }
377}
37811.0e-61.0e-6*types = \&column_types;
37911.0e-61.0e-6*column_type = \&column_types;
38011.0e-61.0e-6*type = \&column_type;
381
382sub column_units {
383 my $this = shift;
384 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
385 my $col = shift;
386 my %kv = map { (lc($this->{names}[$_]) => $this->{units}[$_]) }
387 0..$#{$this->{names}};
388 return $kv{lc $col} if defined $col;
389 if(! $opts->{kv}) {
390 return @{$this->{types}};
391 } else {
392 return wantarray ? %kv : \%kv;
393 }
394}
39511.0e-61.0e-6*units = \&column_units;
39611.0e-61.0e-6*column_unit = \&column_units;
39711.0e-61.0e-6*unit = \&column_unit;
398
399sub column_blanks {
400 my $this = shift;
401 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
402 my $col = shift;
403 my %kv = map { (lc($this->{names}[$_]) => $this->{blanks}[$_]) }
404 0..$#{$this->{names}};
405 return $kv{lc $col} if defined $col;
406 if(! $opts->{kv}) {
407 return @{$this->{types}};
408 } else {
409 return wantarray ? %kv : \%kv;
410 }
411}
41211.0e-61.0e-6*blanks = \&column_blanks;
41311.0e-61.0e-6*column_blank = \&column_blanks;
41411.0e-61.0e-6*blank = \&column_blank;
415
416sub columns_read {
417 my $this = shift;
418 return wantarray ? @{$this->{cols}} : [@{$this->{cols}}];;
419}
42012.0e-62.0e-6*cols = \&columns_read;
421
422sub rows {
423 my $this = shift;
424 return $this->{nrows};
425}
42612.0e-62.0e-6*nrows = \&rows;
427
428sub totrows {
429 my $this = shift;
430 return $this->{totrows};
431}
432
433sub columns {
434 my $this = shift;
435 return scalar @{$this->{cols}};
436}
43712.0e-62.0e-6*ncols = \&columns;
43812.0e-62.0e-6*ncolumns = \&columns;
439
440sub done {
441 my $this = shift;
442 return $this->{eof};
443}
444
445
# spent 61.9ms (16µs+61.9) within WISE::IPACTbl::data which was called # once (16µs+61.9ms) at line 1240 of /wise/base/deliv/dev/bin/getfix
sub data {
44611.0e-61.0e-6 my $this = shift;
44711.2e-51.2e-5 return data_out($this,@_) if $this->{mode} eq 'w'; # <<<< Output
# spent 61.9ms making 1 call to WISE::IPACTbl::data_out
448 # vvvv Input vvvv
449 my $err = "*** $0/WISE::IPACTbl::data(in)";
450 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
451 my $colnames = shift || $opts->{colnames} || $opts->{cols};
452 $colnames = [$colnames] if $colnames && ! ref $colnames;
453 $colnames = undef if $colnames && $colnames->[0] eq '*';
454 my $rownums = shift;
455 $rownums = [$rownums] if defined $rownums && ! ref $rownums;
456 $rownums = undef if defined $rownums && $rownums->[0] eq '*';
457 my $single = $opts->{single} // $this->{single};
458 my $ary = ($opts->{aryrow } // $this->{aryrow});
459 my $hash = ($opts->{hashrow} // $this->{hashrow})
460 || ($rownums && ! $ary);
461 my $byrow = $ary || $hash;
462 my $fast = $opts->{fast} // $this->{fast};
463 my $lookup = $opts->{lookup};
464 my $lookupre = $opts->{lookupre};
465 my $lookupcol= $opts->{lookupcol} || 1;
466 my $aspacked = $opts->{aspacked} && $this->{packed};
467 my $aspdl = $this->{pdl};
468 my @colnms = map {lc $_}
469 ($colnames && @$colnames ? @$colnames : @{$this->{cols}});
470
471 die "$err: Conversion to PDL requested too late.\n"
472 if ! $aspdl && $opts->{pdl};
473
474 die "$err: Conversion to PDL is incompatible with byrow and aspacked options.\n"
475 if $aspdl && ($aspacked || $byrow);
476
477 # In non-incremental mode, all data already exists in the 'rows'
478 # meta-data. If chunk was specified, we must read a chunk on each
479 # call of the data method
480 if($this->{chunk}) {
481 return 0 if $this->{eof};
482 _read_tbl($this,{meta=>$this})
483 or return;
484 return 0 if $this->{eof} && $this->{nrows} == 0;
485 }
486
487 if(! $byrow) {
488 # Column-ordered output; most efficient
489 if(@colnms != 1 || ! $single) {
490 # Multi column return
491 my %return = (! $colnames
492 ? % { _unpack($this,$this->{rows},$aspacked) }
493 : map { ($_ =>
494 _unpack($this,$this->{rows}{$_},$aspacked,$_))
495 } @colnms);
496 if($aspdl) {
497 require PDL::Lite; PDL::Lite->import;
498 for my $col (keys %return) {
499 if(defined $return{$col}) {
500 $return{$col} = PDL::Core::pdl($return{$col});
501 }
502 }
503 }
504 return wantarray ? %return : \%return;
505 } else {
506 # Single column return
507 my @cols = @{ _unpack($this,$this->{rows}{$colnms[0]},
508 $aspacked,$colnms[0]) };
509 if($aspdl) {
510 require PDL::Lite; PDL::Lite->import;
511 @cols = ( PDL::Core::pdl(\@cols) );
512 }
513 return wantarray ? @cols : \@cols;
514 }
515 } else {
516 # Row-ordered output
517 die "$err: Don't know how to do row retrieval for packed data.\n"
518 if $this->{packed};
519 my @rows;
520 push @colnms, $lookupcol if ! grep { lc($lookupcol) eq lc($_) } @colnms;
521 $rownums ||= [0..$this->{nrows}-1];
522 for my $i (@$rownums) {
523 if(! $single || @colnms != 1) {
524 push @rows, { map { ($_ => $this->{rows}{$_}[$i]) } @colnms }
525 if $hash;
526 push @rows, [ map { $this->{rows}{$_}[$i] } @colnms ]
527 if $ary;
528 } else {
529 push @rows, $this->{rows}{$colnms[0]}[$i];
530 }
531 }
532 if($lookup || $lookupre) {
533 $lookupcol = $colnms[0] if @colnms == 1 && $lookup eq '1'; # Default
534 return if ! $this->{rows}{lc $lookupcol};
535 if($lookup) {
536 # Exact matching (case independent)
537 $lookup = [$lookup] if ! ref $lookup;
538 if($opts->{stripap}) { s/^.*:+// for @$lookup; }
539 my %lookup = map { (lc($_)=>1) } @$lookup;
540 $rownums = [grep {
541 my $x = lc $rows[$_]{lc $lookupcol};
542 if($opts->{stripap}) { $x =~ s/^.*:+//; }
543 $lookup{$x}
544 }
545 @$rownums];
546 } else {
547 # Regex matching
548 $lookupre = [$lookupre] if ! ref $lookupre;
549 $lookupre = [ @$lookupre ]; # Shallow copy to avoid modifying arg
550 # Make initial '^' or traing '$' refer to the whole RE as a group
551 # rather than just the first/last eements
552 my $front = $lookupre->[0] =~ s/^\^(:?)//
553 ? '^'.($1 ? "(?:.*:)?" : "") : '';
554 my $back = $lookupre->[-1] =~ s/\$$// ? '$' : '';
555 $lookupre = "$front(?:(?:".join(")|(?:",@$lookupre)."))$back";
556 # Maybe I shouldn't do this, but I want to make matching
557 # easy, so I'm replacing dash and underscores with [-_]*
558 # in case people are lazy with their pattern
559 $lookupre =~ s|[-_]|[-_]*|g;
560 $rownums = [grep { my $tmp = lc $rows[$_]{lc $lookupcol};
561 $tmp =~ s/[-_]+//g;
562 $tmp =~ /$lookupre/i }
563 @$rownums];
564 }
565 return if ! $rownums;
566 @rows = @rows[@$rownums];
567 }
568 return (wantarray
569 ? @rows
570 : (! $single
571 ? \@rows
572 : (@rows <= 1
573 ? $rows[0]
574 : undef
575 )
576 )
577 );
578 }
579}
58012.0e-62.0e-6*tblrow = \&data;
58111.0e-61.0e-6*tblrows = \&data;
582
583sub _unpack {
584 return $_[1] if $_[2] || ! $_[0]->{packed}; # Keep set: Leave as is
585 my $meta = shift;
586 my $data = shift;
587 my $keep = shift; # Already used above
588 my $newdata;
589 if(ref($data) =~ /hash/i) {
590 # Multi-column hash ref
591 $newdata->{$_}
592 = [ unpack(col_pack_templates($meta,$_)."*",$data->{$_})]
593 for keys %$data;
594 } else {
595 # Single-column array ref
596 my $colnm = lc shift;
597 $newdata = [ unpack(col_pack_templates($meta,$colnm)."*",$data) ];
598 }
599 return $newdata;
600}
601
602sub last_row_nums {
603 return $_[0]->{_last_row_nums};
604}
605
606sub keys {
607 my $this = shift;
608 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
609 my $key = shift;
610 my $kv = ! $opts->{array};
611 if(defined $key) {
612 if(ref $key) {
613 my @vals = map { $this->{keyhash}{lc $_} } @$key;
614 return wantarray ? @vals : \@vals;
615 } else {
616 return $this->{keyhash}{lc $key};
617 }
618 } else {
619 if(! $kv) {
620 return wantarray ? @{$this->{keys}} : $this->{keys};
621 } else {
622 return wantarray ? %{$this->{keyhash}} : $this->{keyhash};
623 }
624 }
625}
62611.0e-61.0e-6*key = \&keys;
627
628sub title {
629 my $this = shift;
630 my $r = $this->keys({kv=>1});
631 return $r->{title};
632}
633
634
# spent 61.9ms (36µs+61.8) within WISE::IPACTbl::data_out which was called # once (36µs+61.8ms) by WISE::IPACTbl::data at line 447
sub data_out {
63511.0e-61.0e-6 my $meta = shift;
63611.1e-51.1e-5 my $opts = _is_opt(@_&&$_[-1]) && # Could still be data hash ...
# spent 16µs making 1 call to WISE::IPACTbl::_is_opt
637 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
63811.0e-61.0e-6 my $data = shift || $opts->{data} || $opts->{rows};
63914.0e-64.0e-6 my $err = "*** $0/WISE::IPACTbl::data(out)";
64019.0e-69.0e-6 $data = _rotate_data($meta,$data);
# spent 18µs making 1 call to WISE::IPACTbl::_rotate_data
641 #if($data) {
64211.3e-51.3e-5 WISE::IOUtils::make_ipac_tbl($meta->{obj_fh},$meta,undef,$data,
# spent 61.8ms making 1 call to WISE::IOUtils::make_ipac_tbl
643 {nohdr=>1,
644 fast=>$meta->{fast},
645 %$opts})
646 or die "$err: Unable to write to table '$meta->{file}'.\n";
647 #}
648 # Return true even if $data is undef (a header will have been written)
64915.0e-65.0e-6 return $data || 1;
650}
65111.0e-61.0e-6*write_tblrows = \&data_out;
65211.0e-61.0e-6*tblrows_out = \&data_out;
653
654sub addcol {
655 my $this = shift;
656 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
657 (@_>1 || ! defined $_[-1]{name}) ? pop(@_) : {};
658 my $def = shift || $opts->{def};
659 my $meta = $opts->{meta} || (ref($this) ? $this : undef);
660 my $err = "*** $0/WISE::IPACTbl::addcol";
661 die "$err: Can't call addcol as a class method unless meta is defined.\n"
662 if ! ref $this && ! $meta;
663 die "$err: No meta defined.\n"
664 if ! $meta;
665 die "$err: Column definition must be a reference.\n"
666 if ! ref $def;
667 if(ref($def) !~ /array/i) {
668 $def = [$def];
669 }
670 my @defs;
671 for my $d (@$def) {
672 # Convert to flat array form expected by underlying utility
673 push @defs, (ref($d) =~ /array/i
674 ? $d
675 : [
676 $d->{name},
677 $d->{type},
678 $d->{fmt},
679 $d->{after},
680 $d->{blank},
681 $d->{unit},
682 ]
683 );
684 }
685 WISE::IOUtils::add_ipac_cols($meta, \@defs)
686 or die "$err: Unable to add column(s).\n";
687 return $meta;
688}
68911.0e-61.0e-6*addcols = \&addcol;
690
691sub rmcol {
692 my $this = shift;
693 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
694 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
695 my $cols = shift || $opts->{cols};
696 my $meta = $opts->{meta} || (ref($this) ? $this : undef);
697 my $err = "*** $0/KEEPCOL";
698 die "$err: Can't call rmcol as a class method unless meta is defined.\n"
699 if ! ref $this && ! $meta;
700 die "$err: No meta defined.\n"
701 if ! $meta;
702 my @cols = ref $cols ? @$cols : ($cols);
703 WISE::IOUtils::del_ipac_cols($meta, @cols)
704 or die "$err: Unable to remove column(s).\n";
705 return $meta;
706}
70711.0e-61.0e-6*rmcols = \&rmcol;
708
709sub keepcol {
710 my $this = shift;
711 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
712 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
713 my $cols = shift || $opts->{cols};
714 my $meta = $opts->{meta} || (ref($this) ? $this : undef);
715 my $err = "*** $0/KEEPCOL";
716 die "$err: Can't call keepcol as a class method unless meta is defined.\n"
717 if ! ref $this && ! $meta;
718 die "$err: No meta defined.\n"
719 if ! $meta;
720 my %keepcols = map { lc($_)=>1 } (ref $cols ? @$cols : ($cols));
721 my @rmcols = grep { ! $keepcols{lc $_} } @{$meta->{names}};
722 $meta = meta_ipac($meta); # Get just tbl header stuff
723 WISE::IOUtils::del_ipac_cols($meta, @rmcols)
724 or die "$err: Unable to remove column(s).\n";
725 return $meta;
726}
72711.0e-61.0e-6*keepcols = \&keepcol;
728
729sub mvcol {
730 my $this = shift;
731 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
732 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
733 my $cols = shift || $opts->{cols};
734 my $meta = $opts->{meta} || (ref($this) ? $this : undef);
735 my $err = "*** $0/WISE::IPACTbl::mvcol";
736 die "$err/MVCOL: Column list not a reference.\n"
737 if ! ref $cols;
738 my @cols = ref($cols) =~ /hash/i ? %$cols : @$cols;
739 return 1 if ! @cols;
740 die "$err/MVCOL: Column list not paired.\n"
741 if (@cols%2) != 0;
742 if(! $meta->{ix}) {
743 $meta->{ix} = map { (lc($meta->{names})=>$_) } 0..$#{$meta->{names}};
744 }
745 while(@cols) {
746 my ($old,$new) = (shift(@cols), shift(@cols));
747 my $ix = $meta->{ix}{lc $old};
748 die "$err/MVCOL: Can't find column '$old'.\n"
749 if ! defined $ix;
750 $meta->{names}[$ix] = $new;
751 delete $meta->{ix}{lc $old};
752 $meta->{ix}{lc $new} = $ix;
753 }
754 return $meta;
755}
75611.1e-51.1e-5*mvcols = \&mvcol;
757
758sub sort_tbl {
759 my $this = shift;
760 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
761 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
762 my $cols = shift || $opts->{cols};
763 my $data = $opts->{data} || $this->{rows};
764 my $err = "*** $0/WISE::IPACTbl::sort_tbl";
765 my $types = $this->types({kv=>1});
766 WISE::IOUtils::sort_cols($data,$cols,$types,$opts)
767 or die "$err: Sort failed on '".$this->{file_name}."'.\n";
768 return $this;
769}
770
771sub dump_tbl {
772 my $this = shift;
773 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
774 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
775 my $cols = shift || $opts->{cols};
776 my $data = $opts->{data} || $this->{rows};
777 my $err = "*** $0/WISE::IPACTbl::dump_tbl";
778 my $out = WISE::IPACTbl->new("-","w",
779 {meta=>$this,cols=>$cols,data=>$data,
780 %$opts})
781 or die "$err: Couldn't dump '".$this->{file_name}."'.\n";
782 return $out->data($data);
783}
784
785
# spent 32µs within WISE::IPACTbl::_modes which was called # once (32µs+0) by WISE::IPACTbl::new at line 30
sub _modes {
78612.4e-52.4e-5 return {qw/
787 read_only r read r in r i r < r r r
788 write_only w write w out w o w > w w w
789 append a app a ap a >> a a a
790 /
791 }->{lc $_[0]};
792}
793
794# We want a hash, but not a hash that's a meta definition
795
# spent 42µs within WISE::IPACTbl::_is_opt which was called 2 times, avg 21µs/call: # once (26µs+0) by WISE::IPACTbl::new at line 23 # once (16µs+0) by WISE::IPACTbl::data_out at line 636
sub _is_opt {
79622.8e-51.4e-5 return @_ && $_[0] && ref($_[0])=~/hash/i &&
797 ! (ref($_[0]->{names})=~/array/i &&
798 ref($_[0]->{types})=~/array/i);
799}
800
801
# spent 41µs within WISE::IPACTbl::_rotate_data which was called 2 times, avg 20µs/call: # once (23µs+0) by WISE::IPACTbl::new at line 169 # once (18µs+0) by WISE::IPACTbl::data_out at line 640
sub _rotate_data {
80222.0e-61.0e-6 my $meta = shift;
80322.0e-61.0e-6 my $data = shift;
80425.0e-62.5e-6 my $err = "*** $0/WISE::IPACTbl::rotdata";
80525.0e-62.5e-6 my $warn = "=== $0/WISE::IPACTbl::rotdata";
80623.0e-61.5e-6 my $newdata = {};
80722.0e-61.0e-6 if(! ref($data) ) {
808 warn "$warn: Bad row data provided for output; Rows=".
809 (! defined $data ? "undef" :
810 (ref($data) ? "$data ref" : "non-ref")).".\n";
811 return;
812 }
81328.0e-64.0e-6 return $data if ref($data) =~ /hash/i;
814 for my $row (@$data) {
815 if(ref($row) =~ /array/i) { # Arrays
816 push @{$newdata->{lc $meta->{names}[$_]}}, $row->[$_]
817 for 0..$#$row;
818 } else { # hash
819 my @cols = map {lc $_} @{ $meta->{names} };
820 push @{$newdata->{lc $_}}, $row->{$_} for @cols;
821 }
822 }
823 return $newdata;
824}
825
826sub _init_as_null {
827 my $obj = shift;
828 my $opts = shift;
829 my $meta = $opts->{meta} || {};
830 $obj->{names} = [ @{$meta->{names} || []} ];
831 $obj->{types} = [ @{$meta->{types} || []} ];
832 $obj->{lens} = { @{$meta->{lens} || []} };
833 $obj->{start} = [ @{$meta->{start} || []} ];
834 $obj->{fmts} = [ @{$meta->{fmts} || []} ];
835 $obj->{blanks} = [ @{$meta->{blanks}|| []} ];
836 $obj->{units} = [ @{$meta->{units} || []} ];
837 $obj->{ix} = { %{$meta->{ix} || {}} };
838 $obj->{comments}= [];
839 $obj->{keys} = [];
840 $obj->{keyhash} = {};
841 $obj->{totrows} = 0;
842 $obj->{nrows} = 0;
843 $obj->{cols} = [];
844 $obj->{rows} = {};
845 return $obj;
846}
847
848
849package WISE::IPACTbl::Meta;
850
851# Sub-class for reading meta-data tables
852
85333.9e-51.3e-5use vars qw(@ISA);
# spent 32µs making 1 call to vars::import
854
85511.1e-51.1e-5@ISA = qw(WISE::IPACTbl);
856
85730.001900.00063use vars qw//;
858
859sub new {
860 my $this = shift;
861 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
862 my $file = shift || $opts->{file};
863 my $rawmode = shift || $opts->{mode} || 'r';
864 my $mode = _modes($rawmode);
865
866 if($mode eq 'r') {
867 } else {
868 $opts = {%$opts, meta=>metafile_meta($this,$opts)};
869 }
870
871 return $this->SUPER::new($file,$rawmode,$opts);
872}
873
874sub meta_item {
875 my $this = shift;
876 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
877 my $key = shift;
878 my $band = shift || $opts->{band};
879 my $re = $opts->{re};
880 my $v = $this->tblrow($opts->{colnames}||$opts->{cols}||'*','*',
881 {%$opts,single=>0,hashrow=>1,
882 lookupcol=>'name',
883 ($re?(lookupre=>$key):(lookup=>$key)),
884 });
885 if($band) {
886 # Reduce to one band if the band col is non-empty/zero
887 $v = [ grep { ! $_->{band} || $_->{band} == $band } @$v ];
888 }
889 if(! ($opts->{cols} || $opts->{colnames})) {
890 # Reduce to just the value column
891 $v = [ map { $_->{value} } @$v ];
892 }
893 if($opts->{single} // $this->{single}) {
894 if(@$v <= 1) {
895 $v = $v->[0];
896 }
897 else {
898 return;
899 }
900 }
901 return $v;
902}
903
904sub meta_hash {
905 my $this = shift;
906 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
907 my $whatband = $opts->{band};
908 my $v = $this->tblrows({%$opts,single=>0,hashrow=>1});
909 my %byname;
910 for my $val (@$v) {
911 my $band = $val->{band} > 0 ? $val->{band} : 0;
912 next if defined $whatband && $band != $whatband;
913 my $name = $val->{name};
914 $name =~ s/^.*:// if $opts->{short};
915 $val = $val->{value} if $opts->{simple};
916 if($opts->{single} && (! $band || $whatband)) {
917 # Reduce data structure depth when possible
918 $byname{$name} = $val;
919 $byname{lc $name} = $val if $name ne lc $name;
920 } else {
921 $byname{$name}[$band] = $val;
922 $byname{lc $name}[$band] = $val if $name ne lc $name;
923 }
924 }
925 return wantarray ? %byname : \%byname;
926}
927
928sub metafile_meta {
929 my $this = shift;
930 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
931
932 my $meta = $opts->{meta} ||
933 {
934 names => [qw/name band hdrname type value comment/],
935 types => [qw/c i c c c c /],
936 lens => [ 33, 5, 10, 5, 33, 51 ],
937 blanks=> [qw/null null null null null null /],
938 };
939
940 return $meta;
941}
942
943sub meta_unit {
944 my $this = shift;
945 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
946 my $val = shift;
947 return _meta_unit($val->{comment}||"");
948}
949
950sub _meta_unit {
951 my $comment = shift;
952 my ($unit) = $comment =~ /^\s*\[\s*([^\]]*?)\s*\]/;
953 return $unit;
954}
955
956sub meta_band_merge {
957 my $this = shift; # Object instance or class name (not used)
958 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
959 my $mrgmeta = shift;
960 my $metas = shift;
961 my $err = "*** $0/METABMRG";
962 my $metadef;
963 my @merge;
964 for my $metafile (@$metas) {
965 my $meta = WISE::IPACTbl->new($metafile)
966 or die "$err: Unable to read meta file '$metafile'.\n";
967 my $data = $meta->data({hashrow=>1})
968 or die "$err: Unable to get data from meta file '$metafile]'.\n";
969 # First all non-band dependent parts
970 if(! $metadef) {
971 push @merge, $data->[$_]
972 for grep {! $data->[$_]{band}} 0..$#$data;
973 $metadef = $meta->meta_ipac();
974 }
975 # Now band-dependent lines
976 push @merge, $data->[$_] for grep {$data->[$_]{band}} 0..$#$data;
977 }
978 # Write merged meta-data
979 print "Writing new, band-merged meta-data file '$mrgmeta' ...\n"
980 if $opts->{verbose};
981 my $meta = WISE::IPACTbl->new($mrgmeta,'w',
982 {meta=>$metadef,data=>\@merge})
983 or die "$err: Unable to write coadd meta file '$mrgmeta'.\n";
984 my $data = $meta->data(\@merge)
985 or die "$err: Unable to write data for coadd meta file ".
986 "'$mrgmeta'.\n";
987 return $data;
988}
989
990# Turn a selection of meta-rows into columns in a table row, updating
991# an optionally-supplied meta-table structure and row.
992sub meta_rotate {
993 my $this = shift;
994 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
995 my $names = shift;
996 my $band = shift || $opts->{band};
997 my $fillband = $opts->{fillband} && ! $band;
998 my $rotmeta = $opts->{meta} || {};
999 my $rotrow = $opts->{row} || {};
1000 my $rotdata = exists $opts->{data} ? $opts->{data}||1 : undef;
1001 my $datarow = $opts->{rownum};
1002 my $stripap = $opts->{stripap};
1003 my $noband = $opts->{noband};
1004 my $real = $opts->{real};
1005 my $re = $opts->{re};
1006 my $keywords = $opts->{keywords};
1007 my @keywords = $keywords ? (ref($keywords) ? @$keywords : $keywords) : ();
1008 my $nadded = 0;
1009 my $err = "*** $0/METAROT";
1010 die "$err: Need name list to match.\n" if ! $names;
1011 my %noband;
1012 if(ref $noband) {
1013 $noband{lc $_} = 1 for @$noband;
1014 $noband = 0;
1015 }
1016 SEARCH: {
1017 my $vals = $this->meta_item($names,$band,
1018 {cols=>'*', # Get all col.s, not just value
1019 re=>$re,
1020 });
1021 last SEARCH if ! $vals || ! @$vals;
1022 if(@keywords) {
1023 # Add values based on matching keywords in the header
1024 my $keys = $this->keys();
1025 for my $key (@keywords) {
1026 my $keyval = $keys->{lc $key};
1027 if(defined $keyval) {
1028 push @$vals,{name=>lc($key), band=>0, type=>'c', value=>$keyval};
1029 }
1030 }
1031 }
1032 for my $v (@$vals) {
1033 next if ! defined $v;
1034 my $name = $v->{name};
1035 $name =~ s/^.*:+// if $stripap;
1036 $name =~ s/:+/_/g;
1037 $name = "w$v->{band}$name"
1038 if $v->{band} && ! $noband && ! $noband{lc $name};
1039 if(! defined $rotmeta->{ix}{lc $name}) {
1040 my $type = ($v->{type} eq 'c' || $v->{type} eq 'r'
1041 ? $v->{type}
1042 : $real # type i; translte to 'r' or not?
1043 ? 'r'
1044 : 'i');
1045 my $unit = _meta_unit($v->{comment}||"");
1046 my @add = ($name);
1047 if($v->{band} && $fillband) {
1048 # Add columns for all bands if they're not there yet
1049 @add = (grep { ! defined $rotmeta->{ix}{lc $_} }
1050 map { my $n=$name; $n=~s/^w\d/w$_/; $n; }
1051 1..4);
1052 }
1053 for my $thisname (@add) {
1054 $this->addcol({name => $thisname,
1055 type => $type,
1056 blank =>
1057 {r=>"null", i=>"null", c=>"null"}->{$type},
1058 unit => $unit,
1059 },
1060 {
1061 meta => $rotmeta,
1062 });
1063 }
1064 }
1065 ++$nadded;
1066 $rotrow->{lc $name} = $v->{value};
1067 if($rotdata) {
1068 $rotdata = {} if $rotdata eq '1';
1069 $rotdata->{lc $name} ||= [];
1070 $datarow //= @{$rotdata->{lc $name}};
1071 $rotdata->{lc $name}[$datarow] = $v->{value};
1072 }
1073 }
1074 }
1075 return wantarray ? ($rotrow,$rotmeta,$rotdata eq '1' ? undef : $rotdata)
1076 : $rotrow;
1077}
1078
1079# Copy utility routine names into this package
108011.0e-61.0e-6*_modes = \&WISE::IPACTbl::_modes;
108111.0e-61.0e-6*_is_opt = \&WISE::IPACTbl::_is_opt;
1082
1083
108412.7e-52.7e-51;
1085

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