chmod results from the CPAN

chmod

Alien-ROOT

view release on metacpan or search on metacpan

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

      return \%status;
    }

    $status{have} = eval { $pm_info->version() };
    if ($spec and !defined($status{have})) {
      @status{ qw(have message) } = (undef, "Couldn't find a \$VERSION in prerequisite $modname");
      return \%status;
    }
  }

  my @conditions = $self->_parse_conditions($spec);

  foreach (@conditions) {
    my ($op, $version) = /^\s*  (<=?|>=?|==|!=)  \s*  ([\w.]+)  \s*$/x
      or die "Invalid prerequisite condition '$_' for $modname";

    $version = $self->perl_version_to_float($version)
      if $modname eq 'perl';

    next if $op eq '>=' and !$version;  # Module doesn't have to actually define a $VERSION

    unless ($self->compare_versions( $status{have}, $op, $version )) {
      $status{message} = "$modname ($status{have}) is installed, but we need version $op $version";
      return \%status;
    }
  }

  $status{ok} = 1;
  return \%status;
}

sub compare_versions {
  my $self = shift;
  my ($v1, $op, $v2) = @_;
  $v1 = Module::Build::Version->new($v1)
    unless UNIVERSAL::isa($v1,'Module::Build::Version');

  my $eval_str = "\$v1 $op \$v2";
  my $result   = eval $eval_str;
  $self->log_warn("error comparing versions: '$eval_str' $@") if $@;

  return $result;
}

# I wish I could set $! to a string, but I can't, so I use $@
sub check_installed_version {
  my ($self, $modname, $spec) = @_;

  my $status = $self->check_installed_status($modname, $spec);

  if ($status->{ok}) {
    return $status->{have} if $status->{have} and "$status->{have}" ne '<none>';
    return '0 but true';
  }

  $@ = $status->{message};
  return 0;
}

sub make_executable {
  # Perl's chmod() is mapped to useful things on various non-Unix
  # platforms, so we use it in the base class even though it looks
  # Unixish.

  my $self = shift;
  foreach (@_) {
    my $current_mode = (stat $_)[2];
    chmod $current_mode | oct(111), $_;
  }
}

sub is_executable {
  # We assume this does the right thing on generic platforms, though
  # we do some other more specific stuff on Unixish platforms.
  my ($self, $file) = @_;
  return -x $file;
}

sub _startperl { shift()->config('startperl') }

# Return any directories in @INC which are not in the default @INC for
# this perl.  For example, stuff passed in with -I or loaded with "use lib".
sub _added_to_INC {
  my $self = shift;

  my %seen;
  $seen{$_}++ foreach $self->_default_INC;
  return grep !$seen{$_}++, @INC;
}

# Determine the default @INC for this Perl
{
  my @default_inc; # Memoize
  sub _default_INC {
    my $self = shift;
    return @default_inc if @default_inc;

    local $ENV{PERL5LIB};  # this is not considered part of the default.

    my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;

    my @inc = $self->_backticks($perl, '-le', 'print for @INC');
    chomp @inc;

    return @default_inc = @inc;
  }
}

sub print_build_script {
  my ($self, $fh) = @_;

  my $build_package = $self->build_class;

  my $closedata="";

  my $config_requires;
  if ( -f $self->metafile ) {
    my $meta = eval { $self->read_metafile( $self->metafile ) };
    $config_requires = $meta && $meta->{configure_requires}{'Module::Build'};
  }
  $config_requires ||= 0;

  my %q = map {$_, $self->$_()} qw(config_dir base_dir);

  $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish;

  $q{magic_numfile} = $self->config_file('magicnum');

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

  $self->dispatch('distdir');

  my $dist_dir = $self->dist_dir;

  $self->make_tarball($dist_dir);
  $self->delete_filetree($dist_dir);
}

sub ACTION_distcheck {
  my ($self) = @_;

  $self->_check_manifest_skip unless $self->invoked_action eq 'distclean';

  require ExtUtils::Manifest;
  local $^W; # ExtUtils::Manifest is not warnings clean.
  my ($missing, $extra) = ExtUtils::Manifest::fullcheck();

  return unless @$missing || @$extra;

  my $msg = "MANIFEST appears to be out of sync with the distribution\n";
  if ( $self->invoked_action eq 'distcheck' ) {
    die $msg;
  } else {
    warn $msg;
  }
}

sub _check_mymeta_skip {
  my $self = shift;
  my $maniskip = shift || 'MANIFEST.SKIP';

  require ExtUtils::Manifest;
  local $^W; # ExtUtils::Manifest is not warnings clean.

  # older ExtUtils::Manifest had a private _maniskip
  my $skip_factory = ExtUtils::Manifest->can('maniskip')
                  || ExtUtils::Manifest->can('_maniskip');

  my $mymetafile = $self->mymetafile;
  # we can't check it, just add it anyway to be safe
  for my $file ( $self->mymetafile, $self->mymetafile2 ) {
    unless ( $skip_factory && $skip_factory->($maniskip)->($file) ) {
      $self->log_warn("File '$maniskip' does not include '$file'. Adding it now.\n");
      my $safe = quotemeta($file);
      $self->_append_maniskip("^$safe\$", $maniskip);
    }
  }
}

sub _add_to_manifest {
  my ($self, $manifest, $lines) = @_;
  $lines = [$lines] unless ref $lines;

  my $existing_files = $self->_read_manifest($manifest);
  return unless defined( $existing_files );

  @$lines = grep {!exists $existing_files->{$_}} @$lines
    or return;

  my $mode = (stat $manifest)[2];
  chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!";

  my $fh = IO::File->new("< $manifest") or die "Can't read $manifest: $!";
  my $last_line = (<$fh>)[-1] || "\n";
  my $has_newline = $last_line =~ /\n$/;
  $fh->close;

  $fh = IO::File->new(">> $manifest") or die "Can't write to $manifest: $!";
  print $fh "\n" unless $has_newline;
  print $fh map "$_\n", @$lines;
  close $fh;
  chmod($mode, $manifest);

  $self->log_verbose(map "Added to $manifest: $_\n", @$lines);
}

sub _sign_dir {
  my ($self, $dir) = @_;

  unless (eval { require Module::Signature; 1 }) {
    $self->log_warn("Couldn't load Module::Signature for 'distsign' action:\n $@\n");
    return;
  }

  # Add SIGNATURE to the MANIFEST
  {
    my $manifest = File::Spec->catfile($dir, 'MANIFEST');
    die "Signing a distribution requires a MANIFEST file" unless -e $manifest;
    $self->_add_to_manifest($manifest, "SIGNATURE    Added here by Module::Build");
  }

  # Would be nice if Module::Signature took a directory argument.

  $self->_do_in_dir($dir, sub {local $Module::Signature::Quiet = 1; Module::Signature::sign()});
}

sub _do_in_dir {
  my ($self, $dir, $do) = @_;

  my $start_dir = File::Spec->rel2abs($self->cwd);
  chdir $dir or die "Can't chdir() to $dir: $!";
  eval {$do->()};
  my @err = $@ ? ($@) : ();
  chdir $start_dir or push @err, "Can't chdir() back to $start_dir: $!";
  die join "\n", @err if @err;
}

sub ACTION_distsign {
  my ($self) = @_;
  {
    local $self->{properties}{sign} = 0;  # We'll sign it ourselves
    $self->depends_on('distdir') unless -d $self->dist_dir;
  }
  $self->_sign_dir($self->dist_dir);
}

sub ACTION_skipcheck {
  my ($self) = @_;

  require ExtUtils::Manifest;
  local $^W; # ExtUtils::Manifest is not warnings clean.
  ExtUtils::Manifest::skipcheck();
}

sub ACTION_distclean {
  my ($self) = @_;

  $self->depends_on('realclean');
  $self->depends_on('distcheck');
}

sub do_create_makefile_pl {

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

  my( $file, $version );
  my $err = '';
    foreach my $p ( @$packages ) {
      if ( defined( $p->{version} ) ) {
        if ( defined( $version ) ) {
          if ( $self->compare_versions( $version, '!=', $p->{version} ) ) {
            $err .= "  $p->{file} ($p->{version})\n";
          } else {
            # same version declared multiple times, ignore
          }
        } else {
          $file    = $p->{file};
          $version = $p->{version};
        }
      }
      $file ||= $p->{file} if defined( $p->{file} );
    }

  if ( $err ) {
    $err = "  $file ($version)\n" . $err;
  }

  my %result = (
    file    => $file,
    version => $version,
    err     => $err
  );

  return \%result;
}

sub make_tarball {
  my ($self, $dir, $file) = @_;
  $file ||= $dir;

  $self->log_info("Creating $file.tar.gz\n");

  if ($self->{args}{tar}) {
    my $tar_flags = $self->verbose ? 'cvf' : 'cf';
    $self->do_system($self->split_like_shell($self->{args}{tar}), $tar_flags, "$file.tar", $dir);
    $self->do_system($self->split_like_shell($self->{args}{gzip}), "$file.tar") if $self->{args}{gzip};
  } else {
    eval { require Archive::Tar && Archive::Tar->VERSION(1.09); 1 }
      or die "You must install Archive::Tar 1.09+ to make a distribution tarball\n".
             "or specify a binary tar program with the '--tar' option.\n".
             "See the documentation for the 'dist' action.\n";

    my $files = $self->rscan_dir($dir);

    # Archive::Tar versions >= 1.09 use the following to enable a compatibility
    # hack so that the resulting archive is compatible with older clients.
    # If no file path is 100 chars or longer, we disable the prefix field
    # for maximum compatibility.  If there are any long file paths then we
    # need the prefix field after all.
    $Archive::Tar::DO_NOT_USE_PREFIX =
      (grep { length($_) >= 100 } @$files) ? 0 : 1;

    my $tar   = Archive::Tar->new;
    $tar->add_files(@$files);
    for my $f ($tar->get_files) {
      $f->mode($f->mode & ~022); # chmod go-w
    }
    $tar->write("$file.tar.gz", 1);
  }
}

sub install_path {
  my $self = shift;
  my( $type, $value ) = ( @_, '<empty>' );

  Carp::croak( 'Type argument missing' )
    unless defined( $type );

  my $map = $self->{properties}{install_path};
  return $map unless @_;

  # delete existing value if $value is literal undef()
  unless ( defined( $value ) ) {
    delete( $map->{$type} );
    return undef;
  }

  # return existing value if no new $value is given
  if ( $value eq '<empty>' ) {
    return undef unless exists $map->{$type};
    return $map->{$type};
  }

  # set value if $value is a valid relative path
  return $map->{$type} = $value;
}

sub install_sets {
  # Usage: install_sets('site'), install_sets('site', 'lib'),
  #   or install_sets('site', 'lib' => $value);
  my ($self, $dirs, $key, $value) = @_;
  $dirs = $self->installdirs unless defined $dirs;
  # update property before merging with defaults
  if ( @_ == 4 && defined $dirs && defined $key) {
    # $value can be undef; will mask default
    $self->{properties}{install_sets}{$dirs}{$key} = $value;
  }
  my $map = { $self->_merge_arglist(
    $self->{properties}{install_sets},
    $self->_default_install_paths->{install_sets}
  )};
  if ( defined $dirs && defined $key ) {
    return $map->{$dirs}{$key};
  }
  elsif ( defined $dirs ) {
    return $map->{$dirs};
  }
  else {
    croak "Can't determine installdirs for install_sets()";
  }
}

sub original_prefix {
  # Usage: original_prefix(), original_prefix('lib'),
  #   or original_prefix('lib' => $value);
  my ($self, $key, $value) = @_;

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

  # 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);
  }

  return 1;
}

1;
__END__


=head1 NAME

Module::Build::Base - Default methods for Module::Build

=head1 SYNOPSIS

  Please see the Module::Build documentation.

( run in 1.240 second using v1.01-cache-2.11-cpan-fa01517f264 )