The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
package Perl::Achievements;
BEGIN {
  $Perl::Achievements::AUTHORITY = 'cpan:YANICK';
}
{
  $Perl::Achievements::VERSION = '0.4.0';
}
# ABSTRACT: whoever die()s with the most badges win


use 5.10.0;

use strict;
use warnings;

no warnings qw/ uninitialized /;

use Moose;
use MooseX::SemiAffordanceAccessor;
use MooseX::ClassAttribute;

use Perl::Achievements::User;

use Module::Pluggable
  search_path => ['Perl::Achievements::Achievement'],
  require     => 1;

use YAML::Any qw/ LoadFile Load Dump /;
use PPI;
use File::HomeDir;
use Path::Class qw/ file dir /;
use Method::Signatures;
use DateTime::Functions;
use Data::Printer;
use Digest::SHA qw/ sha1_hex /;
use File::Touch;

extends 'MooseX::App::Cmd';

with qw/ 
    MooseX::Role::Loggable
    MooseX::ConfigFromFile
/;

with 'MooseX::Role::BuildInstanceOf' => {
    target => 'Perl::Achievements::User',
    prefix => 'user',
};

sub get_config_from_file {
    my ( undef, $file ) = @_;

    return {} if not -f $file; 

    my $config = LoadFile( $file );

    # massage the config a wee bit
    if ( $config->{user} ) {
        $_ = [ %$_ ] for $config->{user_args} = delete $config->{user};
    }

    return $config;
}

my $configfile = ''.file(
    $ENV{PERL_ACHIEVEMENTS_HOME} 
        || dir( File::HomeDir->my_home, '.perl-achievements' ),
    'config'
);

has '+configfile' => (
    default => $configfile,
);

class_has rc => (
    is => 'ro',
    default => sub {
        $ENV{PERL_ACHIEVEMENTS_HOME} 
            || dir( File::HomeDir->my_home, '.perl-achievements' );
    },
    lazy => 1,
);

sub rc_file_path {
    my ( $self, @path ) = @_;

    return file( $self->rc, @path );
}


has _achievements => (
    traits => [ 'Array' ], 
    is      => 'ro',
    builder => '_achievements_builder',
    handles => {
        achievements => 'elements',
        add_achievements => 'push',
    },
);

has ppi => (
    is => 'rw',
);

# will change
has history => (
    is => 'ro',
    default => sub {
        my $file = $_[0]->rc_file_path( 'history' );
        return [] unless -f $file;

        return [ map { Load( $_ ) } split /^---\n/, scalar $file->slurp ];
    },
);

has interactive => (
    is => 'ro',
    isa => 'Bool',
    default => 1,
);

has dry_run => (
    is => 'ro',
    isa => 'Bool',
    default => 0,
);

method scan ($file) {
    $self->set_ppi( PPI::Document->new( $file ) );

    my $digest = sha1_hex($self->ppi->serialize);
    my $digest_file = $self->rc_file_path( 'scanned', $digest );

    if ( -f $digest_file ) {
        $self->log_debug( "file '$file' already has been scanned" );
        return;
    }

    $_->scan for $self->achievements;

    $digest_file->touch;
}

sub _achievements_builder {
    my $self = shift;

    my @checks;

    push @checks, $_->load_or_new( app => $self ) for $self->plugins;

    return \@checks;
}

method initialize_environment {
    my $dir = $self->rc;

    die "'$dir' already exist, aborting" if -e $dir;

    mkdir $dir;
    mkdir dir( $dir, 'achievements' );
    mkdir dir( $dir, 'scanned' );

    my $config = file( $dir, 'config' )->openw;

    print $config <<'END_CONFIG';
# user: 
#   name: Your Name Here
#   url: http://yoursite.org/

END_CONFIG

}

sub unlock_achievement {
    my ( $self, %info ) = @_;

    $self->log_debug( "achievement unlocked:\n" 
        . p( %info, colored => 0 )
    );

    $self->add_to_history( %info ) unless $self->dry_run;
}

sub add_to_history {
    my $self = shift;
    my %info = @_;
    my $file = $self->rc_file_path( 'history' );
    open my $fh, '>>', $file;
    print {$fh} Dump \%info;
}

after unlock_achievement => sub {
    my( $self, %info ) = @_;

    return unless $self->interactive;

    say 'Congrats! You have unlocked a new achievement!';

    say '*' x 60;
    say '*** ', $info{achievement};
    say '*** level ', $info{level} if $info{level};
    say '';
    say $info{details} if $info{details};
    say '*' x 60;
};

method generate_report( $format ) {
    my $class = 'Perl::Achievements::Report::'. ucfirst $format;

    eval "use $class; 1" 
        or die "could not use format '$format': $@\n";

    my $report = $class->new(
        who => $self->user->name,
        history => $self->history,
    );

    return $report->generate;
}

1;

__END__
=pod

=head1 NAME

Perl::Achievements - whoever die()s with the most badges win

=head1 VERSION

version 0.4.0

=head1 SYNOPSIS

    use Perl::Achievements;

    my $pa = Perl::Achievements->new;

    $pa->scan( $file );

=head1 DESCRIPTION

If you want to use C<perl-achievement>, look 
at L<perlachievements>.

If you want to implement a new achievement,
look at L<Perl::Achievements::Achievement>.

WARNING: C<Perl::Achievements> is young, rough,
and subject to change. You've been warned.

=head1 AUTHOR

Yanick Champoux <yanick@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 by Yanick Champoux.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut