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