Astro::SpaceTrack - Retrieve orbital data from www.space-track.org.

 my $st = Astro::SpaceTrack->new (username => $me,
     password => $secret, with_name => 1) or die;
 my $rslt = $st->spacetrack ('special');
 print $rslt->is_success ? $rslt->content :
     $rslt->status_line;

 perl -MAstro::SpaceTrack=shell -e shell

 (some banner text gets printed here)

 SpaceTrack> set username me password secret
 OK
 SpaceTrack> set with_name 1
 OK
 SpaceTrack> spacetrack special >special.txt
 SpaceTrack> celestrak visual >visual.txt
 SpaceTrack> exit

package Astro::SpaceTrack;

use 5.006002;

use strict;
use warnings;

use base qw{Exporter};

our $VERSION = '0.052';
our @EXPORT_OK = qw{shell BODY_STATUS_IS_OPERATIONAL BODY_STATUS_IS_SPARE
    BODY_STATUS_IS_TUMBLING};
our %EXPORT_TAGS = (
    status => [qw{BODY_STATUS_IS_OPERATIONAL BODY_STATUS_IS_SPARE
	BODY_STATUS_IS_TUMBLING}],
);

use Astro::SpaceTrack::Parser;
use Carp;
use Compress::Zlib ();
use Getopt::Long;
use IO::File;
use HTTP::Response;	# Not in the base, but comes with LWP.
use HTTP::Status qw{RC_NOT_FOUND RC_OK RC_PRECONDITION_FAILED
	RC_UNAUTHORIZED RC_INTERNAL_SERVER_ERROR};	# Not in the base, but comes with LWP.
use LWP::UserAgent;	# Not in the base.
use POSIX qw{strftime};
use Scalar::Util 1.07 qw{ blessed };
use Text::ParseWords;
use Time::Local;

use constant COPACETIC => 'OK';
use constant BAD_SPACETRACK_RESPONSE =>
	'Unable to parse SpaceTrack response';
use constant INVALID_CATALOG =>
	'Catalog name %s invalid. Legal names are %s.';
use constant LOGIN_FAILED => 'Login failed';
use constant NO_CREDENTIALS => 'Username or password not specified.';
use constant NO_CAT_ID => 'No catalog IDs specified.';
use constant NO_OBJ_NAME => 'No object name specified.';
use constant NO_RECORDS => 'No records found.';

use constant SESSION_PATH => '/';
use constant SESSION_KEY => 'spacetrack_session';

my %catalogs = (	# Catalog names (and other info) for each source.
    celestrak => {
	sts => {name => 'Current Space Shuttle Mission (if any)'},
	'tle-new' => {name => "Last 30 Days' Launches"},
	stations => {name => 'International Space Station'},
	visual => {name => '100 (or so) brightest'},
	weather => {name => 'Weather'},
	noaa => {name => 'NOAA'},
	goes => {name => 'GOES'},
	resource => {name => 'Earth Resources'},
	sarsat => {name => 'Search and Rescue (SARSAT)'},
	dmc => {name => 'Disaster Monitoring'},
	tdrss => {name => 'Tracking and Data Relay Satellite System (TDRSS)'},
	geo => {name => 'Geostationary'},
	intelsat => {name => 'Intelsat'},
	gorizont => {name => 'Gorizont'},
	raduga => {name => 'Raduga'},
	molniya => {name => 'Molniya'},
	iridium => {name => 'Iridium'},
	orbcomm => {name => 'Orbcomm'},
	globalstar => {name => 'Globalstar'},
	amateur => {name => 'Amateur Radio'},
	'x-comm' => {name => 'Experimental Communications'},
	'other-comm' => {name => 'Other communications'},
	'gps-ops' => {name => 'GPS Operational'},
	'glo-ops' => {name => 'Glonass Operational'},
	galileo => {name => 'Galileo'},
	sbas => {name =>
	    'Satellite-Based Augmentation System (WAAS/EGNOS/MSAS)'},
	nnss => {name => 'Navy Navigation Satellite System (NNSS)'},
	musson => {name => 'Russian LEO Navigation'},
	science => {name => 'Space and Earth Science'},
	geodetic => {name => 'Geodetic'},
	engineering => {name => 'Engineering'},
	education => {name => 'Education'},
	military => {name => 'Miscellaneous Military'},
	radar => {name => 'Radar Calibration'},
	cubesat => {name => 'CubeSats'},
	other => {name => 'Other'},
    },
    iridium_status => {
	kelso => {name => 'Celestrak (Kelso)'},
	mccants => {name => 'McCants'},
	sladen => {name => 'Sladen'},
    },
    spaceflight => {
	iss => {name => 'International Space Station',
	    url => 'http://spaceflight.nasa.gov/realdata/sightings/SSapplications/Post/JavaSSOP/orbit/ISS/SVPOST.html',
	},
	shuttle => {name => 'Current shuttle mission',
	    url => 'http://spaceflight.nasa.gov/realdata/sightings/SSapplications/Post/JavaSSOP/orbit/SHUTTLE/SVPOST.html',
	},
    },
    spacetrack => {
	md5 => {name => 'MD5 checksums', number => 0, special => 1},
	full => {name => 'Full catalog', number => 1},
	geosynchronous => {name => 'Geosynchronous satellites', number => 3},
	navigation => {name => 'Navigation satellites', number => 5},
	weather => {name => 'Weather satellites', number => 7},
	iridium => {name => 'Iridium satellites', number => 9},
	orbcomm => {name => 'OrbComm satellites', number => 11},
	globalstar => {name => 'Globalstar satellites', number => 13},
	intelsat => {name => 'Intelsat satellites', number => 15},
	inmarsat => {name => 'Inmarsat satellites', number => 17},
	amateur => {name => 'Amateur Radio satellites', number => 19},
	visible => {name => 'Visible satellites', number => 21},
	special => {name => 'Special satellites', number => 23},
    },
);

my %mutator = (	# Mutators for the various attributes.
    addendum => \&_mutate_attrib,		# Addendum to banner text.
    banner => \&_mutate_attrib,
    cookie_expires => \&_mutate_attrib,
    debug_url => \&_mutate_attrib,	# Force the URL. Undocumented and unsupported.
    direct => \&_mutate_attrib,
    domain_space_track => \&_mutate_authen,
    dump_headers => \&_mutate_attrib,	# Dump all HTTP headers. Undocumented and unsupported.
    fallback => \&_mutate_attrib,
    filter => \&_mutate_attrib,
    iridium_status_format => \&_mutate_iridium_status_format,
    max_range => \&_mutate_number,
    password => \&_mutate_authen,
    scheme_space_track => \&_mutate_attrib,
    session_cookie => \&_mutate_cookie,
    url_iridium_status_kelso => \&_mutate_attrib,
    url_iridium_status_mccants => \&_mutate_attrib,
    url_iridium_status_sladen => \&_mutate_attrib,
    username => \&_mutate_authen,
    verbose => \&_mutate_attrib,
    webcmd => \&_mutate_attrib,
    with_name => \&_mutate_attrib,
);
# Maybe I really want a cookie_file attribute, which is used to do
# $self->{agent}->cookie_jar ({file => $self->{cookie_file}, autosave => 1}).
# We'll want to use a false attribute value to pass an empty hash. Going to
# this may imply modification of the new () method where the cookie_jar is
# defaulted and the session cookie's age is initialized.

sub new {
    my ($class, @args) = @_;
    $class = ref $class if ref $class;

    my $self = {
	agent => LWP::UserAgent->new (),
	banner => 1,	# shell () displays banner if true.
	cookie_expires => 0,
	debug_url => undef,	# Not turned on
	direct => 0,	# Do not direct-fetch from redistributors
	domain_space_track => 'www.space-track.org',
	dump_headers => 0,	# No dumping.
	fallback => 0,	# Do not fall back if primary source offline
	filter => 0,	# Filter mode.
	iridium_status_format => 'mccants',	# For historical reasons.
	max_range => 500,	# Sanity limit on range size.
	password => undef,	# Login password.
	scheme_space_track => 'https',
	session_cookie => undef,
	url_iridium_status_kelso =>
	    'http://celestrak.com/SpaceTrack/query/iridium.txt',
	url_iridium_status_mccants =>
	    'http://www.io.com/~mmccants/tles/iridium.html',
	url_iridium_status_sladen =>
	    'http://www.rod.sladen.org.uk/iridium.htm',
	username => undef,	# Login username.
	verbose => undef,	# Verbose error messages for catalogs.
	webcmd => undef,	# Command to get web help.
	with_name => undef,	# True to retrieve three-line element sets.
    };
    bless $self, $class;

    $self->{agent}->env_proxy;

    $ENV{SPACETRACK_OPT} and
	$self->set (grep {defined $_} split '\s+', $ENV{SPACETRACK_OPT});

    $ENV{SPACETRACK_USER} and do {
	my ($user, $pass) = split '/', $ENV{SPACETRACK_USER}, 2;
	$self->set (username => $user, password => $pass);
    };

    @args and $self->set (@args);

    $self->{agent}->cookie_jar ({})
	unless $self->{agent}->cookie_jar;

    $self->_check_cookie ();

    return $self;
}

sub amsat {
    my $self = shift;
    delete $self->{_pragmata};
    my $content = '';
    foreach my $url (
	'http://www.amsat.org/amsat/ftp/keps/current/nasabare.txt',
    ) {
	my $resp = $self->{agent}->get ($url);
	return $resp unless $resp->is_success;
	$self->_dump_headers( $resp );
	my @data;
	foreach (split '\n', $resp->content) {
	    push @data, "$_\n";
	    @data == 3 or next;
	    shift @data unless $self->{direct} || $self->{with_name};
	    $content .= join '', @data;
	    @data = ();
	}
    }

    $content or
	return HTTP::Response->new (RC_PRECONDITION_FAILED, NO_CAT_ID);

    my $resp = HTTP::Response->new (RC_OK, undef, undef, $content);
    $self->_add_pragmata($resp,
	'spacetrack-type' => 'orbit',
	'spacetrack-source' => 'amsat',
    );
    $self->_dump_headers( $resp );
    return $resp;
}

sub attribute_names {
    return wantarray ? sort keys %mutator : [sort keys %mutator]
}

{
    my $perl_version;

    sub banner {
	my $self = shift;
	$perl_version ||= do {
	    $] >= 5.01 ? $^V : do {
		require Config;
		'v' . $Config::Config{version};	## no critic (ProhibitPackageVars)
	    }
	};
	return HTTP::Response->new (RC_OK, undef, undef, <<"EOD");

@{[__PACKAGE__]} version $VERSION
Perl $perl_version under $^O

This package acquires satellite orbital elements and other data from a
variety of web sites. It is your responsibility to abide by the terms of
use of the individual web sites. In particular, to acquire data from
Space Track ($self->{scheme_space_track}://$self->{domain_space_track}/) you must register and
get a username and password, and you may not make the data available to
a third party without prior permission from Space Track.

Copyright 2005-2011 by T. R. Wyant (wyant at cpan dot org).

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text
of the licenses in the directory LICENSES.

This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
@{[$self->{addendum} || '']}
EOD
    }

}

sub box_score {
    my ( $self ) = @_;

    my $p = Astro::SpaceTrack::Parser->new ();

    my $resp = $self->_post ( 'perl/boxscore.pl' );
    $resp->is_success()
	and not $self->{debug_url}
	or return $resp;

    my $content = $resp->content;
    $content =~ s/   / /smxg;
    my @this_page = @{$p->parse_string (table => $content)};
    ref $this_page[0] eq 'ARRAY'
	or return HTTP::Response->new (RC_INTERNAL_SERVER_ERROR,
	BAD_SPACETRACK_RESPONSE, undef, $content);
    my @data = @{$this_page[0]};
    $content = '';
    my $line = 0;
    foreach my $datum ( @data ) {
	if ( $line++ == 1 ) {
	    foreach ( @{ $datum } ) {
		s/ \s* [(] key [)] \s* \z //smxi;
	    }
	}
	$content .= join( "\t", @{ $datum } ) . "\n";
    }
    $resp = HTTP::Response->new (RC_OK, undef, undef, $content);
    $self->_add_pragmata($resp,
	'spacetrack-type' => 'box_score',
	'spacetrack-source' => 'spacetrack',
    );
    return wantarray ? ($resp, \@data) : $resp;
}

sub celestrak {
    my ($self, @args) = @_;
    delete $self->{_pragmata};

    @args = _parse_retrieve_args( @args );
    my $opt = shift @args;

    my $name = shift @args;
    $self->{direct}
	and return $self->_celestrak_direct ($opt, $name);
    my $resp = $self->{agent}->get (
	"http://celestrak.com/SpaceTrack/query/$name.txt");
    if (my $check = $self->_celestrak_response_check($resp, $name)) {
	return $check;
    }
    $self->_convert_content ($resp);
    $self->_dump_headers( $resp );
    $resp = $self->_handle_observing_list ($opt, $resp->content);
    return ($resp->is_success || !$self->{fallback}) ? $resp :
	$self->_celestrak_direct ($opt, $name);
}

sub _celestrak_direct {
    my ($self, @args) = @_;
    delete $self->{_pragmata};

    @args = _parse_retrieve_args( @args );
##  my $opt = shift @args;
    shift @args;	# $opt not used
    my $name = shift @args;
    my $resp = $self->{agent}->get (
	"http://celestrak.com/NORAD/elements/$name.txt");
    if (my $check = $self->_celestrak_response_check($resp, $name, 'direct')) {
	return $check;
    }
    $self->_convert_content ($resp);
    if ($name eq 'iridium') {
	_celestrak_repack_iridium( $resp );
    }
    $self->_add_pragmata($resp,
	'spacetrack-type' => 'orbit',
	'spacetrack-source' => 'celestrak',
    );
    $self->_dump_headers( $resp );
    return $resp;
}

sub _celestrak_repack_iridium {
    my ( $resp ) = @_;
    my @content;
    foreach ( split qr{ \n }smx, $resp->content() ) {
	s/ \s+ [[] . []] \s* \z //smx;
	push @content, $_;
    }
    $resp->content( join "\n", @content );
    return;
}

{	# Local symbol block.

    my %valid_type = ('text/plain' => 1, 'text/text' => 1);

    sub _celestrak_response_check {
	my ($self, $resp, $name, @args) = @_;
	unless ($resp->is_success) {
	    $resp->code == RC_NOT_FOUND
		and return $self->_no_such_catalog(
		celestrak => $name, @args);
	    return $resp;
	}
	if (my $loc = $resp->header('Content-Location')) {
	    if ($loc =~ m/ redirect [.] htm [?] ( \d{3} ) ; /smx) {
		my $msg = "redirected $1";
		@args and $msg = "@args; $msg";
		$1 == RC_NOT_FOUND
		    and return $self->_no_such_catalog(
		    celestrak => $name, $msg);
		return HTTP::Response->new (+$1, "$msg\n")
	    }
	}
	my $type = lc $resp->header('Content-Type')
	    or do {
	    my $msg = 'No Content-Type header found';
	    @args and $msg = "@args; $msg";
	    return $self->_no_such_catalog(
		celestrak => $name, $msg);
	};
	foreach ( _trim( split ',', $type ) ) {
	    s/ ; .* //smx;
	    $valid_type{$_} and return;
	}
	my $msg = "Content-Type: $type";
	@args and $msg = "@args; $msg";
	return $self->_no_such_catalog(
	    celestrak => $name, $msg);
    }

}	# End local symbol block.

sub content_source {
    my ($self, $resp) = @_;
    defined $resp or return $self->{_pragmata}{'spacetrack-source'};
    foreach ($resp->header ('Pragma')) {
	m/ spacetrack-source \s+ = \s+ (.+) /smxi and return $1;
    }
    return;
}

sub content_type {
    my ($self, $resp) = @_;
    defined $resp or return $self->{_pragmata}{'spacetrack-type'};
    foreach ($resp->header ('Pragma')) {
	m/ spacetrack-type \s+ = \s+ (.+) /smxi and return $1;
    }
    return;
}

sub file {
    my ($self, @args) = @_;
    @args = _parse_retrieve_args( @args );
    my $opt = shift @args;

    delete $self->{_pragmata};
    my $name = shift @args;
    ref $name and fileno ($name)
	and return $self->_handle_observing_list (<$name>);
    -e $name or return HTTP::Response->new (
	RC_NOT_FOUND, "Can't find file $name");
    my $fh = IO::File->new($name, '<') or
	return HTTP::Response->new (
	    RC_INTERNAL_SERVER_ERROR, "Can't open $name: $!");
    local $/ = undef;
    return $self->_handle_observing_list ($opt, <$fh>)
}

sub get {
    my ( $self, $name ) = @_;
    delete $self->{_pragmata};
    my $value = $self->getv( $name );
    my $resp = HTTP::Response->new( RC_OK, undef, undef, $value );
    $self->_add_pragmata( $resp,
	'spacetrack-type' => 'get',
    );
    $self->_dump_headers( $resp );
    return wantarray ? ($resp, $value ) : $resp;
}

sub getv {
    my ( $self, $name ) = @_;
    defined $name
	or croak 'No attribute name specified';
    $mutator{$name}
	or croak "No such attribute as '$name'";
    return $self->{$name};
}

sub help {
    my $self = shift;
    delete $self->{_pragmata};
    if ($self->{webcmd}) {
	system (join ' ', $self->{webcmd},
	    "http://search.cpan.org/~wyant/Astro-SpaceTrack-$VERSION/");
	return HTTP::Response->new (RC_OK, undef, undef, 'OK');
    } else {
	my $resp = HTTP::Response->new (RC_OK, undef, undef, <<'EOD');
The following commands are defined:
  box_score
    Retrieve the SATCAT box score. A Space Track login is needed.
  celestrak name
    Retrieves the named catalog of IDs from Celestrak. If the
    direct attribute is false (the default), the corresponding
    orbital elements come from Space Track. If true, they come
    from Celestrak, and no login is needed.
  exit (or bye)
    Terminate the shell. End-of-file also works.
  file filename
    Retrieve the catalog IDs given in the named file (one per
    line, with the first five characters being the ID).
  get
    Get the value of a single attribute.
  help
    Display this help text.
  iridium_status
    Status of Iridium satellites, from Mike McCants or Rod Sladen and/or
    T. S. Kelso.
  login
    Acquire a session cookie. You must have already set the
    username and password attributes. This will be called
    implicitly if needed by any method that accesses data.
  names source
    Lists the catalog names from the given source.
  retrieve number ...
    Retieves the latest orbital elements for the given
    catalog numbers.
  search_date date ...
    Retrieves orbital elements by launch date.
  search_decay date ...
    Retrieves orbital elements by decay date.
  search_id id ...
    Retrieves orbital elements by international designator.
  search_name name ...
    Retrieves orbital elements by satellite common name.
  set attribute value ...
    Sets the given attributes. Legal attributes are
      addendum = extra text for the shell () banner;
      banner = false to supress the shell () banner;
      cookie_expires = Perl date the session cookie expires;
      debug_url = Override canned url for debugging - do not
        set this in normal use;
      direct = true to fetch orbital elements directly
        from a redistributer. Currently this only affects the
        celestrak() method. The default is false.
      dump_headers is unsupported, and intended for debugging -
        don't be suprised at anything it does, and don't rely
        on anything it does;
      filter = true supresses all output to stdout except
        orbital elements;
      max_range = largest range of numbers that can be re-
        trieved (default: 500);
      password = the Space-Track password;
      session_cookie = the text of the session cookie;
      username = the Space-Track username;
      verbose = true for verbose catalog error messages;
      webcmd = command to launch a URL (for web-based help);
      with_name = true to retrieve common names as well.
    The session_cookie and cookie_expires attributes should
    only be set to previously-retrieved, matching values.
  source filename
    Executes the contents of the given file as shell commands.
  spaceflight
    Retrieves orbital elements from http://spaceflight.nasa.gov/.
    No login needed, but you get at most the ISS and the current
    shuttle mission.
  spacetrack name
    Retrieves the named catalog of orbital elements from
    Space Track.
The shell supports a pseudo-redirection of standard output,
using the usual Unix shell syntax (i.e. '>output_file').
EOD
	$self->_add_pragmata($resp,
	    'spacetrack-type' => 'help',
	);
	$self->_dump_headers( $resp );
	return $resp;
    }
}

{	# Begin local symbol block.

    use constant BODY_STATUS_IS_OPERATIONAL => 0;

    use constant BODY_STATUS_IS_SPARE => 1;
    use constant BODY_STATUS_IS_TUMBLING => 2;

    my %kelso_comment = (	# Expand Kelso status.
	'[S]' => 'Spare',
	'[-]' => 'Tumbling',
	);
    my %status_map = (	# Map Kelso status to McCants status.
	kelso => {
	    mccants => {
		'[S]' => '?',	# spare
		'[-]' => 'tum',	# tumbling
		'[+]' => '',	# operational
		},
	    },
	);
    my %status_portable = (	# Map statuses to portable.
	kelso => {
	    ''	=> BODY_STATUS_IS_OPERATIONAL,
	    '[-]' => BODY_STATUS_IS_TUMBLING,
	    '[S]' => BODY_STATUS_IS_SPARE,
	    '[+]' => BODY_STATUS_IS_OPERATIONAL,
	},
	mccants => {
	    '' => BODY_STATUS_IS_OPERATIONAL,
	    '?' => BODY_STATUS_IS_SPARE,
	    'dum' => BODY_STATUS_IS_TUMBLING,
	    'man' => BODY_STATUS_IS_TUMBLING,
	    'tum' => BODY_STATUS_IS_TUMBLING,
	    'tum?' => BODY_STATUS_IS_TUMBLING,
	},
#	sladen => undef,	# Not needed; done programmatically.
    );
    while (my ($key, $val) = each %{$status_portable{kelso}}) {
	$key and $status_portable{kelso_inverse}{$val} = $key;
    }

    sub iridium_status {
	my $self = shift;
	my $fmt = shift || $self->{iridium_status_format};
	delete $self->{_pragmata};
	my %rslt;
	my $resp = $self->_iridium_status_kelso( $fmt, \%rslt );
	$resp->is_success() or return $resp;
	if ($fmt eq 'mccants') {
	    ( $resp = $self->_iridium_status_mccants( $fmt, \%rslt ) )
		->is_success() or return $resp;
	} elsif ($fmt eq 'sladen') {
	    ( $resp = $self->_iridium_status_sladen( $fmt, \%rslt ) )
		->is_success() or return $resp;
	}
	$resp->content (join '', map {
		sprintf "%6d   %-15s%-8s %s\n", @{$rslt{$_}}}
	    sort {$a <=> $b} keys %rslt);
	$self->_add_pragmata($resp,
	    'spacetrack-type' => 'iridium-status',
	    'spacetrack-source' => $fmt,
	);
	$self->_dump_headers( $resp );
	return wantarray ? ($resp, [values %rslt]) : $resp;
    }

    # Get Iridium data from Celestrak.
    sub _iridium_status_kelso {
	my ( $self, $fmt, $rslt ) = @_;
	my $resp = $self->{agent}->get(
	    $self->getv( 'url_iridium_status_kelso' )
	);
	$resp->is_success or return $resp;
	foreach my $buffer (split '\n', $resp->content) {
	    $buffer =~ s/ \s+ \z //smx;
	    my $id = substr ($buffer, 0, 5) + 0;
	    my $name = substr ($buffer, 5);
	    my $status = '';
	    $name =~ s/ \s+ ( [[] .+? []] ) \s* \z //smx
		and $status = $1;
	    my $portable_status = $status_portable{kelso}{$status};
	    my $comment;
	    if ($fmt eq 'kelso' || $fmt eq 'sladen') {
		$comment = $kelso_comment{$status} || '';
		}
	      else {
		$status = $status_map{kelso}{$fmt}{$status} || '';
		$status = 'dum' unless $name =~ m/ \A IRIDIUM /smxi;
		$comment = 'Celestrak';
		}
	    $name = ucfirst lc $name;
	    $rslt->{$id} = [ $id, $name, $status, $comment,
		$portable_status ];
	}
	return $resp;
    }

    # Get Iridium status from Mike McCants
    sub _iridium_status_mccants {
	my ( $self, undef, $rslt ) = @_;	# $fmt arg not used
	my $resp = $self->{agent}->get(
	    $self->getv( 'url_iridium_status_mccants' )
	);
	$resp->is_success or return $resp;
	foreach my $buffer (split '\n', $resp->content) {
	    $buffer =~ m/ \A \s* (\d+) \s+ Iridium \s+ \S+ /smxi
		or next;
	    my ($id, $name, $status, $comment) = _trim(
		$buffer =~ m/ (.{8}) (.{0,15}) (.{0,9}) (.*) /smx
	    );
	    my $portable_status =
		exists $status_portable{mccants}{$status} ?
		    $status_portable{mccants}{$status} :
		    BODY_STATUS_IS_TUMBLING;
	    $rslt->{$id} = [ $id, $name, $status, $comment,
		$portable_status ];
#0         1         2         3         4         5         6         7
#01234567890123456789012345678901234567890123456789012345678901234567890
# 24836   Iridium 914    tum      Failed; was called Iridium 14
	}
	return $resp;
    }

    my %sladen_interpret_detail = (
	'' => sub {
	    my ( $rslt, $id, $name, $plane ) = @_;
	    $rslt->{$id} = [ $id, $name, '[-]',
		"$plane - Failed on station?",
		BODY_STATUS_IS_TUMBLING ];
	    return;
	},
	d => sub {
	    return;
	},
	t => sub {
	    my ( $rslt, $id, $name, $plane ) = @_;
	    $rslt->{$id} = [ $id, $name, '[-]', $plane,
		BODY_STATUS_IS_TUMBLING ];
	},
    );

    # Get Iridium status from Rod Sladen.
    sub _iridium_status_sladen {
	my ( $self, undef, $rslt ) = @_;	# $fmt arg not used

	my $resp = $self->{agent}->get(
	    $self->getv( 'url_iridium_status_sladen' )
	);
	$resp->is_success or return $resp;
	my %oid;
	my %dummy;
	foreach my $id (keys %{ $rslt } ) {
	    $rslt->{$id}[1] =~ m/ dummy /smxi and do {
		$dummy{$id} = $rslt->{$id};
		$dummy{$id}[3] = 'Dummy';
		next;
	    };
	    $rslt->{$id}[1] =~ m/ (\d+) /smx or next;
	    $oid{+$1} = $id;
	}
	%{ $rslt } = %dummy;

	my $fail;
	my $re = qr{ (\d+) }smx;
	local $_ = $resp->content;
####	s{ <em> .*? </em> }{}smxgi;	# Strip emphasis notes
	s/ < .*? > //smxg;	# Strip markup
	# Parenthesized numbers are assumed to represent tumbling
	# satellites in the in-service or spare grids.
	my %exception;
	{	## no critic (ProhibitUnusedCapture)
	    s< [(] (\d+) [)] >
				< $exception{$1} = BODY_STATUS_IS_TUMBLING; $1>smxge;
	}
	s/ [(] .*? [)] //smxg;	# Strip parenthetical comments
	foreach (split '\n', $_) {
	    if (m/ &lt; -+ \s+ failed \s+ -+ &gt; /smxi) {
		$fail++;
		$re = qr{ (\d+) (\w?) }smx;
	    } elsif ( s/ \A \s* ( plane \s+ \d+ ) \s* : \s* //smxi ) {
		my $plane = $1;
##		s/ \A \D+ //smx;	# Strip leading non-digits
		s/ \b [[:alpha:]] .* //smx;	# Strip trailing comments
		s/ \s+ \z //smx;		# Strip trailing whitespace
		my $inx = 0;	# First 11 functional are in service
		while (m/ $re /smxg) {
		    my $num = +$1;
		    my $detail = $2;
		    my $id = $oid{$num} or do {
#			This is normal for decayed satellites.
#			warn "No oid for Iridium $num\n";
			next;
		    };
		    my $name = "Iridium $num";
		    if ($fail) {
			my $interp = $sladen_interpret_detail{$detail}
			    || $sladen_interpret_detail{''};
			$interp->( $rslt, $id, $name, $plane );
		    } else {
			my $status = $inx++ > 10 ?
			    BODY_STATUS_IS_SPARE :
			    BODY_STATUS_IS_OPERATIONAL;
			exists $exception{$num}
			    and $status = $exception{$num};
			$rslt->{$id} = [ $id, $name,
			    $status_portable{kelso_inverse}{$status},
			    $plane, $status ];
		    }
		}
	    } elsif ( m/ Notes: /smx ) {
		last;
	    }
	}

	return $resp;
    }

}	# End of local symbol block.

sub login {
    my ($self, @args) = @_;
    delete $self->{_pragmata};
    @args and $self->set (@args);
    ($self->{username} && $self->{password}) or
	return HTTP::Response->new (
	    RC_PRECONDITION_FAILED, NO_CREDENTIALS);
    $self->{dump_headers} and warn <<"EOD";
Logging in as $self->{username}.
EOD

    #	Do not use the _post method to retrieve the session cookie,
    #	unless you like bottomless recursions.
    my $resp = $self->{agent}->post (
	"$self->{scheme_space_track}://$self->{domain_space_track}/perl/login.pl", [
	    username => $self->{username},
	    password => $self->{password},
	    _submitted => 1,
	    _sessionid => "",
	    ]);

    $resp->is_success or return $resp;
    $self->_dump_headers( $resp );

    $self->_check_cookie () > time ()
	or return HTTP::Response->new (RC_UNAUTHORIZED, LOGIN_FAILED);

    $self->{dump_headers} and warn <<'EOD';
Login successful.
EOD
    return HTTP::Response->new (RC_OK, undef, undef, "Login successful.\n");
}

sub names {
    my $self = shift;
    delete $self->{_pragmata};
    my $name = lc shift;
    $catalogs{$name} or return HTTP::Response (
	    RC_NOT_FOUND, "Data source '$name' not found.");
    my $src = $catalogs{$name};
    my @list;
    foreach my $cat (sort keys %$src) {
	push @list, defined ($src->{$cat}{number}) ?
	    "$cat ($src->{$cat}{number}): $src->{$cat}{name}\n" :
	    "$cat: $src->{$cat}{name}\n";
    }
    my $resp = HTTP::Response->new (RC_OK, undef, undef, join ('', @list));
    return $resp unless wantarray;
    @list = ();
    foreach my $cat (sort {$src->{$a}{name} cmp $src->{$b}{name}}
	keys %$src) {
	push @list, [$src->{$cat}{name}, $cat];
    }
    return ($resp, \@list);
}

use constant RETRIEVAL_SIZE => 50;

sub retrieve {
    my ($self, @args) = @_;
    delete $self->{_pragmata};

    @args = _parse_retrieve_args( @args );
    my $opt = _parse_retrieve_dates (shift @args);

    my @params = $opt->{start_epoch} ?
	(timeframe => 'timespan',
	    start_year => $opt->{start_epoch}[5] + 1900,
	    start_month => $opt->{start_epoch}[4] + 1,
	    start_day => $opt->{start_epoch}[3],
	    end_year => $opt->{end_epoch}[5] + 1900,
	    end_month => $opt->{end_epoch}[4] + 1,
	    end_day => $opt->{end_epoch}[3],
	) :
	$opt->{last5} ? (timeframe => 'last5') : (timeframe => 'latest');
    push @params, common_name => $self->{with_name} ? 'yes' : '';
    push @params, sort => $opt->{sort};
    push @params, descending => $opt->{descending} ? 'yes' : '';

    @args = grep { m/ \A \d+ (?: - \d+)? \z /smx } @args;

    @args or return HTTP::Response->new (RC_PRECONDITION_FAILED, NO_CAT_ID);
    my $content = '';
    local $_ = undef;
    my $resp;
    while (@args) {
	my @batch;
	my $ids = 0;
	while (@args && $ids < RETRIEVAL_SIZE) {
	    $ids++;
	    my ($lo, $hi) = split '-', shift @args;
	    $lo > 0 or defined $hi or next;
	    defined $hi and do {
		($lo, $hi) = ($hi, $lo) if $lo > $hi;
		$lo or $lo = 1;	# 0 is illegal
		$hi - $lo >= $self->{max_range} and do {
		    carp <<"EOD";
Warning - Range $lo-$hi ignored because it is greater than the
	  currently-set maximum of $self->{max_range}.
EOD
		    next;
		};
		$ids += $hi - $lo;
		$ids > RETRIEVAL_SIZE and do {
		    my $mid = $hi - $ids + RETRIEVAL_SIZE;
		    unshift @args, "@{[$mid + 1]}-$hi";
		    $hi = $mid;
		};
		$lo = "$lo-$hi" if $hi > $lo;
	    };
	    push @batch, $lo;
	}
	next unless @batch;
	$resp = $self->_post ('perl/id_query.pl',
	    ids => "@batch",
	    @params,
	    ascii => 'yes',		# or ''
	    _sessionid => '',
	    _submitted => 1,
	);
	return $resp unless $resp->is_success;
	$_ = $resp->content;
	next if m/ No \s records \s found /smxi;
	if ( m/ ERROR: /smx ) {
	    return HTTP::Response->new (RC_INTERNAL_SERVER_ERROR,
		"Failed to retrieve IDs @batch.\n",
		undef, $content);
	}
	s{ </pre> .* }{}smx;
	s{ .* <pre> }{}smx;
	s{ \A \n }{}smx;
	$content .= $_;
    }
    $content or return HTTP::Response->new (RC_NOT_FOUND, NO_RECORDS);
    $resp->content ($content);
    $self->_convert_content ($resp);
    $self->_add_pragmata($resp,
	'spacetrack-type' => 'orbit',
	'spacetrack-source' => 'spacetrack',
    );
    return $resp;
}

sub search_date {
    my ($self, @args) = @_;
    @args = _parse_search_args (@args);
    return $self->_search_generic (sub {
	my ($self, $name, $opt) = @_;
	my ($year, $month, $day) =
	    $name =~ m/ \A (\d+) (?:\D+ (\d+) (?: \D+ (\d+) )? )? /smx
		or return;
	$year += $year < 57 ? 2000 : $year < 100 ? 1900 : 0;
	$month ||= 0;
	$day ||= 0;
	my $resp = $self->_post ('perl/launch_query.pl',
	    date_spec => 'month',
	    launch_year => $year,
	    launch_month => $month,
	    launch_day => $day,
	    status => $opt->{status},	# 'all', 'onorbit' or 'decayed'.
	    exclude => $opt->{exclude},	# ['debris', 'rocket', or both]
	    _sessionid => '',
	    _submit => 'submit',
	    _submitted => 1,
	);
	return $resp;
    }, @args );
}

sub search_decay {
    my ($self, @args) = @_;
    @args = _parse_search_args (@args);
    return $self->_search_generic (
	{
	    splice => -1,
	    poster => sub {
		my ($self, $name, $opt) = @_;
		my ($year, $month, $day) =
		    $name =~ m{ \A (\d+) (?: \D+ (\d+) (?: \D+ (\d+) )?
						)? }smx
			or return;
		$year += $year < 57 ? 2000 : $year < 100 ? 1900 : 0;
		$month ||= 0;
		$day ||= 0;
		my $resp = $self->_post ('perl/decay_query.pl',
		    decay_year => $year,
		    decay_month => $month,
		    decay_day => $day,
		    status => $opt->{status},	# 'all', 'onorbit' or 'decayed'.
		    exclude => $opt->{exclude},	# ['debris', 'rocket', or both]
		    _sessionid => '',
		    _submit => 'Submit',
		    _submitted => 1,
		);
		return $resp;
	    },
	}, @args);
}

sub search_id {
    my ($self, @args) = @_;
    @args = _parse_search_args (@args);
    return $self->_search_generic (sub {
	my ($self, $name, $opt) = @_;
	my ($year, $number, $piece) =
	    $name =~ m/ \A (\d\d) (\d{3})? ( [[:alpha:]] )? \z /smx
		or return;
	$year += $year < 57 ? 2000 : 1900;
	my $resp = $self->_post ('perl/launch_query.pl',
	    date_spec => 'number',
	    launch_year => $year,
	    launch_number => $number || '',
	    piece => uc ($piece || ''),
	    status => $opt->{status},	# 'all', 'onorbit' or 'decayed'.
	    exclude => $opt->{exclude},	# ['debris', 'rocket', or both]
	    _sessionid => '',
	    _submit => 'submit',
	    _submitted => 1,
	);
	return $resp;
    }, @args);
}

sub search_name {
    my ($self, @args) = @_;
    @args = _parse_search_args (@args);
    return $self->_search_generic (sub {
	my ($self, $name, $opt) = @_;
	$self->_post ('perl/name_query.pl',
	    _submitted => 1,
	    _sessionid => '',
	    name => $name,
	    launch_year_start => 1957,
	    launch_year_end => (gmtime)[5] + 1900,
	    status => $opt->{status},	# 'all', 'onorbit' or 'decayed'.
	    exclude => $opt->{exclude},	# ['debris', 'rocket', or both]
	    _submit => 'Submit',
	    );
	}, @args);
}

sub search_oid {
    my ($self, @args) = @_;
    @args = _parse_retrieve_args(
	[
	    'rcs!' => '(append --rcs radar_cross_section to name)',
	    'tle!' => '(return TLE data from search (defaults true))'
	],
	@args );
    my $opt = shift @args;
    exists $opt->{tle} or $opt->{tle} = 1;
    my $ids = join ' ', @args;
    return $self->_search_generic ( \&_search_oid_generic, $opt, $ids );
}

sub _search_oid_generic {
    my ( $self, $ids, $opt ) = @_;
    return $self->_post (
	'perl/satcat_id_query.pl',
	_submitted => 1,
	_sessionid => '',
	ids => $ids,
	desc => ( $opt->{descending} ? 'yes' : '' ),
	_submit => 'Submit',
    );
}

sub set {	## no critic (ProhibitAmbiguousNames)
    my ($self, @args) = @_;
    delete $self->{_pragmata};
    @args % 2
	and croak __PACKAGE__, '->set( ',
	join( ', ', map { "'$_'" } @args ),
	') requires an even number of arguments';
    while (@args) {
	my $name = shift @args;
	croak "Attribute $name may not be set. Legal attributes are ",
		join (', ', sort keys %mutator), ".\n"
	    unless $mutator{$name};
	my $value = shift @args;
	$mutator{$name}->($self, $name, $value);
    }
    return HTTP::Response->new (RC_OK, undef, undef, COPACETIC);
}

my $rdln;

sub shell {
    my @args = @_;
    my $self = _instance( $args[0], __PACKAGE__ ) ? shift @args :
	Astro::SpaceTrack->new (addendum => <<'EOD');

'help' gets you a list of valid commands.
EOD

    my $prompt = 'SpaceTrack> ';

    my $stdout = \*STDOUT;
    my $read;

    unshift @args, 'banner' if $self->{banner} && !$self->{filter};
    # Perl::Critic wants IO::Interactive::is_interactive() here. But
    # that assumes we're using the *ARGV input mechanism, which we're
    # not (command arguments are SpaceTrack commands.) Also, we would
    # like to be prompted even if output is to a pipe, but the
    # recommended module calls that non-interactive even if input is
    # from a terminal. So:
    my $interactive = -t STDIN;
    while (1) {
	my $buffer;
	if (@args) {
	    $buffer = shift @args;
	} else {
	    $read ||= $interactive ? ( eval {
		    require Term::ReadLine;
		    $rdln ||= Term::ReadLine->new (
			'SpaceTrack orbital element access');
		    $stdout = $rdln->OUT || \*STDOUT;
		    sub { $rdln->readline ($prompt) };
		} || sub { print { $stdout } $prompt; return <STDIN> } ) :
		sub { return<STDIN> };
	    $buffer = $read->();
	}
	last unless defined $buffer;

	$buffer =~ s/ \A \s+ //smx;
	$buffer =~ s/ \s+ \z //smx;
	next unless $buffer;
	next if $buffer =~ m/ \A [#] /smx;
	my @cmdarg = parse_line ('\s+', 0, $buffer);
	my $redir = '';
	@cmdarg = map {m/ \A > /smx ? do {$redir = $_; ()} :
	    $redir =~ m/ \A >+ \z /smx ? do {$redir .= $_; ()} :
	    $_} @cmdarg;
	$redir =~ s/ \A (>+) ~ /$1$ENV{HOME}/smx;
	my $verb = lc shift @cmdarg;
	last if $verb eq 'exit' || $verb eq 'bye';
	$verb eq 'show' and $verb = 'get';
	$verb eq 'source' and do {
	    eval {
		splice @args, 0, 0, $self->_source (shift @cmdarg);
		1;
	    } or warn ( $@ || 'An unknown error occurred' );	## no critic (RequireCarping)
	    next;
	};
	($verb eq 'new' || $verb =~ m/ \A _ /smx || $verb eq 'shell' ||
	    !$self->can ($verb)) and do {
	    warn <<"EOD";
Verb '$verb' undefined. Use 'help' to get help.
EOD
	    next;
	};
	my $out;
	if ( $redir ) {
	    $out = IO::File->new( $redir ) or do {
		warn <<"EOD";
Error - Failed to open $redir
	$^E
EOD
		next;
	    };
	} else {
	    $out = $stdout;
	}
	my $rslt;
	if ($verb eq 'get' && @cmdarg == 0) {
	    $rslt = [];
	    foreach my $name ($self->attribute_names ()) {
		my $val = $self->getv( $name );
		push @$rslt, defined $val ? "$name $val" : $name;
	    }
	} else {
	    eval {
		$rslt = $self->$verb (@cmdarg);
		1;
	    } or do {
		warn $@;	## no critic (RequireCarping)
		next;
	    };
	}
	if (ref $rslt eq 'ARRAY') {
	    foreach (@$rslt) {print { $out } "$_\n"}
	} elsif ($rslt->is_success) {
	    $self->content_type()
		or not $self->{filter}
		or next;
	    my $content = $rslt->content;
	    chomp $content;
	    print { $out } "$content\n";
	} else {
	    my $status = $rslt->status_line;
	    chomp $status;
	    warn $status, "\n";
	}
    }
    $interactive
	and not $self->{filter}
	and print { $stdout } "\n";
    return;
}

# We really just delegate to _source, which unpacks.
sub source {
    my $self = _instance( $_[0], __PACKAGE__ ) ? shift :
	Astro::SpaceTrack->new ();
    $self->shell ($self->_source (@_), 'exit');
    return;
}

sub spaceflight {
    my ($self, @args) = @_;
    delete $self->{_pragmata};

    @args = _parse_retrieve_args(
	[
	    'all!' => 'retrieve all data',
	    'effective!' => 'include effective date',
	],
	@args );
    my $opt = _parse_retrieve_dates (shift @args, {perldate => 1});

    $opt->{all} = 0 if $opt->{last5} || $opt->{start_epoch};

    my @list;
    if (@args) {
	foreach (@args) {
	    my $info = $catalogs{spaceflight}{lc $_} or
		return $self->_no_such_catalog (spaceflight => $_);
	    push @list, $info->{url};
	}
    } else {
	my $hash = $catalogs{spaceflight};
	@list = map {$hash->{$_}{url}} sort keys %$hash;
    }

    my $content = '';
    my $html = '';
    my $now = time ();
    my %tle;
    foreach my $url (@list) {
	my $resp = $self->{agent}->get ($url);
	return $resp unless $resp->is_success;
	$html .= $resp->content();
	my (@data, $acquire, $effective);
	foreach (split qr{ \n }smx, $resp->content) {
	    chomp;
	    m{ Vector \s+ Time \s+ [(] GMT [)] : \s+
				( \d+ / \d+ / \d+ : \d+ : \d+ [.] \d+ )}smx and do {
		$effective = join ' ', '--effective', $1;
		next;
	    };
	    m/TWO LINE MEAN ELEMENT SET/ and do {
		$acquire = 1;
		@data = ();
		next;
	    };
	    next unless $acquire;
	    s/ \A \s+ //smx;
	    $_ and do {push @data, $_; next};
	    @data and do {
		$acquire = undef;
		@data == 2 or @data == 3 or next;
		@data == 3
		    and not $self->{direct}
		    and not $self->{with_name}
		    and shift @data;
		if ($effective && $opt->{effective}) {
		    if (@data == 2) {
			unshift @data, $effective;
		    } else {
			$data[0] .= " $effective";
		    }
		}
		$effective = undef;
		my $id = 0 + substr $data[-2], 2, 5;
		my $yr = substr $data[-2], 18, 2;
		my $da = substr $data[-2], 20, 12;
		$yr += 100 if $yr < 57;
		my $ep = timegm (0, 0, 0, 1, 0, $yr) + ($da - 1) * 86400;
		if ( $opt->{all} ||
		    $opt->{start_epoch} && $ep >= $opt->{start_epoch} &&
			$ep < $opt->{end_epoch} ||
		    $ep <= $now ) {
##		unless (!$opt->{all} && ($opt->{start_epoch} ?
##			($ep > $opt->{end_epoch} || $ep <= $opt->{start_epoch}) :
##			$ep > $now)) {
		    $tle{$id} ||= [];
		    my @keys = $opt->{descending} ? (-$id, -$ep) : ($id, $ep);
		    @keys = reverse @keys if $opt->{sort} eq 'epoch';
		    push @{$tle{$id}}, [@keys, join '', map {"$_\n"} @data];
		}
		@data = ();
	    };
	}
    }

    unless ($opt->{all} || $opt->{start_epoch}) {
	my $keep = $opt->{last5} ? 5 : 1;
	foreach (values %tle) {splice @{ $_ }, $keep}
    }
    $content .= join '',
	map {$_->[2]}
	sort {$a->[0] <=> $b->[0] || $a->[1] <=> $b->[1]}
	map {@$_} values %tle;

    $content
	or return HTTP::Response->new( RC_PRECONDITION_FAILED,
	    NO_RECORDS, undef, $html );

    my $resp = HTTP::Response->new (RC_OK, undef, undef, $content);
    $self->_add_pragmata($resp,
	'spacetrack-type' => 'orbit',
	'spacetrack-source' => 'spaceflight',
    );
    $self->_dump_headers( $resp );
    return $resp;
}

sub spacetrack {
    my $self = shift;
    delete $self->{_pragmata};
    my $catnum = shift;
    $catnum =~ m/ \D /smx and do {
	my $info = $catalogs{spacetrack}{$catnum} or
	    return $self->_no_such_catalog (spacetrack => $catnum);
	$catnum = $info->{number};
	$self->{with_name} && $catnum++ unless $info->{special};
    };
    my $resp = $self->_get ('perl/dl.pl', ID => $catnum);
# At this point, assuming we succeeded, we should have headers
# content-disposition: attachment; filename=the_desired_file_name
# content-type: application/force-download
# In the above, the_desired_file_name is (e.g.) something like
#   spec_interest_2l_2005_03_22_am.txt.gz

    ($resp->is_success() && !$self->{debug_url}) and do {
	my $content = $resp->content ();
	if ($content =~ m/ <html> /smx) {
	    if ($content =~ m/ Requested \s file \s doesn't \s exist/smxi) {
		$resp = HTTP::Response->new (RC_NOT_FOUND,
		    "The file for catalog $catnum is missing.\n",
		    undef, $content);
	    } else {
		$resp = HTTP::Response->new (RC_INTERNAL_SERVER_ERROR,
		    "The file for catalog $catnum could not be retrieved.\n",
		    undef, $content);
	    }
	} else {
	    $catnum and $resp->content (
		Compress::Zlib::memGunzip ($resp->content));
	    # SpaceTrack returns status 200 on a non-existent catalog
	    # number, but whatever content they send back doesn't unzip, so
	    # we catch it here.
	    defined ($resp->content ())
		or return $self->_no_such_catalog (spacetrack => $catnum);
	    $resp->remove_header ('content-disposition');
	    $resp->header (
		'content-type' => 'text/plain',
##		'content-length' => length ($resp->content),
	    );
	    $self->_convert_content ($resp);
	    $self->_add_pragmata($resp,
		'spacetrack-type' => 'orbit',
		'spacetrack-source' => 'spacetrack',
	    );
	}
    };
    return $resp;
}


####
#
#	Private methods.
#

#	$self->_add_pragmata ($resp, $name => $value, ...);
#
#	This method adds pragma headers to the given HTTP::Response
#	object, of the form pragma => "$name = $value". The pragmata are
#	also cached in $self.

sub _add_pragmata {
    my ($self, $resp, @args) = @_;
    while (@args) {
	my $name = shift @args;
	my $value = shift @args;
	$self->{_pragmata}{$name} = $value;
	$resp->push_header(pragma => "$name = $value");
    }
    return;
}

#	_check_cookie looks for our session cookie. If it's found, it returns
#	the cookie's expiration time and sets the relevant attributes.
#	Otherwise it returns zero.

sub _check_cookie {
    my $self = shift;
    my ($cookie, $expir);
    $expir = 0;
    $self->{agent}->cookie_jar->scan (sub {
	$self->{dump_headers} > 1 and _dump_cookie ("_check_cookie:\n", @_);
	($cookie, $expir) = @_[2, 8] if $_[4] eq $self->{domain_space_track} &&
	    $_[3] eq SESSION_PATH && $_[1] eq SESSION_KEY;
	});
    $self->{dump_headers} and warn $expir ? <<"EOD" : <<'EOD';	## no critic (RequireCarping)
Session cookie: $cookie
Cookie expiration: @{[strftime '%d-%b-%Y %H:%M:%S', localtime $expir]} ($expir)
EOD
Session cookie not found
EOD
    $self->{session_cookie} = $cookie;
    $self->{cookie_expires} = $expir;
    return $expir || 0;
}

#	_convert_content converts the content of an HTTP::Response
#	from crlf-delimited to lf-delimited.

{	# Begin local symbol block

    my $lookfor = $^O eq 'MacOS' ? qr{ \012|\015+ }smx : qr{ \r \n }smx;

    sub _convert_content {
	my ($self, @args) = @_;
	local $/ = undef;	# Slurp mode.
	foreach my $resp (@args) {
	    my $buffer = $resp->content;
	    # If we request a non-existent Space Track catalog number,
	    # we get 200 OK but the unzipped content is undefined. We
	    # catch this before we get this far, but the buffer check is
	    # left in in case something else leaks through.
	    defined $buffer or $buffer = '';
	    $buffer =~ s/$lookfor/\n/smxgo;
	    1 while ($buffer =~ s/ \A \n+ //smx);
	    $buffer =~ s/ \s+ \n /\n/smxg;
	    $buffer =~ m/ \n \z /smx or $buffer .= "\n";
	    $resp->content ($buffer);
	    $resp->header (
		'content-length' => length ($buffer),
		);
	}
	return;
    }
}	# End local symbol block.

#	_dump_cookie is intended to be called from inside the
#	HTTP::Cookie->scan method. The first argument is prefix text
#	for the dump, and the subsequent arguments are the arguments
#	passed to the scan method.
#	It dumps the contents of the cookie to STDERR via a warn ().
#	A typical session cookie looks like this:
#	    version => 0
#	    key => 'spacetrack_session'
#	    val => whatever
#	    path => '/'
#	    domain => 'www.space-track.org'
#	    port => undef
#	    path_spec => 1
#	    secure => undef
#	    expires => undef
#	    discard => 1
#	    hash => {}
#	The response to the login, though, has an actual expiration
#	time, which we take cognisance of.

use Data::Dumper;

{	# begin local symbol block

    my @names = qw{version key val path domain port path_spec secure
	    expires discard hash};

    sub _dump_cookie {
	my ($prefix, @args) = @_;
	local $Data::Dumper::Terse = 1;
	$prefix and warn $prefix;	## no critic (RequireCarping)
	for (my $inx = 0; $inx < @names; $inx++) {
	    warn "    $names[$inx] => ", Dumper ($args[$inx]);	## no critic (RequireCarping)
	}
	return;
    }
}	# end local symbol block


#	_dump_headers dumps the headers of the passed-in response
#	object.

sub _dump_headers {
    my ( $self, $resp ) = @_;
    $self->{dump_headers} or return;
    local $Data::Dumper::Terse = 1;
    my $rqst = $resp->request;
    $rqst = ref $rqst ? $rqst->as_string : "undef\n";
    chomp $rqst;
    warn "\nRequest:\n$rqst\nHeaders:\n",
	$resp->headers->as_string, "\nCookies:\n";
    $self->{agent}->cookie_jar->scan (sub {
	_dump_cookie ("\n", @_);
	});
    warn "\n";
    return;
}

#	_dump_request dumps the request if desired.
#
#	If the debug_url is defined, and has the 'dump-request:' scheme,
#	AND any of several YAML modules can be loaded, this routine
#	returns an HTTP::Response object with status RC_OK and whose
#	content is the request and its arguments encoded in YAML.
#
#	If any of the conditions fails, this module simply returns. The
#	moral: don't try to dump requests unless YAML is installed.

sub _dump_request {
    my ($self, $url, @args) = @_;
    my $display = $self->{dump_headers} & 0x02;
    my $respond = ( $self->{debug_url} || '' ) =~ m/ \A dump-request: /smx;
    $display or $respond or return;
    my $dumper = _get_yaml_dumper() or return;
    (my $method = (caller 1)[3]) =~ s/ \A (?: .* :: )? _? //smx;
    my %data = (
	args => {@args},
	method => $method,
	url => $url,
    );
    my $yaml = $dumper->( \%data );
    $yaml =~ s/ \n{2,} /\n/smxg;
    $display and print $yaml;
    $respond and return HTTP::Response->new( RC_OK, undef, undef, $yaml );
    return;
}

#	_get gets the given path on the domain. Arguments after the
#	first are the CGI parameters. It checks the currency of the
#	session cookie, and executes a login if it deems it necessary.
#	The normal return is the HTTP::Response object from the get (),
#	but if a login was attempted and failed, the HTTP::Response
#	object from the login will be returned.

sub _get {
    my ($self, $path, @args) = @_;
    my $cgi = '';
    {
	my @unpack = @args;
	while (@unpack) {
	    my $name = shift @unpack;
	    my $val = shift @unpack || '';
	    $cgi .= "&$name=$val";
	}
    }
    $cgi and substr( $cgi, 0, 1, '?' );
    {	# Single-iteration loop
	$self->{debug_url} or $self->{cookie_expires} > time () or do {
	    my $resp = $self->login ();
	    return $resp unless $resp->is_success;
	};
	my $url = "$self->{scheme_space_track}://$self->{domain_space_track}/$path";
	my $resp = $self->_dump_request($url, @args) ||
	    $self->{agent}->get (($self->{debug_url} || $url) . $cgi);
	$self->_dump_headers( $resp );
##	return $resp unless $resp->is_success && !$self->{debug_url};
	$resp->is_success()
	    and not $self->{debug_url}
	    or return $resp;
	local $_ = $resp->content;
	m/ login [.] pl /smxi and do {
	    $self->{cookie_expires} = 0;
	    redo;
	};
	return $resp;
    }	# end of single-iteration loop
    return;	# Should never get here.
}

#	Note: If we have a bad cookie, we get a success status, with
#	the text
# <?xml version="1.0" encoding="iso-8859-1"?>
# <!DOCTYPE html
#         PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
#          "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
# <html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"><head><title>Space-Track</title>
# </head><body>
# <body bgcolor='#fffacd' text='#191970' link='#3333e6'>
#          <div align='center'><img src='http://www.space-track.org/icons/spacetrack_logo3.jpg' width=640 height=128 align='top' border=0></div>
# <h2>Error, Corrupted session cookie<br>
# Please <A HREF='login.pl'>LOGIN</A> again.<br>
# </h2>
# </body></html>
#	If this happens, it would be good to retry the login.

	
{

    my ($dumper, $loader, $package, $tried);

#	_get_yaml_dumper retrieves a YAML dumper. If one can be found,
#	a code reference to it is returned. Otherwise we simply return.

    sub _get_yaml_dumper {
	$dumper and return $dumper;
	($package ||= _get_yaml_package()) or return;
	$dumper = $package->can('Dump');
	return $dumper;
    }
 
#	__get_yaml_loader retrieves a YAML loader. If one can be found,
#	a code reference to it is returned. Otherwise we simply return.
#
#	NOTE WELL: This subroutine is for the benefit of
#	t/spacetrack_request.t, and is called by that code. The leading
#	double underscore is to flag it to Perl::Critic as package
#	private rather than module private.

    sub __get_yaml_loader {
	$loader and return $loader;
	($package ||= _get_yaml_package()) or return;
	$loader = $package->can('Load');
	return $loader;
    }

#	_get_yaml_package tries to load several YAML packages, returning
#	the name of the first which is loaded successfully. If none can
#	be loaded, it returns undef. Subsequent calls simply return
#	whatever the first call did.

    sub _get_yaml_package {
	$tried and return $package;
	$tried++;
	$package =
	    eval { require YAML::XS;   'YAML::XS'   } ||
	    eval { require YAML::Syck; 'YAML::Syck' } ||
	    eval { require YAML;       'YAML'       } ||
	    eval { require YAML::Tiny; 'YAML::Tiny' }
	;
	return $package;
    }
}

#	_handle_observing_list takes as input any number of arguments.
#	each is split on newlines, and lines beginning with a five-digit
#	number (with leading spaces allowed) are taken to specify the
#	catalog number (first five characters) and common name (the rest)
#	of an object. The resultant catalog numbers are run through the
#	retrieve () method. If called in scalar context, the return is
#	the resultant HTTP::Response object. In list context, the first
#	return is the HTTP::Response object, and the second is a reference
#	to a list of list references, each lower-level reference containing
#	catalog number and name.

sub _handle_observing_list {
    my ($self, @args) = @_;
    my (@catnum, @data);

    @args = _parse_retrieve_args( @args );
    my $opt = shift;

    foreach (map {split qr{ \n }smx, $_} @args) {
	s/ \s+ \z //smx;
	my ( $id ) = m/ \A ( [\s\d]{5} ) /smx or next;
	$id =~ m/ \A \s* \d+ \z /smx or next;
	push @catnum, $id;
	push @data, [$id, substr $_, 5];
    }
    my $resp = $self->retrieve ($opt, sort {$a <=> $b} @catnum);
    if ($resp->is_success) {
	unless ($self->{_pragmata}) {
	    $self->_add_pragmata($resp,
		'spacetrack-type' => 'orbit',
		'spacetrack-source' => 'spacetrack',
	    );
	}
	$self->_dump_headers( $resp );
    }
    return wantarray ? ($resp, \@data) : $resp;
}

#	_instance takes a variable and a class, and returns true if the
#	variable is blessed into the class. It returns false for
#	variables that are not references.
sub _instance {
    my ( $object, $class ) = @_;
    ref $object or return;
    blessed( $object ) or return;
    return $object->isa( $class );
}

#	_mutate_attrib takes the name of an attribute and the new value
#	for the attribute, and does what its name says.

# We supress Perl::Critic because we're a one-liner. CAVEAT: we MUST
# not modify the contents of @_. Modifying @_ itself is fine.
sub _mutate_attrib {
    return ($_[0]{$_[1]} = $_[2]);
}

#	_mutate_authen clears the session cookie and then sets the
#	desired attribute

# This clears the session cookie and cookie expiration, then co-routines
# off to _mutate attrib.
sub _mutate_authen {
    $_[0]->set (session_cookie => undef, cookie_expires => 0);
    goto &_mutate_attrib;
}

#	_mutate_cookie sets the session cookie, in both the object and
#	the user agent's cookie jar. If the session cookie is undef, we
#	delete the session cookie from the cookie jar; otherwise we set
#	it to the specified value.

# This mutates the user agent's cookie jar, then co-routines off to
# _mutate attrib.
sub _mutate_cookie {
    if ($_[0]->{agent} && $_[0]->{agent}->cookie_jar) {
	if (defined $_[2]) {
	    $_[0]->{agent}->cookie_jar->set_cookie (0, SESSION_KEY, $_[2],
		SESSION_PATH, $_[0]{domain_space_track},
		undef, 1, undef, undef, 1, {});
	} else {
	    $_[0]->{agent}->cookie_jar->clear(
		$_[0]{domain_space_track}, SESSION_PATH, SESSION_KEY);
	}
    }
    goto &_mutate_attrib;
}

# This subroutine just does some argument checking and then co-routines
# off to _mutate_attrib.
sub _mutate_iridium_status_format {
    croak "Error - Illegal status format '$_[2]'"
	unless $catalogs{iridium_status}{$_[2]};
    goto &_mutate_attrib;
}

#	_mutate_number croaks if the value to be set is not numeric.
#	Otherwise it sets the value. Only unsigned integers pass.

# This subroutine just does some argument checking and then co-routines
# off to _mutate_attrib.
sub _mutate_number {
    $_[2] =~ m/ \D /smx and croak <<"EOD";
Attribute $_[1] must be set to a numeric value.
EOD
    goto &_mutate_attrib;
}


#	_no_such_catalog takes as arguments a source and catalog name,
#	and returns the appropriate HTTP::Response object based on the
#	current verbosity setting.

my %no_such_name = (
    celestrak => 'CelesTrak',
    spaceflight => 'Manned Spaceflight',
    spacetrack => 'Space Track',
);
my %no_such_trail = (
    spacetrack => <<'EOD',
The Space Track data sets are actually numbered. The given number
corresponds to the data set without names; if you are requesting data
sets by number and want names, add 1 to the given number. When
requesting Space Track data sets by number the 'with_name' attribute is
ignored.
EOD
);
sub _no_such_catalog {
    my $self = shift;
    my $source = lc shift;
    my $catalog = shift;
    my $note = shift;
    my $name = $no_such_name{$source} || $source;
    my $lead = $catalogs{$source}{$catalog} ?
	"Missing $name catalog '$catalog'" :
	"No such $name catalog as '$catalog'";
    $lead .= defined $note ? " ($note)." : '.';
    return HTTP::Response->new (RC_NOT_FOUND, "$lead\n")
	unless $self->{verbose};
    my $resp = $self->names ($source);
    return HTTP::Response->new (RC_NOT_FOUND,
	join '', "$lead Try one of:\n", $resp->content,
	$no_such_trail{$source} || ''
    );
}

#	_parse_args parses options off an argument list. The first
#	argument must be a list reference of options to be parsed.
#	This list is pairs of values, the first being the Getopt::Long
#	specification for the option, and the second being a description
#	of the option suitable for help text. Subsequent arguments are
#	the arguments list to be parsed. It returns a reference to a
#	hash containing the options, followed by any remaining
#	non-option arguments. If the first argument after the list
#	reference is a hash reference, it simply returns.

sub _parse_args {
    my ( $lgl_opts, @args ) = @_;
    ref $args[0] eq 'HASH' and return @args;
    my %lgl = @{ $lgl_opts };
    my $opt = {};
    local @ARGV = @args;
    GetOptions ($opt, keys %lgl) or croak <<"EOD";
Error - Legal options are@{[map {(my $q = $_) =~ s/=.*//;
	$q =~ s/!//;
	"\n  -$q $lgl{$_}"} sort keys %lgl]}
with dates being either Perl times, or numeric year-month-day, with any
non-numeric character valid as punctuation.
EOD
    return ( $opt, @ARGV );
}

#	_parse_retrieve_args parses the retrieve() options off its
#	arguments, prefixes a reference to the resultant options hash to
#	the remaining arguments, and returns the resultant list. If the
#	first argument is a list reference, it is taken as extra
#	options, and removed from the argument list. If the next
#	argument after the list reference (if any) is a hash reference,
#	it simply returns its argument list, under the assumption that
#	it has already been called.

my @legal_retrieve_args = (
    descending => '(direction of sort)',
    'end_epoch=s' => 'date',
    last5 => '(ignored if -start_epoch or -end_epoch specified)',
    'sort=s' => "type ('catnum' or 'epoch', with 'catnum' the default)",
    'start_epoch=s' => 'date',
);

sub _parse_retrieve_args {
    my @args = @_;
    my $extra_args = ref $args[0] eq 'ARRAY' ? shift @args : undef;

    my $opt;

    if ( 'HASH' eq ref $args[0] ) {

	$opt = { %{ shift @args } };	# Poor man's clone

    } else {

	( $opt, @args ) = _parse_args(
	    ( $extra_args ? [ @legal_retrieve_args, @{ $extra_args } ] :
		\@legal_retrieve_args ), @args );

    }

    $opt->{sort} ||= 'catnum';

    $opt->{sort} eq 'catnum' or $opt->{sort} eq 'epoch' or die <<"EOD";
Error - Illegal sort '$opt->{sort}'. You must specify 'catnum'
        (the default) or 'epoch'.
EOD

    return ( $opt, @args );
}

#	$opt = _parse_retrieve_dates ($opt);

#	This subroutine looks for keys start_epoch and end_epoch in the
#	given option hash, parses them as YYYY-MM-DD (where the letters
#	are digits and the dashes are any non-digit punctuation), and
#	replaces those keys' values with a reference to a list
#	containing the output of timegm() for the given time. If only
#	one epoch is provided, the other is defaulted to provide a
#	one-day date range. If the syntax is invalid, we croak.
#
#	The return is the same hash reference that was passed in.

sub _parse_retrieve_dates {
    my $opt = shift;
    my $ctl = shift || {};

    my $found;
    foreach my $key (qw{end_epoch start_epoch}) {
	next unless $opt->{$key};
	$opt->{$key} !~ m/ \D /smx or
	    $opt->{$key} =~ m/ \A (\d+) \D+ (\d+) \D+ (\d+) \z /smx
		and $opt->{$key} = eval {timegm (0, 0, 0, +$3, $2-1, +$1)}
		or croak <<"EOD";
Error - Illegal date '$opt->{$key}'. Valid dates are a number
	(interpreted as a Perl date) or numeric year-month-day.
EOD
	$found++;
    }

    if ($found) {
	if ($found == 1) {
	    $opt->{start_epoch} ||= $opt->{end_epoch} - 86400;
	    $opt->{end_epoch} ||= $opt->{start_epoch} + 86400;
	}
	$opt->{start_epoch} <= $opt->{end_epoch} or croak <<'EOD';
Error - End epoch must not be before start epoch.
EOD
	unless ($ctl->{perldate}) {
	    foreach my $key (qw{start_epoch end_epoch}) {
		$opt->{$key} = [gmtime ($opt->{$key})];
	    }
	}
    }

    return $opt;
}

#	_parse_search_args parses the search_*() options off its
#	arguments, prefixes a reference to the resultant options
#	hash to the remaining arguments, and returns the resultant
#	list. If the first argument is a hash reference, it simply
#	returns its argument list, under the assumption that it
#	has already been called.

my @legal_search_args = (
    'rcs!' => '(append --rcs radar_cross_section to name)',
    'tle!' => '(return TLE data from search (defaults true))',
    'status=s' => q{('onorbit', 'decayed', or 'all')},
    'exclude=s@' => q{('debris', 'rocket', or 'debris,rocket')},
);
my %legal_search_exclude = map {$_ => 1} qw{debris rocket};
my %legal_search_status = map {$_ => 1} qw{onorbit decayed all};

sub _parse_search_args {
    my @args = @_;
    unless (ref ($args[0]) eq 'HASH') {
	ref $args[0] eq 'ARRAY' and my @extra = @{shift @args};
	@args = _parse_retrieve_args(
	    [ @legal_search_args, @extra ], @args );

	my $opt = $args[0];
	$opt->{status} ||= 'all';
	$legal_search_status{$opt->{status}} or croak <<"EOD";
Error - Illegal status '$opt->{status}'. You must specify one of
        @{[join ', ', map {"'$_'"} sort keys %legal_search_status]}
EOD
	$opt->{exclude} ||= [];
	$opt->{exclude} = [map {split ',', $_} @{$opt->{exclude}}];
	foreach (@{$opt->{exclude}}) {
	    $legal_search_exclude{$_} or croak <<"EOD";
Error - Illegal exclusion '$_'. You must specify one or more of
        @{[join ', ', map {"'$_'"} sort keys %legal_search_exclude]}
EOD
	}
    }

    return @args;
}

#	_post is just like _get, except for the method used. DO NOT use
#	this method in the login () method, or you get a bottomless
#	recursion.

sub _post {
    my ($self, $path, @args) = @_;
    {	# Single-iteration loop
	$self->{debug_url} or $self->{cookie_expires} > time () or do {
	    my $resp = $self->login ();
	    return $resp unless $resp->is_success;
	};
	my $url = "$self->{scheme_space_track}://$self->{domain_space_track}/$path";
	my $resp = $self->_dump_request( $url, @args) ||
	    $self->{agent}->post ($self->{debug_url} || $url, [@args]);
	$self->_dump_headers( $resp );
##	return $resp unless $resp->is_success && !$self->{debug_url};
	$resp->is_success()
	    and not $self->{debug_url}
	    or return $resp;
	local $_ = $resp->content;
	m/ login [.] pl /smxi and do {
	    $self->{cookie_expires} = 0;
	    redo;
	};
	return $resp;
    }	# end of single-iteration loop
    return;	# Should never arrive here.
}

#	_search wraps the specific search functions. It is called
#	O-O style, with the first argument (after $self) being a
#	reference to the code that actually requests the data from
#	the server. This code takes two arguments ($self and $name,
#	the latter being the thing to search for), and returns the
#	HTTP::Response object from the request.
#
#	The referenced code is given three arguments: $self, the name
#	of the object to search for, and the option hash. If the
#	referenced code needs the name parsed further, it must do so
#	itself, returning undef if the parse fails.

sub _search_generic {
    my ($self, $poster, @args) = @_;
    delete $self->{_pragmata};

    @args = _parse_retrieve_args( @args );
    my $opt = shift @args;

    @args or return HTTP::Response->new (RC_PRECONDITION_FAILED, NO_OBJ_NAME);

    my %id;
    my $resp;
    $resp = $self->_search_generic_tabulate( \%id, $poster, $opt, @args )
	and return $resp;

    exists $opt->{tle} or $opt->{tle} = 1;
    if ( $opt->{tle} ) {
	my $with_name = $self->getv( 'with_name' );
	$resp = $self->retrieve ($opt, sort {$a <=> $b} keys %id);
	if ( $opt->{rcs} ) {
	    my $content = $resp->content();
	    my $replace = $with_name ? sub {
		my ( $newline, $oid ) = @_;
		return ( $id{$oid} && $id{$oid}[-1] ) ?
		    sprintf( " --rcs %s\n1%6d", $id{$oid}[-1], $oid ) :
		    sprintf( "\n1%6d", $oid );
	    } : sub {
		my ( $newline, $oid ) = @_;
		return ( $id{$oid} && $id{$oid}[-1] ) ?
		    sprintf( "%s--rcs %s\n1%6d", $newline,
			$id{$oid}[-1], $oid ) :
		    sprintf( "%s1%6d", $newline, $oid );
	    };
	    $content =~ s{ ( \A | \n ) 1 \s* ( \d+ ) }
				{ $replace->( $1 || '', $2 ) }smxge;
	    $resp->content( $content );
	}
    } else {
	my $content;
	foreach my $oid ( sort { $a <=> $b } keys %id ) {
	    $content .= join( "\t", @{ $id{$oid} } ) . "\n";
	}
	$resp = HTTP::Response->new (RC_OK, undef, undef, $content);
	$self->_add_pragmata($resp,
	    'spacetrack-type' => 'search',
	    'spacetrack-source' => 'spacetrack',
	);
    }
    wantarray or return $resp;
    my @table;
    foreach my $oid ( sort { $a <=> $b } keys %id ) {
	push @table, [
	    map { ( defined $_ && $_ ne '' ) ? $_ : undef }
	    @{ $id{$oid} } ];
    }
    return ($resp, \@table);
}

sub _search_generic_tabulate {
    my ( $self, $id, $poster, $opt, @args ) = @_;

    my $splice = -2;
    if ( ref $poster eq 'HASH' ) {
	exists $poster->{splice} and $splice = $poster->{splice};
	exists $poster->{poster}
	    or confess 'Programming error - no {poster} key in options hash';
	$poster = $poster->{poster};
    }
    my $p = Astro::SpaceTrack::Parser->new ();

    foreach my $name ( @args ) {
	defined (my $resp = $poster->($self, $name, $opt)) or next;
##	return $resp unless $resp->is_success && !$self->{debug_url};
	$resp->is_success()
	    and not $self->{debug_url}
	    or return $resp;
	my $content = $resp->content;
	next if $content =~ m/ No \s results \s found /smxi;
	$content =~ s/ &nbsp; / /smxg;
	my @this_page = @{$p->parse_string (table => $content)};
	ref $this_page[0] eq 'ARRAY'
	    or return HTTP::Response->new (RC_INTERNAL_SERVER_ERROR,
	    BAD_SPACETRACK_RESPONSE, undef, $content);
	my @data = @{$this_page[0]};
	if ( $splice ) {
	    foreach my $row (@data) {
		splice @{ $row }, $splice;
	    }
	}
	if ( $id->{0} ) {
	    shift @data;
	} else {
	    foreach ( @{ $data[0] } ) {
		s/ \s* [(] key [)] \s* \z //smxi;
	    }
	    $id->{0} = shift @data;
	}
	foreach my $row (@data) {
	    my $oid = $row->[0] or next;
	    $id->{$oid} and next;
	    $id->{$oid} = $row;
	}
    }

    return;
}


#	_source takes a filename, and returns the contents of the file
#	as a list. It dies if anything goes wrong.

sub _source {
    my $self = shift;
    wantarray or die <<'EOD';
Error - _source () called in scalar or no context. This is a bug.
EOD
    my $fn = shift or die <<'EOD';
Error - No source file name specified.
EOD
    my $fh = IO::File->new ($fn, '<') or die <<"EOD";
Error - Failed to open source file '$fn'.
        $!
EOD
    return <$fh>;
}

#	_trim replaces undefined arguments with '', trims all arguments
#	front and back, and returns the modified arguments.

sub _trim {
    my @args = @_;
    foreach ( @args ) {
	defined $_ or $_ = '';
	s/ \A \s+ //smx;
	s/ \s+ \z //smx;
    }
    return @args;
}

1;

__END__