#!/usr/bin/perl -w # (C) Copyright 2010-2016 MET Norway # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # 02110-1301, USA. # pod included at end of file use strict; use Getopt::Long; use Pod::Usage qw(pod2usage); use Geo::BUFR; # Will be used if neither --tablepath nor $ENV{BUFR_TABLES} is set use constant DEFAULT_TABLE_PATH => '/usr/local/lib/bufrtables'; # Parse command line options our %option = (); GetOptions( \%option, 'bufr_edition=i', 'category=i', 'centre=i', 'compress=i', 'data=s%', 'day=i', 'help', 'hour=i', 'int_subcategory=i', 'loc_subcategory=i', 'local_table_version=i', 'master_table_version=i', 'minute=i', 'month=i', 'observed=i', 'outfile=s', 'remove_qc', 'remove_sec2', 'second=i', 'strict_checking=i', 'subcategory=i', 'subcentre=i', 'tablepath=s', 'update_number=i', 'verbose=i', 'year=i', 'year_of_century=i', ) or pod2usage(-verbose => 0); # User asked for help pod2usage(-verbose => 1) if $option{help}; # Make sure there is an input file pod2usage(-verbose => 0) unless @ARGV == 1; my $infile = $ARGV[0]; open(my $IN, '<',$infile) or die "Cannot open $infile: $!"; # Default is to ignore 'recoverable' errors found in decoded or # encoded BUFR format. This can be changed by setting strict_checking, # which will then apply both to decoding and encoding. my $strict_checking = defined $option{strict_checking} ? $option{strict_checking} : 0; Geo::BUFR->set_strict_checking($strict_checking); # Set verbosity level Geo::BUFR->set_verbose($option{verbose}) if $option{verbose}; # Set BUFR table path if ($option{tablepath}) { # Command line option --tablepath overrides all Geo::BUFR->set_tablepath($option{tablepath}); } elsif ($ENV{BUFR_TABLES}) { # If no --tablepath option, use the BUFR_TABLES environment variable Geo::BUFR->set_tablepath($ENV{BUFR_TABLES}); } else { # If all else fails, use the libbufr bufrtables Geo::BUFR->set_tablepath(DEFAULT_TABLE_PATH); } # Where to print the altered BUFR message(s) my $OUT; if ($option{outfile}) { open($OUT, '>', $option{outfile}) or die "Cannot open $option{outfile} for writing: $!"; } else { $OUT = *STDOUT; } binmode($OUT); # Change input separator to 'BUFR' my $oldeol = $/; $/ = 'BUFR'; # Read in everything before first 'BUFR' my $out = <$IN>; while (my $msg = <$IN>) { # Leave input unaltered if 'BUFR' is not start of a BUFR message if (length($msg) < 4) { $out .= $msg; next; } my $len = unpack 'N', "\0$msg"; if ($len < 8 || $len > length($msg) + 4) { $out .= $msg; next; } if (substr($msg,$len-8,4) != '7777') { $out .= $msg; next; } # 'BUFR' is quite probably start of a valid BUFR message, so # transfer 'BUFR' from $out to $msg, transfer text following BUFR # message from $msg to $out, and try to alter $msg. Input # separator must be reverted before calling Geo::BUFR routines chomp $out; my $rest = substr($msg,$len-4); $msg = 'BUFR' . substr($msg,0,$len-4); $/ = $oldeol; my $bufr = Geo::BUFR->new($msg); $out .= alter($bufr); $out .= $rest; $bufr->fclose(); $/ = 'BUFR'; } print $OUT $out if $out; # Extract data from BUFR file, possibly alter the data, and write the # new messages to STDOUT. sub alter { my $bufr = shift; # BUFR object if ($option{remove_qc}) { Geo::BUFR->set_noqc(); } my $new_bufr = Geo::BUFR->new(); my @subset_data; # Will contain data values for subset 1,2... my @subset_desc; # Will contain the set of descriptors for subset 1,2... READLOOP: while (not $bufr->eof()) { # Read (and decode) next observation my ($data, $descriptors) = $bufr->next_observation(); my $isub = $bufr->get_current_subset_number(); my $nsubsets = $bufr->get_number_of_subsets(); if ($isub == 1) { $new_bufr->copy_from($bufr,'metadata'); @subset_data = (); @subset_desc = (); set_section1_data($bufr, $new_bufr); if (defined $option{observed}) { $new_bufr->set_observed_data($option{observed}); } if (defined $option{compress}) { $new_bufr->set_compressed_data($option{compress}); } if ($option{remove_sec2}) { $new_bufr->set_optional_section(0); } if ($option{remove_qc}) { remove_qc_from_unexpanded($new_bufr); } } if (defined $option{data}) { DESCRIPTOR: while (my ($desc, $value) = each %{$option{data}}) { for (my $i=0; $i < @$descriptors; $i++) { if ($descriptors->[$i] == $desc) { if ($value =~ /(.*)\+$/) { $data->[$i] += $1; } elsif ($value eq 'missing') { $data->[$i] = undef; } else { $data->[$i] = $value; } next DESCRIPTOR; } } } } $subset_data[$isub] = $data; $subset_desc[$isub] = $descriptors; if ($isub == $nsubsets) { return $new_bufr->encode_message(\@subset_data, \@subset_desc); } } } sub set_section1_data { my ($bufr, $new_bufr) = @_; if (defined $option{centre}) { $new_bufr->set_centre($option{centre}); } if (defined $option{subcentre}) { $new_bufr->set_subcentre($option{subcentre}); } if (defined $option{update_number}) { if ($option{update_number} >= 0) { $new_bufr->set_update_sequence_number($option{update_number}); } else { my $old_number = $bufr->get_update_sequence_number(); my $update_number = $option{update_number}; if ($option{update_number} == -1) { $new_bufr->set_update_sequence_number($old_number + 1); } elsif ($option{update_number} == -2) { $new_bufr->set_update_sequence_number($old_number - 1); } else { pod2usage(-verbose => 1); } } } if (defined $option{category}) { $new_bufr->set_data_category($option{category}); } if (defined $option{subcategory}) { $new_bufr->set_data_subcategory($option{subcategory}); } if (defined $option{int_subcategory}) { $new_bufr->set_int_data_subcategory($option{int_subcategory}); } if (defined $option{loc_subcategory}) { $new_bufr->set_loc_data_subcategory($option{loc_subcategory}); } if (defined $option{master_table_version}) { $new_bufr->set_master_table_version($option{master_table_version}); } if (defined $option{local_table_version}) { $new_bufr->set_local_table_version($option{local_table_version}); } if (defined $option{year}) { $new_bufr->set_year($option{year}); } if (defined $option{year_of_century}) { $new_bufr->set_year_of_century($option{year_of_century}); } if (defined $option{month}) { $new_bufr->set_month($option{month}); } if (defined $option{day}) { $new_bufr->set_day($option{day}); } if (defined $option{hour}) { $new_bufr->set_hour($option{hour}); } if (defined $option{minute}) { $new_bufr->set_minute($option{minute}); } if (defined $option{second}) { $new_bufr->set_second($option{second}); } # Should be processed last of the change metadata options, # because setting of BUFR edition may depend on other # metadata which user has opted to set if (defined $option{bufr_edition}) { set_bufr_edition($option{bufr_edition}, $bufr, $new_bufr); } return; } sub remove_qc_from_unexpanded { my $bufr = shift; my $desc = $bufr->get_descriptors_unexpanded(); $desc =~ s/ 222000.*//; $bufr->set_descriptors_unexpanded($desc); } # If user hasn't provided the new metadata required for the new bufr # edition, we make some educated guesses of these new metadata. sub set_bufr_edition { my ($new_bufr_edition, $bufr, $new_bufr) = @_; my $old_bufr_edition = $bufr->get_bufr_edition(); if ($old_bufr_edition == 4 and $new_bufr_edition < 4) { if (!defined $new_bufr->get_data_subcategory()) { $new_bufr->set_data_subcategory($bufr->get_loc_data_subcategory()); } # get_year_of_century() fetches from YEAR if YEAR_OF_CENTURY isn't set $new_bufr->set_year_of_century($new_bufr->get_year_of_century()); } elsif ($old_bufr_edition < 4 and $new_bufr_edition == 4) { if (!defined $new_bufr->get_loc_data_subcategory()) { $new_bufr->set_loc_data_subcategory($bufr->get_data_subcategory()); } if (!defined $new_bufr->get_int_data_subcategory()) { $new_bufr->set_int_data_subcategory(255); # Undefined value } if (!defined $new_bufr->get_year()) { # Should work most of the time $new_bufr->set_year($bufr->get_year_of_century() + 2000); } if (!defined $new_bufr->get_second()) { $new_bufr->set_second(0); } } $new_bufr->set_bufr_edition($new_bufr_edition); } =pod =encoding utf8 =head1 SYNOPSIS bufralter.pl <bufr file> [--data <descriptor=value[+]>] [--bufr_edition <value>] [--centre <value>] [--subcentre <value>] [--update_number <value>] [--category <value>] [--subcategory <value>] [--int_subcategory <value>] [--loc_subcategory <value>] [--master_table_version <value>] [--local_table_version <value>] [--year <value>] [--year_of_century <value>] [--month <value>] [--day <value>] [--hour <value>] [--minute <value>] [--second <value>] [--observed 0|1] [--compress 0|1] [--remove_sec2] [--remove_qc] [--outfile <file>] [--strict_checking n] [--tablepath <path to BUFR tables>] [--verbose n] [--help] =head1 DESCRIPTION Will alter the BUFR messages in <bufr file> according to what is specified by the options provided. The modified file (text surrounding the BUFR messages will not be affected) will be printed to STDOUT (unless C<--outfile> is set). Execute without arguments for Usage, with option C<--help> for some additional info. =head1 OPTIONS --data <descriptor=value[+]> Set (first) data value in section 4 for descriptor. A trailing '+' means that the value should be added to existing value. Use 'missing' to set a missing value. Repeat the option if more sequence descriptors are to be set. Example: --data 004004=-1+ --data 00405=50 --data 012101=missing This will set the data value for first (and only first!) occurrence of these 3 descriptors in every subset and every message in <bufr file> to the given value (subtracting 1 from the existing value for 004004) --bufr_edition <value> Set BUFR edition to <value>. If the new edition involves some metadata not present in the old edition, some educated guesses for these new metadata are made, but you should also consider setting these new metadata explicitely --centre <value> Set originating centre to <value> --subcentre <value> Set originating subcentre to <value> --update_number <value> Set update sequence number to <value>. Use the special value -1 to increment existing update sequence number, -2 to decrement it --category <value> Set data category to <value> --subcategory <value> Set data sub-category to <value> --int_subcategory <value> Set international data sub-category to <value> --loc_subcategory <value> Set local data sub-category to <value> --master_table_version <value> Set master table version number to <value> --local_table_version <value> Set local table version number to <value> --<time_var> <value> Set <time_var> (= year | year_of_century | month | day | hour | minute | second) in section 1 to <value> --observed 0|1 Set observed data in section 3 to 0 or 1 --compress 0|1 Set compression in section 3 to 0 or 1 --remove_sec2 Remove optional section 2 if present --remove_qc Remove all quality control information, i.e. remove all descriptors from 222000 on --outfile <filename> Will print to <filename> instead of STDOUT --strict_checking n n=0 (default) Disable strict checking of BUFR format n=1 Issue warning if (recoverable) error in BUFR format n=2 Croak if (recoverable) error in BUFR format. Nothing more in this message will be decoded/encoded. --tablepath <path to BUFR tables> Set path to BUFR tables (overrides $ENV{BUFR_TABLES}) --verbose n Set verbose level to n, 0<=n<=6 (default 0). Verbose output is sent to STDOUT, so ought to be combined with option --outfile --help Display Usage and explain the options used. Almost the same as consulting perldoc bufralter.pl Options may be abbreviated, e.g. C<--he> or C<-he> for C<--help>. To avoid having to use the C<--tablepath> option, you are adviced to set the environment variable BUFR_TABLES to the directory where your BUFR tables are located (unless the default path provided by bufralter.pl works for you). =head1 AUTHOR Pål Sannes E<lt>pal.sannes@met.noE<gt> =head1 COPYRIGHT Copyright (C) 2010-2016 MET Norway =cut