File Coverage

blib/lib/Astro/SpaceTrack.pm
Criterion Covered Total %
statement 1181 1673 70.5
branch 433 910 47.5
condition 86 212 40.5
subroutine 170 214 79.4
pod 36 36 100.0
total 1906 3045 62.5


\s*
line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Astro::SpaceTrack - Retrieve orbital data from www.space-track.org.
4              
5             =head1 SYNOPSIS
6              
7             my $st = Astro::SpaceTrack->new (username => $me,
8             password => $secret, with_name => 1) or die;
9             my $rslt = $st->spacetrack ('special');
10             print $rslt->is_success ? $rslt->content :
11             $rslt->status_line;
12              
13             or
14              
15             $ SpaceTrack
16            
17             (some banner text gets printed here)
18            
19             SpaceTrack> set username me password secret
20             OK
21             SpaceTrack> set with_name 1
22             OK
23             SpaceTrack> spacetrack special >special.txt
24             SpaceTrack> celestrak visual >visual.txt
25             SpaceTrack> exit
26              
27             In either of the above, username and password entry can be omitted if
28             you have installed L, created an
29             L (see below) containing these values, and
30             set the C attribute to a true value. You probably
31             want to encrypt the identity file, if you have C and C.
32              
33             In practice, it is probably not useful to retrieve data from any source
34             more often than once every four hours, and in fact daily usually
35             suffices.
36              
37             =head1 LEGAL NOTICE
38              
39             The following two paragraphs are quoted from the Space Track web site.
40              
41             Due to existing National Security Restrictions pertaining to access of
42             and use of U.S. Government-provided information and data, all users
43             accessing this web site must be an approved registered user to access
44             data on this site.
45              
46             By logging in to the site, you accept and agree to the terms of the
47             User Agreement specified in
48             L.
49              
50             You should consult the above link for the full text of the user
51             agreement before using this software to retrieve content from the Space
52             Track web site.
53              
54             =head1 FUNCTIONAL NOTICES
55              
56             =head2 CELESTRAK API
57              
58             The Celestrak web site, L, is in transition from
59             being simply a file based repository of TLEs to an API-based service
60             providing orbital elements in a number of formats. The C
61             and C methods will track this, growing new
62             arguments as needed.
63              
64             The API-based service appears not to provide OID lists. Accordingly, as
65             of version 0.150 the C attribute defaults to true, and is
66             deprecated. Six months from the release of 0.150 this attribute will
67             warn on the first use; six months after that it will warn on all uses,
68             and six months after that any use will be fatal.
69              
70             The absence of OID lists also means that the Space Track options on
71             Celestrak queries are deprecated. Six months after the release of 0.158
72             these will warn on the first use, and so on as for the C
73             attribute.
74              
75             The absence of OID lists also means that the Space Track options on
76             Celestrak queries are deprecated. Six months after the release of 0.158
77             these will warn on the first use, and so on as for the C
78             attribute.
79              
80             =head2 DEPRECATION NOTICE: IRIDIUM STATUS
81              
82             As of version 0.137, Iridium status format C<'mccants'> is fully
83             deprecated, and will result in an exception.
84              
85             As of version 0.143, any access of attribute
86             C is fatal.
87              
88             Of course, since there are no longer any Iridium Classic satellites in
89             service, all the Iridium status machinery is a candidate for deprecation
90             and removal. Stay tuned.
91              
92             =head1 DESCRIPTION
93              
94             This package retrieves orbital data from the Space Track web site
95             L and several others. You must register and
96             get a user name and password before you can get data from Space Track.
97              
98             Other methods (C, C, ...) have
99             been added to access other repositories of orbital data, and in general
100             these do not require a Space Track username and password.
101              
102             Nothing is exported by default, but the shell method/subroutine
103             and the BODY_STATUS constants (see C)
104             can be exported if you so desire.
105              
106             Most methods return an HTTP::Response object. See the individual
107             method document for details. Methods which return orbital data on
108             success add a 'Pragma: spacetrack-type = orbit' header to the
109             HTTP::Response object if the request succeeds, and a 'Pragma:
110             spacetrack-source =' header to specify what source the data came from.
111              
112             =head2 Methods
113              
114             The following methods should be considered public:
115              
116             =over 4
117              
118             =cut
119              
120             package Astro::SpaceTrack;
121              
122 10     10   81308 use 5.006002;
  10         92  
123              
124 10     10   66 use strict;
  10         19  
  10         228  
125 10     10   58 use warnings;
  10         29  
  10         298  
126              
127 10     10   55 use Exporter;
  10         18  
  10         1761  
128              
129             our @ISA = qw{ Exporter };
130              
131             our $VERSION = '0.161_01';
132             our @EXPORT_OK = qw{
133             shell
134              
135             BODY_STATUS_IS_OPERATIONAL
136             BODY_STATUS_IS_SPARE
137             BODY_STATUS_IS_TUMBLING
138             BODY_STATUS_IS_DECAYED
139              
140             ARRAY_REF
141             CODE_REF
142             HASH_REF
143              
144             };
145             our %EXPORT_TAGS = (
146             ref => [ grep { m/ _REF \z /smx } @EXPORT_OK ],
147             status => [ grep { m/ \A BODY_STATUS_IS_ /smx } @EXPORT_OK ],
148             );
149              
150 10     10   90 use Carp ();
  10         24  
  10         324  
151 10     10   7881 use Getopt::Long 2.39;
  10         126766  
  10         272  
152 10     10   6133 use HTTP::Date ();
  10         54570  
  10         2013  
153 10     10   4360 use HTTP::Request;
  10         208654  
  10         357  
154 10     10   4909 use HTTP::Response;
  10         73735  
  10         472  
155 10         1625 use HTTP::Status qw{
156             HTTP_PAYMENT_REQUIRED
157             HTTP_NOT_FOUND
158             HTTP_I_AM_A_TEAPOT
159             HTTP_INTERNAL_SERVER_ERROR
160             HTTP_NOT_ACCEPTABLE
161             HTTP_NOT_MODIFIED
162             HTTP_OK
163             HTTP_PRECONDITION_FAILED
164             HTTP_UNAUTHORIZED
165             HTTP_INTERNAL_SERVER_ERROR
166 10     10   69 };
  10         21  
167 10     10   5308 use IO::File;
  10         87371  
  10         1067  
168 10     10   7075 use IO::Uncompress::Unzip ();
  10         573724  
  10         289  
169 10     10   6953 use JSON qw{};
  10         101517  
  10         260  
170 10     10   71 use List::Util ();
  10         25  
  10         175  
171 10     10   7197 use LWP::UserAgent; # Not in the base.
  10         165717  
  10         342  
172 10     10   74 use POSIX ();
  10         33  
  10         213  
173 10     10   51 use Scalar::Util 1.07 ();
  10         282  
  10         236  
174 10     10   5052 use Text::ParseWords ();
  10         13159  
  10         255  
175 10     10   74 use Time::Local ();
  10         25  
  10         173  
176 10     10   51 use URI qw{};
  10         21  
  10         488  
177             # use URI::Escape qw{};
178              
179             # Number of OIDs to retrieve at once. This is a global variable so I can
180             # play with it, but it is neither documented nor supported, and I
181             # reserve the right to change it or delete it without notice.
182             our $RETRIEVAL_SIZE = $ENV{SPACETRACK_RETRIEVAL_SIZE};
183             defined $RETRIEVAL_SIZE or $RETRIEVAL_SIZE = 200;
184              
185 10     10   64 use constant COPACETIC => 'OK';
  10         20  
  10         781  
186 10         648 use constant BAD_SPACETRACK_RESPONSE =>
187 10     10   70 'Unable to parse SpaceTrack response';
  10         23  
188 10         486 use constant INVALID_CATALOG =>
189 10     10   65 'Catalog name %s invalid. Legal names are %s.';
  10         18  
190 10     10   60 use constant LAPSED_FUNDING => 'Funding lapsed.';
  10         37  
  10         531  
191 10     10   93 use constant LOGIN_FAILED => 'Login failed';
  10         43  
  10         607  
192 10     10   65 use constant NO_CREDENTIALS => 'Username or password not specified.';
  10         20  
  10         519  
193 10     10   62 use constant NO_CAT_ID => 'No catalog IDs specified.';
  10         18  
  10         450  
194 10     10   65 use constant NO_OBJ_NAME => 'No object name specified.';
  10         20  
  10         555  
195 10     10   65 use constant NO_RECORDS => 'No records found.';
  10         22  
  10         475  
196              
197 10     10   58 use constant SESSION_PATH => '/';
  10         47  
  10         642  
198              
199 10     10   74 use constant DEFAULT_SPACE_TRACK_REST_SEARCH_CLASS => 'satcat';
  10         20  
  10         654  
200 10     10   74 use constant DEFAULT_SPACE_TRACK_VERSION => 2;
  10         20  
  10         515  
201              
202             # dump_headers constants.
203 10     10   80 use constant DUMP_NONE => 0; # No dump
  10         31  
  10         519  
204 10     10   57 use constant DUMP_TRACE => 0x01; # Logic trace
  10         19  
  10         489  
205 10     10   70 use constant DUMP_REQUEST => 0x02; # Request content
  10         18  
  10         446  
206 10     10   52 use constant DUMP_DRY_RUN => 0x04; # Do not execute request
  10         26  
  10         487  
207 10     10   60 use constant DUMP_COOKIE => 0x08; # Dump cookies.
  10         30  
  10         470  
208 10     10   63 use constant DUMP_RESPONSE => 0x10; # Dump response.
  10         18  
  10         446  
209 10     10   76 use constant DUMP_TRUNCATED => 0x20; # Dump with truncated content
  10         19  
  10         1161  
210              
211             my @dump_options;
212             foreach my $key ( sort keys %Astro::SpaceTrack:: ) {
213             $key =~ s/ \A DUMP_ //smx
214             or next;
215             push @dump_options, lc $key;
216             }
217              
218             # Manifest constants for reference types
219 10     10   79 use constant ARRAY_REF => ref [];
  10         17  
  10         749  
220 10     10   65 use constant CODE_REF => ref sub {};
  10         24  
  10         538  
221 10     10   60 use constant HASH_REF => ref {};
  10         27  
  10         779  
222              
223             # These are the Space Track version 1 retrieve Getopt::Long option
224             # specifications, and the descriptions of each option. These need to
225             # survive the returement of Version 1 as a separate entity because I
226             # emulated them in the celestrak() method. I'm _NOT_
227             # emulating the options added in version 2 because they require parsing
228             # the TLE.
229 10         599 use constant CLASSIC_RETRIEVE_OPTIONS => [
230             descending => '(direction of sort)',
231             'end_epoch=s' => 'date',
232             last5 => '(ignored if -start_epoch or -end_epoch specified)',
233             'sort=s' =>
234             "type ('catnum' or 'epoch', with 'catnum' the default)",
235             'start_epoch=s' => 'date',
236 10     10   68 ];
  10         19  
237              
238 10         710 use constant CELESTRAK_API_OPTIONS => [
239             'query=s', 'query type',
240             'format=s', 'data format',
241 10     10   71 ];
  10         42  
242              
243             use constant CELESTRAK_OPTIONS => [
244 10         22 @{ CLASSIC_RETRIEVE_OPTIONS() }, # TODO deprecate and remove
245 10         25 @{ CELESTRAK_API_OPTIONS() },
  10         767  
246 10     10   88 ];
  10         22  
247              
248             use constant CELESTRAK_SUPPLEMENTAL_VALID_QUERY => {
249 10     10   74 map { $_ => 1 } qw{ CATNR INTDES SOURCE NAME SPECIAL FILE } };
  10         18  
  10         23  
  60         901  
250              
251             use constant CELESTRAK_VALID_QUERY => {
252 10     10   65 map { $_ => 1 } qw{ CATNR INTDES GROUP NAME SPECIAL } };
  10         20  
  10         23  
  50         58971  
253              
254             our $COMPLETION_APP; # A hack.
255              
256             my %catalogs = ( # Catalog names (and other info) for each source.
257             celestrak => {
258             'last-30-days' => {name => "Last 30 Days' Launches"},
259             stations => {name => 'International Space Station'},
260             visual => {name => '100 (or so) brightest'},
261             active => { name => 'Active Satellites' },
262             analyst => { name => 'Analyst Satellites' },
263             weather => {name => 'Weather'},
264             noaa => {name => 'NOAA'},
265             goes => {name => 'GOES'},
266             resource => {name => 'Earth Resources'},
267             sarsat => {name => 'Search and Rescue (SARSAT)'},
268             dmc => {name => 'Disaster Monitoring'},
269             tdrss => {name => 'Tracking and Data Relay Satellite System (TDRSS)'},
270             geo => {name => 'Geostationary'},
271             intelsat => {name => 'Intelsat'},
272             gorizont => {name => 'Gorizont'},
273             raduga => {name => 'Raduga'},
274             molniya => {name => 'Molniya'},
275             iridium => {name => 'Iridium'},
276             'iridium-NEXT' => { name => 'Iridium NEXT' },
277             ses => { name => 'SES communication satellites' },
278             orbcomm => {name => 'Orbcomm'},
279             globalstar => {name => 'Globalstar'},
280             amateur => {name => 'Amateur Radio'},
281             'x-comm' => {name => 'Experimental Communications'},
282             'other-comm' => {name => 'Other communications'},
283             'gps-ops' => {name => 'GPS Operational'},
284             'glo-ops' => {name => 'Glonass Operational'},
285             galileo => {name => 'Galileo'},
286             sbas => {name =>
287             'Satellite-Based Augmentation System (WAAS/EGNOS/MSAS)'},
288             nnss => {name => 'Navy Navigation Satellite System (NNSS)'},
289             musson => {name => 'Russian LEO Navigation'},
290             science => {name => 'Space and Earth Science'},
291             geodetic => {name => 'Geodetic'},
292             engineering => {name => 'Engineering'},
293             education => {name => 'Education'},
294             military => {name => 'Miscellaneous Military'},
295             radar => {name => 'Radar Calibration'},
296             cubesat => {name => 'CubeSats'},
297             other => {name => 'Other'},
298             beidou => { name => 'Beidou navigational satellites' },
299             argos => { name => 'ARGOS Data Collection System' },
300             planet => { name => 'Planet Labs (Rapideye, Flock)' },
301             spire => { name => 'Spire Global (Lemur weather and ship tracking)' },
302             satnogs => { name => 'SatNOGS' },
303             starlink => { name => 'Starlink' },
304             oneweb => { name => 'OneWeb' },
305             swarm => { name => 'Swarm' },
306             gnss => { name => 'GNSS navigational satellites' },
307             '1982-092' => { name => 'Russian ASAT Test Debris (COSMOS 1408)' },
308             '1999-025' => { name => 'Fengyun 1C debris' },
309             'cosmos-2251-debris' => { name => 'Cosmos 2251 debris' },
310             'iridium-33-debris' => { name => 'Iridium 33 debris' },
311             '2012-044' => { name => 'BREEZE-M R/B Breakup (2012-044C)' },
312             # Removed 2022-05-12
313             # '2019-006' => { name => 'Indian ASAT Test Debris' },
314             },
315             celestrak_supplemental => {
316             gps => {
317             name => 'GPS Operational',
318             # source => 'GPS-A',
319             rms => 1,
320             match => 1,
321             },
322             glonass => {
323             name => 'GLONASS Operational',
324             # source => 'GLONASS-RE',
325             rms => 1,
326             match => 1,
327             },
328             meteosat => {
329             name => 'METEOSAT',
330             # source => 'METEOSAT-SV',
331             rms => 1,
332             match => 1,
333             },
334             intelsat => {
335             name => 'Intelsat',
336             # source => 'Intelsat-11P',
337             rms => 1,
338             match => 1,
339             },
340             ses => {
341             name => 'SES',
342             # source => 'SES-11P',
343             rms => 1,
344             match => 1,
345             },
346             telesat => {
347             name => 'Telesat',
348             # source => 'Telesat-E',
349             rms => 1,
350             match => 1,
351             },
352             orbcomm => {
353             name => 'Orbcomm (no RMS or match data)',
354             # source => 'Orbcomm-TLE',
355             },
356             iss => {
357             name => 'ISS (from NASA, no match data)',
358             # source => 'ISS-E',
359             rms => 1,
360             },
361             cpf => {
362             name => 'CPF (no match data)',
363             # source => 'CPF',
364             rms => 1,
365             },
366             starlink => {
367             name => 'Starlink',
368             # source => 'SpaceX-E',
369             rms => 1,
370             match => 1,
371             },
372             oneweb => {
373             name => 'OneWeb',
374             # source => 'OneWeb-E',
375             rms => 1,
376             match => 1,
377             },
378             planet => {
379             name => 'Planet (no, not Mercury etc)',
380             # source => 'Planet-E',
381             rms => 1,
382             match => 1,
383             },
384             iridium => {
385             name => 'Iridium Next',
386             # source => 'Iridium-E',
387             rms => 1,
388             match => 1,
389             },
390             ast => {
391             name => 'AST Space Mobile',
392             rms => 1,
393             match => 1,
394             },
395             # Project Kuiper Internet
396             },
397             iridium_status => {
398             kelso => {name => 'Celestrak (Kelso)'},
399             mccants => {name => 'McCants'},
400             sladen => {name => 'Sladen'},
401             spacetrack => { name => 'SpaceTrack' },
402             },
403             mccants => {
404             classified => {
405             name => 'Classified TLE file',
406             member => undef, # classfd.tle
407             spacetrack_type => 'orbit',
408             url => 'https://www.mmccants.org/tles/classfd.zip',
409             },
410             integrated => {
411             name => 'Integrated TLE file',
412             member => undef, # inttles.tle
413             spacetrack_type => 'orbit',
414             url => 'https://www.mmccants.org/tles/inttles.zip',
415             },
416             mcnames => {
417             name => 'Molczan-format magnitude file',
418             member => undef, # mcnames
419             spacetrack_type => 'molczan',
420             url => 'https://www.mmccants.org/tles/mcnames.zip',
421             },
422             quicksat => {
423             name => 'Quicksat-format magnitude file',
424             member => undef, # qs.mag
425             spacetrack_type => 'quicksat',
426             url => 'https://www.mmccants.org/programs/qsmag.zip',
427             },
428             rcs => {
429             name => 'McCants-format RCS data',
430             member => undef, # rcs
431             spacetrack_type => 'rcs.mccants',
432             url => 'https://www.mmccants.org/catalogs/rcs.zip',
433             },
434             vsnames => {
435             name => 'Molczan-format magnitude file (visual only)',
436             member => undef, # vsnames
437             spacetrack_type => 'molczan',
438             url => 'https://www.mmccants.org/tles/vsnames.zip',
439             },
440             },
441             spacetrack => [ # Numbered by space_track_version
442             undef, # No interface version 0
443             undef, # No interface version 1 any more
444             { # Interface version 2 (REST)
445             full => {
446             name => 'Full catalog',
447             # We have to go through satcat to eliminate bodies that
448             # are not on orbit, since tle_latest includes bodies
449             # decayed in the last two years or so
450             # satcat => {},
451             tle => {
452             EPOCH => '>now-30',
453             },
454             # number => 1,
455             },
456             payloads => {
457             name => 'All payloads',
458             satcat => {
459             OBJECT_TYPE => 'PAYLOAD',
460             },
461             },
462             geosynchronous => { # GEO
463             name => 'Geosynchronous satellites',
464             # number => 3,
465             # We have to go through satcat to eliminate bodies that
466             # are not on orbit, since tle_latest includes bodies
467             # decayed in the last two years or so
468             # satcat => {
469             # PERIOD => '1425.6--1454.4'
470             # },
471             # Note that the v2 interface specimen query is
472             # PERIOD 1430--1450.
473             # The v1 definition is
474             # MEAN_MOTION 0.99--1.01
475             # ECCENTRICITY <0.01
476             # tle => {
477             # ECCENTRICITY => '<0.01',
478             ## MEAN_MOTION => '0.99--1.01',
479             # },
480             tle => {
481             ECCENTRICITY => '<0.01',
482             EPOCH => '>now-30',
483             MEAN_MOTION => '0.99--1.01',
484             OBJECT_TYPE => 'payload',
485             },
486             },
487             medium_earth_orbit => { # MEO
488             name => 'Medium Earth Orbit',
489             tle => {
490             ECCENTRICITY => '<0.25',
491             EPOCH => '>now-30',
492             # The web page says '600 minutes <= Period <= 800
493             # minutes', but the query is in terms of mean
494             # motion.
495             MEAN_MOTION => '1.8--2.30',
496             OBJECT_TYPE => 'payload',
497             },
498             },
499             low_earth_orbit => { # LEO
500             name => 'Low Earth Orbit',
501             tle => {
502             ECCENTRICITY => '<0.25',
503             EPOCH => '>now-30',
504             MEAN_MOTION => '>11.25',
505             OBJECT_TYPE => 'payload',
506             },
507             },
508             highly_elliptical_orbit => { # HEO
509             name => 'Highly Elliptical Orbit',
510             tle => {
511             ECCENTRICITY => '>0.25',
512             EPOCH => '>now-30',
513             OBJECT_TYPE => 'payload',
514             },
515             },
516             navigation => {
517             name => 'Navigation satellites',
518             favorite => 'Navigation',
519             tle => {
520             EPOCH => '>now-30',
521             },
522             # number => 5,
523             },
524             weather => {
525             name => 'Weather satellites',
526             favorite => 'Weather',
527             tle => {
528             EPOCH => '>now-30',
529             },
530             # number => 7,
531             },
532             iridium => {
533             name => 'Iridium satellites',
534             tle => {
535             EPOCH => '>now-30',
536             OBJECT_NAME => 'iridium~~',
537             OBJECT_TYPE => 'payload',
538             },
539             # number => 9,
540             },
541             orbcomm => {
542             name => 'OrbComm satellites',
543             tle => {
544             EPOCH => '>now-30',
545             OBJECT_NAME => 'ORBCOMM~~,VESSELSAT~~',
546             OBJECT_TYPE => 'payload',
547             },
548             # number => 11,
549             },
550             globalstar => {
551             name => 'Globalstar satellites',
552             tle => {
553             EPOCH => '>now-30',
554             OBJECT_NAME => 'globalstar~~',
555             OBJECT_TYPE => 'payload',
556             },
557             # number => 13,
558             },
559             intelsat => {
560             name => 'Intelsat satellites',
561             tle => {
562             EPOCH => '>now-30',
563             OBJECT_NAME => 'intelsat~~',
564             OBJECT_TYPE => 'payload',
565             },
566             # number => 15,
567             },
568             inmarsat => {
569             name => 'Inmarsat satellites',
570             tle => {
571             EPOCH => '>now-30',
572             OBJECT_NAME => 'inmarsat~~',
573             OBJECT_TYPE => 'payload',
574             },
575             # number => 17,
576             },
577             amateur => {
578             favorite => 'Amateur',
579             name => 'Amateur Radio satellites',
580             tle => {
581             EPOCH => '>now-30',
582             },
583             # number => 19,
584             },
585             visible => {
586             favorite => 'Visible',
587             name => 'Visible satellites',
588             tle => {
589             EPOCH => '>now-30',
590             },
591             # number => 21,
592             },
593             special => {
594             favorite => 'Special_interest',
595             name => 'Special interest satellites',
596             tle => {
597             EPOCH => '>now-30',
598             },
599             # number => 23,
600             },
601             bright_geosynchronous => {
602             favorite => 'brightgeo',
603             name => 'Bright Geosynchronous satellites',
604             tle => {
605             EPOCH => '>now-30',
606             },
607             },
608             human_spaceflight => {
609             favorite => 'human_spaceflight',
610             name => 'Human Spaceflight',
611             tle => {
612             EPOCH => '>now-30',
613             },
614             },
615             well_tracked_objects => {
616             name => 'Well-Tracked Objects',
617             satcat => {
618             COUNTRY => 'UNKN',
619             SITE => 'UNKN',
620             },
621             },
622             },
623             ],
624             );
625              
626             my %mutator = ( # Mutators for the various attributes.
627             addendum => \&_mutate_attrib, # Addendum to banner text.
628             banner => \&_mutate_attrib,
629             cookie_expires => \&_mutate_spacetrack_interface,
630             cookie_name => \&_mutate_spacetrack_interface,
631             direct => \&_mutate_attrib,
632             domain_space_track => \&_mutate_spacetrack_interface,
633             dump_headers => \&_mutate_dump_headers, # Dump all HTTP headers. Undocumented and unsupported.
634             fallback => \&_mutate_attrib,
635             filter => \&_mutate_attrib,
636             identity => \&_mutate_identity,
637             iridium_status_format => \&_mutate_iridium_status_format,
638             max_range => \&_mutate_number,
639             password => \&_mutate_authen,
640             pretty => \&_mutate_attrib,
641             prompt => \&_mutate_attrib,
642             scheme_space_track => \&_mutate_attrib,
643             session_cookie => \&_mutate_spacetrack_interface,
644             space_track_version => \&_mutate_space_track_version,
645             url_iridium_status_kelso => \&_mutate_attrib,
646             url_iridium_status_mccants => \&_mutate_attrib,
647             url_iridium_status_sladen => \&_mutate_attrib,
648             username => \&_mutate_authen,
649             verbose => \&_mutate_attrib,
650             verify_hostname => \&_mutate_verify_hostname,
651             webcmd => \&_mutate_attrib,
652             with_name => \&_mutate_attrib,
653             );
654              
655             my %accessor = (
656             cookie_expires => \&_access_spacetrack_interface,
657             cookie_name => \&_access_spacetrack_interface,
658             domain_space_track => \&_access_spacetrack_interface,
659             session_cookie => \&_access_spacetrack_interface,
660             );
661             foreach my $key ( keys %mutator ) {
662             exists $accessor{$key}
663             or $accessor{$key} = sub {
664             $_[0]->_deprecation_notice( attribute => $_[1] );
665             return $_[0]->{$_[1]};
666             };
667             }
668              
669             # Maybe I really want a cookie_file attribute, which is used to do
670             # $self->{agent}->cookie_jar ({file => $self->{cookie_file}, autosave => 1}).
671             # We'll want to use a false attribute value to pass an empty hash. Going to
672             # this may imply modification of the new () method where the cookie_jar is
673             # defaulted and the session cookie's age is initialized.
674              
675              
676             =item $st = Astro::SpaceTrack->new ( ... )
677              
678             =for html
679              
680             This method instantiates a new Space-Track accessor object. If any
681             arguments are passed, the C method is called on the new object,
682             and passed the arguments given.
683              
684             For both historical and operational reasons, this method can get the
685             C and C values from multiple locations. It uses the
686             first defined value it finds in the following list:
687              
688             =over
689              
690             =item a value explicitly specified as an argument to C;
691              
692             =item a value from the L, if the
693             C attribute is explicitly specified as true and
694             L is installed;
695              
696             =item a value from environment variable C if that has a
697             non-empty value;
698              
699             =item a value from the L, if the
700             C attribute defaulted to true and
701             L s installed;
702              
703             =item a value from environment variable C.
704              
705             =back
706              
707             The reason for preferring C over an identity file value
708             taken by default is that I have found that under Mac OS X an SSH session
709             does not have access to the system keyring, and
710             L provides no other way to specify
711             the passphrase used to decrypt the private key. I concluded that if the
712             user explicitly requested an identity that it should be preferred to
713             anything from the environment, but that, for SSH access to be usable, I
714             needed to provide a source of username and password that would be taken
715             before the L was tried by default.
716              
717             Proxies are taken from the environment if defined. See the ENVIRONMENT
718             section of the Perl LWP documentation for more information on how to
719             set these up.
720              
721             =cut
722              
723             sub new {
724 10     10 1 2199 my ( $class, %arg ) = @_;
725 10 50       60 $class = ref $class if ref $class;
726              
727 10         228 my $self = {
728             banner => 1, # shell () displays banner if true.
729             direct => 1, # Direct-fetch from redistributors
730             dump_headers => DUMP_NONE, # No dumping.
731             fallback => 0, # Do not fall back if primary source offline
732             filter => 0, # Filter mode.
733             iridium_status_format => 'kelso',
734             max_range => 500, # Sanity limit on range size.
735             password => undef, # Login password.
736             pretty => 0, # Pretty-format content
737             prompt => 'SpaceTrack> ',
738             scheme_space_track => 'https',
739             _space_track_interface => [
740             undef, # No such thing as version 0
741             undef, # Interface version 1 retured.
742             { # Interface version 2
743             # This interface does not seem to put an expiration time
744             # on the cookie. But the docs say it's only good for a
745             # couple hours, so we need this so we can fudge
746             # something in when the time comes.
747             cookie_expires => 0,
748             cookie_name => 'chocolatechip',
749             domain_space_track => 'www.space-track.org',
750             session_cookie => undef,
751             },
752             ],
753             space_track_version => DEFAULT_SPACE_TRACK_VERSION,
754             url_iridium_status_kelso =>
755             'https://celestrak.org/SpaceTrack/query/iridium.txt',
756             url_iridium_status_sladen =>
757             'http://www.rod.sladen.org.uk/iridium.htm',
758             username => undef, # Login username.
759             verbose => undef, # Verbose error messages for catalogs.
760             verify_hostname => 1, # Don't verify host names by default.
761             webcmd => undef, # Command to get web help.
762             with_name => undef, # True to retrieve three-line element sets.
763             };
764 10         44 bless $self, $class;
765              
766 10         78 $self->set( identity => delete $arg{identity} );
767              
768             $ENV{SPACETRACK_OPT} and
769 10 50       51 $self->set (grep {defined $_} split '\s+', $ENV{SPACETRACK_OPT});
  0         0  
770              
771             # TODO this makes no sense - the first branch of the if() can never
772             # be executed because I already deleted $arg{identity}. But I do not
773             # want to execute the SPACETRACK_USER code willy-nilly -- maybe warn
774             # if identity is 1 and I don't have both a username and a password.
775 10 50       66 if ( defined( my $id = delete $arg{identity} ) ) {
    50          
776 0         0 $self->set( identity => $id );
777             } elsif ( $ENV{SPACETRACK_USER} ) {
778 0         0 my ($user, $pass) = split qr{ [:/] }smx, $ENV{SPACETRACK_USER}, 2;
779 0 0 0     0 '' ne $user
780             and '' ne $pass
781             or $user = $pass = undef;
782 0         0 $self->set (username => $user, password => $pass);
783             } else {
784 10         40 $self->set( identity => undef );
785             }
786              
787             defined $ENV{SPACETRACK_VERIFY_HOSTNAME}
788             and $self->set( verify_hostname =>
789 10 50       58 $ENV{SPACETRACK_VERIFY_HOSTNAME} );
790              
791 10 100       55 keys %arg
792             and $self->set( %arg );
793              
794 10         284 return $self;
795             }
796              
797             =for html
798              
799             =item $resp = $st->amsat ()
800              
801             This method downloads current orbital elements from the Radio Amateur
802             Satellite Corporation's web page, L. This lists
803             satellites of interest to radio amateurs, and appears to be updated
804             weekly.
805              
806             No Space Track account is needed to access this data, even if the
807             'direct' attribute is false. As of version 0.150 the setting of
808             the 'with_name' attribute is honored even if the 'direct' attribute is
809             true.
810              
811             You can specify options as either command-type options (e.g.
812             C<< amsat( '-file', 'foo.dat' ) >>) or as a leading hash reference (e.g.
813             C<< amsat( { file => 'foo.dat' } ) >>). If you specify the hash
814             reference, option names must be specified in full, without the leading
815             '-', and the argument list will not be parsed for command-type options.
816             If you specify command-type options, they may be abbreviated, as long as
817             the abbreviation is unique. Errors in either sort result in an exception
818             being thrown.
819              
820             The legal options are:
821              
822             -file
823             specifies the name of the cache file. If the data
824             on line are newer than the modification date of
825             the cache file, the cache file will be updated.
826             Otherwise the data will be returned from the file.
827             Either way the content of the file and the content
828             of the returned HTTP::Response object end up the
829             same.
830              
831             On a successful return, the response object will contain headers
832              
833             Pragma: spacetrack-type = orbit
834             Pragma: spacetrack-source = amsat
835              
836             These can be accessed by C<< $st->content_type( $resp ) >> and
837             C<< $st->content_source( $resp ) >> respectively.
838              
839             If the C option was passed, the following additional header will
840             be provided:
841              
842             Pragma: spacetrack-cache-hit = (either true or false)
843              
844             This can be accessed by the C method. If this pragma is
845             true, the C header of the response will contain the
846             modification time of the file.
847              
848             This method is a web page scraper. Any change in the location of the
849             web page will break this method.
850              
851             =cut
852              
853             # Called dynamically
854             sub _amsat_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
855             return [
856 1     1   4 'file=s' => 'Name of cache file',
857             ];
858             }
859              
860             sub amsat {
861 1     1 1 5 my ( $self, @args ) = @_;
862              
863 1         4 ( my $opt, @args ) = _parse_args( @args );
864              
865             return $self->_get_from_net(
866 1         11 %{ $opt },
867             # url => 'http://www.amsat.org/amsat/ftp/keps/current/nasabare.txt',
868             url => 'https://www.amsat.org/tle/current/nasabare.txt',
869             post_process => sub {
870 1     1   27 my ( $self, $resp ) = @_;
871 1 50       4 unless ( $self->{with_name} ) {
872 1         33 my @content = split qr{ \015? \012 }smx,
873             $resp->content();
874 1 50       694 @content % 3
875             and return HTTP::Response->new(
876             HTTP_PRECONDITION_FAILED,
877             'Response does not contain a multiple of 3 lines' );
878 1         4 my $ct = '';
879 1         3 while ( @content ) {
880 192         310 shift @content;
881 192         253 $ct .= join '', map { "$_\n" } splice @content, 0, 2;
  384         853  
882             }
883 1         67 $resp->content( $ct );
884             }
885 1 50       35 '' eq $resp->content()
886             and return HTTP::Response->new(
887             HTTP_PRECONDITION_FAILED, NO_CAT_ID );
888 1         22 return $resp;
889             },
890 1         2 spacetrack_type => 'orbit',
891             );
892             }
893              
894             =for html
895              
896             =item @names = $st->attribute_names
897              
898             This method returns a list of legal attribute names.
899              
900             =cut
901              
902             sub attribute_names {
903 1     1 1 3 my ( $self ) = @_;
904 1         14 my @keys = grep { ! {
905             url_iridium_status_mccants => 1,
906 26         58 }->{$_} } sort keys %mutator;
907 1 50       18 ref $self
    50          
908             or return wantarray ? @keys : \@keys;
909 0         0 my $space_track_version = $self->getv( 'space_track_version' );
910             my @names = grep {
911 0         0 $mutator{$_} == \&_mutate_spacetrack_interface ?
912 0 0       0 exists $self->{_space_track_interface}[$space_track_version]{$_}
913             : 1
914             } @keys;
915 0 0       0 return wantarray ? @names : \@names;
916             }
917              
918              
919             =for html
920              
921             =item $resp = $st->banner ();
922              
923             This method is a convenience/nuisance: it simply returns a fake
924             HTTP::Response with standard banner text. It's really just for the
925             benefit of the shell method.
926              
927             =cut
928              
929             {
930             my $perl_version;
931              
932             sub banner {
933 1     1 1 3 my $self = shift;
934 1   33     6 $perl_version ||= do {
935 1 50       16 $] >= 5.01 ? $^V : do {
936 0         0 require Config;
937 0         0 'v' . $Config::Config{version}; ## no critic (ProhibitPackageVars)
938             }
939             };
940 1         9 my $url = $self->_make_space_track_base_url();
941 1         4 return HTTP::Response->new (HTTP_OK, undef, undef, <<"EOD");
942              
943 1         12 @{[__PACKAGE__]} version $VERSION
944             Perl $perl_version under $^O
945              
946             This package acquires satellite orbital elements and other data from a
947             variety of web sites. It is your responsibility to abide by the terms of
948             use of the individual web sites. In particular, to acquire data from
949             Space Track ($url/) you must register and
950             get a username and password, and you may not make the data available to
951             a third party without prior permission from Space Track.
952              
953             Copyright 2005-2022 by T. R. Wyant (wyant at cpan dot org).
954              
955             This program is free software; you can redistribute it and/or modify it
956             under the same terms as Perl 5.10.0. For more details, see the full text
957             of the licenses in the directory LICENSES.
958              
959             This program is distributed in the hope that it will be useful, but
960             without any warranty; without even the implied warranty of
961             merchantability or fitness for a particular purpose.
962 1   50     10 @{[$self->{addendum} || '']}
963             EOD
964             }
965              
966             }
967              
968             =for html
969              
970             =item $resp = $st->box_score ();
971              
972             This method returns an HTTP::Response object. If the request succeeds,
973             the content of the object will be the SATCAT Satellite Box Score
974             information in the desired format. If the desired format is C<'legacy'>
975             or C<'json'> and the method is called in list context, the second
976             returned item will be a reference to an array containing the parsed
977             data.
978              
979             This method takes the following options, specified either command-style
980             or as a hash reference.
981              
982             C<-format> specifies the desired format of the retrieved data. Possible
983             values are C<'xml'>, C<'json'>, C<'html'>, C<'csv'>, and C<'legacy'>,
984             which is the default. The legacy format is tab-delimited text, such as
985             was returned by the version 1 interface.
986              
987             C<-json> specifies JSON format. If you specify both C<-json> and
988             C<-format> you will get an exception unless you specify C<-format=json>.
989              
990             This method requires a Space Track username and password. It implicitly
991             calls the C method if the session cookie is missing or expired.
992             If C fails, you will get the HTTP::Response from C.
993              
994             If this method succeeds, the response will contain headers
995              
996             Pragma: spacetrack-type = box_score
997             Pragma: spacetrack-source = spacetrack
998              
999             There are no arguments.
1000              
1001             =cut
1002              
1003             {
1004              
1005             my @fields = qw{ SPADOC_CD
1006             ORBITAL_PAYLOAD_COUNT ORBITAL_ROCKET_BODY_COUNT
1007             ORBITAL_DEBRIS_COUNT ORBITAL_TOTAL_COUNT
1008             DECAYED_PAYLOAD_COUNT DECAYED_ROCKET_BODY_COUNT
1009             DECAYED_DEBRIS_COUNT DECAYED_TOTAL_COUNT
1010             COUNTRY_TOTAL
1011             };
1012              
1013             my @head = (
1014             [ '', 'Objects in Orbit', 'Decayed Objects' ],
1015             [ 'Country/Organization',
1016             'Payload', 'Rocket Body', 'Debris', 'Total',
1017             'Payload', 'Rocket Body', 'Debris', 'Total',
1018             'Grand Total',
1019             ],
1020             );
1021              
1022             # Called dynamically
1023             sub _box_score_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
1024             return [
1025 2     2   9 'json!' => 'Return data in JSON format',
1026             'format=s' => 'Specify return format',
1027             ];
1028             }
1029              
1030             sub box_score {
1031 2     2 1 1027 my ( $self, @args ) = @_;
1032              
1033 2         9 ( my $opt, @args ) = _parse_args( @args );
1034 2         10 my $format = _retrieval_format( box_score => $opt );
1035              
1036 2         11 my $resp = $self->spacetrack_query_v2( qw{
1037             basicspacedata query class boxscore },
1038             format => $format,
1039             qw{ predicates all },
1040             );
1041 2 100       8 $resp->is_success()
1042             or return $resp;
1043              
1044 1         12 $self->_add_pragmata($resp,
1045             'spacetrack-type' => 'box_score',
1046             'spacetrack-source' => 'spacetrack',
1047             'spacetrack-interface' => 2,
1048             );
1049              
1050 1 50       3 'json' eq $format
1051             or return $resp;
1052              
1053 1         4 my $data;
1054              
1055 1 50       4 if ( ! $opt->{json} ) {
1056              
1057 1         4 $data = $self->_get_json_object()->decode( $resp->content() );
1058              
1059 1         122 my $content;
1060 1         10 foreach my $row ( @head ) {
1061 2         5 $content .= join( "\t", @{ $row } ) . "\n";
  2         15  
1062             }
1063 1         4 foreach my $datum ( @{ $data } ) {
  1         3  
1064             defined $datum->{SPADOC_CD}
1065             and $datum->{SPADOC_CD} eq 'ALL'
1066 100 50 33     231 and $datum->{SPADOC_CD} = 'Total';
1067             $content .= join( "\t", map {
1068 100 50       144 defined $datum->{$_} ? $datum->{$_} : ''
  1000         1853  
1069             } @fields ) . "\n";
1070             }
1071              
1072 1         7 $resp = HTTP::Response->new (HTTP_OK, undef, undef, $content);
1073             }
1074              
1075             wantarray
1076 1 50       89 or return $resp;
1077              
1078 0         0 my @table;
1079 0         0 foreach my $row ( @head ) {
1080 0         0 push @table, [ @{ $row } ];
  0         0  
1081             }
1082 0   0     0 $data ||= $self->_get_json_object()->decode( $resp->content() );
1083 0         0 foreach my $datum ( @{ $data } ) {
  0         0  
1084 0         0 push @table, [ map { $datum->{$_} } @fields ];
  0         0  
1085             }
1086 0         0 return ( $resp, \@table );
1087             }
1088             }
1089              
1090             # UNSUPPORTED AND SUBJECT TO CHANGE OR REMOVAL WITHOUT NOTICE!
1091             # If you have a use for this information, please let me know and I will
1092             # see about putting together something I believe I can support.
1093             sub __catalog {
1094 0     0   0 my ( undef, $name ) = @_;
1095 0 0       0 $catalogs{$name}
1096             or Carp::confess "Bug - catalog $name does not exist";
1097 0         0 return $catalogs{$name};
1098             }
1099              
1100             =for html
1101              
1102             =item $resp = $st->celestrak ($name);
1103              
1104             B As of version 0.150 of this module a false value of the
1105             C<'direct'> attribute is unsupported. See L
1106             above for details.
1107              
1108             As of version 0.158 this version is an interface to the CelesTrak API.
1109             The argument is the argument of a Celestrak query (see
1110             L). The
1111             following options are available:
1112              
1113             =over
1114              
1115             =item format
1116              
1117             --format json
1118              
1119             This option specifies the format of the returned data. Valid values are
1120             C<'TLE'>, C<'3LE'>, C<'2LE'>, C<'XML'>, C<'KVN'>, C<'JSON'>, or
1121             C<'CSV'>. See
1122             L for a
1123             discussion of these. C<'JSON-PRETTY'> is not a valid format option, but
1124             will be generated if the C attribute is true.
1125              
1126             The default is C<'TLE'>.
1127              
1128             =item query
1129              
1130             --query name
1131              
1132             This option specifies the type of query to be done. Valid values are
1133              
1134             =over
1135              
1136             =item CATNR
1137              
1138             The argument is a NORAD catalog number (1-9 digits).
1139              
1140             =item GROUP
1141              
1142             The argument is the name of a named group of satellites.
1143              
1144             =item INTDES
1145              
1146             The argument is an international launch designator of the form yyyy-nnn,
1147             where the C is the Gregorian year, and the C is the launch
1148             number in the year.
1149              
1150             =item NAME
1151              
1152             The argument is a satellite name or a portion thereof.
1153              
1154             =item SPECIAL
1155              
1156             The argument specifies a special data set.
1157              
1158             =back
1159              
1160             The default is C<'CATNR'> if the argument is numeric, C<'INTDES'> if the
1161             argument looks like an international designator, or C<'GROUP'>
1162             otherwise.
1163              
1164             =back
1165              
1166             A list of valid C names and brief descriptions can be obtained by
1167             calling C<< $st->names ('celestrak') >>. If you have set the C
1168             attribute true (e.g. C<< $st->set (verbose => 1) >>), the content of the
1169             error response will include this list. Note, however, that this list
1170             does not determine what can be retrieved; if Dr. Kelso adds a data set,
1171             it can be retrieved even if it is not on the list, and if he removes
1172             one, being on the list won't help.
1173              
1174             If this method succeeds, the response will contain headers
1175              
1176             Pragma: spacetrack-type = orbit
1177             Pragma: spacetrack-source = celestrak
1178              
1179             These can be accessed by C<< $st->content_type( $resp ) >> and
1180             C<< $st->content_source( $resp ) >> respectively.
1181              
1182             You can specify the C options on this method as well, but
1183             they will have no effect, are deprecated, and warn on the first use. Six
1184             months after the release of version 0.161 these will warn on every use.
1185             Six months after that they will be fatal. After a further six months all
1186             related code will be removed.
1187              
1188             =cut
1189              
1190             # Called dynamically
1191             sub _celestrak_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
1192 0     0   0 return CELESTRAK_OPTIONS;
1193             }
1194              
1195             sub celestrak {
1196 3     3 1 11 my ($self, @args) = @_;
1197 3         12 delete $self->{_pragmata};
1198              
1199 3         15 ( my $opt, @args ) = _parse_args( CELESTRAK_OPTIONS, @args );
1200              
1201 3         9 my $name = shift @args;
1202 3 50       13 defined $name
1203             or return HTTP::Response->new(
1204             HTTP_PRECONDITION_FAILED,
1205             'No catalog name specified' );
1206              
1207 3         14 $self->_deprecation_notice( celestrak => $name );
1208 3         6 $self->_deprecation_notice( celestrak => "--$_" ) foreach sort keys %{ $opt };
  3         13  
1209              
1210 3         8 my $query;
1211             ref( $query = $self->_celestrak_validate_query(
1212 3 50       16 delete $opt->{query}, $name,
1213             CELESTRAK_VALID_QUERY, 'GROUP' ) )
1214             and return $query;
1215              
1216 3         6 my $format;
1217             ref( $format = $self->_celestrak_validate_format(
1218 3 50       14 delete $opt->{format} ) )
1219             and return $format;
1220              
1221 3         20 my $uri = URI->new( 'https://celestrak.org/NORAD/elements/gp.php' );
1222 3         345 $uri->query_form(
1223             $query => $name,
1224             FORMAT => $format,
1225             );
1226              
1227             return $self->_get_from_net(
1228 3         26 %{ $opt },
1229             url => $uri,
1230             post_process => sub {
1231 3     3   73 my ( $self, $resp ) = @_;
1232 3         8 my $check;
1233 3 100       20 $check = $self->_celestrak_response_check( $resp,
1234             celestrak => $name )
1235             and return $check;
1236 2 100       13 $name eq 'iridium'
1237             and _celestrak_repack_iridium( $resp );
1238 2         6 return $resp;
1239             },
1240 3         328 spacetrack_source => 'celestrak',
1241             spacetrack_type => 'orbit',
1242             );
1243             }
1244              
1245             =for html
1246              
1247             =item $resp = $st->celestrak_supplemental ($name);
1248              
1249             This method takes the name of a Celestrak supplemental data set and
1250             returns an HTTP::Response object whose content is the relevant element
1251             sets.
1252              
1253             These TLE data are B redistributed from Space Track, but are
1254             derived from publicly available ephemeris data for the satellites in
1255             question.
1256              
1257             As of version 0.158 this version is an interface to the CelesTrak API.
1258             The argument is the argument of a Celestrak query (see
1259             L). The
1260             following options are available:
1261              
1262             =over
1263              
1264             =item file
1265              
1266             --file my_data.tle
1267              
1268             This option specifies the name of an output file for the data.
1269              
1270             =item format
1271              
1272             --format json
1273              
1274             This option specifies the format of the returned data. Valid values are
1275             C<'TLE'>, C<'3LE'>, C<'2LE'>, C<'XML'>, C<'KVN'>, C<'JSON'>, or
1276             C<'CSV'>. See
1277             L for a
1278             discussion of these. C<'JSON-PRETTY'> is not a valid format option, but
1279             will be generated if the C attribute is true.
1280              
1281             The default is C<'TLE'>.
1282              
1283             =item match
1284              
1285             This Boolean option specifies that match data be returned rather than
1286             TLE data, if available. This option is valid only on known catalogs that
1287             actually have match data. If this option is asserted, C<--format> and
1288             C<--query> are invalid.
1289              
1290             =item query
1291              
1292             --query name
1293              
1294             This option specifies the type of query to be done. Valid values are
1295              
1296             =over
1297              
1298             =item CATNR
1299              
1300             The argument is a NORAD catalog number (1-9 digits).
1301              
1302             =item FILE
1303              
1304             The argument is the name of a standard data set.
1305              
1306             =item INTDES
1307              
1308             The argument is an international launch designator of the form yyyy-nnn,
1309             where the C is the Gregorian year, and the C is the launch
1310             number in the year.
1311              
1312             =item NAME
1313              
1314             The argument is a satellite name or a portion thereof.
1315              
1316             =item SOURCE
1317              
1318             The argument specifies a data source as specified at
1319             L.
1320              
1321             =item SPECIAL
1322              
1323             The argument specifies a special data set.
1324              
1325             =back
1326              
1327             The default is C<'CATNR'> if the argument is numeric, C<'INTDES'> if the
1328             argument looks like an international designator, or C<'FILE'> otherwise.
1329              
1330             =item rms
1331              
1332             This Boolean option specifies that RMS data be returned rather than TLE
1333             data, if available. This option is valid only on known catalogs that
1334             actually have RMS data. If this option is asserted, C<--format> and
1335             C<--query> are invalid.
1336              
1337             =back
1338              
1339             Valid catalog names are:
1340              
1341             cpf: CPF TLEs
1342             glonass: Glonass satellites
1343             gps: GPS satellites
1344             intelsat: Intelsat satellites
1345             iss: ISS (from NASA, no rms data
1346             meteosat: Meteosat satellites
1347             orbcomm: Orbcomm satellites (no RMS data)
1348             ses: SES satellites
1349             starlink Starlink TLEs
1350              
1351             You can specify options as either command-type options (e.g.
1352             C<< celestrak_supplemental( '-file', 'foo.dat' ) >>) or as a leading
1353             hash reference (e.g.
1354             C<< celestrak_supplemental( { file => 'foo.dat' }) >>). If you specify
1355             the hash reference, option names must be specified in full, without the
1356             leading '-', and the argument list will not be parsed for command-type
1357             options. If you specify command-type options, they may be abbreviated,
1358             as long as the abbreviation is unique. Errors in either sort result in
1359             an exception being thrown.
1360              
1361             A list of valid catalog names and brief descriptions can be obtained by
1362             calling C<< $st->names( 'celestrak_supplemental' ) >>. If you have set
1363             the C attribute true (e.g. C<< $st->set (verbose => 1) >>), the
1364             content of the error response will include this list. Note, however,
1365             that this list does not determine what can be retrieved; if Dr. Kelso
1366             adds a data set, it can be retrieved even if it is not on the list, and
1367             if he removes one, being on the list won't help.
1368              
1369             If the C option was passed, the following additional header will
1370             be provided:
1371              
1372             Pragma: spacetrack-cache-hit = (either true or false)
1373              
1374             This can be accessed by the C method. If this pragma is
1375             true, the C header of the response will contain the
1376             modification time of the file.
1377              
1378             B that it is my belief that the current Celestrak API (as of
1379             September 26 2022) does not support this kind of functionality, so
1380             C will always return false.
1381              
1382             For more information, see
1383             L.
1384              
1385             =cut
1386              
1387             # Called dynamically
1388             sub _celestrak_supplemental_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
1389             return [
1390 2     2   6 @{ CELESTRAK_API_OPTIONS() },
  2         18  
1391             'file=s' => 'Name of cache file',
1392             'rms!' => 'Return RMS data',
1393             'match!' => 'Return match data',
1394             ];
1395             }
1396              
1397             sub celestrak_supplemental {
1398 2     2 1 9 my ( $self, @args ) = @_;
1399 2         14 ( my $opt, @args ) = _parse_args( @args );
1400              
1401             $opt->{rms}
1402             and $opt->{match}
1403 2 50 66     14 and return HTTP::Response->new(
1404             HTTP_PRECONDITION_FAILED,
1405             'You may not assert both --rms and --match',
1406             );
1407              
1408 2 100 66     15 if ( $opt->{rms} || $opt->{match} ) {
1409 1         4 foreach my $key ( qw{ query format } ) {
1410 2 50       8 defined $opt->{$key}
1411             and return HTTP::Response->new(
1412             HTTP_PRECONDITION_FAILED,
1413             "You may not assert --$key with --rms or --match",
1414             );
1415             }
1416             }
1417              
1418 2         5 my $name = $args[0];
1419              
1420 2         10 my $info = $catalogs{celestrak_supplemental}{$name};
1421              
1422 2         6 foreach my $key ( qw{ rms match } ) {
1423             not $opt->{$key}
1424 4 50 66     17 or $info->{$key}
1425             or return HTTP::Response->new(
1426             HTTP_PRECONDITION_FAILED,
1427             "$name does not take the --$key option" );
1428             }
1429              
1430 2         8 my $base_url = 'https://celestrak.org/NORAD/elements/supplemental';
1431              
1432 2         4 my ( $spacetrack_type, $uri );
1433              
1434 2 100       9 if ( $opt->{rms} ) {
    50          
1435 1         3 $spacetrack_type = 'rms';
1436 1         11 $uri = URI->new( "$base_url/$name.rms.txt" );
1437             } elsif ( $opt->{match} ) {
1438 0         0 $spacetrack_type = 'match';
1439 0         0 $uri = URI->new( "$base_url/$name.match.txt" );
1440             } else {
1441 1         3 $spacetrack_type = 'orbit';
1442              
1443 1         3 my $source = $info->{source};
1444 1 50       4 defined $source
1445             or $source = $name;
1446              
1447 1         3 my $query;
1448             ref( $query = $self->_celestrak_validate_query(
1449 1 50       6 delete $opt->{query}, $name,
1450             CELESTRAK_SUPPLEMENTAL_VALID_QUERY, 'FILE' ) )
1451             and return $query;
1452              
1453 1         3 my $format;
1454             ref( $format = $self->_celestrak_validate_format(
1455 1 50       5 delete $opt->{format} ) )
1456             and return $format;
1457              
1458 1         11 $uri = URI->new( "$base_url/sup-gp.php" );
1459 1         116 $uri->query_form(
1460             $query => $source,
1461             FORMAT => $format,
1462             );
1463             }
1464              
1465             return $self->_get_from_net(
1466 2         22 %{ $opt },
1467             url => $uri,
1468             post_process => sub {
1469 2     2   47 my ( $self, $resp ) = @_;
1470 2         9 my $check;
1471 2 50       15 $check = $self->_celestrak_response_check( $resp,
1472             celestrak_supplemental => $name )
1473             and return $check;
1474 2         8 return $resp;
1475             },
1476 2         222 spacetrack_source => 'celestrak',
1477             spacetrack_type => $spacetrack_type,
1478             );
1479             }
1480              
1481             {
1482             my %valid_format = map { $_ => 1 } qw{ TLE 3LE 2LE XML KVN JSON CSV };
1483              
1484             sub _celestrak_validate_format {
1485 4     4   14 my ( $self, $format ) = @_;
1486 4 50       15 $format = defined $format ? uc( $format ) : 'TLE';
1487 4 50       18 $valid_format{$format}
1488             or return HTTP::Response->new(
1489             HTTP_PRECONDITION_FAILED,
1490             "Format '$format' is not valid" );
1491 4 50 33     14 $format eq 'JSON'
1492             and $self->getv( 'pretty' )
1493             and $format = 'JSON-PRETTY';
1494 4         17 return $format;
1495             }
1496             }
1497              
1498             sub _celestrak_validate_query {
1499 4     4   14 my ( undef, $query, $name, $valid, $dflt ) = @_;
1500 4 50       38 $query = defined $query ? uc( $query ) :
    50          
    50          
    50          
1501             $name =~ m/ \A [0-9]+ \z /smx ? 'CATNR' :
1502             $name =~ m/ \A [0-9]{4}-[0-9]+ \z /smx ? 'INTDES' :
1503             defined $dflt ? uc( $dflt ) : $dflt;
1504 4 50       17 defined $query
1505             or return $query;
1506 4 50       19 $valid->{$query}
1507             or return HTTP::Response->new(
1508             HTTP_PRECONDITION_FAILED,
1509             "Query '$query' is not valid" );
1510 4         20 return $query;
1511             }
1512              
1513             sub _celestrak_repack_iridium {
1514 1     1   4 my ( $resp ) = @_;
1515 1         7 local $_ = $resp->content();
1516 1         124 s/ \s+ [[] . []] [ \t]* (?= \r? \n | \z ) //smxg;
1517 1         7 $resp->content( $_ );
1518 1         28 return;
1519             }
1520              
1521             { # Local symbol block.
1522              
1523             my %valid_type = map { $_ => 1 }
1524             qw{ text/plain text/text application/json application/xml };
1525              
1526             sub _celestrak_response_check {
1527 5     5   24 my ($self, $resp, $source, $name, @args) = @_;
1528 5 50       19 unless ($resp->is_success) {
1529 0 0       0 $resp->code == HTTP_NOT_FOUND
1530             and return $self->_no_such_catalog(
1531             $source => $name, @args);
1532 0         0 return $resp;
1533             }
1534 5 50       55 if (my $loc = $resp->header('Content-Location')) {
1535 0 0       0 if ($loc =~ m/ redirect [.] htm [?] ( \d{3} ) ; /smx) {
1536 0         0 my $msg = "redirected $1";
1537 0 0       0 @args and $msg = "@args; $msg";
1538 0 0       0 $1 == HTTP_NOT_FOUND
1539             and return $self->_no_such_catalog(
1540             $source => $name, $msg);
1541 0         0 return HTTP::Response->new (+$1, "$msg\n")
1542             }
1543             }
1544             my $type = lc $resp->header('Content-Type')
1545 5 50       632 or do {
1546 0         0 my $msg = 'No Content-Type header found';
1547 0 0       0 @args and $msg = "@args; $msg";
1548 0         0 return $self->_no_such_catalog(
1549             $source => $name, $msg);
1550             };
1551 5         295 foreach my $type ( _trim( split ',', $type ) ) {
1552 5         33 $type =~ s/ ; .* //smx;
1553 5 50       26 $valid_type{$type}
1554             or next;
1555 5         34 local $_ = $resp->decoded_content();
1556             # As of February 12 2022 Celestrak does this
1557             # As of July 23 2022 this is not at the beginning of the
1558             # string
1559 5 50       3027 m/^No GP data found\b/sm
1560             and last;
1561             # As of July 25 2022 Celestrak does this.
1562 5 100       44 m/^(?:GROUP|FILE) "[^"]+" does not exist/sm
1563             and last;
1564 4         23 return;
1565             }
1566 1         8 my $msg = "Content-Type: $type";
1567 1 50       9 @args and $msg = "@args; $msg";
1568 1         12 return $self->_no_such_catalog(
1569             $source => $name, $msg);
1570             }
1571              
1572             } # End local symbol block.
1573              
1574             =item $bool = $st->cache_hit( $resp );
1575              
1576             This method takes the given HTTP::Response object and returns the cache
1577             hit indicator specified by the 'Pragma: spacetrack-cache-hit =' header.
1578             This will be true if the response came from cache, false if it did not,
1579             and C if cache was not available.
1580              
1581             If the response object is not provided, it returns the data type
1582             from the last method call that returned an HTTP::Response object.
1583              
1584             =cut
1585              
1586             sub cache_hit {
1587 1     1 1 5 $_[2] = 'spacetrack-cache-hit';
1588 1         4 goto &_get_pragma_value;
1589             }
1590              
1591             =item $source = $st->content_source($resp);
1592              
1593             This method takes the given HTTP::Response object and returns the data
1594             source specified by the 'Pragma: spacetrack-source =' header. What
1595             values you can expect depend on the content_type (see below) as follows:
1596              
1597             If the C method returns C<'box_score'>, you can expect
1598             a content-source value of C<'spacetrack'>.
1599              
1600             If the content_type method returns C<'iridium-status'>, you can expect
1601             content_source values of C<'kelso'>, C<'mccants'>, or C<'sladen'>,
1602             corresponding to the main source of the data.
1603              
1604             If the content_type method returns C<'molczan'>, you can expect a
1605             content_source value of C<'mccants'>.
1606              
1607             If the C method returns C<'orbit'>, you can expect
1608             content-source values of C<'amsat'>, C<'celestrak'>, C<'mccants'>,
1609             or C<'spacetrack'>, corresponding to the actual source
1610             of the TLE data. Note that the C method may return a
1611             content_type of C<'spacetrack'> if the C attribute is false.
1612              
1613             If the content_type method returns C<'quicksat'>, you can expect a
1614             content_source value of C<'mccants'>.
1615              
1616             If the C method returns C<'search'>, you can expect a
1617             content-source value of C<'spacetrack'>.
1618              
1619             For any other values of content-type (e.g. C<'get'>, C<'help'>), the
1620             expected values are undefined. In fact, you will probably literally get
1621             undef, but the author does not commit even to this.
1622              
1623             If the response object is not provided, it returns the data source
1624             from the last method call that returned an HTTP::Response object.
1625              
1626             If the response object B provided, you can call this as a static
1627             method (i.e. as Astro::SpaceTrack->content_source($response)).
1628              
1629             =cut
1630              
1631             sub content_source {
1632 37     37 1 111 $_[2] = 'spacetrack-source';
1633 37         126 goto &_get_pragma_value;
1634             }
1635              
1636             =item $type = $st->content_type ($resp);
1637              
1638             This method takes the given HTTP::Response object and returns the
1639             data type specified by the 'Pragma: spacetrack-type =' header. The
1640             following values are supported:
1641              
1642             'box_score': The content is the Space Track satellite
1643             box score.
1644             'get': The content is a parameter value.
1645             'help': The content is help text.
1646             'iridium_status': The content is Iridium status.
1647             'modeldef': The content is a REST model definition.
1648             'molczan': Molczan-format magnitude data.
1649             'orbit': The content is NORAD data sets.
1650             'quicksat': Quicksat-format magnitude data.
1651             'search': The content is Space Track search results.
1652             'set': The content is the result of a 'set' operation.
1653             undef: No spacetrack-type pragma was specified. The
1654             content is something else (typically 'OK').
1655              
1656             If the response object is not provided, it returns the data type
1657             from the last method call that returned an HTTP::Response object.
1658              
1659             If the response object B provided, you can call this as a static
1660             method (i.e. as Astro::SpaceTrack->content_type($response)).
1661              
1662             For the format of the magnitude data, see
1663             L.
1664              
1665             =cut
1666              
1667             sub content_type {
1668 38     38 1 1044 $_[2] = 'spacetrack-type';
1669 38         157 goto &_get_pragma_value;
1670             }
1671              
1672             =item $type = $st->content_interface( $resp );
1673              
1674             This method takes the given HTTP::Response object and returns the Space
1675             Track interface version specified by the
1676             C<'Pragma: spacetrack-interface ='> header. The following values are
1677             supported:
1678              
1679             1: The content was obtained using the version 1 interface.
1680             2: The content was obtained using the version 2 interface.
1681             undef: The content did not come from Space Track.
1682              
1683             If the response object is not provided, it returns the data type
1684             from the last method call that returned an HTTP::Response object.
1685              
1686             If the response object B provided, you can call this as a static
1687             method (i.e. as Astro::SpaceTrack->content_type($response)).
1688              
1689             =cut
1690              
1691             sub content_interface {
1692 22     22 1 54 $_[2] = 'spacetrack-interface';
1693 22         70 goto &_get_pragma_value;
1694             }
1695              
1696             sub _get_pragma_value {
1697 98     98   224 my ( $self, $resp, $pragma ) = @_;
1698             defined $resp
1699 98 100       746 or return $self->{_pragmata}{$pragma};
1700 5         17 ( my $re = $pragma ) =~ s/ _ /-/smxg;
1701 5         71 $re = qr{ \Q$re\E }smxi;
1702 5         25 foreach ( $resp->header( 'Pragma' ) ) {
1703 3 100       184 m/ $re \s+ = \s+ (.+) /smxi and return $1;
1704             }
1705             # Sorry, PBP -- to be compatible with the performance of this method
1706             # when $resp is defined, we must return an explicit undef here.
1707 3         146 return undef; ## no critic (ProhibitExplicitReturnUndef)
1708             }
1709              
1710             =for html
1711              
1712             =item $resp = $st->country_names()
1713              
1714             This method returns an HTTP::Response object. If the request succeeds,
1715             the content of the object will be the known country names and their
1716             abbreviations in the desired format. If the desired format is
1717             C<'legacy'> or C<'json'> and the method is called in list context, the
1718             second returned item will be a reference to an array containing the
1719             parsed data.
1720              
1721             This method takes the following options, specified either command-style
1722             or as a hash reference.
1723              
1724             C<-format> specifies the desired format of the retrieved data. Possible
1725             values are C<'xml'>, C<'json'>, C<'html'>, C<'csv'>, and C<'legacy'>,
1726             which is the default. The legacy format is tab-delimited text, such as
1727             was returned by the version 1 interface.
1728              
1729             C<-json> specifies JSON format. If you specify both C<-json> and
1730             C<-format> you will get an exception unless you specify C<-format=json>.
1731              
1732             This method requires a Space Track username and password. It
1733             implicitly calls the C method if the session cookie is
1734             missing or expired. If C fails, you will get the
1735             HTTP::Response from C.
1736              
1737             If this method succeeds, the response will contain headers
1738              
1739             Pragma: spacetrack-type = country_names
1740             Pragma: spacetrack-source = spacetrack
1741              
1742             There are no arguments.
1743              
1744             =cut
1745              
1746             sub country_names {
1747              
1748 1     1 1 5 my ( $self, @args ) = @_;
1749              
1750 1         6 ( my $opt, @args ) = _parse_args(
1751             [
1752             'json!' => 'Return data in JSON format',
1753             'format=s' => 'Specify return format',
1754             ], @args );
1755 1         5 my $format = _retrieval_format( country_names => $opt );
1756              
1757 1         7 my $resp = $self->spacetrack_query_v2(
1758             basicspacedata => 'query',
1759             class => 'boxscore',
1760             format => $format,
1761             predicates => 'COUNTRY,SPADOC_CD',
1762             );
1763 1 50       5 $resp->is_success()
1764             or return $resp;
1765              
1766 1         11 $self->_add_pragmata( $resp,
1767             'spacetrack-type' => 'country_names',
1768             'spacetrack-source' => 'spacetrack',
1769             'spacetrack-interface' => 2,
1770             );
1771              
1772 1 50       7 'json' eq $format
1773             or return $resp;
1774              
1775 1         4 my $json = $self->_get_json_object();
1776              
1777 1         4 my $data = $json->decode( $resp->content() );
1778              
1779 1         100 my %dict;
1780 1         2 foreach my $datum ( @{ $data } ) {
  1         5  
1781             defined $datum->{SPADOC_CD}
1782 100 50       202 and $dict{$datum->{SPADOC_CD}} = $datum->{COUNTRY};
1783             }
1784              
1785 1 50       6 if ( $opt->{json} ) {
1786              
1787 0         0 $resp->content( $json->encode( \%dict ) );
1788              
1789             } else {
1790              
1791             $resp->content(
1792             join '',
1793             join( "\t", 'Abbreviation', 'Country/Organization' )
1794             . "\n",
1795 1         10 map { "$_\t$dict{$_}\n" } sort keys %dict
  0         0  
1796             );
1797              
1798             }
1799              
1800 1         47 return $resp;
1801             }
1802              
1803              
1804             =for html
1805              
1806             =item $resp = $st->favorite( $name )
1807              
1808             This method returns an HTTP::Response object. If the request succeeds,
1809             the content of the response will be TLE data specified by the named
1810             favorite in the desired format. The named favorite must have previously
1811             been set up by the user, or be one of the 'global' favorites (e.g.
1812             C<'Navigation'>, C<'Weather'>, and so on).
1813              
1814             This method takes the following options, specified either command-style
1815             or as a hash reference.
1816              
1817             C<-format> specifies the desired format of the retrieved data. Possible
1818             values are C<'xml'>, C<'json'>, C<'html'>, C<'csv'>, and C<'legacy'>,
1819             which is the default. The legacy format is tab-delimited text, such as
1820             was returned by the version 1 interface.
1821              
1822             C<-json> specifies JSON format. If you specify both C<-json> and
1823             C<-format> you will get an exception unless you specify C<-format=json>.
1824              
1825             This method requires a Space Track username and password. It
1826             implicitly calls the C method if the session cookie is
1827             missing or expired. If C fails, you will get the
1828             HTTP::Response from C.
1829              
1830             =cut
1831              
1832             # Called dynamically
1833             sub _favorite_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
1834             return [
1835 1     1   4 'json!' => 'Return data in JSON format',
1836             'format=s' => 'Specify return format',
1837             ];
1838             }
1839              
1840             sub favorite {
1841 1     1 1 4 my ($self, @args) = @_;
1842 1         2 delete $self->{_pragmata};
1843              
1844 1         3 ( my $opt, @args ) = _parse_args( @args );
1845              
1846             @args
1847 1 50 33     6 and defined $args[0]
1848             or Carp::croak 'Must specify a favorite';
1849 1 50       4 @args > 1
1850             and Carp::croak 'Can not specify more than one favorite';
1851             # https://beta.space-track.org/basicspacedata/query/class/tle_latest/favorites/Visible/ORDINAL/1/EPOCH/%3Enow-30/format/3le
1852              
1853 1         4 my $rest = $self->_convert_retrieve_options_to_rest( $opt );
1854 1         3 $rest->{favorites} = $args[0];
1855 1         3 $rest->{EPOCH} = '>now-30';
1856 1         2 delete $rest->{orderby};
1857              
1858 1         4 my $resp = $self->spacetrack_query_v2(
1859             basicspacedata => 'query',
1860             _sort_rest_arguments( $rest )
1861             );
1862              
1863 1 50       6 $resp->is_success()
1864             or return $resp;
1865              
1866 0 0       0 _spacetrack_v2_response_is_empty( $resp )
1867             and return HTTP::Response->new(
1868             HTTP_NOT_FOUND,
1869             "Favorite '$args[0]' not found"
1870             );
1871              
1872 0         0 return $resp;
1873             }
1874              
1875              
1876             =for html
1877              
1878             =item $resp = $st->file ($name)
1879              
1880             This method takes the name of an observing list file, or a handle to an
1881             open observing list file, and returns an HTTP::Response object whose
1882             content is the relevant element sets, retrieved from the Space Track web
1883             site. If called in list context, the first element of the list is the
1884             aforementioned HTTP::Response object, and the second element is a list
1885             reference to list references (i.e. a list of lists). Each of the list
1886             references contains the catalog ID of a satellite or other orbiting body
1887             and the common name of the body.
1888              
1889             This method requires a Space Track username and password. It implicitly
1890             calls the C method if the session cookie is missing or expired.
1891             If C fails, you will get the HTTP::Response from C.
1892              
1893             The observing list file is (how convenient!) in the Celestrak format,
1894             with the first five characters of each line containing the object ID,
1895             and the rest containing a name of the object. Lines whose first five
1896             characters do not look like a right-justified number will be ignored.
1897              
1898             If this method succeeds, the response will contain headers
1899              
1900             Pragma: spacetrack-type = orbit
1901             Pragma: spacetrack-source = spacetrack
1902              
1903             These can be accessed by C<< $st->content_type( $resp ) >> and
1904             C<< $st->content_source( $resp ) >> respectively.
1905              
1906             You can specify the C options on this method as well.
1907              
1908             =cut
1909              
1910             # Called dynamically
1911             sub _file_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
1912 0     0   0 return [ _get_retrieve_options() ];
1913             }
1914              
1915             sub file {
1916 1     1 1 5 my ($self, @args) = @_;
1917              
1918 1         5 my ( $opt, $file ) = $self->_parse_retrieve_args( @args );
1919              
1920 1         6 delete $self->{_pragmata};
1921              
1922 1 50       8 if ( ! Scalar::Util::openhandle( $file ) ) {
1923 1 50       23 -e $file or return HTTP::Response->new (
1924             HTTP_NOT_FOUND, "Can't find file $file");
1925 1 50       10 my $fh = IO::File->new($file, '<') or
1926             return HTTP::Response->new (
1927             HTTP_INTERNAL_SERVER_ERROR, "Can't open $file: $!");
1928 1         138 $file = $fh;
1929             }
1930              
1931 1         5 local $/ = undef;
1932 1         53 return $self->_handle_observing_list( $opt, <$file> )
1933             }
1934              
1935              
1936             =for html
1937              
1938             =item $resp = $st->get (attrib)
1939              
1940             B whose content is the value
1941             of the given attribute. If called in list context, the second element
1942             of the list is just the value of the attribute, for those who don't want
1943             to winkle it out of the response object. We croak on a bad attribute name.
1944              
1945             If this method succeeds, the response will contain header
1946              
1947             Pragma: spacetrack-type = get
1948              
1949             This can be accessed by C<< $st->content_type( $resp ) >>.
1950              
1951             See L for the names and functions of the attributes.
1952              
1953             =cut
1954              
1955             # Called dynamically
1956             sub _readline_complete_command_get { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
1957             # my ( $self, $text, $line, $start, $cmd_line ) = @_;
1958 0     0   0 my ( $self, $text ) = @_;
1959 0 0       0 $text eq ''
1960             and return( $self->attribute_names() );
1961 0         0 my $re = qr/ \A \Q$text\E /smx;
1962 0         0 return( sort grep { $_ =~ $re } $self->attribute_names() );
  0         0  
1963             }
1964              
1965             sub get {
1966 1     1 1 4 my ( $self, $name ) = @_;
1967 1         4 delete $self->{_pragmata};
1968 1   33     16 my $code = $self->can( "_get_attr_$name" ) || $self->can( 'getv' );
1969 1         4 my $value = $code->( $self, $name );
1970 1         22 my $resp = HTTP::Response->new( HTTP_OK, COPACETIC, undef, $value );
1971 1         55 $self->_add_pragmata( $resp,
1972             'spacetrack-type' => 'get',
1973             );
1974 1         5 $self->__dump_response( $resp );
1975 1 50       8 return wantarray ? ($resp, $value ) : $resp;
1976             }
1977              
1978             # Called dynamically
1979             sub _get_attr_dump_headers { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
1980 0     0   0 my ( $self, $name ) = @_;
1981 0         0 my $value = $self->getv( $name );
1982 0         0 my @opts = ( $value, '#' );
1983 0 0       0 if ( $value ) {
1984 0         0 foreach my $key ( @dump_options ) {
1985 0         0 my $const = "DUMP_\U$key";
1986 0         0 my $mask = __PACKAGE__->$const();
1987 0 0       0 $value & $mask
1988             and push @opts, "--$key";
1989             }
1990             } else {
1991 0         0 push @opts, '--none';
1992             }
1993 0         0 return "@opts";
1994             }
1995              
1996              
1997             =for html
1998              
1999             =item $value = $st->getv (attrib)
2000              
2001             This method returns the value of the given attribute, which is what
2002             C should have done.
2003              
2004             See L for the names and functions of the attributes.
2005              
2006             =cut
2007              
2008             sub getv {
2009 66     66 1 732 my ( $self, $name ) = @_;
2010 66 50       152 defined $name
2011             or Carp::croak 'No attribute name specified';
2012 66 50       194 my $code = $accessor{$name}
2013             or Carp::croak "No such attribute as '$name'";
2014 66         170 return $code->( $self, $name );
2015             }
2016              
2017              
2018             =for html
2019              
2020             =item $resp = $st->help ()
2021              
2022             This method exists for the convenience of the shell () method. It
2023             always returns success, with the content being whatever it's
2024             convenient (to the author) to include.
2025              
2026             If the C attribute is set, the L
2027             web page for Astro::Satpass is launched.
2028              
2029             If this method succeeds B the webcmd attribute is not set, the
2030             response will contain header
2031              
2032             Pragma: spacetrack-type = help
2033              
2034             This can be accessed by C<< $st->content_type( $resp ) >>.
2035              
2036             Otherwise (i.e. in any case where the response does B contain
2037             actual help text) this header will be absent.
2038              
2039             =cut
2040              
2041             sub help {
2042 1     1 1 3 my $self = shift;
2043 1         41 delete $self->{_pragmata};
2044 1 50       6 if ($self->{webcmd}) {
2045 0         0 my $cmd = $self->{webcmd};
2046 0 0       0 if ( '1' eq $cmd ) {
2047 0         0 require Browser::Open;
2048 0         0 $cmd = Browser::Open::open_browser_cmd();
2049             }
2050             # TODO just use open_browser() once webcmd becomes Boolean.
2051 0         0 system { $cmd } $cmd,
  0         0  
2052             'https://metacpan.org/release/Astro-SpaceTrack';
2053 0         0 return HTTP::Response->new (HTTP_OK, undef, undef, 'OK');
2054             } else {
2055 1         7 my $resp = HTTP::Response->new (HTTP_OK, undef, undef, <<'EOD');
2056             The following commands are defined:
2057             box_score
2058             Retrieve the SATCAT box score. A Space Track login is needed.
2059             celestrak name
2060             Retrieves the named catalog of IDs from Celestrak. If the
2061             direct attribute is false (the default), the corresponding
2062             orbital elements come from Space Track. If true, they come
2063             from Celestrak, and no login is needed.
2064             exit (or bye)
2065             Terminate the shell. End-of-file also works.
2066             file filename
2067             Retrieve the catalog IDs given in the named file (one per
2068             line, with the first five characters being the ID).
2069             get
2070             Get the value of a single attribute.
2071             help
2072             Display this help text.
2073             iridium_status
2074             Status of Iridium satellites, from Rod Sladen and/or T. S. Kelso.
2075             login
2076             Acquire a session cookie. You must have already set the
2077             username and password attributes. This will be called
2078             implicitly if needed by any method that accesses data.
2079             names source
2080             Lists the catalog names from the given source.
2081             retrieve number ...
2082             Retieves the latest orbital elements for the given
2083             catalog numbers.
2084             search_date date ...
2085             Retrieves orbital elements by launch date.
2086             search_decay date ...
2087             Retrieves orbital elements by decay date.
2088             search_id id ...
2089             Retrieves orbital elements by international designator.
2090             search_name name ...
2091             Retrieves orbital elements by satellite common name.
2092             set attribute value ...
2093             Sets the given attributes. Legal attributes are
2094             addendum = extra text for the shell () banner;
2095             banner = false to supress the shell () banner;
2096             cookie_expires = Perl date the session cookie expires;
2097             direct = true to fetch orbital elements directly
2098             from a redistributer. Currently this only affects the
2099             celestrak() method. The default is true, and it is
2100             deprecated.
2101             filter = true supresses all output to stdout except
2102             orbital elements;
2103             identity = load username and password from identity file
2104             if true and Config::Identity can be loaded;
2105             max_range = largest range of numbers that can be re-
2106             trieved (default: 500);
2107             password = the Space-Track password;
2108             session_cookie = the text of the session cookie;
2109             username = the Space-Track username;
2110             verbose = true for verbose catalog error messages;
2111             webcmd = command to launch a URL (for web-based help);
2112             with_name = true to retrieve common names as well.
2113             The session_cookie and cookie_expires attributes should
2114             only be set to previously-retrieved, matching values.
2115             source filename
2116             Executes the contents of the given file as shell commands.
2117             spacetrack name
2118             Retrieves the named catalog of orbital elements from
2119             Space Track.
2120             The shell supports a pseudo-redirection of standard output,
2121             using the usual Unix shell syntax (i.e. '>output_file').
2122             EOD
2123 1         49 $self->_add_pragmata($resp,
2124             'spacetrack-type' => 'help',
2125             );
2126 1         3 $self->__dump_response( $resp );
2127 1         5 return $resp;
2128             }
2129             }
2130              
2131              
2132             =for html
2133              
2134             =item $resp = $st->iridium_status ($format);
2135              
2136             This method queries its sources of Iridium status, returning an
2137             HTTP::Response object containing the relevant data (if all queries
2138             succeeded) or the status of the first failure. If the queries succeed,
2139             the content is a series of lines formatted by "%6d %-15s%-8s %s\n",
2140             with NORAD ID, name, status, and comment substituted in.
2141              
2142             If no format is specified, the format specified in the
2143             C attribute is used.
2144              
2145             There is one option, C<'raw'>, which can be specified either
2146             command-line style (i.e. C<-raw>) or as a leading hash reference.
2147             Asserting this option causes status information from sources other than
2148             Celestrak and Rod Sladen not to be supplemented by Celestrak data. In
2149             addition, it prevents all sources from being supplemented by canned data
2150             that includes all original-design Iridium satellites, including those
2151             that have decayed. By default this option is not asserted.
2152              
2153             Format C<'mccants'> is B, and throws an exception as of
2154             version 0.137. This entire method will be deprecated and removed once
2155             the last flaring Iridium satellite is removed from service.
2156              
2157             A Space Track username and password are required only if the format is
2158             C<'spacetrack'>.
2159              
2160             If this method succeeds, the response will contain headers
2161              
2162             Pragma: spacetrack-type = iridium_status
2163             Pragma: spacetrack-source =
2164              
2165             The spacetrack-source will be C<'kelso'>, C<'sladen'>, or
2166             C<'spacetrack'>, depending on the format requested.
2167              
2168             These can be accessed by C<< $st->content_type( $resp ) >> and
2169             C<< $st->content_source( $resp ) >> respectively.
2170              
2171             The source of the data and, to a certain extent, the format of the
2172             results is determined by the optional $format argument, which defaults
2173             to the value of the C attribute.
2174              
2175             If the format is 'kelso', only Dr. Kelso's Celestrak web site
2176             (L) is queried for
2177             the data. The possible status values are documented at
2178             L, and repeated here for
2179             convenience:
2180              
2181             '[+]' - Operational
2182             '[-]' - Nonoperational
2183             '[P]' - Partially Operational
2184             '[B]' - Backup/Standby
2185             '[S]' - Spare
2186             '[X]' - Extended Mission
2187             '[D]' - Decayed
2188             '[?]' - Unknown
2189              
2190             The comment will be 'Spare', 'Tumbling', or '' depending on the status.
2191              
2192             In addition, the data from Celestrak may contain the following
2193             status:
2194              
2195             'dum' - Dummy mass
2196              
2197             A blank status indicates that the satellite is in service and
2198             therefore capable of producing flares.
2199              
2200             If the format is 'sladen', the primary source of information will be Rod
2201             Sladen's "Iridium Constellation Status" web page,
2202             L, which gives status on all
2203             Iridium satellites, but no OID. The Celestrak list will be used to
2204             provide OIDs for Iridium satellite numbers, so that a complete list is
2205             generated. Mr. Sladen's page simply lists operational and failed
2206             satellites in each plane, so this software imposes Kelso-style statuses
2207             on the data. That is to say, operational satellites will be marked
2208             '[+]', spares will be marked '[S]', and failed satellites will be
2209             marked '[-]', with the corresponding portable statuses. As of version
2210             0.035, all failed satellites will be marked '[-]'. Previous to this
2211             release, failed satellites not specifically marked as tumbling were
2212             considered spares.
2213              
2214             The comment field in 'sladen' format data will contain the orbital plane
2215             designation for the satellite, 'Plane n' with 'n' being a number from 1
2216             to 6. If the satellite is failed but not tumbling, the text ' - Failed
2217             on station?' will be appended to the comment. The dummy masses will be
2218             included from the Kelso data, with status '[-]' but comment 'Dummy'.
2219              
2220             If the format is 'spacetrack', the data come from both Celestrak and
2221             Space Track. For any given OID, we take the Space Track data if it shows
2222             the OID as being decayed, or if the OID does not appear in the Celestrak
2223             data; otherwise we take the Celestrak data. The idea here is to get a
2224             list of statuses that include decayed satellites dropped from the
2225             Celestrak list. You will need a Space Track username and password for
2226             this. The format of the returned data is the same as for Celestrak data.
2227              
2228             If the method is called in list context, the first element of the
2229             returned list will be the HTTP::Response object, and the second
2230             element will be a reference to a list of anonymous lists, each
2231             containing [$id, $name, $status, $comment, $portable_status] for
2232             an Iridium satellite. The portable statuses are:
2233              
2234             0 = BODY_STATUS_IS_OPERATIONAL means object is operational,
2235             and capable of producing predictable flares;
2236             1 = BODY_STATUS_IS_SPARE means object is a spare or
2237             otherwise not in regular service, but is controlled
2238             and may be capable of producing predictable flares;
2239             2 = BODY_STATUS_IS_TUMBLING means object is tumbling
2240             or otherwise unservicable, and incapable of producing
2241             predictable flares
2242             3 - BODY_STATUS_IS_DECAYED neans that the object is decayed.
2243              
2244             In terms of the Kelso statuses, the mapping is:
2245              
2246             '[+]' - BODY_STATUS_IS_OPERATIONAL
2247             '[-]' - BODY_STATUS_IS_TUMBLING
2248             '[P]' - BODY_STATUS_IS_SPARE
2249             '[B]' - BODY_STATUS_IS_SPARE
2250             '[S]' - BODY_STATUS_IS_SPARE
2251             '[X]' - BODY_STATUS_IS_SPARE
2252             '[D]' - BODY_STATUS_IS_DECAYED
2253             '[?]' - BODY_STATUS_IS_TUMBLING
2254              
2255             The BODY_STATUS constants are exportable using the :status tag.
2256              
2257             =cut
2258              
2259             { # Begin local symbol block.
2260              
2261 10     10   107 use constant BODY_STATUS_IS_OPERATIONAL => 0;
  10         22  
  10         694  
2262 10     10   67 use constant BODY_STATUS_IS_SPARE => 1;
  10         23  
  10         617  
2263 10     10   64 use constant BODY_STATUS_IS_TUMBLING => 2;
  10         31  
  10         543  
2264 10     10   84 use constant BODY_STATUS_IS_DECAYED => 3;
  10         22  
  10         83693  
2265              
2266             my %kelso_comment = ( # Expand Kelso status.
2267             '[S]' => 'Spare',
2268             '[-]' => 'Tumbling',
2269             '[D]' => 'Decayed',
2270             );
2271             my %status_portable = ( # Map statuses to portable.
2272             kelso => {
2273             '' => BODY_STATUS_IS_OPERATIONAL,
2274             '[+]' => BODY_STATUS_IS_OPERATIONAL, # Operational
2275             '[-]' => BODY_STATUS_IS_TUMBLING, # Nonoperational
2276             '[P]' => BODY_STATUS_IS_SPARE, # Partially Operational
2277             '[B]' => BODY_STATUS_IS_SPARE, # Backup/Standby
2278             '[S]' => BODY_STATUS_IS_SPARE, # Spare
2279             '[X]' => BODY_STATUS_IS_SPARE, # Extended Mission
2280             '[D]' => BODY_STATUS_IS_DECAYED, # Decayed
2281             '[?]' => BODY_STATUS_IS_TUMBLING, # Unknown
2282             },
2283             # sladen => undef, # Not needed; done programmatically.
2284             );
2285              
2286             $status_portable{kelso_inverse} = {
2287             map { $status_portable{kelso}{$_} => $_ } qw{ [-] [S] [+] } };
2288              
2289             # All Iridium Classic satellites. The order of the data is:
2290             # OID, name, status string, comment, portable status.
2291             #
2292             # Generated by tools/all_iridium_classic -indent=4
2293             # on Sun May 31 12:27:10 2020 GMT
2294              
2295             my @all_iridium_classic = (
2296             [ 24792, 'Iridium 8', '[D]', 'Decayed 2017-11-24', 3 ],
2297             [ 24793, 'Iridium 7', '[?]', 'SpaceTrack', 2 ],
2298             [ 24794, 'Iridium 6', '[D]', 'Decayed 2017-12-23', 3 ],
2299             [ 24795, 'Iridium 5', '[?]', 'SpaceTrack', 2 ],
2300             [ 24796, 'Iridium 4', '[?]', 'SpaceTrack', 2 ],
2301             [ 24836, 'Iridium 914', '[?]', 'SpaceTrack', 2 ],
2302             [ 24837, 'Iridium 12', '[D]', 'Decayed 2018-09-02', 3 ],
2303             [ 24838, 'Iridium 9', '[D]', 'Decayed 2003-03-11', 3 ],
2304             [ 24839, 'Iridium 10', '[D]', 'Decayed 2018-10-06', 3 ],
2305             [ 24840, 'Iridium 13', '[D]', 'Decayed 2018-04-29', 3 ],
2306             [ 24841, 'Iridium 16', '[?]', 'SpaceTrack', 2 ],
2307             [ 24842, 'Iridium 911', '[?]', 'SpaceTrack', 2 ],
2308             [ 24869, 'Iridium 15', '[D]', 'Decayed 2018-10-14', 3 ],
2309             [ 24870, 'Iridium 17', '[?]', 'SpaceTrack', 2 ],
2310             [ 24871, 'Iridium 920', '[?]', 'SpaceTrack', 2 ],
2311             [ 24872, 'Iridium 18', '[D]', 'Decayed 2018-08-19', 3 ],
2312             [ 24873, 'Iridium 921', '[?]', 'SpaceTrack', 2 ],
2313             [ 24903, 'Iridium 26', '[?]', 'SpaceTrack', 2 ],
2314             [ 24904, 'Iridium 25', '[D]', 'Decayed 2018-05-14', 3 ],
2315             [ 24905, 'Iridium 46', '[D]', 'Decayed 2019-05-11', 3 ],
2316             [ 24906, 'Iridium 23', '[D]', 'Decayed 2018-03-28', 3 ],
2317             [ 24907, 'Iridium 22', '[?]', 'SpaceTrack', 2 ],
2318             [ 24944, 'Iridium 29', '[?]', 'SpaceTrack', 2 ],
2319             [ 24945, 'Iridium 32', '[D]', 'Decayed 2019-03-10', 3 ],
2320             [ 24946, 'Iridium 33', '[?]', 'SpaceTrack', 2 ],
2321             [ 24947, 'Iridium 27', '[D]', 'Decayed 2002-02-01', 3 ],
2322             [ 24948, 'Iridium 28', '[?]', 'SpaceTrack', 2 ],
2323             [ 24949, 'Iridium 30', '[D]', 'Decayed 2017-09-28', 3 ],
2324             [ 24950, 'Iridium 31', '[D]', 'Decayed 2018-12-20', 3 ],
2325             [ 24965, 'Iridium 19', '[D]', 'Decayed 2018-04-07', 3 ],
2326             [ 24966, 'Iridium 35', '[D]', 'Decayed 2018-12-26', 3 ],
2327             [ 24967, 'Iridium 36', '[?]', 'SpaceTrack', 2 ],
2328             [ 24968, 'Iridium 37', '[D]', 'Decayed 2018-05-26', 3 ],
2329             [ 24969, 'Iridium 34', '[D]', 'Decayed 2018-01-08', 3 ],
2330             [ 25039, 'Iridium 43', '[D]', 'Decayed 2018-02-11', 3 ],
2331             [ 25040, 'Iridium 41', '[D]', 'Decayed 2018-07-28', 3 ],
2332             [ 25041, 'Iridium 40', '[D]', 'Decayed 2018-09-23', 3 ],
2333             [ 25042, 'Iridium 39', '[?]', 'SpaceTrack', 2 ],
2334             [ 25043, 'Iridium 38', '[?]', 'SpaceTrack', 2 ],
2335             [ 25077, 'Iridium 42', '[?]', 'SpaceTrack', 2 ],
2336             [ 25078, 'Iridium 44', '[?]', 'SpaceTrack', 2 ],
2337             [ 25104, 'Iridium 45', '[?]', 'SpaceTrack', 2 ],
2338             [ 25105, 'Iridium 24', '[?]', 'SpaceTrack', 2 ],
2339             [ 25106, 'Iridium 47', '[D]', 'Decayed 2018-09-01', 3 ],
2340             [ 25107, 'Iridium 48', '[D]', 'Decayed 2001-05-05', 3 ],
2341             [ 25108, 'Iridium 49', '[D]', 'Decayed 2018-02-13', 3 ],
2342             [ 25169, 'Iridium 52', '[D]', 'Decayed 2018-11-05', 3 ],
2343             [ 25170, 'Iridium 56', '[D]', 'Decayed 2018-10-11', 3 ],
2344             [ 25171, 'Iridium 54', '[D]', 'Decayed 2019-05-11', 3 ],
2345             [ 25172, 'Iridium 50', '[D]', 'Decayed 2018-09-23', 3 ],
2346             [ 25173, 'Iridium 53', '[D]', 'Decayed 2018-09-30', 3 ],
2347             [ 25262, 'Iridium 51', '[?]', 'SpaceTrack', 2 ],
2348             [ 25263, 'Iridium 61', '[D]', 'Decayed 2019-07-23', 3 ],
2349             [ 25272, 'Iridium 55', '[D]', 'Decayed 2019-03-31', 3 ],
2350             [ 25273, 'Iridium 57', '[?]', 'SpaceTrack', 2 ],
2351             [ 25274, 'Iridium 58', '[D]', 'Decayed 2019-04-07', 3 ],
2352             [ 25275, 'Iridium 59', '[D]', 'Decayed 2019-03-11', 3 ],
2353             [ 25276, 'Iridium 60', '[D]', 'Decayed 2019-03-17', 3 ],
2354             [ 25285, 'Iridium 62', '[D]', 'Decayed 2018-11-07', 3 ],
2355             [ 25286, 'Iridium 63', '[?]', 'SpaceTrack', 2 ],
2356             [ 25287, 'Iridium 64', '[D]', 'Decayed 2019-04-01', 3 ],
2357             [ 25288, 'Iridium 65', '[D]', 'Decayed 2018-07-19', 3 ],
2358             [ 25289, 'Iridium 66', '[D]', 'Decayed 2018-08-23', 3 ],
2359             [ 25290, 'Iridium 67', '[D]', 'Decayed 2018-07-02', 3 ],
2360             [ 25291, 'Iridium 68', '[D]', 'Decayed 2018-06-06', 3 ],
2361             [ 25319, 'Iridium 69', '[?]', 'SpaceTrack', 2 ],
2362             [ 25320, 'Iridium 71', '[?]', 'SpaceTrack', 2 ],
2363             [ 25342, 'Iridium 70', '[D]', 'Decayed 2018-10-11', 3 ],
2364             [ 25343, 'Iridium 72', '[D]', 'Decayed 2018-05-14', 3 ],
2365             [ 25344, 'Iridium 73', '[?]', 'SpaceTrack', 2 ],
2366             [ 25345, 'Iridium 74', '[D]', 'Decayed 2017-06-11', 3 ],
2367             [ 25346, 'Iridium 75', '[D]', 'Decayed 2018-07-10', 3 ],
2368             [ 25431, 'Iridium 3', '[D]', 'Decayed 2018-02-08', 3 ],
2369             [ 25432, 'Iridium 76', '[D]', 'Decayed 2018-08-28', 3 ],
2370             [ 25467, 'Iridium 82', '[?]', 'SpaceTrack', 2 ],
2371             [ 25468, 'Iridium 81', '[D]', 'Decayed 2018-07-17', 3 ],
2372             [ 25469, 'Iridium 80', '[D]', 'Decayed 2018-08-12', 3 ],
2373             [ 25470, 'Iridium 79', '[D]', 'Decayed 2000-11-29', 3 ],
2374             [ 25471, 'Iridium 77', '[D]', 'Decayed 2017-09-22', 3 ],
2375             [ 25527, 'Iridium 2', '[?]', 'SpaceTrack', 2 ],
2376             [ 25528, 'Iridium 86', '[D]', 'Decayed 2018-10-05', 3 ],
2377             [ 25529, 'Iridium 85', '[D]', 'Decayed 2000-12-30', 3 ],
2378             [ 25530, 'Iridium 84', '[D]', 'Decayed 2018-11-04', 3 ],
2379             [ 25531, 'Iridium 83', '[D]', 'Decayed 2018-11-05', 3 ],
2380             [ 25577, 'Iridium 20', '[D]', 'Decayed 2018-10-22', 3 ],
2381             [ 25578, 'Iridium 11', '[D]', 'Decayed 2018-10-22', 3 ],
2382             [ 25777, 'Iridium 14', '[D]', 'Decayed 2019-03-15', 3 ],
2383             [ 25778, 'Iridium 21', '[D]', 'Decayed 2018-05-24', 3 ],
2384             [ 27372, 'Iridium 91', '[D]', 'Decayed 2019-03-13', 3 ],
2385             [ 27373, 'Iridium 90', '[D]', 'Decayed 2019-01-23', 3 ],
2386             [ 27374, 'Iridium 94', '[D]', 'Decayed 2018-04-18', 3 ],
2387             [ 27375, 'Iridium 95', '[D]', 'Decayed 2019-03-25', 3 ],
2388             [ 27376, 'Iridium 96', '[D]', 'Decayed 2020-05-30', 3 ],
2389             [ 27450, 'Iridium 97', '[D]', 'Decayed 2019-12-27', 3 ],
2390             [ 27451, 'Iridium 98', '[D]', 'Decayed 2018-08-24', 3 ],
2391             );
2392              
2393             my %ignore_raw = map { $_ => 1 } qw{ kelso sladen };
2394              
2395             # Called dynamically
2396             sub _iridium_status_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
2397             return [
2398 2     2   8 'raw!' => 'Do not supplement with kelso data'
2399             ];
2400             }
2401              
2402             sub iridium_status {
2403 2     2 1 8 my ( $self, @args ) = @_;
2404 2         10 my ( $opt, $fmt ) = _parse_args( @args );
2405             defined $fmt
2406 2 50       22 or $fmt = $self->{iridium_status_format};
2407 2         9 $self->_deprecation_notice( iridium_status => $fmt );
2408 2         10 delete $self->{_pragmata};
2409 2         7 my %rslt;
2410             my $resp;
2411              
2412 2 50 33     14 if ( ! $opt->{raw} || $ignore_raw{$fmt} ) {
2413 2         10 $resp = $self->_iridium_status_kelso( $fmt, \%rslt );
2414 2 50       18 $resp->is_success()
2415             or return $resp;
2416             }
2417              
2418 2 100       34 unless ( 'kelso' eq $fmt ) {
2419 1 50       12 my $code = $self->can( "_iridium_status_$fmt" )
2420             or Carp::croak "Bad iridium_status format '$fmt'";
2421 1 50       6 ( $resp = $code->( $self, $fmt, \%rslt ) )->is_success()
2422             or return $resp;
2423             }
2424              
2425 2 50       44 unless ( $opt->{raw} ) {
2426 2         14 foreach my $body ( @all_iridium_classic ) {
2427 190 100 66     701 $rslt{$body->[0]}
2428             and $body->[4] != BODY_STATUS_IS_DECAYED
2429             and next;
2430 132         259 $rslt{$body->[0]} = [ @{ $body } ]; # shallow clone
  132         702  
2431             }
2432             }
2433              
2434             $resp->content (join '', map {
2435 194         296 sprintf "%6d %-15s%-8s %s\n", @{$rslt{$_}}[0 .. 3]}
  194         661  
2436 2         52 sort {$a <=> $b} keys %rslt);
  1052         1820  
2437 2         92 $self->_add_pragmata($resp,
2438             'spacetrack-type' => 'iridium-status',
2439             'spacetrack-source' => $fmt,
2440             );
2441 2         16 $self->__dump_response( $resp );
2442             return wantarray ? ($resp, [
2443 2 50       84 sort { $a->[0] <=> $b->[0] }
  0         0  
2444             values %rslt
2445             ]) : $resp;
2446             }
2447              
2448             # Get Iridium data from Celestrak.
2449             sub _iridium_status_kelso {
2450             # my ( $self, $fmt, $rslt ) = @_;
2451 2     2   8 my ( $self, undef, $rslt ) = @_; # $fmt only relevant to mccants
2452 2         10 my $resp = $self->_get_agent()->get(
2453             $self->getv( 'url_iridium_status_kelso' )
2454             );
2455 2 50       1140939 $resp->is_success or return $resp;
2456 2         58 foreach my $buffer (split '\n', $resp->content) {
2457 62         403 $buffer =~ s/ \s+ \z //smx;
2458 62         208 my $id = substr ($buffer, 0, 5) + 0;
2459 62         139 my $name = substr ($buffer, 5);
2460 62         163 my $status = '';
2461 62 50       409 $name =~ s/ \s+ ( [[] .+? []] ) \s* \z //smx
2462             and $status = $1;
2463 62         169 my $portable_status = $status_portable{kelso}{$status};
2464 62   50     160 my $comment = $kelso_comment{$status} || '';
2465 62         142 $name = ucfirst lc $name;
2466 62         395 $rslt->{$id} = [ $id, $name, $status, $comment,
2467             $portable_status ];
2468             }
2469 2         19 return $resp;
2470             }
2471              
2472             # Mung an Iridium status hash to assume all actual Iridium
2473             # satellites are good. This is used to prevent bleed-through from
2474             # Kelso to McCants, since the latter only reports by exception.
2475             sub _iridium_status_assume_good {
2476 1     1   3 my ( undef, $rslt ) = @_; # Invocant unused
2477              
2478 1         2 foreach my $val ( values %{ $rslt } ) {
  1         5  
2479 31 100       70 $val->[1] =~ m/ \A iridium \b /smxi
2480             or next;
2481 29         38 $val->[2] = '';
2482 29         41 $val->[4] = BODY_STATUS_IS_OPERATIONAL;
2483             }
2484              
2485 1         3 return;
2486             }
2487              
2488             my %sladen_interpret_detail = (
2489             '' => sub {
2490             my ( $rslt, $id, $name, $plane ) = @_;
2491             $rslt->{$id} = [ $id, $name, '[-]',
2492             "$plane - Failed on station?",
2493             BODY_STATUS_IS_TUMBLING ];
2494             return;
2495             },
2496             d => sub {
2497             return;
2498             },
2499             t => sub {
2500             my ( $rslt, $id, $name, $plane ) = @_;
2501             $rslt->{$id} = [ $id, $name, '[-]', $plane,
2502             BODY_STATUS_IS_TUMBLING ];
2503             },
2504             );
2505              
2506             # Get Iridium status from Rod Sladen. Called dynamically
2507             sub _iridium_status_sladen { ## no critic (ProhibitUnusedPrivateSubroutines)
2508 1     1   6 my ( $self, undef, $rslt ) = @_; # $fmt arg not used
2509              
2510 1         5 $self->_iridium_status_assume_good( $rslt );
2511 1         9 my $resp = $self->_get_agent()->get(
2512             $self->getv( 'url_iridium_status_sladen' )
2513             );
2514 1 50       120740 $resp->is_success or return $resp;
2515 1         32 my %oid;
2516             my %dummy;
2517 1         4 foreach my $id (keys %{ $rslt } ) {
  1         10  
2518 31 100       95 $rslt->{$id}[1] =~ m/ dummy /smxi and do {
2519 2         6 $dummy{$id} = $rslt->{$id};
2520 2         4 $dummy{$id}[3] = 'Dummy';
2521 2         4 next;
2522             };
2523 29 50       77 $rslt->{$id}[1] =~ m/ (\d+) /smx or next;
2524 29         80 $oid{+$1} = $id;
2525             }
2526 1         11 %{ $rslt } = %dummy;
  1         16  
2527              
2528 1         4 my $fail;
2529 1         7 my $re = qr{ ( [\d/]+) }smx;
2530 1         8 local $_ = $resp->content;
2531             #### s{ .*? }{}smxgi; # Strip emphasis notes
2532 1         753 s/ < .*? > //smxg; # Strip markup
2533             # Parenthesized numbers are assumed to represent tumbling
2534             # satellites in the in-service or spare grids.
2535 1         10 my %exception;
2536             {
2537             # 23-Nov-2017 update double-parenthesized 6.
2538 1         3 s< [(]+ (\d+) [)]+ >
  1         287  
  0         0  
  0         0  
2539             < $exception{$1} = BODY_STATUS_IS_TUMBLING; $1>smxge;
2540 1         688 }
2541 1         271 s/ [(] .*? [)\n] //smxg; # Strip parenthetical comments
2542 81 100       282 foreach ( split qr{ \n }smx ) {
    100          
    100          
2543 1         4 if (m/ < -+ \s+ failed \s+ (?: or \s+ retired \s+ )? -+ > /smxi) {
2544 1         4 $fail++;
2545             $re = qr{ (\d+) (\w?) }smx;
2546 12         26 } elsif ( s/ \A \s* ( plane \s+ \d+ ) \s* : \s* //smxi ) {
2547             my $plane = $1;
2548 12         59 ## s/ \A \D+ //smx; # Strip leading non-digits
2549 12         57 s/ \b [[:alpha:]] .* //smx; # Strip trailing comments
2550 12         22 s/ \s+ \z //smx; # Strip trailing whitespace
2551 12         122 my $inx = 0; # First 11 functional are in service
2552 169         327 while (m/ $re /smxg) {
2553 169         238 my $num_list = $1;
2554 169         535 my $detail = $2;
2555 170         303 foreach my $num ( split qr{ / }smx, $num_list ) {
2556 170 100       346 $num = $num + 0; # Numify.
2557             my $id = $oid{$num} or do {
2558             # This is normal for decayed satellites or Iridium
2559             # NEXT.
2560 141         245 # warn "No oid for Iridium $num\n";
2561             next;
2562 29         57 };
2563 29 50       48 my $name = "Iridium $num";
2564             if ($fail) {
2565 29   33     60 my $interp = $sladen_interpret_detail{$detail}
2566 29         46 || $sladen_interpret_detail{''};
2567             $interp->( $rslt, $id, $name, $plane );
2568 0 0       0 } else {
2569             my $status = $inx > 10 ?
2570             BODY_STATUS_IS_SPARE :
2571             BODY_STATUS_IS_OPERATIONAL;
2572 0 0       0 exists $exception{$num}
2573             and $status = $exception{$num};
2574 0         0 $rslt->{$id} = [ $id, $name,
2575             $status_portable{kelso_inverse}{$status},
2576             $plane, $status ];
2577             }
2578             }
2579 169         713 } continue {
2580             $inx++;
2581             }
2582 1         3 } elsif ( m/ Notes: /smx ) {
2583             last;
2584 67         90 } else { # TODO this is just for debugging.
2585             0;
2586             }
2587             }
2588 1         99  
2589             return $resp;
2590             }
2591              
2592             # FIXME in the last couple days this has started returning nothing.
2593             # It looks like -exclude debris excludes everything, as does
2594             # -exclude rocket.
2595              
2596             # Get Iridium status from Space Track. Unlike the other sources,
2597             # Space Track does not know whether satellites are in service or
2598             # not, but it does know about all of them, and whether or not they
2599             # are on orbit. So the statuses we report are unknown and decayed.
2600             # Note that the portable status for unknown is
2601             # BODY_STATUS_IS_TUMBLING. Called dynamically
2602 0     0   0 sub _iridium_status_spacetrack { ## no critic (ProhibitUnusedPrivateSubroutines)
2603             my ( $self, undef, $rslt ) = @_; # $fmt arg not used
2604 0         0  
2605             my ( $resp, $data ) = $self->search_name( {
2606             tle => 0,
2607             status => 'all',
2608             include => [ qw{ payload } ],
2609             format => 'legacy',
2610 0 0       0 }, 'iridium' );
2611             $resp->is_success()
2612 0         0 or return $resp;
  0         0  
2613             foreach my $body ( @{ $data } ) {
2614             # Starting in 2017, the launches were Iridium Next
2615 0 0       0 # satellites, which do not flare.
2616             $body->{LAUNCH_YEAR} < 2017
2617 0         0 or next;
2618             my $oid = $body->{OBJECT_NUMBER};
2619             $rslt->{$oid}
2620 0 0 0     0 and not $body->{DECAY}
2621             and next;
2622             $rslt->{$oid} = [
2623             $oid,
2624             ucfirst lc $body->{OBJECT_NAME},
2625 0 0       0 defined $body->{DECAY} ?
2626             ( '[D]', "Decayed $body->{DECAY}", BODY_STATUS_IS_DECAYED ) :
2627             ( '[?]', 'SpaceTrack', BODY_STATUS_IS_TUMBLING )
2628             ];
2629             }
2630 0         0 $resp->content( join '',
2631 0         0 map { "$_->[0]\t$_->[1]\t$_->[2]\t$_->[3]\n" }
2632 0         0 sort { $a->[0] <=> $b->[0] }
  0         0  
2633             values %{ $rslt }
2634 0         0 );
2635             return $resp;
2636             }
2637              
2638             } # End of local symbol block.
2639              
2640             =for html
2641              
2642             =item $resp = $st->launch_sites()
2643              
2644             This method returns an HTTP::Response object. If the request succeeds,
2645             the content of the object will be the known launch sites and their
2646             abbreviations in the desired format. If the desired format is
2647             C<'legacy'> or C<'json'> and the method is called in list context, the
2648             second returned item will be a reference to an array containing the
2649             parsed data.
2650              
2651             This method takes the following options, specified either command-style
2652             or as a hash reference.
2653              
2654             C<-format> specifies the desired format of the retrieved data. Possible
2655             values are C<'xml'>, C<'json'>, C<'html'>, C<'csv'>, and C<'legacy'>,
2656             which is the default. The legacy format is tab-delimited text, such as
2657             was returned by the version 1 interface.
2658              
2659             C<-json> specifies JSON format. If you specify both C<-json> and
2660             C<-format> you will get an exception unless you specify C<-format=json>.
2661              
2662             This method requires a Space Track username and password. It
2663             implicitly calls the C method if the session cookie is
2664             missing or expired. If C fails, you will get the
2665             HTTP::Response from C.
2666              
2667             If this method succeeds, the response will contain headers
2668              
2669             Pragma: spacetrack-type = launch_sites
2670             Pragma: spacetrack-source = spacetrack
2671              
2672             There are no arguments.
2673              
2674             =cut
2675              
2676             {
2677             my @headings = ( 'Abbreviation', 'Launch Site' );
2678              
2679             # Called dynamically
2680             sub _launch_sites_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
2681 1     1   6 return [
2682             'json!' => 'Return data in JSON format',
2683             'format=s' => 'Specify return format',
2684             ];
2685             }
2686              
2687 1     1 1 6 sub launch_sites {
2688             my ( $self, @args ) = @_;
2689 1         6  
2690 1         4 ( my $opt, @args ) = _parse_args( @args );
2691             my $format = _retrieval_format( launch_sites => $opt );
2692 1         5  
2693             my $resp = $self->spacetrack_query_v2( qw{
2694             basicspacedata query class launch_site },
2695             format => $format,
2696             orderby => 'SITE_CODE asc',
2697             qw{ predicates all
2698 1 50       5 } );
2699             $resp->is_success()
2700             or return $resp;
2701 1         10  
2702             $self->_add_pragmata($resp,
2703             'spacetrack-type' => 'launch_sites',
2704             'spacetrack-source' => 'spacetrack',
2705             'spacetrack-interface' => 2,
2706             );
2707 1 50       4  
2708             'json' ne $format
2709             and return $resp;
2710 1         4  
2711             my $json = $self->_get_json_object();
2712 1         5  
2713             my $data = $json->decode( $resp->content() );
2714 1         19  
2715 1         3 my %dict;
  1         3  
2716             foreach my $datum ( @{ $data } ) {
2717 34 50       60 defined $datum->{SITE_CODE}
2718             and $dict{$datum->{SITE_CODE}} = $datum->{LAUNCH_SITE};
2719             }
2720 1 50       5  
2721             if ( $opt->{json} ) {
2722 0         0  
2723             $resp->content( $json->encode( \%dict ) );
2724              
2725             } else {
2726              
2727             $resp->content(
2728             join '',
2729 1         11 join( "\t", @headings ) . "\n",
  0         0  
2730             map { "$_\t$dict{$_}\n" } sort keys %dict
2731             );
2732              
2733             }
2734              
2735 1 50       34 wantarray
2736             or return $resp;
2737 0         0  
2738 0         0 my @table;
2739 0         0 push @table, [ @headings ];
2740 0         0 foreach my $key ( sort keys %dict ) {
2741             push @table, [ $key, $dict{$key} ];
2742 0         0 }
2743             return ( $resp, \@table );
2744             }
2745             }
2746              
2747              
2748             =for html
2749              
2750             =item $resp = $st->login ( ... )
2751              
2752             If any arguments are given, this method passes them to the set ()
2753             method. Then it executes a login to the Space Track web site. The return
2754             is normally the HTTP::Response object from the login. But if no session
2755             cookie was obtained, the return is an HTTP::Response with an appropriate
2756             message and the code set to HTTP_UNAUTHORIZED from HTTP::Status (a.k.a.
2757             401). If a login is attempted without the username and password being
2758             set, the return is an HTTP::Response with an appropriate message and the
2759             code set to HTTP_PRECONDITION_FAILED from HTTP::Status (a.k.a. 412).
2760              
2761             A Space Track username and password are required to use this method.
2762              
2763             =cut
2764              
2765 2     2 1 5 sub login {
2766 2         7 my ( $self, @args ) = @_;
2767 2 50       6 delete $self->{_pragmata};
2768 2 50 33     14 @args and $self->set( @args );
2769             ( $self->{username} && $self->{password} ) or
2770             return HTTP::Response->new (
2771 2 50       18 HTTP_PRECONDITION_FAILED, NO_CREDENTIALS);
2772             $self->{dump_headers} & DUMP_TRACE and warn <<"EOD";
2773             Logging in as $self->{username}.
2774             EOD
2775              
2776             # Do not use the spacetrack_query_v2 method to retrieve the session
2777 2         8 # cookie, unless you like bottomless recursions.
2778             my $url = $self->_make_space_track_base_url( 2 ) .
2779             '/ajaxauth/login';
2780             $self->_dump_request(
2781             arg => [
2782             identity => $self->{username},
2783 2         21 password => $self->{password},
2784             ],
2785             method => 'POST',
2786             url => $url,
2787             );
2788             my $resp = $self->_get_agent()->post(
2789             $url, [
2790             identity => $self->{username},
2791 2         9 password => $self->{password},
2792             ] );
2793 2 50       14  
2794             $resp->is_success()
2795 2         36 or return _mung_login_status( $resp );
2796             $self->__dump_response( $resp );
2797 2 50       12  
2798             $resp->content() =~ m/ \b failed \b /smxi
2799             and return HTTP::Response->new( HTTP_UNAUTHORIZED, LOGIN_FAILED );
2800 2 50       39  
2801             $self->_record_cookie_generic( 2 )
2802             or return HTTP::Response->new( HTTP_UNAUTHORIZED, LOGIN_FAILED );
2803 2 50       8  
2804             $self->{dump_headers} & DUMP_TRACE and warn <<'EOD';
2805             Login successful.
2806 2         12 EOD
2807             return HTTP::Response->new (HTTP_OK, undef, undef, "Login successful.\n");
2808             }
2809              
2810             =for html
2811              
2812             =item $st->logout()
2813              
2814             This method deletes all session cookies. It returns an HTTP::Response
2815             object that indicates success.
2816              
2817             =cut
2818              
2819 4     4 1 7 sub logout {
2820 4         9 my ( $self ) = @_;
2821 4         13 foreach my $spacetrack_interface_info (
2822 12 100       27 @{ $self->{_space_track_interface} } ) {
2823             $spacetrack_interface_info
2824             or next;
2825 4 50       12 exists $spacetrack_interface_info->{session_cookie}
2826             and $spacetrack_interface_info->{session_cookie} = undef;
2827 4 50       17 exists $spacetrack_interface_info->{cookie_expires}
2828             and $spacetrack_interface_info->{cookie_expires} = 0;
2829 4         15 }
2830             return HTTP::Response->new(
2831             HTTP_OK, undef, undef, "Logout successful.\n" );
2832             }
2833              
2834             =for html
2835              
2836             =item $resp = $st->mccants( catalog )
2837              
2838             This method retrieves one of several pieces of data that Mike McCants
2839             makes available on his web site. The return is the
2840             L object from the retrieval. Valid
2841             catalog names are:
2842              
2843             classified: Classified TLE file (classfd.zip)
2844             integrated: Integrated TLE file (inttles.zip)
2845             mcnames: Molczan-format magnitude file (mcnames.zip)
2846             quicksat: Quicksat-format magnitude file (qsmag.zip)
2847             rcs: McCants-format RCS file (rcs.zip)
2848             vsnames: Molczan-format magnitudes of visual bodies (vsnames.zip)
2849              
2850             You can specify options as either command-type options (e.g. C<<
2851             mccants( '-file', 'foo.dat', ... ) >>) or as a leading hash reference
2852             (e.g. C<< mccants( { file => 'foo.dat' }, ...) >>). If you specify the
2853             hash reference, option names must be specified in full, without the
2854             leading '-', and the argument list will not be parsed for command-type
2855             options. If you specify command-type options, they may be abbreviated,
2856             as long as the abbreviation is unique. Errors in either sort result in
2857             an exception being thrown.
2858              
2859             The legal options are:
2860              
2861             -file
2862             specifies the name of the cache file. If the data
2863             on line are newer than the modification date of
2864             the cache file, the cache file will be updated.
2865             Otherwise the data will be returned from the file.
2866             Either way the content of the file and the content
2867             of the returned HTTP::Response object end up the
2868             same.
2869              
2870             On success, the content of the returned object is the actual data,
2871             unzipped and with line endings normalized for the current system.
2872              
2873             If this method succeeds, the response will contain headers
2874              
2875             Pragma: spacetrack-type = (see below)
2876             Pragma: spacetrack-source = mccants
2877              
2878             The content of the spacetrack-type pragma depends on the catalog
2879             fetched, as follows:
2880              
2881             classified: 'orbit'
2882             integrated: 'orbit'
2883             mcnames: 'molczan'
2884             quicksat: 'quicksat'
2885             rcs: 'rcs.mccants'
2886             vsnames: 'molczan'
2887              
2888             If the C option was passed, the following additional header will
2889             be provided:
2890              
2891             Pragma: spacetrack-cache-hit = (either true or false)
2892              
2893             This can be accessed by the C method. If this pragma is
2894             true, the C header of the response will contain the
2895             modification time of the file.
2896              
2897             No Space Track username and password are required to use this method.
2898              
2899             =cut
2900              
2901             # Called dynamically
2902             sub _mccants_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
2903 6     6   29 return [
2904             'file=s' => 'Name of cache file',
2905             ];
2906             }
2907              
2908 6     6 1 23 sub mccants {
2909             my ( $self, @args ) = @_;
2910 6         33  
2911             ( my $opt, @args ) = _parse_args( @args );
2912              
2913 6         75 return $self->_get_from_net(
2914             %{ $opt },
2915             catalog => $args[0],
2916 6     6   161 post_process => sub {
2917 6         16 my ( undef, $resp, $info ) = @_; # Invocant unused
2918             my ( $content, @zip_opt );
2919 6 50       37 defined $info->{member}
2920 6 50       41 and push @zip_opt, Name => $info->{member};
2921             IO::Uncompress::Unzip::unzip( \( $resp->content() ),
2922             \$content, @zip_opt )
2923             or return HTTP::Response->new(
2924             HTTP_NOT_FOUND,
2925 6         45121 $IO::Uncompress::Unzip::UnzipError );
2926 6         959 $resp->content( $content );
2927             return $resp;
2928 6         20 },
2929             );
2930             }
2931              
2932             =for html
2933              
2934             =item $resp = $st->names (source)
2935              
2936             This method retrieves the names of the catalogs for the given source,
2937             either C<'celestrak'>, C<'celestrak_supplemental'>, C<'iridium_status'>,
2938             C<'mccants'>, or C<'spacetrack'>, in the content of
2939             the given HTTP::Response object. If the argument is not one of the
2940             supported values, the C<$resp> object represents a 404 (Not found)
2941             error.
2942              
2943             In list context, you also get a reference to a list of two-element
2944             lists; each inner list contains the description and the catalog name, in
2945             that order (suitable for inserting into a Tk Optionmenu). If the
2946             argument is not one of the supported values, the second return will be
2947             C.
2948              
2949             No Space Track username and password are required to use this method,
2950             since all it is doing is returning data kept by this module.
2951              
2952             =cut
2953              
2954 2     2 1 7 sub names {
2955 2         6 my ( $self, $name ) = @_;
2956 2         6 $name = lc $name;
2957             delete $self->{_pragmata};
2958 2 100       15  
2959             $catalogs{$name} or return HTTP::Response->new(
2960 1         5 HTTP_NOT_FOUND, "Data source '$name' not found.");
2961 1 50       5 my $src = $catalogs{$name};
2962             $name eq 'spacetrack'
2963 1         2 and $src = $src->[ $self->getv( 'space_track_version' ) ];
2964 1         32 my @list;
2965 53 50       181 foreach my $cat (sort keys %$src) {
2966             push @list, defined ($src->{$cat}{number}) ?
2967             "$cat ($src->{$cat}{number}): $src->{$cat}{name}\n" :
2968             "$cat: $src->{$cat}{name}\n";
2969 1         16 }
2970 1 50       58 my $resp = HTTP::Response->new (HTTP_OK, undef, undef, join ('', @list));
2971 0         0 return $resp unless wantarray;
2972 0         0 @list = ();
  0         0  
2973             foreach my $cat (sort {$src->{$a}{name} cmp $src->{$b}{name}}
2974 0         0 keys %$src) {
2975             push @list, [$src->{$cat}{name}, $cat];
2976 0         0 }
2977             return ($resp, \@list);
2978             }
2979              
2980             =for html
2981              
2982             =item $resp = $st->retrieve (number_or_range ...)
2983              
2984             This method retrieves the latest element set for each of the given
2985             satellite ID numbers (also known as SATCAT IDs, NORAD IDs, or OIDs) from
2986             The Space Track web site. Non-numeric catalog numbers are ignored, as
2987             are (at a later stage) numbers that do not actually represent a
2988             satellite.
2989              
2990             A Space Track username and password are required to use this method.
2991              
2992             If this method succeeds, the response will contain headers
2993              
2994             Pragma: spacetrack-type = orbit
2995             Pragma: spacetrack-source = spacetrack
2996              
2997             These can be accessed by C<< $st->content_type( $resp ) >> and
2998             C<< $st->content_source( $resp ) >> respectively.
2999              
3000             Number ranges are represented as 'start-end', where both 'start' and
3001             'end' are catalog numbers. If 'start' > 'end', the numbers will be
3002             taken in the reverse order. Non-numeric ranges are ignored.
3003              
3004             You can specify options for the retrieval as either command-type options
3005             (e.g. C<< retrieve ('-last5', ...) >>) or as a leading hash reference
3006             (e.g. C<< retrieve ({last5 => 1}, ...) >>). If you specify the hash
3007             reference, option names must be specified in full, without the leading
3008             '-', and the argument list will not be parsed for command-type options.
3009             If you specify command-type options, they may be abbreviated, as long as
3010             the abbreviation is unique. Errors in either sort result in an exception
3011             being thrown.
3012              
3013             The legal options are:
3014              
3015             -descending
3016             specifies the data be returned in descending order.
3017             -end_epoch date
3018             specifies the end epoch for the desired data.
3019             -format format_name
3020             specifies the format in which the data are retrieved.
3021             -json
3022             specifies the TLE be returned in JSON format.
3023             -last5
3024             specifies the last 5 element sets be retrieved.
3025             Ignored if start_epoch, end_epoch or since_file is
3026             specified.
3027             -start_epoch date
3028             specifies the start epoch for the desired data.
3029             -since_file number
3030             specifies that only data since the given Space Track
3031             file number be retrieved.
3032             -sort type
3033             specifies how to sort the data. Legal types are
3034             'catnum' and 'epoch', with 'catnum' the default.
3035              
3036             The C<-format> option takes any argument supported by the Space Track
3037             interface: C, C<3le>, C, C, C, or C.
3038             Specifying C<-json> is equivalent to specifying C<-format json>, and if
3039             you specify C<-json>, specifying C<-format> with any other value than
3040             C<'json'> results in an exception being thrown. In addition, you can
3041             specify format C<'legacy'> which is equivalent to C<'tle'> if the
3042             C attribute is false, or C<'3le'> (but without the leading
3043             C<'0 '> before the common name) if C is true. The default is
3044             C<'legacy'> unless C<-json> is specified.
3045              
3046             If you specify either start_epoch or end_epoch, you get data with epochs
3047             at least equal to the start epoch, but less than the end epoch (i.e. the
3048             interval is closed at the beginning but open at the end). If you specify
3049             only one of these, you get a one-day interval. Dates are specified
3050             either numerically (as a Perl date) or as numeric year-month-day (and
3051             optional hour, hour:minute, or hour:minute:second), punctuated by any
3052             non-numeric string. It is an error to specify an end_epoch before the
3053             start_epoch.
3054              
3055             If you are passing the options as a hash reference, you must specify
3056             a value for the Boolean options 'descending' and 'last5'. This value is
3057             interpreted in the Perl sense - that is, undef, 0, and '' are false,
3058             and anything else is true.
3059              
3060             In order not to load the Space Track web site too heavily, data are
3061             retrieved in batches of 200. Ranges will be subdivided and handled in
3062             more than one retrieval if necessary. To limit the damage done by a
3063             pernicious range, ranges greater than the max_range setting (which
3064             defaults to 500) will be ignored with a warning to STDERR.
3065              
3066             If you specify C<-json> and more than one retrieval is needed, data from
3067             retrievals after the first B have field C<_file_of_record> added.
3068             This is because of the theoretical possibility that the database may be
3069             updated between the first and last queries, and therefore taking the
3070             maximum C from queries after the first may cause updates to be
3071             skipped. The C<_file_of_record> key will appear only in data having a
3072             C value greater than the largest C in the first retrieval.
3073              
3074             This method implicitly calls the C method if the session cookie
3075             is missing or expired. If C fails, you will get the
3076             HTTP::Response from C.
3077              
3078             If this method succeeds, a 'Pragma: spacetrack-type = orbit' header is
3079             added to the HTTP::Response object returned.
3080              
3081             =cut
3082              
3083             # Called dynamically
3084             sub _retrieve_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
3085 0     0   0 return [
3086             _get_retrieve_options(),
3087             ];
3088             }
3089              
3090 34     34 1 9474 sub retrieve {
3091 34         90 my ( $self, @args ) = @_;
3092             delete $self->{_pragmata};
3093 34         98  
3094 34         89 @args = $self->_parse_retrieve_args( @args );
3095             my $opt = _parse_retrieve_dates( shift @args );
3096 34         90  
3097             my $rest = $self->_convert_retrieve_options_to_rest( $opt );
3098 34 100       95  
3099             @args = $self->_expand_oid_list( @args )
3100             or return HTTP::Response->new( HTTP_PRECONDITION_FAILED, NO_CAT_ID );
3101 33         89  
3102             my $no_execute = $self->getv( 'dump_headers' ) & DUMP_DRY_RUN;
3103              
3104             ## $rest->{orderby} = 'EPOCH desc';
3105              
3106             my $accumulator = _accumulator_for (
3107             $no_execute ?
3108             ( json => { pretty => 1 } ) :
3109 33 100       123 ( $rest->{format}, {
3110             file => 1,
3111             pretty => $self->getv( 'pretty' )
3112             },
3113             )
3114             );
3115 33         89  
3116             while ( @args ) {
3117 35         94  
3118 35         126 my @batch = splice @args, 0, $RETRIEVAL_SIZE;
3119             $rest->{OBJECT_NUMBER} = _stringify_oid_list( {
3120             separator => ',',
3121             range_operator => '--',
3122             }, @batch );
3123 35         123  
3124             my $resp = $self->spacetrack_query_v2(
3125             basicspacedata => 'query',
3126             _sort_rest_arguments( $rest )
3127             );
3128 35 50 66     131  
3129             $resp->is_success()
3130             or $resp->code() == HTTP_I_AM_A_TEAPOT
3131             or return $resp;
3132 35         428  
3133             $accumulator->( $self, $resp );
3134              
3135             }
3136 33 50       70  
3137             ( my $data = $accumulator->( $self ) )
3138             or return HTTP::Response->new ( HTTP_NOT_FOUND, NO_RECORDS );
3139 33 50       76  
3140             ref $data
3141             and $data = $self->_get_json_object()->encode( $data );
3142 33 100       96  
3143             $no_execute
3144             and return HTTP::Response->new(
3145             HTTP_I_AM_A_TEAPOT, undef, undef, $data );
3146 21         67  
3147             my $resp = HTTP::Response->new( HTTP_OK, COPACETIC, undef,
3148             $data );
3149 21         1002  
3150 21         70 $self->_convert_content( $resp );
3151             $self->_add_pragmata( $resp,
3152             'spacetrack-type' => 'orbit',
3153             'spacetrack-source' => 'spacetrack',
3154             'spacetrack-interface' => 2,
3155 21         255 );
3156             return $resp;
3157             }
3158              
3159             {
3160              
3161             my %rest_sort_map = (
3162             catnum => 'OBJECT_NUMBER',
3163             epoch => 'EPOCH',
3164             );
3165              
3166 38     38   74 sub _convert_retrieve_options_to_rest {
3167             my ( $self, $opt ) = @_;
3168 38         95  
3169             my %rest = (
3170             class => 'tle_latest',
3171             );
3172 38 100 66     149  
3173 5         13 if ( $opt->{start_epoch} || $opt->{end_epoch} ) {
  10         23  
3174             $rest{EPOCH} = join '--', map { _rest_date( $opt->{$_} ) }
3175 5         13 qw{ _start_epoch _end_epoch };
3176             $rest{class} = 'tle';
3177             }
3178              
3179             $rest{orderby} = ( $rest_sort_map{$opt->{sort} || 'catnum'} ||
3180 38 100 50     198 'OBJECT_NUMBER' )
3181             . ( $opt->{descending} ? ' desc' : ' asc' );
3182 38 100       98  
3183 1         4 if ( $opt->{since_file} ) {
3184 1         3 $rest{FILE} = ">$opt->{since_file}";
3185             $rest{class} = 'tle';
3186             }
3187 38 50 33     93  
3188 0         0 if ( $opt->{status} && $opt->{status} ne 'onorbit' ) {
3189             $rest{class} = 'tle';
3190             }
3191 38         108  
3192             foreach my $name (
3193             qw{ class format },
3194             qw{ ECCENTRICITY FILE MEAN_MOTION OBJECT_NAME },
3195             ) {
3196 228 100       480 defined $opt->{$name}
3197             and $rest{$name} = $opt->{$name};
3198             }
3199 38 100       107  
3200 34 100       86 if ( 'legacy' eq $rest{format} ) {
3201 9         16 if ( $self->{with_name} ) {
3202             $rest{format} = '3le';
3203 9 50       29 defined $rest{predicates}
3204             or $rest{predicates} = 'OBJECT_NAME,TLE_LINE1,TLE_LINE2';
3205 25         46 } else {
3206             $rest{format} = 'tle';
3207             }
3208             }
3209              
3210 38 100       119 $rest{class} eq 'tle_latest'
    100          
3211             and $rest{ORDINAL} = $opt->{last5} ? '1--5' : 1;
3212 38         97  
3213             return \%rest;
3214             }
3215              
3216             }
3217              
3218             {
3219             my @heading_info = (
3220             [ undef, OBJECT_NUMBER => 'Catalog Number' ],
3221             [ undef, OBJECT_NAME => 'Common Name' ],
3222             [ undef, OBJECT_ID => 'International Designator' ],
3223             [ undef, COUNTRY => 'Country' ],
3224             [ undef, LAUNCH => 'Launch Date' ],
3225             [ undef, SITE => 'Launch Site' ],
3226             [ undef, DECAY => 'Decay Date' ],
3227             [ undef, PERIOD => 'Period' ],
3228             [ undef, APOGEE => 'Apogee' ],
3229             [ undef, PERIGEE => 'Perigee' ],
3230             [ 'comment', COMMENT => 'Comment' ],
3231             [ undef, RCSVALUE => 'RCS' ],
3232             );
3233              
3234 50     50   87 sub _search_heading_order {
3235 50         82 my ( $opt ) = @_;
  550         816  
3236             return ( map { $_->[1] }
3237             _search_heading_relevant( $opt )
3238             );
3239             }
3240              
3241 100     100   178 sub _search_heading_relevant {
3242             my ( $opt ) = @_;
3243 100 100       171 return (
  1200         2557  
3244             grep { ! defined $_->[0] || $opt->{$_->[0]} }
3245             @heading_info
3246             );
3247             }
3248              
3249 50     50   95 sub _search_heading_hash_ref {
3250             my ( $opt ) = @_;
3251 50         89 return {
  550         1197  
3252             map { $_->[1] => $_->[2] }
3253             _search_heading_relevant( $opt )
3254             };
3255             }
3256              
3257             }
3258              
3259 50     50   139 sub _search_rest {
3260 50         141 my ( $self, $pred, $xfrm, @args ) = @_;
3261             delete $self->{_pragmata};
3262 50         139  
3263             ( my $opt, @args ) = $self->_parse_search_args( @args );
3264 50         109  
3265 50         131 my $headings = _search_heading_hash_ref( $opt );
3266             my @heading_order = _search_heading_order( $opt );
3267 50 100       146  
3268             if ( $pred eq 'OBJECT_NUMBER' ) {
3269 12 50       44  
3270             @args = $self->_expand_oid_list( @args )
3271             or return HTTP::Response->new(
3272             HTTP_PRECONDITION_FAILED, NO_CAT_ID );
3273 12         50  
3274             @args = (
3275             _stringify_oid_list( {
3276             separator => ',',
3277             range_operator => '--',
3278             },
3279             @args
3280             )
3281             );
3282              
3283             }
3284 50         132  
3285 50 50 66     144 my $rest_args = $self->_convert_search_options_to_rest( $opt );
3286 50         91 if ( $opt->{tle} || 'legacy' eq $opt->{format} ) {
3287             $rest_args->{format} = 'json'
3288 0         0 } else {
3289             $rest_args->{format} = $opt->{format};
3290             }
3291              
3292             my $class = defined $rest_args->{class} ?
3293 50 50       112 $rest_args->{class} :
3294             DEFAULT_SPACE_TRACK_REST_SEARCH_CLASS;
3295 50         107  
3296             my $accumulator = _accumulator_for( $rest_args->{format} );
3297 50         103  
  50         120  
3298             foreach my $search_for ( map { $xfrm->( $_, $class ) } @args ) {
3299 50         73  
3300             my $rslt;
3301 50         75 {
  50         125  
3302 50         73 local $self->{pretty} = 0;
  50         199  
3303             $rslt = $self->__search_rest_raw( %{ $rest_args },
3304             $pred, $search_for );
3305             }
3306              
3307 50 100       150 $rslt->is_success()
3308             or return $rslt;
3309 19         141  
3310             $accumulator->( $self, $rslt );
3311              
3312             }
3313 19         56  
3314             my ( $content, $data ) = $accumulator->( $self );
3315 19 100       52  
3316             if ( $opt->{tle} ) {
3317 14 50       38 defined $opt->{format}
3318 14 50       36 or $opt->{format} = 'tle';
3319             ARRAY_REF eq ref $data
3320 14         34 or Carp::croak "Format $rest_args->{format} does not support TLE retrieval";
3321             my $ropt = _remove_search_options( $opt );
3322              
3323 14         25 my $rslt = $self->retrieve( $ropt,
  48         108  
  14         30  
3324             map { $_->{OBJECT_NUMBER} } @{ $data } );
3325 14         358  
3326             return $rslt;
3327              
3328             } else {
3329 5 50       18  
3330 5         8 if ( 'legacy' eq $opt->{format} ) {
3331 5         10 $content = '';
3332             foreach my $datum (
3333 5         11 $headings,
3334             @{ $data }
3335             ) {
3336 12 100       22 $content .= join( "\t",
  132         292  
3337             map { defined $datum->{$_} ? $datum->{$_} : '' }
3338             @heading_order
3339             ) . "\n";
3340             }
3341             }
3342 5         20  
3343 5         241 my $rslt = HTTP::Response->new( HTTP_OK, undef, undef, $content );
3344             $self->_add_pragmata( $rslt,
3345             'spacetrack-type' => 'search',
3346             'spacetrack-source' => 'spacetrack',
3347             'spacetrack-interface' => 2,
3348             );
3349 5 50 33     17 wantarray
3350             and $data
3351 5         115 and return ( $rslt, $data );
3352             return $rslt;
3353             }
3354              
3355             # Note - if we're doing the tab output, the names and order are:
3356             # Catalog Number: OBJECT_NUMBER
3357             # Common Name: OBJECT_NAME
3358             # International Designator: OBJECT_ID
3359             # Country: COUNTRY
3360             # Launch Date: LAUNCH (yyyy-mm-dd)
3361             # Launch Site: SITE
3362             # Decay Date: DECAY
3363             # Period: PERIOD
3364             # Incl.: INCLINATION
3365             # Apogee: APOGEE
3366             # Perigee: PERIGEE
3367             # RCS: RCSVALUE
3368              
3369             }
3370              
3371 50     50   173 sub __search_rest_raw {
3372 50         94 my ( $self, %args ) = @_;
3373             delete $self->{_pragmata};
3374             # https://beta.space-track.org/basicspacedata/query/class/satcat/CURRENT/Y/OBJECT_NUMBER/25544/predicates/all/limit/10,0/metadata/true
3375 50 50       104  
3376             %args
3377             or return HTTP::Response->new( HTTP_PRECONDITION_FAILED, NO_CAT_ID );
3378              
3379 50 50       122 exists $args{class}
3380             or $args{class} = DEFAULT_SPACE_TRACK_REST_SEARCH_CLASS;
3381             $args{class} ne 'satcat'
3382 50 50 33     204 or exists $args{CURRENT}
3383             or $args{CURRENT} = 'Y';
3384 50 50       108 exists $args{format}
3385             or $args{format} = 'json';
3386 50 50       117 exists $args{predicates}
3387             or $args{predicates} = 'all';
3388 50 50       109 exists $args{orderby}
3389             or $args{orderby} = 'OBJECT_NUMBER asc';
3390             # exists $args{limit}
3391             # or $args{limit} = 1000;
3392 50         129  
3393             my $resp = $self->spacetrack_query_v2(
3394             basicspacedata => 'query',
3395             _sort_rest_arguments( \%args ),
3396             );
3397             # $resp->content( $content );
3398 50         218 # $self->_convert_content( $resp );
3399             $self->_add_pragmata( $resp,
3400             'spacetrack-type' => 'orbit',
3401             'spacetrack-source' => 'spacetrack',
3402             'spacetrack-interface' => 2,
3403 50         178 );
3404             return $resp;
3405             }
3406              
3407             =for html
3408              
3409             =item $resp = $st->search_date (date ...)
3410              
3411             This method searches the Space Track database for objects launched on
3412             the given date. The date is specified as year-month-day, with any
3413             non-digit being legal as the separator. You can omit -day or specify it
3414             as 0 to get all launches for the given month. You can omit -month (or
3415             specify it as 0) as well to get all launches for the given year.
3416              
3417             A Space Track username and password are required to use this method.
3418              
3419             You can specify options for the search as either command-type options
3420             (e.g. C<< $st->search_date (-status => 'onorbit', ...) >>) or as a
3421             leading hash reference (e.g.
3422             C<< $st->search_date ({status => onorbit}, ...) >>). If you specify the
3423             hash reference, option names must be specified in full, without the
3424             leading '-', and the argument list will not be parsed for command-type
3425             options. Options that take multiple values (i.e. 'exclude') must have
3426             their values specified as a hash reference, even if you only specify one
3427             value - or none at all.
3428              
3429             If you specify command-type options, they may be abbreviated, as long as
3430             the abbreviation is unique. Errors in either sort of specification
3431             result in an exception being thrown.
3432              
3433             In addition to the options available for C, the following
3434             options may be specified:
3435              
3436             -exclude
3437             specifies the types of bodies to exclude. The
3438             value is one or more of 'payload', 'debris', 'rocket',
3439             'unknown', 'tba', or 'other'. If you specify this as a
3440             command-line option you may either specify this more
3441             than once or specify the values comma-separated.
3442             -include
3443             specifies the types of bodies to include. The possible
3444             values are the same as for -exclude. If you specify a
3445             given body as both included and excluded it is included.
3446             -rcs
3447             used to specify that the radar cross-section returned
3448             by the search was to be appended to the name, in the form
3449             --rcs radar_cross_section. Beginning with version 0.086_02
3450             it does nothing, since as of August 18 2014 Space Track
3451             no longer provides quantitative RCS data.
3452             -status
3453             specifies the desired status of the returned body (or
3454             bodies). Must be 'onorbit', 'decayed', or 'all'. The
3455             default is 'onorbit'. Specifying a value other than the
3456             default will cause the -last5 option to be ignored.
3457             Note that this option represents status at the time the
3458             search was done; you can not combine it with the
3459             retrieve() date options to find bodies onorbit as of a
3460             given date in the past.
3461             -tle
3462             specifies that you want TLE data retrieved for all
3463             bodies that satisfy the search criteria. This is
3464             true by default, but may be negated by specifying
3465             -notle ( or { tle => 0 } ). If negated, the content
3466             of the response object is the results of the search,
3467             one line per body found, with the fields tab-
3468             delimited.
3469             -comment
3470             specifies that you want the comment field. This will
3471             not appear in the TLE data, but in the satcat data
3472             returned in array context, or if C<-notle> is
3473             specified. The default is C<-nocomment> for backward
3474             compatibility.
3475              
3476             The C<-rcs> option does not work with all values of C<-format>. An
3477             exception will be thrown unless C<-format> is C<'tle'>, C<'3le'>,
3478             C<'legacy'>, or C<'json'>.
3479              
3480             Examples:
3481              
3482             search_date (-status => 'onorbit', -exclude =>
3483             'debris,rocket', -last5 '2005-12-25');
3484             search_date (-exclude => 'debris',
3485             -exclude => 'rocket', '2005/12/25');
3486             search_date ({exclude => ['debris', 'rocket']},
3487             '2005-12-25');
3488             search_date ({exclude => 'debris,rocket'}, # INVALID!
3489             '2005-12-25');
3490             search_date ( '-notle', '2005-12-25' );
3491              
3492             The C<-exclude> option is implemented in terms of the C
3493             predicate, which is one of the values C<'PAYLOAD'>, C<'ROCKET BODY'>,
3494             C<'DEBRIS'>, C<'UNKNOWN'>, C<'TBA'>, or C<'OTHER'>. It works by
3495             selecting all values other than the ones specifically excluded. The
3496             C<'TBA'> status was introduced October 1 2013, supposedly replacing
3497             C<'UNKNOWN'>, but I have retained both.
3498              
3499             This method implicitly calls the C method if the session cookie
3500             is missing or expired. If C fails, you will get the
3501             HTTP::Response from C.
3502              
3503             What you get on success depends on the value specified for the -tle
3504             option.
3505              
3506             Unless you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3507             method returns an HTTP::Response object whose content is the relevant
3508             element sets. It will also have the following headers set:
3509              
3510             Pragma: spacetrack-type = orbit
3511             Pragma: spacetrack-source = spacetrack
3512              
3513             These can be accessed by C<< $st->content_type( $resp ) >> and
3514             C<< $st->content_source( $resp ) >> respectively.
3515              
3516             If you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3517             method returns an HTTP::Response object whose content is in the format
3518             specified by the C<-format> retrieval option (q.v.). If the format is
3519             C<'legacy'> (the default if C<-json> is not specified) the content
3520             mimics what was returned under the version 1 interface; that is, it is
3521             the results of the relevant search, one line per object found. Within a
3522             line the fields are tab-delimited, and occur in the same order as the
3523             underlying web page. The first line of the content is the header lines
3524             from the underlying web page.
3525              
3526             The returned object will also have the following headers set if
3527             C<-notle> is specified:
3528              
3529             Pragma: spacetrack-type = search
3530             Pragma: spacetrack-source = spacetrack
3531              
3532             If you call this method in list context, the first element of the
3533             returned object is the aforementioned HTTP::Response object, and the
3534             second is a reference to an array containing the search results. The
3535             first element is a reference to an array containing the header lines
3536             from the web page. Subsequent elements are references to arrays
3537             containing the actual search results.
3538              
3539             =cut
3540              
3541             *_search_date_opts = \&_get_search_options;
3542              
3543 12     12 1 7496 sub search_date { ## no critic (RequireArgUnpacking)
3544 12         39 splice @_, 1, 0, LAUNCH => \&_format_launch_date_rest;
3545             goto &_search_rest;
3546             }
3547              
3548              
3549             =for html
3550              
3551             =item $resp = $st->search_decay (decay ...)
3552              
3553             This method searches the Space Track database for objects decayed on
3554             the given date. The date is specified as year-month-day, with any
3555             non-digit being legal as the separator. You can omit -day or specify it
3556             as 0 to get all decays for the given month. You can omit -month (or
3557             specify it as 0) as well to get all decays for the given year.
3558              
3559             The options are the same as for C.
3560              
3561             A Space Track username and password are required to use this method.
3562              
3563             What you get on success depends on the value specified for the -tle
3564             option.
3565              
3566             Unless you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3567             method returns an HTTP::Response object whose content is the relevant
3568             element sets. It will also have the following headers set:
3569              
3570             Pragma: spacetrack-type = orbit
3571             Pragma: spacetrack-source = spacetrack
3572              
3573             These can be accessed by C<< $st->content_type( $resp ) >> and
3574             C<< $st->content_source( $resp ) >> respectively.
3575              
3576             If you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3577             method returns an HTTP::Response object whose content is the results of
3578             the relevant search, one line per object found. Within a line the fields
3579             are tab-delimited, and occur in the same order as the underlying web
3580             page. The first line of the content is the header lines from the
3581             underlying web page. It will also have the following headers set:
3582              
3583             Pragma: spacetrack-type = search
3584             Pragma: spacetrack-source = spacetrack
3585              
3586             If you call this method in list context, the first element of the
3587             returned object is the aforementioned HTTP::Response object, and the
3588             second is a reference to an array containing the search results. The
3589             first element is a reference to an array containing the header lines
3590             from the web page. Subsequent elements are references to arrays
3591             containing the actual search results.
3592              
3593             =cut
3594              
3595             *_search_decay_opts = \&_get_search_options;
3596              
3597 2     2 1 11 sub search_decay { ## no critic (RequireArgUnpacking)
3598 2         7 splice @_, 1, 0, DECAY => \&_format_launch_date_rest;
3599             goto &_search_rest;
3600             }
3601              
3602              
3603             =for html
3604              
3605             =item $resp = $st->search_id (id ...)
3606              
3607             This method searches the Space Track database for objects having the
3608             given international IDs. The international ID is the last two digits of
3609             the launch year (in the range 1957 through 2056), the three-digit
3610             sequence number of the launch within the year (with leading zeroes as
3611             needed), and the piece (A through ZZZ, with A typically being the
3612             payload). You can omit the piece and get all pieces of that launch, or
3613             omit both the piece and the launch number and get all launches for the
3614             year. There is no mechanism to restrict the search to a given on-orbit
3615             status, or to filter out debris or rocket bodies.
3616              
3617             The options are the same as for C.
3618              
3619             A Space Track username and password are required to use this method.
3620              
3621             This method implicitly calls the C method if the session cookie
3622             is missing or expired. If C fails, you will get the
3623             HTTP::Response from C.
3624              
3625             What you get on success depends on the value specified for the C<-tle>
3626             option.
3627              
3628             Unless you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3629             method returns an HTTP::Response object whose content is the relevant
3630             element sets. It will also have the following headers set:
3631              
3632             Pragma: spacetrack-type = orbit
3633             Pragma: spacetrack-source = spacetrack
3634              
3635             These can be accessed by C<< $st->content_type( $resp ) >> and
3636             C<< $st->content_source( $resp ) >> respectively.
3637              
3638             If you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3639             method returns an HTTP::Response object whose content is the results of
3640             the relevant search, one line per object found. Within a line the fields
3641             are tab-delimited, and occur in the same order as the underlying web
3642             page. The first line of the content is the header lines from the
3643             underlying web page. It will also have the following headers set:
3644              
3645             Pragma: spacetrack-type = search
3646             Pragma: spacetrack-source = spacetrack
3647              
3648             If you call this method in list context, the first element of the
3649             returned object is the aforementioned HTTP::Response object, and the
3650             second is a reference to an array containing the search results. The
3651             first element is a reference to an array containing the header lines
3652             from the web page. Subsequent elements are references to arrays
3653             containing the actual search results.
3654            
3655             =cut
3656              
3657             *_search_id_opts = \&_get_search_options;
3658              
3659 14     14 1 8459 sub search_id { ## no critic (RequireArgUnpacking)
3660 14         41 splice @_, 1, 0, OBJECT_ID => \&_format_international_id_rest;
3661             goto &_search_rest;
3662             }
3663              
3664              
3665             =for html
3666              
3667             =item $resp = $st->search_name (name ...)
3668              
3669             This method searches the Space Track database for the named objects.
3670             Matches are case-insensitive and all matches are returned.
3671              
3672             The options are the same as for C. The C<-status> option
3673             is known to work, but I am not sure about the efficacy the C<-exclude>
3674             option.
3675              
3676             A Space Track username and password are required to use this method.
3677              
3678             This method implicitly calls the C method if the session cookie
3679             is missing or expired. If C fails, you will get the
3680             HTTP::Response from C.
3681              
3682             What you get on success depends on the value specified for the -tle
3683             option.
3684              
3685             Unless you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3686             method returns an HTTP::Response object whose content is the relevant
3687             element sets. It will also have the following headers set:
3688              
3689             Pragma: spacetrack-type = orbit
3690             Pragma: spacetrack-source = spacetrack
3691              
3692             These can be accessed by C<< $st->content_type( $resp ) >> and
3693             C<< $st->content_source( $resp ) >> respectively.
3694              
3695             If you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3696             method returns an HTTP::Response object whose content is the results of
3697             the relevant search, one line per object found. Within a line the fields
3698             are tab-delimited, and occur in the same order as the underlying web
3699             page. The first line of the content is the header lines from the
3700             underlying web page. It will also have the following headers set:
3701              
3702             Pragma: spacetrack-type = search
3703             Pragma: spacetrack-source = spacetrack
3704              
3705             If you call this method in list context, the first element of the
3706             returned object is the aforementioned HTTP::Response object, and the
3707             second is a reference to an array containing the search results. The
3708             first element is a reference to an array containing the header lines
3709             from the web page. Subsequent elements are references to arrays
3710             containing the actual search results.
3711              
3712             =cut
3713              
3714             *_search_name_opts = \&_get_search_options;
3715              
3716 10     10 1 34 sub search_name { ## no critic (RequireArgUnpacking)
  10     10   8366  
3717 10         37 splice @_, 1, 0, OBJECT_NAME => sub { return "~~$_[0]" };
3718             goto &_search_rest;
3719             }
3720              
3721              
3722             =for html
3723              
3724             =item $resp = $st->search_oid (name ...)
3725              
3726             This method searches the Space Track database for the given Space Track
3727             IDs (also known as OIDs, hence the method name).
3728              
3729             B that in effect this is just a stupid, inefficient version of
3730             C, which does not understand ranges. Unless you
3731             assert C<-notle> or call it in list context to get the
3732             search data, you should simply call
3733             C instead.
3734              
3735             In addition to the options available for C, the following
3736             option may be specified:
3737              
3738             rcs
3739             Used to specify that the radar cross-section returned by
3740             the search is to be appended to the name, in the form
3741             --rcs radar_cross_section. Starting with version 0.086_02
3742             it does nothing, since as of August 18 2014 Space Track
3743             no longer provides quantitative RCS data.
3744             tle
3745             specifies that you want TLE data retrieved for all
3746             bodies that satisfy the search criteria. This is
3747             true by default, but may be negated by specifying
3748             -notle ( or { tle => 0 } ). If negated, the content
3749             of the response object is the results of the search,
3750             one line per body found, with the fields tab-
3751             delimited.
3752              
3753             If you specify C<-notle>, all other options are ignored, except for
3754             C<-descending>.
3755              
3756             A Space Track username and password are required to use this method.
3757              
3758             This method implicitly calls the C method if the session cookie
3759             is missing or expired. If C fails, you will get the
3760             HTTP::Response from C.
3761              
3762             What you get on success depends on the value specified for the -tle
3763             option.
3764              
3765             Unless you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3766             method returns an HTTP::Response object whose content is the relevant
3767             element sets. It will also have the following headers set:
3768              
3769             Pragma: spacetrack-type = orbit
3770             Pragma: spacetrack-source = spacetrack
3771              
3772             If the C method returns C<'box_score'>, you can expect
3773             a content-source value of C<'spacetrack'>.
3774              
3775             If you explicitly specified C<-notle> (or C<< { tle => 0 } >>), this
3776             method returns an HTTP::Response object whose content is the results of
3777             the relevant search, one line per object found. Within a line the fields
3778             are tab-delimited, and occur in the same order as the underlying web
3779             page. The first line of the content is the header lines from the
3780             underlying web page. It will also have the following headers set:
3781              
3782             Pragma: spacetrack-type = search
3783             Pragma: spacetrack-source = spacetrack
3784              
3785             If you call this method in list context, the first element of the
3786             returned object is the aforementioned HTTP::Response object, and the
3787             second is a reference to an array containing the search results. The
3788             first element is a reference to an array containing the header lines
3789             from the web page. Subsequent elements are references to arrays
3790             containing the actual search results.
3791              
3792             =cut
3793              
3794             *_search_oid_opts = \&_get_search_options;
3795              
3796             sub search_oid { ## no critic (RequireArgUnpacking)
3797 12     12 1 37 ## my ( $self, @args ) = @_;
  12     12   1373  
3798 12         41 splice @_, 1, 0, OBJECT_NUMBER => sub { return $_[0] };
3799             goto &_search_rest;
3800             }
3801              
3802 1     1   5 sub _check_range {
3803 1 50       5 my ( $self, $lo, $hi ) = @_;
3804 1 50       4 ($lo, $hi) = ($hi, $lo) if $lo > $hi;
3805 1 50       4 $lo or $lo = 1; # 0 is illegal
3806 0         0 $hi - $lo >= $self->{max_range} and do {
3807             Carp::carp <<"EOD";
3808             Warning - Range $lo-$hi ignored because it is greater than the
3809             currently-set maximum of $self->{max_range}.
3810 0         0 EOD
3811             return;
3812 1         7 };
3813             return ( $lo, $hi );
3814             }
3815              
3816             =for html
3817              
3818             =item $st->set ( ... )
3819              
3820             This is the mutator method for the object. It can be called explicitly,
3821             but other methods as noted may call it implicitly also. It croaks if
3822             you give it an odd number of arguments, or if given an attribute that
3823             either does not exist or cannot be set.
3824              
3825             For the convenience of the shell method we return a HTTP::Response
3826             object with a success status if all goes well. But if we encounter an
3827             error we croak.
3828              
3829             See L for the names and functions of the attributes.
3830              
3831             =cut
3832              
3833             # Called dynamically
3834             sub _readline_complete_command_set { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
3835 0     0   0 # my ( $self, $text, $line, $start, $cmd_line ) = @_;
3836 0 0       0 my ( undef, undef, undef, undef, $cmd_line ) = @_;
  0         0  
3837             @{ $cmd_line } % 2
3838 0         0 or return; # Can't complete arguments
3839             goto &_readline_complete_command_get;
3840             }
3841              
3842 56     56 1 20627 sub set { ## no critic (ProhibitAmbiguousNames)
3843 56         211 my ($self, @args) = @_;
3844 56         182 delete $self->{_pragmata};
3845 62         130 while ( @args > 1 ) {
3846             my $name = shift @args;
3847             Carp::croak "Attribute $name may not be set. Legal attributes are ",
3848 62 50       214 join (', ', sort keys %mutator), ".\n"
3849 62         106 unless $mutator{$name};
3850 62         234 my $value = $args[0];
3851 62         179 $mutator{$name}->( $self, $name, $value, \@args );
3852             shift @args;
3853             }
3854 56 50       171 @args
3855 56         234 and Carp::croak __PACKAGE__, "->set() specifies no value for @args";
3856 56         3018 my $resp = HTTP::Response->new( HTTP_OK, COPACETIC, undef, COPACETIC );
3857             $self->_add_pragmata( $resp,
3858             'spacetrack-type' => 'set',
3859 56         188 );
3860 56         232 $self->__dump_response( $resp );
3861             return $resp;
3862             }
3863              
3864              
3865             =for html
3866              
3867             =item $st->shell ()
3868              
3869             This method implements a simple shell. Any public method name except
3870             'new' or 'shell' is a command, and its arguments if any are parameters.
3871             We use L to parse the line, and blank
3872             lines or lines beginning with a hash mark ('#') are ignored. Input is
3873             via Term::ReadLine if that is available. If not, we do the best we can.
3874              
3875             We also recognize 'bye' and 'exit' as commands, which terminate the
3876             method. In addition, 'show' is recognized as a synonym for 'get', and
3877             'get' (or 'show') without arguments is special-cased to list all
3878             attribute names and their values. Attributes listed without a value have
3879             the undefined value.
3880              
3881             There are also a couple meta-commands, that in effect wrap other
3882             commands. These are specified before the command, and can (depending on
3883             the meta-command) have effect either right before the command is
3884             executed, right after it is executed, or both. If more than one
3885             meta-command is specified, the before-actions take place in the order
3886             specified, and the after-actions in the reverse of the order specified.
3887              
3888             The 'time' meta-command times the command, and writes the timing to
3889             standard error before any output from the command is written.
3890              
3891             The 'olist' meta-command turns TLE data into an observing list. This
3892             only affects results with C of C<'orbit'>. If the
3893             content is affected, the C will be changed to
3894             C<'observing-list'>. This meta-command is experimental, and may change
3895             function or be retracted. It is unsupported when applied to commands
3896             that do not return TLE data.
3897              
3898             For commands that produce output, we allow a sort of pseudo-redirection
3899             of the output to a file, using the syntax ">filename" or ">>filename".
3900             If the ">" is by itself the next argument is the filename. In addition,
3901             we do pseudo-tilde expansion by replacing a leading tilde with the
3902             contents of environment variable HOME. Redirection can occur anywhere
3903             on the line. For example,
3904              
3905             SpaceTrack> catalog special >special.txt
3906              
3907             sends the "Special Interest Satellites" to file special.txt. Line
3908             terminations in the file should be appropriate to your OS.
3909              
3910             Redirections will not be recognized as such if quoted or escaped. That
3911             is, both C<< >foo >> and C<< >'foo' >> (without the double quotes) are
3912             redirections to file F, but both "C<< '>foo' >>" and C<< \>foo >>
3913             are arguments whose value is C<< >foo >>.
3914              
3915             This method can also be called as a subroutine - i.e. as
3916              
3917             Astro::SpaceTrack::shell (...)
3918              
3919             Whether called as a method or as a subroutine, each argument passed
3920             (if any) is parsed as though it were a valid command. After all such
3921             have been executed, control passes to the user. Unless, of course,
3922             one of the arguments was 'exit'.
3923              
3924             Unlike most of the other methods, this one returns nothing.
3925              
3926             =cut
3927              
3928             my $rdln;
3929             my %known_meta = (
3930             olist => {
3931             after => sub {
3932             my ( $self, undef, $rslt ) = @_; # Context unused
3933              
3934             ARRAY_REF eq ref $rslt
3935             and return;
3936             $rslt->is_success()
3937             and 'orbit' eq ( $self->content_type( $rslt ) || '' )
3938             or return;
3939              
3940             my $content = $rslt->content();
3941             my @lines;
3942              
3943             if ( $content =~ m/ \A [[]? [{] /smx ) {
3944             my $data = $self->_get_json_object()->decode( $content );
3945             foreach my $datum ( @{ $data } ) {
3946             push @lines, [
3947             sprintf '%05d', $datum->{OBJECT_NUMBER},
3948             defined $datum->{OBJECT_NAME} ? $datum->{OBJECT_NAME} :
3949             (),
3950             ];
3951             }
3952             } else {
3953              
3954             my @name;
3955              
3956             foreach ( split qr{ \n }smx, $content ) {
3957             if ( m/ \A 1 \s+ ( \d+ ) /smx ) {
3958             splice @name, 1;
3959             push @lines, [ sprintf( '%05d', $1 ), @name ];
3960             @name = ();
3961             } elsif ( m/ \A 2 \s+ \d+ /smx || m/ \A \s* [#] /smx ) {
3962             } else {
3963             push @name, $_;
3964             }
3965             }
3966             }
3967              
3968             foreach ( $rslt->header( pragma => undef ) ) {
3969             my ( $name, $value ) = split qr{ \s* = \s* }smx, $_, 2;
3970             'spacetrack-type' eq $name
3971             and $value = 'observing_list';
3972             $self->_add_pragmata( $rslt, $name, $value );
3973             }
3974              
3975             $rslt->content( join '', map { "$_\n" } @lines );
3976              
3977             {
3978             local $" = ''; # Make "@a" equivalent to join '', @a.
3979             $rslt->content( join '',
3980             map { "@$_\n" }
3981             sort { $a->[0] <=> $b->[0] }
3982             @lines
3983             );
3984             }
3985             $self->__dump_response( $rslt );
3986             return;
3987             },
3988             },
3989             time => {
3990             before => sub {
3991             my ( undef, $context ) = @_; # Invocant unused
3992             eval {
3993             require Time::HiRes;
3994             $context->{start_time} = Time::HiRes::time();
3995             1;
3996             } or warn 'No timings available. Can not load Time::HiRes';
3997             return;
3998             },
3999             after => sub {
4000             my ( undef, $context ) = @_; # Invocant unused
4001             $context->{start_time}
4002             and warn sprintf "Elapsed time: %.2f seconds\n",
4003             Time::HiRes::time() - $context->{start_time};
4004             return;
4005             }
4006             },
4007             );
4008              
4009             my $readline_word_break_re;
4010              
4011             {
4012             my %alias = (
4013             show => 'get',
4014             );
4015              
4016 1     1   3 sub _verb_alias {
4017 1   33     6 my ( $verb ) = @_;
4018             return $alias{$verb} || $verb;
4019             }
4020             }
4021              
4022 1     1 1 4 sub shell {
4023 1 50       5 my @args = @_;
4024             my $self = _instance( $args[0], __PACKAGE__ ) ? shift @args :
4025             Astro::SpaceTrack->new (addendum => <<'EOD');
4026              
4027             'help' gets you a list of valid commands.
4028             EOD
4029 1         17  
4030 1         3 my $stdout = \*STDOUT;
4031             my $read;
4032 1 50 33     6  
4033             unshift @args, 'banner' if $self->{banner} && !$self->{filter};
4034             # Perl::Critic wants IO::Interactive::is_interactive() here. But
4035             # that assumes we're using the *ARGV input mechanism, which we're
4036             # not (command arguments are SpaceTrack commands.) Also, we would
4037             # like to be prompted even if output is to a pipe, but the
4038             # recommended module calls that non-interactive even if input is
4039 1         8 # from a terminal. So:
4040 1         2 my $interactive = -t STDIN;
4041 4         7 while (1) {
4042 4 50       10 my $buffer;
4043 4         7 if (@args) {
4044             $buffer = shift @args;
4045             } else {
4046             $read ||= $interactive ? ( eval {
4047 0     0   0 $self->_get_readline( $stdout )
  0         0  
  0         0  
4048 0 0 0 0   0 } || sub { print { $stdout } $self->getv( 'prompt' ); return } ) :
  0   0     0  
4049 0         0 sub { return };
4050             $buffer = $read->();
4051 4 50       10 }
4052             last unless defined $buffer;
4053 4         12  
4054 4         12 $buffer =~ s/ \A \s+ //smx;
4055 4 100       10 $buffer =~ s/ \s+ \z //smx;
4056 3 100       10 next unless $buffer;
4057             next if $buffer =~ m/ \A [#] /smx;
4058              
4059             # Break the buffer up into tokens, but leave quotes and escapes
4060             # in place, so that (e.g.) '\>foo' is seen as an argument, not a
4061             # redirection.
4062 2         14  
4063             my @cmdarg = Text::ParseWords::parse_line( '\s+', 1, $buffer );
4064              
4065             # Pull off any redirections.
4066 2         326  
4067             my $redir = '';
4068 2         6 @cmdarg = map {
  0         0  
  0         0  
4069 4 50       18 m/ \A > /smx ? do {$redir = $_; ()} :
  0 50       0  
  0         0  
4070             $redir =~ m/ \A >+ \z /smx ? do {$redir .= $_; ()} :
4071             $_
4072             } @cmdarg;
4073              
4074             # Rerun everything through parse_line again, but with the $keep
4075             # argument false. This should not create any more tokens, it
4076             # should just un-quote and un-escape the data.
4077 2         5  
  4         173  
4078 2 50       123 @cmdarg = map { Text::ParseWords::parse_line( qr{ \s+ }, 0, $_ ) } @cmdarg;
4079             $redir ne ''
4080             and ( $redir ) = Text::ParseWords::parse_line ( qr{ \s+ }, 0, $redir );
4081 2         5  
4082 2         5 $redir =~ s/ \A (>+) ~ /$1$ENV{HOME}/smx;
4083             my $verb = lc shift @cmdarg;
4084 2         8  
4085             my %meta_command = (
4086             before => [],
4087             after => [],
4088             );
4089 2         7  
4090 0         0 while ( my $def = $known_meta{$verb} ) {
4091 0         0 my %context;
4092 0 0       0 foreach my $key ( qw{ before after } ) {
4093             $def->{$key}
4094 0         0 or next;
4095 0     0   0 push @{ $meta_command{$key} }, sub {
4096 0         0 return $def->{$key}->( $self, \%context, @_ );
4097             };
4098 0         0 }
4099             $verb = shift @cmdarg;
4100             }
4101 2 100 66     12  
4102 1         3 last if $verb eq 'exit' || $verb eq 'bye';
4103 1 50       4 $verb = _verb_alias( $verb );
4104 0 0 0     0 $verb eq 'source' and do {
4105 0         0 eval {
4106 0         0 splice @args, 0, 0, $self->_source (shift @cmdarg);
4107             1;
4108 0         0 } or warn ( $@ || 'An unknown error occurred' ); ## no critic (RequireCarping)
4109             next;
4110             };
4111              
4112             $verb ne 'new'
4113             and $verb ne 'shell'
4114 1 50 33     14 and $verb !~ m/ \A _ [^_] /smx
      33        
4115 0         0 or do {
4116             warn <<"EOD";
4117             Verb '$verb' undefined. Use 'help' to get help.
4118 0         0 EOD
4119             next;
4120 1         3 };
4121 1 50       3 my $out;
4122 0 0       0 if ( $redir ) {
4123 0         0 $out = IO::File->new( $redir ) or do {
4124             warn <<"EOD";
4125             Error - Failed to open $redir
4126             $^E
4127 0         0 EOD
4128             next;
4129             };
4130 1         2 } else {
4131             $out = $stdout;
4132 1         3 }
4133             my $rslt;
4134 1         2  
  1         4  
4135 0         0 foreach my $pseudo ( @{ $meta_command{before} } ) {
4136             $pseudo->();
4137             }
4138 1 50 33     5  
4139 0         0 if ($verb eq 'get' && @cmdarg == 0) {
4140 0         0 $rslt = [];
4141 0         0 foreach my $name ($self->attribute_names ()) {
4142 0 0       0 my $val = $self->getv( $name );
4143             push @$rslt, defined $val ? "$name $val" : $name;
4144             }
4145             } else {
4146 1         3 eval {
4147 1         4 $rslt = $self->$verb (@cmdarg);
4148 1 50       2 1;
4149 0         0 } or do {
4150 0         0 warn $@; ## no critic (RequireCarping)
4151             next;
4152             };
4153             }
4154 1         2  
  1         4  
4155 0         0 foreach my $pseudo ( reverse @{ $meta_command{after} } ) {
4156             $pseudo->( $rslt );
4157             }
4158 1 50       10  
    50          
    50          
4159 0         0 if ( ARRAY_REF eq ref $rslt ) {
  0         0  
  0         0  
4160             foreach (@$rslt) {print { $out } "$_\n"}
4161 0         0 } elsif ( ! ref $rslt ) {
  0         0  
4162             print { $out } "$rslt\n";
4163             } elsif ($rslt->is_success) {
4164             $self->content_type()
4165 1 50 33     10 or not $self->{filter}
4166 1         8 or next;
4167 1         20 my $content = $rslt->content;
4168 1         3 chomp $content;
  1         57  
4169             print { $out } "$content\n";
4170 0         0 } else {
4171 0         0 my $status = $rslt->status_line;
4172 0         0 chomp $status;
4173             warn $status, "\n";
4174 0 0       0 $rslt->code() == HTTP_I_AM_A_TEAPOT
  0         0  
4175             and print { $out } $rslt->content(), "\n";
4176             }
4177             }
4178             $interactive
4179 1 50 33     54 and not $self->{filter}
  0         0  
4180 1         6 and print { $stdout } "\n";
4181             return;
4182             }
4183              
4184 1     1   11 sub _get_readline { ## no critic (Subroutines::RequireArgUnpacking)
4185 1         578 my ( $self ) = @_;
4186 1   33     2643 require Term::ReadLine;
4187             $rdln ||= Term::ReadLine->new (
4188 1 50 0     13819 'SpaceTrack orbital element access');
4189             @_ > 1
4190 1 50       7 and $_[1] = ( $rdln->OUT || \*STDOUT ); # $stdout
4191 0         0 if ( 'Term::ReadLine::Perl' eq $rdln->ReadLine() ) {
4192             require File::Glob;
4193 0   0     0  
4194             $readline_word_break_re ||= qr<
4195             [\Q$readline::rl_completer_word_break_characters\E]+
4196             >smx;
4197 10     10   104  
  10         23  
  10         129978  
4198             no warnings qw{ once };
4199 0     0   0 $readline::rl_completion_function = sub {
4200 0         0 my ( $text, $line, $start ) = @_;
4201             return $self->__readline_completer(
4202 0         0 $text, $line, $start );
4203             };
4204 1     0   37 }
  0         0  
4205             return sub { $rdln->readline ( $self->getv( 'prompt' ) ) };
4206             }
4207              
4208              
4209             =for html
4210              
4211             =item $st->source ($filename);
4212              
4213             This convenience method reads the given file, and passes the individual
4214             lines to the shell method. It croaks if the file is not provided or
4215             cannot be read.
4216              
4217             =cut
4218              
4219             # We really just delegate to _source, which unpacks.
4220 0 0   0 1 0 sub source {
4221             my $self = _instance( $_[0], __PACKAGE__ ) ? shift :
4222 0         0 Astro::SpaceTrack->new ();
4223 0         0 $self->shell ($self->_source (@_), 'exit');
4224             return;
4225             }
4226              
4227              
4228             =for html
4229              
4230             =item $resp = $st->spacetrack ($name);
4231              
4232             This method returns predefined sets of data from the Space Track web
4233             site, using either canned queries or global favorites.
4234              
4235             The following catalogs are available:
4236              
4237             Name Description
4238             full Full catalog
4239             payloads All payloads
4240             navigation Navigation satellites
4241             weather Weather satellites
4242             geosynchronous Geosynchronous bodies
4243             iridium Iridium satellites
4244             orbcomm OrbComm satellites
4245             globalstar Globalstar satellites
4246             intelsat Intelsat satellites
4247             inmarsat Inmarsat satellites
4248             amateur Amateur Radio satellites
4249             visible Visible satellites
4250             special Special satellites
4251             bright_geosynchronous
4252             Bright Geosynchronous satellites
4253             human_spaceflight
4254             Human Spaceflight
4255             well_tracked_objects
4256             Well-Tracked Objects having
4257             unknown country and launch point
4258              
4259             The following option is supported:
4260              
4261             -json
4262             specifies the TLE be returned in JSON format
4263              
4264             Options may be specified either in command-line style
4265             (that is, as C<< spacetrack( '-json', ... ) >>) or as a hash reference
4266             (that is, as C<< spacetrack( { json => 1 }, ... ) >>).
4267              
4268             This method returns an L object. If the
4269             operation succeeded, the content of the response will be the requested
4270             data, unzipped if you used the version 1 interface.
4271              
4272             If you requested a non-existent catalog, the response code will be
4273             C (a.k.a. 404); otherwise the response code will be
4274             whatever the underlying HTTPS request returned.
4275              
4276             A Space Track username and password are required to use this method.
4277              
4278             If this method succeeds, the response will contain headers
4279              
4280             Pragma: spacetrack-type = orbit
4281             Pragma: spacetrack-source = spacetrack
4282              
4283             These can be accessed by C<< $st->content_type( $resp ) >> and
4284             C<< $st->content_source( $resp ) >> respectively.
4285              
4286             A list of valid names and brief descriptions can be obtained by calling
4287             C<< $st->names ('spacetrack') >>.
4288              
4289             If you have set the C attribute true (e.g. C<< $st->set
4290             (verbose => 1) >>), the content of the error response will include the
4291             list of valid names. Note, however, that under version 1 of the
4292             interface this list does not determine what can be retrieved.
4293              
4294             This method implicitly calls the C method if the session cookie
4295             is missing or expired. If C fails, you will get the
4296             HTTP::Response from C.
4297              
4298             =cut
4299              
4300             {
4301              
4302             my %unpack_query = (
4303             ARRAY_REF() => sub { return @{ $_[0] } },
4304             HASH_REF() => sub { return $_[0] },
4305             );
4306              
4307             # Unpack a Space Track REST query. References are unpacked per the
4308             # above table, if found there. Undefined values return an empty hash
4309             # reference. Anything else croaks with a stack trace.
4310              
4311 0     0   0 sub _unpack_query {
4312 0 0       0 my ( $arg ) = @_;
4313             my $code = $unpack_query{ref $arg}
4314 0         0 or Carp::confess "Bug - unexpected query $arg";
4315             return $code->( $arg );
4316             }
4317              
4318             }
4319              
4320             # Called dynamically
4321             sub _spacetrack_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
4322 5     5   19 return [
4323             'json!' => 'Return data in JSON format',
4324             'format=s' => 'Specify retrieval format',
4325             ];
4326             }
4327              
4328             # Called dynamically
4329 0     0   0 sub _spacetrack_catalog_version { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
4330             return $_[0]->getv( 'space_track_version' );
4331             }
4332              
4333 5     5 1 1736 sub spacetrack {
4334             my ( $self, @args ) = @_;
4335 5         27  
4336             my ( $opt, $catalog ) = _parse_args( @args );
4337 5         21  
4338             _retrieval_format( tle => $opt );
4339              
4340 5 100 66     58 defined $catalog
4341             and my $info = $catalogs{spacetrack}[2]{$catalog}
4342             or return $self->_no_such_catalog( spacetrack => 2, $catalog );
4343              
4344 4 50       14 defined $info->{deprecate}
4345             and Carp::croak "Catalog '$catalog' is deprecated in favor of '$info->{deprecate}'";
4346              
4347 4 100       20 defined $info->{favorite}
4348             and return $self->favorite( $opt, $info->{favorite} );
4349              
4350 3         7 my %retrieve_opt = %{
  3         12  
4351             $self->_convert_retrieve_options_to_rest( $opt )
4352             };
4353              
4354 3         15 $info->{tle}
4355 3 50       16 and @retrieve_opt{ keys %{ $info->{tle} } } =
  3         9  
4356             values %{ $info->{tle} };
4357 3         7  
4358             my $rslt;
4359 3 50       10  
4360             if ( $info->{satcat} ) {
4361 0         0  
4362             my %oid;
4363 0         0  
4364             foreach my $query ( _unpack_query( $info->{satcat} ) ) {
4365 0         0  
4366             $rslt = $self->spacetrack_query_v2(
4367             basicspacedata => 'query',
4368             class => 'satcat',
4369             format => 'json',
4370             predicates => 'OBJECT_NUMBER',
4371             CURRENT => 'Y',
4372             DECAY => 'null-val',
4373             _sort_rest_arguments( $query ),
4374             );
4375 0 0       0  
4376             $rslt->is_success()
4377             or return $rslt;
4378 0         0  
4379 0         0 foreach my $body ( @{
4380             $self->_get_json_object()->decode( $rslt->content() )
4381 0         0 } ) {
4382             $oid{ $body->{OBJECT_NUMBER} + 0 } = 1;
4383             }
4384              
4385             }
4386              
4387 0         0 $rslt = $self->retrieve( $opt,
  0         0  
4388             sort { $a <=> $b } keys %oid );
4389 0 0       0  
4390             $rslt->is_success()
4391             or return $rslt;
4392              
4393             } else {
4394 3         13  
4395             $rslt = $self->spacetrack_query_v2(
4396             basicspacedata => 'query',
4397             _sort_rest_arguments( \%retrieve_opt ),
4398             );
4399 3 100       15  
4400             $rslt->is_success()
4401             or return $rslt;
4402 1         17  
4403             $self->_convert_content( $rslt );
4404 1         6  
4405             $self->_add_pragmata( $rslt,
4406             'spacetrack-type' => 'orbit',
4407             'spacetrack-source' => 'spacetrack',
4408             'spacetrack-interface' => 2,
4409             );
4410              
4411             }
4412 1         9  
4413             return $rslt;
4414              
4415             }
4416              
4417             =for html
4418              
4419             =item $resp = $st->spacetrack_query_v2( @path );
4420              
4421             This method exposes the Space Track version 2 interface (a.k.a the REST
4422             interface). It has nothing to do with the (probably badly-named)
4423             C method.
4424              
4425             The arguments are the arguments to the REST interface. These will be
4426             URI-escaped, and a login will be performed if necessary. This method
4427             returns an C object containing the results of the
4428             operation.
4429              
4430             Except for the URI escaping of the arguments and the implicit login,
4431             this method interfaces directly to Space Track. It is provided for those
4432             who want a way to experiment with the REST interface, or who wish to do
4433             something not covered by the higher-level methods.
4434              
4435             For example, if you want the JSON version of the satellite box score
4436             (rather than the tab-delimited version provided by the C
4437             method) you will find the JSON in the response object of the following
4438             call:
4439              
4440             my $resp = $st->spacetrack_query_v2( qw{
4441             basicspacedata query class boxscore
4442             format json predicates all
4443             } );
4444             );
4445              
4446             If this method is called directly from outside the C
4447             name space, pragmata will be added to the results based on the
4448             arguments, as follows:
4449              
4450             For C<< basicspacedata => 'modeldef' >>
4451              
4452             Pragma: spacetrack-type = modeldef
4453             Pragma: spacetrack-source = spacetrack
4454             Pragma: spacetrack-interface = 2
4455              
4456             For C<< basicspacedata => 'query' >> and C<< class => 'tle' >> or
4457             C<'tle_latest'>,
4458              
4459             Pragma: spacetrack-type = orbit
4460             Pragma: spacetrack-source = spacetrack
4461             Pragma: spacetrack-interface = 2
4462              
4463             =cut
4464              
4465             {
4466             our $SPACETRACK_DELAY_SECONDS = $ENV{SPACETRACK_DELAY_SECONDS} || 3;
4467              
4468             my $spacetrack_delay_until;
4469              
4470 95     95   158 sub _spacetrack_delay {
4471 95 50       244 my ( $self ) = @_;
4472             $SPACETRACK_DELAY_SECONDS
4473 0 0       0 or return;
4474             $self->{dump_headers} & DUMP_DRY_RUN
4475 0 0       0 and return;
4476 0         0 if ( defined $spacetrack_delay_until ) {
4477 0 0       0 my $now = _time();
4478             $now < $spacetrack_delay_until
4479             and _sleep( $spacetrack_delay_until - $now );
4480 0         0 }
4481             $spacetrack_delay_until = _time() + $SPACETRACK_DELAY_SECONDS;
4482 0         0  
4483             return;
4484             }
4485             }
4486              
4487             {
4488             my %tle_class = map { $_ => 1 } qw{ tle tle_latest };
4489              
4490 95     95 1 342 sub spacetrack_query_v2 {
4491             my ( $self, @args ) = @_;
4492              
4493             # Space Track has announced that beginning September 22 2014
4494             # they will begin limiting queries to 20 per minute. But they
4495             # seem to have jumped the gun, since I get failures August 19
4496             # 2014 if I don't throttle. None of this applies, though, if
4497 95         275 # we're not actually executing the query.
4498             $self->_spacetrack_delay();
4499 95         184  
4500             delete $self->{_pragmata};
4501              
4502             # # Note that we need to add the comma to URI::Escape's RFC3986 list,
4503             # # since Space Track does not decode it.
4504             # my $url = join '/',
4505             # $self->_make_space_track_base_url( 2 ),
4506             # map {
4507             # URI::Escape::uri_escape( $_, '^A-Za-z0-9.,_~:-' )
4508             # } @args;
4509 95         223  
4510 95         14954 my $uri = URI->new( $self->_make_space_track_base_url( 2 ) );
4511             $uri->path_segments( @args );
4512             # $url eq $uri->as_string()
4513             # or warn "'$url' ne '@{[ $uri->as_string() ]}'";
4514             # $url = $uri->as_string();
4515 95 100       13487  
4516             if ( my $resp = $self->_dump_request(
4517             args => \@args,
4518             method => 'GET',
4519             url => $uri,
4520             version => 2,
4521 48         3068 ) ) {
4522             return $resp;
4523             }
4524              
4525 47 100       134 $self->_check_cookie_generic( 2 )
4526 1         6 or do {
4527 1 50       64 my $resp = $self->login();
4528             $resp->is_success()
4529             or return $resp;
4530             };
4531             ## warn "Debug - $url/$cgi";
4532 47         134 # my $resp = $self->_get_agent()->get( $url );
4533             my $resp = $self->_get_agent()->get( $uri );
4534 47 50       162  
4535             if ( $resp->is_success() ) {
4536 47 50 33     466  
4537             if ( $self->{pretty} &&
4538             _find_rest_arg_value( \@args, format => 'json' ) eq 'json'
4539 0         0 ) {
4540 0         0 my $json = $self->_get_json_object();
4541             $resp->content( $json->encode( $json->decode(
4542             $resp->content() ) ) );
4543             }
4544 47 100       154  
4545             if ( __PACKAGE__ ne caller ) {
4546 2         8  
4547             my $kind = _find_rest_arg_value( \@args,
4548 2         6 basicspacedata => '' );
4549             my $class = _find_rest_arg_value( \@args,
4550             class => '' );
4551 2 100 33     14  
    50          
4552             if ( 'modeldef' eq $kind ) {
4553 1         5  
4554             $self->_add_pragmata( $resp,
4555             'spacetrack-type' => 'modeldef',
4556             'spacetrack-source' => 'spacetrack',
4557             'spacetrack-interface' => 2,
4558             );
4559              
4560             } elsif ( 'query' eq $kind && $tle_class{$class} ) {
4561 1         5  
4562             $self->_add_pragmata( $resp,
4563             'spacetrack-type' => 'orbit',
4564             'spacetrack-source' => 'spacetrack',
4565             'spacetrack-interface' => 2,
4566             );
4567              
4568             }
4569             }
4570             }
4571 47         145  
4572 47         170 $self->__dump_response( $resp );
4573             return $resp;
4574             }
4575             }
4576              
4577 4     4   12 sub _find_rest_arg_value {
4578 4         13 my ( $args, $name, $default ) = @_;
4579 8 100       26 for ( my $inx = $#$args - 1; $inx >= 0; $inx -= 2 ) {
4580             $args->[$inx] eq $name
4581             and return $args->[$inx + 1];
4582 0         0 }
4583             return $default;
4584             }
4585              
4586             =for html
4587              
4588             =item $resp = $st->update( $file_name );
4589              
4590             This method updates the named TLE file, which must be in JSON format. On
4591             a successful update, the content of the returned HTTP::Response object
4592             is the updated TLE data, in whatever format is desired. If any updates
4593             were in fact found, the file is rewritten. The rewritten JSON will be
4594             pretty if the C attribute is true.
4595              
4596             The file to be updated can be generated by using the C<-json> option on
4597             any of the methods that accesses Space Track data. For example,
4598              
4599             # Assuming $ENV{SPACETRACK_USER} contains
4600             # username/password
4601             my $st = Astro::SpaceTrack->new(
4602             pretty => 1,
4603             );
4604             my $rslt = $st->spacetrack( { json => 1 }, 'iridium' );
4605             $rslt->is_success()
4606             or die $rslt->status_line();
4607             open my $fh, '>', 'iridium.json'
4608             or die "Failed to open file: $!";
4609             print { $fh } $rslt->content();
4610             close $fh;
4611              
4612             The following is the equivalent example using the F script:
4613              
4614             SpaceTrack> set pretty 1
4615             SpaceTrack> spacetrack -json iridium >iridium.json
4616              
4617             This method reads the file to be updated, determines the highest C
4618             value, and then requests the given OIDs, restricting the return to
4619             C values greater than the highest found. If anything is returned,
4620             the file is rewritten.
4621              
4622             The following options may be specified:
4623              
4624             -json
4625             specifies the TLE be returned in JSON format
4626              
4627             Options may be specified either in command-line style (that is, as
4628             C<< spacetrack( '-json', ... ) >>) or as a hash reference (that is, as
4629             C<< spacetrack( { json => 1 }, ... ) >>).
4630              
4631             B that there is no way to specify the C<-rcs> or C<-effective>
4632             options. If the file being updated contains these values, they will be
4633             lost as the individual OIDs are updated.
4634              
4635             =cut
4636              
4637             {
4638              
4639             my %encode = (
4640             '3le' => sub {
4641             my ( undef, $data ) = @_; # JSON object unused
4642             return join '', map {
4643             "$_->{OBJECT_NAME}\n$_->{TLE_LINE1}\n$_->{TLE_LINE2}\n"
4644             } @{ $data };
4645             },
4646             json => sub {
4647             my ( $json, $data ) = @_;
4648             return $json->encode( $data );
4649             },
4650             tle => sub {
4651             my ( undef, $data ) = @_; # JSON object unused
4652             return join '', map {
4653             "$_->{TLE_LINE1}\n$_->{TLE_LINE2}\n"
4654             } @{ $data };
4655             },
4656             );
4657              
4658             # Called dynamically
4659             sub _update_opts { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
4660 0     0   0 return [
4661             _get_retrieve_options(),
4662             ];
4663             }
4664              
4665 0     0 1 0 sub update {
4666             my ( $self, @args ) = @_;
4667 0         0  
4668             my ( $opt, $fn ) = $self->_parse_retrieve_args( @args );
4669 0         0  
  0         0  
4670             $opt = { %{ $opt } }; # Since we modify it.
4671              
4672 0 0       0 delete $opt->{start_epoch}
4673             and Carp::croak '-start_epoch not allowed';
4674 0 0       0 delete $opt->{end_epoch}
4675             and Carp::croak '-end_epoch not allowed';
4676 0         0  
4677 0         0 my $json = $self->_get_json_object();
4678             my $data;
4679 0         0 {
  0         0  
4680 0 0       0 local $/ = undef;
4681             open my $fh, '<', $fn
4682 0         0 or Carp::croak "Unable to open $fn: $!";
4683 0         0 $data = $json->decode( <$fh> );
4684             close $fh;
4685             }
4686 0         0  
4687 0         0 my $file = -1;
4688 0         0 my @oids;
  0         0  
4689 0         0 foreach my $datum ( @{ $data } ) {
4690             push @oids, $datum->{OBJECT_NUMBER};
4691             my $ff = defined $datum->{_file_of_record} ?
4692 0 0       0 delete $datum->{_file_of_record} :
4693 0 0       0 $datum->{FILE};
4694             $ff > $file
4695             and $file = $ff;
4696             }
4697              
4698 0 0       0 defined $opt->{since_file}
4699             or $opt->{since_file} = $file;
4700 0 0       0  
    0          
4701             my $format = delete $opt->{json} ? 'json' :
4702 0         0 $self->getv( 'with_name' ) ? '3le' : 'tle';
4703             $opt->{format} = 'json';
4704 0         0  
  0         0  
4705             my $resp = $self->retrieve( $opt, sort { $a <=> $b } @oids );
4706 0 0       0  
4707             if ( $resp->code() == HTTP_NOT_FOUND ) {
4708 0         0  
4709 0         0 $resp->code( HTTP_OK );
4710             $self->_add_pragmata( $resp,
4711             'spacetrack-type' => 'orbit',
4712             'spacetrack-source' => 'spacetrack',
4713             'spacetrack-interface' => 2,
4714             );
4715              
4716             } else {
4717 0 0       0  
4718             $resp->is_success()
4719             or return $resp;
4720 0         0  
  0         0  
  0         0  
4721             my %merge = map { $_->{OBJECT_NUMBER} => $_ } @{ $data };
4722 0         0  
  0         0  
4723 0         0 foreach my $datum ( @{ $json->decode( $resp->content() ) } ) {
  0         0  
  0         0  
4724             %{ $merge{$datum->{OBJECT_NUMBER}} } = %{ $datum };
4725             }
4726              
4727 0 0       0 {
  0         0  
4728             open my $fh, '>', $fn
4729 0         0 or Carp::croak "Failed to open $fn: $!";
  0         0  
4730 0         0 print { $fh } $json->encode( $data );
4731             close $fh;
4732             }
4733              
4734             }
4735 0         0  
4736             $resp->content( $encode{$format}->( $json, $data ) );
4737 0         0  
4738             return $resp;
4739             }
4740              
4741             }
4742              
4743              
4744             ####
4745             #
4746             # Private methods.
4747             #
4748              
4749             # $self->_add_pragmata ($resp, $name => $value, ...);
4750             #
4751             # This method adds pragma headers to the given HTTP::Response
4752             # object, of the form pragma => "$name = $value". The pragmata are
4753             # also cached in $self.
4754             #
4755             # Pragmata names are normalized by converting them to lower case
4756             # and converting underscores to dashes.
4757              
4758 153     153   501 sub _add_pragmata {
4759 153         416 my ($self, $resp, @args) = @_;
4760 331         6383 while (@args) {
4761 331         687 my ( $name, $value ) = splice @args, 0, 2;
4762 331         691 $name = lc $name;
4763 331         863 $name =~ s/ _ /-/smxg;
4764 331         1237 $self->{_pragmata}{$name} = $value;
4765             $resp->push_header(pragma => "$name = $value");
4766 153         5660 }
4767             return;
4768             }
4769              
4770             {
4771             my %format_map = qw{
4772             3le tle
4773             };
4774              
4775             # $accumulator = _accumulator_for( $format, \%opt )
4776             #
4777             # This subroutine manufactires and returns an accumulator for the
4778             # named format. The reference to the options hash is itself
4779             # optional. The supported options are:
4780             # file => true if the data contains a FILE key and the caller
4781             # requests that a _file_of_record key be generated if
4782             # possible and appropriate. Individual accumulators are at
4783             # liberty to ignore this.
4784             # pretty => true if the caller requests that the returned data be
4785             # nicely formatted. This normally comes from the 'pretty'
4786             # attribute. Individual accumulators are at liberty to
4787             # ignore this.
4788             #
4789             # The return is a code reference. This reference is intended to be
4790             # called as
4791             # $accumulator->( $self, $resp )
4792             # for each successful HTTP response. After all responses have been
4793             # processed, the accumulated data are retrieved using
4794             # ( $content, $data ) = $accumulator( $self )
4795             # The first return is the text representation of the accumulated
4796             # data. The second is the decoded data, and is returned at the
4797             # accumulator's option. In scalar context only $content is returned.
4798              
4799 83     83   168 sub _accumulator_for {
4800 83   66     318 my ( $format, $opt ) = @_;
4801 83   50     564 my $name = $format_map{$format} || $format;
4802             my $accumulator = __PACKAGE__->can( "_accumulate_${name}_data" )
4803             || \&_accumulate_unknown_data;
4804             my $returner = __PACKAGE__->can( "_accumulate_${name}_return" )
4805 20     20   39 || sub {
4806 20         68 my ( undef, $context ) = @_;
4807 83   100     444 return $context->{data};
4808 83   100     353 };
4809             my $context = {
4810             format => $format,
4811             opt => $opt || {},
4812             };
4813 106     106   208 return sub {
4814 106 100       260 my ( $self, $resp ) = @_;
4815             defined $resp
4816 54         141 or return $returner->( $self, $context );
4817 54 50 33     795 my $content = $resp->content();
4818             defined $content
4819             and $content ne ''
4820 54         120 or return;
4821             my $data = $accumulator->( $self, $content, $context );
4822 54 100 100     178 $context->{opt}{file}
4823             and $data
4824 54         375 and _accumulate_file_of_record( $self, $context, $data );
4825             return;
4826 83         400 }
4827             }
4828              
4829             }
4830              
4831 1     1   5 sub _accumulate_file_of_record {
4832 1 50       5 my ( undef, $context, $data ) = @_; # Invocant unused
4833 0         0 if ( defined $context->{file} ) {
  0         0  
4834             foreach my $datum ( @{ $data } ) {
4835             defined $datum->{FILE}
4836 0 0 0     0 and $datum->{FILE} > $context->{file}
4837             and $datum->{_file_of_record} = $context->{file};
4838             }
4839             } else {
4840 1         12 $context->{file} = List::Util::max( -1,
4841 1         4 map { $_->{FILE} }
4842 1         3 grep { defined $_->{FILE} }
  1         3  
4843             @{ $data }
4844             );
4845 1         3 }
4846             return;
4847             }
4848              
4849             # The data accumulators. The conventions which must be followed are
4850             # that, given a format named 'fmt':
4851             #
4852             # 1) There MUST be an accumulator named _accumulate_fmt_data(). Its
4853             # arguments are the invocant, the content of the return, and the
4854             # context hash. It must accumulate data in $context->{data}, in any
4855             # format it likes.
4856             # 2) If _accumulate_fmt_data() decodes the data, it SHOULD return a
4857             # reference to the decoded array. Otherwise it MUST return nothing.
4858             # 3) There MAY be a returner named _accumulate_fmt_return(). If it
4859             # exists its arguments are the invocant and the context hash. It MUST
4860             # return a valid representation of the accumulated data in the
4861             # desired format.
4862             # 4) If _accumulate_fmt_return() does not exist, the return will be the
4863             # contents of $context->{data}, which MUST have been maintained by
4864             # _accumulate_fmt_data() as a valid representation of the data in the
4865             # desired format.
4866             # 5) Note that if _accumulate_fmt_return() exists,
4867             # _accumulate_fmt_data need not maintain $context->{data} as a valid
4868             # representation of the accumulated data.
4869              
4870             # Accessed via __PACKAGE__->can( "accumulate_${name}_data" ) in
4871             # _accumulator_for(), above
4872 0     0   0 sub _accumulate_csv_data { ## no critic (ProhibitUnusedPrivateSubroutines)
4873 0 0       0 my ( undef, $content, $context ) = @_; # Invocant unused
4874 0         0 if ( defined $context->{data} ) {
4875 0         0 $context->{data} =~ s{ (?
4876 0         0 $content =~ s{ .* \n }{}smx;
4877             $context->{data} .= $content;
4878 0         0 } else {
4879             $context->{data} = $content;
4880 0         0 }
4881             return;
4882             }
4883              
4884             # Accessed via __PACKAGE__->can( "accumulate_${name}_data" ) in
4885             # _accumulator_for(), above
4886 0     0   0 sub _accumulate_html_data { ## no critic (ProhibitUnusedPrivateSubroutines)
4887 0 0       0 my ( undef, $content, $context ) = @_; # Invocant unused
4888 0         0 if ( defined $context->{data} ) {
4889 0         0 $context->{data} =~ s{ \s*
\s* \z }{}smx; 4890 0         0 $content =~ s{ .* \s* }{}smx; 4891             $context->{data} .= $content; 4892 0         0 } else { 4893             $context->{data} = $content; 4894 0         0 } 4895             return; 4896             } 4897               4898             # Accessed via __PACKAGE__->can( "accumulate_${name}_data" ) in 4899             # _accumulator_for(), above 4900 33     33   148 sub _accumulate_json_data { ## no critic (ProhibitUnusedPrivateSubroutines) 4901             my ( $self, $content, $context ) = @_; 4902               4903             my $json = $context->{json} ||= $self->_get_json_object( 4904 33   66     140 pretty => $context->{opt}{pretty}, 4905             ); 4906 33         812   4907             my $data = $json->decode( $content ); 4908 33 50       166   4909             ARRAY_REF eq ref $data 4910             or $data = [ $data ]; 4911 33 100       51     33         79   4912             @{ $data } 4913             or return; 4914 32 100       79   4915 1         2 if ( $context->{data} ) {   1         3     1         2   4916             push @{ $context->{data} }, @{ $data }; 4917 31         51 } else { 4918             $context->{data} = $data; 4919             } 4920 32         60   4921             return $data; 4922             } 4923               4924             # Accessed via __PACKAGE__->can( "accumulate_${name}_return" ) in 4925             # _accumulator_for(), above 4926 32     32   51 sub _accumulate_json_return { ## no critic (ProhibitUnusedPrivateSubroutines) 4927             my ( $self, $context ) = @_; 4928               4929             my $json = $context->{json} ||= $self->_get_json_object( 4930 32   33     90 pretty => $context->{opt}{pretty}, 4931             ); 4932 32   100     72   4933             $context->{data} ||= []; # In case we did not find anything. 4934             return wantarray 4935 32 100       523 ? ( $json->encode( $context->{data} ), $context->{data} ) 4936             : $json->encode( $context->{data} ); 4937             } 4938               4939 0     0   0 sub _accumulate_unknown_data { 4940             my ( undef, $content, $context ) = @_; # Invocant unused 4941 0 0       0 defined $context->{data} 4942 0         0 and Carp::croak "Unable to accumulate $context->{format} data"; 4943 0         0 $context->{data} = $content; 4944             return; 4945             } 4946               4947             # Accessed via __PACKAGE__->can( "accumulate_${name}_data" ) in 4948             # _accumulator_for(), above 4949 21     21   46 sub _accumulate_tle_data { ## no critic (ProhibitUnusedPrivateSubroutines) 4950 21         68 my ( undef, $content, $context ) = @_; # Invocant unused 4951 21         39 $context->{data} .= $content; 4952             return; 4953             } 4954               4955             # Accessed via __PACKAGE__->can( "accumulate_${name}_data" ) in 4956             # _accumulator_for(), above 4957 0     0   0 sub _accumulate_xml_data { ## no critic (ProhibitUnusedPrivateSubroutines) 4958 0 0       0 my ( undef, $content, $context ) = @_; 4959 0         0 if ( defined $context->{data} ) { 4960 0         0 $context->{data} =~ s{ \s* \s* \z }{}smx; 4961 0         0 $content =~ s{ .* \s* }{}smx; 4962             $context->{data} .= $content; 4963 0         0 } else { 4964             $context->{data} = $content; 4965 0         0 } 4966             return; 4967             } 4968               4969             # _check_cookie_generic looks for our session cookie. If it is found, it 4970             # returns true if it thinks the cookie is valid, and false otherwise. If 4971             # it is not found, it returns false. 4972               4973 2     2   7 sub _record_cookie_generic { 4974             my ( $self, $version ) = @_; 4975 2 50       7 defined $version 4976 2         7 or $version = $self->{space_track_version}; 4977 2         6 my $interface_info = $self->{_space_track_interface}[$version]; 4978 2         5 my $cookie_name = $interface_info->{cookie_name}; 4979             my $domain = $interface_info->{domain_space_track}; 4980 2         4   4981             my ( $cookie, $expires ); 4982 2 50   2   68 $self->_get_agent()->cookie_jar->scan( sub { 4983             $self->{dump_headers} & DUMP_COOKIE 4984 2 50       8 and $self->_dump_cookie( "_record_cookie_generic:\n", @_ ); 4985             $_[4] eq $domain 4986 2 50       6 or return; 4987             $_[3] eq SESSION_PATH 4988 2 50       6 or return; 4989             $_[1] eq $cookie_name 4990 2         9 or return; 4991 2         6 ( $cookie, $expires ) = @_[2, 8]; 4992 2         9 return; 4993             } ); 4994               4995             # I don't get an expiration time back from the version 2 interface. 4996             # But the docs say the cookie is only good for about two hours, so 4997 2 50 33     38 # to be on the safe side I fudge in an hour. 4998             $version == 2 4999             and not defined $expires 5000             and $expires = time + 3600; 5001 2 50       8   5002 2         5 if ( defined $cookie ) { 5003 2 50       8 $interface_info->{session_cookie} = $cookie; 5004             $self->{dump_headers} & DUMP_TRACE 5005 2 50       6 and warn "Session cookie: $cookie\n"; ## no critic (RequireCarping) 5006 2         5 if ( exists $interface_info->{cookie_expires} ) { 5007 2 50       7 $interface_info->{cookie_expires} = $expires; 5008             $self->{dump_headers} & DUMP_TRACE 5009             and warn 'Cookie expiration: ', 5010             POSIX::strftime( '%d-%b-%Y %H:%M:%S', localtime $expires ), 5011 2         10 " ($expires)\n"; ## no critic (RequireCarping) 5012             return $expires > time; 5013 0 0       0 } 5014             return $interface_info->{session_cookie} ? 1 : 0; 5015 0 0       0 } else { 5016             $self->{dump_headers} & DUMP_TRACE 5017 0         0 and warn "Session cookie not found\n"; ## no critic (RequireCarping) 5018             return; 5019             } 5020             } 5021               5022 47     47   76 sub _check_cookie_generic { 5023             my ( $self, $version ) = @_; 5024 47 50       115 defined $version 5025 47         80 or $version = $self->{space_track_version}; 5026             my $interface_info = $self->{_space_track_interface}[$version]; 5027 47 50       107   5028             if ( exists $interface_info->{cookie_expires} ) { 5029 47   66     252 return defined $interface_info->{cookie_expires} 5030             && $interface_info->{cookie_expires} > time; 5031 0         0 } else { 5032             return defined $interface_info->{session_cookie}; 5033             } 5034             } 5035               5036             # _convert_content converts the content of an HTTP::Response 5037             # from crlf-delimited to lf-delimited. 5038               5039             { # Begin local symbol block 5040               5041             my $lookfor = $^O eq 'MacOS' ? qr{ \012|\015+ }smx : qr{ \r \n }smx; 5042               5043 33     33   89 sub _convert_content { 5044 33         143 my ( undef, @args ) = @_; # Invocant unused 5045 33         90 local $/ = undef; # Slurp mode. 5046 33         129 foreach my $resp (@args) { 5047             my $buffer = $resp->content; 5048             # If we request a non-existent Space Track catalog number, 5049             # we get 200 OK but the unzipped content is undefined. We 5050             # catch this before we get this far, but the buffer check is 5051 33 50       450 # left in in case something else leaks through. 5052 33         5759 defined $buffer or $buffer = ''; 5053 33         179 $buffer =~ s/$lookfor/\n/smxgo; 5054 33         16532 1 while ($buffer =~ s/ \A \n+ //smx); 5055 33 100       535 $buffer =~ s/ \s+ \n /\n/smxg; 5056 33         139 $buffer =~ m/ \n \z /smx or $buffer .= "\n"; 5057 33         800 $resp->content ($buffer); 5058             $resp->header ( 5059             'content-length' => length ($buffer), 5060             ); 5061 33         2022 } 5062             return; 5063             } 5064             } # End local symbol block. 5065               5066             # $self->_deprecation_notice( $method, $argument ); 5067             # 5068             # This method centralizes deprecation. Deprecation is driven of 5069             # the %deprecate hash. Values are: 5070             # false - no warning 5071             # 1 - warn on first use 5072             # 2 - warn on each use 5073             # 3 - die on each use. 5074               5075             { 5076               5077             my %deprecate = ( 5078             celestrak => { 5079             # sts => 3, 5080             '--descending' => 1, 5081             '--end_epoch' => 1, 5082             '--last5' => 1, 5083             '--sort' => 1, 5084             '--start_epoch' => 1, 5085             }, 5086             attribute => { 5087             url_iridium_status_mccants => 3, 5088             }, 5089             iridium_status => { 5090             mccants => 3, 5091             }, 5092             iridium_status_format => { 5093             mccants => 3, 5094             }, 5095             ); 5096               5097 96     96   227 sub _deprecation_notice { 5098 96 100       279 my ( undef, $method, $argument ) = @_; # Invocant unused 5099             my $level = $deprecate{$method} 5100 90         143 or return; 5101 90 50       251 my $desc = $method; 5102 90 50       203 if ( ref $level ) { 5103 90 50       264 defined $argument or Carp::confess( 'Bug - $argument undefined' ); 5104             $level = $level->{$argument} 5105 0         0 or return; 5106             $desc = "$method $argument"; 5107 0 0       0 } 5108             $level >= 3 5109 0 0       0 and Carp::croak "$desc is retracted"; 5110             warnings::enabled( 'deprecated' ) 5111 0 0       0 and Carp::carp "$desc is deprecated"; 5112             1 == $level 5113 0 0       0 or return; 5114 0         0 if ( ref $deprecate{$method} ) { 5115             $deprecate{$method}{$argument} = 0; 5116 0         0 } else { 5117             $deprecate{$method} = 0; 5118 0         0 } 5119             return; 5120             } 5121               5122             } 5123               5124             # _dump_cookie is intended to be called from inside the 5125             # HTTP::Cookie->scan method. The first argument is prefix text 5126             # for the dump, and the subsequent arguments are the arguments 5127             # passed to the scan method. 5128             # It dumps the contents of the cookie to STDERR via a warn (). 5129             # A typical session cookie looks like this: 5130             # version => 0 5131             # key => 'spacetrack_session' 5132             # val => whatever 5133             # path => '/' 5134             # domain => 'www.space-track.org' 5135             # port => undef 5136             # path_spec => 1 5137             # secure => undef 5138             # expires => undef 5139             # discard => 1 5140             # hash => {} 5141             # The response to the login, though, has an actual expiration 5142             # time, which we take cognisance of. 5143               5144             { # begin local symbol block 5145               5146             my @names = qw{version key val path domain port path_spec secure 5147             expires discard hash}; 5148               5149 0     0   0 sub _dump_cookie { 5150 0         0 my ( $self, $prefix, @args ) = @_; 5151 0 0       0 my $json = $self->_get_json_object( pretty => 1 ); 5152 0         0 $prefix and warn $prefix; ## no critic (RequireCarping) 5153 0         0 for (my $inx = 0; $inx < @names; $inx++) { 5154             warn " $names[$inx] => ", $json->encode( $args[$inx] ); ## no critic (RequireCarping) 5155 0         0 } 5156             return; 5157             } 5158             } # end local symbol block 5159               5160               5161             # __dump_response dumps the headers of the passed-in response 5162             # object. The hook is used for capturing responses to use when 5163             # mocking LWP::UserAgent, and is UNSUPPORTED, and subject to 5164             # change or retraction without notice. 5165               5166 133     133   344 sub __dump_response { 5167             my ( $self, $resp, $message ) = @_; 5168 133 50       443   5169 0         0 if ( $self->{dump_headers} & DUMP_RESPONSE ) { 5170 0 0 0     0 my $content = $resp->content(); 5171             if ( $self->{dump_headers} & DUMP_TRUNCATED 5172 0         0 && 61 < length $content ) { 5173             $content = substr( $content, 0, 61 ) . '...'; 5174 0         0 } 5175 0         0 my @data = ( $resp->code(), $resp->message(), [], $content ); 5176 0         0 foreach my $name ( $resp->headers()->header_field_names() ) { 5177 0 0       0 my @val = $resp->header( $name );   0         0   5178             push @{ $data[2] }, $name, @val > 1 ? \@val : $val[0]; 5179 0 0       0 } 5180 0         0 if ( my $rqst = $resp->request() ) { 5181             push @data, { 5182             method => $rqst->method(), 5183             uri => '' . $rqst->uri(), # Force stringification 5184             }; 5185 0         0 } 5186             my $encoded = $self->_get_json_object( pretty => 1 )->encode( 5187 0 0       0 \@data ); 5188             defined $message 5189 0         0 or $message = 'Response object'; 5190 0         0 $message =~ s/ \s+ \z //smx; 5191             warn "$message:\n$encoded"; 5192 133         256 } 5193             return; 5194             } 5195               5196             # _dump_request dumps the request if desired. 5197             # 5198             # If the dump_request attribute has the DUMP_REQUEST bit set, this 5199             # routine dumps the request. If the DUMP_DRY_RUN bit is set, 5200             # the dump is returned in the content of an HTTP::Response object, 5201             # with the response code set to HTTP_I_AM_A_TEAPOT. Otherwise the 5202             # request is dumped to STDERR. 5203             # 5204             # If any of the conditions fails, this module simply returns. 5205               5206 121     121   535 sub _dump_request { 5207 121 100       566 my ( $self, %args ) = @_; 5208             $self->{dump_headers} & DUMP_REQUEST 5209             or return; 5210 48         98   5211 48 50       108 my $message = delete $args{message}; 5212             defined $message 5213 48         281 or $message = 'Request object'; 5214             $message =~ s/ \s* \z /:\n/smx; 5215 48 50       133   5216             my $json = $self->_get_json_object( pretty => 1 ) 5217             or return; 5218 48         136   5219 192 50       436 foreach my $key ( keys %args ) { 5220             CODE_REF eq ref $args{$key} 5221 0         0 or next; 5222             $args{$key} = $args{$key}->( \%args ); 5223             } 5224 48 50       629   5225             $self->{dump_headers} & DUMP_DRY_RUN 5226             and return HTTP::Response->new( 5227             HTTP_I_AM_A_TEAPOT, undef, undef, $json->encode( [ \%args ] ) 5228             ); 5229 0         0   5230             warn $message, $json->encode( \%args ); 5231 0         0   5232             return; 5233             } 5234               5235 83     83   260 sub _get_json_object { 5236             my ( $self, %arg ) = @_; 5237 83 100       193 defined $arg{pretty} 5238 83         616 or $arg{pretty} = $self->{pretty}; 5239             my $json = JSON->new()->utf8()->convert_blessed(); 5240 83 100       291 $arg{pretty} 5241 83         264 and $json->pretty()->canonical(); 5242             return $json; 5243             } 5244               5245             # my @oids = $self->_expand_oid_list( @args ); 5246             # 5247             # This subroutine expands the input into a list of OIDs. Commas are 5248             # recognized as separating an argument into multiple specifications. 5249             # Dashes are recognized as range operators, which are expanded. The 5250             # result is returned. 5251               5252 46     46   142 sub _expand_oid_list { 5253             my ( $self, @args ) = @_; 5254 46         69   5255 46         101 my @rslt;   211         1124   5256 211 100       831 foreach my $arg ( map { split qr{ , | \s+ }smx, $_ } @args ) {     50           5257             if ( my ( $lo, $hi ) = $arg =~ 5258             m/ \A \s* ( \d+ ) \s* - \s* ( \d+ ) \s* \z /smx 5259 1 50       5 ) { 5260             ( $lo, $hi ) = $self->_check_range( $lo, $hi ) 5261             and push @rslt, $lo .. $hi; 5262 210         525 } elsif ( $arg =~ m/ \A \s* ( \d+ ) \s* \z /smx ) { 5263             push @rslt, $1; 5264             } else { 5265             # TODO -- ignore? die? what? 5266             } 5267 46         236 } 5268             return @rslt; 5269             } 5270               5271             # Take as input a reference to one of the legal options arrays, and 5272             # extract the equivalent keys. The return is suitable for assigning to a 5273             # hash used to test the keys; that is, it is ( key0 => 1, key1 => 1, ... 5274             # ). 5275               5276             { 5277             my $strip = qr{ [=:|!+] .* }smx; 5278               5279 28     28   75 sub _extract_keys { 5280 28 50       102 my ( $lgl_opts ) = @_; 5281 28         46 if ( ARRAY_REF eq ref $lgl_opts ) {   28         56   5282 28         45 my $len = @{ $lgl_opts }; 5283 28         85 my @rslt; 5284 210         860 for ( my $inx = 0; $inx < $len; $inx += 2 ) { 5285 210         616 ( my $key = $lgl_opts->[$inx] ) =~ s/ $strip //smxo; 5286             push @rslt, $key, 1; 5287 28         239 } 5288             return @rslt; 5289 0         0 } else { 5290 0         0 $lgl_opts =~ s/ $strip //smxo; 5291             return $lgl_opts; 5292             } 5293             } 5294             } 5295               5296             # The following are data transform routines for _search_rest(). 5297             # The arguments are the datum and the class for which it is being 5298             # formatted. 5299               5300             # Parse an international launch id, and format it for a Space-Track REST 5301             # query. The parsing is done by _parse_international_id(). The 5302             # formatting prefixes the 'contains' wildcard '~~' unless year, sequence 5303             # and part are all present. 5304               5305 14     14   32 sub _format_international_id_rest { 5306 14         33 my ( $intl_id ) = @_; 5307 14 100       56 my @parts = _parse_international_id( $intl_id ); 5308             @parts >= 3 5309 10 100       70 and return sprintf '%04d-%03d%s', @parts; 5310             @parts >= 2 5311 1         6 and return sprintf '~~%04d-%03d', @parts; 5312             return sprintf '~~%04d-', $parts[0]; 5313             } 5314               5315             # Parse a launch date, and format it for a Space-Track REST query. The 5316             # parsing is done by _parse_launch_date(). The formatting prefixes the 5317             # 'contains' wildcard '~~' unless year, month, and day are all present. 5318               5319 14     14   28 sub _format_launch_date_rest { 5320 14 50       31 my ( $date ) = @_; 5321             my @parts = _parse_launch_date( $date ) 5322 14 50       117 or return; 5323             @parts >= 3 5324 0 0       0 and return sprintf '%04d-%02d-%02d', @parts; 5325             @parts >= 2 5326 0         0 and return sprintf '~~%04d-%02d', @parts; 5327             return sprintf '~~%04d', $parts[0]; 5328             } 5329               5330             # Note: If we have a bad cookie, we get a success status, with 5331             # the text 5332             # 5333             # 5334             # PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" 5335             # "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> 5336             # Space-Track 5337             # 5338             # 5339             #
5340             #

Error, Corrupted session cookie
5341             # Please LOGIN again.
5342             #

5343             # 5344             # If this happens, it would be good to retry the login. 5345               5346 66     66   127 sub _get_agent { 5347             my ( $self ) = @_; 5348 66 100       321 $self->{agent} 5349 7         37 and return $self->{agent}; 5350             my $agent = $self->{agent} = LWP::UserAgent->new( 5351             ssl_opts => { 5352             verify_hostname => $self->getv( 'verify_hostname' ), 5353             }, 5354             ); 5355 7         1687   5356             $agent->env_proxy(); 5357 7 50       98108   5358             $agent->cookie_jar() 5359             or $agent->cookie_jar( {} ); 5360 7         47711   5361             return $agent; 5362             } 5363               5364             # $resp = $self->_get_from_net( name => value ... ) 5365             # 5366             # This private method retrieves a URL and returns the response object. 5367             # The optional name/value pairs are: 5368             # 5369             # catalog => catalog_name 5370             # If this exists, it is the name of the catalog to retrieve. An 5371             # error is returned if it is not defined, or if the catalog does 5372             # not exist. 5373             # file => cache_file_name 5374             # If this is defined, the data are returned only if it has been 5375             # modified since the modification date of the file. If the data 5376             # have been modified, the cache file is refreshed; otherwise the 5377             # response is loaded from the cache file. 5378             # method => method_name 5379             # If this is defined, it is the name of the method doing the 5380             # catalog lookup. This is unused unless 'catalog' is defined, and 5381             # defaults to the name of the calling method. 5382             # post_process => code reference 5383             # If the network operation succeeded and this is defined, it is 5384             # called and passed the invocant, the HTTP::Response object, and 5385             # a reference to the catalog information hash (or to an empty hash 5386             # if 'url' was specified). The HTTP::Response object returned 5387             # (which may or may not be the one passed in) is the basis for any 5388             # further processing. 5389             # spacetrack_source => spacetrack_source 5390             # If this is defined, the corresponding-named pragma is set. The 5391             # default comes from the same-named key in the catalog info if that 5392             # is defined, or the 'method' argument (as defaulted). 5393             # spacetrack_type => spacetrack_type 5394             # If this is defined, the corresponding-named pragma is set. 5395             # url => URL 5396             # If this is defined, it is the URL of the data to retrieve. 5397             # 5398             # Either 'catalog' or 'url' MUST be specified. If 'url' is defined, 5399             # 'catalog' is ignored. 5400               5401 12     12   87 sub _get_from_net { 5402 12         44 my ( $self, %arg ) = @_; 5403             delete $self->{_pragmata}; 5404 12 50       127   5405 12         92 my $method = defined $arg{method} ? $arg{method} : ( caller 1)[3]; 5406             $method =~ s/ .* :: //smx; 5407 12         44   5408             my $url; 5409 12 100       54 my $info;     50           5410 6         19 if ( defined $arg{url} ) { 5411 6         14 $url = $arg{url}; 5412             $info = {}; 5413             } elsif ( exists $arg{catalog} ) { 5414             defined $arg{catalog} 5415             and $catalogs{$method} 5416 6 50 33     122 and $info = $catalogs{$method}{$arg{catalog}}       33         5417 6         41 or return $self->_no_such_catalog( $method, $arg{catalog} ); 5418             $self->_deprecation_notice( $method => $arg{catalog} ); 5419 6 50       30 $url = $info->{url} 5420             or Carp::confess "Bug - No url defined for $method( '$arg{catalog}' )"; 5421 0         0 } else { 5422             Carp::confess q; 5423             } 5424 12 50       55   5425 37 100       290 if ( my $resp = $self->_dump_request( 5426             args => { map { $_ => CODE_REF eq ref $arg{$_} ? 'sub { ... }' : $arg{$_} } keys %arg }, 5427             method => 'GET', 5428             url => $url, 5429             version => 2, 5430 0         0 ) ) { 5431             return $resp; 5432             } 5433 12         77   5434 12         102 my $agent = $self->_get_agent(); 5435 12         1861 my $rqst = HTTP::Request->new( GET => $url ); 5436 12 100       63 my $file_time; 5437 1 50       27 if ( defined $arg{file} ) { 5438 1         7 if ( my @stat = stat $arg{file} ) { 5439 1         30 $file_time = HTTP::Date::time2str( $stat[9] ); 5440             $rqst->header( if_modified_since => $file_time ); 5441             } 5442             } 5443 12         104   5444             my $resp; 5445             $resp = $self->_dump_request( 5446 0     0   0 arg => sub { 5447 0         0 my %sanitary = %arg; 5448             foreach my $key ( qw{ post_process } ) { 5449 0 0       0 delete $sanitary{$key} 5450             and $sanitary{$key} = CODE_REF; 5451 0         0 } 5452             return \%sanitary; 5453             }, 5454             message => '_get_from_net() request object', 5455             method => 'GET', 5456             url => $url, 5457 0     0   0 hdrs => sub { 5458 0         0 my %rslt; 5459 0         0 foreach my $name ( $rqst->header_field_names() ) { 5460 0 0       0 my @v = $rqst->header( $name ); 5461             $rslt{$name} = @v == 1 ? $v[0] : \@v; 5462 0         0 } 5463             return \%rslt; 5464             }, 5465 12 50       119 ) 5466 12         164 and return $resp; 5467 12         7703327 $resp = $agent->request( $rqst ); 5468             $self->__dump_response( 5469             $resp, '_get_from_net() initial response object' ); 5470 12 50       62   5471             if ( $resp->code() == HTTP_NOT_MODIFIED ) { 5472 0 0       0 defined $arg{file} 5473 0         0 or Carp::confess q{Programming Error - argument 'file' not defined}; 5474             local $/ = undef; 5475 0 0       0 open my $fh, '<', $arg{file} 5476             or return HTTP::Response->new( 5477             HTTP_INTERNAL_SERVER_ERROR, 5478 0         0 "Unable to read $arg{file}: $!" ); 5479 0         0 $resp->content( scalar <$fh> ); 5480 0         0 close $fh; 5481 0 0       0 $resp->code( HTTP_OK ); 5482             defined $file_time 5483 0         0 and $resp->header( last_modified => $file_time ); 5484             $arg{spacetrack_cache_hit} = 1; 5485             } else { 5486             $resp->is_success() 5487 12 50 33     242 and defined $arg{post_process} 5488 12 100       8190 and $resp = $arg{post_process}->( $self, $resp, $info ); 5489             $resp->is_success() # $resp may be a different object now. 5490 11         163 or return $resp; 5491 11 100       69 $self->_convert_content( $resp ); 5492             if ( defined $arg{file} ) { 5493 1 50       112 open my $fh, '>', $arg{file} 5494             or return HTTP::Response->new( 5495             HTTP_INTERNAL_SERVER_ERROR, 5496 1         5 "Unable to write $arg{file}: $!" );   1         8   5497 1         454 print { $fh } $resp->content(); 5498 1         11 close $fh; 5499             $arg{spacetrack_cache_hit} = 0; 5500             } 5501             } 5502               5503             defined $arg{spacetrack_source} 5504             or $arg{spacetrack_source} = 5505             defined $info->{spacetrack_source} ? 5506 11 50       72 $info->{spacetrack_source} :     100           5507             $method; 5508               5509             $self->_add_pragmata( $resp, 5510 11         45 map { 5511 33 100       185 defined $arg{$_} ? ( $_ => $arg{$_} ) :     100           5512             defined $info->{$_} ? ( $_ => $info->{$_} ) : 5513             () 5514             } 5515 11         46 qw{ spacetrack_type spacetrack_source spacetrack_cache_hit } ); 5516             $self->__dump_response( $resp, 5517 11         609 '_get_from_net() final response object' ); 5518             return $resp; 5519             } 5520               5521             # _get_space_track_domain() returns the domain name portion of the Space 5522             # Track URL from the appropriate attribute. The argument is the 5523             # interface version number, which defaults to the value of the 5524             # space_track_version attribute. 5525               5526 99     99   183 sub _get_space_track_domain { 5527             my ( $self, $version ) = @_; 5528 99 100       248 defined $version 5529 99         574 or $version = $self->{space_track_version}; 5530             return $self->{_space_track_interface}[$version]{domain_space_track}; 5531             } 5532               5533             # __get_loader() retrieves a loader. A code reference to it is returned. 5534             # 5535             # NOTE WELL: This subroutine is for the benefit of 5536             # t/spacetrack_request.t, and is called by that code. The leading double 5537             # underscore is to flag it to Perl::Critic as package private rather 5538             # than module private. 5539               5540             sub __get_loader { 5541 1     1   114 ## my ( $invocant, %arg ) = @_; # Arguments unused 5542             my $json = JSON->new()->utf8( 1 ); 5543 48     48   3364 return sub { 5544             return $json->decode( $_[0] ); 5545 1         7 } 5546             } 5547               5548             # _handle_observing_list takes as input any number of arguments. 5549             # each is split on newlines, and lines beginning with a five-digit 5550             # number (with leading spaces allowed) are taken to specify the 5551             # catalog number (first five characters) and common name (the rest) 5552             # of an object. The resultant catalog numbers are run through the 5553             # retrieve () method. If called in scalar context, the return is 5554             # the resultant HTTP::Response object. In list context, the first 5555             # return is the HTTP::Response object, and the second is a reference 5556             # to a list of list references, each lower-level reference containing 5557             # catalog number and name. 5558               5559 1     1   6 sub _handle_observing_list { 5560 1         3 my ( $self, $opt, @args ) = @_; 5561             my (@catnum, @data); 5562               5563             # Do not _parse_retrieve_args() here; we expect our caller to handle 5564             # this. 5565 1         4     1         19   5566 1         6 foreach (map {split qr{ \n }smx, $_} @args) { 5567 1 50       9 s/ \s+ \z //smx; 5568 1 50       6 my ( $id ) = m/ \A ( [\s\d]{5} ) /smx or next; 5569 1         4 $id =~ m/ \A \s* \d+ \z /smx or next; 5570 1         2 my $name = substr $_, 5; 5571 1         3 $name =~ s/ \A \s+ //smx; 5572 1         36 push @catnum, $id; 5573             push @data, [ $id, $name ]; 5574 1         3 } 5575 1 50       5 my $resp; 5576             if ( $opt->{observing_list} ) { 5577 0 0       0 $resp = HTTP::Response->new( HTTP_OK, undef, undef,   0         0   5578 0         0 join '', map { m/ \n \z /smx ? $_ : "$_\n" } @args ); 5579 0         0 my $source = ( caller 1 )[3]; 5580 0         0 $source =~ s/ .* :: //smx; 5581             $self->_add_pragmata( $resp, 5582             'spacetrack-type' => 'observing-list', 5583             'spacetrack-source' => $source, 5584 0         0 ); 5585             $self->__dump_response( $resp ); 5586 1         5 } else {   0         0   5587 1 50       5 $resp = $self->retrieve( $opt, sort {$a <=> $b} @catnum ); 5588             if ( $resp->is_success ) { 5589 1 50       11   5590 0         0 unless ( $self->{_pragmata} ) { 5591             $self->_add_pragmata( $resp, 5592             'spacetrack-type' => 'orbit', 5593             'spacetrack-source' => 'spacetrack', 5594             ); 5595 1         4 } 5596             $self->__dump_response( $resp ); 5597             } 5598 1 50       27 } 5599             return wantarray ? ($resp, \@data) : $resp; 5600             } 5601               5602             # _instance takes a variable and a class, and returns true if the 5603             # variable is blessed into the class. It returns false for 5604             # variables that are not references. 5605 1     1   4 sub _instance { 5606 1 50       5 my ( $object, $class ) = @_; 5607 1 50       6 ref $object or return; 5608 1         14 Scalar::Util::blessed( $object ) or return; 5609             return $object->isa( $class ); 5610             } 5611               5612               5613             # _make_space_track_base_url() makes the a base Space Track URL. You can 5614             # pass the interface version number (1 or 2) as an argument -- it 5615             # defaults to the value of the space_track_version attribute. 5616               5617 99     99   198 sub _make_space_track_base_url { 5618 99         339 my ( $self, $version ) = @_; 5619             return $self->{scheme_space_track} . '://' . 5620             $self->_get_space_track_domain( $version ); 5621             } 5622               5623             # _mung_login_status() takes as its argument an HTTP::Response object. 5624             # If the code is 500 and the message suggests a certificate problem, add 5625             # the suggestion that the user set verify_hostname false. 5626               5627 0     0   0 sub _mung_login_status { 5628             my ( $resp ) = @_; 5629 0 0       0 # 500 Can't connect to www.space-track.org:443 (certificate verify failed) 5630             $resp->code() == HTTP_INTERNAL_SERVER_ERROR 5631 0 0       0 or return $resp; 5632             ( my $msg = $resp->message() ) =~ 5633             s{ ( [(] \Qcertificate verify failed\E ) [)]} 5634 0         0 {$1; try setting the verify_hostname attribute false)}smx 5635 0         0 or return $resp; 5636             $resp->message( $msg ); 5637             return $resp; 5638             } 5639               5640             # _mutate_attrib takes the name of an attribute and the new value 5641             # for the attribute, and does what its name says. 5642               5643             # We supress Perl::Critic because we're a one-liner. CAVEAT: we MUST 5644 17     17   67 # not modify the contents of @_. Modifying @_ itself is fine. 5645 17         58 sub _mutate_attrib { 5646             $_[0]->_deprecation_notice( attribute => $_[1] ); 5647             return ($_[0]{$_[1]} = $_[2]); 5648             } 5649 23     23   54   5650 23 50       68 sub _mutate_dump_headers { 5651 0         0 my ( $self, $name, $value, $args ) = @_; 5652 0         0 if ( $value =~ m/ \A --? /smx ) { 5653 0         0 $value = 0; 5654             my $go = Getopt::Long::Parser->new(); 5655             $go->configure( qw{ require_order } ); 5656 0         0 $go->getoptionsfromarray( 5657 0 0   0   0 $args, 5658 0         0 map {; "$_!" => sub { 5659 0         0 $_[1] and do { 5660             my $method = "DUMP_\U$_[0]"; 5661 0         0 $value |= $self->$method(); 5662             }; 5663 0         0 return; 5664             } 5665 0         0 } @dump_options   0         0   5666             ); 5667 23 50       50 push @{ $args }, $value; # Since caller pops it. 5668             } else { 5669             $value =~ m/ \A 0 (?: [0-7]+ | x [[:xdigit:]]+ ) \z /smx 5670 23         69 and $value = oct $value; 5671             } 5672             return ( $self->{$name} = $value ); 5673             } 5674               5675             { 5676             my %id_file_name = ( 5677             MSWin32 => sub { 5678             my $home = $ENV{HOME} || $ENV{USERPROFILE} || join '', 5679             $ENV{HOMEDRIVE}, $ENV{HOMEPATH}; 5680             return "$home\\spacetrack.id"; 5681             }, 5682             VMS => sub { 5683             my $home = $ENV{HOME} || 'sys$login'; 5684             return "$home:spacetrack.id"; 5685             }, 5686             ); 5687               5688 0     0   0 sub __identity_file_name { 5689 0   0 0   0 my $id_file = ( $id_file_name{$^O} || sub { 5690 0         0 return join '/', $ENV{HOME}, '.spacetrack-identity' } 5691 0 0       0 )->(); 5692             my $gpg_file = "$id_file.gpg"; 5693 0         0 -e $gpg_file 5694             and return $gpg_file; 5695             return $id_file; 5696             } 5697               5698             } 5699               5700 0     0   0 # This basically duplicates the logic in Config::Identity 5701 0 0       0 sub __identity_file_is_encrypted { 5702             my $fn = __identity_file_name(); 5703 0 0       0 -B $fn 5704             and return 1; 5705 0         0 open my $fh, '<:encoding(utf-8)', $fn 5706 0         0 or return; 5707 0         0 local $/ = undef; 5708 0         0 my $content = <$fh>; 5709             close $fh; 5710             return $content =~ m/ \Q----BEGIN PGP MESSAGE----\E /smx; 5711             } 5712 20     20   63   5713             sub _mutate_identity { 5714 20 50       71 my ( $self, $name, $value ) = @_; 5715 20 50 33     130 defined $value 5716 0         0 or $value = $ENV{SPACETRACK_IDENTITY};   0         0   5717             if ( $value and my $identity = __spacetrack_identity() ) { 5718 20         60 $self->set( %{ $identity } ); 5719             } 5720             return ( $self->{$name} = $value ); 5721             } 5722               5723             =for html 5724               5725             =item Astro::SpaceTrack->flush_identity_cache(); 5726               5727             The identity file is normally read only once, and the data cached. This 5728             static method flushes the cache to force the identity data to be reread. 5729               5730             =cut 5731               5732             { 5733             my $identity; 5734             my $loaded; 5735 0     0 1 0   5736 0         0 sub flush_identity_cache { 5737             $identity = $loaded = undef; 5738             return; 5739             } 5740 0 0   0   0   5741             sub __spacetrack_identity { 5742 0         0 $loaded 5743 0         0 and return $identity; 5744 0 0       0 $loaded = 1; 5745             my $fn = __identity_file_name(); 5746             -f $fn 5747 0         0 or return $identity;   0         0   5748 0 0       0 { 5749 0         0 local $@ = undef; 5750 0         0 eval { 5751 0         0 require Config::Identity; 5752             $identity = { Config::Identity->load( $fn ) }; 5753             1; 5754 0         0 } or return; 5755 0 0       0 } 5756             foreach my $key ( qw{ username password } ) { 5757             exists $identity->{$key} 5758 0 0       0 or Carp::croak "Identity file omits $key";   0         0   5759             } 5760 0         0 scalar keys %{ $identity } > 2 5761             and Carp::croak 'Identity file defines keys besides username and password'; 5762             return $identity; 5763             } 5764             } 5765               5766             { 5767             my %need_logout = map { $_ => 1 } qw{ domain_space_track }; 5768 0     0   0   5769 0         0 sub _mutate_spacetrack_interface { 5770             my ( $self, $name, $value ) = @_; 5771             my $version = $self->{space_track_version}; 5772 0         0   5773             my $spacetrack_interface_info = 5774 0 0       0 $self->{_space_track_interface}[$version]; 5775               5776             exists $spacetrack_interface_info->{$name} 5777 0 0       0 or Carp::croak "Can not set $name for interface version $version"; 5778               5779             $need_logout{$name} 5780 0         0 and $self->logout(); 5781               5782             return ( $spacetrack_interface_info->{$name} = $value ); 5783             } 5784             } 5785 0     0   0   5786 0         0 sub _access_spacetrack_interface { 5787             my ( $self, $name ) = @_; 5788 0         0 my $version = $self->{space_track_version}; 5789 0 0       0 my $spacetrack_interface_info = 5790             $self->{_space_track_interface}[$version]; 5791 0         0 exists $spacetrack_interface_info->{$name} 5792             or Carp::croak "Can not get $name for interface version $version"; 5793             return $spacetrack_interface_info->{$name}; 5794             } 5795               5796             # _mutate_authen clears the session cookie and then sets the 5797             # desired attribute 5798               5799             # This clears the session cookie and cookie expiration, then co-routines 5800 4     4   27 # off to _mutate attrib. 5801 4         180 sub _mutate_authen { 5802             $_[0]->logout(); 5803             goto &_mutate_attrib; 5804             } 5805               5806             # This subroutine just does some argument checking and then co-routines 5807             # off to _mutate_attrib. 5808 2 50   2   13 sub _mutate_iridium_status_format { 5809 2         12 Carp::croak "Error - Illegal status format '$_[2]'" 5810 2         13 unless $catalogs{iridium_status}{$_[2]}; 5811             $_[0]->_deprecation_notice( iridium_status_format => $_[2] ); 5812             goto &_mutate_attrib; 5813             } 5814               5815             # _mutate_number croaks if the value to be set is not numeric. 5816             # Otherwise it sets the value. Only unsigned integers pass. 5817               5818             # This subroutine just does some argument checking and then co-routines 5819 0 0   0   0 # off to _mutate_attrib. 5820             sub _mutate_number { 5821             $_[2] =~ m/ \D /smx and Carp::croak <<"EOD"; 5822 0         0 Attribute $_[1] must be set to a numeric value. 5823             EOD 5824             goto &_mutate_attrib; 5825             } 5826               5827             # _mutate_space_track_version() mutates the version of the interface 5828             # used to retrieve data from Space Track. Valid values are 1 and 2, with 5829             # any false value causing the default to be set. 5830 2     2   6   5831 2 50       9 sub _mutate_space_track_version { 5832             my ( $self, $name, $value ) = @_; 5833             $value 5834 2 50 33     34 or $value = DEFAULT_SPACE_TRACK_VERSION; 5835             $value =~ m/ \A \d+ \z /smx 5836             and $self->{_space_track_interface}[$value] 5837 2 50       12 or Carp::croak "Invalid Space Track version $value"; 5838             ## $self->_deprecation_notice( $name => $value ); 5839 2         7 $value == 1 5840             and Carp::croak 'The version 1 SpaceTrack interface stopped working July 16 2013 at 18:00 UT'; 5841             return ( $self->{$name} = $value ); 5842             } 5843               5844             # _mutate_verify_hostname mutates the verify_hostname attribute. 5845             # Since the value of this gets fed to LWP::UserAgent->new() to 5846             # instantiate the {agent} attribute, we delete that attribute 5847             # before changing the value, relying on $self->_get_agent() to 5848             # instantiate it appropriately if needed -- and on any code that 5849             # uses the agent to go through this private method to get it. 5850 1     1   2   5851 1         3 sub _mutate_verify_hostname { 5852             delete $_[0]->{agent}; 5853             goto &_mutate_attrib; 5854             } 5855               5856             # _no_such_catalog takes as arguments a source and catalog name, 5857             # and returns the appropriate HTTP::Response object based on the 5858             # current verbosity setting. 5859               5860             { 5861               5862             my %no_such_name = ( 5863             celestrak => 'CelesTrak', 5864             spacetrack => 'Space Track', 5865             ); 5866 2     2   11   5867             sub _no_such_catalog { 5868 2 50       15 my ( $self, $source, @args ) = @_; 5869               5870             my $info = $catalogs{$source} 5871 2 100       14 or Carp::confess "Bug - No such source as '$source'"; 5872 1         3   5873 1 50       4 if ( ARRAY_REF eq ref $info ) { 5874             my $inx = shift @args; 5875             $info = $info->[$inx] 5876             or Carp::confess "Bug - Illegal index $inx ", 5877             "for '$source'"; 5878 2         8 } 5879               5880 2   33     14 my ( $catalog, $note ) = @args; 5881               5882             my $name = $no_such_name{$source} || $source; 5883 2 50       18       50           5884             my $lead = defined $catalog ? 5885             $info->{$catalog} ? 5886             "$name '$catalog' missing" : 5887 2 100       13 "$name '$catalog' not found" : 5888             "$name item not defined"; 5889             $lead .= defined $note ? " ($note)." : '.'; 5890 2 50       19   5891             return HTTP::Response->new (HTTP_NOT_FOUND, "$lead\n") 5892 0         0 unless $self->{verbose}; 5893 0         0   5894             my $resp = $self->names ($source); 5895             return HTTP::Response->new (HTTP_NOT_FOUND, 5896             join '', "$lead Try one of:\n", $resp->content, 5897             ); 5898             } 5899               5900             } 5901               5902             # _parse_args parses options off an argument list. The first 5903             # argument must be a list reference of options to be parsed. 5904             # This list is pairs of values, the first being the Getopt::Long 5905             # specification for the option, and the second being a description 5906             # of the option suitable for help text. Subsequent arguments are 5907             # the arguments list to be parsed. It returns a reference to a 5908             # hash containing the options, followed by any remaining 5909             # non-option arguments. If the first argument after the list 5910             # reference is a hash reference, it simply returns. 5911               5912             { 5913             my $go = Getopt::Long::Parser->new(); 5914 109     109   278   5915 109 100       352 sub _parse_args { 5916 20         69 my ( $lgl_opts, @args ) = @_; 5917 20         378 unless ( ARRAY_REF eq ref $lgl_opts ) { 5918 20         98 unshift @args, $lgl_opts; 5919 20 50       235 ( my $caller = ( caller 1 )[3] ) =~ s/ ( .* ) :: //smx; 5920             my $pkg = $1; 5921 20         92 my $code = $pkg->can( "_${caller}_opts" ) 5922             or Carp::confess "Bug - _${caller}_opts not found"; 5923 109         177 $lgl_opts = $code->(); 5924 109 100       303 } 5925 18         29 my $opt;   18         71   5926             if ( HASH_REF eq ref $args[0] ) { 5927             $opt = { %{ shift @args } }; # Poor man's clone. 5928 18 50       77 # Validation is new, so I insert a hack to turn it off if need 5929 18         47 # be. 5930 18         49 unless ( $ENV{SPACETRACK_SKIP_OPTION_HASH_VALIDATION} ) { 5931 18         32 my %lgl = _extract_keys( $lgl_opts );   18         55   5932 47 50       103 my @bad; 5933             foreach my $key ( keys %{ $opt } ) { 5934             $lgl{$key} 5935             or push @bad, $key; 5936             } 5937             @bad 5938             and _parse_args_failure( 5939 18 50       66 carp => 1,   0         0   5940             name => \@bad, 5941             legal => { @{ $lgl_opts } }, 5942             suffix => <<'EOD', 5943               5944             You cam suppress this warning by setting environment variable 5945             SPACETRACK_SKIP_OPTION_HASH_VALIDATION to a value Perl understands as 5946             true (say, like 1), but this should be considered a stopgap while you 5947             fix the calling code, or have it fixed, since my plan is to make this 5948             fatal. 5949             EOD 5950             ); 5951 91         171 } 5952 91         153 } else {   91         560   5953 91 50       570 $opt = {}; 5954             my %lgl = @{ $lgl_opts }; 5955             $go->getoptionsfromarray( 5956             \@args, 5957             $opt, 5958             keys %lgl, 5959             ) 5960 109         72000 or _parse_args_failure( legal => \%lgl ); 5961             } 5962             return ( $opt, @args ); 5963             } 5964             } 5965 0     0   0   5966 0 0       0 sub _parse_args_failure { 5967 0 0       0 my %arg = @_; 5968             my $msg = $arg{carp} ? 'Warning - ' : 'Error - '; 5969 0         0 if ( defined $arg{name} ) { 5970 0 0       0 my @names = ( ARRAY_REF eq ref $arg{name} ) ? 5971             @{ $arg{name} } : 5972 0 0       0 $arg{name}; 5973 0 0       0 @names 5974 0         0 or return;   0         0   5975 0         0 my $opt = @names > 1 ? 'Options' : 'Option'; 5976             my $txt = join ', ', map { "-$_" } sort @names; 5977 0 0       0 $msg .= "$opt $txt illegal.\n"; 5978 0         0 } 5979 0         0 if ( defined $arg{legal} ) {   0         0   5980 0         0 $msg .= "Legal options are\n"; 5981 0         0 foreach my $opt ( sort keys %{ $arg{legal} } ) { 5982 0         0 my $desc = $arg{legal}{$opt}; 5983             $opt = _extract_keys( $opt ); 5984 0         0 $msg .= " -$opt - $desc\n"; 5985             } 5986             $msg .= <<"EOD"; 5987             with dates being either Perl times, or numeric year-month-day, with any 5988             non-numeric character valid as punctuation. 5989             EOD 5990 0 0       0 } 5991             defined $arg{suffix} 5992 0 0       0 and $msg .= $arg{suffix}; 5993 0         0 $arg{carp} 5994 0         0 or Carp::croak $msg; 5995             Carp::carp $msg; 5996             return; 5997             } 5998               5999             # Parse an international launch ID in the form yyyy-sssp or yysssp. 6000             # In the yyyy-sssp form, the year can be two digits (in which case 57-99 6001             # are 1957-1999 and 00-56 are 2000-2056) and the dash can be any 6002             # non-alpha, non-digit, non-space character. In either case, trailing 6003             # fields are optional. If provided, the part ('p') can be multiple 6004             # alphabetic characters. Only fields actually specified will be 6005             # returned. 6006 14     14   25   6007 14         23 sub _parse_international_id { 6008             my ( $intl_id ) = @_; 6009 14 50       113 my ( $year, $launch, $part );     50           6010               6011             if ( $intl_id =~ 6012             m< \A ( \d+ ) [^[:alpha:][:digit:]\s] 6013 0         0 (?: ( \d{1,3} ) ( [[:alpha:]]* ) )? \z >smx 6014             ) { 6015             ( $year, $launch, $part ) = ( $1, $2, $3 ); 6016             } elsif ( $intl_id =~ 6017 14         57 m< \A ( \d\d ) (?: ( \d{3} ) ( [[:alpha:]]* ) )? >smx 6018             ) { 6019 0         0 ( $year, $launch, $part ) = ( $1, $2, $3 ); 6020             } else { 6021             return; 6022 14 50       47 }     50           6023 14         31   6024 14 100       33 $year += $year < 57 ? 2000 : $year < 100 ? 1900 : 0; 6025             my @parts = ( $year ); 6026 13         27 $launch 6027 13 100       33 or return @parts; 6028             push @parts, $launch; 6029 13         38 $part 6030             and push @parts, uc $part; 6031             return @parts; 6032             } 6033               6034             # Parse a date in the form yyyy-mm-dd, with either two- or four-digit 6035             # year, and month and day optional. The year is normalized to four 6036             # digits using the NORAD pivot date of 57 -- that is, 57-99 represent 6037             # 1957-1999, and 00-56 represent 2000-2056. The month and day are 6038             # optional. Only fields actually specified will be returned. 6039 14     14   28   6040 14 50       103 sub _parse_launch_date { 6041             my ( $date ) = @_; 6042             my ( $year, $month, $day ) = 6043 14 50       57 $date =~ m/ \A (\d+) (?:\D+ (\d+) (?: \D+ (\d+) )? )? /smx     50           6044 14         30 or return; 6045 14 50       35 $year += $year < 57 ? 2000 : $year < 100 ? 1900 : 0; 6046             my @parts = ( $year ); 6047 14         24 defined $month 6048 14 50       35 or return @parts; 6049 14         54 push @parts, $month; 6050             defined $day and push @parts, $day; 6051             return @parts; 6052             } 6053               6054             # _parse_retrieve_args parses the retrieve() options off its 6055             # arguments, prefixes a reference to the resultant options hash to 6056             # the remaining arguments, and returns the resultant list. If the 6057             # first argument is a list reference, it is taken as extra 6058             # options, and removed from the argument list. If the next 6059             # argument after the list reference (if any) is a hash reference, 6060             # it simply returns its argument list, under the assumption that 6061             # it has already been called. 6062               6063             { 6064               6065             my @legal_retrieve_options = ( 6066             @{ CLASSIC_RETRIEVE_OPTIONS() }, 6067             # Space Track Version 2 interface options 6068             'since_file=i' 6069             => '(Return only results added after the given file number)', 6070             'json!' => '(Return TLEs in JSON format)', 6071             'format=s' => 'Specify data format' 6072             ); 6073 0     0   0   6074             sub _get_retrieve_options { 6075             return @legal_retrieve_options; 6076             } 6077 85     85   224   6078 85 100       270 sub _parse_retrieve_args { 6079             my ( undef, @args ) = @_; # Invocant unused 6080             my $extra_options = ARRAY_REF eq ref $args[0] ? 6081             shift @args : 6082             undef; 6083               6084 85 100       218 ( my $opt, @args ) = _parse_args(   50         222   6085             ( $extra_options ? 6086             [ @legal_retrieve_options, @{ $extra_options } ] : 6087             \@legal_retrieve_options ), 6088 85   66     441 @args ); 6089               6090 85         231 $opt->{sort} ||= _validate_sort( $opt->{sort} ); 6091               6092 85         278 _retrieval_format( undef, $opt ); 6093               6094             return ( $opt, @args ); 6095             } 6096             } 6097               6098             { 6099             my @usual_formats = map { $_ => 1 } qw{ xml json html csv }; 6100             my $legacy_formats = { 6101             default => 'legacy', 6102             valid => { @usual_formats, map { $_ => 1 } qw{ legacy } }, 6103             }; 6104             my $tle_formats = { 6105             default => 'legacy', 6106             valid => { @usual_formats, map { $_ => 1 } qw{ tle 3le legacy } }, 6107             }; 6108             my %format = ( 6109             box_score => $legacy_formats, 6110             country_names => $legacy_formats, 6111             launch_sites => $legacy_formats, 6112             satcat => $legacy_formats, 6113             tle => $tle_formats, 6114             ); 6115 94     94   215   6116             sub _retrieval_format { 6117 94 50       300 my ( $table, $opt ) = @_;     100               100           6118             defined $table 6119             or $table = defined $opt->{tle} ? $opt->{tle} ? 'tle' : 6120             'satcat' : 'tle'; 6121 94 50 100     250 $opt->{json}       66         6122             and defined $opt->{format} 6123 94 50       242 and $opt->{format} ne 'json' 6124             and Carp::croak 'Inconsistent retrieval format specification'; 6125             $format{$table} 6126             or Carp::confess "Bug - $table not supported"; 6127 94 100       306 defined $opt->{format}     100           6128             or $opt->{format} = $opt->{json} ? 'json' : 6129 94 100       299 $format{$table}{default}; 6130             exists $opt->{json} 6131 94 50       267 or $opt->{json} = 'json' eq $opt->{format}; 6132 94 100       217 $format{$table}{valid}{ $opt->{format} } 6133             or Carp::croak "Invalid $table retrieval format '$opt->{format}'"; 6134             return $opt->{format} eq 'legacy' ? 'json' : $opt->{format}; 6135             } 6136             } 6137               6138             # my $sort = _validate_sort( $sort ); 6139             # 6140             # Validate and canonicalize the value of the -sort option. 6141             { 6142 68     68   142 my %valid = map { $_ => 1 } qw{ catnum epoch }; 6143 68 50       292 sub _validate_sort { 6144             my ( $sort ) = @_; 6145 0         0 defined $sort 6146 0 0       0 or return 'catnum'; 6147             $sort = lc $sort; 6148 0         0 $valid{$sort} 6149             or Carp::croak "Illegal sort '$sort'"; 6150             return $sort; 6151             } 6152             } 6153               6154             # $opt = _parse_retrieve_dates ($opt); 6155               6156             # This subroutine looks for keys start_epoch and end_epoch in the 6157             # given option hash, parses them as YYYY-MM-DD (where the letters 6158             # are digits and the dashes are any non-digit punctuation), and 6159             # replaces those keys' values with a reference to a list 6160             # containing the output of timegm() for the given time. If only 6161             # one epoch is provided, the other is defaulted to provide a 6162             # one-day date range. If the syntax is invalid, we croak. 6163             # 6164             # The return is the same hash reference that was passed in. 6165 34     34   55   6166             sub _parse_retrieve_dates { 6167 34         53 my ( $opt ) = @_; 6168 34         63   6169             my $found; 6170 68 100       156 foreach my $key ( qw{ end_epoch start_epoch } ) { 6171               6172 6 50       32 next unless $opt->{$key}; 6173 6         14   6174 6 50       35 if ( $opt->{$key} =~ m/ \D /smx ) { 6175             my $str = $opt->{$key}; 6176             $str =~ m< \A 6177             ( \d+ ) \D+ ( \d+ ) \D+ ( \d+ ) 6178             (?: \D+ ( \d+ ) (?: \D+ ( \d+ ) (?: \D+ ( \d+ ) )? )? )? 6179 6         29 \z >smx 6180 6         14 or Carp::croak "Error - Illegal date '$str'"; 6181 36 100       70 my @time = ( $6, $5, $4, $3, $2, $1 ); 6182             foreach ( @time ) { 6183             defined $_ 6184 6 50       21 or $_ = 0;     0           6185 6         11 } 6186             if ( $time[5] > 1900 ) { 6187 0         0 $time[5] -= 1900; 6188             } elsif ( $time[5] < 57 ) { 6189 6         11 $time[5] += 100; 6190 6 50       13 } 6191 6         23 $time[4] -= 1; 6192 6         257 eval { 6193             $opt->{$key} = Time::Local::timegm( @time ); 6194             1; 6195             } or Carp::croak "Error - Illegal date '$str'"; 6196 6         14 } 6197               6198             $found++; 6199 34 100       70 } 6200               6201 5 100       14 if ( $found ) { 6202 4   66     17   6203 4   66     20 if ( $found == 1 ) { 6204             $opt->{start_epoch} ||= $opt->{end_epoch} - 86400; 6205             $opt->{end_epoch} ||= $opt->{start_epoch} + 86400; 6206 5 50       16 } 6207               6208             $opt->{start_epoch} <= $opt->{end_epoch} or Carp::croak <<'EOD'; 6209             Error - End epoch must not be before start epoch. 6210 5         11 EOD 6211               6212 10         50 foreach my $key ( qw{ start_epoch end_epoch } ) { 6213 10         24   6214 10         17 my @time = reverse( ( gmtime $opt->{$key} )[ 0 .. 5 ] ); 6215 10         33 $time[0] += 1900; 6216             $time[1] += 1; 6217             $opt->{"_$key"} = \@time; 6218               6219             } 6220 34         65 } 6221               6222             return $opt; 6223             } 6224               6225             # _parse_search_args parses the search_*() options off its 6226             # arguments, prefixes a reference to the resultant options 6227             # hash to the remaining arguments, and returns the resultant 6228             # list. If the first argument is a hash reference, it validates 6229             # that the hash contains only legal options. 6230               6231               6232             { 6233               6234             my %status_query = ( 6235             onorbit => 'null-val', 6236             decayed => '<>null-val', 6237             all => '', 6238             ); 6239               6240             my %include_map = ( 6241             payload => 'PAYLOAD', 6242             rocket => 'ROCKET BODY', 6243             debris => 'DEBRIS', 6244             unknown => 'UNKNOWN', 6245             tba => 'TBA', 6246             other => 'OTHER', 6247             ); 6248 50     50   99   6249 50         68 sub _convert_search_options_to_rest { 6250             my ( undef, $opt ) = @_; # Invocant unused 6251 50 50       121 my %rest; 6252               6253 50 50       132 if ( defined $opt->{status} ) { 6254             defined ( my $query = $status_query{$opt->{status}} ) 6255 50 100       146 or Carp::croak "Unknown status '$opt->{status}'"; 6256             $query 6257             and $rest{DECAY} = $query; 6258             } 6259 50         74     50         66   6260             { 6261 50 100 66     119 my %incl;   50         189   6262 12         42     72         126   6263 12         28 if ( $opt->{exclude} && @{ $opt->{exclude} } ) {   12         25   6264 18 50       42 %incl = map { $_ => 1 } keys %include_map; 6265             foreach ( @{ $opt->{exclude} } ) { 6266 18         48 $include_map{$_} 6267             or Carp::croak "Unknown exclusion '$_'"; 6268             delete $incl{$_}; 6269             } 6270 50 100 66     116 }   50         128   6271 1         2     1         3   6272 1 50       4 if ( $opt->{include} && @{ $opt->{include} } ) { 6273             foreach ( @{ $opt->{include} } ) { 6274 1         3 $include_map{$_} 6275             or Carp::croak "Unknown inclusion '$_'"; 6276             $incl{$_} = 1; 6277             } 6278             } 6279               6280 50 100       176 keys %incl   55         123   6281             and $rest{OBJECT_TYPE} = join ',', 6282             map { $include_map{$_} } sort keys %incl; 6283               6284 50         112 } 6285               6286             return \%rest; 6287             } 6288               6289             my @legal_search_args = ( 6290             'rcs!' => '(ignored and deprecated)', 6291             'tle!' => '(return TLE data from search (defaults true))', 6292             'status=s' => q{('onorbit', 'decayed', or 'all')}, 6293             'exclude=s@' => q{('payload', 'debris', 'rocket', ... )}, 6294             'include=s@' => q{('payload', 'debris', 'rocket', ... )}, 6295             'comment!' => '(include comment in satcat data)', 6296             ); 6297             my %legal_search_status = map {$_ => 1} qw{onorbit decayed all}; 6298 0     0   0   6299             sub _get_search_options { 6300             return \@legal_search_args; 6301             } 6302 50     50   134   6303             sub _parse_search_args { 6304 50 50       135 my ( $self, @args ) = @_; 6305               6306 50         96 my $extra = ARRAY_REF eq ref $args[0] ? shift @args : [];   50         196   6307             @args = $self->_parse_retrieve_args( 6308 50         134 [ @legal_search_args, @{ $extra } ], @args ); 6309               6310 50   100     201 my $opt = $args[0]; 6311               6312 50 50       132 $opt->{status} ||= 'onorbit'; 6313               6314 0         0 $legal_search_status{$opt->{status}} or Carp::croak <<"EOD";   0         0   6315             Error - Illegal status '$opt->{status}'. You must specify one of 6316             @{[join ', ', map {"'$_'"} sort keys %legal_search_status]} 6317 50         90 EOD 6318 100   100     408   6319 100         144 foreach my $key ( qw{ exclude include } ) {   16         64     100         209   6320 100         190 $opt->{$key} ||= [];   100         225   6321 19 50       53 $opt->{$key} = [ map { split ',', $_ } @{ $opt->{$key} } ]; 6322             foreach ( @{ $opt->{$key} } ) { 6323 0         0 $include_map{$_} or Carp::croak <<"EOD";   0         0   6324             Error - Illegal -$key value '$_'. You must specify one or more of 6325             @{[join ', ', map {"'$_'"} sort keys %include_map]} 6326             EOD 6327             } 6328             } 6329 50 100       123   6330             defined $opt->{tle} 6331 50         153 or $opt->{tle} = 1; 6332               6333             return @args; 6334             } 6335               6336             my %search_opts = _extract_keys( \@legal_search_args ); 6337               6338             # _remove_search_options 6339             # 6340             # Shallow clone the argument hash, remove any search arguments from 6341             # it, and return a reference to the clone. Used for sanitizing the 6342             # options for a search before passing them to retrieve() to actually 6343 14     14   28 # get the TLEs. 6344 14         18 sub _remove_search_options {   14         84   6345 14         61 my ( $opt ) = @_; 6346 14         40 my %rslt = %{ $opt }; 6347             delete @rslt{ keys %search_opts }; 6348             return \%rslt; 6349             } 6350             } 6351               6352             # @keys = _sort_rest_arguments( \%rest_args ); 6353             # 6354             # This subroutine sorts the argument names in the desired order. 6355             # A better way to do this may be to use Unicode::Collate, which 6356             # has been core since 5.7.3. 6357               6358             { 6359               6360             my %special = map { $_ => 1 } qw{ basicspacedata extendedspacedata }; 6361 89     89   163   6362             sub _sort_rest_arguments { 6363 89 50       228 my ( $rest_args ) = @_; 6364               6365             HASH_REF eq ref $rest_args 6366 89         128 or return; 6367               6368 89         202 my @rslt; 6369               6370 178 50       342 foreach my $key ( keys %special ) { 6371             @rslt 6372 178 50       406 and Carp::croak "You may not specify both '$rslt[0]' and '$key'"; 6373             defined $rest_args->{$key} 6374             and push @rslt, $key, $rest_args->{$key}; 6375             } 6376 567         1125   6377 1001         1572   6378             push @rslt, map { ( $_->[0], $rest_args->{$_->[0]} ) } 6379 567         885 sort { $a->[1] cmp $b->[1] } 6380 567         1018 # Oh, for 5.14 and tr///r 6381 89         159 map { [ $_, _swap_upper_and_lower( $_ ) ] }   89         239   6382             grep { ! $special{$_} } 6383 89         614 keys %{ $rest_args }; 6384               6385             return @rslt; 6386             } 6387             } 6388 0     0   0   6389 0         0 sub _spacetrack_v2_response_is_empty { 6390             my ( $resp ) = @_; 6391             return $resp->content() =~ m/ \A \s* (?: [[] \s* []] )? \s* \z /smx; 6392             } 6393 0     0   0   6394             sub __readline_completer { 6395 0 0       0 my ( $app, $text, $line, $start ) = @_; 6396               6397             $start 6398 0         0 or return $app->_readline_complete_command( $text ); 6399 0         0   6400             my ( $cmd, @cmd_line ) = split $readline_word_break_re, $line, -1; 6401 0         0 $cmd = _verb_alias( $cmd ); 6402               6403 0 0       0 local $COMPLETION_APP = $app; 6404 0         0   6405             if ( my $code = $app->can( "_readline_complete_command_$cmd" ) ) { 6406             return $code->( $app, $text, $line, $start, \@cmd_line ); 6407 0 0 0     0 } 6408 0         0   6409             if ( $text =~ m/ \A - /smx and my $code = $app->can( "_${cmd}_opts") ) { 6410             return _readline_complete_options( $code, $text ); 6411             } 6412 0 0       0   6413               6414             $catalogs{$cmd} 6415 0         0 and return $app->_readline_complete_catalog( $text, $cmd ); 6416 0 0       0       0           6417 0 0       0 my @files = File::Glob::bsd_glob( "$text*" ); 6418             if ( 1 == @files ) { 6419 0         0 $files[0] .= -d $files[0] ? '/' : ' '; 6420 0 0 0     0 } elsif ( $readline::var_CompleteAddsuffix ) {     0               0               0           6421 0         0 foreach ( @files ) { 6422             if ( -l $_ ) { 6423 0         0 $_ .= '@'; 6424             } elsif ( -d $_ ) { 6425 0         0 $_ .= '/'; 6426             } elsif ( -x _) { 6427 0         0 $_ .= '*'; 6428             } elsif ( -S _ || -p _ ) { 6429             $_ .= '='; 6430             } 6431 0         0 } 6432 0         0 } 6433             $readline::rl_completer_terminator_character = ''; 6434             return @files; 6435             } 6436 0     0   0   6437 0         0 sub _readline_complete_catalog { 6438 0 0       0 my ( $app, $text, $cat ) = @_; 6439 0 0       0 my $this_cat = $catalogs{$cat}; 6440             if ( ARRAY_REF eq ref $this_cat ) { 6441 0         0 my $code = $app->can( "_${cat}_catalog_version" ) 6442             or Carp::confess "Bug - _${cat}_catalog_version() not found"; 6443             $this_cat = $this_cat->[ $code->( $app ) ]; 6444             } 6445 0 0 0     0 defined $text   0         0   6446 0         0 and $text ne '' 6447 0         0 or return( sort keys %{ $this_cat } );   0         0     0         0   6448             my $re = qr/ \A \Q$text\E /smx; 6449             return ( grep { $_ =~ $re } sort keys %{ $this_cat } ) 6450             } 6451               6452             { 6453             my @builtins; 6454             my %disallow = map { $_ => 1 } qw{ 6455             can getv import isa new 6456 0     0   0 }; 6457 0 0       0 sub _readline_complete_command { 6458 0         0 my ( $app, $text ) = @_; 6459 0   0     0 unless ( @builtins ) { 6460 10     10   131 push @builtins, qw{ bye exit show };   10         35     10         14610   6461 0         0 my $stash = ( ref $app || $app ) . '::'; 6462 0 0       0 no strict qw{ refs }; 6463             foreach my $sym ( keys %$stash ) { 6464 0 0       0 $sym =~ m/ \A _ /smx 6465             and next; 6466 0 0       0 $sym =~ m/ [[:upper:]] /smx 6467             and next; 6468 0 0       0 $disallow{$sym} 6469             and next; 6470 0         0 $app->can( $sym ) 6471             or next; 6472 0         0 push @builtins, $sym; 6473             } 6474 0         0 @builtins = sort @builtins; 6475 0         0 }   0         0   6476 0 0 0     0 my $match = qr< \A \Q$text\E >smx; 6477             my @rslt = grep { $_ =~ $match } @builtins; 6478             1 == @rslt 6479 0         0 and $rslt[0] =~ m/ \W \z /smx 6480             and $readline::rl_completer_terminator_character = ''; 6481             return ( sort @rslt ); 6482             } 6483             } 6484 0     0   0   6485 0 0       0 sub _readline_complete_options { 6486             my ( $code, $text ) = @_; 6487             $text =~ m/ \A ( --? ) ( .* ) /smx 6488 0         0 or return; 6489 0         0 # my ( $prefix, $match ) = ( $1, $2 );   0         0   6490 0         0 my $match = $2; 6491 0         0 my %lgl = @{ $code->() }; 6492 0         0 my $re = qr< \A \Q$match\E >smx; 6493 0         0 my @rslt; 6494 0 0       0 foreach ( keys %lgl ) { 6495             my $type = ''; 6496 0         0 ( my $o = $_ ) =~ s/ ( [!=?] ) .* //smx 6497             and $type = $1; 6498 0 0       0 my @names = split qr< \| >smx, $o;   0         0   6499 0         0 $type eq q   0         0     0         0   6500             and push @names, map { "no-$_" } @names; 6501 0         0 push @rslt, map { "--$_" } grep { $_ =~ $re } @names; 6502             } 6503             return ( sort @rslt ); 6504             } 6505 10     10   21   6506 10         15 sub _rest_date {   10         57   6507             my ( $time ) = @_; 6508             return sprintf '%04d-%02d-%02d %02d:%02d:%02d', @{ $time }; 6509             } 6510               6511             # $swapped = _swap_upper_and_lower( $original ); 6512             # 6513             # This subroutine swapps upper and lower case in its argument, 6514             # using the transliteration operator. It should be used only by 6515             # _sort_rest_arguments(). This can go away in favor of tr///r when 6516             # (if!) the minimum version becomes 5.14. 6517 567     567   869   6518 567         855 sub _swap_upper_and_lower { 6519 567         1456 my ( $arg ) = @_; 6520             $arg =~ tr/A-Za-z/a-zA-Z/; 6521             return $arg; 6522             } 6523               6524             # _source takes a filename, and returns the contents of the file 6525             # as a list. It dies if anything goes wrong. 6526 0     0   0   6527 0 0       0 sub _source { 6528             my ( undef, $fn ) = @_; # Invocant unused 6529             wantarray or die <<'EOD'; 6530 0 0       0 Error - _source () called in scalar or no context. This is a bug. 6531             EOD 6532             defined $fn or die <<'EOD'; 6533 0 0       0 Error - No source file name specified. 6534             EOD 6535             my $fh = IO::File->new ($fn, '<') or die <<"EOD"; 6536             Error - Failed to open source file '$fn'. 6537 0         0 $! 6538             EOD 6539             return <$fh>; 6540             } 6541               6542             # my $string = _stringify_oid_list( $opt, @oids ); 6543             # 6544             # This subroutine sorts the @oids array, and stringifies it by 6545             # eliminating duplicates, combining any consecutive runs of OIDs into 6546             # ranges, and joining the result with commas. The string is returned. 6547             # 6548             # The $opt is a reference to a hash that specifies punctuation in the 6549             # stringified result. The keys used are 6550             # separator -- The string used to separate OID specifications. The 6551             # default is ','. 6552             # range_operator -- The string used to specify a range. If omitted, 6553             # ranges will not be constructed. 6554             # 6555             # Note that ranges containing only two OIDs (e.g. 5-6) will be expanded 6556             # as "5,6", not "5-6" (presuming $range_operator is '-'). 6557 47     47   123   6558             sub _stringify_oid_list { 6559 47         100 my ( $opt, @args ) = @_; 6560               6561             my @rslt = ( -99 ); # Prime the pump 6562 47 50       121   6563             @args 6564 47 50       119 or return @args; 6565 47         73   6566             my $separator = defined $opt->{separator} ? $opt->{separator} : ','; 6567 47 50       83 my $range_operator = $opt->{range_operator}; 6568 47         138     201         274   6569 213 100       355 if ( defined $range_operator ) { 6570 151 100       228 foreach my $arg ( sort { $a <=> $b } @args ) { 6571 147         214 if ( ARRAY_REF eq ref $rslt[-1] ) { 6572             if ( $arg == $rslt[-1][1] + 1 ) { 6573 4 50       11 $rslt[-1][1] = $arg; 6574             } else { 6575             $arg > $rslt[-1][1] 6576             and push @rslt, $arg; 6577 62 100       161 } 6578 11         32 } else { 6579             if ( $arg == $rslt[-1] + 1 ) { 6580 51 50       158 $rslt[-1] = [ $rslt[-1], $arg ]; 6581             } else { 6582             $arg > $rslt[-1] 6583             and push @rslt, $arg; 6584             } 6585 47         79 } 6586             } 6587             shift @rslt; # Drop the pump priming. 6588 47         91   6589             return join( $separator, 6590             map { ref $_ ? 6591 55 100       283 $_->[1] > $_->[0] + 1 ?   1 100       7   6592             "$_->[0]$range_operator$_->[1]" : 6593             @{ $_ } : 6594             $_ 6595             } @rslt 6596             ); 6597 0         0     0         0   6598             } else { 6599             return join $separator, sort { $a <=> $b } @args; 6600             } 6601               6602             } 6603               6604             eval { 6605             require Time::HiRes; 6606             *_sleep = \&Time::HiRes::sleep; 6607             *_time = \&Time::HiRes::time; 6608             1; 6609             } or do { 6610             *_sleep = sub { 6611             return sleep $_[0]; 6612             }; 6613             *_time = sub { 6614             return time; 6615             }; 6616             }; 6617               6618             # _trim replaces undefined arguments with '', trims all arguments 6619             # front and back, and returns the modified arguments. 6620 5     5   23   6621 5         23 sub _trim { 6622 5 50       22 my @args = @_; 6623 5         21 foreach ( @args ) { 6624 5         29 defined $_ or $_ = ''; 6625             s/ \A \s+ //smx; 6626 5         19 s/ \s+ \z //smx; 6627             } 6628             return @args; 6629             } 6630               6631             1; 6632               6633             __END__