base.pm

source of perl for linux application,

    unless (chdir(\$base_dir)) {
      die ("Couldn't chdir(\$base_dir), aborting\\n");
    }
    unless (magic_number_matches()) {
      die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n");
    }
  }
  unshift \@INC,
    (
$quoted_INC
    );
}

close(*DATA) unless eof(*DATA); # ensure no open handles to this script

use $build_package;

# Some platforms have problems setting \$^X in shebang contexts, fix it up here
\$^X = Module::Build->find_perl_interpreter;

if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) {
   warn "Warning: Build.PL has been altered.  You may need to run 'perl Build.PL' again.\\n";
}

# This should have just enough arguments to be able to bootstrap the rest.
my \$build = $build_package->resume (
  properties => {
    config_dir => '$q{config_dir}',
    orig_dir => \$orig_dir,
  },
);

\$build->dispatch;
EOF
}

sub create_build_script {
  my ($self) = @_;
  $self->write_config;
  
  my ($build_script, $dist_name, $dist_version)
    = map $self->$_(), qw(build_script dist_name dist_version);
  
  if ( $self->delete_filetree($build_script) ) {
    $self->log_info("Removed previous script '$build_script'\n\n");
  }

  $self->log_info("Creating new '$build_script' script for ",
		  "'$dist_name' version '$dist_version'\n");
  my $fh = IO::File->new(">$build_script") or die "Can't create '$build_script': $!";
  $self->print_build_script($fh);
  close $fh;
  
  $self->make_executable($build_script);

  return 1;
}

sub check_manifest {
  my $self = shift;
  return unless -e 'MANIFEST';
  
  # Stolen nearly verbatim from MakeMaker.  But ExtUtils::Manifest
  # could easily be re-written into a modern Perl dialect.

  require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
  local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
  
  $self->log_info("Checking whether your kit is complete...\n");
  if (my @missed = ExtUtils::Manifest::manicheck()) {
    $self->log_warn("WARNING: the following files are missing in your kit:\n",
		    "\t", join("\n\t", @missed), "\n",
		    "Please inform the author.\n\n");
  } else {
    $self->log_info("Looks good\n\n");
  }
}

sub dispatch {
  my $self = shift;
  local $self->{_completed_actions} = {};

  if (@_) {
    my ($action, %p) = @_;
    my $args = $p{args} ? delete($p{args}) : {};

    local $self->{invoked_action} = $action;
    local $self->{args} = {%{$self->{args}}, %$args};
    local $self->{properties} = {%{$self->{properties}}, %p};
    return $self->_call_action($action);
  }

  die "No build action specified" unless $self->{action};
  local $self->{invoked_action} = $self->{action};
  $self->_call_action($self->{action});
}

sub _call_action {
  my ($self, $action) = @_;

  return if $self->{_completed_actions}{$action}++;

  local $self->{action} = $action;
  my $method = "ACTION_$action";
  die "No action '$action' defined, try running the 'help' action.\n" unless $self->can($method);
  return $self->$method();
}

sub cull_options {
    my $self = shift;
    my $specs = $self->get_options or return ({}, @_);
    require Getopt::Long;
    # XXX Should we let Getopt::Long handle M::B's options? That would
    # be easy-ish to add to @specs right here, but wouldn't handle options
    # passed without "--" as M::B currently allows. We might be able to
    # get around this by setting the "prefix_pattern" Configure option.
    my @specs;
    my $args = {};
    # Construct the specifications for GetOptions.
    while (my ($k, $v) = each %$specs) {
        # Throw an error if specs conflict with our own.
        die "Option specification '$k' conflicts with a " . ref $self
          . " option of the same name"
          if $self->valid_property($k);
        push @specs, $k . (defined $v->{type} ? $v->{type} : '');
        push @specs, $v->{store} if exists $v->{store};
        $args->{$k} = $v->{default} if exists $v->{default};
    }

    local @ARGV = @_; # No other way to dupe Getopt::Long

    # Get the options values and return them.
    # XXX Add option to allow users to set options?
    if ( @specs ) {
      Getopt::Long::Configure('pass_through');
      Getopt::Long::GetOptions($args, @specs);
    }

    return $args, @ARGV;
}

sub unparse_args {
  my ($self, $args) = @_;
  my @out;
  while (my ($k, $v) = each %$args) {
    push @out, (UNIVERSAL::isa($v, 'HASH')  ? map {+"--$k", "$_=$v->{$_}"} keys %$v :
		UNIVERSAL::isa($v, 'ARRAY') ? map {+"--$k", $_} @$v :
		("--$k", $v));
  }
  return @out;
}

sub args {
    my $self = shift;
    return wantarray ? %{ $self->{args} } : $self->{args} unless @_;
    my $key = shift;
    $self->{args}{$key} = shift if @_;
    return $self->{args}{$key};
}

sub _translate_option {
  my $self = shift;
  my $opt  = shift;

  (my $tr_opt = $opt) =~ tr/-/_/;

  return $tr_opt if grep $tr_opt =~ /^(?:no_?)?$_$/, qw(
    create_makefile_pl
    create_readme
    extra_compiler_flags
    extra_linker_flags
    html_css
    install_base
    install_path
    meta_add
    meta_merge
    test_files
    use_rcfile
  ); # normalize only selected option names

  return $opt;
}

sub _read_arg {
  my ($self, $args, $key, $val) = @_;

  $key = $self->_translate_option($key);

  if ( exists $args->{$key} ) {
    $args->{$key} = [ $args->{$key} ] unless ref $args->{$key};
    push @{$args->{$key}}, $val;
  } else {
    $args->{$key} = $val;
  }
}

sub _optional_arg {
  my $self = shift;
  my $opt  = shift;
  my $argv = shift;

  $opt = $self->_translate_option($opt);

  my @bool_opts = qw(
    build_bat
    create_readme
    pollute
    quiet
    uninst
    use_rcfile
    verbose
  );

  # inverted boolean options; eg --noverbose or --no-verbose
  # converted to proper name & returned with false value (verbose, 0)
  if ( grep $opt =~ /^no[-_]?$_$/, @bool_opts ) {
    $opt =~ s/^no-?//;
    return ($opt, 0);
  }

  # non-boolean option; return option unchanged along with its argument
  return ($opt, shift(@$argv)) unless grep $_ eq $opt, @bool_opts;

  # we're punting a bit here, if an option appears followed by a digit
  # we take the digit as the argument for the option. If there is
  # nothing that looks like a digit, we pretent the option is a flag
  # that is being set and has no argument.
  my $arg = 1;
  $arg = shift(@$argv) if @$argv && $argv->[0] =~ /^\d+$/;

  return ($opt, $arg);
}

sub read_args {
  my $self = shift;
  my ($action, @argv);
  (my $args, @_) = $self->cull_options(@_);
  my %args = %$args;

  my $opt_re = qr/[\w\-]+/;

  while (@_) {
    local $_ = shift;
    if ( /^(?:--)?($opt_re)=(.*)$/ ) {
      $self->_read_arg(\%args, $1, $2);
    } elsif ( /^--($opt_re)$/ ) {
      my($opt, $arg) = $self->_optional_arg($1, \@_);
      $self->_read_arg(\%args, $opt, $arg);
    } elsif ( /^($opt_re)$/ and !defined($action)) {
      $action = $1;
    } else {
      push @argv, $_;
    }
  }
  $args{ARGV} = \@argv;

  for ('extra_compiler_flags', 'extra_linker_flags') {
    $args{$_} = [ $self->split_like_shell($args{$_}) ] if exists $args{$_};
  }

  # Hashify these parameters
  for ($self->hash_properties, 'config') {
    next unless exists $args{$_};
    my %hash;
    $args{$_} ||= [];
    $args{$_} = [ $args{$_} ] unless ref $args{$_};
    foreach my $arg ( @{$args{$_}} ) {
      $arg =~ /(\w+)=(.*)/
	or die "Malformed '$_' argument: '$arg' should be something like 'foo=bar'";
      $hash{$1} = $2;
    }
    $args{$_} = \%hash;
  }

  # De-tilde-ify any path parameters
  for my $key (qw(prefix install_base destdir)) {
    next if !defined $args{$key};
    $args{$key} = $self->_detildefy($args{$key});
  }

  for my $key (qw(install_path)) {
    next if !defined $args{$key};

    for my $subkey (keys %{$args{$key}}) {
      next if !defined $args{$key}{$subkey};
      my $subkey_ext = $self->_detildefy($args{$key}{$subkey});
      if ( $subkey eq 'html' ) { # translate for compatability
	$args{$key}{binhtml} = $subkey_ext;
	$args{$key}{libhtml} = $subkey_ext;
      } else {
	$args{$key}{$subkey} = $subkey_ext;
      }
    }
  }

  if ($args{makefile_env_macros}) {
    require Module::Build::Compat;
    %args = (%args, Module::Build::Compat->makefile_to_build_macros);
  }
  
  return \%args, $action;
}

# Default: do nothing.  Overridden for Unix & Windows.
sub _detildefy {}


# merge Module::Build argument lists that have already been parsed
# by read_args(). Takes two references to option hashes and merges
# the contents, giving priority to the first.
sub _merge_arglist {
  my( $self, $opts1, $opts2 ) = @_;

  my %new_opts = %$opts1;
  while (my ($key, $val) = each %$opts2) {
    if ( exists( $opts1->{$key} ) ) {
      if ( ref( $val ) eq 'HASH' ) {
        while (my ($k, $v) = each %$val) {
	  $new_opts{$key}{$k} = $v unless exists( $opts1->{$key}{$k} );
	}
      }
    } else {
      $new_opts{$key} = $val
    }
  }

  return %new_opts;
}

# Look for a home directory on various systems.
sub _home_dir {
  my @home_dirs;
  push( @home_dirs, $ENV{HOME} ) if $ENV{HOME};

  push( @home_dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
      if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};

  my @other_home_envs = qw( USERPROFILE APPDATA WINDIR SYS$LOGIN );
  push( @home_dirs, map $ENV{$_}, grep $ENV{$_}, @other_home_envs );

  my @real_home_dirs = grep -d, @home_dirs;

  return wantarray ? @real_home_dirs : shift( @real_home_dirs );
}

sub _find_user_config {
  my $self = shift;
  my $file = shift;
  foreach my $dir ( $self->_home_dir ) {
    my $path = File::Spec->catfile( $dir, $file );
    return $path if -e $path;
  }
  return undef;
}

# read ~/.modulebuildrc returning global options '*' and
# options specific to the currently executing $action.
sub read_modulebuildrc {
  my( $self, $action ) = @_;

  return () unless $self->use_rcfile;

  my $modulebuildrc;
  if ( exists($ENV{MODULEBUILDRC}) && $ENV{MODULEBUILDRC} eq 'NONE' ) {
    return ();
  } elsif ( exists($ENV{MODULEBUILDRC}) && -e $ENV{MODULEBUILDRC} ) {
    $modulebuildrc = $ENV{MODULEBUILDRC};
  } elsif ( exists($ENV{MODULEBUILDRC}) ) {
    $self->log_warn("WARNING: Can't find resource file " .
		    "'$ENV{MODULEBUILDRC}' defined in environment.\n" .
		    "No options loaded\n");
    return ();
  } else {
    $modulebuildrc = $self->_find_user_config( '.modulebuildrc' );
    return () unless $modulebuildrc;
  }

  my $fh = IO::File->new( $modulebuildrc )
      or die "Can't open $modulebuildrc: $!";

  my %options; my $buffer = '';
  while (defined( my $line = <$fh> )) {
    chomp( $line );
    $line =~ s/#.*$//;
    next unless length( $line );

    if ( $line =~ /^\S/ ) {
      if ( $buffer ) {
	my( $action, $options ) = split( /\s+/, $buffer, 2 );
	$options{$action} .= $options . ' ';
	$buffer = '';
      }
      $buffer = $line;
    } else {
      $buffer .= $line;
    }
  }

  if ( $buffer ) { # anything left in $buffer ?
    my( $action, $options ) = split( /\s+/, $buffer, 2 );
    $options{$action} .= $options . ' '; # merge if more than one line
  }

  my ($global_opts) =
    $self->read_args( $self->split_like_shell( $options{'*'} || '' ) );
  my ($action_opts) =
    $self->read_args( $self->split_like_shell( $options{$action} || '' ) );

  # specific $action options take priority over global options '*'
  return $self->_merge_arglist( $action_opts, $global_opts );
}

# merge the relevant options in ~/.modulebuildrc into Module::Build's
# option list where they do not conflict with commandline options.
sub merge_modulebuildrc {
  my( $self, $action, %cmdline_opts ) = @_;
  my %rc_opts = $self->read_modulebuildrc( $action || $self->{action} || 'build' );
  my %new_opts = $self->_merge_arglist( \%cmdline_opts, \%rc_opts );
  $self->merge_args( $action, %new_opts );
}

sub merge_args {
  my ($self, $action, %args) = @_;
  $self->{action} = $action if defined $action;

  my %additive = map { $_ => 1 } $self->hash_properties;

  # Extract our 'properties' from $cmd_args, the rest are put in 'args'.
  while (my ($key, $val) = each %args) {
    $self->{phash}{runtime_params}->access( $key => $val )
      if $self->valid_property($key);

    if ($key eq 'config') {
      $self->config($_ => $val->{$_}) foreach keys %$val;
    } else {
      my $add_to = ( $additive{$key} ? $self->{properties}{$key}
		     : $self->valid_property($key) ? $self->{properties}
		     : $self->{args});

      if ($additive{$key}) {
	$add_to->{$_} = $val->{$_} foreach keys %$val;
      } else {
	$add_to->{$key} = $val;
      }
    }
  }
}

sub cull_args {
  my $self = shift;
  my ($args, $action) = $self->read_args(@_);
  $self->merge_args($action, %$args);
  $self->merge_modulebuildrc( $action, %$args );
}

sub super_classes {
  my ($self, $class, $seen) = @_;
  $class ||= ref($self) || $self;
  $seen  ||= {};
  
  no strict 'refs';
  my @super = grep {not $seen->{$_}++} $class, @{ $class . '::ISA' };
  return @super, map {$self->super_classes($_,$seen)} @super;
}