File Coverage

blib/lib/CPANPLUS/Dist/Debora/License.pm
Criterion Covered Total %
statement 59 68 86.7
branch 4 12 33.3
condition 1 2 50.0
subroutine 15 15 100.0
pod 7 7 100.0
total 86 104 82.6


line stmt bran cond sub pod time code
1             package CPANPLUS::Dist::Debora::License;
2              
3             # SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
4              
5 8     8   1399 use 5.016;
  8         39  
6 8     8   40 use warnings;
  8         13  
  8         217  
7 8     8   42 use utf8;
  8         14  
  8         36  
8              
9             our $VERSION = '0.010';
10              
11 8     8   727 use parent qw(Software::License);
  8         424  
  8         65  
12              
13 8     8   39112 use File::Spec::Functions qw(catfile);
  8         855  
  8         453  
14 8     8   48 use Scalar::Util qw(weaken);
  8         16  
  8         348  
15 8     8   3801 use Text::Wrap qw();
  8         18787  
  8         225  
16              
17 8     8   2488 use CPANPLUS::Dist::Debora::Util qw(slurp_utf8);
  8         25  
  8         4656  
18              
19             # Common modules whose license might not be guessed.
20             my %LICENSE_NAME_FOR = (
21             'Coro' => '(Artistic-1.0-Perl OR GPL-1.0-or-later) '
22             . 'AND (BSD-2-Clause OR GPL-2.0-or-later)',
23             'Crypt-Blowfish' => 'BSD-4-Clause',
24             'Data-Hexdumper' => 'Artistic-1.0-Perl OR GPL-2.0-or-later',
25             'EV' => '(Artistic-1.0-Perl OR GPL-1.0-or-later) '
26             . 'AND (BSD-2-Clause OR GPL-2.0-or-later)',
27             'Exporter-Tidy' => 'SUSE-Permissive '
28             . 'OR GPL-2.0-or-later OR LGPL-2.1-or-later OR MPL-2.0',
29             'FCGI' => 'BSD-2-Clause',
30             'Net-Patricia' => 'GPL-2.0-or-later AND BSD-2-Clause',
31             'Time-ParseDate' => 'SUSE-Permissive',
32             );
33              
34             sub new {
35 1     1 1 4353 my ($class, $attrs) = @_;
36              
37 1         3 my $package = $attrs->{package};
38 1         3 delete $attrs->{package};
39              
40 1         21 my $self = $class->SUPER::new($attrs);
41              
42 1         18 $self->{package} = $package;
43 1         5 weaken $self->{package};
44              
45 1         3 return $self;
46             }
47              
48             sub name {
49 1     1 1 343 my $self = shift;
50              
51 1         9 return 'Unknown license';
52             }
53              
54             sub url {
55 1     1 1 3 my $self = shift;
56              
57 1         4 return;
58             }
59              
60             sub meta_name {
61 1     1 1 3 my $self = shift;
62              
63 1         10 return 'restrictive';
64             }
65              
66             sub meta2_name {
67 1     1 1 2 my $self = shift;
68              
69 1         4 return 'restricted';
70             }
71              
72             sub spdx_expression {
73 1     1 1 3 my $self = shift;
74              
75 1         3 my $package = $self->{package};
76 1         13 my $dist_name = $package->dist_name;
77              
78 1   50     76 return $LICENSE_NAME_FOR{$dist_name} // 'Unknown';
79             }
80              
81             sub license {
82 1     1 1 3 my $self = shift;
83              
84 1         3 my $package = $self->{package};
85 1         7 my $builddir = $package->builddir;
86              
87 1         8 my $text = q{};
88              
89             # Read the license files.
90 1         3 my @license_files = @{$package->files_by_type('license')};
  1         18  
91 1         7 for my $filename (@license_files) {
92 1         3 my $buf = eval { slurp_utf8(catfile($builddir, $filename)) };
  1         14  
93 1 50       5 if ($buf) {
94 1         84 $buf =~ s{\A \v+}{}xms; # Remove leading newlines.
95 1         272 $buf =~ s{\v+ \z}{}xms; # Remove trailing newlines.
96              
97 1 50       5 if ($text) {
98 0         0 $text .= "\n\n";
99             }
100              
101 1 50       4 if (@license_files > 1) {
102 0         0 $text .= "-- $filename file --\n\n";
103             }
104              
105 1         27 $text .= $buf;
106             }
107             }
108              
109             # Is there a LICENSE section in the Pod document?
110 1 50       4 if (!$text) {
111 0         0 my $pod = $package->_pod;
112 0 0       0 if ($pod) {
113 0         0 my $section = $pod->section(q{1}, qr{LICEN[CS]E}xmsi);
114 0 0       0 if ($section) {
115             ## no critic (Variables::ProhibitPackageVars)
116             # Remove headings.
117 0         0 $section =~ s{^ =head\d \h (\V+) \v+}{}xmsg;
118 0         0 local $Text::Wrap::unexpand = 0;
119 0         0 $text = Text::Wrap::wrap(q{}, q{}, $section);
120             }
121             }
122             }
123              
124 1         6 return $text;
125             }
126              
127             1;
128              
129             ## no critic (Documentation::RequirePodAtEnd)
130              
131             =pod
132              
133             =encoding UTF-8
134              
135             =head1 NAME
136              
137             CPANPLUS::Dist::Debora::License - Read license files
138              
139             =head1 VERSION
140              
141             version 0.010
142              
143             =head1 SYNOPSIS
144              
145             use CPANPLUS::Dist::Debora::License;
146              
147             my $license = CPANPLUS::Dist::Debora::License->new({
148             package => $package,
149             holder => $holder,
150             year => $year,
151             });
152              
153             print $license->license;
154              
155             =head1 DESCRIPTION
156              
157             This L subclass reads license texts from files and Pod
158             documents.
159              
160             =head1 SUBROUTINES/METHODS
161              
162             =head2 new
163              
164             my $license = CPANPLUS::Dist::Debora::License->new({
165             package => $package,
166             holder => $holder,
167             });
168              
169             Creates a new object. The L object parameter
170             and the copyright holder are mandatory.
171              
172             =head2 name
173              
174             Returns "Unknown license".
175              
176             =head2 url
177              
178             Returns the undefined value.
179              
180             =head2 meta_name
181              
182             Returns "restrictive".
183              
184             =head2 meta2_name
185              
186             Returns "restricted".
187              
188             =head2 spdx_expression
189              
190             Returns a short license name or "Unknown".
191              
192             =head2 license
193              
194             Returns the license text or the empty string.
195              
196             =head1 DIAGNOSTICS
197              
198             None.
199              
200             =head1 CONFIGURATION AND ENVIRONMENT
201              
202             None.
203              
204             =head1 DEPENDENCIES
205              
206             Requires the module L from CPAN.
207              
208             =head1 INCOMPATIBILITIES
209              
210             None.
211              
212             =head1 AUTHOR
213              
214             Andreas Vögele Evoegelas@cpan.orgE
215              
216             =head1 BUGS AND LIMITATIONS
217              
218             None known.
219              
220             =head1 LICENSE AND COPYRIGHT
221              
222             Copyright 2022 Andreas Vögele
223              
224             This module is free software; you can redistribute it and/or modify it under
225             the same terms as Perl itself.
226              
227             =cut
228              
229             __DATA__