base.pm

source of perl for linux application,

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

  my %actions;
  no strict 'refs';
  
  foreach my $class ($self->super_classes) {
    foreach ( keys %{ $class . '::' } ) {
      $actions{$1}++ if /^ACTION_(\w+)/;
    }
  }

  return wantarray ? sort keys %actions : \%actions;
}

sub get_action_docs {
  my ($self, $action) = @_;
  my $actions = $self->known_actions;
  die "No known action '$action'" unless $actions->{$action};

  my ($files_found, @docs) = (0);
  foreach my $class ($self->super_classes) {
    (my $file = $class) =~ s{::}{/}g;
    # NOTE: silently skipping relative paths if any chdir() happened
    $file = $INC{$file . '.pm'} or next;
    my $fh = IO::File->new("< $file") or next;
    $files_found++;

    # Code below modified from /usr/bin/perldoc

    # Skip to ACTIONS section
    local $_;
    while (<$fh>) {
      last if /^=head1 ACTIONS\s/;
    }

    # Look for our action and determine the style
    my $style;
    while (<$fh>) {
      last if /^=head1 /;

      # only item and head2 are allowed (3&4 are not in 5.005)
      if(/^=(item|head2)\s+\Q$action\E\b/) {
        $style = $1;
        push @docs, $_;
        last;
      }
    }
    $style or next; # not here

    # and the content
    if($style eq 'item') {
      my ($found, $inlist) = (0, 0);
      while (<$fh>) {
        if (/^=(item|back)/) {
          last unless $inlist;
        }
        push @docs, $_;
        ++$inlist if /^=over/;
        --$inlist if /^=back/;
      }
    }
    else { # head2 style
      # stop at anything equal or greater than the found level
      while (<$fh>) {
        last if(/^=(?:head[12]|cut)/);
        push @docs, $_;
      }
    }
    # TODO maybe disallow overriding just pod for an action
    # TODO and possibly: @docs and last;
  }

  unless ($files_found) {
    $@ = "Couldn't find any documentation to search";
    return;
  }
  unless (@docs) {
    $@ = "Couldn't find any docs for action '$action'";
    return;
  }
  
  return join '', @docs;
}

sub ACTION_prereq_report {
  my $self = shift;
  $self->log_info( $self->prereq_report );
}

sub prereq_report {
  my $self = shift;
  my @types = @{ $self->prereq_action_types };
  my $info = { map { $_ => $self->$_() } @types };

  my $output = '';
  foreach my $type (@types) {
    my $prereqs = $info->{$type};
    next unless %$prereqs;
    $output .= "\n$type:\n";
    my $mod_len = 2;
    my $ver_len = 4;
    my %mods;
    while ( my ($modname, $spec) = each %$prereqs ) {
      my $len  = length $modname;
      $mod_len = $len if $len > $mod_len;
      $spec    ||= '0';
      $len     = length $spec;
      $ver_len = $len if $len > $ver_len;

      my $mod = $self->check_installed_status($modname, $spec);
      $mod->{name} = $modname;
      $mod->{ok} ||= 0;
      $mod->{ok} = ! $mod->{ok} if $type =~ /^(\w+_)?conflicts$/;

      $mods{lc $modname} = $mod;
    }

    my $space  = q{ } x ($mod_len - 3);
    my $vspace = q{ } x ($ver_len - 3);
    my $sline  = q{-} x ($mod_len - 3);
    my $vline  = q{-} x ($ver_len - 3);
    my $disposition = ($type =~ /^(\w+_)?conflicts$/) ?
                        'Clash' : 'Need';
    $output .=
      "    Module $space  $disposition $vspace  Have\n".
      "    ------$sline+------$vline-+----------\n";


    for my $k (sort keys %mods) {
      my $mod = $mods{$k};
      my $space  = q{ } x ($mod_len - length $k);
      my $vspace = q{ } x ($ver_len - length $mod->{need});
      my $f = $mod->{ok} ? ' ' : '!';
      $output .=
        "  $f $mod->{name} $space     $mod->{need}  $vspace   ".
        (defined($mod->{have}) ? $mod->{have} : "")."\n";
    }
  }
  return $output;
}

sub ACTION_help {
  my ($self) = @_;
  my $actions = $self->known_actions;
  
  if (@{$self->{args}{ARGV}}) {
    my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)};
    print $@ ? "$@\n" : $msg;
    return;
  }

  print <<EOF;

 Usage: $0 <action> arg1=value arg2=value ...
 Example: $0 test verbose=1
 
 Actions defined:
EOF
  
  print $self->_action_listing($actions);

  print "\nRun `Build help <action>` for details on an individual action.\n";
  print "See `perldoc Module::Build` for complete documentation.\n";
}

sub _action_listing {
  my ($self, $actions) = @_;

  # Flow down columns, not across rows
  my @actions = sort keys %$actions;
  @actions = map $actions[($_ + ($_ % 2) * @actions) / 2],  0..$#actions;
  
  my $out = '';
  while (my ($one, $two) = splice @actions, 0, 2) {
    $out .= sprintf("  %-12s                   %-12s\n", $one, $two||'');
  }
  return $out;
}

sub ACTION_retest {
  my ($self) = @_;
  
  # Protect others against our @INC changes
  local @INC = @INC;

  # Filter out nonsensical @INC entries - some versions of
  # Test::Harness will really explode the number of entries here
  @INC = grep {ref() || -d} @INC if @INC > 100;

  $self->do_tests;
}

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

  my @types;
  for my $action (grep { $_ ne 'all' } $self->get_test_types) {
    # XXX We can't just dispatch because we get multiple summaries but
    # we'll need to dispatch to support custom setup/teardown in the
    # action.  To support that, we'll need to call something besides
    # Harness::runtests() because we'll need to collect the results in
    # parts, then run the summary.
    push(@types, $action);
    #$self->_call_action( "test$action" );
  }
  $self->generic_test(types => ['default', @types]);
}

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

  my $t = $self->{properties}->{test_types};
  return ( defined $t ? ( keys %$t ) : () );
}


sub ACTION_test {
  my ($self) = @_;
  $self->generic_test(type => 'default');
}

sub generic_test {
  my $self = shift;
  (@_ % 2) and croak('Odd number of elements in argument hash');
  my %args = @_;

  my $p = $self->{properties};

  my @types = (
    (exists($args{type})  ? $args{type} : ()), 
    (exists($args{types}) ? @{$args{types}} : ()),
  );
  @types or croak "need some types of tests to check";

  my %test_types = (
    default => '.t',
    (defined($p->{test_types}) ? %{$p->{test_types}} : ()),
  );

  for my $type (@types) {
    croak "$type not defined in test_types!"
      unless defined $test_types{ $type };
  }

  # we use local here because it ends up two method calls deep
  local $p->{test_file_exts} = [ @test_types{@types} ];
  $self->depends_on('code');

  # Protect others against our @INC changes
  local @INC = @INC;

  # Make sure we test the module in blib/
  unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
		 File::Spec->catdir($p->{base_dir}, $self->blib, 'arch'));

  # Filter out nonsensical @INC entries - some versions of
  # Test::Harness will really explode the number of entries here
  @INC = grep {ref() || -d} @INC if @INC > 100;

  $self->do_tests;
}

sub do_tests {
  my $self = shift;
  my $p = $self->{properties};
  require Test::Harness;

  # Do everything in our power to work with all versions of Test::Harness
  my @harness_switches = $p->{debugger} ? qw(-w -d) : ();
  local $Test::Harness::switches    = join ' ', grep defined, $Test::Harness::switches, @harness_switches;
  local $Test::Harness::Switches    = join ' ', grep defined, $Test::Harness::Switches, @harness_switches;
  local $ENV{HARNESS_PERL_SWITCHES} = join ' ', grep defined, $ENV{HARNESS_PERL_SWITCHES}, @harness_switches;
  
  $Test::Harness::switches = undef   unless length $Test::Harness::switches;
  $Test::Harness::Switches = undef   unless length $Test::Harness::Switches;
  delete $ENV{HARNESS_PERL_SWITCHES} unless length $ENV{HARNESS_PERL_SWITCHES};
  
  local ($Test::Harness::verbose,
	 $Test::Harness::Verbose,
	 $ENV{TEST_VERBOSE},
         $ENV{HARNESS_VERBOSE}) = ($p->{verbose} || 0) x 4;

  my $tests = $self->find_test_files;

  if (@$tests) {
    # Work around a Test::Harness bug that loses the particular perl
    # we're running under.  $self->perl is trustworthy, but $^X isn't.
    local $^X = $self->perl;
    Test::Harness::runtests(@$tests);
  } else {
    $self->log_info("No tests defined.\n");
  }

  # This will get run and the user will see the output.  It doesn't
  # emit Test::Harness-style output.
  if (-e 'visual.pl') {
    $self->run_perl_script('visual.pl', '-Mblib='.$self->blib);
  }
}

sub test_files {
  my $self = shift;
  my $p = $self->{properties};
  if (@_) {
    return $p->{test_files} = (@_ == 1 ? shift : [@_]);
  }
  return $self->find_test_files;
}

sub expand_test_dir {
  my ($self, $dir) = @_;
  my $exts = $self->{properties}{test_file_exts} || ['.t'];

  return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts
    if $self->recursive_test_files;

  return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts;
}

sub ACTION_testdb {
  my ($self) = @_;
  local $self->{properties}{debugger} = 1;
  $self->depends_on('test');
}

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

  unless (Module::Build::ModuleInfo->find_module_by_name('Devel::Cover')) {
    warn("Cannot run testcover action unless Devel::Cover is installed.\n");
    return;
  }

  $self->add_to_cleanup('coverage', 'cover_db');
  $self->depends_on('code');

  # See whether any of the *.pm files have changed since last time
  # testcover was run.  If so, start over.
  if (-e 'cover_db') {
    my $pm_files = $self->rscan_dir
        (File::Spec->catdir($self->blib, 'lib'), file_qr('\.pm$') );
    my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/});
    
    $self->do_system(qw(cover -delete))
      unless $self->up_to_date($pm_files,         $cover_files)
	  && $self->up_to_date($self->test_files, $cover_files);
  }

  local $Test::Harness::switches    = 
  local $Test::Harness::Switches    = 
  local $ENV{HARNESS_PERL_SWITCHES} = "-MDevel::Cover";

  $self->depends_on('test');
  $self->do_system('cover');
}

sub ACTION_code {
  my ($self) = @_;
  
  # All installable stuff gets created in blib/ .
  # Create blib/arch to keep blib.pm happy
  my $blib = $self->blib;
  $self->add_to_cleanup($blib);
  File::Path::mkpath( File::Spec->catdir($blib, 'arch') );
  
  if (my $split = $self->autosplit) {
    $self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split);
  }
  
  foreach my $element (@{$self->build_elements}) {
    my $method = "process_${element}_files";
    $method = "process_files_by_extension" unless $self->can($method);
    $self->$method($element);
  }

  $self->depends_on('config_data');
}

sub ACTION_build {
  my $self = shift;
  $self->depends_on('code');
  $self->depends_on('docs');
}

sub process_files_by_extension {
  my ($self, $ext) = @_;
  
  my $method = "find_${ext}_files";
  my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext,  'lib');
  
  while (my ($file, $dest) = each %$files) {
    $self->copy_if_modified(from => $file, to => File::Spec->catfile($self->blib, $dest) );
  }
}

sub process_support_files {
  my $self = shift;
  my $p = $self->{properties};
  return unless $p->{c_source};
  
  push @{$p->{include_dirs}}, $p->{c_source};
  
  my $files = $self->rscan_dir($p->{c_source}, file_qr('\.c(pp)?$'));
  foreach my $file (@$files) {
    push @{$p->{objects}}, $self->compile_c($file);
  }
}

sub process_PL_files {
  my ($self) = @_;
  my $files = $self->find_PL_files;
  
  while (my ($file, $to) = each %$files) {
    unless ($self->up_to_date( $file, $to )) {
      $self->run_perl_script($file, [], [@$to]) or die "$file failed";
      $self->add_to_cleanup(@$to);
    }
  }
}

sub process_xs_files {
  my $self = shift;
  my $files = $self->find_xs_files;
  while (my ($from, $to) = each %$files) {
    unless ($from eq $to) {
      $self->add_to_cleanup($to);
      $self->copy_if_modified( from => $from, to => $to );
    }
    $self->process_xs($to);
  }
}

sub process_pod_files { shift()->process_files_by_extension(shift()) }
sub process_pm_files  { shift()->process_files_by_extension(shift()) }

sub process_script_files {
  my $self = shift;
  my $files = $self->find_script_files;
  return unless keys %$files;

  my $script_dir = File::Spec->catdir($self->blib, 'script');
  File::Path::mkpath( $script_dir );
  
  foreach my $file (keys %$files) {
    my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
    $self->fix_shebang_line($result) unless $self->is_vmsish;
    $self->make_executable($result);
  }
}

sub find_PL_files {
  my $self = shift;
  if (my $files = $self->{properties}{PL_files}) {
    # 'PL_files' is given as a Unix file spec, so we localize_file_path().
    
    if (UNIVERSAL::isa($files, 'ARRAY')) {
      return { map {$_, [/^(.*)\.PL$/]}
	       map $self->localize_file_path($_),
	       @$files };

    } elsif (UNIVERSAL::isa($files, 'HASH')) {
      my %out;
      while (my ($file, $to)