File Coverage

blib/lib/String/License/Naming/Custom.pm
Criterion Covered Total %
statement 41 52 78.8
branch 3 6 50.0
condition n/a
subroutine 13 14 92.8
pod 4 4 100.0
total 61 76 80.2


line stmt bran cond sub pod time code
1 11     11   1231941 use Feature::Compat::Class 0.04;
  11         571  
  11         73  
2              
3 11     11   14351 use v5.12;
  11         56  
4 11     11   78 use utf8;
  11         41  
  11         113  
5 11     11   287 use warnings;
  11         27  
  11         680  
6              
7             =head1 NAME
8              
9             String::License::Naming - names of licenses and license naming schemes
10              
11             =head1 VERSION
12              
13             Version v0.0.5
14              
15             =head1 SYNOPSIS
16              
17             use String::License::Naming::Custom;
18              
19             my $obj = String::License::Naming::Custom->new( schemes => [qw(spdx internal)] );
20              
21             my $schemes = [ $obj->list_schemes ]; # => is_deeply [ 'spdx', 'internal' ]
22              
23             my $license = [ grep { /^(Expat|Perl)$/ } $obj->list_licenses ]; # => is_deeply ['Perl']
24              
25             # use and prefer Debian-specific identifiers
26             $schemes = [ $obj->add_scheme('debian') ]; # => is_deeply [ 'debian', 'spdx', 'internal' ]
27              
28             $license = [ grep { /^(Expat|Perl)$/ } $obj->list_licenses ]; # => is_deeply [ 'Expat', 'Perl' ]
29              
30             =head1 DESCRIPTION
31              
32             L enumerates supported licenses
33             matching an ordered set of naming schemes,
34             or enumerates the names of supported license naming schemes.
35              
36             Some licenses are known by different names.
37             E.g. the license "MIT" according to SPDX
38             is named "Expat" in Debian.
39              
40             Some licenses are not always represented.
41             E.g. "Perl" is a (discouraged) license in Debian
42             while it is a relationship of several licenses with SPDX
43             (and that expression is recommended in Debian as well).
44              
45             By default,
46             licenses are matched using naming schemes C<[ 'spdx', 'internal' ]>,
47             which lists all supported licenses,
48             preferrably by their SPDX name
49             or as fallback by an internal name.
50              
51             =cut
52              
53             package String::License::Naming::Custom v0.0.5;
54              
55 11     11   77 use Carp qw(croak);
  11         26  
  11         548  
56 11     11   80 use Log::Any ();
  11         24  
  11         257  
57 11     11   610 use List::SomeUtils qw(uniq);
  11         13498  
  11         579  
58 11     11   85 use Regexp::Pattern::License 3.4.0;
  11         171  
  11         269  
59              
60 11     11   5064 use namespace::clean;
  11         109328  
  11         79  
61              
62 11     11   7704 class String::License::Naming::Custom :isa(String::License::Naming);
  11         28  
  11         15526  
63              
64             field $log;
65              
66             =head1 CONSTRUCTOR
67              
68             =over
69              
70             =item new
71              
72             my $names = String::License::Naming->new;
73              
74             my $spdx_names = String::License::Naming->new( schemes => ['spdx'] );
75              
76             Constructs and returns a String::License::Naming object.
77              
78             Takes an optional array as named argument B.
79             both ordering by which name licenses should be presented,
80             and limiting which licenses to cover.
81              
82             When omitted,
83             the default schemes array C<[ 'spdx', 'internal' ]> is used,
84             which includes all supported licenses,
85             and they are presented by their SPDX name when defined
86             or otherwise by a semi-stable internal name.
87              
88             When passing an empty array reference,
89             all supported licenses are included,
90             presented by a semi-stable internal potentially multi-word description.
91              
92             =back
93              
94             =cut
95              
96             field $schemes :param = undef;
97              
98             # TODO: maybe support seeding explicit keys
99             field $keys;
100              
101             ADJUST {
102             $log = Log::Any->get_logger;
103              
104             if ( defined $schemes ) {
105              
106             croak $log->fatal('parameter "schemes" must be an array reference')
107             unless ref $schemes eq 'ARRAY';
108              
109             # TODO: die unless each arrayref entry is a string and supported
110              
111             my @uniq_schemes = uniq @$schemes;
112             if ( join( ' ', @$schemes ) ne join( ' ', @uniq_schemes ) ) {
113             $log->warn("duplicate scheme(s) omitted");
114             @$schemes = \@uniq_schemes;
115             }
116             }
117             else {
118             $schemes = [];
119             }
120              
121             $keys = [
122             String::License::Naming::resolve_shortnames( $keys, $schemes, 1 ) ];
123             }
124              
125             =head1 FUNCTIONS
126              
127             =over
128              
129             =item add_scheme
130              
131             Takes a string representing a license naming scheme to use,
132             favored over existing schemes in use.
133              
134             Returns array of schemes in use after addition.
135              
136             =cut
137              
138             method add_scheme
139 3     3 1 206890 {
140 3         14 my ($new_scheme) = @_;
141 3 50       14 croak $log->fatal("no new scheme provided")
142             unless $new_scheme;
143 3 50       13 $log->warn("excess arguments beyond new scheme ignored")
144             if @_ > 1;
145              
146 3 50       12 if ( grep { $_ eq $new_scheme } @$schemes ) {
  1         6  
147 0         0 $log->warn("already included scheme $new_scheme not added");
148 0         0 return @$schemes;
149             }
150              
151             # TODO: validate new entry is string and supported, or die
152 3         10 unshift @$schemes, $new_scheme;
153              
154 3         25 return @$schemes;
155             }
156              
157             =item list_schemes
158              
159             Returns a list of license naming schemes in use.
160              
161             =cut
162              
163             method list_schemes
164 7095     7095 1 15548 {
165 7095         18555 return @$schemes;
166             }
167              
168             =item list_available_schemes
169              
170             Returns a list of all license naming schemes available.
171              
172             =cut
173              
174             method list_available_schemes
175 0     0 1 0 {
176 0         0 my $_prop = '(?:[a-z][a-z0-9_]*)';
177 0         0 my $_any = '[a-z0-9_.()]';
178              
179             my @result = uniq sort
180 0         0 map {/^(?:name|caption)\.alt\.org\.($_prop)$_any*/}
181 0         0 map { keys %{ $Regexp::Pattern::License::RE{$_} } }
  0         0  
182 0         0 grep {/^[a-z]/} keys %Regexp::Pattern::License::RE;
  0         0  
183              
184 0         0 return @result;
185             }
186              
187             =item list_licenses
188              
189             Returns a list of licensing patterns covered by this object instance,
190             each labeled by shortname according to current set of schemes.
191              
192             =cut
193              
194             method list_licenses
195 4     4 1 18 {
196 4         15 return String::License::Naming::resolve_shortnames( $keys, $schemes );
197             }
198              
199             =back
200              
201             =encoding UTF-8
202              
203             =head1 AUTHOR
204              
205             Jonas Smedegaard C<< >>
206              
207             =head1 COPYRIGHT AND LICENSE
208              
209             Copyright © 2023 Jonas Smedegaard
210              
211             This program is free software:
212             you can redistribute it and/or modify it
213             under the terms of the GNU Affero General Public License
214             as published by the Free Software Foundation,
215             either version 3, or (at your option) any later version.
216              
217             This program is distributed in the hope that it will be useful,
218             but WITHOUT ANY WARRANTY;
219             without even the implied warranty
220             of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
221             See the GNU Affero General Public License for more details.
222              
223             You should have received a copy
224             of the GNU Affero General Public License along with this program.
225             If not, see .
226              
227             =cut
228              
229             1;