1use strict;
2use warnings;
3use Carp;
4
5package Software::LicenseUtils;
6# ABSTRACT: little useful bits of code for licensey things
7$Software::LicenseUtils::VERSION = '0.104001';
8use File::Spec;
9use IO::Dir;
10use Module::Load;
11
12#pod =method guess_license_from_pod
13#pod
14#pod   my @guesses = Software::LicenseUtils->guess_license_from_pod($pm_text);
15#pod
16#pod Given text containing POD, like a .pm file, this method will attempt to guess
17#pod at the license under which the code is available.  This method will return
18#pod either a list of Software::License classes names (as strings) or false.
19#pod
20#pod This method looks for a POD heading like 'license', 'copyright', or 'legal'.
21#pod
22#pod Calling this method in scalar context is a fatal error.
23#pod
24#pod =cut
25
26my $_v = qr/(?:v(?:er(?:sion|\.))?(?: |\.)?)/i;
27my @phrases = (
28  "under the same (?:terms|license) as perl $_v?6" => [],
29  'under the same (?:terms|license) as (?:the )?perl'    => 'Perl_5',
30  'affero g'                                    => 'AGPL_3',
31  "GNU (?:general )?public license,? $_v?([123])" => sub { "GPL_$_[0]" },
32  'GNU (?:general )?public license'             => [ map {"GPL_$_"} (1..3) ],
33  "GNU (?:lesser|library) (?:general )?public license,? $_v?([23])\\D"  => sub {
34    $_[0] == 2 ? 'LGPL_2_1' : $_[0] == 3 ? 'LGPL_3_0' : ()
35  },
36  'GNU (?:lesser|library) (?:general )?public license'  => [ qw(LGPL_2_1 LGPL_3_0) ],
37  '(?:the )?2[-\s]clause (?:Free)?BSD' => 'FreeBSD',
38  'BSD license'                => 'BSD',
39  'FreeBSD license'            => 'FreeBSD',
40  "Artistic license $_v?(\\d)" => sub { "Artistic_$_[0]_0" },
41  'Artistic license'           => [ map { "Artistic_$_\_0" } (1..2) ],
42  "LGPL,? $_v?(\\d)"             => sub {
43    $_[0] == 2 ? 'LGPL_2_1' : $_[0] == 3 ? 'LGPL_3_0' : ()
44  },
45  'LGPL'                       => [ qw(LGPL_2_1 LGPL_3_0) ],
46  "GPL,? $_v?(\\d)"              => sub { "GPL_$_[0]" },
47  'GPL'                        => [ map { "GPL_$_" } (1..3) ],
48  'FreeBSD'                    => 'FreeBSD',
49  'BSD'                        => 'BSD',
50  'Artistic'                   => [ map { "Artistic_$_\_0" } (1..2) ],
51  'MIT'                        => 'MIT',
52  'has dedicated the work to the Commons' => 'CC0_1_0',
53  'waiving all of his or her rights to the work worldwide under copyright law' => 'CC0_1_0',
54  'has waived all copyright and related or neighboring rights to' => 'CC0_1_0',
55);
56
57my %meta_keys  = ();
58my %meta1_keys = ();
59my %meta2_keys = ();
60my %spdx_expression  = ();
61
62# find all known Software::License::* modules and get identification data
63#
64# XXX: Grepping over @INC is dangerous, as it means that someone can change the
65# behavior of your code by installing a new library that you don't load.  rjbs
66# is not a fan.  On the other hand, it will solve a real problem.  One better
67# solution is to check "core" licenses first, then fall back, and to skip (but
68# warn about) bogus libraries.  Another is, at least when testing S-L itself,
69# to only scan lib/ blib. -- rjbs, 2013-10-20
70for my $lib (map { "$_/Software/License" } @INC) {
71  next unless -d $lib;
72  for my $file (IO::Dir->new($lib)->read) {
73    next unless $file =~ m{\.pm$};
74
75    # if it fails, ignore it
76    eval {
77      (my $mod = $file) =~ s{\.pm$}{};
78      my $class = "Software::License::$mod";
79      load $class;
80      $meta_keys{  $class->meta_name  }{$mod} = undef;
81      $meta1_keys{ $class->meta_name  }{$mod} = undef;
82      $meta_keys{  $class->meta2_name }{$mod} = undef;
83      $meta2_keys{ $class->meta2_name }{$mod} = undef;
84      if (defined $class->spdx_expression) {
85        $spdx_expression{  $class->spdx_expression   }{$class} = undef;
86      }
87      my $name = $class->name;
88      unshift @phrases, qr/\Q$name\E/, [$mod];
89      if ((my $name_without_space = $name) =~ s/\s+\(.+?\)//) {
90        unshift @phrases, qr/\Q$name_without_space\E/, [$mod];
91      }
92    };
93  }
94}
95
96sub guess_license_from_pod {
97  my ($class, $pm_text) = @_;
98  die "can't call guess_license_* in scalar context" unless wantarray;
99  return unless $pm_text =~ /
100    (
101      =head \d \s+
102      (?:licen[cs]e|licensing|copyright|legal)\b
103    )
104  /ixmsg;
105
106  my $header = $1;
107
108  if (
109    $pm_text =~ m/
110      \G
111      (
112        .*?
113      )
114      (=head\\d.*|=cut.*|)
115      \z
116    /ixms
117  ) {
118    my $license_text = "$header$1";
119
120    for (my $i = 0; $i < @phrases; $i += 2) {
121      my ($pattern, $license) = @phrases[ $i .. $i+1 ];
122      $pattern =~ s{\s+}{\\s+}g
123        unless ref $pattern eq 'Regexp';
124      if ( $license_text =~ /\b$pattern\b/i ) {
125        my $match = $1;
126        # if ( $osi and $license_text =~ /All rights reserved/i ) {
127        #   warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
128        # }
129        my @result = (ref $license||'') eq 'CODE'  ? $license->($match)
130                   : (ref $license||'') eq 'ARRAY' ? @$license
131                   :                                 $license;
132
133        return unless @result;
134        return map { "Software::License::$_" } sort @result;
135      }
136    }
137  }
138
139  return;
140}
141
142#pod =method guess_license_from_meta
143#pod
144#pod   my @guesses = Software::LicenseUtils->guess_license_from_meta($meta_str);
145#pod
146#pod Given the content of the META.(yml|json) file found in a CPAN distribution, this
147#pod method makes a guess as to which licenses may apply to the distribution.  It
148#pod will return a list of zero or more Software::License instances or classes.
149#pod
150#pod =cut
151
152sub guess_license_from_meta {
153  my ($class, $meta_text) = @_;
154  die "can't call guess_license_* in scalar context" unless wantarray;
155
156  my ($license_text) = $meta_text =~ m{\b["']?license["']?\s*:\s*["']?([a-z_0-9]+)["']?}gm;
157
158  return unless $license_text and my $license = $meta_keys{ $license_text };
159
160  return map { "Software::License::$_" } sort keys %$license;
161}
162
163{
164  no warnings 'once';
165  *guess_license_from_meta_yml = \&guess_license_from_meta;
166}
167
168#pod =method guess_license_from_meta_key
169#pod
170#pod   my @guesses = Software::LicenseUtils->guess_license_from_meta_key($key, $v);
171#pod
172#pod This method returns zero or more Software::License classes known to use C<$key>
173#pod as their META key.  If C<$v> is supplied, it specifies whether to treat C<$key>
174#pod as a v1 or v2 meta entry.  Any value other than 1 or 2 will raise an exception.
175#pod
176#pod =cut
177
178sub guess_license_from_meta_key {
179  my ($self, $key, $v) = @_;
180
181  my $src = (! defined $v) ? \%meta_keys
182          : $v eq '1'      ? \%meta1_keys
183          : $v eq '2'      ? \%meta2_keys
184          : Carp::croak("illegal META version: $v");
185
186  return unless $src->{$key};
187  return map { "Software::License::$_" } sort keys %{ $src->{$key} };
188}
189
190my %short_name = (
191  'GPL-1'      =>  'Software::License::GPL_1',
192  'GPL-2'      =>  'Software::License::GPL_2',
193  'GPL-3'      =>  'Software::License::GPL_3',
194  'LGPL-2'     =>  'Software::License::LGPL_2',
195  'LGPL-2.1'   =>  'Software::License::LGPL_2_1',
196  'LGPL-3'     =>  'Software::License::LGPL_3_0',
197  'LGPL-3.0'   =>  'Software::License::LGPL_3_0',
198  'Artistic'   =>  'Software::License::Artistic_1_0',
199  'Artistic-1' =>  'Software::License::Artistic_1_0',
200  'Artistic-2' =>  'Software::License::Artistic_2_0',
201);
202
203#pod =method new_from_short_name
204#pod
205#pod   my $license_object = Software::LicenseUtils->new_from_short_name( {
206#pod      short_name => 'GPL-1',
207#pod      holder => 'X. Ample'
208#pod   }) ;
209#pod
210#pod Create a new L<Software::License> object from the license specified
211#pod with C<short_name>. Known short license names are C<GPL-*>, C<LGPL-*> ,
212#pod C<Artistic> and C<Artistic-*>
213#pod
214#pod =cut
215
216sub new_from_short_name {
217  my ( $class, $arg ) = @_;
218
219  Carp::croak "no license short name specified"
220    unless defined $arg->{short_name};
221  my $short = delete $arg->{short_name};
222  Carp::croak "Unknown license with short name $short"
223    unless $short_name{$short};
224
225  my $lic_file = my $lic_class = $short_name{$short} ;
226  $lic_file =~ s!::!/!g;
227  require "$lic_file.pm";
228  return $lic_class->new( $arg );
229}
230
231#pod =method new_from_spdx_expression
232#pod
233#pod   my $license_object = Software::LicenseUtils->new_from_spdx_expression( {
234#pod      spdx_expression => 'MPL-2.0',
235#pod      holder => 'X. Ample'
236#pod   }) ;
237#pod
238#pod Create a new L<Software::License> object from the license specified
239#pod with C<spdx_expression>. Some licenses doesn't have an spdx
240#pod identifier (for example L<Software::License::Perl_5>), so you can pass
241#pod spdx identifier but also expressions.
242#pod Known spdx license identifiers are C<BSD>, C<MPL-1.0>.
243#pod
244#pod =cut
245
246sub new_from_spdx_expression {
247  my ( $class, $arg ) = @_;
248
249  Carp::croak "no license spdx name specified"
250    unless defined $arg->{spdx_expression};
251  my $spdx = delete $arg->{spdx_expression};
252  Carp::croak "Unknown license with spdx name $spdx"
253    unless $spdx_expression{$spdx};
254
255  my ($lic_file) = my ($lic_class) = keys %{$spdx_expression{$spdx}} ;
256  $lic_file =~ s!::!/!g;
257  require "$lic_file.pm";
258  return $lic_class->new( $arg );
259}
260
2611;
262
263__END__
264
265=pod
266
267=encoding UTF-8
268
269=head1 NAME
270
271Software::LicenseUtils - little useful bits of code for licensey things
272
273=head1 VERSION
274
275version 0.104001
276
277=head1 METHODS
278
279=head2 guess_license_from_pod
280
281  my @guesses = Software::LicenseUtils->guess_license_from_pod($pm_text);
282
283Given text containing POD, like a .pm file, this method will attempt to guess
284at the license under which the code is available.  This method will return
285either a list of Software::License classes names (as strings) or false.
286
287This method looks for a POD heading like 'license', 'copyright', or 'legal'.
288
289Calling this method in scalar context is a fatal error.
290
291=head2 guess_license_from_meta
292
293  my @guesses = Software::LicenseUtils->guess_license_from_meta($meta_str);
294
295Given the content of the META.(yml|json) file found in a CPAN distribution, this
296method makes a guess as to which licenses may apply to the distribution.  It
297will return a list of zero or more Software::License instances or classes.
298
299=head2 guess_license_from_meta_key
300
301  my @guesses = Software::LicenseUtils->guess_license_from_meta_key($key, $v);
302
303This method returns zero or more Software::License classes known to use C<$key>
304as their META key.  If C<$v> is supplied, it specifies whether to treat C<$key>
305as a v1 or v2 meta entry.  Any value other than 1 or 2 will raise an exception.
306
307=head2 new_from_short_name
308
309  my $license_object = Software::LicenseUtils->new_from_short_name( {
310     short_name => 'GPL-1',
311     holder => 'X. Ample'
312  }) ;
313
314Create a new L<Software::License> object from the license specified
315with C<short_name>. Known short license names are C<GPL-*>, C<LGPL-*> ,
316C<Artistic> and C<Artistic-*>
317
318=head2 new_from_spdx_expression
319
320  my $license_object = Software::LicenseUtils->new_from_spdx_expression( {
321     spdx_expression => 'MPL-2.0',
322     holder => 'X. Ample'
323  }) ;
324
325Create a new L<Software::License> object from the license specified
326with C<spdx_expression>. Some licenses doesn't have an spdx
327identifier (for example L<Software::License::Perl_5>), so you can pass
328spdx identifier but also expressions.
329Known spdx license identifiers are C<BSD>, C<MPL-1.0>.
330
331=head1 AUTHOR
332
333Ricardo Signes <rjbs@semiotic.systems>
334
335=head1 COPYRIGHT AND LICENSE
336
337This software is copyright (c) 2021 by Ricardo Signes.
338
339This is free software; you can redistribute it and/or modify it under
340the same terms as the Perl 5 programming language system itself.
341
342=cut
343