File Coverage

blib/lib/App/Licensecheck.pm
Criterion Covered Total %
statement 140 158 88.6
branch 33 50 66.0
condition 11 21 52.3
subroutine 24 24 100.0
pod 0 5 0.0
total 208 258 80.6


line stmt bran cond sub pod time code
1 2     2   2548010 use Feature::Compat::Class 0.04;
  2         74  
  2         14  
2              
3 2     2   536 use v5.12;
  2         7  
4 2     2   11 use utf8;
  2         15  
  2         12  
5 2     2   57 use warnings;
  2         14  
  2         65  
6 2     2   1096 use autodie;
  2         30445  
  2         11  
7              
8             =head1 NAME
9              
10             App::Licensecheck - functions for a simple license checker for source files
11              
12             =head1 VERSION
13              
14             Version v3.3.7
15              
16             =head1 SYNOPSIS
17              
18             use Path::Tiny;
19             use App::Licensecheck;
20              
21             my $tempfile = Path::Tiny->tempfile;
22              
23             $tempfile->spew(<
24             # Dummy file simply stating some copyright and license.
25             # Copyright (C) 2020, 2022 Foo Bar.
26             #
27             # This file is licensed under version 2 or later of the GPL.
28             EOF
29              
30             my $app = App::Licensecheck->new( top_lines => 0 ); # Parse whole files
31              
32             my @output = $app->parse($tempfile);
33              
34             my $license = $output[0]; # => is "GPL-2.0-or-later"
35             my $copyrights = $output[1]; # => is "2020, 2022 Foo Bar."
36              
37             =head1 DESCRIPTION
38              
39             L is the core of L script
40             to check for licenses of source files.
41             See the script for casual usage.
42              
43             =cut
44              
45             package App::Licensecheck v3.3.7;
46              
47             class App::Licensecheck;
48              
49 2     2   14294 use Carp qw(croak);
  2         8  
  2         107  
50 2     2   621 use Log::Any ();
  2         9264  
  2         66  
51 2     2   14 use Scalar::Util qw(blessed);
  2         7  
  2         120  
52 2     2   2002 use Path::Tiny();
  2         28644  
  2         69  
53 2     2   1060 use Feature::Compat::Try;
  2         664  
  2         10  
54 2     2   3939 use Fcntl qw(:seek);
  2         5  
  2         321  
55 2     2   17 use Encode 2.93;
  2         38  
  2         332  
56             use String::Copyright 0.003 {
57 8   33     8151 format => sub { join ' ', $_->[0] || (), $_->[1] || () }
      33        
58 2     2   968 };
  2         56011  
  2         35  
59             use String::Copyright 0.003 {
60             threshold_after => 5,
61 3   33     2903 format => sub { join ' ', $_->[0] || (), $_->[1] || () },
      66        
62             },
63 2     2   765 'copyright' => { -as => 'copyright_optimistic' };
  2         44  
  2         26  
64 2     2   1661 use String::License;
  2         74927  
  2         131  
65 2     2   21 use String::License::Naming::SPDX;
  2         6  
  2         68  
66              
67 2     2   14 use namespace::clean qw(-except new);
  2         4  
  2         17  
68              
69             # fatalize Unicode::UTF8 and PerlIO::encoding decoding errors
70 2     2   1044 use warnings FATAL => 'utf8';
  2         5  
  2         187  
71             $PerlIO::encoding::fallback = Encode::FB_CROAK;
72              
73 2     2   14 no if ( $] >= 5.034 ), warnings => "experimental::try";
  2         4  
  2         24  
74              
75             field $log;
76              
77             field $path;
78              
79             # resolve patterns
80              
81             field $naming :param = undef;
82              
83             # parse
84              
85             field $top_lines :param //= 60;
86             field $end_bytes :param //= 5000; # roughly 60 lines of 80 chars
87             field $encoding :param = undef;
88             field $fh;
89             field $content :param = undef;
90             field $tail_content;
91             field $offset;
92             field $license;
93             field $copyrights;
94              
95             ADJUST {
96             $log = Log::Any->get_logger;
97              
98             if ( defined $naming ) {
99             croak $log->fatal(
100             'parameter "naming" must be a String::License::Naming object')
101             unless defined blessed($naming)
102             and $naming->isa('String::License::Naming');
103             }
104             else {
105             $naming = String::License::Naming::SPDX->new;
106             }
107              
108             if ( $encoding and not ref($encoding) eq 'OBJECT' ) {
109             $encoding = find_encoding($encoding);
110             }
111             }
112              
113             method parse
114 17     17 0 60 {
115 17         50 ($path) = @_;
116              
117 17         94 $path = Path::Tiny::path($path);
118              
119             try {
120             return $self->parse_file;
121             }
122 17         1051 catch ($e) {
123             if ( $encoding and $e =~ /does not map to Unicode/ ) {
124             $log->warnf(
125             'failed decoding file %s as %s, will try iso-8859-1',
126             $path, $encoding->name
127             );
128             $log->debugf( 'decoding error: %s', $e );
129             try {
130             $encoding = find_encoding('iso-8859-1');
131             return $self->parse_file;
132             }
133             catch ($e) {
134             if (/does not map to Unicode/) {
135             $log->warnf(
136             'failed decoding file %s as iso-8859-1, will try raw',
137             $path
138             );
139             $log->debugf( 'decoding error: %s', $e );
140             $encoding = undef;
141             return $self->parse_file;
142             }
143             else {
144             die $log->fatalf( 'unknown error: %s', $e );
145             }
146             }
147             }
148             else {
149             die $log->fatalf( 'unknown error: %s', $e );
150             }
151             }
152             }
153              
154             method parse_file
155 17     17 0 64 {
156             # TODO: stop reuse slots across files, and drop this hack
157 17         32 $content = undef;
158 17         32 $license = undef;
159 17         33 $copyrights = undef;
160              
161 17 100       53 if ( $top_lines == 0 ) {
162 10         44 my $licensed = String::License->new(
163             string => $self->content_extracleaned,
164             naming => $naming,
165             );
166 10         1319 $license = $licensed->as_text;
167 10         2111712 $copyrights = copyright( $self->content_cleaned );
168             }
169             else {
170 7         34 my $licensed = String::License->new(
171             string => $self->content_extracleaned,
172             naming => $naming,
173             );
174 7         887 $license = $licensed->as_text;
175 7         2011980 $copyrights = copyright_optimistic( $self->content_cleaned );
176 7 100 33     3697 if ( $offset and not $copyrights and $license eq 'UNKNOWN' ) {
      66        
177              
178             # TODO: stop reuse slots across files, and drop this hack
179 6         83 $tail_content = undef;
180              
181 6         26 my $licensed = String::License->new(
182             string => $self->content_extracleaned,
183             naming => $naming,
184             );
185 6         712 $license = $licensed->as_text;
186 6         323635 $copyrights = copyright_optimistic( $self->content_cleaned );
187             }
188 7         12096 $fh->close;
189             }
190              
191 17         29513 return ( $license, $copyrights );
192             }
193              
194             method content
195 46     46 0 131 {
196 46 100 100     241 if ( $top_lines == 0 ) {
    100          
    50          
197 20 100       104 return $content
198             if defined($content);
199              
200 10 50       34 if ( not defined($encoding) ) {
201 10         44 $log->debugf( 'reading whole file %s as raw bytes', $path );
202 10         69 $content = $path->slurp_raw;
203             }
204             else {
205 0         0 my $id = $encoding->name;
206 0         0 $log->debugf( 'decoding whole file %s as %s', $path, $id );
207 0         0 $content = $path->slurp( { binmode => ":encoding($id)" } );
208             }
209 10 50       3032 $log->trace("----- content -----\n$content----- end content -----")
210             if $log->is_trace;
211             }
212             elsif ( not defined($license) or not defined($copyrights) ) {
213              
214             # TODO: distinguish header from full content
215 14 100       61 return $content
216             if defined($content);
217              
218 7         21 $content = '';
219              
220 7 50       17 if ( not defined($encoding) ) {
221 7         41 $log->debugf( 'reading part(s) of file %s as raw bytes', $path );
222 7         1582 $fh = $path->openr_raw;
223             }
224             else {
225 0         0 my $id = $encoding->name;
226 0         0 $log->debugf( 'decoding part(s) of file %s as %s', $path, $id );
227 0         0 $fh = $path->openr(":encoding($id)");
228             }
229              
230 7         1665 while ( my $line = $fh->getline ) {
231 77 100       12208 last if ( $fh->input_line_number > $top_lines );
232 70         2249 $content .= $line;
233             }
234 7 50       138 $log->trace("----- header -----\n$content----- end header -----")
235             if $log->is_trace;
236              
237 7 50       455 if ($end_bytes) {
238 7         49 my $position = $fh->tell; # see IO::Seekable
239 7         82 my $filesize = $path->stat->size;
240 7 100       9774 if ( $position >= $filesize - $end_bytes ) { # header overlaps
    50          
    0          
241 1 50       11 if ( $position < $filesize ) {
    0          
242 1         13 $log->debugf(
243             'tail offset set to %s (end of header)',
244             $position
245             );
246 1         71 $offset = $position;
247             }
248             elsif ( $position = $filesize ) {
249 0         0 $log->debug('header end matches file size');
250 0         0 $offset = 0;
251             }
252             else {
253 0         0 $log->error('header end beyond file size');
254 0         0 $offset = 0;
255             }
256             }
257             elsif ( $position > 0 ) {
258 6         17 $offset = $filesize - $end_bytes;
259 6         23 $log->debugf(
260             'tail offset set to %s',
261             $offset
262             );
263             }
264             elsif ( $position < 0 ) {
265 0         0 $log->error('header end could not be resolved');
266 0         0 $offset = 0;
267             }
268             else {
269 0         0 $log->error('header end oddly at beginning of file');
270 0         0 $offset = 0;
271             }
272             }
273             }
274             elsif ($offset) {
275              
276             # TODO: distinguish tail from full content
277 12 100       92 return $content
278             if defined($tail_content);
279              
280 6         24 $tail_content = '';
281 6         50 $fh->seek( $offset, SEEK_SET ); # see IO::Seekable
282 6         328 $tail_content .= join( '', $fh->getlines );
283 6 50       709 $log->trace("----- tail -----\n$tail_content----- end tail -----")
284             if $log->is_trace;
285              
286 6         473 $content = $tail_content;
287             }
288             else {
289 0         0 $log->errorf(
290             'tail offset not usable: %s',
291             $offset
292             );
293 0         0 return '';
294             }
295              
296             # TODO: distinguish comment-mangled content from pristine content
297 23 50       707 local $_ = $content or return '';
298              
299             # Remove generic comments: look for 4 or more lines beginning with
300             # regular comment pattern and trim it. Fall back to old algorithm
301             # if no such pattern found.
302 23         734 my @matches = m/^[ \t]*([^a-zA-Z0-9\s]{1,3})[ \t]+\S/mg;
303 23 100       91 if ( @matches >= 4 ) {
304 13         589 my $comment_re = qr/^[ \t]*[\Q$matches[0]\E]{1,3}[ \t]*/m;
305 13         547 s/$comment_re//g;
306             }
307              
308 23         343 my @wordmatches = m/^[ \t]*(dnl|REM|COMMENT)[ \t]+\S/mg;
309 23 50       91 if ( @wordmatches >= 4 ) {
310 0         0 my $comment_re = qr/^[ \t]*\Q$wordmatches[0]\E[ \t]*/m;
311 0         0 s/$comment_re//g;
312             }
313              
314             # Remove other side of "boxed" comments
315 23         1453 s/[ \t]*[*#][ \t]*$//gm;
316              
317             # Remove Fortran comments
318 23         227 s/^[cC]$//gm;
319 23         143 s/^[cC] //gm;
320              
321             # Remove C / C++ comments
322 23         5350 s#(\*/|/\*|(?
323              
324             # Strip escaped newline
325 23         122 s/\s*\\n\s*/ /g;
326              
327 23         74 $content = $_;
328              
329 23         131 return $content;
330             }
331              
332             my $html_xml_tags_re = qr/<\/?(?:p|br|ref)(?:\s[^>]*)?>/i;
333              
334             # clean cruft
335             method content_cleaned
336 23     23 0 110 {
337 23 50       86 local $_ = $self->content or return '';
338              
339             # strip common html and xml tags
340 23         198 s/$html_xml_tags_re//g;
341              
342             # TODO: decode latin1/UTF-8/HTML data instead
343 23         183 s/\xcb\x97|\xe2\x80[\x90-\x95|\xe2\x81\x83|\xe2\x88\x92|\xef\x89\xa3|\xef\xbc\x8d]|[&](?:ndash|mdash|horbar|minus|[#](?:727|820[8-9]|821[0-3]|8259|8722|65123|65293|x727|z201[0-5]|x2043|x2212|xFE63|xFF0D))[;]/-/gm;
344 23         161 s/\x58\xa9|\xc2\xa9|\xe2\x92\x9e|\xe2\x92\xb8|\xe2\x93\x92|\xf0\x9f\x84\x92|\xf0\x9f\x84\xab|\xf0\x9f\x85\x92|[&](?:copy|[#](?:169|9374|9400|9426|127250|127275|127314|x0A9|x249E|x24b8|x24D2|x0F112|x0F12B|x0F152))[;]/©/gm;
345              
346             # TODO: decode nroff files specifically instead
347 23         102 s/\\//gm; # de-cruft nroff files
348              
349 23         137 return $_;
350             }
351              
352             # clean cruft and whitespace
353             method content_extracleaned
354 23     23 0 51 {
355 23 50       58 local $_ = $self->content or return '';
356              
357             # strip trailing dash, assuming it is soft-wrap
358             # (example: disclaimers in GNU autotools file "install-sh")
359 23         179 s/-\r?\n//g;
360              
361             # strip common html and xml tags
362 23         134 s/$html_xml_tags_re//g;
363              
364 23         194 tr/\t\r\n/ /;
365              
366             # this also removes quotes
367 23         158 tr% A-Za-z.,:@;0-9\(\)/-%%cd;
368 23         206 tr/ //s;
369              
370 23         305 return $_;
371             }
372              
373             =encoding UTF-8
374              
375             =head1 AUTHOR
376              
377             Jonas Smedegaard C<< >>
378              
379             =head1 COPYRIGHT AND LICENSE
380              
381             This program is based on the script "licensecheck" from the KDE SDK,
382             originally introduced by Stefan Westerfeld C<< >>.
383              
384             Copyright © 2007, 2008 Adam D. Barratt
385              
386             Copyright © 2012 Francesco Poli
387              
388             Copyright © 2016-2022 Jonas Smedegaard
389              
390             Copyright © 2017-2022 Purism SPC
391              
392             This program is free software:
393             you can redistribute it and/or modify it
394             under the terms of the GNU Affero General Public License
395             as published by the Free Software Foundation,
396             either version 3, or (at your option) any later version.
397              
398             This program is distributed in the hope that it will be useful,
399             but WITHOUT ANY WARRANTY;
400             without even the implied warranty
401             of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
402             See the GNU Affero General Public License for more details.
403              
404             You should have received a copy
405             of the GNU Affero General Public License along with this program.
406             If not, see .
407              
408             =cut
409              
410             1;