view release on metacpan or  search on metacpan

local/lib/perl5/Module/Build/Base.pm  view on Meta::CPAN

             $self->install_sets($self->installdirs)->{$type} )
         ) ? 1 : 0;
}

sub _is_ActivePerl {
#  return 0;
  my $self = shift;
  unless (exists($self->{_is_ActivePerl})) {
    $self->{_is_ActivePerl} = (eval { require ActivePerl::DocTools; } || 0);
  }
  return $self->{_is_ActivePerl};
}

sub _is_ActivePPM {
#  return 0;
  my $self = shift;
  unless (exists($self->{_is_ActivePPM})) {
    $self->{_is_ActivePPM} = (eval { require ActivePerl::PPM; } || 0);
  }
  return $self->{_is_ActivePPM};
}

sub ACTION_manpages {
  my $self = shift;

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

  $self->depends_on('code');

  my %extra_manify_args = $self->{properties}{'extra_manify_args'} ? %{ $self->{properties}{'extra_manify_args'} } : ();

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

    my $sub = $self->can("manify_${type}_pods");
    $self->$sub( %extra_manify_args ) if defined( $sub );
  }
}

sub manify_bin_pods {
  my $self    = shift;
  my %podman_args = (section =>  1, @_); # binaries go in section 1

  my $files   = $self->_find_pods( $self->{properties}{bindoc_dirs},
                                   exclude => [ $self->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 (sort 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( %podman_args );
    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 %podman_args = (section => 3, @_); # libraries go in section 3

  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;
  foreach my $file (sort 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( %podman_args );
    my $manpage = $self->man3page_name( $files->{$file} ) . '.' .
                  $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;
      }
      $file = $self->localize_file_path($file);
      $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

  open(my $fh, '<', $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) ) {
    next unless ( $self->invoked_action eq 'html' || $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");

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

  my $pods = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
                                exclude => [ $self->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 $podroot = $ENV{PERL_CORE}
              ? File::Basename::dirname($ENV{PERL_CORE})
              : $self->original_prefix('core');

  my $htmlroot = $self->install_sets('core')->{libhtml};
  my $podpath;
  unless (defined $self->args('html_links') and !$self->args('html_links')) {
    my @podpath = ( (map { File::Spec->abs2rel($_ ,$podroot) } grep { -d  }
                     ( $self->install_sets('core', 'lib'), # lib
                       $self->install_sets('core', 'bin'), # bin
                       $self->install_sets('site', 'lib'), # site/lib
                     ) ), File::Spec->rel2abs($self->blib) );

    $podpath = $ENV{PERL_CORE}
      ? File::Spec->catdir($podroot, 'lib')
        : join(":", map { tr,:\\,|/,; $_ } @podpath);
  }

  my $blibdir = join('/', File::Spec->splitdir(
    (File::Spec->splitpath(File::Spec->rel2abs($htmldir),1))[1]),''
  );

  my ($with_ActiveState, $htmltool);

  if ( $with_ActiveState = $self->_is_ActivePerl
    && eval { require ActivePerl::DocTools::Pod; 1 }
  ) {
    my $tool_v = ActiveState::DocTools::Pod->VERSION;
    $htmltool = "ActiveState::DocTools::Pod";
    $htmltool .= " $tool_v" if $tool_v && length $tool_v;
  }
  else {
      require Module::Build::PodParser;
      require Pod::Html;
    $htmltool = "Pod::Html " .  Pod::Html->VERSION;
  }
  $self->log_verbose("Converting Pod to HTML with $htmltool\n");

  my $errors = 0;

  POD:
  foreach my $pod ( sort keys %$pods ) {

    my ($name, $path) = File::Basename::fileparse($pods->{$pod},
      $self->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->catdir($htmldir, @rootdirs, @dirs);
    my $tmpfile = File::Spec->catfile($fulldir, "${name}.tmp");
    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: $!";
    }

    $self->log_verbose("HTMLifying $infile -> $outfile\n");
    if ( $with_ActiveState ) {
      my $depth = @rootdirs + @dirs;
      my %opts = ( infile => $infile,
        outfile => $tmpfile,
        ( defined($podpath) ? (podpath => $podpath) : ()),
        podroot => $podroot,
        index => 1,
        depth => $depth,
      );
      eval {
        ActivePerl::DocTools::Pod::pod2html(map { ($_, $opts{$_}) } sort keys %opts);
        1;
      } or $self->log_warn("[$htmltool] pod2html (" .
        join(", ", map { "q{$_} => q{$opts{$_}}" } (sort keys %opts)) . ") failed: $@");
    } else {
      my $path2root = File::Spec->catdir((File::Spec->updir) x @dirs);
      open(my $fh, '<', $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 = (
        "--title=$title",
        ( defined($podpath) ? "--podpath=$podpath" : ()),
        "--infile=$infile",
        "--outfile=$tmpfile",
        "--podroot=$podroot",
        ($path2root ? "--htmlroot=$path2root" : ()),
      );

      unless ( eval{Pod::Html->VERSION(1.12)} ) {
        push( @opts, ('--flush') ); # caching removed in 1.12
      }

      if ( eval{Pod::Html->VERSION(1.12)} ) {
        push( @opts, ('--header', '--backlink') );
      } elsif ( eval{Pod::Html->VERSION(1.03)} ) {
        push( @opts, ('--header', '--backlink=Back to Top') );
      }

      $self->log_verbose("P::H::pod2html @opts\n");
      {
        my $orig = Cwd::getcwd();
        eval { Pod::Html::pod2html(@opts); 1 }
          or $self->log_warn("[$htmltool] pod2html( " .
          join(", ", map { "q{$_}" } @opts) . ") failed: $@");
        chdir($orig);
      }
    }
    # We now have to cleanup the resulting html file
    if ( ! -r $tmpfile ) {
      $errors++;
      next POD;
    }
    open(my $fh, '<', $tmpfile) or die "Can't read $tmpfile: $!";
    my $html = join('',<$fh>);
    close $fh;
    if (!$self->_is_ActivePerl) {
      # These fixups are already done by AP::DT:P:pod2html
      # The output from pod2html is NOT XHTML!
      # IE6+ will display content that is not valid for DOCTYPE
      $html =~ s#^<!DOCTYPE .*?>#<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">#im;
      $html =~ s#<html xmlns="http://www.w3.org/1999/xhtml">#<html>#i;

      # IE6+ will not display local HTML files with strict
      # security without this comment
      $html =~ s#<head>#<head>\n<!-- saved from url=(0017)http://localhost/ -->#i;
    }
    # Fixup links that point to our temp blib
    $html =~ s/\Q$blibdir\E//g;

    open($fh, '>', $outfile) or die "Can't write $outfile: $!";
    print $fh $html;
    close $fh;
    unlink($tmpfile);
  }

  return ! $errors;

}

# 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 = $self->file_qr('\.(pm|pod)$');

  foreach my $localdir (sort keys %$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

local/lib/perl5/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 = $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 => $self->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::Metadata->find_module_by_name('ExtUtils::xsubpp')
      or die "Can't find ExtUtils::xsubpp in INC (@INC)";

    my @typemaps;
    push @typemaps, Module::Metadata->find_module_by_name(
        'ExtUtils::typemap', \@INC
    );
    my $lib_typemap = Module::Metadata->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");
    open(my $fh, '>', $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 ref $string eq '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{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') );

  require DynaLoader;
  my $modfname = defined &DynaLoader::mod2fname ? DynaLoader::mod2fname([@d, $file_base]) : $file_base;

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

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

  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?
    open(my $fh, '>>', $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";
  }