use strict; use warnings; use Carp; package Software::LicenseUtils 0.104006; # ABSTRACT: little useful bits of code for licensey things use File::Spec; use IO::Dir; use Module::Load; #pod =method guess_license_from_pod #pod #pod my @guesses = Software::LicenseUtils->guess_license_from_pod($pm_text); #pod #pod Given text containing POD, like a .pm file, this method will attempt to guess #pod at the license under which the code is available. This method will return #pod either a list of Software::License classes names (as strings) or false. #pod #pod This method looks for a POD heading like 'license', 'copyright', or 'legal'. #pod #pod Calling this method in scalar context is a fatal error. #pod #pod =cut my $_v = qr/(?:v(?:er(?:sion|\.))?(?: |\.)?)/i; my @phrases = ( "under the same (?:terms|license) as perl $_v?6" => [], 'under the same (?:terms|license) as (?:the )?perl' => 'Perl_5', 'affero g' => 'AGPL_3', "GNU (?:general )?public license,? $_v?([123])" => sub { "GPL_$_[0]" }, 'GNU (?:general )?public license' => [ map {"GPL_$_"} (1..3) ], "GNU (?:lesser|library) (?:general )?public license,? $_v?([23])\\D" => sub { $_[0] == 2 ? 'LGPL_2_1' : $_[0] == 3 ? 'LGPL_3_0' : () }, 'GNU (?:lesser|library) (?:general )?public license' => [ qw(LGPL_2_1 LGPL_3_0) ], '(?:the )?2[-\s]clause (?:Free)?BSD' => 'FreeBSD', 'BSD license' => 'BSD', 'FreeBSD license' => 'FreeBSD', "Artistic license $_v?(\\d)" => sub { "Artistic_$_[0]_0" }, 'Artistic license' => [ map { "Artistic_$_\_0" } (1..2) ], "LGPL,? $_v?(\\d)" => sub { $_[0] == 2 ? 'LGPL_2_1' : $_[0] == 3 ? 'LGPL_3_0' : () }, 'LGPL' => [ qw(LGPL_2_1 LGPL_3_0) ], "GPL,? $_v?(\\d)" => sub { "GPL_$_[0]" }, 'GPL' => [ map { "GPL_$_" } (1..3) ], 'FreeBSD' => 'FreeBSD', 'BSD' => 'BSD', 'Artistic' => [ map { "Artistic_$_\_0" } (1..2) ], 'MIT' => 'MIT', 'has dedicated the work to the Commons' => 'CC0_1_0', 'waiving all of his or her rights to the work worldwide under copyright law' => 'CC0_1_0', 'has waived all copyright and related or neighboring rights to' => 'CC0_1_0', 'apache(?: |-)1.1' => "Apache_1_1", "Apache Software License(\\s)+Version 1.1" => "Apache_1_1", 'apache(?: |-)2.0' => "Apache_2_0", "Apache License(\\s)+Version 2.0" => "Apache_2_0", 'No license is granted to other entities' => 'None', ); my %meta_keys = (); my %meta1_keys = (); my %meta2_keys = (); my %spdx_expression = (); # find all known Software::License::* modules and get identification data # # XXX: Grepping over @INC is dangerous, as it means that someone can change the # behavior of your code by installing a new library that you don't load. rjbs # is not a fan. On the other hand, it will solve a real problem. One better # solution is to check "core" licenses first, then fall back, and to skip (but # warn about) bogus libraries. Another is, at least when testing S-L itself, # to only scan lib/ blib. -- rjbs, 2013-10-20 for my $lib (map { "$_/Software/License" } @INC) { next unless -d $lib; for my $file (IO::Dir->new($lib)->read) { next unless $file =~ m{\.pm$}; # if it fails, ignore it eval { (my $mod = $file) =~ s{\.pm$}{}; my $class = "Software::License::$mod"; load $class; $meta_keys{ $class->meta_name }{$mod} = undef; $meta1_keys{ $class->meta_name }{$mod} = undef; $meta_keys{ $class->meta2_name }{$mod} = undef; $meta2_keys{ $class->meta2_name }{$mod} = undef; if (defined $class->spdx_expression) { $spdx_expression{ $class->spdx_expression }{$class} = undef; } my $name = $class->name; unshift @phrases, qr/\Q$name\E/, [$mod]; if ((my $name_without_space = $name) =~ s/\s+\(.+?\)//) { unshift @phrases, qr/\Q$name_without_space\E/, [$mod]; } }; } } sub guess_license_from_pod { my ($class, $pm_text) = @_; die "can't call guess_license_* in scalar context" unless wantarray; return unless $pm_text =~ / ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b ) /ixmsg; my $header = $1; if ( $pm_text =~ m/ \G ( .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = "$header$1"; for (my $i = 0; $i < @phrases; $i += 2) { my ($pattern, $license) = @phrases[ $i .. $i+1 ]; $pattern =~ s{\s+}{\\s+}g unless ref $pattern eq 'Regexp'; if ( $license_text =~ /\b$pattern\b/i ) { my $match = $1; # if ( $osi and $license_text =~ /All rights reserved/i ) { # warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it."; # } my @result = (ref $license||'') eq 'CODE' ? $license->($match) : (ref $license||'') eq 'ARRAY' ? @$license : $license; return unless @result; return map { "Software::License::$_" } sort @result; } } } return; } #pod =method guess_license_from_meta #pod #pod my @guesses = Software::LicenseUtils->guess_license_from_meta($meta_str); #pod #pod Given the content of the META.(yml|json) file found in a CPAN distribution, this #pod method makes a guess as to which licenses may apply to the distribution. It #pod will return a list of zero or more Software::License instances or classes. #pod #pod =cut sub guess_license_from_meta { my ($class, $meta_text) = @_; die "can't call guess_license_* in scalar context" unless wantarray; my ($license_text) = $meta_text =~ m{\b["']?license["']?\s*:\s*["']?([a-z_0-9]+)["']?}gm; return unless $license_text and my $license = $meta_keys{ $license_text }; return map { "Software::License::$_" } sort keys %$license; } { no warnings 'once'; *guess_license_from_meta_yml = \&guess_license_from_meta; } #pod =method guess_license_from_meta_key #pod #pod my @guesses = Software::LicenseUtils->guess_license_from_meta_key($key, $v); #pod #pod This method returns zero or more Software::License classes known to use C<$key> #pod as their META key. If C<$v> is supplied, it specifies whether to treat C<$key> #pod as a v1 or v2 meta entry. Any value other than 1 or 2 will raise an exception. #pod #pod =cut sub guess_license_from_meta_key { my ($self, $key, $v) = @_; my $src = (! defined $v) ? \%meta_keys : $v eq '1' ? \%meta1_keys : $v eq '2' ? \%meta2_keys : Carp::croak("illegal META version: $v"); return unless $src->{$key}; return map { "Software::License::$_" } sort keys %{ $src->{$key} }; } my %short_name = ( 'GPL-1' => 'Software::License::GPL_1', 'GPL-2' => 'Software::License::GPL_2', 'GPL-3' => 'Software::License::GPL_3', 'LGPL-2' => 'Software::License::LGPL_2', 'LGPL-2.1' => 'Software::License::LGPL_2_1', 'LGPL-3' => 'Software::License::LGPL_3_0', 'LGPL-3.0' => 'Software::License::LGPL_3_0', 'Artistic' => 'Software::License::Artistic_1_0', 'Artistic-1' => 'Software::License::Artistic_1_0', 'Artistic-2' => 'Software::License::Artistic_2_0', ); #pod =method new_from_short_name #pod #pod my $license_object = Software::LicenseUtils->new_from_short_name( { #pod short_name => 'GPL-1', #pod holder => 'X. Ample' #pod }) ; #pod #pod Create a new L object from the license specified #pod with C. Known short license names are C, C , #pod C and C #pod #pod =cut sub new_from_short_name { my ( $class, $arg ) = @_; Carp::croak "no license short name specified" unless defined $arg->{short_name}; my $short = delete $arg->{short_name}; Carp::croak "Unknown license with short name $short" unless $short_name{$short}; my $lic_file = my $lic_class = $short_name{$short} ; $lic_file =~ s!::!/!g; require "$lic_file.pm"; return $lic_class->new( $arg ); } #pod =method new_from_spdx_expression #pod #pod my $license_object = Software::LicenseUtils->new_from_spdx_expression( { #pod spdx_expression => 'MPL-2.0', #pod holder => 'X. Ample' #pod }) ; #pod #pod Create a new L object from the license specified #pod with C. Some licenses doesn't have an spdx #pod identifier (for example L), so you can pass #pod spdx identifier but also expressions. #pod Known spdx license identifiers are C, C. #pod #pod =cut sub new_from_spdx_expression { my ( $class, $arg ) = @_; Carp::croak "no license spdx name specified" unless defined $arg->{spdx_expression}; my $spdx = delete $arg->{spdx_expression}; Carp::croak "Unknown license with spdx name $spdx" unless $spdx_expression{$spdx}; my ($lic_file) = my ($lic_class) = keys %{$spdx_expression{$spdx}} ; $lic_file =~ s!::!/!g; require "$lic_file.pm"; return $lic_class->new( $arg ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Software::LicenseUtils - little useful bits of code for licensey things =head1 VERSION version 0.104006 =head1 PERL VERSION This module is part of CPAN toolchain, or is treated as such. As such, it follows the agreement of the Perl Toolchain Gang to require no newer version of perl than one released in the last ten years. This version may change by agreement of the Toolchain Gang, but for now is governed by the L of 2013 and the Lyon Amendment of 2023 (described at the linked-to document). Although it may work on older versions of perl, no guarantee is made that the minimum required version will not be increased. The version may be increased for any reason, and there is no promise that patches will be accepted to lower the minimum required perl. =head1 METHODS =head2 guess_license_from_pod my @guesses = Software::LicenseUtils->guess_license_from_pod($pm_text); Given text containing POD, like a .pm file, this method will attempt to guess at the license under which the code is available. This method will return either a list of Software::License classes names (as strings) or false. This method looks for a POD heading like 'license', 'copyright', or 'legal'. Calling this method in scalar context is a fatal error. =head2 guess_license_from_meta my @guesses = Software::LicenseUtils->guess_license_from_meta($meta_str); Given the content of the META.(yml|json) file found in a CPAN distribution, this method makes a guess as to which licenses may apply to the distribution. It will return a list of zero or more Software::License instances or classes. =head2 guess_license_from_meta_key my @guesses = Software::LicenseUtils->guess_license_from_meta_key($key, $v); This method returns zero or more Software::License classes known to use C<$key> as their META key. If C<$v> is supplied, it specifies whether to treat C<$key> as a v1 or v2 meta entry. Any value other than 1 or 2 will raise an exception. =head2 new_from_short_name my $license_object = Software::LicenseUtils->new_from_short_name( { short_name => 'GPL-1', holder => 'X. Ample' }) ; Create a new L object from the license specified with C. Known short license names are C, C , C and C =head2 new_from_spdx_expression my $license_object = Software::LicenseUtils->new_from_spdx_expression( { spdx_expression => 'MPL-2.0', holder => 'X. Ample' }) ; Create a new L object from the license specified with C. Some licenses doesn't have an spdx identifier (for example L), so you can pass spdx identifier but also expressions. Known spdx license identifiers are C, C. =head1 AUTHOR Ricardo Signes =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2024 by Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut