X-Git-Url: http://git.ieval.ro/?p=nethack-naodash.git;a=blobdiff_plain;f=lib%2FNetHack%2FNAOdash.pm;h=5a27640c15728b2892f052d4ff5c32bbff0fd0fb;hp=af574ef2fcfe71b12796bc383c4ef412bfe53834;hb=350c8f14c97a428aff2cf1a7267d61c22be127a9;hpb=01ba3ddc757514e3474b1c79855de5fea5da1445 diff --git a/lib/NetHack/NAOdash.pm b/lib/NetHack/NAOdash.pm index af574ef..5a27640 100644 --- a/lib/NetHack/NAOdash.pm +++ b/lib/NetHack/NAOdash.pm @@ -6,10 +6,12 @@ use warnings; use re '/saa'; use parent qw/Exporter/; -our $VERSION = '0.001'; +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/; @@ -85,6 +87,10 @@ our %min_subs = ( ); 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); @@ -96,6 +102,7 @@ sub naodash_xlog { ## no critic (RequireArgUnpacking) 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; @@ -111,13 +118,30 @@ sub naodash_xlog { ## no critic (RequireArgUnpacking) my $ht = HTTP::Tiny->new(agent => "NetHack-NAOdash/$VERSION "); -sub naodash_user { +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}; - my ($xlog) = $ret->{content} =~ m{
(.*)}i; + $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 $xlog; + naodash_xlog $args, $xlog; } 1; @@ -133,18 +157,23 @@ NetHack::NAOdash - Analyze NetHack xlogfiles and extract statistics use NetHack::NAOdash; my $stats = naodash_user 'mgv'; # Retrieve and analyze mgv's xlogfile from alt.org - my @checks = @{$stats->{checks}}; # List of "achievements" obtained by mgv + my @checks = @{$stats->{checks}}; # List of 'achievements' obtained by mgv my %checks = map { $_ => 1 } @checks; - say "mgv has ascended an orcish rogue" if $checks{combo_rog_orc_cha}; - say "mgv has ascended an atheist character" if $checks{conduct_atheist}; + say 'mgv has ascended an orcish rogue' if $checks{combo_rog_orc_cha}; + say 'mgv has ascended an atheist character' if $checks{conduct_atheist}; my %numbers = %{$stats->{numbers}}; say "mgv has ascended $numbers{ascensions} out of $numbers{games} games"; say "mgv has spent $numbers{totalrealtime} seconds playing NetHack on NAO"; + $stats = naodash_user {include_versions => ['3.6.0']}, 'mgv'; + say 'mgv has ascended an orcish rogue in 3.6.0' if $checks{combo_rog_orc_cha}; + $stats = naodash_user {exclude_versions => ['3.6.0']}, 'mgv'; + say 'mgv has ascended an atheist character pre-3.6.0' if $checks{conduct_atheist}; + use File::Slurp; $stats = naodash_xlog read_file 'path/to/my/xlogfile'; %checks = map { $_ => 1 } @{$stats->{checks}}; - say "I have ascended a survivor" if $checks{uconduct_survivor}; + say 'I have ascended a survivor' if $checks{uconduct_survivor}; =head1 DESCRIPTION @@ -240,14 +269,35 @@ This module exports two functions: =over -=item B