view release on metacpan or  search on metacpan

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

      $type eq 'ARRAY'? sub { return [ @{ $p{default} } ]   } :
                        sub { return $p{default}            } ;

    push @{$additive_properties{$class}->{$type}}, $property
      if $type;

    unless ($class->can($property)) {
      # TODO probably should put these in a util package
      my $sub = $type eq 'HASH'
        ? _make_hash_accessor($property, \%p)
        : _make_accessor($property, \%p);
      no strict 'refs';
      *{"$class\::$property"} = $sub;
    }

    return $class;
  }

    sub property_error {
      my $self = shift;
      die 'ERROR: ', @_;
    }

  sub _set_defaults {
    my $self = shift;

    # Set the build class.
    $self->{properties}{build_class} ||= ref $self;

    # If there was no orig_dir, set to the same as base_dir
    $self->{properties}{orig_dir} ||= $self->{properties}{base_dir};

    my $defaults = $self->valid_properties_defaults;

    foreach my $prop (keys %$defaults) {
      $self->{properties}{$prop} = $defaults->{$prop}
        unless exists $self->{properties}{$prop};
    }

    # Copy defaults for arrays any arrays.
    for my $prop ($self->array_properties) {
      $self->{properties}{$prop} = [@{$defaults->{$prop}}]
        unless exists $self->{properties}{$prop};
    }
    # Copy defaults for arrays any hashes.
    for my $prop ($self->hash_properties) {
      $self->{properties}{$prop} = {%{$defaults->{$prop}}}
        unless exists $self->{properties}{$prop};
    }
  }

} # end closure
########################################################################
sub _make_hash_accessor {
  my ($property, $p) = @_;
  my $check = $p->{check} || sub { 1 };

  return sub {
    my $self = shift;

    # This is only here to deprecate the historic accident of calling
    # properties as class methods - I suspect it only happens in our
    # test suite.
    unless(ref($self)) {
      carp("\n$property not a class method (@_)");
      return;
    }

    my $x = $self->{properties};
    return $x->{$property} unless @_;

    my $prop = $x->{$property};
    if ( defined $_[0] && !ref $_[0] ) {
      if ( @_ == 1 ) {
        return exists $prop->{$_[0]} ? $prop->{$_[0]} : undef;
      } elsif ( @_ % 2 == 0 ) {
        my %new = (%{ $prop }, @_);
        local $_ = \%new;
        $x->{$property} = \%new if $check->($self);
        return $x->{$property};
      } else {
        die "Unexpected arguments for property '$property'\n";
      }
    } else {
      die "Unexpected arguments for property '$property'\n"
          if defined $_[0] && ref $_[0] ne 'HASH';
      local $_ = $_[0];
      $x->{$property} = shift if $check->($self);
    }
  };
}
########################################################################
sub _make_accessor {
  my ($property, $p) = @_;
  my $check = $p->{check} || sub { 1 };

  return sub {
    my $self = shift;

    # This is only here to deprecate the historic accident of calling
    # properties as class methods - I suspect it only happens in our
    # test suite.
    unless(ref($self)) {
      carp("\n$property not a class method (@_)");
      return;
    }

    my $x = $self->{properties};
    return $x->{$property} unless @_;
    local $_ = $_[0];
    $x->{$property} = shift if $check->($self);
    return $x->{$property};
  };
}
########################################################################

# Add the default properties.
__PACKAGE__->add_property(auto_configure_requires => 1);
__PACKAGE__->add_property(blib => 'blib');
__PACKAGE__->add_property(build_class => 'Module::Build');
__PACKAGE__->add_property(build_elements => [qw(PL support pm xs share_dir pod script)]);
__PACKAGE__->add_property(build_script => 'Build');
__PACKAGE__->add_property(build_bat => 0);
__PACKAGE__->add_property(bundle_inc => []);
__PACKAGE__->add_property(bundle_inc_preload => []);
__PACKAGE__->add_property(config_dir => '_build');
__PACKAGE__->add_property(dynamic_config => 1);
__PACKAGE__->add_property(include_dirs => []);
__PACKAGE__->add_property(license => 'unknown');
__PACKAGE__->add_property(metafile => 'META.yml');
__PACKAGE__->add_property(mymetafile => 'MYMETA.yml');
__PACKAGE__->add_property(metafile2 => 'META.json');
__PACKAGE__->add_property(mymetafile2 => 'MYMETA.json');
__PACKAGE__->add_property(recurse_into => []);
__PACKAGE__->add_property(use_rcfile => 1);
__PACKAGE__->add_property(create_packlist => 1);
__PACKAGE__->add_property(allow_mb_mismatch => 0);
__PACKAGE__->add_property(config => undef);
__PACKAGE__->add_property(test_file_exts => ['.t']);
__PACKAGE__->add_property(use_tap_harness => 0);
__PACKAGE__->add_property(cpan_client => 'cpan');
__PACKAGE__->add_property(tap_harness_args => {});
__PACKAGE__->add_property(
  'installdirs',
  default => 'site',
  check   => sub {
    return 1 if /^(core|site|vendor)$/;
    return shift->property_error(
      $_ eq 'perl'
      ? 'Perhaps you meant installdirs to be "core" rather than "perl"?'
      : 'installdirs must be one of "core", "site", or "vendor"'
    );
    return shift->property_error("Perhaps you meant 'core'?") if $_ eq 'perl';
    return 0;
  },
);

{
  __PACKAGE__->add_property(html_css => '');
}

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

  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/;

sub _read_arg {
  my ($self, $args, $key, $val) = @_;

  $key = $self->_translate_option($key);

  if ( exists $args->{$key} and not $singular_argument{$key} ) {
    $args->{$key} = [ $args->{$key} ] unless ref $args->{$key};
    push @{$args->{$key}}, $val;
  } else {
    $args->{$key} = $val;
  }
}

# decide whether or not an option requires/has an operand
sub _optional_arg {
  my $self = shift;
  my $opt  = shift;
  my $argv = shift;

  $opt = $self->_translate_option($opt);

  my @bool_opts = qw(
    build_bat
    create_license
    create_readme
    pollute
    quiet
    uninst
    use_rcfile
    verbose
    debug
    sign
    use_tap_harness
  );

  # inverted boolean options; eg --noverbose or --no-verbose
  # converted to proper name & returned with false value (verbose, 0)
  if ( grep $opt =~ /^no[-_]?$_$/, @bool_opts ) {
    $opt =~ s/^no-?//;
    return ($opt, 0);
  }

  # non-boolean option; return option unchanged along with its argument
  return ($opt, shift(@$argv)) unless grep $_ eq $opt, @bool_opts;

  # we're punting a bit here, if an option appears followed by a digit
  # we take the digit as the argument for the option. If there is
  # nothing that looks like a digit, we pretend the option is a flag
  # that is being set and has no argument.
  my $arg = 1;
  $arg = shift(@$argv) if @$argv && $argv->[0] =~ /^\d+$/;

  return ($opt, $arg);
}

sub read_args {
  my $self = shift;

  (my $args, @_) = $self->cull_options(@_);
  my %args = %$args;

  my $opt_re = qr/[\w\-]+/;

  my ($action, @argv);
  while (@_) {
    local $_ = shift;
    if ( /^(?:--)?($opt_re)=(.*)$/ ) {
      $self->_read_arg(\%args, $1, $2);
    } elsif ( /^--($opt_re)$/ ) {
      my($opt, $arg) = $self->_optional_arg($1, \@_);
      $self->_read_arg(\%args, $opt, $arg);
    } elsif ( /^($opt_re)$/ and !defined($action)) {
      $action = $1;
    } else {