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

File/wise/base/deliv/dev/lib/perl/WISE/Ingest/Decom.pm
Statements Executed62
Total Time0.007575 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
00000WISE::Ingest::Decom::BEGIN
00000WISE::Ingest::Decom::_check_pkt_hdr
00000WISE::Ingest::Decom::_extract_frame
00000WISE::Ingest::Decom::_file_begend_pkthdrs
00000WISE::Ingest::Decom::_massage_pkt
00000WISE::Ingest::Decom::_read_stream
00000WISE::Ingest::Decom::_shorten_pkt
00000WISE::Ingest::Decom::_strip_pkt_hdr
00000WISE::Ingest::Decom::_unpack_pkt_hdr
00000WISE::Ingest::Decom::bracketing_hdrs
00000WISE::Ingest::Decom::bracketing_vtcs
00000WISE::Ingest::Decom::frame_hdr
00000WISE::Ingest::Decom::frame_nbytes
00000WISE::Ingest::Decom::frame_nbytes_compressed
00000WISE::Ingest::Decom::frame_num
00000WISE::Ingest::Decom::frames_missed
00000WISE::Ingest::Decom::frames_unknown
00000WISE::Ingest::Decom::gaps
00000WISE::Ingest::Decom::new
00000WISE::Ingest::Decom::next_frame
00000WISE::Ingest::Decom::pkt_vtc
00000WISE::Ingest::Decom::pkt_vtc_range
00000WISE::Ingest::Decom::pkt_vtcs_hash
00000WISE::Ingest::Decom::tlm_offset
00000WISE::Ingest::Decom::tlm_pkt_num
00000WISE::Ingest::Decom::vtc_epoch
00000WISE::Ingest::Decom::write_fits

LineStmts.Exclusive
Time		Avg.Code
1#! /usr/bin/env perl
2
333.8e-51.3e-5use strict;
# spent 17µs making 1 call to strict::import
436.2e-52.1e-5use warnings;
# spent 34µs making 1 call to warnings::import
5
6package WISE::Ingest::Decom;
7
8use WISE::Env (cfglib => "<:LIB:>",
# spent 1.20ms making 1 call to WISE::Env::import
9 mod => "WISE::Decom",
10 version => '$Id: Decom.pm 5957 2009-10-14 00:01:52Z tim $ ',
11 use_wise => 1,
1233.1e-51.0e-5 );
13
1430.001450.00048use WISE::Ingest::Rice;
# spent 9µs making 1 call to import
15
1634.0e-51.3e-5use IO::Handle;
# spent 40µs making 1 call to Exporter::import
1736.2e-52.1e-5use Fcntl;
# spent 489µs making 1 call to Exporter::import
1831.7e-55.7e-6use File::Basename ();
1935.5e-51.8e-5use Cwd ();
20
2111.5e-51.5e-5my ($err, $warn) = WISE::Env->err_prefix();
# spent 27µs making 1 call to WISE::Env::err_prefix
2211.0e-61.0e-6my $tlmerr = "$err [decom]";
23
2436.5e-52.2e-5use constant SrcPktSz => 1092;
# spent 73µs making 1 call to constant::import
2535.5e-51.8e-5use constant PriHdrSz => 6;
# spent 45µs making 1 call to constant::import
2633.4e-51.1e-5use constant SecHdrSz => 8;
# spent 95µs making 1 call to constant::import
2735.7e-51.9e-5use constant PktHdrSz => PriHdrSz + SecHdrSz;
# spent 86µs making 1 call to constant::import
2835.4e-51.8e-5use constant SrcDataSz => SrcPktSz - PktHdrSz;
# spent 44µs making 1 call to constant::import
2935.6e-51.9e-5use constant SciApID => 254;
# spent 43µs making 1 call to constant::import
3030.000103.4e-5use constant PktReadSz => 10*SrcPktSz;
# spent 96µs making 1 call to constant::import
31# id bnd cmp id bnd cmp id bnd cmp id bnd cmp
3211.6e-51.6e-5my %sci_pktids= (26=>[1, 1], 27=>[2, 1], 28=>[3, 1], 29 => [4, 1],
33 42=>[1, 0], 43=>[2, 0], 44=>[3, 0], 45 => [4, 0]);
3413.0e-63.0e-6my %pkthdr_defaults=(vsn=>0, type=>0, sechdr=>1, spare1=>0, apid=>SciApID);
35
3639.6e-53.2e-5use constant J2000 => WISE::Time::Str_time("2000-01-01T11:58:55.816Z");
# spent 307µs making 1 call to WISE::Time::Str_time # spent 122µs making 1 call to constant::import
3739.5e-53.2e-5use constant Y2007 => 7*365.25*86400;
# spent 94µs making 1 call to constant::import
3833.9e-51.3e-5use constant Nov09 => (8*365.25 + 10*30)*86400;
# spent 43µs making 1 call to constant::import
3930.005120.00171use constant May12 => (11*365.25 + 5*30)*86400;
# spent 92µs making 1 call to constant::import
40
41sub new {
42 my $this = shift;
43 my $opts = ref $_[-1] ? pop(@_) : {};
44 my $file = shift || $opts->{file};
45 die "$err: No input file specified.\n"
46 if ! defined $file;
47 my %riceopts = %{ ($opts->{riceopts} || $opts->{rice_opts}) || {} };
48 my @riceflags = @{ ($opts->{riceflags} || $opts->{rice_flags}) || [] };
49 my $verbose = $opts->{verbose} || $opts->{debug} || 0;
50 my $search = $opts->{search};
51 my $vtc_epoch = $opts->{vtc_epoch} || J2000;
52 $vtc_epoch = WISE::Time::Str_time($vtc_epoch)
53 if $vtc_epoch && $vtc_epoch !~ m|^[-+]\d+$|;
54 my $vtc0 = $opts->{vtc0} || 0;
55 die "$err: Illegal band '$opts->{band}' specified.\n"
56 if $opts->{band} && ($opts->{band} < 1 || $opts->{band} > 4);
57 my ($base) = $file =~ m|^(?:.*/)?([^.]+)|;
58
59 my $class = ref($this) || $this;
60
61 print "\n>>>>>>> Processing telemetry file '$file' ...\n"
62 if $verbose;
63
64 my ($fh,$tlm);
65
66 sysopen($fh, $file, O_RDONLY)
67 or die "$err: Unable to sysopen '$file'; $!\n";
68
69 # Search for start of a packet.
70 my ($hdr0, $hdr1, $off0) = _file_begend_pkthdrs($fh, $file, $search);
71
72 my %meta = (
73 file => $file,
74 base => $base,
75 cwd => Cwd::fastcwd(),
76 fh => $fh,
77 strict => $opts->{strict},
78 robust => ! $opts->{fragile},
79 frint => $opts->{frint} || 11,
80 gaps => 0,
81 tlm => '',
82 nfr => 0,
83 errmsg => '',
84 band => $opts->{band},
85 compressed => $opts->{compressed},
86 riceopts => { %riceopts, opt_flags => \@riceflags },
87 bpp => $opts->{bpp}||16,
88 Bpp => ($opts->{bpp}||16)/8,
89 datime => WISE::Time::Time_str(time(),{form=>1}),
90 nx => $opts->{nx},
91 ny => $opts->{ny},
92 nerr => 0,
93 vtcepoch => $vtc_epoch,
94 vtc0 => $vtc0,
95 pkt_vtcs => {},
96 ber => $opts->{ber} || 0,
97 verbose => $verbose,
98 maxerrs => $opts->{maxerrs} || $opts->{max_errs},
99 debug => $opts->{debug} || '',
100 showmuberr1 => $opts->{showmuberr1},
101 fr => undef,
102 off => $off0,
103 hdr0 => $hdr0,
104 hdr1 => $hdr1,
105 );
106
107 STDOUT->autoflush(1) if $meta{verbose};
108
109 my $meta = bless \%meta, $class;
110
111 return $meta;
112}
113
114# Get the next frame from a telemtry file.
115# Return values:
116# - Non-empty string reference: Next frame returned
117# . 'missing' != 0: Some frames were missed due to depacketizing error(s)
118# . 'missing' = 0 or undef: No problems.
119# . 'done' set: file exhausted, no more frames
120# - Empty string reference: EOF reached
121# . 'done' and 'eof' also set.
122# - Undef: Error depacketizing next frame
123# . 'done' set: End of file reached, 'missing' will be > 0
124# . 'done' not set: decompression error, more frames to come
125# - Exception thrown (die): unrecoverable error for this file
126
127sub next_frame {
128 my $this = shift;
129 die "$err: Object instance not initialized.\n"
130 if ! ref $this || ! $this->{fh};
131 my $opts = ref $_[-1] ? pop(@_) : {};
132 my $thiscompressed = $this->{compressed}; # Possible manual override
133 my $thisband = $this->{band}; # Possible manual override
134 my %thisriceopts = %{$this->{riceopts}};
135 my $verbose = $opts->{verbose} // $this->{verbose};
136 my $debug = $opts->{debug} // $this->{debug};
137 my $robust = $this->{robust};
138 my $file = $this->{file};
139 my ($bytes,$pktime,$pkid,$vtc,$hdr);
140
141 $this->{fr} = undef;
142 $this->{missed} = undef;
143 $this->{skipped} = undef;
144
145 # Still more packets?
146 if(! $this->{nfr} || length $this->{tlm}) {
147 # Yup
148 print "\n" if $debug && $this->{nfr};
149 } else {
150 # Nope. Normal end of file return.
151 $this->{eof} = 1;
152 $this->{done} = 1;
153 $bytes = "";
154 return \$bytes;
155 }
156
157 my $lastvtc;
158 $lastvtc = $this->{vtc_pkt} if defined $this->{vtc_pkt};
159 my $nfr = ++$this->{nfr};
160
161 # Strip (and get info from) packet headers, assemble a frame.
162 # $this->{tlm} is shortened within _extract_frame as the frame
163 # is pulled out.
164 ($hdr,$bytes) = _extract_frame($this);
165
166 # Error check and frame accounting
167 if(! $hdr) {
168 # Failed to assemble frame correctly
169 if($robust) {
170 # Scan for good start packet.
171 # ("Scan" just means silence warnings.)
172 while(! $hdr && length $this->{tlm}) {
173 ($hdr,$bytes) = _extract_frame($this,{scanning=>1,
174 debug=>$debug,});
175 }
176 if(! $hdr) {
177 if(! defined $lastvtc) {
178 # Couldn't read anything
179 die "$err: Failure depacketizing any of file='$file'.\n";
180 } else {
181 # Chunk missing off end
182 $this->{missed} = -2;
183 warn "$tlmerr: Unknown number of frames missed at end ".
184 "from ".
185 "frame $nfr after VTC=$lastvtc, file='$file'.\n";
186 $this->{done} = 1;
187 $this->{eof} = 1;
188 return;
189 }
190 } else {
191 # Sync'd up OK
192 if(defined $lastvtc) {
193 # Chunk missing from middle.
194 # Compute missing frame count.
195 $this->{missed} = int(($hdr->{vtcsecs} - $lastvtc)
196 /$this->{frint} + 0.5) - 1;
197 ++$this->{gaps};
198 warn "$tlmerr: Missed $this->{missed} frames ".
199 "at frame $nfr ".
200 "between VTC's $lastvtc and $hdr->{vtcsecs}, ".
201 "file='$file'.\n";
202 } else {
203 # Chunk missing off beginning
204 $this->{missed} = -1;
205 warn "$tlmerr: Unknown number of frames missed ".
206 "at start of file='$file'.\n";
207 }
208 warn "$warn: Resync'd at VTC=$hdr->{vtcsecs}.\n";
209 }
210 } else {
211 # Give up immediately
212 die "$err: Failed to extract frame from frame ".
213 "$nfr after VTC=$lastvtc, file='$file'.\n";
214 }
215 } else {
216 # We depacketized OK
217 if($lastvtc) {
218 # Were any frames skipped, probably due to normal data start/stops?
219 $this->{skipped} = int(($hdr->{vtcsecs} - $lastvtc)
220 /$this->{frint} + 0.5);
221 # Missing frames but with no depacketizing error is not an
222 # error condition since it will happen normally all the
223 # time. Checks for missing frames when there's no
224 # depacketizing error will have to happen at a higher
225 # level when correlation to scans is done. This goes for
226 # accounting for frames missing at the start/end of files too,
227 # with or without an error.
228 }
229 }
230
231 $this->{hdr} = $hdr;
232
233 # Pkt header info
234 $pktime = $hdr->{vtcsecs};
235 $pkid = $hdr->{pktid};
236 $vtc = $hdr->{vtc};
237 # Ignore internal pktid re band if we explicitely set it
238 $thisband = $hdr->{band} if ! $thisband;
239 # Ignore internal pktid re compression if we explicitely
240 # set it
241 $thiscompressed = $hdr->{compressed} if ! defined $thiscompressed;
242
243 print "\tExtracted ".length($bytes)." ".
244 ($thiscompressed ? "compressed" : "uncompressed").
245 " band $thisband frame bytes for ".
246 "frame $nfr with packet time $hdr->{vtcsecs} secs.\n"
247 if $verbose;
248
249 my $ninbytes = length($bytes);
250 $this->{ninbytes} = $ninbytes;
251
252 my ($thisnx,$thisny) = ($this->{nx} && $this->{ny}
253 ? ($this->{nx},$this->{ny})
254 : $thisband<4 ? (1024,1024) : (512,512));
255
256 my $thisnpix = $thisnx*$thisny;
257 my $thisnbytes = $thisnpix*$this->{Bpp};
258
259 $this->{expect} = $thisnbytes;
260
261 $this->{hdr}{nx} = $thisnx;
262 $this->{hdr}{ny} = $thisny;
263
264 if(defined $this->{ber} && $this->{ber}>0 && $thiscompressed) {
265 my $nb = 0;
266 for (1..$this->{ber}) {
267 # Inject (a) randomly placed bit error(s)
268 my $bit = ($this->{bit}>=0
269 ? $this->{bit}
270 : int(rand()*$ninbytes*8)) + $nb++;
271 my $mask = pack("C",1<<($bit%8));
272 print "\t(Flipped bit #$bit.)\n" if $this->{debug};
273 substr($bytes,$bit/8,1) ^= $mask;
274 }
275 }
276
277 my $nbytes = length $bytes;
278
279 if($thiscompressed) {
280
281 $this->{nbytes_compressed} = length($bytes);
282
283 print "\tDecompressing into $thisnbytes bytes ...\n"
284 if $debug;
285
286 $bytes = WISE::Ingest::Rice::WISE_decom(
287 $bytes,
288 output_buffer_size => $thisnbytes,
289 pixels_per_scanline=>
290 ($thisband<4?1024:512),
291 %thisriceopts,
292 );
293
294 if(! $bytes) {
295 warn "$tlmerr: Unable to decompress frame $nfr at ".
296 "VTC=$hdr->{vtcsecs}, file '$file'.\n";
297 return;
298 }
299
300 } else {
301 $this->{nbytes_compressed} = undef;
302 }
303
304 $this->{nbytes} = $nbytes = length($bytes);
305
306 # Check the frame size
307 if($nbytes != $thisnbytes) {
308 warn "$tlmerr: Frame $nfr size is unexpected ".
309 "($nbytes != $thisnbytes) ".
310 "at VTC=$hdr->{vtcsecs}, file='$file'.\n";
311 return;
312 }
313
314 print "\t... decompressed length = ".length($bytes)." bytes.\n"
315 if $verbose;
316
317 # Byte swap to Intel architecture
318 WISE::Ingest::Rice::swap2($bytes);
319
320 $this->{pkt_vtcs}{$this->{hdr}{vtcsecs}} = 2;
321
322 return \$bytes;
323}
324
325sub frames_missed {
326 return ($_[0]->{missed}||0) > 0 ? $_[0]->{missed} : 0;
327}
328
329sub frames_unknown {
330 return ($_[0]->{missed}||0) < 0 ? abs($_[0]->{missed}) : 0;
331}
332
333sub frame_hdr {
334 return $_[0]->{hdr};
335}
336
337sub frame_nbytes {
338 return $_[0]->{nbytes};
339}
340
341sub frame_nbytes_compressed {
342 return $_[0]->{nbytes_compressed};
343}
344
345sub frame_num {
346 return $_[0]->{nfr};
347}
348
349sub tlm_offset {
350 return $_[0]->{off};
351}
352
353sub tlm_pkt_num {
354 return $_[0]->{off}/SrcPktSz;
355}
356
357sub pkt_vtc_range {
358 return ($_[0]->{vtc_pkt0}, $_[0]->{vtc_pkt1});
359}
360
361sub pkt_vtc {
362 return $_[0]->{vtc_pkt};
363}
364
365sub pkt_vtcs_hash {
366 my %vtcs = %{ $_[0]->{pkt_vtcs} };
367 return wantarray ? %vtcs : \%vtcs;
368}
369
370sub gaps {
371 return $_[0]->{gaps};
372}
373
374sub bracketing_hdrs {
375 return ($_[0]->{hdr0}, $_[0]->{hdr1});
376}
377
378sub bracketing_vtcs {
379 my $this = shift;
380 my $slop = shift || 0;
381 my @hdrs = $this->bracketing_hdrs();
382 return ($hdrs[0]->{vtcsecs}-$slop, $hdrs[1]->{vtcsecs}+$slop);
383}
384
385sub vtc_epoch {
386 return $_[0]->{vtcepoch};
387}
388
389sub _file_begend_pkthdrs {
390 my $fh = shift;
391 my $file = shift;
392 my $search = shift;
393 my ($rc,@bad,$buf0,$buf1,$hdr0,$hdr1,$off0);
394
395 my $max = $search ? SrcPktSz-1 : 0;
396
397 # Search for 1st packet header
398
399 for my $off (0..$max) {
400 $rc = sysseek $fh, $off, 0;
401 die "$err: Unable to seek to start ($off) of '$file'; $!\n"
402 if ! defined $rc;
403
404 $rc = sysread $fh, $buf0, SrcPktSz;
405 die "$err: Unable to sysread start of '$file'; $!\n"
406 if ! defined $rc;
407 die "$err: Unable to read a full pkt header at start of '$file'; $!\n"
408 if $rc < PktHdrSz ;
409
410 my $pkthdr0 = _strip_pkt_hdr($buf0);
411 $hdr0 = _unpack_pkt_hdr($pkthdr0);
412
413 @bad = _check_pkt_hdr($hdr0);
414
415 $off0 = $off; # Real start of packet data (if ! @bad)
416 last if ! @bad;
417
418 if(! $search || $off == SrcPktSz-1) {
419 die "$tlmerr: Bad pkt hdr at start of '$file'.\n".
420 "$tlmerr: Bad value(s)=".
421 join(",",map{"$_->[1]=>$hdr0->{$_->[0]}"}@bad).".\n";
422 }
423 }
424
425 # Search for last packet header
426
427 for my $off (0..$max) {
428 my $endoff = SrcPktSz-$off;
429 if($endoff < PktHdrSz) { $endoff -= SrcPktSz; }
430
431 $rc = sysseek $fh, -$endoff, 2;
432 die "$err: Unable to seek to end (-$endoff) of '$file'; $!\n"
433 if ! defined $rc;
434
435 $rc = sysread $fh, $buf1, SrcPktSz;
436 die "$err: Unable to sysread end of '$file'; $!\n"
437 if ! defined $rc;
438 die "$err: Unable to read a full pkt header at end of '$file'; $!\n"
439 if $rc < PktHdrSz;
440
441 my $pkthdr1 = _strip_pkt_hdr($buf1);
442 $hdr1 = _unpack_pkt_hdr($pkthdr1);
443
444 @bad = _check_pkt_hdr($hdr1);
445
446 last if ! @bad; # Got a good packet header
447
448 if(! $search || $off == SrcPktSz-1) {
449 die "$tlmerr: Bad pkt hdr at end of '$file'.\n".
450 "$tlmerr: Bad value(s)=".
451 join(",",map{"$_->[1]=>$hdr1->{$_->[0]}"}@bad).".\n";
452 }
453 }
454
455 # Seek to start of packets
456 $rc = sysseek $fh, $off0, 0;
457 die "$err: Unable to seek back to start ($off0) of '$file'; $!\n"
458 if ! defined $rc;
459
460 return ($hdr0, $hdr1, $off0);
461}
462
463sub _extract_frame {
464 my $this = shift;
465 my $opts = shift || {};
466 my $scanning = $opts->{scanning}; # Scanning for good packet
467 my ($hdr,$pkt);
468 my $fr = "";
469 my $seqcnt = -1;
470 my $vtc;
471 my $scibytes_err_pkt;
472
473 while( 1 ) {
474 if(! $this->{end} && length $this->{tlm} < PktReadSz) {
475 # Too little data; read new chunk from stream
476 _read_stream($this);
477 }
478 last if ! length $this->{tlm};
479 $pkt = substr($this->{tlm},0,SrcPktSz,"");
480 $hdr = _massage_pkt($this,$scanning,$pkt) or return;
481 $scibytes_err_pkt = $hdr->{scibytes_err_pkt}
482 if ! defined $scibytes_err_pkt;
483 if($this->{debug} =~ /hdrs/ &&
484 ($hdr->{grpid}==1 || $this->{debug} =~ /hdrs_?all/)) {
485 printf("\tPkt %04d: ApID=%02X, PktID=%02X, ".
486 "GrpID=%1d, NSciBytes=%04d, Pktlen=%04d, VTC=%013.2f, ".
487 "RAW=%28s".
488 "\n",
489 $hdr->{seqcnt}, $hdr->{apid}, $hdr->{pktid}, $hdr->{grpid},
490 $hdr->{scibytes}, $hdr->{pktlen}, $hdr->{vtcsecs},
491 unpack("H*",$hdr->{raw}),
492 );
493 }
494 # Packet error checks
495 # Packet is shorter than a proper source packet should be
496 if(length($pkt) < SrcDataSz && $hdr->{grpid} != 2) {
497 warn "$tlmerr: Short pkt (".length($pkt)." != ".SrcDataSz.") ".
498 "at pkt #$hdr->{seqcnt}; ".
499 "Frame=$this->{nfr}, file='$this->{file}'.\n"
500 if ! $scanning;
501 return;
502 }
503 # First packet does not have expected packet counter value
504 if($hdr->{seqcnt} != 0 && $hdr->{grpid} == 1) {
505 warn "$tlmerr: Initial packet has pkt seqcnt #$hdr->{seqcnt} ".
506 "instead of 0; ".
507 "Frame=$this->{nfr}, file='$this->{file}'.\n"
508 if ! $scanning;
509 return;
510 }
511 # Packet header values out of range
512 if(my @bad = _check_pkt_hdr($hdr,$vtc,$seqcnt)) {
513 warn "$tlmerr: Bad pkt hdr at pkt #$hdr->{seqcnt}; ".
514 "Frame=$this->{nfr}, file='$this->{file}'.\n".
515 "$tlmerr: Bad value(s)=".
516 join(",",map{"$_->[1]=>$hdr->{$_->[0]}"}@bad).".\n"
517 if ! $scanning;
518 return;
519 }
520 $this->{pkt_vtcs}{$hdr->{vtcsecs}} = 1;
521 $vtc = $hdr->{vtc};
522 $seqcnt = $hdr->{seqcnt};
523 $fr .= $pkt;
524 $this->{off} += SrcPktSz;
525 last if $hdr->{done};
526 }
527
528 if(defined $scibytes_err_pkt && $scibytes_err_pkt != $hdr->{seqcnt}-1) {
529 warn "$tlmerr: SciBytes error detected in non-penultimate packet ".
530 "(err pkt=$scibytes_err_pkt, last pkt=$hdr->{seqcnt}); ".
531 "Frame=$this->{nfr}, file='$this->{file}'.\n";
532 return;
533 }
534
535 return ($hdr,$fr);
536}
537
538sub _massage_pkt { # $hdr = massage_pkt($pkt); # $pkt changed in place
539 my $this = shift;
540 my $scanning = shift;
541 my $pkthdr = _strip_pkt_hdr($_[0]);
542 my $hdr = _unpack_pkt_hdr($this,$pkthdr);
543 my $fill = _shorten_pkt($this,$hdr,$scanning,$_[0]);
544 return if ! defined $fill;
545 return $hdr;
546}
547
548sub _strip_pkt_hdr { # $pkthdr = strip_pkt_hdr($pkt); # $pkt changed in place
549 return substr($_[0],0,PktHdrSz,"");
550}
551
552sub _unpack_pkt_hdr { # $hdr = unpack_pkt_hdr($pkthdr);
553 my $this = shift;
554 my $hdr = shift;
555 $hdr = $this, $this = undef if ! $hdr;
556 my %hdr;
557 # from n swap sz
558 $hdr{vsn} = WISE::Ingest::Rice::unpack_bits($hdr, 0, 3, 1, 4);
559 $hdr{type} = WISE::Ingest::Rice::unpack_bits($hdr, 3, 1, 1, 4);
560 $hdr{sechdr} = WISE::Ingest::Rice::unpack_bits($hdr, 4, 1, 1, 4);
561 $hdr{spare1} = WISE::Ingest::Rice::unpack_bits($hdr, 5, 3, 1, 4);
562 $hdr{apid} = WISE::Ingest::Rice::unpack_bits($hdr, 8, 8, 1, 4);
563 $hdr{grpid} = WISE::Ingest::Rice::unpack_bits($hdr, 16, 2, 1, 4);
564 $hdr{seqcnt} = WISE::Ingest::Rice::unpack_bits($hdr, 18, 14, 1, 4);
565 $hdr{pktlen} = WISE::Ingest::Rice::unpack_bits($hdr, 32, 16, 1, 4);
566 $hdr{vtc} = WISE::Ingest::Rice::unpack_bits($hdr, 48, 40, 1, 8);
567 $hdr{vtc_isecs} = WISE::Ingest::Rice::unpack_bits($hdr, 48, 32, 1, 4);
568 $hdr{vtc_fsecs} = WISE::Ingest::Rice::unpack_bits($hdr, 80, 8, 1, 4);
569 $hdr{vtcsecs} = $hdr{vtc_isecs} + $hdr{vtc_fsecs}*4096/1e6;
570 $hdr{scibytes} = WISE::Ingest::Rice::unpack_bits($hdr, 96, 16, 1, 4);
571 $hdr{pktid} = WISE::Ingest::Rice::unpack_bits($hdr, 88, 8, 1, 4);
572 if($sci_pktids{$hdr{pktid}}) {
573 ($hdr{band}, $hdr{compressed})= @{ $sci_pktids{$hdr{pktid}} };
574 }
575 $hdr{raw} = $hdr;
576 if($this) {
577 $hdr{vtcsecs} += $this->{vtc0} || 0;
578 $this->{vtc_pkt0} = $hdr{vtcsecs} if ! defined $this->{vtc_pkt0};
579 $this->{vtc_pkt1} = $hdr{vtcsecs};
580 $this->{vtc_pkt} = $hdr{vtcsecs};
581 $this->{pkt_vtcs}{$hdr{vtcsecs}} = 0;
582 }
583 return \%hdr;
584}
585
586sub _check_pkt_hdr {
587 my $hdr = shift;
588 my $prev_vtc = shift;
589 my $seq = shift;
590 my $strict = shift;
591 my @bad = map { [$_,$_] }
592 (grep {$hdr->{$_} != $pkthdr_defaults{$_} }
593 qw(vsn type sechdr spare1 apid));
594 push @bad, ["pktid","pktid($hdr->{pktid})"] if ! $hdr->{band};
595 push @bad, ["vtcsecs","vtc_range"]
596 if $hdr->{vtcsecs} > May12 || ($strict && $hdr->{vtcsecs} < Nov09);
597 if(defined $prev_vtc) {
598 push @bad, ["vtc","vtc($prev_vtc)"] if $hdr->{vtc} != $prev_vtc;
599 }
600 if(defined $seq) {
601 push @bad, ["seqcnt","seq(".($seq+1).")"] if $hdr->{seqcnt} != $seq+1;
602 }
603 return @bad;
604 }
605
606sub _shorten_pkt { # $stripped = shorten_pkt($hdr,$pkt); # $pkt changed in place
607 my $this= shift;
608 my $hdr = shift;
609 my $scanning = shift;
610 my $pkt_data_sz = $hdr->{pktlen}+1 - 8;
611 my $sci_data_sz = $hdr->{scibytes};
612 if($pkt_data_sz != SrcDataSz) {
613 warn "$tlmerr: Partial packet at pkt #$hdr->{seqcnt}; ".
614 "Pkt_data_sz=$pkt_data_sz, Sci_data_sz=$sci_data_sz, ".
615 "nominal packet size=".SrcDataSz."; ".
616 "Frame=$this->{nfr}, file='$this->{file}'.\n"
617 if ! $scanning;
618 return;
619 }
620 if($pkt_data_sz < $sci_data_sz) { # Error
621 warn "$tlmerr: Science data exceeds packet size ".
622 "at pkt #$hdr->{seqcnt}; ".
623 "Pkt_data_sz($pkt_data_sz) < Sci_data_sz($sci_data_sz).\n"
624 if ! $scanning;
625 return;
626 }
627 # Last packet for this frame?
628 $hdr->{done} = 1 if $hdr->{grpid} == 2;
629 if($pkt_data_sz == $sci_data_sz) {
630 # Full packet, all is well
631 return "";
632 }
633 # Partial packet; scidata<pktsz. Should only happen on last packet
634 if($hdr->{grpid} != 2) { # Science data doesn't fill a packet
635 my $msg = "Data doesn't fill non-terminal pkt at ".
636 "pkt #$hdr->{seqcnt}; ".
637 "Pkt_data_sz($pkt_data_sz) > Sci_data_sz($sci_data_sz), ".
638 "but group flags=$hdr->{grpid}; ".
639 "Frame=$this->{nfr}, file='$this->{file}'.";
640 if($hdr->{grpid} == 1) { # Error if first packet
641 warn "$tlmerr: $msg.\n" if ! $scanning;
642 return;
643 } else {
644 # Could just be the known MUB pixel reformatter FPGA bug
645 # where an errorneous sci_data_sz i swritten to the 2nd-to-last
646 # packet. Change expected $sci_data_sz to be the whole packet.
647 warn "$warn: $msg.\n" if ! $scanning && $this->{showmuberr1};
648 $hdr->{scibytes} = $pkt_data_sz;
649 $hdr->{scibytes_err_pkt} = $hdr->{seqcnt};
650 return ""; # Full packet, all is well, sort of
651 }
652 }
653 # There's fill at the end; strip and return it
654 $hdr->{done} = 1;
655 return substr($_[0],$sci_data_sz,$pkt_data_sz-$sci_data_sz,"");
656}
657
658sub _read_stream {
659 my $this = shift;
660 my $new;
661 my $infh = $this->{fh};
662 my $rc = sysread $infh, $new, PktReadSz;
663 die "$err: Unable to sysread '$this->{file}'; $!\n"
664 if ! defined $rc;
665 warn "$warn: Failed to read full packet from '$this->{file}'.\n"
666 if $rc && ($rc%SrcPktSz) != 0;
667 $this->{tlm} .= $new if $rc;
668 if($this->{debug} =~ /read/) {
669 print "\t... read $rc stream bytes, ",
670 "offset now ",sysseek($infh,0,1)," bytes, ",
671 "buffer now ",length($this->{tlm}),
672 " bytes.\n";
673 }
674 $this->{end} = 1 if ! $rc
675}
676
677sub write_fits {
678 my $this = shift;
679 my $ofile = shift;
680 my $dref = shift;
681 my $opts = shift || {};
682 my ($file,$datime, $nfr,$ninbytes,$nbytes,$expect,$ber,$verbose)
683 = @{$this}{qw/file datime nfr ninbytes nbytes expect ber verbose/};
684 my ($thisnx,$thisny,$band,$pkid,$vtc)
685 = @{$this->{hdr}}{qw/nx ny band pkid vtcsecs/};
686
687 die "$err: Frame is incorrect size for FITS output to '$ofile', ".
688 "$nbytes bytes instead of $expect bytes; ".
689 "Frame=$nfr, file='$file'.\n"
690 if $nbytes != $expect;
691
692 print "\tWriting FITS file '$ofile'.\n"
693 if $verbose;
694
695 my $dir = File::Basename::dirname($ofile);
696
697 die "$err: Can't write to directory '$dir' for file '$ofile'; ".
698 "Frame=$nfr, file='$file'.\n"
699 if ! -r $dir || ! -w _ || ! -x _;
700
701 my @axes = ($thisnx,$thisny);
702 my $out = WISE::FITSIO->new($ofile,{mode=>'new',
703 hdudefs=>[{hdu=>[BITPIX=>16,
704 NAXIS=>scalar(@axes),
705 NAXES=>[@axes]]}]
706
707 })
708 or die "$err: Failed to open output FITS file '$ofile'".
709 "Frame=$nfr, file='$file'.\n";
710 $out->key([[BAND => $band,
711 DATIME => $datime,
712 VTCRAW => defined $vtc ? $vtc : -999,
713 PKID => defined $pkid ? $pkid : -999,
714 INFILE => $file,
715 NFRAME => $nfr,
716 INBYTES => $ninbytes,
717 RUNDIR => $this->{cwd},
718 EXEC => $0,
719 EXECTIME => (stat($0))[9]||0,
720 @{ $opts->{addhdr} || [] },
721 ]]
722 );
723 $out->writepix($dref)
724 or die "$err: Unable to write pixels to FITS file '$ofile'; ".
725 "Frame=$nfr, file='$file'.\n";
726
727 return;
728}
729
73011.3e-51.3e-51;

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