view release on metacpan or  search on metacpan

lib/Test/Legal/Util.pm  view on Meta::CPAN

		Artistic_2_0 GFDL_1_2     LGPL_2_1     None         SSLeay
	/;
}
=pod

=head2  write_LICENSE

 Writes the LICENSE file
Input: 
Output: the specific license object

=cut
sub write_LICENSE {
	my ($dir, $author, $type) = @_ ;
	my $meta  = load_meta($dir);
	$author //=  find_authors($meta);
	$type   //= find_license($meta) || return;
	my $lok   = check_META_file($dir);
	$lok or INFO($::o->usage) and INFO( qq(The "list" command lists available licenses))  and return  ;
    unless ($::opts->{yes}) {
		 -T "$dir/LICENSE"  ?  (prompt '-yes', 'Overide LICENSE?') ||  return  : 1;
    }
 	DEBUG 'Adding LICENSE file';
 	open my ($o), '>', "$dir/LICENSE" or die$! ;
 	say {$o} $lok->fulltext;
}
=pod

=head2 check_license_files
 Input:  base directory
 Performs and outputs diagnostics 
=cut
sub check_license_files {
	my $dir = shift || return;
	check_LICENSE_file( $dir); 
	check_META_file( $dir); 
}

#no namespace::clean;

=pod

=head2  is_annotated
 Input: filename and message
 Output: True, if file is already annotated with this message;
         otherwise, false
=cut
sub is_annotated {
    my ($file, $msg) = @_ ;
	#$msg //= qr/\s*(\#{0,3})? \s* Copyright \s* \Q (c)\E/oxim;
	$msg //= 'copyright (c)';
	my $contents = slurp $file  or return;
	 () = $contents =~ /\Q$msg/gis ;
	# () = $contents =~ (ref $msg eq 'Regexp') ? $msg : /\Q$msg/gis;
}
=pod

=head2  default_copyright_notice
=cut
sub default_copyright_notice {
	my $geco =  ucfirst ([getpwuid $<]->[6] || getlogin);
	my $year =  1900 + [localtime]->[5];
	sprintf '%s %s, %s', '# Copyright (C)', $year, $geco ;
}
=pod

=head2  _annotate_copyright
 Annotates one file . 
 Assumptions: msg already validated
 Input: filename, copyright notice
 Output: TRUE on  file change, otherwise FALSE
=cut
sub _annotate_copyright {
    my ($file, $msg) = @_ ;
	return  unless -T $file ;
	# Don't annotate if already annotated
	return   if is_annotated($file,$msg);
    my $perms = ((stat($file))[2]) & 07777 ;
    #DEBUG  sprintf( "perms are %04o\n", $perms) ;
	open my ($in), '<', $file  or return;
	unlink $file;
	open my ($out), '>', "$file";
    chmod($perms | 0600, $out);
	print {$out} scalar <$in>;
	print {$out} $msg,"\n";
	print {$out}  <$in> ;
}
=pod

=head2  _deannotate_copyright
 Remove copyright from  one file . 
 Assumptions: msg already validated
 Input: filename, copyright notice
 Output: TRUE on  file change, otherwise FALSE
=cut
sub _deannotate_copyright {
    my ($file, $msg) = @_ ;
	return  unless -T $file ;
    my $perms = ((stat($file))[2]) & 07777 ;
    #DEBUG  sprintf( "perms are %04o\n", $perms) ;
	my $content = slurp $file or return;
	$content =~ s/\Q$msg\E//g ;
	open my ($out), '>', "$file";
    chmod($perms | 0600, $out);
	print {$out}  $content;
}
=pod

=head2  find_authors
 Input:  filename or CPAN::Meta object
 Output: all  authors mentioned in CPAN::Meta. 
	     Returns 'unknown' if no authors found, or
                  undef for other failures
 Authors are are non-repeating and never in "Last, First" format
=cut
sub find_authors {
    my $meta = shift||return;
	$meta = load_meta($meta) || return;;
    my @authors = map { s/^\s*|\s*$//o; $_}
				 map { s/([^,]+),(.+)/$2 $1/o; $_}
				 map { s/\W*<.*>\s*//so; $_}