view release on metacpan or  search on metacpan

inc/inc_Module-Build/Module/Build/Base.pm  view on Meta::CPAN

  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 ( UNIVERSAL::isa($package, $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) = @_;

  $package->run_perl_script('Build.PL',[],[$package->unparse_args(\%args)]);
  return $package->resume;
}

sub current {
  # hmm, wonder what the right thing to do here is
  local @ARGV;
  return shift()->resume;
}

sub _construct {
  my ($package, %input) = @_;

  my $args   = delete $input{args}   || {};
  my $config = delete $input{config} || {};

  my $self = bless {
      args => {%$args},
      config => Module::Build::Config->new(values => $config),
      properties => {
          base_dir        => $package->cwd,
          mb_version      => $Module::Build::VERSION,
          %input,
      },
      phash => {},
      stash => {}, # temporary caching, not stored in _build
  }, $package;

  $self->_set_defaults;
  my ($p, $ph) = ($self->{properties}, $self->{phash});

  foreach (qw(notes config_data features runtime_params cleanup auto_features)) {
    my $file = File::Spec->catfile($self->config_dir, $_);
    $ph->{$_} = Module::Build::Notes->new(file => $file);
    $ph->{$_}->restore if -e $file;
    if (exists $p->{$_}) {
      my $vals = delete $p->{$_};
      while (my ($k, $v) = each %$vals) {
        $self->$_($k, $v);
      }
    }
  }

  # The following warning could be unnecessary if the user is running
  # an embedded perl, but there aren't too many of those around, and
  # embedded perls aren't usually used to install modules, and the
  # installation process sometimes needs to run external scripts
  # (e.g. to run tests).
  $p->{perl} = $self->find_perl_interpreter
    or $self->log_warn("Warning: Can't locate your perl binary");

  my $blibdir = sub { File::Spec->catdir($p->{blib}, @_) };
  $p->{bindoc_dirs} ||= [ $blibdir->("script") ];
  $p->{libdoc_dirs} ||= [ $blibdir->("lib"), $blibdir->("arch") ];

  $p->{dist_author} = [ $p->{dist_author} ] if defined $p->{dist_author} and not ref $p->{dist_author};

  # Synonyms
  $p->{requires} = delete $p->{prereq} if defined $p->{prereq};
  $p->{script_files} = delete $p->{scripts} if defined $p->{scripts};

  # Convert to from shell strings to arrays
  for ('extra_compiler_flags', 'extra_linker_flags') {
    $p->{$_} = [ $self->split_like_shell($p->{$_}) ] if exists $p->{$_};
  }

  # Convert to arrays

inc/inc_Module-Build/Module/Build/Base.pm  view on Meta::CPAN

    local $self->{invoked_action} = $action;
    local $self->{args} = {%{$self->{args}}, %$args};
    local $self->{properties} = {%{$self->{properties}}, %p};
    return $self->_call_action($action);
  }

  die "No build action specified" unless $self->{action};
  local $self->{invoked_action} = $self->{action};
  $self->_call_action($self->{action});
}

sub _call_action {
  my ($self, $action) = @_;

  return if $self->{_completed_actions}{$action}++;

  local $self->{action} = $action;
  my $method = $self->can_action( $action );
  die "No action '$action' defined, try running the 'help' action.\n" unless $method;
  $self->log_debug("Starting ACTION_$action\n");
  my $rc = $self->$method();
  $self->log_debug("Finished ACTION_$action\n");
  return $rc;
}

sub can_action {
  my ($self, $action) = @_;
  return $self->can( "ACTION_$action" );
}

# cuts the user-specified options out of the command-line args
sub cull_options {
    my $self = shift;
    my (@argv) = @_;

    # XXX is it even valid to call this as a class method?
    return({}, @argv) unless(ref($self)); # no object

    my $specs = $self->get_options;
    return({}, @argv) unless($specs and %$specs); # no user options

    require Getopt::Long;
    # XXX Should we let Getopt::Long handle M::B's options? That would
    # be easy-ish to add to @specs right here, but wouldn't handle options
    # passed without "--" as M::B currently allows. We might be able to
    # get around this by setting the "prefix_pattern" Configure option.
    my @specs;
    my $args = {};
    # Construct the specifications for GetOptions.
    while (my ($k, $v) = each %$specs) {
        # Throw an error if specs conflict with our own.
        die "Option specification '$k' conflicts with a " . ref $self
          . " option of the same name"
          if $self->valid_property($k);
        push @specs, $k . (defined $v->{type} ? $v->{type} : '');
        push @specs, $v->{store} if exists $v->{store};
        $args->{$k} = $v->{default} if exists $v->{default};
    }

    local @ARGV = @argv; # No other way to dupe Getopt::Long

    # Get the options values and return them.
    # XXX Add option to allow users to set options?
    if ( @specs ) {
      Getopt::Long::Configure('pass_through');
      Getopt::Long::GetOptions($args, @specs);
    }

    return $args, @ARGV;
}

sub unparse_args {
  my ($self, $args) = @_;
  my @out;
  while (my ($k, $v) = each %$args) {
    push @out, (UNIVERSAL::isa($v, 'HASH')  ? map {+"--$k", "$_=$v->{$_}"} keys %$v :
                UNIVERSAL::isa($v, 'ARRAY') ? map {+"--$k", $_} @$v :
                ("--$k", $v));
  }
  return @out;
}

sub args {
    my $self = shift;
    return wantarray ? %{ $self->{args} } : $self->{args} unless @_;
    my $key = shift;
    $self->{args}{$key} = shift if @_;
    return $self->{args}{$key};
}

# allows select parameters (with underscores) to be spoken with dashes
# when used as command-line options
sub _translate_option {
  my $self = shift;
  my $opt  = shift;

  (my $tr_opt = $opt) =~ tr/-/_/;

  return $tr_opt if grep $tr_opt =~ /^(?:no_?)?$_$/, qw(
    create_license
    create_makefile_pl
    create_readme
    extra_compiler_flags
    extra_linker_flags
    install_base
    install_path
    meta_add
    meta_merge
    test_files
    use_rcfile
    use_tap_harness
    tap_harness_args
    cpan_client
  ); # normalize only selected option names

  return $opt;
}

my %singular_argument = map { ($_ => 1) } qw/install_base prefix destdir installdir verbose quiet uninst debug sign/;