File Coverage

blib/lib/Dist/Inkt/Role/WriteCOPYRIGHT.pm
Criterion Covered Total %
statement 32 132 24.2
branch 0 48 0.0
condition 0 32 0.0
subroutine 11 18 61.1
pod 0 1 0.0
total 43 231 18.6


line stmt bran cond sub pod time code
1             package Dist::Inkt::Role::WriteCOPYRIGHT;
2              
3             our $AUTHORITY = 'cpan:TOBYINK';
4             our $VERSION = '0.022';
5              
6 1     1   1221 use Moose::Role;
  1         3  
  1         6  
7 1     1   5627 use List::MoreUtils qw( uniq );
  1         4004  
  1         20  
8 1     1   1364 use Path::Tiny qw( path );
  1         9475  
  1         64  
9 1     1   632 use Path::Iterator::Rule;
  1         8492  
  1         28  
10 1     1   494 use Software::License;
  1         6319  
  1         28  
11 1     1   435 use Software::LicenseUtils;
  1         48481  
  1         43  
12 1     1   9 use Types::Standard -types;
  1         2  
  1         12  
13 1     1   4194 use namespace::autoclean;
  1         2  
  1         10  
14              
15 1     1   72 use constant FORMAT_URI => 'http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/';
  1         3  
  1         337  
16              
17             my ($_serialize_file, $_serialize_stanza);
18             BEGIN {
19             $_serialize_file = sub {
20 0     0   0 my $self = shift;
21             return join "\n",
22             map $_->to_string,
23             (
24             $self->header,
25 0         0 @{ $self->files },
26 0         0 @{ $self->license },
  0         0  
27             );
28 1     1   7 };
29              
30             $_serialize_stanza = sub
31             {
32 0         0 my $self = shift;
33 0         0 my $str;
34 0         0 for my $f ($self->FIELDS)
35             {
36 0         0 my $F = join "-", map ucfirst, split "_", $f;
37 0         0 my $v = $self->$f;
38 0 0 0     0 if ($f eq 'body') {
    0          
    0          
39 0         0 $v =~ s{^}" "mg;
40 0         0 $str .= "$v\n";
41             }
42             elsif (ref $v eq "ARRAY") {
43 0         0 $v = join "\n " => @$v;
44 0         0 $str .= "$F: $v\n";
45             }
46             elsif (defined $v and length $v) {
47 0         0 $v =~ s{^}" "mg;
48 0         0 $str .= "$F:$v\n";
49             }
50             }
51 0         0 return $str;
52             }
53 1         57 }; #/BEGIN
54              
55 1         12 use MooX::Struct -rw,
56             CopyrightFile => [
57             qw/ $header @files @license /,
58             to_string => $_serialize_file,
59             ],
60             HeaderSection => [
61             qw/ $format $upstream_name $upstream_contact $source /,
62             to_string => $_serialize_stanza,
63             ],
64             FilesSection => [
65             qw/ @files $copyright $license $comment /,
66             to_string => $_serialize_stanza,
67             ],
68             LicenseSection => [
69             qw/ $license $body /,
70             to_string => $_serialize_stanza,
71             ],
72 1     1   433 ;
  1         39539  
73              
74             my %DEB = qw(
75             Software::License::Apache_1_1 Apache-1.1
76             Software::License::Apache_2_0 Apache-2.0
77             Software::License::Artistic_1_0 Artistic-1.0
78             Software::License::Artistic_2_0 Artistic-2.0
79             Software::License::BSD BSD-3-clause
80             Software::License::CC0_1_0 CC0
81             Software::License::GFDL_1_2 GFDL-1.2
82             Software::License::GFDL_1_3 GFDL-1.3
83             Software::License::GPL_1 GPL-1.0
84             Software::License::GPL_2 GPL-2.0
85             Software::License::GPL_3 GPL-3.0
86             Software::License::LGPL_2_1 LGPL-2.1
87             Software::License::LGPL_3_0 GPL-3.0
88             Software::License::MIT Expat
89             Software::License::Mozilla_1_0 MPL-1.0
90             Software::License::Mozilla_1_1 MPL-1.1
91             Software::License::QPL_1_0 QPL-1.0
92             Software::License::Zlib Zlib
93             );
94              
95             my %URIS = (
96             'http://www.gnu.org/licenses/agpl-3.0.txt' => 'AGPL_3',
97             'http://www.apache.org/licenses/LICENSE-1.1' => 'Apache_1_1',
98             'http://www.apache.org/licenses/LICENSE-2.0' => 'Apache_2_0',
99             'http://www.apache.org/licenses/LICENSE-2.0.txt' => 'Apache_2_0',
100             'http://www.perlfoundation.org/artistic_license_1_0' => 'Artistic_1_0',
101             'http://opensource.org/licenses/artistic-license.php' => 'Artistic_1_0',
102             'http://www.perlfoundation.org/artistic_license_2_0' => 'Artistic_2_0',
103             'http://opensource.org/licenses/artistic-license-2.0.php' => 'Artistic_2_0',
104             'http://www.opensource.org/licenses/bsd-license.php' => 'BSD',
105             'http://creativecommons.org/publicdomain/zero/1.0/' => 'CC0_1_0',
106             'http://www.freebsd.org/copyright/freebsd-license.html' => 'FreeBSD',
107             'http://www.gnu.org/copyleft/fdl.html' => 'GFDL_1_3',
108             'http://www.opensource.org/licenses/gpl-license.php' => 'GPL_1',
109             'http://www.gnu.org/licenses/old-licenses/gpl-1.0.txt' => 'GPL_1',
110             'http://www.opensource.org/licenses/gpl-2.0.php' => 'GPL_2',
111             'http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt' => 'GPL_2',
112             'http://www.opensource.org/licenses/gpl-3.0.html' => 'GPL_3',
113             'http://www.gnu.org/licenses/gpl-3.0.txt' => 'GPL_3',
114             'http://www.opensource.org/licenses/lgpl-2.1.php' => 'LGPL_2_1',
115             'http://www.gnu.org/licenses/old-licenses/lgpl-2.1.txt' => 'LGPL_2_1',
116             'http://www.opensource.org/licenses/lgpl-3.0.html' => 'LGPL_3_0',
117             'http://www.gnu.org/licenses/lgpl-3.0.txt' => 'LGPL_3_0',
118             'http://www.opensource.org/licenses/mit-license.php' => 'MIT',
119             'http://www.mozilla.org/MPL/MPL-1.0.txt' => 'Mozilla_1_0',
120             'http://www.mozilla.org/MPL/MPL-1.1.txt' => 'Mozilla_1_1',
121             'http://opensource.org/licenses/mozilla1.1.php' => 'Mozilla_1_1',
122             'http://www.openssl.org/source/license.html' => 'OpenSSL',
123             'http://dev.perl.org/licenses/' => 'Perl_5',
124             'http://www.opensource.org/licenses/postgresql' => 'PostgreSQL',
125             'http://trolltech.com/products/qt/licenses/licensing/qpl' => 'QPL_1_0',
126             'http://h71000.www7.hp.com/doc/83final/BA554_90007/apcs02.html' => 'SSLeay',
127             'http://www.openoffice.org/licenses/sissl_license.html' => 'Sun',
128             'http://www.zlib.net/zlib_license.html' => 'Zlib',
129             );
130             eval("require Software::License::$_") for uniq values %URIS;
131              
132             has debian_copyright => (
133             is => 'ro',
134             isa => InstanceOf[CopyrightFile],
135             lazy => 1,
136             builder => '_build_debian_copyright',
137             );
138              
139             our @Licences;
140             sub _build_debian_copyright
141             {
142 0     0     my $self = shift;
143            
144 0           my @files = uniq('COPYRIGHT', sort $self->_get_dist_files);
145            
146 0           my $c = CopyrightFile->new(
147             files => [],
148             license => [],
149             );
150            
151             $c->header(
152             HeaderSection->new(
153             format => FORMAT_URI,
154             upstream_name => $self->name,
155 0           upstream_contact => Moose::Util::english_list(@{$self->metadata->{author}}),
156             source => $self->metadata->{resources}{homepage},
157 0           ),
158             );
159            
160 0           local @Licences = ();
161 0           local $; = "\034";
162 0           my %group_by;
163 0           for my $f (@files)
164             {
165 0           my ($file, $copyright, $licence, $comment) = $self->_handle_file($f);
166 0 0         push @{ $group_by{$copyright, $licence, (defined $comment ? $comment : '')} }, $file;
  0            
167             }
168            
169 0           push @{ $c->files },
170             map {
171 0           my $key = $_;
172 0           my ($copyright, $licence, $comment) = split /\Q$;/;
173             FilesSection->new(
174 0           files => $group_by{$key},
175             copyright => $copyright,
176             license => $licence,
177             (comment => $comment)x(defined $comment),
178             );
179             }
180             sort {
181 0           scalar(@{$group_by{$b}}) <=> scalar(@{$group_by{$a}})
  0            
  0            
  0            
182             }
183             keys %group_by;
184            
185 0           my %seen;
186 0           for my $licence (@Licences) {
187 0 0         next if $seen{ref $licence}++;
188            
189 0           my $licence_name;
190 0 0 0       if ((ref($licence) || '') =~ /^Software::License::(.+)/) {
191 0           push @Licences, $licence;
192 0   0       $licence_name = $DEB{ ref $licence } || $1;
193             }
194             else {
195 0           $licence_name = "$licence";
196             }
197            
198 0           chomp( my $licence_text = $licence->notice );
199 0           push @{ $c->license }, LicenseSection->new(
  0            
200             license => $licence_name,
201             body => $licence_text,
202             );
203             }
204            
205 0           $c;
206             }
207              
208             sub _get_dist_files
209             {
210 0     0     my $self = shift;
211 0           my $rule = 'Path::Iterator::Rule'->new->file;
212 0           my $dir = $self->targetdir;
213 0           map { path($_)->relative($dir) } $rule->all($dir);
  0            
214             }
215              
216             sub _handle_file
217             {
218 0     0     my ($self, $f) = @_;
219 0           my ($copyright, $licence, $comment) = $self->_determine_rights($f);
220 0 0         return ($f, 'Unknown', 'Unknown') unless $copyright;
221            
222 0           my $licence_name;
223 0 0 0       if ((ref($licence) || '') eq "Software::License::Perl_5") {
    0 0        
224 0           push @Licences => (
225             "Software::License::Artistic_1_0"->new({holder => "the copyright holder(s)"}),
226             "Software::License::GPL_1"->new({holder => "the copyright holder(s)"}),
227             );
228 0           $licence_name = "GPL-1.0+ or Artistic-1.0";
229             }
230             elsif ((ref($licence) || '') =~ /^Software::License::(.+)/) {
231 0           push @Licences, $licence;
232 0   0       $licence_name = $DEB{ ref $licence } || $1;
233             }
234             else {
235 0           $licence_name = "$licence";
236             }
237            
238 0           return ($f, $copyright, $licence_name, $comment);
239             }
240              
241             around _inherited_rights => sub
242             {
243             my $next = shift;
244             my $self = shift;
245             my ($f) = @_;
246            
247             my @licence_uris = @{$self->metadata->{resources}{license} || [] };
248             if (@licence_uris)
249             {
250             my $holders = Moose::Util::english_list(
251             $self->can('doap_project')
252             ? map($_->to_string('compact'), @{$self->doap_project->maintainer})
253             : @{$self->metadata->{author}}
254             );
255            
256             my $year = 1900 + (localtime)[5];
257             $year = 1900 + (localtime((stat $f)[9]))[5] if $f;
258            
259             for my $l (@licence_uris)
260             {
261             next unless exists $URIS{$l};
262             my $class = "Software::License::".$URIS{$l};
263            
264             return (
265             sprintf("Copyright %d %s.", $year, $holders),
266             $class->new({ holder => $holders, year => $year }),
267             );
268             }
269             }
270            
271             return $self->$next(@_);
272             };
273              
274             sub _determine_rights
275             {
276 0     0     my ($self, $f) = @_;
277            
278 0 0         if ($self->can('_determine_rights_from_rdf'))
279             {
280 0 0         if (my @rights = $self->_determine_rights_from_rdf($f))
281             {
282 0           return @rights;
283             }
284             }
285            
286 0 0         if (my @rights = $self->_determine_rights_from_pod($f))
287             {
288 0           return @rights;
289             }
290            
291 0 0         if (my @rights = @{ $self->rights_for_generated_files->{$f} || [] })
  0 0          
292             {
293 0           return @rights;
294             }
295            
296 0 0 0       if ($f =~ m{\Alib/.*\.pm\z}
      0        
      0        
297             or $f =~ m{\Abin/[\w_-]+(\.pl|\.PL)?\z}
298             or $f =~ m{\At/.*(\.pm|\.t)\z}
299             or $f eq 'dist.ini')
300             {
301 0 0         if (my @rights = $self->_inherited_rights($f))
302             {
303 0           $self->log("Guessing copyright for file $f");
304 0           return @rights;
305             }
306             }
307            
308 0           $self->log("WARNING: Unable to determine copyright for file $f");
309 0           return;
310             }
311              
312             sub _determine_rights_from_pod
313             {
314 0     0     my ($self, $f) = @_;
315 0 0         return unless $f =~ /\.(?:pl|pm|pod|t)$/i;
316            
317             # For files in 'inc' try to figure out the normal (not stripped of pod)
318             # module.
319             #
320 0 0 0       $f = $INC{$1} if $f =~ m{^inc/(.+\.pm)$}i && exists $INC{$1};
321            
322 0           my $text = path($f)->absolute($self->targetdir)->slurp;
323            
324 0           my @guesses = 'Software::LicenseUtils'->guess_license_from_pod($text);
325 0 0         if (@guesses) {
326             my $copyright =
327             join qq[\n],
328 0 0         map { s/\s+$//; /[.?!]$/ ? $_ : "$_." }
  0            
329 0 0         grep { /^Copyright/i or /^This software is copyright/ }
  0            
330             split /(?:\r?\n|\r)/, $text;
331            
332 0           $copyright =~ s{E<lt>}{<}g;
333 0           $copyright =~ s{E<gt>}{>}g;
334            
335             return(
336 0 0 0       $copyright,
337             $guesses[0]->new({holder => 'the copyright holder(s)'}),
338             ) if $copyright && $guesses[0];
339             }
340            
341 0           return;
342             }
343              
344             after BUILD => sub {
345             my $self = shift;
346             push @{ $self->targets }, 'COPYRIGHT'; # push rather than shift
347             };
348              
349             sub Build_COPYRIGHT
350             {
351 0     0 0   my $self = shift;
352 0           my $file = $self->targetfile('COPYRIGHT');
353 0 0         $file->exists and return $self->log('Skipping %s; it already exists', $file);
354 0           $self->log('Writing %s', $file);
355 0 0 0       $self->rights_for_generated_files->{'COPYRIGHT'} ||= [
356             'None', 'public-domain'
357             ] if $self->DOES('Dist::Inkt::Role::WriteCOPYRIGHT');
358            
359 0           $file->spew_utf8( $self->debian_copyright->to_string );
360             }
361              
362             1;