—
—
—
—
—
—
—
—
—

              
package Test::Legal;
use v5.10;
use Data::Dumper;
use strict;
use warnings;
our $VERSION = '0.10';
use Sub::Exporter;
use CPAN::Meta;
#use Data::Show;
use File::Find::Rule;
use List::Util 'first';
use Log::Log4perl ':easy';
use List::Compare;
use IO::Prompter;
use Test::Builder::Module;
use Test::Legal::Util qw/ annotate_copyright   deannotate_copyright load_meta write_LICENSE /;
use Sub::Exporter -setup => { exports => [ qw/ disable_test_builder annotate_dirs deannotate_dirs/, 
                                                                                  copyright_ok => \'_build_copyright_ok' ,
                                           license_ok   => \'_build_license_ok'],
                              groups  => { default => [qw/ copyright_ok license_ok /],
                                           core    => [qw/ copyright_ok license_ok /]
                                         },
                                      collectors => [qw/ defaults /]
}; 
use constant DEFAULTS =>  { base      => '.',
                            dirs      => [ qw/ lib script /],
};
my $tb = new Test::Builder ;
END   { $tb->done_testing; }
HideShow 49 lines of Pod
=pod 
=head1 NAME
Test::Legal -  Test and (optionally) fix copyright notices, LICENSE file, and relevant field of META file
=head1 SYNOPSIS
  use Test::Legal;         
  copyright_ok;
  license_ok;
  # Or, to fix things at the same time
  use Test::Legal  -core  => { actions =>['fix']};
  # Here is the more refined way to acomplish the same thing
  use Test::Legal  copyright_ok => {  dirs=> [qw/ sctipt lib /] } ,
                   'license_ok' ,
                   defaults     => { base=> $dir, actions => [qw/ fix /]}
  ;
  # Note,  The  "actions=>['fix']"  automatically fixes things so it can pass testing
  
=head1 DESCRIPTION
   Checks for (a) copyright notices in .pl and .pm distribution files; (b) for author entry 
 in META.yml or META.json, which ever peresent; and (c) for existence of LICENSE file, with the
 correct license text autogenerate if so desired.
   Although you can alwyas add copyright notices manually to files, Test::Legal can fix things
 for you if operated in 'fix' mode (see bellow); alternatively, use the tools available in
 script/ named copyright-injection.pl an license-injection.pl .
=head2 Fix mode
 When "fix" mode is requested, most issues are automatically fixed so testing succeeds 
 with a harmless note() send to Test::Harness. 
=head1 FUNCTIONS
=head2  disable_test_builder
=cut
sub disable_test_builder { 
        sub ok{}; sub done_testing{}; $tb=bless{} 
HideShow 6 lines of Pod
}
=pod
=head2  _values
=cut
sub _values {
    my ($arg, $defaults) = @_;
        $arg //= {}; $defaults //= {};
    return unless ref $arg      eq 'HASH';      
    return unless ref $defaults eq 'HASH';      
    $arg = { %{DEFAULTS()}, %$defaults, %$arg };
    ($arg->{ meta }) = load_meta($arg->{base}) || die 'no META file in dir "'. $arg->{base}.qq("\n);
    $arg;
HideShow 8 lines of Pod
}
=head2  _in_mode
 Assumptions: $arg exists and has been validated
 Input: the user arguments (a hashref)
 Output: TRUE if "dry" mode was specified, otherwise FALSE
=cut
sub _in_mode {
    my ($arg,$mode) = @_;
        return unless $mode;
    return unless ref $arg eq 'HASH';   
        return unless exists $arg->{actions};
        first {$_ =~ /^$mode$/i}  @{$arg->{actions}};
HideShow 5 lines of Pod
}
=pod
=head2 set_of_files
=cut
sub set_of_files {
        my ($pat, @dirs) =  @_;
        $pat //= 'Copyright (C)';
        $pat = qr/\Q$pat\E/i;
        my @all_files = File::Find::Rule->file->name(qr/.*(\.pm|\.pl)$/o)->in(@dirs);
        my @copyrighted = File::Find::Rule->file->name(qr/.*(\.pm|\.pl)$/o)-> grep($pat)->in(@dirs);
        List::Compare->new( \@all_files, \@copyrighted);
HideShow 5 lines of Pod
}
=pod
=head2  annotate_dirs
=cut
sub annotate_dirs {
        my ($pat, @dirs) =  @_;
        my $l = set_of_files ($pat, @dirs) ;
        my @without_c =  $l->get_unique  ;
        return (0,0) unless @without_c;
        DEBUG "Without copyright:\n\t" . join "\n\t", @without_c ;
        unless ($::opts->{yes}) {
                return (0,scalar @without_c) unless (prompt '-yes', 'Add copyright to all files that need it?') ;
        }
        DEBUG "Updating...";
        my $num = annotate_copyright(\@without_c, $pat) || 0;
        #verify
        $l = set_of_files ($pat, @dirs) ;
        my @remain = $l->get_unique; 
        DEBUG "Remain without copyrigh:\n\t" . join "\n\t", @remain  if @remain;
        ($num, scalar @remain);
HideShow 5 lines of Pod
}
=pod
=head2  deanntate_dirs
=cut
sub deannotate_dirs {
        my ($pat, @dirs) =  @_;
        my $l = set_of_files ($pat, @dirs) ;
        my @with_c =  $l->get_intersection  ;
        return (0,0) unless @with_c;
        DEBUG "Have copyright:\n\t" . join "\n\t", @with_c ;
        unless ($::opts->{yes}) {
                return (0, scalar @with_c) unless (prompt '-yes', 'Remove copyright from all files?') ;
        }
        DEBUG "Updating...";
        my $num = deannotate_copyright(\@with_c, $pat) || 0;
        #verify
        $l = set_of_files ($pat, @dirs) ;
        my @remain = $l->get_intersection ;
        DEBUG "Remain copyrighted:\n\t" . join "\n\t", @remain  if @remain;
        ($num, scalar @remain);
HideShow 5 lines of Pod
}
=pod
=head2  _build_copyright_ok
=cut
sub _build_copyright_ok {
    my ($class, $fun, $arg, $defaults) = @_;
    $arg = _values($arg, $defaults->{defaults});  # keys : base, dirs , meta
    my @dirs   = map {$arg->{base} . "/$_"} @{$arg->{dirs}};
    sub {
            return ('noop', $arg)  if _in_mode($arg,'noop');
                my $pat = shift;
                $pat //= 'Copyright (C)';
        my $l= set_of_files($pat, @dirs);
                if( (_in_mode($arg,'fix')) && ($l->get_unique) ) {
                        # fix them by adding copyright notices
                        $tb->note( 'adding Copyright notices' )  if annotate_copyright([$l->get_unique],undef);
                        # re-scan for files without copyright
                        $l= set_of_files($pat, @dirs);
                }
        $tb->ok( 0, $_ ) for  $l->get_unique ;
        $tb->ok( 1, $_ ) for  $l->get_intersection;
                $l->get_unique;
    }
HideShow 5 lines of Pod
}
=pod
=head2  _build_license_ok
=cut
sub _build_license_ok {
    my ($class, $fun, $arg, $defaults) = @_;
    $arg = _values($arg, $defaults->{defaults});  # keys : base, dirs , meta
    sub {
            return ('noop', $arg)  if _in_mode($arg,'noop');
        my $has_file =  -f $arg->{base}.'/LICENSE' ;
                # attempt to fix?
            if ((_in_mode($arg,'fix')) && (!$has_file)) {
                        $tb->note( 'added LICENSE' )  if  write_LICENSE($arg->{base}); 
                }
        $tb->ok( -f $arg->{base}.'/LICENSE', 'dist contains LICENSE file');
        $tb->ok( @{[$arg->{meta}->license]} > 0 , 'META mentions license');
    }
}
HideShow 34 lines of Pod
1;
=pod
=head1 EXPORT
    copyritht_ok;
    legal_ok;
=head1 EXPORT_OK
    disable_test_builder 
        annotate_dirs 
    deannotate_dirs
=head1 SEE ALSO
 copyright_injection.pl  ( provided with Test::Legal )
 Test::Copyright
=head1 AUTHOR
Tambouras, Ioannis E<lt>ioannis@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2011 by Ioannis Tambouras
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.12.1 or,
at your option, any later version of Perl 5 you may have available.
=cut