File Coverage

blib/lib/Geo/WebService/Elevation/USGS.pm
Criterion Covered Total %
statement 134 173 77.4
branch 42 90 46.6
condition 16 41 39.0
subroutine 28 33 84.8
pod 6 6 100.0
total 226 343 65.8


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Geo::WebService::Elevation::USGS - Elevation queries against USGS web services.
4              
5             =head1 SYNOPSIS
6              
7             use Geo::WebService::Elevation::USGS;
8            
9             my $eq = Geo::WebService::Elevation::USGS->new();
10             print "The elevation of the White House is ",
11             $eq->elevation( 38.898748, -77.037684 )->{Elevation},
12             " feet above sea level.\n";
13              
14             =head1 NOTICE
15              
16             The GIS data web service this module was originally based on has gone
17             the way of the dodo. This release uses the NED service, which is similar
18             but simpler. When the change was made, code was installed to ease the
19             transition by emulating the old service to the extent possible. This
20             code was deprecated pretty much when it was released as 0.100_01 in July
21             of 2014.
22              
23             With the release of 0.116_01 all this compatibility code has been
24             removed. Specifically, methods C and
25             C are gone, as are attributes C,
26             C, C, C, and C.
27              
28             =head1 DESCRIPTION
29              
30             This module executes elevation queries against the United States
31             Geological Survey's web NAD server. You provide the latitude and longitude
32             in degrees, with south latitude and west longitude being negative. The
33             return is typically a hash containing the data you want. Query errors
34             are exceptions by default, though the object can be configured to signal
35             an error by an undef response, with the error retrievable from the
36             'error' attribute.
37              
38             For documentation on the underlying web service, see
39             L.
40              
41             For all methods, the input latitude and longitude are documented at the
42             above web site as being WGS84, which for practical purposes I understand
43             to be equivalent to NAD83. The vertical reference is not documented
44             under the above link, but correspondence with the USGS says that it is
45             derived from the National Elevation Dataset (NED; see
46             L). This is referred to NAD83 (horizontal) and
47             NAVD88 (vertical). NAVD88 is based on geodetic leveling surveys, B
48             the WGS84/NAD83 ellipsoid,> and takes as its zero datum sea level at
49             Father Point/Rimouski, in Quebec, Canada. Alaska is an exception, and is
50             based on NAD27 (horizontal) and NAVD29 (vertical).
51              
52             Anyone interested in the gory details may find the paper I
53             GPS Height into NAVD88 Elevation with the GEOID96 Geoid Height Model> by
54             Dennis G. Milbert, Ph.D. and Dru A. Smith, Ph.D helpful. This is
55             available at L. This
56             paper states that the difference between ellipsoid and geoid heights
57             ranges between -75 and +100 meters globally, and between -53 and -8
58             meters in "the conterminous United States."
59              
60             =head2 Methods
61              
62             The following public methods are provided:
63              
64             =cut
65              
66             package Geo::WebService::Elevation::USGS;
67              
68 2     2   1592 use 5.008;
  2         12  
69              
70 2     2   11 use strict;
  2         4  
  2         43  
71 2     2   9 use warnings;
  2         4  
  2         58  
72              
73 2     2   9 use Carp;
  2         4  
  2         150  
74 2     2   1232 use HTTP::Request::Common;
  2         25803  
  2         209  
75 2     2   987 use JSON;
  2         9700  
  2         19  
76 2     2   2019 use LWP::UserAgent;
  2         50421  
  2         130  
77 2     2   29 use Scalar::Util 1.10 qw{ blessed looks_like_number };
  2         73  
  2         232  
78              
79             our $VERSION = '0.119';
80              
81             # use constant USGS_URL => 'https://ned.usgs.gov/epqs/pqs.php';
82 2     2   14 use constant USGS_URL => 'https://nationalmap.gov/epqs/pqs.php';
  2         6  
  2         195  
83              
84 2     2   13 use constant ARRAY_REF => ref [];
  2         6  
  2         120  
85 2     2   12 use constant CODE_REF => ref sub {};
  2         6  
  2         110  
86 2     2   12 use constant HASH_REF => ref {};
  2         4  
  2         116  
87 2     2   26 use constant REGEXP_REF => ref qr{};
  2         10  
  2         5815  
88              
89             my $using_time_hires;
90             {
91             my $mark;
92             if ( eval {
93             require Time::HiRes;
94             Time::HiRes->can( 'time' ) && Time::HiRes->can( 'sleep' );
95             } ) {
96             *_time = \&Time::HiRes::time;
97             *_sleep = \&Time::HiRes::sleep;
98             $using_time_hires = 1;
99             } else {
100             *_time = sub { return time };
101             *_sleep = sub { return sleep $_[0] };
102             }
103              
104             $mark = _time();
105             sub _pause {
106             ## my ( $self ) = @_; # Invocant unused
107 5     5   23 my $now = _time();
108 5         32 while ( $now < $mark ) {
109 0         0 _sleep( $mark - $now );
110 0         0 $now = _time();
111             }
112             # We use __PACKAGE__ rather than $self because the attribute is
113             # static, and it needs to be static because it needs to apply to
114             # everything coming from this user, not just everything coming
115             # from the invoking object.
116 5         45 $mark = $now + __PACKAGE__->get( 'throttle' );
117 5         14 return;
118             }
119             }
120              
121             =head3 $eq = Geo::WebService::Elevation::USGS->new();
122              
123             This method instantiates a query object. If any arguments are given,
124             they are passed to the set() method. The instantiated object is
125             returned.
126              
127             =cut
128              
129             sub new {
130 3     3 1 1536 my ($class, @args) = @_;
131 3 50       14 ref $class and $class = ref $class;
132 3 100       148 $class or croak "No class name specified";
133 2         6 shift;
134             my $self = {
135             carp => 0,
136             croak => 1,
137             error => undef,
138             places => undef,
139             retry => 0,
140       0     retry_hook => sub {},
141             timeout => 30,
142             trace => undef,
143             units => 'FEET',
144 2   50     31 usgs_url => $ENV{GEO_WEBSERVICE_ELEVATION_USGS_URL} || USGS_URL,
145             };
146 2         18 bless $self, $class;
147 2 100       14 @args and $self->set(@args);
148 2         9 return $self;
149             }
150              
151             my %mutator = (
152             croak => \&_set_literal,
153             carp => \&_set_literal,
154             error => \&_set_literal,
155             places => \&_set_integer_or_undef,
156             retry => \&_set_unsigned_integer,
157             retry_hook => \&_set_hook,
158             throttle => \&_set_throttle,
159             timeout => \&_set_integer_or_undef,
160             trace => \&_set_literal,
161             units => \&_set_literal,
162             usgs_url => \&_set_literal,
163             );
164              
165             my %access_type = (
166             throttle => \&_only_static_attr,
167             );
168              
169             foreach my $name ( keys %mutator ) {
170             exists $access_type{$name}
171             or $access_type{$name} = \&_no_static_attr;
172             }
173              
174             =head3 %values = $eq->attributes();
175              
176             This method returns a list of the names and values of all attributes of
177             the object. If called in scalar context it returns a hash reference.
178              
179             =cut
180              
181             sub attributes {
182 3     3 1 579 my $self = shift;
183 3         8 my %attr;
184 3         22 foreach (keys %mutator) {
185 33         71 $attr{$_} = $self->{$_};
186             }
187 3 100       30 return wantarray ? %attr : \%attr;
188             }
189              
190             =head3 $rslt = $usgs->elevation($lat, $lon, $valid);
191              
192             This method queries the data base for the elevation at the given
193             latitude and longitude, returning the results as a hash reference. This
194             hash will contain the following keys:
195              
196             {Data_Source} => A text description of the data source;
197              
198             {Elevation} => The elevation in the given units;
199              
200             {Units} => The units of the elevation (C<'Feet'> or C<'Meters'>);
201              
202             {x} => The C<$lon> argument;
203              
204             {y} => The C<$lat> argument.
205              
206             You can also pass a C, C, or C
207             object in lieu of the C<$lat> and C<$lon> arguments. If you do this,
208             C<$valid> becomes the second argument, rather than the third.
209              
210             If the optional C<$valid> argument is specified and the returned data
211             are invalid, nothing is returned. The NAD source does not seem to
212             produce data recognizable as invalid, so you will probably not see this.
213              
214             The NAD server appears to return an elevation of C<0> if the elevation
215             is unavailable.
216              
217             =cut
218              
219             sub elevation {
220 5     5 1 1032279 my ( $self, $lat, $lon, $valid ) = _latlon( @_ );
221 5         45 my $retry_limit = $self->get( 'retry' );
222 5         15 my $retry = 0;
223              
224 5         37 while ( $retry++ <= $retry_limit ) {
225              
226 5         14 $self->{error} = undef;
227              
228 5         25 $self->_pause();
229              
230 5         11 my $rslt;
231             eval {
232             $rslt = $self->_request(
233             x => $lon,
234             y => $lat,
235             units => $self->{units},
236 5         26 );
237 5         28 1;
238 5 50       12 } or do {
239 0         0 $self->_error( $@ );
240 0         0 next;
241             };
242              
243 5 50       21 $rslt
244             or next;
245              
246 5 50 33     27 not $valid
247             or is_valid( $rslt )
248             or next;
249              
250 5         38 return $rslt;
251              
252             } continue {
253              
254 0 0       0 if ( $retry <= $retry_limit ) {
255 0         0 ( my $sub = ( caller( 0 ) )[3] ) =~ s/ .* :: //smx;
256 0         0 $self->get( 'retry_hook' )->( $self, $retry, $sub, $lat,
257             $lon );
258             }
259              
260             }
261              
262 0 0       0 $self->{croak} and croak $self->{error};
263 0         0 return;
264              
265             }
266              
267             =head3 $value = $eq->get($attribute);
268              
269             This method returns the value of the given attribute. It will croak if
270             the attribute does not exist.
271              
272             =cut
273              
274             sub get {
275 38     38 1 4457 my ($self, $name) = @_;
276 38 100       300 $access_type{$name}
277             or croak "No such attribute as '$name'";
278 36         122 my $holder = $access_type{$name}->( $self, $name );
279 36         645 return $holder->{$name};
280             }
281              
282             =head3 $rslt = $eq->getAllElevations($lat, $lon, $valid);
283              
284             This method was removed in version 0.116_01. Please use the
285             C method instead. See the L above for
286             details.
287              
288             =head3 $rslt = $eq->getElevation($lat, $lon, $source, $elevation_only);
289              
290             This method was removed in version 0.116_01. Please use the
291             C method instead. See the L above for
292             details.
293              
294             =cut
295              
296             =head3 $boolean = $eq->is_valid($elevation);
297              
298             This method (which can also be called as a static method or as a
299             subroutine) returns true if the given datum represents a valid
300             elevation, and false otherwise. A valid elevation is a number having a
301             value greater than -1e+300. The input can be either an elevation value
302             or a hash whose {Elevation} key supplies the elevation value.
303              
304             =cut
305              
306             sub is_valid {
307 6     6 1 3150 my $ele = pop;
308 6         13 my $ref = ref $ele;
309 6 100       26 if ( HASH_REF eq $ref ) {
    100          
310 1         4 $ele = $ele->{Elevation};
311             } elsif ($ref) {
312 1         158 croak "$ref reference not understood";
313             }
314 5   100     44 return defined( $ele ) && looks_like_number($ele) && $ele > -1e+300;
315             }
316              
317             =head3 $eq = $eq->set($attribute => $value ...);
318              
319             This method sets the value of the given attribute. Multiple
320             attribute/value pairs may be specified. The object itself is returned,
321             to allow call chaining. An attempt to set a non-existent attribute will
322             result in an exception being thrown.
323              
324             =cut
325              
326             {
327              
328             # Changes in these values require re-instantiating the transport
329             # object. Or at least, they may do, under the following assumptions:
330             # HTTP_Post: timeout.
331             my %clean_transport_object = map { $_ => 1 } qw{ timeout };
332              
333             sub set { ## no critic (ProhibitAmbiguousNames)
334 11     11 1 5073 my ($self, @args) = @_;
335 11         22 my $clean;
336 11         42 while (@args) {
337 12         41 my ( $name, $val ) = splice @args, 0, 2;
338 12 100       191 $access_type{$name}
339             or croak "No such attribute as '$name'";
340 10 50       30 exists $mutator{$name}
341             or croak "Attribute '$name' is read-only";
342 10         34 _deprecate( attribute => $name );
343 10         26 my $holder = $access_type{$name}->( $self, $name );
344 10         41 $mutator{$name}->( $holder, $name, $val );
345 9   33     49 $clean ||= $clean_transport_object{$name};
346             }
347 8 50       25 $clean and delete $self->{_transport_object};
348 8         18 return $self;
349             }
350              
351             }
352              
353             sub _set_hook {
354 0     0   0 my ( $self, $name, $val ) = @_;
355 0 0       0 CODE_REF eq ref $val
356             or croak "Attribute $name must be a code reference";
357 0         0 return( $self->{$name} = $val );
358             }
359              
360             sub _set_integer_or_undef {
361 5     5   16 my ($self, $name, $val) = @_;
362 5 100 100     257 (defined $val && $val !~ m/ \A \d+ \z /smx)
363             and croak "Attribute $name must be an unsigned integer or undef";
364 4         20 return ($self->{$name} = $val);
365             }
366              
367             sub _set_literal {
368 5     5   16 return $_[0]{$_[1]} = $_[2];
369             }
370              
371             sub _set_throttle {
372 0     0   0 my ( $self, $name, $val ) = @_;
373 0 0       0 if ( defined $val ) {
374 0 0 0     0 looks_like_number( $val )
375             and $val >= 0
376             or croak "The $name attribute must be undef or a ",
377             'non-negative number';
378 0 0 0     0 $using_time_hires
      0        
379             or $val >= 1
380             or $val == 0
381             or $val = 1;
382             } else {
383 0         0 $val = 0;
384             }
385 0         0 return( $self->{$name} = $val );
386             }
387              
388             sub _set_unsigned_integer {
389 0     0   0 my ($self, $name, $val) = @_;
390 0 0 0     0 ( !defined $val || $val !~ m/ \A \d+ \z /smx )
391             and croak "Attribute $name must be an unsigned integer";
392 0         0 return ($self->{$name} = $val + 0);
393             }
394              
395             ########################################################################
396             #
397             # Private methods
398             #
399             # The author reserves the right to change these without notice.
400              
401             {
402             # NOTE to me: The deprecation of everything but 'compatible' is on
403             # hold until 'compatible' gets to 2. Then everything goes to 3
404             # together.
405             my %dep = (
406             attribute => {
407             dflt => sub { return },
408             item => {
409             compatible => 3,
410             default_ns => 3,
411             proxy => 3,
412             source => 3,
413             use_all_limit => 3,
414             },
415             },
416             subroutine => {
417             dflt => sub {
418             ( my $name = ( caller( 2 ) )[3] ) =~ s/ .* :: //smx;
419             return $name;
420             },
421             item => {
422             getElevation => 3,
423             getAllElevations => 3,
424             },
425             },
426             );
427              
428             sub _deprecate {
429 10     10   22 my ( $group, $item ) = @_;
430 10 50       36 my $info = $dep{$group}
431             or confess "Programming error - Deprecation group '$group' unknown";
432             defined $item
433 10 50 33     31 or defined( $item = $info->{dflt}->() )
434             or croak "Programming error - No item default for group '$group'";
435 10 50       34 $info->{item}{$item}
436             or return;
437 0         0 my $msg = ucfirst "$group $item is deprecated";
438 0 0       0 $info->{item}{$item} > 2
439             and croak "Fatal - $msg";
440 0 0       0 warnings::enabled( 'deprecated' )
441             or return;
442 0         0 carp "Warning - $msg";
443             $info->{item}{$item} == 1
444 0 0       0 and $info->{item}{$item} = 0;
445 0         0 return;
446             }
447             }
448              
449             # $ele->_error($text);
450             #
451             # Set the error attribute, and croak if the croak attribute is
452             # true. If croak is false, just return, carping if the carp
453             # attribute is true.
454              
455             sub _error {
456 0     0   0 my ($self, @args) = @_;
457 0         0 $self->{error} = join '', @args;
458             ## $self->{croak} and croak $self->{error};
459 0 0       0 $self->{croak} and return;
460 0 0       0 $self->{carp} and carp $self->{error};
461 0         0 return;
462             }
463              
464             # _instance( $object, $class )
465             # and print "\$object isa $class\n";
466             #
467             # Return true if $object is an instance of class $class, and false
468             # otherwise. Unlike UNIVERSAL::isa, this is false if the first
469             # object is not a reference.
470              
471             sub _instance {
472 14     14   32 my ( $object, $class ) = @_;
473 14 100       65 blessed( $object ) or return;
474 5         49 return $object->isa( $class );
475             }
476              
477             # my ($self, $lat, $lon, @_) = _latlon(@_);
478             #
479             # Strip the object reference, latitude, and longitude off the
480             # argument list. If the first argument is a Geo::Point,
481             # GPS::Point, or Net::GPSD::Point object the latitude and
482             # longitude come from it. Otherwise the first argument is assumed
483             # to be latitude, and the second to be longitude.
484              
485             {
486              
487             my %known = (
488             'Geo::Point' => sub {$_[0]->latlong('wgs84')},
489             'GPS::Point' => sub {$_[0]->latlon()},
490             'Net::GPSD::Point' => sub {$_[0]->latlon()},
491             );
492              
493             sub _latlon {
494 5     5   23 my ($self, $obj, @args) = @_;
495 5         29 foreach my $class (keys %known) {
496 14 100       39 if (_instance( $obj, $class ) ) {
497 2         71 return ($self, $known{$class}->($obj), @args);
498             }
499             }
500 3         16 return ($self, $obj, @args);
501             }
502             }
503              
504             {
505             my %static = ( # Static attribute values.
506             throttle => 0,
507             );
508              
509             # $self->_no_static_attr( $name );
510             #
511             # Croaks if the invocant is not a reference. The message assumes
512             # the method was called trying to access an attribute, whose name
513             # is $name.
514              
515             sub _no_static_attr {
516 41     41   92 my ( $self, $name ) = @_;
517 41 50       112 ref $self
518             or croak "Attribute $name may not be accessed statically";
519 41         89 return $self;
520             }
521              
522             # $self->_only_static_attr( $name );
523             #
524             # Croaks if the invocant is a reference. The message assumes the
525             # method was called trying to access an attribute, whose name is
526             # $name.
527              
528             sub _only_static_attr {
529 5     5   16 my ( $self, $name ) = @_;
530 5 50       18 ref $self
531             and croak "Attribute $name may only be accessed statically";
532 5         16 return \%static;
533             }
534              
535             }
536              
537             # $rslt = $self->_request( %args );
538             #
539             # This private method requests data from the USGS' web service.
540             # The %args are the arguments for the request:
541             # {x} => longitude (West is negative)
542             # {y} => latitude (South is negative)
543             # {units} => desired units ('Meters' or 'Feet')
544             # The return is a reference to a hash containing the parsed JSON
545             # returned from the NAD server.
546              
547             sub _request {
548 5     5   32 my ( $self, %arg ) = @_;
549              
550             # The allow_nonref() is for the benefit of {_hack_result}.
551 5   66     72 my $json = $self->{_json} ||= JSON->new()->utf8()->allow_nonref();
552              
553             my $ua = $self->{_transport_object} ||=
554 5   66     40 LWP::UserAgent->new( timeout => $self->{timeout} );
555              
556             defined $arg{units}
557 5 50       348 or $arg{units} = 'Feet';
558 5 100       40 $arg{units} = $arg{units} =~ m/ \A meters \z /smxi
559             ? 'Meters'
560             : 'Feet';
561 5         14 $arg{output} = 'json';
562              
563 5         16 my $uri = URI->new( $self->get( 'usgs_url' ) );
564 5         653 $uri->query_form( \%arg );
565 5         936 my $rqst = HTTP::Request::Common::GET( $uri );
566              
567             $self->{trace}
568 5 50       603 and print STDERR $rqst->as_string();
569              
570 5 50       37 my $rslt = exists $self->{_hack_result} ? do {
571 0         0 my $data = delete $self->{_hack_result};
572 0 0       0 CODE_REF eq ref $data ? $data->( $self, %arg ) : $data;
573             } : $ua->request( $rqst );
574              
575 5 50       4205471 if ( $self->{trace} ) {
576 0 0       0 if ( my $redir = $rslt->request() ) {
577 0         0 print STDERR $redir->as_string();
578             }
579 0         0 print STDERR $rslt->as_string();
580             }
581              
582             $rslt->is_success()
583 5 50       36 or croak $rslt->status_line();
584              
585 5         117 $rslt = $json->decode( $rslt->content() );
586              
587 5 50       318 defined $rslt
588             or return $self->_error( 'No data found in query result' );
589              
590 5         20 foreach my $key (
591             qw{ USGS_Elevation_Point_Query_Service Elevation_Query }
592             ) {
593             HASH_REF eq ref $rslt
594 10 50 33     79 and exists $rslt->{$key}
595             or return $self->_error(
596             "Elevation result is missing element {$key}" );
597 10         43 $rslt = $rslt->{$key};
598             }
599              
600 5 50       28 unless ( ref $rslt ) {
601 0         0 $rslt =~ s/ (?
602 0         0 return $self->_error( $rslt );
603             }
604              
605 5         13 my $places;
606             defined $rslt->{Elevation}
607             and defined( $places = $self->get( 'places' ) )
608 5 50 33     40 and $rslt->{Elevation} = sprintf '%.*f', $places, $rslt->{Elevation};
609              
610 5         59 return $rslt;
611             }
612              
613             1;
614              
615             __END__