File Coverage

blib/lib/Software/LicenseUtils.pm

Criterion	Covered	Total	%
statement	66	66	100.0
branch	24	36	66.6
condition	5	7	71.4
subroutine	12	12	100.0
pod	5	5	100.0
total	112	126	88.8

use strict;
use warnings;
use Carp;

# ABSTRACT: little useful bits of code for licensey things
$Software::LicenseUtils::VERSION = '0.104002';
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];
      }
    };
  }
}

  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

  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

  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<Software::License> object from the license specified
#pod with C<short_name>. Known short license names are C<GPL-*>, C<LGPL-*> ,
#pod C<Artistic> and C<Artistic-*>
#pod
#pod =cut

  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<Software::License> object from the license specified
#pod with C<spdx_expression>. Some licenses doesn't have an spdx
#pod identifier (for example L<Software::License::Perl_5>), so you can pass
#pod spdx identifier but also expressions.
#pod Known spdx license identifiers are C<BSD>, C<MPL-1.0>.
#pod
#pod =cut

  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;


=pod

=encoding UTF-8

=head1 NAME

Software::LicenseUtils - little useful bits of code for licensey things

=head1 VERSION

version 0.104002

=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 v5.8.1.  This version may change by agreement of the Toolchain Gang,
but for now is governed by the L<Lancaster
Consensus|https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>
of 2013.

=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<Software::License> object from the license specified
with C<short_name>. Known short license names are C<GPL-*>, C<LGPL-*> ,
C<Artistic> and C<Artistic-*>

=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<Software::License> object from the license specified
with C<spdx_expression>. Some licenses doesn't have an spdx
identifier (for example L<Software::License::Perl_5>), so you can pass
spdx identifier but also expressions.
Known spdx license identifiers are C<BSD>, C<MPL-1.0>.

=head1 AUTHOR

Ricardo Signes <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2022 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