Skip to content

Instantly share code, notes, and snippets.

@elmobp

elmobp/install.pl

Created July 16, 2020 03:17
Show Gist options
  • Save elmobp/ab8a797c239c6a2bb5d4a01eb32bbea4 to your computer and use it in GitHub Desktop.
Save elmobp/ab8a797c239c6a2bb5d4a01eb32bbea4 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
install.pl
This file has been truncated, but you can view the full file.
#!/usr/bin/perl
use strict;
use Config;
BEGIN {
my @oldinc = @INC;
@INC = ( $Config{sitelibexp}."/".$Config{archname}, $Config{sitelibexp}, @Config{qw<vendorlibexp vendorarchexp archlibexp privlibexp>} );
require Cwd;
@INC = @oldinc;
}
# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;
$fatpacked{"App/Perlbrew/Path.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH';
use strict;
use warnings;
package App::Perlbrew::Path;
require File::Basename;
require File::Glob;
require File::Path;
use overload (
'""' => \& stringify,
fallback => 1,
);
sub _joinpath {
for my $entry(@_) {
no warnings 'uninitialized';
die 'Received an undefined entry as a parameter (all parameters are: '. join(', ', @_). ')'." Got $entry" unless (defined($entry));
}
return join "/", @_;
}
sub _child {
my ($self, $package, @path) = @_;
$package->new ($self->{path}, @path);
}
sub _children {
my ($self, $package) = @_;
return map $package->new ($_),
File::Glob::bsd_glob ($self->child ("*"))
;
}
sub new {
my ($class, @path) = @_;
bless { path => _joinpath (@path) }, $class;
}
sub basename {
my ($self, $suffix) = @_;
return scalar File::Basename::fileparse ($self, ($suffix) x!! defined $suffix);
}
sub child {
my ($self, @path) = @_;
return $self->_child (__PACKAGE__, @path);
}
sub children {
my ($self) = @_;
return $self->_children (__PACKAGE__);
}
sub dirname {
my ($self) = @_;
return App::Perlbrew::Path->new (File::Basename::dirname ($self));
}
sub mkpath {
my ($self) = @_;
File::Path::mkpath ([$self->stringify], 0, 0777);
return $self;
}
sub readlink {
my ($self) = @_;
my $link = readlink $self->stringify;
$link = __PACKAGE__->new ($link) if defined $link;
return $link;
}
sub rmpath {
my ($self) = @_;
File::Path::rmtree([$self->stringify], 0, 0);
return $self;
}
sub stringify {
my ($self) = @_;
return $self->{path};
}
sub stringify_with_tilde {
my ($self) = @_;
my $path = $self->stringify;
my $home = $ENV{HOME};
$path =~ s!\Q$home/\E!~/! if $home;
return $path;
}
sub symlink {
my ($self, $destination, $force) = @_;
$destination = App::Perlbrew::Path->new ($destination)
unless ref $destination;
CORE::unlink $destination
if $force && (-e $destination || -l $destination);
$destination if CORE::symlink $self, $destination;
}
sub unlink {
my ($self) = @_;
CORE::unlink ($self);
}
1;
APP_PERLBREW_PATH
$fatpacked{"App/Perlbrew/Path/Installation.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_INSTALLATION';
use strict;
use warnings;
package App::Perlbrew::Path::Installation;
require App::Perlbrew::Path;
our @ISA = qw( App::Perlbrew::Path );
sub name {
$_[0]->basename;
}
sub bin {
shift->child (bin => @_);
}
sub man {
shift->child (man => @_);
}
sub perl {
shift->bin ('perl');
}
sub version_file {
shift->child ('.version');
}
1;
APP_PERLBREW_PATH_INSTALLATION
$fatpacked{"App/Perlbrew/Path/Installations.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_INSTALLATIONS';
use strict;
use warnings;
package App::Perlbrew::Path::Installations;
require App::Perlbrew::Path;
require App::Perlbrew::Path::Installation;
our @ISA = qw( App::Perlbrew::Path );
sub child {
my ($self, @params) = @_;
my $return = $self;
$return = $return->_child ('App::Perlbrew::Path::Installation' => shift @params) if @params;
$return = $return->child (@params) if @params;
$return;
}
sub children {
shift->_children ('App::Perlbrew::Path::Installation' => @_);
}
sub list {
shift->children;
}
1;
APP_PERLBREW_PATH_INSTALLATIONS
$fatpacked{"App/Perlbrew/Path/Root.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_ROOT';
use strict;
use warnings;
package App::Perlbrew::Path::Root;
require App::Perlbrew::Path;
require App::Perlbrew::Path::Installations;
our @ISA = qw( App::Perlbrew::Path );
sub bin {
shift->child (bin => @_);
}
sub build {
shift->child (build => @_);
}
sub dists {
shift->child (dists => @_);
}
sub etc {
shift->child (etc => @_);
}
sub perls {
my ($self, @params) = @_;
my $return = $self->_child ('App::Perlbrew::Path::Installations', 'perls');
$return = $return->child (@params) if @params;
return $return;
}
1;
APP_PERLBREW_PATH_ROOT
$fatpacked{"App/Perlbrew/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_UTIL';
package App::Perlbrew::Util;
use strict;
use warnings;
use 5.008;
use Exporter 'import';
our @EXPORT = qw(uniq min editdist);
sub uniq {
my %seen;
grep { !$seen{$_}++ } @_;
}
sub min(@) {
my $m = $_[0];
for(@_) {
$m = $_ if $_ < $m;
}
return $m;
}
# straight copy of Wikipedia's "Levenshtein Distance"
sub editdist {
my @a = split //, shift;
my @b = split //, shift;
# There is an extra row and column in the matrix. This is the
# distance from the empty string to a substring of the target.
my @d;
$d[$_][0] = $_ for (0 .. @a);
$d[0][$_] = $_ for (0 .. @b);
for my $i (1 .. @a) {
for my $j (1 .. @b) {
$d[$i][$j] = ($a[$i-1] eq $b[$j-1] ? $d[$i-1][$j-1]
: 1 + min($d[$i-1][$j], $d[$i][$j-1], $d[$i-1][$j-1]));
}
}
return $d[@a][@b];
}
1;
APP_PERLBREW_UTIL
$fatpacked{"App/perlbrew.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW';
package App::perlbrew;
use strict;
use warnings;
use 5.008;
our $VERSION = "0.88";
use Config;
BEGIN {
# Special treat for Cwd to prevent it to be loaded from somewhere binary-incompatible with system perl.
my @oldinc = @INC;
@INC = (
$Config{sitelibexp}."/".$Config{archname},
$Config{sitelibexp},
@Config{qw<vendorlibexp vendorarchexp archlibexp privlibexp>},
);
require Cwd;
@INC = @oldinc;
}
use Getopt::Long ();
use CPAN::Perl::Releases;
use JSON::PP 'decode_json';
use App::Perlbrew::Util;
use App::Perlbrew::Path;
use App::Perlbrew::Path::Root;
### global variables
# set $ENV{SHELL} to executable path of parent process (= shell) if it's missing
# (e.g. if this script was executed by a daemon started with "service xxx start")
# ref: https://github.com/gugod/App-perlbrew/pull/404
$ENV{SHELL} ||= App::Perlbrew::Path->new ("/proc", getppid, "exe")->readlink if -d "/proc";
local $SIG{__DIE__} = sub {
my $message = shift;
warn $message;
exit(1);
};
our $CONFIG;
our $PERLBREW_ROOT;
our $PERLBREW_HOME;
my @flavors = ( { d_option => 'usethreads',
implies => 'multi',
common => 1,
opt => 'thread|threads' }, # threads is for backward compatibility
{ d_option => 'usemultiplicity',
opt => 'multi' },
{ d_option => 'uselongdouble',
common => 1,
opt => 'ld' },
{ d_option => 'use64bitint',
common => 1,
opt => '64int' },
{ d_option => 'use64bitall',
implies => '64int',
opt => '64all' },
{ d_option => 'DEBUGGING',
opt => 'debug' },
{ d_option => 'cc=clang',
opt => 'clang' },
);
my %flavor;
my $flavor_ix = 0;
for (@flavors) {
my ($name) = $_->{opt} =~ /([^|]+)/;
$_->{name} = $name;
$_->{ix} = ++$flavor_ix;
$flavor{$name} = $_;
}
for (@flavors) {
if (my $implies = $_->{implies}) {
$flavor{$implies}{implied_by} = $_->{name};
}
}
### functions
sub files_are_the_same {
## Check dev and inode num. Not useful on Win32.
## The for loop should always return false on Win32, as a result.
my @files = @_;
my @stats = map {[ stat($_) ]} @files;
my $stats0 = join " ", @{$stats[0]}[0,1];
for (@stats) {
return 0 if ((! defined($_->[1])) || $_->[1] == 0);
unless ($stats0 eq join(" ", $_->[0], $_->[1])) {
return 0;
}
}
return 1
}
{
my %commands = (
curl => {
test => '--version >/dev/null 2>&1',
get => '--silent --location --fail -o - {url}',
download => '--silent --location --fail -o {output} {url}',
order => 1,
# Exit code is 22 on 404s etc
die_on_error => sub { die 'Page not retrieved; HTTP error code 400 or above.' if ($_[ 0 ] >> 8 == 22); },
},
wget => {
test => '--version >/dev/null 2>&1',
get => '--quiet -O - {url}',
download => '--quiet -O {output} {url}',
order => 2,
# Exit code is not 0 on error
die_on_error => sub { die 'Page not retrieved: fetch failed.' if ($_[ 0 ]); },
},
fetch => {
test => '--version >/dev/null 2>&1',
get => '-o - {url}',
download => '-o {output} {url}',
order => 3,
# Exit code is 8 on 404s etc
die_on_error => sub { die 'Server issued an error response.' if ($_[ 0 ] >> 8 == 8); },
}
);
our $HTTP_USER_AGENT_PROGRAM;
sub http_user_agent_program {
$HTTP_USER_AGENT_PROGRAM ||= do {
my $program;
for my $p (sort {$commands{$a}{order}<=>$commands{$b}{order}} keys %commands) {
my $code = system("$p $commands{$p}->{test}") >> 8;
if ($code != 127) {
$program = $p;
last;
}
}
unless ($program) {
die "[ERROR] Cannot find a proper http user agent program. Please install curl or wget.\n";
}
$program;
};
die "[ERROR] Unrecognized http user agent program: $HTTP_USER_AGENT_PROGRAM. It can only be one of: ".join(",", keys %commands)."\n" unless $commands{$HTTP_USER_AGENT_PROGRAM};
return $HTTP_USER_AGENT_PROGRAM;
}
sub http_user_agent_command {
my ($purpose, $params) = @_;
my $ua = http_user_agent_program;
my $cmd = $ua . " " . $commands{ $ua }->{ $purpose };
for (keys %$params) {
$cmd =~ s!{$_}!$params->{$_}!g;
}
return ($ua, $cmd) if wantarray;
return $cmd;
}
sub http_download {
my ($url, $path) = @_;
if (-e $path) {
die "ERROR: The download target < $path > already exists.\n";
}
my $partial = 0;
local $SIG{TERM} = local $SIG{INT} = sub { $partial++ };
my $download_command = http_user_agent_command(download => { url => $url, output => $path });
my $status = system($download_command);
if ($partial) {
$path->unlink;
return "ERROR: Interrupted.";
}
unless ($status == 0) {
$path->unlink;
return "ERROR: Failed to execute the command\n\n\t$download_command\n\nReason:\n\n\t$?";
}
return 0;
}
sub http_get {
my ($url, $header, $cb) = @_;
if (ref($header) eq 'CODE') {
$cb = $header;
$header = undef;
}
my ($program, $command) = http_user_agent_command(get => { url => $url });
open my $fh, '-|', $command
or die "open() pipe for '$command': $!";
local $/;
my $body = <$fh>;
close $fh;
# check if the download has failed and die automatically
$commands{ $program }{ die_on_error }->($?);
return $cb ? $cb->($body) : $body;
}
}
sub perl_version_to_integer {
my $version = shift;
my @v = split(/[\.\-_]/, $version);
return undef if @v < 2;
if ($v[1] <= 5) {
$v[2] ||= 0;
$v[3] = 0;
}
else {
$v[3] ||= $v[1] >= 6 ? 9 : 0;
$v[3] =~ s/[^0-9]//g;
}
return $v[1]*1000000 + $v[2]*1000 + $v[3];
}
### methods
sub new {
my($class, @argv) = @_;
my %opt = (
original_argv => \@argv,
args => [],
yes => 0,
force => 0,
quiet => 0,
D => [],
U => [],
A => [],
sitecustomize => '',
destdir => '',
noman => '',
variation => '',
both => [],
append => '',
reverse => 0,
verbose => 0,
);
$opt{$_} = '' for keys %flavor;
if (@argv) {
# build a local @ARGV to allow us to use an older
# Getopt::Long API in case we are building on an older system
local (@ARGV) = @argv;
Getopt::Long::Configure(
'pass_through',
'no_ignore_case',
'bundling',
'permute', # default behaviour except 'exec'
);
$class->parse_cmdline(\%opt);
$opt{args} = \@ARGV;
# fix up the effect of 'bundling'
foreach my $flags (@opt{qw(D U A)}) {
foreach my $value (@{$flags}) {
$value =~ s/^=//;
}
}
}
my $self = bless \%opt, $class;
# Treat --root option same way as env variable PERLBREW_ROOT (with higher priority)
$ENV{PERLBREW_ROOT} = $self->root ($opt{root})
if $opt{root};
$self->{builddir} = App::Perlbrew::Path->new ($self->{builddir})
if $opt{builddir};
# Ensure propagation of $PERLBREW_HOME and $PERLBREW_ROOT
$self->root;
$self->home;
return $self;
}
sub parse_cmdline {
my ($self, $params, @ext) = @_;
my @f = map { $flavor{$_}{opt} || $_ } keys %flavor;
return Getopt::Long::GetOptions(
$params,
'yes',
'force|f',
'reverse',
'notest|n',
'quiet|q',
'verbose|v',
'as=s',
'append=s',
'help|h',
'version',
'root=s',
'switch',
'all',
'shell=s',
'no-patchperl',
"builddir=s",
# options passed directly to Configure
'D=s@',
'U=s@',
'A=s@',
'j=i',
# options that affect Configure and customize post-build
'sitecustomize=s',
'destdir=s',
'noman',
# flavors support
'both|b=s@',
'all-variations',
'common-variations',
@f,
@ext
)
}
sub root {
my ($self, $new_root) = @_;
$new_root ||= $PERLBREW_ROOT
|| $ENV{PERLBREW_ROOT}
|| App::Perlbrew::Path->new ($ENV{HOME}, "perl5", "perlbrew")->stringify
unless $self->{root};
$self->{root} = $PERLBREW_ROOT = $new_root
if defined $new_root;
$self->{root} = App::Perlbrew::Path::Root->new ($self->{root})
unless ref $self->{root};
$self->{root} = App::Perlbrew::Path::Root->new ($self->{root}->stringify)
unless $self->{root}->isa ('App::Perlbrew::Path::Root');
return $self->{root};
}
sub home {
my ($self, $new_home) = @_;
$new_home ||= $PERLBREW_HOME
|| $ENV{PERLBREW_HOME}
|| App::Perlbrew::Path->new ($ENV{HOME}, ".perlbrew")->stringify
unless $self->{home};
$self->{home} = $PERLBREW_HOME = $new_home
if defined $new_home;
$self->{home} = App::Perlbrew::Path->new ($self->{home})
unless ref $self->{home};
return $self->{home};
}
sub builddir {
my ($self) = @_;
return $self->{builddir} || $self->root->build;
}
sub current_perl {
my ($self, $v) = @_;
$self->{current_perl} = $v if $v;
return $self->{current_perl} || $self->env('PERLBREW_PERL') || '';
}
sub current_lib {
my ($self, $v) = @_;
$self->{current_lib} = $v if $v;
return $self->{current_lib} || $self->env('PERLBREW_LIB') || '';
}
sub current_shell_is_bashish {
my ($self) = @_;
if (($self->current_shell eq 'bash') or ($self->current_shell eq 'zsh')) {
return 1;
} else {
return 0;
}
}
sub current_shell {
my ($self, $x) = @_;
$self->{current_shell} = $x if $x;
return $self->{current_shell} ||= do {
my $shell_name = App::Perlbrew::Path->new ($self->{shell} || $self->env('SHELL'))->basename;
$shell_name =~ s/\d+$//;
$shell_name;
};
}
sub current_env {
my ($self) = @_;
my $l = $self->current_lib;
$l = "@" . $l if $l;
return $self->current_perl . $l;
}
sub installed_perl_executable {
my ($self, $name) = @_;
die unless $name;
my $executable = $self->root->perls ($name)->perl;
return $executable if -e $executable;
return "";
}
sub configure_args {
my ($self, $name) = @_;
my $perl_cmd = $self->installed_perl_executable($name);
my $code = 'while(($_,$v)=each(%Config)){print"$_ $v" if /config_arg/}';
my @output = split "\n" => $self->do_capture($perl_cmd, '-MConfig', '-wle', $code);
my %arg;
for(@output) {
my ($k, $v) = split " ", $_, 2;
$arg{$k} = $v;
}
if (wantarray) {
return map { $arg{"config_arg$_"} } (1 .. $arg{config_argc})
}
return $arg{config_args}
}
sub cpan_mirror {
my ($self) = @_;
unless($self->{cpan_mirror}) {
$self->{cpan_mirror} = $self->env("PERLBREW_CPAN_MIRROR") || "http://www.cpan.org";
$self->{cpan_mirror} =~ s{/+$}{};
}
return $self->{cpan_mirror};
}
sub env {
my ($self, $name) = @_;
return $ENV{$name} if $name;
return \%ENV;
}
sub is_shell_csh {
my ($self) = @_;
return 1 if $self->env('SHELL') =~ /(t?csh)/;
return 0;
}
# Entry point method: handles all the arguments
# and dispatches to an appropriate internal
# method to execute the corresponding command.
sub run {
my($self) = @_;
$self->run_command($self->args);
}
sub args {
my ($self) = @_;
# keep 'force' and 'yes' coherent across commands
$self->{force} = $self->{yes} = 1 if ($self->{force} || $self->{yes});
return @{ $self->{args} };
}
sub commands {
my ($self) = @_;
my $package = ref $self ? ref $self : $self;
my @commands;
my $symtable = do {
no strict 'refs';
\%{$package . '::'};
};
foreach my $sym (keys %$symtable) {
if ($sym =~ /^run_command_/) {
my $glob = $symtable->{$sym};
if (ref($glob) eq 'CODE' || defined *$glob{CODE}) {
# with perl >= 5.27 stash entry can points to a CV directly
$sym =~ s/^run_command_//;
$sym =~ s/_/-/g;
push @commands, $sym;
}
}
}
return @commands;
}
sub find_similar_commands {
my ($self, $command) = @_;
my $SIMILAR_DISTANCE = 6;
$command =~ s/_/-/g;
my @commands = sort {
$a->[1] <=> $b->[1]
} map {
my $d = editdist($_, $command);
(($d < $SIMILAR_DISTANCE) ? [ $_, $d ] : ())
} $self->commands;
if (@commands) {
my $best = $commands[0][1];
@commands = map { $_->[0] } grep { $_->[1] == $best } @commands;
}
return @commands;
}
# This method is called in the 'run' loop
# and executes every specific action depending
# on the type of command.
#
# The first argument to this method is a self reference,
# while the first "real" argument is the command to execute.
# Other parameters after the command to execute are
# considered as arguments for the command itself.
#
# In general the command is executed via a method named after the
# command itself and with the 'run_command' prefix. For instance
# the command 'exec' is handled by a method
# `run_command_exec`
#
# If no candidates can be found, an execption is thrown
# and a similar command is shown to the user.
sub run_command {
my ($self, $x, @args) = @_;
my $command = $x;
if ($self->{version}) {
$x = 'version';
}
elsif (!$x) {
$x = 'help';
@args = (0, $self->{help} ? 2 : 0);
}
elsif ($x eq 'help') {
@args = (0, 2) unless @args;
}
my $s = $self->can("run_command_$x");
unless ($s) {
$x =~ y/-/_/;
$s = $self->can("run_command_$x");
}
unless ($s) {
my @commands = $self->find_similar_commands($x);
if (@commands > 1) {
@commands = map { ' ' . $_ } @commands;
die "Unknown command: `$command`. Did you mean one of the following?\n" . join("\n", @commands) . "\n";
} elsif (@commands == 1) {
die "Unknown command: `$command`. Did you mean `$commands[0]`?\n";
} else {
die "Unknown command: `$command`. Typo?\n";
}
}
$self->$s(@args);
}
sub run_command_version {
my ($self) = @_;
my $package = ref $self;
my $version = $self->VERSION;
print "$0 - $package/$version\n";
}
# Provides help information about a command.
# The idea is similar to the 'run_command' and 'run_command_$x' chain:
# this method dispatches to a 'run_command_help_$x' method
# if found in the class, otherwise it tries to extract the help
# documentation via the POD of the class itself using the
# section 'COMMAND: $x' with uppercase $x.
sub run_command_help {
my ($self, $status, $verbose, $return_text) = @_;
require Pod::Usage;
if ($status && !defined($verbose)) {
if ($self->can("run_command_help_${status}")) {
$self->can("run_command_help_${status}")->($self);
}
else {
my $out = "";
open my $fh, ">", \$out;
Pod::Usage::pod2usage(
-exitval => "NOEXIT",
-verbose => 99,
-sections => "COMMAND: " . uc($status),
-output => $fh,
-noperldoc => 1
);
$out =~ s/\A[^\n]+\n//s;
$out =~ s/^ //gm;
if ($out =~ /\A\s*\Z/) {
$out = "Cannot find documentation for '$status'\n\n";
}
return "\n$out" if ($return_text);
print "\n$out";
close $fh;
}
}
else {
Pod::Usage::pod2usage(
-noperldoc => 1,
-verbose => $verbose||0,
-exitval => (defined $status ? $status : 1)
);
}
}
# introspection for compgen
my %comp_installed = (
use => 1,
switch => 1,
);
sub run_command_compgen {
my($self, $cur, @args) = @_;
$cur = 0 unless defined($cur);
# do `tail -f bashcomp.log` for debugging
if ($self->env('PERLBREW_DEBUG_COMPLETION')) {
open my $log, '>>', 'bashcomp.log';
print $log "[$$] $cur of [@args]\n";
}
my $subcommand = $args[1];
my $subcommand_completed = ($cur >= 2);
if (!$subcommand_completed) {
$self->_compgen($subcommand, $self->commands);
}
else { # complete args of a subcommand
if ($comp_installed{$subcommand}) {
if ($cur <= 2) {
my $part;
if (defined($part = $args[2])) {
$part = qr/ \Q$part\E /xms;
}
$self->_compgen($part,
map{ $_->{name} } $self->installed_perls());
}
}
elsif ($subcommand eq 'help') {
if ($cur <= 2) {
$self->_compgen($args[2], $self->commands());
}
}
else {
# TODO
}
}
}
sub _firstrcfile {
my ($self, @files) = @_;
foreach my $path (@files) {
return $path if -f App::Perlbrew::Path->new ($self->env('HOME'), $path);
}
return;
}
sub _compgen {
my($self, $part, @reply) = @_;
if (defined $part) {
$part = qr/\A \Q$part\E /xms if ref($part) ne ref(qr//);
@reply = grep { /$part/ } @reply;
}
foreach my $word(@reply) {
print $word, "\n";
}
}
# Internal utility function.
# Given a specific perl version, e.g., perl-5.27.4
# returns a string with a formatted version number such
# as 05027004. Such string can be used as a number
# in order to make either a string comparison
# or a numeric comparison.
#
# In the case of cperl the major number is added by 6
# so that it would match the project claim of being
# Perl 5+6 = 11. The final result is then
# multiplied by a negative factor (-1) in order
# to make cperl being "less" in the ordered list
# than a normal Perl installation.
#
# The returned string is made by four pieces of two digits each:
# MMmmppbb
# where:
# MM is the major Perl version (e.g., 5 -> 05)
# mm is the minor Perl version (e.g. 27 -> 27)
# pp is the patch level (e.g., 4 -> 04)
# bb is the blead flag: it is 00 for a "normal" release, or 01 for a blead one
sub comparable_perl_version {
my ($self, $perl_version) = @_;
my ($is_cperl, $is_blead) = (0, 0);
my ($major, $minor, $patch) = (0, 0, 0);
if ($perl_version =~ /^(?:(c?perl)-?)?(\d)\.(\d+).(\d+).*/) {
$is_cperl = $1 && ($1 eq 'cperl');
$major = $2 + ($is_cperl ? 6 : 0); # major version
$minor = $3; # minor version
$patch = $4; # patch level
}
elsif ($perl_version =~ /^(?:(c?perl)-?)?-?(blead)$/) {
# in the case of a blead release use a fake high number
# to assume it is the "latest" release number available
$is_cperl = $1 && ($1 eq 'cperl');
$is_blead = $2 && ($2 eq 'blead');
($major, $minor, $patch) = (5, 99, 99);
}
return ($is_cperl ? -1 : 1)
* sprintf('%02d%02d%02d%02d',
$major + ($is_cperl ? 6 : 0), # major version
$minor, # minor version
$patch, # patch level
$is_blead); # blead
}
# Internal method.
# Performs a comparable sort of the perl versions specified as
# list.
sub sort_perl_versions {
my ($self, @perls) = @_;
return map { $_->[ 0 ] }
sort { ( $self->{reverse}
? $a->[ 1 ] <=> $b->[ 1 ]
: $b->[ 1 ] <=> $a->[ 1 ] ) }
map { [ $_, $self->comparable_perl_version($_) ] }
@perls;
}
sub run_command_available {
my ($self) = @_;
my $perls = $self->available_perls_with_urls(@_);
my @installed = $self->installed_perls(@_);
my $is_verbose = $self->{verbose};
# sort the keys of Perl installation (Randal to the rescue!)
my @sorted_perls = $self->sort_perl_versions(keys %$perls);
for my $available (@sorted_perls) {
my $url = $perls->{$available};
my $ctime;
for my $installed (@installed) {
my $name = $installed->{name};
my $cur = $installed->{is_current};
if ($available eq $installed->{name}) {
$ctime = $installed->{ctime};
last;
}
}
printf "\n%1s %12s %s %s",
$ctime ? 'i' : '',
$available,
( $is_verbose
? $ctime ? "INSTALLED on $ctime via" : 'available from '
: ''),
( $is_verbose ? "<$url>" : '' ) ;
}
print "\n";
return @sorted_perls;
}
sub available_perls {
my ($self) = @_;
my $perls = $self->available_perls_with_urls;
return $self->sort_perl_versions(keys %$perls);
}
sub available_perls_with_urls {
my ($self, $dist, $opts) = @_;
my $perls = {};
my @perllist;
my $url = $self->{all} ? "https://www.cpan.org/src/5.0/"
: "https://www.cpan.org/src/README.html" ;
my $html = http_get($url, undef, undef);
unless ($html) {
die "\nERROR: Unable to retrieve the list of perls.\n\n";
}
for (split "\n", $html) {
my ($current_perl, $current_url);
if ($self->{all}) {
($current_perl, $current_url) = ($2, $1) if m|<a href="(perl.*?\.tar\.gz)">\s*([^\s]+?)\s*</a>|;
}
else {
($current_perl, $current_url ) = ($2, $1) if m|<td><a href="(http(?:s?)://www.cpan.org/src/.+?)">\s*([^\s]+?)\s*</a></td>|;
}
# if we have a $current_perl add it to the available hash of perls
if ($current_perl) {
$current_perl =~ s/\.tar\.(bz2|gz)//;
push @perllist, [ $current_perl, $current_url ];
$perls->{$current_perl} = $current_url;
}
}
# we got impatient waiting for cpan.org to get updated to show 5.28...
# So, we also fetch from metacpan for anything that looks perlish,
# and we do our own processing to filter out the development
# releases and minor versions when needed (using
# filter_perl_available)
$url = 'https://fastapi.metacpan.org/v1/release/versions/perl';
$html = http_get($url, undef, undef);
unless ($html) {
$html = '';
warn "\nERROR: Unable to retrieve list of perls from Metacpan.\n\n";
}
while ($html =~ m{"(http(?:s?)://cpan\.metacpan\.org/[^"]+/(perl-5\.[0-9]+\.[0-9]+(?:-[A-Z0-9]+)?)\.tar\.(?:bz2|gz))"}g) {
my ($current_perl, $current_url) = ($2, $1);
push @perllist, [ $current_perl, $current_url ];
}
foreach my $perl ($self->filter_perl_available(\@perllist)) {
# We only want to add a Metacpan link if the www.cpan.org link
# doesn't exist, and this assures that we do that properly.
if (!exists($perls->{ $perl->[0] })) {
$perls->{ $perl->[0] } = $perl->[1];
}
}
# cperl releases: https://github.com/perl11/cperl/tags
my $cperl_remote = 'https://github.com';
my $url_cperl_release_list = $cperl_remote . '/perl11/cperl/tags';
$html = http_get($url_cperl_release_list);
if ($html) {
while ($html =~ m{href="(/perl11/cperl/archive/cperl-(5.+?)\.tar\.gz)"}xg) {
$perls->{ "cperl-$2" } = $cperl_remote . $1;
}
} else {
if ($self->{verbose}) {
warn "\nWARN: Unable to retrieve the list of cperl releases.\n\n";
}
}
return $perls;
}
# $perllist is an arrayref of arrayrefs. The inner arrayrefs are of the
# format: [ <perl_name>, <perl_url> ]
# perl_name = something like perl-5.28.0
# perl_url = URL the Perl is available from.
#
# If $self->{all} is true, this just returns a list of the contents of
# the list referenced by $perllist
#
# Otherwise, this looks for even middle numbers in the version and no
# suffix (like -RC1) following the URL, and returns the list of
# arrayrefs that so match
#
# If any "newest" Perl has a
sub filter_perl_available {
my ($self, $perllist) = @_;
if ($self->{all}) { return @$perllist; }
my %max_release;
foreach my $perl (@$perllist) {
my $ver = $perl->[0];
if ($ver !~ m/^perl-5\.[0-9]*[02468]\.[0-9]+$/) { next; } # most likely TRIAL or RC, or a DEV release
my ($release_line, $minor) = $ver =~ m/^perl-5\.([0-9]+)\.([0-9]+)/;
if (exists $max_release{$release_line}) {
if ($max_release{$release_line}->[0] > $minor) { next; } # We have a newer release
}
$max_release{$release_line} = [ $minor, $perl ];
}
return map { $_->[1] } values %max_release;
}
sub perl_release {
my ($self, $version) = @_;
my $mirror = $self->cpan_mirror();
# try CPAN::Perl::Releases
my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
my $x = (values %$tarballs)[0];
if ($x) {
my $dist_tarball = (split("/", $x))[-1];
my $dist_tarball_url = "$mirror/authors/id/$x";
return ($dist_tarball, $dist_tarball_url);
}
# try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz
my $index = http_get("http://www.cpan.org/src/5.0/");
if ($index) {
for my $prefix ("perl-", "perl") {
for my $suffix (".tar.bz2", ".tar.gz") {
my $dist_tarball = "$prefix$version$suffix";
my $dist_tarball_url = "$mirror/src/5.0/$dist_tarball";
return ($dist_tarball, $dist_tarball_url)
if ($index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms);
}
}
}
my $json = http_get("'https://fastapi.metacpan.org/v1/release/_search?size=1&q=name:perl-${version}'");
my $result;
unless ($json and $result = decode_json($json)->{hits}{hits}[0]) {
die "ERROR: Failed to locate perl-${version} tarball.";
}
my ($dist_path, $dist_tarball) =
$result->{_source}{download_url} =~ m[(/authors/id/.+/(perl-${version}.tar.(gz|bz2|xz)))$];
die "ERROR: Cannot find the tarball for perl-$version\n"
if !$dist_path and !$dist_tarball;
my $dist_tarball_url = "https://cpan.metacpan.org${dist_path}";
return ($dist_tarball, $dist_tarball_url);
}
sub cperl_release {
my ($self, $version) = @_;
my %url = (
"5.22.3" => "https://github.com/perl11/cperl/releases/download/cperl-5.22.3/cperl-5.22.3.tar.gz",
"5.22.2" => "https://github.com/perl11/cperl/releases/download/cperl-5.22.2/cperl-5.22.2.tar.gz",
"5.24.0-RC1" => "https://github.com/perl11/cperl/releases/download/cperl-5.24.0-RC1/cperl-5.24.0-RC1.tar.gz",
);
# my %digest => {
# "5.22.3" => "bcf494a6b12643fa5e803f8e0d9cef26312b88fc",
# "5.22.2" => "8615964b0a519cf70d69a155b497de98e6a500d0",
# };
my $dist_tarball_url = $url{$version}or die "ERROR: Cannot find the tarball for cperl-$version\n";
my $dist_tarball = "cperl-${version}.tar.gz";
return ($dist_tarball, $dist_tarball_url);
}
sub release_detail_perl_local {
my ($self, $dist, $rd) = @_;
$rd ||= {};
my $error = 1;
my $mirror = $self->cpan_mirror();
my $tarballs = CPAN::Perl::Releases::perl_tarballs($rd->{version});
if (keys %$tarballs) {
for ("tar.bz2", "tar.gz") {
if (my $x = $tarballs->{$_}) {
$rd->{tarball_name} = (split("/", $x))[-1];
$rd->{tarball_url} = "$mirror/authors/id/$x";
$error = 0;
last;
}
}
}
return ($error, $rd);
}
sub release_detail_perl_remote {
my ($self, $dist, $rd) = @_;
$rd ||= {};
my $error = 1;
my $mirror = $self->cpan_mirror();
my $version = $rd->{version};
# try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz
my $index = http_get("http://www.cpan.org/src/5.0/");
if ($index) {
for my $prefix ("perl-", "perl") {
for my $suffix (".tar.bz2", ".tar.gz") {
my $dist_tarball = "$prefix$version$suffix";
my $dist_tarball_url = "$mirror/src/5.0/$dist_tarball";
if ($index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms) {
$rd->{tarball_url} = $dist_tarball_url;
$rd->{tarball_name} = $dist_tarball;
$error = 0;
return ($error, $rd);
}
}
}
}
my $json = http_get("'https://fastapi.metacpan.org/v1/release/_search?size=1&q=name:perl-${version}'");
my $result;
unless ($json and $result = decode_json($json)->{hits}{hits}[0]) {
die "ERROR: Failed to locate perl-${version} tarball.";
}
my ($dist_path, $dist_tarball) =
$result->{_source}{download_url} =~ m[(/authors/id/.+/(perl-${version}.tar.(gz|bz2|xz)))$];
die "ERROR: Cannot find the tarball for perl-$version\n"
if !$dist_path and !$dist_tarball;
my $dist_tarball_url = "https://cpan.metacpan.org${dist_path}";
$rd->{tarball_name} = $dist_tarball;
$rd->{tarball_url} = $dist_tarball_url;
$error = 0;
return ($error, $rd);
}
sub release_detail_cperl_local {
my ($self, $dist, $rd) = @_;
$rd ||= {};
my %url = (
"cperl-5.22.3" => "https://github.com/perl11/cperl/releases/download/cperl-5.22.3/cperl-5.22.3.tar.gz",
"cperl-5.22.2" => "https://github.com/perl11/cperl/releases/download/cperl-5.22.2/cperl-5.22.2.tar.gz",
"cperl-5.24.0-RC1" => "https://github.com/perl11/cperl/releases/download/cperl-5.24.0-RC1/cperl-5.24.0-RC1.tar.gz",
"cperl-5.24.2" => "https://github.com/perl11/cperl/releases/download/cperl-5.24.2/cperl-5.24.2.tar.gz",
"cperl-5.25.2" => "https://github.com/perl11/cperl/releases/download/cperl-5.24.2/cperl-5.25.2.tar.gz",
"cperl-5.26.0" => "https://github.com/perl11/cperl/archive/cperl-5.26.0.tar.gz",
"cperl-5.26.0-RC1" => "https://github.com/perl11/cperl/archive/cperl-5.26.0-RC1.tar.gz",
"cperl-5.27.0" => "https://github.com/perl11/cperl/archive/cperl-5.27.0.tar.gz",
);
my $error = 1;
if (my $u = $url{$dist}) {
$rd->{tarball_name} = "${dist}.tar.gz";
$rd->{tarball_url} = $u;
$error = 0;
}
return ($error, $rd);
}
sub release_detail_cperl_remote {
my ($self, $dist, $rd) = @_;
$rd ||= {};
my $expect_href = "/perl11/cperl/archive/${dist}.tar.gz";
my $html = http_get('https://github.com/perl11/cperl/releases/tag/' . $dist);
my $error = 1;
if ($html =~ m{ <a \s+ href="($expect_href)" }xsi) {
$rd->{tarball_name} = "${dist}.tar.gz";
$rd->{tarball_url} = "https://github.com" . $1;
$error = 0;
} else {
$error = 1;
}
return ($error, $rd);
}
sub release_detail {
my ($self, $dist) = @_;
my ($dist_type, $dist_version);
($dist_type, $dist_version) = $dist =~ /^ (?: (c?perl) -? )? ( [\d._]+ (?:-RC\d+)? |git|stable|blead)$/x;
$dist_type = "perl" if $dist_version && !$dist_type;
my $rd = {
type => $dist_type,
version => $dist_version,
tarball_url => undef,
tarball_name => undef,
};
# dynamic methods: release_detail_perl_local, release_detail_cperl_local, release_detail_perl_remote, release_detail_cperl_remote
my $m_local = "release_detail_${dist_type}_local";
my $m_remote = "release_detail_${dist_type}_remote";
my ($error) = $self->$m_local($dist, $rd);
($error) = $self->$m_remote($dist, $rd) if $error;
if ($error) {
die "ERROR: Fail to get the tarball URL for dist: $dist\n";
}
return $rd;
}
sub run_command_init {
my $self = shift;
my @args = @_;
if (@args && $args[0] eq '-') {
if ($self->current_shell_is_bashish) {
$self->run_command_init_in_bash;
}
exit 0;
}
$_->mkpath for (grep { ! -d $_ } map { $self->root->$_ } qw(perls dists build etc bin));
my ($f, $fh) = @_;
my $etc_dir = $self->root->etc;
for (["bashrc", "BASHRC_CONTENT"],
["cshrc", "CSHRC_CONTENT"],
["csh_reinit", "CSH_REINIT_CONTENT"],
["csh_wrapper", "CSH_WRAPPER_CONTENT"],
["csh_set_path", "CSH_SET_PATH_CONTENT"],
["perlbrew-completion.bash", "BASH_COMPLETION_CONTENT"],
["perlbrew.fish", "PERLBREW_FISH_CONTENT" ],
) {
my ($file_name, $method) = @$_;
my $path = $etc_dir->child ($file_name);
if (! -f $path) {
open($fh, ">", $path) or die "Fail to create $path. Please check the permission of $etc_dir and try `perlbrew init` again.";
print $fh $self->$method;
close $fh;
}
else {
if (-w $path && open($fh, ">", $path)) {
print $fh $self->$method;
close $fh;
}
else {
print "NOTICE: $path already exists and not updated.\n" unless $self->{quiet};
}
}
}
my $root_dir = $self->root->stringify_with_tilde;
# Skip this if we are running in a shell that already 'source's perlbrew.
# This is true during a self-install/self-init.
# Ref. https://github.com/gugod/App-perlbrew/issues/525
if ($ENV{PERLBREW_SHELLRC_VERSION}) {
print("\nperlbrew root ($root_dir) is initialized.\n");
} else {
my $shell = $self->current_shell;
my ($code, $yourshrc);
if ($shell =~ m/(t?csh)/) {
$code = "source $root_dir/etc/cshrc";
$yourshrc = $1 . "rc";
}
elsif ($shell =~ m/zsh\d?$/) {
$code = "source $root_dir/etc/bashrc";
$yourshrc = $self->_firstrcfile(qw(
.zshenv
.bash_profile
.bash_login
.profile
)) || ".zshenv";
}
elsif ($shell =~ m/fish/) {
$code = ". $root_dir/etc/perlbrew.fish";
$yourshrc = 'config/fish/config.fish';
}
else {
$code = "source $root_dir/etc/bashrc";
$yourshrc = $self->_firstrcfile(qw(
.bash_profile
.bash_login
.profile
)) || ".bash_profile";
}
if ($self->home ne App::Perlbrew::Path->new ($self->env('HOME'), ".perlbrew")) {
my $pb_home_dir = $self->home->stringify_with_tilde;
if ( $shell =~ m/fish/ ) {
$code = "set -x PERLBREW_HOME $pb_home_dir\n $code";
} else {
$code = "export PERLBREW_HOME=$pb_home_dir\n $code";
}
}
print <<INSTRUCTION;
perlbrew root ($root_dir) is initialized.
Append the following piece of code to the end of your ~/${yourshrc} and start a
new shell, perlbrew should be up and fully functional from there:
$code
Simply run `perlbrew` for usage details.
Happy brewing!
INSTRUCTION
}
}
sub run_command_init_in_bash {
print BASHRC_CONTENT();
}
sub run_command_self_install {
my $self = shift;
my $executable = $0;
my $target = $self->root->bin ("perlbrew");
if (files_are_the_same($executable, $target)) {
print "You are already running the installed perlbrew:\n\n $executable\n";
exit;
}
$self->root->bin->mkpath;
open my $fh, "<", $executable;
my @lines = <$fh>;
close $fh;
$lines[0] = $self->system_perl_shebang . "\n";
open $fh, ">", $target;
print $fh $_ for @lines;
close $fh;
chmod(0755, $target);
my $path = $target->stringify_with_tilde;
print "perlbrew is installed: $path\n" unless $self->{quiet};
$self->run_command_init();
return;
}
sub do_install_git {
my ($self, $dist) = @_;
my $dist_name;
my $dist_git_describe;
my $dist_version;
opendir my $cwd_orig, ".";
chdir $dist;
if (`git describe` =~ /v((5\.\d+\.\d+(?:-RC\d)?)(-\d+-\w+)?)$/) {
$dist_name = 'perl';
$dist_git_describe = "v$1";
$dist_version = $2;
}
chdir $cwd_orig;
require File::Spec;
my $dist_extracted_dir = File::Spec->rel2abs($dist);
$self->do_install_this(App::Perlbrew::Path->new ($dist_extracted_dir), $dist_version, "$dist_name-$dist_version");
return;
}
sub do_install_url {
my ($self, $dist) = @_;
my $dist_name = 'perl';
# need the period to account for the file extension
my ($dist_version) = $dist =~ m/-([\d.]+(?:-RC\d+)?|git)\./;
my ($dist_tarball) = $dist =~ m{/([^/]*)$};
if (! $dist_version && $dist =~ /blead\.tar.gz$/) {
$dist_version = "blead";
}
my $dist_tarball_path = $self->root->dists($dist_tarball);
my $dist_tarball_url = $dist;
$dist = "$dist_name-$dist_version"; # we install it as this name later
if ($dist_tarball_url =~ m/^file/) {
print "Installing $dist from local archive $dist_tarball_url\n";
$dist_tarball_url =~ s/^file:\/+/\//;
$dist_tarball_path = $dist_tarball_url;
}
else {
print "Fetching $dist as $dist_tarball_path\n";
my $error = http_download($dist_tarball_url, $dist_tarball_path);
die "ERROR: Failed to download $dist_tarball_url\n$error\n" if $error;
}
my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
$self->do_install_this($dist_extracted_path, $dist_version, $dist);
return;
}
sub do_extract_tarball {
my ($self, $dist_tarball) = @_;
# Assuming the dir extracted from the tarball is named after the tarball.
my $dist_tarball_basename = $dist_tarball->basename (qr/\.tar\.(?:gz|bz2|xz)$/);
# Note that this is incorrect for blead.
my $workdir = $self->builddir->child ($dist_tarball_basename);
$workdir->rmpath;
$workdir->mkpath;
my $extracted_dir;
# Was broken on Solaris, where GNU tar is probably
# installed as 'gtar' - RT #61042
my $tarx =
($^O =~ /solaris|aix/ ? 'gtar ' : 'tar ') .
( $dist_tarball =~ m/xz$/ ? 'xJf' :
$dist_tarball =~ m/bz2$/ ? 'xjf' : 'xzf' );
my $extract_command = "cd $workdir; $tarx $dist_tarball";
die "Failed to extract $dist_tarball" if system($extract_command);
my @things = $workdir->children;
if (@things == 1) {
$extracted_dir = App::Perlbrew::Path->new ($things[0]);
}
unless (defined($extracted_dir) && -d $extracted_dir) {
die "Failed to find the extracted directory under $workdir";
}
return $extracted_dir;
}
sub do_install_blead {
my ($self) = @_;
# We always blindly overwrite anything that's already there,
# because blead is a moving target.
my $dist_tarball_path = $self->root->dists("blead.tar.gz");
unlink($dist_tarball_path) if -f $dist_tarball_path;
$self->do_install_url("https://github.com/Perl/perl5/archive/blead.tar.gz");
}
sub resolve_stable_version {
my ($self) = @_;
my ($latest_ver, $latest_minor);
for my $cand ($self->available_perls) {
my ($ver, $minor) = $cand =~ m/^perl-(5\.(6|8|[0-9]+[02468])\.[0-9]+)$/
or next;
($latest_ver, $latest_minor) = ($ver, $minor)
if !defined $latest_minor
|| $latest_minor < $minor;
}
die "Can't determine latest stable Perl release\n"
if !defined $latest_ver;
return $latest_ver;
}
sub do_install_release {
my ($self, $dist, $dist_version) = @_;
my $rd = $self->release_detail($dist);
my $dist_type = $rd->{type};
die "\"$dist\" does not look like a perl distribution name. " unless $dist_type && $dist_version =~ /^\d\./;
my $dist_tarball = $rd->{tarball_name};
my $dist_tarball_url = $rd->{tarball_url};
my $dist_tarball_path = $self->root->dists ($dist_tarball);
if (-f $dist_tarball_path) {
print "Using the previously fetched ${dist_tarball}\n"
if $self->{verbose};
}
else {
print "Fetching perl $dist_version as $dist_tarball_path\n" unless $self->{quiet};
$self->run_command_download($dist);
}
my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
$self->do_install_this($dist_extracted_path, $dist_version, $dist);
return;
}
sub run_command_install {
my ($self, $dist, $opts) = @_;
unless ($dist) {
$self->run_command_help("install");
exit(-1);
}
$self->{dist_name} = $dist; # for help msg generation, set to non
# normalized name
my ($dist_type, $dist_version);
if (($dist_type, $dist_version) = $dist =~ /^(?:(c?perl)-?)?([\d._]+(?:-RC\d+)?|git|stable|blead)$/) {
$dist_version = $self->resolve_stable_version if $dist_version eq 'stable';
$dist_type ||= "perl";
$dist = "${dist_type}-${dist_version}"; # normalize dist name
my $installation_name = ($self->{as} || $dist) . $self->{variation} . $self->{append};
if (not $self->{force} and $self->is_installed($installation_name)) {
die "\nABORT: $installation_name is already installed.\n\n";
}
if ($dist_type eq 'perl' && $dist_version eq 'blead') {
$self->do_install_blead();
}
else {
$self->do_install_release($dist, $dist_version);
}
}
# else it is some kind of special install:
elsif (-d "$dist/.git") {
$self->do_install_git($dist);
}
elsif (-f $dist) {
$self->do_install_archive(App::Perlbrew::Path->new ($dist));
}
elsif ($dist =~ m/^(?:https?|ftp|file)/) { # more protocols needed?
$self->do_install_url($dist);
}
else {
die "Unknown installation target \"$dist\", abort.\nPlease see `perlbrew help` " .
"for the instruction on using the install command.\n\n";
}
if ($self->{switch}) {
if (defined(my $installation_name = $self->{installation_name})) {
$self->switch_to($installation_name)
}
else {
warn "can't switch, unable to infer final destination name.\n\n";
}
}
return;
}
sub check_and_calculate_variations {
my $self = shift;
my @both = @{$self->{both}};
if ($self->{'all-variations'}) {
@both = keys %flavor;
}
elsif ($self->{'common-variations'}) {
push @both, grep $flavor{$_}{common}, keys %flavor;
}
# check the validity of the varitions given via 'both'
for my $both (@both) {
$flavor{$both} or die "$both is not a supported flavor.\n\n";
$self->{$both} and die "options --both $both and --$both can not be used together";
if (my $implied_by = $flavor{$both}{implied_by}) {
$self->{$implied_by} and die "options --both $both and --$implied_by can not be used together";
}
}
# flavors selected always
my $start = '';
$start .= "-$_" for grep $self->{$_}, keys %flavor;
# make variations
my @var = $start;
for my $both (@both) {
my $append = join('-', $both, grep defined, $flavor{$both}{implies});
push @var, map "$_-$append", @var;
}
# normalize the variation names
@var = map { join '-', '', sort { $flavor{$a}{ix} <=> $flavor{$b}{ix} } grep length, split /-+/, $_ } @var;
s/(\b\w+\b)(?:-\1)+/$1/g for @var; # remove duplicate flavors
# After inspecting perl Configure script this seems to be the most
# reliable heuristic to determine if perl would have 64bit IVs by
# default or not:
if ($Config::Config{longsize} >= 8) {
# We are in a 64bit platform. 64int and 64all are always set but
# we don't want them to appear on the final perl name
s/-64\w+//g for @var;
}
# remove duplicated variations
my %var = map { $_ => 1 } @var;
sort keys %var;
}
sub run_command_install_multiple {
my ($self, @dists) = @_;
unless (@dists) {
$self->run_command_help("install-multiple");
exit(-1);
}
die "--switch can not be used with command install-multiple.\n\n"
if $self->{switch};
die "--as can not be used when more than one distribution is given.\n\n"
if $self->{as} and @dists > 1;
my @variations = $self->check_and_calculate_variations;
print join("\n",
"Compiling the following distributions:",
map(" $_$self->{append}", @dists),
" with the following variations:",
map((/-(.*)/ ? " $1" : " default"), @variations),
"", "");
my @ok;
for my $dist (@dists) {
for my $variation (@variations) {
local $@;
eval {
$self->{$_} = '' for keys %flavor;
$self->{$_} = 1 for split /-/, $variation;
$self->{variation} = $variation;
$self->{installation_name} = undef;
$self->run_command_install($dist);
push @ok, $self->{installation_name};
};
if ($@) {
$@ =~ s/\n+$/\n/;
print "Installation of $dist$variation failed: $@";
}
}
}
print join("\n",
"",
"The following perls have been installed:",
map (" $_", grep defined, @ok),
"", "");
return
}
sub run_command_download {
my ($self, $dist) = @_;
$dist = $self->resolve_stable_version
if $dist && $dist eq 'stable';
my $rd = $self->release_detail($dist);
my $dist_tarball = $rd->{tarball_name};
my $dist_tarball_url = $rd->{tarball_url};
my $dist_tarball_path = $self->root->dists ($dist_tarball);
if (-f $dist_tarball_path && !$self->{force}) {
print "$dist_tarball already exists\n";
}
else {
print "Download $dist_tarball_url to $dist_tarball_path\n" unless $self->{quiet};
my $error = http_download($dist_tarball_url, $dist_tarball_path);
if ($error) {
die "ERROR: Failed to download $dist_tarball_url\n$error\n";
}
}
}
sub purify {
my ($self, $envname) = @_;
my @paths = grep { index($_, $self->home) < 0 && index($_, $self->root) < 0 } split /:/, $self->env($envname);
return wantarray ? @paths : join(":", @paths);
}
sub system_perl_executable {
my ($self) = @_;
my $system_perl_executable = do {
local $ENV{PATH} = $self->pristine_path;
`perl -MConfig -e 'print \$Config{perlpath}'`
};
return $system_perl_executable;
}
sub system_perl_shebang {
my ($self) = @_;
return $Config{sharpbang}. $self->system_perl_executable;
}
sub pristine_path {
my ($self) = @_;
return $self->purify("PATH");
}
sub pristine_manpath {
my ($self) = @_;
return $self->purify("MANPATH");
}
sub run_command_display_system_perl_executable {
print $_[0]->system_perl_executable . "\n";
}
sub run_command_display_system_perl_shebang {
print $_[0]->system_perl_shebang . "\n";
}
sub run_command_display_pristine_path {
print $_[0]->pristine_path . "\n";
}
sub run_command_display_pristine_manpath {
print $_[0]->pristine_manpath . "\n";
}
sub do_install_archive {
require File::Basename;
my $self = shift;
my $dist_tarball_path = shift;
my $dist_version;
my $installation_name;
if ($dist_tarball_path->basename =~ m{(c?perl)-?(5.+)\.tar\.(gz|bz2|xz)\Z}) {
my $perl_variant = $1;
$dist_version = $2;
$installation_name = "${perl_variant}-${dist_version}";
}
unless ($dist_version && $installation_name) {
die "Unable to determine perl version from archive filename.\n\nThe archive name should look like perl-5.x.y.tar.gz or perl-5.x.y.tar.bz2 or perl-5.x.y.tar.xz\n";
}
my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
$self->do_install_this($dist_extracted_path, $dist_version, $installation_name);
}
sub do_install_this {
my ($self, $dist_extracted_dir, $dist_version, $installation_name) = @_;
my $variation = $self->{variation};
my $append = $self->{append};
my $looks_like_we_are_installing_cperl = $dist_extracted_dir =~ /\/ cperl- /x;
$self->{dist_extracted_dir} = $dist_extracted_dir;
$self->{log_file} = $self->root->child ("build.${installation_name}${variation}${append}.log");
my @d_options = @{ $self->{D} };
my @u_options = @{ $self->{U} };
my @a_options = @{ $self->{A} };
my $sitecustomize = $self->{sitecustomize};
my $destdir = $self->{destdir};
$installation_name = $self->{as} if $self->{as};
$installation_name .= "$variation$append";
$self->{installation_name} = $installation_name;
if ($sitecustomize) {
die "Could not read sitecustomize file '$sitecustomize'\n"
unless -r $sitecustomize;
push @d_options, "usesitecustomize";
}
if ($self->{noman}) {
push @d_options, qw/man1dir=none man3dir=none/;
}
for my $flavor (keys %flavor) {
$self->{$flavor} and push @d_options, $flavor{$flavor}{d_option}
}
my $perlpath = $self->root->perls ($installation_name);
my $patchperl = $self->root->bin ("patchperl");
unless (-x $patchperl && -f _) {
$patchperl = "patchperl";
}
unshift @d_options, qq(prefix=$perlpath);
push @d_options, "usedevel" if $dist_version =~ /5\.\d[13579]|git|blead/;
push @d_options, "usecperl" if $looks_like_we_are_installing_cperl;
my $version = $self->comparable_perl_version($dist_version);
if (defined $version and $version < $self->comparable_perl_version('5.6.0')) {
# ancient perls do not support -A for Configure
@a_options = ();
} else {
unless (grep { /eval:scriptdir=/} @a_options) {
push @a_options, "'eval:scriptdir=${perlpath}/bin'";
}
}
print "Installing $dist_extracted_dir into " . $self->root->perls ($installation_name)->stringify_with_tilde . "\n\n";
print <<INSTALL if !$self->{verbose};
This could take a while. You can run the following command on another shell to track the status:
tail -f ${\ $self->{log_file}->stringify_with_tilde }
INSTALL
my @preconfigure_commands = (
"cd $dist_extracted_dir",
"rm -f config.sh Policy.sh",
);
push @preconfigure_commands, 'chmod -R +w .', $patchperl unless $self->{"no-patchperl"} || $looks_like_we_are_installing_cperl;
my $configure_flags = $self->env("PERLBREW_CONFIGURE_FLAGS") || '-de';
my @configure_commands = (
"sh Configure $configure_flags " .
join( ' ',
( map { qq{'-D$_'} } @d_options ),
( map { qq{'-U$_'} } @u_options ),
( map { qq{'-A$_'} } @a_options ),
),
(defined $version and $version < $self->comparable_perl_version('5.8.9'))
? ("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile")
: ()
);
my $make = $ENV{MAKE} || ($^O eq "solaris" ? 'gmake' : 'make');
my @build_commands = (
$make . ' ' . ($self->{j} ? "-j$self->{j}" : "")
);
# Test via "make test_harness" if available so we'll get
# automatic parallel testing via $HARNESS_OPTIONS. The
# "test_harness" target was added in 5.7.3, which was the last
# development release before 5.8.0.
my $test_target = "test";
if ($dist_version =~ /^5\.(\d+)\.(\d+)/
&& ($1 >= 8 || $1 == 7 && $2 == 3)) {
$test_target = "test_harness";
}
local $ENV{TEST_JOBS}=$self->{j}
if $test_target eq "test_harness" && ($self->{j}||1) > 1;
my @install_commands = ("${make} install" . ($destdir ? " DESTDIR=$destdir" : q||));
unshift @install_commands, "${make} $test_target" unless $self->{notest};
# Whats happening here? we optionally join with && based on $self->{force}, but then subsequently join with && anyway?
@install_commands = join " && ", @install_commands unless ($self->{force});
my $cmd = join " && ",
(
@preconfigure_commands,
@configure_commands,
@build_commands,
@install_commands
);
$self->{log_file}->unlink;
if ($self->{verbose}) {
$cmd = "($cmd) 2>&1 | tee $self->{log_file}";
print "$cmd\n" if $self->{verbose};
} else {
$cmd = "($cmd) >> '$self->{log_file}' 2>&1 ";
}
delete $ENV{$_} for qw(PERL5LIB PERL5OPT AWKPATH);
if ($self->do_system($cmd)) {
my $newperl = $self->root->perls ($installation_name)->perl;
unless (-e $newperl) {
$self->run_command_symlink_executables($installation_name);
}
eval { $self->append_log('##### Brew Finished #####') };
if ($sitecustomize) {
my $capture = $self->do_capture("$newperl -V:sitelib");
my ($sitelib) = $capture =~ m/sitelib='([^']*)';/;
$sitelib = $destdir . $sitelib if $destdir;
$sitelib = App::Perlbrew::Path->new ($sitelib);
$sitelib->mkpath;
my $target = $sitelib->child ("sitecustomize.pl");
open my $dst, ">", $target
or die "Could not open '$target' for writing: $!\n";
open my $src, "<", $sitecustomize
or die "Could not open '$sitecustomize' for reading: $!\n";
print {$dst} do { local $/; <$src> };
}
my $version_file =
$self->root->perls ($installation_name)->version_file;
if (-e $version_file) {
$version_file->unlink
or die "Could not unlink $version_file file: $!\n";
}
print "$installation_name is successfully installed.\n";
}
else {
eval { $self->append_log('##### Brew Failed #####') };
die $self->INSTALLATION_FAILURE_MESSAGE;
}
return;
}
sub do_install_program_from_url {
my ($self, $url, $program_name, $body_filter) = @_;
my $out = $self->root->bin ($program_name);
if (-f $out && !$self->{force} && !$self->{yes}) {
require ExtUtils::MakeMaker;
my $ans = ExtUtils::MakeMaker::prompt("\n$out already exists, are you sure to override ? [y/N]", "N");
if ($ans !~ /^Y/i) {
print "\n$program_name installation skipped.\n\n" unless $self->{quiet};
return;
}
}
my $body = http_get($url) or die "\nERROR: Failed to retrieve $program_name executable.\n\n";
unless ($body =~ m{\A#!/}s) {
my $x = App::Perlbrew::Path->new ($self->env('TMPDIR') || "/tmp", "${program_name}.downloaded.$$");
my $message = "\nERROR: The downloaded $program_name program seem to be invalid. Please check if the following URL can be reached correctly\n\n\t$url\n\n...and try again latter.";
unless (-f $x) {
open my $OUT, ">", $x;
print $OUT $body;
close($OUT);
$message .= "\n\nThe previously downloaded file is saved at $x for manual inspection.\n\n";
}
die $message;
}
if ($body_filter && ref($body_filter) eq "CODE") {
$body = $body_filter->($body);
}
$self->root->bin->mkpath;
open my $OUT, '>', $out or die "cannot open file($out): $!";
print $OUT $body;
close $OUT;
chmod 0755, $out;
print "\n$program_name is installed to\n\n $out\n\n" unless $self->{quiet};
}
sub do_exit_with_error_code {
my ($self, $code) = @_;
exit($code);
}
sub do_system_with_exit_code {
my ($self, @cmd) = @_;
return system(@cmd);
}
sub do_system {
my ($self, @cmd) = @_;
return ! $self->do_system_with_exit_code(@cmd);
}
sub do_capture {
my ($self, @cmd) = @_;
require Capture::Tiny;
return Capture::Tiny::capture(sub {
$self->do_system(@cmd);
});
}
sub format_perl_version {
my $self = shift;
my $version = shift;
return sprintf "%d.%d.%d",
substr($version, 0, 1),
substr($version, 2, 3),
substr($version, 5) || 0;
}
sub installed_perls {
my $self = shift;
my @result;
my $root = $self->root;
for my $installation ($root->perls->list) {
my $name = $installation->name;
my $executable = $installation->perl;
next unless -f $executable;
my $version_file = $installation->version_file;
my $ctime = localtime((stat $executable)[ 10 ]); # localtime in scalar context!
my $orig_version;
if (-e $version_file) {
open my $fh, '<', $version_file;
local $/;
$orig_version = <$fh>;
chomp $orig_version;
} else {
$orig_version = `$executable -e 'print \$]'`;
if (defined $orig_version and length $orig_version) {
if (open my $fh, '>', $version_file ) {
print {$fh} $orig_version;
}
}
}
push @result, {
name => $name,
orig_version=> $orig_version,
version => $self->format_perl_version($orig_version),
is_current => ($self->current_perl eq $name) && !($self->current_lib),
libs => [ $self->local_libs($name) ],
executable => $executable,
dir => $installation,
comparable_version => $self->comparable_perl_version($orig_version),
ctime => $ctime,
};
}
return sort { ( $self->{reverse}
? ( $a->{comparable_version} <=> $b->{comparable_version} or $b->{name} cmp $a->{name} )
: ( $b->{comparable_version} <=> $a->{comparable_version} or $a->{name} cmp $b->{name} ) ) } @result;
}
sub compose_locallib {
my ($self, $perl_name, $lib_name) = @_;
return join '@', $perl_name, $lib_name;
}
sub decompose_locallib {
my ($self, $name) = @_;
return split '@', $name;
}
sub enforce_localib {
my ($self, $name) = @_;
$name =~ s/^/@/ unless $name =~ m/@/;
return $name;
}
sub local_libs {
my ($self, $perl_name) = @_;
my $current = $self->current_env;
my @libs = map {
my $name = $_->basename;
my ($p, $l) = $self->decompose_locallib ($name);
+{
name => $name,
is_current => $name eq $current,
perl_name => $p,
lib_name => $l,
dir => $_,
}
} $self->home->child ("libs")->children;
if ($perl_name) {
@libs = grep { $perl_name eq $_->{perl_name} } @libs;
}
return @libs;
}
sub is_installed {
my ($self, $name) = @_;
return grep { $name eq $_->{name} } $self->installed_perls;
}
sub assert_known_installation {
my ($self, $name) = @_;
return 1 if $self->is_installed($name);
die "ERROR: The installation \"$name\" is unknown\n\n";
}
# Return a hash of PERLBREW_* variables
sub perlbrew_env {
my ($self, $name) = @_;
my ($perl_name, $lib_name);
if ($name) {
($perl_name, $lib_name) = $self->resolve_installation_name($name);
unless ($perl_name) {
die "\nERROR: The installation \"$name\" is unknown.\n\n";
}
unless (!$lib_name || grep { $_->{lib_name} eq $lib_name } $self->local_libs($perl_name)) {
die "\nERROR: The lib name \"$lib_name\" is unknown.\n\n";
}
}
my %env = (
PERLBREW_VERSION => $VERSION,
PERLBREW_PATH => $self->root->bin,
PERLBREW_MANPATH => "",
PERLBREW_ROOT => $self->root
);
require local::lib;
my $pb_home = $self->home;
my $current_local_lib_root = $self->env("PERL_LOCAL_LIB_ROOT") || "";
my $current_local_lib_context = local::lib->new;
my @perlbrew_local_lib_root = uniq(grep { /\Q${pb_home}\E/ } split(/:/, $current_local_lib_root));
if ($current_local_lib_root =~ /^\Q${pb_home}\E/) {
$current_local_lib_context = $current_local_lib_context->activate($_) for @perlbrew_local_lib_root;
}
if ($perl_name) {
my $installation = $self->root->perls ($perl_name);
if(-d $installation->child("bin")) {
$env{PERLBREW_PERL} = $perl_name;
$env{PERLBREW_PATH} .= ":" . $installation->child ("bin");
$env{PERLBREW_MANPATH} = $installation->child ("man")
}
if ($lib_name) {
$current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root;
my $base = $self->home->child ("libs", "${perl_name}\@${lib_name}");
if (-d $base) {
$current_local_lib_context = $current_local_lib_context->activate($base);
if ($self->env('PERLBREW_LIB_PREFIX')) {
unshift
@{$current_local_lib_context->libs},
$self->env('PERLBREW_LIB_PREFIX');
}
$env{PERLBREW_PATH} = $base->child ("bin") . ":" . $env{PERLBREW_PATH};
$env{PERLBREW_MANPATH} = $base->child ("man") . ":" . $env{PERLBREW_MANPATH};
$env{PERLBREW_LIB} = $lib_name;
}
} else {
$current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root;
$env{PERLBREW_LIB} = undef;
}
my %ll_env = $current_local_lib_context->build_environment_vars;
delete $ll_env{PATH};
for my $key (keys %ll_env) {
$env{$key} = $ll_env{$key};
}
} else {
$current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root;
my %ll_env = $current_local_lib_context->build_environment_vars;
delete $ll_env{PATH};
for my $key (keys %ll_env) {
$env{$key} = $ll_env{$key};
}
$env{PERLBREW_LIB} = undef;
$env{PERLBREW_PERL} = undef;
}
return %env;
}
sub run_command_list {
my $self = shift;
my $is_verbose = $self->{verbose};
for my $i ($self->installed_perls) {
printf "%-2s%-20s %-20s %s\n",
$i->{is_current} ? '*' : '',
$i->{name},
( $is_verbose ?
(index($i->{name}, $i->{version}) < 0) ? "($i->{version})" : ''
: '' ),
( $is_verbose ? "(installed on $i->{ctime})" : '' );
for my $lib (@{$i->{libs}}) {
print $lib->{is_current} ? "* " : " ",
$lib->{name}, "\n"
}
}
return 0;
}
sub launch_sub_shell {
my ($self, $name) = @_;
my $shell = $self->env('SHELL');
my $shell_opt = "";
if ($shell =~ /\/zsh\d?$/) {
$shell_opt = "-d -f";
if ($^O eq 'darwin') {
my $root_dir = $self->root;
print <<"WARNINGONMAC"
--------------------------------------------------------------------------------
WARNING: zsh perlbrew sub-shell is not working on Mac OSX Lion.
It is known that on MacOS Lion, zsh always resets the value of PATH on launching
a sub-shell. Effectively nullify the changes required by perlbrew sub-shell. You
may `echo \$PATH` to examine it and if you see perlbrew related paths are in the
end, instead of in the beginning, you are unfortunate.
You are advised to include the following line to your ~/.zshenv as a better
way to work with perlbrew:
source $root_dir/etc/bashrc
--------------------------------------------------------------------------------
WARNINGONMAC
}
}
my %env = ($self->perlbrew_env($name), PERLBREW_SKIP_INIT => 1);
unless ($ENV{PERLBREW_VERSION}) {
my $root = $self->root;
# The user does not source bashrc/csh in their shell initialization.
$env{PATH} = $env{PERLBREW_PATH} . ":" . join ":", grep { !/$root\/bin/ } split ":", $ENV{PATH};
$env{MANPATH} = $env{PERLBREW_MANPATH} . ":" . join ":", grep { !/$root\/man/ }
( defined($ENV{MANPATH}) ? split(":", $ENV{MANPATH}) : () );
}
my $command = "env ";
while (my ($k, $v) = each(%env)) {
no warnings "uninitialized";
$command .= "$k=\"$v\" ";
}
$command .= " $shell $shell_opt";
my $pretty_name = defined($name) ? $name : "the default perl";
print "\nA sub-shell is launched with $pretty_name as the activated perl. Run 'exit' to finish it.\n\n";
exec($command);
}
sub run_command_use {
my $self = shift;
my $perl = shift;
if ( !$perl ) {
my $current = $self->current_env;
if ($current) {
print "Currently using $current\n";
} else {
print "No version in use; defaulting to system\n";
}
return;
}
$self->launch_sub_shell($perl);
}
sub run_command_switch {
my ($self, $dist, $alias) = @_;
unless ( $dist ) {
my $current = $self->current_env;
printf "Currently switched %s\n",
( $current ? "to $current" : 'off' );
return;
}
$self->switch_to($dist, $alias);
}
sub switch_to {
my ($self, $dist, $alias) = @_;
die "Cannot use for alias something that starts with 'perl-'\n"
if $alias && $alias =~ /^perl-/;
die "${dist} is not installed\n" unless -d $self->root->perls ($dist);
if ($self->env("PERLBREW_SHELLRC_VERSION") && $self->current_shell_is_bashish) {
local $ENV{PERLBREW_PERL} = $dist;
my $HOME = $self->env('HOME');
my $pb_home = $self->home;
$pb_home->mkpath;
system("$0 env $dist > " . $pb_home->child ("init"));
print "Switched to $dist.\n\n";
}
else {
$self->launch_sub_shell($dist);
}
}
sub run_command_off {
my $self = shift;
$self->launch_sub_shell;
}
sub run_command_switch_off {
my $self = shift;
my $pb_home = $self->home;
$pb_home->mkpath;
system("env PERLBREW_PERL= $0 env > " . $pb_home->child ("init"));
print "\nperlbrew is switched off. Please exit this shell and start a new one to make it effective.\n";
print "To immediately make it effective, run this line in this terminal:\n\n exec @{[ $self->env('SHELL') ]}\n\n";
}
sub run_command_env {
my($self, $name) = @_;
my %env = $self->perlbrew_env($name);
my @statements;
for my $k (sort keys %env) {
my $v = $env{$k};
if (defined($v) && $v ne '') {
$v =~ s/(\\")/\\$1/g;
push @statements, ["set", $k, $v];
} else {
if (exists $ENV{$k}) {
push @statements, ["unset", $k];
}
}
}
if ($self->env('SHELL') =~ /(ba|k|z|\/)sh\d?$/) {
for (@statements) {
my ($o, $k, $v) = @$_;
if ($o eq 'unset') {
print "unset $k\n";
} else {
$v =~ s/(\\")/\\$1/g;
print "export $k=\"$v\"\n";
}
}
} else {
for (@statements) {
my ($o, $k, $v) = @$_;
if ($o eq 'unset') {
print "unsetenv $k\n";
} else {
print "setenv $k \"$v\"\n";
}
}
}
}
sub run_command_symlink_executables {
my($self, @perls) = @_;
my $root = $self->root;
unless (@perls) {
@perls = map { $_->name } grep { -d $_ && ! -l $_ } $root->perls->list;
}
for my $perl (@perls) {
for my $executable ($root->perls ($perl)->bin->children) {
my ($name, $version) = $executable =~ m/bin\/(.+?)(5\.\d.*)?$/;
next unless $version;
$executable->symlink ($root->perls ($perl)->bin($name));
$executable->symlink ($root->perls ($perl)->perl) if $name eq "cperl";
}
}
}
sub run_command_install_patchperl {
my ($self) = @_;
$self->do_install_program_from_url(
'https://raw.githubusercontent.com/gugod/patchperl-packing/master/patchperl',
'patchperl',
sub {
my ($body) = @_;
$body =~ s/\A#!.+?\n/ $self->system_perl_shebang . "\n" /se;
return $body;
}
);
}
sub run_command_install_cpanm {
my ($self) = @_;
$self->do_install_program_from_url('https://raw.githubusercontent.com/miyagawa/cpanminus/master/cpanm' => 'cpanm');
}
sub run_command_install_cpm {
my ($self) = @_;
$self->do_install_program_from_url('https://raw.githubusercontent.com/skaji/cpm/master/cpm' => 'cpm');
}
sub run_command_self_upgrade {
my ($self) = @_;
my $TMPDIR = $ENV{TMPDIR} || "/tmp";
my $TMP_PERLBREW = App::Perlbrew::Path->new ($TMPDIR, "perlbrew");
require FindBin;
unless (-w $FindBin::Bin) {
die "Your perlbrew installation appears to be system-wide. Please upgrade through your package manager.\n";
}
http_get('https://raw.githubusercontent.com/gugod/App-perlbrew/master/perlbrew', undef, sub {
my ($body) = @_;
open my $fh, '>', $TMP_PERLBREW or die "Unable to write perlbrew: $!";
print $fh $body;
close $fh;
});
chmod 0755, $TMP_PERLBREW;
my $new_version = qx($TMP_PERLBREW version);
chomp $new_version;
if ($new_version =~ /App::perlbrew\/(\d+\.\d+)$/) {
$new_version = $1;
} else {
die "Unable to detect version of new perlbrew!\n";
}
if ($new_version <= $VERSION) {
print "Your perlbrew is up-to-date.\n";
return;
}
system $TMP_PERLBREW, "self-install";
$TMP_PERLBREW->unlink;
}
sub run_command_uninstall {
my ($self, $target) = @_;
unless ($target) {
$self->run_command_help("uninstall");
exit(-1);
}
my @installed = $self->installed_perls(@_);
my ($to_delete) = grep { $_->{name} eq $target } @installed;
die "'$target' is not installed\n" unless $to_delete;
my @dir_to_delete;
for (@{$to_delete->{libs}}) {
push @dir_to_delete, $_->{dir};
}
push @dir_to_delete, $to_delete->{dir};
my $ans = ($self->{yes}) ? "Y": undef;
if (!defined($ans)) {
require ExtUtils::MakeMaker;
$ans = ExtUtils::MakeMaker::prompt("\nThe following perl+lib installation(s) will be deleted:\n\n\t" . join("\n\t", @dir_to_delete) . "\n\n... are you sure ? [y/N]", "N");
}
if ($ans =~ /^Y/i) {
for (@dir_to_delete) {
print "Deleting: $_\n" unless $self->{quiet};
App::Perlbrew::Path->new ($_)->rmpath;
print "Deleted: $_\n" unless $self->{quiet};
}
} else {
print "\nOK. Not deleting anything.\n\n";
return;
}
}
sub run_command_exec {
my $self = shift;
my %opts;
local (@ARGV) = @{$self->{original_argv}};
Getopt::Long::Configure ('require_order');
my @command_options = ('with=s', 'halt-on-error', 'min=s', 'max=s');
$self->parse_cmdline (\%opts, @command_options);
shift @ARGV; # "exec"
$self->parse_cmdline (\%opts, @command_options);
my @exec_with;
if ($opts{with}) {
my %installed = map { $_->{name} => $_ } map { ($_, @{$_->{libs}}) } $self->installed_perls;
my $d = ($opts{with} =~ m/ /) ? qr( +) : qr(,+);
my @with = grep { $_ } map {
my ($p, $l) = $self->resolve_installation_name($_);
$p .= "\@$l" if $l;
$p;
} split $d, $opts{with};
@exec_with = map { $installed{$_} } @with;
}
else {
@exec_with = map { ($_, @{$_->{libs}}) } $self->installed_perls;
}
if ($opts{min}) {
# TODO use comparable version.
# For now, it doesn't produce consistent results for 5.026001 and 5.26.1
@exec_with = grep { $_->{orig_version} >= $opts{min} } @exec_with;
};
if ($opts{max}) {
@exec_with = grep { $_->{orig_version} <= $opts{max} } @exec_with;
};
if (0 == @exec_with) {
print "No perl installation found.\n" unless $self->{quiet};
}
my $no_header = 0;
if (1 == @exec_with) {
$no_header = 1;
}
my $overall_success = 1;
for my $i ( @exec_with ) {
next if -l $self->root->perls ($i->{name}); # Skip Aliases
my %env = $self->perlbrew_env($i->{name});
next if !$env{PERLBREW_PERL};
local %ENV = %ENV;
$ENV{$_} = defined $env{$_} ? $env{$_} : '' for keys %env;
$ENV{PATH} = join(':', $env{PERLBREW_PATH}, $ENV{PATH});
$ENV{MANPATH} = join(':', $env{PERLBREW_MANPATH}, $ENV{MANPATH}||"");
$ENV{PERL5LIB} = $env{PERL5LIB} || "";
print "$i->{name}\n==========\n" unless $no_header || $self->{quiet};
if (my $err = $self->do_system_with_exit_code(@ARGV)) {
my $exit_code = $err >> 8;
# return 255 for case when process was terminated with signal, in that case real exit code is useless and weird
$exit_code = 255 if $exit_code > 255;
$overall_success = 0;
unless ($self->{quiet}) {
print "Command terminated with non-zero status.\n";
print STDERR "Command [" .
join(' ', map { /\s/ ? "'$_'" : $_ } @ARGV) . # trying reverse shell escapes - quote arguments containing spaces
"] terminated with exit code $exit_code (\$? = $err) under the following perl environment:\n";
print STDERR $self->format_info_output;
}
$self->do_exit_with_error_code($exit_code) if ($opts{'halt-on-error'});
}
print "\n" unless $self->{quiet} || $no_header;
}
$self->do_exit_with_error_code(1) unless $overall_success;
}
sub run_command_clean {
my ($self) = @_;
my $root = $self->root;
my @build_dirs = $root->build->children;
for my $dir (@build_dirs) {
print "Removing $dir\n";
App::Perlbrew::Path->new ($dir)->rmpath;
}
my @tarballs = $root->dists->children;
for my $file ( @tarballs ) {
print "Removing $file\n";
$file->unlink;
}
print "\nDone\n";
}
sub run_command_alias {
my ($self, $cmd, $name, $alias) = @_;
unless ($cmd) {
$self->run_command_help("alias");
exit(-1);
}
my $path_name = $self->root->perls ($name) if $name;
my $path_alias = $self->root->perls ($alias) if $alias;
if ($alias && -e $path_alias && !-l $path_alias) {
die "\nABORT: The installation name `$alias` is not an alias, cannot override.\n\n";
}
if ($cmd eq 'create') {
$self->assert_known_installation($name);
if ($self->is_installed($alias) && !$self->{force}) {
die "\nABORT: The installation `${alias}` already exists. Cannot override.\n\n";
}
$path_alias->unlink;
$path_name->symlink ($path_alias);
}
elsif ($cmd eq 'delete') {
$self->assert_known_installation($name);
unless (-l $path_name) {
die "\nABORT: The installation name `$name` is not an alias, cannot remove.\n\n";
}
$path_name->unlink;
}
elsif ($cmd eq 'rename') {
$self->assert_known_installation($name);
unless (-l $path_name) {
die "\nABORT: The installation name `$name` is not an alias, cannot rename.\n\n";
}
if (-l $path_alias && !$self->{force}) {
die "\nABORT: The alias `$alias` already exists, cannot rename to it.\n\n";
}
rename($path_name, $path_alias);
}
elsif ($cmd eq 'help') {
$self->run_command_help("alias");
}
else {
die "\nERROR: Unrecognized action: `${cmd}`.\n\n";
}
}
sub run_command_display_bashrc {
print BASHRC_CONTENT();
}
sub run_command_display_cshrc {
print CSHRC_CONTENT();
}
sub run_command_display_installation_failure_message {
my ($self) = @_;
}
sub run_command_lib {
my ($self, $subcommand, @args) = @_;
unless ($subcommand) {
$self->run_command_help("lib");
exit(-1);
}
my $sub = "run_command_lib_$subcommand";
if ($self->can($sub)) {
$self->$sub(@args);
}
else {
print "Unknown command: $subcommand\n";
}
}
sub run_command_lib_create {
my ($self, $name) = @_;
die "ERROR: No lib name\n", $self->run_command_help("lib", undef, 'return_text') unless $name;
$name = $self->enforce_localib ($name);
my ($perl_name, $lib_name) = $self->resolve_installation_name($name);
if (!$perl_name) {
my ($perl_name, $lib_name) = $self->decompose_locallib ($name);
die "ERROR: '$perl_name' is not installed yet, '$name' cannot be created.\n";
}
my $fullname = $self->compose_locallib ($perl_name, $lib_name);
my $dir = $self->home->child ("libs", $fullname);
if (-d $dir) {
die "$fullname is already there.\n";
}
$dir->mkpath;
print "lib '$fullname' is created.\n"
unless $self->{quiet};
return;
}
sub run_command_lib_delete {
my ($self, $name) = @_;
die "ERROR: No lib to delete\n", $self->run_command_help("lib", undef, 'return_text') unless $name;
$name = $self->enforce_localib ($name);
my ($perl_name, $lib_name) = $self->resolve_installation_name($name);
my $fullname = $self->compose_locallib ($perl_name, $lib_name);
my $current = $self->current_env;
my $dir = $self->home->child ("libs", $fullname);
if (-d $dir) {
if ($fullname eq $current) {
die "$fullname is currently being used in the current shell, it cannot be deleted.\n";
}
$dir->rmpath;
print "lib '$fullname' is deleted.\n"
unless $self->{quiet};
}
else {
die "ERROR: '$fullname' does not exist.\n";
}
return;
}
sub run_command_lib_list {
my ($self) = @_;
my $dir = $self->home->child ("libs");
return unless -d $dir;
opendir my $dh, $dir or die "open $dir failed: $!";
my @libs = grep { !/^\./ && /\@/ } readdir($dh);
my $current = $self->current_env;
for (@libs) {
print $current eq $_ ? "* " : " ";
print "$_\n";
}
}
sub run_command_upgrade_perl {
my ($self) = @_;
my $PERL_VERSION_RE = qr/(\d+)\.(\d+)\.(\d+)/;
my ($current) = grep { $_->{is_current} } $self->installed_perls;
unless (defined $current) {
print "no perlbrew environment is currently in use\n";
exit(1);
}
my ($major, $minor, $release);
if ($current->{version} =~ /^$PERL_VERSION_RE$/) {
($major, $minor, $release) = ($1, $2, $3);
} else {
print "unable to parse version '$current->{version}'\n";
exit(1);
}
my @available = grep {
/^perl-$major\.$minor/
} $self->available_perls;
my $latest_available_perl = $release;
foreach my $perl (@available) {
if ($perl =~ /^perl-$PERL_VERSION_RE$/) {
my $this_release = $3;
if ($this_release > $latest_available_perl) {
$latest_available_perl = $this_release;
}
}
}
if ($latest_available_perl == $release) {
print "This perlbrew environment ($current->{name}) is already up-to-date.\n";
exit(0);
}
my $dist_version = "$major.$minor.$latest_available_perl";
my $dist = "perl-$dist_version";
print "Upgrading $current->{name} to $dist_version\n" unless $self->{quiet};
local $self->{as} = $current->{name};
local $self->{dist_name} = $dist;
require Config ;
my @d_options = map { '-D' . $flavor{$_}->{d_option}} keys %flavor ;
my %sub_config = map { $_ => $Config{$_}} grep { /^config_arg\d/} keys %Config ;
for my $value (values %sub_config) {
my $value_wo_D = $value;
$value_wo_D =~ s/^-D//;
push @{$self->{D}} , $value_wo_D if grep {/$value/} @d_options;
}
$self->do_install_release($dist, $dist_version);
}
# Executes the list-modules command.
# This routine launches a new perl instance that, thru
# ExtUtils::Installed prints out all the modules
# in the system. If an argument is passed to the
# subroutine it is managed as a filename
# to which prints the list of modules.
sub run_command_list_modules {
my ($self, $output_filename) = @_;
my $class = ref($self) || __PACKAGE__;
# avoid something that does not seem as a filename to print
# output to...
undef $output_filename if (! scalar($output_filename));
my $name = $self->current_env;
if (-l (my $path = $self->root->perls ($name))) {
$name = $path->readlink->basename;
}
my $app = $class->new(
qw(--quiet exec --with),
$name,
'perl',
'-MExtUtils::Installed',
'-le',
sprintf('BEGIN{@INC=grep {$_ ne q!.!} @INC}; %s print {%s} $_ for grep {$_ ne q!Perl!} ExtUtils::Installed->new->modules;',
$output_filename ? sprintf('open my $output_fh, \'>\', "%s"; ', $output_filename) : '',
$output_filename ? '$output_fh' : 'STDOUT')
);
$app->run;
}
sub resolve_installation_name {
my ($self, $name) = @_;
die "App::perlbrew->resolve_installation_name requires one argument." unless $name;
my ($perl_name, $lib_name) = $self->decompose_locallib ($name);
$perl_name = $name unless $lib_name;
$perl_name ||= $self->current_perl;
if (!$self->is_installed($perl_name)) {
if ($self->is_installed("perl-${perl_name}") ) {
$perl_name = "perl-${perl_name}";
}
else {
return undef;
}
}
return wantarray ? ($perl_name, $lib_name) : $perl_name;
}
# Implementation of the 'clone-modules' command.
#
# This method accepts a destination and source installation
# of Perl to clone modules from and into.
# For instance calling
# $app->run_command_clone_modules($perl_a, $perl_b);
# installs all modules that have been installed on Perl A
# to the instance of Perl B.
# The source instance is optional, that is if the method
# is invoked with a single argument, the currently
# running instance is used as source. Therefore the
# two following calls are the same:
#
# $app->run_command_clone_modules( $self->current_perl, $perl_b );
# $app->run_command_clone_modules( $perl_b );
#
# Of course, both Perl installation must exist on this
# perlbrew enviroment.
#
# The method extracts the modules installed on the source Perl
# instance and put them on a temporary file, such file is then
# passed to another instance of the application to
# execute cpanm on it. The final result is the installation
# of source modules into the destination instance.
sub run_command_clone_modules {
my $self = shift;
# default to use the currently installation
my ( $dst_perl, $src_perl );
# the first argument is the destination, the second
# optional argument is the source version, default
# to use the current installation
$dst_perl = pop || $self->current_env;
$src_perl = pop || $self->current_env;
# check source and destination do exist
undef $src_perl if (! $self->resolve_installation_name($src_perl));
undef $dst_perl if (! $self->resolve_installation_name($dst_perl));
if ( ! $src_perl
|| ! $dst_perl
|| $src_perl eq $dst_perl ){
# cannot understand from where to where or
# the user did specify the same versions
$self->run_command_help('clone-modules');
exit(-1);
}
# I need to run an application to do the module listing.
# and get the result back so to handle it and pass
# to the exec subroutine. The solution I found so far
# is to store the result in a temp file (the list_modules
# uses a sub-perl process, so there is no way to pass a
# filehandle or something similar).
my $class = ref($self);
require File::Temp;
my $modules_fh = File::Temp->new;
# list all the modules and place them in the output file
my $src_app = $class->new(
qw(--quiet exec --with),
$src_perl,
'perl',
'-MExtUtils::Installed',
'-le',
sprintf('BEGIN{@INC=grep {$_ ne q!.!} @INC}; open my $output_fh, ">", "%s"; print {$output_fh} $_ for ExtUtils::Installed->new->modules;',
$modules_fh->filename )
);
$src_app->run;
# here I should have the list of modules into the
# temporary file name, so I can ask the destination
# perl instance to install such list
$modules_fh->close;
open $modules_fh, '<', $modules_fh->filename;
chomp(my @modules_to_install = <$modules_fh>);
$modules_fh->close;
die "\nNo modules installed on $src_perl !\n" if (! @modules_to_install);
print "\nInstalling $#modules_to_install modules from $src_perl to $dst_perl ...\n";
# create a new application to 'exec' the 'cpanm'
# with the specified module list
my $app = $class->new(
qw(--quiet exec --with),
$dst_perl,
'cpanm',
@modules_to_install
);
$app->run;
}
sub format_info_output
{
my ($self, $module) = @_;
my $out = '';
$out .= "Current perl:\n";
if ($self->current_perl) {
$out .= " Name: " . $self->current_env . "\n";
$out .= " Path: " . $self->installed_perl_executable($self->current_perl) . "\n";
$out .= " Config: " . $self->configure_args($self->current_perl) . "\n";
$out .= join('', " Compiled at: ", (map {
/ Compiled at (.+)\n/ ? $1 : ()
} `@{[ $self->installed_perl_executable($self->current_perl) ]} -V`), "\n");
}
else {
$out .= "Using system perl." . "\n";
$out .= "Shebang: " . $self->system_perl_shebang . "\n";
}
$out .= "\nperlbrew:\n";
$out .= " version: " . $self->VERSION . "\n";
$out .= " ENV:\n";
for(map{"PERLBREW_$_"}qw(ROOT HOME PATH MANPATH)) {
$out .= " $_: " . ($self->env($_)||"") . "\n";
}
if ($module) {
my $code = qq{eval "require $module" and do { (my \$f = "$module") =~ s<::></>g; \$f .= ".pm"; print "$module\n Location: \$INC{\$f}\n Version: " . ($module->VERSION ? $module->VERSION : "no VERSION specified" ) } or do { print "$module could not be found, is it installed?" } };
$out .= "\nModule: ".$self->do_capture($self->installed_perl_executable($self->current_perl), "-le", $code);
}
$out;
}
sub run_command_info {
my ($self) = shift;
print $self->format_info_output(@_);
}
sub BASHRC_CONTENT() {
return "export PERLBREW_SHELLRC_VERSION=$VERSION\n" .
(exists $ENV{PERLBREW_ROOT} ? "export PERLBREW_ROOT=$PERLBREW_ROOT\n" : "") . "\n" . <<'RC';
__perlbrew_reinit() {
if [[ ! -d "$PERLBREW_HOME" ]]; then
mkdir -p "$PERLBREW_HOME"
fi
[ -f "$PERLBREW_HOME/init" ] && rm "$PERLBREW_HOME/init"
echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init"
command perlbrew env $1 | \grep PERLBREW_ >> "$PERLBREW_HOME/init"
. "$PERLBREW_HOME/init"
__perlbrew_set_path
}
__perlbrew_purify () {
local path patharray outsep
IFS=: read -r${BASH_VERSION+a}${ZSH_VERSION+A} patharray <<< "$1"
for path in "${patharray[@]}" ; do
case "$path" in
(*"$PERLBREW_HOME"*) ;;
(*"$PERLBREW_ROOT"*) ;;
(*) printf '%s' "$outsep$path" ; outsep=: ;;
esac
done
}
__perlbrew_set_path () {
export MANPATH=$PERLBREW_MANPATH${PERLBREW_MANPATH:+:}$(__perlbrew_purify "$(manpath 2>/dev/null)")
export PATH=${PERLBREW_PATH:-$PERLBREW_ROOT/bin}:$(__perlbrew_purify "$PATH")
hash -r
}
__perlbrew_set_env() {
local code
code="$($perlbrew_command env $@)" || return $?
eval "$code"
}
__perlbrew_activate() {
[[ -n $(alias perl 2>/dev/null) ]] && unalias perl 2>/dev/null
if [[ -n "$PERLBREW_PERL" ]]; then
__perlbrew_set_env "$PERLBREW_PERL${PERLBREW_LIB:+@}$PERLBREW_LIB"
fi
__perlbrew_set_path
}
__perlbrew_deactivate() {
__perlbrew_set_env
unset PERLBREW_PERL
unset PERLBREW_LIB
__perlbrew_set_path
}
perlbrew () {
local exit_status
local short_option
export SHELL
if [[ $1 == -* ]]; then
short_option=$1
shift
else
short_option=""
fi
case $1 in
(use)
if [[ -z "$2" ]] ; then
echo -n "Currently using ${PERLBREW_PERL:-system perl}"
[ -n "$PERLBREW_LIB" ] && echo -n "@$PERLBREW_LIB"
echo
else
__perlbrew_set_env "$2" && { __perlbrew_set_path ; true ; }
exit_status="$?"
fi
;;
(switch)
if [[ -z "$2" ]] ; then
command perlbrew switch
else
perlbrew use $2 && { __perlbrew_reinit $2 ; true ; }
exit_status=$?
fi
;;
(off)
__perlbrew_deactivate
echo "perlbrew is turned off."
;;
(switch-off)
__perlbrew_deactivate
__perlbrew_reinit
echo "perlbrew is switched off."
;;
(*)
command perlbrew $short_option "$@"
exit_status=$?
;;
esac
hash -r
return ${exit_status:-0}
}
[[ -z "$PERLBREW_ROOT" ]] && export PERLBREW_ROOT="$HOME/perl5/perlbrew"
[[ -z "$PERLBREW_HOME" ]] && export PERLBREW_HOME="$HOME/.perlbrew"
if [[ ! -n "$PERLBREW_SKIP_INIT" ]]; then
if [[ -f "$PERLBREW_HOME/init" ]]; then
. "$PERLBREW_HOME/init"
fi
fi
perlbrew_bin_path="${PERLBREW_ROOT}/bin"
if [[ -f $perlbrew_bin_path/perlbrew ]]; then
perlbrew_command="$perlbrew_bin_path/perlbrew"
else
perlbrew_command="perlbrew"
fi
unset perlbrew_bin_path
__perlbrew_activate
RC
}
sub BASH_COMPLETION_CONTENT() {
return <<'COMPLETION';
if [[ -n ${ZSH_VERSION-} ]]; then
autoload -U +X bashcompinit && bashcompinit
fi
export PERLBREW="command perlbrew"
_perlbrew_compgen()
{
COMPREPLY=( $($PERLBREW compgen $COMP_CWORD ${COMP_WORDS[*]}) )
}
complete -F _perlbrew_compgen perlbrew
COMPLETION
}
sub PERLBREW_FISH_CONTENT {
return "set -x PERLBREW_SHELLRC_VERSION $VERSION\n" . <<'END';
function __perlbrew_reinit
if not test -d "$PERLBREW_HOME"
mkdir -p "$PERLBREW_HOME"
end
echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init"
command perlbrew env $argv[1] | \grep PERLBREW_ >> "$PERLBREW_HOME/init"
__source_init
__perlbrew_set_path
end
function __perlbrew_set_path
set -l MANPATH_WITHOUT_PERLBREW (perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_HOME}) < 0 } grep { index($_, $ENV{PERLBREW_ROOT}) < 0 } split/:/,qx(manpath 2> /dev/null);')
if test -n "$PERLBREW_MANPATH"
set -l PERLBREW_MANPATH $PERLBREW_MANPATH":"
set -x MANPATH {$PERLBREW_MANPATH}{$MANPATH_WITHOUT_PERLBREW}
else
set -x MANPATH $MANPATH_WITHOUT_PERLBREW
end
set -l PATH_WITHOUT_PERLBREW (eval $perlbrew_command display-pristine-path | perl -pe'y/:/ /')
# silencing stderr in case there's a non-existent path in $PATH (see GH#446)
if test -n "$PERLBREW_PATH"
set -x PERLBREW_PATH (echo $PERLBREW_PATH | perl -pe 'y/:/ /' )
eval set -x PATH $PERLBREW_PATH $PATH_WITHOUT_PERLBREW 2> /dev/null
else
eval set -x PATH $PERLBREW_ROOT/bin $PATH_WITHOUT_PERLBREW 2> /dev/null
end
end
function __perlbrew_set_env
set -l code (eval $perlbrew_command env $argv | perl -pe 's/^(export|setenv)/set -xg/; s/=/ /; s/^unset[env]*/set -eug/; s/$/;/; y/:/ /')
if test -z "$code"
return 0;
else
eval $code
end
end
function __perlbrew_activate
functions -e perl
if test -n "$PERLBREW_PERL"
if test -z "$PERLBREW_LIB"
__perlbrew_set_env $PERLBREW_PERL
else
__perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB
end
end
__perlbrew_set_path
end
function __perlbrew_deactivate
__perlbrew_set_env
set -x PERLBREW_PERL
set -x PERLBREW_LIB
set -x PERLBREW_PATH
__perlbrew_set_path
end
function perlbrew
test -z "$argv"
and echo " Usage: perlbrew <command> [options] [arguments]"
and echo " or: perlbrew help"
and return 1
switch $argv[1]
case use
if test ( count $argv ) -eq 1
if test -z "$PERLBREW_PERL"
echo "Currently using system perl"
else
echo "Currently using $PERLBREW_PERL"
end
else
__perlbrew_set_env $argv[2]
if test "$status" -eq 0
__perlbrew_set_path
end
end
case switch
if test ( count $argv ) -eq 1
command perlbrew switch
else
perlbrew use $argv[2]
if test "$status" -eq 0
__perlbrew_reinit $argv[2]
end
end
case off
__perlbrew_deactivate
echo "perlbrew is turned off."
case switch-off
__perlbrew_deactivate
__perlbrew_reinit
echo "perlbrew is switched off."
case '*'
command perlbrew $argv
end
end
function __source_init
perl -pe's/^(export|setenv)/set -xg/; s/=/ /; s/$/;/;' "$PERLBREW_HOME/init" | source
end
if test -z "$PERLBREW_ROOT"
set -x PERLBREW_ROOT "$HOME/perl5/perlbrew"
end
if test -z "$PERLBREW_HOME"
set -x PERLBREW_HOME "$HOME/.perlbrew"
end
if test -z "$PERLBREW_SKIP_INIT" -a -f "$PERLBREW_HOME/init"
__source_init
end
set perlbrew_bin_path "$PERLBREW_ROOT/bin"
if test -f "$perlbrew_bin_path/perlbrew"
set perlbrew_command "$perlbrew_bin_path/perlbrew"
else
set perlbrew_command perlbrew
end
set -e perlbrew_bin_path
__perlbrew_activate
## autocomplete stuff #############################################
function __fish_perlbrew_needs_command
set cmd (commandline -opc)
if test (count $cmd) -eq 1 -a $cmd[1] = 'perlbrew'
return 0
end
return 1
end
function __fish_perlbrew_using_command
set cmd (commandline -opc)
if test (count $cmd) -gt 1
if [ $argv[1] = $cmd[2] ]
return 0
end
end
end
for com in (perlbrew help | perl -ne'print lc if s/^COMMAND:\s+//')
complete -f -c perlbrew -n '__fish_perlbrew_needs_command' -a $com
end
for com in switch use;
complete -f -c perlbrew -n "__fish_perlbrew_using_command $com" \
-a '(perlbrew list | perl -pe\'s/\*?\s*(\S+).*/$1/\')'
end
END
}
sub CSH_WRAPPER_CONTENT {
return <<'WRAPPER';
set perlbrew_exit_status=0
if ( "$1" =~ -* ) then
set perlbrew_short_option="$1"
shift
else
set perlbrew_short_option=""
endif
switch ( "$1" )
case use:
if ( $%2 == 0 ) then
if ( $?PERLBREW_PERL == 0 ) then
echo "Currently using system perl"
else
if ( $%PERLBREW_PERL == 0 ) then
echo "Currently using system perl"
else
echo "Currently using $PERLBREW_PERL"
endif
endif
else
set perlbrew_line_count=0
foreach perlbrew_line ( "`\perlbrew env $2:q`" )
eval "$perlbrew_line"
@ perlbrew_line_count++
end
if ( $perlbrew_line_count == 0 ) then
set perlbrew_exit_status=1
else
source "$PERLBREW_ROOT/etc/csh_set_path"
endif
endif
breaksw
case switch:
if ( $%2 == 0 ) then
\perlbrew switch
else
perlbrew use "$2" && source "$PERLBREW_ROOT/etc/csh_reinit" "$2"
endif
breaksw
case off:
unsetenv PERLBREW_PERL
foreach perlbrew_line ( "`\perlbrew env`" )
eval "$perlbrew_line"
end
source "$PERLBREW_ROOT/etc/csh_set_path"
echo "perlbrew is turned off."
breaksw
case switch-off:
unsetenv PERLBREW_PERL
source "$PERLBREW_ROOT/etc/csh_reinit" ''
echo "perlbrew is switched off."
breaksw
default:
\perlbrew $perlbrew_short_option:q $argv:q
set perlbrew_exit_status=$?
breaksw
endsw
rehash
exit $perlbrew_exit_status
WRAPPER
}
sub CSH_REINIT_CONTENT {
return <<'REINIT';
if ( ! -d "$PERLBREW_HOME" ) then
mkdir -p "$PERLBREW_HOME"
endif
echo '# DO NOT EDIT THIS FILE' >! "$PERLBREW_HOME/init"
\perlbrew env $1 >> "$PERLBREW_HOME/init"
source "$PERLBREW_HOME/init"
source "$PERLBREW_ROOT/etc/csh_set_path"
REINIT
}
sub CSH_SET_PATH_CONTENT {
return <<'SETPATH';
unalias perl
if ( $?PERLBREW_PATH == 0 ) then
setenv PERLBREW_PATH "$PERLBREW_ROOT/bin"
endif
setenv PATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,$ENV{PATH};'`
setenv PATH "${PERLBREW_PATH}:${PATH_WITHOUT_PERLBREW}"
setenv MANPATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,qx(manpath 2> /dev/null);'`
if ( $?PERLBREW_MANPATH == 1 ) then
setenv MANPATH ${PERLBREW_MANPATH}:${MANPATH_WITHOUT_PERLBREW}
else
setenv MANPATH ${MANPATH_WITHOUT_PERLBREW}
endif
SETPATH
}
sub CSHRC_CONTENT {
return "setenv PERLBREW_SHELLRC_VERSION $VERSION\n\n" . <<'CSHRC';
if ( $?PERLBREW_HOME == 0 ) then
setenv PERLBREW_HOME "$HOME/.perlbrew"
endif
if ( $?PERLBREW_ROOT == 0 ) then
setenv PERLBREW_ROOT "$HOME/perl5/perlbrew"
endif
if ( $?PERLBREW_SKIP_INIT == 0 ) then
if ( -f "$PERLBREW_HOME/init" ) then
source "$PERLBREW_HOME/init"
endif
endif
if ( $?PERLBREW_PATH == 0 ) then
setenv PERLBREW_PATH "$PERLBREW_ROOT/bin"
endif
source "$PERLBREW_ROOT/etc/csh_set_path"
alias perlbrew 'source "$PERLBREW_ROOT/etc/csh_wrapper"'
CSHRC
}
sub append_log {
my ($self, $message) = @_;
my $log_handler;
open($log_handler, '>>', $self->{log_file})
or die "Cannot open log file for appending: $!";
print $log_handler "$message\n";
close($log_handler);
}
sub INSTALLATION_FAILURE_MESSAGE {
my ($self) = @_;
return <<FAIL;
Installation process failed. To spot any issues, check
$self->{log_file}
If some perl tests failed and you still want to install this distribution anyway,
do:
(cd $self->{dist_extracted_dir}; make install)
You might also want to try upgrading patchperl before trying again:
perlbrew install-patchperl
Generally, if you need to install a perl distribution known to have minor test
failures, do one of these commands to avoid seeing this message:
perlbrew --notest install $self->{dist_name}
perlbrew --force install $self->{dist_name}
FAIL
}
1;
__END__
=encoding utf8
=head1 NAME
App::perlbrew - Manage perl installations in your C<$HOME>
=head2 SYNOPSIS
# Installation
curl -L https://install.perlbrew.pl | bash
# Initialize
perlbrew init
# See what is available
perlbrew available
# Install some Perls
perlbrew install 5.18.2
perlbrew install perl-5.8.1
perlbrew install perl-5.19.9
# See what were installed
perlbrew list
# Swith to an installation and set it as default
perlbrew switch perl-5.18.2
# Temporarily use another version only in current shell.
perlbrew use perl-5.8.1
perl -v
# Or turn it off completely. Useful when you messed up too deep.
# Or want to go back to the system Perl.
perlbrew off
# Use 'switch' command to turn it back on.
perlbrew switch perl-5.12.2
# Exec something with all perlbrew-ed perls
perlbrew exec -- perl -E 'say $]'
=head2 DESCRIPTION
L<perlbrew> is a program to automate the building and installation of perl in an
easy way. It provides multiple isolated perl environments, and a mechanism
for you to switch between them.
Everything are installed unter C<~/perl5/perlbrew>. You then need to include a
bashrc/cshrc provided by perlbrew to tweak the PATH for you. You then can
benefit from not having to run C<sudo> commands to install
cpan modules because those are installed inside your C<HOME> too.
For the documentation of perlbrew usage see L<perlbrew> command
on L<MetaCPAN|https://metacpan.org/>, or by running C<perlbrew help>,
or by visiting L<perlbrew's official website|https://perlbrew.pl/>. The following documentation
features the API of C<App::perlbrew> module, and may not be remotely
close to what your want to read.
=head2 INSTALLATION
It is the simplest to use the perlbrew installer, just paste this statement to
your terminal:
curl -L https://install.perlbrew.pl | bash
Or this one, if you have C<fetch> (default on FreeBSD):
fetch -o- https://install.perlbrew.pl | sh
After that, C<perlbrew> installs itself to C<~/perl5/perlbrew/bin>, and you
should follow the instruction on screen to modify your shell rc file to put it
in your PATH.
The installed perlbrew command is a standalone executable that can be run with
system perl. The minimum system perl version requirement is 5.8.0, which should
be good enough for most of the OSes these days.
A fat-packed version of L<patchperl> is also installed to
C<~/perl5/perlbrew/bin>, which is required to build old perls.
The directory C<~/perl5/perlbrew> will contain all install perl executables,
libraries, documentations, lib, site_libs. In the documentation, that directory
is referred as C<perlbrew root>. If you need to set it to somewhere else because,
say, your C<HOME> has limited quota, you can do that by setting C<PERLBREW_ROOT>
environment variable before running the installer:
export PERLBREW_ROOT=/opt/perl5
curl -L https://install.perlbrew.pl | bash
As a result, different users on the same machine can all share the same perlbrew
root directory (although only original user that made the installation would
have the permission to perform perl installations.)
You may also install perlbrew from CPAN:
cpan App::perlbrew
In this case, the perlbrew command is installed as C</usr/bin/perlbrew> or
C</usr/local/bin/perlbrew> or others, depending on the location of your system
perl installation.
Please make sure not to run this with one of the perls brewed with
perlbrew. It's the best to turn perlbrew off before you run that, if you're
upgrading.
perlbrew off
cpan App::perlbrew
You should always use system cpan (like /usr/bin/cpan) to install
C<App::perlbrew> because it will be installed under a system PATH like
C</usr/bin>, which is not affected by perlbrew C<switch> or C<use> command.
The C<self-upgrade> command will not upgrade the perlbrew installed by cpan
command, but it is also easy to upgrade perlbrew by running C<cpan App::perlbrew>
again.
=head2 METHODS
=over 4
=item (Str) current_perl
Return the "current perl" object attribute string, or, if absent, the value of
C<PERLBREW_PERL> environment variable.
=item (Str) current_perl (Str)
Set the C<current_perl> object attribute to the given value.
=back
=head2 PROJECT DEVELOPMENT
L<perlbrew project|https://perlbrew.pl/> uses github
L<https://github.com/gugod/App-perlbrew/issues> and RT
<https://rt.cpan.org/Dist/Display.html?Queue=App-perlbrew> for issue
tracking. Issues sent to these two systems will eventually be reviewed
and handled.
See L<https://github.com/gugod/App-perlbrew/contributors> for a list
of project contributors.
=head1 AUTHOR
Kang-min Liu C<< <[email protected]> >>
=head1 COPYRIGHT
Copyright (c) 2010- Kang-min Liu C<< <[email protected]> >>.
=head3 LICENCE
The MIT License
=head2 DISCLAIMER OF WARRANTY
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR, OR CORRECTION.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
=cut
APP_PERLBREW
$fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META';
use 5.006;
use strict;
use warnings;
package CPAN::Meta;
# VERSION
$CPAN::Meta::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod use v5.10;
#pod use strict;
#pod use warnings;
#pod use CPAN::Meta;
#pod use Module::Load;
#pod
#pod my $meta = CPAN::Meta->load_file('META.json');
#pod
#pod printf "testing requirements for %s version %s\n",
#pod $meta->name,
#pod $meta->version;
#pod
#pod my $prereqs = $meta->effective_prereqs;
#pod
#pod for my $phase ( qw/configure runtime build test/ ) {
#pod say "Requirements for $phase:";
#pod my $reqs = $prereqs->requirements_for($phase, "requires");
#pod for my $module ( sort $reqs->required_modules ) {
#pod my $status;
#pod if ( eval { load $module unless $module eq 'perl'; 1 } ) {
#pod my $version = $module eq 'perl' ? $] : $module->VERSION;
#pod $status = $reqs->accepts_module($module, $version)
#pod ? "$version ok" : "$version not ok";
#pod } else {
#pod $status = "missing"
#pod };
#pod say " $module ($status)";
#pod }
#pod }
#pod
#pod =head1 DESCRIPTION
#pod
#pod Software distributions released to the CPAN include a F<META.json> or, for
#pod older distributions, F<META.yml>, which describes the distribution, its
#pod contents, and the requirements for building and installing the distribution.
#pod The data structure stored in the F<META.json> file is described in
#pod L<CPAN::Meta::Spec>.
#pod
#pod CPAN::Meta provides a simple class to represent this distribution metadata (or
#pod I<distmeta>), along with some helpful methods for interrogating that data.
#pod
#pod The documentation below is only for the methods of the CPAN::Meta object. For
#pod information on the meaning of individual fields, consult the spec.
#pod
#pod =cut
use Carp qw(carp croak);
use CPAN::Meta::Feature;
use CPAN::Meta::Prereqs;
use CPAN::Meta::Converter;
use CPAN::Meta::Validator;
use Parse::CPAN::Meta 1.4414 ();
BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }
#pod =head1 STRING DATA
#pod
#pod The following methods return a single value, which is the value for the
#pod corresponding entry in the distmeta structure. Values should be either undef
#pod or strings.
#pod
#pod =for :list
#pod * abstract
#pod * description
#pod * dynamic_config
#pod * generated_by
#pod * name
#pod * release_status
#pod * version
#pod
#pod =cut
BEGIN {
my @STRING_READERS = qw(
abstract
description
dynamic_config
generated_by
name
release_status
version
);
no strict 'refs';
for my $attr (@STRING_READERS) {
*$attr = sub { $_[0]{ $attr } };
}
}
#pod =head1 LIST DATA
#pod
#pod These methods return lists of string values, which might be represented in the
#pod distmeta structure as arrayrefs or scalars:
#pod
#pod =for :list
#pod * authors
#pod * keywords
#pod * licenses
#pod
#pod The C<authors> and C<licenses> methods may also be called as C<author> and
#pod C<license>, respectively, to match the field name in the distmeta structure.
#pod
#pod =cut
BEGIN {
my @LIST_READERS = qw(
author
keywords
license
);
no strict 'refs';
for my $attr (@LIST_READERS) {
*$attr = sub {
my $value = $_[0]{ $attr };
croak "$attr must be called in list context"
unless wantarray;
return @{ _dclone($value) } if ref $value;
return $value;
};
}
}
sub authors { $_[0]->author }
sub licenses { $_[0]->license }
#pod =head1 MAP DATA
#pod
#pod These readers return hashrefs of arbitrary unblessed data structures, each
#pod described more fully in the specification:
#pod
#pod =for :list
#pod * meta_spec
#pod * resources
#pod * provides
#pod * no_index
#pod * prereqs
#pod * optional_features
#pod
#pod =cut
BEGIN {
my @MAP_READERS = qw(
meta-spec
resources
provides
no_index
prereqs
optional_features
);
no strict 'refs';
for my $attr (@MAP_READERS) {
(my $subname = $attr) =~ s/-/_/;
*$subname = sub {
my $value = $_[0]{ $attr };
return _dclone($value) if $value;
return {};
};
}
}
#pod =head1 CUSTOM DATA
#pod
#pod A list of custom keys are available from the C<custom_keys> method and
#pod particular keys may be retrieved with the C<custom> method.
#pod
#pod say $meta->custom($_) for $meta->custom_keys;
#pod
#pod If a custom key refers to a data structure, a deep clone is returned.
#pod
#pod =cut
sub custom_keys {
return grep { /^x_/i } keys %{$_[0]};
}
sub custom {
my ($self, $attr) = @_;
my $value = $self->{$attr};
return _dclone($value) if ref $value;
return $value;
}
#pod =method new
#pod
#pod my $meta = CPAN::Meta->new($distmeta_struct, \%options);
#pod
#pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash
#pod reference fails to validate. Older-format metadata will be up-converted to
#pod version 2 if they validate against the original stated specification.
#pod
#pod It takes an optional hashref of options. Valid options include:
#pod
#pod =over
#pod
#pod =item *
#pod
#pod lazy_validation -- if true, new will attempt to convert the given metadata
#pod to version 2 before attempting to validate it. This means than any
#pod fixable errors will be handled by CPAN::Meta::Converter before validation.
#pod (Note that this might result in invalid optional data being silently
#pod dropped.) The default is false.
#pod
#pod =back
#pod
#pod =cut
sub _new {
my ($class, $struct, $options) = @_;
my $self;
if ( $options->{lazy_validation} ) {
# try to convert to a valid structure; if succeeds, then return it
my $cmc = CPAN::Meta::Converter->new( $struct );
$self = $cmc->convert( version => 2 ); # valid or dies
return bless $self, $class;
}
else {
# validate original struct
my $cmv = CPAN::Meta::Validator->new( $struct );
unless ( $cmv->is_valid) {
die "Invalid metadata structure. Errors: "
. join(", ", $cmv->errors) . "\n";
}
}
# up-convert older spec versions
my $version = $struct->{'meta-spec'}{version} || '1.0';
if ( $version == 2 ) {
$self = $struct;
}
else {
my $cmc = CPAN::Meta::Converter->new( $struct );
$self = $cmc->convert( version => 2 );
}
return bless $self, $class;
}
sub new {
my ($class, $struct, $options) = @_;
my $self = eval { $class->_new($struct, $options) };
croak($@) if $@;
return $self;
}
#pod =method create
#pod
#pod my $meta = CPAN::Meta->create($distmeta_struct, \%options);
#pod
#pod This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
#pod will be generated if not provided. This means the metadata structure is
#pod assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
#pod
#pod =cut
sub create {
my ($class, $struct, $options) = @_;
my $version = __PACKAGE__->VERSION || 2;
$struct->{generated_by} ||= __PACKAGE__ . " version $version" ;
$struct->{'meta-spec'}{version} ||= int($version);
my $self = eval { $class->_new($struct, $options) };
croak ($@) if $@;
return $self;
}
#pod =method load_file
#pod
#pod my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
#pod
#pod Given a pathname to a file containing metadata, this deserializes the file
#pod according to its file suffix and constructs a new C<CPAN::Meta> object, just
#pod like C<new()>. It will die if the deserialized version fails to validate
#pod against its stated specification version.
#pod
#pod It takes the same options as C<new()> but C<lazy_validation> defaults to
#pod true.
#pod
#pod =cut
sub load_file {
my ($class, $file, $options) = @_;
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
croak "load_file() requires a valid, readable filename"
unless -r $file;
my $self;
eval {
my $struct = Parse::CPAN::Meta->load_file( $file );
$self = $class->_new($struct, $options);
};
croak($@) if $@;
return $self;
}
#pod =method load_yaml_string
#pod
#pod my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
#pod
#pod This method returns a new CPAN::Meta object using the first document in the
#pod given YAML string. In other respects it is identical to C<load_file()>.
#pod
#pod =cut
sub load_yaml_string {
my ($class, $yaml, $options) = @_;
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
my $self;
eval {
my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml );
$self = $class->_new($struct, $options);
};
croak($@) if $@;
return $self;
}
#pod =method load_json_string
#pod
#pod my $meta = CPAN::Meta->load_json_string($json, \%options);
#pod
#pod This method returns a new CPAN::Meta object using the structure represented by
#pod the given JSON string. In other respects it is identical to C<load_file()>.
#pod
#pod =cut
sub load_json_string {
my ($class, $json, $options) = @_;
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
my $self;
eval {
my $struct = Parse::CPAN::Meta->load_json_string( $json );
$self = $class->_new($struct, $options);
};
croak($@) if $@;
return $self;
}
#pod =method load_string
#pod
#pod my $meta = CPAN::Meta->load_string($string, \%options);
#pod
#pod If you don't know if a string contains YAML or JSON, this method will use
#pod L<Parse::CPAN::Meta> to guess. In other respects it is identical to
#pod C<load_file()>.
#pod
#pod =cut
sub load_string {
my ($class, $string, $options) = @_;
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
my $self;
eval {
my $struct = Parse::CPAN::Meta->load_string( $string );
$self = $class->_new($struct, $options);
};
croak($@) if $@;
return $self;
}
#pod =method save
#pod
#pod $meta->save($distmeta_file, \%options);
#pod
#pod Serializes the object as JSON and writes it to the given file. The only valid
#pod option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
#pod is saved with UTF-8 encoding.
#pod
#pod For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
#pod is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
#pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
#pod backend like L<JSON::XS>.
#pod
#pod For C<version> less than 2, the filename should end in '.yml'.
#pod L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
#pod is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may
#pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
#pod this is not recommended due to subtle incompatibilities between YAML parsers on
#pod CPAN.
#pod
#pod =cut
sub save {
my ($self, $file, $options) = @_;
my $version = $options->{version} || '2';
my $layer = $] ge '5.008001' ? ':utf8' : '';
if ( $version ge '2' ) {
carp "'$file' should end in '.json'"
unless $file =~ m{\.json$};
}
else {
carp "'$file' should end in '.yml'"
unless $file =~ m{\.yml$};
}
my $data = $self->as_string( $options );
open my $fh, ">$layer", $file
or die "Error opening '$file' for writing: $!\n";
print {$fh} $data;
close $fh
or die "Error closing '$file': $!\n";
return 1;
}
#pod =method meta_spec_version
#pod
#pod This method returns the version part of the C<meta_spec> entry in the distmeta
#pod structure. It is equivalent to:
#pod
#pod $meta->meta_spec->{version};
#pod
#pod =cut
sub meta_spec_version {
my ($self) = @_;
return $self->meta_spec->{version};
}
#pod =method effective_prereqs
#pod
#pod my $prereqs = $meta->effective_prereqs;
#pod
#pod my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
#pod
#pod This method returns a L<CPAN::Meta::Prereqs> object describing all the
#pod prereqs for the distribution. If an arrayref of feature identifiers is given,
#pod the prereqs for the identified features are merged together with the
#pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
#pod
#pod =cut
sub effective_prereqs {
my ($self, $features) = @_;
$features ||= [];
my $prereq = CPAN::Meta::Prereqs->new($self->prereqs);
return $prereq unless @$features;
my @other = map {; $self->feature($_)->prereqs } @$features;
return $prereq->with_merged_prereqs(\@other);
}
#pod =method should_index_file
#pod
#pod ... if $meta->should_index_file( $filename );
#pod
#pod This method returns true if the given file should be indexed. It decides this
#pod by checking the C<file> and C<directory> keys in the C<no_index> property of
#pod the distmeta structure. Note that neither the version format nor
#pod C<release_status> are considered.
#pod
#pod C<$filename> should be given in unix format.
#pod
#pod =cut
sub should_index_file {
my ($self, $filename) = @_;
for my $no_index_file (@{ $self->no_index->{file} || [] }) {
return if $filename eq $no_index_file;
}
for my $no_index_dir (@{ $self->no_index->{directory} }) {
$no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z};
return if index($filename, $no_index_dir) == 0;
}
return 1;
}
#pod =method should_index_package
#pod
#pod ... if $meta->should_index_package( $package );
#pod
#pod This method returns true if the given package should be indexed. It decides
#pod this by checking the C<package> and C<namespace> keys in the C<no_index>
#pod property of the distmeta structure. Note that neither the version format nor
#pod C<release_status> are considered.
#pod
#pod =cut
sub should_index_package {
my ($self, $package) = @_;
for my $no_index_pkg (@{ $self->no_index->{package} || [] }) {
return if $package eq $no_index_pkg;
}
for my $no_index_ns (@{ $self->no_index->{namespace} }) {
return if index($package, "${no_index_ns}::") == 0;
}
return 1;
}
#pod =method features
#pod
#pod my @feature_objects = $meta->features;
#pod
#pod This method returns a list of L<CPAN::Meta::Feature> objects, one for each
#pod optional feature described by the distribution's metadata.
#pod
#pod =cut
sub features {
my ($self) = @_;
my $opt_f = $self->optional_features;
my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) }
keys %$opt_f;
return @features;
}
#pod =method feature
#pod
#pod my $feature_object = $meta->feature( $identifier );
#pod
#pod This method returns a L<CPAN::Meta::Feature> object for the optional feature
#pod with the given identifier. If no feature with that identifier exists, an
#pod exception will be raised.
#pod
#pod =cut
sub feature {
my ($self, $ident) = @_;
croak "no feature named $ident"
unless my $f = $self->optional_features->{ $ident };
return CPAN::Meta::Feature->new($ident, $f);
}
#pod =method as_struct
#pod
#pod my $copy = $meta->as_struct( \%options );
#pod
#pod This method returns a deep copy of the object's metadata as an unblessed hash
#pod reference. It takes an optional hashref of options. If the hashref contains
#pod a C<version> argument, the copied metadata will be converted to the version
#pod of the specification and returned. For example:
#pod
#pod my $old_spec = $meta->as_struct( {version => "1.4"} );
#pod
#pod =cut
sub as_struct {
my ($self, $options) = @_;
my $struct = _dclone($self);
if ( $options->{version} ) {
my $cmc = CPAN::Meta::Converter->new( $struct );
$struct = $cmc->convert( version => $options->{version} );
}
return $struct;
}
#pod =method as_string
#pod
#pod my $string = $meta->as_string( \%options );
#pod
#pod This method returns a serialized copy of the object's metadata as a character
#pod string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref
#pod of options. If the hashref contains a C<version> argument, the copied metadata
#pod will be converted to the version of the specification and returned. For
#pod example:
#pod
#pod my $string = $meta->as_string( {version => "1.4"} );
#pod
#pod For C<version> greater than or equal to 2, the string will be serialized as
#pod JSON. For C<version> less than 2, the string will be serialized as YAML. In
#pod both cases, the same rules are followed as in the C<save()> method for choosing
#pod a serialization backend.
#pod
#pod =cut
sub as_string {
my ($self, $options) = @_;
my $version = $options->{version} || '2';
my $struct;
if ( $self->meta_spec_version ne $version ) {
my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
$struct = $cmc->convert( version => $version );
}
else {
$struct = $self->as_struct;
}
my ($data, $backend);
if ( $version ge '2' ) {
$backend = Parse::CPAN::Meta->json_backend();
$data = $backend->new->pretty->canonical->encode($struct);
}
else {
$backend = Parse::CPAN::Meta->yaml_backend();
$data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
if ( $@ ) {
croak $backend->can('errstr') ? $backend->errstr : $@
}
}
return $data;
}
# Used by JSON::PP, etc. for "convert_blessed"
sub TO_JSON {
return { %{ $_[0] } };
}
1;
# ABSTRACT: the distribution metadata for a CPAN dist
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta - the distribution metadata for a CPAN dist
=head1 VERSION
version 2.143240
=head1 SYNOPSIS
use v5.10;
use strict;
use warnings;
use CPAN::Meta;
use Module::Load;
my $meta = CPAN::Meta->load_file('META.json');
printf "testing requirements for %s version %s\n",
$meta->name,
$meta->version;
my $prereqs = $meta->effective_prereqs;
for my $phase ( qw/configure runtime build test/ ) {
say "Requirements for $phase:";
my $reqs = $prereqs->requirements_for($phase, "requires");
for my $module ( sort $reqs->required_modules ) {
my $status;
if ( eval { load $module unless $module eq 'perl'; 1 } ) {
my $version = $module eq 'perl' ? $] : $module->VERSION;
$status = $reqs->accepts_module($module, $version)
? "$version ok" : "$version not ok";
} else {
$status = "missing"
};
say " $module ($status)";
}
}
=head1 DESCRIPTION
Software distributions released to the CPAN include a F<META.json> or, for
older distributions, F<META.yml>, which describes the distribution, its
contents, and the requirements for building and installing the distribution.
The data structure stored in the F<META.json> file is described in
L<CPAN::Meta::Spec>.
CPAN::Meta provides a simple class to represent this distribution metadata (or
I<distmeta>), along with some helpful methods for interrogating that data.
The documentation below is only for the methods of the CPAN::Meta object. For
information on the meaning of individual fields, consult the spec.
=head1 METHODS
=head2 new
my $meta = CPAN::Meta->new($distmeta_struct, \%options);
Returns a valid CPAN::Meta object or dies if the supplied metadata hash
reference fails to validate. Older-format metadata will be up-converted to
version 2 if they validate against the original stated specification.
It takes an optional hashref of options. Valid options include:
=over
=item *
lazy_validation -- if true, new will attempt to convert the given metadata
to version 2 before attempting to validate it. This means than any
fixable errors will be handled by CPAN::Meta::Converter before validation.
(Note that this might result in invalid optional data being silently
dropped.) The default is false.
=back
=head2 create
my $meta = CPAN::Meta->create($distmeta_struct, \%options);
This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
will be generated if not provided. This means the metadata structure is
assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
=head2 load_file
my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
Given a pathname to a file containing metadata, this deserializes the file
according to its file suffix and constructs a new C<CPAN::Meta> object, just
like C<new()>. It will die if the deserialized version fails to validate
against its stated specification version.
It takes the same options as C<new()> but C<lazy_validation> defaults to
true.
=head2 load_yaml_string
my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
This method returns a new CPAN::Meta object using the first document in the
given YAML string. In other respects it is identical to C<load_file()>.
=head2 load_json_string
my $meta = CPAN::Meta->load_json_string($json, \%options);
This method returns a new CPAN::Meta object using the structure represented by
the given JSON string. In other respects it is identical to C<load_file()>.
=head2 load_string
my $meta = CPAN::Meta->load_string($string, \%options);
If you don't know if a string contains YAML or JSON, this method will use
L<Parse::CPAN::Meta> to guess. In other respects it is identical to
C<load_file()>.
=head2 save
$meta->save($distmeta_file, \%options);
Serializes the object as JSON and writes it to the given file. The only valid
option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
is saved with UTF-8 encoding.
For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
backend like L<JSON::XS>.
For C<version> less than 2, the filename should end in '.yml'.
L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may
set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
this is not recommended due to subtle incompatibilities between YAML parsers on
CPAN.
=head2 meta_spec_version
This method returns the version part of the C<meta_spec> entry in the distmeta
structure. It is equivalent to:
$meta->meta_spec->{version};
=head2 effective_prereqs
my $prereqs = $meta->effective_prereqs;
my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
This method returns a L<CPAN::Meta::Prereqs> object describing all the
prereqs for the distribution. If an arrayref of feature identifiers is given,
the prereqs for the identified features are merged together with the
distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
=head2 should_index_file
... if $meta->should_index_file( $filename );
This method returns true if the given file should be indexed. It decides this
by checking the C<file> and C<directory> keys in the C<no_index> property of
the distmeta structure. Note that neither the version format nor
C<release_status> are considered.
C<$filename> should be given in unix format.
=head2 should_index_package
... if $meta->should_index_package( $package );
This method returns true if the given package should be indexed. It decides
this by checking the C<package> and C<namespace> keys in the C<no_index>
property of the distmeta structure. Note that neither the version format nor
C<release_status> are considered.
=head2 features
my @feature_objects = $meta->features;
This method returns a list of L<CPAN::Meta::Feature> objects, one for each
optional feature described by the distribution's metadata.
=head2 feature
my $feature_object = $meta->feature( $identifier );
This method returns a L<CPAN::Meta::Feature> object for the optional feature
with the given identifier. If no feature with that identifier exists, an
exception will be raised.
=head2 as_struct
my $copy = $meta->as_struct( \%options );
This method returns a deep copy of the object's metadata as an unblessed hash
reference. It takes an optional hashref of options. If the hashref contains
a C<version> argument, the copied metadata will be converted to the version
of the specification and returned. For example:
my $old_spec = $meta->as_struct( {version => "1.4"} );
=head2 as_string
my $string = $meta->as_string( \%options );
This method returns a serialized copy of the object's metadata as a character
string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref
of options. If the hashref contains a C<version> argument, the copied metadata
will be converted to the version of the specification and returned. For
example:
my $string = $meta->as_string( {version => "1.4"} );
For C<version> greater than or equal to 2, the string will be serialized as
JSON. For C<version> less than 2, the string will be serialized as YAML. In
both cases, the same rules are followed as in the C<save()> method for choosing
a serialization backend.
=head1 STRING DATA
The following methods return a single value, which is the value for the
corresponding entry in the distmeta structure. Values should be either undef
or strings.
=over 4
=item *
abstract
=item *
description
=item *
dynamic_config
=item *
generated_by
=item *
name
=item *
release_status
=item *
version
=back
=head1 LIST DATA
These methods return lists of string values, which might be represented in the
distmeta structure as arrayrefs or scalars:
=over 4
=item *
authors
=item *
keywords
=item *
licenses
=back
The C<authors> and C<licenses> methods may also be called as C<author> and
C<license>, respectively, to match the field name in the distmeta structure.
=head1 MAP DATA
These readers return hashrefs of arbitrary unblessed data structures, each
described more fully in the specification:
=over 4
=item *
meta_spec
=item *
resources
=item *
provides
=item *
no_index
=item *
prereqs
=item *
optional_features
=back
=head1 CUSTOM DATA
A list of custom keys are available from the C<custom_keys> method and
particular keys may be retrieved with the C<custom> method.
say $meta->custom($_) for $meta->custom_keys;
If a custom key refers to a data structure, a deep clone is returned.
=for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config
generated_by keywords license licenses meta_spec name no_index
optional_features prereqs provides release_status resources version
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 SEE ALSO
=over 4
=item *
L<CPAN::Meta::Converter>
=item *
L<CPAN::Meta::Validator>
=back
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta>
git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 CONTRIBUTORS
=for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern moznion Olaf Alders Olivier Mengue Randy Sims
=over 4
=item *
Ansgar Burchardt <[email protected]>
=item *
Avar Arnfjord Bjarmason <[email protected]>
=item *
Christopher J. Madsen <[email protected]>
=item *
Chuck Adams <[email protected]>
=item *
Cory G Watson <[email protected]>
=item *
Damyan Ivanov <[email protected]>
=item *
Eric Wilhelm <[email protected]>
=item *
Graham Knop <[email protected]>
=item *
Gregor Hermann <[email protected]>
=item *
Karen Etheridge <[email protected]>
=item *
Kenichi Ishigaki <[email protected]>
=item *
Ken Williams <[email protected]>
=item *
Lars Dieckow <[email protected]>
=item *
Leon Timmermans <[email protected]>
=item *
majensen <[email protected]>
=item *
Mark Fowler <[email protected]>
=item *
Matt S Trout <[email protected]>
=item *
Michael G. Schwern <[email protected]>
=item *
moznion <[email protected]>
=item *
Olaf Alders <[email protected]>
=item *
Olivier Mengue <[email protected]>
=item *
Randy Sims <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META
$fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Converter;
# VERSION
$CPAN::Meta::Converter::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod my $struct = decode_json_file('META.json');
#pod
#pod my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod my $new_struct = $cmc->convert( version => "2" );
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module converts CPAN Meta structures from one form to another. The
#pod primary use is to convert older structures to the most modern version of
#pod the specification, but other transformations may be implemented in the
#pod future as needed. (E.g. stripping all custom fields or stripping all
#pod optional fields.)
#pod
#pod =cut
use CPAN::Meta::Validator;
use CPAN::Meta::Requirements;
use Parse::CPAN::Meta 1.4400 ();
# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available. This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.
BEGIN {
eval "use version ()"; ## no critic
if ( my $err = $@ ) {
eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
}
}
# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
sub _dclone {
my $ref = shift;
# if an object is in the data structure and doesn't specify how to
# turn itself into JSON, we just stringify the object. That does the
# right thing for typical things that might be there, like version objects,
# Path::Class objects, etc.
no warnings 'once';
no warnings 'redefine';
local *UNIVERSAL::TO_JSON = sub { "$_[0]" };
my $json = Parse::CPAN::Meta->json_backend()->new
->utf8
->allow_blessed
->convert_blessed;
$json->decode($json->encode($ref))
}
my %known_specs = (
'2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
'1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
'1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
'1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
'1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
'1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);
my @spec_list = sort { $a <=> $b } keys %known_specs;
my ($LOWEST, $HIGHEST) = @spec_list[0,-1];
#--------------------------------------------------------------------------#
# converters
#
# called as $converter->($element, $field_name, $full_meta, $to_version)
#
# defined return value used for field
# undef return value means field is skipped
#--------------------------------------------------------------------------#
sub _keep { $_[0] }
sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
sub _generated_by {
my $gen = shift;
my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
return $sig unless defined $gen and length $gen;
return $gen if $gen =~ /\Q$sig/;
return "$gen, $sig";
}
sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
sub _prefix_custom {
my $key = shift;
$key =~ s/^(?!x_) # Unless it already starts with x_
(?:x-?)? # Remove leading x- or x (if present)
/x_/ix; # and prepend x_
return $key;
}
sub _ucfirst_custom {
my $key = shift;
$key = ucfirst $key unless $key =~ /[A-Z]/;
return $key;
}
sub _no_prefix_ucfirst_custom {
my $key = shift;
$key =~ s/^x_//;
return _ucfirst_custom($key);
}
sub _change_meta_spec {
my ($element, undef, undef, $version) = @_;
return {
version => $version,
url => $known_specs{$version},
};
}
my @open_source = (
'perl',
'gpl',
'apache',
'artistic',
'artistic_2',
'lgpl',
'bsd',
'gpl',
'mit',
'mozilla',
'open_source',
);
my %is_open_source = map {; $_ => 1 } @open_source;
my @valid_licenses_1 = (
@open_source,
'unrestricted',
'restrictive',
'unknown',
);
my %license_map_1 = (
( map { $_ => $_ } @valid_licenses_1 ),
artistic2 => 'artistic_2',
);
sub _license_1 {
my ($element) = @_;
return 'unknown' unless defined $element;
if ( $license_map_1{lc $element} ) {
return $license_map_1{lc $element};
}
else {
return 'unknown';
}
}
my @valid_licenses_2 = qw(
agpl_3
apache_1_1
apache_2_0
artistic_1
artistic_2
bsd
freebsd
gfdl_1_2
gfdl_1_3
gpl_1
gpl_2
gpl_3
lgpl_2_1
lgpl_3_0
mit
mozilla_1_0
mozilla_1_1
openssl
perl_5
qpl_1_0
ssleay
sun
zlib
open_source
restricted
unrestricted
unknown
);
# The "old" values were defined by Module::Build, and were often vague. I have
# made the decisions below based on reading Module::Build::API and how clearly
# it specifies the version of the license.
my %license_map_2 = (
(map { $_ => $_ } @valid_licenses_2),
apache => 'apache_2_0', # clearly stated as 2.0
artistic => 'artistic_1', # clearly stated as 1
artistic2 => 'artistic_2', # clearly stated as 2
gpl => 'open_source', # we don't know which GPL; punt
lgpl => 'open_source', # we don't know which LGPL; punt
mozilla => 'open_source', # we don't know which MPL; punt
perl => 'perl_5', # clearly Perl 5
restrictive => 'restricted',
);
sub _license_2 {
my ($element) = @_;
return [ 'unknown' ] unless defined $element;
$element = [ $element ] unless ref $element eq 'ARRAY';
my @new_list;
for my $lic ( @$element ) {
next unless defined $lic;
if ( my $new = $license_map_2{lc $lic} ) {
push @new_list, $new;
}
}
return @new_list ? \@new_list : [ 'unknown' ];
}
my %license_downgrade_map = qw(
agpl_3 open_source
apache_1_1 apache
apache_2_0 apache
artistic_1 artistic
artistic_2 artistic_2
bsd bsd
freebsd open_source
gfdl_1_2 open_source
gfdl_1_3 open_source
gpl_1 gpl
gpl_2 gpl
gpl_3 gpl
lgpl_2_1 lgpl
lgpl_3_0 lgpl
mit mit
mozilla_1_0 mozilla
mozilla_1_1 mozilla
openssl open_source
perl_5 perl
qpl_1_0 open_source
ssleay open_source
sun open_source
zlib open_source
open_source open_source
restricted restrictive
unrestricted unrestricted
unknown unknown
);
sub _downgrade_license {
my ($element) = @_;
if ( ! defined $element ) {
return "unknown";
}
elsif( ref $element eq 'ARRAY' ) {
if ( @$element > 1) {
if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
return 'unknown';
}
else {
return 'open_source';
}
}
elsif ( @$element == 1 ) {
return $license_downgrade_map{lc $element->[0]} || "unknown";
}
}
elsif ( ! ref $element ) {
return $license_downgrade_map{lc $element} || "unknown";
}
return "unknown";
}
my $no_index_spec_1_2 = {
'file' => \&_listify,
'dir' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
};
my $no_index_spec_1_3 = {
'file' => \&_listify,
'directory' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
};
my $no_index_spec_2 = {
'file' => \&_listify,
'directory' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
':custom' => \&_prefix_custom,
};
sub _no_index_1_2 {
my (undef, undef, $meta) = @_;
my $no_index = $meta->{no_index} || $meta->{private};
return unless $no_index;
# cleanup wrong format
if ( ! ref $no_index ) {
my $item = $no_index;
$no_index = { dir => [ $item ], file => [ $item ] };
}
elsif ( ref $no_index eq 'ARRAY' ) {
my $list = $no_index;
$no_index = { dir => [ @$list ], file => [ @$list ] };
}
# common mistake: files -> file
if ( exists $no_index->{files} ) {
$no_index->{file} = delete $no_index->{file};
}
# common mistake: modules -> module
if ( exists $no_index->{modules} ) {
$no_index->{module} = delete $no_index->{module};
}
return _convert($no_index, $no_index_spec_1_2);
}
sub _no_index_directory {
my ($element, $key, $meta, $version) = @_;
return unless $element;
# cleanup wrong format
if ( ! ref $element ) {
my $item = $element;
$element = { directory => [ $item ], file => [ $item ] };
}
elsif ( ref $element eq 'ARRAY' ) {
my $list = $element;
$element = { directory => [ @$list ], file => [ @$list ] };
}
if ( exists $element->{dir} ) {
$element->{directory} = delete $element->{dir};
}
# common mistake: files -> file
if ( exists $element->{files} ) {
$element->{file} = delete $element->{file};
}
# common mistake: modules -> module
if ( exists $element->{modules} ) {
$element->{module} = delete $element->{module};
}
my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
return _convert($element, $spec);
}
sub _is_module_name {
my $mod = shift;
return unless defined $mod && length $mod;
return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
}
sub _clean_version {
my ($element) = @_;
return 0 if ! defined $element;
$element =~ s{^\s*}{};
$element =~ s{\s*$}{};
$element =~ s{^\.}{0.};
return 0 if ! length $element;
return 0 if ( $element eq 'undef' || $element eq '<undef>' );
my $v = eval { version->new($element) };
# XXX check defined $v and not just $v because version objects leak memory
# in boolean context -- dagolden, 2012-02-03
if ( defined $v ) {
return _is_qv($v) ? $v->normal : $element;
}
else {
return 0;
}
}
sub _bad_version_hook {
my ($v) = @_;
$v =~ s{[a-z]+$}{}; # strip trailing alphabetics
my $vobj = eval { version->new($v) };
return defined($vobj) ? $vobj : version->new(0); # or give up
}
sub _version_map {
my ($element) = @_;
return unless defined $element;
if ( ref $element eq 'HASH' ) {
# XXX turn this into CPAN::Meta::Requirements with bad version hook
# and then turn it back into a hash
my $new_map = CPAN::Meta::Requirements->new(
{ bad_version_hook => \&_bad_version_hook } # punt
);
while ( my ($k,$v) = each %$element ) {
next unless _is_module_name($k);
if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) {
$v = 0;
}
# some weird, old META have bad yml with module => module
# so check if value is like a module name and not like a version
if ( _is_module_name($v) && ! version::is_lax($v) ) {
$new_map->add_minimum($k => 0);
$new_map->add_minimum($v => 0);
}
$new_map->add_string_requirement($k => $v);
}
return $new_map->as_string_hash;
}
elsif ( ref $element eq 'ARRAY' ) {
my $hashref = { map { $_ => 0 } @$element };
return _version_map($hashref); # cleanup any weird stuff
}
elsif ( ref $element eq '' && length $element ) {
return { $element => 0 }
}
return;
}
sub _prereqs_from_1 {
my (undef, undef, $meta) = @_;
my $prereqs = {};
for my $phase ( qw/build configure/ ) {
my $key = "${phase}_requires";
$prereqs->{$phase}{requires} = _version_map($meta->{$key})
if $meta->{$key};
}
for my $rel ( qw/requires recommends conflicts/ ) {
$prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
if $meta->{$rel};
}
return $prereqs;
}
my $prereqs_spec = {
configure => \&_prereqs_rel,
build => \&_prereqs_rel,
test => \&_prereqs_rel,
runtime => \&_prereqs_rel,
develop => \&_prereqs_rel,
':custom' => \&_prefix_custom,
};
my $relation_spec = {
requires => \&_version_map,
recommends => \&_version_map,
suggests => \&_version_map,
conflicts => \&_version_map,
':custom' => \&_prefix_custom,
};
sub _cleanup_prereqs {
my ($prereqs, $key, $meta, $to_version) = @_;
return unless $prereqs && ref $prereqs eq 'HASH';
return _convert( $prereqs, $prereqs_spec, $to_version );
}
sub _prereqs_rel {
my ($relation, $key, $meta, $to_version) = @_;
return unless $relation && ref $relation eq 'HASH';
return _convert( $relation, $relation_spec, $to_version );
}
BEGIN {
my @old_prereqs = qw(
requires
configure_requires
recommends
conflicts
);
for ( @old_prereqs ) {
my $sub = "_get_$_";
my ($phase,$type) = split qr/_/, $_;
if ( ! defined $type ) {
$type = $phase;
$phase = 'runtime';
}
no strict 'refs';
*{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
}
}
sub _get_build_requires {
my ($data, $key, $meta) = @_;
my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
$test_req->add_requirements($build_req)->as_string_hash;
}
sub _extract_prereqs {
my ($prereqs, $phase, $type) = @_;
return unless ref $prereqs eq 'HASH';
return scalar _version_map($prereqs->{$phase}{$type});
}
sub _downgrade_optional_features {
my (undef, undef, $meta) = @_;
return unless exists $meta->{optional_features};
my $origin = $meta->{optional_features};
my $features = {};
for my $name ( keys %$origin ) {
$features->{$name} = {
description => $origin->{$name}{description},
requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
};
for my $k (keys %{$features->{$name}} ) {
delete $features->{$name}{$k} unless defined $features->{$name}{$k};
}
}
return $features;
}
sub _upgrade_optional_features {
my (undef, undef, $meta) = @_;
return unless exists $meta->{optional_features};
my $origin = $meta->{optional_features};
my $features = {};
for my $name ( keys %$origin ) {
$features->{$name} = {
description => $origin->{$name}{description},
prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
};
delete $features->{$name}{prereqs}{configure};
}
return $features;
}
my $optional_features_2_spec = {
description => \&_keep,
prereqs => \&_cleanup_prereqs,
':custom' => \&_prefix_custom,
};
sub _feature_2 {
my ($element, $key, $meta, $to_version) = @_;
return unless $element && ref $element eq 'HASH';
_convert( $element, $optional_features_2_spec, $to_version );
}
sub _cleanup_optional_features_2 {
my ($element, $key, $meta, $to_version) = @_;
return unless $element && ref $element eq 'HASH';
my $new_data = {};
for my $k ( keys %$element ) {
$new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
}
return unless keys %$new_data;
return $new_data;
}
sub _optional_features_1_4 {
my ($element) = @_;
return unless $element;
$element = _optional_features_as_map($element);
for my $name ( keys %$element ) {
for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
delete $element->{$name}{$drop};
}
}
return $element;
}
sub _optional_features_as_map {
my ($element) = @_;
return unless $element;
if ( ref $element eq 'ARRAY' ) {
my %map;
for my $feature ( @$element ) {
my (@parts) = %$feature;
$map{$parts[0]} = $parts[1];
}
$element = \%map;
}
return $element;
}
sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
sub _url_or_drop {
my ($element) = @_;
return $element if _is_urlish($element);
return;
}
sub _url_list {
my ($element) = @_;
return unless $element;
$element = _listify( $element );
$element = [ grep { _is_urlish($_) } @$element ];
return unless @$element;
return $element;
}
sub _author_list {
my ($element) = @_;
return [ 'unknown' ] unless $element;
$element = _listify( $element );
$element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
return [ 'unknown' ] unless @$element;
return $element;
}
my $resource2_upgrade = {
license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
homepage => \&_url_or_drop,
bugtracker => sub {
my ($item) = @_;
return unless $item;
if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
elsif( _is_urlish($item) ) { return { web => $item } }
else { return }
},
repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
':custom' => \&_prefix_custom,
};
sub _upgrade_resources_2 {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource2_upgrade);
}
my $bugtracker2_spec = {
web => \&_url_or_drop,
mailto => \&_keep,
':custom' => \&_prefix_custom,
};
sub _repo_type {
my ($element, $key, $meta, $to_version) = @_;
return $element if defined $element;
return unless exists $meta->{url};
my $repo_url = $meta->{url};
for my $type ( qw/git svn/ ) {
return $type if $repo_url =~ m{\A$type};
}
return;
}
my $repository2_spec = {
web => \&_url_or_drop,
url => \&_url_or_drop,
type => \&_repo_type,
':custom' => \&_prefix_custom,
};
my $resources2_cleanup = {
license => \&_url_list,
homepage => \&_url_or_drop,
bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
':custom' => \&_prefix_custom,
};
sub _cleanup_resources_2 {
my ($resources, $key, $meta, $to_version) = @_;
return unless $resources && ref $resources eq 'HASH';
return _convert($resources, $resources2_cleanup, $to_version);
}
my $resource1_spec = {
license => \&_url_or_drop,
homepage => \&_url_or_drop,
bugtracker => \&_url_or_drop,
repository => \&_url_or_drop,
':custom' => \&_keep,
};
sub _resources_1_3 {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource1_spec);
}
*_resources_1_4 = *_resources_1_3;
sub _resources_1_2 {
my (undef, undef, $meta) = @_;
my $resources = $meta->{resources} || {};
if ( $meta->{license_url} && ! $resources->{license} ) {
$resources->{license} = $meta->{license_url}
if _is_urlish($meta->{license_url});
}
return unless keys %$resources;
return _convert($resources, $resource1_spec);
}
my $resource_downgrade_spec = {
license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
homepage => \&_url_or_drop,
bugtracker => sub { return $_[0]->{web} },
repository => sub { return $_[0]->{url} || $_[0]->{web} },
':custom' => \&_no_prefix_ucfirst_custom,
};
sub _downgrade_resources {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource_downgrade_spec);
}
sub _release_status {
my ($element, undef, $meta) = @_;
return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
return _release_status_from_version(undef, undef, $meta);
}
sub _release_status_from_version {
my (undef, undef, $meta) = @_;
my $version = $meta->{version} || '';
return ( $version =~ /_/ ) ? 'testing' : 'stable';
}
my $provides_spec = {
file => \&_keep,
version => \&_keep,
};
my $provides_spec_2 = {
file => \&_keep,
version => \&_keep,
':custom' => \&_prefix_custom,
};
sub _provides {
my ($element, $key, $meta, $to_version) = @_;
return unless defined $element && ref $element eq 'HASH';
my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
my $new_data = {};
for my $k ( keys %$element ) {
$new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
$new_data->{$k}{version} = _clean_version($element->{$k}{version})
if exists $element->{$k}{version};
}
return $new_data;
}
sub _convert {
my ($data, $spec, $to_version, $is_fragment) = @_;
my $new_data = {};
for my $key ( keys %$spec ) {
next if $key eq ':custom' || $key eq ':drop';
next unless my $fcn = $spec->{$key};
if ( $is_fragment && $key eq 'generated_by' ) {
$fcn = \&_keep;
}
die "spec for '$key' is not a coderef"
unless ref $fcn && ref $fcn eq 'CODE';
my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
$new_data->{$key} = $new_value if defined $new_value;
}
my $drop_list = $spec->{':drop'};
my $customizer = $spec->{':custom'} || \&_keep;
for my $key ( keys %$data ) {
next if $drop_list && grep { $key eq $_ } @$drop_list;
next if exists $spec->{$key}; # we handled it
$new_data->{ $customizer->($key) } = $data->{$key};
}
return $new_data;
}
#--------------------------------------------------------------------------#
# define converters for each conversion
#--------------------------------------------------------------------------#
# each converts from prior version
# special ":custom" field is used for keys not recognized in spec
my %up_convert = (
'2-from-1.4' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_2,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# CHANGED TO MANDATORY
'dynamic_config' => \&_keep_or_one,
# ADDED MANDATORY
'release_status' => \&_release_status_from_version,
# PRIOR OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_upgrade_optional_features,
'provides' => \&_provides,
'resources' => \&_upgrade_resources_2,
# ADDED OPTIONAL
'description' => \&_keep,
'prereqs' => \&_prereqs_from_1,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
build_requires
configure_requires
conflicts
distribution_type
license_url
private
recommends
requires
) ],
# other random keys need x_ prefixing
':custom' => \&_prefix_custom,
},
'1.4-from-1.3' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_1_4,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_4,
# ADDED OPTIONAL
'configure_requires' => \&_keep,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.3-from-1.2' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.2-from-1.1' => {
# PRIOR MANDATORY
'version' => \&_keep,
# CHANGED TO MANDATORY
'license' => \&_license_1,
'name' => \&_keep,
'generated_by' => \&_generated_by,
# ADDED MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'resources' => \&_resources_1_2,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.1-from-1.0' => {
# CHANGED TO MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'license_url' => \&_url_or_drop,
'private' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
);
my %down_convert = (
'1.4-from-2' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_downgrade_license,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_get_build_requires,
'configure_requires' => \&_get_configure_requires,
'conflicts' => \&_get_conflicts,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_downgrade_optional_features,
'provides' => \&_provides,
'recommends' => \&_get_recommends,
'requires' => \&_get_requires,
'resources' => \&_downgrade_resources,
# drop these unsupported fields (after conversion)
':drop' => [ qw(
description
prereqs
release_status
)],
# custom keys will be left unchanged
':custom' => \&_keep
},
'1.3-from-1.4' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# drop these unsupported fields, but only after we convert
':drop' => [ qw(
configure_requires
)],
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.2-from-1.3' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.1-from-1.2' => {
# MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'private' => \&_keep,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# drop unsupported fields
':drop' => [ qw(
abstract
author
provides
no_index
keywords
resources
)],
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.0-from-1.1' => {
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# other random keys are OK if already valid
':custom' => \&_keep,
},
);
my %cleanup = (
'2' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_2,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# CHANGED TO MANDATORY
'dynamic_config' => \&_keep_or_one,
# ADDED MANDATORY
'release_status' => \&_release_status,
# PRIOR OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_cleanup_optional_features_2,
'provides' => \&_provides,
'resources' => \&_cleanup_resources_2,
# ADDED OPTIONAL
'description' => \&_keep,
'prereqs' => \&_cleanup_prereqs,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
build_requires
configure_requires
conflicts
distribution_type
license_url
private
recommends
requires
) ],
# other random keys need x_ prefixing
':custom' => \&_prefix_custom,
},
'1.4' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_1_4,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_4,
# ADDED OPTIONAL
'configure_requires' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.3' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.2' => {
# PRIOR MANDATORY
'version' => \&_keep,
# CHANGED TO MANDATORY
'license' => \&_license_1,
'name' => \&_keep,
'generated_by' => \&_generated_by,
# ADDED MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'resources' => \&_resources_1_2,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.1' => {
# CHANGED TO MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'license_url' => \&_url_or_drop,
'private' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.0' => {
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
'version' => \&_keep,
# IMPLIED OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# other random keys are OK if already valid
':custom' => \&_keep,
},
);
# for a given field in a spec version, what fields will it feed
# into in the *latest* spec (i.e. v2); meta-spec omitted because
# we always expect a meta-spec to be generated
my %fragments_generate = (
'2' => {
'abstract' => 'abstract',
'author' => 'author',
'generated_by' => 'generated_by',
'license' => 'license',
'name' => 'name',
'version' => 'version',
'dynamic_config' => 'dynamic_config',
'release_status' => 'release_status',
'keywords' => 'keywords',
'no_index' => 'no_index',
'optional_features' => 'optional_features',
'provides' => 'provides',
'resources' => 'resources',
'description' => 'description',
'prereqs' => 'prereqs',
},
'1.4' => {
'abstract' => 'abstract',
'author' => 'author',
'generated_by' => 'generated_by',
'license' => 'license',
'name' => 'name',
'version' => 'version',
'build_requires' => 'prereqs',
'conflicts' => 'prereqs',
'distribution_type' => 'distribution_type',
'dynamic_config' => 'dynamic_config',
'keywords' => 'keywords',
'no_index' => 'no_index',
'optional_features' => 'optional_features',
'provides' => 'provides',
'recommends' => 'prereqs',
'requires' => 'prereqs',
'resources' => 'resources',
'configure_requires' => 'prereqs',
},
);
# this is not quite true but will work well enough
# as 1.4 is a superset of earlier ones
$fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;
#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#
#pod =method new
#pod
#pod my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod The constructor should be passed a valid metadata structure but invalid
#pod structures are accepted. If no meta-spec version is provided, version 1.0 will
#pod be assumed.
#pod
#pod Optionally, you can provide a C<default_version> argument after C<$struct>:
#pod
#pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
#pod
#pod This is only needed when converting a metadata fragment that does not include a
#pod C<meta-spec> field.
#pod
#pod =cut
sub new {
my ($class,$data,%args) = @_;
# create an attributes hash
my $self = {
'data' => $data,
'spec' => _extract_spec_version($data, $args{default_version}),
};
# create the object
return bless $self, $class;
}
sub _extract_spec_version {
my ($data, $default) = @_;
my $spec = $data->{'meta-spec'};
# is meta-spec there and valid?
return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?
# does the version key look like a valid version?
my $v = $spec->{version};
if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
}
# otherwise, use heuristics: look for 1.x vs 2.0 fields
return "2" if exists $data->{prereqs};
return "1.4" if exists $data->{configure_requires};
return( $default || "1.2" ); # when meta-spec was first defined
}
#pod =method convert
#pod
#pod my $new_struct = $cmc->convert( version => "2" );
#pod
#pod Returns a new hash reference with the metadata converted to a different form.
#pod C<convert> will die if any conversion/standardization still results in an
#pod invalid structure.
#pod
#pod Valid parameters include:
#pod
#pod =over
#pod
#pod =item *
#pod
#pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
#pod Defaults to the latest version of the CPAN Meta Spec.
#pod
#pod =back
#pod
#pod Conversion proceeds through each version in turn. For example, a version 1.2
#pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
#pod conversion process attempts to clean-up simple errors and standardize data.
#pod For example, if C<author> is given as a scalar, it will converted to an array
#pod reference containing the item. (Converting a structure to its own version will
#pod also clean-up and standardize.)
#pod
#pod When data are cleaned and standardized, missing or invalid fields will be
#pod replaced with sensible defaults when possible. This may be lossy or imprecise.
#pod For example, some badly structured META.yml files on CPAN have prerequisite
#pod modules listed as both keys and values:
#pod
#pod requires => { 'Foo::Bar' => 'Bam::Baz' }
#pod
#pod These would be split and each converted to a prerequisite with a minimum
#pod version of zero.
#pod
#pod When some mandatory fields are missing or invalid, the conversion will attempt
#pod to provide a sensible default or will fill them with a value of 'unknown'. For
#pod example a missing or unrecognized C<license> field will result in a C<license>
#pod field of 'unknown'. Fields that may get an 'unknown' include:
#pod
#pod =for :list
#pod * abstract
#pod * author
#pod * license
#pod
#pod =cut
sub convert {
my ($self, %args) = @_;
my $args = { %args };
my $new_version = $args->{version} || $HIGHEST;
my $is_fragment = $args->{is_fragment};
my ($old_version) = $self->{spec};
my $converted = _dclone($self->{data});
if ( $old_version == $new_version ) {
$converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
}
}
return $converted;
}
elsif ( $old_version > $new_version ) {
my @vers = sort { $b <=> $a } keys %known_specs;
for my $i ( 0 .. $#vers-1 ) {
next if $vers[$i] > $old_version;
last if $vers[$i+1] < $new_version;
my $spec_string = "$vers[$i+1]-from-$vers[$i]";
$converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
}
}
}
return $converted;
}
else {
my @vers = sort { $a <=> $b } keys %known_specs;
for my $i ( 0 .. $#vers-1 ) {
next if $vers[$i] < $old_version;
last if $vers[$i+1] > $new_version;
my $spec_string = "$vers[$i+1]-from-$vers[$i]";
$converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
}
}
}
return $converted;
}
}
#pod =method upgrade_fragment
#pod
#pod my $new_struct = $cmc->upgrade_fragment;
#pod
#pod Returns a new hash reference with the metadata converted to the latest version
#pod of the CPAN Meta Spec. No validation is done on the result -- you must
#pod validate after merging fragments into a complete metadata document.
#pod
#pod =cut
sub upgrade_fragment {
my ($self) = @_;
my ($old_version) = $self->{spec};
my %expected =
map {; $_ => 1 }
grep { defined }
map { $fragments_generate{$old_version}{$_} }
keys %{ $self->{data} };
my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
for my $key ( keys %$converted ) {
next if $key =~ /^x_/i || $key eq 'meta-spec';
delete $converted->{$key} unless $expected{$key};
}
return $converted;
}
1;
# ABSTRACT: Convert CPAN distribution metadata structures
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Converter - Convert CPAN distribution metadata structures
=head1 VERSION
version 2.143240
=head1 SYNOPSIS
my $struct = decode_json_file('META.json');
my $cmc = CPAN::Meta::Converter->new( $struct );
my $new_struct = $cmc->convert( version => "2" );
=head1 DESCRIPTION
This module converts CPAN Meta structures from one form to another. The
primary use is to convert older structures to the most modern version of
the specification, but other transformations may be implemented in the
future as needed. (E.g. stripping all custom fields or stripping all
optional fields.)
=head1 METHODS
=head2 new
my $cmc = CPAN::Meta::Converter->new( $struct );
The constructor should be passed a valid metadata structure but invalid
structures are accepted. If no meta-spec version is provided, version 1.0 will
be assumed.
Optionally, you can provide a C<default_version> argument after C<$struct>:
my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
This is only needed when converting a metadata fragment that does not include a
C<meta-spec> field.
=head2 convert
my $new_struct = $cmc->convert( version => "2" );
Returns a new hash reference with the metadata converted to a different form.
C<convert> will die if any conversion/standardization still results in an
invalid structure.
Valid parameters include:
=over
=item *
C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
Defaults to the latest version of the CPAN Meta Spec.
=back
Conversion proceeds through each version in turn. For example, a version 1.2
structure might be converted to 1.3 then 1.4 then finally to version 2. The
conversion process attempts to clean-up simple errors and standardize data.
For example, if C<author> is given as a scalar, it will converted to an array
reference containing the item. (Converting a structure to its own version will
also clean-up and standardize.)
When data are cleaned and standardized, missing or invalid fields will be
replaced with sensible defaults when possible. This may be lossy or imprecise.
For example, some badly structured META.yml files on CPAN have prerequisite
modules listed as both keys and values:
requires => { 'Foo::Bar' => 'Bam::Baz' }
These would be split and each converted to a prerequisite with a minimum
version of zero.
When some mandatory fields are missing or invalid, the conversion will attempt
to provide a sensible default or will fill them with a value of 'unknown'. For
example a missing or unrecognized C<license> field will result in a C<license>
field of 'unknown'. Fields that may get an 'unknown' include:
=over 4
=item *
abstract
=item *
author
=item *
license
=back
=head2 upgrade_fragment
my $new_struct = $cmc->upgrade_fragment;
Returns a new hash reference with the metadata converted to the latest version
of the CPAN Meta Spec. No validation is done on the result -- you must
validate after merging fragments into a complete metadata document.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# vim: ts=2 sts=2 sw=2 et:
CPAN_META_CONVERTER
$fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;
# VERSION
$CPAN::Meta::Feature::VERSION = '2.143240';
use CPAN::Meta::Prereqs;
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
#pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
#pod file.
#pod
#pod For the most part, this class will only be used when operating on the result of
#pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
#pod
#pod =method new
#pod
#pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
#pod
#pod This returns a new Feature object. The C<%spec> argument to the constructor
#pod should be the same as the value of the C<optional_feature> entry in the
#pod distmeta. It must contain entries for C<description> and C<prereqs>.
#pod
#pod =cut
sub new {
my ($class, $identifier, $spec) = @_;
my %guts = (
identifier => $identifier,
description => $spec->{description},
prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}),
);
bless \%guts => $class;
}
#pod =method identifier
#pod
#pod This method returns the feature's identifier.
#pod
#pod =cut
sub identifier { $_[0]{identifier} }
#pod =method description
#pod
#pod This method returns the feature's long description.
#pod
#pod =cut
sub description { $_[0]{description} }
#pod =method prereqs
#pod
#pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
#pod object.
#pod
#pod =cut
sub prereqs { $_[0]{prereqs} }
1;
# ABSTRACT: an optional feature provided by a CPAN distribution
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Feature - an optional feature provided by a CPAN distribution
=head1 VERSION
version 2.143240
=head1 DESCRIPTION
A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
distribution and specified in the distribution's F<META.json> (or F<META.yml>)
file.
For the most part, this class will only be used when operating on the result of
the C<feature> or C<features> methods on a L<CPAN::Meta> object.
=head1 METHODS
=head2 new
my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
This returns a new Feature object. The C<%spec> argument to the constructor
should be the same as the value of the C<optional_feature> entry in the
distmeta. It must contain entries for C<description> and C<prereqs>.
=head2 identifier
This method returns the feature's identifier.
=head2 description
This method returns the feature's long description.
=head2 prereqs
This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
object.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META_FEATURE
$fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY';
# vi:tw=72
use 5.006;
use strict;
use warnings;
package CPAN::Meta::History;
# VERSION
$CPAN::Meta::History::VERSION = '2.143240';
1;
# ABSTRACT: history of CPAN Meta Spec changes
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::History - history of CPAN Meta Spec changes
=head1 VERSION
version 2.143240
=head1 DESCRIPTION
The CPAN Meta Spec has gone through several iterations. It was
originally written in HTML and later revised into POD (though published
in HTML generated from the POD). Fields were added, removed or changed,
sometimes by design and sometimes to reflect real-world usage after the
fact.
This document reconstructs the history of the CPAN Meta Spec based on
change logs, repository commit messages and the published HTML files.
In some cases, particularly prior to version 1.2, the exact version
when certain fields were introduced or changed is inconsistent between
sources. When in doubt, the published HTML files for versions 1.0 to
1.4 as they existed when version 2 was developed are used as the
definitive source.
Starting with version 2, the specification document is part of the
CPAN-Meta distribution and will be published on CPAN as
L<CPAN::Meta::Spec>.
Going forward, specification version numbers will be integers and
decimal portions will correspond to a release date for the CPAN::Meta
library.
=head1 HISTORY
=head2 Version 2
April 2010
=over
=item *
Revised spec examples as perl data structures rather than YAML
=item *
Switched to JSON serialization from YAML
=item *
Specified allowed version number formats
=item *
Replaced 'requires', 'build_requires', 'configure_requires',
'recommends' and 'conflicts' with new 'prereqs' data structure divided
by I<phase> (configure, build, test, runtime, etc.) and I<relationship>
(requires, recommends, suggests, conflicts)
=item *
Added support for 'develop' phase for requirements for maintaining
a list of authoring tools
=item *
Changed 'license' to a list and revised the set of valid licenses
=item *
Made 'dynamic_config' mandatory to reduce confusion
=item *
Changed 'resources' subkey 'repository' to a hash that clarifies
repository type, url for browsing and url for checkout
=item *
Changed 'resources' subkey 'bugtracker' to a hash for either web
or mailto resource
=item *
Changed specification of 'optional_features':
=over
=item *
Added formal specification and usage guide instead of just example
=item *
Changed to use new prereqs data structure instead of individual keys
=back
=item *
Clarified intended use of 'author' as generalized contact list
=item *
Added 'release_status' field to indicate stable, testing or unstable
status to provide hints to indexers
=item *
Added 'description' field for a longer description of the distribution
=item *
Formalized use of "x_" or "X_" for all custom keys not listed in the
official spec
=back
=head2 Version 1.4
June 2008
=over
=item *
Noted explicit support for 'perl' in prerequisites
=item *
Added 'configure_requires' prerequisite type
=item *
Changed 'optional_features'
=over
=item *
Example corrected to show map of maps instead of list of maps
(though descriptive text said 'map' even in v1.3)
=item *
Removed 'requires_packages', 'requires_os' and 'excluded_os'
as valid subkeys
=back
=back
=head2 Version 1.3
November 2006
=over
=item *
Added 'no_index' subkey 'directory' and removed 'dir' to match actual
usage in the wild
=item *
Added a 'repository' subkey to 'resources'
=back
=head2 Version 1.2
August 2005
=over
=item *
Re-wrote and restructured spec in POD syntax
=item *
Changed 'name' to be mandatory
=item *
Changed 'generated_by' to be mandatory
=item *
Changed 'license' to be mandatory
=item *
Added version range specifications for prerequisites
=item *
Added required 'abstract' field
=item *
Added required 'author' field
=item *
Added required 'meta-spec' field to define 'version' (and 'url') of the
CPAN Meta Spec used for metadata
=item *
Added 'provides' field
=item *
Added 'no_index' field and deprecated 'private' field. 'no_index'
subkeys include 'file', 'dir', 'package' and 'namespace'
=item *
Added 'keywords' field
=item *
Added 'resources' field with subkeys 'homepage', 'license', and
'bugtracker'
=item *
Added 'optional_features' field as an alternate under 'recommends'.
Includes 'description', 'requires', 'build_requires', 'conflicts',
'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys
=item *
Removed 'license_uri' field
=back
=head2 Version 1.1
May 2003
=over
=item *
Changed 'version' to be mandatory
=item *
Added 'private' field
=item *
Added 'license_uri' field
=back
=head2 Version 1.0
March 2003
=over
=item *
Original release (in HTML format only)
=item *
Included 'name', 'version', 'license', 'distribution_type', 'requires',
'recommends', 'build_requires', 'conflicts', 'dynamic_config',
'generated_by'
=back
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META_HISTORY
$fatpacked{"CPAN/Meta/Merge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_MERGE';
use strict;
use warnings;
package CPAN::Meta::Merge;
# VERSION
$CPAN::Meta::Merge::VERSION = '2.143240';
use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use CPAN::Meta::Converter;
sub _identical {
my ($left, $right, $path) = @_;
croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right unless $left eq $right;
return $left;
}
sub _merge {
my ($current, $next, $mergers, $path) = @_;
for my $key (keys %{$next}) {
if (not exists $current->{$key}) {
$current->{$key} = $next->{$key};
}
elsif (my $merger = $mergers->{$key}) {
$current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
}
elsif ($merger = $mergers->{':default'}) {
$current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
}
else {
croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
}
}
return $current;
}
sub _uniq {
my %seen = ();
return grep { not $seen{$_}++ } @_;
}
sub _set_addition {
my ($left, $right) = @_;
return [ +_uniq(@{$left}, @{$right}) ];
}
sub _uniq_map {
my ($left, $right, $path) = @_;
for my $key (keys %{$right}) {
if (not exists $left->{$key}) {
$left->{$key} = $right->{$key};
}
else {
croak 'Duplication of element ' . join '.', @{$path}, $key;
}
}
return $left;
}
sub _improvize {
my ($left, $right, $path) = @_;
my ($name) = reverse @{$path};
if ($name =~ /^x_/) {
if (ref($left) eq 'ARRAY') {
return _set_addition($left, $right, $path);
}
elsif (ref($left) eq 'HASH') {
return _uniq_map($left, $right, $path);
}
else {
return _identical($left, $right, $path);
}
}
croak sprintf "Can't merge '%s'", join '.', @{$path};
}
sub _optional_features {
my ($left, $right, $path) = @_;
for my $key (keys %{$right}) {
if (not exists $left->{$key}) {
$left->{$key} = $right->{$key};
}
else {
for my $subkey (keys %{ $right->{$key} }) {
next if $subkey eq 'prereqs';
if (not exists $left->{$key}{$subkey}) {
$left->{$key}{$subkey} = $right->{$key}{$subkey};
}
else {
Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
}
}
require CPAN::Meta::Prereqs;
$left->{$key}{prereqs} =
CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
->as_string_hash;
}
}
return $left;
}
my %default = (
abstract => \&_identical,
author => \&_set_addition,
dynamic_config => sub {
my ($left, $right) = @_;
return $left || $right;
},
generated_by => sub {
my ($left, $right) = @_;
return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
},
license => \&_set_addition,
'meta-spec' => {
version => \&_identical,
url => \&_identical
},
name => \&_identical,
release_status => \&_identical,
version => \&_identical,
description => \&_identical,
keywords => \&_set_addition,
no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
optional_features => \&_optional_features,
prereqs => sub {
require CPAN::Meta::Prereqs;
my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
return $left->with_merged_prereqs($right)->as_string_hash;
},
provides => \&_uniq_map,
resources => {
license => \&_set_addition,
homepage => \&_identical,
bugtracker => \&_uniq_map,
repository => \&_uniq_map,
':default' => \&_improvize,
},
':default' => \&_improvize,
);
sub new {
my ($class, %arguments) = @_;
croak 'default version required' if not exists $arguments{default_version};
my %mapping = %default;
my %extra = %{ $arguments{extra_mappings} || {} };
for my $key (keys %extra) {
if (ref($mapping{$key}) eq 'HASH') {
$mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
}
else {
$mapping{$key} = $extra{$key};
}
}
return bless {
default_version => $arguments{default_version},
mapping => _coerce_mapping(\%mapping, []),
}, $class;
}
my %coderef_for = (
set_addition => \&_set_addition,
uniq_map => \&_uniq_map,
identical => \&_identical,
improvize => \&_improvize,
);
sub _coerce_mapping {
my ($orig, $map_path) = @_;
my %ret;
for my $key (keys %{$orig}) {
my $value = $orig->{$key};
if (ref($orig->{$key}) eq 'CODE') {
$ret{$key} = $value;
}
elsif (ref($value) eq 'HASH') {
my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
$ret{$key} = sub {
my ($left, $right, $path) = @_;
return _merge($left, $right, $mapping, [ @{$path} ]);
};
}
elsif ($coderef_for{$value}) {
$ret{$key} = $coderef_for{$value};
}
else {
croak "Don't know what to do with " . join '.', @{$map_path}, $key;
}
}
return \%ret;
}
sub merge {
my ($self, @items) = @_;
my $current = {};
for my $next (@items) {
if ( blessed($next) && $next->isa('CPAN::Meta') ) {
$next = $next->as_struct;
}
elsif ( ref($next) eq 'HASH' ) {
my $cmc = CPAN::Meta::Converter->new(
$next, default_version => $self->{default_version}
);
$next = $cmc->upgrade_fragment;
}
else {
croak "Don't know how to merge '$next'";
}
$current = _merge($current, $next, $self->{mapping}, []);
}
return $current;
}
1;
# ABSTRACT: Merging CPAN Meta fragments
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Merge - Merging CPAN Meta fragments
=head1 VERSION
version 2.143240
=head1 SYNOPSIS
my $merger = CPAN::Meta::Merge->new(default_version => "2");
my $meta = $merger->merge($base, @additional);
=head1 DESCRIPTION
=head1 METHODS
=head2 new
This creates a CPAN::Meta::Merge object. It takes one mandatory named
argument, C<version>, declaring the version of the meta-spec that must be
used for the merge. It can optionally take an C<extra_mappings> argument
that allows one to add additional merging functions for specific elements.
=head2 merge(@fragments)
Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
(possibly incomplete) hashrefs of metadata.
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META_MERGE
$fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
# VERSION
$CPAN::Meta::Prereqs::VERSION = '2.143240';
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
#pod distribution or one of its optional features. Each set of prereqs is
#pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
#pod
#pod =cut
use Carp qw(confess);
use Scalar::Util qw(blessed);
use CPAN::Meta::Requirements 2.121;
#pod =method new
#pod
#pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
#pod
#pod This method returns a new set of Prereqs. The input should look like the
#pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
#pod something more or less like this:
#pod
#pod my $prereq = CPAN::Meta::Prereqs->new({
#pod runtime => {
#pod requires => {
#pod 'Some::Module' => '1.234',
#pod ...,
#pod },
#pod ...,
#pod },
#pod ...,
#pod });
#pod
#pod You can also construct an empty set of prereqs with:
#pod
#pod my $prereqs = CPAN::Meta::Prereqs->new;
#pod
#pod This empty set of prereqs is useful for accumulating new prereqs before finally
#pod dumping the whole set into a structure or string.
#pod
#pod =cut
sub __legal_phases { qw(configure build test runtime develop) }
sub __legal_types { qw(requires recommends suggests conflicts) }
# expect a prereq spec from META.json -- rjbs, 2010-04-11
sub new {
my ($class, $prereq_spec) = @_;
$prereq_spec ||= {};
my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
my %is_legal_type = map {; $_ => 1 } $class->__legal_types;
my %guts;
PHASE: for my $phase (keys %$prereq_spec) {
next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};
my $phase_spec = $prereq_spec->{ $phase };
next PHASE unless keys %$phase_spec;
TYPE: for my $type (keys %$phase_spec) {
next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};
my $spec = $phase_spec->{ $type };
next TYPE unless keys %$spec;
$guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
$spec
);
}
}
return bless \%guts => $class;
}
#pod =method requirements_for
#pod
#pod my $requirements = $prereqs->requirements_for( $phase, $type );
#pod
#pod This method returns a L<CPAN::Meta::Requirements> object for the given
#pod phase/type combination. If no prerequisites are registered for that
#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
#pod be added to as needed.
#pod
#pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
#pod be raised.
#pod
#pod =cut
sub requirements_for {
my ($self, $phase, $type) = @_;
confess "requirements_for called without phase" unless defined $phase;
confess "requirements_for called without type" unless defined $type;
unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
confess "requested requirements for unknown phase: $phase";
}
unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
confess "requested requirements for unknown type: $type";
}
my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);
$req->finalize if $self->is_finalized;
return $req;
}
#pod =method with_merged_prereqs
#pod
#pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
#pod
#pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
#pod
#pod This method returns a new CPAN::Meta::Prereqs objects in which all the
#pod other prerequisites given are merged into the current set. This is primarily
#pod provided for combining a distribution's core prereqs with the prereqs of one of
#pod its optional features.
#pod
#pod The new prereqs object has no ties to the originals, and altering it further
#pod will not alter them.
#pod
#pod =cut
sub with_merged_prereqs {
my ($self, $other) = @_;
my @other = blessed($other) ? $other : @$other;
my @prereq_objs = ($self, @other);
my %new_arg;
for my $phase ($self->__legal_phases) {
for my $type ($self->__legal_types) {
my $req = CPAN::Meta::Requirements->new;
for my $prereq (@prereq_objs) {
my $this_req = $prereq->requirements_for($phase, $type);
next unless $this_req->required_modules;
$req->add_requirements($this_req);
}
next unless $req->required_modules;
$new_arg{ $phase }{ $type } = $req->as_string_hash;
}
}
return (ref $self)->new(\%new_arg);
}
#pod =method merged_requirements
#pod
#pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
#pod my $new_reqs = $prereqs->merged_requirements( \@phases );
#pod my $new_reqs = $preerqs->merged_requirements();
#pod
#pod This method joins together all requirements across a number of phases
#pod and types into a new L<CPAN::Meta::Requirements> object. If arguments
#pod are omitted, it defaults to "runtime", "build" and "test" for phases
#pod and "requires" and "recommends" for types.
#pod
#pod =cut
sub merged_requirements {
my ($self, $phases, $types) = @_;
$phases = [qw/runtime build test/] unless defined $phases;
$types = [qw/requires recommends/] unless defined $types;
confess "merged_requirements phases argument must be an arrayref"
unless ref $phases eq 'ARRAY';
confess "merged_requirements types argument must be an arrayref"
unless ref $types eq 'ARRAY';
my $req = CPAN::Meta::Requirements->new;
for my $phase ( @$phases ) {
unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
confess "requested requirements for unknown phase: $phase";
}
for my $type ( @$types ) {
unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
confess "requested requirements for unknown type: $type";
}
$req->add_requirements( $self->requirements_for($phase, $type) );
}
}
$req->finalize if $self->is_finalized;
return $req;
}
#pod =method as_string_hash
#pod
#pod This method returns a hashref containing structures suitable for dumping into a
#pod distmeta data structure. It is made up of hashes and strings, only; there will
#pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
#pod
#pod =cut
sub as_string_hash {
my ($self) = @_;
my %hash;
for my $phase ($self->__legal_phases) {
for my $type ($self->__legal_types) {
my $req = $self->requirements_for($phase, $type);
next unless $req->required_modules;
$hash{ $phase }{ $type } = $req->as_string_hash;
}
}
return \%hash;
}
#pod =method is_finalized
#pod
#pod This method returns true if the set of prereqs has been marked "finalized," and
#pod cannot be altered.
#pod
#pod =cut
sub is_finalized { $_[0]{finalized} }
#pod =method finalize
#pod
#pod Calling C<finalize> on a Prereqs object will close it for further modification.
#pod Attempting to make any changes that would actually alter the prereqs will
#pod result in an exception being thrown.
#pod
#pod =cut
sub finalize {
my ($self) = @_;
$self->{finalized} = 1;
for my $phase (keys %{ $self->{prereqs} }) {
$_->finalize for values %{ $self->{prereqs}{$phase} };
}
}
#pod =method clone
#pod
#pod my $cloned_prereqs = $prereqs->clone;
#pod
#pod This method returns a Prereqs object that is identical to the original object,
#pod but can be altered without affecting the original object. Finalization does
#pod not survive cloning, meaning that you may clone a finalized set of prereqs and
#pod then modify the clone.
#pod
#pod =cut
sub clone {
my ($self) = @_;
my $clone = (ref $self)->new( $self->as_string_hash );
}
1;
# ABSTRACT: a set of distribution prerequisites by phase and type
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type
=head1 VERSION
version 2.143240
=head1 DESCRIPTION
A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
distribution or one of its optional features. Each set of prereqs is
organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
=head1 METHODS
=head2 new
my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
This method returns a new set of Prereqs. The input should look like the
contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
something more or less like this:
my $prereq = CPAN::Meta::Prereqs->new({
runtime => {
requires => {
'Some::Module' => '1.234',
...,
},
...,
},
...,
});
You can also construct an empty set of prereqs with:
my $prereqs = CPAN::Meta::Prereqs->new;
This empty set of prereqs is useful for accumulating new prereqs before finally
dumping the whole set into a structure or string.
=head2 requirements_for
my $requirements = $prereqs->requirements_for( $phase, $type );
This method returns a L<CPAN::Meta::Requirements> object for the given
phase/type combination. If no prerequisites are registered for that
combination, a new CPAN::Meta::Requirements object will be returned, and it may
be added to as needed.
If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
be raised.
=head2 with_merged_prereqs
my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
This method returns a new CPAN::Meta::Prereqs objects in which all the
other prerequisites given are merged into the current set. This is primarily
provided for combining a distribution's core prereqs with the prereqs of one of
its optional features.
The new prereqs object has no ties to the originals, and altering it further
will not alter them.
=head2 merged_requirements
my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
my $new_reqs = $prereqs->merged_requirements( \@phases );
my $new_reqs = $preerqs->merged_requirements();
This method joins together all requirements across a number of phases
and types into a new L<CPAN::Meta::Requirements> object. If arguments
are omitted, it defaults to "runtime", "build" and "test" for phases
and "requires" and "recommends" for types.
=head2 as_string_hash
This method returns a hashref containing structures suitable for dumping into a
distmeta data structure. It is made up of hashes and strings, only; there will
be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
=head2 is_finalized
This method returns true if the set of prereqs has been marked "finalized," and
cannot be altered.
=head2 finalize
Calling C<finalize> on a Prereqs object will close it for further modification.
Attempting to make any changes that would actually alter the prereqs will
result in an exception being thrown.
=head2 clone
my $cloned_prereqs = $prereqs->clone;
This method returns a Prereqs object that is identical to the original object,
but can be altered without affecting the original object. Finalization does
not survive cloning, meaning that you may clone a finalized set of prereqs and
then modify the clone.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META_PREREQS
$fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS';
use strict;
use warnings;
package CPAN::Meta::Requirements;
# ABSTRACT: a set of version requirements for a CPAN dist
our $VERSION = '2.131';
#pod =head1 SYNOPSIS
#pod
#pod use CPAN::Meta::Requirements;
#pod
#pod my $build_requires = CPAN::Meta::Requirements->new;
#pod
#pod $build_requires->add_minimum('Library::Foo' => 1.208);
#pod
#pod $build_requires->add_minimum('Library::Foo' => 2.602);
#pod
#pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
#pod
#pod $METAyml->{build_requires} = $build_requires->as_string_hash;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>;
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut
use Carp ();
# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available. This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.
BEGIN {
eval "use version ()"; ## no critic
if ( my $err = $@ ) {
eval "require ExtUtils::MakeMaker::version" or die $err; ## no critic
}
}
# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
# construct once, reuse many times
my $V0 = version->new(0);
#pod =method new
#pod
#pod my $req = CPAN::Meta::Requirements->new;
#pod
#pod This returns a new CPAN::Meta::Requirements object. It takes an optional
#pod hash reference argument. Currently, only one key is supported:
#pod
#pod =for :list
#pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
#pod a version object, this code reference will be called with the invalid
#pod version string as first argument, and the module name as second
#pod argument. It must return a valid version object.
#pod
#pod All other keys are ignored.
#pod
#pod =cut
my @valid_options = qw( bad_version_hook );
sub new {
my ($class, $options) = @_;
$options ||= {};
Carp::croak "Argument to $class\->new() must be a hash reference"
unless ref $options eq 'HASH';
my %self = map {; $_ => $options->{$_}} @valid_options;
return bless \%self => $class;
}
# from version::vpp
sub _find_magic_vstring {
my $value = shift;
my $tvalue = '';
require B;
my $sv = B::svref_2object(\$value);
my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
while ( $magic ) {
if ( $magic->TYPE eq 'V' ) {
$tvalue = $magic->PTR;
$tvalue =~ s/^v?(.+)$/v$1/;
last;
}
else {
$magic = $magic->MOREMAGIC;
}
}
return $tvalue;
}
# safe if given an unblessed reference
sub _isa_version {
UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version')
}
sub _version_object {
my ($self, $module, $version) = @_;
my $vobj;
# hack around version::vpp not handling <3 character vstring literals
if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
my $magic = _find_magic_vstring( $version );
$version = $magic if length $magic;
}
eval {
if (not defined $version or $version eq '0') {
$vobj = $V0;
}
elsif ( ref($version) eq 'version' || _isa_version($version) ) {
$vobj = $version;
}
else {
local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
$vobj = version->new($version);
}
};
if ( my $err = $@ ) {
my $hook = $self->{bad_version_hook};
$vobj = eval { $hook->($version, $module) }
if ref $hook eq 'CODE';
unless (eval { $vobj->isa("version") }) {
$err =~ s{ at .* line \d+.*$}{};
die "Can't convert '$version': $err";
}
}
# ensure no leading '.'
if ( $vobj =~ m{\A\.} ) {
$vobj = version->new("0$vobj");
}
# ensure normal v-string form
if ( _is_qv($vobj) ) {
$vobj = version->new($vobj->normal);
}
return $vobj;
}
#pod =method add_minimum
#pod
#pod $req->add_minimum( $module => $version );
#pod
#pod This adds a new minimum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive. C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_maximum
#pod
#pod $req->add_maximum( $module => $version );
#pod
#pod This adds a new maximum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive. No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_exclusion
#pod
#pod $req->add_exclusion( $module => $version );
#pod
#pod This adds a new excluded version. For example, you might use these three
#pod method calls:
#pod
#pod $req->add_minimum( $module => '1.00' );
#pod $req->add_maximum( $module => '1.82' );
#pod
#pod $req->add_exclusion( $module => '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =method exact_version
#pod
#pod $req->exact_version( $module => $version );
#pod
#pod This sets the version required for the given module to I<exactly> the given
#pod version. No other version would be considered acceptable.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
BEGIN {
for my $type (qw(maximum exclusion exact_version)) {
my $method = "with_$type";
my $to_add = $type eq 'exact_version' ? $type : "add_$type";
my $code = sub {
my ($self, $name, $version) = @_;
$version = $self->_version_object( $name, $version );
$self->__modify_entry_for($name, $method, $version);
return $self;
};
no strict 'refs';
*$to_add = $code;
}
}
sub add_minimum {
my ($self, $name, $version) = @_;
if (not defined $version or $version eq '0') {
return $self if $self->__entry_for($name);
Carp::confess("can't add new requirements to finalized requirements")
if $self->is_finalized;
$self->{requirements}{ $name } =
CPAN::Meta::Requirements::_Range::Range->with_minimum($V0);
}
else {
$version = $self->_version_object( $name, $version );
$self->__modify_entry_for($name, 'with_minimum', $version);
}
return $self;
}
#pod =method add_requirements
#pod
#pod $req->add_requirements( $another_req_object );
#pod
#pod This method adds all the requirements in the given CPAN::Meta::Requirements object
#pod to the requirements object on which it was called. If there are any conflicts,
#pod an exception is thrown.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
sub add_requirements {
my ($self, $req) = @_;
for my $module ($req->required_modules) {
my $modifiers = $req->__entry_for($module)->as_modifiers;
for my $modifier (@$modifiers) {
my ($method, @args) = @$modifier;
$self->$method($module => @args);
};
}
return $self;
}
#pod =method accepts_module
#pod
#pod my $bool = $req->accepts_module($module => $version);
#pod
#pod Given an module and version, this method returns true if the version
#pod specification for the module accepts the provided version. In other words,
#pod given:
#pod
#pod Module => '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod For modules that do not appear in the requirements, this method will return
#pod true.
#pod
#pod =cut
sub accepts_module {
my ($self, $module, $version) = @_;
$version = $self->_version_object( $module, $version );
return 1 unless my $range = $self->__entry_for($module);
return $range->_accepts($version);
}
#pod =method clear_requirement
#pod
#pod $req->clear_requirement( $module );
#pod
#pod This removes the requirement for a given module from the object.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
sub clear_requirement {
my ($self, $module) = @_;
return $self unless $self->__entry_for($module);
Carp::confess("can't clear requirements on finalized requirements")
if $self->is_finalized;
delete $self->{requirements}{ $module };
return $self;
}
#pod =method requirements_for_module
#pod
#pod $req->requirements_for_module( $module );
#pod
#pod This returns a string containing the version requirements for a given module in
#pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
#pod requirements. This should only be used for informational purposes such as error
#pod messages and should not be interpreted or used for comparison (see
#pod L</accepts_module> instead.)
#pod
#pod =cut
sub requirements_for_module {
my ($self, $module) = @_;
my $entry = $self->__entry_for($module);
return unless $entry;
return $entry->as_string;
}
#pod =method required_modules
#pod
#pod This method returns a list of all the modules for which requirements have been
#pod specified.
#pod
#pod =cut
sub required_modules { keys %{ $_[0]{requirements} } }
#pod =method clone
#pod
#pod $req->clone;
#pod
#pod This method returns a clone of the invocant. The clone and the original object
#pod can then be changed independent of one another.
#pod
#pod =cut
sub clone {
my ($self) = @_;
my $new = (ref $self)->new;
return $new->add_requirements($self);
}
sub __entry_for { $_[0]{requirements}{ $_[1] } }
sub __modify_entry_for {
my ($self, $name, $method, $version) = @_;
my $fin = $self->is_finalized;
my $old = $self->__entry_for($name);
Carp::confess("can't add new requirements to finalized requirements")
if $fin and not $old;
my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range')
->$method($version);
Carp::confess("can't modify finalized requirements")
if $fin and $old->as_string ne $new->as_string;
$self->{requirements}{ $name } = $new;
}
#pod =method is_simple
#pod
#pod This method returns true if and only if all requirements are inclusive minimums
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut
sub is_simple {
my ($self) = @_;
for my $module ($self->required_modules) {
# XXX: This is a complete hack, but also entirely correct.
return if $self->__entry_for($module)->as_string =~ /\s/;
}
return 1;
}
#pod =method is_finalized
#pod
#pod This method returns true if the requirements have been finalized by having the
#pod C<finalize> method called on them.
#pod
#pod =cut
sub is_finalized { $_[0]{finalized} }
#pod =method finalize
#pod
#pod This method marks the requirements finalized. Subsequent attempts to change
#pod the requirements will be fatal, I<if> they would result in a change. If they
#pod would not alter the requirements, they have no effect.
#pod
#pod If a finalized set of requirements is cloned, the cloned requirements are not
#pod also finalized.
#pod
#pod =cut
sub finalize { $_[0]{finalized} = 1 }
#pod =method as_string_hash
#pod
#pod This returns a reference to a hash describing the requirements using the
#pod strings in the L<CPAN::Meta::Spec> specification.
#pod
#pod For example after the following program:
#pod
#pod my $req = CPAN::Meta::Requirements->new;
#pod
#pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
#pod
#pod $req->add_minimum('Library::Foo' => 1.208);
#pod
#pod $req->add_maximum('Library::Foo' => 2.602);
#pod
#pod $req->add_minimum('Module::Bar' => 'v1.2.3');
#pod
#pod $req->add_exclusion('Module::Bar' => 'v1.2.8');
#pod
#pod $req->exact_version('Xyzzy' => '6.01');
#pod
#pod my $hashref = $req->as_string_hash;
#pod
#pod C<$hashref> would contain:
#pod
#pod {
#pod 'CPAN::Meta::Requirements' => '0.102',
#pod 'Library::Foo' => '>= 1.208, <= 2.206',
#pod 'Module::Bar' => '>= v1.2.3, != v1.2.8',
#pod 'Xyzzy' => '== 6.01',
#pod }
#pod
#pod =cut
sub as_string_hash {
my ($self) = @_;
my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
$self->required_modules;
return \%hash;
}
#pod =method add_string_requirement
#pod
#pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
#pod $req->add_string_requirement('Library::Foo' => v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement
#pod for the given module. A version can be a Perl "v-string". It understands
#pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
#pod example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>). Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut
my %methods_for_op = (
'==' => [ qw(exact_version) ],
'!=' => [ qw(add_exclusion) ],
'>=' => [ qw(add_minimum) ],
'<=' => [ qw(add_maximum) ],
'>' => [ qw(add_minimum add_exclusion) ],
'<' => [ qw(add_maximum add_exclusion) ],
);
sub add_string_requirement {
my ($self, $module, $req) = @_;
unless ( defined $req && length $req ) {
$req = 0;
$self->_blank_carp($module);
}
my $magic = _find_magic_vstring( $req );
if (length $magic) {
$self->add_minimum($module => $magic);
return;
}
my @parts = split qr{\s*,\s*}, $req;
for my $part (@parts) {
my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
if (! defined $op) {
$self->add_minimum($module => $part);
} else {
Carp::confess("illegal requirement string: $req")
unless my $methods = $methods_for_op{ $op };
$self->$_($module => $ver) for @$methods;
}
}
}
#pod =method from_string_hash
#pod
#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
#pod
#pod This is an alternate constructor for a CPAN::Meta::Requirements
#pod object. It takes a hash of module names and version requirement
#pod strings and returns a new CPAN::Meta::Requirements object. As with
#pod add_string_requirement, a version can be a Perl "v-string". Optionally,
#pod you can supply a hash-reference of options, exactly as with the L</new>
#pod method.
#pod
#pod =cut
sub _blank_carp {
my ($self, $module) = @_;
Carp::carp("Undefined requirement for $module treated as '0'");
}
sub from_string_hash {
my ($class, $hash, $options) = @_;
my $self = $class->new($options);
for my $module (keys %$hash) {
my $req = $hash->{$module};
unless ( defined $req && length $req ) {
$req = 0;
$class->_blank_carp($module);
}
$self->add_string_requirement($module, $req);
}
return $self;
}
##############################################################
{
package
CPAN::Meta::Requirements::_Range::Exact;
sub _new { bless { version => $_[1] } => $_[0] }
sub _accepts { return $_[0]{version} == $_[1] }
sub as_string { return "== $_[0]{version}" }
sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] }
sub _clone {
(ref $_[0])->_new( version->new( $_[0]{version} ) )
}
sub with_exact_version {
my ($self, $version) = @_;
return $self->_clone if $self->_accepts($version);
Carp::confess("illegal requirements: unequal exact version specified");
}
sub with_minimum {
my ($self, $minimum) = @_;
return $self->_clone if $self->{version} >= $minimum;
Carp::confess("illegal requirements: minimum above exact specification");
}
sub with_maximum {
my ($self, $maximum) = @_;
return $self->_clone if $self->{version} <= $maximum;
Carp::confess("illegal requirements: maximum below exact specification");
}
sub with_exclusion {
my ($self, $exclusion) = @_;
return $self->_clone unless $exclusion == $self->{version};
Carp::confess("illegal requirements: excluded exact specification");
}
}
##############################################################
{
package
CPAN::Meta::Requirements::_Range::Range;
sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) }
sub _clone {
return (bless { } => $_[0]) unless ref $_[0];
my ($s) = @_;
my %guts = (
(exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
(exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
(exists $s->{exclusions}
? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
: ()),
);
bless \%guts => ref($s);
}
sub as_modifiers {
my ($self) = @_;
my @mods;
push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum};
push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum};
push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []};
return \@mods;
}
sub as_string {
my ($self) = @_;
return 0 if ! keys %$self;
return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum};
my @exclusions = @{ $self->{exclusions} || [] };
my @parts;
for my $pair (
[ qw( >= > minimum ) ],
[ qw( <= < maximum ) ],
) {
my ($op, $e_op, $k) = @$pair;
if (exists $self->{$k}) {
my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
if (@new_exclusions == @exclusions) {
push @parts, "$op $self->{ $k }";
} else {
push @parts, "$e_op $self->{ $k }";
@exclusions = @new_exclusions;
}
}
}
push @parts, map {; "!= $_" } @exclusions;
return join q{, }, @parts;
}
sub with_exact_version {
my ($self, $version) = @_;
$self = $self->_clone;
Carp::confess("illegal requirements: exact specification outside of range")
unless $self->_accepts($version);
return CPAN::Meta::Requirements::_Range::Exact->_new($version);
}
sub _simplify {
my ($self) = @_;
if (defined $self->{minimum} and defined $self->{maximum}) {
if ($self->{minimum} == $self->{maximum}) {
Carp::confess("illegal requirements: excluded all values")
if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] };
return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})
}
Carp::confess("illegal requirements: minimum exceeds maximum")
if $self->{minimum} > $self->{maximum};
}
# eliminate irrelevant exclusions
if ($self->{exclusions}) {
my %seen;
@{ $self->{exclusions} } = grep {
(! defined $self->{minimum} or $_ >= $self->{minimum})
and
(! defined $self->{maximum} or $_ <= $self->{maximum})
and
! $seen{$_}++
} @{ $self->{exclusions} };
}
return $self;
}
sub with_minimum {
my ($self, $minimum) = @_;
$self = $self->_clone;
if (defined (my $old_min = $self->{minimum})) {
$self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
} else {
$self->{minimum} = $minimum;
}
return $self->_simplify;
}
sub with_maximum {
my ($self, $maximum) = @_;
$self = $self->_clone;
if (defined (my $old_max = $self->{maximum})) {
$self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
} else {
$self->{maximum} = $maximum;
}
return $self->_simplify;
}
sub with_exclusion {
my ($self, $exclusion) = @_;
$self = $self->_clone;
push @{ $self->{exclusions} ||= [] }, $exclusion;
return $self->_simplify;
}
sub _accepts {
my ($self, $version) = @_;
return if defined $self->{minimum} and $version < $self->{minimum};
return if defined $self->{maximum} and $version > $self->{maximum};
return if defined $self->{exclusions}
and grep { $version == $_ } @{ $self->{exclusions} };
return 1;
}
}
1;
# vim: ts=2 sts=2 sw=2 et:
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Requirements - a set of version requirements for a CPAN dist
=head1 VERSION
version 2.131
=head1 SYNOPSIS
use CPAN::Meta::Requirements;
my $build_requires = CPAN::Meta::Requirements->new;
$build_requires->add_minimum('Library::Foo' => 1.208);
$build_requires->add_minimum('Library::Foo' => 2.602);
$build_requires->add_minimum('Module::Bar' => 'v1.2.3');
$METAyml->{build_requires} = $build_requires->as_string_hash;
=head1 DESCRIPTION
A CPAN::Meta::Requirements object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>;
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.
Logically impossible constraints will be identified immediately by thrown
exceptions.
=head1 METHODS
=head2 new
my $req = CPAN::Meta::Requirements->new;
This returns a new CPAN::Meta::Requirements object. It takes an optional
hash reference argument. Currently, only one key is supported:
=over 4
=item *
C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object.
=back
All other keys are ignored.
=head2 add_minimum
$req->add_minimum( $module => $version );
This adds a new minimum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Minimum requirements are inclusive. C<$version> is required, along with any
greater version number.
This method returns the requirements object.
=head2 add_maximum
$req->add_maximum( $module => $version );
This adds a new maximum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Maximum requirements are inclusive. No version strictly greater than the given
version is allowed.
This method returns the requirements object.
=head2 add_exclusion
$req->add_exclusion( $module => $version );
This adds a new excluded version. For example, you might use these three
method calls:
$req->add_minimum( $module => '1.00' );
$req->add_maximum( $module => '1.82' );
$req->add_exclusion( $module => '1.75' );
Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.
This method returns the requirements object.
=head2 exact_version
$req->exact_version( $module => $version );
This sets the version required for the given module to I<exactly> the given
version. No other version would be considered acceptable.
This method returns the requirements object.
=head2 add_requirements
$req->add_requirements( $another_req_object );
This method adds all the requirements in the given CPAN::Meta::Requirements object
to the requirements object on which it was called. If there are any conflicts,
an exception is thrown.
This method returns the requirements object.
=head2 accepts_module
my $bool = $req->accepts_module($module => $version);
Given an module and version, this method returns true if the version
specification for the module accepts the provided version. In other words,
given:
Module => '>= 1.00, < 2.00'
We will accept 1.00 and 1.75 but not 0.50 or 2.00.
For modules that do not appear in the requirements, this method will return
true.
=head2 clear_requirement
$req->clear_requirement( $module );
This removes the requirement for a given module from the object.
This method returns the requirements object.
=head2 requirements_for_module
$req->requirements_for_module( $module );
This returns a string containing the version requirements for a given module in
the format described in L<CPAN::Meta::Spec> or undef if the given module has no
requirements. This should only be used for informational purposes such as error
messages and should not be interpreted or used for comparison (see
L</accepts_module> instead.)
=head2 required_modules
This method returns a list of all the modules for which requirements have been
specified.
=head2 clone
$req->clone;
This method returns a clone of the invocant. The clone and the original object
can then be changed independent of one another.
=head2 is_simple
This method returns true if and only if all requirements are inclusive minimums
-- that is, if their string expression is just the version number.
=head2 is_finalized
This method returns true if the requirements have been finalized by having the
C<finalize> method called on them.
=head2 finalize
This method marks the requirements finalized. Subsequent attempts to change
the requirements will be fatal, I<if> they would result in a change. If they
would not alter the requirements, they have no effect.
If a finalized set of requirements is cloned, the cloned requirements are not
also finalized.
=head2 as_string_hash
This returns a reference to a hash describing the requirements using the
strings in the L<CPAN::Meta::Spec> specification.
For example after the following program:
my $req = CPAN::Meta::Requirements->new;
$req->add_minimum('CPAN::Meta::Requirements' => 0.102);
$req->add_minimum('Library::Foo' => 1.208);
$req->add_maximum('Library::Foo' => 2.602);
$req->add_minimum('Module::Bar' => 'v1.2.3');
$req->add_exclusion('Module::Bar' => 'v1.2.8');
$req->exact_version('Xyzzy' => '6.01');
my $hashref = $req->as_string_hash;
C<$hashref> would contain:
{
'CPAN::Meta::Requirements' => '0.102',
'Library::Foo' => '>= 1.208, <= 2.206',
'Module::Bar' => '>= v1.2.3, != v1.2.8',
'Xyzzy' => '== 6.01',
}
=head2 add_string_requirement
$req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
$req->add_string_requirement('Library::Foo' => v1.208);
This method parses the passed in string and adds the appropriate requirement
for the given module. A version can be a Perl "v-string". It understands
version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
example:
=over 4
=item 1.3
=item >= 1.3
=item <= 1.3
=item == 1.3
=item != 1.3
=item > 1.3
=item < 1.3
=item >= 1.3, != 1.5, <= 2.0
A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>). Extra whitespace is allowed.
=back
=head2 from_string_hash
my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
This is an alternate constructor for a CPAN::Meta::Requirements
object. It takes a hash of module names and version requirement
strings and returns a new CPAN::Meta::Requirements object. As with
add_string_requirement, a version can be a Perl "v-string". Optionally,
you can supply a hash-reference of options, exactly as with the L</new>
method.
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/CPAN-Meta-Requirements/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/dagolden/CPAN-Meta-Requirements>
git clone https://github.com/dagolden/CPAN-Meta-Requirements.git
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 CONTRIBUTORS
=for stopwords Ed J Karen Etheridge Leon Timmermans robario
=over 4
=item *
Ed J <[email protected]>
=item *
Karen Etheridge <[email protected]>
=item *
Leon Timmermans <[email protected]>
=item *
robario <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META_REQUIREMENTS
$fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC';
# XXX RULES FOR PATCHING THIS FILE XXX
# Patches that fix typos or formatting are acceptable. Patches
# that change semantics are not acceptable without prior approval
# by David Golden or Ricardo Signes.
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Spec;
# VERSION
$CPAN::Meta::Spec::VERSION = '2.143240';
1;
# ABSTRACT: specification for CPAN distribution metadata
# vi:tw=72
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Spec - specification for CPAN distribution metadata
=head1 VERSION
version 2.143240
=head1 SYNOPSIS
my $distmeta = {
name => 'Module-Build',
abstract => 'Build and install Perl modules',
description => "Module::Build is a system for "
. "building, testing, and installing Perl modules. "
. "It is meant to ... blah blah blah ...",
version => '0.36',
release_status => 'stable',
author => [
'Ken Williams <[email protected]>',
'Module-Build List <[email protected]>', # additional contact
],
license => [ 'perl_5' ],
prereqs => {
runtime => {
requires => {
'perl' => '5.006',
'ExtUtils::Install' => '0',
'File::Basename' => '0',
'File::Compare' => '0',
'IO::File' => '0',
},
recommends => {
'Archive::Tar' => '1.00',
'ExtUtils::Install' => '0.3',
'ExtUtils::ParseXS' => '2.02',
},
},
build => {
requires => {
'Test::More' => '0',
},
}
},
resources => {
license => ['http://dev.perl.org/licenses/'],
},
optional_features => {
domination => {
description => 'Take over the world',
prereqs => {
develop => { requires => { 'Genius::Evil' => '1.234' } },
runtime => { requires => { 'Machine::Weather' => '2.0' } },
},
},
},
dynamic_config => 1,
keywords => [ qw/ toolchain cpan dual-life / ],
'meta-spec' => {
version => '2',
url => 'https://metacpan.org/pod/CPAN::Meta::Spec',
},
generated_by => 'Module::Build version 0.36',
};
=head1 DESCRIPTION
This document describes version 2 of the CPAN distribution metadata
specification, also known as the "CPAN Meta Spec".
Revisions of this specification for typo corrections and prose
clarifications may be issued as CPAN::Meta::Spec 2.I<x>. These
revisions will never change semantics or add or remove specified
behavior.
Distribution metadata describe important properties of Perl
distributions. Distribution building tools like Module::Build,
Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a
metadata file in accordance with this specification and include it with
the distribution for use by automated tools that index, examine, package
or install Perl distributions.
=head1 TERMINOLOGY
=over 4
=item distribution
This is the primary object described by the metadata. In the context of
this document it usually refers to a collection of modules, scripts,
and/or documents that are distributed together for other developers to
use. Examples of distributions are C<Class-Container>, C<libwww-perl>,
or C<DBI>.
=item module
This refers to a reusable library of code contained in a single file.
Modules usually contain one or more packages and are often referred
to by the name of a primary package that can be mapped to the file
name. For example, one might refer to C<File::Spec> instead of
F<File/Spec.pm>
=item package
This refers to a namespace declared with the Perl C<package> statement.
In Perl, packages often have a version number property given by the
C<$VERSION> variable in the namespace.
=item consumer
This refers to code that reads a metadata file, deserializes it into a
data structure in memory, or interprets a data structure of metadata
elements.
=item producer
This refers to code that constructs a metadata data structure,
serializes into a bytestream and/or writes it to disk.
=item must, should, may, etc.
These terms are interpreted as described in IETF RFC 2119.
=back
=head1 DATA TYPES
Fields in the L</STRUCTURE> section describe data elements, each of
which has an associated data type as described herein. There are four
primitive types: Boolean, String, List and Map. Other types are
subtypes of primitives and define compound data structures or define
constraints on the values of a data element.
=head2 Boolean
A I<Boolean> is used to provide a true or false value. It B<must> be
represented as a defined value.
=head2 String
A I<String> is data element containing a non-zero length sequence of
Unicode characters, such as an ordinary Perl scalar that is not a
reference.
=head2 List
A I<List> is an ordered collection of zero or more data elements.
Elements of a List may be of mixed types.
Producers B<must> represent List elements using a data structure which
unambiguously indicates that multiple values are possible, such as a
reference to a Perl array (an "arrayref").
Consumers expecting a List B<must> consider a String as equivalent to a
List of length 1.
=head2 Map
A I<Map> is an unordered collection of zero or more data elements
("values"), indexed by associated String elements ("keys"). The Map's
value elements may be of mixed types.
=head2 License String
A I<License String> is a subtype of String with a restricted set of
values. Valid values are described in detail in the description of
the L</license> field.
=head2 URL
I<URL> is a subtype of String containing a Uniform Resource Locator or
Identifier. [ This type is called URL and not URI for historical reasons. ]
=head2 Version
A I<Version> is a subtype of String containing a value that describes
the version number of packages or distributions. Restrictions on format
are described in detail in the L</Version Formats> section.
=head2 Version Range
The I<Version Range> type is a subtype of String. It describes a range
of Versions that may be present or installed to fulfill prerequisites.
It is specified in detail in the L</Version Ranges> section.
=head1 STRUCTURE
The metadata structure is a data element of type Map. This section
describes valid keys within the Map.
Any keys not described in this specification document (whether top-level
or within compound data structures described herein) are considered
I<custom keys> and B<must> begin with an "x" or "X" and be followed by an
underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>. If a
custom key refers to a compound data structure, subkeys within it do not
need an "x_" or "X_" prefix.
Consumers of metadata may ignore any or all custom keys. All other keys
not described herein are invalid and should be ignored by consumers.
Producers must not generate or output invalid keys.
For each key, an example is provided followed by a description. The
description begins with the version of spec in which the key was added
or in which the definition was modified, whether the key is I<required>
or I<optional> and the data type of the corresponding data element.
These items are in parentheses, brackets and braces, respectively.
If a data type is a Map or Map subtype, valid subkeys will be described
as well.
Some fields are marked I<Deprecated>. These are shown for historical
context and must not be produced in or consumed from any metadata structure
of version 2 or higher.
=head2 REQUIRED FIELDS
=head3 abstract
Example:
abstract => 'Build and install Perl modules'
(Spec 1.2) [required] {String}
This is a short description of the purpose of the distribution.
=head3 author
Example:
author => [ 'Ken Williams <[email protected]>' ]
(Spec 1.2) [required] {List of one or more Strings}
This List indicates the person(s) to contact concerning the
distribution. The preferred form of the contact string is:
contact-name <email-address>
This field provides a general contact list independent of other
structured fields provided within the L</resources> field, such as
C<bugtracker>. The addressee(s) can be contacted for any purpose
including but not limited to (security) problems with the distribution,
questions about the distribution or bugs in the distribution.
A distribution's original author is usually the contact listed within
this field. Co-maintainers, successor maintainers or mailing lists
devoted to the distribution may also be listed in addition to or instead
of the original author.
=head3 dynamic_config
Example:
dynamic_config => 1
(Spec 2) [required] {Boolean}
A boolean flag indicating whether a F<Build.PL> or F<Makefile.PL> (or
similar) must be executed to determine prerequisites.
This field should be set to a true value if the distribution performs
some dynamic configuration (asking questions, sensing the environment,
etc.) as part of its configuration. This field should be set to a false
value to indicate that prerequisites included in metadata may be
considered final and valid for static analysis.
Note: when this field is true, post-configuration prerequisites are not
guaranteed to bear any relation whatsoever to those stated in the metadata,
and relying on them doing so is an error. See also
L</Prerequisites for dynamically configured distributions> in the implementors'
notes.
This field explicitly B<does not> indicate whether installation may be
safely performed without using a Makefile or Build file, as there may be
special files to install or custom installation targets (e.g. for
dual-life modules that exist on CPAN as well as in the Perl core). This
field only defines whether or not prerequisites are exactly as given in the
metadata.
=head3 generated_by
Example:
generated_by => 'Module::Build version 0.36'
(Spec 1.0) [required] {String}
This field indicates the tool that was used to create this metadata.
There are no defined semantics for this field, but it is traditional to
use a string in the form "Generating::Package version 1.23" or the
author's name, if the file was generated by hand.
=head3 license
Example:
license => [ 'perl_5' ]
license => [ 'apache_2_0', 'mozilla_1_0' ]
(Spec 2) [required] {List of one or more License Strings}
One or more licenses that apply to some or all of the files in the
distribution. If multiple licenses are listed, the distribution
documentation should be consulted to clarify the interpretation of
multiple licenses.
The following list of license strings are valid:
string description
------------- -----------------------------------------------
agpl_3 GNU Affero General Public License, Version 3
apache_1_1 Apache Software License, Version 1.1
apache_2_0 Apache License, Version 2.0
artistic_1 Artistic License, (Version 1)
artistic_2 Artistic License, Version 2.0
bsd BSD License (three-clause)
freebsd FreeBSD License (two-clause)
gfdl_1_2 GNU Free Documentation License, Version 1.2
gfdl_1_3 GNU Free Documentation License, Version 1.3
gpl_1 GNU General Public License, Version 1
gpl_2 GNU General Public License, Version 2
gpl_3 GNU General Public License, Version 3
lgpl_2_1 GNU Lesser General Public License, Version 2.1
lgpl_3_0 GNU Lesser General Public License, Version 3.0
mit MIT (aka X11) License
mozilla_1_0 Mozilla Public License, Version 1.0
mozilla_1_1 Mozilla Public License, Version 1.1
openssl OpenSSL License
perl_5 The Perl 5 License (Artistic 1 & GPL 1 or later)
qpl_1_0 Q Public License, Version 1.0
ssleay Original SSLeay License
sun Sun Internet Standards Source License (SISSL)
zlib zlib License
The following license strings are also valid and indicate other
licensing not described above:
string description
------------- -----------------------------------------------
open_source Other Open Source Initiative (OSI) approved license
restricted Requires special permission from copyright holder
unrestricted Not an OSI approved license, but not restricted
unknown License not provided in metadata
All other strings are invalid in the license field.
=head3 meta-spec
Example:
'meta-spec' => {
version => '2',
url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
}
(Spec 1.2) [required] {Map}
This field indicates the version of the CPAN Meta Spec that should be
used to interpret the metadata. Consumers must check this key as soon
as possible and abort further metadata processing if the meta-spec
version is not supported by the consumer.
The following keys are valid, but only C<version> is required.
=over
=item version
This subkey gives the integer I<Version> of the CPAN Meta Spec against
which the document was generated.
=item url
This is a I<URL> of the metadata specification document corresponding to
the given version. This is strictly for human-consumption and should
not impact the interpretation of the document.
For the version 2 spec, either of these are recommended:
=over 4
=item *
C<https://metacpan.org/pod/CPAN::Meta::Spec>
=item *
C<http://search.cpan.org/perldoc?CPAN::Meta::Spec>
=back
=back
=head3 name
Example:
name => 'Module-Build'
(Spec 1.0) [required] {String}
This field is the name of the distribution. This is often created by
taking the "main package" in the distribution and changing C<::> to
C<->, but the name may be completely unrelated to the packages within
the distribution. For example, L<LWP::UserAgent> is distributed as part
of the distribution name "libwww-perl".
=head3 release_status
Example:
release_status => 'stable'
(Spec 2) [required] {String}
This field provides the release status of this distribution. If the
C<version> field contains an underscore character, then
C<release_status> B<must not> be "stable."
The C<release_status> field B<must> have one of the following values:
=over
=item stable
This indicates an ordinary, "final" release that should be indexed by PAUSE
or other indexers.
=item testing
This indicates a "beta" release that is substantially complete, but has an
elevated risk of bugs and requires additional testing. The distribution
should not be installed over a stable release without an explicit request
or other confirmation from a user. This release status may also be used
for "release candidate" versions of a distribution.
=item unstable
This indicates an "alpha" release that is under active development, but has
been released for early feedback or testing and may be missing features or
may have serious bugs. The distribution should not be installed over a
stable release without an explicit request or other confirmation from a
user.
=back
Consumers B<may> use this field to determine how to index the
distribution for CPAN or other repositories in addition to or in
replacement of heuristics based on version number or file name.
=head3 version
Example:
version => '0.36'
(Spec 1.0) [required] {Version}
This field gives the version of the distribution to which the metadata
structure refers.
=head2 OPTIONAL FIELDS
=head3 description
Example:
description => "Module::Build is a system for "
. "building, testing, and installing Perl modules. "
. "It is meant to ... blah blah blah ...",
(Spec 2) [optional] {String}
A longer, more complete description of the purpose or intended use of
the distribution than the one provided by the C<abstract> key.
=head3 keywords
Example:
keywords => [ qw/ toolchain cpan dual-life / ]
(Spec 1.1) [optional] {List of zero or more Strings}
A List of keywords that describe this distribution. Keywords
B<must not> include whitespace.
=head3 no_index
Example:
no_index => {
file => [ 'My/Module.pm' ],
directory => [ 'My/Private' ],
package => [ 'My::Module::Secret' ],
namespace => [ 'My::Module::Sample' ],
}
(Spec 1.2) [optional] {Map}
This Map describes any files, directories, packages, and namespaces that
are private to the packaging or implementation of the distribution and
should be ignored by indexing or search tools. Note that this is a list of
exclusions, and the spec does not define what to I<include> - see
L</Indexing distributions a la PAUSE> in the implementors notes for more
information.
Valid subkeys are as follows:
=over
=item file
A I<List> of relative paths to files. Paths B<must be> specified with
unix conventions.
=item directory
A I<List> of relative paths to directories. Paths B<must be> specified
with unix conventions.
[ Note: previous editions of the spec had C<dir> instead of C<directory> ]
=item package
A I<List> of package names.
=item namespace
A I<List> of package namespaces, where anything below the namespace
must be ignored, but I<not> the namespace itself.
In the example above for C<no_index>, C<My::Module::Sample::Foo> would
be ignored, but C<My::Module::Sample> would not.
=back
=head3 optional_features
Example:
optional_features => {
sqlite => {
description => 'Provides SQLite support',
prereqs => {
runtime => {
requires => {
'DBD::SQLite' => '1.25'
}
}
}
}
}
(Spec 2) [optional] {Map}
This Map describes optional features with incremental prerequisites.
Each key of the C<optional_features> Map is a String used to identify
the feature and each value is a Map with additional information about
the feature. Valid subkeys include:
=over
=item description
This is a String describing the feature. Every optional feature
should provide a description
=item prereqs
This entry is required and has the same structure as that of the
C<L</prereqs>> key. It provides a list of package requirements
that must be satisfied for the feature to be supported or enabled.
There is one crucial restriction: the prereqs of an optional feature
B<must not> include C<configure> phase prereqs.
=back
Consumers B<must not> include optional features as prerequisites without
explicit instruction from users (whether via interactive prompting,
a function parameter or a configuration value, etc. ).
If an optional feature is used by a consumer to add additional
prerequisites, the consumer should merge the optional feature
prerequisites into those given by the C<prereqs> key using the same
semantics. See L</Merging and Resolving Prerequisites> for details on
merging prerequisites.
I<Suggestion for disuse:> Because there is currently no way for a
distribution to specify a dependency on an optional feature of another
dependency, the use of C<optional_feature> is discouraged. Instead,
create a separate, installable distribution that ensures the desired
feature is available. For example, if C<Foo::Bar> has a C<Baz> feature,
release a separate C<Foo-Bar-Baz> distribution that satisfies
requirements for the feature.
=head3 prereqs
Example:
prereqs => {
runtime => {
requires => {
'perl' => '5.006',
'File::Spec' => '0.86',
'JSON' => '2.16',
},
recommends => {
'JSON::XS' => '2.26',
},
suggests => {
'Archive::Tar' => '0',
},
},
build => {
requires => {
'Alien::SDL' => '1.00',
},
},
test => {
recommends => {
'Test::Deep' => '0.10',
},
}
}
(Spec 2) [optional] {Map}
This is a Map that describes all the prerequisites of the distribution.
The keys are phases of activity, such as C<configure>, C<build>, C<test>
or C<runtime>. Values are Maps in which the keys name the type of
prerequisite relationship such as C<requires>, C<recommends>, or
C<suggests> and the value provides a set of prerequisite relations. The
set of relations B<must> be specified as a Map of package names to
version ranges.
The full definition for this field is given in the L</Prereq Spec>
section.
=head3 provides
Example:
provides => {
'Foo::Bar' => {
file => 'lib/Foo/Bar.pm',
version => '0.27_02',
},
'Foo::Bar::Blah' => {
file => 'lib/Foo/Bar/Blah.pm',
},
'Foo::Bar::Baz' => {
file => 'lib/Foo/Bar/Baz.pm',
version => '0.3',
},
}
(Spec 1.2) [optional] {Map}
This describes all packages provided by this distribution. This
information is used by distribution and automation mechanisms like
PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in
which distribution various packages can be found.
The keys of C<provides> are package names that can be found within
the distribution. If a package name key is provided, it must
have a Map with the following valid subkeys:
=over
=item file
This field is required. It must contain a Unix-style relative file path
from the root of the distribution directory to a file that contains or
generates the package. It may be given as C<META.yml> or C<META.json>
to claim a package for indexing without needing a C<*.pm>.
=item version
If it exists, this field must contains a I<Version> String for the
package. If the package does not have a C<$VERSION>, this field must
be omitted.
=back
=head3 resources
Example:
resources => {
license => [ 'http://dev.perl.org/licenses/' ],
homepage => 'http://sourceforge.net/projects/module-build',
bugtracker => {
web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta',
mailto => '[email protected]',
},
repository => {
url => 'git://github.com/dagolden/cpan-meta.git',
web => 'http://github.com/dagolden/cpan-meta',
type => 'git',
},
x_twitter => 'http://twitter.com/cpan_linked/',
}
(Spec 2) [optional] {Map}
This field describes resources related to this distribution.
Valid subkeys include:
=over
=item homepage
The official home of this project on the web.
=item license
A List of I<URL>'s that relate to this distribution's license. As with the
top-level C<license> field, distribution documentation should be consulted
to clarify the interpretation of multiple licenses provided here.
=item bugtracker
This entry describes the bug tracking system for this distribution. It
is a Map with the following valid keys:
web - a URL pointing to a web front-end for the bug tracker
mailto - an email address to which bugs can be sent
=item repository
This entry describes the source control repository for this distribution. It
is a Map with the following valid keys:
url - a URL pointing to the repository itself
web - a URL pointing to a web front-end for the repository
type - a lowercase string indicating the VCS used
Because a url like C<http://myrepo.example.com/> is ambiguous as to
type, producers should provide a C<type> whenever a C<url> key is given.
The C<type> field should be the name of the most common program used
to work with the repository, e.g. C<git>, C<svn>, C<cvs>, C<darcs>,
C<bzr> or C<hg>.
=back
=head2 DEPRECATED FIELDS
=head3 build_requires
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head3 configure_requires
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head3 conflicts
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head3 distribution_type
I<(Deprecated in Spec 2)> [optional] {String}
This field indicated 'module' or 'script' but was considered
meaningless, since many distributions are hybrids of several kinds of
things.
=head3 license_uri
I<(Deprecated in Spec 1.2)> [optional] {URL}
Replaced by C<license> in C<resources>
=head3 private
I<(Deprecated in Spec 1.2)> [optional] {Map}
This field has been renamed to L</"no_index">.
=head3 recommends
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head3 requires
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head1 VERSION NUMBERS
=head2 Version Formats
This section defines the Version type, used by several fields in the
CPAN Meta Spec.
Version numbers must be treated as strings, not numbers. For
example, C<1.200> B<must not> be serialized as C<1.2>. Version
comparison should be delegated to the Perl L<version> module, version
0.80 or newer.
Unless otherwise specified, version numbers B<must> appear in one of two
formats:
=over
=item Decimal versions
Decimal versions are regular "decimal numbers", with some limitations.
They B<must> be non-negative and B<must> begin and end with a digit. A
single underscore B<may> be included, but B<must> be between two digits.
They B<must not> use exponential notation ("1.23e-2").
version => '1.234' # OK
version => '1.23_04' # OK
version => '1.23_04_05' # Illegal
version => '1.' # Illegal
version => '.1' # Illegal
=item Dotted-integer versions
Dotted-integer (also known as dotted-decimal) versions consist of
positive integers separated by full stop characters (i.e. "dots",
"periods" or "decimal points"). This are equivalent in format to Perl
"v-strings", with some additional restrictions on form. They must be
given in "normal" form, which has a leading "v" character and at least
three integer components. To retain a one-to-one mapping with decimal
versions, all components after the first B<should> be restricted to the
range 0 to 999. The final component B<may> be separated by an
underscore character instead of a period.
version => 'v1.2.3' # OK
version => 'v1.2_3' # OK
version => 'v1.2.3.4' # OK
version => 'v1.2.3_4' # OK
version => 'v2009.10.31' # OK
version => 'v1.2' # Illegal
version => '1.2.3' # Illegal
version => 'v1.2_3_4' # Illegal
version => 'v1.2009.10.31' # Not recommended
=back
=head2 Version Ranges
Some fields (prereq, optional_features) indicate the particular
version(s) of some other module that may be required as a prerequisite.
This section details the Version Range type used to provide this
information.
The simplest format for a Version Range is just the version
number itself, e.g. C<2.4>. This means that B<at least> version 2.4
must be present. To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.
Alternatively, a version range B<may> use the operators E<lt> (less than),
E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than
or equal), == (equal), and != (not equal). For example, the
specification C<E<lt> 2.0> means that any version of the prerequisite
less than 2.0 is suitable.
For more complicated situations, version specifications B<may> be AND-ed
together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0,
and B<not equal to> 1.5.
=head1 PREREQUISITES
=head2 Prereq Spec
The C<prereqs> key in the top-level metadata and within
C<optional_features> define the relationship between a distribution and
other packages. The prereq spec structure is a hierarchical data
structure which divides prerequisites into I<Phases> of activity in the
installation process and I<Relationships> that indicate how
prerequisites should be resolved.
For example, to specify that C<Data::Dumper> is C<required> during the
C<test> phase, this entry would appear in the distribution metadata:
prereqs => {
test => {
requires => {
'Data::Dumper' => '2.00'
}
}
}
=head3 Phases
Requirements for regular use must be listed in the C<runtime> phase.
Other requirements should be listed in the earliest stage in which they
are required and consumers must accumulate and satisfy requirements
across phases before executing the activity. For example, C<build>
requirements must also be available during the C<test> phase.
before action requirements that must be met
---------------- --------------------------------
perl Build.PL configure
perl Makefile.PL
make configure, runtime, build
Build
make test configure, runtime, build, test
Build test
Consumers that install the distribution must ensure that
I<runtime> requirements are also installed and may install
dependencies from other phases.
after action requirements that must be met
---------------- --------------------------------
make install runtime
Build install
=over
=item configure
The configure phase occurs before any dynamic configuration has been
attempted. Libraries required by the configure phase B<must> be
available for use before the distribution building tool has been
executed.
=item build
The build phase is when the distribution's source code is compiled (if
necessary) and otherwise made ready for installation.
=item test
The test phase is when the distribution's automated test suite is run.
Any library that is needed only for testing and not for subsequent use
should be listed here.
=item runtime
The runtime phase refers not only to when the distribution's contents
are installed, but also to its continued use. Any library that is a
prerequisite for regular use of this distribution should be indicated
here.
=item develop
The develop phase's prereqs are libraries needed to work on the
distribution's source code as its author does. These tools might be
needed to build a release tarball, to run author-only tests, or to
perform other tasks related to developing new versions of the
distribution.
=back
=head3 Relationships
=over
=item requires
These dependencies B<must> be installed for proper completion of the
phase.
=item recommends
Recommended dependencies are I<strongly> encouraged and should be
satisfied except in resource constrained environments.
=item suggests
These dependencies are optional, but are suggested for enhanced operation
of the described distribution.
=item conflicts
These libraries cannot be installed when the phase is in operation.
This is a very rare situation, and the C<conflicts> relationship should
be used with great caution, or not at all.
=back
=head2 Merging and Resolving Prerequisites
Whenever metadata consumers merge prerequisites, either from different
phases or from C<optional_features>, they should merged in a way which
preserves the intended semantics of the prerequisite structure. Generally,
this means concatenating the version specifications using commas, as
described in the L<Version Ranges> section.
Another subtle error that can occur in resolving prerequisites comes from
the way that modules in prerequisites are indexed to distribution files on
CPAN. When a module is deleted from a distribution, prerequisites calling
for that module could indicate an older distribution should be installed,
potentially overwriting files from a newer distribution.
For example, as of Oct 31, 2009, the CPAN index file contained these
module-distribution mappings:
Class::MOP 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz
Class::MOP::Class 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz
Class::MOP::Class::Immutable 0.04 S/ST/STEVAN/Class-MOP-0.36.tar.gz
Consider the case where "Class::MOP" 0.94 is installed. If a
distribution specified "Class::MOP::Class::Immutable" as a prerequisite,
it could result in Class-MOP-0.36.tar.gz being installed, overwriting
any files from Class-MOP-0.94.tar.gz.
Consumers of metadata B<should> test whether prerequisites would result
in installed module files being "downgraded" to an older version and
B<may> warn users or ignore the prerequisite that would cause such a
result.
=head1 SERIALIZATION
Distribution metadata should be serialized (as a hashref) as
JSON-encoded data and packaged with distributions as the file
F<META.json>.
In the past, the distribution metadata structure had been packed with
distributions as F<META.yml>, a file in the YAML Tiny format (for which,
see L<YAML::Tiny>). Tools that consume distribution metadata from disk
should be capable of loading F<META.yml>, but should prefer F<META.json>
if both are found.
=head1 NOTES FOR IMPLEMENTORS
=head2 Extracting Version Numbers from Perl Modules
To get the version number from a Perl module, consumers should use the
C<< MM->parse_version($file) >> method provided by
L<ExtUtils::MakeMaker> or L<Module::Metadata>. For example, for the
module given by C<$mod>, the version may be retrieved in one of the
following ways:
# via ExtUtils::MakeMaker
my $file = MM->_installed_file_for_module($mod);
my $version = MM->parse_version($file)
The private C<_installed_file_for_module> method may be replaced with
other methods for locating a module in C<@INC>.
# via Module::Metadata
my $info = Module::Metadata->new_from_module($mod);
my $version = $info->version;
If only a filename is available, the following approach may be used:
# via Module::Build
my $info = Module::Metadata->new_from_file($file);
my $version = $info->version;
=head2 Comparing Version Numbers
The L<version> module provides the most reliable way to compare version
numbers in all the various ways they might be provided or might exist
within modules. Given two strings containing version numbers, C<$v1> and
C<$v2>, they should be converted to C<version> objects before using
ordinary comparison operators. For example:
use version;
if ( version->new($v1) <=> version->new($v2) ) {
print "Versions are not equal\n";
}
If the only comparison needed is whether an installed module is of a
sufficiently high version, a direct test may be done using the string
form of C<eval> and the C<use> function. For example, for module C<$mod>
and version prerequisite C<$prereq>:
if ( eval "use $mod $prereq (); 1" ) {
print "Module $mod version is OK.\n";
}
If the values of C<$mod> and C<$prereq> have not been scrubbed, however,
this presents security implications.
=head2 Prerequisites for dynamically configured distributions
When C<dynamic_config> is true, it is an error to presume that the
prerequisites given in distribution metadata will have any relationship
whatsoever to the actual prerequisites of the distribution.
In practice, however, one can generally expect such prerequisites to be
one of two things:
=over 4
=item *
The minimum prerequisites for the distribution, to which dynamic configuration will only add items
=item *
Whatever the distribution configured with on the releaser's machine at release time
=back
The second case often turns out to have identical results to the first case,
albeit only by accident.
As such, consumers may use this data for informational analysis, but
presenting it to the user as canonical or relying on it as such is
invariably the height of folly.
=head2 Indexing distributions a la PAUSE
While no_index tells you what must be ignored when indexing, this spec holds
no opinion on how you should get your initial candidate list of things to
possibly index. For "normal" distributions you might consider simply indexing
the contents of lib/, but there are many fascinating oddities on CPAN and
many dists from the days when it was normal to put the main .pm file in the
root of the distribution archive - so PAUSE currently indexes all .pm and .PL
files that are not either (a) specifically excluded by no_index (b) in
C<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as
C<perl5>.
Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and
C<t> as well as anything marked as no_index.
Also remember: If the META file contains a provides field, you shouldn't be
indexing anything in the first place - just use that.
=head1 SEE ALSO
=over 4
=item *
CPAN, L<http://www.cpan.org/>
=item *
JSON, L<http://json.org/>
=item *
YAML, L<http://www.yaml.org/>
=item *
L<CPAN>
=item *
L<CPANPLUS>
=item *
L<ExtUtils::MakeMaker>
=item *
L<Module::Build>
=item *
L<Module::Install>
=back
=head1 HISTORY
Ken Williams wrote the original CPAN Meta Spec (also known as the
"META.yml spec") in 2003 and maintained it through several revisions
with input from various members of the community. In 2005, Randy
Sims redrafted it from HTML to POD for the version 1.2 release. Ken
continued to maintain the spec through version 1.4.
In late 2009, David Golden organized the version 2 proposal review
process. David and Ricardo Signes drafted the final version 2 spec
in April 2010 based on the version 1.4 spec and patches contributed
during the proposal process.
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META_SPEC
$fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_VALIDATOR';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Validator;
# VERSION
$CPAN::Meta::Validator::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod my $struct = decode_json_file('META.json');
#pod
#pod my $cmv = CPAN::Meta::Validator->new( $struct );
#pod
#pod unless ( $cmv->is_valid ) {
#pod my $msg = "Invalid META structure. Errors found:\n";
#pod $msg .= join( "\n", $cmv->errors );
#pod die $msg;
#pod }
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module validates a CPAN Meta structure against the version of the
#pod the specification claimed in the C<meta-spec> field of the structure.
#pod
#pod =cut
#--------------------------------------------------------------------------#
# This code copied and adapted from Test::CPAN::Meta
# by Barbie, <[email protected]> for Miss Barbell Productions,
# L<http://www.missbarbell.co.uk>
#--------------------------------------------------------------------------#
#--------------------------------------------------------------------------#
# Specification Definitions
#--------------------------------------------------------------------------#
my %known_specs = (
'1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
'1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
'1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
'1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
'1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);
my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } };
my $no_index_2 = {
'map' => { file => { list => { value => \&string } },
directory => { list => { value => \&string } },
'package' => { list => { value => \&string } },
namespace => { list => { value => \&string } },
':key' => { name => \&custom_2, value => \&anything },
}
};
my $no_index_1_3 = {
'map' => { file => { list => { value => \&string } },
directory => { list => { value => \&string } },
'package' => { list => { value => \&string } },
namespace => { list => { value => \&string } },
':key' => { name => \&string, value => \&anything },
}
};
my $no_index_1_2 = {
'map' => { file => { list => { value => \&string } },
dir => { list => { value => \&string } },
'package' => { list => { value => \&string } },
namespace => { list => { value => \&string } },
':key' => { name => \&string, value => \&anything },
}
};
my $no_index_1_1 = {
'map' => { ':key' => { name => \&string, list => { value => \&string } },
}
};
my $prereq_map = {
map => {
':key' => {
name => \&phase,
'map' => {
':key' => {
name => \&relation,
%$module_map1,
},
},
}
},
};
my %definitions = (
'2' => {
# REQUIRED
'abstract' => { mandatory => 1, value => \&string },
'author' => { mandatory => 1, list => { value => \&string } },
'dynamic_config' => { mandatory => 1, value => \&boolean },
'generated_by' => { mandatory => 1, value => \&string },
'license' => { mandatory => 1, list => { value => \&license } },
'meta-spec' => {
mandatory => 1,
'map' => {
version => { mandatory => 1, value => \&version},
url => { value => \&url },
':key' => { name => \&custom_2, value => \&anything },
}
},
'name' => { mandatory => 1, value => \&string },
'release_status' => { mandatory => 1, value => \&release_status },
'version' => { mandatory => 1, value => \&version },
# OPTIONAL
'description' => { value => \&string },
'keywords' => { list => { value => \&string } },
'no_index' => $no_index_2,
'optional_features' => {
'map' => {
':key' => {
name => \&string,
'map' => {
description => { value => \&string },
prereqs => $prereq_map,
':key' => { name => \&custom_2, value => \&anything },
}
}
}
},
'prereqs' => $prereq_map,
'provides' => {
'map' => {
':key' => {
name => \&module,
'map' => {
file => { mandatory => 1, value => \&file },
version => { value => \&version },
':key' => { name => \&custom_2, value => \&anything },
}
}
}
},
'resources' => {
'map' => {
license => { list => { value => \&url } },
homepage => { value => \&url },
bugtracker => {
'map' => {
web => { value => \&url },
mailto => { value => \&string},
':key' => { name => \&custom_2, value => \&anything },
}
},
repository => {
'map' => {
web => { value => \&url },
url => { value => \&url },
type => { value => \&string },
':key' => { name => \&custom_2, value => \&anything },
}
},
':key' => { value => \&string, name => \&custom_2 },
}
},
# CUSTOM -- additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&custom_2, value => \&anything },
},
'1.4' => {
'meta-spec' => {
mandatory => 1,
'map' => {
version => { mandatory => 1, value => \&version},
url => { mandatory => 1, value => \&urlspec },
':key' => { name => \&string, value => \&anything },
},
},
'name' => { mandatory => 1, value => \&string },
'version' => { mandatory => 1, value => \&version },
'abstract' => { mandatory => 1, value => \&string },
'author' => { mandatory => 1, list => { value => \&string } },
'license' => { mandatory => 1, value => \&license },
'generated_by' => { mandatory => 1, value => \&string },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'configure_requires' => $module_map1,
'conflicts' => $module_map2,
'optional_features' => {
'map' => {
':key' => { name => \&string,
'map' => { description => { value => \&string },
requires => $module_map1,
recommends => $module_map1,
build_requires => $module_map1,
conflicts => $module_map2,
':key' => { name => \&string, value => \&anything },
}
}
}
},
'provides' => {
'map' => {
':key' => { name => \&module,
'map' => {
file => { mandatory => 1, value => \&file },
version => { value => \&version },
':key' => { name => \&string, value => \&anything },
}
}
}
},
'no_index' => $no_index_1_3,
'private' => $no_index_1_3,
'keywords' => { list => { value => \&string } },
'resources' => {
'map' => { license => { value => \&url },
homepage => { value => \&url },
bugtracker => { value => \&url },
repository => { value => \&url },
':key' => { value => \&string, name => \&custom_1 },
}
},
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
'1.3' => {
'meta-spec' => {
mandatory => 1,
'map' => {
version => { mandatory => 1, value => \&version},
url => { mandatory => 1, value => \&urlspec },
':key' => { name => \&string, value => \&anything },
},
},
'name' => { mandatory => 1, value => \&string },
'version' => { mandatory => 1, value => \&version },
'abstract' => { mandatory => 1, value => \&string },
'author' => { mandatory => 1, list => { value => \&string } },
'license' => { mandatory => 1, value => \&license },
'generated_by' => { mandatory => 1, value => \&string },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'conflicts' => $module_map2,
'optional_features' => {
'map' => {
':key' => { name => \&string,
'map' => { description => { value => \&string },
requires => $module_map1,
recommends => $module_map1,
build_requires => $module_map1,
conflicts => $module_map2,
':key' => { name => \&string, value => \&anything },
}
}
}
},
'provides' => {
'map' => {
':key' => { name => \&module,
'map' => {
file => { mandatory => 1, value => \&file },
version => { value => \&version },
':key' => { name => \&string, value => \&anything },
}
}
}
},
'no_index' => $no_index_1_3,
'private' => $no_index_1_3,
'keywords' => { list => { value => \&string } },
'resources' => {
'map' => { license => { value => \&url },
homepage => { value => \&url },
bugtracker => { value => \&url },
repository => { value => \&url },
':key' => { value => \&string, name => \&custom_1 },
}
},
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
# v1.2 is misleading, it seems to assume that a number of fields where created
# within v1.1, when they were created within v1.2. This may have been an
# original mistake, and that a v1.1 was retro fitted into the timeline, when
# v1.2 was originally slated as v1.1. But I could be wrong ;)
'1.2' => {
'meta-spec' => {
mandatory => 1,
'map' => {
version => { mandatory => 1, value => \&version},
url => { mandatory => 1, value => \&urlspec },
':key' => { name => \&string, value => \&anything },
},
},
'name' => { mandatory => 1, value => \&string },
'version' => { mandatory => 1, value => \&version },
'license' => { mandatory => 1, value => \&license },
'generated_by' => { mandatory => 1, value => \&string },
'author' => { mandatory => 1, list => { value => \&string } },
'abstract' => { mandatory => 1, value => \&string },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'keywords' => { list => { value => \&string } },
'private' => $no_index_1_2,
'$no_index' => $no_index_1_2,
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'conflicts' => $module_map2,
'optional_features' => {
'map' => {
':key' => { name => \&string,
'map' => { description => { value => \&string },
requires => $module_map1,
recommends => $module_map1,
build_requires => $module_map1,
conflicts => $module_map2,
':key' => { name => \&string, value => \&anything },
}
}
}
},
'provides' => {
'map' => {
':key' => { name => \&module,
'map' => {
file => { mandatory => 1, value => \&file },
version => { value => \&version },
':key' => { name => \&string, value => \&anything },
}
}
}
},
'resources' => {
'map' => { license => { value => \&url },
homepage => { value => \&url },
bugtracker => { value => \&url },
repository => { value => \&url },
':key' => { value => \&string, name => \&custom_1 },
}
},
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
# note that the 1.1 spec only specifies 'version' as mandatory
'1.1' => {
'name' => { value => \&string },
'version' => { mandatory => 1, value => \&version },
'license' => { value => \&license },
'generated_by' => { value => \&string },
'license_uri' => { value => \&url },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'private' => $no_index_1_1,
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'conflicts' => $module_map2,
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
# note that the 1.0 spec doesn't specify optional or mandatory fields
# but we will treat version as mandatory since otherwise META 1.0 is
# completely arbitrary and pointless
'1.0' => {
'name' => { value => \&string },
'version' => { mandatory => 1, value => \&version },
'license' => { value => \&license },
'generated_by' => { value => \&string },
'license_uri' => { value => \&url },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'conflicts' => $module_map2,
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
);
#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#
#pod =method new
#pod
#pod my $cmv = CPAN::Meta::Validator->new( $struct )
#pod
#pod The constructor must be passed a metadata structure.
#pod
#pod =cut
sub new {
my ($class,$data) = @_;
# create an attributes hash
my $self = {
'data' => $data,
'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0",
'errors' => undef,
};
# create the object
return bless $self, $class;
}
#pod =method is_valid
#pod
#pod if ( $cmv->is_valid ) {
#pod ...
#pod }
#pod
#pod Returns a boolean value indicating whether the metadata provided
#pod is valid.
#pod
#pod =cut
sub is_valid {
my $self = shift;
my $data = $self->{data};
my $spec_version = $self->{spec};
$self->check_map($definitions{$spec_version},$data);
return ! $self->errors;
}
#pod =method errors
#pod
#pod warn( join "\n", $cmv->errors );
#pod
#pod Returns a list of errors seen during validation.
#pod
#pod =cut
sub errors {
my $self = shift;
return () unless(defined $self->{errors});
return @{$self->{errors}};
}
#pod =begin :internals
#pod
#pod =head2 Check Methods
#pod
#pod =over
#pod
#pod =item *
#pod
#pod check_map($spec,$data)
#pod
#pod Checks whether a map (or hash) part of the data structure conforms to the
#pod appropriate specification definition.
#pod
#pod =item *
#pod
#pod check_list($spec,$data)
#pod
#pod Checks whether a list (or array) part of the data structure conforms to
#pod the appropriate specification definition.
#pod
#pod =item *
#pod
#pod =back
#pod
#pod =cut
my $spec_error = "Missing validation action in specification. "
. "Must be one of 'map', 'list', or 'value'";
sub check_map {
my ($self,$spec,$data) = @_;
if(ref($spec) ne 'HASH') {
$self->_error( "Unknown META specification, cannot validate." );
return;
}
if(ref($data) ne 'HASH') {
$self->_error( "Expected a map structure from string or file." );
return;
}
for my $key (keys %$spec) {
next unless($spec->{$key}->{mandatory});
next if(defined $data->{$key});
push @{$self->{stack}}, $key;
$self->_error( "Missing mandatory field, '$key'" );
pop @{$self->{stack}};
}
for my $key (keys %$data) {
push @{$self->{stack}}, $key;
if($spec->{$key}) {
if($spec->{$key}{value}) {
$spec->{$key}{value}->($self,$key,$data->{$key});
} elsif($spec->{$key}{'map'}) {
$self->check_map($spec->{$key}{'map'},$data->{$key});
} elsif($spec->{$key}{'list'}) {
$self->check_list($spec->{$key}{'list'},$data->{$key});
} else {
$self->_error( "$spec_error for '$key'" );
}
} elsif ($spec->{':key'}) {
$spec->{':key'}{name}->($self,$key,$key);
if($spec->{':key'}{value}) {
$spec->{':key'}{value}->($self,$key,$data->{$key});
} elsif($spec->{':key'}{'map'}) {
$self->check_map($spec->{':key'}{'map'},$data->{$key});
} elsif($spec->{':key'}{'list'}) {
$self->check_list($spec->{':key'}{'list'},$data->{$key});
} else {
$self->_error( "$spec_error for ':key'" );
}
} else {
$self->_error( "Unknown key, '$key', found in map structure" );
}
pop @{$self->{stack}};
}
}
sub check_list {
my ($self,$spec,$data) = @_;
if(ref($data) ne 'ARRAY') {
$self->_error( "Expected a list structure" );
return;
}
if(defined $spec->{mandatory}) {
if(!defined $data->[0]) {
$self->_error( "Missing entries from mandatory list" );
}
}
for my $value (@$data) {
push @{$self->{stack}}, $value || "<undef>";
if(defined $spec->{value}) {
$spec->{value}->($self,'list',$value);
} elsif(defined $spec->{'map'}) {
$self->check_map($spec->{'map'},$value);
} elsif(defined $spec->{'list'}) {
$self->check_list($spec->{'list'},$value);
} elsif ($spec->{':key'}) {
$self->check_map($spec,$value);
} else {
$self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
}
pop @{$self->{stack}};
}
}
#pod =head2 Validator Methods
#pod
#pod =over
#pod
#pod =item *
#pod
#pod header($self,$key,$value)
#pod
#pod Validates that the header is valid.
#pod
#pod Note: No longer used as we now read the data structure, not the file.
#pod
#pod =item *
#pod
#pod url($self,$key,$value)
#pod
#pod Validates that a given value is in an acceptable URL format
#pod
#pod =item *
#pod
#pod urlspec($self,$key,$value)
#pod
#pod Validates that the URL to a META specification is a known one.
#pod
#pod =item *
#pod
#pod string_or_undef($self,$key,$value)
#pod
#pod Validates that the value is either a string or an undef value. Bit of a
#pod catchall function for parts of the data structure that are completely user
#pod defined.
#pod
#pod =item *
#pod
#pod string($self,$key,$value)
#pod
#pod Validates that a string exists for the given key.
#pod
#pod =item *
#pod
#pod file($self,$key,$value)
#pod
#pod Validate that a file is passed for the given key. This may be made more
#pod thorough in the future. For now it acts like \&string.
#pod
#pod =item *
#pod
#pod exversion($self,$key,$value)
#pod
#pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
#pod
#pod =item *
#pod
#pod version($self,$key,$value)
#pod
#pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
#pod are both valid. A leading 'v' like 'v1.2.3' is also valid.
#pod
#pod =item *
#pod
#pod boolean($self,$key,$value)
#pod
#pod Validates for a boolean value. Currently these values are '1', '0', 'true',
#pod 'false', however the latter 2 may be removed.
#pod
#pod =item *
#pod
#pod license($self,$key,$value)
#pod
#pod Validates that a value is given for the license. Returns 1 if an known license
#pod type, or 2 if a value is given but the license type is not a recommended one.
#pod
#pod =item *
#pod
#pod custom_1($self,$key,$value)
#pod
#pod Validates that the given key is in CamelCase, to indicate a user defined
#pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
#pod of the spec, this was only explicitly stated for 'resources'.
#pod
#pod =item *
#pod
#pod custom_2($self,$key,$value)
#pod
#pod Validates that the given key begins with 'x_' or 'X_', to indicate a user
#pod defined keyword and only has characters in the class [-_a-zA-Z]
#pod
#pod =item *
#pod
#pod identifier($self,$key,$value)
#pod
#pod Validates that key is in an acceptable format for the META specification,
#pod for an identifier, i.e. any that matches the regular expression
#pod qr/[a-z][a-z_]/i.
#pod
#pod =item *
#pod
#pod module($self,$key,$value)
#pod
#pod Validates that a given key is in an acceptable module name format, e.g.
#pod 'Test::CPAN::Meta::Version'.
#pod
#pod =back
#pod
#pod =end :internals
#pod
#pod =cut
sub header {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value && $value =~ /^--- #YAML:1.0/);
}
$self->_error( "file does not have a valid YAML header." );
return 0;
}
sub release_status {
my ($self,$key,$value) = @_;
if(defined $value) {
my $version = $self->{data}{version} || '';
if ( $version =~ /_/ ) {
return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
$self->_error( "'$value' for '$key' is invalid for version '$version'" );
}
else {
return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
$self->_error( "'$value' for '$key' is invalid" );
}
}
else {
$self->_error( "'$key' is not defined" );
}
return 0;
}
# _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
sub _uri_split {
return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
}
sub url {
my ($self,$key,$value) = @_;
if(defined $value) {
my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
unless ( defined $scheme && length $scheme ) {
$self->_error( "'$value' for '$key' does not have a URL scheme" );
return 0;
}
unless ( defined $auth && length $auth ) {
$self->_error( "'$value' for '$key' does not have a URL authority" );
return 0;
}
return 1;
}
$value ||= '';
$self->_error( "'$value' for '$key' is not a valid URL." );
return 0;
}
sub urlspec {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value && $known_specs{$self->{spec}} eq $value);
if($value && $known_urls{$value}) {
$self->_error( 'META specification URL does not match version' );
return 0;
}
}
$self->_error( 'Unknown META specification' );
return 0;
}
sub anything { return 1 }
sub string {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value || $value =~ /^0$/);
}
$self->_error( "value is an undefined string" );
return 0;
}
sub string_or_undef {
my ($self,$key,$value) = @_;
return 1 unless(defined $value);
return 1 if($value || $value =~ /^0$/);
$self->_error( "No string defined for '$key'" );
return 0;
}
sub file {
my ($self,$key,$value) = @_;
return 1 if(defined $value);
$self->_error( "No file defined for '$key'" );
return 0;
}
sub exversion {
my ($self,$key,$value) = @_;
if(defined $value && ($value || $value =~ /0/)) {
my $pass = 1;
for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
return $pass;
}
$value = '<undef>' unless(defined $value);
$self->_error( "'$value' for '$key' is not a valid version." );
return 0;
}
sub version {
my ($self,$key,$value) = @_;
if(defined $value) {
return 0 unless($value || $value =~ /0/);
return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
} else {
$value = '<undef>';
}
$self->_error( "'$value' for '$key' is not a valid version." );
return 0;
}
sub boolean {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value =~ /^(0|1|true|false)$/);
} else {
$value = '<undef>';
}
$self->_error( "'$value' for '$key' is not a boolean value." );
return 0;
}
my %v1_licenses = (
'perl' => 'http://dev.perl.org/licenses/',
'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
'apache' => 'http://apache.org/licenses/LICENSE-2.0',
'artistic' => 'http://opensource.org/licenses/artistic-license.php',
'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php',
'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
'mit' => 'http://opensource.org/licenses/mit-license.php',
'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php',
'open_source' => undef,
'unrestricted' => undef,
'restrictive' => undef,
'unknown' => undef,
);
my %v2_licenses = map { $_ => 1 } qw(
agpl_3
apache_1_1
apache_2_0
artistic_1
artistic_2
bsd
freebsd
gfdl_1_2
gfdl_1_3
gpl_1
gpl_2
gpl_3
lgpl_2_1
lgpl_3_0
mit
mozilla_1_0
mozilla_1_1
openssl
perl_5
qpl_1_0
ssleay
sun
zlib
open_source
restricted
unrestricted
unknown
);
sub license {
my ($self,$key,$value) = @_;
my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
if(defined $value) {
return 1 if($value && exists $licenses->{$value});
} else {
$value = '<undef>';
}
$self->_error( "License '$value' is invalid" );
return 0;
}
sub custom_1 {
my ($self,$key) = @_;
if(defined $key) {
# a valid user defined key should be alphabetic
# and contain at least one capital case letter.
return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
} else {
$key = '<undef>';
}
$self->_error( "Custom resource '$key' must be in CamelCase." );
return 0;
}
sub custom_2 {
my ($self,$key) = @_;
if(defined $key) {
return 1 if($key && $key =~ /^x_/i); # user defined
} else {
$key = '<undef>';
}
$self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
return 0;
}
sub identifier {
my ($self,$key) = @_;
if(defined $key) {
return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined
} else {
$key = '<undef>';
}
$self->_error( "Key '$key' is not a legal identifier." );
return 0;
}
sub module {
my ($self,$key) = @_;
if(defined $key) {
return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
} else {
$key = '<undef>';
}
$self->_error( "Key '$key' is not a legal module name." );
return 0;
}
my @valid_phases = qw/ configure build test runtime develop /;
sub phase {
my ($self,$key) = @_;
if(defined $key) {
return 1 if( length $key && grep { $key eq $_ } @valid_phases );
return 1 if $key =~ /x_/i;
} else {
$key = '<undef>';
}
$self->_error( "Key '$key' is not a legal phase." );
return 0;
}
my @valid_relations = qw/ requires recommends suggests conflicts /;
sub relation {
my ($self,$key) = @_;
if(defined $key) {
return 1 if( length $key && grep { $key eq $_ } @valid_relations );
return 1 if $key =~ /x_/i;
} else {
$key = '<undef>';
}
$self->_error( "Key '$key' is not a legal prereq relationship." );
return 0;
}
sub _error {
my $self = shift;
my $mess = shift;
$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
$mess .= " [Validation: $self->{spec}]";
push @{$self->{errors}}, $mess;
}
1;
# ABSTRACT: validate CPAN distribution metadata structures
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Validator - validate CPAN distribution metadata structures
=head1 VERSION
version 2.143240
=head1 SYNOPSIS
my $struct = decode_json_file('META.json');
my $cmv = CPAN::Meta::Validator->new( $struct );
unless ( $cmv->is_valid ) {
my $msg = "Invalid META structure. Errors found:\n";
$msg .= join( "\n", $cmv->errors );
die $msg;
}
=head1 DESCRIPTION
This module validates a CPAN Meta structure against the version of the
the specification claimed in the C<meta-spec> field of the structure.
=head1 METHODS
=head2 new
my $cmv = CPAN::Meta::Validator->new( $struct )
The constructor must be passed a metadata structure.
=head2 is_valid
if ( $cmv->is_valid ) {
...
}
Returns a boolean value indicating whether the metadata provided
is valid.
=head2 errors
warn( join "\n", $cmv->errors );
Returns a list of errors seen during validation.
=begin :internals
=head2 Check Methods
=over
=item *
check_map($spec,$data)
Checks whether a map (or hash) part of the data structure conforms to the
appropriate specification definition.
=item *
check_list($spec,$data)
Checks whether a list (or array) part of the data structure conforms to
the appropriate specification definition.
=item *
=back
=head2 Validator Methods
=over
=item *
header($self,$key,$value)
Validates that the header is valid.
Note: No longer used as we now read the data structure, not the file.
=item *
url($self,$key,$value)
Validates that a given value is in an acceptable URL format
=item *
urlspec($self,$key,$value)
Validates that the URL to a META specification is a known one.
=item *
string_or_undef($self,$key,$value)
Validates that the value is either a string or an undef value. Bit of a
catchall function for parts of the data structure that are completely user
defined.
=item *
string($self,$key,$value)
Validates that a string exists for the given key.
=item *
file($self,$key,$value)
Validate that a file is passed for the given key. This may be made more
thorough in the future. For now it acts like \&string.
=item *
exversion($self,$key,$value)
Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
=item *
version($self,$key,$value)
Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
are both valid. A leading 'v' like 'v1.2.3' is also valid.
=item *
boolean($self,$key,$value)
Validates for a boolean value. Currently these values are '1', '0', 'true',
'false', however the latter 2 may be removed.
=item *
license($self,$key,$value)
Validates that a value is given for the license. Returns 1 if an known license
type, or 2 if a value is given but the license type is not a recommended one.
=item *
custom_1($self,$key,$value)
Validates that the given key is in CamelCase, to indicate a user defined
keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
of the spec, this was only explicitly stated for 'resources'.
=item *
custom_2($self,$key,$value)
Validates that the given key begins with 'x_' or 'X_', to indicate a user
defined keyword and only has characters in the class [-_a-zA-Z]
=item *
identifier($self,$key,$value)
Validates that key is in an acceptable format for the META specification,
for an identifier, i.e. any that matches the regular expression
qr/[a-z][a-z_]/i.
=item *
module($self,$key,$value)
Validates that a given key is in an acceptable module name format, e.g.
'Test::CPAN::Meta::Version'.
=back
=end :internals
=for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file
identifier license module phase relation release_status string string_or_undef
url urlspec version header check_map
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <[email protected]>
=item *
Ricardo Signes <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_META_VALIDATOR
$fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML';
use 5.008001; # sane UTF-8 support
use strict;
use warnings;
package CPAN::Meta::YAML;
$CPAN::Meta::YAML::VERSION = '0.011';
BEGIN {
$CPAN::Meta::YAML::AUTHORITY = 'cpan:ADAMK';
}
# git description: v1.59-TRIAL-1-g33d9cd2
; # original $VERSION removed by Doppelgaenger
# XXX-INGY is 5.8.1 too old/broken for utf8?
# XXX-XDG Lancaster consensus was that it was sufficient until
# proven otherwise
#####################################################################
# The CPAN::Meta::YAML API.
#
# These are the currently documented API functions/methods and
# exports:
use Exporter;
our @ISA = qw{ Exporter };
our @EXPORT = qw{ Load Dump };
our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
###
# Functional/Export API:
sub Dump {
return CPAN::Meta::YAML->new(@_)->_dump_string;
}
# XXX-INGY Returning last document seems a bad behavior.
# XXX-XDG I think first would seem more natural, but I don't know
# that it's worth changing now
sub Load {
my $self = CPAN::Meta::YAML->_load_string(@_);
if ( wantarray ) {
return @$self;
} else {
# To match YAML.pm, return the last document
return $self->[-1];
}
}
# XXX-INGY Do we really need freeze and thaw?
# XXX-XDG I don't think so. I'd support deprecating them.
BEGIN {
*freeze = \&Dump;
*thaw = \&Load;
}
sub DumpFile {
my $file = shift;
return CPAN::Meta::YAML->new(@_)->_dump_file($file);
}
sub LoadFile {
my $file = shift;
my $self = CPAN::Meta::YAML->_load_file($file);
if ( wantarray ) {
return @$self;
} else {
# Return only the last document to match YAML.pm,
return $self->[-1];
}
}
###
# Object Oriented API:
# Create an empty CPAN::Meta::YAML object
# XXX-INGY Why do we use ARRAY object?
# NOTE: I get it now, but I think it's confusing and not needed.
# Will change it on a branch later, for review.
#
# XXX-XDG I don't support changing it yet. It's a very well-documented
# "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested
# we not change it until YAML.pm's own OO API is established so that
# users only have one API change to digest, not two
sub new {
my $class = shift;
bless [ @_ ], $class;
}
# XXX-INGY It probably doesn't matter, and it's probably too late to
# change, but 'read/write' are the wrong names. Read and Write
# are actions that take data from storage to memory
# characters/strings. These take the data to/from storage to native
# Perl objects, which the terms dump and load are meant. As long as
# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
# to add new {read,write}_* methods to this API.
sub read_string {
my $self = shift;
$self->_load_string(@_);
}
sub write_string {
my $self = shift;
$self->_dump_string(@_);
}
sub read {
my $self = shift;
$self->_load_file(@_);
}
sub write {
my $self = shift;
$self->_dump_file(@_);
}
#####################################################################
# Constants
# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
0 x01 x02 x03 x04 x05 x06 a
b t n v f r x0E x0F
x10 x11 x12 x13 x14 x15 x16 x17
x18 x19 x1A e x1C x1D x1E x1F
);
# Printable characters for escapes
my %UNESCAPES = (
0 => "\x00", z => "\x00", N => "\x85",
a => "\x07", b => "\x08", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
# XXX-INGY
# I(ngy) need to decide if these values should be quoted in
# CPAN::Meta::YAML or not. Probably yes.
# These 3 values have special meaning when unquoted and using the
# default YAML schema. They need quotes if they are strings.
my %QUOTE = map { $_ => 1 } qw{
null true false
};
# The commented out form is simpler, but overloaded the Perl regex
# engine due to recursion and backtracking problems on strings
# larger than 32,000ish characters. Keep it for reference purposes.
# qr/\"((?:\\.|[^\"])*)\"/
my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
# unquoted re gets trailing space that needs to be stripped
my $re_capture_unquoted_key = qr/([^:]+(?::+\S[^:]*)*)(?=\s*\:(?:\s+|$))/;
my $re_trailing_comment = qr/(?:\s+\#.*)?/;
my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
#####################################################################
# CPAN::Meta::YAML Implementation.
#
# These are the private methods that do all the work. They may change
# at any time.
###
# Loader functions:
# Create an object from a file
sub _load_file {
my $class = ref $_[0] ? ref shift : shift;
# Check the file
my $file = shift or $class->_error( 'You did not specify a file name' );
$class->_error( "File '$file' does not exist" )
unless -e $file;
$class->_error( "'$file' is a directory, not a file" )
unless -f _;
$class->_error( "Insufficient permissions to read '$file'" )
unless -r _;
# Open unbuffered with strict UTF-8 decoding and no translation layers
open( my $fh, "<:unix:encoding(UTF-8)", $file );
unless ( $fh ) {
$class->_error("Failed to open file '$file': $!");
}
# flock if available (or warn if not possible for OS-specific reasons)
if ( _can_flock() ) {
flock( $fh, Fcntl::LOCK_SH() )
or warn "Couldn't lock '$file' for reading: $!";
}
# slurp the contents
my $contents = eval {
use warnings FATAL => 'utf8';
local $/;
<$fh>
};
if ( my $err = $@ ) {
$class->_error("Error reading from file '$file': $err");
}
# close the file (release the lock)
unless ( close $fh ) {
$class->_error("Failed to close file '$file': $!");
}
$class->_load_string( $contents );
}
# Create an object from a string
sub _load_string {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless [], $class;
my $string = $_[0];
eval {
unless ( defined $string ) {
die \"Did not provide a string to load";
}
# Check if Perl has it marked as characters, but it's internally
# inconsistent. E.g. maybe latin1 got read on a :utf8 layer
if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
die \<<'...';
Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
...
}
# Ensure Unicode character semantics, even for 0x80-0xff
utf8::upgrade($string);
# Check for and strip any leading UTF-8 BOM
$string =~ s/^\x{FEFF}//;
# Check for some special cases
return $self unless length $string;
# Split the file into lines
my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
split /(?:\015{1,2}\012|\015|\012)/, $string;
# Strip the initial YAML header
@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
# A nibbling parser
my $in_document = 0;
while ( @lines ) {
# Do we have a document header?
if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
# Handle scalar documents
shift @lines;
if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
push @$self,
$self->_load_scalar( "$1", [ undef ], \@lines );
next;
}
$in_document = 1;
}
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
# A naked document
push @$self, undef;
while ( @lines and $lines[0] !~ /^---/ ) {
shift @lines;
}
$in_document = 0;
# XXX The final '-+$' is to look for -- which ends up being an
# error later.
} elsif ( ! $in_document && @$self ) {
# only the first document can be explicit
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
} elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
# An array at the root
my $document = [ ];
push @$self, $document;
$self->_load_array( $document, [ 0 ], \@lines );
} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
# A hash at the root
my $document = { };
push @$self, $document;
$self->_load_hash( $document, [ length($1) ], \@lines );
} else {
# Shouldn't get here. @lines have whitespace-only lines
# stripped, and previous match is a line with any
# non-whitespace. So this clause should only be reachable via
# a perlbug where \s is not symmetric with \S
# uncoverable statement
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
}
}
};
if ( ref $@ eq 'SCALAR' ) {
$self->_error(${$@});
} elsif ( $@ ) {
$self->_error($@);
}
return $self;
}
sub _unquote_single {
my ($self, $string) = @_;
return '' unless length $string;
$string =~ s/\'\'/\'/g;
return $string;
}
sub _unquote_double {
my ($self, $string) = @_;
return '' unless length $string;
$string =~ s/\\"/"/g;
$string =~
s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
{(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
return $string;
}
# Load a YAML scalar string to the actual Perl scalar
sub _load_scalar {
my ($self, $string, $indent, $lines) = @_;
# Trim trailing whitespace
$string =~ s/\s*\z//;
# Explitic null/undef
return undef if $string eq '~';
# Single quote
if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
return $self->_unquote_single($1);
}
# Double quote.
if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
return $self->_unquote_double($1);
}
# Special cases
if ( $string =~ /^[\'\"!&]/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$string'";
}
return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
# Regular unquoted string
if ( $string !~ /^[>|]/ ) {
die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
$string =~ /:(?:\s|$)/;
$string =~ s/\s+#.*\z//;
return $string;
}
# Error
die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
# Check the indent depth
$lines->[0] =~ /^(\s*)/;
$indent->[-1] = length("$1");
if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
# Pull the lines
my @multiline = ();
while ( @$lines ) {
$lines->[0] =~ /^(\s*)/;
last unless length($1) >= $indent->[-1];
push @multiline, substr(shift(@$lines), length($1));
}
my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
return join( $j, @multiline ) . $t;
}
# Load an array
sub _load_array {
my ($self, $array, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
# Inline nested hash
my $indent2 = length("$1");
$lines->[0] =~ s/-/ /;
push @$array, { };
$self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
shift @$lines;
unless ( @$lines ) {
push @$array, undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)\-/ ) {
my $indent2 = length("$1");
if ( $indent->[-1] == $indent2 ) {
# Null array entry
push @$array, undef;
} else {
# Naked indenter
push @$array, [ ];
$self->_load_array(
$array->[-1], [ @$indent, $indent2 ], $lines
);
}
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
push @$array, { };
$self->_load_hash(
$array->[-1], [ @$indent, length("$1") ], $lines
);
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
# Array entry with a value
shift @$lines;
push @$array, $self->_load_scalar(
"$2", [ @$indent, undef ], $lines
);
} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
# This is probably a structure like the following...
# ---
# foo:
# - list
# bar: value
#
# ... so lets return and let the hash parser handle it
return 1;
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
}
return 1;
}
# Load a hash
sub _load_hash {
my ($self, $hash, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
# Find the key
my $key;
# Quoted keys
if ( $lines->[0] =~
s/^\s*$re_capture_single_quoted$re_key_value_separator//
) {
$key = $self->_unquote_single($1);
}
elsif ( $lines->[0] =~
s/^\s*$re_capture_double_quoted$re_key_value_separator//
) {
$key = $self->_unquote_double($1);
}
elsif ( $lines->[0] =~
s/^\s*$re_capture_unquoted_key$re_key_value_separator//
) {
$key = $1;
$key =~ s/\s+$//;
}
elsif ( $lines->[0] =~ /^\s*\?/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
}
else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
# Do we have a value?
if ( length $lines->[0] ) {
# Yes
$hash->{$key} = $self->_load_scalar(
shift(@$lines), [ @$indent, undef ], $lines
);
} else {
# An indent
shift @$lines;
unless ( @$lines ) {
$hash->{$key} = undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)-/ ) {
$hash->{$key} = [];
$self->_load_array(
$hash->{$key}, [ @$indent, length($1) ], $lines
);
} elsif ( $lines->[0] =~ /^(\s*)./ ) {
my $indent2 = length("$1");
if ( $indent->[-1] >= $indent2 ) {
# Null hash entry
$hash->{$key} = undef;
} else {
$hash->{$key} = {};
$self->_load_hash(
$hash->{$key}, [ @$indent, length($1) ], $lines
);
}
}
}
}
return 1;
}
###
# Dumper functions:
# Save an object to a file
sub _dump_file {
my $self = shift;
require Fcntl;
# Check the file
my $file = shift or $self->_error( 'You did not specify a file name' );
my $fh;
# flock if available (or warn if not possible for OS-specific reasons)
if ( _can_flock() ) {
# Open without truncation (truncate comes after lock)
my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
sysopen( $fh, $file, $flags );
unless ( $fh ) {
$self->_error("Failed to open file '$file' for writing: $!");
}
# Use no translation and strict UTF-8
binmode( $fh, ":raw:encoding(UTF-8)");
flock( $fh, Fcntl::LOCK_EX() )
or warn "Couldn't lock '$file' for reading: $!";
# truncate and spew contents
truncate $fh, 0;
seek $fh, 0, 0;
}
else {
open $fh, ">:unix:encoding(UTF-8)", $file;
}
# serialize and spew to the handle
print {$fh} $self->_dump_string;
# close the file (release the lock)
unless ( close $fh ) {
$self->_error("Failed to close file '$file': $!");
}
return 1;
}
# Save an object to a string
sub _dump_string {
my $self = shift;
return '' unless ref $self && @$self;
# Iterate over the documents
my $indent = 0;
my @lines = ();
eval {
foreach my $cursor ( @$self ) {
push @lines, '---';
# An empty document
if ( ! defined $cursor ) {
# Do nothing
# A scalar document
} elsif ( ! ref $cursor ) {
$lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
# A list at the root
} elsif ( ref $cursor eq 'ARRAY' ) {
unless ( @$cursor ) {
$lines[-1] .= ' []';
next;
}
push @lines, $self->_dump_array( $cursor, $indent, {} );
# A hash at the root
} elsif ( ref $cursor eq 'HASH' ) {
unless ( %$cursor ) {
$lines[-1] .= ' {}';
next;
}
push @lines, $self->_dump_hash( $cursor, $indent, {} );
} else {
die \("Cannot serialize " . ref($cursor));
}
}
};
if ( ref $@ eq 'SCALAR' ) {
$self->_error(${$@});
} elsif ( $@ ) {
$self->_error($@);
}
join '', map { "$_\n" } @lines;
}
sub _has_internal_string_value {
my $value = shift;
my $b_obj = B::svref_2object(\$value); # for round trip problem
return $b_obj->FLAGS & B::SVf_POK();
}
sub _dump_scalar {
my $string = $_[1];
my $is_key = $_[2];
# Check this before checking length or it winds up looking like a string!
my $has_string_flag = _has_internal_string_value($string);
return '~' unless defined $string;
return "''" unless length $string;
if (Scalar::Util::looks_like_number($string)) {
# keys and values that have been used as strings get quoted
if ( $is_key || $has_string_flag ) {
return qq['$string'];
}
else {
return $string;
}
}
if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
$string =~ s/\\/\\\\/g;
$string =~ s/"/\\"/g;
$string =~ s/\n/\\n/g;
$string =~ s/[\x85]/\\N/g;
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
return qq|"$string"|;
}
if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
$QUOTE{$string}
) {
return "'$string'";
}
return $string;
}
sub _dump_array {
my ($self, $array, $indent, $seen) = @_;
if ( $seen->{refaddr($array)}++ ) {
die \"CPAN::Meta::YAML does not support circular references";
}
my @lines = ();
foreach my $el ( @$array ) {
my $line = (' ' x $indent) . '-';
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_dump_scalar( $el );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_dump_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die \"CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
sub _dump_hash {
my ($self, $hash, $indent, $seen) = @_;
if ( $seen->{refaddr($hash)}++ ) {
die \"CPAN::Meta::YAML does not support circular references";
}
my @lines = ();
foreach my $name ( sort keys %$hash ) {
my $el = $hash->{$name};
my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_dump_scalar( $el );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_dump_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die \"CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
#####################################################################
# DEPRECATED API methods:
# Error storage (DEPRECATED as of 1.57)
our $errstr = '';
# Set error
sub _error {
require Carp;
$errstr = $_[1];
$errstr =~ s/ at \S+ line \d+.*//;
Carp::croak( $errstr );
}
# Retrieve error
my $errstr_warned;
sub errstr {
require Carp;
Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
unless $errstr_warned++;
$errstr;
}
#####################################################################
# Helper functions. Possibly not needed.
# Use to detect nv or iv
use B;
# XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
# Some platforms can't flock :-(
# XXX-XDG I think it is. When reading and writing files, we ought
# to be locking whenever possible. People (foolishly) use YAML
# files for things like session storage, which has race issues.
my $HAS_FLOCK;
sub _can_flock {
if ( defined $HAS_FLOCK ) {
return $HAS_FLOCK;
}
else {
require Config;
my $c = \%Config::Config;
$HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
require Fcntl if $HAS_FLOCK;
return $HAS_FLOCK;
}
}
# XXX-INGY Is this core in 5.8.1? Can we remove this?
# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it
BEGIN {
local $@;
if ( eval { require Scalar::Util }
&& $Scalar::Util::VERSION
&& eval($Scalar::Util::VERSION) >= 1.18
) {
*refaddr = *Scalar::Util::refaddr;
}
else {
eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
my $pkg = ref($_[0]) or return undef;
if ( !! UNIVERSAL::can($_[0], 'can') ) {
bless $_[0], 'Scalar::Util::Fake';
} else {
$pkg = undef;
}
"$_[0]" =~ /0x(\w+)/;
my $i = do { no warnings 'portable'; hex $1 };
bless $_[0], $pkg if defined $pkg;
$i;
}
END_PERL
}
}
1;
# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
# but leaving grey area stuff up here.
#
# I would like to change Read/Write to Load/Dump below without
# changing the actual API names.
#
# It might be better to put Load/Dump API in the SYNOPSIS instead of the
# dubious OO API.
#
# null and bool explanations may be outdated.
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
=head1 VERSION
version 0.011
=head1 SYNOPSIS
use CPAN::Meta::YAML;
# reading a META file
open $fh, "<:utf8", "META.yml";
$yaml_text = do { local $/; <$fh> };
$yaml = CPAN::Meta::YAML->read_string($yaml_text)
or die CPAN::Meta::YAML->errstr;
# finding the metadata
$meta = $yaml->[0];
# writing a META file
$yaml_text = $yaml->write_string
or die CPAN::Meta::YAML->errstr;
open $fh, ">:utf8", "META.yml";
print $fh $yaml_text;
=head1 DESCRIPTION
This module implements a subset of the YAML specification for use in reading
and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should
not be used for any other general YAML parsing or generation task.
NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
responsible for proper encoding and decoding. In particular, the C<read> and
C<write> methods do B<not> support UTF-8 and should not be used.
=head1 SUPPORT
This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
there are bugs in how it parses a particular META.yml file, please file
a bug report in the YAML::Tiny bugtracker:
L<https://rt.cpan.org/Public/Dist/Display.html?Name=YAML-Tiny>
=head1 SEE ALSO
L<YAML::Tiny>, L<YAML>, L<YAML::XS>
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/CPAN-Meta-YAML/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/dagolden/CPAN-Meta-YAML>
git clone https://github.com/dagolden/CPAN-Meta-YAML.git
=head1 AUTHORS
=over 4
=item *
Adam Kennedy <[email protected]>
=item *
David Golden <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by Adam Kennedy.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# ABSTRACT: Read and write a subset of YAML for CPAN Meta files
CPAN_META_YAML
$fatpacked{"CPAN/Perl/Releases.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_PERL_RELEASES';
package CPAN::Perl::Releases;
$CPAN::Perl::Releases::VERSION = '5.20200120';
#ABSTRACT: Mapping Perl releases on CPAN to the location of the tarballs
use strict;
use warnings;
use vars qw[@ISA @EXPORT_OK];
use Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(perl_tarballs perl_versions perl_pumpkins);
# Data gathered from using findlinks.pl script in this dists tools/
# directory, run over the src/5.0 of a local CPAN mirror.
our $cache = { };
our $data =
{
"5.004" => { id => 'CHIPS' },
"5.004_01" => { id => 'TIMB' },
"5.004_02" => { id => 'TIMB' },
"5.004_03" => { id => 'TIMB' },
"5.004_04" => { id => 'TIMB' },
"5.004_05" => { id => 'CHIPS' },
"5.005" => { id => 'GSAR' },
"5.005_01" => { id => 'GSAR' },
"5.005_02" => { id => 'GSAR' },
"5.005_03" => { id => 'GBARR' },
"5.005_04" => { id => 'LBROCARD' },
"5.6.0" => { id => 'GSAR' },
"5.6.1-TRIAL1" => { id => 'GSAR' },
"5.6.1-TRIAL2" => { id => 'GSAR' },
"5.6.1-TRIAL3" => { id => 'GSAR' },
"5.6.1" => { id => 'GSAR' },
"5.6.2" => { id => 'RGARCIA' },
"5.7.0" => { id => 'JHI' },
"5.7.2" => { id => 'JHI' },
"5.7.3" => { id => 'JHI' },
"5.8.0" => { id => 'JHI' },
"5.8.1" => { id => 'JHI' },
"5.8.2" => { id => 'NWCLARK' },
"5.8.3" => { id => 'NWCLARK' },
"5.8.4" => { id => 'NWCLARK' },
"5.8.5" => { id => 'NWCLARK' },
"5.8.6" => { id => 'NWCLARK' },
"5.8.7" => { id => 'NWCLARK' },
"5.8.8" => { id => 'NWCLARK' },
"5.8.9" => { id => 'NWCLARK' },
"5.9.0" => { id => 'HVDS' },
"5.9.1" => { id => 'RGARCIA' },
"5.9.2" => { id => 'RGARCIA' },
"5.9.3" => { id => 'RGARCIA' },
"5.9.4" => { id => 'RGARCIA' },
"5.9.5" => { id => 'RGARCIA' },
"5.10.0" => { id => 'RGARCIA' },
"5.10.1" => { id => 'DAPM' },
"5.11.0" => { id => 'JESSE' },
"5.11.1" => { id => 'JESSE' },
"5.11.2" => { id => 'LBROCARD' },
"5.11.3" => { id => 'JESSE' },
"5.11.4" => { id => 'RJBS' },
"5.11.5" => { id => 'SHAY' },
"5.12.0" => { id => 'JESSE' },
"5.12.1" => { id => 'JESSE' },
"5.12.2" => { id => 'JESSE' },
"5.12.3" => { id => 'RJBS' },
"5.12.4" => { id => 'LBROCARD' },
"5.12.5" => { id => 'DOM' },
"5.13.0" => { id => 'LBROCARD' },
"5.13.1" => { id => 'RJBS' },
"5.13.2" => { id => 'MSTROUT' },
"5.13.3" => { id => 'DAGOLDEN' },
"5.13.4" => { id => 'FLORA' },
"5.13.5" => { id => 'SHAY' },
"5.13.6" => { id => 'MIYAGAWA' },
"5.13.7" => { id => 'BINGOS' },
"5.13.8" => { id => 'ZEFRAM' },
"5.13.9" => { id => 'JESSE' },
"5.13.10" => { id => 'AVAR' },
"5.13.11" => { id => 'FLORA' },
"5.14.0" => { id => 'JESSE' },
"5.14.1" => { id => 'JESSE' },
"5.14.2-RC1" => { id => 'FLORA' },
"5.14.2" => { id => 'FLORA' },
"5.14.3" => { id => 'DOM' },
"5.14.4-RC1" => { id => 'DAPM' },
"5.14.4-RC2" => { id => 'DAPM' },
"5.14.4" => { id => 'DAPM' },
"5.15.0" => { id => 'DAGOLDEN' },
"5.15.1" => { id => 'ZEFRAM' },
"5.15.2" => { id => 'RJBS' },
"5.15.3" => { id => 'STEVAN' },
"5.15.4" => { id => 'FLORA' },
"5.15.5" => { id => 'SHAY' },
"5.15.6" => { id => 'DROLSKY' },
"5.15.7" => { id => 'BINGOS' },
"5.15.8" => { id => 'CORION' },
"5.15.9" => { id => 'ABIGAIL' },
"5.16.0" => { id => 'RJBS' },
"5.16.1" => { id => 'RJBS' },
"5.16.2" => { id => 'RJBS' },
"5.16.3" => { id => 'RJBS' },
"5.17.0" => { id => 'ZEFRAM' },
"5.17.1" => { id => 'DOY' },
"5.17.2" => { id => 'TONYC' },
"5.17.3" => { id => 'SHAY' },
"5.17.4" => { id => 'FLORA' },
"5.17.5" => { id => 'FLORA' },
"5.17.6" => { id => 'RJBS' },
"5.17.7" => { id => 'DROLSKY' },
"5.17.8" => { id => 'ARC' },
"5.17.9" => { id => 'BINGOS' },
"5.17.10" => { id => 'CORION' },
"5.17.11" => { id => 'RJBS' },
"5.18.0" => { id => 'RJBS' },
"5.18.1" => { id => 'RJBS' },
"5.19.0" => { id => 'RJBS' },
"5.19.1" => { id => 'DAGOLDEN' },
"5.19.2" => { id => 'ARISTOTLE' },
"5.19.3" => { id => 'SHAY' },
"5.19.4" => { id => 'SHAY' },
"5.19.5" => { id => 'SHAY' },
"5.19.6" => { id => 'BINGOS' },
"5.19.7" => { id => 'ABIGAIL' },
"5.18.2" => { id => 'RJBS' },
"5.19.8" => { id => 'RJBS' },
"5.19.9" => { id => 'TONYC' },
"5.19.10" => { id => 'ARC' },
"5.19.11" => { id => 'SHAY' },
"5.20.0" => { id => 'RJBS' },
"5.21.0" => { id => 'RJBS' },
"5.21.1" => { id => 'WOLFSAGE' },
"5.21.2" => { id => 'ABIGAIL' },
"5.21.3" => { id => 'PCM' },
"5.20.1-RC1" => { id => 'SHAY' },
"5.20.1-RC2" => { id => 'SHAY' },
"5.20.1" => { id => 'SHAY' },
"5.21.4" => { id => 'SHAY' },
"5.18.3" => { id => 'RJBS' },
"5.18.4" => { id => 'RJBS' },
"5.21.5" => { id => 'ABIGAIL' },
"5.21.6" => { id => 'BINGOS' },
"5.21.7" => { id => 'CORION' },
"5.21.8" => { id => 'WOLFSAGE' },
"5.20.2-RC1" => { id => 'SHAY' },
"5.20.2" => { id => 'SHAY' },
"5.21.10" => { id => 'SHAY' },
"5.21.11" => { id => 'SHAY' },
"5.22.0" => { id => 'RJBS' },
"5.23.0" => { id => 'RJBS' },
"5.23.1" => { id => 'WOLFSAGE' },
"5.23.2" => { id => 'WOLFSAGE' },
"5.20.3-RC1" => { id => 'SHAY' },
"5.20.3-RC2" => { id => 'SHAY' },
"5.20.3" => { id => 'SHAY' },
"5.23.3" => { id => 'PCM' },
"5.23.4" => { id => 'SHAY' },
"5.22.1-RC1" => { id => 'SHAY' },
"5.22.1-RC2" => { id => 'SHAY' },
"5.23.5" => { id => 'ABIGAIL' },
"5.22.1-RC3" => { id => 'SHAY' },
"5.22.1-RC4" => { id => 'SHAY' },
"5.22.1" => { id => 'SHAY' },
"5.23.6" => { id => 'DAGOLDEN', noxz => 1 },
"5.23.7" => { id => 'STEVAN' },
"5.23.9" => { id => 'ABIGAIL' },
"5.22.2-RC1" => { id => 'SHAY' },
"5.24.0-RC1" => { id => 'RJBS' },
"5.24.0-RC2" => { id => 'RJBS' },
"5.24.0-RC3" => { id => 'RJBS' },
"5.22.2" => { id => 'SHAY' },
"5.24.0-RC4" => { id => 'RJBS' },
"5.24.0-RC5" => { id => 'RJBS' },
"5.24.0" => { id => 'RJBS' },
"5.25.0" => { id => 'RJBS' },
"5.25.2" => { id => 'WOLFSAGE' },
"5.22.3-RC1" => { id => 'SHAY' },
"5.24.1-RC1" => { id => 'SHAY' },
"5.25.3" => { id => 'SHAY' },
"5.22.3-RC2" => { id => 'SHAY' },
"5.24.1-RC2" => { id => 'SHAY' },
"5.22.3-RC3" => { id => 'SHAY' },
"5.24.1-RC3" => { id => 'SHAY' },
"5.25.4" => { id => 'BINGOS' },
"5.25.5" => { id => 'STEVAN' },
"5.22.3-RC4" => { id => 'SHAY' },
"5.24.1-RC4" => { id => 'SHAY' },
"5.25.6" => { id => 'ARC' },
"5.25.7" => { id => 'EXODIST' },
"5.22.3-RC5" => { id => 'SHAY' },
"5.24.1-RC5" => { id => 'SHAY' },
"5.22.3" => { id => 'SHAY' },
"5.24.1" => { id => 'SHAY' },
"5.25.9" => { id => 'ABIGAIL' },
"5.25.10" => { id => 'RENEEB' },
"5.26.0" => { id => 'XSAWYERX' },
"5.27.1" => { id => 'EHERMAN' },
"5.22.4-RC1" => { id => 'SHAY' },
"5.24.2-RC1" => { id => 'SHAY' },
"5.22.4" => { id => 'SHAY' },
"5.24.2" => { id => 'SHAY' },
"5.27.2" => { id => 'ARC' },
"5.27.3" => { id => 'WOLFSAGE' },
"5.24.3-RC1" => { id => 'SHAY' },
"5.26.1-RC1" => { id => 'SHAY' },
"5.27.4" => { id => 'GENEHACK' },
"5.24.3" => { id => 'SHAY' },
"5.26.1" => { id => 'SHAY' },
"5.27.5" => { id => 'SHAY' },
"5.27.6" => { id => 'ETHER' },
"5.27.7" => { id => 'BINGOS' },
"5.27.8" => { id => 'ABIGAIL' },
"5.27.9" => { id => 'RENEEB' },
"5.27.10" => { id => 'TODDR' },
"5.24.4-RC1" => { id => 'SHAY' },
"5.26.2-RC1" => { id => 'SHAY' },
"5.24.4" => { id => 'SHAY' },
"5.26.2" => { id => 'SHAY' },
"5.27.11" => { id => 'XSAWYERX' },
"5.28.0-RC1" => { id => 'XSAWYERX' },
"5.28.0-RC2" => { id => 'XSAWYERX' },
"5.28.0-RC3" => { id => 'XSAWYERX' },
"5.28.0-RC4" => { id => 'XSAWYERX' },
"5.28.0" => { id => 'XSAWYERX' },
"5.29.0" => { id => 'XSAWYERX' },
"5.29.1" => { id => 'SHAY' },
"5.29.2" => { id => 'BINGOS' },
"5.29.3" => { id => 'GENEHACK' },
"5.29.4" => { id => 'ARC' },
"5.29.5" => { id => 'ETHER' },
"5.26.3" => { id => 'SHAY' },
"5.28.1" => { id => 'SHAY' },
"5.29.6" => { id => 'ABIGAIL' },
"5.29.7" => { id => 'ABIGAIL' },
"5.29.8" => { id => 'ATOOMIC' },
"5.29.9" => { id => 'ZAKAME' },
"5.28.2-RC1" => { id => 'SHAY' },
"5.28.2" => { id => 'SHAY' },
"5.29.10" => { id => 'XSAWYERX' },
"5.30.0-RC1" => { id => 'XSAWYERX' },
"5.30.0-RC2" => { id => 'XSAWYERX' },
"5.30.0" => { id => 'XSAWYERX' },
"5.31.0" => { id => 'XSAWYERX' },
"5.31.1" => { id => 'ETHER' },
"5.31.2" => { id => 'SHAY' },
"5.31.3" => { id => 'TOMHUKINS' },
"5.31.4" => { id => 'CORION' },
"5.31.5" => { id => 'SHAY' },
"5.30.1-RC1" => { id => 'SHAY' },
"5.30.1" => { id => 'SHAY' },
"5.31.6" => { id => 'BINGOS' },
"5.31.7" => { id => 'ATOOMIC' },
"5.31.8" => { id => 'WOLFSAGE' },
};
sub perl_tarballs {
my $vers = shift;
return unless defined $vers;
$vers = shift if eval { $vers->isa(__PACKAGE__) };
return unless exists $data->{ $vers };
if ( exists $cache->{ $vers } ) {
return { %{ $cache->{ $vers } } };
}
my $pumpkin = $data->{ $vers }->{id};
my $path = join '/', substr( $pumpkin, 0, 1 ), substr( $pumpkin, 0, 2 ), $pumpkin;
my $sep = ( $vers =~ m!^5\.0! ? '' : '-' );
my $perl = join $sep, 'perl', $vers;
my $onlygz = 1 if $vers =~ m!(?-xism:5.(?:00(?:4(?:_0[12345])?|5(?:_0[1234])?|3_07)|1(?:0.0(?:-RC[12])?|6.0-RC0)|6.(?:[02]|1(?:-TRIAL[123])?)|9.[12345]|7.[0123]|8.[01]))! || $data->{ $vers }->{onlygz};
my $onlybz2 = 1 if $data->{ $vers }->{onlybz2};
my $noxz = 1 if $data->{ $vers }->{noxz};
my $lvers;
{
my $tvers = $vers;
$tvers =~ s!\-?(TRIAL|RC)\d*!!g;
$tvers =~ s!_!.!g;
my @parts = split m!\.!, $tvers;
push @parts, 0 if scalar @parts < 3;
$lvers = sprintf("%d.%03d%03d",@parts);
}
my $foo = { };
$foo->{'tar.gz'} = "$path/$perl.tar.gz" unless $onlybz2;
$foo->{'tar.bz2'} = "$path/$perl.tar.bz2" unless $onlygz || $lvers > 5.027005;
$foo->{'tar.xz'} = "$path/$perl.tar.xz" if $lvers > 5.021005 && !$noxz;
$cache->{ $vers } = $foo;
return { %$foo };
}
sub perl_versions {
return sort _by_version keys %$data;
}
sub _by_version {
my %v = map {
my @v = split(qr/[-._]0*/, $_);
$v[2] ||= 0;
$v[3] ||= 'Z';
($_ => sprintf '%d.%03d%03d-%s', @v)
} $a, $b;
$v{$a} cmp $v{$b};
}
sub perl_pumpkins {
my %pumps = map { ( $data->{$_}->{id} => 1 ) } keys %$data;
return sort keys %pumps;
}
q|Acme::Why::Did::I::Not::Read::The::Fecking::Memo|;
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Perl::Releases - Mapping Perl releases on CPAN to the location of the tarballs
=head1 VERSION
version 5.20200120
=head1 SYNOPSIS
use CPAN::Perl::Releases qw[perl_tarballs];
my $perl = '5.14.0';
my $hashref = perl_tarballs( $perl );
print "Location: ", $_, "\n" for values %{ $hashref };
=head1 DESCRIPTION
CPAN::Perl::Releases is a module that contains the mappings of all C<perl> releases that have been uploaded to CPAN to the
C<authors/id/> path that the tarballs reside in.
This is static data, but newer versions of this module will be made available as new releases of C<perl> are uploaded to CPAN.
=head1 FUNCTIONS
=over
=item C<perl_tarballs>
Takes one parameter, a C<perl> version to search for. Returns an hashref on success or C<undef> otherwise.
The returned hashref will have a key/value for each type of tarball. A key of C<tar.gz> indicates the location
of a gzipped tar file and C<tar.bz2> of a bzip2'd tar file. The values will be the relative path under C<authors/id/>
on CPAN where the indicated tarball will be located.
perl_tarballs( '5.14.0' );
Returns a hashref like:
{
"tar.bz2" => "J/JE/JESSE/perl-5.14.0.tar.bz2",
"tar.gz" => "J/JE/JESSE/perl-5.14.0.tar.gz"
}
Not all C<perl> releases had C<tar.bz2>, but only a C<tar.gz>.
Perl tarballs may also be compressed using C<xz> and therefore have a C<tar.xz> entry.
=item C<perl_versions>
Returns the list of all the perl versions supported by the module in ascending order. C<TRIAL> and C<RC> will be lower
than an actual release.
=item C<perl_pumpkins>
Returns a sorted list of all PAUSE IDs of Perl pumpkins.
=back
=head1 SEE ALSO
L<http://www.cpan.org/src/5.0/>
=head1 AUTHOR
Chris Williams <[email protected]>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Chris Williams.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
CPAN_PERL_RELEASES
$fatpacked{"Capture/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CAPTURE_TINY';
use 5.006;
use strict;
use warnings;
package Capture::Tiny;
# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
our $VERSION = '0.48';
use Carp ();
use Exporter ();
use IO::Handle ();
use File::Spec ();
use File::Temp qw/tempfile tmpnam/;
use Scalar::Util qw/reftype blessed/;
# Get PerlIO or fake it
BEGIN {
local $@;
eval { require PerlIO; PerlIO->can('get_layers') }
or *PerlIO::get_layers = sub { return () };
}
#--------------------------------------------------------------------------#
# create API subroutines and export them
# [do STDOUT flag, do STDERR flag, do merge flag, do tee flag]
#--------------------------------------------------------------------------#
my %api = (
capture => [1,1,0,0],
capture_stdout => [1,0,0,0],
capture_stderr => [0,1,0,0],
capture_merged => [1,1,1,0],
tee => [1,1,0,1],
tee_stdout => [1,0,0,1],
tee_stderr => [0,1,0,1],
tee_merged => [1,1,1,1],
);
for my $sub ( keys %api ) {
my $args = join q{, }, @{$api{$sub}};
eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
}
our @ISA = qw/Exporter/;
our @EXPORT_OK = keys %api;
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
#--------------------------------------------------------------------------#
# constants and fixtures
#--------------------------------------------------------------------------#
my $IS_WIN32 = $^O eq 'MSWin32';
##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
##
##my $DEBUGFH;
##open $DEBUGFH, "> DEBUG" if $DEBUG;
##
##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0};
our $TIMEOUT = 30;
#--------------------------------------------------------------------------#
# command to tee output -- the argument is a filename that must
# be opened to signal that the process is ready to receive input.
# This is annoying, but seems to be the best that can be done
# as a simple, portable IPC technique
#--------------------------------------------------------------------------#
my @cmd = ($^X, '-C0', '-e', <<'HERE');
use Fcntl;
$SIG{HUP}=sub{exit};
if ( my $fn=shift ) {
sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!;
print {$fh} $$;
close $fh;
}
my $buf; while (sysread(STDIN, $buf, 2048)) {
syswrite(STDOUT, $buf); syswrite(STDERR, $buf);
}
HERE
#--------------------------------------------------------------------------#
# filehandle manipulation
#--------------------------------------------------------------------------#
sub _relayer {
my ($fh, $apply_layers) = @_;
# _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
# eliminate pseudo-layers
binmode( $fh, ":raw" );
# strip off real layers until only :unix is left
while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
binmode( $fh, ":pop" );
}
# apply other layers
my @to_apply = @$apply_layers;
shift @to_apply; # eliminate initial :unix
# _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n");
binmode($fh, ":" . join(":",@to_apply));
}
sub _name {
my $glob = shift;
no strict 'refs'; ## no critic
return *{$glob}{NAME};
}
sub _open {
open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!";
# _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" );
}
sub _close {
# _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" );
close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
}
my %dup; # cache this so STDIN stays fd0
my %proxy_count;
sub _proxy_std {
my %proxies;
if ( ! defined fileno STDIN ) {
$proxy_count{stdin}++;
if (defined $dup{stdin}) {
_open \*STDIN, "<&=" . fileno($dup{stdin});
# _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
}
else {
_open \*STDIN, "<" . File::Spec->devnull;
# _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
_open $dup{stdin} = IO::Handle->new, "<&=STDIN";
}
$proxies{stdin} = \*STDIN;
binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic
}
if ( ! defined fileno STDOUT ) {
$proxy_count{stdout}++;
if (defined $dup{stdout}) {
_open \*STDOUT, ">&=" . fileno($dup{stdout});
# _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
}
else {
_open \*STDOUT, ">" . File::Spec->devnull;
# _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
_open $dup{stdout} = IO::Handle->new, ">&=STDOUT";
}
$proxies{stdout} = \*STDOUT;
binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic
}
if ( ! defined fileno STDERR ) {
$proxy_count{stderr}++;
if (defined $dup{stderr}) {
_open \*STDERR, ">&=" . fileno($dup{stderr});
# _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
}
else {
_open \*STDERR, ">" . File::Spec->devnull;
# _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
_open $dup{stderr} = IO::Handle->new, ">&=STDERR";
}
$proxies{stderr} = \*STDERR;
binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic
}
return %proxies;
}
sub _unproxy {
my (%proxies) = @_;
# _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" );
for my $p ( keys %proxies ) {
$proxy_count{$p}--;
# _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
if ( ! $proxy_count{$p} ) {
_close $proxies{$p};
_close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
delete $dup{$p};
}
}
}
sub _copy_std {
my %handles;
for my $h ( qw/stdout stderr stdin/ ) {
next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied
my $redir = $h eq 'stdin' ? "<&" : ">&";
_open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN"
}
return \%handles;
}
# In some cases we open all (prior to forking) and in others we only open
# the output handles (setting up redirection)
sub _open_std {
my ($handles) = @_;
_open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin};
_open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout};
_open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr};
}
#--------------------------------------------------------------------------#
# private subs
#--------------------------------------------------------------------------#
sub _start_tee {
my ($which, $stash) = @_; # $which is "stdout" or "stderr"
# setup pipes
$stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
pipe $stash->{reader}{$which}, $stash->{tee}{$which};
# _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" );
select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush
# setup desired redirection for parent and child
$stash->{new}{$which} = $stash->{tee}{$which};
$stash->{child}{$which} = {
stdin => $stash->{reader}{$which},
stdout => $stash->{old}{$which},
stderr => $stash->{capture}{$which},
};
# flag file is used to signal the child is ready
$stash->{flag_files}{$which} = scalar( tmpnam() ) . $$;
# execute @cmd as a separate process
if ( $IS_WIN32 ) {
my $old_eval_err=$@;
undef $@;
eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";
# _debug( "# Win32API::File loaded\n") unless $@;
my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} );
# _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE();
my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0);
# _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n"));
_open_std( $stash->{child}{$which} );
$stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which});
# not restoring std here as it all gets redirected again shortly anyway
$@=$old_eval_err;
}
else { # use fork
_fork_exec( $which, $stash );
}
}
sub _fork_exec {
my ($which, $stash) = @_; # $which is "stdout" or "stderr"
my $pid = fork;
if ( not defined $pid ) {
Carp::confess "Couldn't fork(): $!";
}
elsif ($pid == 0) { # child
# _debug( "# in child process ...\n" );
untie *STDIN; untie *STDOUT; untie *STDERR;
_close $stash->{tee}{$which};
# _debug( "# redirecting handles in child ...\n" );
_open_std( $stash->{child}{$which} );
# _debug( "# calling exec on command ...\n" );
exec @cmd, $stash->{flag_files}{$which};
}
$stash->{pid}{$which} = $pid
}
my $have_usleep = eval "use Time::HiRes 'usleep'; 1";
sub _files_exist {
return 1 if @_ == grep { -f } @_;
Time::HiRes::usleep(1000) if $have_usleep;
return 0;
}
sub _wait_for_tees {
my ($stash) = @_;
my $start = time;
my @files = values %{$stash->{flag_files}};
my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT}
? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT;
1 until _files_exist(@files) || ($timeout && (time - $start > $timeout));
Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
unlink $_ for @files;
}
sub _kill_tees {
my ($stash) = @_;
if ( $IS_WIN32 ) {
# _debug( "# closing handles\n");
close($_) for values %{ $stash->{tee} };
# _debug( "# waiting for subprocesses to finish\n");
my $start = time;
1 until wait == -1 || (time - $start > 30);
}
else {
_close $_ for values %{ $stash->{tee} };
waitpid $_, 0 for values %{ $stash->{pid} };
}
}
sub _slurp {
my ($name, $stash) = @_;
my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/;
# _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n");
seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n";
my $text = do { local $/; scalar readline $fh };
return defined($text) ? $text : "";
}
#--------------------------------------------------------------------------#
# _capture_tee() -- generic main sub for capturing or teeing
#--------------------------------------------------------------------------#
sub _capture_tee {
# _debug( "# starting _capture_tee with (@_)...\n" );
my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_;
my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ());
Carp::confess("Custom capture options must be given as key/value pairs\n")
unless @opts % 2 == 0;
my $stash = { capture => { @opts } };
for ( keys %{$stash->{capture}} ) {
my $fh = $stash->{capture}{$_};
Carp::confess "Custom handle for $_ must be seekable\n"
unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable"));
}
# save existing filehandles and setup captures
local *CT_ORIG_STDIN = *STDIN ;
local *CT_ORIG_STDOUT = *STDOUT;
local *CT_ORIG_STDERR = *STDERR;
# find initial layers
my %layers = (
stdin => [PerlIO::get_layers(\*STDIN) ],
stdout => [PerlIO::get_layers(\*STDOUT, output => 1)],
stderr => [PerlIO::get_layers(\*STDERR, output => 1)],
);
# _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
# get layers from underlying glob of tied filehandles if we can
# (this only works for things that work like Tie::StdHandle)
$layers{stdout} = [PerlIO::get_layers(tied *STDOUT)]
if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB');
$layers{stderr} = [PerlIO::get_layers(tied *STDERR)]
if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB');
# _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
# bypass scalar filehandles and tied handles
# localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN
my %localize;
$localize{stdin}++, local(*STDIN)
if grep { $_ eq 'scalar' } @{$layers{stdin}};
$localize{stdout}++, local(*STDOUT)
if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}};
$localize{stderr}++, local(*STDERR)
if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}};
$localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0")
if tied *STDIN && $] >= 5.008;
$localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1")
if $do_stdout && tied *STDOUT && $] >= 5.008;
$localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2")
if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008;
# _debug( "# localized $_\n" ) for keys %localize;
# proxy any closed/localized handles so we don't use fds 0, 1 or 2
my %proxy_std = _proxy_std();
# _debug( "# proxy std: @{ [%proxy_std] }\n" );
# update layers after any proxying
$layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout};
$layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr};
# _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
# store old handles and setup handles for capture
$stash->{old} = _copy_std();
$stash->{new} = { %{$stash->{old}} }; # default to originals
for ( keys %do ) {
$stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new);
seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n";
$stash->{pos}{$_} = tell $stash->{capture}{$_};
# _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" );
_start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new}
}
_wait_for_tees( $stash ) if $do_tee;
# finalize redirection
$stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge;
# _debug( "# redirecting in parent ...\n" );
_open_std( $stash->{new} );
# execute user provided code
my ($exit_code, $inner_error, $outer_error, $orig_pid, @result);
{
$orig_pid = $$;
local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
# _debug( "# finalizing layers ...\n" );
_relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
_relayer(\*STDERR, $layers{stderr}) if $do_stderr;
# _debug( "# running code $code ...\n" );
my $old_eval_err=$@;
undef $@;
eval { @result = $code->(); $inner_error = $@ };
$exit_code = $?; # save this for later
$outer_error = $@; # save this for later
STDOUT->flush if $do_stdout;
STDERR->flush if $do_stderr;
$@ = $old_eval_err;
}
# restore prior filehandles and shut down tees
# _debug( "# restoring filehandles ...\n" );
_open_std( $stash->{old} );
_close( $_ ) for values %{$stash->{old}}; # don't leak fds
# shouldn't need relayering originals, but see rt.perl.org #114404
_relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
_relayer(\*STDERR, $layers{stderr}) if $do_stderr;
_unproxy( %proxy_std );
# _debug( "# killing tee subprocesses ...\n" ) if $do_tee;
_kill_tees( $stash ) if $do_tee;
# return captured output, but shortcut in void context
# unless we have to echo output to tied/scalar handles;
my %got;
if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) {
for ( keys %do ) {
_relayer($stash->{capture}{$_}, $layers{$_});
$got{$_} = _slurp($_, $stash);
# _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
}
print CT_ORIG_STDOUT $got{stdout}
if $do_stdout && $do_tee && $localize{stdout};
print CT_ORIG_STDERR $got{stderr}
if $do_stderr && $do_tee && $localize{stderr};
}
$? = $exit_code;
$@ = $inner_error if $inner_error;
die $outer_error if $outer_error;
# _debug( "# ending _capture_tee with (@_)...\n" );
return unless defined wantarray;
my @return;
push @return, $got{stdout} if $do_stdout;
push @return, $got{stderr} if $do_stderr && ! $do_merge;
push @return, @result;
return wantarray ? @return : $return[0];
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs
=head1 VERSION
version 0.48
=head1 SYNOPSIS
use Capture::Tiny ':all';
# capture from external command
($stdout, $stderr, $exit) = capture {
system( $cmd, @args );
};
# capture from arbitrary code (Perl or external)
($stdout, $stderr, @result) = capture {
# your code here
};
# capture partial or merged output
$stdout = capture_stdout { ... };
$stderr = capture_stderr { ... };
$merged = capture_merged { ... };
# tee output
($stdout, $stderr) = tee {
# your code here
};
$stdout = tee_stdout { ... };
$stderr = tee_stderr { ... };
$merged = tee_merged { ... };
=head1 DESCRIPTION
Capture::Tiny provides a simple, portable way to capture almost anything sent
to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or
from an external program. Optionally, output can be teed so that it is
captured while being passed through to the original filehandles. Yes, it even
works on Windows (usually). Stop guessing which of a dozen capturing modules
to use in any particular situation and just use this one.
=head1 USAGE
The following functions are available. None are exported by default.
=head2 capture
($stdout, $stderr, @result) = capture \&code;
$stdout = capture \&code;
The C<capture> function takes a code reference and returns what is sent to
STDOUT and STDERR as well as any return values from the code reference. In
scalar context, it returns only STDOUT. If no output was received for a
filehandle, it returns an empty string for that filehandle. Regardless of calling
context, all output is captured -- nothing is passed to the existing filehandles.
It is prototyped to take a subroutine reference as an argument. Thus, it
can be called in block form:
($stdout, $stderr) = capture {
# your code here ...
};
Note that the coderef is evaluated in list context. If you wish to force
scalar context on the return value, you must use the C<scalar> keyword.
($stdout, $stderr, $count) = capture {
my @list = qw/one two three/;
return scalar @list; # $count will be 3
};
Also note that within the coderef, the C<@_> variable will be empty. So don't
use arguments from a surrounding subroutine without copying them to an array
first:
sub wont_work {
my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG
...
}
sub will_work {
my @args = @_;
my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT
...
}
Captures are normally done to an anonymous temporary filehandle. To
capture via a named file (e.g. to externally monitor a long-running capture),
provide custom filehandles as a trailing list of option pairs:
my $out_fh = IO::File->new("out.txt", "w+");
my $err_fh = IO::File->new("out.txt", "w+");
capture { ... } stdout => $out_fh, stderr => $err_fh;
The filehandles must be read/write and seekable. Modifying the files or
filehandles during a capture operation will give unpredictable results.
Existing IO layers on them may be changed by the capture.
When called in void context, C<capture> saves memory and time by
not reading back from the capture handles.
=head2 capture_stdout
($stdout, @result) = capture_stdout \&code;
$stdout = capture_stdout \&code;
The C<capture_stdout> function works just like C<capture> except only
STDOUT is captured. STDERR is not captured.
=head2 capture_stderr
($stderr, @result) = capture_stderr \&code;
$stderr = capture_stderr \&code;
The C<capture_stderr> function works just like C<capture> except only
STDERR is captured. STDOUT is not captured.
=head2 capture_merged
($merged, @result) = capture_merged \&code;
$merged = capture_merged \&code;
The C<capture_merged> function works just like C<capture> except STDOUT and
STDERR are merged. (Technically, STDERR is redirected to the same capturing
handle as STDOUT before executing the function.)
Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
properly ordered due to buffering.
=head2 tee
($stdout, $stderr, @result) = tee \&code;
$stdout = tee \&code;
The C<tee> function works just like C<capture>, except that output is captured
as well as passed on to the original STDOUT and STDERR.
When called in void context, C<tee> saves memory and time by
not reading back from the capture handles, except when the
original STDOUT OR STDERR were tied or opened to a scalar
handle.
=head2 tee_stdout
($stdout, @result) = tee_stdout \&code;
$stdout = tee_stdout \&code;
The C<tee_stdout> function works just like C<tee> except only
STDOUT is teed. STDERR is not teed (output goes to STDERR as usual).
=head2 tee_stderr
($stderr, @result) = tee_stderr \&code;
$stderr = tee_stderr \&code;
The C<tee_stderr> function works just like C<tee> except only
STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual).
=head2 tee_merged
($merged, @result) = tee_merged \&code;
$merged = tee_merged \&code;
The C<tee_merged> function works just like C<capture_merged> except that output
is captured as well as passed on to STDOUT.
Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
properly ordered due to buffering.
=head1 LIMITATIONS
=head2 Portability
Portability is a goal, not a guarantee. C<tee> requires fork, except on
Windows where C<system(1, @cmd)> is used instead. Not tested on any
particularly esoteric platforms yet. See the
L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny>
for test result by platform.
=head2 PerlIO layers
Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or
':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to
STDOUT or STDERR I<before> the call to C<capture> or C<tee>. This may not work
for tied filehandles (see below).
=head2 Modifying filehandles before capturing
Generally speaking, you should do little or no manipulation of the standard IO
filehandles prior to using Capture::Tiny. In particular, closing, reopening,
localizing or tying standard filehandles prior to capture may cause a variety of
unexpected, undesirable and/or unreliable behaviors, as described below.
Capture::Tiny does its best to compensate for these situations, but the
results may not be what you desire.
=head3 Closed filehandles
Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
closed. However, since they will be reopened to capture or tee output, any
code within the captured block that depends on finding them closed will, of
course, not find them to be closed. If they started closed, Capture::Tiny will
close them again when the capture block finishes.
Note that this reopening will happen even for STDIN or a filehandle not being
captured to ensure that the filehandle used for capture is not opened to file
descriptor 0, as this causes problems on various platforms.
Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles
and also breaks tee() for undiagnosed reasons. So don't do that.
=head3 Localized filehandles
If code localizes any of Perl's standard filehandles before capturing, the capture
will affect the localized filehandles and not the original ones. External system
calls are not affected by localizing a filehandle in Perl and will continue
to send output to the original filehandles (which will thus not be captured).
=head3 Scalar filehandles
If STDOUT or STDERR are reopened to scalar filehandles prior to the call to
C<capture> or C<tee>, then Capture::Tiny will override the output filehandle for
the duration of the C<capture> or C<tee> call and then, for C<tee>, send captured
output to the output filehandle after the capture is complete. (Requires Perl
5.8)
Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
reference, but note that external processes will not be able to read from such
a handle. Capture::Tiny tries to ensure that external processes will read from
the null device instead, but this is not guaranteed.
=head3 Tied output filehandles
If STDOUT or STDERR are tied prior to the call to C<capture> or C<tee>, then
Capture::Tiny will attempt to override the tie for the duration of the
C<capture> or C<tee> call and then send captured output to the tied filehandle after
the capture is complete. (Requires Perl 5.8)
Capture::Tiny may not succeed resending UTF-8 encoded data to a tied
STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle
is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine
appropriate layers like C<:utf8> from the underlying filehandle and do the right
thing.
=head3 Tied input filehandle
Capture::Tiny attempts to preserve the semantics of tied STDIN, but this
requires Perl 5.8 and is not entirely predictable. External processes
will not be able to read from such a handle.
Unless having STDIN tied is crucial, it may be safest to localize STDIN when
capturing:
my ($out, $err) = do { local *STDIN; capture { ... } };
=head2 Modifying filehandles during a capture
Attempting to modify STDIN, STDOUT or STDERR I<during> C<capture> or C<tee> is
almost certainly going to cause problems. Don't do that.
=head3 Forking inside a capture
Forks aren't portable. The behavior of filehandles during a fork is even
less so. If Capture::Tiny detects that a fork has occurred within a
capture, it will shortcut in the child process and return empty strings for
captures. Other problems may occur in the child or parent, as well.
Forking in a capture block is not recommended.
=head3 Using threads
Filehandles are global. Mixing up I/O and captures in different threads
without coordination is going to cause problems. Besides, threads are
officially discouraged.
=head3 Dropping privileges during a capture
If you drop privileges during a capture, temporary files created to
facilitate the capture may not be cleaned up afterwards.
=head2 No support for Perl 5.8.0
It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later
is recommended.
=head2 Limited support for Perl 5.6
Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly.
=head1 ENVIRONMENT
=head2 PERL_CAPTURE_TINY_TIMEOUT
Capture::Tiny uses subprocesses internally for C<tee>. By default,
Capture::Tiny will timeout with an error if such subprocesses are not ready to
receive data within 30 seconds (or whatever is the value of
C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting
the C<PERL_CAPTURE_TINY_TIMEOUT> environment variable. Setting it to zero will
disable timeouts. B<NOTE>, this does not timeout the code reference being
captured -- this only prevents Capture::Tiny itself from hanging your process
waiting for its child processes to be ready to proceed.
=head1 SEE ALSO
This module was inspired by L<IO::CaptureOutput>, which provides
similar functionality without the ability to tee output and with more
complicated code and API. L<IO::CaptureOutput> does not handle layers
or most of the unusual cases described in the L</Limitations> section and
I no longer recommend it.
There are many other CPAN modules that provide some sort of output capture,
albeit with various limitations that make them appropriate only in particular
circumstances. I'm probably missing some. The long list is provided to show
why I felt Capture::Tiny was necessary.
=over 4
=item *
L<IO::Capture>
=item *
L<IO::Capture::Extended>
=item *
L<IO::CaptureOutput>
=item *
L<IPC::Capture>
=item *
L<IPC::Cmd>
=item *
L<IPC::Open2>
=item *
L<IPC::Open3>
=item *
L<IPC::Open3::Simple>
=item *
L<IPC::Open3::Utils>
=item *
L<IPC::Run>
=item *
L<IPC::Run::SafeHandles>
=item *
L<IPC::Run::Simple>
=item *
L<IPC::Run3>
=item *
L<IPC::System::Simple>
=item *
L<Tee>
=item *
L<IO::Tee>
=item *
L<File::Tee>
=item *
L<Filter::Handle>
=item *
L<Tie::STDERR>
=item *
L<Tie::STDOUT>
=item *
L<Test::Output>
=back
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/Capture-Tiny/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/dagolden/Capture-Tiny>
git clone https://github.com/dagolden/Capture-Tiny.git
=head1 AUTHOR
David Golden <[email protected]>
=head1 CONTRIBUTORS
=for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson
=over 4
=item *
Dagfinn Ilmari Mannsåker <[email protected]>
=item *
David E. Wheeler <[email protected]>
=item *
fecundf <[email protected]>
=item *
Graham Knop <[email protected]>
=item *
Peter Rabbitson <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2009 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
CAPTURE_TINY
$fatpacked{"ExtUtils/Command.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_COMMAND';
package ExtUtils::Command;
use 5.00503;
use strict;
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
dos2unix);
$VERSION = '7.34';
$VERSION = eval $VERSION;
my $Is_VMS = $^O eq 'VMS';
my $Is_VMS_mode = $Is_VMS;
my $Is_VMS_noefs = $Is_VMS;
my $Is_Win32 = $^O eq 'MSWin32';
if( $Is_VMS ) {
my $vms_unix_rpt;
my $vms_efs;
my $vms_case;
if (eval { local $SIG{__DIE__};
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
require VMS::Feature; }) {
$vms_unix_rpt = VMS::Feature::current("filename_unix_report");
$vms_efs = VMS::Feature::current("efs_charset");
$vms_case = VMS::Feature::current("efs_case_preserve");
} else {
my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
$vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
$vms_efs = $efs_charset =~ /^[ET1]/i;
$vms_case = $efs_case =~ /^[ET1]/i;
}
$Is_VMS_mode = 0 if $vms_unix_rpt;
$Is_VMS_noefs = 0 if ($vms_efs);
}
=head1 NAME
ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
=head1 SYNOPSIS
perl -MExtUtils::Command -e cat files... > destination
perl -MExtUtils::Command -e mv source... destination
perl -MExtUtils::Command -e cp source... destination
perl -MExtUtils::Command -e touch files...
perl -MExtUtils::Command -e rm_f files...
perl -MExtUtils::Command -e rm_rf directories...
perl -MExtUtils::Command -e mkpath directories...
perl -MExtUtils::Command -e eqtime source destination
perl -MExtUtils::Command -e test_f file
perl -MExtUtils::Command -e test_d directory
perl -MExtUtils::Command -e chmod mode files...
...
=head1 DESCRIPTION
The module is used to replace common UNIX commands. In all cases the
functions work from @ARGV rather than taking arguments. This makes
them easier to deal with in Makefiles. Call them like this:
perl -MExtUtils::Command -e some_command some files to work on
and I<NOT> like this:
perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
For that use L<Shell::Command>.
Filenames with * and ? will be glob expanded.
=head2 FUNCTIONS
=over 4
=cut
# VMS uses % instead of ? to mean "one character"
my $wild_regex = $Is_VMS ? '*%' : '*?';
sub expand_wildcards
{
@ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV);
}
=item cat
cat file ...
Concatenates all files mentioned on command line to STDOUT.
=cut
sub cat ()
{
expand_wildcards();
print while (<>);
}
=item eqtime
eqtime source destination
Sets modified time of destination to that of source.
=cut
sub eqtime
{
my ($src,$dst) = @ARGV;
local @ARGV = ($dst); touch(); # in case $dst doesn't exist
utime((stat($src))[8,9],$dst);
}
=item rm_rf
rm_rf files or directories ...
Removes files and directories - recursively (even if readonly)
=cut
sub rm_rf
{
expand_wildcards();
require File::Path;
File::Path::rmtree([grep -e $_,@ARGV],0,0);
}
=item rm_f
rm_f file ...
Removes files (even if readonly)
=cut
sub rm_f {
expand_wildcards();
foreach my $file (@ARGV) {
next unless -f $file;
next if _unlink($file);
chmod(0777, $file);
next if _unlink($file);
require Carp;
Carp::carp("Cannot delete $file: $!");
}
}
sub _unlink {
my $files_unlinked = 0;
foreach my $file (@_) {
my $delete_count = 0;
$delete_count++ while unlink $file;
$files_unlinked++ if $delete_count;
}
return $files_unlinked;
}
=item touch
touch file ...
Makes files exist, with current timestamp
=cut
sub touch {
my $t = time;
expand_wildcards();
foreach my $file (@ARGV) {
open(FILE,">>$file") || die "Cannot write $file:$!";
close(FILE);
utime($t,$t,$file);
}
}
=item mv
mv source_file destination_file
mv source_file source_file destination_dir
Moves source to destination. Multiple sources are allowed if
destination is an existing directory.
Returns true if all moves succeeded, false otherwise.
=cut
sub mv {
expand_wildcards();
my @src = @ARGV;
my $dst = pop @src;
if (@src > 1 && ! -d $dst) {
require Carp;
Carp::croak("Too many arguments");
}
require File::Copy;
my $nok = 0;
foreach my $src (@src) {
$nok ||= !File::Copy::move($src,$dst);
}
return !$nok;
}
=item cp
cp source_file destination_file
cp source_file source_file destination_dir
Copies sources to the destination. Multiple sources are allowed if
destination is an existing directory.
Returns true if all copies succeeded, false otherwise.
=cut
sub cp {
expand_wildcards();
my @src = @ARGV;
my $dst = pop @src;
if (@src > 1 && ! -d $dst) {
require Carp;
Carp::croak("Too many arguments");
}
require File::Copy;
my $nok = 0;
foreach my $src (@src) {
$nok ||= !File::Copy::copy($src,$dst);
# Win32 does not update the mod time of a copied file, just the
# created time which make does not look at.
utime(time, time, $dst) if $Is_Win32;
}
return $nok;
}
=item chmod
chmod mode files ...
Sets UNIX like permissions 'mode' on all the files. e.g. 0666
=cut
sub chmod {
local @ARGV = @ARGV;
my $mode = shift(@ARGV);
expand_wildcards();
if( $Is_VMS_mode && $Is_VMS_noefs) {
require File::Spec;
foreach my $idx (0..$#ARGV) {
my $path = $ARGV[$idx];
next unless -d $path;
# chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
# chmod 0777, [.foo]bar.dir
my @dirs = File::Spec->splitdir( $path );
$dirs[-1] .= '.dir';
$path = File::Spec->catfile(@dirs);
$ARGV[$idx] = $path;
}
}
chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
}
=item mkpath
mkpath directory ...
Creates directories, including any parent directories.
=cut
sub mkpath
{
expand_wildcards();
require File::Path;
File::Path::mkpath([@ARGV],0,0777);
}
=item test_f
test_f file
Tests if a file exists. I<Exits> with 0 if it does, 1 if it does not (ie.
shell's idea of true and false).
=cut
sub test_f
{
exit(-f $ARGV[0] ? 0 : 1);
}
=item test_d
test_d directory
Tests if a directory exists. I<Exits> with 0 if it does, 1 if it does
not (ie. shell's idea of true and false).
=cut
sub test_d
{
exit(-d $ARGV[0] ? 0 : 1);
}
=item dos2unix
dos2unix files or dirs ...
Converts DOS and OS/2 linefeeds to Unix style recursively.
=cut
sub dos2unix {
require File::Find;
File::Find::find(sub {
return if -d;
return unless -w _;
return unless -r _;
return if -B _;
local $\;
my $orig = $_;
my $temp = '.dos2unix_tmp';
open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
open TEMP, ">$temp" or
do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
binmode ORIG; binmode TEMP;
while (my $line = <ORIG>) {
$line =~ s/\015\012/\012/g;
print TEMP $line;
}
close ORIG;
close TEMP;
rename $temp, $orig;
}, @ARGV);
}
=back
=head1 SEE ALSO
Shell::Command which is these same functions but take arguments normally.
=head1 AUTHOR
Nick Ing-Simmons C<[email protected]>
Maintained by Michael G Schwern C<[email protected]> within the
ExtUtils-MakeMaker package and, as a separate CPAN package, by
Randy Kobes C<[email protected]>.
=cut
EXTUTILS_COMMAND
$fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_COMMAND_MM';
package ExtUtils::Command::MM;
require 5.006;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
warn_if_old_packlist test_s cp_nonempty);
our $VERSION = '7.34';
$VERSION = eval $VERSION;
my $Is_VMS = $^O eq 'VMS';
sub mtime {
no warnings 'redefine';
local $@;
*mtime = (eval { require Time::HiRes } && defined &Time::HiRes::stat)
? sub { (Time::HiRes::stat($_[0]))[9] }
: sub { ( stat($_[0]))[9] }
;
goto &mtime;
}
=head1 NAME
ExtUtils::Command::MM - Commands for the MM's to use in Makefiles
=head1 SYNOPSIS
perl "-MExtUtils::Command::MM" -e "function" "--" arguments...
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY!> The interface is not stable.
ExtUtils::Command::MM encapsulates code which would otherwise have to
be done with large "one" liners.
Any $(FOO) used in the examples are make variables, not Perl.
=over 4
=item B<test_harness>
test_harness($verbose, @test_libs);
Runs the tests on @ARGV via Test::Harness passing through the $verbose
flag. Any @test_libs will be unshifted onto the test's @INC.
@test_libs are run in alphabetical order.
=cut
sub test_harness {
require Test::Harness;
require File::Spec;
$Test::Harness::verbose = shift;
# Because Windows doesn't do this for us and listing all the *.t files
# out on the command line can blow over its exec limit.
require ExtUtils::Command;
my @argv = ExtUtils::Command::expand_wildcards(@ARGV);
local @INC = @INC;
unshift @INC, map { File::Spec->rel2abs($_) } @_;
Test::Harness::runtests(sort { lc $a cmp lc $b } @argv);
}
=item B<pod2man>
pod2man( '--option=value',
$podfile1 => $manpage1,
$podfile2 => $manpage2,
...
);
# or args on @ARGV
pod2man() is a function performing most of the duties of the pod2man
program. Its arguments are exactly the same as pod2man as of 5.8.0
with the addition of:
--perm_rw octal permission to set the resulting manpage to
And the removal of:
--verbose/-v
--help/-h
If no arguments are given to pod2man it will read from @ARGV.
If Pod::Man is unavailable, this function will warn and return undef.
=cut
sub pod2man {
local @ARGV = @_ ? @_ : @ARGV;
{
local $@;
if( !eval { require Pod::Man } ) {
warn "Pod::Man is not available: $@".
"Man pages will not be generated during this install.\n";
return 0;
}
}
require Getopt::Long;
# We will cheat and just use Getopt::Long. We fool it by putting
# our arguments into @ARGV. Should be safe.
my %options = ();
Getopt::Long::config ('bundling_override');
Getopt::Long::GetOptions (\%options,
'section|s=s', 'release|r=s', 'center|c=s',
'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l',
'name|n=s', 'perm_rw=i', 'utf8|u'
);
delete $options{utf8} unless $Pod::Man::VERSION >= 2.17;
# If there's no files, don't bother going further.
return 0 unless @ARGV;
# Official sets --center, but don't override things explicitly set.
if ($options{official} && !defined $options{center}) {
$options{center} = q[Perl Programmer's Reference Guide];
}
# This isn't a valid Pod::Man option and is only accepted for backwards
# compatibility.
delete $options{lax};
my $count = scalar @ARGV / 2;
my $plural = $count == 1 ? 'document' : 'documents';
print "Manifying $count pod $plural\n";
do {{ # so 'next' works
my ($pod, $man) = splice(@ARGV, 0, 2);
next if ((-e $man) &&
(mtime($man) > mtime($pod)) &&
(mtime($man) > mtime("Makefile")));
my $parser = Pod::Man->new(%options);
$parser->parse_from_file($pod, $man)
or do { warn("Could not install $man\n"); next };
if (exists $options{perm_rw}) {
chmod(oct($options{perm_rw}), $man)
or do { warn("chmod $options{perm_rw} $man: $!\n"); next };
}
}} while @ARGV;
return 1;
}
=item B<warn_if_old_packlist>
perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile>
Displays a warning that an old packlist file was found. Reads the
filename from @ARGV.
=cut
sub warn_if_old_packlist {
my $packlist = $ARGV[0];
return unless -f $packlist;
print <<"PACKLIST_WARNING";
WARNING: I have found an old package in
$packlist.
Please make sure the two installations are not conflicting
PACKLIST_WARNING
}
=item B<perllocal_install>
perl "-MExtUtils::Command::MM" -e perllocal_install
<type> <module name> <key> <value> ...
# VMS only, key|value pairs come on STDIN
perl "-MExtUtils::Command::MM" -e perllocal_install
<type> <module name> < <key>|<value> ...
Prints a fragment of POD suitable for appending to perllocal.pod.
Arguments are read from @ARGV.
'type' is the type of what you're installing. Usually 'Module'.
'module name' is simply the name of your module. (Foo::Bar)
Key/value pairs are extra information about the module. Fields include:
installed into which directory your module was out into
LINKTYPE dynamic or static linking
VERSION module version number
EXE_FILES any executables installed in a space separated
list
=cut
sub perllocal_install {
my($type, $name) = splice(@ARGV, 0, 2);
# VMS feeds args as a piped file on STDIN since it usually can't
# fit all the args on a single command line.
my @mod_info = $Is_VMS ? split /\|/, <STDIN>
: @ARGV;
my $pod;
my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time);
$pod = sprintf <<'POD', scalar($time), $type, $name, $name;
=head2 %s: C<%s> L<%s|%s>
=over 4
POD
do {
my($key, $val) = splice(@mod_info, 0, 2);
$pod .= <<POD
=item *
C<$key: $val>
POD
} while(@mod_info);
$pod .= "=back\n\n";
$pod =~ s/^ //mg;
print $pod;
return 1;
}
=item B<uninstall>
perl "-MExtUtils::Command::MM" -e uninstall <packlist>
A wrapper around ExtUtils::Install::uninstall(). Warns that
uninstallation is deprecated and doesn't actually perform the
uninstallation.
=cut
sub uninstall {
my($packlist) = shift @ARGV;
require ExtUtils::Install;
print <<'WARNING';
Uninstall is unsafe and deprecated, the uninstallation was not performed.
We will show what would have been done.
WARNING
ExtUtils::Install::uninstall($packlist, 1, 1);
print <<'WARNING';
Uninstall is unsafe and deprecated, the uninstallation was not performed.
Please check the list above carefully, there may be errors.
Remove the appropriate files manually.
Sorry for the inconvenience.
WARNING
}
=item B<test_s>
perl "-MExtUtils::Command::MM" -e test_s <file>
Tests if a file exists and is not empty (size > 0).
I<Exits> with 0 if it does, 1 if it does not.
=cut
sub test_s {
exit(-s $ARGV[0] ? 0 : 1);
}
=item B<cp_nonempty>
perl "-MExtUtils::Command::MM" -e cp_nonempty <srcfile> <dstfile> <perm>
Tests if the source file exists and is not empty (size > 0). If it is not empty
it copies it to the given destination with the given permissions.
=back
=cut
sub cp_nonempty {
my @args = @ARGV;
return 0 unless -s $args[0];
require ExtUtils::Command;
{
local @ARGV = @args[0,1];
ExtUtils::Command::cp(@ARGV);
}
{
local @ARGV = @args[2,1];
ExtUtils::Command::chmod(@ARGV);
}
}
1;
EXTUTILS_COMMAND_MM
$fatpacked{"ExtUtils/Install.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALL';
package ExtUtils::Install;
use strict;
use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);
use AutoSplit;
use Carp ();
use Config qw(%Config);
use Cwd qw(cwd);
use Exporter;
use ExtUtils::Packlist;
use File::Basename qw(dirname);
use File::Compare qw(compare);
use File::Copy;
use File::Find qw(find);
use File::Path;
use File::Spec;
@ISA = ('Exporter');
@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
=pod
=head1 NAME
ExtUtils::Install - install files from here to there
=head1 SYNOPSIS
use ExtUtils::Install;
install({ 'blib/lib' => 'some/install/dir' } );
uninstall($packlist);
pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
=head1 VERSION
2.06
=cut
$VERSION = '2.06'; # <-- do not forget to update the POD section just above this line!
$VERSION = eval $VERSION;
=pod
=head1 DESCRIPTION
Handles the installing and uninstalling of perl modules, scripts, man
pages, etc...
Both install() and uninstall() are specific to the way
ExtUtils::MakeMaker handles the installation and deinstallation of
perl modules. They are not designed as general purpose tools.
On some operating systems such as Win32 installation may not be possible
until after a reboot has occurred. This can have varying consequences:
removing an old DLL does not impact programs using the new one, but if
a new DLL cannot be installed properly until reboot then anything
depending on it must wait. The package variable
$ExtUtils::Install::MUST_REBOOT
is used to store this status.
If this variable is true then such an operation has occurred and
anything depending on this module cannot proceed until a reboot
has occurred.
If this value is defined but false then such an operation has
ocurred, but should not impact later operations.
=over
=begin _private
=item _chmod($$;$)
Wrapper to chmod() for debugging and error trapping.
=item _warnonce(@)
Warns about something only once.
=item _choke(@)
Dies with a special message.
=back
=end _private
=cut
my $Is_VMS = $^O eq 'VMS';
my $Is_MacPerl = $^O eq 'MacOS';
my $Is_Win32 = $^O eq 'MSWin32';
my $Is_cygwin = $^O eq 'cygwin';
my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin);
my $Inc_uninstall_warn_handler;
# install relative to here
my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
my $INSTALL_QUIET = $ENV{PERL_INSTALL_QUIET};
my $Curdir = File::Spec->curdir;
my $Updir = File::Spec->updir;
sub _estr(@) {
return join "\n",'!' x 72,@_,'!' x 72,'';
}
{my %warned;
sub _warnonce(@) {
my $first=shift;
my $msg=_estr "WARNING: $first",@_;
warn $msg unless $warned{$msg}++;
}}
sub _choke(@) {
my $first=shift;
my $msg=_estr "ERROR: $first",@_;
Carp::croak($msg);
}
sub _chmod($$;$) {
my ( $mode, $item, $verbose )=@_;
$verbose ||= 0;
if (chmod $mode, $item) {
printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1;
} else {
my $err="$!";
_warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n",
$mode, $item, $err
if -e $item;
}
}
=begin _private
=over
=item _move_file_at_boot( $file, $target, $moan )
OS-Specific, Win32/Cygwin
Schedules a file to be moved/renamed/deleted at next boot.
$file should be a filespec of an existing file
$target should be a ref to an array if the file is to be deleted
otherwise it should be a filespec for a rename. If the file is existing
it will be replaced.
Sets $MUST_REBOOT to 0 to indicate a deletion operation has occurred
and sets it to 1 to indicate that a move operation has been requested.
returns 1 on success, on failure if $moan is false errors are fatal.
If $moan is true then returns 0 on error and warns instead of dies.
=end _private
=cut
{
my $Has_Win32API_File;
sub _move_file_at_boot { #XXX OS-SPECIFIC
my ( $file, $target, $moan )= @_;
Carp::confess("Panic: Can't _move_file_at_boot on this platform!")
unless $CanMoveAtBoot;
my $descr= ref $target
? "'$file' for deletion"
: "'$file' for installation as '$target'";
# *note* CanMoveAtBoot is only incidentally the same condition as below
# this needs not hold true in the future.
$Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
? (eval {require Win32API::File; 1} || 0)
: 0 unless defined $Has_Win32API_File;
if ( ! $Has_Win32API_File ) {
my @msg=(
"Cannot schedule $descr at reboot.",
"Try installing Win32API::File to allow operations on locked files",
"to be scheduled during reboot. Or try to perform the operation by",
"hand yourself. (You may need to close other perl processes first)"
);
if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
return 0;
}
my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();
$opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()
unless ref $target;
_chmod( 0666, $file );
_chmod( 0666, $target ) unless ref $target;
if (Win32API::File::MoveFileEx( $file, $target, $opts )) {
$MUST_REBOOT ||= ref $target ? 0 : 1;
return 1;
} else {
my @msg=(
"MoveFileEx $descr at reboot failed: $^E",
"You may try to perform the operation by hand yourself. ",
"(You may need to close other perl processes first).",
);
if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
}
return 0;
}
}
=begin _private
=item _unlink_or_rename( $file, $tryhard, $installing )
OS-Specific, Win32/Cygwin
Tries to get a file out of the way by unlinking it or renaming it. On
some OS'es (Win32 based) DLL files can end up locked such that they can
be renamed but not deleted. Likewise sometimes a file can be locked such
that it cant even be renamed or changed except at reboot. To handle
these cases this routine finds a tempfile name that it can either rename
the file out of the way or use as a proxy for the install so that the
rename can happen later (at reboot).
$file : the file to remove.
$tryhard : should advanced tricks be used for deletion
$installing : we are not merely deleting but we want to overwrite
When $tryhard is not true if the unlink fails its fatal. When $tryhard
is true then the file is attempted to be renamed. The renamed file is
then scheduled for deletion. If the rename fails then $installing
governs what happens. If it is false the failure is fatal. If it is true
then an attempt is made to schedule installation at boot using a
temporary file to hold the new file. If this fails then a fatal error is
thrown, if it succeeds it returns the temporary file name (which will be
a derivative of the original in the same directory) so that the caller can
use it to install under. In all other cases of success returns $file.
On failure throws a fatal error.
=end _private
=cut
sub _unlink_or_rename { #XXX OS-SPECIFIC
my ( $file, $tryhard, $installing )= @_;
# this chmod was originally unconditional. However, its not needed on
# POSIXy systems since permission to unlink a file is specified by the
# directory rather than the file; and in fact it screwed up hard- and
# symlinked files. Keep it for other platforms in case its still
# needed there.
if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) {
_chmod( 0666, $file );
}
my $unlink_count = 0;
while (unlink $file) { $unlink_count++; }
return $file if $unlink_count > 0;
my $error="$!";
_choke("Cannot unlink '$file': $!")
unless $CanMoveAtBoot && $tryhard;
my $tmp= "AAA";
++$tmp while -e "$file.$tmp";
$tmp= "$file.$tmp";
warn "WARNING: Unable to unlink '$file': $error\n",
"Going to try to rename it to '$tmp'.\n";
if ( rename $file, $tmp ) {
warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n";
# when $installing we can set $moan to true.
# IOW, if we cant delete the renamed file at reboot its
# not the end of the world. The other cases are more serious
# and need to be fatal.
_move_file_at_boot( $tmp, [], $installing );
return $file;
} elsif ( $installing ) {
_warnonce("Rename failed: $!. Scheduling '$tmp'\nfor".
" installation as '$file' at reboot.\n");
_move_file_at_boot( $tmp, $file );
return $tmp;
} else {
_choke("Rename failed:$!", "Cannot proceed.");
}
}
=pod
=back
=head2 Functions
=begin _private
=over
=item _get_install_skip
Handles loading the INSTALL.SKIP file. Returns an array of patterns to use.
=cut
sub _get_install_skip {
my ( $skip, $verbose )= @_;
if ($ENV{EU_INSTALL_IGNORE_SKIP}) {
print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n"
if $verbose>2;
return [];
}
if ( ! defined $skip ) {
print "Looking for install skip list\n"
if $verbose>2;
for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) {
next unless $file;
print "\tChecking for $file\n"
if $verbose>2;
if (-e $file) {
$skip= $file;
last;
}
}
}
if ($skip && !ref $skip) {
print "Reading skip patterns from '$skip'.\n"
if $verbose;
if (open my $fh,$skip ) {
my @patterns;
while (<$fh>) {
chomp;
next if /^\s*(?:#|$)/;
print "\tSkip pattern: $_\n" if $verbose>3;
push @patterns, $_;
}
$skip= \@patterns;
} else {
warn "Can't read skip file:'$skip':$!\n";
$skip=[];
}
} elsif ( UNIVERSAL::isa($skip,'ARRAY') ) {
print "Using array for skip list\n"
if $verbose>2;
} elsif ($verbose) {
print "No skip list found.\n"
if $verbose>1;
$skip= [];
}
warn "Got @{[0+@$skip]} skip patterns.\n"
if $verbose>3;
return $skip
}
=pod
=item _have_write_access
Abstract a -w check that tries to use POSIX::access() if possible.
=cut
{
my $has_posix;
sub _have_write_access {
my $dir=shift;
unless (defined $has_posix) {
$has_posix= (!$Is_cygwin && !$Is_Win32
&& eval 'local $^W; require POSIX; 1') || 0;
}
if ($has_posix) {
return POSIX::access($dir, POSIX::W_OK());
} else {
return -w $dir;
}
}
}
=pod
=item _can_write_dir(C<$dir>)
Checks whether a given directory is writable, taking account
the possibility that the directory might not exist and would have to
be created first.
Returns a list, containing: C<($writable, $determined_by, @create)>
C<$writable> says whether the directory is (hypothetically) writable
C<$determined_by> is the directory the status was determined from. It will be
either the C<$dir>, or one of its parents.
C<@create> is a list of directories that would probably have to be created
to make the requested directory. It may not actually be correct on
relative paths with C<..> in them. But for our purposes it should work ok
=cut
sub _can_write_dir {
my $dir=shift;
return
unless defined $dir and length $dir;
my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1);
my @dirs = File::Spec->splitdir($dirs);
unshift @dirs, File::Spec->curdir
unless File::Spec->file_name_is_absolute($dir);
my $path='';
my @make;
while (@dirs) {
if ($Is_VMS) {
$dir = File::Spec->catdir($vol,@dirs);
}
else {
$dir = File::Spec->catdir(@dirs);
$dir = File::Spec->catpath($vol,$dir,'')
if defined $vol and length $vol;
}
next if ( $dir eq $path );
if ( ! -e $dir ) {
unshift @make,$dir;
next;
}
if ( _have_write_access($dir) ) {
return 1,$dir,@make
} else {
return 0,$dir,@make
}
} continue {
pop @dirs;
}
return 0;
}
=pod
=item _mkpath($dir,$show,$mode,$verbose,$dry_run)
Wrapper around File::Path::mkpath() to handle errors.
If $verbose is true and >1 then additional diagnostics will be produced, also
this will force $show to true.
If $dry_run is true then the directory will not be created but a check will be
made to see whether it would be possible to write to the directory, or that
it would be possible to create the directory.
If $dry_run is not true dies if the directory can not be created or is not
writable.
=cut
sub _mkpath {
my ($dir,$show,$mode,$verbose,$dry_run)=@_;
if ( $verbose && $verbose > 1 && ! -d $dir) {
$show= 1;
printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
}
if (!$dry_run) {
if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
_choke("Can't create '$dir'","$@");
}
}
my ($can,$root,@make)=_can_write_dir($dir);
if (!$can) {
my @msg=(
"Can't create '$dir'",
$root ? "Do not have write permissions on '$root'"
: "Unknown Error"
);
if ($dry_run) {
_warnonce @msg;
} else {
_choke @msg;
}
} elsif ($show and $dry_run) {
print "$_\n" for @make;
}
}
=pod
=item _copy($from,$to,$verbose,$dry_run)
Wrapper around File::Copy::copy to handle errors.
If $verbose is true and >1 then additional diagnostics will be emitted.
If $dry_run is true then the copy will not actually occur.
Dies if the copy fails.
=cut
sub _copy {
my ( $from, $to, $verbose, $dry_run)=@_;
if ($verbose && $verbose>1) {
printf "copy(%s,%s)\n", $from, $to;
}
if (!$dry_run) {
File::Copy::copy($from,$to)
or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
}
}
=pod
=item _chdir($from)
Wrapper around chdir to catch errors.
If not called in void context returns the cwd from before the chdir.
dies on error.
=cut
sub _chdir {
my ($dir)= @_;
my $ret;
if (defined wantarray) {
$ret= cwd;
}
chdir $dir
or _choke("Couldn't chdir to '$dir': $!");
return $ret;
}
=pod
=back
=end _private
=over
=item B<install>
# deprecated forms
install(\%from_to);
install(\%from_to, $verbose, $dry_run, $uninstall_shadows,
$skip, $always_copy, \%result);
# recommended form as of 1.47
install([
from_to => \%from_to,
verbose => 1,
dry_run => 0,
uninstall_shadows => 1,
skip => undef,
always_copy => 1,
result => \%install_results,
]);
Copies each directory tree of %from_to to its corresponding value
preserving timestamps and permissions.
There are two keys with a special meaning in the hash: "read" and
"write". These contain packlist files. After the copying is done,
install() will write the list of target files to $from_to{write}. If
$from_to{read} is given the contents of this file will be merged into
the written file. The read and the written file may be identical, but
on AFS it is quite likely that people are installing to a different
directory than the one where the files later appear.
If $verbose is true, will print out each file removed. Default is
false. This is "make install VERBINST=1". $verbose values going
up to 5 show increasingly more diagnostics output.
If $dry_run is true it will only print what it was going to do
without actually doing it. Default is false.
If $uninstall_shadows is true any differing versions throughout @INC
will be uninstalled. This is "make install UNINST=1"
As of 1.37_02 install() supports the use of a list of patterns to filter out
files that shouldn't be installed. If $skip is omitted or undefined then
install will try to read the list from INSTALL.SKIP in the CWD. This file is
a list of regular expressions and is just like the MANIFEST.SKIP file used
by L<ExtUtils::Manifest>.
A default site INSTALL.SKIP may be provided by setting then environment
variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a
distribution specific INSTALL.SKIP. If the environment variable
EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
performed.
If $skip is undefined then the skip file will be autodetected and used if it
is found. If $skip is a reference to an array then it is assumed the array
contains the list of patterns, if $skip is a true non reference it is
assumed to be the filename holding the list of patterns, any other value of
$skip is taken to mean that no install filtering should occur.
B<Changes As of Version 1.47>
As of version 1.47 the following additions were made to the install interface.
Note that the new argument style and use of the %result hash is recommended.
The $always_copy parameter which when true causes files to be updated
regardless as to whether they have changed, if it is defined but false then
copies are made only if the files have changed, if it is undefined then the
value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default.
The %result hash will be populated with the various keys/subhashes reflecting
the install. Currently these keys and their structure are:
install => { $target => $source },
install_fail => { $target => $source },
install_unchanged => { $target => $source },
install_filtered => { $source => $pattern },
uninstall => { $uninstalled => $source },
uninstall_fail => { $uninstalled => $source },
where C<$source> is the filespec of the file being installed. C<$target> is where
it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC>
or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that
caused a source file to be skipped. In future more keys will be added, such as to
show created directories, however this requires changes in other modules and must
therefore wait.
These keys will be populated before any exceptions are thrown should there be an
error.
Note that all updates of the %result are additive, the hash will not be
cleared before use, thus allowing status results of many installs to be easily
aggregated.
B<NEW ARGUMENT STYLE>
If there is only one argument and it is a reference to an array then
the array is assumed to contain a list of key-value pairs specifying
the options. In this case the option "from_to" is mandatory. This style
means that you do not have to supply a cryptic list of arguments and can
use a self documenting argument list that is easier to understand.
This is now the recommended interface to install().
B<RETURN>
If all actions were successful install will return a hashref of the results
as described above for the $result parameter. If any action is a failure
then install will die, therefore it is recommended to pass in the $result
parameter instead of using the return value. If the result parameter is
provided then the returned hashref will be the passed in hashref.
=cut
sub install { #XXX OS-SPECIFIC
my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_;
if (@_==1 and eval { 1+@$from_to }) {
my %opts = @$from_to;
$from_to = $opts{from_to}
or Carp::confess("from_to is a mandatory parameter");
$verbose = $opts{verbose};
$dry_run = $opts{dry_run};
$uninstall_shadows = $opts{uninstall_shadows};
$skip = $opts{skip};
$always_copy = $opts{always_copy};
$result = $opts{result};
}
$result ||= {};
$verbose ||= 0;
$dry_run ||= 0;
$skip= _get_install_skip($skip,$verbose);
$always_copy = $ENV{EU_INSTALL_ALWAYS_COPY}
|| $ENV{EU_ALWAYS_COPY}
|| 0
unless defined $always_copy;
my(%from_to) = %$from_to;
my(%pack, $dir, %warned);
my($packlist) = ExtUtils::Packlist->new();
local(*DIR);
for (qw/read write/) {
$pack{$_}=$from_to{$_};
delete $from_to{$_};
}
my $tmpfile = install_rooted_file($pack{"read"});
$packlist->read($tmpfile) if (-f $tmpfile);
my $cwd = cwd();
my @found_files;
my %check_dirs;
MOD_INSTALL: foreach my $source (sort keys %from_to) {
#copy the tree to the target directory without altering
#timestamp and permission and remember for the .packlist
#file. The packlist file contains the absolute paths of the
#install locations. AFS users may call this a bug. We'll have
#to reconsider how to add the means to satisfy AFS users also.
#October 1997: we want to install .pm files into archlib if
#there are any files in arch. So we depend on having ./blib/arch
#hardcoded here.
my $targetroot = install_rooted_dir($from_to{$source});
my $blib_lib = File::Spec->catdir('blib', 'lib');
my $blib_arch = File::Spec->catdir('blib', 'arch');
if ($source eq $blib_lib and
exists $from_to{$blib_arch} and
directory_not_empty($blib_arch)
){
$targetroot = install_rooted_dir($from_to{$blib_arch});
print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
}
next unless -d $source;
_chdir($source);
# 5.5.3's File::Find missing no_chdir option
# XXX OS-SPECIFIC
# File::Find seems to always be Unixy except on MacPerl :(
my $current_directory= $Is_MacPerl ? $Curdir : '.';
find(sub {
my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
return if !-f _;
my $origfile = $_;
return if $origfile eq ".exists";
my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
my $targetfile = File::Spec->catfile($targetdir, $origfile);
my $sourcedir = File::Spec->catdir($source, $File::Find::dir);
my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
for my $pat (@$skip) {
if ( $sourcefile=~/$pat/ ) {
print "Skipping $targetfile (filtered)\n"
if $verbose>1;
$result->{install_filtered}{$sourcefile} = $pat;
return;
}
}
# we have to do this for back compat with old File::Finds
# and because the target is relative
my $save_cwd = _chdir($cwd);
my $diff = 0;
# XXX: I wonder how useful this logic is actually -- demerphq
if ( $always_copy or !-f $targetfile or -s $targetfile != $size) {
$diff++;
} else {
# we might not need to copy this file
$diff = compare($sourcefile, $targetfile);
}
$check_dirs{$targetdir}++
unless -w $targetfile;
push @found_files,
[ $diff, $File::Find::dir, $origfile,
$mode, $size, $atime, $mtime,
$targetdir, $targetfile, $sourcedir, $sourcefile,
];
#restore the original directory we were in when File::Find
#called us so that it doesn't get horribly confused.
_chdir($save_cwd);
}, $current_directory );
_chdir($cwd);
}
foreach my $targetdir (sort keys %check_dirs) {
_mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
}
foreach my $found (@found_files) {
my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
$targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;
my $realtarget= $targetfile;
if ($diff) {
eval {
if (-f $targetfile) {
print "_unlink_or_rename($targetfile)\n" if $verbose>1;
$targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
unless $dry_run;
} elsif ( ! -d $targetdir ) {
_mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
}
print "Installing $targetfile\n";
_copy( $sourcefile, $targetfile, $verbose, $dry_run, );
#XXX OS-SPECIFIC
print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1;
$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
$mode = $mode | 0222
if $realtarget ne $targetfile;
_chmod( $mode, $targetfile, $verbose );
$result->{install}{$targetfile} = $sourcefile;
1
} or do {
$result->{install_fail}{$targetfile} = $sourcefile;
die $@;
};
} else {
$result->{install_unchanged}{$targetfile} = $sourcefile;
print "Skipping $targetfile (unchanged)\n" if $verbose;
}
if ( $uninstall_shadows ) {
inc_uninstall($sourcefile,$ffd, $verbose,
$dry_run,
$realtarget ne $targetfile ? $realtarget : "",
$result);
}
# Record the full pathname.
$packlist->{$targetfile}++;
}
if ($pack{'write'}) {
$dir = install_rooted_dir(dirname($pack{'write'}));
_mkpath( $dir, 0, 0755, $verbose, $dry_run );
print "Writing $pack{'write'}\n" if $verbose;
$packlist->write(install_rooted_file($pack{'write'})) unless $dry_run;
}
_do_cleanup($verbose);
return $result;
}
=begin _private
=item _do_cleanup
Standardize finish event for after another instruction has occurred.
Handles converting $MUST_REBOOT to a die for instance.
=end _private
=cut
sub _do_cleanup {
my ($verbose) = @_;
if ($MUST_REBOOT) {
die _estr "Operation not completed! ",
"You must reboot to complete the installation.",
"Sorry.";
} elsif (defined $MUST_REBOOT & $verbose) {
warn _estr "Installation will be completed at the next reboot.\n",
"However it is not necessary to reboot immediately.\n";
}
}
=begin _undocumented
=item install_rooted_file( $file )
Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
is defined.
=item install_rooted_dir( $dir )
Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
is defined.
=end _undocumented
=cut
sub install_rooted_file {
if (defined $INSTALL_ROOT) {
File::Spec->catfile($INSTALL_ROOT, $_[0]);
} else {
$_[0];
}
}
sub install_rooted_dir {
if (defined $INSTALL_ROOT) {
File::Spec->catdir($INSTALL_ROOT, $_[0]);
} else {
$_[0];
}
}
=begin _undocumented
=item forceunlink( $file, $tryhard )
Tries to delete a file. If $tryhard is true then we will use whatever
devious tricks we can to delete the file. Currently this only applies to
Win32 in that it will try to use Win32API::File to schedule a delete at
reboot. A wrapper for _unlink_or_rename().
=end _undocumented
=cut
sub forceunlink {
my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
_unlink_or_rename( $file, $tryhard, not("installing") );
}
=begin _undocumented
=item directory_not_empty( $dir )
Returns 1 if there is an .exists file somewhere in a directory tree.
Returns 0 if there is not.
=end _undocumented
=cut
sub directory_not_empty ($) {
my($dir) = @_;
my $files = 0;
find(sub {
return if $_ eq ".exists";
if (-f) {
$File::Find::prune++;
$files = 1;
}
}, $dir);
return $files;
}
=pod
=item B<install_default> I<DISCOURAGED>
install_default();
install_default($fullext);
Calls install() with arguments to copy a module from blib/ to the
default site installation location.
$fullext is the name of the module converted to a directory
(ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it
will attempt to read it from @ARGV.
This is primarily useful for install scripts.
B<NOTE> This function is not really useful because of the hard-coded
install location with no way to control site vs core vs vendor
directories and the strange way in which the module name is given.
Consider its use discouraged.
=cut
sub install_default {
@_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
my $FULLEXT = @_ ? shift : $ARGV[0];
defined $FULLEXT or die "Do not know to where to write install log";
my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
my @INST_HTML;
if($Config{installhtmldir}) {
my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html');
@INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir});
}
install({
read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
$INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
$Config{installsitearch} :
$Config{installsitelib},
$INST_ARCHLIB => $Config{installsitearch},
$INST_BIN => $Config{installbin} ,
$INST_SCRIPT => $Config{installscript},
$INST_MAN1DIR => $Config{installman1dir},
$INST_MAN3DIR => $Config{installman3dir},
@INST_HTML,
},1,0,0);
}
=item B<uninstall>
uninstall($packlist_file);
uninstall($packlist_file, $verbose, $dont_execute);
Removes the files listed in a $packlist_file.
If $verbose is true, will print out each file removed. Default is
false.
If $dont_execute is true it will only print what it was going to do
without actually doing it. Default is false.
=cut
sub uninstall {
my($fil,$verbose,$dry_run) = @_;
$verbose ||= 0;
$dry_run ||= 0;
die _estr "ERROR: no packlist file found: '$fil'"
unless -f $fil;
# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
# require $my_req; # Hairy, but for the first
my ($packlist) = ExtUtils::Packlist->new($fil);
foreach (sort(keys(%$packlist))) {
chomp;
print "unlink $_\n" if $verbose;
forceunlink($_,'tryhard') unless $dry_run;
}
print "unlink $fil\n" if $verbose;
forceunlink($fil, 'tryhard') unless $dry_run;
_do_cleanup($verbose);
}
=begin _undocumented
=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results)
Remove shadowed files. If $ignore is true then it is assumed to hold
a filename to ignore. This is used to prevent spurious warnings from
occurring when doing an install at reboot.
We now only die when failing to remove a file that has precedence over
our own, when our install has precedence we only warn.
$results is assumed to contain a hashref which will have the keys
'uninstall' and 'uninstall_fail' populated with keys for the files
removed and values of the source files they would shadow.
=end _undocumented
=cut
sub inc_uninstall {
my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_;
my($dir);
$ignore||="";
my $file = (File::Spec->splitpath($filepath))[2];
my %seen_dir = ();
my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
my @dirs=( @PERL_ENV_LIB,
@INC,
@Config{qw(archlibexp
privlibexp
sitearchexp
sitelibexp)});
#warn join "\n","---",@dirs,"---";
my $seen_ours;
foreach $dir ( @dirs ) {
my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir);
next if $canonpath eq $Curdir;
next if $seen_dir{$canonpath}++;
my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
next unless -f $targetfile;
# The reason why we compare file's contents is, that we cannot
# know, which is the file we just installed (AFS). So we leave
# an identical file in place
my $diff = 0;
if ( -f $targetfile && -s _ == -s $filepath) {
# We have a good chance, we can skip this one
$diff = compare($filepath,$targetfile);
} else {
$diff++;
}
print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
if (!$diff or $targetfile eq $ignore) {
$seen_ours = 1;
next;
}
if ($dry_run) {
$results->{uninstall}{$targetfile} = $filepath;
if ($verbose) {
$Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
$libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
$Inc_uninstall_warn_handler->add(
File::Spec->catfile($libdir, $file),
$targetfile
);
}
# if not verbose, we just say nothing
} else {
print "Unlinking $targetfile (shadowing?)\n" if $verbose;
eval {
die "Fake die for testing"
if $ExtUtils::Install::Testing and
ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile);
forceunlink($targetfile,'tryhard');
$results->{uninstall}{$targetfile} = $filepath;
1;
} or do {
$results->{fail_uninstall}{$targetfile} = $filepath;
if ($seen_ours) {
warn "Failed to remove probably harmless shadow file '$targetfile'\n";
} else {
die "$@\n";
}
};
}
}
}
=begin _undocumented
=item run_filter($cmd,$src,$dest)
Filter $src using $cmd into $dest.
=end _undocumented
=cut
sub run_filter {
my ($cmd, $src, $dest) = @_;
local(*CMD, *SRC);
open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
open(SRC, $src) || die "Cannot open $src: $!";
my $buf;
my $sz = 1024;
while (my $len = sysread(SRC, $buf, $sz)) {
syswrite(CMD, $buf, $len);
}
close SRC;
close CMD or die "Filter command '$cmd' failed for $src";
}
=pod
=item B<pm_to_blib>
pm_to_blib(\%from_to);
pm_to_blib(\%from_to, $autosplit_dir);
pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
Copies each key of %from_to to its corresponding value efficiently.
If an $autosplit_dir is provided, all .pm files will be autosplit into it.
Any destination directories are created.
$filter_cmd is an optional shell command to run each .pm file through
prior to splitting and copying. Input is the contents of the module,
output the new module contents.
You can have an environment variable PERL_INSTALL_ROOT set which will
be prepended as a directory to each installed file (and directory).
By default verbose output is generated, setting the PERL_INSTALL_QUIET
environment variable will silence this output.
=cut
sub pm_to_blib {
my($fromto,$autodir,$pm_filter) = @_;
_mkpath($autodir,0,0755) if defined $autodir;
while(my($from, $to) = each %$fromto) {
if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
print "Skip $to (unchanged)\n" unless $INSTALL_QUIET;
next;
}
# When a pm_filter is defined, we need to pre-process the source first
# to determine whether it has changed or not. Therefore, only perform
# the comparison check when there's no filter to be ran.
# -- RAM, 03/01/2001
my $need_filtering = defined $pm_filter && length $pm_filter &&
$from =~ /\.pm$/;
if (!$need_filtering && 0 == compare($from,$to)) {
print "Skip $to (unchanged)\n" unless $INSTALL_QUIET;
next;
}
if (-f $to){
# we wont try hard here. its too likely to mess things up.
forceunlink($to);
} else {
_mkpath(dirname($to),0,0755);
}
if ($need_filtering) {
run_filter($pm_filter, $from, $to);
print "$pm_filter <$from >$to\n";
} else {
_copy( $from, $to );
print "cp $from $to\n" unless $INSTALL_QUIET;
}
my($mode,$atime,$mtime) = (stat $from)[2,8,9];
utime($atime,$mtime+$Is_VMS,$to);
_chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
next unless $from =~ /\.pm$/;
_autosplit($to,$autodir) if defined $autodir;
}
}
=begin _private
=item _autosplit
From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
the file being split. This causes problems on systems with mandatory
locking (ie. Windows). So we wrap it and close the filehandle.
=end _private
=cut
sub _autosplit { #XXX OS-SPECIFIC
my $retval = autosplit(@_);
close *AutoSplit::IN if defined *AutoSplit::IN{IO};
return $retval;
}
package ExtUtils::Install::Warn;
sub new { bless {}, shift }
sub add {
my($self,$file,$targetfile) = @_;
push @{$self->{$file}}, $targetfile;
}
sub DESTROY {
unless(defined $INSTALL_ROOT) {
my $self = shift;
my($file,$i,$plural);
foreach $file (sort keys %$self) {
$plural = @{$self->{$file}} > 1 ? "s" : "";
print "## Differing version$plural of $file found. You might like to\n";
for (0..$#{$self->{$file}}) {
print "rm ", $self->{$file}[$_], "\n";
$i++;
}
}
$plural = $i>1 ? "all those files" : "this file";
my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
? ( $Config::Config{make} || 'make' ).' install'
. ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' )
: './Build install uninst=1';
print "## Running '$inst' will unlink $plural for you.\n";
}
}
=begin _private
=item _invokant
Does a heuristic on the stack to see who called us for more intelligent
error messages. Currently assumes we will be called only by Module::Build
or by ExtUtils::MakeMaker.
=end _private
=cut
sub _invokant {
my @stack;
my $frame = 0;
while (my $file = (caller($frame++))[1]) {
push @stack, (File::Spec->splitpath($file))[2];
}
my $builder;
my $top = pop @stack;
if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
$builder = 'Module::Build';
} else {
$builder = 'ExtUtils::MakeMaker';
}
return $builder;
}
=pod
=back
=head1 ENVIRONMENT
=over 4
=item B<PERL_INSTALL_ROOT>
Will be prepended to each install path.
=item B<EU_INSTALL_IGNORE_SKIP>
Will prevent the automatic use of INSTALL.SKIP as the install skip file.
=item B<EU_INSTALL_SITE_SKIPFILE>
If there is no INSTALL.SKIP file in the make directory then this value
can be used to provide a default.
=item B<EU_INSTALL_ALWAYS_COPY>
If this environment variable is true then normal install processes will
always overwrite older identical files during the install process.
Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY
is not defined until at least the 1.50 release. Please ensure you use the
correct EU_INSTALL_ALWAYS_COPY.
=back
=head1 AUTHOR
Original author lost in the mists of time. Probably the same as Makemaker.
Production release currently maintained by demerphq C<yves at cpan.org>,
extensive changes by Michael G. Schwern.
Send bug reports via http://rt.cpan.org/. Please send your
generated Makefile along with your report.
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut
1;
EXTUTILS_INSTALL
$fatpacked{"ExtUtils/Installed.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALLED';
package ExtUtils::Installed;
use 5.00503;
use strict;
#use warnings; # XXX requires 5.6
use Carp qw();
use ExtUtils::Packlist;
use ExtUtils::MakeMaker;
use Config;
use File::Find;
use File::Basename;
use File::Spec;
my $Is_VMS = $^O eq 'VMS';
my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
require VMS::Filespec if $Is_VMS;
use vars qw($VERSION);
$VERSION = '2.06';
$VERSION = eval $VERSION;
sub _is_prefix {
my ($self, $path, $prefix) = @_;
return unless defined $prefix && defined $path;
if( $Is_VMS ) {
$prefix = VMS::Filespec::unixify($prefix);
$path = VMS::Filespec::unixify($path);
}
# Unix path normalization.
$prefix = File::Spec->canonpath($prefix);
return 1 if substr($path, 0, length($prefix)) eq $prefix;
if ($DOSISH) {
$path =~ s|\\|/|g;
$prefix =~ s|\\|/|g;
return 1 if $path =~ m{^\Q$prefix\E}i;
}
return(0);
}
sub _is_doc {
my ($self, $path) = @_;
my $man1dir = $self->{':private:'}{Config}{man1direxp};
my $man3dir = $self->{':private:'}{Config}{man3direxp};
return(($man1dir && $self->_is_prefix($path, $man1dir))
||
($man3dir && $self->_is_prefix($path, $man3dir))
? 1 : 0)
}
sub _is_type {
my ($self, $path, $type) = @_;
return 1 if $type eq "all";
return($self->_is_doc($path)) if $type eq "doc";
my $conf= $self->{':private:'}{Config};
if ($type eq "prog") {
return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
&& !($self->_is_doc($path)) ? 1 : 0);
}
return(0);
}
sub _is_under {
my ($self, $path, @under) = @_;
$under[0] = "" if (! @under);
foreach my $dir (@under) {
return(1) if ($self->_is_prefix($path, $dir));
}
return(0);
}
sub _fix_dirs {
my ($self, @dirs)= @_;
# File::Find does not know how to deal with VMS filepaths.
if( $Is_VMS ) {
$_ = VMS::Filespec::unixify($_)
for @dirs;
}
if ($DOSISH) {
s|\\|/|g for @dirs;
}
return wantarray ? @dirs : $dirs[0];
}
sub _make_entry {
my ($self, $module, $packlist_file, $modfile)= @_;
my $data= {
module => $module,
packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
packlist_file => $packlist_file,
};
if (!$modfile) {
$data->{version} = $self->{':private:'}{Config}{version};
} else {
$data->{modfile} = $modfile;
# Find the top-level module file in @INC
$data->{version} = '';
foreach my $dir (@{$self->{':private:'}{INC}}) {
my $p = File::Spec->catfile($dir, $modfile);
if (-r $p) {
$module = _module_name($p, $module) if $Is_VMS;
$data->{version} = MM->parse_version($p);
$data->{version_from} = $p;
$data->{packlist_valid} = exists $data->{packlist}{$p};
last;
}
}
}
$self->{$module}= $data;
}
our $INSTALLED;
sub new {
my ($class) = shift(@_);
$class = ref($class) || $class;
my %args = @_;
return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});
my $self = bless {}, $class;
$INSTALLED= $self if $args{default_set} || $args{default};
if ($args{config_override}) {
eval {
$self->{':private:'}{Config} = { %{$args{config_override}} };
} or Carp::croak(
"The 'config_override' parameter must be a hash reference."
);
}
else {
$self->{':private:'}{Config} = \%Config;
}
for my $tuple ([inc_override => INC => [ @INC ] ],
[ extra_libs => EXTRA => [] ])
{
my ($arg,$key,$val)=@$tuple;
if ( $args{$arg} ) {
eval {
$self->{':private:'}{$key} = [ @{$args{$arg}} ];
} or Carp::croak(
"The '$arg' parameter must be an array reference."
);
}
elsif ($val) {
$self->{':private:'}{$key} = $val;
}
}
{
my %dupe;
@{$self->{':private:'}{LIBDIRS}} =
grep { $_ ne '.' || ! $args{skip_cwd} }
grep { -e $_ && !$dupe{$_}++ }
@{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
}
my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});
# Read the core packlist
my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
$self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));
my $root;
# Read the module packlists
my $sub = sub {
# Only process module .packlists
return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
# Hack of the leading bits of the paths & convert to a module name
my $module = $File::Find::name;
my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
or do {
# warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
# join ("\n",@dirs);
return;
};
my $modfile = "$module.pm";
$module =~ s!/!::!g;
return if $self->{$module}; #shadowing?
$self->_make_entry($module,$File::Find::name,$modfile);
};
while (@dirs) {
$root= shift @dirs;
next if !-d $root;
find($sub,$root);
}
return $self;
}
# VMS's non-case preserving file-system means the package name can't
# be reconstructed from the filename.
sub _module_name {
my($file, $orig_module) = @_;
my $module = '';
if (open PACKFH, $file) {
while (<PACKFH>) {
if (/package\s+(\S+)\s*;/) {
my $pack = $1;
# Make a sanity check, that lower case $module
# is identical to lowercase $pack before
# accepting it
if (lc($pack) eq lc($orig_module)) {
$module = $pack;
last;
}
}
}
close PACKFH;
}
print STDERR "Couldn't figure out the package name for $file\n"
unless $module;
return $module;
}
sub modules {
my ($self) = @_;
$self= $self->new(default=>1) if !ref $self;
# Bug/feature of sort in scalar context requires this.
return wantarray
? sort grep { not /^:private:$/ } keys %$self
: grep { not /^:private:$/ } keys %$self;
}
sub files {
my ($self, $module, $type, @under) = @_;
$self= $self->new(default=>1) if !ref $self;
# Validate arguments
Carp::croak("$module is not installed") if (! exists($self->{$module}));
$type = "all" if (! defined($type));
Carp::croak('type must be "all", "prog" or "doc"')
if ($type ne "all" && $type ne "prog" && $type ne "doc");
my (@files);
foreach my $file (keys(%{$self->{$module}{packlist}})) {
push(@files, $file)
if ($self->_is_type($file, $type) &&
$self->_is_under($file, @under));
}
return(@files);
}
sub directories {
my ($self, $module, $type, @under) = @_;
$self= $self->new(default=>1) if !ref $self;
my (%dirs);
foreach my $file ($self->files($module, $type, @under)) {
$dirs{dirname($file)}++;
}
return sort keys %dirs;
}
sub directory_tree {
my ($self, $module, $type, @under) = @_;
$self= $self->new(default=>1) if !ref $self;
my (%dirs);
foreach my $dir ($self->directories($module, $type, @under)) {
$dirs{$dir}++;
my ($last) = ("");
while ($last ne $dir) {
$last = $dir;
$dir = dirname($dir);
last if !$self->_is_under($dir, @under);
$dirs{$dir}++;
}
}
return(sort(keys(%dirs)));
}
sub validate {
my ($self, $module, $remove) = @_;
$self= $self->new(default=>1) if !ref $self;
Carp::croak("$module is not installed") if (! exists($self->{$module}));
return($self->{$module}{packlist}->validate($remove));
}
sub packlist {
my ($self, $module) = @_;
$self= $self->new(default=>1) if !ref $self;
Carp::croak("$module is not installed") if (! exists($self->{$module}));
return($self->{$module}{packlist});
}
sub version {
my ($self, $module) = @_;
$self= $self->new(default=>1) if !ref $self;
Carp::croak("$module is not installed") if (! exists($self->{$module}));
return($self->{$module}{version});
}
sub debug_dump {
my ($self, $module) = @_;
$self= $self->new(default=>1) if !ref $self;
local $self->{":private:"}{Config};
require Data::Dumper;
print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
}
1;
__END__
=head1 NAME
ExtUtils::Installed - Inventory management of installed modules
=head1 SYNOPSIS
use ExtUtils::Installed;
my ($inst) = ExtUtils::Installed->new( skip_cwd => 1 );
my (@modules) = $inst->modules();
my (@missing) = $inst->validate("DBI");
my $all_files = $inst->files("DBI");
my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
my $all_dirs = $inst->directories("DBI");
my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
my $packlist = $inst->packlist("DBI");
=head1 DESCRIPTION
ExtUtils::Installed provides a standard way to find out what core and module
files have been installed. It uses the information stored in .packlist files
created during installation to provide this information. In addition it
provides facilities to classify the installed files and to extract directory
information from the .packlist files.
=head1 USAGE
The new() function searches for all the installed .packlists on the system, and
stores their contents. The .packlists can be queried with the functions
described below. Where it searches by default is determined by the settings found
in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
=head1 METHODS
Unless specified otherwise all method can be called as class methods, or as object
methods. If called as class methods then the "default" object will be used, and if
necessary created using the current processes %Config and @INC. See the
'default' option to new() for details.
=over 4
=item new()
This takes optional named parameters. Without parameters, this
searches for all the installed .packlists on the system using
information from C<%Config::Config> and the default module search
paths C<@INC>. The packlists are read using the
L<ExtUtils::Packlist> module.
If the named parameter C<skip_cwd> is true, the current directory C<.> will
be stripped from C<@INC> before searching for .packlists. This keeps
ExtUtils::Installed from finding modules installed in other perls that
happen to be located below the current directory.
If the named parameter C<config_override> is specified,
it should be a reference to a hash which contains all information
usually found in C<%Config::Config>. For example, you can obtain
the configuration information for a separate perl installation and
pass that in.
my $yoda_cfg = get_fake_config('yoda');
my $yoda_inst =
ExtUtils::Installed->new(config_override=>$yoda_cfg);
Similarly, the parameter C<inc_override> may be a reference to an
array which is used in place of the default module search paths
from C<@INC>.
use Config;
my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
B<Note>: You probably do not want to use these options alone, almost always
you will want to set both together.
The parameter C<extra_libs> can be used to specify B<additional> paths to
search for installed modules. For instance
my $installed =
ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
This should only be necessary if F</my/lib/path> is not in PERL5LIB.
Finally there is the 'default', and the related 'default_get' and 'default_set'
options. These options control the "default" object which is provided by the
class interface to the methods. Setting C<default_get> to true tells the constructor
to return the default object if it is defined. Setting C<default_set> to true tells
the constructor to make the default object the constructed object. Setting the
C<default> option is like setting both to true. This is used primarily internally
and probably isn't interesting to any real user.
=item modules()
This returns a list of the names of all the installed modules. The perl 'core'
is given the special name 'Perl'.
=item files()
This takes one mandatory parameter, the name of a module. It returns a list of
all the filenames from the package. To obtain a list of core perl files, use
the module name 'Perl'. Additional parameters are allowed. The first is one
of the strings "prog", "doc" or "all", to select either just program files,
just manual files or all files. The remaining parameters are a list of
directories. The filenames returned will be restricted to those under the
specified directories.
=item directories()
This takes one mandatory parameter, the name of a module. It returns a list of
all the directories from the package. Additional parameters are allowed. The
first is one of the strings "prog", "doc" or "all", to select either just
program directories, just manual directories or all directories. The remaining
parameters are a list of directories. The directories returned will be
restricted to those under the specified directories. This method returns only
the leaf directories that contain files from the specified module.
=item directory_tree()
This is identical in operation to directories(), except that it includes all the
intermediate directories back up to the specified directories.
=item validate()
This takes one mandatory parameter, the name of a module. It checks that all
the files listed in the modules .packlist actually exist, and returns a list of
any missing files. If an optional second argument which evaluates to true is
given any missing files will be removed from the .packlist
=item packlist()
This returns the ExtUtils::Packlist object for the specified module.
=item version()
This returns the version number for the specified module.
=back
=head1 EXAMPLE
See the example in L<ExtUtils::Packlist>.
=head1 AUTHOR
Alan Burlison <[email protected]>
=cut
EXTUTILS_INSTALLED
$fatpacked{"ExtUtils/Liblist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_LIBLIST';
package ExtUtils::Liblist;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
use File::Spec;
require ExtUtils::Liblist::Kid;
our @ISA = qw(ExtUtils::Liblist::Kid File::Spec);
# Backwards compatibility with old interface.
sub ext {
goto &ExtUtils::Liblist::Kid::ext;
}
sub lsdir {
shift;
my $rex = qr/$_[1]/;
opendir my $dir_fh, $_[0];
my @out = grep /$rex/, readdir $dir_fh;
closedir $dir_fh;
return @out;
}
__END__
=head1 NAME
ExtUtils::Liblist - determine libraries to use and how to use them
=head1 SYNOPSIS
require ExtUtils::Liblist;
$MM->ext($potential_libs, $verbose, $need_names);
# Usually you can get away with:
ExtUtils::Liblist->ext($potential_libs, $verbose, $need_names)
=head1 DESCRIPTION
This utility takes a list of libraries in the form C<-llib1 -llib2
-llib3> and returns lines suitable for inclusion in an extension
Makefile. Extra library paths may be included with the form
C<-L/another/path> this will affect the searches for all subsequent
libraries.
It returns an array of four or five scalar values: EXTRALIBS,
BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to
the array of the filenames of actual libraries. Some of these don't
mean anything unless on Unix. See the details about those platform
specifics below. The list of the filenames is returned only if
$need_names argument is true.
Dependent libraries can be linked in one of three ways:
=over 2
=item * For static extensions
by the ld command when the perl binary is linked with the extension
library. See EXTRALIBS below.
=item * For dynamic extensions at build/link time
by the ld command when the shared object is built/linked. See
LDLOADLIBS below.
=item * For dynamic extensions at load time
by the DynaLoader when the shared object is loaded. See BSLOADLIBS
below.
=back
=head2 EXTRALIBS
List of libraries that need to be linked with when linking a perl
binary which includes this extension. Only those libraries that
actually exist are included. These are written to a file and used
when linking perl.
=head2 LDLOADLIBS and LD_RUN_PATH
List of those libraries which can or must be linked into the shared
library when created using ld. These may be static or dynamic
libraries. LD_RUN_PATH is a colon separated list of the directories
in LDLOADLIBS. It is passed as an environment variable to the process
that links the shared library.
=head2 BSLOADLIBS
List of those libraries that are needed but can be linked in
dynamically at run time on this platform. SunOS/Solaris does not need
this because ld records the information (from LDLOADLIBS) into the
object file. This list is used to create a .bs (bootstrap) file.
=head1 PORTABILITY
This module deals with a lot of system dependencies and has quite a
few architecture specific C<if>s in the code.
=head2 VMS implementation
The version of ext() which is executed under VMS differs from the
Unix-OS/2 version in several respects:
=over 2
=item *
Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is
present, a token is considered a directory to search if it is in fact
a directory, and a library to search for otherwise. Authors who wish
their extensions to be portable to Unix or OS/2 should use the Unix
prefixes, since the Unix-OS/2 version of ext() requires them.
=item *
Wherever possible, shareable images are preferred to object libraries,
and object libraries to plain object files. In accordance with VMS
naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl;
it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions
used in some ported software.
=item *
For each library that is found, an appropriate directive for a linker options
file is generated. The return values are space-separated strings of
these directives, rather than elements used on the linker command line.
=item *
LDLOADLIBS contains both the libraries found based on C<$potential_libs> and
the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those
libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH
are always empty.
=back
In addition, an attempt is made to recognize several common Unix library
names, and filter them out or convert them to their VMS equivalents, as
appropriate.
In general, the VMS version of ext() should properly handle input from
extensions originally designed for a Unix or VMS environment. If you
encounter problems, or discover cases where the search could be improved,
please let us know.
=head2 Win32 implementation
The version of ext() which is executed under Win32 differs from the
Unix-OS/2 version in several respects:
=over 2
=item *
If C<$potential_libs> is empty, the return value will be empty.
Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
will be appended to the list of C<$potential_libs>. The libraries
will be searched for in the directories specified in C<$potential_libs>,
C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
For each library that is found, a space-separated list of fully qualified
library pathnames is generated.
=item *
Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefixes used by Unix linkers.
An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look
for the libraries that follow.
An entry of the form C<-lfoo> specifies the library C<foo>, which may be
spelled differently depending on what kind of compiler you are using. If
you are using GCC, it gets translated to C<libfoo.a>, but for other win32
compilers, it becomes C<foo.lib>. If no files are found by those translated
names, one more attempt is made to find them using either C<foo.a> or
C<libfoo.lib>, depending on whether GCC or some other win32 compiler is
being used, respectively.
If neither the C<-L> or C<-l> prefix is present in an entry, the entry is
considered a directory to search if it is in fact a directory, and a
library to search for otherwise. The C<$Config{lib_ext}> suffix will
be appended to any entries that are not directories and don't already have
the suffix.
Note that the C<-L> and C<-l> prefixes are B<not required>, but authors
who wish their extensions to be portable to Unix or OS/2 should use the
prefixes, since the Unix-OS/2 version of ext() requires them.
=item *
Entries cannot be plain object files, as many Win32 compilers will
not handle object files in the place of libraries.
=item *
Entries in C<$potential_libs> beginning with a colon and followed by
alphanumeric characters are treated as flags. Unknown flags will be ignored.
An entry that matches C</:nodefault/i> disables the appending of default
libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
An entry that matches C</:nosearch/i> disables all searching for
the libraries specified after it. Translation of C<-Lfoo> and
C<-lfoo> still happens as appropriate (depending on compiler being used,
as reflected by C<$Config{cc}>), but the entries are not verified to be
valid files or directories.
An entry that matches C</:search/i> reenables searching for
the libraries specified after it. You can put it at the end to
enable searching for default libraries specified by C<$Config{perllibs}>.
=item *
The libraries specified may be a mixture of static libraries and
import libraries (to link with DLLs). Since both kinds are used
pretty transparently on the Win32 platform, we do not attempt to
distinguish between them.
=item *
LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS
and LD_RUN_PATH are always empty (this may change in future).
=item *
You must make sure that any paths and path components are properly
surrounded with double-quotes if they contain spaces. For example,
C<$potential_libs> could be (literally):
"-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib"
Note how the first and last entries are protected by quotes in order
to protect the spaces.
=item *
Since this module is most often used only indirectly from extension
C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add
a library to the build process for an extension:
LIBS => ['-lgl']
When using GCC, that entry specifies that MakeMaker should first look
for C<libgl.a> (followed by C<gl.a>) in all the locations specified by
C<$Config{libpth}>.
When using a compiler other than GCC, the above entry will search for
C<gl.lib> (followed by C<libgl.lib>).
If the library happens to be in a location not in C<$Config{libpth}>,
you need:
LIBS => ['-Lc:\gllibs -lgl']
Here is a less often used example:
LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32']
This specifies a search for library C<gl> as before. If that search
fails to find the library, it looks at the next item in the list. The
C<:nosearch> flag will prevent searching for the libraries that follow,
so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>,
since GCC can use that value as is with its linker.
When using the Visual C compiler, the second item is returned as
C<-libpath:d:\mesalibs mesa.lib user32.lib>.
When using the Borland compiler, the second item is returned as
C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of
moving the C<-Ld:\mesalibs> to the correct place in the linker
command line.
=back
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
EXTUTILS_LIBLIST
$fatpacked{"ExtUtils/Liblist/Kid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_LIBLIST_KID';
package ExtUtils::Liblist::Kid;
# XXX Splitting this out into its own .pm is a temporary solution.
# This kid package is to be used by MakeMaker. It will not work if
# $self is not a Makemaker.
use 5.006;
# Broken out of MakeMaker from version 4.11
use strict;
use warnings;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
use ExtUtils::MakeMaker::Config;
use Cwd 'cwd';
use File::Basename;
use File::Spec;
sub ext {
if ( $^O eq 'VMS' ) { return &_vms_ext; }
elsif ( $^O eq 'MSWin32' ) { return &_win32_ext; }
else { return &_unix_os2_ext; }
}
sub _unix_os2_ext {
my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
$verbose ||= 0;
if ( $^O =~ /os2|android/ and $Config{perllibs} ) {
# Dynamic libraries are not transitive, so we may need including
# the libraries linked against perl.dll/libperl.so again.
$potential_libs .= " " if $potential_libs;
$potential_libs .= $Config{perllibs};
}
return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs;
warn "Potential libraries are '$potential_libs':\n" if $verbose;
my ( $so ) = $Config{so};
my ( $libs ) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs};
my $Config_libext = $Config{lib_ext} || ".a";
my $Config_dlext = $Config{dlext};
# compute $extralibs, $bsloadlibs and $ldloadlibs from
# $potential_libs
# this is a rewrite of Andy Dougherty's extliblist in perl
my ( @searchpath ); # from "-L/path" entries in $potential_libs
my ( @libpath ) = split " ", $Config{'libpth'} || '';
my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen );
my ( @libs, %libs_seen );
my ( $fullname, @fullname );
my ( $pwd ) = cwd(); # from Cwd.pm
my ( $found ) = 0;
if ( $^O eq 'darwin' or $^O eq 'next' ) {
# 'escape' Mach-O ld -framework and -F flags, so they aren't dropped later on
$potential_libs =~ s/(^|\s)(-(?:weak_|reexport_|lazy_)?framework)\s+(\S+)/$1-Wl,$2 -Wl,$3/g;
$potential_libs =~ s/(^|\s)(-F)\s*(\S+)/$1-Wl,$2 -Wl,$3/g;
}
foreach my $thislib ( split ' ', $potential_libs ) {
my ( $custom_name ) = '';
# Handle possible linker path arguments.
if ( $thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)// ) { # save path flag type
my ( $ptype ) = $1;
unless ( -d $thislib ) {
warn "$ptype$thislib ignored, directory does not exist\n"
if $verbose;
next;
}
my ( $rtype ) = $ptype;
if ( ( $ptype eq '-R' ) or ( $ptype =~ m!^-Wl,-[Rr]! ) ) {
if ( $Config{'lddlflags'} =~ /-Wl,-[Rr]/ ) {
$rtype = '-Wl,-R';
}
elsif ( $Config{'lddlflags'} =~ /-R/ ) {
$rtype = '-R';
}
}
unless ( File::Spec->file_name_is_absolute( $thislib ) ) {
warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
$thislib = $self->catdir( $pwd, $thislib );
}
push( @searchpath, $thislib );
push( @extralibs, "$ptype$thislib" );
push( @ldloadlibs, "$rtype$thislib" );
next;
}
if ( $thislib =~ m!^-Wl,! ) {
push( @extralibs, $thislib );
push( @ldloadlibs, $thislib );
next;
}
# Handle possible library arguments.
if ( $thislib =~ s/^-l(:)?// ) {
# Handle -l:foo.so, which means that the library will
# actually be called foo.so, not libfoo.so. This
# is used in Android by ExtUtils::Depends to allow one XS
# module to link to another.
$custom_name = $1 || '';
}
else {
warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
next;
}
my ( $found_lib ) = 0;
foreach my $thispth ( @searchpath, @libpath ) {
# Try to find the full name of the library. We need this to
# determine whether it's a dynamically-loadable library or not.
# This tends to be subject to various os-specific quirks.
# For gcc-2.6.2 on linux (March 1995), DLD can not load
# .sa libraries, with the exception of libm.sa, so we
# deliberately skip them.
if ((@fullname =
$self->lsdir($thispth, "^\Qlib$thislib.$so.\E[0-9]+")) ||
(@fullname =
$self->lsdir($thispth, "^\Qlib$thislib.\E[0-9]+\Q\.$so"))) {
# Take care that libfoo.so.10 wins against libfoo.so.9.
# Compare two libraries to find the most recent version
# number. E.g. if you have libfoo.so.9.0.7 and
# libfoo.so.10.1, first convert all digits into two
# decimal places. Then we'll add ".00" to the shorter
# strings so that we're comparing strings of equal length
# Thus we'll compare libfoo.so.09.07.00 with
# libfoo.so.10.01.00. Some libraries might have letters
# in the version. We don't know what they mean, but will
# try to skip them gracefully -- we'll set any letter to
# '0'. Finally, sort in reverse so we can take the
# first element.
#TODO: iterate through the directory instead of sorting
$fullname = "$thispth/" . (
sort {
my ( $ma ) = $a;
my ( $mb ) = $b;
$ma =~ tr/A-Za-z/0/s;
$ma =~ s/\b(\d)\b/0$1/g;
$mb =~ tr/A-Za-z/0/s;
$mb =~ s/\b(\d)\b/0$1/g;
while ( length( $ma ) < length( $mb ) ) { $ma .= ".00"; }
while ( length( $mb ) < length( $ma ) ) { $mb .= ".00"; }
# Comparison deliberately backwards
$mb cmp $ma;
} @fullname
)[0];
}
elsif ( -f ( $fullname = "$thispth/lib$thislib.$so" )
&& ( ( $Config{'dlsrc'} ne "dl_dld.xs" ) || ( $thislib eq "m" ) ) )
{
}
elsif (-f ( $fullname = "$thispth/lib${thislib}_s$Config_libext" )
&& ( $Config{'archname'} !~ /RM\d\d\d-svr4/ )
&& ( $thislib .= "_s" ) )
{ # we must explicitly use _s version
}
elsif ( -f ( $fullname = "$thispth/lib$thislib$Config_libext" ) ) {
}
elsif ( defined( $Config_dlext )
&& -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) )
{
}
elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) {
}
elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) {
}
elsif ( $^O eq 'cygwin' && -f ( $fullname = "$thispth/$thislib.dll" ) ) {
}
elsif ( -f ( $fullname = "$thispth/Slib$thislib$Config_libext" ) ) {
}
elsif ($^O eq 'dgux'
&& -l ( $fullname = "$thispth/lib$thislib$Config_libext" )
&& readlink( $fullname ) =~ /^elink:/s )
{
# Some of DG's libraries look like misconnected symbolic
# links, but development tools can follow them. (They
# look like this:
#
# libm.a -> elink:${SDE_PATH:-/usr}/sde/\
# ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a
#
# , the compilation tools expand the environment variables.)
}
elsif ( $custom_name && -f ( $fullname = "$thispth/$thislib" ) ) {
}
else {
warn "$thislib not found in $thispth\n" if $verbose;
next;
}
warn "'-l$thislib' found at $fullname\n" if $verbose;
push @libs, $fullname unless $libs_seen{$fullname}++;
$found++;
$found_lib++;
# Now update library lists
# what do we know about this library...
my $is_dyna = ( $fullname !~ /\Q$Config_libext\E\z/ );
my $in_perl = ( $libs =~ /\B-l:?\Q${thislib}\E\b/s );
# include the path to the lib once in the dynamic linker path
# but only if it is a dynamic lib and not in Perl itself
my ( $fullnamedir ) = dirname( $fullname );
push @ld_run_path, $fullnamedir
if $is_dyna
&& !$in_perl
&& !$ld_run_path_seen{$fullnamedir}++;
# Do not add it into the list if it is already linked in
# with the main perl executable.
# We have to special-case the NeXT, because math and ndbm
# are both in libsys_s
unless (
$in_perl
|| ( $Config{'osname'} eq 'next'
&& ( $thislib eq 'm' || $thislib eq 'ndbm' ) )
)
{
push( @extralibs, "-l$custom_name$thislib" );
}
# We might be able to load this archive file dynamically
if ( ( $Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0' )
|| ( $Config{'dlsrc'} =~ /dl_dld/ ) )
{
# We push -l$thislib instead of $fullname because
# it avoids hardwiring a fixed path into the .bs file.
# Mkbootstrap will automatically add dl_findfile() to
# the .bs file if it sees a name in the -l format.
# USE THIS, when dl_findfile() is fixed:
# push(@bsloadlibs, "-l$thislib");
# OLD USE WAS while checking results against old_extliblist
push( @bsloadlibs, "$fullname" );
}
else {
if ( $is_dyna ) {
# For SunOS4, do not add in this shared library if
# it is already linked in the main perl executable
push( @ldloadlibs, "-l$custom_name$thislib" )
unless ( $in_perl and $^O eq 'sunos' );
}
else {
push( @ldloadlibs, "-l$custom_name$thislib" );
}
}
last; # found one here so don't bother looking further
}
warn "Warning (mostly harmless): " . "No library found for -l$thislib\n"
unless $found_lib > 0;
}
unless ( $found ) {
return ( '', '', '', '', ( $give_libs ? \@libs : () ) );
}
else {
return ( "@extralibs", "@bsloadlibs", "@ldloadlibs", join( ":", @ld_run_path ), ( $give_libs ? \@libs : () ) );
}
}
sub _win32_ext {
require Text::ParseWords;
my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
$verbose ||= 0;
# If user did not supply a list, we punt.
# (caller should probably use the list in $Config{libs})
return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs;
# TODO: make this use MM_Win32.pm's compiler detection
my %libs_seen;
my @extralibs;
my $cc = $Config{cc} || '';
my $VC = $cc =~ /\bcl\b/i;
my $GC = $cc =~ /\bgcc\b/i;
my $libext = _win32_lib_extensions();
my @searchpath = ( '' ); # from "-L/path" entries in $potential_libs
my @libpath = _win32_default_search_paths( $VC, $GC );
my $pwd = cwd(); # from Cwd.pm
my $search = 1;
# compute @extralibs from $potential_libs
my @lib_search_list = _win32_make_lib_search_list( $potential_libs, $verbose );
for ( @lib_search_list ) {
my $thislib = $_;
# see if entry is a flag
if ( /^:\w+$/ ) {
$search = 0 if lc eq ':nosearch';
$search = 1 if lc eq ':search';
_debug( "Ignoring unknown flag '$thislib'\n", $verbose ) if !/^:(no)?(search|default)$/i;
next;
}
# if searching is disabled, do compiler-specific translations
unless ( $search ) {
s/^-l(.+)$/$1.lib/ unless $GC;
s/^-L/-libpath:/ if $VC;
push( @extralibs, $_ );
next;
}
# handle possible linker path arguments
if ( s/^-L// and not -d ) {
_debug( "$thislib ignored, directory does not exist\n", $verbose );
next;
}
elsif ( -d ) {
unless ( File::Spec->file_name_is_absolute( $_ ) ) {
warn "Warning: '$thislib' changed to '-L$pwd/$_'\n";
$_ = $self->catdir( $pwd, $_ );
}
push( @searchpath, $_ );
next;
}
my @paths = ( @searchpath, @libpath );
my ( $fullname, $path ) = _win32_search_file( $thislib, $libext, \@paths, $verbose, $GC );
if ( !$fullname ) {
warn "Warning (mostly harmless): No library found for $thislib\n";
next;
}
_debug( "'$thislib' found as '$fullname'\n", $verbose );
push( @extralibs, $fullname );
$libs_seen{$fullname} = 1 if $path; # why is this a special case?
}
my @libs = sort keys %libs_seen;
return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs;
# make sure paths with spaces are properly quoted
@extralibs = map { qq["$_"] } @extralibs;
@libs = map { qq["$_"] } @libs;
my $lib = join( ' ', @extralibs );
# normalize back to backward slashes (to help braindead tools)
# XXX this may break equally braindead GNU tools that don't understand
# backslashes, either. Seems like one can't win here. Cursed be CP/M.
$lib =~ s,/,\\,g;
_debug( "Result: $lib\n", $verbose );
wantarray ? ( $lib, '', $lib, '', ( $give_libs ? \@libs : () ) ) : $lib;
}
sub _win32_make_lib_search_list {
my ( $potential_libs, $verbose ) = @_;
# If Config.pm defines a set of default libs, we always
# tack them on to the user-supplied list, unless the user
# specified :nodefault
my $libs = $Config{'perllibs'};
$potential_libs = join( ' ', $potential_libs, $libs ) if $libs and $potential_libs !~ /:nodefault/i;
_debug( "Potential libraries are '$potential_libs':\n", $verbose );
$potential_libs =~ s,\\,/,g; # normalize to forward slashes
my @list = Text::ParseWords::quotewords( '\s+', 0, $potential_libs );
return @list;
}
sub _win32_default_search_paths {
my ( $VC, $GC ) = @_;
my $libpth = $Config{'libpth'} || '';
$libpth =~ s,\\,/,g; # normalize to forward slashes
my @libpath = Text::ParseWords::quotewords( '\s+', 0, $libpth );
push @libpath, "$Config{installarchlib}/CORE"; # add "$Config{installarchlib}/CORE" to default search path
push @libpath, split /;/, $ENV{LIB} if $VC and $ENV{LIB};
push @libpath, split /;/, $ENV{LIBRARY_PATH} if $GC and $ENV{LIBRARY_PATH};
return @libpath;
}
sub _win32_search_file {
my ( $thislib, $libext, $paths, $verbose, $GC ) = @_;
my @file_list = _win32_build_file_list( $thislib, $GC, $libext );
for my $lib_file ( @file_list ) {
for my $path ( @{$paths} ) {
my $fullname = $lib_file;
$fullname = "$path\\$fullname" if $path;
return ( $fullname, $path ) if -f $fullname;
_debug( "'$thislib' not found as '$fullname'\n", $verbose );
}
}
return;
}
sub _win32_build_file_list {
my ( $lib, $GC, $extensions ) = @_;
my @pre_fixed = _win32_build_prefixed_list( $lib, $GC );
return map _win32_attach_extensions( $_, $extensions ), @pre_fixed;
}
sub _win32_build_prefixed_list {
my ( $lib, $GC ) = @_;
return $lib if $lib !~ s/^-l//;
return $lib if $lib =~ /^lib/ and !$GC;
( my $no_prefix = $lib ) =~ s/^lib//i;
$lib = "lib$lib" if $no_prefix eq $lib;
return ( $lib, $no_prefix ) if $GC;
return ( $no_prefix, $lib );
}
sub _win32_attach_extensions {
my ( $lib, $extensions ) = @_;
return map _win32_try_attach_extension( $lib, $_ ), @{$extensions};
}
sub _win32_try_attach_extension {
my ( $lib, $extension ) = @_;
return $lib if $lib =~ /\Q$extension\E$/i;
return "$lib$extension";
}
sub _win32_lib_extensions {
my @extensions;
push @extensions, $Config{'lib_ext'} if $Config{'lib_ext'};
push @extensions, '.dll.a' if grep { m!^\.a$! } @extensions;
push @extensions, '.lib' unless grep { m!^\.lib$! } @extensions;
return \@extensions;
}
sub _debug {
my ( $message, $verbose ) = @_;
return if !$verbose;
warn $message;
return;
}
sub _vms_ext {
my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
$verbose ||= 0;
my ( @crtls, $crtlstr );
@crtls = ( ( $Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '' ) . 'PerlShr/Share' );
push( @crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'} );
push( @crtls, grep { not /\(/ } split /\s+/, $Config{'libc'} );
# In general, we pass through the basic libraries from %Config unchanged.
# The one exception is that if we're building in the Perl source tree, and
# a library spec could be resolved via a logical name, we go to some trouble
# to insure that the copy in the local tree is used, rather than one to
# which a system-wide logical may point.
if ( $self->{PERL_SRC} ) {
my ( $locspec, $type );
foreach my $lib ( @crtls ) {
if ( ( $locspec, $type ) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i ) {
if ( lc $type eq '/share' ) { $locspec .= $Config{'exe_ext'}; }
elsif ( lc $type eq '/library' ) { $locspec .= $Config{'lib_ext'}; }
else { $locspec .= $Config{'obj_ext'}; }
$locspec = $self->catfile( $self->{PERL_SRC}, $locspec );
$lib = "$locspec$type" if -e $locspec;
}
}
}
$crtlstr = @crtls ? join( ' ', @crtls ) : '';
unless ( $potential_libs ) {
warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
return ( '', '', $crtlstr, '', ( $give_libs ? [] : () ) );
}
my ( %found, @fndlibs, $ldlib );
my $cwd = cwd();
my ( $so, $lib_ext, $obj_ext ) = @Config{ 'so', 'lib_ext', 'obj_ext' };
# List of common Unix library names and their VMS equivalents
# (VMS equivalent of '' indicates that the library is automatically
# searched by the linker, and should be skipped here.)
my ( @flibs, %libs_seen );
my %libmap = (
'm' => '',
'f77' => '',
'F77' => '',
'V77' => '',
'c' => '',
'malloc' => '',
'crypt' => '',
'resolv' => '',
'c_s' => '',
'socket' => '',
'X11' => 'DECW$XLIBSHR',
'Xt' => 'DECW$XTSHR',
'Xm' => 'DECW$XMLIBSHR',
'Xmu' => 'DECW$XMULIBSHR'
);
warn "Potential libraries are '$potential_libs'\n" if $verbose;
# First, sort out directories and library names in the input
my ( @dirs, @libs );
foreach my $lib ( split ' ', $potential_libs ) {
push( @dirs, $1 ), next if $lib =~ /^-L(.*)/;
push( @dirs, $lib ), next if $lib =~ /[:>\]]$/;
push( @dirs, $lib ), next if -d $lib;
push( @libs, $1 ), next if $lib =~ /^-l(.*)/;
push( @libs, $lib );
}
push( @dirs, split( ' ', $Config{'libpth'} ) );
# Now make sure we've got VMS-syntax absolute directory specs
# (We don't, however, check whether someone's hidden a relative
# path in a logical name.)
foreach my $dir ( @dirs ) {
unless ( -d $dir ) {
warn "Skipping nonexistent Directory $dir\n" if $verbose > 1;
$dir = '';
next;
}
warn "Resolving directory $dir\n" if $verbose;
if ( File::Spec->file_name_is_absolute( $dir ) ) {
$dir = VMS::Filespec::vmspath( $dir );
}
else {
$dir = $self->catdir( $cwd, $dir );
}
}
@dirs = grep { length( $_ ) } @dirs;
unshift( @dirs, '' ); # Check each $lib without additions first
LIB: foreach my $lib ( @libs ) {
if ( exists $libmap{$lib} ) {
next unless length $libmap{$lib};
$lib = $libmap{$lib};
}
my ( @variants, $cand );
my ( $ctype ) = '';
# If we don't have a file type, consider it a possibly abbreviated name and
# check for common variants. We try these first to grab libraries before
# a like-named executable image (e.g. -lperl resolves to perlshr.exe
# before perl.exe).
if ( $lib !~ /\.[^:>\]]*$/ ) {
push( @variants, "${lib}shr", "${lib}rtl", "${lib}lib" );
push( @variants, "lib$lib" ) if $lib !~ /[:>\]]/;
}
push( @variants, $lib );
warn "Looking for $lib\n" if $verbose;
foreach my $variant ( @variants ) {
my ( $fullname, $name );
foreach my $dir ( @dirs ) {
my ( $type );
$name = "$dir$variant";
warn "\tChecking $name\n" if $verbose > 2;
$fullname = VMS::Filespec::rmsexpand( $name );
if ( defined $fullname and -f $fullname ) {
# It's got its own suffix, so we'll have to figure out the type
if ( $fullname =~ /(?:$so|exe)$/i ) { $type = 'SHR'; }
elsif ( $fullname =~ /(?:$lib_ext|olb)$/i ) { $type = 'OLB'; }
elsif ( $fullname =~ /(?:$obj_ext|obj)$/i ) {
warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n";
$type = 'OBJ';
}
else {
warn "Warning (mostly harmless): " . "Unknown library type for $fullname; assuming shared\n";
$type = 'SHR';
}
}
elsif (-f ( $fullname = VMS::Filespec::rmsexpand( $name, $so ) )
or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.exe' ) ) )
{
$type = 'SHR';
$name = $fullname unless $fullname =~ /exe;?\d*$/i;
}
elsif (
not length( $ctype ) and # If we've got a lib already,
# don't bother
( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $lib_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.olb' ) ) )
)
{
$type = 'OLB';
$name = $fullname unless $fullname =~ /olb;?\d*$/i;
}
elsif (
not length( $ctype ) and # If we've got a lib already,
# don't bother
( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $obj_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.obj' ) ) )
)
{
warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n";
$type = 'OBJ';
$name = $fullname unless $fullname =~ /obj;?\d*$/i;
}
if ( defined $type ) {
$ctype = $type;
$cand = $name;
last if $ctype eq 'SHR';
}
}
if ( $ctype ) {
push @{ $found{$ctype} }, $cand;
warn "\tFound as $cand (really $fullname), type $ctype\n"
if $verbose > 1;
push @flibs, $name unless $libs_seen{$fullname}++;
next LIB;
}
}
warn "Warning (mostly harmless): " . "No library found for $lib\n";
}
push @fndlibs, @{ $found{OBJ} } if exists $found{OBJ};
push @fndlibs, map { "$_/Library" } @{ $found{OLB} } if exists $found{OLB};
push @fndlibs, map { "$_/Share" } @{ $found{SHR} } if exists $found{SHR};
my $lib = join( ' ', @fndlibs );
$ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
$ldlib =~ s/^\s+|\s+$//g;
warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
wantarray ? ( $lib, '', $ldlib, '', ( $give_libs ? \@flibs : () ) ) : $lib;
}
1;
EXTUTILS_LIBLIST_KID
$fatpacked{"ExtUtils/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM';
package ExtUtils::MM;
use strict;
use ExtUtils::MakeMaker::Config;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::Liblist;
require ExtUtils::MakeMaker;
our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker);
=head1 NAME
ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass
=head1 SYNOPSIS
require ExtUtils::MM;
my $mm = MM->new(...);
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY>
ExtUtils::MM is a subclass of ExtUtils::MakeMaker which automatically
chooses the appropriate OS specific subclass for you
(ie. ExtUils::MM_Unix, etc...).
It also provides a convenient alias via the MM class (I didn't want
MakeMaker modules outside of ExtUtils/).
This class might turn out to be a temporary solution, but MM won't go
away.
=cut
{
# Convenient alias.
package MM;
our @ISA = qw(ExtUtils::MM);
sub DESTROY {}
}
sub _is_win95 {
# miniperl might not have the Win32 functions available and we need
# to run in miniperl.
my $have_win32 = eval { require Win32 };
return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95()
: ! defined $ENV{SYSTEMROOT};
}
my %Is = ();
$Is{VMS} = $^O eq 'VMS';
$Is{OS2} = $^O eq 'os2';
$Is{MacOS} = $^O eq 'MacOS';
if( $^O eq 'MSWin32' ) {
_is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1;
}
$Is{UWIN} = $^O =~ /^uwin(-nt)?$/;
$Is{Cygwin} = $^O eq 'cygwin';
$Is{NW5} = $Config{osname} eq 'NetWare'; # intentional
$Is{BeOS} = ($^O =~ /beos/i or $^O eq 'haiku');
$Is{DOS} = $^O eq 'dos';
if( $Is{NW5} ) {
$^O = 'NetWare';
delete $Is{Win32};
}
$Is{VOS} = $^O eq 'vos';
$Is{QNX} = $^O eq 'qnx';
$Is{AIX} = $^O eq 'aix';
$Is{Darwin} = $^O eq 'darwin';
$Is{Unix} = !grep { $_ } values %Is;
map { delete $Is{$_} unless $Is{$_} } keys %Is;
_assert( keys %Is == 1 );
my($OS) = keys %Is;
my $class = "ExtUtils::MM_$OS";
eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic
die $@ if $@;
unshift @ISA, $class;
sub _assert {
my $sanity = shift;
die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity;
return;
}
EXTUTILS_MM
$fatpacked{"ExtUtils/MM_AIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_AIX';
package ExtUtils::MM_AIX;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
use ExtUtils::MakeMaker::Config;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
=head1 NAME
ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality for
AIX.
Unless otherwise stated it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=head3 dlsyms
Define DL_FUNCS and DL_VARS and write the *.exp files.
=cut
sub dlsyms {
my($self,%attribs) = @_;
return '' unless $self->needs_linking;
join "\n", $self->xs_dlsyms_iterator(\%attribs);
}
=head3 xs_dlsyms_ext
On AIX, is C<.exp>.
=cut
sub xs_dlsyms_ext {
'.exp';
}
sub xs_dlsyms_arg {
my($self, $file) = @_;
return qq{-bE:${file}};
}
sub init_others {
my $self = shift;
$self->SUPER::init_others;
# perl "hints" add -bE:$(BASEEXT).exp to LDDLFLAGS. strip that out
# so right value can be added by xs_make_dynamic_lib to work for XSMULTI
$self->{LDDLFLAGS} ||= $Config{lddlflags};
$self->{LDDLFLAGS} =~ s#(\s*)\S*\Q$(BASEEXT)\E\S*(\s*)#$1$2#;
return;
}
=head1 AUTHOR
Michael G Schwern <[email protected]> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_AIX
$fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_ANY';
package ExtUtils::MM_Any;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
use Carp;
use File::Spec;
use File::Basename;
BEGIN { our @ISA = qw(File::Spec); }
# We need $Verbose
use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);
use ExtUtils::MakeMaker::Config;
# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values. Faster and shrtr.
my $Curdir = __PACKAGE__->curdir;
#my $Updir = __PACKAGE__->updir;
my $METASPEC_URL = 'https://metacpan.org/pod/CPAN::Meta::Spec';
my $METASPEC_V = 2;
=head1 NAME
ExtUtils::MM_Any - Platform-agnostic MM methods
=head1 SYNOPSIS
FOR INTERNAL USE ONLY!
package ExtUtils::MM_SomeOS;
# Temporarily, you have to subclass both. Put MM_Any first.
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
@ISA = qw(ExtUtils::MM_Any ExtUtils::Unix);
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY!>
ExtUtils::MM_Any is a superclass for the ExtUtils::MM_* set of
modules. It contains methods which are either inherently
cross-platform or are written in a cross-platform manner.
Subclass off of ExtUtils::MM_Any I<and> ExtUtils::MM_Unix. This is a
temporary solution.
B<THIS MAY BE TEMPORARY!>
=head1 METHODS
Any methods marked I<Abstract> must be implemented by subclasses.
=head2 Cross-platform helper methods
These are methods which help writing cross-platform code.
=head3 os_flavor I<Abstract>
my @os_flavor = $mm->os_flavor;
@os_flavor is the style of operating system this is, usually
corresponding to the MM_*.pm file we're using.
The first element of @os_flavor is the major family (ie. Unix,
Windows, VMS, OS/2, etc...) and the rest are sub families.
Some examples:
Cygwin98 ('Unix', 'Cygwin', 'Cygwin9x')
Windows ('Win32')
Win98 ('Win32', 'Win9x')
Linux ('Unix', 'Linux')
MacOS X ('Unix', 'Darwin', 'MacOS', 'MacOS X')
OS/2 ('OS/2')
This is used to write code for styles of operating system.
See os_flavor_is() for use.
=head3 os_flavor_is
my $is_this_flavor = $mm->os_flavor_is($this_flavor);
my $is_this_flavor = $mm->os_flavor_is(@one_of_these_flavors);
Checks to see if the current operating system is one of the given flavors.
This is useful for code like:
if( $mm->os_flavor_is('Unix') ) {
$out = `foo 2>&1`;
}
else {
$out = `foo`;
}
=cut
sub os_flavor_is {
my $self = shift;
my %flavors = map { ($_ => 1) } $self->os_flavor;
return (grep { $flavors{$_} } @_) ? 1 : 0;
}
=head3 can_load_xs
my $can_load_xs = $self->can_load_xs;
Returns true if we have the ability to load XS.
This is important because miniperl, used to build XS modules in the
core, can not load XS.
=cut
sub can_load_xs {
return defined &DynaLoader::boot_DynaLoader ? 1 : 0;
}
=head3 can_run
use ExtUtils::MM;
my $runnable = MM->can_run($Config{make});
If called in a scalar context it will return the full path to the binary
you asked for if it was found, or C<undef> if it was not.
If called in a list context, it will return a list of the full paths to instances
of the binary where found in C<PATH>, or an empty list if it was not found.
Copied from L<IPC::Cmd|IPC::Cmd/"$path = can_run( PROGRAM );">, but modified into
a method (and removed C<$INSTANCES> capability).
=cut
sub can_run {
my ($self, $command) = @_;
# a lot of VMS executables have a symbol defined
# check those first
if ( $^O eq 'VMS' ) {
require VMS::DCLsym;
my $syms = VMS::DCLsym->new;
return $command if scalar $syms->getsym( uc $command );
}
my @possibles;
if( File::Spec->file_name_is_absolute($command) ) {
return $self->maybe_command($command);
} else {
for my $dir (
File::Spec->path,
File::Spec->curdir
) {
next if ! $dir || ! -d $dir;
my $abs = File::Spec->catfile($self->os_flavor_is('Win32') ? Win32::GetShortPathName( $dir ) : $dir, $command);
push @possibles, $abs if $abs = $self->maybe_command($abs);
}
}
return @possibles if wantarray;
return shift @possibles;
}
=head3 can_redirect_error
$useredirect = MM->can_redirect_error;
True if on an OS where qx operator (or backticks) can redirect C<STDERR>
onto C<STDOUT>.
=cut
sub can_redirect_error {
my $self = shift;
$self->os_flavor_is('Unix')
or ($self->os_flavor_is('Win32') and !$self->os_flavor_is('Win9x'))
or $self->os_flavor_is('OS/2')
}
=head3 is_make_type
my $is_dmake = $self->is_make_type('dmake');
Returns true if C<<$self->make>> is the given type; possibilities are:
gmake GNU make
dmake
nmake
bsdmake BSD pmake-derived
=cut
my %maketype2true;
# undocumented - so t/cd.t can still do its thing
sub _clear_maketype_cache { %maketype2true = () }
sub is_make_type {
my($self, $type) = @_;
return $maketype2true{$type} if defined $maketype2true{$type};
(undef, undef, my $make_basename) = $self->splitpath($self->make);
return $maketype2true{$type} = 1
if $make_basename =~ /\b$type\b/i; # executable's filename
return $maketype2true{$type} = 0
if $make_basename =~ /\b[gdn]make\b/i; # Never fall through for dmake/nmake/gmake
# now have to run with "-v" and guess
my $redirect = $self->can_redirect_error ? '2>&1' : '';
my $make = $self->make || $self->{MAKE};
my $minus_v = `"$make" -v $redirect`;
return $maketype2true{$type} = 1
if $type eq 'gmake' and $minus_v =~ /GNU make/i;
return $maketype2true{$type} = 1
if $type eq 'bsdmake'
and $minus_v =~ /^usage: make \[-BeikNnqrstWwX\]/im;
$maketype2true{$type} = 0; # it wasn't whatever you asked
}
=head3 can_dep_space
my $can_dep_space = $self->can_dep_space;
Returns true if C<make> can handle (probably by quoting)
dependencies that contain a space. Currently known true for GNU make,
false for BSD pmake derivative.
=cut
my $cached_dep_space;
sub can_dep_space {
my $self = shift;
return $cached_dep_space if defined $cached_dep_space;
return $cached_dep_space = 1 if $self->is_make_type('gmake');
return $cached_dep_space = 0 if $self->is_make_type('dmake'); # only on W32
return $cached_dep_space = 0 if $self->is_make_type('bsdmake');
return $cached_dep_space = 0; # assume no
}
=head3 quote_dep
$text = $mm->quote_dep($text);
Method that protects Makefile single-value constants (mainly filenames),
so that make will still treat them as single values even if they
inconveniently have spaces in. If the make program being used cannot
achieve such protection and the given text would need it, throws an
exception.
=cut
sub quote_dep {
my ($self, $arg) = @_;
die <<EOF if $arg =~ / / and not $self->can_dep_space;
Tried to use make dependency with space for make that can't:
'$arg'
EOF
$arg =~ s/( )/\\$1/g; # how GNU make does it
return $arg;
}
=head3 split_command
my @cmds = $MM->split_command($cmd, @args);
Most OS have a maximum command length they can execute at once. Large
modules can easily generate commands well past that limit. Its
necessary to split long commands up into a series of shorter commands.
C<split_command> will return a series of @cmds each processing part of
the args. Collectively they will process all the arguments. Each
individual line in @cmds will not be longer than the
$self->max_exec_len being careful to take into account macro expansion.
$cmd should include any switches and repeated initial arguments.
If no @args are given, no @cmds will be returned.
Pairs of arguments will always be preserved in a single command, this
is a heuristic for things like pm_to_blib and pod2man which work on
pairs of arguments. This makes things like this safe:
$self->split_command($cmd, %pod2man);
=cut
sub split_command {
my($self, $cmd, @args) = @_;
my @cmds = ();
return(@cmds) unless @args;
# If the command was given as a here-doc, there's probably a trailing
# newline.
chomp $cmd;
# set aside 30% for macro expansion.
my $len_left = int($self->max_exec_len * 0.70);
$len_left -= length $self->_expand_macros($cmd);
do {
my $arg_str = '';
my @next_args;
while( @next_args = splice(@args, 0, 2) ) {
# Two at a time to preserve pairs.
my $next_arg_str = "\t ". join ' ', @next_args, "\n";
if( !length $arg_str ) {
$arg_str .= $next_arg_str
}
elsif( length($arg_str) + length($next_arg_str) > $len_left ) {
unshift @args, @next_args;
last;
}
else {
$arg_str .= $next_arg_str;
}
}
chop $arg_str;
push @cmds, $self->escape_newlines("$cmd \n$arg_str");
} while @args;
return @cmds;
}
sub _expand_macros {
my($self, $cmd) = @_;
$cmd =~ s{\$\((\w+)\)}{
defined $self->{$1} ? $self->{$1} : "\$($1)"
}e;
return $cmd;
}
=head3 make_type
Returns a suitable string describing the type of makefile being written.
=cut
# override if this isn't suitable!
sub make_type { return 'Unix-style'; }
=head3 stashmeta
my @recipelines = $MM->stashmeta($text, $file);
Generates a set of C<@recipelines> which will result in the literal
C<$text> ending up in literal C<$file> when the recipe is executed. Call
it once, with all the text you want in C<$file>. Make macros will not
be expanded, so the locations will be fixed at configure-time, not
at build-time.
=cut
sub stashmeta {
my($self, $text, $file) = @_;
$self->echo($text, $file, { allow_variables => 0, append => 0 });
}
=head3 echo
my @commands = $MM->echo($text);
my @commands = $MM->echo($text, $file);
my @commands = $MM->echo($text, $file, \%opts);
Generates a set of @commands which print the $text to a $file.
If $file is not given, output goes to STDOUT.
If $opts{append} is true the $file will be appended to rather than
overwritten. Default is to overwrite.
If $opts{allow_variables} is true, make variables of the form
C<$(...)> will not be escaped. Other C<$> will. Default is to escape
all C<$>.
Example of use:
my $make = join '', map "\t$_\n", $MM->echo($text, $file);
=cut
sub echo {
my($self, $text, $file, $opts) = @_;
# Compatibility with old options
if( !ref $opts ) {
my $append = $opts;
$opts = { append => $append || 0 };
}
$opts->{allow_variables} = 0 unless defined $opts->{allow_variables};
my $ql_opts = { allow_variables => $opts->{allow_variables} };
my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_, $ql_opts) }
split /\n/, $text;
if( $file ) {
my $redirect = $opts->{append} ? '>>' : '>';
$cmds[0] .= " $redirect $file";
$_ .= " >> $file" foreach @cmds[1..$#cmds];
}
return @cmds;
}
=head3 wraplist
my $args = $mm->wraplist(@list);
Takes an array of items and turns them into a well-formatted list of
arguments. In most cases this is simply something like:
FOO \
BAR \
BAZ
=cut
sub wraplist {
my $self = shift;
return join " \\\n\t", @_;
}
=head3 maketext_filter
my $filter_make_text = $mm->maketext_filter($make_text);
The text of the Makefile is run through this method before writing to
disk. It allows systems a chance to make portability fixes to the
Makefile.
By default it does nothing.
This method is protected and not intended to be called outside of
MakeMaker.
=cut
sub maketext_filter { return $_[1] }
=head3 cd I<Abstract>
my $subdir_cmd = $MM->cd($subdir, @cmds);
This will generate a make fragment which runs the @cmds in the given
$dir. The rough equivalent to this, except cross platform.
cd $subdir && $cmd
Currently $dir can only go down one level. "foo" is fine. "foo/bar" is
not. "../foo" is right out.
The resulting $subdir_cmd has no leading tab nor trailing newline. This
makes it easier to embed in a make string. For example.
my $make = sprintf <<'CODE', $subdir_cmd;
foo :
$(ECHO) what
%s
$(ECHO) mouche
CODE
=head3 oneliner I<Abstract>
my $oneliner = $MM->oneliner($perl_code);
my $oneliner = $MM->oneliner($perl_code, \@switches);
This will generate a perl one-liner safe for the particular platform
you're on based on the given $perl_code and @switches (a -e is
assumed) suitable for using in a make target. It will use the proper
shell quoting and escapes.
$(PERLRUN) will be used as perl.
Any newlines in $perl_code will be escaped. Leading and trailing
newlines will be stripped. Makes this idiom much easier:
my $code = $MM->oneliner(<<'CODE', [...switches...]);
some code here
another line here
CODE
Usage might be something like:
# an echo emulation
$oneliner = $MM->oneliner('print "Foo\n"');
$make = '$oneliner > somefile';
Dollar signs in the $perl_code will be protected from make using the
C<quote_literal> method, unless they are recognised as being a make
variable, C<$(varname)>, in which case they will be left for make
to expand. Remember to quote make macros else it might be used as a
bareword. For example:
# Assign the value of the $(VERSION_FROM) make macro to $vf.
$oneliner = $MM->oneliner('$vf = "$(VERSION_FROM)"');
Its currently very simple and may be expanded sometime in the figure
to include more flexible code and switches.
=head3 quote_literal I<Abstract>
my $safe_text = $MM->quote_literal($text);
my $safe_text = $MM->quote_literal($text, \%options);
This will quote $text so it is interpreted literally in the shell.
For example, on Unix this would escape any single-quotes in $text and
put single-quotes around the whole thing.
If $options{allow_variables} is true it will leave C<'$(FOO)'> make
variables untouched. If false they will be escaped like any other
C<$>. Defaults to true.
=head3 escape_dollarsigns
my $escaped_text = $MM->escape_dollarsigns($text);
Escapes stray C<$> so they are not interpreted as make variables.
It lets by C<$(...)>.
=cut
sub escape_dollarsigns {
my($self, $text) = @_;
# Escape dollar signs which are not starting a variable
$text =~ s{\$ (?!\() }{\$\$}gx;
return $text;
}
=head3 escape_all_dollarsigns
my $escaped_text = $MM->escape_all_dollarsigns($text);
Escapes all C<$> so they are not interpreted as make variables.
=cut
sub escape_all_dollarsigns {
my($self, $text) = @_;
# Escape dollar signs
$text =~ s{\$}{\$\$}gx;
return $text;
}
=head3 escape_newlines I<Abstract>
my $escaped_text = $MM->escape_newlines($text);
Shell escapes newlines in $text.
=head3 max_exec_len I<Abstract>
my $max_exec_len = $MM->max_exec_len;
Calculates the maximum command size the OS can exec. Effectively,
this is the max size of a shell command line.
=for _private
$self->{_MAX_EXEC_LEN} is set by this method, but only for testing purposes.
=head3 make
my $make = $MM->make;
Returns the make variant we're generating the Makefile for. This attempts
to do some normalization on the information from %Config or the user.
=cut
sub make {
my $self = shift;
my $make = lc $self->{MAKE};
# Truncate anything like foomake6 to just foomake.
$make =~ s/^(\w+make).*/$1/;
# Turn gnumake into gmake.
$make =~ s/^gnu/g/;
return $make;
}
=head2 Targets
These are methods which produce make targets.
=head3 all_target
Generate the default target 'all'.
=cut
sub all_target {
my $self = shift;
return <<'MAKE_EXT';
all :: pure_all
$(NOECHO) $(NOOP)
MAKE_EXT
}
=head3 blibdirs_target
my $make_frag = $mm->blibdirs_target;
Creates the blibdirs target which creates all the directories we use
in blib/.
The blibdirs.ts target is deprecated. Depend on blibdirs instead.
=cut
sub _xs_list_basenames {
my ($self) = @_;
map { (my $b = $_) =~ s/\.xs$//; $b } sort keys %{ $self->{XS} };
}
sub blibdirs_target {
my $self = shift;
my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib
autodir archautodir
bin script
man1dir man3dir
);
if ($self->{XSMULTI}) {
for my $ext ($self->_xs_list_basenames) {
my ($v, $d, $f) = File::Spec->splitpath($ext);
my @d = File::Spec->splitdir($d);
shift @d if $d[0] eq 'lib';
push @dirs, $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
}
}
my @exists = map { $_.'$(DFSEP).exists' } @dirs;
my $make = sprintf <<'MAKE', join(' ', @exists);
blibdirs : %s
$(NOECHO) $(NOOP)
# Backwards compat with 6.18 through 6.25
blibdirs.ts : blibdirs
$(NOECHO) $(NOOP)
MAKE
$make .= $self->dir_target(@dirs);
return $make;
}
=head3 clean (o)
Defines the clean target.
=cut
sub clean {
# --- Cleanup and Distribution Sections ---
my($self, %attribs) = @_;
my @m;
push(@m, '
# Delete temporary files but do not touch installed files. We don\'t delete
# the Makefile here so a later make realclean still has a makefile to use.
clean :: clean_subdirs
');
my @files = sort values %{$self->{XS}}; # .c files from *.xs files
push @files, map {
my $file = $_;
map { $file.$_ } $self->{OBJ_EXT}, qw(.def _def.old .bs .bso .exp .base);
} $self->_xs_list_basenames;
my @dirs = qw(blib);
# Normally these are all under blib but they might have been
# redefined.
# XXX normally this would be a good idea, but the Perl core sets
# INST_LIB = ../../lib rather than actually installing the files.
# So a "make clean" in an ext/ directory would blow away lib.
# Until the core is adjusted let's leave this out.
# push @dirs, qw($(INST_ARCHLIB) $(INST_LIB)
# $(INST_BIN) $(INST_SCRIPT)
# $(INST_MAN1DIR) $(INST_MAN3DIR)
# $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR)
# $(INST_STATIC) $(INST_DYNAMIC)
# );
if( $attribs{FILES} ) {
# Use @dirs because we don't know what's in here.
push @dirs, ref $attribs{FILES} ?
@{$attribs{FILES}} :
split /\s+/, $attribs{FILES} ;
}
push(@files, qw[$(MAKE_APERL_FILE)
MYMETA.json MYMETA.yml perlmain.c tmon.out mon.out so_locations
blibdirs.ts pm_to_blib pm_to_blib.ts
*$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT)
$(BOOTSTRAP) $(BASEEXT).bso
$(BASEEXT).def lib$(BASEEXT).def
$(BASEEXT).exp $(BASEEXT).x
]);
push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'));
push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld'));
# core files
if ($^O eq 'vos') {
push(@files, qw[perl*.kp]);
}
else {
push(@files, qw[core core.*perl.*.? *perl.core]);
}
push(@files, map { "core." . "[0-9]"x$_ } (1..5));
# OS specific things to clean up. Use @dirs since we don't know
# what might be in here.
push @dirs, $self->extra_clean_files;
# Occasionally files are repeated several times from different sources
{ my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; }
{ my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; }
push @m, map "\t$_\n", $self->split_command('- $(RM_F)', @files);
push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs);
# Leave Makefile.old around for realclean
push @m, <<'MAKE';
$(NOECHO) $(RM_F) $(MAKEFILE_OLD)
- $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL)
MAKE
push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP};
join("", @m);
}
=head3 clean_subdirs_target
my $make_frag = $MM->clean_subdirs_target;
Returns the clean_subdirs target. This is used by the clean target to
call clean on any subdirectories which contain Makefiles.
=cut
sub clean_subdirs_target {
my($self) = shift;
# No subdirectories, no cleaning.
return <<'NOOP_FRAG' unless @{$self->{DIR}};
clean_subdirs :
$(NOECHO) $(NOOP)
NOOP_FRAG
my $clean = "clean_subdirs :\n";
for my $dir (@{$self->{DIR}}) {
my $subclean = $self->oneliner(sprintf <<'CODE', $dir);
exit 0 unless chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)';
CODE
$clean .= "\t$subclean\n";
}
return $clean;
}
=head3 dir_target
my $make_frag = $mm->dir_target(@directories);
Generates targets to create the specified directories and set its
permission to PERM_DIR.
Because depending on a directory to just ensure it exists doesn't work
too well (the modified time changes too often) dir_target() creates a
.exists file in the created directory. It is this you should depend on.
For portability purposes you should use the $(DIRFILESEP) macro rather
than a '/' to separate the directory from the file.
yourdirectory$(DIRFILESEP).exists
=cut
sub dir_target {
my($self, @dirs) = @_;
my $make = '';
foreach my $dir (@dirs) {
$make .= sprintf <<'MAKE', ($dir) x 4;
%s$(DFSEP).exists :: Makefile.PL
$(NOECHO) $(MKPATH) %s
$(NOECHO) $(CHMOD) $(PERM_DIR) %s
$(NOECHO) $(TOUCH) %s$(DFSEP).exists
MAKE
}
return $make;
}
=head3 distdir
Defines the scratch directory target that will hold the distribution
before tar-ing (or shar-ing).
=cut
# For backwards compatibility.
*dist_dir = *distdir;
sub distdir {
my($self) = shift;
my $meta_target = $self->{NO_META} ? '' : 'distmeta';
my $sign_target = !$self->{SIGN} ? '' : 'distsignature';
return sprintf <<'MAKE_FRAG', $meta_target, $sign_target;
create_distdir :
$(RM_RF) $(DISTVNAME)
$(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \
-e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
distdir : create_distdir %s %s
$(NOECHO) $(NOOP)
MAKE_FRAG
}
=head3 dist_test
Defines a target that produces the distribution in the
scratch directory, and runs 'perl Makefile.PL; make ;make test' in that
subdirectory.
=cut
sub dist_test {
my($self) = shift;
my $mpl_args = join " ", map qq["$_"], @ARGV;
my $test = $self->cd('$(DISTVNAME)',
'$(ABSPERLRUN) Makefile.PL '.$mpl_args,
'$(MAKE) $(PASTHRU)',
'$(MAKE) test $(PASTHRU)'
);
return sprintf <<'MAKE_FRAG', $test;
disttest : distdir
%s
MAKE_FRAG
}
=head3 xs_dlsyms_arg
Returns command-line arg(s) to linker for file listing dlsyms to export.
Defaults to returning empty string, can be overridden by e.g. AIX.
=cut
sub xs_dlsyms_arg {
return '';
}
=head3 xs_dlsyms_ext
Returns file-extension for C<xs_make_dlsyms> method's output file,
including any "." character.
=cut
sub xs_dlsyms_ext {
die "Pure virtual method";
}
=head3 xs_dlsyms_extra
Returns any extra text to be prepended to the C<$extra> argument of
C<xs_make_dlsyms>.
=cut
sub xs_dlsyms_extra {
'';
}
=head3 xs_dlsyms_iterator
Iterates over necessary shared objects, calling C<xs_make_dlsyms> method
for each with appropriate arguments.
=cut
sub xs_dlsyms_iterator {
my ($self, $attribs) = @_;
if ($self->{XSMULTI}) {
my @m;
for my $ext ($self->_xs_list_basenames) {
my @parts = File::Spec->splitdir($ext);
shift @parts if $parts[0] eq 'lib';
my $name = join '::', @parts;
push @m, $self->xs_make_dlsyms(
$attribs,
$ext . $self->xs_dlsyms_ext,
"$ext.xs",
$name,
$parts[-1],
{}, [], {}, [],
$self->xs_dlsyms_extra . q!, 'FILE' => ! . neatvalue($ext),
);
}
return join "\n", @m;
} else {
return $self->xs_make_dlsyms(
$attribs,
$self->{BASEEXT} . $self->xs_dlsyms_ext,
'Makefile.PL',
$self->{NAME},
$self->{DLBASE},
$attribs->{DL_FUNCS} || $self->{DL_FUNCS} || {},
$attribs->{FUNCLIST} || $self->{FUNCLIST} || [],
$attribs->{IMPORTS} || $self->{IMPORTS} || {},
$attribs->{DL_VARS} || $self->{DL_VARS} || [],
$self->xs_dlsyms_extra,
);
}
}
=head3 xs_make_dlsyms
$self->xs_make_dlsyms(
\%attribs, # hashref from %attribs in caller
"$self->{BASEEXT}.def", # output file for Makefile target
'Makefile.PL', # dependency
$self->{NAME}, # shared object's "name"
$self->{DLBASE}, # last ::-separated part of name
$attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}, # various params
$attribs{FUNCLIST} || $self->{FUNCLIST} || [],
$attribs{IMPORTS} || $self->{IMPORTS} || {},
$attribs{DL_VARS} || $self->{DL_VARS} || [],
# optional extra param that will be added as param to Mksymlists
);
Utility method that returns Makefile snippet to call C<Mksymlists>.
=cut
sub xs_make_dlsyms {
my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_;
my @m = (
"\n$target: $dep\n",
q! $(PERLRUN) -MExtUtils::Mksymlists \\
-e "Mksymlists('NAME'=>\"!, $name,
q!\", 'DLBASE' => '!,$dlbase,
# The above two lines quoted differently to work around
# a bug in the 4DOS/4NT command line interpreter. The visible
# result of the bug was files named q('extension_name',) *with the
# single quotes and the comma* in the extension build directories.
q!', 'DL_FUNCS' => !,neatvalue($funcs),
q!, 'FUNCLIST' => !,neatvalue($funclist),
q!, 'IMPORTS' => !,neatvalue($imports),
q!, 'DL_VARS' => !, neatvalue($vars)
);
push @m, $extra if defined $extra;
push @m, qq!);"\n!;
join '', @m;
}
=head3 dynamic (o)
Defines the dynamic target.
=cut
sub dynamic {
# --- Dynamic Loading Sections ---
my($self) = shift;
'
dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC)
$(NOECHO) $(NOOP)
';
}
=head3 makemakerdflt_target
my $make_frag = $mm->makemakerdflt_target
Returns a make fragment with the makemakerdeflt_target specified.
This target is the first target in the Makefile, is the default target
and simply points off to 'all' just in case any make variant gets
confused or something gets snuck in before the real 'all' target.
=cut
sub makemakerdflt_target {
return <<'MAKE_FRAG';
makemakerdflt : all
$(NOECHO) $(NOOP)
MAKE_FRAG
}
=head3 manifypods_target
my $manifypods_target = $self->manifypods_target;
Generates the manifypods target. This target generates man pages from
all POD files in MAN1PODS and MAN3PODS.
=cut
sub manifypods_target {
my($self) = shift;
my $man1pods = '';
my $man3pods = '';
my $dependencies = '';
# populate manXpods & dependencies:
foreach my $name (sort keys %{$self->{MAN1PODS}}, sort keys %{$self->{MAN3PODS}}) {
$dependencies .= " \\\n\t$name";
}
my $manify = <<END;
manifypods : pure_all config $dependencies
END
my @man_cmds;
foreach my $section (qw(1 3)) {
my $pods = $self->{"MAN${section}PODS"};
my $p2m = sprintf <<'CMD', $section, $] > 5.008 ? " -u" : "";
$(NOECHO) $(POD2MAN) --section=%s --perm_rw=$(PERM_RW)%s
CMD
push @man_cmds, $self->split_command($p2m, map {($_,$pods->{$_})} sort keys %$pods);
}
$manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds;
$manify .= join '', map { "$_\n" } @man_cmds;
return $manify;
}
{
my $has_cpan_meta;
sub _has_cpan_meta {
return $has_cpan_meta if defined $has_cpan_meta;
return $has_cpan_meta = !!eval {
require CPAN::Meta;
CPAN::Meta->VERSION(2.112150);
1;
};
}
}
=head3 metafile_target
my $target = $mm->metafile_target;
Generate the metafile target.
Writes the file META.yml (YAML encoded meta-data) and META.json
(JSON encoded meta-data) about the module in the distdir.
The format follows Module::Build's as closely as possible.
=cut
sub metafile_target {
my $self = shift;
return <<'MAKE_FRAG' if $self->{NO_META} or ! _has_cpan_meta();
metafile :
$(NOECHO) $(NOOP)
MAKE_FRAG
my $metadata = $self->metafile_data(
$self->{META_ADD} || {},
$self->{META_MERGE} || {},
);
my $meta = $self->_fix_metadata_before_conversion( $metadata );
my @write_metayml = $self->stashmeta(
$meta->as_string({version => "1.4"}), 'META_new.yml'
);
my @write_metajson = $self->stashmeta(
$meta->as_string({version => "2.0"}), 'META_new.json'
);
my $metayml = join("\n\t", @write_metayml);
my $metajson = join("\n\t", @write_metajson);
return sprintf <<'MAKE_FRAG', $metayml, $metajson;
metafile : create_distdir
$(NOECHO) $(ECHO) Generating META.yml
%s
-$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml
$(NOECHO) $(ECHO) Generating META.json
%s
-$(NOECHO) $(MV) META_new.json $(DISTVNAME)/META.json
MAKE_FRAG
}
=begin private
=head3 _fix_metadata_before_conversion
$mm->_fix_metadata_before_conversion( \%metadata );
Fixes errors in the metadata before it's handed off to CPAN::Meta for
conversion. This hopefully results in something that can be used further
on, no guarantee is made though.
=end private
=cut
sub _fix_metadata_before_conversion {
my ( $self, $metadata ) = @_;
# we should never be called unless this already passed but
# prefer to be defensive in case somebody else calls this
return unless _has_cpan_meta;
my $bad_version = $metadata->{version} &&
!CPAN::Meta::Validator->new->version( 'version', $metadata->{version} );
# just delete all invalid versions
if( $bad_version ) {
warn "Can't parse version '$metadata->{version}'\n";
$metadata->{version} = '';
}
my $validator2 = CPAN::Meta::Validator->new( $metadata );
my @errors;
push @errors, $validator2->errors if !$validator2->is_valid;
my $validator14 = CPAN::Meta::Validator->new(
{
%$metadata,
'meta-spec' => { version => 1.4 },
}
);
push @errors, $validator14->errors if !$validator14->is_valid;
# fix non-camelcase custom resource keys (only other trick we know)
for my $error ( @errors ) {
my ( $key ) = ( $error =~ /Custom resource '(.*)' must be in CamelCase./ );
next if !$key;
# first try to remove all non-alphabetic chars
( my $new_key = $key ) =~ s/[^_a-zA-Z]//g;
# if that doesn't work, uppercase first one
$new_key = ucfirst $new_key if !$validator14->custom_1( $new_key );
# copy to new key if that worked
$metadata->{resources}{$new_key} = $metadata->{resources}{$key}
if $validator14->custom_1( $new_key );
# and delete old one in any case
delete $metadata->{resources}{$key};
}
# paper over validation issues, but still complain, necessary because
# there's no guarantee that the above will fix ALL errors
my $meta = eval { CPAN::Meta->create( $metadata, { lazy_validation => 1 } ) };
warn $@ if $@ and
$@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/;
# use the original metadata straight if the conversion failed
# or if it can't be stringified.
if( !$meta ||
!eval { $meta->as_string( { version => $METASPEC_V } ) } ||
!eval { $meta->as_string }
) {
$meta = bless $metadata, 'CPAN::Meta';
}
my $now_license = $meta->as_struct({ version => 2 })->{license};
if ($self->{LICENSE} and $self->{LICENSE} ne 'unknown' and
@{$now_license} == 1 and $now_license->[0] eq 'unknown'
) {
warn "Invalid LICENSE value '$self->{LICENSE}' ignored\n";
}
$meta;
}
=begin private
=head3 _sort_pairs
my @pairs = _sort_pairs($sort_sub, \%hash);
Sorts the pairs of a hash based on keys ordered according
to C<$sort_sub>.
=end private
=cut
sub _sort_pairs {
my $sort = shift;
my $pairs = shift;
return map { $_ => $pairs->{$_} }
sort $sort
keys %$pairs;
}
# Taken from Module::Build::Base
sub _hash_merge {
my ($self, $h, $k, $v) = @_;
if (ref $h->{$k} eq 'ARRAY') {
push @{$h->{$k}}, ref $v ? @$v : $v;
} elsif (ref $h->{$k} eq 'HASH') {
$self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v;
} else {
$h->{$k} = $v;
}
}
=head3 metafile_data
my $metadata_hashref = $mm->metafile_data(\%meta_add, \%meta_merge);
Returns the data which MakeMaker turns into the META.yml file
and the META.json file. It is always in version 2.0 of the format.
Values of %meta_add will overwrite any existing metadata in those
keys. %meta_merge will be merged with them.
=cut
sub metafile_data {
my $self = shift;
my($meta_add, $meta_merge) = @_;
$meta_add ||= {};
$meta_merge ||= {};
my $version = _normalize_version($self->{VERSION});
my $release_status = ($version =~ /_/) ? 'unstable' : 'stable';
my %meta = (
# required
abstract => $self->{ABSTRACT} || 'unknown',
author => defined($self->{AUTHOR}) ? $self->{AUTHOR} : ['unknown'],
dynamic_config => 1,
generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
license => [ $self->{LICENSE} || 'unknown' ],
'meta-spec' => {
url => $METASPEC_URL,
version => $METASPEC_V,
},
name => $self->{DISTNAME},
release_status => $release_status,
version => $version,
# optional
no_index => { directory => [qw(t inc)] },
);
$self->_add_requirements_to_meta(\%meta);
if (!eval { require JSON::PP; require CPAN::Meta::Converter; CPAN::Meta::Converter->VERSION(2.141170) }) {
return \%meta;
}
# needs to be based on the original version
my $v1_add = _metaspec_version($meta_add) !~ /^2/;
my ($add_v, $merge_v) = map _metaspec_version($_), $meta_add, $meta_merge;
for my $frag ($meta_add, $meta_merge) {
my $def_v = $frag == $meta_add ? $merge_v : $add_v;
$frag = CPAN::Meta::Converter->new($frag, default_version => $def_v)->upgrade_fragment;
}
# if we upgraded a 1.x _ADD fragment, we gave it a prereqs key that
# will override all prereqs, which is more than the user asked for;
# instead, we'll go inside the prereqs and override all those
while( my($key, $val) = each %$meta_add ) {
if ($v1_add and $key eq 'prereqs') {
$meta{$key}{$_} = $val->{$_} for keys %$val;
} elsif ($key ne 'meta-spec') {
$meta{$key} = $val;
}
}
while( my($key, $val) = each %$meta_merge ) {
next if $key eq 'meta-spec';
$self->_hash_merge(\%meta, $key, $val);
}
return \%meta;
}
=begin private
=cut
sub _add_requirements_to_meta {
my ( $self, $meta ) = @_;
# Check the original args so we can tell between the user setting it
# to an empty hash and it just being initialized.
$meta->{prereqs}{configure}{requires} = $self->{ARGS}{CONFIGURE_REQUIRES}
? $self->{CONFIGURE_REQUIRES}
: { 'ExtUtils::MakeMaker' => 0, };
$meta->{prereqs}{build}{requires} = $self->{ARGS}{BUILD_REQUIRES}
? $self->{BUILD_REQUIRES}
: { 'ExtUtils::MakeMaker' => 0, };
$meta->{prereqs}{test}{requires} = $self->{TEST_REQUIRES}
if $self->{ARGS}{TEST_REQUIRES};
$meta->{prereqs}{runtime}{requires} = $self->{PREREQ_PM}
if $self->{ARGS}{PREREQ_PM};
$meta->{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
if $self->{MIN_PERL_VERSION};
}
# spec version of given fragment - if not given, assume 1.4
sub _metaspec_version {
my ( $meta ) = @_;
return $meta->{'meta-spec'}->{version}
if defined $meta->{'meta-spec'}
and defined $meta->{'meta-spec'}->{version};
return '1.4';
}
sub _add_requirements_to_meta_v1_4 {
my ( $self, $meta ) = @_;
# Check the original args so we can tell between the user setting it
# to an empty hash and it just being initialized.
if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
$meta->{configure_requires} = $self->{CONFIGURE_REQUIRES};
} else {
$meta->{configure_requires} = {
'ExtUtils::MakeMaker' => 0,
};
}
if( $self->{ARGS}{BUILD_REQUIRES} ) {
$meta->{build_requires} = $self->{BUILD_REQUIRES};
} else {
$meta->{build_requires} = {
'ExtUtils::MakeMaker' => 0,
};
}
if( $self->{ARGS}{TEST_REQUIRES} ) {
$meta->{build_requires} = {
%{ $meta->{build_requires} },
%{ $self->{TEST_REQUIRES} },
};
}
$meta->{requires} = $self->{PREREQ_PM}
if defined $self->{PREREQ_PM};
$meta->{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
if $self->{MIN_PERL_VERSION};
}
# Adapted from Module::Build::Base
sub _normalize_version {
my ($version) = @_;
$version = 0 unless defined $version;
if ( ref $version eq 'version' ) { # version objects
$version = $version->stringify;
}
elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
# normalize string tuples without "v": "1.2.3" -> "v1.2.3"
$version = "v$version";
}
else {
# leave alone
}
return $version;
}
=head3 _dump_hash
$yaml = _dump_hash(\%options, %hash);
Implements a fake YAML dumper for a hash given
as a list of pairs. No quoting/escaping is done. Keys
are supposed to be strings. Values are undef, strings,
hash refs or array refs of strings.
Supported options are:
delta => STR - indentation delta
use_header => BOOL - whether to include a YAML header
indent => STR - a string of spaces
default: ''
max_key_length => INT - maximum key length used to align
keys and values of the same hash
default: 20
key_sort => CODE - a sort sub
It may be undef, which means no sorting by keys
default: sub { lc $a cmp lc $b }
customs => HASH - special options for certain keys
(whose values are hashes themselves)
may contain: max_key_length, key_sort, customs
=end private
=cut
sub _dump_hash {
croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH';
my $options = shift;
my %hash = @_;
# Use a list to preserve order.
my @pairs;
my $k_sort
= exists $options->{key_sort} ? $options->{key_sort}
: sub { lc $a cmp lc $b };
if ($k_sort) {
croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE';
@pairs = _sort_pairs($k_sort, \%hash);
} else { # list of pairs, no sorting
@pairs = @_;
}
my $yaml = $options->{use_header} ? "--- #YAML:1.0\n" : '';
my $indent = $options->{indent} || '';
my $k_length = min(
($options->{max_key_length} || 20),
max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash)
);
my $customs = $options->{customs} || {};
# printf format for key
my $k_format = "%-${k_length}s";
while( @pairs ) {
my($key, $val) = splice @pairs, 0, 2;
$val = '~' unless defined $val;
if(ref $val eq 'HASH') {
if ( keys %$val ) {
my %k_options = ( # options for recursive call
delta => $options->{delta},
use_header => 0,
indent => $indent . $options->{delta},
);
if (exists $customs->{$key}) {
my %k_custom = %{$customs->{$key}};
foreach my $k (qw(key_sort max_key_length customs)) {
$k_options{$k} = $k_custom{$k} if exists $k_custom{$k};
}
}
$yaml .= $indent . "$key:\n"
. _dump_hash(\%k_options, %$val);
}
else {
$yaml .= $indent . "$key: {}\n";
}
}
elsif (ref $val eq 'ARRAY') {
if( @$val ) {
$yaml .= $indent . "$key:\n";
for (@$val) {
croak "only nested arrays of non-refs are supported" if ref $_;
$yaml .= $indent . $options->{delta} . "- $_\n";
}
}
else {
$yaml .= $indent . "$key: []\n";
}
}
elsif( ref $val and !blessed($val) ) {
croak "only nested hashes, arrays and objects are supported";
}
else { # if it's an object, just stringify it
$yaml .= $indent . sprintf "$k_format %s\n", "$key:", $val;
}
};
return $yaml;
}
sub blessed {
return eval { $_[0]->isa("UNIVERSAL"); };
}
sub max {
return (sort { $b <=> $a } @_)[0];
}
sub min {
return (sort { $a <=> $b } @_)[0];
}
=head3 metafile_file
my $meta_yml = $mm->metafile_file(@metadata_pairs);
Turns the @metadata_pairs into YAML.
This method does not implement a complete YAML dumper, being limited
to dump a hash with values which are strings, undef's or nested hashes
and arrays of strings. No quoting/escaping is done.
=cut
sub metafile_file {
my $self = shift;
my %dump_options = (
use_header => 1,
delta => ' ' x 4,
key_sort => undef,
);
return _dump_hash(\%dump_options, @_);
}
=head3 distmeta_target
my $make_frag = $mm->distmeta_target;
Generates the distmeta target to add META.yml and META.json to the MANIFEST
in the distdir.
=cut
sub distmeta_target {
my $self = shift;
my @add_meta = (
$self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']),
exit unless -e q{META.yml};
eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) }
or die "Could not add META.yml to MANIFEST: ${'@'}"
CODE
$self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd'])
exit unless -f q{META.json};
eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) }
or die "Could not add META.json to MANIFEST: ${'@'}"
CODE
);
my @add_meta_to_distdir = map { $self->cd('$(DISTVNAME)', $_) } @add_meta;
return sprintf <<'MAKE', @add_meta_to_distdir;
distmeta : create_distdir metafile
$(NOECHO) %s
$(NOECHO) %s
MAKE
}
=head3 mymeta
my $mymeta = $mm->mymeta;
Generate MYMETA information as a hash either from an existing CPAN Meta file
(META.json or META.yml) or from internal data.
=cut
sub mymeta {
my $self = shift;
my $file = shift || ''; # for testing
my $mymeta = $self->_mymeta_from_meta($file);
my $v2 = 1;
unless ( $mymeta ) {
$mymeta = $self->metafile_data(
$self->{META_ADD} || {},
$self->{META_MERGE} || {},
);
$v2 = 0;
}
# Overwrite the non-configure dependency hashes
$self->_add_requirements_to_meta($mymeta);
$mymeta->{dynamic_config} = 0;
return $mymeta;
}
sub _mymeta_from_meta {
my $self = shift;
my $metafile = shift || ''; # for testing
return unless _has_cpan_meta();
my $meta;
for my $file ( $metafile, "META.json", "META.yml" ) {
next unless -e $file;
eval {
$meta = CPAN::Meta->load_file($file)->as_struct( { version => 2 } );
};
last if $meta;
}
return unless $meta;
# META.yml before 6.25_01 cannot be trusted. META.yml lived in the source directory.
# There was a good chance the author accidentally uploaded a stale META.yml if they
# rolled their own tarball rather than using "make dist".
if ($meta->{generated_by} &&
$meta->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
my $eummv = do { local $^W = 0; $1+0; };
if ($eummv < 6.2501) {
return;
}
}
return $meta;
}
=head3 write_mymeta
$self->write_mymeta( $mymeta );
Write MYMETA information to MYMETA.json and MYMETA.yml.
=cut
sub write_mymeta {
my $self = shift;
my $mymeta = shift;
return unless _has_cpan_meta();
my $meta_obj = $self->_fix_metadata_before_conversion( $mymeta );
$meta_obj->save( 'MYMETA.json', { version => "2.0" } );
$meta_obj->save( 'MYMETA.yml', { version => "1.4" } );
return 1;
}
=head3 realclean (o)
Defines the realclean target.
=cut
sub realclean {
my($self, %attribs) = @_;
my @dirs = qw($(DISTVNAME));
my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD));
# Special exception for the perl core where INST_* is not in blib.
# This cleans up the files built from the ext/ directory (all XS).
if( $self->{PERL_CORE} ) {
push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR));
push @files, values %{$self->{PM}};
}
if( $self->has_link_code ){
push @files, qw($(OBJECT));
}
if( $attribs{FILES} ) {
if( ref $attribs{FILES} ) {
push @dirs, @{ $attribs{FILES} };
}
else {
push @dirs, split /\s+/, $attribs{FILES};
}
}
# Occasionally files are repeated several times from different sources
{ my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; }
{ my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; }
my $rm_cmd = join "\n\t", map { "$_" }
$self->split_command('- $(RM_F)', @files);
my $rmf_cmd = join "\n\t", map { "$_" }
$self->split_command('- $(RM_RF)', @dirs);
my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd;
# Delete temporary files (via clean) and also delete dist files
realclean purge :: realclean_subdirs
%s
%s
MAKE
$m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP};
return $m;
}
=head3 realclean_subdirs_target
my $make_frag = $MM->realclean_subdirs_target;
Returns the realclean_subdirs target. This is used by the realclean
target to call realclean on any subdirectories which contain Makefiles.
=cut
sub realclean_subdirs_target {
my $self = shift;
my @m = <<'EOF';
# so clean is forced to complete before realclean_subdirs runs
realclean_subdirs : clean
EOF
return join '', @m, "\t\$(NOECHO) \$(NOOP)\n" unless @{$self->{DIR}};
foreach my $dir (@{$self->{DIR}}) {
foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) {
my $subrclean .= $self->oneliner(_sprintf562 <<'CODE', $dir, $makefile);
chdir '%1$s'; system '$(MAKE) $(USEMAKEFILE) %2$s realclean' if -f '%2$s';
CODE
push @m, "\t- $subrclean\n";
}
}
return join '', @m;
}
=head3 signature_target
my $target = $mm->signature_target;
Generate the signature target.
Writes the file SIGNATURE with "cpansign -s".
=cut
sub signature_target {
my $self = shift;
return <<'MAKE_FRAG';
signature :
cpansign -s
MAKE_FRAG
}
=head3 distsignature_target
my $make_frag = $mm->distsignature_target;
Generates the distsignature target to add SIGNATURE to the MANIFEST in the
distdir.
=cut
sub distsignature_target {
my $self = shift;
my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']);
eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) }
or die "Could not add SIGNATURE to MANIFEST: ${'@'}"
CODE
my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s');
# cpansign -s complains if SIGNATURE is in the MANIFEST yet does not
# exist
my $touch_sig = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE');
my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign );
return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist
distsignature : distmeta
$(NOECHO) %s
$(NOECHO) %s
%s
MAKE
}
=head3 special_targets
my $make_frag = $mm->special_targets
Returns a make fragment containing any targets which have special
meaning to make. For example, .SUFFIXES and .PHONY.
=cut
sub special_targets {
my $make_frag = <<'MAKE_FRAG';
.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT)
.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static
MAKE_FRAG
$make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT};
.NO_CONFIG_REC: Makefile
MAKE_FRAG
return $make_frag;
}
=head2 Init methods
Methods which help initialize the MakeMaker object and macros.
=head3 init_ABSTRACT
$mm->init_ABSTRACT
=cut
sub init_ABSTRACT {
my $self = shift;
if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) {
warn "Both ABSTRACT_FROM and ABSTRACT are set. ".
"Ignoring ABSTRACT_FROM.\n";
return;
}
if ($self->{ABSTRACT_FROM}){
$self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or
carp "WARNING: Setting ABSTRACT via file ".
"'$self->{ABSTRACT_FROM}' failed\n";
}
if ($self->{ABSTRACT} && $self->{ABSTRACT} =~ m![[:cntrl:]]+!) {
warn "WARNING: ABSTRACT contains control character(s),".
" they will be removed\n";
$self->{ABSTRACT} =~ s![[:cntrl:]]+!!g;
return;
}
}
=head3 init_INST
$mm->init_INST;
Called by init_main. Sets up all INST_* variables except those related
to XS code. Those are handled in init_xs.
=cut
sub init_INST {
my($self) = shift;
$self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch");
$self->{INST_BIN} ||= $self->catdir($Curdir,'blib','bin');
# INST_LIB typically pre-set if building an extension after
# perl has been built and installed. Setting INST_LIB allows
# you to build directly into, say $Config{privlibexp}.
unless ($self->{INST_LIB}){
if ($self->{PERL_CORE}) {
$self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB};
} else {
$self->{INST_LIB} = $self->catdir($Curdir,"blib","lib");
}
}
my @parentdir = split(/::/, $self->{PARENT_NAME});
$self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)', @parentdir);
$self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)', @parentdir);
$self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)', 'auto',
'$(FULLEXT)');
$self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto',
'$(FULLEXT)');
$self->{INST_SCRIPT} ||= $self->catdir($Curdir,'blib','script');
$self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1');
$self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3');
return 1;
}
=head3 init_INSTALL
$mm->init_INSTALL;
Called by init_main. Sets up all INSTALL_* variables (except
INSTALLDIRS) and *PREFIX.
=cut
sub init_INSTALL {
my($self) = shift;
if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) {
die "Only one of PREFIX or INSTALL_BASE can be given. Not both.\n";
}
if( $self->{ARGS}{INSTALL_BASE} ) {
$self->init_INSTALL_from_INSTALL_BASE;
}
else {
$self->init_INSTALL_from_PREFIX;
}
}
=head3 init_INSTALL_from_PREFIX
$mm->init_INSTALL_from_PREFIX;
=cut
sub init_INSTALL_from_PREFIX {
my $self = shift;
$self->init_lib2arch;
# There are often no Config.pm defaults for these new man variables so
# we fall back to the old behavior which is to use installman*dir
foreach my $num (1, 3) {
my $k = 'installsiteman'.$num.'dir';
$self->{uc $k} ||= uc "\$(installman${num}dir)"
unless $Config{$k};
}
foreach my $num (1, 3) {
my $k = 'installvendorman'.$num.'dir';
unless( $Config{$k} ) {
$self->{uc $k} ||= $Config{usevendorprefix}
? uc "\$(installman${num}dir)"
: '';
}
}
$self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)'
unless $Config{installsitebin};
$self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)'
unless $Config{installsitescript};
unless( $Config{installvendorbin} ) {
$self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix}
? $Config{installbin}
: '';
}
unless( $Config{installvendorscript} ) {
$self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix}
? $Config{installscript}
: '';
}
my $iprefix = $Config{installprefixexp} || $Config{installprefix} ||
$Config{prefixexp} || $Config{prefix} || '';
my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : '';
my $sprefix = $Config{siteprefixexp} || '';
# 5.005_03 doesn't have a siteprefix.
$sprefix = $iprefix unless $sprefix;
$self->{PREFIX} ||= '';
if( $self->{PREFIX} ) {
@{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} =
('$(PREFIX)') x 3;
}
else {
$self->{PERLPREFIX} ||= $iprefix;
$self->{SITEPREFIX} ||= $sprefix;
$self->{VENDORPREFIX} ||= $vprefix;
# Lots of MM extension authors like to use $(PREFIX) so we
# put something sensible in there no matter what.
$self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)';
}
my $arch = $Config{archname};
my $version = $Config{version};
# default style
my $libstyle = $Config{installstyle} || 'lib/perl5';
my $manstyle = '';
if( $self->{LIBSTYLE} ) {
$libstyle = $self->{LIBSTYLE};
$manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : '';
}
# Some systems, like VOS, set installman*dir to '' if they can't
# read man pages.
for my $num (1, 3) {
$self->{'INSTALLMAN'.$num.'DIR'} ||= 'none'
unless $Config{'installman'.$num.'dir'};
}
my %bin_layouts =
(
bin => { s => $iprefix,
t => 'perl',
d => 'bin' },
vendorbin => { s => $vprefix,
t => 'vendor',
d => 'bin' },
sitebin => { s => $sprefix,
t => 'site',
d => 'bin' },
script => { s => $iprefix,
t => 'perl',
d => 'bin' },
vendorscript=> { s => $vprefix,
t => 'vendor',
d => 'bin' },
sitescript => { s => $sprefix,
t => 'site',
d => 'bin' },
);
my %man_layouts =
(
man1dir => { s => $iprefix,
t => 'perl',
d => 'man/man1',
style => $manstyle, },
siteman1dir => { s => $sprefix,
t => 'site',
d => 'man/man1',
style => $manstyle, },
vendorman1dir => { s => $vprefix,
t => 'vendor',
d => 'man/man1',
style => $manstyle, },
man3dir => { s => $iprefix,
t => 'perl',
d => 'man/man3',
style => $manstyle, },
siteman3dir => { s => $sprefix,
t => 'site',
d => 'man/man3',
style => $manstyle, },
vendorman3dir => { s => $vprefix,
t => 'vendor',
d => 'man/man3',
style => $manstyle, },
);
my %lib_layouts =
(
privlib => { s => $iprefix,
t => 'perl',
d => '',
style => $libstyle, },
vendorlib => { s => $vprefix,
t => 'vendor',
d => '',
style => $libstyle, },
sitelib => { s => $sprefix,
t => 'site',
d => 'site_perl',
style => $libstyle, },
archlib => { s => $iprefix,
t => 'perl',
d => "$version/$arch",
style => $libstyle },
vendorarch => { s => $vprefix,
t => 'vendor',
d => "$version/$arch",
style => $libstyle },
sitearch => { s => $sprefix,
t => 'site',
d => "site_perl/$version/$arch",
style => $libstyle },
);
# Special case for LIB.
if( $self->{LIB} ) {
foreach my $var (keys %lib_layouts) {
my $Installvar = uc "install$var";
if( $var =~ /arch/ ) {
$self->{$Installvar} ||=
$self->catdir($self->{LIB}, $Config{archname});
}
else {
$self->{$Installvar} ||= $self->{LIB};
}
}
}
my %type2prefix = ( perl => 'PERLPREFIX',
site => 'SITEPREFIX',
vendor => 'VENDORPREFIX'
);
my %layouts = (%bin_layouts, %man_layouts, %lib_layouts);
while( my($var, $layout) = each(%layouts) ) {
my($s, $t, $d, $style) = @{$layout}{qw(s t d style)};
my $r = '$('.$type2prefix{$t}.')';
warn "Prefixing $var\n" if $Verbose >= 2;
my $installvar = "install$var";
my $Installvar = uc $installvar;
next if $self->{$Installvar};
$d = "$style/$d" if $style;
$self->prefixify($installvar, $s, $r, $d);
warn " $Installvar == $self->{$Installvar}\n"
if $Verbose >= 2;
}
# Generate these if they weren't figured out.
$self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH};
$self->{VENDORLIBEXP} ||= $self->{INSTALLVENDORLIB};
return 1;
}
=head3 init_from_INSTALL_BASE
$mm->init_from_INSTALL_BASE
=cut
my %map = (
lib => [qw(lib perl5)],
arch => [('lib', 'perl5', $Config{archname})],
bin => [qw(bin)],
man1dir => [qw(man man1)],
man3dir => [qw(man man3)]
);
$map{script} = $map{bin};
sub init_INSTALL_from_INSTALL_BASE {
my $self = shift;
@{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} =
'$(INSTALL_BASE)';
my %install;
foreach my $thing (keys %map) {
foreach my $dir (('', 'SITE', 'VENDOR')) {
my $uc_thing = uc $thing;
my $key = "INSTALL".$dir.$uc_thing;
$install{$key} ||=
$self->catdir('$(INSTALL_BASE)', @{$map{$thing}});
}
}
# Adjust for variable quirks.
$install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH};
$install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB};
foreach my $key (keys %install) {
$self->{$key} ||= $install{$key};
}
return 1;
}
=head3 init_VERSION I<Abstract>
$mm->init_VERSION
Initialize macros representing versions of MakeMaker and other tools
MAKEMAKER: path to the MakeMaker module.
MM_VERSION: ExtUtils::MakeMaker Version
MM_REVISION: ExtUtils::MakeMaker version control revision (for backwards
compat)
VERSION: version of your module
VERSION_MACRO: which macro represents the version (usually 'VERSION')
VERSION_SYM: like version but safe for use as an RCS revision number
DEFINE_VERSION: -D line to set the module version when compiling
XS_VERSION: version in your .xs file. Defaults to $(VERSION)
XS_VERSION_MACRO: which macro represents the XS version.
XS_DEFINE_VERSION: -D line to set the xs version when compiling.
Called by init_main.
=cut
sub init_VERSION {
my($self) = shift;
$self->{MAKEMAKER} = $ExtUtils::MakeMaker::Filename;
$self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION;
$self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision;
$self->{VERSION_FROM} ||= '';
if ($self->{VERSION_FROM}){
$self->{VERSION} = $self->parse_version($self->{VERSION_FROM});
if( $self->{VERSION} eq 'undef' ) {
carp("WARNING: Setting VERSION via file ".
"'$self->{VERSION_FROM}' failed\n");
}
}
if (defined $self->{VERSION}) {
if ( $self->{VERSION} !~ /^\s*v?[\d_\.]+\s*$/ ) {
require version;
my $normal = eval { version->new( $self->{VERSION} ) };
$self->{VERSION} = $normal if defined $normal;
}
$self->{VERSION} =~ s/^\s+//;
$self->{VERSION} =~ s/\s+$//;
}
else {
$self->{VERSION} = '';
}
$self->{VERSION_MACRO} = 'VERSION';
($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g;
$self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"';
# Graham Barr and Paul Marquess had some ideas how to ensure
# version compatibility between the *.pm file and the
# corresponding *.xs file. The bottom line was, that we need an
# XS_VERSION macro that defaults to VERSION:
$self->{XS_VERSION} ||= $self->{VERSION};
$self->{XS_VERSION_MACRO} = 'XS_VERSION';
$self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"';
}
=head3 init_tools
$MM->init_tools();
Initializes the simple macro definitions used by tools_other() and
places them in the $MM object. These use conservative cross platform
versions and should be overridden with platform specific versions for
performance.
Defines at least these macros.
Macro Description
NOOP Do nothing
NOECHO Tell make not to display the command itself
SHELL Program used to run shell commands
ECHO Print text adding a newline on the end
RM_F Remove a file
RM_RF Remove a directory
TOUCH Update a file's timestamp
TEST_F Test for a file's existence
TEST_S Test the size of a file
CP Copy a file
CP_NONEMPTY Copy a file if it is not empty
MV Move a file
CHMOD Change permissions on a file
FALSE Exit with non-zero
TRUE Exit with zero
UMASK_NULL Nullify umask
DEV_NULL Suppress all command output
=cut
sub init_tools {
my $self = shift;
$self->{ECHO} ||= $self->oneliner('binmode STDOUT, qq{:raw}; print qq{@ARGV}', ['-l']);
$self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}');
$self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]);
$self->{CHMOD} ||= $self->oneliner('chmod', ["-MExtUtils::Command"]);
$self->{RM_F} ||= $self->oneliner('rm_f', ["-MExtUtils::Command"]);
$self->{RM_RF} ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]);
$self->{TEST_F} ||= $self->oneliner('test_f', ["-MExtUtils::Command"]);
$self->{TEST_S} ||= $self->oneliner('test_s', ["-MExtUtils::Command::MM"]);
$self->{CP_NONEMPTY} ||= $self->oneliner('cp_nonempty', ["-MExtUtils::Command::MM"]);
$self->{FALSE} ||= $self->oneliner('exit 1');
$self->{TRUE} ||= $self->oneliner('exit 0');
$self->{MKPATH} ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]);
$self->{CP} ||= $self->oneliner('cp', ["-MExtUtils::Command"]);
$self->{MV} ||= $self->oneliner('mv', ["-MExtUtils::Command"]);
$self->{MOD_INSTALL} ||=
$self->oneliner(<<'CODE', ['-MExtUtils::Install']);
install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE
$self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]);
$self->{UNINSTALL} ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]);
$self->{WARN_IF_OLD_PACKLIST} ||=
$self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]);
$self->{FIXIN} ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]);
$self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]);
$self->{UNINST} ||= 0;
$self->{VERBINST} ||= 0;
$self->{SHELL} ||= $Config{sh};
# UMASK_NULL is not used by MakeMaker but some CPAN modules
# make use of it.
$self->{UMASK_NULL} ||= "umask 0";
# Not the greatest default, but its something.
$self->{DEV_NULL} ||= "> /dev/null 2>&1";
$self->{NOOP} ||= '$(TRUE)';
$self->{NOECHO} = '@' unless defined $self->{NOECHO};
$self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE} || 'Makefile';
$self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
$self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old';
$self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl';
# Not everybody uses -f to indicate "use this Makefile instead"
$self->{USEMAKEFILE} ||= '-f';
# Some makes require a wrapper around macros passed in on the command
# line.
$self->{MACROSTART} ||= '';
$self->{MACROEND} ||= '';
return;
}
=head3 init_others
$MM->init_others();
Initializes the macro definitions having to do with compiling and
linking used by tools_other() and places them in the $MM object.
If there is no description, its the same as the parameter to
WriteMakefile() documented in ExtUtils::MakeMaker.
=cut
sub init_others {
my $self = shift;
$self->{LD_RUN_PATH} = "";
$self->{LIBS} = $self->_fix_libs($self->{LIBS});
# Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS}
foreach my $libs ( @{$self->{LIBS}} ){
$libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace
my(@libs) = $self->extliblist($libs);
if ($libs[0] or $libs[1] or $libs[2]){
# LD_RUN_PATH now computed by ExtUtils::Liblist
($self->{EXTRALIBS}, $self->{BSLOADLIBS},
$self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs;
last;
}
}
if ( $self->{OBJECT} ) {
$self->{OBJECT} = join(" ", @{$self->{OBJECT}}) if ref $self->{OBJECT};
$self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
} elsif ( ($self->{MAGICXS} || $self->{XSMULTI}) && @{$self->{O_FILES}||[]} ) {
$self->{OBJECT} = join(" ", @{$self->{O_FILES}});
$self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
} else {
# init_dirscan should have found out, if we have C files
$self->{OBJECT} = "";
$self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]};
}
$self->{OBJECT} =~ s/\n+/ \\\n\t/g;
$self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : "";
$self->{PERLMAINCC} ||= '$(CC)';
$self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM};
# Sanity check: don't define LINKTYPE = dynamic if we're skipping
# the 'dynamic' section of MM. We don't have this problem with
# 'static', since we either must use it (%Config says we can't
# use dynamic loading) or the caller asked for it explicitly.
if (!$self->{LINKTYPE}) {
$self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'}
? 'static'
: ($Config{usedl} ? 'dynamic' : 'static');
}
return;
}
# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or
# undefined. In any case we turn it into an anon array
sub _fix_libs {
my($self, $libs) = @_;
return !defined $libs ? [''] :
!ref $libs ? [$libs] :
!defined $libs->[0] ? [''] :
$libs ;
}
=head3 tools_other
my $make_frag = $MM->tools_other;
Returns a make fragment containing definitions for the macros init_others()
initializes.
=cut
sub tools_other {
my($self) = shift;
my @m;
# We set PM_FILTER as late as possible so it can see all the earlier
# on macro-order sensitive makes such as nmake.
for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH
UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP
FALSE TRUE
ECHO ECHO_N
UNINST VERBINST
MOD_INSTALL DOC_INSTALL UNINSTALL
WARN_IF_OLD_PACKLIST
MACROSTART MACROEND
USEMAKEFILE
PM_FILTER
FIXIN
CP_NONEMPTY
} )
{
next unless defined $self->{$tool};
push @m, "$tool = $self->{$tool}\n";
}
return join "", @m;
}
=head3 init_DIRFILESEP I<Abstract>
$MM->init_DIRFILESEP;
my $dirfilesep = $MM->{DIRFILESEP};
Initializes the DIRFILESEP macro which is the separator between the
directory and filename in a filepath. ie. / on Unix, \ on Win32 and
nothing on VMS.
For example:
# instead of $(INST_ARCHAUTODIR)/extralibs.ld
$(INST_ARCHAUTODIR)$(DIRFILESEP)extralibs.ld
Something of a hack but it prevents a lot of code duplication between
MM_* variants.
Do not use this as a separator between directories. Some operating
systems use different separators between subdirectories as between
directories and filenames (for example: VOLUME:[dir1.dir2]file on VMS).
=head3 init_linker I<Abstract>
$mm->init_linker;
Initialize macros which have to do with linking.
PERL_ARCHIVE: path to libperl.a equivalent to be linked to dynamic
extensions.
PERL_ARCHIVE_AFTER: path to a library which should be put on the
linker command line I<after> the external libraries to be linked to
dynamic extensions. This may be needed if the linker is one-pass, and
Perl includes some overrides for C RTL functions, such as malloc().
EXPORT_LIST: name of a file that is passed to linker to define symbols
to be exported.
Some OSes do not need these in which case leave it blank.
=head3 init_platform
$mm->init_platform
Initialize any macros which are for platform specific use only.
A typical one is the version number of your OS specific module.
(ie. MM_Unix_VERSION or MM_VMS_VERSION).
=cut
sub init_platform {
return '';
}
=head3 init_MAKE
$mm->init_MAKE
Initialize MAKE from either a MAKE environment variable or $Config{make}.
=cut
sub init_MAKE {
my $self = shift;
$self->{MAKE} ||= $ENV{MAKE} || $Config{make};
}
=head2 Tools
A grab bag of methods to generate specific macros and commands.
=head3 manifypods
Defines targets and routines to translate the pods into manpages and
put them into the INST_* directories.
=cut
sub manifypods {
my $self = shift;
my $POD2MAN_macro = $self->POD2MAN_macro();
my $manifypods_target = $self->manifypods_target();
return <<END_OF_TARGET;
$POD2MAN_macro
$manifypods_target
END_OF_TARGET
}
=head3 POD2MAN_macro
my $pod2man_macro = $self->POD2MAN_macro
Returns a definition for the POD2MAN macro. This is a program
which emulates the pod2man utility. You can add more switches to the
command by simply appending them on the macro.
Typical usage:
$(POD2MAN) --section=3 --perm_rw=$(PERM_RW) podfile1 man_page1 ...
=cut
sub POD2MAN_macro {
my $self = shift;
# Need the trailing '--' so perl stops gobbling arguments and - happens
# to be an alternative end of line separator on VMS so we quote it
return <<'END_OF_DEF';
POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--"
POD2MAN = $(POD2MAN_EXE)
END_OF_DEF
}
=head3 test_via_harness
my $command = $mm->test_via_harness($perl, $tests);
Returns a $command line which runs the given set of $tests with
Test::Harness and the given $perl.
Used on the t/*.t files.
=cut
sub test_via_harness {
my($self, $perl, $tests) = @_;
return qq{\t$perl "-MExtUtils::Command::MM" "-MTest::Harness" }.
qq{"-e" "undef *Test::Harness::Switches; test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
}
=head3 test_via_script
my $command = $mm->test_via_script($perl, $script);
Returns a $command line which just runs a single test without
Test::Harness. No checks are done on the results, they're just
printed.
Used for test.pl, since they don't always follow Test::Harness
formatting.
=cut
sub test_via_script {
my($self, $perl, $script) = @_;
return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n};
}
=head3 tool_autosplit
Defines a simple perl call that runs autosplit. May be deprecated by
pm_to_blib soon.
=cut
sub tool_autosplit {
my($self, %attribs) = @_;
my $maxlen = $attribs{MAXLEN} ? '$$AutoSplit::Maxlen=$attribs{MAXLEN};'
: '';
my $asplit = $self->oneliner(sprintf <<'PERL_CODE', $maxlen);
use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)
PERL_CODE
return sprintf <<'MAKE_FRAG', $asplit;
# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
AUTOSPLITFILE = %s
MAKE_FRAG
}
=head3 arch_check
my $arch_ok = $mm->arch_check(
$INC{"Config.pm"},
File::Spec->catfile($Config{archlibexp}, "Config.pm")
);
A sanity check that what Perl thinks the architecture is and what
Config thinks the architecture is are the same. If they're not it
will return false and show a diagnostic message.
When building Perl it will always return true, as nothing is installed
yet.
The interface is a bit odd because this is the result of a
quick refactoring. Don't rely on it.
=cut
sub arch_check {
my $self = shift;
my($pconfig, $cconfig) = @_;
return 1 if $self->{PERL_SRC};
my($pvol, $pthinks) = $self->splitpath($pconfig);
my($cvol, $cthinks) = $self->splitpath($cconfig);
$pthinks = $self->canonpath($pthinks);
$cthinks = $self->canonpath($cthinks);
my $ret = 1;
if ($pthinks ne $cthinks) {
print "Have $pthinks\n";
print "Want $cthinks\n";
$ret = 0;
my $arch = (grep length, $self->splitdir($pthinks))[-1];
print <<END unless $self->{UNINSTALLED_PERL};
Your perl and your Config.pm seem to have different ideas about the
architecture they are running on.
Perl thinks: [$arch]
Config says: [$Config{archname}]
This may or may not cause problems. Please check your installation of perl
if you have problems building this extension.
END
}
return $ret;
}
=head2 File::Spec wrappers
ExtUtils::MM_Any is a subclass of File::Spec. The methods noted here
override File::Spec.
=head3 catfile
File::Spec <= 0.83 has a bug where the file part of catfile is not
canonicalized. This override fixes that bug.
=cut
sub catfile {
my $self = shift;
return $self->canonpath($self->SUPER::catfile(@_));
}
=head2 Misc
Methods I can't really figure out where they should go yet.
=head3 find_tests
my $test = $mm->find_tests;
Returns a string suitable for feeding to the shell to return all
tests in t/*.t.
=cut
sub find_tests {
my($self) = shift;
return -d 't' ? 't/*.t' : '';
}
=head3 find_tests_recursive
my $tests = $mm->find_tests_recursive;
Returns a string suitable for feeding to the shell to return all
tests in t/ but recursively. Equivalent to
my $tests = $mm->find_tests_recursive_in('t');
=cut
sub find_tests_recursive {
my $self = shift;
return $self->find_tests_recursive_in('t');
}
=head3 find_tests_recursive_in
my $tests = $mm->find_tests_recursive_in($dir);
Returns a string suitable for feeding to the shell to return all
tests in $dir recursively.
=cut
sub find_tests_recursive_in {
my($self, $dir) = @_;
return '' unless -d $dir;
require File::Find;
my $base_depth = grep { $_ ne '' } File::Spec->splitdir( (File::Spec->splitpath($dir))[1] );
my %depths;
my $wanted = sub {
return unless m!\.t$!;
my ($volume,$directories,$file) =
File::Spec->splitpath( $File::Find::name );
my $depth = grep { $_ ne '' } File::Spec->splitdir( $directories );
$depth -= $base_depth;
$depths{ $depth } = 1;
};
File::Find::find( $wanted, $dir );
return join ' ',
map { $dir . '/*' x $_ . '.t' }
sort { $a <=> $b }
keys %depths;
}
=head3 extra_clean_files
my @files_to_clean = $MM->extra_clean_files;
Returns a list of OS specific files to be removed in the clean target in
addition to the usual set.
=cut
# An empty method here tickled a perl 5.8.1 bug and would return its object.
sub extra_clean_files {
return;
}
=head3 installvars
my @installvars = $mm->installvars;
A list of all the INSTALL* variables without the INSTALL prefix. Useful
for iteration or building related variable sets.
=cut
sub installvars {
return qw(PRIVLIB SITELIB VENDORLIB
ARCHLIB SITEARCH VENDORARCH
BIN SITEBIN VENDORBIN
SCRIPT SITESCRIPT VENDORSCRIPT
MAN1DIR SITEMAN1DIR VENDORMAN1DIR
MAN3DIR SITEMAN3DIR VENDORMAN3DIR
);
}
=head3 libscan
my $wanted = $self->libscan($path);
Takes a path to a file or dir and returns an empty string if we don't
want to include this file in the library. Otherwise it returns the
the $path unchanged.
Mainly used to exclude version control administrative directories
and base-level F<README.pod> from installation.
=cut
sub libscan {
my($self,$path) = @_;
if ($path =~ m<^README\.pod$>i) {
warn "WARNING: Older versions of ExtUtils::MakeMaker may errantly install $path as part of this distribution. It is recommended to avoid using this path in CPAN modules.\n"
unless $ENV{PERL_CORE};
return '';
}
my($dirs,$file) = ($self->splitpath($path))[1,2];
return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/,
$self->splitdir($dirs), $file;
return $path;
}
=head3 platform_constants
my $make_frag = $mm->platform_constants
Returns a make fragment defining all the macros initialized in
init_platform() rather than put them in constants().
=cut
sub platform_constants {
return '';
}
=head3 post_constants (o)
Returns an empty string per default. Dedicated to overrides from
within Makefile.PL after all constants have been defined.
=cut
sub post_constants {
"";
}
=head3 post_initialize (o)
Returns an empty string per default. Used in Makefile.PLs to add some
chunk of text to the Makefile after the object is initialized.
=cut
sub post_initialize {
"";
}
=head3 postamble (o)
Returns an empty string. Can be used in Makefile.PLs to write some
text to the Makefile at the end.
=cut
sub postamble {
"";
}
=begin private
=head3 _PREREQ_PRINT
$self->_PREREQ_PRINT;
Implements PREREQ_PRINT.
Refactored out of MakeMaker->new().
=end private
=cut
sub _PREREQ_PRINT {
my $self = shift;
require Data::Dumper;
my @what = ('PREREQ_PM');
push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION};
push @what, 'BUILD_REQUIRES' if $self->{BUILD_REQUIRES};
print Data::Dumper->Dump([@{$self}{@what}], \@what);
exit 0;
}
=begin private
=head3 _PRINT_PREREQ
$mm->_PRINT_PREREQ;
Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT
added by Redhat to, I think, support generating RPMs from Perl modules.
Should not include BUILD_REQUIRES as RPMs do not include them.
Refactored out of MakeMaker->new().
=end private
=cut
sub _PRINT_PREREQ {
my $self = shift;
my $prereqs= $self->{PREREQ_PM};
my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs;
if ( $self->{MIN_PERL_VERSION} ) {
push @prereq, ['perl' => $self->{MIN_PERL_VERSION}];
}
print join(" ", map { "perl($_->[0])>=$_->[1] " }
sort { $a->[0] cmp $b->[0] } @prereq), "\n";
exit 0;
}
=begin private
=head3 _perl_header_files
my $perl_header_files= $self->_perl_header_files;
returns a sorted list of header files as found in PERL_SRC or $archlibexp/CORE.
Used by perldepend() in MM_Unix and MM_VMS via _perl_header_files_fragment()
=end private
=cut
sub _perl_header_files {
my $self = shift;
my $header_dir = $self->{PERL_SRC} || $ENV{PERL_SRC} || $self->catdir($Config{archlibexp}, 'CORE');
opendir my $dh, $header_dir
or die "Failed to opendir '$header_dir' to find header files: $!";
# we need to use a temporary here as the sort in scalar context would have undefined results.
my @perl_headers= sort grep { /\.h\z/ } readdir($dh);
closedir $dh;
return @perl_headers;
}
=begin private
=head3 _perl_header_files_fragment ($o, $separator)
my $perl_header_files_fragment= $self->_perl_header_files_fragment("/");
return a Makefile fragment which holds the list of perl header files which
XS code depends on $(PERL_INC), and sets up the dependency for the $(OBJECT) file.
The $separator argument defaults to "". MM_VMS will set it to "" and MM_UNIX to "/"
in perldepend(). This reason child subclasses need to control this is that in
VMS the $(PERL_INC) directory will already have delimiters in it, but in
UNIX $(PERL_INC) will need a slash between it an the filename. Hypothetically
win32 could use "\\" (but it doesn't need to).
=end private
=cut
sub _perl_header_files_fragment {
my ($self, $separator)= @_;
$separator ||= "";
return join("\\\n",
"PERL_HDRS = ",
map {
sprintf( " \$(PERL_INCDEP)%s%s ", $separator, $_ )
} $self->_perl_header_files()
) . "\n\n"
. "\$(OBJECT) : \$(PERL_HDRS)\n";
}
=head1 AUTHOR
Michael G Schwern <[email protected]> and the denizens of
[email protected] with code from ExtUtils::MM_Unix and
ExtUtils::MM_Win32.
=cut
1;
EXTUTILS_MM_ANY
$fatpacked{"ExtUtils/MM_BeOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_BEOS';
package ExtUtils::MM_BeOS;
use strict;
=head1 NAME
ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_BeOS; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=over 4
=cut
use ExtUtils::MakeMaker::Config;
use File::Spec;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
our $VERSION = '7.34';
$VERSION = eval $VERSION;
=item os_flavor
BeOS is BeOS.
=cut
sub os_flavor {
return('BeOS');
}
=item init_linker
libperl.a equivalent to be linked to dynamic extensions.
=cut
sub init_linker {
my($self) = shift;
$self->{PERL_ARCHIVE} ||=
File::Spec->catdir('$(PERL_INC)',$Config{libperl});
$self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
=back
1;
__END__
EXTUTILS_MM_BEOS
$fatpacked{"ExtUtils/MM_Cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_CYGWIN';
package ExtUtils::MM_Cygwin;
use strict;
use ExtUtils::MakeMaker::Config;
use File::Spec;
require ExtUtils::MM_Unix;
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );
our $VERSION = '7.34';
$VERSION = eval $VERSION;
=head1 NAME
ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_Cygwin; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided there.
=over 4
=item os_flavor
We're Unix and Cygwin.
=cut
sub os_flavor {
return('Unix', 'Cygwin');
}
=item cflags
if configured for dynamic loading, triggers #define EXT in EXTERN.h
=cut
sub cflags {
my($self,$libperl)=@_;
return $self->{CFLAGS} if $self->{CFLAGS};
return '' unless $self->needs_linking();
my $base = $self->SUPER::cflags($libperl);
foreach (split /\n/, $base) {
/^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
};
$self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true');
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};
}
=item replace_manpage_separator
replaces strings '::' with '.' in MAN*POD man page names
=cut
sub replace_manpage_separator {
my($self, $man) = @_;
$man =~ s{/+}{.}g;
return $man;
}
=item init_linker
points to libperl.a
=cut
sub init_linker {
my $self = shift;
if ($Config{useshrplib} eq 'true') {
my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}";
if( $] >= 5.006002 ) {
$libperl =~ s/(dll\.)?a$/dll.a/;
}
$self->{PERL_ARCHIVE} = $libperl;
} else {
$self->{PERL_ARCHIVE} =
'$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a");
}
$self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
=item maybe_command
Determine whether a file is native to Cygwin by checking whether it
resides inside the Cygwin installation (using Windows paths). If so,
use C<ExtUtils::MM_Unix> to determine if it may be a command.
Otherwise use the tests from C<ExtUtils::MM_Win32>.
=cut
sub maybe_command {
my ($self, $file) = @_;
my $cygpath = Cygwin::posix_to_win_path('/', 1);
my $filepath = Cygwin::posix_to_win_path($file, 1);
return (substr($filepath,0,length($cygpath)) eq $cygpath)
? $self->SUPER::maybe_command($file) # Unix
: ExtUtils::MM_Win32->maybe_command($file); # Win32
}
=item dynamic_lib
Use the default to produce the *.dll's.
But for new archdir dll's use the same rebase address if the old exists.
=cut
sub dynamic_lib {
my($self, %attribs) = @_;
my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs);
return '' unless $s;
return $s unless %{$self->{XS}};
# do an ephemeral rebase so the new DLL fits to the current rebase map
$s .= "\t/bin/find \$\(INST_ARCHLIB\)/auto -xdev -name \\*.$self->{DLEXT} | /bin/rebase -sOT -" if (( $Config{myarchname} eq 'i686-cygwin' ) and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} ));
$s;
}
=item install
Rebase dll's with the global rebase database after installation.
=cut
sub install {
my($self, %attribs) = @_;
my $s = ExtUtils::MM_Unix::install($self, %attribs);
return '' unless $s;
return $s unless %{$self->{XS}};
my $INSTALLDIRS = $self->{INSTALLDIRS};
my $INSTALLLIB = $self->{"INSTALL". ($INSTALLDIRS eq 'perl' ? 'ARCHLIB' : uc($INSTALLDIRS)."ARCH")};
my $dop = "\$\(DESTDIR\)$INSTALLLIB/auto/";
my $dll = "$dop/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}";
$s =~ s|^(pure_install :: pure_\$\(INSTALLDIRS\)_install\n\t)\$\(NOECHO\) \$\(NOOP\)\n|$1\$(CHMOD) \$(PERM_RWX) $dll\n\t/bin/find $dop -xdev -name \\*.$self->{DLEXT} \| /bin/rebase -sOT -\n|m if (( $Config{myarchname} eq 'i686-cygwin') and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} ));
$s;
}
=item all_target
Build man pages, too
=cut
sub all_target {
ExtUtils::MM_Unix::all_target(shift);
}
=back
=cut
1;
EXTUTILS_MM_CYGWIN
$fatpacked{"ExtUtils/MM_DOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_DOS';
package ExtUtils::MM_DOS;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
=head1 NAME
ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality
for DOS.
Unless otherwise stated, it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=over 4
=item os_flavor
=cut
sub os_flavor {
return('DOS');
}
=item B<replace_manpage_separator>
Generates Foo__Bar.3 style man page names
=cut
sub replace_manpage_separator {
my($self, $man) = @_;
$man =~ s,/+,__,g;
return $man;
}
=item xs_static_lib_is_xs
=cut
sub xs_static_lib_is_xs {
return 1;
}
=back
=head1 AUTHOR
Michael G Schwern <[email protected]> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MM_Unix>, L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_DOS
$fatpacked{"ExtUtils/MM_Darwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_DARWIN';
package ExtUtils::MM_Darwin;
use strict;
BEGIN {
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Unix );
}
our $VERSION = '7.34';
$VERSION = eval $VERSION;
=head1 NAME
ExtUtils::MM_Darwin - special behaviors for OS X
=head1 SYNOPSIS
For internal MakeMaker use only
=head1 DESCRIPTION
See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documentation on the
methods overridden here.
=head2 Overridden Methods
=head3 init_dist
Turn off Apple tar's tendency to copy resource forks as "._foo" files.
=cut
sub init_dist {
my $self = shift;
# Thank you, Apple, for breaking tar and then breaking the work around.
# 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants
# COPYFILE_DISABLE. I'm not going to push my luck and instead just
# set both.
$self->{TAR} ||=
'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar';
$self->SUPER::init_dist(@_);
}
1;
EXTUTILS_MM_DARWIN
$fatpacked{"ExtUtils/MM_MacOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_MACOS';
package ExtUtils::MM_MacOS;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
sub new {
die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker';
}
=head1 NAME
ExtUtils::MM_MacOS - once produced Makefiles for MacOS Classic
=head1 SYNOPSIS
# MM_MacOS no longer contains any code. This is just a stub.
=head1 DESCRIPTION
Once upon a time, MakeMaker could produce an approximation of a correct
Makefile on MacOS Classic (MacPerl). Due to a lack of maintainers, this
fell out of sync with the rest of MakeMaker and hadn't worked in years.
Since there's little chance of it being repaired, MacOS Classic is fading
away, and the code was icky to begin with, the code has been deleted to
make maintenance easier.
Anyone interested in resurrecting this file should pull the old version
from the MakeMaker CVS repository and contact [email protected].
=cut
1;
EXTUTILS_MM_MACOS
$fatpacked{"ExtUtils/MM_NW5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_NW5';
package ExtUtils::MM_NW5;
=head1 NAME
ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=over
=cut
use strict;
use ExtUtils::MakeMaker::Config;
use File::Basename;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
use ExtUtils::MakeMaker qw(&neatvalue &_sprintf562);
$ENV{EMXSHELL} = 'sh'; # to run `commands`
my $BORLAND = $Config{'cc'} =~ /\bbcc/i;
my $GCC = $Config{'cc'} =~ /\bgcc/i;
=item os_flavor
We're Netware in addition to being Windows.
=cut
sub os_flavor {
my $self = shift;
return ($self->SUPER::os_flavor, 'Netware');
}
=item init_platform
Add Netware macros.
LIBPTH, BASE_IMPORT, NLM_VERSION, MPKTOOL, TOOLPATH, BOOT_SYMBOL,
NLM_SHORT_NAME, INCLUDE, PATH, MM_NW5_REVISION
=item platform_constants
Add Netware macros initialized above to the Makefile.
=cut
sub init_platform {
my($self) = shift;
# To get Win32's setup.
$self->SUPER::init_platform;
# incpath is copied to makefile var INCLUDE in constants sub, here just
# make it empty
my $libpth = $Config{'libpth'};
$libpth =~ s( )(;);
$self->{'LIBPTH'} = $libpth;
$self->{'BASE_IMPORT'} = $Config{'base_import'};
# Additional import file specified from Makefile.pl
if($self->{'base_import'}) {
$self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'};
}
$self->{'NLM_VERSION'} = $Config{'nlm_version'};
$self->{'MPKTOOL'} = $Config{'mpktool'};
$self->{'TOOLPATH'} = $Config{'toolpath'};
(my $boot = $self->{'NAME'}) =~ s/:/_/g;
$self->{'BOOT_SYMBOL'}=$boot;
# If the final binary name is greater than 8 chars,
# truncate it here.
if(length($self->{'BASEEXT'}) > 8) {
$self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8);
}
# Get the include path and replace the spaces with ;
# Copy this to makefile as INCLUDE = d:\...;d:\;
($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g;
# Set the path to CodeWarrior binaries which might not have been set in
# any other place
$self->{PATH} = '$(PATH);$(TOOLPATH)';
$self->{MM_NW5_VERSION} = $VERSION;
}
sub platform_constants {
my($self) = shift;
my $make_frag = '';
# Setup Win32's constants.
$make_frag .= $self->SUPER::platform_constants;
foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL
TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH
MM_NW5_VERSION
))
{
next unless defined $self->{$macro};
$make_frag .= "$macro = $self->{$macro}\n";
}
return $make_frag;
}
=item static_lib_pure_cmd
Defines how to run the archive utility
=cut
sub static_lib_pure_cmd {
my ($self, $src) = @_;
$src =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND;
sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $src
: ($GCC ? '-ru $@ ' . $src
: '-type library -o $@ ' . $src));
}
=item xs_static_lib_is_xs
=cut
sub xs_static_lib_is_xs {
return 1;
}
=item dynamic_lib
Override of utility methods for OS-specific work.
=cut
sub xs_make_dynamic_lib {
my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
my @m;
# Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
if ($to =~ /^\$/) {
if ($self->{NLM_SHORT_NAME}) {
# deal with shortnames
my $newto = q{$(INST_AUTODIR)\\$(NLM_SHORT_NAME).$(DLEXT)};
push @m, "$to: $newto\n\n";
$to = $newto;
}
} else {
my ($v, $d, $f) = File::Spec->splitpath($to);
# relies on $f having a literal "." in it, unlike for $(OBJ_EXT)
if ($f =~ /[^\.]{9}\./) {
# 9+ chars before '.', need to shorten
$f = substr $f, 0, 8;
}
my $newto = File::Spec->catpath($v, $d, $f);
push @m, "$to: $newto\n\n";
$to = $newto;
}
# bits below should be in dlsyms, not here
# 1 2 3 4
push @m, _sprintf562 <<'MAKE_FRAG', $to, $from, $todir, $exportlist;
# Create xdc data for an MT safe NLM in case of mpk build
%1$s: %2$s $(MYEXTLIB) $(BOOTSTRAP) %3$s$(DFSEP).exists
$(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > %4$s
$(NOECHO) $(ECHO) $(BASE_IMPORT) >> %4$s
$(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> %4$s
MAKE_FRAG
if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) {
(my $xdc = $exportlist) =~ s#def\z#xdc#;
$xdc = '$(BASEEXT).xdc';
push @m, sprintf <<'MAKE_FRAG', $xdc, $exportlist;
$(MPKTOOL) $(XDCFLAGS) %s
$(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> %s
MAKE_FRAG
}
# Reconstruct the X.Y.Z version.
my $version = join '.', map { sprintf "%d", $_ }
$] =~ /(\d)\.(\d{3})(\d{2})/;
push @m, sprintf <<'EOF', $from, $version, $to, $exportlist;
$(LD) $(LDFLAGS) %s -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) -o %s $(MYEXTLIB) $(PERL_INC)\Main.lib -commandfile %s
$(CHMOD) 755 $@
EOF
join '', @m;
}
1;
__END__
=back
=cut
EXTUTILS_MM_NW5
$fatpacked{"ExtUtils/MM_OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_OS2';
package ExtUtils::MM_OS2;
use strict;
use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix);
=pod
=head1 NAME
ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=head1 METHODS
=over 4
=item init_dist
Define TO_UNIX to convert OS2 linefeeds to Unix style.
=cut
sub init_dist {
my($self) = @_;
$self->{TO_UNIX} ||= <<'MAKE_TEXT';
$(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip
MAKE_TEXT
$self->SUPER::init_dist;
}
sub dlsyms {
my($self,%attribs) = @_;
if ($self->{IMPORTS} && %{$self->{IMPORTS}}) {
# Make import files (needed for static build)
-d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp";
foreach my $name (sort keys %{$self->{IMPORTS}}) {
my $exp = $self->{IMPORTS}->{$name};
my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'";
print $imp "$name $lib $id ?\n";
}
close $imp or die "Can't close tmpimp.imp";
# print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n";
system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp"
and die "Cannot make import library: $!, \$?=$?";
# May be running under miniperl, so have no glob...
eval { unlink <tmp_imp/*>; 1 } or system "rm tmp_imp/*";
system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}"
and die "Cannot extract import objects: $!, \$?=$?";
}
return '' if $self->{SKIPHASH}{'dynamic'};
$self->xs_dlsyms_iterator(\%attribs);
}
sub xs_dlsyms_ext {
'.def';
}
sub xs_dlsyms_extra {
join '', map { qq{, "$_" => "\$($_)"} } qw(VERSION DISTNAME INSTALLDIRS);
}
sub static_lib_pure_cmd {
my($self) = @_;
my $old = $self->SUPER::static_lib_pure_cmd;
return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
$old . <<'EOC';
$(AR) $(AR_STATIC_ARGS) "$@" tmp_imp/*
$(RANLIB) "$@"
EOC
}
sub replace_manpage_separator {
my($self,$man) = @_;
$man =~ s,/+,.,g;
$man;
}
sub maybe_command {
my($self,$file) = @_;
$file =~ s,[/\\]+,/,g;
return $file if -x $file && ! -d _;
return "$file.exe" if -x "$file.exe" && ! -d _;
return "$file.cmd" if -x "$file.cmd" && ! -d _;
return;
}
=item init_linker
=cut
sub init_linker {
my $self = shift;
$self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)";
$self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout
? ''
: '$(PERL_INC)/libperl_override$(LIB_EXT)';
$self->{EXPORT_LIST} = '$(BASEEXT).def';
}
=item os_flavor
OS/2 is OS/2
=cut
sub os_flavor {
return('OS/2');
}
=item xs_static_lib_is_xs
=cut
sub xs_static_lib_is_xs {
return 1;
}
=back
=cut
1;
EXTUTILS_MM_OS2
$fatpacked{"ExtUtils/MM_QNX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_QNX';
package ExtUtils::MM_QNX;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
=head1 NAME
ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality for
QNX.
Unless otherwise stated it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=head3 extra_clean_files
Add .err files corresponding to each .c file.
=cut
sub extra_clean_files {
my $self = shift;
my @errfiles = @{$self->{C}};
for ( @errfiles ) {
s/.c$/.err/;
}
return( @errfiles, 'perlmain.err' );
}
=head1 AUTHOR
Michael G Schwern <[email protected]> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_QNX
$fatpacked{"ExtUtils/MM_UWIN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_UWIN';
package ExtUtils::MM_UWIN;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
=head1 NAME
ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality for
the AT&T U/WIN UNIX on Windows environment.
Unless otherwise stated it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=over 4
=item os_flavor
In addition to being Unix, we're U/WIN.
=cut
sub os_flavor {
return('Unix', 'U/WIN');
}
=item B<replace_manpage_separator>
=cut
sub replace_manpage_separator {
my($self, $man) = @_;
$man =~ s,/+,.,g;
return $man;
}
=back
=head1 AUTHOR
Michael G Schwern <[email protected]> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MM_Win32>, L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_UWIN
$fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_UNIX';
package ExtUtils::MM_Unix;
require 5.006;
use strict;
use Carp;
use ExtUtils::MakeMaker::Config;
use File::Basename qw(basename dirname);
our %Config_Override;
use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);
# If we make $VERSION an our variable parse_version() breaks
use vars qw($VERSION);
$VERSION = '7.34';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
require ExtUtils::MM_Any;
our @ISA = qw(ExtUtils::MM_Any);
my %Is;
BEGIN {
$Is{OS2} = $^O eq 'os2';
$Is{Win32} = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare';
$Is{Dos} = $^O eq 'dos';
$Is{VMS} = $^O eq 'VMS';
$Is{OSF} = $^O eq 'dec_osf';
$Is{IRIX} = $^O eq 'irix';
$Is{NetBSD} = $^O eq 'netbsd';
$Is{Interix} = $^O eq 'interix';
$Is{SunOS4} = $^O eq 'sunos';
$Is{Solaris} = $^O eq 'solaris';
$Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
$Is{BSD} = ($^O =~ /^(?:free|net|open)bsd$/ or
grep( $^O eq $_, qw(bsdos interix dragonfly) )
);
$Is{Android} = $^O =~ /android/;
}
BEGIN {
if( $Is{VMS} ) {
# For things like vmsify()
require VMS::Filespec;
VMS::Filespec->import;
}
}
=head1 NAME
ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
=head1 SYNOPSIS
C<require ExtUtils::MM_Unix;>
=head1 DESCRIPTION
The methods provided by this package are designed to be used in
conjunction with ExtUtils::MakeMaker. When MakeMaker writes a
Makefile, it creates one or more objects that inherit their methods
from a package C<MM>. MM itself doesn't provide any methods, but it
ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating
specific packages take the responsibility for all the methods provided
by MM_Unix. We are trying to reduce the number of the necessary
overrides by defining rather primitive operations within
ExtUtils::MM_Unix.
If you are going to write a platform specific MM package, please try
to limit the necessary overrides to primitive methods, and if it is not
possible to do so, let's work out how to achieve that gain.
If you are overriding any of these methods in your Makefile.PL (in the
MY class), please report that to the makemaker mailing list. We are
trying to minimize the necessary method overrides and switch to data
driven Makefile.PLs wherever possible. In the long run less methods
will be overridable via the MY class.
=head1 METHODS
The following description of methods is still under
development. Please refer to the code for not suitably documented
sections and complain loudly to the [email protected] mailing list.
Better yet, provide a patch.
Not all of the methods below are overridable in a
Makefile.PL. Overridable methods are marked as (o). All methods are
overridable by a platform specific MM_*.pm file.
Cross-platform methods are being moved into MM_Any. If you can't find
something that used to be in here, look in MM_Any.
=cut
# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values. Faster and shrtr.
my $Curdir = __PACKAGE__->curdir;
my $Updir = __PACKAGE__->updir;
=head2 Methods
=over 4
=item os_flavor
Simply says that we're Unix.
=cut
sub os_flavor {
return('Unix');
}
=item c_o (o)
Defines the suffix rules to compile different flavors of C files to
object files.
=cut
sub c_o {
# --- Translation Sections ---
my($self) = shift;
return '' unless $self->needs_linking();
my(@m);
my $command = '$(CCCMD)';
my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)';
if (my $cpp = $Config{cpprun}) {
my $cpp_cmd = $self->const_cccmd;
$cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/;
push @m, qq{
.c.i:
$cpp_cmd $flags \$*.c > \$*.i
};
}
my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*.s') : '';
push @m, sprintf <<'EOF', $command, $flags, $m_o;
.c.s :
%s -S %s $*.c %s
EOF
my @exts = qw(c cpp cxx cc);
push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
$m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
for my $ext (@exts) {
push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags \$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n";
}
return join "", @m;
}
=item xs_obj_opt
Takes the object file as an argument, and returns the portion of compile
command-line that will output to the specified object file.
=cut
sub xs_obj_opt {
my ($self, $output_file) = @_;
"-o $output_file";
}
=item cflags (o)
Does very much the same as the cflags script in the perl
distribution. It doesn't return the whole compiler command line, but
initializes all of its parts. The const_cccmd method then actually
returns the definition of the CCCMD macro which uses these parts.
=cut
#'
sub cflags {
my($self,$libperl)=@_;
return $self->{CFLAGS} if $self->{CFLAGS};
return '' unless $self->needs_linking();
my($prog, $uc, $perltype, %cflags);
$libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ;
$libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/;
@cflags{qw(cc ccflags optimize shellflags)}
= @Config{qw(cc ccflags optimize shellflags)};
# Perl 5.21.4 adds the (gcc) warning (-Wall ...) and std (-std=c89)
# flags to the %Config, and the modules in the core should be built
# with the warning flags, but NOT the -std=c89 flags (the latter
# would break using any system header files that are strict C99).
my @ccextraflags = qw(ccwarnflags);
if ($ENV{PERL_CORE}) {
for my $x (@ccextraflags) {
if (exists $Config{$x}) {
$cflags{$x} = $Config{$x};
}
}
}
my($optdebug) = "";
$cflags{shellflags} ||= '';
my(%map) = (
D => '-DDEBUGGING',
E => '-DEMBED',
DE => '-DDEBUGGING -DEMBED',
M => '-DEMBED -DMULTIPLICITY',
DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY',
);
if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){
$uc = uc($1);
} else {
$uc = ""; # avoid warning
}
$perltype = $map{$uc} ? $map{$uc} : "";
if ($uc =~ /^D/) {
$optdebug = "-g";
}
my($name);
( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
if ($prog = $Config{$name}) {
# Expand hints for this extension via the shell
print "Processing $name hint:\n" if $Verbose;
my(@o)=`cc=\"$cflags{cc}\"
ccflags=\"$cflags{ccflags}\"
optimize=\"$cflags{optimize}\"
perltype=\"$cflags{perltype}\"
optdebug=\"$cflags{optdebug}\"
eval '$prog'
echo cc=\$cc
echo ccflags=\$ccflags
echo optimize=\$optimize
echo perltype=\$perltype
echo optdebug=\$optdebug
`;
foreach my $line (@o){
chomp $line;
if ($line =~ /(.*?)=\s*(.*)\s*$/){
$cflags{$1} = $2;
print " $1 = $2\n" if $Verbose;
} else {
print "Unrecognised result from hint: '$line'\n";
}
}
}
if ($optdebug) {
$cflags{optimize} = $optdebug;
}
for (qw(ccflags optimize perltype)) {
$cflags{$_} ||= '';
$cflags{$_} =~ s/^\s+//;
$cflags{$_} =~ s/\s+/ /g;
$cflags{$_} =~ s/\s+$//;
$self->{uc $_} ||= $cflags{$_};
}
if ($self->{POLLUTE}) {
$self->{CCFLAGS} .= ' -DPERL_POLLUTE ';
}
for my $x (@ccextraflags) {
next unless exists $cflags{$x};
$self->{CCFLAGS} .= $cflags{$x} =~ m!^\s! ? $cflags{$x} : ' ' . $cflags{$x};
}
my $pollute = '';
if ($Config{usemymalloc} and not $Config{bincompat5005}
and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/
and $self->{PERL_MALLOC_OK}) {
$pollute = '$(PERL_MALLOC_DEF)';
}
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
MPOLLUTE = $pollute
};
}
=item const_cccmd (o)
Returns the full compiler call for C programs and stores the
definition in CONST_CCCMD.
=cut
sub const_cccmd {
my($self,$libperl)=@_;
return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
return '' unless $self->needs_linking();
return $self->{CONST_CCCMD} =
q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\
$(CCFLAGS) $(OPTIMIZE) \\
$(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\
$(XS_DEFINE_VERSION)};
}
=item const_config (o)
Sets SHELL if needed, then defines a couple of constants in the Makefile
that are imported from %Config.
=cut
sub const_config {
# --- Constants Sections ---
my($self) = shift;
my @m = $self->specify_shell(); # Usually returns empty string
push @m, <<"END";
# These definitions are from config.sh (via $INC{'Config.pm'}).
# They may have been overridden via Makefile.PL or on the command line.
END
my(%once_only);
foreach my $key (@{$self->{CONFIG}}){
# SITE*EXP macros are defined in &constants; avoid duplicates here
next if $once_only{$key};
push @m, uc($key) , ' = ' , $self->{uc $key}, "\n";
$once_only{$key} = 1;
}
join('', @m);
}
=item const_loadlibs (o)
Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See
L<ExtUtils::Liblist> for details.
=cut
sub const_loadlibs {
my($self) = shift;
return "" unless $self->needs_linking;
my @m;
push @m, qq{
# $self->{NAME} might depend on some other libraries:
# See ExtUtils::Liblist for details
#
};
for my $tmp (qw/
EXTRALIBS LDLOADLIBS BSLOADLIBS
/) {
next unless defined $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
}
# don't set LD_RUN_PATH if empty
for my $tmp (qw/
LD_RUN_PATH
/) {
next unless $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
}
return join "", @m;
}
=item constants (o)
my $make_frag = $mm->constants;
Prints out macros for lots of constants.
=cut
sub constants {
my($self) = @_;
my @m = ();
$self->{DFSEP} = '$(DIRFILESEP)'; # alias for internal use
for my $macro (qw(
AR_STATIC_ARGS DIRFILESEP DFSEP
NAME NAME_SYM
VERSION VERSION_MACRO VERSION_SYM DEFINE_VERSION
XS_VERSION XS_VERSION_MACRO XS_DEFINE_VERSION
INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB
INST_MAN1DIR INST_MAN3DIR
MAN1EXT MAN3EXT
INSTALLDIRS INSTALL_BASE DESTDIR PREFIX
PERLPREFIX SITEPREFIX VENDORPREFIX
),
(map { ("INSTALL".$_,
"DESTINSTALL".$_)
} $self->installvars),
qw(
PERL_LIB
PERL_ARCHLIB PERL_ARCHLIBDEP
LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE
PERLMAINCC PERL_SRC PERL_INC PERL_INCDEP
PERL FULLPERL ABSPERL
PERLRUN FULLPERLRUN ABSPERLRUN
PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST
PERL_CORE
PERM_DIR PERM_RW PERM_RWX
) )
{
next unless defined $self->{$macro};
# pathnames can have sharp signs in them; escape them so
# make doesn't think it is a comment-start character.
$self->{$macro} =~ s/#/\\#/g;
$self->{$macro} = $self->quote_dep($self->{$macro})
if $ExtUtils::MakeMaker::macro_dep{$macro};
push @m, "$macro = $self->{$macro}\n";
}
push @m, qq{
MAKEMAKER = $self->{MAKEMAKER}
MM_VERSION = $self->{MM_VERSION}
MM_REVISION = $self->{MM_REVISION}
};
push @m, q{
# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
};
for my $macro (qw/
MAKE
FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
LDFROM LINKTYPE BOOTDEP
/ )
{
next unless defined $self->{$macro};
push @m, "$macro = $self->{$macro}\n";
}
push @m, "
# Handy lists of source code files:
XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})."
C_FILES = ".$self->wraplist(sort @{$self->{C}})."
O_FILES = ".$self->wraplist(sort @{$self->{O_FILES}})."
H_FILES = ".$self->wraplist(sort @{$self->{H}})."
MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})."
MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})."
";
push @m, q{
# Where is the Config information that we are using/depend on
CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h
} if -e $self->catfile( $self->{PERL_INC}, 'config.h' );
push @m, qq{
# Where to build things
INST_LIBDIR = $self->{INST_LIBDIR}
INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
INST_AUTODIR = $self->{INST_AUTODIR}
INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
INST_STATIC = $self->{INST_STATIC}
INST_DYNAMIC = $self->{INST_DYNAMIC}
INST_BOOT = $self->{INST_BOOT}
};
push @m, qq{
# Extra linker info
EXPORT_LIST = $self->{EXPORT_LIST}
PERL_ARCHIVE = $self->{PERL_ARCHIVE}
PERL_ARCHIVEDEP = $self->{PERL_ARCHIVEDEP}
PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER}
};
push @m, "
TO_INST_PM = ".$self->wraplist(map $self->quote_dep($_), sort keys %{$self->{PM}})."\n";
join('',@m);
}
=item depend (o)
Same as macro for the depend attribute.
=cut
sub depend {
my($self,%attribs) = @_;
my(@m,$key,$val);
for my $key (sort keys %attribs){
my $val = $attribs{$key};
next unless defined $key and defined $val;
push @m, "$key : $val\n";
}
join "", @m;
}
=item init_DEST
$mm->init_DEST
Defines the DESTDIR and DEST* variables paralleling the INSTALL*.
=cut
sub init_DEST {
my $self = shift;
# Initialize DESTDIR
$self->{DESTDIR} ||= '';
# Make DEST variables.
foreach my $var ($self->installvars) {
my $destvar = 'DESTINSTALL'.$var;
$self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')';
}
}
=item init_dist
$mm->init_dist;
Defines a lot of macros for distribution support.
macro description default
TAR tar command to use tar
TARFLAGS flags to pass to TAR cvf
ZIP zip command to use zip
ZIPFLAGS flags to pass to ZIP -r
COMPRESS compression command to gzip --best
use for tarfiles
SUFFIX suffix to put on .gz
compressed files
SHAR shar command to use shar
PREOP extra commands to run before
making the archive
POSTOP extra commands to run after
making the archive
TO_UNIX a command to convert linefeeds
to Unix style in your archive
CI command to checkin your ci -u
sources to version control
RCS_LABEL command to label your sources rcs -Nv$(VERSION_SYM): -q
just after CI is run
DIST_CP $how argument to manicopy() best
when the distdir is created
DIST_DEFAULT default target to use to tardist
create a distribution
DISTVNAME name of the resulting archive $(DISTNAME)-$(VERSION)
(minus suffixes)
=cut
sub init_dist {
my $self = shift;
$self->{TAR} ||= 'tar';
$self->{TARFLAGS} ||= 'cvf';
$self->{ZIP} ||= 'zip';
$self->{ZIPFLAGS} ||= '-r';
$self->{COMPRESS} ||= 'gzip --best';
$self->{SUFFIX} ||= '.gz';
$self->{SHAR} ||= 'shar';
$self->{PREOP} ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST
$self->{POSTOP} ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir
$self->{TO_UNIX} ||= '$(NOECHO) $(NOOP)';
$self->{CI} ||= 'ci -u';
$self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q';
$self->{DIST_CP} ||= 'best';
$self->{DIST_DEFAULT} ||= 'tardist';
($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME};
$self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION};
}
=item dist (o)
my $dist_macros = $mm->dist(%overrides);
Generates a make fragment defining all the macros initialized in
init_dist.
%overrides can be used to override any of the above.
=cut
sub dist {
my($self, %attribs) = @_;
my $make = '';
if ( $attribs{SUFFIX} && $attribs{SUFFIX} !~ m!^\.! ) {
$attribs{SUFFIX} = '.' . $attribs{SUFFIX};
}
foreach my $key (qw(
TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR
PREOP POSTOP TO_UNIX
CI RCS_LABEL DIST_CP DIST_DEFAULT
DISTNAME DISTVNAME
))
{
my $value = $attribs{$key} || $self->{$key};
$make .= "$key = $value\n";
}
return $make;
}
=item dist_basics (o)
Defines the targets distclean, distcheck, skipcheck, manifest, veryclean.
=cut
sub dist_basics {
my($self) = shift;
return <<'MAKE_FRAG';
distclean :: realclean distcheck
$(NOECHO) $(NOOP)
distcheck :
$(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck
skipcheck :
$(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck
manifest :
$(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest
veryclean : realclean
$(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old
MAKE_FRAG
}
=item dist_ci (o)
Defines a check in target for RCS.
=cut
sub dist_ci {
my($self) = shift;
return sprintf "ci :\n\t%s\n", $self->oneliner(<<'EOF', [qw(-MExtUtils::Manifest=maniread)]);
@all = sort keys %{ maniread() };
print(qq{Executing $(CI) @all\n});
system(qq{$(CI) @all}) == 0 or die $!;
print(qq{Executing $(RCS_LABEL) ...\n});
system(qq{$(RCS_LABEL) @all}) == 0 or die $!;
EOF
}
=item dist_core (o)
my $dist_make_fragment = $MM->dist_core;
Puts the targets necessary for 'make dist' together into one make
fragment.
=cut
sub dist_core {
my($self) = shift;
my $make_frag = '';
foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile
shdist))
{
my $method = $target.'_target';
$make_frag .= "\n";
$make_frag .= $self->$method();
}
return $make_frag;
}
=item B<dist_target>
my $make_frag = $MM->dist_target;
Returns the 'dist' target to make an archive for distribution. This
target simply checks to make sure the Makefile is up-to-date and
depends on $(DIST_DEFAULT).
=cut
sub dist_target {
my($self) = shift;
my $date_check = $self->oneliner(<<'CODE', ['-l']);
print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'
if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';
CODE
return sprintf <<'MAKE_FRAG', $date_check;
dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE)
$(NOECHO) %s
MAKE_FRAG
}
=item B<tardist_target>
my $make_frag = $MM->tardist_target;
Returns the 'tardist' target which is simply so 'make tardist' works.
The real work is done by the dynamically named tardistfile_target()
method, tardist should have that as a dependency.
=cut
sub tardist_target {
my($self) = shift;
return <<'MAKE_FRAG';
tardist : $(DISTVNAME).tar$(SUFFIX)
$(NOECHO) $(NOOP)
MAKE_FRAG
}
=item B<zipdist_target>
my $make_frag = $MM->zipdist_target;
Returns the 'zipdist' target which is simply so 'make zipdist' works.
The real work is done by the dynamically named zipdistfile_target()
method, zipdist should have that as a dependency.
=cut
sub zipdist_target {
my($self) = shift;
return <<'MAKE_FRAG';
zipdist : $(DISTVNAME).zip
$(NOECHO) $(NOOP)
MAKE_FRAG
}
=item B<tarfile_target>
my $make_frag = $MM->tarfile_target;
The name of this target is the name of the tarball generated by
tardist. This target does the actual work of turning the distdir into
a tarball.
=cut
sub tarfile_target {
my($self) = shift;
return <<'MAKE_FRAG';
$(DISTVNAME).tar$(SUFFIX) : distdir
$(PREOP)
$(TO_UNIX)
$(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
$(RM_RF) $(DISTVNAME)
$(COMPRESS) $(DISTVNAME).tar
$(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)'
$(POSTOP)
MAKE_FRAG
}
=item zipfile_target
my $make_frag = $MM->zipfile_target;
The name of this target is the name of the zip file generated by
zipdist. This target does the actual work of turning the distdir into
a zip file.
=cut
sub zipfile_target {
my($self) = shift;
return <<'MAKE_FRAG';
$(DISTVNAME).zip : distdir
$(PREOP)
$(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
$(RM_RF) $(DISTVNAME)
$(NOECHO) $(ECHO) 'Created $(DISTVNAME).zip'
$(POSTOP)
MAKE_FRAG
}
=item uutardist_target
my $make_frag = $MM->uutardist_target;
Converts the tarfile into a uuencoded file
=cut
sub uutardist_target {
my($self) = shift;
return <<'MAKE_FRAG';
uutardist : $(DISTVNAME).tar$(SUFFIX)
uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu
$(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)_uu'
MAKE_FRAG
}
=item shdist_target
my $make_frag = $MM->shdist_target;
Converts the distdir into a shell archive.
=cut
sub shdist_target {
my($self) = shift;
return <<'MAKE_FRAG';
shdist : distdir
$(PREOP)
$(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
$(RM_RF) $(DISTVNAME)
$(NOECHO) $(ECHO) 'Created $(DISTVNAME).shar'
$(POSTOP)
MAKE_FRAG
}
=item dlsyms (o)
Used by some OS' to define DL_FUNCS and DL_VARS and write the *.exp files.
Normally just returns an empty string.
=cut
sub dlsyms {
return '';
}
=item dynamic_bs (o)
Defines targets for bootstrap files.
=cut
sub dynamic_bs {
my($self, %attribs) = @_;
return "\nBOOTSTRAP =\n" unless $self->has_link_code();
my @exts;
if ($self->{XSMULTI}) {
@exts = $self->_xs_list_basenames;
} else {
@exts = '$(BASEEXT)';
}
return join "\n",
"BOOTSTRAP = @{[map { qq{$_.bs} } @exts]}\n",
map { $self->_xs_make_bs($_) } @exts;
}
sub _xs_make_bs {
my ($self, $basename) = @_;
my ($v, $d, $f) = File::Spec->splitpath($basename);
my @d = File::Spec->splitdir($d);
shift @d if $self->{XSMULTI} and $d[0] eq 'lib';
my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
$instdir = '$(INST_ARCHAUTODIR)' if $basename eq '$(BASEEXT)';
my $instfile = $self->catfile($instdir, "$f.bs");
my $exists = "$instdir\$(DFSEP).exists"; # match blibdirs_target
# 1 2 3
return _sprintf562 <<'MAKE_FRAG', $basename, $instfile, $exists;
# As Mkbootstrap might not write a file (if none is required)
# we use touch to prevent make continually trying to remake it.
# The DynaLoader only reads a non-empty file.
%1$s.bs : $(FIRST_MAKEFILE) $(BOOTDEP)
$(NOECHO) $(ECHO) "Running Mkbootstrap for %1$s ($(BSLOADLIBS))"
$(NOECHO) $(PERLRUN) \
"-MExtUtils::Mkbootstrap" \
-e "Mkbootstrap('%1$s','$(BSLOADLIBS)');"
$(NOECHO) $(TOUCH) "%1$s.bs"
$(CHMOD) $(PERM_RW) "%1$s.bs"
%2$s : %1$s.bs %3$s
$(NOECHO) $(RM_RF) %2$s
- $(CP_NONEMPTY) %1$s.bs %2$s $(PERM_RW)
MAKE_FRAG
}
=item dynamic_lib (o)
Defines how to produce the *.so (or equivalent) files.
=cut
sub dynamic_lib {
my($self, %attribs) = @_;
return '' unless $self->needs_linking(); #might be because of a subdir
return '' unless $self->has_link_code;
my @m = $self->xs_dynamic_lib_macros(\%attribs);
my @libs;
my $dlsyms_ext = eval { $self->xs_dlsyms_ext };
if ($self->{XSMULTI}) {
my @exts = $self->_xs_list_basenames;
for my $ext (@exts) {
my ($v, $d, $f) = File::Spec->splitpath($ext);
my @d = File::Spec->splitdir($d);
shift @d if $d[0] eq 'lib';
my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
# Dynamic library names may need special handling.
eval { require DynaLoader };
if (defined &DynaLoader::mod2fname) {
$f = &DynaLoader::mod2fname([@d, $f]);
}
my $instfile = $self->catfile($instdir, "$f.\$(DLEXT)");
my $objfile = $self->_xsbuild_value('xs', $ext, 'OBJECT');
$objfile = "$ext\$(OBJ_EXT)" unless defined $objfile;
my $ldfrom = $self->_xsbuild_value('xs', $ext, 'LDFROM');
$ldfrom = $objfile unless defined $ldfrom;
my $exportlist = "$ext.def";
my @libchunk = ($objfile, $instfile, $instdir, $ldfrom, $exportlist);
push @libchunk, $dlsyms_ext ? $ext.$dlsyms_ext : undef;
push @libs, \@libchunk;
}
} else {
my @libchunk = qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST));
push @libchunk, $dlsyms_ext ? '$(BASEEXT)'.$dlsyms_ext : undef;
@libs = (\@libchunk);
}
push @m, map { $self->xs_make_dynamic_lib(\%attribs, @$_); } @libs;
return join("\n",@m);
}
=item xs_dynamic_lib_macros
Defines the macros for the C<dynamic_lib> section.
=cut
sub xs_dynamic_lib_macros {
my ($self, $attribs) = @_;
my $otherldflags = $attribs->{OTHERLDFLAGS} || "";
my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
my $armaybe = $self->_xs_armaybe($attribs);
my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too?
my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : '';
sprintf <<'EOF', $armaybe, $ld_opt.$otherldflags, $inst_dynamic_dep, $ld_fix;
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
ARMAYBE = %s
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
INST_DYNAMIC_FIX = %s
EOF
}
sub _xs_armaybe {
my ($self, $attribs) = @_;
my $armaybe = $attribs->{ARMAYBE} || $self->{ARMAYBE} || ":";
$armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':');
$armaybe;
}
=item xs_make_dynamic_lib
Defines the recipes for the C<dynamic_lib> section.
=cut
sub xs_make_dynamic_lib {
my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist, $dlsyms) = @_;
$exportlist = '' if $exportlist ne '$(EXPORT_LIST)';
my $armaybe = $self->_xs_armaybe($attribs);
my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n", $to, $object, $todir, $exportlist, ($dlsyms || '');
my $dlsyms_arg = $self->xs_dlsyms_arg($dlsyms);
if ($armaybe ne ':'){
$ldfrom = 'tmp$(LIB_EXT)';
push(@m," \$(ARMAYBE) cr $ldfrom $object\n");
push(@m," \$(RANLIB) $ldfrom\n");
}
$ldfrom = "-all $ldfrom -none" if $Is{OSF};
# The IRIX linker doesn't use LD_RUN_PATH
my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ?
qq{-rpath "$self->{LD_RUN_PATH}"} : '';
# For example in AIX the shared objects/libraries from previous builds
# linger quite a while in the shared dynalinker cache even when nobody
# is using them. This is painful if one for instance tries to restart
# a failed build because the link command will fail unnecessarily 'cos
# the shared object/library is 'busy'.
push(@m," \$(RM_F) \$\@\n");
my $libs = '$(LDLOADLIBS)';
if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') {
# Use nothing on static perl platforms, and to the flags needed
# to link against the shared libperl library on shared perl
# platforms. We peek at lddlflags to see if we need -Wl,-R
# or -R to add paths to the run-time library search path.
if ($Config{'lddlflags'} =~ /-Wl,-R/) {
$libs .= ' "-L$(PERL_INC)" "-Wl,-R$(INSTALLARCHLIB)/CORE" "-Wl,-R$(PERL_ARCHLIB)/CORE" -lperl';
} elsif ($Config{'lddlflags'} =~ /-R/) {
$libs .= ' "-L$(PERL_INC)" "-R$(INSTALLARCHLIB)/CORE" "-R$(PERL_ARCHLIB)/CORE" -lperl';
} elsif ( $Is{Android} ) {
# The Android linker will not recognize symbols from
# libperl unless the module explicitly depends on it.
$libs .= ' "-L$(PERL_INC)" -lperl';
}
}
my $ld_run_path_shell = "";
if ($self->{LD_RUN_PATH} ne "") {
$ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
}
push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $dlsyms_arg, $ldfrom, $self->xs_obj_opt('$@'), $libs, $exportlist;
%s$(LD) %s $(LDDLFLAGS) %s %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \
$(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \
$(INST_DYNAMIC_FIX)
$(CHMOD) $(PERM_RWX) $@
MAKE
join '', @m;
}
=item exescan
Deprecated method. Use libscan instead.
=cut
sub exescan {
my($self,$path) = @_;
$path;
}
=item extliblist
Called by init_others, and calls ext ExtUtils::Liblist. See
L<ExtUtils::Liblist> for details.
=cut
sub extliblist {
my($self,$libs) = @_;
require ExtUtils::Liblist;
$self->ext($libs, $Verbose);
}
=item find_perl
Finds the executables PERL and FULLPERL
=cut
sub find_perl {
my($self, $ver, $names, $dirs, $trace) = @_;
if ($trace >= 2){
print "Looking for perl $ver by these names:
@$names
in these dirs:
@$dirs
";
}
my $stderr_duped = 0;
local *STDERR_COPY;
unless ($Is{BSD}) {
# >& and lexical filehandles together give 5.6.2 indigestion
if( open(STDERR_COPY, '>&STDERR') ) { ## no critic
$stderr_duped = 1;
}
else {
warn <<WARNING;
find_perl() can't dup STDERR: $!
You might see some garbage while we search for Perl
WARNING
}
}
foreach my $name (@$names){
my ($abs, $use_dir);
if ($self->file_name_is_absolute($name)) { # /foo/bar
$abs = $name;
} elsif ($self->canonpath($name) eq
$self->canonpath(basename($name))) { # foo
$use_dir = 1;
} else { # foo/bar
$abs = $self->catfile($Curdir, $name);
}
foreach my $dir ($use_dir ? @$dirs : 1){
next unless defined $dir; # $self->{PERL_SRC} may be undefined
$abs = $self->catfile($dir, $name)
if $use_dir;
print "Checking $abs\n" if ($trace >= 2);
next unless $self->maybe_command($abs);
print "Executing $abs\n" if ($trace >= 2);
my $val;
my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"};
# To avoid using the unportable 2>&1 to suppress STDERR,
# we close it before running the command.
# However, thanks to a thread library bug in many BSDs
# ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 )
# we cannot use the fancier more portable way in here
# but instead need to use the traditional 2>&1 construct.
if ($Is{BSD}) {
$val = `$version_check 2>&1`;
} else {
close STDERR if $stderr_duped;
$val = `$version_check`;
# 5.6.2's 3-arg open doesn't work with >&
open STDERR, ">&STDERR_COPY" ## no critic
if $stderr_duped;
}
if ($val =~ /^VER_OK/m) {
print "Using PERL=$abs\n" if $trace;
return $abs;
} elsif ($trace >= 2) {
print "Result: '$val' ".($? >> 8)."\n";
}
}
}
print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
0; # false and not empty
}
=item fixin
$mm->fixin(@files);
Inserts the sharpbang or equivalent magic number to a set of @files.
=cut
sub fixin { # stolen from the pink Camel book, more or less
my ( $self, @files ) = @_;
for my $file (@files) {
my $file_new = "$file.new";
my $file_bak = "$file.bak";
open( my $fixin, '<', $file ) or croak "Can't process '$file': $!";
local $/ = "\n";
chomp( my $line = <$fixin> );
next unless $line =~ s/^\s*\#!\s*//; # Not a shebang file.
my $shb = $self->_fixin_replace_shebang( $file, $line );
next unless defined $shb;
open( my $fixout, ">", "$file_new" ) or do {
warn "Can't create new $file: $!\n";
next;
};
# Print out the new #! line (or equivalent).
local $\;
local $/;
print $fixout $shb, <$fixin>;
close $fixin;
close $fixout;
chmod 0666, $file_bak;
unlink $file_bak;
unless ( _rename( $file, $file_bak ) ) {
warn "Can't rename $file to $file_bak: $!";
next;
}
unless ( _rename( $file_new, $file ) ) {
warn "Can't rename $file_new to $file: $!";
unless ( _rename( $file_bak, $file ) ) {
warn "Can't rename $file_bak back to $file either: $!";
warn "Leaving $file renamed as $file_bak\n";
}
next;
}
unlink $file_bak;
}
continue {
system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
}
}
sub _rename {
my($old, $new) = @_;
foreach my $file ($old, $new) {
if( $Is{VMS} and basename($file) !~ /\./ ) {
# rename() in 5.8.0 on VMS will not rename a file if it
# does not contain a dot yet it returns success.
$file = "$file.";
}
}
return rename($old, $new);
}
sub _fixin_replace_shebang {
my ( $self, $file, $line ) = @_;
# Now figure out the interpreter name.
my ( $cmd, $arg ) = split ' ', $line, 2;
$cmd =~ s!^.*/!!;
# Now look (in reverse) for interpreter in absolute PATH (unless perl).
my $interpreter;
if ( $cmd =~ m{^perl(?:\z|[^a-z])} ) {
if ( $Config{startperl} =~ m,^\#!.*/perl, ) {
$interpreter = $Config{startperl};
$interpreter =~ s,^\#!,,;
}
else {
$interpreter = $Config{perlpath};
}
}
else {
my (@absdirs)
= reverse grep { $self->file_name_is_absolute($_) } $self->path;
$interpreter = '';
foreach my $dir (@absdirs) {
my $maybefile = $self->catfile($dir,$cmd);
if ( $self->maybe_command($maybefile) ) {
warn "Ignoring $interpreter in $file\n"
if $Verbose && $interpreter;
$interpreter = $maybefile;
}
}
}
# Figure out how to invoke interpreter on this machine.
my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/;
my ($shb) = "";
if ($interpreter) {
print "Changing sharpbang in $file to $interpreter"
if $Verbose;
# this is probably value-free on DOSISH platforms
if ($does_shbang) {
$shb .= "$Config{'sharpbang'}$interpreter";
$shb .= ' ' . $arg if defined $arg;
$shb .= "\n";
}
}
else {
warn "Can't find $cmd in PATH, $file unchanged"
if $Verbose;
return;
}
return $shb
}
=item force (o)
Writes an empty FORCE: target.
=cut
sub force {
my($self) = shift;
'# Phony target to force checking subdirectories.
FORCE :
$(NOECHO) $(NOOP)
';
}
=item guess_name
Guess the name of this package by examining the working directory's
name. MakeMaker calls this only if the developer has not supplied a
NAME attribute.
=cut
# ';
sub guess_name {
my($self) = @_;
use Cwd 'cwd';
my $name = basename(cwd());
$name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we
# strip minus or underline
# followed by a float or some such
print "Warning: Guessing NAME [$name] from current directory name.\n";
$name;
}
=item has_link_code
Returns true if C, XS, MYEXTLIB or similar objects exist within this
object that need a compiler. Does not descend into subdirectories as
needs_linking() does.
=cut
sub has_link_code {
my($self) = shift;
return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE};
if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){
$self->{HAS_LINK_CODE} = 1;
return 1;
}
return $self->{HAS_LINK_CODE} = 0;
}
=item init_dirscan
Scans the directory structure and initializes DIR, XS, XS_FILES,
C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES.
Called by init_main.
=cut
sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
my($self) = @_;
my(%dir, %xs, %c, %o, %h, %pl_files, %pm);
my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t);
# ignore the distdir
$Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1
: $ignore{$self->{DISTVNAME}} = 1;
my $distprefix = $Is{VMS} ? qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+\.dir$/i
: qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+$/;
@ignore{map lc, keys %ignore} = values %ignore if $Is{VMS};
if ( defined $self->{XS} and !defined $self->{C} ) {
my @c_files = grep { m/\.c(pp|xx)?\z/i } values %{$self->{XS}};
my @o_files = grep { m/(?:.(?:o(?:bj)?)|\$\(OBJ_EXT\))\z/i } values %{$self->{XS}};
%c = map { $_ => 1 } @c_files;
%o = map { $_ => 1 } @o_files;
}
foreach my $name ($self->lsdir($Curdir)){
next if $name =~ /\#/;
next if $name =~ $distprefix && -d $name;
$name = lc($name) if $Is{VMS};
next if $name eq $Curdir or $name eq $Updir or $ignore{$name};
next unless $self->libscan($name);
if (-d $name){
next if -l $name; # We do not support symlinks at all
next if $self->{NORECURS};
$dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
} elsif ($name =~ /\.xs\z/){
my($c); ($c = $name) =~ s/\.xs\z/.c/;
$xs{$name} = $c;
$c{$c} = 1;
} elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc
$c{$name} = 1
unless $name =~ m/perlmain\.c/; # See MAP_TARGET
} elsif ($name =~ /\.h\z/i){
$h{$name} = 1;
} elsif ($name =~ /\.PL\z/) {
($pl_files{$name} = $name) =~ s/\.PL\z// ;
} elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) {
# case-insensitive filesystem, one dot per name, so foo.h.PL
# under Unix appears as foo.h_pl under VMS or fooh.pl on Dos
local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl;
if ($txt =~ /Extracting \S+ \(with variable substitutions/) {
($pl_files{$name} = $name) =~ s/[._]pl\z//i ;
}
else {
$pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
}
} elsif ($name =~ /\.(p[ml]|pod)\z/){
$pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
}
}
$self->{PL_FILES} ||= \%pl_files;
$self->{DIR} ||= [sort keys %dir];
$self->{XS} ||= \%xs;
$self->{C} ||= [sort keys %c];
$self->{H} ||= [sort keys %h];
$self->{PM} ||= \%pm;
my @o_files = @{$self->{C}};
%o = (%o, map { $_ => 1 } grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files);
$self->{O_FILES} = [sort keys %o];
}
=item init_MANPODS
Determines if man pages should be generated and initializes MAN1PODS
and MAN3PODS as appropriate.
=cut
sub init_MANPODS {
my $self = shift;
# Set up names of manual pages to generate from pods
foreach my $man (qw(MAN1 MAN3)) {
if ( $self->{"${man}PODS"}
or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/
) {
$self->{"${man}PODS"} ||= {};
}
else {
my $init_method = "init_${man}PODS";
$self->$init_method();
}
}
}
sub _has_pod {
my($self, $file) = @_;
my($ispod)=0;
if (open( my $fh, '<', $file )) {
while (<$fh>) {
if (/^=(?:head\d+|item|pod)\b/) {
$ispod=1;
last;
}
}
close $fh;
} else {
# If it doesn't exist yet, we assume, it has pods in it
$ispod = 1;
}
return $ispod;
}
=item init_MAN1PODS
Initializes MAN1PODS from the list of EXE_FILES.
=cut
sub init_MAN1PODS {
my($self) = @_;
if ( exists $self->{EXE_FILES} ) {
foreach my $name (@{$self->{EXE_FILES}}) {
next unless $self->_has_pod($name);
$self->{MAN1PODS}->{$name} =
$self->catfile("\$(INST_MAN1DIR)",
basename($name).".\$(MAN1EXT)");
}
}
}
=item init_MAN3PODS
Initializes MAN3PODS from the list of PM files.
=cut
sub init_MAN3PODS {
my $self = shift;
my %manifypods = (); # we collect the keys first, i.e. the files
# we have to convert to pod
foreach my $name (keys %{$self->{PM}}) {
if ($name =~ /\.pod\z/ ) {
$manifypods{$name} = $self->{PM}{$name};
} elsif ($name =~ /\.p[ml]\z/ ) {
if( $self->_has_pod($name) ) {
$manifypods{$name} = $self->{PM}{$name};
}
}
}
my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
# Remove "Configure.pm" and similar, if it's not the only pod listed
# To force inclusion, just name it "Configure.pod", or override
# MAN3PODS
foreach my $name (keys %manifypods) {
if (
($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) or
( $name =~ m/^README\.pod$/i ) # don't manify top-level README.pod
) {
delete $manifypods{$name};
next;
}
my($manpagename) = $name;
$manpagename =~ s/\.p(od|m|l)\z//;
# everything below lib is ok
unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) {
$manpagename = $self->catfile(
split(/::/,$self->{PARENT_NAME}),$manpagename
);
}
$manpagename = $self->replace_manpage_separator($manpagename);
$self->{MAN3PODS}->{$name} =
$self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
}
}
=item init_PM
Initializes PMLIBDIRS and PM from PMLIBDIRS.
=cut
sub init_PM {
my $self = shift;
# Some larger extensions often wish to install a number of *.pm/pl
# files into the library in various locations.
# The attribute PMLIBDIRS holds an array reference which lists
# subdirectories which we should search for library files to
# install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We
# recursively search through the named directories (skipping any
# which don't exist or contain Makefile.PL files).
# For each *.pm or *.pl file found $self->libscan() is called with
# the default installation path in $_[1]. The return value of
# libscan defines the actual installation location. The default
# libscan function simply returns the path. The file is skipped
# if libscan returns false.
# The default installation location passed to libscan in $_[1] is:
#
# ./*.pm => $(INST_LIBDIR)/*.pm
# ./xyz/... => $(INST_LIBDIR)/xyz/...
# ./lib/... => $(INST_LIB)/...
#
# In this way the 'lib' directory is seen as the root of the actual
# perl library whereas the others are relative to INST_LIBDIR
# (which includes PARENT_NAME). This is a subtle distinction but one
# that's important for nested modules.
unless( $self->{PMLIBDIRS} ) {
if( $Is{VMS} ) {
# Avoid logical name vs directory collisions
$self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"];
}
else {
$self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}];
}
}
#only existing directories that aren't in $dir are allowed
# Avoid $_ wherever possible:
# @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}};
my (@pmlibdirs) = @{$self->{PMLIBDIRS}};
@{$self->{PMLIBDIRS}} = ();
my %dir = map { ($_ => $_) } @{$self->{DIR}};
foreach my $pmlibdir (@pmlibdirs) {
-d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir;
}
unless( $self->{PMLIBPARENTDIRS} ) {
@{$self->{PMLIBPARENTDIRS}} = ('lib');
}
return if $self->{PM} and $self->{ARGS}{PM};
if (@{$self->{PMLIBDIRS}}){
print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n"
if ($Verbose >= 2);
require File::Find;
File::Find::find(sub {
if (-d $_){
unless ($self->libscan($_)){
$File::Find::prune = 1;
}
return;
}
return if /\#/;
return if /~$/; # emacs temp files
return if /,v$/; # RCS files
return if m{\.swp$}; # vim swap files
my $path = $File::Find::name;
my $prefix = $self->{INST_LIBDIR};
my $striplibpath;
my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
$prefix = $self->{INST_LIB}
if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W}
{$1}i;
my($inst) = $self->catfile($prefix,$striplibpath);
local($_) = $inst; # for backwards compatibility
$inst = $self->libscan($inst);
print "libscan($path) => '$inst'\n" if ($Verbose >= 2);
return unless $inst;
if ($self->{XSMULTI} and $inst =~ /\.xs\z/) {
my($base); ($base = $path) =~ s/\.xs\z//;
$self->{XS}{$path} = "$base.c";
push @{$self->{C}}, "$base.c";
push @{$self->{O_FILES}}, "$base$self->{OBJ_EXT}";
} else {
$self->{PM}{$path} = $inst;
}
}, @{$self->{PMLIBDIRS}});
}
}
=item init_DIRFILESEP
Using / for Unix. Called by init_main.
=cut
sub init_DIRFILESEP {
my($self) = shift;
$self->{DIRFILESEP} = '/';
}
=item init_main
Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE,
EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*,
INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME,
OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB,
PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION,
VERSION_SYM, XS_VERSION.
=cut
sub init_main {
my($self) = @_;
# --- Initialize Module Name and Paths
# NAME = Foo::Bar::Oracle
# FULLEXT = Foo/Bar/Oracle
# BASEEXT = Oracle
# PARENT_NAME = Foo::Bar
### Only UNIX:
### ($self->{FULLEXT} =
### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket
$self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME});
# Copied from DynaLoader:
my(@modparts) = split(/::/,$self->{NAME});
my($modfname) = $modparts[-1];
# Some systems have restrictions on files names for DLL's etc.
# mod2fname returns appropriate file base name (typically truncated)
# It may also edit @modparts if required.
# We require DynaLoader to make sure that mod2fname is loaded
eval { require DynaLoader };
if (defined &DynaLoader::mod2fname) {
$modfname = &DynaLoader::mod2fname(\@modparts);
}
($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ;
$self->{PARENT_NAME} ||= '';
if (defined &DynaLoader::mod2fname) {
# As of 5.001m, dl_os2 appends '_'
$self->{DLBASE} = $modfname;
} else {
$self->{DLBASE} = '$(BASEEXT)';
}
# --- Initialize PERL_LIB, PERL_SRC
# *Real* information: where did we get these two from? ...
my $inc_config_dir = dirname($INC{'Config.pm'});
my $inc_carp_dir = dirname($INC{'Carp.pm'});
unless ($self->{PERL_SRC}){
foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting
my $dir = $self->catdir(($Updir) x $dir_count);
if (-f $self->catfile($dir,"config_h.SH") &&
-f $self->catfile($dir,"perl.h") &&
-f $self->catfile($dir,"lib","strict.pm")
) {
$self->{PERL_SRC}=$dir ;
last;
}
}
}
warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if
$self->{PERL_CORE} and !$self->{PERL_SRC};
if ($self->{PERL_SRC}){
$self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib");
$self->{PERL_ARCHLIB} = $self->{PERL_LIB};
$self->{PERL_INC} = ($Is{Win32}) ?
$self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};
# catch a situation that has occurred a few times in the past:
unless (
-s $self->catfile($self->{PERL_SRC},'cflags')
or
$Is{VMS}
&&
-s $self->catfile($self->{PERL_SRC},'vmsish.h')
or
$Is{Win32}
){
warn qq{
You cannot build extensions below the perl source tree after executing
a 'make clean' in the perl source tree.
To rebuild extensions distributed with the perl source you should
simply Configure (to include those extensions) and then build perl as
normal. After installing perl the source tree can be deleted. It is
not needed for building extensions by running 'perl Makefile.PL'
usually without extra arguments.
It is recommended that you unpack and build additional extensions away
from the perl source tree.
};
}
} else {
# we should also consider $ENV{PERL5LIB} here
my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC};
$self->{PERL_LIB} ||= $Config{privlibexp};
$self->{PERL_ARCHLIB} ||= $Config{archlibexp};
$self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
my $perl_h;
if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
and not $old){
# Maybe somebody tries to build an extension with an
# uninstalled Perl outside of Perl build tree
my $lib;
for my $dir (@INC) {
$lib = $dir, last if -e $self->catfile($dir, "Config.pm");
}
if ($lib) {
# Win32 puts its header files in /perl/src/lib/CORE.
# Unix leaves them in /perl/src.
my $inc = $Is{Win32} ? $self->catdir($lib, "CORE" )
: dirname $lib;
if (-e $self->catfile($inc, "perl.h")) {
$self->{PERL_LIB} = $lib;
$self->{PERL_ARCHLIB} = $lib;
$self->{PERL_INC} = $inc;
$self->{UNINSTALLED_PERL} = 1;
print <<EOP;
... Detected uninstalled Perl. Trying to continue.
EOP
}
}
}
}
if ($Is{Android}) {
# Android fun times!
# ../../perl -I../../lib -MFile::Glob -e1 works
# ../../../perl -I../../../lib -MFile::Glob -e1 fails to find
# the .so for File::Glob.
# This always affects core perl, but may also affect an installed
# perl built with -Duserelocatableinc.
$self->{PERL_LIB} = File::Spec->rel2abs($self->{PERL_LIB});
$self->{PERL_ARCHLIB} = File::Spec->rel2abs($self->{PERL_ARCHLIB});
}
$self->{PERL_INCDEP} = $self->{PERL_INC};
$self->{PERL_ARCHLIBDEP} = $self->{PERL_ARCHLIB};
# We get SITELIBEXP and SITEARCHEXP directly via
# Get_from_Config. When we are running standard modules, these
# won't matter, we will set INSTALLDIRS to "perl". Otherwise we
# set it to "site". I prefer that INSTALLDIRS be set from outside
# MakeMaker.
$self->{INSTALLDIRS} ||= "site";
$self->{MAN1EXT} ||= $Config{man1ext};
$self->{MAN3EXT} ||= $Config{man3ext};
# Get some stuff out of %Config if we haven't yet done so
print "CONFIG must be an array ref\n"
if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY');
$self->{CONFIG} = [] unless (ref $self->{CONFIG});
push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config);
push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags};
my(%once_only);
foreach my $m (@{$self->{CONFIG}}){
next if $once_only{$m};
print "CONFIG key '$m' does not exist in Config.pm\n"
unless exists $Config{$m};
$self->{uc $m} ||= $Config{$m};
$once_only{$m} = 1;
}
# This is too dangerous:
# if ($^O eq "next") {
# $self->{AR} = "libtool";
# $self->{AR_STATIC_ARGS} = "-o";
# }
# But I leave it as a placeholder
$self->{AR_STATIC_ARGS} ||= "cr";
# These should never be needed
$self->{OBJ_EXT} ||= '.o';
$self->{LIB_EXT} ||= '.a';
$self->{MAP_TARGET} ||= "perl";
$self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}";
# make a simple check if we find strict
warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory
(strict.pm not found)"
unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") ||
$self->{NAME} eq "ExtUtils::MakeMaker";
}
=item init_tools
Initializes tools to use their common (and faster) Unix commands.
=cut
sub init_tools {
my $self = shift;
$self->{ECHO} ||= 'echo';
$self->{ECHO_N} ||= 'echo -n';
$self->{RM_F} ||= "rm -f";
$self->{RM_RF} ||= "rm -rf";
$self->{TOUCH} ||= "touch";
$self->{TEST_F} ||= "test -f";
$self->{TEST_S} ||= "test -s";
$self->{CP} ||= "cp";
$self->{MV} ||= "mv";
$self->{CHMOD} ||= "chmod";
$self->{FALSE} ||= 'false';
$self->{TRUE} ||= 'true';
$self->{LD} ||= 'ld';
return $self->SUPER::init_tools(@_);
# After SUPER::init_tools so $Config{shell} has a
# chance to get set.
$self->{SHELL} ||= '/bin/sh';
return;
}
=item init_linker
Unix has no need of special linker flags.
=cut
sub init_linker {
my($self) = shift;
$self->{PERL_ARCHIVE} ||= '';
$self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
=begin _protected
=item init_lib2arch
$mm->init_lib2arch
=end _protected
=cut
sub init_lib2arch {
my($self) = shift;
# The user who requests an installation directory explicitly
# should not have to tell us an architecture installation directory
# as well. We look if a directory exists that is named after the
# architecture. If not we take it as a sign that it should be the
# same as the requested installation directory. Otherwise we take
# the found one.
for my $libpair ({l=>"privlib", a=>"archlib"},
{l=>"sitelib", a=>"sitearch"},
{l=>"vendorlib", a=>"vendorarch"},
)
{
my $lib = "install$libpair->{l}";
my $Lib = uc $lib;
my $Arch = uc "install$libpair->{a}";
if( $self->{$Lib} && ! $self->{$Arch} ){
my($ilib) = $Config{$lib};
$self->prefixify($Arch,$ilib,$self->{$Lib});
unless (-d $self->{$Arch}) {
print "Directory $self->{$Arch} not found\n"
if $Verbose;
$self->{$Arch} = $self->{$Lib};
}
print "Defaulting $Arch to $self->{$Arch}\n" if $Verbose;
}
}
}
=item init_PERL
$mm->init_PERL;
Called by init_main. Sets up ABSPERL, PERL, FULLPERL and all the
*PERLRUN* permutations.
PERL is allowed to be miniperl
FULLPERL must be a complete perl
ABSPERL is PERL converted to an absolute path
*PERLRUN contains everything necessary to run perl, find it's
libraries, etc...
*PERLRUNINST is *PERLRUN + everything necessary to find the
modules being built.
=cut
sub init_PERL {
my($self) = shift;
my @defpath = ();
foreach my $component ($self->{PERL_SRC}, $self->path(),
$Config{binexp})
{
push @defpath, $component if defined $component;
}
# Build up a set of file names (not command names).
my $thisperl = $self->canonpath($^X);
$thisperl .= $Config{exe_ext} unless
# VMS might have a file version # at the end
$Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i
: $thisperl =~ m/$Config{exe_ext}$/i;
# We need a relative path to perl when in the core.
$thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE};
my @perls = ($thisperl);
push @perls, map { "$_$Config{exe_ext}" }
("perl$Config{version}", 'perl5', 'perl');
# miniperl has priority over all but the canonical perl when in the
# core. Otherwise its a last resort.
my $miniperl = "miniperl$Config{exe_ext}";
if( $self->{PERL_CORE} ) {
splice @perls, 1, 0, $miniperl;
}
else {
push @perls, $miniperl;
}
$self->{PERL} ||=
$self->find_perl(5.0, \@perls, \@defpath, $Verbose );
my $perl = $self->{PERL};
$perl =~ s/^"//;
my $has_mcr = $perl =~ s/^MCR\s*//;
my $perlflags = '';
my $stripped_perl;
while ($perl) {
($stripped_perl = $perl) =~ s/"$//;
last if -x $stripped_perl;
last unless $perl =~ s/(\s+\S+)$//;
$perlflags = $1.$perlflags;
}
$self->{PERL} = $stripped_perl;
$self->{PERL} = 'MCR '.$self->{PERL} if $has_mcr || $Is{VMS};
# When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe.
my $perl_name = 'perl';
$perl_name = 'ndbgperl' if $Is{VMS} &&
defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define';
# XXX This logic is flawed. If "miniperl" is anywhere in the path
# it will get confused. It should be fixed to work only on the filename.
# Define 'FULLPERL' to be a non-miniperl (used in test: target)
unless ($self->{FULLPERL}) {
($self->{FULLPERL} = $self->{PERL}) =~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i;
$self->{FULLPERL} = qq{"$self->{FULLPERL}"}.$perlflags;
}
# Can't have an image name with quotes, and findperl will have
# already escaped spaces.
$self->{FULLPERL} =~ tr/"//d if $Is{VMS};
# Little hack to get around VMS's find_perl putting "MCR" in front
# sometimes.
$self->{ABSPERL} = $self->{PERL};
$has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//;
if( $self->file_name_is_absolute($self->{ABSPERL}) ) {
$self->{ABSPERL} = '$(PERL)';
}
else {
$self->{ABSPERL} = $self->rel2abs($self->{ABSPERL});
# Quote the perl command if it contains whitespace
$self->{ABSPERL} = $self->quote_literal($self->{ABSPERL})
if $self->{ABSPERL} =~ /\s/;
$self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr;
}
$self->{PERL} = qq{"$self->{PERL}"}.$perlflags;
# Can't have an image name with quotes, and findperl will have
# already escaped spaces.
$self->{PERL} =~ tr/"//d if $Is{VMS};
# Are we building the core?
$self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE};
$self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE};
# Make sure perl can find itself before it's installed.
my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE}
? ( $self->{PERL_ARCHLIB} && $self->{PERL_LIB} && $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ) ?
q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"}
: undef;
my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB}
? 'RUN)'.$perlflags.' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"'
: 'RUN)'.$perlflags.' "-I$(INST_LIB)"';
# How do we run perl?
foreach my $perl (qw(PERL FULLPERL ABSPERL)) {
my $run = $perl.'RUN';
$self->{$run} = qq{\$($perl)};
$self->{$run} .= $lib_paths if $lib_paths;
$self->{$perl.'RUNINST'} = '$('.$perl.$inst_lib_paths;
}
return 1;
}
=item init_platform
=item platform_constants
Add MM_Unix_VERSION.
=cut
sub init_platform {
my($self) = shift;
$self->{MM_Unix_VERSION} = $VERSION;
$self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '.
'-Dfree=Perl_mfree -Drealloc=Perl_realloc '.
'-Dcalloc=Perl_calloc';
}
sub platform_constants {
my($self) = shift;
my $make_frag = '';
foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF))
{
next unless defined $self->{$macro};
$make_frag .= "$macro = $self->{$macro}\n";
}
return $make_frag;
}
=item init_PERM
$mm->init_PERM
Called by init_main. Initializes PERL_*
=cut
sub init_PERM {
my($self) = shift;
$self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR};
$self->{PERM_RW} = 644 unless defined $self->{PERM_RW};
$self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX};
return 1;
}
=item init_xs
$mm->init_xs
Sets up macros having to do with XS code. Currently just INST_STATIC,
INST_DYNAMIC and INST_BOOT.
=cut
sub init_xs {
my $self = shift;
if ($self->has_link_code()) {
$self->{INST_STATIC} =
$self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)');
$self->{INST_DYNAMIC} =
$self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)');
$self->{INST_BOOT} =
$self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs');
if ($self->{XSMULTI}) {
my @exts = $self->_xs_list_basenames;
my (@statics, @dynamics, @boots);
for my $ext (@exts) {
my ($v, $d, $f) = File::Spec->splitpath($ext);
my @d = File::Spec->splitdir($d);
shift @d if defined $d[0] and $d[0] eq 'lib';
my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
my $instfile = $self->catfile($instdir, $f);
push @statics, "$instfile\$(LIB_EXT)";
# Dynamic library names may need special handling.
my $dynfile = $instfile;
eval { require DynaLoader };
if (defined &DynaLoader::mod2fname) {
$dynfile = $self->catfile($instdir, &DynaLoader::mod2fname([@d, $f]));
}
push @dynamics, "$dynfile.\$(DLEXT)";
push @boots, "$instfile.bs";
}
$self->{INST_STATIC} = join ' ', @statics;
$self->{INST_DYNAMIC} = join ' ', @dynamics;
$self->{INST_BOOT} = join ' ', @boots;
}
} else {
$self->{INST_STATIC} = '';
$self->{INST_DYNAMIC} = '';
$self->{INST_BOOT} = '';
}
}
=item install (o)
Defines the install target.
=cut
sub install {
my($self, %attribs) = @_;
my(@m);
push @m, q{
install :: pure_install doc_install
$(NOECHO) $(NOOP)
install_perl :: pure_perl_install doc_perl_install
$(NOECHO) $(NOOP)
install_site :: pure_site_install doc_site_install
$(NOECHO) $(NOOP)
install_vendor :: pure_vendor_install doc_vendor_install
$(NOECHO) $(NOOP)
pure_install :: pure_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
pure__install : pure_site_install
$(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
doc__install : doc_site_install
$(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
pure_perl_install :: all
$(NOECHO) $(MOD_INSTALL) \
};
push @m,
q{ read "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
write "}.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
q{ "$(INST_LIB)" "$(DESTINSTALLPRIVLIB)" \
"$(INST_ARCHLIB)" "$(DESTINSTALLARCHLIB)" \
"$(INST_BIN)" "$(DESTINSTALLBIN)" \
"$(INST_SCRIPT)" "$(DESTINSTALLSCRIPT)" \
"$(INST_MAN1DIR)" "$(DESTINSTALLMAN1DIR)" \
"$(INST_MAN3DIR)" "$(DESTINSTALLMAN3DIR)"
$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
"}.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{"
pure_site_install :: all
$(NOECHO) $(MOD_INSTALL) \
};
push @m,
q{ read "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
write "}.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
q{ "$(INST_LIB)" "$(DESTINSTALLSITELIB)" \
"$(INST_ARCHLIB)" "$(DESTINSTALLSITEARCH)" \
"$(INST_BIN)" "$(DESTINSTALLSITEBIN)" \
"$(INST_SCRIPT)" "$(DESTINSTALLSITESCRIPT)" \
"$(INST_MAN1DIR)" "$(DESTINSTALLSITEMAN1DIR)" \
"$(INST_MAN3DIR)" "$(DESTINSTALLSITEMAN3DIR)"
$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
"}.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{"
pure_vendor_install :: all
$(NOECHO) $(MOD_INSTALL) \
};
push @m,
q{ read "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
write "}.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
q{ "$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \
"$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \
"$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \
"$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \
"$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \
"$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)"
};
push @m, q{
doc_perl_install :: all
$(NOECHO) $(NOOP)
doc_site_install :: all
$(NOECHO) $(NOOP)
doc_vendor_install :: all
$(NOECHO) $(NOOP)
} if $self->{NO_PERLLOCAL};
push @m, q{
doc_perl_install :: all
$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
"installed into" "$(INSTALLPRIVLIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
>> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
doc_site_install :: all
$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
"installed into" "$(INSTALLSITELIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
>> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
doc_vendor_install :: all
$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
"installed into" "$(INSTALLVENDORLIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
>> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
} unless $self->{NO_PERLLOCAL};
push @m, q{
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
$(NOECHO) $(NOOP)
uninstall_from_perldirs ::
$(NOECHO) $(UNINSTALL) "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{"
uninstall_from_sitedirs ::
$(NOECHO) $(UNINSTALL) "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
uninstall_from_vendordirs ::
$(NOECHO) $(UNINSTALL) "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
};
join("",@m);
}
=item installbin (o)
Defines targets to make and to install EXE_FILES.
=cut
sub installbin {
my($self) = shift;
return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
my @exefiles = sort @{$self->{EXE_FILES}};
return "" unless @exefiles;
@exefiles = map vmsify($_), @exefiles if $Is{VMS};
my %fromto;
for my $from (@exefiles) {
my($path)= $self->catfile('$(INST_SCRIPT)', basename($from));
local($_) = $path; # for backwards compatibility
my $to = $self->libscan($path);
print "libscan($from) => '$to'\n" if ($Verbose >=2);
$to = vmsify($to) if $Is{VMS};
$fromto{$from} = $to;
}
my @to = sort values %fromto;
my @m;
push(@m, qq{
EXE_FILES = @exefiles
pure_all :: @to
\$(NOECHO) \$(NOOP)
realclean ::
});
# realclean can get rather large.
push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to);
push @m, "\n";
# A target for each exe file.
my @froms = sort keys %fromto;
for my $from (@froms) {
# 1 2
push @m, _sprintf562 <<'MAKE', $from, $fromto{$from};
%2$s : %1$s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists
$(NOECHO) $(RM_F) %2$s
$(CP) %1$s %2$s
$(FIXIN) %2$s
-$(NOECHO) $(CHMOD) $(PERM_RWX) %2$s
MAKE
}
join "", @m;
}
=item linkext (o)
Defines the linkext target which in turn defines the LINKTYPE.
=cut
# LINKTYPE => static or dynamic or ''
sub linkext {
my($self, %attribs) = @_;
my $linktype = $attribs{LINKTYPE};
$linktype = $self->{LINKTYPE} unless defined $linktype;
if (defined $linktype and $linktype eq '') {
warn "Warning: LINKTYPE set to '', no longer necessary\n";
}
$linktype = '$(LINKTYPE)' unless defined $linktype;
"
linkext :: $linktype
\$(NOECHO) \$(NOOP)
";
}
=item lsdir
Takes as arguments a directory name and a regular expression. Returns
all entries in the directory that match the regular expression.
=cut
sub lsdir {
# $self
my(undef, $dir, $regex) = @_;
opendir(my $dh, defined($dir) ? $dir : ".")
or return;
my @ls = readdir $dh;
closedir $dh;
@ls = grep(/$regex/, @ls) if defined $regex;
@ls;
}
=item macro (o)
Simple subroutine to insert the macros defined by the macro attribute
into the Makefile.
=cut
sub macro {
my($self,%attribs) = @_;
my @m;
foreach my $key (sort keys %attribs) {
my $val = $attribs{$key};
push @m, "$key = $val\n";
}
join "", @m;
}
=item makeaperl (o)
Called by staticmake. Defines how to write the Makefile to produce a
static new perl.
By default the Makefile produced includes all the static extensions in
the perl library. (Purified versions of library files, e.g.,
DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.)
=cut
sub makeaperl {
my($self, %attribs) = @_;
my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
@attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
s/^(.*)/"-I$1"/ for @{$perlinc || []};
my(@m);
push @m, "
# --- MakeMaker makeaperl section ---
MAP_TARGET = $target
FULLPERL = $self->{FULLPERL}
MAP_PERLINC = @{$perlinc || []}
";
return join '', @m if $self->{PARENT};
my($dir) = join ":", @{$self->{DIR}};
unless ($self->{MAKEAPERL}) {
push @m, q{
$(MAP_TARGET) :: $(MAKE_APERL_FILE)
$(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@
$(MAKE_APERL_FILE) : static $(FIRST_MAKEFILE) pm_to_blib
$(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
$(NOECHO) $(PERLRUNINST) \
Makefile.PL DIR="}, $dir, q{" \
MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
foreach (@ARGV){
my $arg = $_; # avoid lvalue aliasing
if ( $arg =~ /(^.*?=)(.*['\s].*)/ ) {
$arg = $1 . $self->quote_literal($2);
}
push @m, " \\\n\t\t$arg";
}
push @m, "\n";
return join '', @m;
}
my $cccmd = $self->const_cccmd($libperl);
$cccmd =~ s/^CCCMD\s*=\s*//;
$cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /;
$cccmd .= " $Config{cccdlflags}"
if ($Config{useshrplib} eq 'true');
$cccmd =~ s/\(CC\)/\(PERLMAINCC\)/;
# The front matter of the linkcommand...
my $linkcmd = join ' ', "\$(CC)",
grep($_, @Config{qw(ldflags ccdlflags)});
$linkcmd =~ s/\s+/ /g;
$linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;
# Which *.a files could we make use of...
my $staticlib21 = $self->_find_static_libs($searchdirs);
# We trust that what has been handed in as argument, will be buildable
$static = [] unless $static;
@$staticlib21{@{$static}} = (1) x @{$static};
$extra = [] unless $extra && ref $extra eq 'ARRAY';
for (sort keys %$staticlib21) {
next unless /\Q$self->{LIB_EXT}\E\z/;
$_ = dirname($_) . "/extralibs.ld";
push @$extra, $_;
}
s/^(.*)/"-I$1"/ for @{$perlinc || []};
$target ||= "perl";
$tmp ||= ".";
# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we
# regenerate the Makefiles, MAP_STATIC and the dependencies for
# extralibs.all are computed correctly
my @map_static = reverse sort keys %$staticlib21;
push @m, "
MAP_LINKCMD = $linkcmd
MAP_STATIC = ", join(" \\\n\t", map { qq{"$_"} } @map_static), "
MAP_STATICDEP = ", join(' ', map { $self->quote_dep($_) } @map_static), "
MAP_PRELIBS = $Config{perllibs} $Config{cryptlib}
";
my $lperl;
if (defined $libperl) {
($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/;
}
unless ($libperl && -f $lperl) { # Ilya's code...
my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE";
$dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL};
$libperl ||= "libperl$self->{LIB_EXT}";
$libperl = "$dir/$libperl";
$lperl ||= "libperl$self->{LIB_EXT}";
$lperl = "$dir/$lperl";
if (! -f $libperl and ! -f $lperl) {
# We did not find a static libperl. Maybe there is a shared one?
if ($Is{SunOS}) {
$lperl = $libperl = "$dir/$Config{libperl}";
# SUNOS ld does not take the full path to a shared library
$libperl = '' if $Is{SunOS4};
}
}
print <<EOF unless -f $lperl || defined($self->{PERL_SRC});
Warning: $libperl not found
If you're going to build a static perl binary, make sure perl is installed
otherwise ignore this warning
EOF
}
# SUNOS ld does not take the full path to a shared library
my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl';
my $libperl_dep = $self->quote_dep($libperl);
push @m, "
MAP_LIBPERL = $libperl
MAP_LIBPERLDEP = $libperl_dep
LLIBPERL = $llibperl
";
push @m, '
$(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).'
$(NOECHO) $(RM_F) $@
$(NOECHO) $(TOUCH) $@
';
foreach my $catfile (@$extra){
push @m, "\tcat $catfile >> \$\@\n";
}
my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)';
# 1 2 3 4
push @m, _sprintf562 <<'EOF', $tmp, $ldfrom, $self->xs_obj_opt('$@'), $makefilename;
$(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all
$(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS)
$(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call"
$(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s inst_perl MAP_TARGET=$(MAP_TARGET)"
$(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s map_clean"
%1$s/perlmain\$(OBJ_EXT): %1$s/perlmain.c
EOF
push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n";
my $maybe_DynaLoader = $Config{usedl} ? 'q(DynaLoader)' : '';
push @m, _sprintf562 <<'EOF', $tmp, $makefilename, $maybe_DynaLoader;
%1$s/perlmain.c: %2$s
$(NOECHO) $(ECHO) Writing $@
$(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \
-e "writemain(grep(s#.*/auto/##s, @ARGV), %3$s)" $(MAP_STATIC) > $@t
$(MV) $@t $@
EOF
push @m, "\t", q{$(NOECHO) $(PERL) "$(INSTALLSCRIPT)/fixpmain"
} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0);
push @m, q{
doc_inst_perl :
$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
-$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Perl binary" "$(MAP_TARGET)" \
MAP_STATIC "$(MAP_STATIC)" \
MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
MAP_LIBPERL "$(MAP_LIBPERL)" \
>> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
};
push @m, q{
inst_perl : pure_inst_perl doc_inst_perl
pure_inst_perl : $(MAP_TARGET)
}.$self->{CP}.q{ $(MAP_TARGET) "}.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{"
clean :: map_clean
map_clean :
}.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all
};
join '', @m;
}
# utility method
sub _find_static_libs {
my ($self, $searchdirs) = @_;
# don't use File::Spec here because on Win32 F::F still uses "/"
my $installed_version = join('/',
'auto', $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}"
);
my %staticlib21;
require File::Find;
File::Find::find(sub {
if ($File::Find::name =~ m{/auto/share\z}) {
# in a subdir of auto/share, prune because e.g.
# Alien::pkgconfig uses File::ShareDir to put .a files
# there. do not want
$File::Find::prune = 1;
return;
}
return unless m/\Q$self->{LIB_EXT}\E$/;
return unless -f 'extralibs.ld'; # this checks is a "proper" XS installation
# Skip perl's libraries.
return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/;
# Skip purified versions of libraries
# (e.g., DynaLoader_pure_p1_c0_032.a)
return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure";
if( exists $self->{INCLUDE_EXT} ){
my $found = 0;
(my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
# Throw away anything not explicitly marked for inclusion.
# DynaLoader is implied.
foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
if( $xx eq $incl ){
$found++;
last;
}
}
return unless $found;
}
elsif( exists $self->{EXCLUDE_EXT} ){
(my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
# Throw away anything explicitly marked for exclusion
foreach my $excl (@{$self->{EXCLUDE_EXT}}){
return if( $xx eq $excl );
}
}
# don't include the installed version of this extension. I
# leave this line here, although it is not necessary anymore:
# I patched minimod.PL instead, so that Miniperl.pm won't
# include duplicates
# Once the patch to minimod.PL is in the distribution, I can
# drop it
return if $File::Find::name =~ m:\Q$installed_version\E\z:;
return if !$self->xs_static_lib_is_xs($_);
use Cwd 'cwd';
$staticlib21{cwd() . "/" . $_}++;
}, grep( -d $_, map { $self->catdir($_, 'auto') } @{$searchdirs || []}) );
return \%staticlib21;
}
=item xs_static_lib_is_xs (o)
Called by a utility method of makeaperl. Checks whether a given file
is an XS library by seeing whether it defines any symbols starting
with C<boot_>.
=cut
sub xs_static_lib_is_xs {
my ($self, $libfile) = @_;
my $devnull = File::Spec->devnull;
return `nm $libfile 2>$devnull` =~ /\bboot_/;
}
=item makefile (o)
Defines how to rewrite the Makefile.
=cut
sub makefile {
my($self) = shift;
my $m;
# We do not know what target was originally specified so we
# must force a manual rerun to be sure. But as it should only
# happen very rarely it is not a significant problem.
$m = '
$(OBJECT) : $(FIRST_MAKEFILE)
' if $self->{OBJECT};
my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?';
my $mpl_args = join " ", map qq["$_"], @ARGV;
my $cross = '';
if (defined $::Cross::platform) {
# Inherited from win32/buildext.pl
$cross = "-MCross=$::Cross::platform ";
}
$m .= sprintf <<'MAKE_FRAG', $newer_than_target, $cross, $mpl_args;
# We take a very conservative approach here, but it's worth it.
# We move Makefile to Makefile.old here to avoid gnu make looping.
$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP)
$(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s"
$(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..."
-$(NOECHO) $(RM_F) $(MAKEFILE_OLD)
-$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD)
- $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL)
$(PERLRUN) %sMakefile.PL %s
$(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <=="
$(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <=="
$(FALSE)
MAKE_FRAG
return $m;
}
=item maybe_command
Returns true, if the argument is likely to be a command.
=cut
sub maybe_command {
my($self,$file) = @_;
return $file if -x $file && ! -d $file;
return;
}
=item needs_linking (o)
Does this module need linking? Looks into subdirectory objects (see
also has_link_code())
=cut
sub needs_linking {
my($self) = shift;
my $caller = (caller(0))[3];
confess("needs_linking called too early") if
$caller =~ /^ExtUtils::MakeMaker::/;
return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING};
if ($self->has_link_code or $self->{MAKEAPERL}){
$self->{NEEDS_LINKING} = 1;
return 1;
}
foreach my $child (keys %{$self->{CHILDREN}}) {
if ($self->{CHILDREN}->{$child}->needs_linking) {
$self->{NEEDS_LINKING} = 1;
return 1;
}
}
return $self->{NEEDS_LINKING} = 0;
}
=item parse_abstract
parse a file and return what you think is the ABSTRACT
=cut
sub parse_abstract {
my($self,$parsefile) = @_;
my $result;
local $/ = "\n";
open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
binmode $fh;
my $inpod = 0;
my $pod_encoding;
my $package = $self->{DISTNAME};
$package =~ s/-/::/g;
while (<$fh>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if !$inpod;
s#\r*\n\z##; # handle CRLF input
if ( /^=encoding\s*(.*)$/i ) {
$pod_encoding = $1;
}
if ( /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x ) {
$result = $2;
next;
}
next unless $result;
if ( $result && ( /^\s*$/ || /^\=/ ) ) {
last;
}
$result = join ' ', $result, $_;
}
close $fh;
if ( $pod_encoding and !( $] < 5.008 or !$Config{useperlio} ) ) {
# Have to wrap in an eval{} for when running under PERL_CORE
# Encode isn't available during build phase and parsing
# ABSTRACT isn't important there
eval {
require Encode;
$result = Encode::decode($pod_encoding, $result);
}
}
return $result;
}
=item parse_version
my $version = MM->parse_version($file);
Parse a $file and return what $VERSION is set to by the first assignment.
It will return the string "undef" if it can't figure out what $VERSION
is. $VERSION should be for all to see, so C<our $VERSION> or plain $VERSION
are okay, but C<my $VERSION> is not.
C<<package Foo VERSION>> is also checked for. The first version
declaration found is used, but this may change as it differs from how
Perl does it.
parse_version() will try to C<use version> before checking for
C<$VERSION> so the following will work.
$VERSION = qv(1.2.3);
=cut
sub parse_version {
my($self,$parsefile) = @_;
my $result;
local $/ = "\n";
local $_;
open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
my $inpod = 0;
while (<$fh>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if $inpod || /^\s*#/;
chop;
next if /^\s*(if|unless|elsif)/;
if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* (;|\{) }x ) {
local $^W = 0;
$result = $1;
}
elsif ( m{(?<!\\) ([\$*]) (([\w\:\']*) \bVERSION)\b .* (?<![<>=!])\=[^=]}x ) {
$result = $self->get_version($parsefile, $1, $2);
}
else {
next;
}
last if defined $result;
}
close $fh;
if ( defined $result && $result !~ /^v?[\d_\.]+$/ ) {
require version;
my $normal = eval { version->new( $result ) };
$result = $normal if defined $normal;
}
$result = "undef" unless defined $result;
return $result;
}
sub get_version {
my ($self, $parsefile, $sigil, $name) = @_;
my $line = $_; # from the while() loop in parse_version
{
package ExtUtils::MakeMaker::_version;
undef *version; # in case of unexpected version() sub
eval {
require version;
version::->import;
};
no strict;
local *{$name};
local $^W = 0;
$line = $1 if $line =~ m{^(.+)}s;
eval($line); ## no critic
return ${$name};
}
}
=item pasthru (o)
Defines the string that is passed to recursive make calls in
subdirectories. The variables like C<PASTHRU_DEFINE> are used in each
level, and passed downwards on the command-line with e.g. the value of
that level's DEFINE. Example:
# Level 0 has DEFINE = -Dfunky
# This code will define level 0's PASTHRU=PASTHRU_DEFINE="$(DEFINE)
# $(PASTHRU_DEFINE)"
# Level 0's $(CCCMD) will include macros $(DEFINE) and $(PASTHRU_DEFINE)
# So will level 1's, so when level 1 compiles, it will get right values
# And so ad infinitum
=cut
sub pasthru {
my($self) = shift;
my(@m);
my(@pasthru);
my($sep) = $Is{VMS} ? ',' : '';
$sep .= "\\\n\t";
foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE
PREFIX INSTALL_BASE)
)
{
next unless defined $self->{$key};
push @pasthru, "$key=\"\$($key)\"";
}
foreach my $key (qw(DEFINE INC)) {
# default to the make var
my $val = qq{\$($key)};
# expand within perl if given since need to use quote_literal
# since INC might include space-protecting ""!
chomp($val = $self->{$key}) if defined $self->{$key};
$val .= " \$(PASTHRU_$key)";
my $quoted = $self->quote_literal($val);
push @pasthru, qq{PASTHRU_$key=$quoted};
}
push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n";
join "", @m;
}
=item perl_script
Takes one argument, a file name, and returns the file name, if the
argument is likely to be a perl script. On MM_Unix this is true for
any ordinary, readable file.
=cut
sub perl_script {
my($self,$file) = @_;
return $file if -r $file && -f _;
return;
}
=item perldepend (o)
Defines the dependency from all *.h files that come with the perl
distribution.
=cut
sub perldepend {
my($self) = shift;
my(@m);
my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm');
push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC};
# Check for unpropogated config.sh changes. Should never happen.
# We do NOT just update config.h because that is not sufficient.
# An out of date config.h is not fatal but complains loudly!
$(PERL_INCDEP)/config.h: $(PERL_SRC)/config.sh
-$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE)
$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
$(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh"
%s
MAKE_FRAG
return join "", @m unless $self->needs_linking;
if ($self->{OBJECT}) {
# Need to add an object file dependency on the perl headers.
# this is very important for XS modules in perl.git development.
push @m, $self->_perl_header_files_fragment("/"); # Directory separator between $(PERL_INC)/header.h
}
push @m, join(" ", sort values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}};
return join "\n", @m;
}
=item pm_to_blib
Defines target that copies all files in the hash PM to their
destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>
=cut
sub pm_to_blib {
my $self = shift;
my($autodir) = $self->catdir('$(INST_LIB)','auto');
my $r = q{
pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)
};
# VMS will swallow '' and PM_FILTER is often empty. So use q[]
my $pm_to_blib = $self->oneliner(<<CODE, ['-MExtUtils::Install']);
pm_to_blib({\@ARGV}, '$autodir', q[\$(PM_FILTER)], '\$(PERM_DIR)')
CODE
my @cmds = $self->split_command($pm_to_blib,
map { ($self->quote_literal($_) => $self->quote_literal($self->{PM}->{$_})) } sort keys %{$self->{PM}});
$r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds;
$r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n};
return $r;
}
# transform dot-separated version string into comma-separated quadruple
# examples: '1.2.3.4.5' => '1,2,3,4'
# '1.2.3' => '1,2,3,0'
sub _ppd_version {
my ($self, $string) = @_;
return join ',', ((split /\./, $string), (0) x 4)[0..3];
}
=item ppd
Defines target that creates a PPD (Perl Package Description) file
for a binary distribution.
=cut
sub ppd {
my($self) = @_;
my $abstract = $self->{ABSTRACT} || '';
$abstract =~ s/\n/\\n/sg;
$abstract =~ s/</&lt;/g;
$abstract =~ s/>/&gt;/g;
my $author = join(', ',@{ ref $self->{AUTHOR} eq 'ARRAY' ? $self->{AUTHOR} : [ $self->{AUTHOR} || '']});
$author =~ s/</&lt;/g;
$author =~ s/>/&gt;/g;
my $ppd_file = "$self->{DISTNAME}.ppd";
my @ppd_chunks = qq(<SOFTPKG NAME="$self->{DISTNAME}" VERSION="$self->{VERSION}">\n);
push @ppd_chunks, sprintf <<'PPD_HTML', $abstract, $author;
<ABSTRACT>%s</ABSTRACT>
<AUTHOR>%s</AUTHOR>
PPD_HTML
push @ppd_chunks, " <IMPLEMENTATION>\n";
if ( $self->{MIN_PERL_VERSION} ) {
my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION});
push @ppd_chunks, sprintf <<'PPD_PERLVERS', $min_perl_version;
<PERLCORE VERSION="%s" />
PPD_PERLVERS
}
# Don't add "perl" to requires. perl dependencies are
# handles by ARCHITECTURE.
my %prereqs = %{$self->{PREREQ_PM}};
delete $prereqs{perl};
# Build up REQUIRE
foreach my $prereq (sort keys %prereqs) {
my $name = $prereq;
$name .= '::' unless $name =~ /::/;
my $version = $prereqs{$prereq};
my %attrs = ( NAME => $name );
$attrs{VERSION} = $version if $version;
my $attrs = join " ", map { qq[$_="$attrs{$_}"] } sort keys %attrs;
push @ppd_chunks, qq( <REQUIRE $attrs />\n);
}
my $archname = $Config{archname};
if ($] >= 5.008) {
# archname did not change from 5.6 to 5.8, but those versions may
# not be not binary compatible so now we append the part of the
# version that changes when binary compatibility may change
$archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}";
}
push @ppd_chunks, sprintf <<'PPD_OUT', $archname;
<ARCHITECTURE NAME="%s" />
PPD_OUT
if ($self->{PPM_INSTALL_SCRIPT}) {
if ($self->{PPM_INSTALL_EXEC}) {
push @ppd_chunks, sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n},
$self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT};
}
else {
push @ppd_chunks, sprintf qq{ <INSTALL>%s</INSTALL>\n},
$self->{PPM_INSTALL_SCRIPT};
}
}
if ($self->{PPM_UNINSTALL_SCRIPT}) {
if ($self->{PPM_UNINSTALL_EXEC}) {
push @ppd_chunks, sprintf qq{ <UNINSTALL EXEC="%s">%s</UNINSTALL>\n},
$self->{PPM_UNINSTALL_EXEC}, $self->{PPM_UNINSTALL_SCRIPT};
}
else {
push @ppd_chunks, sprintf qq{ <UNINSTALL>%s</UNINSTALL>\n},
$self->{PPM_UNINSTALL_SCRIPT};
}
}
my ($bin_location) = $self->{BINARY_LOCATION} || '';
$bin_location =~ s/\\/\\\\/g;
push @ppd_chunks, sprintf <<'PPD_XML', $bin_location;
<CODEBASE HREF="%s" />
</IMPLEMENTATION>
</SOFTPKG>
PPD_XML
my @ppd_cmds = $self->stashmeta(join('', @ppd_chunks), $ppd_file);
return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds;
# Creates a PPD (Perl Package Description) for a binary distribution.
ppd :
%s
PPD_OUT
}
=item prefixify
$MM->prefixify($var, $prefix, $new_prefix, $default);
Using either $MM->{uc $var} || $Config{lc $var}, it will attempt to
replace it's $prefix with a $new_prefix.
Should the $prefix fail to match I<AND> a PREFIX was given as an
argument to WriteMakefile() it will set it to the $new_prefix +
$default. This is for systems whose file layouts don't neatly fit into
our ideas of prefixes.
This is for heuristics which attempt to create directory structures
that mirror those of the installed perl.
For example:
$MM->prefixify('installman1dir', '/usr', '/home/foo', 'man/man1');
this will attempt to remove '/usr' from the front of the
$MM->{INSTALLMAN1DIR} path (initializing it to $Config{installman1dir}
if necessary) and replace it with '/home/foo'. If this fails it will
simply use '/home/foo/man/man1'.
=cut
sub prefixify {
my($self,$var,$sprefix,$rprefix,$default) = @_;
my $path = $self->{uc $var} ||
$Config_Override{lc $var} || $Config{lc $var} || '';
$rprefix .= '/' if $sprefix =~ m|/$|;
warn " prefixify $var => $path\n" if $Verbose >= 2;
warn " from $sprefix to $rprefix\n" if $Verbose >= 2;
if( $self->{ARGS}{PREFIX} &&
$path !~ s{^\Q$sprefix\E\b}{$rprefix}s )
{
warn " cannot prefix, using default.\n" if $Verbose >= 2;
warn " no default!\n" if !$default && $Verbose >= 2;
$path = $self->catdir($rprefix, $default) if $default;
}
print " now $path\n" if $Verbose >= 2;
return $self->{uc $var} = $path;
}
=item processPL (o)
Defines targets to run *.PL files.
=cut
sub processPL {
my $self = shift;
my $pl_files = $self->{PL_FILES};
return "" unless $pl_files;
my $m = '';
foreach my $plfile (sort keys %$pl_files) {
my $list = ref($pl_files->{$plfile})
? $pl_files->{$plfile}
: [$pl_files->{$plfile}];
foreach my $target (@$list) {
if( $Is{VMS} ) {
$plfile = vmsify($self->eliminate_macros($plfile));
$target = vmsify($self->eliminate_macros($target));
}
# Normally a .PL file runs AFTER pm_to_blib so it can have
# blib in its @INC and load the just built modules. BUT if
# the generated module is something in $(TO_INST_PM) which
# pm_to_blib depends on then it can't depend on pm_to_blib
# else we have a dependency loop.
my $pm_dep;
my $perlrun;
if( defined $self->{PM}{$target} ) {
$pm_dep = '';
$perlrun = 'PERLRUN';
}
else {
$pm_dep = 'pm_to_blib';
$perlrun = 'PERLRUNINST';
}
$m .= <<MAKE_FRAG;
pure_all :: $target
\$(NOECHO) \$(NOOP)
$target :: $plfile $pm_dep
\$($perlrun) $plfile $target
MAKE_FRAG
}
}
return $m;
}
=item specify_shell
Specify SHELL if needed - not done on Unix.
=cut
sub specify_shell {
return '';
}
=item quote_paren
Backslashes parentheses C<()> in command line arguments.
Doesn't handle recursive Makefile C<$(...)> constructs,
but handles simple ones.
=cut
sub quote_paren {
my $arg = shift;
$arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g; # protect $(...)
$arg =~ s{(?<!\\)([()])}{\\$1}g; # quote unprotected
$arg =~ s{\$\\\\\((.+?)\\\\\)}{\$($1)}g; # unprotect $(...)
return $arg;
}
=item replace_manpage_separator
my $man_name = $MM->replace_manpage_separator($file_path);
Takes the name of a package, which may be a nested package, in the
form 'Foo/Bar.pm' and replaces the slash with C<::> or something else
safe for a man page file name. Returns the replacement.
=cut
sub replace_manpage_separator {
my($self,$man) = @_;
$man =~ s,/+,::,g;
return $man;
}
=item cd
=cut
sub cd {
my($self, $dir, @cmds) = @_;
# No leading tab and no trailing newline makes for easier embedding
my $make_frag = join "\n\t", map { "cd $dir && $_" } @cmds;
return $make_frag;
}
=item oneliner
=cut
sub oneliner {
my($self, $cmd, $switches) = @_;
$switches = [] unless defined $switches;
# Strip leading and trailing newlines
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
my @cmds = split /\n/, $cmd;
$cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds;
$cmd = $self->escape_newlines($cmd);
$switches = join ' ', @$switches;
return qq{\$(ABSPERLRUN) $switches -e $cmd --};
}
=item quote_literal
Quotes macro literal value suitable for being used on a command line so
that when expanded by make, will be received by command as given to
this method:
my $quoted = $mm->quote_literal(q{it isn't});
# returns:
# 'it isn'\''t'
print MAKEFILE "target:\n\techo $quoted\n";
# when run "make target", will output:
# it isn't
=cut
sub quote_literal {
my($self, $text, $opts) = @_;
$opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
# Quote single quotes
$text =~ s{'}{'\\''}g;
$text = $opts->{allow_variables}
? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
return "'$text'";
}
=item escape_newlines
=cut
sub escape_newlines {
my($self, $text) = @_;
$text =~ s{\n}{\\\n}g;
return $text;
}
=item max_exec_len
Using POSIX::ARG_MAX. Otherwise falling back to 4096.
=cut
sub max_exec_len {
my $self = shift;
if (!defined $self->{_MAX_EXEC_LEN}) {
if (my $arg_max = eval { require POSIX; &POSIX::ARG_MAX }) {
$self->{_MAX_EXEC_LEN} = $arg_max;
}
else { # POSIX minimum exec size
$self->{_MAX_EXEC_LEN} = 4096;
}
}
return $self->{_MAX_EXEC_LEN};
}
=item static (o)
Defines the static target.
=cut
sub static {
# --- Static Loading Sections ---
my($self) = shift;
'
## $(INST_PM) has been moved to the all: target.
## It remains here for awhile to allow for old usage: "make static"
static :: $(FIRST_MAKEFILE) $(INST_STATIC)
$(NOECHO) $(NOOP)
';
}
sub static_lib {
my($self) = @_;
return '' unless $self->has_link_code;
my(@m);
my @libs;
if ($self->{XSMULTI}) {
for my $ext ($self->_xs_list_basenames) {
my ($v, $d, $f) = File::Spec->splitpath($ext);
my @d = File::Spec->splitdir($d);
shift @d if $d[0] eq 'lib';
my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
my $instfile = $self->catfile($instdir, "$f\$(LIB_EXT)");
my $objfile = "$ext\$(OBJ_EXT)";
push @libs, [ $objfile, $instfile, $instdir ];
}
} else {
@libs = ([ qw($(OBJECT) $(INST_STATIC) $(INST_ARCHAUTODIR)) ]);
}
push @m, map { $self->xs_make_static_lib(@$_); } @libs;
join "\n", @m;
}
=item xs_make_static_lib
Defines the recipes for the C<static_lib> section.
=cut
sub xs_make_static_lib {
my ($self, $from, $to, $todir) = @_;
my @m = sprintf '%s: %s $(MYEXTLIB) %s$(DFSEP).exists'."\n", $to, $from, $todir;
push @m, "\t\$(RM_F) \"\$\@\"\n";
push @m, $self->static_lib_fixtures;
push @m, $self->static_lib_pure_cmd($from);
push @m, "\t\$(CHMOD) \$(PERM_RWX) \$\@\n";
push @m, $self->static_lib_closures($todir);
join '', @m;
}
=item static_lib_closures
Records C<$(EXTRALIBS)> in F<extralibs.ld> and F<$(PERL_SRC)/ext.libs>.
=cut
sub static_lib_closures {
my ($self, $todir) = @_;
my @m = sprintf <<'MAKE_FRAG', $todir;
$(NOECHO) $(ECHO) "$(EXTRALIBS)" > %s$(DFSEP)extralibs.ld
MAKE_FRAG
# Old mechanism - still available:
push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
$(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)$(DFSEP)ext.libs
MAKE_FRAG
@m;
}
=item static_lib_fixtures
Handles copying C<$(MYEXTLIB)> as starter for final static library that
then gets added to.
=cut
sub static_lib_fixtures {
my ($self) = @_;
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
return unless $self->{MYEXTLIB};
"\t\$(CP) \$(MYEXTLIB) \"\$\@\"\n";
}
=item static_lib_pure_cmd
Defines how to run the archive utility.
=cut
sub static_lib_pure_cmd {
my ($self, $from) = @_;
my $ar;
if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) {
# Prefer the absolute pathed ar if available so that PATH
# doesn't confuse us. Perl itself is built with the full_ar.
$ar = 'FULL_AR';
} else {
$ar = 'AR';
}
sprintf <<'MAKE_FRAG', $ar, $from;
$(%s) $(AR_STATIC_ARGS) "$@" %s
$(RANLIB) "$@"
MAKE_FRAG
}
=item staticmake (o)
Calls makeaperl.
=cut
sub staticmake {
my($self, %attribs) = @_;
my(@static);
my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB});
# And as it's not yet built, we add the current extension
# but only if it has some C code (or XS code, which implies C code)
if (@{$self->{C}}) {
@static = $self->catfile($self->{INST_ARCHLIB},
"auto",
$self->{FULLEXT},
"$self->{BASEEXT}$self->{LIB_EXT}"
);
}
# Either we determine now, which libraries we will produce in the
# subdirectories or we do it at runtime of the make.
# We could ask all subdir objects, but I cannot imagine, why it
# would be necessary.
# Instead we determine all libraries for the new perl at
# runtime.
my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB});
$self->makeaperl(MAKE => $self->{MAKEFILE},
DIRS => \@searchdirs,
STAT => \@static,
INCL => \@perlinc,
TARGET => $self->{MAP_TARGET},
TMP => "",
LIBPERL => $self->{LIBPERL_A}
);
}
=item subdir_x (o)
Helper subroutine for subdirs
=cut
sub subdir_x {
my($self, $subdir) = @_;
my $subdir_cmd = $self->cd($subdir,
'$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)'
);
return sprintf <<'EOT', $subdir_cmd;
subdirs ::
$(NOECHO) %s
EOT
}
=item subdirs (o)
Defines targets to process subdirectories.
=cut
sub subdirs {
# --- Sub-directory Sections ---
my($self) = shift;
my(@m);
# This method provides a mechanism to automatically deal with
# subdirectories containing further Makefile.PL scripts.
# It calls the subdir_x() method for each subdirectory.
foreach my $dir (@{$self->{DIR}}){
push @m, $self->subdir_x($dir);
#### print "Including $dir subdirectory\n";
}
if (@m){
unshift @m, <<'EOF';
# The default clean, realclean and test targets in this Makefile
# have automatically been given entries for each subdir.
EOF
} else {
push(@m, "\n# none")
}
join('',@m);
}
=item test (o)
Defines the test targets.
=cut
sub test {
my($self, %attribs) = @_;
my $tests = $attribs{TESTS} || '';
if (!$tests && -d 't' && defined $attribs{RECURSIVE_TEST_FILES}) {
$tests = $self->find_tests_recursive;
}
elsif (!$tests && -d 't') {
$tests = $self->find_tests;
}
# have to do this because nmake is broken
$tests =~ s!/!\\!g if $self->is_make_type('nmake');
# note: 'test.pl' name is also hardcoded in init_dirscan()
my @m;
my $default_testtype = $Config{usedl} ? 'dynamic' : 'static';
push @m, <<EOF;
TEST_VERBOSE=0
TEST_TYPE=test_\$(LINKTYPE)
TEST_FILE = test.pl
TEST_FILES = $tests
TESTDB_SW = -d
testdb :: testdb_\$(LINKTYPE)
\$(NOECHO) \$(NOOP)
test :: \$(TEST_TYPE)
\$(NOECHO) \$(NOOP)
# Occasionally we may face this degenerate target:
test_ : test_$default_testtype
\$(NOECHO) \$(NOOP)
EOF
for my $linktype (qw(dynamic static)) {
my $directdeps = join ' ', grep !$self->{SKIPHASH}{$_}, $linktype, "pure_all"; # no depend on a linktype if SKIPped
push @m, "subdirs-test_$linktype :: $directdeps\n";
foreach my $dir (@{ $self->{DIR} }) {
my $test = $self->cd($dir, "\$(MAKE) test_$linktype \$(PASTHRU)");
push @m, "\t\$(NOECHO) $test\n";
}
push @m, "\n";
if ($tests or -f "test.pl") {
for my $testspec ([ '', '' ], [ 'db', ' $(TESTDB_SW)' ]) {
my ($db, $switch) = @$testspec;
my ($command, $deps);
# if testdb, build all but don't test all
$deps = $db eq 'db' ? $directdeps : "subdirs-test_$linktype";
if ($linktype eq 'static' and $self->needs_linking) {
my $target = File::Spec->rel2abs('$(MAP_TARGET)');
$command = qq{"$target" \$(MAP_PERLINC)};
$deps .= ' $(MAP_TARGET)';
} else {
$command = '$(FULLPERLRUN)' . $switch;
}
push @m, "test${db}_$linktype :: $deps\n";
if ($db eq 'db') {
push @m, $self->test_via_script($command, '$(TEST_FILE)')
} else {
push @m, $self->test_via_script($command, '$(TEST_FILE)')
if -f "test.pl";
push @m, $self->test_via_harness($command, '$(TEST_FILES)')
if $tests;
}
push @m, "\n";
}
} else {
push @m, _sprintf562 <<'EOF', $linktype;
testdb_%1$s test_%1$s :: subdirs-test_%1$s
$(NOECHO) $(ECHO) 'No tests defined for $(NAME) extension.'
EOF
}
}
join "", @m;
}
=item test_via_harness (override)
For some reason which I forget, Unix machines like to have
PERL_DL_NONLAZY set for tests.
=cut
sub test_via_harness {
my($self, $perl, $tests) = @_;
return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests);
}
=item test_via_script (override)
Again, the PERL_DL_NONLAZY thing.
=cut
sub test_via_script {
my($self, $perl, $script) = @_;
return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script);
}
=item tool_xsubpp (o)
Determines typemaps, xsubpp version, prototype behaviour.
=cut
sub tool_xsubpp {
my($self) = shift;
return "" unless $self->needs_linking;
my $xsdir;
my @xsubpp_dirs = @INC;
# Make sure we pick up the new xsubpp if we're building perl.
unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE};
my $foundxsubpp = 0;
foreach my $dir (@xsubpp_dirs) {
$xsdir = $self->catdir($dir, 'ExtUtils');
if( -r $self->catfile($xsdir, "xsubpp") ) {
$foundxsubpp = 1;
last;
}
}
die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if !$foundxsubpp;
my $tmdir = $self->catdir($self->{PERL_LIB},"ExtUtils");
my(@tmdeps) = $self->catfile($tmdir,'typemap');
if( $self->{TYPEMAPS} ){
foreach my $typemap (@{$self->{TYPEMAPS}}){
if( ! -f $typemap ) {
warn "Typemap $typemap not found.\n";
}
else {
$typemap = vmsify($typemap) if $Is{VMS};
push(@tmdeps, $typemap);
}
}
}
push(@tmdeps, "typemap") if -f "typemap";
# absolutised because with deep-located typemaps, eg "lib/XS/typemap",
# if xsubpp is called from top level with
# $(XSUBPP) ... -typemap "lib/XS/typemap" "lib/XS/Test.xs"
# it says:
# Can't find lib/XS/type map in (fulldir)/lib/XS
# because ExtUtils::ParseXS::process_file chdir's to .xs file's
# location. This is the only way to get all specified typemaps used,
# wherever located.
my @tmargs = map { '-typemap '.$self->quote_literal(File::Spec->rel2abs($_)) } @tmdeps;
$_ = $self->quote_dep($_) for @tmdeps;
if( exists $self->{XSOPT} ){
unshift( @tmargs, $self->{XSOPT} );
}
if ($Is{VMS} &&
$Config{'ldflags'} &&
$Config{'ldflags'} =~ m!/Debug!i &&
(!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/)
)
{
unshift(@tmargs,'-nolinenumbers');
}
$self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG};
my $xsdirdep = $self->quote_dep($xsdir);
# -dep for use when dependency not command
return qq{
XSUBPPDIR = $xsdir
XSUBPP = "\$(XSUBPPDIR)\$(DFSEP)xsubpp"
XSUBPPRUN = \$(PERLRUN) \$(XSUBPP)
XSPROTOARG = $self->{XSPROTOARG}
XSUBPPDEPS = @tmdeps $xsdirdep\$(DFSEP)xsubpp
XSUBPPARGS = @tmargs
XSUBPP_EXTRA_ARGS =
};
}
=item all_target
Build man pages, too
=cut
sub all_target {
my $self = shift;
return <<'MAKE_EXT';
all :: pure_all manifypods
$(NOECHO) $(NOOP)
MAKE_EXT
}
=item top_targets (o)
Defines the targets all, subdirs, config, and O_FILES
=cut
sub top_targets {
# --- Target Sections ---
my($self) = shift;
my(@m);
push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'};
push @m, sprintf <<'EOF';
pure_all :: config pm_to_blib subdirs linkext
$(NOECHO) $(NOOP)
$(NOECHO) $(NOOP)
subdirs :: $(MYEXTLIB)
$(NOECHO) $(NOOP)
config :: $(FIRST_MAKEFILE) blibdirs
$(NOECHO) $(NOOP)
EOF
push @m, '
$(O_FILES) : $(H_FILES)
' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
push @m, q{
help :
perldoc ExtUtils::MakeMaker
};
join('',@m);
}
=item writedoc
Obsolete, deprecated method. Not used since Version 5.21.
=cut
sub writedoc {
# --- perllocal.pod section ---
my($self,$what,$name,@attribs)=@_;
my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time);
print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n";
print join "\n\n=item *\n\n", map("C<$_>",@attribs);
print "\n\n=back\n\n";
}
=item xs_c (o)
Defines the suffix rules to compile XS files to C.
=cut
sub xs_c {
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs.c:
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.c
';
}
=item xs_cpp (o)
Defines the suffix rules to compile XS files to C++.
=cut
sub xs_cpp {
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs.cpp:
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.cpp
';
}
=item xs_o (o)
Defines suffix rules to go from XS to object files directly. This was
originally only intended for broken make implementations, but is now
necessary for per-XS file under C<XSMULTI>, since each XS file might
have an individual C<$(VERSION)>.
=cut
sub xs_o {
my ($self) = @_;
return '' unless $self->needs_linking();
my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
my $frag = '';
# dmake makes noise about ambiguous rule
$frag .= sprintf <<'EOF', $m_o unless $self->is_make_type('dmake');
.xs$(OBJ_EXT) :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.c
$(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c %s
EOF
if ($self->{XSMULTI}) {
for my $ext ($self->_xs_list_basenames) {
my $pmfile = "$ext.pm";
croak "$ext.xs has no matching $pmfile: $!" unless -f $pmfile;
my $version = $self->parse_version($pmfile);
my $cccmd = $self->{CONST_CCCMD};
$cccmd =~ s/^\s*CCCMD\s*=\s*//;
$cccmd =~ s/\$\(DEFINE_VERSION\)/-DVERSION=\\"$version\\"/;
$cccmd =~ s/\$\(XS_DEFINE_VERSION\)/-DXS_VERSION=\\"$version\\"/;
$self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC');
my $define = '$(DEFINE)';
$self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE');
# 1 2 3 4
$frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $define;
%1$s$(OBJ_EXT): %1$s.xs
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.c
%2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s $*.c %3$s
EOF
}
}
$frag;
}
# param gets modified
sub _xsbuild_replace_macro {
my ($self, undef, $xstype, $ext, $varname) = @_;
my $value = $self->_xsbuild_value($xstype, $ext, $varname);
return unless defined $value;
$_[1] =~ s/\$\($varname\)/$value/;
}
sub _xsbuild_value {
my ($self, $xstype, $ext, $varname) = @_;
return $self->{XSBUILD}{$xstype}{$ext}{$varname}
if $self->{XSBUILD}{$xstype}{$ext}{$varname};
return $self->{XSBUILD}{$xstype}{all}{$varname}
if $self->{XSBUILD}{$xstype}{all}{$varname};
();
}
1;
=back
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
__END__
EXTUTILS_MM_UNIX
$fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_VMS';
package ExtUtils::MM_VMS;
use strict;
use ExtUtils::MakeMaker::Config;
require Exporter;
BEGIN {
# so we can compile the thing on non-VMS platforms.
if( $^O eq 'VMS' ) {
require VMS::Filespec;
VMS::Filespec->import;
}
}
use File::Basename;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);
our $Revision = $ExtUtils::MakeMaker::Revision;
=head1 NAME
ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
Do not use this directly.
Instead, use ExtUtils::MM and it will figure out which MM_*
class to use for you.
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=head2 Methods always loaded
=over 4
=item wraplist
Converts a list into a string wrapped at approximately 80 columns.
=cut
sub wraplist {
my($self) = shift;
my($line,$hlen) = ('',0);
foreach my $word (@_) {
# Perl bug -- seems to occasionally insert extra elements when
# traversing array (scalar(@array) doesn't show them, but
# foreach(@array) does) (5.00307)
next unless $word =~ /\w/;
$line .= ' ' if length($line);
if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; }
$line .= $word;
$hlen += length($word) + 2;
}
$line;
}
# This isn't really an override. It's just here because ExtUtils::MM_VMS
# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext()
# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just
# mimic inheritance here and hand off to ExtUtils::Liblist::Kid.
# XXX This hackery will die soon. --Schwern
sub ext {
require ExtUtils::Liblist::Kid;
goto &ExtUtils::Liblist::Kid::ext;
}
=back
=head2 Methods
Those methods which override default MM_Unix methods are marked
"(override)", while methods unique to MM_VMS are marked "(specific)".
For overridden methods, documentation is limited to an explanation
of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix
documentation for more details.
=over 4
=item guess_name (override)
Try to determine name of extension being built. We begin with the name
of the current directory. Since VMS filenames are case-insensitive,
however, we look for a F<.pm> file whose name matches that of the current
directory (presumably the 'main' F<.pm> file for this extension), and try
to find a C<package> statement from which to obtain the Mixed::Case
package name.
=cut
sub guess_name {
my($self) = @_;
my($defname,$defpm,@pm,%xs);
local *PM;
$defname = basename(fileify($ENV{'DEFAULT'}));
$defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version
$defpm = $defname;
# Fallback in case for some reason a user has copied the files for an
# extension into a working directory whose name doesn't reflect the
# extension's name. We'll use the name of a unique .pm file, or the
# first .pm file with a matching .xs file.
if (not -e "${defpm}.pm") {
@pm = glob('*.pm');
s/.pm$// for @pm;
if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
elsif (@pm) {
%xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic
if (keys %xs) {
foreach my $pm (@pm) {
$defpm = $pm, last if exists $xs{$pm};
}
}
}
}
if (open(my $pm, '<', "${defpm}.pm")){
while (<$pm>) {
if (/^\s*package\s+([^;]+)/i) {
$defname = $1;
last;
}
}
print "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
"defaulting package name to $defname\n"
if eof($pm);
close $pm;
}
else {
print "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
"defaulting package name to $defname\n";
}
$defname =~ s#[\d.\-_]+$##;
$defname;
}
=item find_perl (override)
Use VMS file specification syntax and CLI commands to find and
invoke Perl images.
=cut
sub find_perl {
my($self, $ver, $names, $dirs, $trace) = @_;
my($vmsfile,@sdirs,@snames,@cand);
my($rslt);
my($inabs) = 0;
local *TCF;
if( $self->{PERL_CORE} ) {
# Check in relative directories first, so we pick up the current
# version of Perl if we're running MakeMaker as part of the main build.
@sdirs = sort { my($absa) = $self->file_name_is_absolute($a);
my($absb) = $self->file_name_is_absolute($b);
if ($absa && $absb) { return $a cmp $b }
else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
} @$dirs;
# Check miniperl before perl, and check names likely to contain
# version numbers before "generic" names, so we pick up an
# executable that's less likely to be from an old installation.
@snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename
my($bb) = $b =~ m!([^:>\]/]+)$!;
my($ahasdir) = (length($a) - length($ba) > 0);
my($bhasdir) = (length($b) - length($bb) > 0);
if ($ahasdir and not $bhasdir) { return 1; }
elsif ($bhasdir and not $ahasdir) { return -1; }
else { $bb =~ /\d/ <=> $ba =~ /\d/
or substr($ba,0,1) cmp substr($bb,0,1)
or length($bb) <=> length($ba) } } @$names;
}
else {
@sdirs = @$dirs;
@snames = @$names;
}
# Image names containing Perl version use '_' instead of '.' under VMS
s/\.(\d+)$/_$1/ for @snames;
if ($trace >= 2){
print "Looking for perl $ver by these names:\n";
print "\t@snames,\n";
print "in these dirs:\n";
print "\t@sdirs\n";
}
foreach my $dir (@sdirs){
next unless defined $dir; # $self->{PERL_SRC} may be undefined
$inabs++ if $self->file_name_is_absolute($dir);
if ($inabs == 1) {
# We've covered relative dirs; everything else is an absolute
# dir (probably an installed location). First, we'll try
# potential command names, to see whether we can avoid a long
# MCR expression.
foreach my $name (@snames) {
push(@cand,$name) if $name =~ /^[\w\-\$]+$/;
}
$inabs++; # Should happen above in next $dir, but just in case...
}
foreach my $name (@snames){
push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name)
: $self->fixpath($name,0);
}
}
foreach my $name (@cand) {
print "Checking $name\n" if $trace >= 2;
# If it looks like a potential command, try it without the MCR
if ($name =~ /^[\w\-\$]+$/) {
open(my $tcf, ">", "temp_mmvms.com")
or die('unable to open temp file');
print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n";
close $tcf;
$rslt = `\@temp_mmvms.com` ;
unlink('temp_mmvms.com');
if ($rslt =~ /VER_OK/) {
print "Using PERL=$name\n" if $trace;
return $name;
}
}
next unless $vmsfile = $self->maybe_command($name);
$vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well
print "Executing $vmsfile\n" if ($trace >= 2);
open(my $tcf, '>', "temp_mmvms.com")
or die('unable to open temp file');
print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n";
close $tcf;
$rslt = `\@temp_mmvms.com`;
unlink('temp_mmvms.com');
if ($rslt =~ /VER_OK/) {
print "Using PERL=MCR $vmsfile\n" if $trace;
return "MCR $vmsfile";
}
}
print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
0; # false and not empty
}
=item _fixin_replace_shebang (override)
Helper routine for MM->fixin(), overridden because there's no such thing as an
actual shebang line that will be interpreted by the shell, so we just prepend
$Config{startperl} and preserve the shebang line argument for any switches it
may contain.
=cut
sub _fixin_replace_shebang {
my ( $self, $file, $line ) = @_;
my ( undef, $arg ) = split ' ', $line, 2;
return $Config{startperl} . "\n" . $Config{sharpbang} . "perl $arg\n";
}
=item maybe_command (override)
Follows VMS naming conventions for executable files.
If the name passed in doesn't exactly match an executable file,
appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
to check for DCL procedure. If this fails, checks directories in DCL$PATH
and finally F<Sys$System:> for an executable file having the name specified,
with or without the F<.Exe>-equivalent suffix.
=cut
sub maybe_command {
my($self,$file) = @_;
return $file if -x $file && ! -d _;
my(@dirs) = ('');
my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
if ($file !~ m![/:>\]]!) {
for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
my $dir = $ENV{"DCL\$PATH;$i"};
$dir .= ':' unless $dir =~ m%[\]:]$%;
push(@dirs,$dir);
}
push(@dirs,'Sys$System:');
foreach my $dir (@dirs) {
my $sysfile = "$dir$file";
foreach my $ext (@exts) {
return $file if -x "$sysfile$ext" && ! -d _;
}
}
}
return 0;
}
=item pasthru (override)
The list of macro definitions to be passed through must be specified using
the /MACRO qualifier and must not add another /DEFINE qualifier. We prepend
our own comma here to the contents of $(PASTHRU_DEFINE) because it is often
empty and a comma always present in CCFLAGS would generate a missing
qualifier value error.
=cut
sub pasthru {
my($self) = shift;
my $pasthru = $self->SUPER::pasthru;
$pasthru =~ s|(PASTHRU\s*=\s*)|$1/MACRO=(|;
$pasthru =~ s|\n\z|)\n|m;
$pasthru =~ s|/defi?n?e?=\(?([^\),]+)\)?|,$1|ig;
return $pasthru;
}
=item pm_to_blib (override)
VMS wants a dot in every file so we can't have one called 'pm_to_blib',
it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when
you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'.
So in VMS its pm_to_blib.ts.
=cut
sub pm_to_blib {
my $self = shift;
my $make = $self->SUPER::pm_to_blib;
$make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m;
$make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts};
$make = <<'MAKE' . $make;
# Dummy target to match Unix target name; we use pm_to_blib.ts as
# timestamp file to avoid repeated invocations under VMS
pm_to_blib : pm_to_blib.ts
$(NOECHO) $(NOOP)
MAKE
return $make;
}
=item perl_script (override)
If name passed in doesn't specify a readable file, appends F<.com> or
F<.pl> and tries again, since it's customary to have file types on all files
under VMS.
=cut
sub perl_script {
my($self,$file) = @_;
return $file if -r $file && ! -d _;
return "$file.com" if -r "$file.com";
return "$file.pl" if -r "$file.pl";
return '';
}
=item replace_manpage_separator
Use as separator a character which is legal in a VMS-syntax file name.
=cut
sub replace_manpage_separator {
my($self,$man) = @_;
$man = unixify($man);
$man =~ s#/+#__#g;
$man;
}
=item init_DEST
(override) Because of the difficulty concatenating VMS filepaths we
must pre-expand the DEST* variables.
=cut
sub init_DEST {
my $self = shift;
$self->SUPER::init_DEST;
# Expand DEST variables.
foreach my $var ($self->installvars) {
my $destvar = 'DESTINSTALL'.$var;
$self->{$destvar} = $self->eliminate_macros($self->{$destvar});
}
}
=item init_DIRFILESEP
No separator between a directory path and a filename on VMS.
=cut
sub init_DIRFILESEP {
my($self) = shift;
$self->{DIRFILESEP} = '';
return 1;
}
=item init_main (override)
=cut
sub init_main {
my($self) = shift;
$self->SUPER::init_main;
$self->{DEFINE} ||= '';
if ($self->{DEFINE} ne '') {
my(@terms) = split(/\s+/,$self->{DEFINE});
my(@defs,@udefs);
foreach my $def (@terms) {
next unless $def;
my $targ = \@defs;
if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition
$targ = \@udefs if $1 eq 'U';
$def =~ s/='(.*)'$/=$1/; # then remove shell-protection ''
$def =~ s/^'(.*)'$/$1/; # from entire term or argument
}
if ($def =~ /=/) {
$def =~ s/"/""/g; # Protect existing " from DCL
$def = qq["$def"]; # and quote to prevent parsing of =
}
push @$targ, $def;
}
$self->{DEFINE} = '';
if (@defs) {
$self->{DEFINE} = '/Define=(' . join(',',@defs) . ')';
}
if (@udefs) {
$self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')';
}
}
}
=item init_tools (override)
Provide VMS-specific forms of various utility commands.
Sets DEV_NULL to nothing because I don't know how to do it on VMS.
Changes EQUALIZE_TIMESTAMP to set revision date of target file to
one second later than source file, since MMK interprets precisely
equal revision dates for a source and target file as a sign that the
target needs to be updated.
=cut
sub init_tools {
my($self) = @_;
$self->{NOOP} = 'Continue';
$self->{NOECHO} ||= '@ ';
$self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS';
$self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE};
$self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
$self->{MAKEFILE_OLD} ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old');
#
# If an extension is not specified, then MMS/MMK assumes an
# an extension of .MMS. If there really is no extension,
# then a trailing "." needs to be appended to specify a
# a null extension.
#
$self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./;
$self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./;
$self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./;
$self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./;
$self->{MACROSTART} ||= '/Macro=(';
$self->{MACROEND} ||= ')';
$self->{USEMAKEFILE} ||= '/Descrip=';
$self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"';
$self->{MOD_INSTALL} ||=
$self->oneliner(<<'CODE', ['-MExtUtils::Install']);
install([ from_to => {split('\|', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE
$self->{UMASK_NULL} = '! ';
$self->SUPER::init_tools;
# Use the default shell
$self->{SHELL} ||= 'Posix';
# Redirection on VMS goes before the command, not after as on Unix.
# $(DEV_NULL) is used once and its not worth going nuts over making
# it work. However, Unix's DEV_NULL is quite wrong for VMS.
$self->{DEV_NULL} = '';
return;
}
=item init_platform (override)
Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION.
MM_VMS_REVISION is for backwards compatibility before MM_VMS had a
$VERSION.
=cut
sub init_platform {
my($self) = shift;
$self->{MM_VMS_REVISION} = $Revision;
$self->{MM_VMS_VERSION} = $VERSION;
$self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS')
if $self->{PERL_SRC};
}
=item platform_constants
=cut
sub platform_constants {
my($self) = shift;
my $make_frag = '';
foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION))
{
next unless defined $self->{$macro};
$make_frag .= "$macro = $self->{$macro}\n";
}
return $make_frag;
}
=item init_VERSION (override)
Override the *DEFINE_VERSION macros with VMS semantics. Translate the
MAKEMAKER filepath to VMS style.
=cut
sub init_VERSION {
my $self = shift;
$self->SUPER::init_VERSION;
$self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""';
$self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""';
$self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'});
}
=item constants (override)
Fixes up numerous file and directory macros to insure VMS syntax
regardless of input syntax. Also makes lists of files
comma-separated.
=cut
sub constants {
my($self) = @_;
# Be kind about case for pollution
for (@ARGV) { $_ = uc($_) if /POLLUTE/i; }
# Cleanup paths for directories in MMS macros.
foreach my $macro ( qw [
INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
PERL_LIB PERL_ARCHLIB
PERL_INC PERL_SRC ],
(map { 'INSTALL'.$_ } $self->installvars)
)
{
next unless defined $self->{$macro};
next if $macro =~ /MAN/ && $self->{$macro} eq 'none';
$self->{$macro} = $self->fixpath($self->{$macro},1);
}
# Cleanup paths for files in MMS macros.
foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD
MAKE_APERL_FILE MYEXTLIB] )
{
next unless defined $self->{$macro};
$self->{$macro} = $self->fixpath($self->{$macro},0);
}
# Fixup files for MMS macros
# XXX is this list complete?
for my $macro (qw/
FULLEXT VERSION_FROM
/ ) {
next unless defined $self->{$macro};
$self->{$macro} = $self->fixpath($self->{$macro},0);
}
for my $macro (qw/
OBJECT LDFROM
/ ) {
next unless defined $self->{$macro};
# Must expand macros before splitting on unescaped whitespace.
$self->{$macro} = $self->eliminate_macros($self->{$macro});
if ($self->{$macro} =~ /(?<!\^)\s/) {
$self->{$macro} =~ s/(\\)?\n+\s+/ /g;
$self->{$macro} = $self->wraplist(
map $self->fixpath($_,0), split /,?(?<!\^)\s+/, $self->{$macro}
);
}
else {
$self->{$macro} = $self->fixpath($self->{$macro},0);
}
}
for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) {
# Where is the space coming from? --jhi
next unless $self ne " " && defined $self->{$macro};
my %tmp = ();
for my $key (keys %{$self->{$macro}}) {
$tmp{$self->fixpath($key,0)} =
$self->fixpath($self->{$macro}{$key},0);
}
$self->{$macro} = \%tmp;
}
for my $macro (qw/ C O_FILES H /) {
next unless defined $self->{$macro};
my @tmp = ();
for my $val (@{$self->{$macro}}) {
push(@tmp,$self->fixpath($val,0));
}
$self->{$macro} = \@tmp;
}
# mms/k does not define a $(MAKE) macro.
$self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)';
return $self->SUPER::constants;
}
=item special_targets
Clear the default .SUFFIXES and put in our own list.
=cut
sub special_targets {
my $self = shift;
my $make_frag .= <<'MAKE_FRAG';
.SUFFIXES :
.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs
MAKE_FRAG
return $make_frag;
}
=item cflags (override)
Bypass shell script and produce qualifiers for CC directly (but warn
user if a shell script for this extension exists). Fold multiple
/Defines into one, since some C compilers pay attention to only one
instance of this qualifier on the command line.
=cut
sub cflags {
my($self,$libperl) = @_;
my($quals) = $self->{CCFLAGS} || $Config{'ccflags'};
my($definestr,$undefstr,$flagoptstr) = ('','','');
my($incstr) = '/Include=($(PERL_INC)';
my($name,$sys,@m);
( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
print "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
" required to modify CC command for $self->{'BASEEXT'}\n"
if ($Config{$name});
if ($quals =~ / -[DIUOg]/) {
while ($quals =~ / -([Og])(\d*)\b/) {
my($type,$lvl) = ($1,$2);
$quals =~ s/ -$type$lvl\b\s*//;
if ($type eq 'g') { $flagoptstr = '/NoOptimize'; }
else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); }
}
while ($quals =~ / -([DIU])(\S+)/) {
my($type,$def) = ($1,$2);
$quals =~ s/ -$type$def\s*//;
$def =~ s/"/""/g;
if ($type eq 'D') { $definestr .= qq["$def",]; }
elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); }
else { $undefstr .= qq["$def",]; }
}
}
if (length $quals and $quals !~ m!/!) {
warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n";
$quals = '';
}
$definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE};
if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; }
if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; }
# Deal with $self->{DEFINE} here since some C compilers pay attention
# to only one /Define clause on command line, so we have to
# conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
# ($self->{DEFINE} has already been VMSified in constants() above)
if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
for my $type (qw(Def Undef)) {
my(@terms);
while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
my $term = $1;
$term =~ s:^\((.+)\)$:$1:;
push @terms, $term;
}
if ($type eq 'Def') {
push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
}
if (@terms) {
$quals =~ s:/${type}i?n?e?=[^/]+::ig;
# PASTHRU_DEFINE will have its own comma
$quals .= "/${type}ine=(" . join(',',@terms) . ($type eq 'Def' ? '$(PASTHRU_DEFINE)' : '') . ')';
}
}
$libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";
# Likewise with $self->{INC} and /Include
if ($self->{'INC'}) {
my(@includes) = split(/\s+/,$self->{INC});
foreach (@includes) {
s/^-I//;
$incstr .= ','.$self->fixpath($_,1);
}
}
$quals .= "$incstr)";
# $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g;
$self->{CCFLAGS} = $quals;
$self->{PERLTYPE} ||= '';
$self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
if ($self->{OPTIMIZE} !~ m!/!) {
if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' }
elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) {
$self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : '');
}
else {
warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE};
$self->{OPTIMIZE} = '/Optimize';
}
}
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};
}
=item const_cccmd (override)
Adds directives to point C preprocessor to the right place when
handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC
command line a bit differently than MM_Unix method.
=cut
sub const_cccmd {
my($self,$libperl) = @_;
my(@m);
return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
return '' unless $self->needs_linking();
if ($Config{'vms_cc_type'} eq 'gcc') {
push @m,'
.FIRST
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]';
}
elsif ($Config{'vms_cc_type'} eq 'vaxc') {
push @m,'
.FIRST
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include';
}
else {
push @m,'
.FIRST
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ',
($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),'
',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include';
}
push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n");
$self->{CONST_CCCMD} = join('',@m);
}
=item tools_other (override)
Throw in some dubious extra macros for Makefile args.
Also keep around the old $(SAY) macro in case somebody's using it.
=cut
sub tools_other {
my($self) = @_;
# XXX Are these necessary? Does anyone override them? They're longer
# than just typing the literal string.
my $extra_tools = <<'EXTRA_TOOLS';
# Just in case anyone is using the old macro.
USEMACROS = $(MACROSTART)
SAY = $(ECHO)
EXTRA_TOOLS
return $self->SUPER::tools_other . $extra_tools;
}
=item init_dist (override)
VMSish defaults for some values.
macro description default
ZIPFLAGS flags to pass to ZIP -Vu
COMPRESS compression command to gzip
use for tarfiles
SUFFIX suffix to put on -gz
compressed files
SHAR shar command to use vms_share
DIST_DEFAULT default target to use to tardist
create a distribution
DISTVNAME Use VERSION_SYM instead of $(DISTNAME)-$(VERSION_SYM)
VERSION for the name
=cut
sub init_dist {
my($self) = @_;
$self->{ZIPFLAGS} ||= '-Vu';
$self->{COMPRESS} ||= 'gzip';
$self->{SUFFIX} ||= '-gz';
$self->{SHAR} ||= 'vms_share';
$self->{DIST_DEFAULT} ||= 'zipdist';
$self->SUPER::init_dist;
$self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}"
unless $self->{ARGS}{DISTVNAME};
return;
}
=item c_o (override)
Use VMS syntax on command line. In particular, $(DEFINE) and
$(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros.
=cut
sub c_o {
my($self) = @_;
return '' unless $self->needs_linking();
'
.c$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
.cpp$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
.cxx$(OBJ_EXT) :
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
';
}
=item xs_c (override)
Use MM[SK] macros.
=cut
sub xs_c {
my($self) = @_;
return '' unless $self->needs_linking();
'
.xs.c :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc
$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
';
}
=item xs_o (override)
Use MM[SK] macros, and VMS command line for C compiler.
=cut
sub xs_o {
my ($self) = @_;
return '' unless $self->needs_linking();
my $frag = '
.xs$(OBJ_EXT) :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc
$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
';
if ($self->{XSMULTI}) {
for my $ext ($self->_xs_list_basenames) {
my $version = $self->parse_version("$ext.pm");
my $ccflags = $self->{CCFLAGS};
$ccflags =~ s/\$\(DEFINE_VERSION\)/\"VERSION_MACRO=\\"\"$version\\"\"/;
$ccflags =~ s/\$\(XS_DEFINE_VERSION\)/\"XS_VERSION_MACRO=\\"\"$version\\"\"/;
$self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'INC');
$self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'DEFINE');
$frag .= _sprintf562 <<'EOF', $ext, $ccflags;
%1$s$(OBJ_EXT) : %1$s.xs
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc
$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
$(CC)%2$s$(OPTIMIZE) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
EOF
}
}
$frag;
}
=item _xsbuild_replace_macro (override)
There is no simple replacement possible since a qualifier and all its
subqualifiers must be considered together, so we use our own utility
routine for the replacement.
=cut
sub _xsbuild_replace_macro {
my ($self, undef, $xstype, $ext, $varname) = @_;
my $value = $self->_xsbuild_value($xstype, $ext, $varname);
return unless defined $value;
$_[1] = _vms_replace_qualifier($self, $_[1], $value, $varname);
}
=item _xsbuild_value (override)
Convert the extension spec to Unix format, as that's what will
match what's in the XSBUILD data structure.
=cut
sub _xsbuild_value {
my ($self, $xstype, $ext, $varname) = @_;
$ext = unixify($ext);
return $self->SUPER::_xsbuild_value($xstype, $ext, $varname);
}
sub _vms_replace_qualifier {
my ($self, $flags, $newflag, $macro) = @_;
my $qual_type;
my $type_suffix;
my $quote_subquals = 0;
my @subquals_new = split /\s+/, $newflag;
if ($macro eq 'DEFINE') {
$qual_type = 'Def';
$type_suffix = 'ine';
map { $_ =~ s/^-D// } @subquals_new;
$quote_subquals = 1;
}
elsif ($macro eq 'INC') {
$qual_type = 'Inc';
$type_suffix = 'lude';
map { $_ =~ s/^-I//; $_ = $self->fixpath($_) } @subquals_new;
}
my @subquals = ();
while ($flags =~ m:/${qual_type}\S{0,4}=([^/]+):ig) {
my $term = $1;
$term =~ s/\"//g;
$term =~ s:^\((.+)\)$:$1:;
push @subquals, split /,/, $term;
}
for my $new (@subquals_new) {
my ($sq_new, $sqval_new) = split /=/, $new;
my $replaced_old = 0;
for my $old (@subquals) {
my ($sq, $sqval) = split /=/, $old;
if ($sq_new eq $sq) {
$old = $sq_new;
$old .= '=' . $sqval_new if defined($sqval_new) and length($sqval_new);
$replaced_old = 1;
last;
}
}
push @subquals, $new unless $replaced_old;
}
if (@subquals) {
$flags =~ s:/${qual_type}\S{0,4}=[^/]+::ig;
# add quotes if requested but not for unexpanded macros
map { $_ = qq/"$_"/ if $_ !~ m/^\$\(/ } @subquals if $quote_subquals;
$flags .= "/${qual_type}$type_suffix=(" . join(',',@subquals) . ')';
}
return $flags;
}
sub xs_dlsyms_ext {
'.opt';
}
=item dlsyms (override)
Create VMS linker options files specifying universal symbols for this
extension's shareable image(s), and listing other shareable images or
libraries to which it should be linked.
=cut
sub dlsyms {
my ($self, %attribs) = @_;
return '' unless $self->needs_linking;
$self->xs_dlsyms_iterator;
}
sub xs_make_dlsyms {
my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_;
my @m;
my $instloc;
if ($self->{XSMULTI}) {
my ($v, $d, $f) = File::Spec->splitpath($target);
my @d = File::Spec->splitdir($d);
shift @d if $d[0] eq 'lib';
$instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f);
push @m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n"
unless $self->{SKIPHASH}{'dynamic'};
push @m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n"
unless $self->{SKIPHASH}{'static'};
push @m, "\n", sprintf <<'EOF', $instloc, $target;
%s : %s
$(CP) $(MMS$SOURCE) $(MMS$TARGET)
EOF
}
else {
push @m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n"
unless $self->{SKIPHASH}{'dynamic'};
push @m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n"
unless $self->{SKIPHASH}{'static'};
push @m, "\n", sprintf <<'EOF', $target;
$(INST_ARCHAUTODIR)$(BASEEXT).opt : %s
$(CP) $(MMS$SOURCE) $(MMS$TARGET)
EOF
}
push @m,
"\n$target : $dep\n\t",
q!$(PERLRUN) -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>'!, $name,
q!', 'DLBASE' => '!,$dlbase,
q!', 'DL_FUNCS' => !,neatvalue($funcs),
q!, 'FUNCLIST' => !,neatvalue($funclist),
q!, 'IMPORTS' => !,neatvalue($imports),
q!, 'DL_VARS' => !, neatvalue($vars);
push @m, $extra if defined $extra;
push @m, qq!);"\n\t!;
# Can't use dlbase as it's been through mod2fname.
my $olb_base = basename($target, '.opt');
if ($self->{XSMULTI}) {
# We've been passed everything but the kitchen sink -- and the location of the
# static library we're using to build the dynamic library -- so concoct that
# location from what we do have.
my $olb_dir = $self->catdir(dirname($instloc), $olb_base);
push @m, qq!\$(PERL) -e "print ""${olb_dir}${olb_base}\$(LIB_EXT)/Include=!;
push @m, ($Config{d_vms_case_sensitive_symbols} ? uc($olb_base) : $olb_base);
push @m, '\n' . $olb_dir . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n";
}
else {
push @m, qq!\$(PERL) -e "print ""\$(INST_ARCHAUTODIR)${olb_base}\$(LIB_EXT)/Include=!;
if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
$self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
push @m, ($Config{d_vms_case_sensitive_symbols}
? uc($self->{BASEEXT}) :'$(BASEEXT)');
}
else { # We don't have a "main" object file, so pull 'em all in
# Upcase module names if linker is being case-sensitive
my($upcase) = $Config{d_vms_case_sensitive_symbols};
my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
for (@omods) {
s/\.[^.]*$//; # Trim off file type
s[\$\(\w+_EXT\)][]; # even as a macro
s/.*[:>\/\]]//; # Trim off dir spec
$_ = uc if $upcase;
};
my(@lines);
my $tmp = shift @omods;
foreach my $elt (@omods) {
$tmp .= ",$elt";
if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; }
}
push @lines, $tmp;
push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
}
push @m, '\n$(INST_ARCHAUTODIR)' . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n";
}
if (length $self->{LDLOADLIBS}) {
my($line) = '';
foreach my $lib (split ' ', $self->{LDLOADLIBS}) {
$lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs
if (length($line) + length($lib) > 160) {
push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n";
$line = $lib . '\n';
}
else { $line .= $lib . '\n'; }
}
push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
}
join '', @m;
}
=item xs_obj_opt
Override to fixup -o flags.
=cut
sub xs_obj_opt {
my ($self, $output_file) = @_;
"/OBJECT=$output_file";
}
=item dynamic_lib (override)
Use VMS Link command.
=cut
sub xs_dynamic_lib_macros {
my ($self, $attribs) = @_;
my $otherldflags = $attribs->{OTHERLDFLAGS} || "";
my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
sprintf <<'EOF', $otherldflags, $inst_dynamic_dep;
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
EOF
}
sub xs_make_dynamic_lib {
my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
my $shr = $Config{'dbgprefix'} . 'PerlShr';
$exportlist =~ s/.def$/.opt/; # it's a linker options file
# 1 2 3 4 5
_sprintf562 <<'EOF', $to, $todir, $exportlist, $shr, "$shr Sys\$Share:$shr.$Config{'dlext'}";
%1$s : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt %2$s$(DFSEP).exists %3$s $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
If F$TrnLNm("%4$s").eqs."" Then Define/NoLog/User %5$s
Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) %3$s/Option,$(PERL_INC)perlshr_attr.opt/Option
EOF
}
=item xs_make_static_lib (override)
Use VMS commands to manipulate object library.
=cut
sub xs_make_static_lib {
my ($self, $object, $to, $todir) = @_;
my @objects;
if ($self->{XSMULTI}) {
# The extension name should be the main object file name minus file type.
my $lib = $object;
$lib =~ s/\$\(OBJ_EXT\)\z//;
my $override = $self->_xsbuild_value('xs', $lib, 'OBJECT');
$object = $override if defined $override;
@objects = map { $self->fixpath($_,0) } split /(?<!\^)\s+/, $object;
}
else {
push @objects, $object;
}
my @m;
for my $obj (@objects) {
push(@m, sprintf "\n%s : %s\$(DFSEP).exists", $obj, $todir);
}
push(@m, sprintf "\n\n%s : %s \$(MYEXTLIB)\n", $to, (join ' ', @objects));
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n");
# if there was a library to copy, then we can't use MMS$SOURCE_LIST,
# 'cause it's a library and you can't stick them in other libraries.
# In that case, we use $OBJECT instead and hope for the best
if ($self->{MYEXTLIB}) {
for my $obj (@objects) {
push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) ' . $obj,"\n");
}
}
else {
push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
}
push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n";
foreach my $lib (split ' ', $self->{EXTRALIBS}) {
push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n");
}
join('',@m);
}
=item static_lib_pure_cmd (override)
Use VMS commands to manipulate object library.
=cut
sub static_lib_pure_cmd {
my ($self, $from) = @_;
sprintf <<'MAKE_FRAG', $from;
If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
Library/Object/Replace $(MMS$TARGET) %s
MAKE_FRAG
}
=item xs_static_lib_is_xs
=cut
sub xs_static_lib_is_xs {
return 1;
}
=item extra_clean_files
Clean up some OS specific files. Plus the temp file used to shorten
a lot of commands. And the name mangler database.
=cut
sub extra_clean_files {
return qw(
*.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso
.MM_Tmp cxx_repository
);
}
=item zipfile_target
=item tarfile_target
=item shdist_target
Syntax for invoking shar, tar and zip differs from that for Unix.
=cut
sub zipfile_target {
my($self) = shift;
return <<'MAKE_FRAG';
$(DISTVNAME).zip : distdir
$(PREOP)
$(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
$(RM_RF) $(DISTVNAME)
$(POSTOP)
MAKE_FRAG
}
sub tarfile_target {
my($self) = shift;
return <<'MAKE_FRAG';
$(DISTVNAME).tar$(SUFFIX) : distdir
$(PREOP)
$(TO_UNIX)
$(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
$(RM_RF) $(DISTVNAME)
$(COMPRESS) $(DISTVNAME).tar
$(POSTOP)
MAKE_FRAG
}
sub shdist_target {
my($self) = shift;
return <<'MAKE_FRAG';
shdist : distdir
$(PREOP)
$(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share
$(RM_RF) $(DISTVNAME)
$(POSTOP)
MAKE_FRAG
}
# --- Test and Installation Sections ---
=item install (override)
Work around DCL's 255 character limit several times,and use
VMS-style command line quoting in a few cases.
=cut
sub install {
my($self, %attribs) = @_;
my(@m);
push @m, q[
install :: all pure_install doc_install
$(NOECHO) $(NOOP)
install_perl :: all pure_perl_install doc_perl_install
$(NOECHO) $(NOOP)
install_site :: all pure_site_install doc_site_install
$(NOECHO) $(NOOP)
install_vendor :: all pure_vendor_install doc_vendor_install
$(NOECHO) $(NOOP)
pure_install :: pure_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
pure__install : pure_site_install
$(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
doc__install : doc_site_install
$(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
# This hack brought to you by DCL's 255-character command line limit
pure_perl_install ::
];
push @m,
q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp
] unless $self->{NO_PACKLIST};
push @m,
q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLPRIVLIB)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLARCHLIB)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLBIN)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLMAN3DIR)" >>.MM_tmp
$(NOECHO) $(MOD_INSTALL) <.MM_tmp
$(NOECHO) $(RM_F) .MM_tmp
$(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q["
# Likewise
pure_site_install ::
];
push @m,
q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp
] unless $self->{NO_PACKLIST};
push @m,
q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLSITELIB)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLSITEARCH)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLSITEBIN)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLSITEMAN1DIR)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLSITEMAN3DIR)" >>.MM_tmp
$(NOECHO) $(MOD_INSTALL) <.MM_tmp
$(NOECHO) $(RM_F) .MM_tmp
$(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q["
pure_vendor_install ::
];
push @m,
q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp
] unless $self->{NO_PACKLIST};
push @m,
q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLVENDORLIB)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLVENDORARCH)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLVENDORBIN)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLVENDORMAN1DIR)|" >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLVENDORMAN3DIR)" >>.MM_tmp
$(NOECHO) $(MOD_INSTALL) <.MM_tmp
$(NOECHO) $(RM_F) .MM_tmp
];
push @m, q[
# Ditto
doc_perl_install ::
$(NOECHO) $(NOOP)
# And again
doc_site_install ::
$(NOECHO) $(NOOP)
doc_vendor_install ::
$(NOECHO) $(NOOP)
] if $self->{NO_PERLLOCAL};
push @m, q[
# Ditto
doc_perl_install ::
$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
$(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp
$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
# And again
doc_site_install ::
$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
$(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp
$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
doc_vendor_install ::
$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
$(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp
$(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
] unless $self->{NO_PERLLOCAL};
push @m, q[
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
$(NOECHO) $(NOOP)
uninstall_from_perldirs ::
$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
uninstall_from_sitedirs ::
$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
uninstall_from_vendordirs ::
$(NOECHO) $(UNINSTALL) ].$self->catfile($self->{VENDORARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
];
join('',@m);
}
=item perldepend (override)
Use VMS-style syntax for files; it's cheaper to just do it directly here
than to have the MM_Unix method call C<catfile> repeatedly. Also, if
we have to rebuild Config.pm, use MM[SK] to do it.
=cut
sub perldepend {
my($self) = @_;
my(@m);
if ($self->{OBJECT}) {
# Need to add an object file dependency on the perl headers.
# this is very important for XS modules in perl.git development.
push @m, $self->_perl_header_files_fragment(""); # empty separator on VMS as its in the $(PERL_INC)
}
if ($self->{PERL_SRC}) {
my(@macros);
my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)';
push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP';
push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc';
push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc';
push(@macros,'SOCKET=1') if $Config{'d_has_sockets'};
push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!;
$mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros;
push(@m,q[
# Check for unpropagated config.sh changes. Should never happen.
# We do NOT just update config.h because that is not sufficient.
# An out of date config.h is not fatal but complains loudly!
$(PERL_INC)config.h : $(PERL_SRC)config.sh
$(NOOP)
$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
$(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
olddef = F$Environment("Default")
Set Default $(PERL_SRC)
$(MMS)],$mmsquals,);
if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
$target =~ s/\Q$prefix/[/;
push(@m," $target");
}
else { push(@m,' $(MMS$TARGET)'); }
push(@m,q[
Set Default 'olddef'
]);
}
push(@m, join(" ", map($self->fixpath($_,0),sort values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
if %{$self->{XS}};
join('',@m);
}
=item makeaperl (override)
Undertake to build a new set of Perl images using VMS commands. Since
VMS does dynamic loading, it's not necessary to statically link each
extension into the Perl image, so this isn't the normal build path.
Consequently, it hasn't really been tested, and may well be incomplete.
=cut
our %olbs; # needs to be localized
sub makeaperl {
my($self, %attribs) = @_;
my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
@attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
my(@m);
push @m, "
# --- MakeMaker makeaperl section ---
MAP_TARGET = $target
";
return join '', @m if $self->{PARENT};
my($dir) = join ":", @{$self->{DIR}};
unless ($self->{MAKEAPERL}) {
push @m, q{
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
$(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
$(NOECHO) $(PERLRUNINST) \
Makefile.PL DIR=}, $dir, q{ \
FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1 };
push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{
$(MAP_TARGET) :: $(MAKE_APERL_FILE)
$(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
};
push @m, "\n";
return join '', @m;
}
my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen);
local($_);
# The front matter of the linkcommand...
$linkcmd = join ' ', $Config{'ld'},
grep($_, @Config{qw(large split ldflags ccdlflags)});
$linkcmd =~ s/\s+/ /g;
# Which *.olb files could we make use of...
local(%olbs); # XXX can this be lexical?
$olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
require File::Find;
File::Find::find(sub {
return unless m/\Q$self->{LIB_EXT}\E$/;
return if m/^libperl/;
if( exists $self->{INCLUDE_EXT} ){
my $found = 0;
(my $xx = $File::Find::name) =~ s,.*?/auto/,,;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
# Throw away anything not explicitly marked for inclusion.
# DynaLoader is implied.
foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
if( $xx eq $incl ){
$found++;
last;
}
}
return unless $found;
}
elsif( exists $self->{EXCLUDE_EXT} ){
(my $xx = $File::Find::name) =~ s,.*?/auto/,,;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
# Throw away anything explicitly marked for exclusion
foreach my $excl (@{$self->{EXCLUDE_EXT}}){
return if( $xx eq $excl );
}
}
$olbs{$ENV{DEFAULT}} = $_;
}, grep( -d $_, @{$searchdirs || []}));
# We trust that what has been handed in as argument will be buildable
$static = [] unless $static;
@olbs{@{$static}} = (1) x @{$static};
$extra = [] unless $extra && ref $extra eq 'ARRAY';
# Sort the object libraries in inverse order of
# filespec length to try to insure that dependent extensions
# will appear before their parents, so the linker will
# search the parent library to resolve references.
# (e.g. Intuit::DWIM will precede Intuit, so unresolved
# references from [.intuit.dwim]dwim.obj can be found
# in [.intuit]intuit.olb).
for (sort { length($a) <=> length($b) || $a cmp $b } keys %olbs) {
next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
my($dir) = $self->fixpath($_,1);
my($extralibs) = $dir . "extralibs.ld";
my($extopt) = $dir . $olbs{$_};
$extopt =~ s/$self->{LIB_EXT}$/.opt/;
push @optlibs, "$dir$olbs{$_}";
# Get external libraries this extension will need
if (-f $extralibs ) {
my %seenthis;
open my $list, "<", $extralibs or warn $!,next;
while (<$list>) {
chomp;
# Include a library in the link only once, unless it's mentioned
# multiple times within a single extension's options file, in which
# case we assume the builder needed to search it again later in the
# link.
my $skip = exists($libseen{$_}) && !exists($seenthis{$_});
$libseen{$_}++; $seenthis{$_}++;
next if $skip;
push @$extra,$_;
}
}
# Get full name of extension for ExtUtils::Miniperl
if (-f $extopt) {
open my $opt, '<', $extopt or die $!;
while (<$opt>) {
next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
my $pkg = $1;
$pkg =~ s#__*#::#g;
push @staticpkgs,$pkg;
}
}
}
# Place all of the external libraries after all of the Perl extension
# libraries in the final link, in order to maximize the opportunity
# for XS code from multiple extensions to resolve symbols against the
# same external library while only including that library once.
push @optlibs, @$extra;
$target = "Perl$Config{'exe_ext'}" unless $target;
my $shrtarget;
($shrtarget,$targdir) = fileparse($target);
$shrtarget =~ s/^([^.]*)/$1Shr/;
$shrtarget = $targdir . $shrtarget;
$target = "Perlshr.$Config{'dlext'}" unless $target;
$tmpdir = "[]" unless $tmpdir;
$tmpdir = $self->fixpath($tmpdir,1);
if (@optlibs) { $extralist = join(' ',@optlibs); }
else { $extralist = ''; }
# Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
# that's what we're building here).
push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
if ($libperl) {
unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
print "Warning: $libperl not found\n";
undef $libperl;
}
}
unless ($libperl) {
if (defined $self->{PERL_SRC}) {
$libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
} elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
} else {
print "Warning: $libperl not found
If you're going to build a static perl binary, make sure perl is installed
otherwise ignore this warning\n";
}
}
$libperldir = $self->fixpath((fileparse($libperl))[1],1);
push @m, '
# Fill in the target you want to produce if it\'s not perl
MAP_TARGET = ',$self->fixpath($target,0),'
MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
MAP_LINKCMD = $linkcmd
MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',"
MAP_EXTRA = $extralist
MAP_LIBPERL = ",$self->fixpath($libperl,0),'
';
push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n";
foreach (@optlibs) {
push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n";
}
push @m,"\n${tmpdir}PerlShr.Opt :\n\t";
push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n";
push @m,'
$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",'
$(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",'
$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",'
$(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
$(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say"
$(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
$(NOECHO) $(ECHO) "To remove the intermediate files, say
$(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean"
';
push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n";
push @m, "# More from the 255-char line length limit\n";
foreach (@staticpkgs) {
push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n];
}
push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir;
$(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
$(NOECHO) $(RM_F) %sWritemain.tmp
MAKE_FRAG
push @m, q[
# Still more from the 255-char line length limit
doc_inst_perl :
$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
$(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp
$(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp
$(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
$(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp
$(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
];
push @m, "
inst_perl : pure_inst_perl doc_inst_perl
\$(NOECHO) \$(NOOP)
pure_inst_perl : \$(MAP_TARGET)
$self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
$self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
clean :: map_clean
\$(NOECHO) \$(NOOP)
map_clean :
\$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE)
\$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET)
";
join '', @m;
}
# --- Output postprocessing section ---
=item maketext_filter (override)
Ensure that colons marking targets are preceded by space, in order
to distinguish the target delimiter from a colon appearing as
part of a filespec.
=cut
sub maketext_filter {
my($self, $text) = @_;
$text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg;
return $text;
}
=item prefixify (override)
prefixifying on VMS is simple. Each should simply be:
perl_root:[some.dir]
which can just be converted to:
volume:[your.prefix.some.dir]
otherwise you get the default layout.
In effect, your search prefix is ignored and $Config{vms_prefix} is
used instead.
=cut
sub prefixify {
my($self, $var, $sprefix, $rprefix, $default) = @_;
# Translate $(PERLPREFIX) to a real path.
$rprefix = $self->eliminate_macros($rprefix);
$rprefix = vmspath($rprefix) if $rprefix;
$sprefix = vmspath($sprefix) if $sprefix;
$default = vmsify($default)
unless $default =~ /\[.*\]/;
(my $var_no_install = $var) =~ s/^install//;
my $path = $self->{uc $var} ||
$ExtUtils::MM_Unix::Config_Override{lc $var} ||
$Config{lc $var} || $Config{lc $var_no_install};
if( !$path ) {
warn " no Config found for $var.\n" if $Verbose >= 2;
$path = $self->_prefixify_default($rprefix, $default);
}
elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) {
# do nothing if there's no prefix or if its relative
}
elsif( $sprefix eq $rprefix ) {
warn " no new prefix.\n" if $Verbose >= 2;
}
else {
warn " prefixify $var => $path\n" if $Verbose >= 2;
warn " from $sprefix to $rprefix\n" if $Verbose >= 2;
my($path_vol, $path_dirs) = $self->splitpath( $path );
if( $path_vol eq $Config{vms_prefix}.':' ) {
warn " $Config{vms_prefix}: seen\n" if $Verbose >= 2;
$path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
$path = $self->_catprefix($rprefix, $path_dirs);
}
else {
$path = $self->_prefixify_default($rprefix, $default);
}
}
print " now $path\n" if $Verbose >= 2;
return $self->{uc $var} = $path;
}
sub _prefixify_default {
my($self, $rprefix, $default) = @_;
warn " cannot prefix, using default.\n" if $Verbose >= 2;
if( !$default ) {
warn "No default!\n" if $Verbose >= 1;
return;
}
if( !$rprefix ) {
warn "No replacement prefix!\n" if $Verbose >= 1;
return '';
}
return $self->_catprefix($rprefix, $default);
}
sub _catprefix {
my($self, $rprefix, $default) = @_;
my($rvol, $rdirs) = $self->splitpath($rprefix);
if( $rvol ) {
return $self->catpath($rvol,
$self->catdir($rdirs, $default),
''
)
}
else {
return $self->catdir($rdirs, $default);
}
}
=item cd
=cut
sub cd {
my($self, $dir, @cmds) = @_;
$dir = vmspath($dir);
my $cmd = join "\n\t", map "$_", @cmds;
# No leading tab makes it look right when embedded
my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd;
startdir = F$Environment("Default")
Set Default %s
%s
Set Default 'startdir'
MAKE_FRAG
# No trailing newline makes this easier to embed
chomp $make_frag;
return $make_frag;
}
=item oneliner
=cut
sub oneliner {
my($self, $cmd, $switches) = @_;
$switches = [] unless defined $switches;
# Strip leading and trailing newlines
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
my @cmds = split /\n/, $cmd;
$cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds;
$cmd = $self->escape_newlines($cmd);
# Switches must be quoted else they will be lowercased.
$switches = join ' ', map { qq{"$_"} } @$switches;
return qq{\$(ABSPERLRUN) $switches -e $cmd "--"};
}
=item B<echo>
perl trips up on "<foo>" thinking it's an input redirect. So we use the
native Write command instead. Besides, it's faster.
=cut
sub echo {
my($self, $text, $file, $opts) = @_;
# Compatibility with old options
if( !ref $opts ) {
my $append = $opts;
$opts = { append => $append || 0 };
}
my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write';
$opts->{allow_variables} = 0 unless defined $opts->{allow_variables};
my $ql_opts = { allow_variables => $opts->{allow_variables} };
my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) }
split /\n/, $text;
push @cmds, '$(NOECHO) Close MMECHOFILE';
return @cmds;
}
=item quote_literal
=cut
sub quote_literal {
my($self, $text, $opts) = @_;
$opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
# I believe this is all we should need.
$text =~ s{"}{""}g;
$text = $opts->{allow_variables}
? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
return qq{"$text"};
}
=item escape_dollarsigns
Quote, don't escape.
=cut
sub escape_dollarsigns {
my($self, $text) = @_;
# Quote dollar signs which are not starting a variable
$text =~ s{\$ (?!\() }{"\$"}gx;
return $text;
}
=item escape_all_dollarsigns
Quote, don't escape.
=cut
sub escape_all_dollarsigns {
my($self, $text) = @_;
# Quote dollar signs
$text =~ s{\$}{"\$\"}gx;
return $text;
}
=item escape_newlines
=cut
sub escape_newlines {
my($self, $text) = @_;
$text =~ s{\n}{-\n}g;
return $text;
}
=item max_exec_len
256 characters.
=cut
sub max_exec_len {
my $self = shift;
return $self->{_MAX_EXEC_LEN} ||= 256;
}
=item init_linker
=cut
sub init_linker {
my $self = shift;
$self->{EXPORT_LIST} ||= '$(BASEEXT).opt';
my $shr = $Config{dbgprefix} . 'PERLSHR';
if ($self->{PERL_SRC}) {
$self->{PERL_ARCHIVE} ||=
$self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}");
}
else {
$self->{PERL_ARCHIVE} ||=
$ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
}
$self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
}
=item catdir (override)
=item catfile (override)
Eliminate the macros in the output to the MMS/MMK file.
(File::Spec::VMS used to do this for us, but it's being removed)
=cut
sub catdir {
my $self = shift;
# Process the macros on VMS MMS/MMK
my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_;
my $dir = $self->SUPER::catdir(@args);
# Fix up the directory and force it to VMS format.
$dir = $self->fixpath($dir, 1);
return $dir;
}
sub catfile {
my $self = shift;
# Process the macros on VMS MMS/MMK
my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_;
my $file = $self->SUPER::catfile(@args);
$file = vmsify($file);
return $file
}
=item eliminate_macros
Expands MM[KS]/Make macros in a text string, using the contents of
identically named elements of C<%$self>, and returns the result
as a file specification in Unix syntax.
NOTE: This is the canonical version of the method. The version in
File::Spec::VMS is deprecated.
=cut
sub eliminate_macros {
my($self,$path) = @_;
return '' unless $path;
$self = {} unless ref $self;
my($npath) = unixify($path);
# sometimes unixify will return a string with an off-by-one trailing null
$npath =~ s{\0$}{};
my($complex) = 0;
my($head,$macro,$tail);
# perform m##g in scalar context so it acts as an iterator
while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
if (defined $self->{$2}) {
($head,$macro,$tail) = ($1,$2,$3);
if (ref $self->{$macro}) {
if (ref $self->{$macro} eq 'ARRAY') {
$macro = join ' ', @{$self->{$macro}};
}
else {
print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
"\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
$macro = "\cB$macro\cB";
$complex = 1;
}
}
else {
$macro = $self->{$macro};
# Don't unixify if there is unescaped whitespace
$macro = unixify($macro) unless ($macro =~ /(?<!\^)\s/);
$macro =~ s#/\Z(?!\n)##;
}
$npath = "$head$macro$tail";
}
}
if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
$npath;
}
=item fixpath
my $path = $mm->fixpath($path);
my $path = $mm->fixpath($path, $is_dir);
Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
in any directory specification, in order to avoid juxtaposing two
VMS-syntax directories when MM[SK] is run. Also expands expressions which
are all macro, so that we can tell how long the expansion is, and avoid
overrunning DCL's command buffer when MM[KS] is running.
fixpath() checks to see whether the result matches the name of a
directory in the current default directory and returns a directory or
file specification accordingly. C<$is_dir> can be set to true to
force fixpath() to consider the path to be a directory or false to force
it to be a file.
NOTE: This is the canonical version of the method. The version in
File::Spec::VMS is deprecated.
=cut
sub fixpath {
my($self,$path,$force_path) = @_;
return '' unless $path;
$self = bless {}, $self unless ref $self;
my($fixedpath,$prefix,$name);
if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
$fixedpath = vmspath($self->eliminate_macros($path));
}
else {
$fixedpath = vmsify($self->eliminate_macros($path));
}
}
elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
my($vmspre) = $self->eliminate_macros("\$($prefix)");
# is it a dir or just a name?
$vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
$fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
$fixedpath = vmspath($fixedpath) if $force_path;
}
else {
$fixedpath = $path;
$fixedpath = vmspath($fixedpath) if $force_path;
}
# No hints, so we try to guess
if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
$fixedpath = vmspath($fixedpath) if -d $fixedpath;
}
# Trim off root dirname if it's had other dirs inserted in front of it.
$fixedpath =~ s/\.000000([\]>])/$1/;
# Special case for VMS absolute directory specs: these will have had device
# prepended during trip through Unix syntax in eliminate_macros(), since
# Unix syntax has no way to express "absolute from the top of this device's
# directory tree".
if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
return $fixedpath;
}
=item os_flavor
VMS is VMS.
=cut
sub os_flavor {
return('VMS');
}
=item is_make_type (override)
None of the make types being checked for is viable on VMS,
plus our $self->{MAKE} is an unexpanded (and unexpandable)
macro whose value is known only to the make utility itself.
=cut
sub is_make_type {
my($self, $type) = @_;
return 0;
}
=item make_type (override)
Returns a suitable string describing the type of makefile being written.
=cut
sub make_type { "$Config{make}-style"; }
=back
=head1 AUTHOR
Original author Charles Bailey F<[email protected]>
Maintained by Michael G Schwern F<[email protected]>
See L<ExtUtils::MakeMaker> for patching and contact information.
=cut
1;
EXTUTILS_MM_VMS
$fatpacked{"ExtUtils/MM_VOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_VOS';
package ExtUtils::MM_VOS;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
=head1 NAME
ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix
=head1 SYNOPSIS
Don't use this module directly.
Use ExtUtils::MM and let it choose.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Unix which contains functionality for
VOS.
Unless otherwise stated it works just like ExtUtils::MM_Unix
=head2 Overridden methods
=head3 extra_clean_files
Cleanup VOS core files
=cut
sub extra_clean_files {
return qw(*.kp);
}
=head1 AUTHOR
Michael G Schwern <[email protected]> with code from ExtUtils::MM_Unix
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
1;
EXTUTILS_MM_VOS
$fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_WIN32';
package ExtUtils::MM_Win32;
use strict;
=head1 NAME
ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
=head1 SYNOPSIS
use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed
=head1 DESCRIPTION
See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
=cut
use ExtUtils::MakeMaker::Config;
use File::Basename;
use File::Spec;
use ExtUtils::MakeMaker qw(neatvalue _sprintf562);
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
our $VERSION = '7.34';
$VERSION = eval $VERSION;
$ENV{EMXSHELL} = 'sh'; # to run `commands`
my ( $BORLAND, $GCC, $MSVC ) = _identify_compiler_environment( \%Config );
sub _identify_compiler_environment {
my ( $config ) = @_;
my $BORLAND = $config->{cc} =~ /\bbcc/i ? 1 : 0;
my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0;
my $MSVC = $config->{cc} =~ /\b(?:cl|icl)/i ? 1 : 0; # MSVC can come as clarm.exe, icl=Intel C
return ( $BORLAND, $GCC, $MSVC );
}
=head2 Overridden methods
=over 4
=item B<dlsyms>
=cut
sub dlsyms {
my($self,%attribs) = @_;
return '' if $self->{SKIPHASH}{'dynamic'};
$self->xs_dlsyms_iterator(\%attribs);
}
=item xs_dlsyms_ext
On Win32, is C<.def>.
=cut
sub xs_dlsyms_ext {
'.def';
}
=item replace_manpage_separator
Changes the path separator with .
=cut
sub replace_manpage_separator {
my($self,$man) = @_;
$man =~ s,/+,.,g;
$man;
}
=item B<maybe_command>
Since Windows has nothing as simple as an executable bit, we check the
file extension.
The PATHEXT env variable will be used to get a list of extensions that
might indicate a command, otherwise .com, .exe, .bat and .cmd will be
used by default.
=cut
sub maybe_command {
my($self,$file) = @_;
my @e = exists($ENV{'PATHEXT'})
? split(/;/, $ENV{PATHEXT})
: qw(.com .exe .bat .cmd);
my $e = '';
for (@e) { $e .= "\Q$_\E|" }
chop $e;
# see if file ends in one of the known extensions
if ($file =~ /($e)$/i) {
return $file if -e $file;
}
else {
for (@e) {
return "$file$_" if -e "$file$_";
}
}
return;
}
=item B<init_DIRFILESEP>
Using \ for Windows, except for "gmake" where it is /.
=cut
sub init_DIRFILESEP {
my($self) = shift;
# The ^ makes sure its not interpreted as an escape in nmake
$self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' :
$self->is_make_type('dmake') ? '\\\\' :
$self->is_make_type('gmake') ? '/'
: '\\';
}
=item init_tools
Override some of the slower, portable commands with Windows specific ones.
=cut
sub init_tools {
my ($self) = @_;
$self->{NOOP} ||= 'rem';
$self->{DEV_NULL} ||= '> NUL';
$self->{FIXIN} ||= $self->{PERL_CORE} ?
"\$(PERLRUN) $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" :
'pl2bat.bat';
$self->SUPER::init_tools;
# Setting SHELL from $Config{sh} can break dmake. Its ok without it.
delete $self->{SHELL};
return;
}
=item init_others
Override the default link and compile tools.
LDLOADLIBS's default is changed to $Config{libs}.
Adjustments are made for Borland's quirks needing -L to come first.
=cut
sub init_others {
my $self = shift;
$self->{LD} ||= 'link';
$self->{AR} ||= 'lib';
$self->SUPER::init_others;
$self->{LDLOADLIBS} ||= $Config{libs};
# -Lfoo must come first for Borland, so we put it in LDDLFLAGS
if ($BORLAND) {
my $libs = $self->{LDLOADLIBS};
my $libpath = '';
while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
$libpath .= ' ' if length $libpath;
$libpath .= $1;
}
$self->{LDLOADLIBS} = $libs;
$self->{LDDLFLAGS} ||= $Config{lddlflags};
$self->{LDDLFLAGS} .= " $libpath";
}
return;
}
=item init_platform
Add MM_Win32_VERSION.
=item platform_constants
=cut
sub init_platform {
my($self) = shift;
$self->{MM_Win32_VERSION} = $VERSION;
return;
}
sub platform_constants {
my($self) = shift;
my $make_frag = '';
foreach my $macro (qw(MM_Win32_VERSION))
{
next unless defined $self->{$macro};
$make_frag .= "$macro = $self->{$macro}\n";
}
return $make_frag;
}
=item specify_shell
Set SHELL to $ENV{COMSPEC} only if make is type 'gmake'.
=cut
sub specify_shell {
my $self = shift;
return '' unless $self->is_make_type('gmake');
"\nSHELL = $ENV{COMSPEC}\n";
}
=item constants
Add MAXLINELENGTH for dmake before all the constants are output.
=cut
sub constants {
my $self = shift;
my $make_text = $self->SUPER::constants;
return $make_text unless $self->is_make_type('dmake');
# dmake won't read any single "line" (even those with escaped newlines)
# larger than a certain size which can be as small as 8k. PM_TO_BLIB
# on large modules like DateTime::TimeZone can create lines over 32k.
# So we'll crank it up to a <ironic>WHOPPING</ironic> 64k.
#
# This has to come here before all the constants and not in
# platform_constants which is after constants.
my $size = $self->{MAXLINELENGTH} || 800000;
my $prefix = qq{
# Get dmake to read long commands like PM_TO_BLIB
MAXLINELENGTH = $size
};
return $prefix . $make_text;
}
=item special_targets
Add .USESHELL target for dmake.
=cut
sub special_targets {
my($self) = @_;
my $make_frag = $self->SUPER::special_targets;
$make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake');
.USESHELL :
MAKE_FRAG
return $make_frag;
}
=item static_lib_pure_cmd
Defines how to run the archive utility
=cut
sub static_lib_pure_cmd {
my ($self, $from) = @_;
$from =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND;
sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $from
: ($GCC ? '-ru $@ ' . $from
: '-out:$@ ' . $from));
}
=item dynamic_lib
Methods are overridden here: not dynamic_lib itself, but the utility
ones that do the OS-specific work.
=cut
sub xs_make_dynamic_lib {
my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_;
my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)'."\n", $to, $from, $todir, $exportlist;
if ($GCC) {
# per https://rt.cpan.org/Ticket/Display.html?id=78395 no longer
# uses dlltool - relies on post 2002 MinGW
# 1 2
push @m, _sprintf562 <<'EOF', $exportlist, $ldfrom;
$(LD) %1$s -o $@ $(LDDLFLAGS) %2$s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -Wl,--enable-auto-image-base
EOF
} elsif ($BORLAND) {
my $ldargs = $self->is_make_type('dmake')
? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),}
: q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) $(subst /,\,$(MYEXTLIB)),};
my $subbed;
if ($exportlist eq '$(EXPORT_LIST)') {
$subbed = $self->is_make_type('dmake')
? q{$(EXPORT_LIST:s,/,\,)}
: q{$(subst /,\,$(EXPORT_LIST))};
} else {
# in XSMULTI, exportlist is per-XS, so have to sub in perl not make
($subbed = $exportlist) =~ s#/#\\#g;
}
push @m, sprintf <<'EOF', $ldfrom, $ldargs . $subbed;
$(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) %s,$@,,%s,$(RESFILES)
EOF
} else { # VC
push @m, sprintf <<'EOF', $ldfrom, $exportlist;
$(LD) -out:$@ $(LDDLFLAGS) %s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:%s
EOF
# Embed the manifest file if it exists
push(@m, q{ if exist [email protected] mt -nologo -manifest [email protected] -outputresource:$@;2
if exist [email protected] del [email protected]});
}
push @m, "\n\t\$(CHMOD) \$(PERM_RWX) \$\@\n";
join '', @m;
}
sub xs_dynamic_lib_macros {
my ($self, $attribs) = @_;
my $otherldflags = $attribs->{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || "";
sprintf <<'EOF', $otherldflags, $inst_dynamic_dep;
# This section creates the dynamically loadable objects from relevant
# objects and possibly $(MYEXTLIB).
OTHERLDFLAGS = %s
INST_DYNAMIC_DEP = %s
EOF
}
=item extra_clean_files
Clean out some extra dll.{base,exp} files which might be generated by
gcc. Otherwise, take out all *.pdb files.
=cut
sub extra_clean_files {
my $self = shift;
return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb');
}
=item init_linker
=cut
sub init_linker {
my $self = shift;
$self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}";
$self->{PERL_ARCHIVEDEP} = "\$(PERL_INCDEP)\\$Config{libperl}";
$self->{PERL_ARCHIVE_AFTER} = '';
$self->{EXPORT_LIST} = '$(BASEEXT).def';
}
=item perl_script
Checks for the perl program under several common perl extensions.
=cut
sub perl_script {
my($self,$file) = @_;
return $file if -r $file && -f _;
return "$file.pl" if -r "$file.pl" && -f _;
return "$file.plx" if -r "$file.plx" && -f _;
return "$file.bat" if -r "$file.bat" && -f _;
return;
}
sub can_dep_space {
my $self = shift;
1; # with Win32::GetShortPathName
}
=item quote_dep
=cut
sub quote_dep {
my ($self, $arg) = @_;
if ($arg =~ / / and not $self->is_make_type('gmake')) {
require Win32;
$arg = Win32::GetShortPathName($arg);
die <<EOF if not defined $arg or $arg =~ / /;
Tried to use make dependency with space for non-GNU make:
'$arg'
Fallback to short pathname failed.
EOF
return $arg;
}
return $self->SUPER::quote_dep($arg);
}
=item xs_obj_opt
Override to fixup -o flags for MSVC.
=cut
sub xs_obj_opt {
my ($self, $output_file) = @_;
($MSVC ? "/Fo" : "-o ") . $output_file;
}
=item pasthru
All we send is -nologo to nmake to prevent it from printing its damned
banner.
=cut
sub pasthru {
my($self) = shift;
my $old = $self->SUPER::pasthru;
return $old unless $self->is_make_type('nmake');
$old =~ s/(PASTHRU\s*=\s*)/$1 -nologo /;
$old;
}
=item arch_check (override)
Normalize all arguments for consistency of comparison.
=cut
sub arch_check {
my $self = shift;
# Win32 is an XS module, minperl won't have it.
# arch_check() is not critical, so just fake it.
return 1 unless $self->can_load_xs;
return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_);
}
sub _normalize_path_name {
my $self = shift;
my $file = shift;
require Win32;
my $short = Win32::GetShortPathName($file);
return defined $short ? lc $short : lc $file;
}
=item oneliner
These are based on what command.com does on Win98. They may be wrong
for other Windows shells, I don't know.
=cut
sub oneliner {
my($self, $cmd, $switches) = @_;
$switches = [] unless defined $switches;
# Strip leading and trailing newlines
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
$cmd = $self->quote_literal($cmd);
$cmd = $self->escape_newlines($cmd);
$switches = join ' ', @$switches;
return qq{\$(ABSPERLRUN) $switches -e $cmd --};
}
sub quote_literal {
my($self, $text, $opts) = @_;
$opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
# See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP
# Apply the Microsoft C/C++ parsing rules
$text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\"
$text =~ s{(?<!\\)\\"}{\\\\\\"}g; # \" -> \\\"
$text =~ s{(?<!\\)"}{\\"}g; # " -> \"
$text = qq{"$text"} if $text =~ /[ \t]/;
# Apply the Command Prompt parsing rules (cmd.exe)
my @text = split /("[^"]*")/, $text;
# We should also escape parentheses, but it breaks one-liners containing
# $(MACRO)s in makefiles.
s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text;
$text = join('', @text);
# dmake expands {{ to { and }} to }.
if( $self->is_make_type('dmake') ) {
$text =~ s/{/{{/g;
$text =~ s/}/}}/g;
}
$text = $opts->{allow_variables}
? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
return $text;
}
sub escape_newlines {
my($self, $text) = @_;
# Escape newlines
$text =~ s{\n}{\\\n}g;
return $text;
}
=item cd
dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot. It
wants:
cd dir1\dir2
command
another_command
cd ..\..
=cut
sub cd {
my($self, $dir, @cmds) = @_;
return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake');
my $cmd = join "\n\t", map "$_", @cmds;
my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir));
# No leading tab and no trailing newline makes for easier embedding.
my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs;
cd %s
%s
cd %s
MAKE_FRAG
chomp $make_frag;
return $make_frag;
}
=item max_exec_len
nmake 1.50 limits command length to 2048 characters.
=cut
sub max_exec_len {
my $self = shift;
return $self->{_MAX_EXEC_LEN} ||= 2 * 1024;
}
=item os_flavor
Windows is Win32.
=cut
sub os_flavor {
return('Win32');
}
=item cflags
Defines the PERLDLL symbol if we are configured for static building since all
code destined for the perl5xx.dll must be compiled with the PERLDLL symbol
defined.
=cut
sub cflags {
my($self,$libperl)=@_;
return $self->{CFLAGS} if $self->{CFLAGS};
return '' unless $self->needs_linking();
my $base = $self->SUPER::cflags($libperl);
foreach (split /\n/, $base) {
/^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
};
$self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static');
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
};
}
=item make_type
Returns a suitable string describing the type of makefile being written.
=cut
sub make_type {
my ($self) = @_;
my $make = $self->make;
$make = +( File::Spec->splitpath( $make ) )[-1];
$make =~ s!\.exe$!!i;
if ( $make =~ m![^A-Z0-9]!i ) {
($make) = grep { m!make!i } split m![^A-Z0-9]!i, $make;
}
return "$make-style";
}
1;
__END__
=back
EXTUTILS_MM_WIN32
$fatpacked{"ExtUtils/MM_Win95.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_WIN95';
package ExtUtils::MM_Win95;
use strict;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
use ExtUtils::MakeMaker::Config;
=head1 NAME
ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X
=head1 SYNOPSIS
You should not be using this module directly.
=head1 DESCRIPTION
This is a subclass of ExtUtils::MM_Win32 containing changes necessary
to get MakeMaker playing nice with command.com and other Win9Xisms.
=head2 Overridden methods
Most of these make up for limitations in the Win9x/nmake command shell.
=over 4
=item max_exec_len
Win98 chokes on things like Encode if we set the max length to nmake's max
of 2K. So we go for a more conservative value of 1K.
=cut
sub max_exec_len {
my $self = shift;
return $self->{_MAX_EXEC_LEN} ||= 1024;
}
=item os_flavor
Win95 and Win98 and WinME are collectively Win9x and Win32
=cut
sub os_flavor {
my $self = shift;
return ($self->SUPER::os_flavor, 'Win9x');
}
=back
=head1 AUTHOR
Code originally inside MM_Win32. Original author unknown.
Currently maintained by Michael G Schwern C<[email protected]>.
Send patches and ideas to C<[email protected]>.
See https://metacpan.org/release/ExtUtils-MakeMaker.
=cut
1;
EXTUTILS_MM_WIN95
$fatpacked{"ExtUtils/MY.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MY';
package ExtUtils::MY;
use strict;
require ExtUtils::MM;
our $VERSION = '7.34';
$VERSION = eval $VERSION;
our @ISA = qw(ExtUtils::MM);
{
package MY;
our @ISA = qw(ExtUtils::MY);
}
sub DESTROY {}
=head1 NAME
ExtUtils::MY - ExtUtils::MakeMaker subclass for customization
=head1 SYNOPSIS
# in your Makefile.PL
sub MY::whatever {
...
}
=head1 DESCRIPTION
B<FOR INTERNAL USE ONLY>
ExtUtils::MY is a subclass of ExtUtils::MM. Its provided in your
Makefile.PL for you to add and override MakeMaker functionality.
It also provides a convenient alias via the MY class.
ExtUtils::MY might turn out to be a temporary solution, but MY won't
go away.
=cut
EXTUTILS_MY
$fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER';
# $Id$
package ExtUtils::MakeMaker;
use strict;
BEGIN {require 5.006;}
require Exporter;
use ExtUtils::MakeMaker::Config;
use ExtUtils::MakeMaker::version; # ensure we always have our fake version.pm
use Carp;
use File::Path;
my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone
eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') }
if $CAN_DECODE and Encode::find_encoding('locale')->name eq 'ascii';
our $Verbose = 0; # exported
our @Parent; # needs to be localized
our @Get_from_Config; # referenced by MM_Unix
our @MM_Sections;
our @Overridable;
my @Prepend_parent;
my %Recognized_Att_Keys;
our %macro_fsentity; # whether a macro is a filesystem name
our %macro_dep; # whether a macro is a dependency
our $VERSION = '7.34';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
# Emulate something resembling CVS $Revision$
(our $Revision = $VERSION) =~ s{_}{};
$Revision = int $Revision * 10000;
our $Filename = __FILE__; # referenced outside MakeMaker
our @ISA = qw(Exporter);
our @EXPORT = qw(&WriteMakefile $Verbose &prompt &os_unsupported);
our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists
&WriteEmptyMakefile &open_for_writing &write_file_via_tmp
&_sprintf562);
# These will go away once the last of the Win32 & VMS specific code is
# purged.
my $Is_VMS = $^O eq 'VMS';
my $Is_Win32 = $^O eq 'MSWin32';
our $UNDER_CORE = $ENV{PERL_CORE}; # needs to be our
full_setup();
require ExtUtils::MM; # Things like CPAN assume loading ExtUtils::MakeMaker
# will give them MM.
require ExtUtils::MY; # XXX pre-5.8 versions of ExtUtils::Embed expect
# loading ExtUtils::MakeMaker will give them MY.
# This will go when Embed is its own CPAN module.
# 5.6.2 can't do sprintf "%1$s" - this can only do %s
sub _sprintf562 {
my ($format, @args) = @_;
for (my $i = 1; $i <= @args; $i++) {
$format =~ s#%$i\$s#$args[$i-1]#g;
}
$format;
}
sub WriteMakefile {
croak "WriteMakefile: Need even number of args" if @_ % 2;
require ExtUtils::MY;
my %att = @_;
_convert_compat_attrs(\%att);
_verify_att(\%att);
my $mm = MM->new(\%att);
$mm->flush;
return $mm;
}
# Basic signatures of the attributes WriteMakefile takes. Each is the
# reference type. Empty value indicate it takes a non-reference
# scalar.
my %Att_Sigs;
my %Special_Sigs = (
AUTHOR => 'ARRAY',
C => 'ARRAY',
CONFIG => 'ARRAY',
CONFIGURE => 'CODE',
DIR => 'ARRAY',
DL_FUNCS => 'HASH',
DL_VARS => 'ARRAY',
EXCLUDE_EXT => 'ARRAY',
EXE_FILES => 'ARRAY',
FUNCLIST => 'ARRAY',
H => 'ARRAY',
IMPORTS => 'HASH',
INCLUDE_EXT => 'ARRAY',
LIBS => ['ARRAY',''],
MAN1PODS => 'HASH',
MAN3PODS => 'HASH',
META_ADD => 'HASH',
META_MERGE => 'HASH',
OBJECT => ['ARRAY', ''],
PL_FILES => 'HASH',
PM => 'HASH',
PMLIBDIRS => 'ARRAY',
PMLIBPARENTDIRS => 'ARRAY',
PREREQ_PM => 'HASH',
BUILD_REQUIRES => 'HASH',
CONFIGURE_REQUIRES => 'HASH',
TEST_REQUIRES => 'HASH',
SKIP => 'ARRAY',
TYPEMAPS => 'ARRAY',
XS => 'HASH',
XSBUILD => 'HASH',
VERSION => ['version',''],
_KEEP_AFTER_FLUSH => '',
clean => 'HASH',
depend => 'HASH',
dist => 'HASH',
dynamic_lib=> 'HASH',
linkext => 'HASH',
macro => 'HASH',
postamble => 'HASH',
realclean => 'HASH',
test => 'HASH',
tool_autosplit => 'HASH',
);
@Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys;
@Att_Sigs{keys %Special_Sigs} = values %Special_Sigs;
sub _convert_compat_attrs { #result of running several times should be same
my($att) = @_;
if (exists $att->{AUTHOR}) {
if ($att->{AUTHOR}) {
if (!ref($att->{AUTHOR})) {
my $t = $att->{AUTHOR};
$att->{AUTHOR} = [$t];
}
} else {
$att->{AUTHOR} = [];
}
}
}
sub _verify_att {
my($att) = @_;
foreach my $key (sort keys %$att) {
my $val = $att->{$key};
my $sig = $Att_Sigs{$key};
unless( defined $sig ) {
warn "WARNING: $key is not a known parameter.\n";
next;
}
my @sigs = ref $sig ? @$sig : $sig;
my $given = ref $val;
unless( grep { _is_of_type($val, $_) } @sigs ) {
my $takes = join " or ", map { _format_att($_) } @sigs;
my $has = _format_att($given);
warn "WARNING: $key takes a $takes not a $has.\n".
" Please inform the author.\n";
}
}
}
# Check if a given thing is a reference or instance of $type
sub _is_of_type {
my($thing, $type) = @_;
return 1 if ref $thing eq $type;
local $SIG{__DIE__};
return 1 if eval{ $thing->isa($type) };
return 0;
}
sub _format_att {
my $given = shift;
return $given eq '' ? "string/number"
: uc $given eq $given ? "$given reference"
: "$given object"
;
}
sub prompt ($;$) { ## no critic
my($mess, $def) = @_;
confess("prompt function called without an argument")
unless defined $mess;
my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
my $dispdef = defined $def ? "[$def] " : " ";
$def = defined $def ? $def : "";
local $|=1;
local $\;
print "$mess $dispdef";
my $ans;
if ($ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) {
print "$def\n";
}
else {
$ans = <STDIN>;
if( defined $ans ) {
$ans =~ s{\015?\012$}{};
}
else { # user hit ctrl-D
print "\n";
}
}
return (!defined $ans || $ans eq '') ? $def : $ans;
}
sub os_unsupported {
die "OS unsupported\n";
}
sub eval_in_subdirs {
my($self) = @_;
use Cwd qw(cwd abs_path);
my $pwd = cwd() || die "Can't figure out your cwd!";
local @INC = map eval {abs_path($_) if -e} || $_, @INC;
push @INC, '.'; # '.' has to always be at the end of @INC
foreach my $dir (@{$self->{DIR}}){
my($abs) = $self->catdir($pwd,$dir);
eval { $self->eval_in_x($abs); };
last if $@;
}
chdir $pwd;
die $@ if $@;
}
sub eval_in_x {
my($self,$dir) = @_;
chdir $dir or carp("Couldn't change to directory $dir: $!");
{
package main;
do './Makefile.PL';
};
if ($@) {
# if ($@ =~ /prerequisites/) {
# die "MakeMaker WARNING: $@";
# } else {
# warn "WARNING from evaluation of $dir/Makefile.PL: $@";
# }
die "ERROR from evaluation of $dir/Makefile.PL: $@";
}
}
# package name for the classes into which the first object will be blessed
my $PACKNAME = 'PACK000';
sub full_setup {
$Verbose ||= 0;
my @dep_macros = qw/
PERL_INCDEP PERL_ARCHLIBDEP PERL_ARCHIVEDEP
/;
my @fs_macros = qw/
FULLPERL XSUBPPDIR
INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR
INSTALLDIRS
DESTDIR PREFIX INSTALL_BASE
PERLPREFIX SITEPREFIX VENDORPREFIX
INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
INSTALLMAN1DIR INSTALLMAN3DIR
INSTALLSITEMAN1DIR INSTALLSITEMAN3DIR
INSTALLVENDORMAN1DIR INSTALLVENDORMAN3DIR
INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
PERL_LIB PERL_ARCHLIB
SITELIBEXP SITEARCHEXP
MAKE LIBPERL_A LIB PERL_SRC PERL_INC
PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC
PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT
/;
my @attrib_help = qw/
AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION
C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME
DL_FUNCS DL_VARS
EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE
FULLPERLRUN FULLPERLRUNINST
FUNCLIST H IMPORTS
INC INCLUDE_EXT LDFROM LIBS LICENSE
LINKTYPE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET
META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES
MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NO_MYMETA NO_PACKLIST NO_PERLLOCAL
NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN
PERLRUNINST PERL_CORE
PERM_DIR PERM_RW PERM_RWX MAGICXS
PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS
XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION
clean depend dist dynamic_lib linkext macro realclean tool_autosplit
MAN1EXT MAN3EXT
MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC
MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED
/;
push @attrib_help, @fs_macros;
@macro_fsentity{@fs_macros, @dep_macros} = (1) x (@fs_macros+@dep_macros);
@macro_dep{@dep_macros} = (1) x @dep_macros;
# IMPORTS is used under OS/2 and Win32
# @Overridable is close to @MM_Sections but not identical. The
# order is important. Many subroutines declare macros. These
# depend on each other. Let's try to collect the macros up front,
# then pasthru, then the rules.
# MM_Sections are the sections we have to call explicitly
# in Overridable we have subroutines that are used indirectly
@MM_Sections =
qw(
post_initialize const_config constants platform_constants
tool_autosplit tool_xsubpp tools_other
makemakerdflt
dist macro depend cflags const_loadlibs const_cccmd
post_constants
pasthru
special_targets
c_o xs_c xs_o
top_targets blibdirs linkext dlsyms dynamic_bs dynamic
dynamic_lib static static_lib manifypods processPL
installbin subdirs
clean_subdirs clean realclean_subdirs realclean
metafile signature
dist_basics dist_core distdir dist_test dist_ci distmeta distsignature
install force perldepend makefile staticmake test ppd
); # loses section ordering
@Overridable = @MM_Sections;
push @Overridable, qw[
libscan makeaperl needs_linking
subdir_x test_via_harness test_via_script
init_VERSION init_dist init_INST init_INSTALL init_DEST init_dirscan
init_PM init_MANPODS init_xs init_PERL init_DIRFILESEP init_linker
];
push @MM_Sections, qw[
pm_to_blib selfdocument
];
# Postamble needs to be the last that was always the case
push @MM_Sections, "postamble";
push @Overridable, "postamble";
# All sections are valid keys.
@Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections;
# we will use all these variables in the Makefile
@Get_from_Config =
qw(
ar cc cccdlflags ccdlflags dlext dlsrc exe_ext full_ar ld
lddlflags ldflags libc lib_ext obj_ext osname osvers ranlib
sitelibexp sitearchexp so
);
# 5.5.3 doesn't have any concept of vendor libs
push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if $] >= 5.006;
foreach my $item (@attrib_help){
$Recognized_Att_Keys{$item} = 1;
}
foreach my $item (@Get_from_Config) {
$Recognized_Att_Keys{uc $item} = $Config{$item};
print "Attribute '\U$item\E' => '$Config{$item}'\n"
if ($Verbose >= 2);
}
#
# When we eval a Makefile.PL in a subdirectory, that one will ask
# us (the parent) for the values and will prepend "..", so that
# all files to be installed end up below OUR ./blib
#
@Prepend_parent = qw(
INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT
MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC
PERL FULLPERL
);
}
sub _has_cpan_meta_requirements {
return eval {
require CPAN::Meta::Requirements;
CPAN::Meta::Requirements->VERSION(2.130);
require B; # CMR requires this, for core we have to too.
};
}
sub new {
my($class,$self) = @_;
my($key);
_convert_compat_attrs($self) if defined $self && $self;
# Store the original args passed to WriteMakefile()
foreach my $k (keys %$self) {
$self->{ARGS}{$k} = $self->{$k};
}
$self = {} unless defined $self;
# Temporarily bless it into MM so it can be used as an
# object. It will be blessed into a temp package later.
bless $self, "MM";
# Cleanup all the module requirement bits
my %key2cmr;
for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
$self->{$key} ||= {};
if (_has_cpan_meta_requirements) {
my $cmr = CPAN::Meta::Requirements->from_string_hash(
$self->{$key},
{
bad_version_hook => sub {
#no warnings 'numeric'; # module doesn't use warnings
my $fallback;
if ( $_[0] =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
$fallback = sprintf "%f", $_[0];
} else {
($fallback) = $_[0] ? ($_[0] =~ /^([0-9.]+)/) : 0;
$fallback += 0;
carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as $fallback";
}
version->new($fallback);
},
},
);
$self->{$key} = $cmr->as_string_hash;
$key2cmr{$key} = $cmr;
} else {
for my $module (sort keys %{ $self->{$key} }) {
my $version = $self->{$key}->{$module};
my $fallback = 0;
if (!defined($version) or !length($version)) {
carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)";
}
elsif ($version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/) {
next;
}
else {
if ( $version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
$fallback = sprintf "%f", $version;
} else {
($fallback) = $version ? ($version =~ /^([0-9.]+)/) : 0;
$fallback += 0;
carp "Unparsable version '$version' for prerequisite $module treated as $fallback (CPAN::Meta::Requirements not available)";
}
}
$self->{$key}->{$module} = $fallback;
}
}
}
if ("@ARGV" =~ /\bPREREQ_PRINT\b/) {
$self->_PREREQ_PRINT;
}
# PRINT_PREREQ is RedHatism.
if ("@ARGV" =~ /\bPRINT_PREREQ\b/) {
$self->_PRINT_PREREQ;
}
print "MakeMaker (v$VERSION)\n" if $Verbose;
if (-f "MANIFEST" && ! -f "Makefile" && ! $UNDER_CORE){
check_manifest();
}
check_hints($self);
if ( defined $self->{MIN_PERL_VERSION}
&& $self->{MIN_PERL_VERSION} !~ /^v?[\d_\.]+$/ ) {
require version;
my $normal = eval {
local $SIG{__WARN__} = sub {
# simulate "use warnings FATAL => 'all'" for vintage perls
die @_;
};
version->new( $self->{MIN_PERL_VERSION} )
};
$self->{MIN_PERL_VERSION} = $normal if defined $normal && !$@;
}
# Translate X.Y.Z to X.00Y00Z
if( defined $self->{MIN_PERL_VERSION} ) {
$self->{MIN_PERL_VERSION} =~ s{ ^v? (\d+) \. (\d+) \. (\d+) $ }
{sprintf "%d.%03d%03d", $1, $2, $3}ex;
}
my $perl_version_ok = eval {
local $SIG{__WARN__} = sub {
# simulate "use warnings FATAL => 'all'" for vintage perls
die @_;
};
!$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= $]
};
if (!$perl_version_ok) {
if (!defined $perl_version_ok) {
die <<'END';
Warning: MIN_PERL_VERSION is not in a recognized format.
Recommended is a quoted numerical value like '5.005' or '5.008001'.
END
}
elsif ($self->{PREREQ_FATAL}) {
die sprintf <<"END", $self->{MIN_PERL_VERSION}, $];
MakeMaker FATAL: perl version too low for this distribution.
Required is %s. We run %s.
END
}
else {
warn sprintf
"Warning: Perl version %s or higher required. We run %s.\n",
$self->{MIN_PERL_VERSION}, $];
}
}
my %configure_att; # record &{$self->{CONFIGURE}} attributes
my(%initial_att) = %$self; # record initial attributes
my(%unsatisfied) = ();
my %prereq2version;
my $cmr;
if (_has_cpan_meta_requirements) {
$cmr = CPAN::Meta::Requirements->new;
for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
$cmr->add_requirements($key2cmr{$key}) if $key2cmr{$key};
}
foreach my $prereq ($cmr->required_modules) {
$prereq2version{$prereq} = $cmr->requirements_for_module($prereq);
}
} else {
for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) {
next unless my $module2version = $self->{$key};
$prereq2version{$_} = $module2version->{$_} for keys %$module2version;
}
}
foreach my $prereq (sort keys %prereq2version) {
my $required_version = $prereq2version{$prereq};
my $pr_version = 0;
my $installed_file;
if ( $prereq eq 'perl' ) {
if ( defined $required_version && $required_version =~ /^v?[\d_\.]+$/
|| $required_version !~ /^v?[\d_\.]+$/ ) {
require version;
my $normal = eval { version->new( $required_version ) };
$required_version = $normal if defined $normal;
}
$installed_file = $prereq;
$pr_version = $];
}
else {
$installed_file = MM->_installed_file_for_module($prereq);
$pr_version = MM->parse_version($installed_file) if $installed_file;
$pr_version = 0 if $pr_version eq 'undef';
if ( !eval { version->new( $pr_version ); 1 } ) {
#no warnings 'numeric'; # module doesn't use warnings
my $fallback;
if ( $pr_version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
$fallback = sprintf '%f', $pr_version;
} else {
($fallback) = $pr_version ? ($pr_version =~ /^([0-9.]+)/) : 0;
$fallback += 0;
carp "Unparsable version '$pr_version' for installed prerequisite $prereq treated as $fallback";
}
$pr_version = $fallback;
}
}
# convert X.Y_Z alpha version #s to X.YZ for easier comparisons
$pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/;
if (!$installed_file) {
warn sprintf "Warning: prerequisite %s %s not found.\n",
$prereq, $required_version
unless $self->{PREREQ_FATAL}
or $UNDER_CORE;
$unsatisfied{$prereq} = 'not installed';
}
elsif (
$cmr
? !$cmr->accepts_module($prereq, $pr_version)
: $required_version > $pr_version
) {
warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n",
$prereq, $required_version, ($pr_version || 'unknown version')
unless $self->{PREREQ_FATAL}
or $UNDER_CORE;
$unsatisfied{$prereq} = $required_version || 'unknown version' ;
}
}
if (%unsatisfied && $self->{PREREQ_FATAL}){
my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"}
sort { $a cmp $b } keys %unsatisfied;
die <<"END";
MakeMaker FATAL: prerequisites not found.
$failedprereqs
Please install these modules first and rerun 'perl Makefile.PL'.
END
}
if (defined $self->{CONFIGURE}) {
if (ref $self->{CONFIGURE} eq 'CODE') {
%configure_att = %{&{$self->{CONFIGURE}}};
_convert_compat_attrs(\%configure_att);
$self = { %$self, %configure_att };
} else {
croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n";
}
}
my $newclass = ++$PACKNAME;
local @Parent = @Parent; # Protect against non-local exits
{
print "Blessing Object into class [$newclass]\n" if $Verbose>=2;
mv_all_methods("MY",$newclass);
bless $self, $newclass;
push @Parent, $self;
require ExtUtils::MY;
no strict 'refs'; ## no critic;
@{"$newclass\:\:ISA"} = 'MM';
}
if (defined $Parent[-2]){
$self->{PARENT} = $Parent[-2];
for my $key (@Prepend_parent) {
next unless defined $self->{PARENT}{$key};
# Don't stomp on WriteMakefile() args.
next if defined $self->{ARGS}{$key} and
$self->{ARGS}{$key} eq $self->{$key};
$self->{$key} = $self->{PARENT}{$key};
if ($Is_VMS && $key =~ /PERL$/) {
# PERL or FULLPERL will be a command verb or even a
# command with an argument instead of a full file
# specification under VMS. So, don't turn the command
# into a filespec, but do add a level to the path of
# the argument if not already absolute.
my @cmd = split /\s+/, $self->{$key};
$cmd[1] = $self->catfile('[-]',$cmd[1])
unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]);
$self->{$key} = join(' ', @cmd);
} else {
my $value = $self->{$key};
# not going to test in FS so only stripping start
$value =~ s/^"// if $key =~ /PERL$/;
$value = $self->catdir("..", $value)
unless $self->file_name_is_absolute($value);
$value = qq{"$value} if $key =~ /PERL$/;
$self->{$key} = $value;
}
}
if ($self->{PARENT}) {
$self->{PARENT}->{CHILDREN}->{$newclass} = $self;
foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE LD OPTIMIZE)) {
if (exists $self->{PARENT}->{$opt}
and not exists $self->{$opt})
{
# inherit, but only if already unspecified
$self->{$opt} = $self->{PARENT}->{$opt};
}
}
}
my @fm = grep /^FIRST_MAKEFILE=/, @ARGV;
parse_args($self,@fm) if @fm;
}
else {
parse_args($self, _shellwords($ENV{PERL_MM_OPT} || ''),@ARGV);
}
# RT#91540 PREREQ_FATAL not recognized on command line
if (%unsatisfied && $self->{PREREQ_FATAL}){
my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"}
sort { $a cmp $b } keys %unsatisfied;
die <<"END";
MakeMaker FATAL: prerequisites not found.
$failedprereqs
Please install these modules first and rerun 'perl Makefile.PL'.
END
}
$self->{NAME} ||= $self->guess_name;
warn "Warning: NAME must be a package name\n"
unless $self->{NAME} =~ m!^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*$!;
($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g;
$self->init_MAKE;
$self->init_main;
$self->init_VERSION;
$self->init_dist;
$self->init_INST;
$self->init_INSTALL;
$self->init_DEST;
$self->init_dirscan;
$self->init_PM;
$self->init_MANPODS;
$self->init_xs;
$self->init_PERL;
$self->init_DIRFILESEP;
$self->init_linker;
$self->init_ABSTRACT;
$self->arch_check(
$INC{'Config.pm'},
$self->catfile($Config{'archlibexp'}, "Config.pm")
);
$self->init_tools();
$self->init_others();
$self->init_platform();
$self->init_PERM();
my @args = @ARGV;
@args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE;
my($argv) = neatvalue(\@args);
$argv =~ s/^\[/(/;
$argv =~ s/\]$/)/;
push @{$self->{RESULT}}, <<END;
# This Makefile is for the $self->{NAME} extension to perl.
#
# It was generated automatically by MakeMaker version
# $VERSION (Revision: $Revision) from the contents of
# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
#
# ANY CHANGES MADE HERE WILL BE LOST!
#
# MakeMaker ARGV: $argv
#
END
push @{$self->{RESULT}}, $self->_MakeMaker_Parameters_section(\%initial_att);
if (defined $self->{CONFIGURE}) {
push @{$self->{RESULT}}, <<END;
# MakeMaker 'CONFIGURE' Parameters:
END
if (scalar(keys %configure_att) > 0) {
foreach my $key (sort keys %configure_att){
next if $key eq 'ARGS';
my($v) = neatvalue($configure_att{$key});
$v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
$v =~ tr/\n/ /s;
push @{$self->{RESULT}}, "# $key => $v";
}
}
else
{
push @{$self->{RESULT}}, "# no values returned";
}
undef %configure_att; # free memory
}
# turn the SKIP array into a SKIPHASH hash
for my $skip (@{$self->{SKIP} || []}) {
$self->{SKIPHASH}{$skip} = 1;
}
delete $self->{SKIP}; # free memory
if ($self->{PARENT}) {
for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/) {
$self->{SKIPHASH}{$_} = 1;
}
}
# We run all the subdirectories now. They don't have much to query
# from the parent, but the parent has to query them: if they need linking!
unless ($self->{NORECURS}) {
$self->eval_in_subdirs if @{$self->{DIR}};
}
foreach my $section ( @MM_Sections ){
# Support for new foo_target() methods.
my $method = $section;
$method .= '_target' unless $self->can($method);
print "Processing Makefile '$section' section\n" if ($Verbose >= 2);
my($skipit) = $self->skipcheck($section);
if ($skipit){
push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit.";
} else {
my(%a) = %{$self->{$section} || {}};
push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:";
push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a;
push @{$self->{RESULT}}, $self->maketext_filter(
$self->$method( %a )
);
}
}
push @{$self->{RESULT}}, "\n# End.";
$self;
}
sub WriteEmptyMakefile {
croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2;
my %att = @_;
$att{DIR} = [] unless $att{DIR}; # don't recurse by default
my $self = MM->new(\%att);
my $new = $self->{MAKEFILE};
my $old = $self->{MAKEFILE_OLD};
if (-f $old) {
_unlink($old) or warn "unlink $old: $!";
}
if ( -f $new ) {
_rename($new, $old) or warn "rename $new => $old: $!"
}
open my $mfh, '>', $new or die "open $new for write: $!";
print $mfh <<'EOP';
all :
manifypods :
subdirs :
dynamic :
static :
clean :
install :
makemakerdflt :
test :
test_dynamic :
test_static :
EOP
close $mfh or die "close $new for write: $!";
}
=begin private
=head3 _installed_file_for_module
my $file = MM->_installed_file_for_module($module);
Return the first installed .pm $file associated with the $module. The
one which will show up when you C<use $module>.
$module is something like "strict" or "Test::More".
=end private
=cut
sub _installed_file_for_module {
my $class = shift;
my $prereq = shift;
my $file = "$prereq.pm";
$file =~ s{::}{/}g;
my $path;
for my $dir (@INC) {
my $tmp = File::Spec->catfile($dir, $file);
if ( -r $tmp ) {
$path = $tmp;
last;
}
}
return $path;
}
# Extracted from MakeMaker->new so we can test it
sub _MakeMaker_Parameters_section {
my $self = shift;
my $att = shift;
my @result = <<'END';
# MakeMaker Parameters:
END
foreach my $key (sort keys %$att){
next if $key eq 'ARGS';
my $v;
if ($key eq 'PREREQ_PM') {
# CPAN.pm takes prereqs from this field in 'Makefile'
# and does not know about BUILD_REQUIRES
$v = neatvalue({
%{ $att->{PREREQ_PM} || {} },
%{ $att->{BUILD_REQUIRES} || {} },
%{ $att->{TEST_REQUIRES} || {} },
});
} else {
$v = neatvalue($att->{$key});
}
$v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
$v =~ tr/\n/ /s;
push @result, "# $key => $v";
}
return @result;
}
# _shellwords and _parseline borrowed from Text::ParseWords
sub _shellwords {
my (@lines) = @_;
my @allwords;
foreach my $line (@lines) {
$line =~ s/^\s+//;
my @words = _parse_line('\s+', 0, $line);
pop @words if (@words and !defined $words[-1]);
return() unless (@words || !length($line));
push(@allwords, @words);
}
return(@allwords);
}
sub _parse_line {
my($delimiter, $keep, $line) = @_;
my($word, @pieces);
no warnings 'uninitialized'; # we will be testing undef strings
while (length($line)) {
# This pattern is optimised to be stack conservative on older perls.
# Do not refactor without being careful and testing it on very long strings.
# See Perl bug #42980 for an example of a stack busting input.
$line =~ s/^
(?:
# double quoted string
(") # $quote
((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted
| # --OR--
# singe quoted string
(') # $quote
((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted
| # --OR--
# unquoted string
( # $unquoted
(?:\\.|[^\\"'])*?
)
# followed by
( # $delim
\Z(?!\n) # EOL
| # --OR--
(?-x:$delimiter) # delimiter
| # --OR--
(?!^)(?=["']) # a quote
)
)//xs or return; # extended layout
my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6);
return() unless( defined($quote) || length($unquoted) || length($delim));
if ($keep) {
$quoted = "$quote$quoted$quote";
}
else {
$unquoted =~ s/\\(.)/$1/sg;
if (defined $quote) {
$quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
#$quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
}
}
$word .= substr($line, 0, 0); # leave results tainted
$word .= defined $quote ? $quoted : $unquoted;
if (length($delim)) {
push(@pieces, $word);
push(@pieces, $delim) if ($keep eq 'delimiters');
undef $word;
}
if (!length($line)) {
push(@pieces, $word);
}
}
return(@pieces);
}
sub check_manifest {
print "Checking if your kit is complete...\n";
require ExtUtils::Manifest;
# avoid warning
$ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1;
my(@missed) = ExtUtils::Manifest::manicheck();
if (@missed) {
print "Warning: the following files are missing in your kit:\n";
print "\t", join "\n\t", @missed;
print "\n";
print "Please inform the author.\n";
} else {
print "Looks good\n";
}
}
sub parse_args{
my($self, @args) = @_;
@args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE;
foreach (@args) {
unless (m/(.*?)=(.*)/) {
++$Verbose if m/^verb/;
next;
}
my($name, $value) = ($1, $2);
if ($value =~ m/^~(\w+)?/) { # tilde with optional username
$value =~ s [^~(\w*)]
[$1 ?
((getpwnam($1))[7] || "~$1") :
(getpwuid($>))[7]
]ex;
}
# Remember the original args passed it. It will be useful later.
$self->{ARGS}{uc $name} = $self->{uc $name} = $value;
}
# catch old-style 'potential_libs' and inform user how to 'upgrade'
if (defined $self->{potential_libs}){
my($msg)="'potential_libs' => '$self->{potential_libs}' should be";
if ($self->{potential_libs}){
print "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n";
} else {
print "$msg deleted.\n";
}
$self->{LIBS} = [$self->{potential_libs}];
delete $self->{potential_libs};
}
# catch old-style 'ARMAYBE' and inform user how to 'upgrade'
if (defined $self->{ARMAYBE}){
my($armaybe) = $self->{ARMAYBE};
print "ARMAYBE => '$armaybe' should be changed to:\n",
"\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n";
my(%dl) = %{$self->{dynamic_lib} || {}};
$self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe};
delete $self->{ARMAYBE};
}
if (defined $self->{LDTARGET}){
print "LDTARGET should be changed to LDFROM\n";
$self->{LDFROM} = $self->{LDTARGET};
delete $self->{LDTARGET};
}
# Turn a DIR argument on the command line into an array
if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') {
# So they can choose from the command line, which extensions they want
# the grep enables them to have some colons too much in case they
# have to build a list with the shell
$self->{DIR} = [grep $_, split ":", $self->{DIR}];
}
# Turn a INCLUDE_EXT argument on the command line into an array
if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') {
$self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}];
}
# Turn a EXCLUDE_EXT argument on the command line into an array
if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') {
$self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}];
}
foreach my $mmkey (sort keys %$self){
next if $mmkey eq 'ARGS';
print " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose;
print "'$mmkey' is not a known MakeMaker parameter name.\n"
unless exists $Recognized_Att_Keys{$mmkey};
}
$| = 1 if $Verbose;
}
sub check_hints {
my($self) = @_;
# We allow extension-specific hints files.
require File::Spec;
my $curdir = File::Spec->curdir;
my $hint_dir = File::Spec->catdir($curdir, "hints");
return unless -d $hint_dir;
# First we look for the best hintsfile we have
my($hint)="${^O}_$Config{osvers}";
$hint =~ s/\./_/g;
$hint =~ s/_$//;
return unless $hint;
# Also try without trailing minor version numbers.
while (1) {
last if -f File::Spec->catfile($hint_dir, "$hint.pl"); # found
} continue {
last unless $hint =~ s/_[^_]*$//; # nothing to cut off
}
my $hint_file = File::Spec->catfile($hint_dir, "$hint.pl");
return unless -f $hint_file; # really there
_run_hintfile($self, $hint_file);
}
sub _run_hintfile {
our $self;
local($self) = shift; # make $self available to the hint file.
my($hint_file) = shift;
local($@, $!);
print "Processing hints file $hint_file\n" if $Verbose;
# Just in case the ./ isn't on the hint file, which File::Spec can
# often strip off, we bung the curdir into @INC
local @INC = (File::Spec->curdir, @INC);
my $ret = do $hint_file;
if( !defined $ret ) {
my $error = $@ || $!;
warn $error;
}
}
sub mv_all_methods {
my($from,$to) = @_;
local $SIG{__WARN__} = sub {
# can't use 'no warnings redefined', 5.6 only
warn @_ unless $_[0] =~ /^Subroutine .* redefined/
};
foreach my $method (@Overridable) {
next unless defined &{"${from}::$method"};
no strict 'refs'; ## no critic
*{"${to}::$method"} = \&{"${from}::$method"};
# If we delete a method, then it will be undefined and cannot
# be called. But as long as we have Makefile.PLs that rely on
# %MY:: being intact, we have to fill the hole with an
# inheriting method:
{
package MY;
my $super = "SUPER::".$method;
*{$method} = sub {
shift->$super(@_);
};
}
}
}
sub skipcheck {
my($self) = shift;
my($section) = @_;
return 'skipped' if $section eq 'metafile' && $UNDER_CORE;
if ($section eq 'dynamic') {
print "Warning (non-fatal): Target 'dynamic' depends on targets ",
"in skipped section 'dynamic_bs'\n"
if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
print "Warning (non-fatal): Target 'dynamic' depends on targets ",
"in skipped section 'dynamic_lib'\n"
if $self->{SKIPHASH}{dynamic_lib} && $Verbose;
}
if ($section eq 'dynamic_lib') {
print "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ",
"targets in skipped section 'dynamic_bs'\n"
if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
}
if ($section eq 'static') {
print "Warning (non-fatal): Target 'static' depends on targets ",
"in skipped section 'static_lib'\n"
if $self->{SKIPHASH}{static_lib} && $Verbose;
}
return 'skipped' if $self->{SKIPHASH}{$section};
return '';
}
# returns filehandle, dies on fail. :raw so no :crlf
sub open_for_writing {
my ($file) = @_;
open my $fh ,">", $file or die "Unable to open $file: $!";
my @layers = ':raw';
push @layers, join ' ', ':encoding(locale)' if $CAN_DECODE;
binmode $fh, join ' ', @layers;
$fh;
}
sub flush {
my $self = shift;
my $finalname = $self->{MAKEFILE};
printf "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT};
print "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT};
unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ());
write_file_via_tmp($finalname, $self->{RESULT});
# Write MYMETA.yml to communicate metadata up to the CPAN clients
print "Writing MYMETA.yml and MYMETA.json\n"
if !$self->{NO_MYMETA} and $self->write_mymeta( $self->mymeta );
# save memory
if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) {
my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE);
delete $self->{$_} for grep !$keep{$_}, keys %$self;
}
system("$Config::Config{eunicefix} $finalname")
if $Config::Config{eunicefix} ne ":";
return;
}
sub write_file_via_tmp {
my ($finalname, $contents) = @_;
my $fh = open_for_writing("MakeMaker.tmp");
die "write_file_via_tmp: 2nd arg must be ref" unless ref $contents;
for my $chunk (@$contents) {
my $to_write = $chunk;
utf8::encode $to_write if !$CAN_DECODE && $] > 5.008;
print $fh "$to_write\n" or die "Can't write to MakeMaker.tmp: $!";
}
close $fh or die "Can't write to MakeMaker.tmp: $!";
_rename("MakeMaker.tmp", $finalname) or
warn "rename MakeMaker.tmp => $finalname: $!";
chmod 0644, $finalname if !$Is_VMS;
return;
}
# This is a rename for OS's where the target must be unlinked first.
sub _rename {
my($src, $dest) = @_;
_unlink($dest);
return rename $src, $dest;
}
# This is an unlink for OS's where the target must be writable first.
sub _unlink {
my @files = @_;
chmod 0666, @files;
return unlink @files;
}
# The following mkbootstrap() is only for installations that are calling
# the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker
# writes Makefiles, that use ExtUtils::Mkbootstrap directly.
sub mkbootstrap {
die <<END;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker. !!!
!!! Please rebuild your Makefile !!!
END
}
# Ditto for mksymlists() as of MakeMaker 5.17
sub mksymlists {
die <<END;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker. !!!
!!! Please rebuild your Makefile !!!
END
}
sub neatvalue {
my($v) = @_;
return "undef" unless defined $v;
my($t) = ref $v;
return "q[$v]" unless $t;
if ($t eq 'ARRAY') {
my(@m, @neat);
push @m, "[";
foreach my $elem (@$v) {
push @neat, "q[$elem]";
}
push @m, join ", ", @neat;
push @m, "]";
return join "", @m;
}
return $v unless $t eq 'HASH';
my(@m, $key, $val);
for my $key (sort keys %$v) {
last unless defined $key; # cautious programming in case (undef,undef) is true
push @m,"$key=>".neatvalue($v->{$key});
}
return "{ ".join(', ',@m)." }";
}
sub _find_magic_vstring {
my $value = shift;
return $value if $UNDER_CORE;
my $tvalue = '';
require B;
my $sv = B::svref_2object(\$value);
my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
while ( $magic ) {
if ( $magic->TYPE eq 'V' ) {
$tvalue = $magic->PTR;
$tvalue =~ s/^v?(.+)$/v$1/;
last;
}
else {
$magic = $magic->MOREMAGIC;
}
}
return $tvalue;
}
sub selfdocument {
my($self) = @_;
my(@m);
if ($Verbose){
push @m, "\n# Full list of MakeMaker attribute values:";
foreach my $key (sort keys %$self){
next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/;
my($v) = neatvalue($self->{$key});
$v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
$v =~ tr/\n/ /s;
push @m, "# $key => $v";
}
}
# added here as selfdocument is not overridable
push @m, <<'EOF';
# here so even if top_targets is overridden, these will still be defined
# gmake will silently still work if any are .PHONY-ed but nmake won't
EOF
push @m, join "\n", map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n",
# config is so manifypods won't puke if no subdirs
grep !$self->{SKIPHASH}{$_},
qw(static dynamic config);
join "\n", @m;
}
1;
__END__
=head1 NAME
ExtUtils::MakeMaker - Create a module Makefile
=head1 SYNOPSIS
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => "Foo::Bar",
VERSION_FROM => "lib/Foo/Bar.pm",
);
=head1 DESCRIPTION
This utility is designed to write a Makefile for an extension module
from a Makefile.PL. It is based on the Makefile.SH model provided by
Andy Dougherty and the perl5-porters.
It splits the task of generating the Makefile into several subroutines
that can be individually overridden. Each subroutine returns the text
it wishes to have written to the Makefile.
As there are various Make programs with incompatible syntax, which
use operating system shells, again with incompatible syntax, it is
important for users of this module to know which flavour of Make
a Makefile has been written for so they'll use the correct one and
won't have to face the possibly bewildering errors resulting from
using the wrong one.
On POSIX systems, that program will likely be GNU Make; on Microsoft
Windows, it will be either Microsoft NMake, DMake or GNU Make.
See the section on the L</"MAKE"> parameter for details.
ExtUtils::MakeMaker (EUMM) is object oriented. Each directory below the current
directory that contains a Makefile.PL is treated as a separate
object. This makes it possible to write an unlimited number of
Makefiles with a single invocation of WriteMakefile().
All inputs to WriteMakefile are Unicode characters, not just octets. EUMM
seeks to handle all of these correctly. It is currently still not possible
to portably use Unicode characters in module names, because this requires
Perl to handle Unicode filenames, which is not yet the case on Windows.
=head2 How To Write A Makefile.PL
See L<ExtUtils::MakeMaker::Tutorial>.
The long answer is the rest of the manpage :-)
=head2 Default Makefile Behaviour
The generated Makefile enables the user of the extension to invoke
perl Makefile.PL # optionally "perl Makefile.PL verbose"
make
make test # optionally set TEST_VERBOSE=1
make install # See below
The Makefile to be produced may be altered by adding arguments of the
form C<KEY=VALUE>. E.g.
perl Makefile.PL INSTALL_BASE=~
Other interesting targets in the generated Makefile are
make config # to check if the Makefile is up-to-date
make clean # delete local temp files (Makefile gets renamed)
make realclean # delete derived files (including ./blib)
make ci # check in all the files in the MANIFEST file
make dist # see below the Distribution Support section
=head2 make test
MakeMaker checks for the existence of a file named F<test.pl> in the
current directory, and if it exists it executes the script with the
proper set of perl C<-I> options.
MakeMaker also checks for any files matching glob("t/*.t"). It will
execute all matching files in alphabetical order via the
L<Test::Harness> module with the C<-I> switches set correctly.
You can also organize your tests within subdirectories in the F<t/> directory.
To do so, use the F<test> directive in your I<Makefile.PL>. For example, if you
had tests in:
t/foo
t/foo/bar
You could tell make to run tests in both of those directories with the
following directives:
test => {TESTS => 't/*/*.t t/*/*/*.t'}
test => {TESTS => 't/foo/*.t t/foo/bar/*.t'}
The first will run all test files in all first-level subdirectories and all
subdirectories they contain. The second will run tests in only the F<t/foo>
and F<t/foo/bar>.
If you'd like to see the raw output of your tests, set the
C<TEST_VERBOSE> variable to true.
make test TEST_VERBOSE=1
If you want to run particular test files, set the C<TEST_FILES> variable.
It is possible to use globbing with this mechanism.
make test TEST_FILES='t/foobar.t t/dagobah*.t'
Windows users who are using C<nmake> should note that due to a bug in C<nmake>,
when specifying C<TEST_FILES> you must use back-slashes instead of forward-slashes.
nmake test TEST_FILES='t\foobar.t t\dagobah*.t'
=head2 make testdb
A useful variation of the above is the target C<testdb>. It runs the
test under the Perl debugger (see L<perldebug>). If the file
F<test.pl> exists in the current directory, it is used for the test.
If you want to debug some other testfile, set the C<TEST_FILE> variable
thusly:
make testdb TEST_FILE=t/mytest.t
By default the debugger is called using C<-d> option to perl. If you
want to specify some other option, set the C<TESTDB_SW> variable:
make testdb TESTDB_SW=-Dx
=head2 make install
make alone puts all relevant files into directories that are named by
the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR and
INST_MAN3DIR. All these default to something below ./blib if you are
I<not> building below the perl source directory. If you I<are>
building below the perl source, INST_LIB and INST_ARCHLIB default to
../../lib, and INST_SCRIPT is not defined.
The I<install> target of the generated Makefile copies the files found
below each of the INST_* directories to their INSTALL*
counterparts. Which counterparts are chosen depends on the setting of
INSTALLDIRS according to the following table:
INSTALLDIRS set to
perl site vendor
PERLPREFIX SITEPREFIX VENDORPREFIX
INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
INST_LIB INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
INST_BIN INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
INST_SCRIPT INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
INST_MAN1DIR INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR
INST_MAN3DIR INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR
The INSTALL... macros in turn default to their %Config
($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts.
You can check the values of these variables on your system with
perl '-V:install.*'
And to check the sequence in which the library directories are
searched by perl, run
perl -le 'print join $/, @INC'
Sometimes older versions of the module you're installing live in other
directories in @INC. Because Perl loads the first version of a module it
finds, not the newest, you might accidentally get one of these older
versions even after installing a brand new version. To delete I<all other
versions of the module you're installing> (not simply older ones) set the
C<UNINST> variable.
make install UNINST=1
=head2 INSTALL_BASE
INSTALL_BASE can be passed into Makefile.PL to change where your
module will be installed. INSTALL_BASE is more like what everyone
else calls "prefix" than PREFIX is.
To have everything installed in your home directory, do the following.
# Unix users, INSTALL_BASE=~ works fine
perl Makefile.PL INSTALL_BASE=/path/to/your/home/dir
Like PREFIX, it sets several INSTALL* attributes at once. Unlike
PREFIX it is easy to predict where the module will end up. The
installation pattern looks like this:
INSTALLARCHLIB INSTALL_BASE/lib/perl5/$Config{archname}
INSTALLPRIVLIB INSTALL_BASE/lib/perl5
INSTALLBIN INSTALL_BASE/bin
INSTALLSCRIPT INSTALL_BASE/bin
INSTALLMAN1DIR INSTALL_BASE/man/man1
INSTALLMAN3DIR INSTALL_BASE/man/man3
INSTALL_BASE in MakeMaker and C<--install_base> in Module::Build (as
of 0.28) install to the same location. If you want MakeMaker and
Module::Build to install to the same location simply set INSTALL_BASE
and C<--install_base> to the same location.
INSTALL_BASE was added in 6.31.
=head2 PREFIX and LIB attribute
PREFIX and LIB can be used to set several INSTALL* attributes in one
go. Here's an example for installing into your home directory.
# Unix users, PREFIX=~ works fine
perl Makefile.PL PREFIX=/path/to/your/home/dir
This will install all files in the module under your home directory,
with man pages and libraries going into an appropriate place (usually
~/man and ~/lib). How the exact location is determined is complicated
and depends on how your Perl was configured. INSTALL_BASE works more
like what other build systems call "prefix" than PREFIX and we
recommend you use that instead.
Another way to specify many INSTALL directories with a single
parameter is LIB.
perl Makefile.PL LIB=~/lib
This will install the module's architecture-independent files into
~/lib, the architecture-dependent files into ~/lib/$archname.
Note, that in both cases the tilde expansion is done by MakeMaker, not
by perl by default, nor by make.
Conflicts between parameters LIB, PREFIX and the various INSTALL*
arguments are resolved so that:
=over 4
=item *
setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB,
INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX);
=item *
without LIB, setting PREFIX replaces the initial C<$Config{prefix}>
part of those INSTALL* arguments, even if the latter are explicitly
set (but are set to still start with C<$Config{prefix}>).
=back
If the user has superuser privileges, and is not working on AFS or
relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB,
INSTALLSCRIPT, etc. will be appropriate, and this incantation will be
the best:
perl Makefile.PL;
make;
make test
make install
make install by default writes some documentation of what has been
done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature
can be bypassed by calling make pure_install.
=head2 AFS users
will have to specify the installation directories as these most
probably have changed since perl itself has been installed. They will
have to do this by calling
perl Makefile.PL INSTALLSITELIB=/afs/here/today \
INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages
make
Be careful to repeat this procedure every time you recompile an
extension, unless you are sure the AFS installation directories are
still valid.
=head2 Static Linking of a new Perl Binary
An extension that is built with the above steps is ready to use on
systems supporting dynamic loading. On systems that do not support
dynamic loading, any newly created extension has to be linked together
with the available resources. MakeMaker supports the linking process
by creating appropriate targets in the Makefile whenever an extension
is built. You can invoke the corresponding section of the makefile with
make perl
That produces a new perl binary in the current directory with all
extensions linked in that can be found in INST_ARCHLIB, SITELIBEXP,
and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on
UNIX, this is called F<Makefile.aperl> (may be system dependent). If you
want to force the creation of a new perl, it is recommended that you
delete this F<Makefile.aperl>, so the directories are searched through
for linkable libraries again.
The binary can be installed into the directory where perl normally
resides on your machine with
make inst_perl
To produce a perl binary with a different name than C<perl>, either say
perl Makefile.PL MAP_TARGET=myperl
make myperl
make inst_perl
or say
perl Makefile.PL
make myperl MAP_TARGET=myperl
make inst_perl MAP_TARGET=myperl
In any case you will be prompted with the correct invocation of the
C<inst_perl> target that installs the new binary into INSTALLBIN.
make inst_perl by default writes some documentation of what has been
done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This
can be bypassed by calling make pure_inst_perl.
Warning: the inst_perl: target will most probably overwrite your
existing perl binary. Use with care!
Sometimes you might want to build a statically linked perl although
your system supports dynamic loading. In this case you may explicitly
set the linktype with the invocation of the Makefile.PL or make:
perl Makefile.PL LINKTYPE=static # recommended
or
make LINKTYPE=static # works on most systems
=head2 Determination of Perl Library and Installation Locations
MakeMaker needs to know, or to guess, where certain things are
located. Especially INST_LIB and INST_ARCHLIB (where to put the files
during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read
existing modules from), and PERL_INC (header files and C<libperl*.*>).
Extensions may be built either using the contents of the perl source
directory tree or from the installed perl library. The recommended way
is to build extensions after you have run 'make install' on perl
itself. You can do that in any directory on your hard disk that is not
below the perl source tree. The support for extensions below the ext
directory of the perl distribution is only good for the standard
extensions that come with perl.
If an extension is being built below the C<ext/> directory of the perl
source then MakeMaker will set PERL_SRC automatically (e.g.,
C<../..>). If PERL_SRC is defined and the extension is recognized as
a standard extension, then other variables default to the following:
PERL_INC = PERL_SRC
PERL_LIB = PERL_SRC/lib
PERL_ARCHLIB = PERL_SRC/lib
INST_LIB = PERL_LIB
INST_ARCHLIB = PERL_ARCHLIB
If an extension is being built away from the perl source then MakeMaker
will leave PERL_SRC undefined and default to using the installed copy
of the perl library. The other variables default to the following:
PERL_INC = $archlibexp/CORE
PERL_LIB = $privlibexp
PERL_ARCHLIB = $archlibexp
INST_LIB = ./blib/lib
INST_ARCHLIB = ./blib/arch
If perl has not yet been installed then PERL_SRC can be defined on the
command line as shown in the previous section.
=head2 Which architecture dependent directory?
If you don't want to keep the defaults for the INSTALL* macros,
MakeMaker helps you to minimize the typing needed: the usual
relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined
by Configure at perl compilation time. MakeMaker supports the user who
sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not,
then MakeMaker defaults the latter to be the same subdirectory of
INSTALLPRIVLIB as Configure decided for the counterparts in %Config,
otherwise it defaults to INSTALLPRIVLIB. The same relationship holds
for INSTALLSITELIB and INSTALLSITEARCH.
MakeMaker gives you much more freedom than needed to configure
internal variables and get different results. It is worth mentioning
that make(1) also lets you configure most of the variables that are
used in the Makefile. But in the majority of situations this will not
be necessary, and should only be done if the author of a package
recommends it (or you know what you're doing).
=head2 Using Attributes and Parameters
The following attributes may be specified as arguments to WriteMakefile()
or as NAME=VALUE pairs on the command line. Attributes that became
available with later versions of MakeMaker are indicated.
In order to maintain portability of attributes with older versions of
MakeMaker you may want to use L<App::EUMM::Upgrade> with your C<Makefile.PL>.
=over 2
=item ABSTRACT
One line description of the module. Will be included in PPD file.
=item ABSTRACT_FROM
Name of the file that contains the package description. MakeMaker looks
for a line in the POD matching /^($package\s-\s)(.*)/. This is typically
the first line in the "=head1 NAME" section. $2 becomes the abstract.
=item AUTHOR
Array of strings containing name (and email address) of package author(s).
Is used in CPAN Meta files (META.yml or META.json) and PPD
(Perl Package Description) files for PPM (Perl Package Manager).
=item BINARY_LOCATION
Used when creating PPD files for binary packages. It can be set to a
full or relative path or URL to the binary archive for a particular
architecture. For example:
perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz
builds a PPD package that references a binary of the C<Agent> package,
located in the C<x86> directory relative to the PPD itself.
=item BUILD_REQUIRES
Available in version 6.55_03 and above.
A hash of modules that are needed to build your module but not run it.
This will go into the C<build_requires> field of your F<META.yml> and the C<build> of the C<prereqs> field of your F<META.json>.
Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified.
The format is the same as PREREQ_PM.
=item C
Ref to array of *.c file names. Initialised from a directory scan
and the values portion of the XS attribute hash. This is not
currently used by MakeMaker but may be handy in Makefile.PLs.
=item CCFLAGS
String that will be included in the compiler call command line between
the arguments INC and OPTIMIZE.
=item CONFIG
Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from
config.sh. MakeMaker will add to CONFIG the following values anyway:
ar
cc
cccdlflags
ccdlflags
dlext
dlsrc
ld
lddlflags
ldflags
libc
lib_ext
obj_ext
ranlib
sitelibexp
sitearchexp
so
=item CONFIGURE
CODE reference. The subroutine should return a hash reference. The
hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to
be determined by some evaluation method.
=item CONFIGURE_REQUIRES
Available in version 6.52 and above.
A hash of modules that are required to run Makefile.PL itself, but not
to run your distribution.
This will go into the C<configure_requires> field of your F<META.yml> and the C<configure> of the C<prereqs> field of your F<META.json>.
Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified.
The format is the same as PREREQ_PM.
=item DEFINE
Something like C<"-DHAVE_UNISTD_H">
=item DESTDIR
This is the root directory into which the code will be installed. It
I<prepends itself to the normal prefix>. For example, if your code
would normally go into F</usr/local/lib/perl> you could set DESTDIR=~/tmp/
and installation would go into F<~/tmp/usr/local/lib/perl>.
This is primarily of use for people who repackage Perl modules.
NOTE: Due to the nature of make, it is important that you put the trailing
slash on your DESTDIR. F<~/tmp/> not F<~/tmp>.
=item DIR
Ref to array of subdirectories containing Makefile.PLs e.g. ['sdbm']
in ext/SDBM_File
=item DISTNAME
A safe filename for the package.
Defaults to NAME below but with :: replaced with -.
For example, Foo::Bar becomes Foo-Bar.
=item DISTVNAME
Your name for distributing the package with the version number
included. This is used by 'make dist' to name the resulting archive
file.
Defaults to DISTNAME-VERSION.
For example, version 1.04 of Foo::Bar becomes Foo-Bar-1.04.
On some OS's where . has special meaning VERSION_SYM may be used in
place of VERSION.
=item DLEXT
Specifies the extension of the module's loadable object. For example:
DLEXT => 'unusual_ext', # Default value is $Config{so}
NOTE: When using this option to alter the extension of a module's
loadable object, it is also necessary that the module's pm file
specifies the same change:
local $DynaLoader::dl_dlext = 'unusual_ext';
=item DL_FUNCS
Hashref of symbol names for routines to be made available as universal
symbols. Each key/value pair consists of the package name and an
array of routine names in that package. Used only under AIX, OS/2,
VMS and Win32 at present. The routine names supplied will be expanded
in the same way as XSUB names are expanded by the XS() macro.
Defaults to
{"$(NAME)" => ["boot_$(NAME)" ] }
e.g.
{"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )],
"NetconfigPtr" => [ 'DESTROY'] }
Please see the L<ExtUtils::Mksymlists> documentation for more information
about the DL_FUNCS, DL_VARS and FUNCLIST attributes.
=item DL_VARS
Array of symbol names for variables to be made available as universal symbols.
Used only under AIX, OS/2, VMS and Win32 at present. Defaults to [].
(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ])
=item EXCLUDE_EXT
Array of extension names to exclude when doing a static build. This
is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more
details. (e.g. [ qw( Socket POSIX ) ] )
This attribute may be most useful when specified as a string on the
command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe'
=item EXE_FILES
Ref to array of executable files. The files will be copied to the
INST_SCRIPT directory. Make realclean will delete them from there
again.
If your executables start with something like #!perl or
#!/usr/bin/perl MakeMaker will change this to the path of the perl
'Makefile.PL' was invoked with so the programs will be sure to run
properly even if perl is not in /usr/bin/perl.
=item FIRST_MAKEFILE
The name of the Makefile to be produced. This is used for the second
Makefile that will be produced for the MAP_TARGET.
Defaults to 'Makefile' or 'Descrip.MMS' on VMS.
(Note: we couldn't use MAKEFILE because dmake uses this for something
else).
=item FULLPERL
Perl binary able to run this extension, load XS modules, etc...
=item FULLPERLRUN
Like PERLRUN, except it uses FULLPERL.
=item FULLPERLRUNINST
Like PERLRUNINST, except it uses FULLPERL.
=item FUNCLIST
This provides an alternate means to specify function names to be
exported from the extension. Its value is a reference to an
array of function names to be exported by the extension. These
names are passed through unaltered to the linker options file.
=item H
Ref to array of *.h file names. Similar to C.
=item IMPORTS
This attribute is used to specify names to be imported into the
extension. Takes a hash ref.
It is only used on OS/2 and Win32.
=item INC
Include file dirs eg: C<"-I/usr/5include -I/path/to/inc">
=item INCLUDE_EXT
Array of extension names to be included when doing a static build.
MakeMaker will normally build with all of the installed extensions when
doing a static build, and that is usually the desired behavior. If
INCLUDE_EXT is present then MakeMaker will build only with those extensions
which are explicitly mentioned. (e.g. [ qw( Socket POSIX ) ])
It is not necessary to mention DynaLoader or the current extension when
filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then
only DynaLoader and the current extension will be included in the build.
This attribute may be most useful when specified as a string on the
command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek'
=item INSTALLARCHLIB
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment