├── .gitignore ├── MANIFEST.SKIP ├── dist.ini ├── lib └── Perl │ ├── Achievements │ ├── Role │ │ └── ConfigItem.pm │ ├── Command │ │ ├── scan.pm │ │ └── init.pm │ ├── Command.pm │ ├── Achievement │ │ ├── PerlHacker.pm │ │ ├── PerlAchiever.pm │ │ ├── WeekendWarrior.pm │ │ └── Cryptomancer.pm │ └── Achievement.pm │ └── Achievements.pm ├── Changes ├── scripts └── perlacheivements └── MANIFEST /.gitignore: -------------------------------------------------------------------------------- 1 | Perl-Achievements-* 2 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | Perl-Achievements.*- 2 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Perl-Achievements 2 | author = Yanick Champoux 3 | license = Perl_5 4 | copyright_holder = Yanick Champoux 5 | 6 | [@YANICK] 7 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Role/ConfigItem.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Role::ConfigItem; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Moose::Role; 7 | 8 | 9 | 1; 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl::Achievements 2 | 3 | {{$NEXT}} 4 | 5 | 0.1.0 2012-02-02 6 | [ENHANCEMENTS] 7 | - add WeekendWarrior achievement 8 | 9 | 10 | 0.0.2 2012-01-30 11 | - unleashed to CPAN, due to severe peer pressure. (aka brian d foy made 12 | me do it) 13 | 14 | 0.0.1 2010-08-20T09:45:12Z 15 | - Birth of a strange new baby. 16 | 17 | -------------------------------------------------------------------------------- /scripts/perlacheivements: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | package 4 | perlachievements; 5 | 6 | =head1 NAME 7 | 8 | perlachievements - run some perl, collect some badges 9 | 10 | =head1 SYNOPSIS 11 | 12 | # create the config directories and such 13 | $ perlachievements init 14 | 15 | # scan files, collect acheivements! 16 | $ perlachievements scan my_script.pl 17 | 18 | # get list of commands 19 | $ perlachievements commands 20 | 21 | 22 | =cut 23 | 24 | use strict; 25 | use warnings; 26 | 27 | use Perl::Achievements; 28 | 29 | Perl::Achievements->run; 30 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Command/scan.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Command::scan; 2 | # ABSTRACT: inspects scripts/modules for achievements 3 | 4 | use 5.10.0; 5 | 6 | =head1 SYNOPSIS 7 | 8 | perl-achievement scan 9 | 10 | =head1 DESCRIPTION 11 | 12 | Inspects the given files for achievements. 13 | 14 | =cut 15 | 16 | use strict; 17 | use warnings; 18 | 19 | use Moose; 20 | 21 | extends 'Perl::Achievements::Command'; 22 | 23 | sub execute { 24 | my ( $self, $opt, $args ) = @_; 25 | 26 | for ( @$args ) { 27 | $self->log_debug( "scanning '$_'..." ); 28 | $self->scan( $_ ); 29 | } 30 | } 31 | 32 | 1; 33 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Build.PL 2 | Changes 3 | INSTALL 4 | LICENSE 5 | MANIFEST 6 | MANIFEST.SKIP 7 | META.json 8 | META.yml 9 | README 10 | README.mkdn 11 | SIGNATURE 12 | dist.ini 13 | lib/Perl/Achievements.pm 14 | lib/Perl/Achievements/Achievement.pm 15 | lib/Perl/Achievements/Achievement/Cryptomancer.pm 16 | lib/Perl/Achievements/Achievement/PerlAchiever.pm 17 | lib/Perl/Achievements/Achievement/PerlHacker.pm 18 | lib/Perl/Achievements/Achievement/WeekendWarrior.pm 19 | lib/Perl/Achievements/Command.pm 20 | lib/Perl/Achievements/Command/init.pm 21 | lib/Perl/Achievements/Command/scan.pm 22 | lib/Perl/Achievements/Role/ConfigItem.pm 23 | scripts/perlacheivements 24 | t/000-report-versions.t 25 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Command.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Command; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Moose; 7 | use MooseX::SemiAffordanceAccessor; 8 | 9 | use Path::Class qw/ dir file /; 10 | use File::HomeDir; 11 | 12 | extends qw/ 13 | MooseX::App::Cmd::Command 14 | Perl::Achievements 15 | /; 16 | 17 | has verbose => ( 18 | isa => 'Bool', 19 | is => 'ro', 20 | ); 21 | 22 | sub BUILDARGS { 23 | my $self = shift; 24 | 25 | my %args = @_ == 1 ? %{$_[0]} : @_; 26 | 27 | my @args = %args; 28 | 29 | unshift @args, debug => 1, log_to_stdout => 1 if $args{verbose}; 30 | 31 | $self->SUPER::BUILDARGS( @args ); 32 | } 33 | 34 | 35 | 1; 36 | 37 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Achievement/PerlHacker.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Achievement::PerlHacker; 2 | # ABSTRACT: just another Perl hacker 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use Moose; 8 | 9 | no warnings qw/ uninitialized /; 10 | 11 | with 'Perl::Achievements::Achievement'; 12 | 13 | has locs => ( 14 | traits => [ qw/ Number Perl::Achievements::Role::ConfigItem / ], 15 | isa => 'Num', 16 | is => 'rw', 17 | handles => { add_locs => 'add', }, 18 | ); 19 | 20 | sub scan { 21 | my $self = shift; 22 | 23 | my @lines = split "\n", $self->ppi->serialize; 24 | $self->add_locs( scalar @lines ); 25 | 26 | if ( $self->locs > 10 ** (1+$self->level) ) { 27 | $self->inc_level; 28 | $self->unlock; 29 | } 30 | 31 | } 32 | 33 | 1; 34 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Command/init.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Command::init; 2 | # ABSTRACT: initializes the perl-achievements environment 3 | 4 | use 5.10.0; 5 | 6 | =head1 SYNOPSIS 7 | 8 | perl-achievement init [ --rc $dir ] 9 | 10 | =head1 DESCRIPTION 11 | 12 | Creates the directory where the configuration and the state 13 | of C will be kept. 14 | 15 | If the directory is not explicitly given via the argument I<--rc> , defaults to 16 | (if defined) the environment variable I, 17 | or I<$HOME/.perl_achievements>. 18 | 19 | =cut 20 | 21 | use 5.10.0; 22 | 23 | use strict; 24 | use warnings; 25 | 26 | use Moose; 27 | 28 | extends 'Perl::Achievements::Command'; 29 | 30 | sub execute { 31 | my ( $self, $opt, $args ) = @_; 32 | 33 | $self->initialize_environment; 34 | 35 | say $self->rc, ' created'; 36 | } 37 | 38 | 39 | 1; 40 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Achievement/PerlAchiever.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Achievement::PerlAchiever; 2 | # ABSTRACT: feeds code to perl-achiever 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use Moose; 8 | use MooseX::SemiAffordanceAccessor; 9 | 10 | no warnings qw/ uninitialized /; 11 | 12 | with 'Perl::Achievements::Achievement'; 13 | 14 | has runs => ( 15 | traits => [ qw/ Counter Perl::Achievements::Role::ConfigItem / ], 16 | isa => 'Num', 17 | is => 'rw', 18 | default => 0, 19 | handles => { 20 | inc_runs => 'inc', 21 | }, 22 | ); 23 | 24 | sub scan { 25 | my $self = shift; 26 | 27 | $self->inc_runs; 28 | 29 | return unless $self->runs >= 2** $self->level; 30 | 31 | $self->inc_level; 32 | $self->unlock( 33 | sprintf "ran perl-achievements against %d scripts/modules", 34 | 2 ** ( $self->level - 1 ) 35 | ); 36 | } 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Achievement/WeekendWarrior.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Achievement::WeekendWarrior; 2 | # ABSTRACT: code over the week-end 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use Moose; 8 | use MooseX::SemiAffordanceAccessor; 9 | 10 | no warnings qw/ uninitialized /; 11 | 12 | with 'Perl::Achievements::Achievement'; 13 | 14 | has days => ( 15 | traits => [ qw/ Counter Perl::Achievements::Role::ConfigItem / ], 16 | isa => 'Num', 17 | is => 'rw', 18 | default => 0, 19 | handles => { 20 | inc_days => 'inc', 21 | }, 22 | ); 23 | 24 | sub scan { 25 | my $self = shift; 26 | 27 | my $wday = (localtime)[6]; 28 | 29 | return unless $wday == 0 or $wday == 6; 30 | 31 | $self->inc_days; 32 | 33 | return unless $self->days >= 2**$self->level; 34 | 35 | $self->inc_level; 36 | $self->unlock( 37 | sprintf "Was at the computer %d days during week-ends", $self->days 38 | ); 39 | } 40 | 41 | 1; 42 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Achievement/Cryptomancer.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Achievement::Cryptomancer; 2 | # ABSTRACT: uses Perl magic variables 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use Moose; 8 | use MooseX::SemiAffordanceAccessor; 9 | 10 | no warnings qw/ uninitialized /; 11 | 12 | use List::MoreUtils qw/ uniq any/; 13 | 14 | with 'Perl::Achievements::Achievement'; 15 | 16 | has variables => ( 17 | traits => [ qw/ Perl::Achievements::Role::ConfigItem / ], 18 | is => 'rw', 19 | default => sub { [] }, 20 | ); 21 | 22 | sub scan { 23 | my $self = shift; 24 | 25 | my $magic = $self->ppi->find( 'PPI::Token::Magic' ) or return; 26 | 27 | my @vars = @{ $self->variables }; 28 | 29 | my @new_vars = uniq @vars, map { $_->content } @$magic; 30 | 31 | return if $self->level == @new_vars; 32 | 33 | $self->set_level( scalar @new_vars ); 34 | 35 | $self->set_variables( \@new_vars ); 36 | 37 | my %vars = map { $_ => 1 } @vars; 38 | @new_vars = sort grep { !$vars{$_} } @new_vars; 39 | 40 | $self->unlock( "new magic variables used: ". join ', ', @new_vars ); 41 | } 42 | 43 | 1; 44 | 45 | 46 | 47 | -------------------------------------------------------------------------------- /lib/Perl/Achievements.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements; 2 | # ABSTRACT: whoever die()s with the most badges win 3 | 4 | =head1 SYNOPSIS 5 | 6 | use Perl::Achievements; 7 | 8 | my $pa = Perl::Achievements->new; 9 | 10 | $pa->scan( $file ); 11 | 12 | =head1 DESCRIPTION 13 | 14 | If you want to use C, look 15 | at L. 16 | 17 | If you want to implement a new achievement, 18 | look at L. 19 | 20 | WARNING: C is young, rough, 21 | and subject to change. You've been warned. 22 | 23 | =cut 24 | 25 | use 5.10.0; 26 | 27 | use strict; 28 | use warnings; 29 | 30 | no warnings qw/ uninitialized /; 31 | 32 | use Moose; 33 | use MooseX::SemiAffordanceAccessor; 34 | 35 | use Module::Pluggable 36 | search_path => ['Perl::Achievements::Achievement'], 37 | require => 1; 38 | 39 | use YAML::Any; 40 | use PPI; 41 | use File::HomeDir; 42 | use Path::Class; 43 | use Method::Signatures; 44 | use DateTime::Functions; 45 | use Data::Printer; 46 | use Digest::SHA qw/ sha1_hex /; 47 | use File::Touch; 48 | 49 | extends 'MooseX::App::Cmd'; 50 | 51 | with qw/ 52 | MooseX::Role::Loggable 53 | /; 54 | 55 | sub get_config_from_file { 56 | my ( $class, $file ) = @_; 57 | 58 | # TODO 59 | } 60 | 61 | has rc => ( 62 | is => 'ro', 63 | isa => 'Str', 64 | default => sub { 65 | $ENV{PERL_ACHIEVEMENTS_HOME} 66 | || dir( File::HomeDir->my_home, '.perl_achievements' ); 67 | }, 68 | lazy => 1, 69 | ); 70 | 71 | sub rc_file_path { 72 | my ( $self, @path ) = @_; 73 | 74 | return file( $self->rc, @path ); 75 | } 76 | 77 | 78 | has _achievements => ( 79 | traits => [ 'Array' ], 80 | is => 'ro', 81 | builder => '_achievements_builder', 82 | handles => { 83 | achievements => 'elements', 84 | add_achievements => 'push', 85 | }, 86 | ); 87 | 88 | has rc => ( 89 | is => 'ro', 90 | default => sub { $ENV{HOME} . '/.perl-achievements' }, 91 | ); 92 | 93 | has ppi => ( 94 | is => 'rw', 95 | ); 96 | 97 | method scan ($file) { 98 | $self->set_ppi( PPI::Document->new( $file ) ); 99 | 100 | my $digest = sha1_hex($self->ppi->serialize); 101 | my $digest_file = $self->rc_file_path( 'scanned', $digest ); 102 | 103 | if ( -f $digest_file ) { 104 | $self->log_debug( "file '$file' already has been scanned" ); 105 | return; 106 | } 107 | 108 | $_->scan for $self->achievements; 109 | 110 | $digest_file->touch; 111 | } 112 | 113 | sub _achievements_builder { 114 | my $self = shift; 115 | 116 | my @checks; 117 | 118 | push @checks, $_->load_or_new( app => $self ) for $self->plugins; 119 | 120 | return \@checks; 121 | } 122 | 123 | method initialize_environment { 124 | my $dir = $self->rc; 125 | 126 | die "'$dir' already exist, aborting" if -e $dir; 127 | 128 | mkdir $dir; 129 | mkdir dir( $dir, 'achievements' ); 130 | mkdir dir( $dir, 'scanned' ); 131 | } 132 | 133 | sub unlock_achievement { 134 | my ( $self, %info ) = @_; 135 | 136 | $self->log_debug( "achievement unlocked:\n" 137 | . p( %info, colored => 0 ) 138 | ); 139 | 140 | $self->add_to_history( %info ); 141 | } 142 | 143 | sub add_to_history { 144 | my $self = shift; 145 | my %info = @_; 146 | my $file = $self->rc_file_path( 'history' ); 147 | open my $fh, '>>', $file; 148 | print {$fh} Dump \%info; 149 | } 150 | 151 | after unlock_achievement => sub { 152 | my( $self, %info ) = @_; 153 | 154 | say 'Congrats! You have unlocked a new achievement!'; 155 | 156 | say '*' x 60; 157 | say '*** ', $info{achievement}; 158 | say '*** level ', $info{level} if $info{level}; 159 | say ''; 160 | say $info{details} if $info{details}; 161 | say '*' x 60; 162 | }; 163 | 164 | 1; 165 | -------------------------------------------------------------------------------- /lib/Perl/Achievements/Achievement.pm: -------------------------------------------------------------------------------- 1 | package Perl::Achievements::Achievement; 2 | # ABSTRACT: base role for achievements 3 | 4 | =head1 SYNOPSIS 5 | 6 | package Perl::Achievements::Achievement::PerlAchiever; 7 | 8 | use strict; 9 | use warnings; 10 | 11 | use Moose; 12 | use MooseX::SemiAffordanceAccessor; 13 | 14 | with 'Perl::Achievements::Achievement'; 15 | 16 | has runs => ( 17 | traits => [ qw/ Counter Perl::Achievements::Role::ConfigItem / ], 18 | isa => 'Num', 19 | is => 'rw', 20 | default => 0, 21 | handles => { 22 | inc_runs => 'inc', 23 | }, 24 | ); 25 | 26 | sub scan { 27 | my $self = shift; 28 | 29 | $self->inc_runs; 30 | 31 | return unless $self->runs >= 2** $self->level; 32 | 33 | $self->inc_level; 34 | 35 | $self->unlock( 36 | sprintf "ran perl-achievements against %d scripts/modules", 37 | 2 ** ( $self->level - 1 ) 38 | ); 39 | } 40 | 41 | 1; 42 | 43 | =head1 DESCRIPTION 44 | 45 | Each type of achievement is a module consuming the 46 | L role. 47 | 48 | To be able to preserve counters and states across runs, 49 | all attributes of the class having the L 50 | trait will be serialized and saved in a yaml file in the 51 | C<$PERL_ACHIEVEMENTS_HOME/achievements> directory. 52 | 53 | =head1 REQUIRED METHODS 54 | 55 | =head2 scan() 56 | 57 | C is the only required method by the role. It is typically invoked 58 | by the main C method of the main L object, 59 | and is expected to inspect the current Perl file (available via C) 60 | and unlock the achievement when the right conditions are met. 61 | 62 | =head1 METHODS 63 | 64 | =cut 65 | 66 | use strict; 67 | use warnings; 68 | 69 | use Moose::Role; 70 | 71 | no warnings qw/ uninitialized /; 72 | 73 | use MooseX::SemiAffordanceAccessor; 74 | 75 | use YAML::Any qw/ LoadFile DumpFile /; 76 | use DateTime::Functions qw/ now /; 77 | 78 | with 'MooseX::ConfigFromFile'; 79 | 80 | requires qw/ scan /; 81 | 82 | =head2 app() 83 | 84 | Returns the L object to which this achievement 85 | object belongs to. 86 | 87 | =head2 ppi() 88 | 89 | Returns the L object corresponding to the Perl script 90 | currently under study. 91 | 92 | =head2 log( $message ) 93 | 94 | Logs the I<$message>. 95 | 96 | =head2 log_debug( $message ) 97 | 98 | Debug-level logging. 99 | 100 | =cut 101 | 102 | has 'app' => ( 103 | required => 1, 104 | is => 'ro', 105 | handles => [ qw/ ppi log log_debug / ], 106 | ); 107 | 108 | =head2 level() 109 | 110 | Returns the current achieved level. A level of I means that the 111 | achievement has not been reached yet, whereas a level of 0 is used for 112 | achievements that don't have multiple levels. 113 | 114 | =head2 set_level( $level ) 115 | 116 | Sets the level to I<$level>. 117 | 118 | =head2 inc_level( $increment ) 119 | 120 | Increments the level by the I<$increment>. If the increment 121 | is not given, increment by 1. 122 | 123 | =cut 124 | 125 | 126 | 127 | has level => ( 128 | traits => [ 'Perl::Achievements::Role::ConfigItem', 'Number' ], 129 | isa => 'Num|Undef', 130 | is => 'rw', 131 | default => undef, 132 | ); 133 | 134 | sub inc_level { 135 | my ( $self, $value ) = @_; 136 | $value ||= 1; 137 | $self->set_level( 138 | $self->level + $value 139 | ); 140 | } 141 | 142 | 143 | sub get_config_from_file { 144 | my ( $class, $file ) = @_; 145 | 146 | return -f $file ? LoadFile( $file ) : {}; 147 | } 148 | 149 | sub storage_file { 150 | my $class = shift; 151 | 152 | # if object, turn to class name 153 | $class = ref $class if ref $class; 154 | 155 | $class =~ s/^Perl::Achievements::Achievement:://; 156 | $class =~ s/::/__/g; 157 | $class .= '.yaml'; 158 | 159 | return $class; 160 | } 161 | 162 | sub load_or_new { 163 | my ( $class, %args ) = @_; 164 | 165 | my $file = $args{app}->rc_file_path( 'achievements', $class->storage_file ); 166 | 167 | return $class->new_with_config( configfile => $file, %args ); 168 | } 169 | 170 | =head2 unlock( $details ) 171 | 172 | Unlocks the achievement. An optional message can be passed, providing 173 | specific on the deed. 174 | 175 | If not set manually beforehand, unlocking the achievement would automatically 176 | set the level to 0. 177 | 178 | =cut 179 | 180 | sub unlock { 181 | my ($self, $details ) = @_; 182 | 183 | $self->app->unlock_achievement( 184 | achievement => ref($self), 185 | timestamp => ''.now(), 186 | ( level => $self->level ) x ( $self->level > 0 ) , 187 | ( details => $details ) x !!$details, 188 | ); 189 | } 190 | 191 | before unlock => sub { 192 | my $self = shift; 193 | 194 | $self->set_level(0) unless defined $self->level; 195 | }; 196 | 197 | before scan => sub { 198 | my $self = shift; 199 | $self->log_debug( "scanning for achievement " . ref $self ); 200 | }; 201 | 202 | after scan => sub { 203 | my $self = shift; 204 | 205 | $self->log_debug( 'storing state of ' . ref $self ); 206 | 207 | $self->store( "".$self->app->rc_file_path( 208 | 'achievements', $self->storage_file ) ); 209 | }; 210 | 211 | sub pack { 212 | my $self = shift; 213 | 214 | my %data; 215 | 216 | for my $attr ( map { $self->meta->get_attribute($_) } 217 | $self->meta->get_attribute_list ) { 218 | next unless $attr->does('Perl::Achievements::Role::ConfigItem'); 219 | 220 | my $name = $attr->name; 221 | $data{$name} = $self->$name; 222 | } 223 | 224 | return %data; 225 | } 226 | 227 | sub store { 228 | my $self = shift; 229 | 230 | my %data = $self->pack; 231 | DumpFile( shift, \%data ); 232 | } 233 | 234 | 1; 235 | --------------------------------------------------------------------------------