view release on metacpan or  search on metacpan

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

  my $self = shift;

  $self->depends_on('code');
  $self->depends_on('manpages', 'html');
}

# Given a file type, will return true if the file type would normally
# be installed when neither install-base nor prefix has been set.
# I.e. it will be true only if the path is set from Config.pm or
# set explicitly by the user via install-path.
sub _is_default_installable {
  my $self = shift;
  my $type = shift;
  return ( $self->install_destination($type) &&
           ( $self->install_path($type) ||
	     $self->install_sets($self->installdirs)->{$type} )
	 ) ? 1 : 0;
}

sub ACTION_manpages {
  my $self = shift;

  return unless $self->_mb_feature('manpage_support');

  $self->depends_on('code');

  foreach my $type ( qw(bin lib) ) {
    my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
                                   exclude => [ file_qr('\.bat$') ] );
    next unless %$files;

    my $sub = $self->can("manify_${type}_pods");
    next unless defined( $sub );

    if ( $self->invoked_action eq 'manpages' ) {
      $self->$sub();
    } elsif ( $self->_is_default_installable("${type}doc") ) {
      $self->$sub();
    }
  }

}

sub manify_bin_pods {
  my $self    = shift;

  my $files   = $self->_find_pods( $self->{properties}{bindoc_dirs},
                                   exclude => [ file_qr('\.bat$') ] );
  return unless keys %$files;

  my $mandir = File::Spec->catdir( $self->blib, 'bindoc' );
  File::Path::mkpath( $mandir, 0, oct(777) );

  require Pod::Man;
  foreach my $file (keys %$files) {
    # Pod::Simple based parsers only support one document per instance.
    # This is expected to change in a future version (Pod::Simple > 3.03).
    my $parser  = Pod::Man->new( section => 1 ); # binaries go in section 1
    my $manpage = $self->man1page_name( $file ) . '.' .
	          $self->config( 'man1ext' );
    my $outfile = File::Spec->catfile($mandir, $manpage);
    next if $self->up_to_date( $file, $outfile );
    $self->log_verbose("Manifying $file -> $outfile\n");
    eval { $parser->parse_from_file( $file, $outfile ); 1 }
      or $self->log_warn("Error creating '$outfile': $@\n");
    $files->{$file} = $outfile;
  }
}

sub manify_lib_pods {
  my $self    = shift;

  my $files   = $self->_find_pods($self->{properties}{libdoc_dirs});
  return unless keys %$files;

  my $mandir = File::Spec->catdir( $self->blib, 'libdoc' );
  File::Path::mkpath( $mandir, 0, oct(777) );

  require Pod::Man;
  while (my ($file, $relfile) = each %$files) {
    # Pod::Simple based parsers only support one document per instance.
    # This is expected to change in a future version (Pod::Simple > 3.03).
    my $parser  = Pod::Man->new( section => 3 ); # libraries go in section 3
    my $manpage = $self->man3page_name( $relfile ) . '.' .
	          $self->config( 'man3ext' );
    my $outfile = File::Spec->catfile( $mandir, $manpage);
    next if $self->up_to_date( $file, $outfile );
    $self->log_verbose("Manifying $file -> $outfile\n");
    eval { $parser->parse_from_file( $file, $outfile ); 1 }
      or $self->log_warn("Error creating '$outfile': $@\n");
    $files->{$file} = $outfile;
  }
}

sub _find_pods {
  my ($self, $dirs, %args) = @_;
  my %files;
  foreach my $spec (@$dirs) {
    my $dir = $self->localize_dir_path($spec);
    next unless -e $dir;

    FILE: foreach my $file ( @{ $self->rscan_dir( $dir ) } ) {
      foreach my $regexp ( @{ $args{exclude} } ) {
	next FILE if $file =~ $regexp;
      }
      $files{$file} = File::Spec->abs2rel($file, $dir) if $self->contains_pod( $file )
    }
  }
  return \%files;
}

sub contains_pod {
  my ($self, $file) = @_;
  return '' unless -T $file;  # Only look at text files

  my $fh = IO::File->new( $file ) or die "Can't open $file: $!";
  while (my $line = <$fh>) {
    return 1 if $line =~ /^\=(?:head|pod|item)/;
  }

  return '';
}

sub ACTION_html {
  my $self = shift;

  return unless $self->_mb_feature('HTML_support');

  $self->depends_on('code');

  foreach my $type ( qw(bin lib) ) {
    my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
				   exclude =>
                                        [ file_qr('\.(?:bat|com|html)$') ] );
    next unless %$files;

    if ( $self->invoked_action eq 'html' ) {
      $self->htmlify_pods( $type );
    } elsif ( $self->_is_default_installable("${type}html") ) {
      $self->htmlify_pods( $type );
    }
  }

}


# 1) If it's an ActiveState perl install, we need to run
#    ActivePerl::DocTools->UpdateTOC;
# 2) Links to other modules are not being generated
sub htmlify_pods {
  my $self = shift;
  my $type = shift;
  my $htmldir = shift || File::Spec->catdir($self->blib, "${type}html");

  require Module::Build::PodParser;
  require Pod::Html;

  $self->add_to_cleanup('pod2htm*');

  my $pods = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
                                exclude => [ file_qr('\.(?:bat|com|html)$') ] );
  return unless %$pods;  # nothing to do

  unless ( -d $htmldir ) {
    File::Path::mkpath($htmldir, 0, oct(755))
      or die "Couldn't mkdir $htmldir: $!";
  }

  my @rootdirs = ($type eq 'bin') ? qw(bin) :
      $self->installdirs eq 'core' ? qw(lib) : qw(site lib);

  my $podpath = join ':',
                map  $_->[1],
                grep -e $_->[0],
                map  [File::Spec->catdir($self->blib, $_), $_],
                qw( script lib );

  foreach my $pod ( keys %$pods ) {

    my ($name, $path) = File::Basename::fileparse($pods->{$pod},
                                                 file_qr('\.(?:pm|plx?|pod)$'));
    my @dirs = File::Spec->splitdir( File::Spec->canonpath( $path ) );
    pop( @dirs ) if scalar(@dirs) && $dirs[-1] eq File::Spec->curdir;

    my $fulldir = File::Spec->catfile($htmldir, @rootdirs, @dirs);
    my $outfile = File::Spec->catfile($fulldir, "${name}.html");
    my $infile  = File::Spec->abs2rel($pod);

    next if $self->up_to_date($infile, $outfile);

    unless ( -d $fulldir ){
      File::Path::mkpath($fulldir, 0, oct(755))
        or die "Couldn't mkdir $fulldir: $!";
    }

    my $path2root = join( '/', ('..') x (@rootdirs+@dirs) );
    my $htmlroot = join( '/',
			 ($path2root,
			  $self->installdirs eq 'core' ? () : qw(site) ) );

    my $fh = IO::File->new($infile) or die "Can't read $infile: $!";
    my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract();

    my $title = join( '::', (@dirs, $name) );
    $title .= " - $abstract" if $abstract;

    my @opts = (
                '--flush',
                "--title=$title",
                "--podpath=$podpath",
                "--infile=$infile",
                "--outfile=$outfile",
                '--podroot=' . $self->blib,
                "--htmlroot=$htmlroot",
               );

    if ( eval{Pod::Html->VERSION(1.03)} ) {
      push( @opts, ('--header', '--backlink=Back to Top') );
      push( @opts, "--css=$path2root/" . $self->html_css) if $self->html_css;
    }

    $self->log_verbose("HTMLifying $infile -> $outfile\n");
    $self->log_verbose("pod2html @opts\n");
    eval { Pod::Html::pod2html(@opts); 1 }
      or $self->log_warn("pod2html @opts failed: $@");
  }

}

# Adapted from ExtUtils::MM_Unix
sub man1page_name {
  my $self = shift;
  return File::Basename::basename( shift );
}

# Adapted from ExtUtils::MM_Unix and Pod::Man
# Depending on M::B's dependency policy, it might make more sense to refactor
# Pod::Man::begin_pod() to extract a name() methods, and use them...
#    -spurkis
sub man3page_name {
  my $self = shift;
  my ($vol, $dirs, $file) = File::Spec->splitpath( shift );
  my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );

  # Remove known exts from the base name
  $file =~ s/\.p(?:od|m|l)\z//i;

  return join( $self->manpage_separator, @dirs, $file );
}

sub manpage_separator {
  return '::';
}

# For systems that don't have 'diff' executable, should use Algorithm::Diff
sub ACTION_diff {
  my $self = shift;
  $self->depends_on('build');
  my $local_lib = File::Spec->rel2abs('lib');
  my @myINC = grep {$_ ne $local_lib} @INC;

  # The actual install destination might not be in @INC, so check there too.
  push @myINC, map $self->install_destination($_), qw(lib arch);

  my @flags = @{$self->{args}{ARGV}};
  @flags = $self->split_like_shell($self->{args}{flags} || '') unless @flags;

  my $installmap = $self->install_map;
  delete $installmap->{read};
  delete $installmap->{write};

  my $text_suffix = file_qr('\.(pm|pod)$');

  while (my $localdir = each %$installmap) {
    my @localparts = File::Spec->splitdir($localdir);
    my $files = $self->rscan_dir($localdir, sub {-f});

    foreach my $file (@$files) {
      my @parts = File::Spec->splitdir($file);
      @parts = @parts[@localparts .. $#parts]; # Get rid of blib/lib or similar

      my $installed = Module::Build::ModuleInfo->find_module_by_name(

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

  my ($self) = @_;

  my $p = $self->{properties};
  return $p->{_have_c_compiler} if defined $p->{_have_c_compiler};

  $self->log_verbose("Checking if compiler tools configured... ");
  my $b = eval { $self->cbuilder };
  my $have = $b && eval { $b->have_compiler };
  $self->log_verbose($have ? "ok.\n" : "failed.\n");
  return $p->{_have_c_compiler} = $have;
}

sub compile_c {
  my ($self, $file, %args) = @_;

  if ( ! $self->have_c_compiler ) {
    die "Error: no compiler detected to compile '$file'.  Aborting\n";
  }

  my $b = $self->cbuilder;
  my $obj_file = $b->object_file($file);
  $self->add_to_cleanup($obj_file);
  return $obj_file if $self->up_to_date($file, $obj_file);

  $b->compile(source => $file,
	      defines => $args{defines},
	      object_file => $obj_file,
	      include_dirs => $self->include_dirs,
	      extra_compiler_flags => $self->extra_compiler_flags,
	     );

  return $obj_file;
}

sub link_c {
  my ($self, $spec) = @_;
  my $p = $self->{properties}; # For convenience

  $self->add_to_cleanup($spec->{lib_file});

  my $objects = $p->{objects} || [];

  return $spec->{lib_file}
    if $self->up_to_date([$spec->{obj_file}, @$objects],
			 $spec->{lib_file});

  my $module_name = $spec->{module_name} || $self->module_name;

  $self->cbuilder->link(
    module_name => $module_name,
    objects     => [$spec->{obj_file}, @$objects],
    lib_file    => $spec->{lib_file},
    extra_linker_flags => $p->{extra_linker_flags} );

  return $spec->{lib_file};
}

sub compile_xs {
  my ($self, $file, %args) = @_;

  $self->log_verbose("$file -> $args{outfile}\n");

  if (eval {require ExtUtils::ParseXS; 1}) {

    ExtUtils::ParseXS::process_file(
				    filename => $file,
				    prototypes => 0,
				    output => $args{outfile},
				   );
  } else {
    # Ok, I give up.  Just use backticks.

    my $xsubpp = Module::Build::ModuleInfo->find_module_by_name('ExtUtils::xsubpp')
      or die "Can't find ExtUtils::xsubpp in INC (@INC)";

    my @typemaps;
    push @typemaps, Module::Build::ModuleInfo->find_module_by_name(
        'ExtUtils::typemap', \@INC
    );
    my $lib_typemap = Module::Build::ModuleInfo->find_module_by_name(
        'typemap', [File::Basename::dirname($file), File::Spec->rel2abs('.')]
    );
    push @typemaps, $lib_typemap if $lib_typemap;
    @typemaps = map {+'-typemap', $_} @typemaps;

    my $cf = $self->{config};
    my $perl = $self->{properties}{perl};

    my @command = ($perl, "-I".$cf->get('installarchlib'), "-I".$cf->get('installprivlib'), $xsubpp, '-noprototypes',
		   @typemaps, $file);

    $self->log_info("@command\n");
    my $fh = IO::File->new("> $args{outfile}") or die "Couldn't write $args{outfile}: $!";
    print {$fh} $self->_backticks(@command);
    close $fh;
  }
}

sub split_like_shell {
  my ($self, $string) = @_;

  return () unless defined($string);
  return @$string if UNIVERSAL::isa($string, 'ARRAY');
  $string =~ s/^\s+|\s+$//g;
  return () unless length($string);

  return Text::ParseWords::shellwords($string);
}

sub oneliner {
  # Returns a string that the shell can evaluate as a perl command.
  # This should be avoided whenever possible, since "the shell" really
  # means zillions of shells on zillions of platforms and it's really
  # hard to get it right all the time.

  # Some of this code is stolen with permission from ExtUtils::MakeMaker.

  my($self, $cmd, $switches, $args) = @_;
  $switches = [] unless defined $switches;
  $args = [] unless defined $args;

  # Strip leading and trailing newlines
  $cmd =~ s{^\n+}{};
  $cmd =~ s{\n+$}{};

  my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
  return $self->_quote_args($perl, @$switches, '-e', $cmd, @$args);
}

sub run_perl_script {
  my ($self, $script, $preargs, $postargs) = @_;
  foreach ($preargs, $postargs) {
    $_ = [ $self->split_like_shell($_) ] unless ref();
  }
  return $self->run_perl_command([@$preargs, $script, @$postargs]);
}

sub run_perl_command {
  # XXX Maybe we should accept @args instead of $args?  Must resolve
  # this before documenting.
  my ($self, $args) = @_;
  $args = [ $self->split_like_shell($args) ] unless ref($args);
  my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;

  # Make sure our local additions to @INC are propagated to the subprocess
  local $ENV{PERL5LIB} = join $self->config('path_sep'), $self->_added_to_INC;

  return $self->do_system($perl, @$args);
}

# Infer various data from the path of the input filename
# that is needed to create output files.
# The input filename is expected to be of the form:
#   lib/Module/Name.ext or Module/Name.ext
sub _infer_xs_spec {
  my $self = shift;
  my $file = shift;

  my $cf = $self->{config};

  my %spec;

  my( $v, $d, $f ) = File::Spec->splitpath( $file );
  my @d = File::Spec->splitdir( $d );
  (my $file_base = $f) =~ s/\.[^.]+$//i;

  $spec{base_name} = $file_base;

  $spec{src_dir} = File::Spec->catpath( $v, $d, '' );

  # the module name
  shift( @d ) while @d && ($d[0] eq 'lib' || $d[0] eq '');
  pop( @d ) while @d && $d[-1] eq '';
  $spec{module_name} = join( '::', (@d, $file_base) );

  $spec{archdir} = File::Spec->catdir($self->blib, 'arch', 'auto',
				      @d, $file_base);

  $spec{bs_file} = File::Spec->catfile($spec{archdir}, "${file_base}.bs");

  $spec{lib_file} = File::Spec->catfile($spec{archdir},
					"${file_base}.".$cf->get('dlext'));

  $spec{c_file} = File::Spec->catfile( $spec{src_dir},
				       "${file_base}.c" );

  $spec{obj_file} = File::Spec->catfile( $spec{src_dir},
					 "${file_base}".$cf->get('obj_ext') );

  return \%spec;
}

sub process_xs {
  my ($self, $file) = @_;

  my $spec = $self->_infer_xs_spec($file);

  # File name, minus the suffix
  (my $file_base = $file) =~ s/\.[^.]+$//;

  # .xs -> .c
  $self->add_to_cleanup($spec->{c_file});

  unless ($self->up_to_date($file, $spec->{c_file})) {
    $self->compile_xs($file, outfile => $spec->{c_file});
  }

  # .c -> .o
  my $v = $self->dist_version;
  $self->compile_c($spec->{c_file},
		   defines => {VERSION => qq{"$v"}, XS_VERSION => qq{"$v"}});

  # archdir
  File::Path::mkpath($spec->{archdir}, 0, oct(777)) unless -d $spec->{archdir};

  # .xs -> .bs
  $self->add_to_cleanup($spec->{bs_file});
  unless ($self->up_to_date($file, $spec->{bs_file})) {
    require ExtUtils::Mkbootstrap;
    $self->log_info("ExtUtils::Mkbootstrap::Mkbootstrap('$spec->{bs_file}')\n");
    ExtUtils::Mkbootstrap::Mkbootstrap($spec->{bs_file});  # Original had $BSLOADLIBS - what's that?
    {my $fh = IO::File->new(">> $spec->{bs_file}")}  # create
    utime((time)x2, $spec->{bs_file});  # touch
  }

  # .o -> .(a|bundle)
  $self->link_c($spec);
}

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";
  }