File Coverage

blib/lib/Astro/SpaceTrack.pm
Criterion Covered Total %
statement 1066 1699 62.7
branch 398 920 43.2
condition 83 215 38.6
subroutine 163 221 73.7
pod 36 40 90.0
total 1746 3095 56.4


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

Error, Corrupted session cookie
5537             # Please LOGIN again.
5538             #

5539             # 5540             # If this happens, it would be good to retry the login. 5541               5542             sub _get_agent { 5543 56     56   86 my ( $self ) = @_; 5544             $self->{agent} 5545 56 100       266 and return $self->{agent}; 5546 4         43 my $agent = $self->{agent} = LWP::UserAgent->new( 5547             ssl_opts => { 5548             verify_hostname => $self->getv( 'verify_hostname' ), 5549             }, 5550             ); 5551               5552 4         681 $agent->env_proxy(); 5553               5554 4 50       8733 $agent->cookie_jar() 5555             or $agent->cookie_jar( {} ); 5556               5557 4         16987 return $agent; 5558             } 5559               5560             # $resp = $self->_get_from_net( name => value ... ) 5561             # 5562             # This private method retrieves a URL and returns the response object. 5563             # The optional name/value pairs are: 5564             # 5565             # catalog => catalog_name 5566             # If this exists, it is the name of the catalog to retrieve. An 5567             # error is returned if it is not defined, or if the catalog does 5568             # not exist. 5569             # file => cache_file_name 5570             # If this is defined, the data are returned only if it has been 5571             # modified since the modification date of the file. If the data 5572             # have been modified, the cache file is refreshed; otherwise the 5573             # response is loaded from the cache file. 5574             # method => method_name 5575             # If this is defined, it is the name of the method doing the 5576             # catalog lookup. This is unused unless 'catalog' is defined, and 5577             # defaults to the name of the calling method. 5578             # post_process => code reference 5579             # If the network operation succeeded and this is defined, it is 5580             # called and passed the invocant, the HTTP::Response object, and 5581             # a reference to the catalog information hash (or to an empty hash 5582             # if 'url' was specified). The HTTP::Response object returned 5583             # (which may or may not be the one passed in) is the basis for any 5584             # further processing. 5585             # spacetrack_source => spacetrack_source 5586             # If this is defined, the corresponding-named pragma is set. The 5587             # default comes from the same-named key in the catalog info if that 5588             # is defined, or the 'method' argument (as defaulted). 5589             # spacetrack_type => spacetrack_type 5590             # If this is defined, the corresponding-named pragma is set. 5591             # url => URL 5592             # If this is defined, it is the URL of the data to retrieve. 5593             # 5594             # Either 'catalog' or 'url' MUST be specified. If 'url' is defined, 5595             # 'catalog' is ignored. 5596               5597             sub _get_from_net { 5598 7     7   42 my ( $self, %arg ) = @_; 5599 7         25 delete $self->{_pragmata}; 5600               5601 7 50       62 my $method = defined $arg{method} ? $arg{method} : ( caller 1)[3]; 5602 7         49 $method =~ s/ .* :: //smx; 5603               5604 7         18 my $url; 5605             my $info; 5606 7 100       86 if ( defined $arg{url} ) {     50           5607 4         9 $url = $arg{url}; 5608 4         5 $info = {}; 5609             } elsif ( exists $arg{catalog} ) { 5610             defined $arg{catalog} 5611             and $catalogs{$method} 5612             and $info = $catalogs{$method}{$arg{catalog}} 5613 3 100 33     53 or return $self->_no_such_catalog( $method, $arg{catalog} );       66         5614 2         15 $self->_deprecation_notice( $method => $arg{catalog} ); 5615             $url = $info->{url} 5616 2 50       16 or Carp::confess "Bug - No url defined for $method( '$arg{catalog}' )"; 5617             } else { 5618 0         0 Carp::confess q; 5619             } 5620               5621 6 50       24 if ( my $resp = $self->_dump_request( 5622 21 100       206 args => { map { $_ => CODE_REF eq ref $arg{$_} ? 'sub { ... }' : $arg{$_} } keys %arg }, 5623             method => 'GET', 5624             url => $url, 5625             version => 2, 5626             ) ) { 5627 0         0 return $resp; 5628             } 5629               5630 6         37 my $agent = $self->_get_agent(); 5631 6         75 my $rqst = HTTP::Request->new( GET => $url ); 5632 6         926 my $file_time; 5633 6 50       28 if ( defined $arg{file} ) { 5634 0 0       0 if ( my @stat = stat $arg{file} ) { 5635 0         0 $file_time = HTTP::Date::time2str( $stat[9] ); 5636 0         0 $rqst->header( if_modified_since => $file_time ); 5637             } 5638             } 5639               5640 6         9 my $resp; 5641             $resp = $self->_dump_request( 5642             arg => sub { 5643 0     0   0 my %sanitary = %arg; 5644 0         0 foreach my $key ( qw{ post_process } ) { 5645             delete $sanitary{$key} 5646 0 0       0 and $sanitary{$key} = CODE_REF; 5647             } 5648 0         0 return \%sanitary; 5649             }, 5650             message => '_get_from_net() request object', 5651             method => 'GET', 5652             url => $url, 5653             hdrs => sub { 5654 0     0   0 my %rslt; 5655 0         0 foreach my $name ( $rqst->header_field_names() ) { 5656 0         0 my @v = $rqst->header( $name ); 5657 0 0       0 $rslt{$name} = @v == 1 ? $v[0] : \@v; 5658             } 5659 0         0 return \%rslt; 5660             }, 5661             ) 5662 6 50       79 and return $resp; 5663 6         92 $resp = $agent->request( $rqst ); 5664 6         6058142 $self->__dump_response( 5665             $resp, '_get_from_net() initial response object' ); 5666               5667 6 50       19 if ( $resp->code() == HTTP_NOT_MODIFIED ) { 5668             defined $arg{file} 5669 0 0       0 or Carp::confess q{Programming Error - argument 'file' not defined}; 5670 0         0 local $/ = undef; 5671             open my $fh, '<', $arg{file} 5672 0 0       0 or return HTTP::Response->new( 5673             HTTP_INTERNAL_SERVER_ERROR, 5674             "Unable to read $arg{file}: $!" ); 5675 0         0 $resp->content( scalar <$fh> ); 5676 0         0 close $fh; 5677 0         0 $resp->code( HTTP_OK ); 5678 0 0       0 defined $file_time 5679             and $resp->header( last_modified => $file_time ); 5680 0         0 $arg{spacetrack_cache_hit} = 1; 5681             } else { 5682             $resp->is_success() 5683             and defined $arg{post_process} 5684 6 50 33     93 and $resp = $arg{post_process}->( $self, $resp, $info ); 5685 6 100       81 $resp->is_success() # $resp may be a different object now. 5686             or return $resp; 5687 5         100 $self->_convert_content( $resp ); 5688 5 50       24 if ( defined $arg{file} ) { 5689             open my $fh, '>', $arg{file} 5690 0 0       0 or return HTTP::Response->new( 5691             HTTP_INTERNAL_SERVER_ERROR, 5692             "Unable to write $arg{file}: $!" ); 5693 0         0 print { $fh } $resp->content();   0         0   5694 0         0 close $fh; 5695 0         0 $arg{spacetrack_cache_hit} = 0; 5696             } 5697             } 5698               5699             defined $arg{spacetrack_source} 5700             or $arg{spacetrack_source} = 5701             defined $info->{spacetrack_source} ? 5702             $info->{spacetrack_source} : 5703 5 50       36 $method;     100           5704               5705             $self->_add_pragmata( $resp, 5706             map { 5707 5         18 defined $arg{$_} ? ( $_ => $arg{$_} ) : 5708 15 100       87 defined $info->{$_} ? ( $_ => $info->{$_} ) :     100           5709             () 5710             } 5711             qw{ spacetrack_type spacetrack_source spacetrack_cache_hit } ); 5712 5         27 $self->__dump_response( $resp, 5713             '_get_from_net() final response object' ); 5714 5         151 return $resp; 5715             } 5716               5717             # _get_space_track_domain() returns the domain name portion of the Space 5718             # Track URL from the appropriate attribute. The argument is the 5719             # interface version number, which defaults to the value of the 5720             # space_track_version attribute. 5721               5722             sub _get_space_track_domain { 5723 96     96   163 my ( $self, $version ) = @_; 5724             defined $version 5725 96 100       153 or $version = $self->{space_track_version}; 5726 96         562 return $self->{_space_track_interface}[$version]{domain_space_track}; 5727             } 5728               5729             # __get_loader() retrieves a loader. A code reference to it is returned. 5730             # 5731             # NOTE WELL: This subroutine is for the benefit of 5732             # t/spacetrack_request.t, and is called by that code. The leading double 5733             # underscore is to flag it to Perl::Critic as package private rather 5734             # than module private. 5735               5736             sub __get_loader { 5737             ## my ( $invocant, %arg ) = @_; # Arguments unused 5738 1     1   42 my $json = JSON->new()->utf8( 1 ); 5739             return sub { 5740 46     46   2569 return $json->decode( $_[0] ); 5741             } 5742 1         6 } 5743               5744             # _handle_observing_list takes as input any number of arguments. 5745             # each is split on newlines, and lines beginning with a five-digit 5746             # number (with leading spaces allowed) are taken to specify the 5747             # catalog number (first five characters) and common name (the rest) 5748             # of an object. The resultant catalog numbers are run through the 5749             # retrieve () method. If called in scalar context, the return is 5750             # the resultant HTTP::Response object. In list context, the first 5751             # return is the HTTP::Response object, and the second is a reference 5752             # to a list of list references, each lower-level reference containing 5753             # catalog number and name. 5754               5755             sub _handle_observing_list { 5756 1     1   4 my ( $self, $opt, @args ) = @_; 5757 1         2 my (@catnum, @data); 5758               5759             # Do not _parse_retrieve_args() here; we expect our caller to handle 5760             # this. 5761               5762 1         3 foreach (map {split qr{ \n }smx, $_} @args) {   1         11   5763 1         3 s/ \s+ \z //smx; 5764 1 50       6 my ( $id ) = m/ \A ( [\s\d]{5} ) /smx or next; 5765 1 50       4 $id =~ m/ \A \s* \d+ \z /smx or next; 5766 1         4 my $name = substr $_, 5; 5767 1         2 $name =~ s/ \A \s+ //smx; 5768 1         2 push @catnum, $id; 5769 1         4 push @data, [ $id, $name ]; 5770             } 5771 1         1 my $resp; 5772 1 50       4 if ( $opt->{observing_list} ) { 5773             $resp = HTTP::Response->new( HTTP_OK, undef, undef, 5774 0 0       0 join '', map { m/ \n \z /smx ? $_ : "$_\n" } @args );   0         0   5775 0         0 my $source = ( caller 1 )[3]; 5776 0         0 $source =~ s/ .* :: //smx; 5777 0         0 $self->_add_pragmata( $resp, 5778             'spacetrack-type' => 'observing-list', 5779             'spacetrack-source' => $source, 5780             ); 5781 0         0 $self->__dump_response( $resp ); 5782             } else { 5783 1         26 $resp = $self->retrieve( $opt, sort {$a <=> $b} @catnum );   0         0   5784 1 50       3 if ( $resp->is_success ) { 5785               5786 1 50       8 unless ( $self->{_pragmata} ) { 5787 0         0 $self->_add_pragmata( $resp, 5788             'spacetrack-type' => 'orbit', 5789             'spacetrack-source' => 'spacetrack', 5790             ); 5791             } 5792 1         3 $self->__dump_response( $resp ); 5793             } 5794             } 5795 1 50       30 return wantarray ? ($resp, \@data) : $resp; 5796             } 5797               5798             # _instance takes a variable and a class, and returns true if the 5799             # variable is blessed into the class. It returns false for 5800             # variables that are not references. 5801             sub _instance { 5802 1     1   3 my ( $object, $class ) = @_; 5803 1 50       4 ref $object or return; 5804 1 50       4 Scalar::Util::blessed( $object ) or return; 5805 1         14 return $object->isa( $class ); 5806             } 5807               5808               5809             # _make_space_track_base_url() makes the a base Space Track URL. You can 5810             # pass the interface version number (1 or 2) as an argument -- it 5811             # defaults to the value of the space_track_version attribute. 5812               5813             sub _make_space_track_base_url { 5814 96     96   153 my ( $self, $version ) = @_; 5815 96         256 return $self->{scheme_space_track} . '://' . 5816             $self->_get_space_track_domain( $version ); 5817             } 5818               5819             # _mung_login_status() takes as its argument an HTTP::Response object. 5820             # If the code is 500 and the message suggests a certificate problem, add 5821             # the suggestion that the user set verify_hostname false. 5822               5823             sub _mung_login_status { 5824 0     0   0 my ( $resp ) = @_; 5825             # 500 Can't connect to www.space-track.org:443 (certificate verify failed) 5826 0 0       0 $resp->code() == HTTP_INTERNAL_SERVER_ERROR 5827             or return $resp; 5828 0 0       0 ( my $msg = $resp->message() ) =~ 5829             s{ ( [(] \Qcertificate verify failed\E ) [)]} 5830             {$1; try setting the verify_hostname attribute false)}smx 5831             or return $resp; 5832 0         0 $resp->message( $msg ); 5833 0         0 return $resp; 5834             } 5835               5836             # _mutate_attrib takes the name of an attribute and the new value 5837             # for the attribute, and does what its name says. 5838               5839             # We supress Perl::Critic because we're a one-liner. CAVEAT: we MUST 5840             # not modify the contents of @_. Modifying @_ itself is fine. 5841             sub _mutate_attrib { 5842 14     14   56 $_[0]->_deprecation_notice( attribute => $_[1] ); 5843 14         31 return ($_[0]{$_[1]} = $_[2]); 5844             } 5845               5846             sub _mutate_dump_headers { 5847 22     22   62 my ( $self, $name, $value, $args ) = @_; 5848 22 50       82 if ( $value =~ m/ \A --? /smx ) { 5849 0         0 $value = 0; 5850 0         0 my $go = Getopt::Long::Parser->new(); 5851 0         0 $go->configure( qw{ require_order } ); 5852             $go->getoptionsfromarray( 5853             $args, 5854 0         0 map {; "$_!" => sub { 5855 0 0   0   0 $_[1] and do { 5856 0         0 my $method = "DUMP_\U$_[0]"; 5857 0         0 $value |= $self->$method(); 5858             }; 5859 0         0 return; 5860             } 5861 0         0 } @dump_options 5862             ); 5863 0         0 push @{ $args }, $value; # Since caller pops it.   0         0   5864             } else { 5865 22 50       58 $value =~ m/ \A 0 (?: [0-7]+ | x [[:xdigit:]]+ ) \z /smx 5866             and $value = oct $value; 5867             } 5868 22         62 return ( $self->{$name} = $value ); 5869             } 5870               5871             { 5872             my %id_file_name = ( 5873             MSWin32 => sub { 5874             my $home = $ENV{HOME} || $ENV{USERPROFILE} || join '', 5875             $ENV{HOMEDRIVE}, $ENV{HOMEPATH}; 5876             return "$home\\spacetrack.id"; 5877             }, 5878             VMS => sub { 5879             my $home = $ENV{HOME} || 'sys$login'; 5880             return "$home:spacetrack.id"; 5881             }, 5882             ); 5883               5884             sub __identity_file_name { 5885             my $id_file = ( $id_file_name{$^O} || sub { 5886 0     0   0 return join '/', $ENV{HOME}, '.spacetrack-identity' } 5887 0   0 0   0 )->(); 5888 0         0 my $gpg_file = "$id_file.gpg"; 5889 0 0       0 -e $gpg_file 5890             and return $gpg_file; 5891 0         0 return $id_file; 5892             } 5893               5894             } 5895               5896             # This basically duplicates the logic in Config::Identity 5897             sub __identity_file_is_encrypted { 5898 0     0   0 my $fn = __identity_file_name(); 5899 0 0       0 -B $fn 5900             and return 1; 5901 0 0       0 open my $fh, '<:encoding(utf-8)', $fn 5902             or return; 5903 0         0 local $/ = undef; 5904 0         0 my $content = <$fh>; 5905 0         0 close $fh; 5906 0         0 return $content =~ m/ \Q----BEGIN PGP MESSAGE----\E /smx; 5907             } 5908               5909             sub _mutate_identity { 5910 14     14   32 my ( $self, $name, $value ) = @_; 5911             defined $value 5912 14 50       55 or $value = $ENV{SPACETRACK_IDENTITY}; 5913 14 50 33     53 if ( $value and my $identity = __spacetrack_identity() ) { 5914 0         0 $self->set( %{ $identity } );   0         0   5915             } 5916 14         36 return ( $self->{$name} = $value ); 5917             } 5918               5919             =for html 5920               5921             =item Astro::SpaceTrack->flush_identity_cache(); 5922               5923             The identity file is normally read only once, and the data cached. This 5924             static method flushes the cache to force the identity data to be reread. 5925               5926             =cut 5927               5928             { 5929             my $identity; 5930             my $loaded; 5931               5932             sub flush_identity_cache { 5933 0     0 1 0 $identity = $loaded = undef; 5934 0         0 return; 5935             } 5936               5937             sub __spacetrack_identity { 5938 0 0   0   0 $loaded 5939             and return $identity; 5940 0         0 $loaded = 1; 5941 0         0 my $fn = __identity_file_name(); 5942 0 0       0 -f $fn 5943             or return $identity; 5944             { 5945 0         0 local $@ = undef;   0         0   5946 0 0       0 eval { 5947 0         0 require Config::Identity; 5948 0         0 $identity = { Config::Identity->load( $fn ) }; 5949 0         0 1; 5950             } or return; 5951             } 5952 0         0 foreach my $key ( qw{ username password } ) { 5953 0 0       0 exists $identity->{$key} 5954             or Carp::croak "Identity file omits $key"; 5955             } 5956 0 0       0 scalar keys %{ $identity } > 2   0         0   5957             and Carp::croak 'Identity file defines keys besides username and password'; 5958 0         0 return $identity; 5959             } 5960             } 5961               5962             { 5963             my %need_logout = map { $_ => 1 } qw{ domain_space_track }; 5964               5965             sub _mutate_spacetrack_interface { 5966 0     0   0 my ( $self, $name, $value ) = @_; 5967 0         0 my $version = $self->{space_track_version}; 5968               5969             my $spacetrack_interface_info = 5970 0         0 $self->{_space_track_interface}[$version]; 5971               5972 0 0       0 exists $spacetrack_interface_info->{$name} 5973             or Carp::croak "Can not set $name for interface version $version"; 5974               5975 0 0       0 $need_logout{$name} 5976             and $self->logout(); 5977               5978 0         0 return ( $spacetrack_interface_info->{$name} = $value ); 5979             } 5980             } 5981               5982             sub _access_spacetrack_interface { 5983 0     0   0 my ( $self, $name ) = @_; 5984 0         0 my $version = $self->{space_track_version}; 5985             my $spacetrack_interface_info = 5986 0         0 $self->{_space_track_interface}[$version]; 5987 0 0       0 exists $spacetrack_interface_info->{$name} 5988             or Carp::croak "Can not get $name for interface version $version"; 5989 0         0 return $spacetrack_interface_info->{$name}; 5990             } 5991               5992             # _mutate_authen clears the session cookie and then sets the 5993             # desired attribute 5994               5995             # This clears the session cookie and cookie expiration, then co-routines 5996             # off to _mutate attrib. 5997             sub _mutate_authen { 5998 4     4   16 $_[0]->logout(); 5999 4         154 goto &_mutate_attrib; 6000             } 6001               6002             # This subroutine just does some argument checking and then co-routines 6003             # off to _mutate_attrib. 6004             sub _mutate_iridium_status_format { 6005             Carp::croak "Error - Illegal status format '$_[2]'" 6006 0 0   0   0 unless $catalogs{iridium_status}{$_[2]}; 6007 0         0 $_[0]->_deprecation_notice( iridium_status_format => $_[2] ); 6008 0         0 goto &_mutate_attrib; 6009             } 6010               6011             # _mutate_number croaks if the value to be set is not numeric. 6012             # Otherwise it sets the value. Only unsigned integers pass. 6013               6014             # This subroutine just does some argument checking and then co-routines 6015             # off to _mutate_attrib. 6016             sub _mutate_number { 6017 0 0   0   0 $_[2] =~ m/ \D /smx and Carp::croak <<"EOD"; 6018             Attribute $_[1] must be set to a numeric value. 6019             EOD 6020 0         0 goto &_mutate_attrib; 6021             } 6022               6023             # _mutate_space_track_version() mutates the version of the interface 6024             # used to retrieve data from Space Track. Valid values are 1 and 2, with 6025             # any false value causing the default to be set. 6026               6027             sub _mutate_space_track_version { 6028 2     2   5 my ( $self, $name, $value ) = @_; 6029 2 50       4 $value 6030             or $value = DEFAULT_SPACE_TRACK_VERSION; 6031             $value =~ m/ \A \d+ \z /smx 6032 2 50 33     21 and $self->{_space_track_interface}[$value] 6033             or Carp::croak "Invalid Space Track version $value"; 6034             ## $self->_deprecation_notice( $name => $value ); 6035 2 50       6 $value == 1 6036             and Carp::croak 'The version 1 SpaceTrack interface stopped working July 16 2013 at 18:00 UT'; 6037 2         5 return ( $self->{$name} = $value ); 6038             } 6039               6040             # _mutate_verify_hostname mutates the verify_hostname attribute. 6041             # Since the value of this gets fed to LWP::UserAgent->new() to 6042             # instantiate the {agent} attribute, we delete that attribute 6043             # before changing the value, relying on $self->_get_agent() to 6044             # instantiate it appropriately if needed -- and on any code that 6045             # uses the agent to go through this private method to get it. 6046               6047             sub _mutate_verify_hostname { 6048 1     1   1 delete $_[0]->{agent}; 6049 1         3 goto &_mutate_attrib; 6050             } 6051               6052             # _no_such_catalog takes as arguments a source and catalog name, 6053             # and returns the appropriate HTTP::Response object based on the 6054             # current verbosity setting. 6055               6056             { 6057               6058             my %no_such_name = ( 6059             celestrak => 'CelesTrak', 6060             spacetrack => 'Space Track', 6061             ); 6062               6063             sub _no_such_catalog { 6064 3     3   12 my ( $self, $source, @args ) = @_; 6065               6066 3 50       14 my $info = $catalogs{$source} 6067             or Carp::confess "Bug - No such source as '$source'"; 6068               6069 3 100       13 if ( ARRAY_REF eq ref $info ) { 6070 1         2 my $inx = shift @args; 6071 1 50       4 $info = $info->[$inx] 6072             or Carp::confess "Bug - Illegal index $inx ", 6073             "for '$source'"; 6074             } 6075               6076 3         8 my ( $catalog, $note ) = @args; 6077               6078 3   66     12 my $name = $no_such_name{$source} || $source; 6079               6080             my $lead = defined $catalog ? 6081 3 50       16 $info->{$catalog} ?     50           6082             "$name '$catalog' missing" : 6083             "$name '$catalog' not found" : 6084             "$name item not defined"; 6085 3 50       9 $lead .= defined $note ? " ($note)." : '.'; 6086               6087             return HTTP::Response->new (HTTP_NOT_FOUND, "$lead\n") 6088 3 50       33 unless $self->{verbose}; 6089               6090 0         0 my $resp = $self->names ($source); 6091 0         0 return HTTP::Response->new (HTTP_NOT_FOUND, 6092             join '', "$lead Try one of:\n", $resp->content, 6093             ); 6094             } 6095               6096             } 6097               6098             # _parse_args parses options off an argument list. The first 6099             # argument must be a list reference of options to be parsed. 6100             # This list is pairs of values, the first being the Getopt::Long 6101             # specification for the option, and the second being a description 6102             # of the option suitable for help text. Subsequent arguments are 6103             # the arguments list to be parsed. It returns a reference to a 6104             # hash containing the options, followed by any remaining 6105             # non-option arguments. If the first argument after the list 6106             # reference is a hash reference, it simply returns. 6107               6108             { 6109             my $go = Getopt::Long::Parser->new(); 6110               6111             sub _parse_args { 6112 99     99   257 my ( $lgl_opts, @args ) = @_; 6113 99 100       308 unless ( ARRAY_REF eq ref $lgl_opts ) { 6114 14         51 unshift @args, $lgl_opts; 6115 14         182 ( my $caller = ( caller 1 )[3] ) =~ s/ ( .* ) :: //smx; 6116 14         63 my $pkg = $1; 6117 14 50       175 my $code = $pkg->can( "_${caller}_opts" ) 6118             or Carp::confess "Bug - _${caller}_opts not found"; 6119 14         40 $lgl_opts = $code->(); 6120             } 6121 99         175 my $opt; 6122 99 100       248 if ( HASH_REF eq ref $args[0] ) { 6123 18         23 $opt = { %{ shift @args } }; # Poor man's clone.   18         59   6124             # Validation is new, so I insert a hack to turn it off if need 6125             # be. 6126 18 50       48 unless ( $ENV{SPACETRACK_SKIP_OPTION_HASH_VALIDATION} ) { 6127 18         50 my %lgl = _extract_keys( $lgl_opts ); 6128 18         35 my @bad; 6129 18         25 foreach my $key ( keys %{ $opt } ) {   18         46   6130 47 50       98 $lgl{$key} 6131             or push @bad, $key; 6132             } 6133             @bad 6134             and _parse_args_failure( 6135             carp => 1, 6136             name => \@bad, 6137 18 50       51 legal => { @{ $lgl_opts } },   0         0   6138             suffix => <<'EOD', 6139               6140             You cam suppress this warning by setting environment variable 6141             SPACETRACK_SKIP_OPTION_HASH_VALIDATION to a value Perl understands as 6142             true (say, like 1), but this should be considered a stopgap while you 6143             fix the calling code, or have it fixed, since my plan is to make this 6144             fatal. 6145             EOD 6146             ); 6147             } 6148             } else { 6149 81         131 $opt = {}; 6150 81         119 my %lgl = @{ $lgl_opts };   81         654   6151 81 50       617 $go->getoptionsfromarray( 6152             \@args, 6153             $opt, 6154             keys %lgl, 6155             ) 6156             or _parse_args_failure( legal => \%lgl ); 6157             } 6158 99         59029 return ( $opt, @args ); 6159             } 6160             } 6161               6162             sub _parse_args_failure { 6163 0     0   0 my %arg = @_; 6164 0 0       0 my $msg = $arg{carp} ? 'Warning - ' : 'Error - '; 6165 0 0       0 if ( defined $arg{name} ) { 6166             my @names = ( ARRAY_REF eq ref $arg{name} ) ? 6167 0         0 @{ $arg{name} } : 6168 0 0       0 $arg{name}; 6169             @names 6170 0 0       0 or return; 6171 0 0       0 my $opt = @names > 1 ? 'Options' : 'Option'; 6172 0         0 my $txt = join ', ', map { "-$_" } sort @names;   0         0   6173 0         0 $msg .= "$opt $txt illegal.\n"; 6174             } 6175 0 0       0 if ( defined $arg{legal} ) { 6176 0         0 $msg .= "Legal options are\n"; 6177 0         0 foreach my $opt ( sort keys %{ $arg{legal} } ) {   0         0   6178 0         0 my $desc = $arg{legal}{$opt}; 6179 0         0 $opt = _extract_keys( $opt ); 6180 0         0 $msg .= " -$opt - $desc\n"; 6181             } 6182 0         0 $msg .= <<"EOD"; 6183             with dates being either Perl times, or numeric year-month-day, with any 6184             non-numeric character valid as punctuation. 6185             EOD 6186             } 6187             defined $arg{suffix} 6188 0 0       0 and $msg .= $arg{suffix}; 6189             $arg{carp} 6190 0 0       0 or Carp::croak $msg; 6191 0         0 Carp::carp $msg; 6192 0         0 return; 6193             } 6194               6195             # Parse an international launch ID in the form yyyy-sssp or yysssp. 6196             # In the yyyy-sssp form, the year can be two digits (in which case 57-99 6197             # are 1957-1999 and 00-56 are 2000-2056) and the dash can be any 6198             # non-alpha, non-digit, non-space character. In either case, trailing 6199             # fields are optional. If provided, the part ('p') can be multiple 6200             # alphabetic characters. Only fields actually specified will be 6201             # returned. 6202               6203             sub _parse_international_id { 6204 14     14   21 my ( $intl_id ) = @_; 6205 14         36 my ( $year, $launch, $part ); 6206               6207 14 50       95 if ( $intl_id =~     50           6208             m< \A ( \d+ ) [^[:alpha:][:digit:]\s] 6209             (?: ( \d{1,3} ) ( [[:alpha:]]* ) )? \z >smx 6210             ) { 6211 0         0 ( $year, $launch, $part ) = ( $1, $2, $3 ); 6212             } elsif ( $intl_id =~ 6213             m< \A ( \d\d ) (?: ( \d{3} ) ( [[:alpha:]]* ) )? >smx 6214             ) { 6215 14         48 ( $year, $launch, $part ) = ( $1, $2, $3 ); 6216             } else { 6217 0         0 return; 6218             } 6219               6220 14 50       52 $year += $year < 57 ? 2000 : $year < 100 ? 1900 : 0;     50           6221 14         22 my @parts = ( $year ); 6222 14 100       26 $launch 6223             or return @parts; 6224 13         15 push @parts, $launch; 6225 13 100       28 $part 6226             and push @parts, uc $part; 6227 13         31 return @parts; 6228             } 6229               6230             # Parse a date in the form yyyy-mm-dd, with either two- or four-digit 6231             # year, and month and day optional. The year is normalized to four 6232             # digits using the NORAD pivot date of 57 -- that is, 57-99 represent 6233             # 1957-1999, and 00-56 represent 2000-2056. The month and day are 6234             # optional. Only fields actually specified will be returned. 6235               6236             sub _parse_launch_date { 6237 14     14   18 my ( $date ) = @_; 6238 14 50       86 my ( $year, $month, $day ) = 6239             $date =~ m/ \A (\d+) (?:\D+ (\d+) (?: \D+ (\d+) )? )? /smx 6240             or return; 6241 14 50       43 $year += $year < 57 ? 2000 : $year < 100 ? 1900 : 0;     50           6242 14         25 my @parts = ( $year ); 6243 14 50       24 defined $month 6244             or return @parts; 6245 14         35 push @parts, $month; 6246 14 50       27 defined $day and push @parts, $day; 6247 14         74 return @parts; 6248             } 6249               6250             # _parse_retrieve_args parses the retrieve() options off its 6251             # arguments, prefixes a reference to the resultant options hash to 6252             # the remaining arguments, and returns the resultant list. If the 6253             # first argument is a list reference, it is taken as extra 6254             # options, and removed from the argument list. If the next 6255             # argument after the list reference (if any) is a hash reference, 6256             # it simply returns its argument list, under the assumption that 6257             # it has already been called. 6258               6259             { 6260               6261             my @legal_retrieve_options = ( 6262             @{ CLASSIC_RETRIEVE_OPTIONS() }, 6263             # Space Track Version 2 interface options 6264             'since_file=i' 6265             => '(Return only results added after the given file number)', 6266             'json!' => '(Return TLEs in JSON format)', 6267             'format=s' => 'Specify data format' 6268             ); 6269               6270             sub _get_retrieve_options { 6271 0     0   0 return @legal_retrieve_options; 6272             } 6273               6274             sub _parse_retrieve_args { 6275 82     82   224 my ( undef, @args ) = @_; # Invocant unused 6276 82 100       242 my $extra_options = ARRAY_REF eq ref $args[0] ? 6277             shift @args : 6278             undef; 6279               6280             ( my $opt, @args ) = _parse_args( 6281             ( $extra_options ? 6282 82 100       213 [ @legal_retrieve_options, @{ $extra_options } ] :   50         306   6283             \@legal_retrieve_options ), 6284             @args ); 6285               6286 82   66     377 $opt->{sort} ||= _validate_sort( $opt->{sort} ); 6287               6288 82         195 _retrieval_format( undef, $opt ); 6289               6290 82         209 return ( $opt, @args ); 6291             } 6292             } 6293               6294             { 6295             my @usual_formats = map { $_ => 1 } qw{ xml json html csv }; 6296             my $legacy_formats = { 6297             default => 'legacy', 6298             valid => { @usual_formats, map { $_ => 1 } qw{ legacy } }, 6299             }; 6300             my $tle_formats = { 6301             default => 'legacy', 6302             valid => { @usual_formats, map { $_ => 1 } qw{ tle 3le legacy } }, 6303             }; 6304             my %format = ( 6305             box_score => $legacy_formats, 6306             country_names => $legacy_formats, 6307             launch_sites => $legacy_formats, 6308             satcat => $legacy_formats, 6309             tle => $tle_formats, 6310             ); 6311               6312             sub _retrieval_format { 6313 91     91   158 my ( $table, $opt ) = @_; 6314             defined $table 6315 91 50       250 or $table = defined $opt->{tle} ? $opt->{tle} ? 'tle' :     100               100           6316             'satcat' : 'tle'; 6317             $opt->{json} 6318             and defined $opt->{format} 6319 91 50 100     218 and $opt->{format} ne 'json'       66         6320             and Carp::croak 'Inconsistent retrieval format specification'; 6321 91 50       197 $format{$table} 6322             or Carp::confess "Bug - $table not supported"; 6323             defined $opt->{format} 6324             or $opt->{format} = $opt->{json} ? 'json' : 6325 91 100       250 $format{$table}{default};     100           6326             exists $opt->{json} 6327 91 100       196 or $opt->{json} = 'json' eq $opt->{format}; 6328             $format{$table}{valid}{ $opt->{format} } 6329 91 50       188 or Carp::croak "Invalid $table retrieval format '$opt->{format}'"; 6330 91 100       181 return $opt->{format} eq 'legacy' ? 'json' : $opt->{format}; 6331             } 6332             } 6333               6334             # my $sort = _validate_sort( $sort ); 6335             # 6336             # Validate and canonicalize the value of the -sort option. 6337             { 6338             my %valid = map { $_ => 1 } qw{ catnum epoch }; 6339             sub _validate_sort { 6340 65     65   113 my ( $sort ) = @_; 6341 65 50       218 defined $sort 6342             or return 'catnum'; 6343 0         0 $sort = lc $sort; 6344 0 0       0 $valid{$sort} 6345             or Carp::croak "Illegal sort '$sort'"; 6346 0         0 return $sort; 6347             } 6348             } 6349               6350             # $opt = _parse_retrieve_dates ($opt); 6351               6352             # This subroutine looks for keys start_epoch and end_epoch in the 6353             # given option hash, parses them as YYYY-MM-DD (where the letters 6354             # are digits and the dashes are any non-digit punctuation), and 6355             # replaces those keys' values with a reference to a list 6356             # containing the output of timegm() for the given time. If only 6357             # one epoch is provided, the other is defaulted to provide a 6358             # one-day date range. If the syntax is invalid, we croak. 6359             # 6360             # The return is the same hash reference that was passed in. 6361               6362             sub _parse_retrieve_dates { 6363 31     31   47 my ( $opt ) = @_; 6364               6365 31         37 my $found; 6366 31         52 foreach my $key ( qw{ end_epoch start_epoch } ) { 6367               6368 62 100       129 next unless $opt->{$key}; 6369               6370 5 50       19 if ( $opt->{$key} =~ m/ \D /smx ) { 6371 5         7 my $str = $opt->{$key}; 6372 5 50       24 $str =~ m< \A 6373             ( \d+ ) \D+ ( \d+ ) \D+ ( \d+ ) 6374             (?: \D+ ( \d+ ) (?: \D+ ( \d+ ) (?: \D+ ( \d+ ) )? )? )? 6375             \z >smx 6376             or Carp::croak "Error - Illegal date '$str'"; 6377 5         23 my @time = ( $6, $5, $4, $3, $2, $1 ); 6378 5         6 foreach ( @time ) { 6379 30 100       43 defined $_ 6380             or $_ = 0; 6381             } 6382 5 50       12 if ( $time[5] > 1900 ) {     0           6383 5         8 $time[5] -= 1900; 6384             } elsif ( $time[5] < 57 ) { 6385 0         0 $time[5] += 100; 6386             } 6387 5         6 $time[4] -= 1; 6388 5 50       7 eval { 6389 5         18 $opt->{$key} = Time::Local::timegm( @time ); 6390 5         166 1; 6391             } or Carp::croak "Error - Illegal date '$str'"; 6392             } 6393               6394 5         9 $found++; 6395             } 6396               6397 31 100       56 if ( $found ) { 6398               6399 4 100       17 if ( $found == 1 ) { 6400 3   66     13 $opt->{start_epoch} ||= $opt->{end_epoch} - 86400; 6401 3   66     14 $opt->{end_epoch} ||= $opt->{start_epoch} + 86400; 6402             } 6403               6404 4 50       10 $opt->{start_epoch} <= $opt->{end_epoch} or Carp::croak <<'EOD'; 6405             Error - End epoch must not be before start epoch. 6406             EOD 6407               6408 4         6 foreach my $key ( qw{ start_epoch end_epoch } ) { 6409               6410 8         24 my @time = reverse( ( gmtime $opt->{$key} )[ 0 .. 5 ] ); 6411 8         16 $time[0] += 1900; 6412 8         8 $time[1] += 1; 6413 8         35 $opt->{"_$key"} = \@time; 6414               6415             } 6416             } 6417               6418 31         59 return $opt; 6419             } 6420               6421             # _parse_search_args parses the search_*() options off its 6422             # arguments, prefixes a reference to the resultant options 6423             # hash to the remaining arguments, and returns the resultant 6424             # list. If the first argument is a hash reference, it validates 6425             # that the hash contains only legal options. 6426               6427               6428             { 6429               6430             my %status_query = ( 6431             onorbit => 'null-val', 6432             decayed => '<>null-val', 6433             all => '', 6434             ); 6435               6436             my %include_map = ( 6437             payload => 'PAYLOAD', 6438             rocket => 'ROCKET BODY', 6439             debris => 'DEBRIS', 6440             unknown => 'UNKNOWN', 6441             tba => 'TBA', 6442             other => 'OTHER', 6443             ); 6444               6445             sub _convert_search_options_to_rest { 6446 50     50   75 my ( undef, $opt ) = @_; # Invocant unused 6447 50         67 my %rest; 6448               6449 50 50       80 if ( defined $opt->{status} ) { 6450             defined ( my $query = $status_query{$opt->{status}} ) 6451 50 50       108 or Carp::croak "Unknown status '$opt->{status}'"; 6452             $query 6453 50 100       119 and $rest{DECAY} = $query; 6454             } 6455               6456             { 6457 50         55 my %incl;   50         72   6458               6459 50 100 66     103 if ( $opt->{exclude} && @{ $opt->{exclude} } ) {   50         113   6460 12         25 %incl = map { $_ => 1 } keys %include_map;   72         98   6461 12         23 foreach ( @{ $opt->{exclude} } ) {   12         16   6462 18 50       57 $include_map{$_} 6463             or Carp::croak "Unknown exclusion '$_'"; 6464 18         26 delete $incl{$_}; 6465             } 6466             } 6467               6468 50 100 66     97 if ( $opt->{include} && @{ $opt->{include} } ) {   50         96   6469 1         2 foreach ( @{ $opt->{include} } ) {   1         2   6470 1 50       4 $include_map{$_} 6471             or Carp::croak "Unknown inclusion '$_'"; 6472 1         2 $incl{$_} = 1; 6473             } 6474             } 6475               6476             keys %incl 6477             and $rest{OBJECT_TYPE} = join ',', 6478 50 100       138 map { $include_map{$_} } sort keys %incl;   55         97   6479               6480             } 6481               6482 50         87 return \%rest; 6483             } 6484               6485             my @legal_search_args = ( 6486             'rcs!' => '(ignored and deprecated)', 6487             'tle!' => '(return TLE data from search (defaults true))', 6488             'status=s' => q{('onorbit', 'decayed', or 'all')}, 6489             'exclude=s@' => q{('payload', 'debris', 'rocket', ... )}, 6490             'include=s@' => q{('payload', 'debris', 'rocket', ... )}, 6491             'comment!' => '(include comment in satcat data)', 6492             ); 6493             my %legal_search_status = map {$_ => 1} qw{onorbit decayed all}; 6494               6495             sub _get_search_options { 6496 0     0   0 return \@legal_search_args; 6497             } 6498               6499             sub _parse_search_args { 6500 50     50   126 my ( $self, @args ) = @_; 6501               6502 50 50       148 my $extra = ARRAY_REF eq ref $args[0] ? shift @args : []; 6503             @args = $self->_parse_retrieve_args( 6504 50         111 [ @legal_search_args, @{ $extra } ], @args );   50         239   6505               6506 50         100 my $opt = $args[0]; 6507               6508 50   100     148 $opt->{status} ||= 'onorbit'; 6509               6510 50 50       104 $legal_search_status{$opt->{status}} or Carp::croak <<"EOD"; 6511             Error - Illegal status '$opt->{status}'. You must specify one of 6512 0         0 @{[join ', ', map {"'$_'"} sort keys %legal_search_status]}   0         0   6513             EOD 6514               6515 50         74 foreach my $key ( qw{ exclude include } ) { 6516 100   100     332 $opt->{$key} ||= []; 6517 100         110 $opt->{$key} = [ map { split ',', $_ } @{ $opt->{$key} } ];   16         42     100         161   6518 100         120 foreach ( @{ $opt->{$key} } ) {   100         182   6519 19 50       42 $include_map{$_} or Carp::croak <<"EOD"; 6520             Error - Illegal -$key value '$_'. You must specify one or more of 6521 0         0 @{[join ', ', map {"'$_'"} sort keys %include_map]}   0         0   6522             EOD 6523             } 6524             } 6525               6526             defined $opt->{tle} 6527 50 100       149 or $opt->{tle} = 1; 6528               6529 50         123 return @args; 6530             } 6531               6532             my %search_opts = _extract_keys( \@legal_search_args ); 6533               6534             # _remove_search_options 6535             # 6536             # Shallow clone the argument hash, remove any search arguments from 6537             # it, and return a reference to the clone. Used for sanitizing the 6538             # options for a search before passing them to retrieve() to actually 6539             # get the TLEs. 6540             sub _remove_search_options { 6541 14     14   20 my ( $opt ) = @_; 6542 14         20 my %rslt = %{ $opt };   14         86   6543 14         56 delete @rslt{ keys %search_opts }; 6544 14         27 return \%rslt; 6545             } 6546             } 6547               6548             # @keys = _sort_rest_arguments( \%rest_args ); 6549             # 6550             # This subroutine sorts the argument names in the desired order. 6551             # A better way to do this may be to use Unicode::Collate, which 6552             # has been core since 5.7.3. 6553               6554             { 6555               6556             my %special = map { $_ => 1 } qw{ basicspacedata extendedspacedata }; 6557               6558             sub _sort_rest_arguments { 6559 86     86   120 my ( $rest_args ) = @_; 6560               6561 86 50       158 HASH_REF eq ref $rest_args 6562             or return; 6563               6564 86         92 my @rslt; 6565               6566 86         143 foreach my $key ( keys %special ) { 6567             @rslt 6568 172 50       232 and Carp::croak "You may not specify both '$rslt[0]' and '$key'"; 6569             defined $rest_args->{$key} 6570 172 50       252 and push @rslt, $key, $rest_args->{$key}; 6571             } 6572               6573               6574 521         939 push @rslt, map { ( $_->[0], $rest_args->{$_->[0]} ) } 6575 866         1019 sort { $a->[1] cmp $b->[1] } 6576             # Oh, for 5.14 and tr///r 6577 521         602 map { [ $_, _swap_upper_and_lower( $_ ) ] } 6578 521         669 grep { ! $special{$_} } 6579 86         143 keys %{ $rest_args };   86         182   6580               6581 86         498 return @rslt; 6582             } 6583             } 6584               6585             sub _spacetrack_v2_response_is_empty { 6586 0     0   0 my ( $resp ) = @_; 6587 0         0 return $resp->content() =~ m/ \A \s* (?: [[] \s* []] )? \s* \z /smx; 6588             } 6589               6590             sub __readline_completer { 6591 0     0   0 my ( $app, $text, $line, $start ) = @_; 6592               6593 0 0       0 $start 6594             or return $app->_readline_complete_command( $text ); 6595               6596 0         0 my ( $cmd, @cmd_line ) = split $readline_word_break_re, $line, -1; 6597 0         0 $cmd = _verb_alias( $cmd ); 6598               6599 0         0 local $COMPLETION_APP = $app; 6600               6601 0 0       0 if ( my $code = $app->can( "_readline_complete_command_$cmd" ) ) { 6602 0         0 return $code->( $app, $text, $line, $start, \@cmd_line ); 6603             } 6604               6605 0 0 0     0 if ( $text =~ m/ \A - /smx and my $code = $app->can( "_${cmd}_opts") ) { 6606 0         0 return _readline_complete_options( $code, $text ); 6607             } 6608               6609               6610 0 0       0 $catalogs{$cmd} 6611             and return $app->_readline_complete_catalog( $text, $cmd ); 6612               6613 0         0 my @files = File::Glob::bsd_glob( "$text*" ); 6614 0 0       0 if ( 1 == @files ) {     0           6615 0 0       0 $files[0] .= -d $files[0] ? '/' : ' '; 6616             } elsif ( $readline::var_CompleteAddsuffix ) { 6617 0         0 foreach ( @files ) { 6618 0 0 0     0 if ( -l $_ ) {     0               0               0           6619 0         0 $_ .= '@'; 6620             } elsif ( -d $_ ) { 6621 0         0 $_ .= '/'; 6622             } elsif ( -x _) { 6623 0         0 $_ .= '*'; 6624             } elsif ( -S _ || -p _ ) { 6625 0         0 $_ .= '='; 6626             } 6627             } 6628             } 6629 0         0 $readline::rl_completer_terminator_character = ''; 6630 0         0 return @files; 6631             } 6632               6633             sub _readline_complete_catalog { 6634 0     0   0 my ( $app, $text, $cat ) = @_; 6635 0         0 my $this_cat = $catalogs{$cat}; 6636 0 0       0 if ( ARRAY_REF eq ref $this_cat ) { 6637 0 0       0 my $code = $app->can( "_${cat}_catalog_version" ) 6638             or Carp::confess "Bug - _${cat}_catalog_version() not found"; 6639 0         0 $this_cat = $this_cat->[ $code->( $app ) ]; 6640             } 6641             defined $text 6642             and $text ne '' 6643 0 0 0     0 or return( sort keys %{ $this_cat } );   0         0   6644 0         0 my $re = qr/ \A \Q$text\E /smx; 6645 0         0 return ( grep { $_ =~ $re } sort keys %{ $this_cat } )   0         0     0         0   6646             } 6647               6648             { 6649             my @builtins; 6650             my %disallow = map { $_ => 1 } qw{ 6651             can getv import isa new 6652             }; 6653             sub _readline_complete_command { 6654 0     0   0 my ( $app, $text ) = @_; 6655 0 0       0 unless ( @builtins ) { 6656 0         0 push @builtins, qw{ bye exit show }; 6657 0   0     0 my $stash = ( ref $app || $app ) . '::'; 6658 7     7   63 no strict qw{ refs };   7         12     7         10757   6659 0         0 foreach my $sym ( keys %$stash ) { 6660 0 0       0 $sym =~ m/ \A _ /smx 6661             and next; 6662 0 0       0 $sym =~ m/ [[:upper:]] /smx 6663             and next; 6664 0 0       0 $disallow{$sym} 6665             and next; 6666 0 0       0 $app->can( $sym ) 6667             or next; 6668 0         0 push @builtins, $sym; 6669             } 6670 0         0 @builtins = sort @builtins; 6671             } 6672 0         0 my $match = qr< \A \Q$text\E >smx; 6673 0         0 my @rslt = grep { $_ =~ $match } @builtins;   0         0   6674 0 0 0     0 1 == @rslt 6675             and $rslt[0] =~ m/ \W \z /smx 6676             and $readline::rl_completer_terminator_character = ''; 6677 0         0 return ( sort @rslt ); 6678             } 6679             } 6680               6681             sub _readline_complete_options { 6682 0     0   0 my ( $code, $text ) = @_; 6683 0 0       0 $text =~ m/ \A ( --? ) ( .* ) /smx 6684             or return; 6685             # my ( $prefix, $match ) = ( $1, $2 ); 6686 0         0 my $match = $2; 6687 0         0 my %lgl = @{ $code->() };   0         0   6688 0         0 my $re = qr< \A \Q$match\E >smx; 6689 0         0 my @rslt; 6690 0         0 foreach ( keys %lgl ) { 6691 0         0 my $type = ''; 6692 0 0       0 ( my $o = $_ ) =~ s/ ( [!=?] ) .* //smx 6693             and $type = $1; 6694 0         0 my @names = split qr< \| >smx, $o; 6695             $type eq q 6696 0 0       0 and push @names, map { "no-$_" } @names;   0         0   6697 0         0 push @rslt, map { "--$_" } grep { $_ =~ $re } @names;   0         0     0         0   6698             } 6699 0         0 return ( sort @rslt ); 6700             } 6701               6702             sub _rest_date { 6703 8     8   12 my ( $time ) = @_; 6704 8         10 return sprintf '%04d-%02d-%02d %02d:%02d:%02d', @{ $time };   8         35   6705             } 6706               6707             # $swapped = _swap_upper_and_lower( $original ); 6708             # 6709             # This subroutine swapps upper and lower case in its argument, 6710             # using the transliteration operator. It should be used only by 6711             # _sort_rest_arguments(). This can go away in favor of tr///r when 6712             # (if!) the minimum version becomes 5.14. 6713               6714             sub _swap_upper_and_lower { 6715 521     521   633 my ( $arg ) = @_; 6716 521         609 $arg =~ tr/A-Za-z/a-zA-Z/; 6717 521         1064 return $arg; 6718             } 6719               6720             # _source takes a filename, and returns the contents of the file 6721             # as a list. It dies if anything goes wrong. 6722               6723             sub _source { 6724 0     0   0 my ( undef, $fn ) = @_; # Invocant unused 6725 0 0       0 wantarray or die <<'EOD'; 6726             Error - _source () called in scalar or no context. This is a bug. 6727             EOD 6728 0 0       0 defined $fn or die <<'EOD'; 6729             Error - No source file name specified. 6730             EOD 6731 0 0       0 my $fh = IO::File->new ($fn, '<') or die <<"EOD"; 6732             Error - Failed to open source file '$fn'. 6733             $! 6734             EOD 6735 0         0 return <$fh>; 6736             } 6737               6738             # my $string = _stringify_oid_list( $opt, @oids ); 6739             # 6740             # This subroutine sorts the @oids array, and stringifies it by 6741             # eliminating duplicates, combining any consecutive runs of OIDs into 6742             # ranges, and joining the result with commas. The string is returned. 6743             # 6744             # The $opt is a reference to a hash that specifies punctuation in the 6745             # stringified result. The keys used are 6746             # separator -- The string used to separate OID specifications. The 6747             # default is ','. 6748             # range_operator -- The string used to specify a range. If omitted, 6749             # ranges will not be constructed. 6750             # 6751             # Note that ranges containing only two OIDs (e.g. 5-6) will be expanded 6752             # as "5,6", not "5-6" (presuming $range_operator is '-'). 6753               6754             sub _stringify_oid_list { 6755 44     44   90 my ( $opt, @args ) = @_; 6756               6757 44         67 my @rslt = ( -99 ); # Prime the pump 6758               6759             @args 6760 44 50       62 or return @args; 6761               6762 44 50       99 my $separator = defined $opt->{separator} ? $opt->{separator} : ','; 6763 44         54 my $range_operator = $opt->{range_operator}; 6764               6765 44 50       71 if ( defined $range_operator ) { 6766 44         104 foreach my $arg ( sort { $a <=> $b } @args ) {   201         210   6767 210 100       270 if ( ARRAY_REF eq ref $rslt[-1] ) { 6768 151 100       164 if ( $arg == $rslt[-1][1] + 1 ) { 6769 147         153 $rslt[-1][1] = $arg; 6770             } else { 6771 4 50       11 $arg > $rslt[-1][1] 6772             and push @rslt, $arg; 6773             } 6774             } else { 6775 59 100       107 if ( $arg == $rslt[-1] + 1 ) { 6776 11         22 $rslt[-1] = [ $rslt[-1], $arg ]; 6777             } else { 6778 48 50       114 $arg > $rslt[-1] 6779             and push @rslt, $arg; 6780             } 6781             } 6782             } 6783 44         58 shift @rslt; # Drop the pump priming. 6784               6785             return join( $separator, 6786 44         65 map { ref $_ ? 6787             $_->[1] > $_->[0] + 1 ? 6788             "$_->[0]$range_operator$_->[1]" : 6789 52 100       259 @{ $_ } :   1 100       7   6790             $_ 6791             } @rslt 6792             ); 6793               6794             } else { 6795 0         0 return join $separator, sort { $a <=> $b } @args;   0         0   6796             } 6797               6798             } 6799               6800             eval { 6801             require Time::HiRes; 6802             *_sleep = \&Time::HiRes::sleep; 6803             *_time = \&Time::HiRes::time; 6804             1; 6805             } or do { 6806             *_sleep = sub { 6807             return sleep $_[0]; 6808             }; 6809             *_time = sub { 6810             return time; 6811             }; 6812             }; 6813               6814             # _trim replaces undefined arguments with '', trims all arguments 6815             # front and back, and returns the modified arguments. 6816               6817             sub _trim { 6818 3     3   10 my @args = @_; 6819 3         8 foreach ( @args ) { 6820 3 50       9 defined $_ or $_ = ''; 6821 3         13 s/ \A \s+ //smx; 6822 3         13 s/ \s+ \z //smx; 6823             } 6824 3         6 return @args; 6825             } 6826               6827             1; 6828               6829             __END__