view release on metacpan or  search on metacpan

RObufr.pp  view on Meta::CPAN

#/**----------------------------------------------------------------------
# @sub       getvalues
#
# Fetch the $values array structure from a BUFR object.  This structure
# looks like this:  $values = [[values from first field], [values from second field],...]
#              or:  $values = [single value from first field, single value from second field, ...]
# 
# @parameter  $self -- BUFR file to read
# @return     $values -- The object so called to get or print values can be chained.
# @exception  Can be raised
# ----------------------------------------------------------------------*/
sub getvalues {
  my $self = shift;

  die "No values structure set" if (!defined($self->{VALUES}));
  
  return $self->{VALUES};
}


#/**----------------------------------------------------------------------
# @sub       getbufr
#
# Fetch the BUFR message from a BUFR object.
# 
# @parameter  $self -- BUFR file to read
# @return     $bufr -- The BUFR file contents
# @exception  Can be raised
# ----------------------------------------------------------------------*/
sub getbufr {
  my $self = shift;

  die "No message set" if (!defined($self->{MESSAGE}));

  return $self->{GTSHDR} . $self->{MESSAGE} . $self->{GTSTRLR};  
}


#/**----------------------------------------------------------------------
# @sub       read
#
# Read in a BUFR file, extracting the values and storing them within the object.
# 
# @parameter  $file -- BUFR file to read
# @return     $self -- The object so called to get or print values can be chained.
# @exception  Can be raised
# ----------------------------------------------------------------------*/
sub read {
  my $self = shift;
  my $file = shift;

  my $bufrlib = $self->{BUFRLIB};
  my $seqfile = (-s "./gpsseq2.dat") ? "./gpsseq2.dat" : "$bufrlib/gpsseq2.dat";
  die "Cannot find sequence file gpsseq2.dat (looked in . and $bufrlib)" unless (-s $seqfile);

  # Read in code tables
  my $tabled = read_table_d("$bufrlib/TABLED");
  my $tableb = read_table_b("$bufrlib/TABLEB");

  $self->{BUFRTEXT} = do { local( @ARGV, $/ ) = $file; <> } ; # slurp!

  #
  ## Pull out the separate BUFR sections and lengths
  #
  my $ptr = CORE::index($self->{BUFRTEXT}, 'BUFR'); # Find start of BUFR file
  die "Cannot find BUFR section 0" if ($ptr < 0);
  
  $self->{SECTION0} = substr($self->{BUFRTEXT}, $ptr, 8);
  $ptr += 8;
  $self->{BUFR_LEN} = unpack ("N", "\x0" . substr($self->{SECTION0}, 4, 3));

  my $sec1_len = unpack ("N", "\x0" . substr($self->{BUFRTEXT}, $ptr, 3));
  $self->{SECTION1} = substr($self->{BUFRTEXT}, $ptr, $sec1_len);
  $ptr += $sec1_len;

  # Assume there is no section 2.
  
  my $sec3_len = unpack ("N", "\x0" . substr($self->{BUFRTEXT}, $ptr, 3));
  $self->{SECTION3} = substr($self->{BUFRTEXT}, $ptr, $sec3_len);
  $ptr += $sec3_len;

  my $sec4_len = unpack ("N", "\x0" . substr($self->{BUFRTEXT}, $ptr, 3));
  $self->{SECTION4} = substr($self->{BUFRTEXT}, $ptr, $sec4_len);
  $ptr += $sec4_len;

  $self->{SECTION5} = substr($self->{BUFRTEXT}, $ptr, 4);
  if ($self->{SECTION5} ne '7777') { die "Did not find correct section 5 (7777) at $ptr" }

  #
  ## Read in necessary values from section 1
  #
  $self->{NOBS}       = unpack "n", substr($self->{SECTION3}, 4, 2);
  $self->{COMPRESSED} = unpack ('C', substr($self->{SECTION3}, 6, 1)) & 0x40; # check flags byte, 0x40 = 'compressed'
  $self->{TOP_DESC}   = unpack_desc(unpack "n", substr($self->{SECTION3}, 7, 2)); # top level descriptor
  if ($self->{NOBS} > 1 && !$self->{COMPRESSED}) { die "Cannot handle multiple uncompressed observations" }

  # Expand descriptors.  $expanded_desc = [{NAME => '', UNITS => '', SCALE => S, REF => R, WIDTH => W}]
  # These expanded descriptors include 'leaf' or bottom level descriptors and modifying (2) descriptors.
  # All compound (3) descriptors have been expanded.
  $self->{EXPANDED_DESC} = expand_desc([$self->{TOP_DESC}], $tabled, $tableb);

  # Unpack section4 into either a single 1D @$values perl array (for a single obs) or
  # a list of lists:  @$values = ([obs1, ...], [obs2, ...], ...)
  $self->{VALUES} = $self->unpack_values;

  return $self;
  
}

#/**----------------------------------------------------------------------
# @sub       print
#
# Print out a text version of the descriptors and values
#
# @parameter  $self   -- RObufr object
# @return     $string -- String containing printout      
# @exception  Can be raised
# ----------------------------------------------------------------------*/
sub print {

RObufr.pp  view on Meta::CPAN

      unshift (@desc, $rep_desc) if ($y == 0);
      
    } else {

      # a modifying descriptor (starts with 2)
      if      ($x == 1) {
        $dw = ($y == 0) ? 0 : $dw + $y-128; # change of width
      } elsif ($x == 2) {
        $ds = ($y == 0) ? 0 : $ds + $y-128; # change of scale
      } else {
        die "Can only (currently) modify width or scale.  X = $x not yet supported."
      }
    }
  }

  $self->{PRINTOUT} = $printout;
  
  return (\@values);

}


#/**----------------------------------------------------------------------
# @sub       unpack_desc
# 
# Convert a two-byte coded descriptor into FXXYYY format.
# 
# @parameter  $desc -- Two-byte coded descriptor
# @return     $fxxyyy -- Decoded descriptor
# @exception  Can be raised
# ----------------------------------------------------------------------*/
sub unpack_desc {

  my $desc = shift;

  my $f = int($desc/16384);
  my $x = int(($desc-$f*16384)/256);
  my $y = int($desc-$f*16384-$x*256);

  return sprintf "%01d%02d%03d", $f, $x, $y;

}   


#/**----------------------------------------------------------------------
# @sub       readDesc
# 
# Function that reads a set of BUFR descriptors from the gpsseq.dat file
# 
# @parameter  $name -- The name of the desciptor sequence in gpsseq2.dat
# @           $file -- The full path of gpsseq2.dat
# @return     $desc -- An integer PDL of descriptors
# @exception  Can be raised
# ----------------------------------------------------------------------*/
sub readDesc {

  my $name = shift;
  my $file = shift;

  # magical slurp of data from $file
  my $text = do { local( @ARGV, $/ ) = $file ; <> } ;

  my ($desc) = ($text =~ m|\[$name\]\s*\d+ ([\d{6}\s*]+)|s);
  my @desc = split " ", $desc;

  # descriptors are 6 digits of the form FXXYYY.
  # Encode as desc[i] = (F * 64 + XX) * 256 + YYY
  #$desc = ( floor($desc/100000) * 64 + (floor($desc/1000) % 100) ) * 256 + ($desc % 1000);

  return \@desc;

}

#/**----------------------------------------------------------------------
# @sub       read_table_d
#
# Function that reads in the BUFR Table D file from UK MET and returns
# a perl structure:
#
# $tabled->{301045}[301011,004004,004005,201138,202131,004006,201000,202000,304030,304031];
#
# @parameter  $infile -- The name of the table D file
# @return     $tabled -- Structure as above
# @exception  Can be raised
# ----------------------------------------------------------------------*/
sub read_table_d {

  my $infile = shift;

  my %tabled = ();

  open my $fh, '<', $infile or die "Cannot open $infile";

  while (<$fh>) {
    chomp;
    next if (substr($_,0,1) ne '3'); # skip commentary lines that do not start with a compound descriptor
    my ($name, $n, @desc) = split /[ \?]+/;
    while ($n > @desc) { # look for more descriptors on continuation lines
      $_ = <$fh>;
      chomp;
      push (@desc, split /[ \?]+/);
    }
    $tabled{$name} = [@desc];
    @desc = ();
  }

  close $fh;

  return \%tabled;
}


#/**----------------------------------------------------------------------
# @sub       read_table_b
#
# Function that reads in the BUFR Table B file (which gives information
# on 'leaf' (bottom level) descriptors) from UK MET and returns
# a perl structure:
#
# $tableb->{027021}{NAME}  = 'IN DIRECTION OF 0 DEGREES LONGITUDE, DISTANCE FROM EARTH'S CENTR'
#                  {UNITS} = 'M'