Alien-ROOT

 view release on metacpan or  search on metacpan

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

    # We're building Module::Build itself, so ...::ConfigData isn't
    # valid, but $self->features() should be.
    return $self->feature(@_);
  } else {
    require Module::Build::ConfigData;
    return Module::Build::ConfigData->feature(@_);
  }
}

sub _warn_mb_feature_deps {
  my $self = shift;
  my $name = shift;
  $self->log_warn(
    "The '$name' feature is not available.  Please install missing\n" .
    "feature dependencies and try again.\n".
    $self->_feature_deps_msg($name) . "\n"
  );
}

sub add_build_element {
    my ($self, $elem) = @_;
    my $elems = $self->build_elements;
    push @$elems, $elem unless grep { $_ eq $elem } @$elems;
}

sub ACTION_config_data {
  my $self = shift;
  return unless $self->has_config_data;

  my $module_name = $self->module_name
    or die "The config_data feature requires that 'module_name' be set";
  my $notes_name = $module_name . '::ConfigData'; # TODO: Customize name ???
  my $notes_pm = File::Spec->catfile($self->blib, 'lib', split /::/, "$notes_name.pm");

  return if $self->up_to_date(['Build.PL',
                               $self->config_file('config_data'),
                               $self->config_file('features')
                              ], $notes_pm);

  $self->log_verbose("Writing config notes to $notes_pm\n");
  File::Path::mkpath(File::Basename::dirname($notes_pm));

  Module::Build::Notes->write_config_data
    (
     file => $notes_pm,
     module => $module_name,
     config_module => $notes_name,
     config_data => scalar $self->config_data,
     feature => scalar $self->{phash}{features}->access(),
     auto_features => scalar $self->auto_features,
    );
}

########################################################################
{ # enclosing these lexicals -- TODO
  my %valid_properties = ( __PACKAGE__,  {} );
  my %additive_properties;

  sub _mb_classes {
    my $class = ref($_[0]) || $_[0];
    return ($class, $class->mb_parents);
  }

  sub valid_property {
    my ($class, $prop) = @_;
    return grep exists( $valid_properties{$_}{$prop} ), $class->_mb_classes;
  }

  sub valid_properties {
    return keys %{ shift->valid_properties_defaults() };
  }

  sub valid_properties_defaults {
    my %out;
    for my $class (reverse shift->_mb_classes) {
      @out{ keys %{ $valid_properties{$class} } } = map {
        $_->()
      } values %{ $valid_properties{$class} };
    }
    return \%out;
  }

  sub array_properties {
    for (shift->_mb_classes) {
      return @{$additive_properties{$_}->{ARRAY}}
        if exists $additive_properties{$_}->{ARRAY};
    }
  }

  sub hash_properties {
    for (shift->_mb_classes) {
      return @{$additive_properties{$_}->{'HASH'}}
        if exists $additive_properties{$_}->{'HASH'};
    }
  }

  sub add_property {
    my ($class, $property) = (shift, shift);
    die "Property '$property' already exists"
      if $class->valid_property($property);
    my %p = @_ == 1 ? ( default => shift ) : @_;

    my $type = ref $p{default};
    $valid_properties{$class}{$property} =
      $type eq 'CODE' ? $p{default}                           :
      $type eq 'HASH' ? sub { return { %{ $p{default} } }   } :
      $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;
    }

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

);

__PACKAGE__->add_property($_) for qw(
  PL_files
  autosplit
  base_dir
  bindoc_dirs
  c_source
  create_license
  create_makefile_pl
  create_readme
  debugger
  destdir
  dist_abstract
  dist_author
  dist_name
  dist_suffix
  dist_version
  dist_version_from
  extra_compiler_flags
  extra_linker_flags
  has_config_data
  install_base
  libdoc_dirs
  magic_number
  mb_version
  module_name
  needs_compiler
  orig_dir
  perl
  pm_files
  pod_files
  pollute
  prefix
  program_name
  quiet
  recursive_test_files
  release_status
  script_files
  scripts
  share_dir
  sign
  test_files
  verbose
  debug
  xs_files
);

sub config {
  my $self = shift;
  my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
  return $c->all_config unless @_;

  my $key = shift;
  return $c->get($key) unless @_;

  my $val = shift;
  return $c->set($key => $val);
}

sub mb_parents {
    # Code borrowed from Class::ISA.
    my @in_stack = (shift);
    my %seen = ($in_stack[0] => 1);

    my ($current, @out);
    while (@in_stack) {
        next unless defined($current = shift @in_stack)
          && $current->isa('Module::Build::Base');
        push @out, $current;
        next if $current eq 'Module::Build::Base';
        no strict 'refs';
        unshift @in_stack,
          map {
              my $c = $_; # copy, to avoid being destructive
              substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
              # Canonize the :: -> main::, ::foo -> main::foo thing.
              # Should I ever canonize the Foo'Bar = Foo::Bar thing?
              $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;

  my $fh = IO::File->new("> $filename") or die "Can't create $filename: $!";
  print $fh <<EOF;
package $opts{class};
use $pack;
\@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};

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

}

sub do_system {
  my ($self, @cmd) = @_;
  $self->log_verbose("@cmd\n");

  # Some systems proliferate huge PERL5LIBs, try to ameliorate:
  my %seen;
  my $sep = $self->config('path_sep');
  local $ENV{PERL5LIB} =
    ( !exists($ENV{PERL5LIB}) ? '' :
      length($ENV{PERL5LIB}) < 500
      ? $ENV{PERL5LIB}
      : join $sep, grep { ! $seen{$_}++ and -d $_ } split($sep, $ENV{PERL5LIB})
    );

  my $status = system(@cmd);
  if ($status and $! =~ /Argument list too long/i) {
    my $env_entries = '';
    foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
    warn "'Argument list' was 'too long', env lengths are $env_entries";
  }
  return !$status;
}

sub copy_if_modified {
  my $self = shift;
  my %args = (@_ > 3
              ? ( @_ )
              : ( from => shift, to_dir => shift, flatten => shift )
             );
  $args{verbose} = !$self->quiet
    unless exists $args{verbose};

  my $file = $args{from};
  unless (defined $file and length $file) {
    die "No 'from' parameter given to copy_if_modified";
  }

  # makes no sense to replicate an absolute path, so assume flatten
  $args{flatten} = 1 if File::Spec->file_name_is_absolute( $file );

  my $to_path;
  if (defined $args{to} and length $args{to}) {
    $to_path = $args{to};
  } elsif (defined $args{to_dir} and length $args{to_dir}) {
    $to_path = File::Spec->catfile( $args{to_dir}, $args{flatten}
                                    ? File::Basename::basename($file)
                                    : $file );
  } else {
    die "No 'to' or 'to_dir' parameter given to copy_if_modified";
  }

  return if $self->up_to_date($file, $to_path); # Already fresh

  {
    local $self->{properties}{quiet} = 1;
    $self->delete_filetree($to_path); # delete destination if exists
  }

  # Create parent directories
  File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777));

  $self->log_verbose("Copying $file -> $to_path\n");

  if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite
    chmod 0666, $to_path;
    File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!";
  } else {
    File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
  }

  # mode is read-only + (executable if source is executable)
  my $mode = oct(444) | ( $self->is_executable($file) ? oct(111) : 0 );
  chmod( $mode, $to_path );

  return $to_path;
}

sub up_to_date {
  my ($self, $source, $derived) = @_;
  $source  = [$source]  unless ref $source;
  $derived = [$derived] unless ref $derived;

  # empty $derived means $source should always run
  return 0 if @$source && !@$derived || grep {not -e} @$derived;

  my $most_recent_source = time / (24*60*60);
  foreach my $file (@$source) {
    unless (-e $file) {
      $self->log_warn("Can't find source file $file for up-to-date check");
      next;
    }
    $most_recent_source = -M _ if -M _ < $most_recent_source;
  }

  foreach my $derived (@$derived) {
    return 0 if -M $derived > $most_recent_source;
  }
  return 1;
}

sub dir_contains {
  my ($self, $first, $second) = @_;
  # File::Spec doesn't have an easy way to check whether one directory
  # is inside another, unfortunately.

  ($first, $second) = map File::Spec->canonpath($_), ($first, $second);
  my @first_dirs = File::Spec->splitdir($first);
  my @second_dirs = File::Spec->splitdir($second);

  return 0 if @second_dirs < @first_dirs;

  my $is_same = ( $self->_case_tolerant
                  ? sub {lc(shift()) eq lc(shift())}
                  : sub {shift() eq shift()} );

  while (@first_dirs) {
    return 0 unless $is_same->(shift @first_dirs, shift @second_dirs);
  }