File Coverage

blib/lib/NetHack/NAOdash.pm

Criterion	Covered	Total	%
statement	72	89	80.9
branch	8	22	36.3
condition	10	24	41.6
subroutine	15	18	83.3
pod	2	4	50.0
total	107	157	68.1

package NetHack::NAOdash;

use 5.014000;
use strict;
use warnings;
use re '/saa';
use parent qw/Exporter/;

our $VERSION = '0.003';
our @EXPORT_OK = qw/naodash_xlog naodash_user/;
our @EXPORT = @EXPORT_OK;

use File::Slurp;
use File::Spec::Functions qw/tmpdir catdir catfile/;
use HTTP::Tiny;
use List::Util qw/max min sum/;
use List::MoreUtils qw/uniq/;
use Text::XLogfile qw/parse_xlogline/;

sub won_game {
	my %game = @_;
	$game{death} eq 'ascended'
}

our @check_subs = (
	sub { # Combos
		my %game = @_;
		return unless won_game %game;
		$game{align0} //= $game{align};
		"combo_$game{role}_$game{race}_$game{align0}"
	},

	sub { # Achievements
		my %game = @_;
		my @achieves = qw/bell gehennom candelabrum book invocation amulet endgame astral ascended luckstone sokoban medusa/;
		map { $game{achieve} & (1 << $_) ? "achieve_$achieves[$_]" : () } 0 .. $#achieves
	},

	sub { # Conducts
		my %game = @_;
		return unless won_game %game;
		my @conducts = qw/foodless vegan vegetarian atheist weaponless pacifist illiterate polypileless polyselfless wishless artiwishless genocideless/;
		map { $game{conduct} & (1 << $_) ? "conduct_$conducts[$_]" : () } 0 .. $#conducts
	},

	sub { # Unofficial conducts
		my %game = @_;
		return unless won_game %game;
		my @uconducts;
		push @uconducts, 'survivor' if $game{deaths} == 0;
		push @uconducts, 'boneless' unless $game{flags} & 32;
		push @uconducts, 'minscore' if $game{points} - 100 * ($game{maxlvl} - 45) == 24_400;
		map { "uconduct_$_" } @uconducts
	},
);

our %sum_subs = (
	games => sub { 1 },
	ascensions => sub {
		my %game = @_;
		!!won_game %game
	},
	totalrealtime => sub {
		my %game = @_;
		$game{realtime} // 0
	},
);

sub make_attr_sub ($) { ## no critic (ProhibitSubroutinePrototypes)
	my ($attr) = @_;
	sub {
		my %game = @_;
		return unless won_game %game;
		$game{$attr} // ()
	},
}

our %max_subs = (
	maxhp => make_attr_sub 'maxhp',
	maxpoints => make_attr_sub 'points',
	maxconducts => make_attr_sub 'nconducts',
);

our %min_subs = (
	minturns => make_attr_sub 'turns',
	minrealtime => make_attr_sub 'realtime',
);

sub naodash_xlog { ## no critic (RequireArgUnpacking)
	my (%args, %exclude, %include);
	%args = %{shift()} if ref $_[0] eq 'HASH'; ## no critic (Builtin)
	%exclude = map { $_ => 1 } @{$args{exclude_versions} // []};
	%include = map { $_ => 1 } @{$args{include_versions} // []};
	my ($xlog) = join '', @_;
	my %number_subs = (%sum_subs, %max_subs, %min_subs);

	my @checks;
	my %numbers = map { $_ => [] } keys %number_subs;

	for my $logline (split /\n/, $xlog) {
		my %game = %{parse_xlogline $logline};
		for (keys %game) {
			delete $game{$_} if $game{$_} eq ''
		}
		next if $exclude{$game{version}} || %include && !$include{$game{version}};
		next if $game{flags} & 3; # flag 0x01 is wizard mode, 0x02 is explore mode
		push @checks, $_->(%game) for @check_subs;
		push @{$numbers{$_}}, $number_subs{$_}->(%game) for keys %number_subs;
	}

	$numbers{$_} = sum @{$numbers{$_}} for keys %sum_subs;
	$numbers{$_} = max @{$numbers{$_}} for keys %max_subs;
	$numbers{$_} = min @{$numbers{$_}} for keys %min_subs;
	@checks = uniq map { lc } @checks;

	{checks => [sort @checks], numbers => \%numbers}
}

my $ht = HTTP::Tiny->new(agent => "NetHack-NAOdash/$VERSION ");

sub _get_xlog_from_server {
	my ($name) = @_;
	my $ret = $ht->get("http://alt.org/nethack/player-all-xlog.php?player=$name");
	die 'Error while retrieving xlogfile from alt.org: ' . $ret->{status} . ' ' . $ret->{reason} . "\n" unless $ret->{success};
	$ret->{content} =~ m{(.*)}i;
}

sub _get_xlog {
	my ($name) = @_;
	return _get_xlog_from_server $name if $ENV{NAODASH_CACHE} && lc $ENV{NAODASH_CACHE} eq 'none';
	my $dir = $ENV{NAODASH_CACHE} || catdir tmpdir, 'naodash';
	mkdir $dir or die "Cannot create cache directory: $!\n" unless -d $dir;
	my $file = catfile $dir, $name;
	write_file $file, _get_xlog_from_server $name if ! -f $file || time - (stat $file)[9] >= 86_400;
	scalar read_file $file
}

sub naodash_user { ## no critic (RequireArgUnpacking)
	my $args = {};
	$args = shift if ref $_[0] eq 'HASH';
	my ($name) = @_;
	my $xlog = _get_xlog $name;
	die "No xlogfile found for user $name\n" unless defined $xlog;
	naodash_xlog $args, $xlog;
}

1;
__END__