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

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

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
2220.868630.87326WISE::IPACTbl::data
2210.001640.00164WISE::IPACTbl::_rotate_data
2220.000950.57971WISE::IPACTbl::new
1110.000130.57702WISE::IPACTbl::_read_tbl
4315.9e-55.9e-5WISE::IPACTbl::_is_opt
2114.6e-54.6e-5WISE::IPACTbl::_modes
1114.3e-50.00461WISE::IPACTbl::data_out
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::_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
234.2e-51.4e-5use strict;
# spent 23µs making 1 call to strict::import
333.8e-51.3e-5use warnings;
# spent 33µs making 1 call to warnings::import
4
5package WISE::IPACTbl;
6
760.000111.8e-5use 5.010;
# spent 59µs making 1 call to feature::import
8
912.0e-62.0e-6my $version = '$Id: IPACTbl.pm 7947 2010-06-03 18:33:21Z tim $ ';
10
1134.4e-51.5e-5use WISE::IOUtils;
# spent 30µs making 1 call to Exporter::import
12
13use vars qw/&ncols &ncolumns &nrows &types &type &column_type
# spent 415µs making 1 call to vars::import
14 &names &name &tblrow &tblrows &key &ipac_meta
15 &write_tblrows &tblrows_out &addcols &rmcols &keepcols &cols
1630.007410.00247 &blank &blanks &unit &units &mvcols &colix/;
17
18
# spent 580ms (953µs+579) within WISE::IPACTbl::new which was called 2 times, avg 290ms/call: # once (119µs+577ms) by WISE::Ingest::Seq::PEF::load_event_ipactbl at line 911 of /wise/base/deliv/dev/lib/perl/WISE/Ingest/Seq.pm # once (834µs+1.70ms) at line 316 of /wise/base/deliv/dev/bin/wdate
sub new {
194810.001022.1e-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.
23 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
# spent 27µs making 2 calls to WISE::IPACTbl::_is_opt, avg 14µs/call
24 my $err = "*** $0/WISE::IPACTbl::new";
25 my $warn = "=== $0/WISE::IPACTbl::new";
26 my $file = shift || $opts->{file};
27 die "$err: No input file specified (did you not call new as a method?).\n"
28 if ! defined $file;
29 my $rawmode = shift || $opts->{mode} || 'r';
30 my $mode = _modes($rawmode)
# spent 46µs making 2 calls to WISE::IPACTbl::_modes, avg 23µs/call
31 or die "$err: I/O mode '$rawmode' not recognized.\n";
32 my $colnames = $opts->{colnames} || $opts->{cols};
33 $colnames = undef if $colnames && $colnames eq '*';
34 $colnames = [$colnames] if $colnames && ! ref $colnames;
35 my @ok_mbrs = qw(packed nrows keys comments names types blanks units lens
36 start fmts ix read_pack_template);
37 my $class = ref($this) || $this;
38 my $fast = $opts->{fast} && ! $opts->{chunk};
39
40 my ($obj);
41
42 # Options for read or write
43 $obj->{packed} = $opts->{packed};
44 $obj->{chunk} = $opts->{chunk};
45 $obj->{file} = $file;
46 $obj->{file_name} = ! ref($file) ? $file : '<Internal>';
47 $obj->{debug} = $opts->{debug};
48 $obj->{fast} = $fast;
49 $obj->{robust} = $opts->{robust};
50 $obj->{error} = 1; # Reset to 0 uppon success below
51
52 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(ref($file) =~ /hash/i || (ref($file) =~ /array/i && ! ref($file->[0]))) {
66 # Parsed data structure
67 # Inherit from object or get emta-data from options
68 my $meta_in;
69 @{$meta_in}{@ok_mbrs} = @{$this}{@ok_mbrs} if ref $this;
70 if($opts->{meta}) {
71 $meta_in = $opts->{meta}; # Override
72 }
73 if(! $meta_in && ref($file) =~ /hash/i) {
74 $meta_in->{names} = [sort keys %$file];
75 }
76 die "$err: No meta info provided for data structure pass-through.\n"
77 if ! $meta_in;
78 if(ref($file) =~ /hash/i && ! ref((values(%$file))[0])) {
79 $_ = [$_] for values(%$file);
80 }
81 $meta_in->{rows} = _rotate_data($meta_in,$file);
82 if(! $meta_in->{types}) {
83 # Use duck typing
84 my $fpre = WISE::Utils::fpre();
85 for my $c (@{$meta_in->{names}}) {
86 my $t;
87 for my $v (@{$meta_in->{rows}{$c}}) {
88 next if ! defined $v;
89 $t = 'i', next if ($t//'i') eq 'i' && $v =~ /^[-+]\d+$/;
90 $t = 'c', last if $v !~ /$fpre/;
91 $t = 'r';
92 }
93 push @{$meta_in->{types}}, $t//'c';
94 }
95 }
96 @{$meta_in->{ix}}{map {lc $_} @{$meta_in->{names}}} = (0..$#{$meta_in->{names}});
97 my $nc = 0;
98 for (values(%{$meta_in->{rows}})) {
99 $nc = @$_ if defined $_ && @$_ > $nc;
100 }
101 $meta_in->{totrows} = $meta_in->{nrows} = $nc;
102 $meta_in->{cols} = [map {lc $_} @{$meta_in->{names}}];
103 $meta_in->{eof} = 1;
104 $obj->{$_} = $meta_in->{$_} for keys %$meta_in;
105 } else {
106 # File name, glob, or internal data string
107 if(! $obj->{robust} || ref $file || $file eq '-' ||
# spent 577ms making 1 call to WISE::IPACTbl::_read_tbl
108 (-e $file && ! -z _)) {
109 # Normal error handling; undef return on error
110 _read_tbl($obj,{hdronly => $opts->{hdronly}})
111 or return;
112 } else {
113 # Robust handling.
114 # Return a null table entry so caller can continue processing
115 warn "$err: File '$file' ".(! -e _ ? "doesn't exist" : "is empty").
116 ".\n";
117 _init_as_null($obj,$opts);
118 return bless $obj,$class;
119 }
120 }
121
122 if($obj->{cat} && $opts->{data} && $obj->{rows}) {
123 my $new = $obj->{rows};
124 my $nnew = $obj->{nrows};
125 my $old = $opts->{data};
126 my $nold = 0;
127 if(keys %$old) {
128 ($nold) = grep {$_} # Count of first non-empty column
129 map { scalar @{$old->{$_}} } keys %$old;
130 }
131 my %seen;
132 my @cols = grep {! $seen{$_}++} (keys %$new, keys %$old);
133 for my $col (@cols) {
134 if($old->{$col} && $new->{$col}) {
135 push @{$old->{$col}}, @{$new->{$col}};
136 } elsif($old->{$col}) {
137 push @{$old->{$col}}, (undef) x $nnew;
138 } else {
139 $old->{$col} = [(undef) x $nold];
140 push @{$old->{$col}}, @{$new->{$col}};
141 }
142 }
143 }
144
145 } else {
146
147 # Write or append mode
148
149 die "$err: Can't handle data ref as file in write mode.\n"
150 if ref $file;
151
152 my $meta_in;
153
154 my $append = $mode eq 'a' || $opts->{append};
155
156 # Inherit from object
157 @{$meta_in}{@ok_mbrs} = @{$this}{@ok_mbrs} if ref $this;
158
159 $meta_in = shift || $opts->{meta}; # Override
160
161 if(($append && ! $opts->{csv}) || $opts->{meta_from}) {
162 # Get from existing table file
163 my $from = $append ? $file : $opts->{meta_from};
164 $meta_in = _get_meta($from)
165 or die "$err: Unable to get header meta info from '$from'.\n";
166 if($append && $opts->{data}) {
167 warn "$warn: Can't resize columns from data in append mode.\n"
168 if $opts->{data};
169 $opts->{data} = undef;
170 }
171 }
172
173 # Sterilize meta_in of unwanted members and make a copy
174 my %meta_in;
175 @meta_in{@ok_mbrs} = @{$meta_in}{@ok_mbrs};
176 $meta_in = \%meta_in;
177
178 $meta_in->{append} = $append;
179 if($opts->{csv}) {
180 $meta_in->{csv} = $opts->{csv};
181 $meta_in->{nohdr} = 1;
182 $meta_in->{nokeys} = 1;
183 $meta_in->{nocoms} = 1;
184 } else {
185 $meta_in->{nohdr} = $opts->{nohdr};
186 $meta_in->{nokeys} = $opts->{nokeys};
187 $meta_in->{nocoms} = $opts->{nocoms};
188 }
189
190 my $keys = $meta_in->{nokeys}
191 ? undef
192 : $opts->{keys}//$meta_in->{keys};
193 my $coms = $meta_in->{nocoms}
194 ? undef
195 : $opts->{comments}//$meta_in->{comments};
196
197 if(! $meta_in->{csv}) {
198 # Regular IPAC table file; header data required
199 my @need = qw(names types);
200 my @missing = grep { ! $meta_in->{$_} } @need;
201 die "$err: Missing mandatory meta keys '@missing'.\n" if @missing;
202 }
203
204 my $data = $opts->{data};
205 my @names = map {lc $_} @{$meta_in->{names}};
206
207 if($data && ! $meta_in->{csv}) {
208 # Look for widest column values and widen the o/p column to suit
209 # if data is supplied
210 my %lenix;
211 @lenix{@names} = (0..$#names);
212 $data = _rotate_data($meta_in,$data);
# spent 1.20ms making 1 call to WISE::IPACTbl::_rotate_data
213 for my $col (@names) {
214 next if ! $data->{$col};
215 my $len = $meta_in->{lens}[$lenix{$col}] || length($col)+1;
216 for my $i (0 .. $#{ $data->{$col} || [] }) {
217 my $val = $data->{$col}[$i]||'XX';
218 my $lenval = length($val);
219 $len = $lenval+1 if $lenval >= $len;
220 }
221 $meta_in->{lens}[$lenix{$col}] = $len;
222 }
223 }
224
225 # Massage keys ...
226 if($keys) {
227 my($key,$val);
228 my $newkeys = [];
229 while (@$keys) {
230 $key = shift @$keys;
231 if(! ref $key) {
232 $val = shift @$keys;
233 $key = {name=>$key, value=>$val};
234 }
235 push @$newkeys, $key;
236 }
237 $keys = $newkeys;
238 }
239 if(! $meta_in->{nokeys}) {
240 $keys ||= [];
241 push @$keys, {name=>'wsds_release',
# spent 97µs making 1 call to WISE::Release::new # spent 13µs making 1 call to WISE::Release::release
242 value=>WISE::Release->new()->release()//'NONE'};
243 }
244
245 # Just write the header and leave the file open
246 my $fh = WISE::IOUtils::make_ipac_tbl(
# spent 352µs making 1 call to WISE::IOUtils::make_ipac_tbl
247 $file,
248 $meta_in,
249 $keys,
250 undef, # No data; wait for call to data() method
251 {
252 noclose => 1,
253 com => $coms,
254 nohdr => $meta_in->{nohdr},
255 append => $meta_in->{append},
256 })
257 or die "$err: Unable to create table '$file'.\n";
258 # Init meta
259 $obj = {%$obj, %$meta_in};
260 # Fill out rest of object meta-data; cribbed from slurp_ipac_tbl().
261 # !!! Should be provided by a method or helper func.
262 $obj->{obj_fh} = $fh;
263 $obj->{mode} = 'w';
264 $obj->{cols} = [map {lc $_} @names];
265 $obj->{nrows} = 0;
266 $obj->{totrows}= 0;
267 $obj->{keys} = $keys;
268 $obj->{comments} = $opts->{comments}||$meta_in->{comments};
269 $obj->{fh} = $fh;
270 $obj->{eof} = 0;
271 }
272
273 $obj->{error} = 0;
274
275 return bless $obj,$class;
276}
277
278sub rotate_data {
279 my $this = shift;
280 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
281 my $data = shift || $opts->{data};
282 return _rotate_data($this,$data);
283}
284
285sub meta {
286 return { %{$_[0]} }; # Unbless !!! Make deeper copy
287}
288
289sub meta_ipac {
290 my $meta = shift;
291 $meta = shift if ref $_[0];
292 return {
293 names => [ @{$meta->{names} || []} ],
294 types => [ @{$meta->{types} || []} ],
295 units => [ @{$meta->{units} || []} ],
296 blanks=> [ @{$meta->{blanks}|| []} ],
297 lens => [ @{$meta->{lens} || []} ],
298 start => [ @{$meta->{start} || []} ],
299 fmts => [ @{$meta->{fmts} || []} ],
300 ix => { %{$meta->{ix} || {}} },
301 };
302}
30314.0e-64.0e-6*ipac_meta = \&meta_ipac;
304
305sub _get_meta {
306 my $file = shift;
307 my $meta;
308 (undef,$meta) =
309 WISE::IOUtils::slurp_ipac_tbl($file, {lc => 1, hdronly => 1})
310 or return;
311
312 return $meta;
313}
314
315
# spent 577ms (135µs+577) within WISE::IPACTbl::_read_tbl which was called # once (135µs+577ms) by WISE::IPACTbl::new at line 107
sub _read_tbl {
31690.000131.5e-5 my $meta = shift;
317 my $opts = shift || {};
318 my $fast = $opts->{fast} || $meta->{fast};
319
320 my ($rows,$tmpmeta);
321 if(! $fast) {
322 ($rows,$tmpmeta) =
323 WISE::IOUtils::slurp_ipac_tbl($meta->{file},
324 {
325 meta => $opts->{meta},
326 nrows => $meta->{chunk},
327 lc => 1,
328 cols => $meta->{colnames},
329 skip_overflow =>
330 $meta->{skip_overflow},
331 packed => $meta->{packed},
332 ($meta->{pdl} ? (nanblank=>1) : ()),
333 hdronly => $opts->{hdronly},
334 debug => $opts->{debug} ||
335 $meta->{debug},
336 })
337 or return;
338 } else {
339 ($rows,$tmpmeta) =
# spent 577ms making 1 call to WISE::IOUtils::gulp_ipac_tbl
340 WISE::IOUtils::gulp_ipac_tbl($meta->{file},
341 {
342 cols=>$meta->{colnames},
343 }
344 )
345 or return;
346 }
347
348 # $tmpmeta also contains 'file', 'ix', 'nrows', etc.
349 @{$meta}{CORE::keys %$tmpmeta} = values %$tmpmeta;
350
351 $meta->{rows} = $rows;
352
353 return 1;
354}
355
356sub col_pack_templates {
357 my $this = shift;
358 state $type_tmpl8s = WISE::IOUtils::type_pack_templates();
359 if(! @_) {
360 my $col_tmpl8s = { map { ( $_ =>
361 $type_tmpl8s->
362 {$this->{types}[$this->{ix}{$_}]} )
363 } map {lc} @{ $this->{names} }
364 };
365 return wantarray ? %$col_tmpl8s : $col_tmpl8s;
366 }
367 my @tmpl8s=@{$type_tmpl8s}{@{$this->{types}}[@{$this->{ix}}{map {lc} @_}]};
368 return wantarray
369 ? @tmpl8s
370 : join("",@tmpl8s);
371}
372
373sub error {
374 my $this = shift;
375 return $this->{error};
376}
377
378sub comments {
379 my $this = shift;
380 return @{$this->{comments}};
381}
382
383sub column_names {
384 my $this = shift;
385 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
386 my $name = shift || $opts->{name};
387 if(! defined $name) {
388 return wantarray ? @{$this->{names}} : [@{$this->{names}}];
389 } else {
390 return grep { lc($_) eq lc($name) } @{$this->{names}};
391 }
392}
39312.0e-62.0e-6*names = \&column_names;
39412.0e-62.0e-6*name = \&column_names;
395
396sub column_index {
397 my $this = shift;
398 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
399 my $name = shift || $opts->{name};
400 if(! defined $name) {
401 return wantarray ? %{$this->{ix}} : {%{$this->{ix}}};
402 } else {
403 return $this->{ix}{lc $name};
404 }
405}
40612.0e-62.0e-6*colix = \&column_index;
407
408sub column_types {
409 my $this = shift;
410 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
411 my $col = shift;
412 my %kv = map { (lc($this->{names}[$_]) => $this->{types}[$_]) }
413 0..$#{$this->{names}};
414 return $kv{lc $col} if defined $col;
415 if(! $opts->{kv}) {
416 return @{$this->{types}};
417 } else {
418 return wantarray ? %kv : \%kv;
419 }
420}
42112.0e-62.0e-6*types = \&column_types;
42211.0e-61.0e-6*column_type = \&column_types;
42312.0e-62.0e-6*type = \&column_type;
424
425sub column_units {
426 my $this = shift;
427 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
428 my $col = shift;
429 my %kv = map { (lc($this->{names}[$_]) => $this->{units}[$_]) }
430 0..$#{$this->{names}};
431 return $kv{lc $col} if defined $col;
432 if(! $opts->{kv}) {
433 return @{$this->{types}};
434 } else {
435 return wantarray ? %kv : \%kv;
436 }
437}
43811.0e-61.0e-6*units = \&column_units;
43913.8e-53.8e-5*column_unit = \&column_units;
44012.0e-62.0e-6*unit = \&column_unit;
441
442sub column_blanks {
443 my $this = shift;
444 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
445 my $col = shift;
446 my %kv = map { (lc($this->{names}[$_]) => $this->{blanks}[$_]) }
447 0..$#{$this->{names}};
448 return $kv{lc $col} if defined $col;
449 if(! $opts->{kv}) {
450 return @{$this->{types}};
451 } else {
452 return wantarray ? %kv : \%kv;
453 }
454}
45511.0e-61.0e-6*blanks = \&column_blanks;
45611.0e-61.0e-6*column_blank = \&column_blanks;
45711.0e-61.0e-6*blank = \&column_blank;
458
459sub columns_read {
460 my $this = shift;
461 return wantarray ? @{$this->{cols}} : [@{$this->{cols}}];;
462}
46311.0e-61.0e-6*cols = \&columns_read;
464
465sub rows {
466 my $this = shift;
467 return $this->{nrows};
468}
46911.0e-61.0e-6*nrows = \&rows;
470
471sub totrows {
472 my $this = shift;
473 return $this->{totrows};
474}
475
476sub columns {
477 my $this = shift;
478 return scalar @{$this->{cols}};
479}
48011.0e-61.0e-6*ncols = \&columns;
48111.0e-61.0e-6*ncolumns = \&columns;
482
483sub done {
484 my $this = shift;
485 return $this->{eof};
486}
487
488
# spent 873ms (869+4.63) within WISE::IPACTbl::data which was called 2 times, avg 437ms/call: # once (869ms+21µs) by WISE::Ingest::Seq::PEF::load_event_ipactbl at line 913 of /wise/base/deliv/dev/lib/perl/WISE/Ingest/Seq.pm # once (11µs+4.61ms) at line 316 of /wise/base/deliv/dev/bin/wdate
sub data {
4891198840.868627.2e-6 my $this = shift;
490 return data_out($this,@_) if $this->{mode} eq 'w'; # <<<< Output
# spent 4.61ms making 1 call to WISE::IPACTbl::data_out
491 # vvvv Input vvvv
492 my $err = "*** $0/WISE::IPACTbl::data(in)";
493 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
# spent 21µs making 1 call to WISE::IPACTbl::_is_opt
494 my $colnames = shift || $opts->{colnames} || $opts->{cols};
495 $colnames = [$colnames] if $colnames && ! ref $colnames;
496 $colnames = undef if $colnames && $colnames->[0] eq '*';
497 my $rownums = shift;
498 $rownums = [$rownums] if defined $rownums && ! ref $rownums;
499 $rownums = undef if defined $rownums && $rownums->[0] eq '*';
500 my $single = $opts->{single} // $this->{single};
501 my $ary = ($opts->{aryrow } // $this->{aryrow});
502 my $hash = ($opts->{hashrow} // $this->{hashrow})
503 || ($rownums && ! $ary);
504 my $byrow = $ary || $hash;
505 my $fast = $opts->{fast} // $this->{fast};
506 my $lookup = $opts->{lookup};
507 my $lookupre = $opts->{lookupre};
508 my $lookupcol= $opts->{lookupcol} || 1;
509 my $aspacked = $opts->{aspacked} && $this->{packed};
510 my $aspdl = $this->{pdl};
511 my @colnms = map {lc $_}
512 ($colnames && @$colnames ? @$colnames : @{$this->{cols}});
513
514 die "$err: Conversion to PDL requested too late.\n"
515 if ! $aspdl && $opts->{pdl};
516
517 die "$err: Conversion to PDL is incompatible with byrow and aspacked options.\n"
518 if $aspdl && ($aspacked || $byrow);
519
520 # In non-incremental mode, all data already exists in the 'rows'
521 # meta-data. If chunk was specified, we must read a chunk on each
522 # call of the data method
523 if($this->{chunk}) {
524 return 0 if $this->{eof};
525 _read_tbl($this,{meta=>$this})
526 or return;
527 return 0 if $this->{eof} && $this->{nrows} == 0;
528 }
529
530 if(! $byrow) {
531 # Column-ordered output; most efficient
532 if(@colnms != 1 || ! $single) {
533 # Multi column return
534 my %return = (! $colnames
535 ? % { _unpack($this,$this->{rows},$aspacked) }
536 : map { ($_ =>
537 _unpack($this,$this->{rows}{$_},$aspacked,$_))
538 } @colnms);
539 if($aspdl) {
540 require PDL::Lite; PDL::Lite->import;
541 for my $col (keys %return) {
542 if(defined $return{$col}) {
543 $return{$col} = PDL::Core::pdl($return{$col});
544 }
545 }
546 }
547 return wantarray ? %return : \%return;
548 } else {
549 # Single column return
550 my @cols = @{ _unpack($this,$this->{rows}{$colnms[0]},
551 $aspacked,$colnms[0]) };
552 if($aspdl) {
553 require PDL::Lite; PDL::Lite->import;
554 @cols = ( PDL::Core::pdl(\@cols) );
555 }
556 return wantarray ? @cols : \@cols;
557 }
558 } else {
559 # Row-ordered output
560 die "$err: Don't know how to do row retrieval for packed data.\n"
561 if $this->{packed};
562 my @rows;
563 push @colnms, $lookupcol if ! grep { lc($lookupcol) eq lc($_) } @colnms;
564 $rownums ||= [0..$this->{nrows}-1];
565 for my $i (@$rownums) {
566 if(! $single || @colnms != 1) {
567 push @rows, { map { ($_ => $this->{rows}{$_}[$i]) } @colnms }
568 if $hash;
569 push @rows, [ map { $this->{rows}{$_}[$i] } @colnms ]
570 if $ary;
571 } else {
572 push @rows, $this->{rows}{$colnms[0]}[$i];
573 }
574 }
575 if($lookup || $lookupre) {
576 $lookupcol = $colnms[0] if @colnms == 1 && $lookup eq '1'; # Default
577 return if ! $this->{rows}{lc $lookupcol};
578 if($lookup) {
579 # Exact matching (case independent)
580 $lookup = [$lookup] if ! ref $lookup;
581 if($opts->{stripap}) { s/^.*:+// for @$lookup; }
582 my %lookup = map { (lc($_)=>1) } @$lookup;
583 $rownums = [grep {
584 my $x = lc $rows[$_]{lc $lookupcol};
585 if($opts->{stripap}) { $x =~ s/^.*:+//; }
586 $lookup{$x}
587 }
588 @$rownums];
589 } else {
590 # Regex matching
591 $lookupre = [$lookupre] if ! ref $lookupre;
592 $lookupre = [ @$lookupre ]; # Shallow copy to avoid modifying arg
593 # Make initial '^' or traing '$' refer to the whole RE as a group
594 # rather than just the first/last eements
595 my $front = $lookupre->[0] =~ s/^\^(:?)//
596 ? '^'.($1 ? "(?:.*:)?" : "") : '';
597 my $back = $lookupre->[-1] =~ s/\$$// ? '$' : '';
598 $lookupre = "$front(?:(?:".join(")|(?:",@$lookupre)."))$back";
599 # Maybe I shouldn't do this, but I want to make matching
600 # easy, so I'm replacing dash and underscores with [-_]*
601 # in case people are lazy with their pattern
602 $lookupre =~ s|[-_]|[-_]*|g;
603 $rownums = [grep { my $tmp = lc $rows[$_]{lc $lookupcol};
604 $tmp =~ s/[-_]+//g;
605 $tmp =~ /$lookupre/i }
606 @$rownums];
607 }
608 return if ! $rownums;
609 @rows = @rows[@$rownums];
610 }
611 return (wantarray
612 ? @rows
613 : (! $single
614 ? \@rows
615 : (@rows <= 1
616 ? $rows[0]
617 : undef
618 )
619 )
620 );
621 }
622}
62312.0e-62.0e-6*tblrow = \&data;
62412.0e-62.0e-6*tblrows = \&data;
625
626sub _unpack {
627 return $_[1] if $_[2] || ! $_[0]->{packed}; # Keep set: Leave as is
628 my $meta = shift;
629 my $data = shift;
630 my $keep = shift; # Already used above
631 my $newdata;
632 if(ref($data) =~ /hash/i) {
633 # Multi-column hash ref
634 $newdata->{$_}
635 = [ unpack(col_pack_templates($meta,$_)."*",$data->{$_})]
636 for keys %$data;
637 } else {
638 # Single-column array ref
639 my $colnm = lc shift;
640 $newdata = [ unpack(col_pack_templates($meta,$colnm)."*",$data) ];
641 }
642 return $newdata;
643}
644
645sub last_row_nums {
646 return $_[0]->{_last_row_nums};
647}
648
649sub keys {
650 my $this = shift;
651 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
652 my $key = shift;
653 my $kv = ! $opts->{array};
654 if(defined $key) {
655 if(ref $key) {
656 my @vals = map { $this->{keyhash}{lc $_} } @$key;
657 return wantarray ? @vals : \@vals;
658 } else {
659 return $this->{keyhash}{lc $key};
660 }
661 } else {
662 if(! $kv) {
663 return wantarray ? @{$this->{keys}} : $this->{keys};
664 } else {
665 return wantarray ? %{$this->{keyhash}} : $this->{keyhash};
666 }
667 }
668}
66912.0e-62.0e-6*key = \&keys;
670
671sub title {
672 my $this = shift;
673 my $r = $this->keys({kv=>1});
674 return $r->{title};
675}
676
677
# spent 4.61ms (43µs+4.57) within WISE::IPACTbl::data_out which was called # once (43µs+4.57ms) by WISE::IPACTbl::data at line 490
sub data_out {
67875.3e-57.6e-6 my $meta = shift;
679 my $opts = _is_opt(@_&&$_[-1]) && # Could still be data hash ...
# spent 11µs making 1 call to WISE::IPACTbl::_is_opt
680 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
681 my $data = shift || $opts->{data} || $opts->{rows};
682 my $err = "*** $0/WISE::IPACTbl::data(out)";
683 $data = _rotate_data($meta,$data);
# spent 436µs making 1 call to WISE::IPACTbl::_rotate_data
684 #if($data) {
685 WISE::IOUtils::make_ipac_tbl($meta->{obj_fh},$meta,undef,$data,
# spent 4.12ms making 1 call to WISE::IOUtils::make_ipac_tbl
686 {nohdr=>1,
687 fast=>$meta->{fast},
688 %$opts})
689 or die "$err: Unable to write to table '$meta->{file}'.\n";
690 #}
691 # Return true even if $data is undef (a header will have been written)
692 return $data || 1;
693}
69412.0e-62.0e-6*write_tblrows = \&data_out;
69511.0e-61.0e-6*tblrows_out = \&data_out;
696
697sub addcol {
698 my $this = shift;
699 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
700 (@_>1 || ! defined $_[-1]{name}) ? pop(@_) : {};
701 my $def = shift || $opts->{def};
702 my $meta = $opts->{meta} || (ref($this) ? $this : undef);
703 my $err = "*** $0/WISE::IPACTbl::addcol";
704 die "$err: Can't call addcol as a class method unless meta is defined.\n"
705 if ! ref $this && ! $meta;
706 die "$err: No meta defined.\n"
707 if ! $meta;
708 die "$err: Column definition must be a reference.\n"
709 if ! ref $def;
710 if(ref($def) !~ /array/i) {
711 $def = [$def];
712 }
713 my @defs;
714 for my $d (@$def) {
715 # Convert to flat array form expected by underlying utility
716 push @defs, (ref($d) =~ /array/i
717 ? $d
718 : [
719 $d->{name},
720 $d->{type},
721 $d->{fmt},
722 $d->{after},
723 $d->{blank},
724 $d->{unit},
725 ]
726 );
727 }
728 WISE::IOUtils::add_ipac_cols($meta, \@defs)
729 or die "$err: Unable to add column(s).\n";
730 return $meta;
731}
73211.0e-61.0e-6*addcols = \&addcol;
733
734sub rmcol {
735 my $this = shift;
736 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
737 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
738 my $cols = shift || $opts->{cols};
739 my $meta = $opts->{meta} || (ref($this) ? $this : undef);
740 my $err = "*** $0/KEEPCOL";
741 die "$err: Can't call rmcol as a class method unless meta is defined.\n"
742 if ! ref $this && ! $meta;
743 die "$err: No meta defined.\n"
744 if ! $meta;
745 my @cols = ref $cols ? @$cols : ($cols);
746 WISE::IOUtils::del_ipac_cols($meta, @cols)
747 or die "$err: Unable to remove column(s).\n";
748 return $meta;
749}
75011.0e-61.0e-6*rmcols = \&rmcol;
751
752sub keepcol {
753 my $this = shift;
754 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
755 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
756 my $cols = shift || $opts->{cols};
757 my $meta = $opts->{meta} || (ref($this) ? $this : undef);
758 my $err = "*** $0/KEEPCOL";
759 die "$err: Can't call keepcol as a class method unless meta is defined.\n"
760 if ! ref $this && ! $meta;
761 die "$err: No meta defined.\n"
762 if ! $meta;
763 my %keepcols = map { lc($_)=>1 } (ref $cols ? @$cols : ($cols));
764 my @rmcols = grep { ! $keepcols{lc $_} } @{$meta->{names}};
765 $meta = meta_ipac($meta); # Get just tbl header stuff
766 WISE::IOUtils::del_ipac_cols($meta, @rmcols)
767 or die "$err: Unable to remove column(s).\n";
768 return $meta;
769}
77012.5e-52.5e-5*keepcols = \&keepcol;
771
772sub mvcol {
773 my $this = shift;
774 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
775 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
776 my $cols = shift || $opts->{cols};
777 my $meta = $opts->{meta} || (ref($this) ? $this : undef);
778 my $err = "*** $0/WISE::IPACTbl::mvcol";
779 die "$err/MVCOL: Column list not a reference.\n"
780 if ! ref $cols;
781 my @cols = ref($cols) =~ /hash/i ? %$cols : @$cols;
782 return 1 if ! @cols;
783 die "$err/MVCOL: Column list not paired.\n"
784 if (@cols%2) != 0;
785 if(! $meta->{ix}) {
786 $meta->{ix} = map { (lc($meta->{names})=>$_) } 0..$#{$meta->{names}};
787 }
788 while(@cols) {
789 my ($old,$new) = (shift(@cols), shift(@cols));
790 my $ix = $meta->{ix}{lc $old};
791 die "$err/MVCOL: Can't find column '$old'.\n"
792 if ! defined $ix;
793 $meta->{names}[$ix] = $new;
794 delete $meta->{ix}{lc $old};
795 $meta->{ix}{lc $new} = $ix;
796 }
797 return $meta;
798}
79911.3e-51.3e-5*mvcols = \&mvcol;
800
801sub sort_tbl {
802 my $this = shift;
803 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
804 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
805 my $cols = shift || $opts->{cols};
806 my $data = $opts->{data} || $this->{rows};
807 my $err = "*** $0/WISE::IPACTbl::sort_tbl";
808 my $types = $this->types({kv=>1});
809 WISE::IOUtils::sort_cols($data,$cols,$types,$opts)
810 or die "$err: Sort failed on '".$this->{file_name}."'.\n";
811 return $this;
812}
813
814sub dump_tbl {
815 my $this = shift;
816 my $opts = _is_opt(@_&&$_[-1]) && # Could still be col. def. hash ...
817 (@_>1 || ref($_[-1]{data})=~/hash/i) ? pop(@_) : {};
818 my $cols = shift || $opts->{cols};
819 my $data = $opts->{data} || $this->{rows};
820 my $err = "*** $0/WISE::IPACTbl::dump_tbl";
821 my $out = WISE::IPACTbl->new("-","w",
822 {meta=>$this,cols=>$cols,data=>$data,
823 %$opts})
824 or die "$err: Couldn't dump '".$this->{file_name}."'.\n";
825 return $out->data($data);
826}
827
828
# spent 46µs within WISE::IPACTbl::_modes which was called 2 times, avg 23µs/call: # 2 times (46µs+0) by WISE::IPACTbl::new at line 30, avg 23µs/call
sub _modes {
82923.7e-51.9e-5 return {qw/
830 read_only r read r in r i r < r r r
831 write_only w write w out w o w > w w w
832 append a app a ap a >> a a a
833 /
834 }->{lc $_[0]};
835}
836
837# We want a hash, but not a hash that's a meta definition
838
# spent 59µs within WISE::IPACTbl::_is_opt which was called 4 times, avg 15µs/call: # 2 times (27µs+0) by WISE::IPACTbl::new at line 23, avg 14µs/call # once (21µs+0) by WISE::IPACTbl::data at line 493 # once (11µs+0) by WISE::IPACTbl::data_out at line 679
sub _is_opt {
83943.3e-58.3e-6 return @_ && $_[0] && ref($_[0])=~/hash/i &&
840 ! (ref($_[0]->{names})=~/array/i &&
841 ref($_[0]->{types})=~/array/i);
842}
843
844
# spent 1.64ms within WISE::IPACTbl::_rotate_data which was called 2 times, avg 818µs/call: # once (1.20ms+0) by WISE::IPACTbl::new at line 212 # once (436µs+0) by WISE::IPACTbl::data_out at line 683
sub _rotate_data {
8452580.001626.3e-6 my $meta = shift;
846 my $data = shift;
847 my $err = "*** $0/WISE::IPACTbl::rotdata";
848 my $warn = "=== $0/WISE::IPACTbl::rotdata";
849 my $newdata = {};
850 if(! ref($data) ) {
851 warn "$warn: Bad row data provided for output; Rows=".
852 (! defined $data ? "undef" :
853 (ref($data) ? "$data ref" : "non-ref")).".\n";
854 return;
855 }
856 return $data if ref($data) =~ /hash/i;
857 for my $row (@$data) {
858 if(ref($row) =~ /array/i) { # Arrays
859 push @{$newdata->{lc $meta->{names}[$_]}}, $row->[$_]
860 for 0..$#$row;
861 } else { # hash
862 my @cols = map {lc $_} @{ $meta->{names} };
863 push @{$newdata->{lc $_}}, $row->{$_} for @cols;
864 }
865 }
866 return $newdata;
867}
868
869sub _init_as_null {
870 my $obj = shift;
871 my $opts = shift;
872 my $meta = $opts->{meta} || {};
873 $obj->{names} = [ @{$meta->{names} || []} ];
874 $obj->{types} = [ @{$meta->{types} || []} ];
875 $obj->{lens} = { @{$meta->{lens} || []} };
876 $obj->{start} = [ @{$meta->{start} || []} ];
877 $obj->{fmts} = [ @{$meta->{fmts} || []} ];
878 $obj->{blanks} = [ @{$meta->{blanks}|| []} ];
879 $obj->{units} = [ @{$meta->{units} || []} ];
880 $obj->{ix} = { %{$meta->{ix} || {}} };
881 $obj->{comments}= [];
882 $obj->{keys} = [];
883 $obj->{keyhash} = {};
884 $obj->{totrows} = 0;
885 $obj->{nrows} = 0;
886 $obj->{cols} = [];
887 $obj->{rows} = {};
888 return $obj;
889}
890
891
892package WISE::IPACTbl::Meta;
893
894# Sub-class for reading meta-data tables
895
89634.5e-51.5e-5use vars qw(@ISA);
# spent 37µs making 1 call to vars::import
897
89811.3e-51.3e-5@ISA = qw(WISE::IPACTbl);
899
90030.002580.00086use vars qw//;
901
902sub new {
903 my $this = shift;
904 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
905 my $file = shift || $opts->{file};
906 my $rawmode = shift || $opts->{mode} || 'r';
907 my $mode = _modes($rawmode);
908
909 if($mode eq 'r') {
910 } else {
911 $opts = {%$opts, meta=>metafile_meta($this,$opts)};
912 }
913
914 return $this->SUPER::new($file,$rawmode,$opts);
915}
916
917sub meta_item {
918 my $this = shift;
919 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
920 my $key = shift;
921 my $band = shift || $opts->{band};
922 my $re = $opts->{re};
923 my $v = $this->tblrow($opts->{colnames}||$opts->{cols}||'*','*',
924 {%$opts,single=>0,hashrow=>1,
925 lookupcol=>'name',
926 ($re?(lookupre=>$key):(lookup=>$key)),
927 });
928 if($band) {
929 # Reduce to one band if the band col is non-empty/zero
930 $v = [ grep { ! $_->{band} || $_->{band} == $band } @$v ];
931 }
932 if(! ($opts->{cols} || $opts->{colnames})) {
933 # Reduce to just the value column
934 $v = [ map { $_->{value} } @$v ];
935 }
936 if($opts->{single} // $this->{single}) {
937 if(@$v <= 1) {
938 $v = $v->[0];
939 }
940 else {
941 return;
942 }
943 }
944 return $v;
945}
946
947sub meta_hash {
948 my $this = shift;
949 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
950 my $whatband = $opts->{band};
951 my $v = $this->tblrows({%$opts,single=>0,hashrow=>1});
952 my %byname;
953 for my $val (@$v) {
954 my $band = $val->{band} > 0 ? $val->{band} : 0;
955 next if defined $whatband && $band != $whatband;
956 my $name = $val->{name};
957 $name =~ s/^.*:// if $opts->{short};
958 $val = $val->{value} if $opts->{simple};
959 if($opts->{single} && (! $band || $whatband)) {
960 # Reduce data structure depth when possible
961 $byname{$name} = $val;
962 $byname{lc $name} = $val if $name ne lc $name;
963 } else {
964 $byname{$name}[$band] = $val;
965 $byname{lc $name}[$band] = $val if $name ne lc $name;
966 }
967 }
968 return wantarray ? %byname : \%byname;
969}
970
971sub metafile_meta {
972 my $this = shift;
973 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
974
975 my $meta = $opts->{meta} ||
976 {
977 names => [qw/name band hdrname type value comment/],
978 types => [qw/c i c c c c /],
979 lens => [ 33, 5, 10, 5, 33, 51 ],
980 blanks=> [qw/null null null null null null /],
981 };
982
983 return $meta;
984}
985
986sub meta_unit {
987 my $this = shift;
988 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
989 my $val = shift;
990 return _meta_unit($val->{comment}||"");
991}
992
993sub _meta_unit {
994 my $comment = shift;
995 my ($unit) = $comment =~ /^\s*\[\s*([^\]]*?)\s*\]/;
996 return $unit;
997}
998
999sub meta_band_merge {
1000 my $this = shift; # Object instance or class name (not used)
1001 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
1002 my $mrgmeta = shift;
1003 my $metas = shift;
1004 my $err = "*** $0/METABMRG";
1005 my $metadef;
1006 my @merge;
1007 for my $metafile (@$metas) {
1008 my $meta = WISE::IPACTbl->new($metafile)
1009 or die "$err: Unable to read meta file '$metafile'.\n";
1010 my $data = $meta->data({hashrow=>1})
1011 or die "$err: Unable to get data from meta file '$metafile]'.\n";
1012 # First all non-band dependent parts
1013 if(! $metadef) {
1014 push @merge, $data->[$_]
1015 for grep {! $data->[$_]{band}} 0..$#$data;
1016 $metadef = $meta->meta_ipac();
1017 }
1018 # Now band-dependent lines
1019 push @merge, $data->[$_] for grep {$data->[$_]{band}} 0..$#$data;
1020 }
1021 # Write merged meta-data
1022 print "Writing new, band-merged meta-data file '$mrgmeta' ...\n"
1023 if $opts->{verbose};
1024 my $meta = WISE::IPACTbl->new($mrgmeta,'w',
1025 {meta=>$metadef,data=>\@merge})
1026 or die "$err: Unable to write coadd meta file '$mrgmeta'.\n";
1027 my $data = $meta->data(\@merge)
1028 or die "$err: Unable to write data for coadd meta file ".
1029 "'$mrgmeta'.\n";
1030 return $data;
1031}
1032
1033# Turn a selection of meta-rows into columns in a table row, updating
1034# an optionally-supplied meta-table structure and row.
1035sub meta_rotate {
1036 my $this = shift;
1037 my $opts = _is_opt(@_&&$_[-1]) ? pop(@_) : {};
1038 my $names = shift;
1039 my $band = shift || $opts->{band};
1040 my $fillband = $opts->{fillband} && ! $band;
1041 my $rotmeta = $opts->{meta} || {};
1042 my $rotrow = $opts->{row} || {};
1043 my $rotdata = exists $opts->{data} ? $opts->{data}||1 : undef;
1044 my $datarow = $opts->{rownum};
1045 my $stripap = $opts->{stripap};
1046 my $noband = $opts->{noband};
1047 my $real = $opts->{real};
1048 my $re = $opts->{re};
1049 my $keywords = $opts->{keywords};
1050 my @keywords = $keywords ? (ref($keywords) ? @$keywords : $keywords) : ();
1051 my $nadded = 0;
1052 my $err = "*** $0/METAROT";
1053 die "$err: Need name list to match.\n" if ! $names;
1054 my %noband;
1055 if(ref $noband) {
1056 $noband{lc $_} = 1 for @$noband;
1057 $noband = 0;
1058 }
1059 SEARCH: {
1060 my $vals = $this->meta_item($names,$band,
1061 {cols=>'*', # Get all col.s, not just value
1062 re=>$re,
1063 });
1064 last SEARCH if ! $vals || ! @$vals;
1065 if(@keywords) {
1066 # Add values based on matching keywords in the header
1067 my $keys = $this->keys();
1068 for my $key (@keywords) {
1069 my $keyval = $keys->{lc $key};
1070 if(defined $keyval) {
1071 push @$vals,{name=>lc($key), band=>0, type=>'c', value=>$keyval};
1072 }
1073 }
1074 }
1075 for my $v (@$vals) {
1076 next if ! defined $v;
1077 my $name = $v->{name};
1078 $name =~ s/^.*:+// if $stripap;
1079 $name =~ s/:+/_/g;
1080 $name = "w$v->{band}$name"
1081 if $v->{band} && ! $noband && ! $noband{lc $name};
1082 if(! defined $rotmeta->{ix}{lc $name}) {
1083 my $type = ($v->{type} eq 'c' || $v->{type} eq 'r'
1084 ? $v->{type}
1085 : $real # type i; translte to 'r' or not?
1086 ? 'r'
1087 : 'i');
1088 my $unit = _meta_unit($v->{comment}||"");
1089 my @add = ($name);
1090 if($v->{band} && $fillband) {
1091 # Add columns for all bands if they're not there yet
1092 @add = (grep { ! defined $rotmeta->{ix}{lc $_} }
1093 map { my $n=$name; $n=~s/^w\d/w$_/; $n; }
1094 1..4);
1095 }
1096 for my $thisname (@add) {
1097 $this->addcol({name => $thisname,
1098 type => $type,
1099 blank =>
1100 {r=>"null", i=>"null", c=>"null"}->{$type},
1101 unit => $unit,
1102 },
1103 {
1104 meta => $rotmeta,
1105 });
1106 }
1107 }
1108 ++$nadded;
1109 $rotrow->{lc $name} = $v->{value};
1110 if($rotdata) {
1111 $rotdata = {} if $rotdata eq '1';
1112 $rotdata->{lc $name} ||= [];
1113 $datarow //= @{$rotdata->{lc $name}};
1114 $rotdata->{lc $name}[$datarow] = $v->{value};
1115 }
1116 }
1117 }
1118 return wantarray ? ($rotrow,$rotmeta,$rotdata eq '1' ? undef : $rotdata)
1119 : $rotrow;
1120}
1121
1122# Copy utility routine names into this package
112311.0e-61.0e-6*_modes = \&WISE::IPACTbl::_modes;
112411.0e-61.0e-6*_is_opt = \&WISE::IPACTbl::_is_opt;
1125
1126
112715.1e-55.1e-51;
1128

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