File Coverage

blib/lib/Astro/SpaceTrack.pm
Criterion Covered Total %
statement 1071 1699 63.0
branch 399 920 43.3
condition 83 215 38.6
subroutine 164 221 74.2
pod 36 40 90.0
total 1753 3095 56.6


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

Error, Corrupted session cookie
5547             # Please LOGIN again.
5548             #

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