view release on metacpan or  search on metacpan

lib/Weather/GHCN/App/StationCounts.pm  view on Meta::CPAN

    my ( $output, $new_fh, $old_fh );
    if ( $Opt->outclip and $USE_WINCLIP ) {
        open $new_fh, '>', \$output
            or die 'Unable to open buffer for write';
        $old_fh = select $new_fh;  ## no critic (ProhibitOneArgSelect)
    }

    my @files = $argv_aref->@*;
    @files = ($DASH) unless @files;

    foreach my $file (@files) {
        my $fh;
        if ($file eq $DASH) {
            $fh = *STDIN;
        } else {
            open $fh, '<', $file or die;
        }

        read_data( $fh, \%count );
    }

    say join "\t", qw(Year Decade Stn_Count);

    foreach my $yr (sort { $a <=> $b } keys %count) {
        my $stn_count = keys %{ $count{$yr} };
        ## no critic [ProhibitMagicNumbers]
        my $decade = (substr $yr, 0, 3) . '0s';
        say sprintf "%3d\t%s\t%d", $yr, $decade, $stn_count;
    }

WRAP_UP:
    # send output to the Windows clipboard
    if ( $Opt->outclip and $USE_WINCLIP ) {
        Win32::Clipboard->new()->Set( $output );
        select $old_fh; ## no critic [ProhibitOneArgSelect]
    }


    return;
}

########################################################################
# Script-specific Subroutines
########################################################################

=head2 read_data( $fh, \%count )

From the file handle $fh, read a list of stations in the format
generated by Fetch.pm, and count the stations that were active in any
given year.

=cut

sub read_data ($fh, $count_href) {
    my $lineno = 0;

    while ( my $data = <$fh> ) {
        chomp $data;
        next if $data =~ m{ \A \s* \Z }xms;

        my ($stnid, $co, $state, $active) = split m{\t}xms, $data;

        $lineno++;
        if ($lineno == 1) {
            die '*E* invalid input data'
                unless  $stnid eq 'StationId' and $active eq 'Active';
            next;
        }

        last if not $active;

        my @rangelist = parse_active_range($stnid, $active);

        next unless @rangelist;

        foreach my $range (@rangelist) {
            my ($from, $to) = split m{-}xms, $range;

            $to //= $from;

            foreach my $yr ($from..$to) {
                $count_href->{$yr}{$stnid}++;
            }
        }
    }

    return;
}

=head2 parse_active_range ($stnid, $active)

Sometime the active range in data retreived from the NOAA station
inventory is malformed. This routine tries to spot these malformed
ranges and fix them.

=cut

sub parse_active_range ($stnid, $active) {

    if ( $active =~ m{ \A \d\d,\d\d\d,\d\d\d \Z }xms ) {
        # misplaced commas, but we can fix it
        my $s = $active;
        $s =~ s{ [,] }{}xmsg;
        if ( $s =~ m{ (\d\d\d\d) (\d\d\d\d) }xms ) {
            $active = $1 . $DASH . $2;
        }
    }

    if ( $active !~ m{ \A $RANGELIST_RE \Z }xms ) {
        warn "*W* unrecognized range list at stnid $stnid: $active\n";
        return;
    }

    my @rangelist = split $COMMA, $active;

    return @rangelist;
}


########################################################################
# Script-standard Subroutines
########################################################################

=head2 get_options ( \@argv )

get_options encapsulates everything we need to process command line
options, or to set options when invoking this script from a test script.

Normally it's called by passing a reference to @ARGV; from a test script
you'd set up a local array variable to specify the options.

By convention, you should set up a file-scoped lexical variable named
$Opt and set it in the mainline using the return value from this function.
Then all options can be accessed used $Opt->option notation.

=cut

sub get_options ($argv_aref) {

    my @options = (
        'outclip',              # output data to the Windows clipboard
        'debug',                # enable debug() statements on stderr
        'help','usage|?',       # help
    );

    my %opt;

    # create a list of option key names by stripping the various adornments
    my @keys = map { (split m{ [!+=:|] }xms)[0] } grep { !ref  } @options;
    # initialize all possible options to undef
    @opt{ @keys } = ( undef ) x @keys;

    GetOptionsFromArray($argv_aref, \%opt, @options)
        or pod2usage(2);

    # Make %opt into an object and name it the same as what we usually
    # call the global options object.  Note that this doesn't set the
    # global -- the script will have to do that using the return value
    # from this function.  But, what this does is allow us to call
    # $Opt->help and other option within this function using the same
    # syntax as what we use in the script.  This is handy if you need
    # to rename option '-foo' to '-bar' because you can do a find/replace
    # on '$Opt->foo' and you'll get any instances of it here as well as
    # in the script.

    ## no critic [Capitalization]
    ## no critic [ProhibitReusedNames]
    my $Opt = _wrap_hash \%opt;

    pod2usage(1)             if $Opt->usage;
    pod2usage(-verbose => 2) if $Opt->help;


    return $Opt;
}

1;  # needed in case we import this as a module (e.g. for testing)

=head1 AUTHOR

Gary Puckering (jgpuckering@rogers.com)

=head1 LICENSE AND COPYRIGHT

Copyright 2022, Gary Puckering

=cut