File Coverage

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


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

Error, Corrupted session cookie
5543             # Please LOGIN again.
5544             #

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