#!/usr/bin/env perl

package heavens_above_mag;

use 5.010;

use strict;
use warnings;

use Getopt::Long 2.33 qw{ :config auto_version };
use HTML::TreeBuilder;
use LWP::UserAgent;
use Pod::Usage;
use YAML 1.25 qw{ Dump Load };

our $VERSION = '0.134';

use constant CACHE_DIR	=> 'cache';

use constant MARK	=> '# $$';
use constant MARK_BEGIN	=> join ' ', MARK, 'BEGIN';
use constant MARK_BEGIN_MAG	=> join ' ', MARK_BEGIN, 'magnitude_table';
use constant MARK_END	=> join ' ', MARK, 'END';
use constant MODIFY_FILE	=> 'lib/Astro/Coord/ECI/TLE.pm';

use constant REF_CODE	=> sub {};

use constant VISUAL_URL	=> 'https://celestrak.org/SpaceTrack/query/visual.txt';
use constant VISUAL_YML	=> 'visual.yml';

my %opt = (
    age	=> 86400,	# One day, in seconds
);

unless ( caller ) {	# We're a modulino.
    GetOptions( \%opt,
	qw{ age=i celestrak! open! purge! update! verbose! },
	help	=> sub { pod2usage( { -verbose => 2 } ) },
    ) or pod2usage( { -verbose => 0 } );

    $opt{celestrak} //= $opt{update};

    if ( $opt{purge} ) {
	require File::Glob;
	my $glob = join '/', CACHE_DIR, '*';
	foreach ( File::Glob::bsd_glob( $glob ) ) {
	    unlink
		or warn "Failed to remove $_: $!\n";
	}
	@ARGV
	    or $opt{celestrak}
	    or exit;
    }

    if ( $opt{celestrak} ) {
	@ARGV and pod2usage( {
		-message	=> 'Arguments forbidden with --celestrak',
		-verbose	=> 0,
	    } );
	process_celestrak();
    } else {
	@ARGV or pod2usage( {
		-message	=> 'Arguments required unless --celestrak or --purge specified',
		-verbose	=> 0,
	    } );

	if ( $opt{open} ) {
	    process_open( @ARGV );
	} else {
	    process_perl( @ARGV );
	}
    }
}

# This mess exists because Heavens-Above enclosed multiple table rows in
# a <span>..</span>. This is a standards violation which (e.g.) Firefox
# tolerates, but HTML::TreeBuilder's parse emits such spans as empty
# tags at some indeterminate point in the parse. Unless this is fixed,
# we will have to just hope they continue to honor the Accept-Language
# request header, or that the default language remains English.
sub find_td_by_content {
    my ( $tree, $re ) = @_;

    my $ele = $tree->look_down( _tag => 'td', sub {
	    ( local $_ ) = $_[0]->content_list();
	    defined
		or return $_;
	    return $_ =~ $re;
	} )
	or return;

    my ( $val ) = $ele->content_list();
    $val =~ s/ \A \s+ //smx;
    $val =~ s/ \s+ .* //smx;
    return $val;
}

sub find_span {
    my ( $tree, $id ) = @_;
    my $ele = $tree->look_down( _tag => 'span', id => $id )
	or die "Bug - span id='$id' not found";
    my ( $val ) = $ele->content_list();
    $val =~ s/ \A \s+ //smx;
    $val =~ s/ \s+ \z //smx;
    return $val;
}

sub get_cached {
    my ( $file, $uri ) = @_;

    my $path = join '/', CACHE_DIR, $file;
    -d CACHE_DIR
	or mkdir CACHE_DIR
	or die "Failed to create directory @{[ CACHE_DIR ]}/: $!\n";

    {
	my @stat;
	@stat = stat $path
	    and $stat[9] + $opt{age} > time
	    and do {
	    open my $fh, '<:encoding(utf-8)', $path
		or die "Failed to open $path for input: $!\n";
	    local $/ = undef;
	    local $YAML::LoadBlessed = 1;
	    return Load( <$fh> );
	};
    }

    state $ua = LWP::UserAgent->new();
    my $resp = $ua->get( $uri );
    $resp->is_success()
	or die "Failed to fetch $uri: ", $resp->status_line();
    my ( $last_modified ) = $resp->header( 'Last-Modified' );
    my $content = $resp->decoded_content();
    $content =~ s/ \r (?= \n ) //smxg;
    my $data = {
	last_modified	=> $last_modified,
	content		=> $content,
    };
    open my $fh, '>:encoding(utf-8)', $path
	or die "Failed to open $path for output: $!\n";
    print { $fh } Dump( $resp );
    return $resp;
}

sub get_file {
    my ( $fn ) = @_;
    local $/ = undef;
    open my $fh, '<:encoding(utf-8)', $fn
	or die "Unable to open $fn: $!\n";
    my $content = <$fh>;
    close $fh;
    return $content;
}

sub get_html {
    my ( $oid ) = @_;
    my $url = heavens_above_url( $oid );
    my $resp = get_cached( "oid-$oid", $url );
    return $resp->decoded_content();
}

sub heavens_above_url {
    my ( $oid ) = @_;
    $oid =~ m/ \A [0-9]+ \z /smx
	or die "OID '$oid' not numeric\n";
    return sprintf 'https://www.heavens-above.com/SatInfo.aspx?satid=%05d', $oid;
}

sub open_file_for_output {
    my ( $path ) = @_;
    open my $fh, '>:encoding(utf-8)', $path
	or die "Failed to open $path: $!\n";
    return $fh;
}

sub print_perl {
    my ( $oid, $name, $mag ) = @_;
    if ( defined $mag ) {
	# die "Debug - $oid ($name) '$mag'";
	printf "  '%05d' => %5.1f, # %s\n", $oid, $mag, $name;
    } else {
	printf "  '%05d' => undef, # %s has no recorded magnitude\n", $oid, $name;
    }
    return;
}

sub process_celestrak {
    my $visual = get_cached( VISUAL_YML, VISUAL_URL );
    my ( $last_modified ) = $visual->header( 'Last-Modified' );
    my ( @preamble, @postamble );
    my @options = qw{ --celestrak };
    if ( $opt{update} ) {
	open my $fh, '<:encoding(utf-8)', MODIFY_FILE
	    or die "Failed to open @{[ MODIFY_FILE ]}: $!\n";
	local $_ = undef;
	while ( <$fh> ) {
	    push @preamble, $_;
	    $_ eq MARK_BEGIN_MAG . "\n"
		and last;
	}
	defined $_
	    or die q/Failed to find '/, MARK_BEGIN_MAG, q/' in /,
		MODIFY_FILE, "\n";
	push @preamble, "\n";
	while ( <$fh> ) {
	    $_ eq MARK_END . "\n"
		and last;
	}
	defined $_
	    or die q/Failed to find '/, MARK_END, q/' in /, MODIFY_FILE, "\n";
	push @postamble, "\n", $_;
	while ( <$fh> ) {
	    push @postamble, $_;
	}
	close $fh;
	push @options, qw{ --update };
    }
    $opt{update}
	and local *STDOUT = open_file_for_output( MODIFY_FILE );
    print @preamble;
    print <<"EOD";
# The following is all the Celestrak visual list that have magnitudes in
# Heavens Above. These data are generated by the following:
#
#   \$ tools/heavens-above-mag @options
#
# Last-Modified: @{[ $last_modified // 'unknown' ]}

%magnitude_table = (
EOD

    my %oid = parse_visual( $visual );
    process_perl( sort { $a <=> $b } keys %oid );
    say ');';
    print @postamble;
    return;
}

sub parse_visual {
    my ( $resp ) = @_;
    my $content = $resp->decoded_content();
    local $_ = undef;	# while (<>) ... does not localize $_.
    my %oid;
    open my $fh, '<', \$content;
    local $_ = undef;  # while (<>) ... does not localize $_.
    while ( <$fh> ) {
	my ( $id, $name ) = unpack 'A5A*';
	$oid{$id} = $name;
    }
    close $fh;
    foreach (
	[ '53807', 'Bluewalker 3' ],
    ) {
	my ( $extra, $name ) = @{ $_ };
	if ( defined $oid{$extra} ) {
	    warn "OID $extra is already in visual.txt\n";
	} else {
	    $opt{verbose} and warn "Adding OID $extra\n";
	    $oid{$extra} = $name;
	}
    }
    return %oid;
}

sub process_get {
    my ( $spec ) = @_;
    my @rslt;
    process_parse(
	sub {
	    push @rslt, [ @_ ];
	    return;
	},
	$spec,
    );
    return @rslt;
}

sub process_open {
    my @arg = @_;
    require Browser::Open;
    my $cmd = Browser::Open::open_browser_cmd();
    foreach my $oid ( @arg ) {
	my $url = heavens_above_url( $oid );
	system { $cmd } $cmd, $url;
    }
    return;
}

sub process_parse {
    my ( $handler, @arg ) = @_;
    foreach my $spec ( @arg ) {
	my $get = $spec =~ m/ \A [0-9]+ \z /smx ? \&get_html : \&get_file;
	my $tree = HTML::TreeBuilder->new_from_content( $get->( $spec ) );
	# print $tree->as_HTML();
	# Should return a <span>..</span> containing the OID
	my $oid = find_span( $tree, 'ctl00_cph1_lblSatID' );
	# Should return a <span>..</span> containing the name
	my $name = find_span( $tree, 'ctl00_cph1_lblOIGName' );
	# We would like to look for id ctl00_cph1_lblBrightness here, but it
	# contains table rows (which it should not), so HTML::TreeBuilder
	# spits it out any old where. Sometimes before the table, sometimes
	# in the middle of it (but still empty). So we just have to hope the
	# default display is English.
	my $mag = find_td_by_content(
	    $tree, qr< \b at \s+ 1000 \s* km \s+ distance \b >smxi );
	$handler->( $oid, $name, $mag );
    }
    return;
}

sub process_perl {
    my ( @arg ) = @_;
    process_parse( \&print_perl, @arg );
    return;
}

1;

__END__

=head1 TITLE

heavens-above-mag - Get magnitudes from Heavens Above

=head1 SYNOPSIS

 heavens-above-mag 25544
 heavens-above-mag --help
 heavens-above-mag --version

=head1 OPTIONS

=head2 --age

 --age 43200

This option specifies the maximum age of the cache, in seconds. Setting
C<--age=0> disables the cache.

The default is C<--age=86400>, i.e. one day.

=head2 --celestrak

If this Boolean option is asserted, the OIDs come from Celestrak's
F<visual.txt> file, and the output is the canned magnitude table in
L<Astro::Coord::ECI::TLE|Astro::Coord::ECI::TLE>. If this option is
asserted, no non-option arguments may be specified, and
L<--open|/--open> is ignored.

The default is the value of L<--update|/--update>.

=head2 --help

This option displays the documentation for this script. The script then
exits.

=head2 --open

If this Boolean option is asserted, a web browser is spawned, displaying
the Heavens-Above web page of the OIDs specified. You cannot specify
file names if you specify this option.

=head2 --purge

This option causes the cache to be purged before any magnitudes are
retrieved. The script will exit afterwards unless either arguments or
L<--celestrak|/--celestrak> were specified.

=head2 --update

This option causes everything between the lines

 # $$ BEGIN magnitude_table

and

 # $$ END

in F<lib/Astro/Coord/ECI/TLE.pm> to be replaced by the output
of the L<--celestrak|/--celestrak> option. An error is reported if the
file can not be opened, or if the markers are not found.

The default is C<--no-update>.

=head2 --verbose

If this Boolean option is asserted, whatever information the author
deems useful is displayed on C<STDERR>.

The default is C<--no-verbose>.

=head2 --version

This option displays the version of this script. The script then exits.

=head1 DETAILS

This Perl script parses intrinsic magnitude data out of Heavens Above
data. You can specify either an OID (which is fetched) or a file name
(which is read) or a mixture of the two.

Heavens Above defines intrinsic magnitude as the magnitude at a range of
1000km, and 50% illuminated.

All web I/O goes through a cache in top-level project directory
F<cache/>. Data will come from the cache rather than the web if the file
in the cache is newer than the value of the L<--age|/--age> option. The
cache directory will be created if necessary.

=head1 AUTHOR

Thomas R. Wyant, III F<wyant at cpan dot org>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2021-2025 by Thomas R. Wyant, III

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 Artistic
License 1.0 at
L<https://www.perlfoundation.org/artistic-license-10.html>, and/or the
Gnu GPL at L<http://www.gnu.org/licenses/old-licenses/gpl-1.0.txt>.

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.

=cut

# ex: set textwidth=72 :
