File Coverage

lib/Weather/GHCN/App/StationCounts.pm
Criterion Covered Total %
statement 100 111 90.0
branch 16 34 47.0
condition 5 12 41.6
subroutine 15 15 100.0
pod 4 4 100.0
total 140 176 79.5


line stmt bran cond sub pod time code
1             # ghcn_station_counts - Count stations in ghcn_fetch station output
2            
3             ## no critic (Documentation::RequirePodAtEnd)
4            
5             =head1 NAME
6            
7             Weather::GHCN::App::StationCounts - Count stations in Weather::GHCN::Fetch station output
8              
9             =head1 VERSION
10              
11             version v0.0.010
12            
13             =head1 SYNOPSIS
14            
15             use Weather::GHCN::App::StationCounts;
16            
17             Weather::GHCN::App::StationCounts->run( \@ARGV );
18            
19             See ghcn_station_counts -help for details.
20            
21             =cut
22            
23             ########################################################################
24             # Pragmas
25             ########################################################################
26            
27             # these are needed because perlcritic fails to detect that Object::Pad handles these things
28             ## no critic [ProhibitVersionStrings]
29             ## no critic [RequireUseWarnings]
30            
31 1     1   133863 use v5.18; # minimum for Object::Pad
  1         18  
32            
33             package Weather::GHCN::App::StationCounts;
34            
35             our $VERSION = 'v0.0.010';
36            
37 1     1   6 use feature 'signatures';
  1         2  
  1         171  
38 1     1   6 no warnings 'experimental::signatures';
  1         2  
  1         83  
39            
40             ########################################################################
41             # perlcritic rules
42             ########################################################################
43            
44             ## no critic [ErrorHandling::RequireCarping]
45             ## no critic [Modules::ProhibitAutomaticExportation]
46             ## no critic [Subroutines::ProhibitSubroutinePrototypes]
47            
48             # due to use of postfix dereferencing, we have to disable these warnings
49             ## no critic [References::ProhibitDoubleSigils]
50            
51            
52             ########################################################################
53             # Export
54             ########################################################################
55            
56             require Exporter;
57            
58 1     1   6 use base 'Exporter';
  1         2  
  1         164  
59            
60             our @EXPORT = ( 'run' );
61            
62             ########################################################################
63             # Libraries
64             ########################################################################
65 1     1   745 use Getopt::Long qw( GetOptionsFromArray );
  1         10453  
  1         4  
66 1     1   704 use Pod::Usage;
  1         54371  
  1         189  
67 1     1   604 use Const::Fast;
  1         2763  
  1         7  
68 1     1   792 use Hash::Wrap {-lvalue => 1, -defined => 1, -as => '_wrap_hash'};
  1         4989  
  1         8  
69 1     1   1416 use Const::Fast;
  1         3  
  1         7  
70 1     1   606 use English qw( -no_match_vars );
  1         1814  
  1         8  
71            
72 1     1   1012 use if $OSNAME eq 'MSWin32', 'Win32::Clipboard';
  1         14  
  1         7  
73            
74             ########################################################################
75             # Global delarations
76             ########################################################################
77            
78             # is it ok to use Win32::Clipboard?
79             our $USE_WINCLIP = $OSNAME eq 'MSWin32';
80            
81             my $Opt;
82            
83             ########################################################################
84             # Constants
85             ########################################################################
86            
87             const my $EMPTY => q(); # empty string
88             const my $SPACE => q( ); # space character
89             const my $COMMA => q(,); # comma character
90             const my $DASH => q(-); # dash character
91             const my $TAB => qq(\t); # tab character
92             const my $TRUE => 1; # perl's usual TRUE
93             const my $FALSE => not $TRUE; # a dual-var consisting of '' and 0
94            
95             const my $RANGE_RE => qr{ \d{4} ( [-] \d{4} )? }xms;
96             const my $RANGELIST_RE => qr{ $RANGE_RE ( [,] $RANGE_RE )* }xms;
97             const my $FIXABLE_RE => qr{ \A [\d,-]{4} \Z }xms;
98            
99             ########################################################################
100             # Script Mainline
101             ########################################################################
102             __PACKAGE__->run( \@ARGV ) unless caller;
103            
104             #-----------------------------------------------------------------------
105            
106             =head1 SUBROUTINES
107            
108             =head2 run ($progname, $argv_aref)
109            
110             Encapsulates the mainline logic so this module can be used in a test
111             script. An application script merely needs to use this module and
112             then call:
113            
114             Weather::GHCN::App::StationCounts->run( \@ARGV );
115            
116             See ghcn_station_counts -help for details.
117            
118             =cut
119            
120 1     1 1 1727 sub run ($progname, $argv_aref) {
  1         4  
  1         1  
  1         3  
121            
122 1         2 my %count;
123            
124 1         5 $Opt = get_options($argv_aref);
125            
126             ## no critic [RequireBriefOpen]
127 1         3 my ( $output, $new_fh, $old_fh );
128 1 0 33     23 if ( $Opt->outclip and $USE_WINCLIP ) {
129 0 0       0 open $new_fh, '>', \$output
130             or die 'Unable to open buffer for write';
131 0         0 $old_fh = select $new_fh; ## no critic (ProhibitOneArgSelect)
132             }
133            
134 1         522 my @files = $argv_aref->@*;
135 1 50       4 @files = ($DASH) unless @files;
136            
137 1         3 foreach my $file (@files) {
138 1         3 my $fh;
139 1 50       4 if ($file eq $DASH) {
140 0         0 $fh = *STDIN;
141             } else {
142 1 50       52 open $fh, '<', $file or die;
143             }
144            
145 1         6 read_data( $fh, \%count );
146             }
147            
148 1         66 say join "\t", qw(Year Decade Stn_Count);
149            
150 1         42 foreach my $yr (sort { $a <=> $b } keys %count) {
  929         1207  
151 154         324 my $stn_count = keys %{ $count{$yr} };
  154         437  
152             ## no critic [ProhibitMagicNumbers]
153 154         322 my $decade = (substr $yr, 0, 3) . '0s';
154 154         1728 say sprintf "%3d\t%s\t%d", $yr, $decade, $stn_count;
155             }
156            
157             WRAP_UP:
158             # send output to the Windows clipboard
159 1 0 33     38 if ( $Opt->outclip and $USE_WINCLIP ) {
160 0         0 Win32::Clipboard->new()->Set( $output );
161 0         0 select $old_fh; ## no critic [ProhibitOneArgSelect]
162             }
163            
164            
165 1         69 return;
166             }
167            
168             ########################################################################
169             # Script-specific Subroutines
170             ########################################################################
171            
172             =head2 read_data( $fh, \%count )
173            
174             From the file handle $fh, read a list of stations in the format
175             generated by Fetch.pm, and count the stations that were active in any
176             given year.
177            
178             =cut
179            
180 1     1 1 3 sub read_data ($fh, $count_href) {
  1         2  
  1         2  
  1         3  
181 1         3 my $lineno = 0;
182            
183 1         39 while ( my $data = <$fh> ) {
184 14         29 chomp $data;
185 14 100       55 next if $data =~ m{ \A \s* \Z }xms;
186            
187 12         50 my ($stnid, $co, $state, $active) = split m{\t}xms, $data;
188            
189 12         21 $lineno++;
190 12 100       27 if ($lineno == 1) {
191 1 50 33     9 die '*E* invalid input data'
192             unless $stnid eq 'StationId' and $active eq 'Active';
193 1         5 next;
194             }
195            
196 11 100       24 last if not $active;
197            
198 10         24 my @rangelist = parse_active_range($stnid, $active);
199            
200 10 50       30 next unless @rangelist;
201            
202 10         23 foreach my $range (@rangelist) {
203 10         23 my ($from, $to) = split m{-}xms, $range;
204            
205 10   66     27 $to //= $from;
206            
207 10         35 foreach my $yr ($from..$to) {
208 502         1061 $count_href->{$yr}{$stnid}++;
209             }
210             }
211             }
212            
213 1         24 return;
214             }
215            
216             =head2 parse_active_range ($stnid, $active)
217            
218             Sometime the active range in data retreived from the NOAA station
219             inventory is malformed. This routine tries to spot these malformed
220             ranges and fix them.
221            
222             =cut
223            
224 10     10 1 14 sub parse_active_range ($stnid, $active) {
  10         19  
  10         14  
  10         14  
225            
226 10 50       28 if ( $active =~ m{ \A \d\d,\d\d\d,\d\d\d \Z }xms ) {
227             # misplaced commas, but we can fix it
228 0         0 my $s = $active;
229 0         0 $s =~ s{ [,] }{}xmsg;
230 0 0       0 if ( $s =~ m{ (\d\d\d\d) (\d\d\d\d) }xms ) {
231 0         0 $active = $1 . $DASH . $2;
232             }
233             }
234            
235 10 50       111 if ( $active !~ m{ \A $RANGELIST_RE \Z }xms ) {
236 0         0 warn "*W* unrecognized range list at stnid $stnid: $active\n";
237 0         0 return;
238             }
239            
240 10         111 my @rangelist = split $COMMA, $active;
241            
242 10         35 return @rangelist;
243             }
244            
245            
246             ########################################################################
247             # Script-standard Subroutines
248             ########################################################################
249            
250             =head2 get_options ( \@argv )
251            
252             get_options encapsulates everything we need to process command line
253             options, or to set options when invoking this script from a test script.
254            
255             Normally it's called by passing a reference to @ARGV; from a test script
256             you'd set up a local array variable to specify the options.
257            
258             By convention, you should set up a file-scoped lexical variable named
259             $Opt and set it in the mainline using the return value from this function.
260             Then all options can be accessed used $Opt->option notation.
261            
262             =cut
263            
264 1     1 1 2 sub get_options ($argv_aref) {
  1         2  
  1         2  
265            
266 1         5 my @options = (
267             'outclip', # output data to the Windows clipboard
268             'debug', # enable debug() statements on stderr
269             'help','usage|?', # help
270             );
271            
272 1         2 my %opt;
273            
274             # create a list of option key names by stripping the various adornments
275 1         3 my @keys = map { (split m{ [!+=:|] }xms)[0] } grep { !ref } @options;
  4         15  
  4         10  
276             # initialize all possible options to undef
277 1         10 @opt{ @keys } = ( undef ) x @keys;
278            
279 1 50       6 GetOptionsFromArray($argv_aref, \%opt, @options)
280             or pod2usage(2);
281            
282             # Make %opt into an object and name it the same as what we usually
283             # call the global options object. Note that this doesn't set the
284             # global -- the script will have to do that using the return value
285             # from this function. But, what this does is allow us to call
286             # $Opt->help and other option within this function using the same
287             # syntax as what we use in the script. This is handy if you need
288             # to rename option '-foo' to '-bar' because you can do a find/replace
289             # on '$Opt->foo' and you'll get any instances of it here as well as
290             # in the script.
291            
292             ## no critic [Capitalization]
293             ## no critic [ProhibitReusedNames]
294 1         383 my $Opt = _wrap_hash \%opt;
295            
296 1 50       48 pod2usage(1) if $Opt->usage;
297 1 50       528 pod2usage(-verbose => 2) if $Opt->help;
298            
299            
300 1         431 return $Opt;
301             }
302            
303             1; # needed in case we import this as a module (e.g. for testing)
304            
305             =head1 AUTHOR
306            
307             Gary Puckering (jgpuckering@rogers.com)
308            
309             =head1 LICENSE AND COPYRIGHT
310            
311             Copyright 2022, Gary Puckering
312            
313             =cut
314