App-SimpleBackuper

 view release on metacpan or  search on metacpan

local/lib/perl5/Module/Build/Base.pm  view on Meta::CPAN

our $VERSION = '0.4234';
$VERSION = eval $VERSION;

use Carp;
use Cwd ();
use File::Copy ();
use File::Find ();
use File::Path ();
use File::Basename ();
use File::Spec 0.82 ();
use File::Compare ();
use Module::Build::Dumper ();
use Text::ParseWords ();

use Module::Metadata;
use Module::Build::Notes;
use Module::Build::Config;
use version;


#################### Constructors ###########################
sub new {
  my $self = shift()->_construct(@_);

  $self->{invoked_action} = $self->{action} ||= 'Build_PL';
  $self->cull_args(@ARGV);

  die "Too early to specify a build action '$self->{action}'.  Do 'Build $self->{action}' instead.\n"
    if $self->{action} && $self->{action} ne 'Build_PL';

  $self->check_manifest;
  $self->auto_require;

  # All checks must run regardless if one fails, so no short circuiting!
  if( grep { !$_ } $self->check_prereq, $self->check_autofeatures ) {
    $self->log_warn(<<EOF);

ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
of the modules indicated above before proceeding with this installation

EOF
    unless (
      $self->dist_name eq 'Module-Build' ||
      $ENV{PERL5_CPANPLUS_IS_RUNNING} || $ENV{PERL5_CPAN_IS_RUNNING}
    ) {
      $self->log_warn(
        "Run 'Build installdeps' to install missing prerequisites.\n\n"
      );
    }
  }

  # record for later use in resume;
  $self->{properties}{_added_to_INC} = [ $self->_added_to_INC ];

  $self->set_bundle_inc;

  $self->dist_name;
  $self->dist_version;
  $self->release_status;
  $self->_guess_module_name unless $self->module_name;

  $self->_find_nested_builds;

  return $self;
}

sub resume {
  my $package = shift;
  my $self = $package->_construct(@_);
  $self->read_config;

  my @added_earlier = @{ $self->{properties}{_added_to_INC} || [] };

  @INC = ($self->_added_to_INC, @added_earlier, $self->_default_INC);

  # If someone called Module::Build->current() or
  # Module::Build->new_from_context() and the correct class to use is
  # actually a *subclass* of Module::Build, we may need to load that
  # subclass here and re-delegate the resume() method to it.
  unless ( $package->isa($self->build_class) ) {
    my $build_class = $self->build_class;
    my $config_dir = $self->config_dir || '_build';
    my $build_lib = File::Spec->catdir( $config_dir, 'lib' );
    unshift( @INC, $build_lib );
    unless ( $build_class->can('new') ) {
      eval "require $build_class; 1" or die "Failed to re-load '$build_class': $@";
    }
    return $build_class->resume(@_);
  }

  unless ($self->_perl_is_same($self->{properties}{perl})) {
    my $perl = $self->find_perl_interpreter;
    die(<<"DIEFATAL");
* FATAL ERROR: Perl interpreter mismatch. Configuration was initially
  created with '$self->{properties}{perl}'
  but we are now using '$perl'.  You must
  run 'Build realclean' or 'make realclean' and re-configure.
DIEFATAL
  }

  $self->cull_args(@ARGV);

  unless ($self->allow_mb_mismatch) {
    my $mb_version = $Module::Build::VERSION;
    if ( $mb_version ne $self->{properties}{mb_version} ) {
      $self->log_warn(<<"MISMATCH");
* WARNING: Configuration was initially created with Module::Build
  version '$self->{properties}{mb_version}' but we are now using version '$mb_version'.
  If errors occur, you must re-run the Build.PL or Makefile.PL script.
MISMATCH
    }
  }

  $self->{invoked_action} = $self->{action} ||= 'build';

  return $self;
}

sub new_from_context {
  my ($package, %args) = @_;

local/lib/perl5/Module/Build/Base.pm  view on Meta::CPAN

              $seen{$c}++ ? () : $c;
          } @{"$current\::ISA"};

        # I.e., if this class has any parents (at least, ones I've never seen
        # before), push them, in order, onto the stack of classes I need to
        # explore.
    }
    shift @out;
    return @out;
}

sub extra_linker_flags   { shift->_list_accessor('extra_linker_flags',   @_) }
sub extra_compiler_flags { shift->_list_accessor('extra_compiler_flags', @_) }

sub _list_accessor {
  (my $self, local $_) = (shift, shift);
  my $p = $self->{properties};
  $p->{$_} = [@_] if @_;
  $p->{$_} = [] unless exists $p->{$_};
  return ref($p->{$_}) ? $p->{$_} : [$p->{$_}];
}

# XXX Problem - if Module::Build is loaded from a different directory,
# it'll look for (and perhaps destroy/create) a _build directory.
sub subclass {
  my ($pack, %opts) = @_;

  my $build_dir = '_build'; # XXX The _build directory is ostensibly settable by the user.  Shouldn't hard-code here.
  $pack->delete_filetree($build_dir) if -e $build_dir;

  die "Must provide 'code' or 'class' option to subclass()\n"
    unless $opts{code} or $opts{class};

  $opts{code}  ||= '';
  $opts{class} ||= 'MyModuleBuilder';

  my $filename = File::Spec->catfile($build_dir, 'lib', split '::', $opts{class}) . '.pm';
  my $filedir  = File::Basename::dirname($filename);
  $pack->log_verbose("Creating custom builder $filename in $filedir\n");

  File::Path::mkpath($filedir);
  die "Can't create directory $filedir: $!" unless -d $filedir;

  open(my $fh, '>', $filename) or die "Can't create $filename: $!";
  print $fh <<EOF;
package $opts{class};
use $pack;
our \@ISA = qw($pack);
$opts{code}
1;
EOF
  close $fh;

  unshift @INC, File::Spec->catdir(File::Spec->rel2abs($build_dir), 'lib');
  eval "use $opts{class}";
  die $@ if $@;

  return $opts{class};
}

sub _guess_module_name {
  my $self = shift;
  my $p = $self->{properties};
  return if $p->{module_name};
  if ( $p->{dist_version_from} && -e $p->{dist_version_from} ) {
    my $mi = Module::Metadata->new_from_file($self->dist_version_from);
    $p->{module_name} = $mi->name;
  }
  else {
    my $mod_path = my $mod_name = $p->{dist_name};
    $mod_name =~ s{-}{::}g;
    $mod_path =~ s{-}{/}g;
    $mod_path .= ".pm";
    if ( -e $mod_path || -e "lib/$mod_path" ) {
      $p->{module_name} = $mod_name;
    }
    else {
      $self->log_warn( << 'END_WARN' );
No 'module_name' was provided and it could not be inferred
from other properties.  This will prevent a packlist from
being written for this file.  Please set either 'module_name'
or 'dist_version_from' in Build.PL.
END_WARN
    }
  }
}

sub dist_name {
  my $self = shift;
  my $p = $self->{properties};
  my $me = 'dist_name';
  return $p->{$me} if defined $p->{$me};

  die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter"
    unless $self->module_name;

  ($p->{$me} = $self->module_name) =~ s/::/-/g;

  return $p->{$me};
}

sub release_status {
  my ($self) = @_;
  my $me = 'release_status';
  my $p = $self->{properties};

  if ( ! defined $p->{$me} ) {
    $p->{$me} = $self->_is_dev_version ? 'testing' : 'stable';
  }

  unless ( $p->{$me} =~ qr/\A(?:stable|testing|unstable)\z/ ) {
    die "Illegal value '$p->{$me}' for $me\n";
  }

  if ( $p->{$me} eq 'stable' && $self->_is_dev_version ) {
    my $version = $self->dist_version;
    die "Illegal value '$p->{$me}' with version '$version'\n";
  }
  return $p->{$me};
}

local/lib/perl5/Module/Build/Base.pm  view on Meta::CPAN

  return $_ = { map {$_ => 1} grep !$pl_files{$bin_map{$_}}, @bin_files };
}
BEGIN { *scripts = \&script_files; }

{
  my %licenses = (
    perl         => 'Perl_5',
    apache       => 'Apache_2_0',
    apache_1_1   => 'Apache_1_1',
    artistic     => 'Artistic_1',
    artistic_2   => 'Artistic_2',
    lgpl         => 'LGPL_2_1',
    lgpl2        => 'LGPL_2_1',
    lgpl3        => 'LGPL_3_0',
    bsd          => 'BSD',
    gpl          => 'GPL_1',
    gpl2         => 'GPL_2',
    gpl3         => 'GPL_3',
    mit          => 'MIT',
    mozilla      => 'Mozilla_1_1',
    restrictive  => 'Restricted',
    open_source  => undef,
    unrestricted => undef,
    unknown      => undef,
  );

  # TODO - would be nice to not have these here, since they're more
  # properly stored only in Software::License
  my %license_urls = (
    perl         => 'http://dev.perl.org/licenses/',
    apache       => 'http://apache.org/licenses/LICENSE-2.0',
    apache_1_1   => 'http://apache.org/licenses/LICENSE-1.1',
    artistic     => 'http://opensource.org/licenses/artistic-license.php',
    artistic_2   => 'http://opensource.org/licenses/artistic-license-2.0.php',
    lgpl         => 'http://opensource.org/licenses/lgpl-license.php',
    lgpl2        => 'http://opensource.org/licenses/lgpl-2.1.php',
    lgpl3        => 'http://opensource.org/licenses/lgpl-3.0.html',
    bsd          => 'http://opensource.org/licenses/bsd-license.php',
    gpl          => 'http://opensource.org/licenses/gpl-license.php',
    gpl2         => 'http://opensource.org/licenses/gpl-2.0.php',
    gpl3         => 'http://opensource.org/licenses/gpl-3.0.html',
    mit          => 'http://opensource.org/licenses/mit-license.php',
    mozilla      => 'http://opensource.org/licenses/mozilla1.1.php',
    restrictive  => undef,
    open_source  => undef,
    unrestricted => undef,
    unknown      => undef,
  );
  sub valid_licenses {
    return \%licenses;
  }
  sub _license_url {
    return $license_urls{$_[1]};
  }
}

sub _software_license_class {
  my ($self, $license) = @_;
  if ($self->valid_licenses->{$license} && eval { require Software::LicenseUtils; Software::LicenseUtils->VERSION(0.103009) }) {
    my @classes = Software::LicenseUtils->guess_license_from_meta_key($license, 1);
    if (@classes == 1) {
      eval "require $classes[0]";
      return $classes[0];
    }
  }
  LICENSE: for my $l ( $self->valid_licenses->{ $license }, $license ) {
    next unless defined $l;
    my $trial = "Software::License::" . $l;
    if ( eval "require Software::License; Software::License->VERSION(0.014); require $trial; 1" ) {
      return $trial;
    }
  }
  return;
}

# use mapping or license name directly
sub _software_license_object {
  my ($self) = @_;
  return unless defined( my $license = $self->license );

  my $class = $self->_software_license_class($license) or return;

  # Software::License requires a 'holder' argument
  my $author = join( " & ", @{ $self->dist_author }) || 'unknown';
  my $sl = eval { $class->new({holder=>$author}) };
  if ( $@ ) {
    $self->log_warn( "Error getting '$class' object: $@" );
  }

  return $sl;
}

sub _hash_merge {
  my ($self, $h, $k, $v) = @_;
  if (ref $h->{$k} eq 'ARRAY') {
    push @{$h->{$k}}, ref $v ? @$v : $v;
  } elsif (ref $h->{$k} eq 'HASH') {
    $h->{$k}{$_} = $v->{$_} foreach keys %$v;
  } else {
    $h->{$k} = $v;
  }
}

sub ACTION_distmeta {
  my ($self) = @_;
  $self->do_create_makefile_pl if $self->create_makefile_pl;
  $self->do_create_readme if $self->create_readme;
  $self->do_create_license if $self->create_license;
  $self->do_create_metafile;
}

sub do_create_metafile {
  my $self = shift;
  return if $self->{wrote_metadata};

  my $p = $self->{properties};

  unless ($p->{license}) {
    $self->log_warn("No license specified, setting license = 'unknown'\n");
    $p->{license} = 'unknown';