Your IP : 216.73.216.227
Packlist.pm 0000644 00000020565 15272605367 0006701 0 ustar 00 package ExtUtils::Packlist;
use 5.00503;
use strict;
use Carp qw();
use Config;
use vars qw($VERSION $Relocations);
$VERSION = '1.46';
$VERSION = eval $VERSION;
# Used for generating filehandle globs. IO::File might not be available!
my $fhname = "FH1";
=begin _undocumented
=over
=item mkfh()
Make a filehandle. Same kind of idea as Symbol::gensym().
=cut
sub mkfh()
{
no strict;
local $^W;
my $fh = \*{$fhname++};
use strict;
return($fh);
}
=item __find_relocations
Works out what absolute paths in the configuration have been located at run
time relative to $^X, and generates a regexp that matches them
=back
=end _undocumented
=cut
sub __find_relocations
{
my %paths;
while (my ($raw_key, $raw_val) = each %Config) {
my $exp_key = $raw_key . "exp";
next unless exists $Config{$exp_key};
next unless $raw_val =~ m!\.\.\./!;
$paths{$Config{$exp_key}}++;
}
# Longest prefixes go first in the alternatives
my $alternations = join "|", map {quotemeta $_}
sort {length $b <=> length $a} keys %paths;
qr/^($alternations)/o;
}
sub new($$)
{
my ($class, $packfile) = @_;
$class = ref($class) || $class;
my %self;
tie(%self, $class, $packfile);
return(bless(\%self, $class));
}
sub TIEHASH
{
my ($class, $packfile) = @_;
my $self = { packfile => $packfile };
bless($self, $class);
$self->read($packfile) if (defined($packfile) && -f $packfile);
return($self);
}
sub STORE
{
$_[0]->{data}->{$_[1]} = $_[2];
}
sub FETCH
{
return($_[0]->{data}->{$_[1]});
}
sub FIRSTKEY
{
my $reset = scalar(keys(%{$_[0]->{data}}));
return(each(%{$_[0]->{data}}));
}
sub NEXTKEY
{
return(each(%{$_[0]->{data}}));
}
sub EXISTS
{
return(exists($_[0]->{data}->{$_[1]}));
}
sub DELETE
{
return(delete($_[0]->{data}->{$_[1]}));
}
sub CLEAR
{
%{$_[0]->{data}} = ();
}
sub DESTROY
{
}
sub read($;$)
{
my ($self, $packfile) = @_;
$self = tied(%$self) || $self;
if (defined($packfile)) { $self->{packfile} = $packfile; }
else { $packfile = $self->{packfile}; }
Carp::croak("No packlist filename specified") if (! defined($packfile));
my $fh = mkfh();
open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
$self->{data} = {};
my ($line);
while (defined($line = <$fh>))
{
chomp $line;
my ($key, $data) = $line;
if ($key =~ /^(.*?)( \w+=.*)$/)
{
$key = $1;
$data = { map { split('=', $_) } split(' ', $2)};
if ($Config{userelocatableinc} && $data->{relocate_as})
{
require File::Spec;
require Cwd;
my ($vol, $dir) = File::Spec->splitpath($packfile);
my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
$key = Cwd::realpath($newpath);
}
}
$key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths
$self->{data}->{$key} = $data;
}
close($fh);
}
sub write($;$)
{
my ($self, $packfile) = @_;
$self = tied(%$self) || $self;
if (defined($packfile)) { $self->{packfile} = $packfile; }
else { $packfile = $self->{packfile}; }
Carp::croak("No packlist filename specified") if (! defined($packfile));
my $fh = mkfh();
open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
foreach my $key (sort(keys(%{$self->{data}})))
{
my $data = $self->{data}->{$key};
if ($Config{userelocatableinc}) {
$Relocations ||= __find_relocations();
if ($packfile =~ $Relocations) {
# We are writing into a subdirectory of a run-time relocated
# path. Figure out if the this file is also within a subdir.
my $prefix = $1;
if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
{
# The relocated path is within the found prefix
my $packfile_prefix;
(undef, $packfile_prefix)
= File::Spec->splitpath($packfile);
my $relocate_as
= File::Spec->abs2rel($key, $packfile_prefix);
if (!ref $data) {
$data = {};
}
$data->{relocate_as} = $relocate_as;
}
}
}
print $fh ("$key");
if (ref($data))
{
foreach my $k (sort(keys(%$data)))
{
print $fh (" $k=$data->{$k}");
}
}
print $fh ("\n");
}
close($fh);
}
sub validate($;$)
{
my ($self, $remove) = @_;
$self = tied(%$self) || $self;
my @missing;
foreach my $key (sort(keys(%{$self->{data}})))
{
if (! -e $key)
{
push(@missing, $key);
delete($self->{data}{$key}) if ($remove);
}
}
return(@missing);
}
sub packlist_file($)
{
my ($self) = @_;
$self = tied(%$self) || $self;
return($self->{packfile});
}
1;
__END__
=head1 NAME
ExtUtils::Packlist - manage .packlist files
=head1 SYNOPSIS
use ExtUtils::Packlist;
my ($pl) = ExtUtils::Packlist->new('.packlist');
$pl->read('/an/old/.packlist');
my @missing_files = $pl->validate();
$pl->write('/a/new/.packlist');
$pl->{'/some/file/name'}++;
or
$pl->{'/some/other/file/name'} = { type => 'file',
from => '/some/file' };
=head1 DESCRIPTION
ExtUtils::Packlist provides a standard way to manage .packlist files.
Functions are provided to read and write .packlist files. The original
.packlist format is a simple list of absolute pathnames, one per line. In
addition, this package supports an extended format, where as well as a filename
each line may contain a list of attributes in the form of a space separated
list of key=value pairs. This is used by the installperl script to
differentiate between files and links, for example.
=head1 USAGE
The hash reference returned by the new() function can be used to examine and
modify the contents of the .packlist. Items may be added/deleted from the
.packlist by modifying the hash. If the value associated with a hash key is a
scalar, the entry written to the .packlist by any subsequent write() will be a
simple filename. If the value is a hash, the entry written will be the
filename followed by the key=value pairs from the hash. Reading back the
.packlist will recreate the original entries.
=head1 FUNCTIONS
=over 4
=item new()
This takes an optional parameter, the name of a .packlist. If the file exists,
it will be opened and the contents of the file will be read. The new() method
returns a reference to a hash. This hash holds an entry for each line in the
.packlist. In the case of old-style .packlists, the value associated with each
key is undef. In the case of new-style .packlists, the value associated with
each key is a hash containing the key=value pairs following the filename in the
.packlist.
=item read()
This takes an optional parameter, the name of the .packlist to be read. If
no file is specified, the .packlist specified to new() will be read. If the
.packlist does not exist, Carp::croak will be called.
=item write()
This takes an optional parameter, the name of the .packlist to be written. If
no file is specified, the .packlist specified to new() will be overwritten.
=item validate()
This checks that every file listed in the .packlist actually exists. If an
argument which evaluates to true is given, any missing files will be removed
from the internal hash. The return value is a list of the missing files, which
will be empty if they all exist.
=item packlist_file()
This returns the name of the associated .packlist file
=back
=head1 EXAMPLE
Here's C<modrm>, a little utility to cleanly remove an installed module.
#!/usr/local/bin/perl -w
use strict;
use IO::Dir;
use ExtUtils::Packlist;
use ExtUtils::Installed;
sub emptydir($) {
my ($dir) = @_;
my $dh = IO::Dir->new($dir) || return(0);
my @count = $dh->read();
$dh->close();
return(@count == 2 ? 1 : 0);
}
# Find all the installed packages
print("Finding all installed modules...\n");
my $installed = ExtUtils::Installed->new();
foreach my $module (grep(!/^Perl$/, $installed->modules())) {
my $version = $installed->version($module) || "???";
print("Found module $module Version $version\n");
print("Do you want to delete $module? [n] ");
my $r = <STDIN>; chomp($r);
if ($r && $r =~ /^y/i) {
# Remove all the files
foreach my $file (sort($installed->files($module))) {
print("rm $file\n");
unlink($file);
}
my $pf = $installed->packlist($module)->packlist_file();
print("rm $pf\n");
unlink($pf);
foreach my $dir (sort($installed->directory_tree($module))) {
if (emptydir($dir)) {
print("rmdir $dir\n");
rmdir($dir);
}
}
}
}
=head1 AUTHOR
Alan Burlison <Alan.Burlison@uk.sun.com>
=cut
Constant/Base.pm 0000644 00000101037 15272605367 0007564 0 ustar 00 package ExtUtils::Constant::Base;
use strict;
use vars qw($VERSION);
use Carp;
use Text::Wrap;
use ExtUtils::Constant::Utils qw(C_stringify perl_stringify);
$VERSION = '0.05';
use constant is_perl56 => ($] < 5.007 && $] > 5.005_50);
=head1 NAME
ExtUtils::Constant::Base - base class for ExtUtils::Constant objects
=head1 SYNOPSIS
require ExtUtils::Constant::Base;
@ISA = 'ExtUtils::Constant::Base';
=head1 DESCRIPTION
ExtUtils::Constant::Base provides a base implementation of methods to
generate C code to give fast constant value lookup by named string. Currently
it's mostly used ExtUtils::Constant::XS, which generates the lookup code
for the constant() subroutine found in many XS modules.
=head1 USAGE
ExtUtils::Constant::Base exports no subroutines. The following methods are
available
=over 4
=cut
sub valid_type {
# Default to assuming that you don't need different types of return data.
1;
}
sub default_type {
'';
}
=item header
A method returning a scalar containing definitions needed, typically for a
C header file.
=cut
sub header {
''
}
# This might actually be a return statement. Note that you are responsible
# for any space you might need before your value, as it lets to perform
# "tricks" such as "return KEY_" and have strings appended.
sub assignment_clause_for_type;
# In which case this might be an empty string
sub return_statement_for_type {undef};
sub return_statement_for_notdef;
sub return_statement_for_notfound;
# "#if 1" is true to a C pre-processor
sub macro_from_name {
1;
}
sub macro_from_item {
1;
}
sub macro_to_ifdef {
my ($self, $macro) = @_;
if (ref $macro) {
return $macro->[0];
}
if (defined $macro && $macro ne "" && $macro ne "1") {
return $macro ? "#ifdef $macro\n" : "#if 0\n";
}
return "";
}
sub macro_to_ifndef {
my ($self, $macro) = @_;
if (ref $macro) {
# Can't invert these stylishly, so "bodge it"
return "$macro->[0]#else\n";
}
if (defined $macro && $macro ne "" && $macro ne "1") {
return $macro ? "#ifndef $macro\n" : "#if 1\n";
}
croak "Can't generate an ifndef for unconditional code";
}
sub macro_to_endif {
my ($self, $macro) = @_;
if (ref $macro) {
return $macro->[1];
}
if (defined $macro && $macro ne "" && $macro ne "1") {
return "#endif\n";
}
return "";
}
sub name_param {
'name';
}
# This is possibly buggy, in that it's not mandatory (below, in the main
# C_constant parameters, but is expected to exist here, if it's needed)
# Buggy because if you're definitely pure 8 bit only, and will never be
# presented with your constants in utf8, the default form of C_constant can't
# be told not to do the utf8 version.
sub is_utf8_param {
'utf8';
}
sub memEQ {
"!memcmp";
}
=item memEQ_clause args_hashref
A method to return a suitable C C<if> statement to check whether I<name>
is equal to the C variable C<name>. If I<checked_at> is defined, then it
is used to avoid C<memEQ> for short names, or to generate a comment to
highlight the position of the character in the C<switch> statement.
If i<checked_at> is a reference to a scalar, then instead it gives
the characters pre-checked at the beginning, (and the number of chars by
which the C variable name has been advanced. These need to be chopped from
the front of I<name>).
=cut
sub memEQ_clause {
# if (memEQ(name, "thingy", 6)) {
# Which could actually be a character comparison or even ""
my ($self, $args) = @_;
my ($name, $checked_at, $indent) = @{$args}{qw(name checked_at indent)};
$indent = ' ' x ($indent || 4);
my $front_chop;
if (ref $checked_at) {
# regexp won't work on 5.6.1 without use utf8; in turn that won't work
# on 5.005_03.
substr ($name, 0, length $$checked_at,) = '';
$front_chop = C_stringify ($$checked_at);
undef $checked_at;
}
my $len = length $name;
if ($len < 2) {
return $indent . "{\n"
if (defined $checked_at and $checked_at == 0) or $len == 0;
# We didn't switch, drop through to the code for the 2 character string
$checked_at = 1;
}
my $name_param = $self->name_param;
if ($len < 3 and defined $checked_at) {
my $check;
if ($checked_at == 1) {
$check = 0;
} elsif ($checked_at == 0) {
$check = 1;
}
if (defined $check) {
my $char = C_stringify (substr $name, $check, 1);
# Placate 5.005 with a break in the string. I can't see a good way of
# getting it to not take [ as introducing an array lookup, even with
# ${name_param}[$check]
return $indent . "if ($name_param" . "[$check] == '$char') {\n";
}
}
if (($len == 2 and !defined $checked_at)
or ($len == 3 and defined ($checked_at) and $checked_at == 2)) {
my $char1 = C_stringify (substr $name, 0, 1);
my $char2 = C_stringify (substr $name, 1, 1);
return $indent .
"if ($name_param" . "[0] == '$char1' && $name_param" . "[1] == '$char2') {\n";
}
if (($len == 3 and defined ($checked_at) and $checked_at == 1)) {
my $char1 = C_stringify (substr $name, 0, 1);
my $char2 = C_stringify (substr $name, 2, 1);
return $indent .
"if ($name_param" . "[0] == '$char1' && $name_param" . "[2] == '$char2') {\n";
}
my $pointer = '^';
my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1;
if ($have_checked_last) {
# Checked at the last character, so no need to memEQ it.
$pointer = C_stringify (chop $name);
$len--;
}
$name = C_stringify ($name);
my $memEQ = $self->memEQ();
my $body = $indent . "if ($memEQ($name_param, \"$name\", $len)) {\n";
# Put a little ^ under the letter we checked at
# Screws up for non printable and non-7 bit stuff, but that's too hard to
# get right.
if (defined $checked_at) {
$body .= $indent . "/* " . (' ' x length $memEQ)
. (' ' x length $name_param)
. (' ' x $checked_at) . $pointer
. (' ' x ($len - $checked_at + length $len)) . " */\n";
} elsif (defined $front_chop) {
$body .= $indent . "/* $front_chop"
. (' ' x ($len + 1 + length $len)) . " */\n";
}
return $body;
}
=item dump_names arg_hashref, ITEM...
An internal function to generate the embedded perl code that will regenerate
the constant subroutines. I<default_type>, I<types> and I<ITEM>s are the
same as for C_constant. I<indent> is treated as number of spaces to indent
by. If C<declare_types> is true a C<$types> is always declared in the perl
code generated, if defined and false never declared, and if undefined C<$types>
is only declared if the values in I<types> as passed in cannot be inferred from
I<default_types> and the I<ITEM>s.
=cut
sub dump_names {
my ($self, $args, @items) = @_;
my ($default_type, $what, $indent, $declare_types)
= @{$args}{qw(default_type what indent declare_types)};
$indent = ' ' x ($indent || 0);
my $result;
my (@simple, @complex, %used_types);
foreach (@items) {
my $type;
if (ref $_) {
$type = $_->{type} || $default_type;
if ($_->{utf8}) {
# For simplicity always skip the bytes case, and reconstitute this entry
# from its utf8 twin.
next if $_->{utf8} eq 'no';
# Copy the hashref, as we don't want to mess with the caller's hashref.
$_ = {%$_};
unless (is_perl56) {
utf8::decode ($_->{name});
} else {
$_->{name} = pack 'U*', unpack 'U0U*', $_->{name};
}
delete $_->{utf8};
}
} else {
$_ = {name=>$_};
$type = $default_type;
}
$used_types{$type}++;
if ($type eq $default_type
# grr 5.6.1
and length $_->{name}
and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//)
and !defined ($_->{macro}) and !defined ($_->{value})
and !defined ($_->{default}) and !defined ($_->{pre})
and !defined ($_->{post}) and !defined ($_->{def_pre})
and !defined ($_->{def_post}) and !defined ($_->{weight})) {
# It's the default type, and the name consists only of A-Za-z0-9_
push @simple, $_->{name};
} else {
push @complex, $_;
}
}
if (!defined $declare_types) {
# Do they pass in any types we weren't already using?
foreach (keys %$what) {
next if $used_types{$_};
$declare_types++; # Found one in $what that wasn't used.
last; # And one is enough to terminate this loop
}
}
if ($declare_types) {
$result = $indent . 'my $types = {map {($_, 1)} qw('
. join (" ", sort keys %$what) . ")};\n";
}
local $Text::Wrap::huge = 'overflow';
local $Text::Wrap::columns = 80;
$result .= wrap ($indent . "my \@names = (qw(",
$indent . " ", join (" ", sort @simple) . ")");
if (@complex) {
foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
my $name = perl_stringify $item->{name};
my $line = ",\n$indent {name=>\"$name\"";
$line .= ", type=>\"$item->{type}\"" if defined $item->{type};
foreach my $thing (qw (macro value default pre post def_pre def_post)) {
my $value = $item->{$thing};
if (defined $value) {
if (ref $value) {
$line .= ", $thing=>[\""
. join ('", "', map {perl_stringify $_} @$value) . '"]';
} else {
$line .= ", $thing=>\"" . perl_stringify($value) . "\"";
}
}
}
$line .= "}";
# Ensure that the enclosing C comment doesn't end
# by turning */ into *" . "/
$line =~ s!\*\/!\*" . "/!gs;
# gcc -Wall doesn't like finding /* inside a comment
$line =~ s!\/\*!/" . "\*!gs;
$result .= $line;
}
}
$result .= ");\n";
$result;
}
=item assign arg_hashref, VALUE...
A method to return a suitable assignment clause. If I<type> is aggregate
(eg I<PVN> expects both pointer and length) then there should be multiple
I<VALUE>s for the components. I<pre> and I<post> if defined give snippets
of C code to proceed and follow the assignment. I<pre> will be at the start
of a block, so variables may be defined in it.
=cut
# Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
sub assign {
my $self = shift;
my $args = shift;
my ($indent, $type, $pre, $post, $item)
= @{$args}{qw(indent type pre post item)};
$post ||= '';
my $clause;
my $close;
if ($pre) {
chomp $pre;
$close = "$indent}\n";
$clause = $indent . "{\n";
$indent .= " ";
$clause .= "$indent$pre";
$clause .= ";" unless $pre =~ /;$/;
$clause .= "\n";
}
confess "undef \$type" unless defined $type;
confess "Can't generate code for type $type"
unless $self->valid_type($type);
$clause .= join '', map {"$indent$_\n"}
$self->assignment_clause_for_type({type=>$type,item=>$item}, @_);
chomp $post;
if (length $post) {
$clause .= "$post";
$clause .= ";" unless $post =~ /;$/;
$clause .= "\n";
}
my $return = $self->return_statement_for_type($type);
$clause .= "$indent$return\n" if defined $return;
$clause .= $close if $close;
return $clause;
}
=item return_clause arg_hashref, ITEM
A method to return a suitable C<#ifdef> clause. I<ITEM> is a hashref
(as passed to C<C_constant> and C<match_clause>. I<indent> is the number
of spaces to indent, defaulting to 6.
=cut
sub return_clause {
##ifdef thingy
# *iv_return = thingy;
# return PERL_constant_ISIV;
##else
# return PERL_constant_NOTDEF;
##endif
my ($self, $args, $item) = @_;
my $indent = $args->{indent};
my ($name, $value, $default, $pre, $post, $def_pre, $def_post, $type)
= @$item{qw (name value default pre post def_pre def_post type)};
$value = $name unless defined $value;
my $macro = $self->macro_from_item($item);
$indent = ' ' x ($indent || 6);
unless (defined $type) {
# use Data::Dumper; print STDERR Dumper ($item);
confess "undef \$type";
}
##ifdef thingy
my $clause = $self->macro_to_ifdef($macro);
# *iv_return = thingy;
# return PERL_constant_ISIV;
$clause
.= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post,
item=>$item}, ref $value ? @$value : $value);
if (defined $macro && $macro ne "" && $macro ne "1") {
##else
$clause .= "#else\n";
# return PERL_constant_NOTDEF;
if (!defined $default) {
my $notdef = $self->return_statement_for_notdef();
$clause .= "$indent$notdef\n" if defined $notdef;
} else {
my @default = ref $default ? @$default : $default;
$type = shift @default;
$clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre,
post=>$post, item=>$item}, @default);
}
}
##endif
$clause .= $self->macro_to_endif($macro);
return $clause;
}
sub match_clause {
# $offset defined if we have checked an offset.
my ($self, $args, $item) = @_;
my ($offset, $indent) = @{$args}{qw(checked_at indent)};
$indent = ' ' x ($indent || 4);
my $body = '';
my ($no, $yes, $either, $name, $inner_indent);
if (ref $item eq 'ARRAY') {
($yes, $no) = @$item;
$either = $yes || $no;
confess "$item is $either expecting hashref in [0] || [1]"
unless ref $either eq 'HASH';
$name = $either->{name};
} else {
confess "$item->{name} has utf8 flag '$item->{utf8}', should be false"
if $item->{utf8};
$name = $item->{name};
$inner_indent = $indent;
}
$body .= $self->memEQ_clause ({name => $name, checked_at => $offset,
indent => length $indent});
# If we've been presented with an arrayref for $item, then the user string
# contains in the range 128-255, and we need to check whether it was utf8
# (or not).
# In the worst case we have two named constants, where one's name happens
# encoded in UTF8 happens to be the same byte sequence as the second's
# encoded in (say) ISO-8859-1.
# In this case, $yes and $no both have item hashrefs.
if ($yes) {
$body .= $indent . " if (" . $self->is_utf8_param . ") {\n";
} elsif ($no) {
$body .= $indent . " if (!" . $self->is_utf8_param . ") {\n";
}
if ($either) {
$body .= $self->return_clause ({indent=>4 + length $indent}, $either);
if ($yes and $no) {
$body .= $indent . " } else {\n";
$body .= $self->return_clause ({indent=>4 + length $indent}, $no);
}
$body .= $indent . " }\n";
} else {
$body .= $self->return_clause ({indent=>2 + length $indent}, $item);
}
$body .= $indent . "}\n";
}
=item switch_clause arg_hashref, NAMELEN, ITEMHASH, ITEM...
An internal method to generate a suitable C<switch> clause, called by
C<C_constant> I<ITEM>s are in the hash ref format as given in the description
of C<C_constant>, and must all have the names of the same length, given by
I<NAMELEN>. I<ITEMHASH> is a reference to a hash, keyed by name, values being
the hashrefs in the I<ITEM> list. (No parameters are modified, and there can
be keys in the I<ITEMHASH> that are not in the list of I<ITEM>s without
causing problems - the hash is passed in to save generating it afresh for
each call).
=cut
sub switch_clause {
my ($self, $args, $namelen, $items, @items) = @_;
my ($indent, $comment) = @{$args}{qw(indent comment)};
$indent = ' ' x ($indent || 2);
local $Text::Wrap::huge = 'overflow';
local $Text::Wrap::columns = 80;
my @names = sort map {$_->{name}} @items;
my $leader = $indent . '/* ';
my $follower = ' ' x length $leader;
my $body = $indent . "/* Names all of length $namelen. */\n";
if (defined $comment) {
$body = wrap ($leader, $follower, $comment) . "\n";
$leader = $follower;
}
my @safe_names = @names;
foreach (@safe_names) {
confess sprintf "Name '$_' is length %d, not $namelen", length
unless length == $namelen;
# Argh. 5.6.1
# next unless tr/A-Za-z0-9_//c;
next if tr/A-Za-z0-9_// == length;
$_ = '"' . perl_stringify ($_) . '"';
# Ensure that the enclosing C comment doesn't end
# by turning */ into *" . "/
s!\*\/!\*"."/!gs;
# gcc -Wall doesn't like finding /* inside a comment
s!\/\*!/"."\*!gs;
}
$body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n";
# Figure out what to switch on.
# (RMS, Spread of jump table, Position, Hashref)
my @best = (1e38, ~0);
# Prefer the last character over the others. (As it lets us shorten the
# memEQ clause at no cost).
foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) {
my ($min, $max) = (~0, 0);
my %spread;
if (is_perl56) {
# Need proper Unicode preserving hash keys for bytes in range 128-255
# here too, for some reason. grr 5.6.1 yet again.
tie %spread, 'ExtUtils::Constant::Aaargh56Hash';
}
foreach (@names) {
my $char = substr $_, $i, 1;
my $ord = ord $char;
confess "char $ord is out of range" if $ord > 255;
$max = $ord if $ord > $max;
$min = $ord if $ord < $min;
push @{$spread{$char}}, $_;
# warn "$_ $char";
}
# I'm going to pick the character to split on that minimises the root
# mean square of the number of names in each case. Normally this should
# be the one with the most keys, but it may pick a 7 where the 8 has
# one long linear search. I'm not sure if RMS or just sum of squares is
# actually better.
# $max and $min are for the tie-breaker if the root mean squares match.
# Assuming that the compiler may be building a jump table for the
# switch() then try to minimise the size of that jump table.
# Finally use < not <= so that if it still ties the earliest part of
# the string wins. Because if that passes but the memEQ fails, it may
# only need the start of the string to bin the choice.
# I think. But I'm micro-optimising. :-)
# OK. Trump that. Now favour the last character of the string, before the
# rest.
my $ss;
$ss += @$_ * @$_ foreach values %spread;
my $rms = sqrt ($ss / keys %spread);
if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
@best = ($rms, $max - $min, $i, \%spread);
}
}
confess "Internal error. Failed to pick a switch point for @names"
unless defined $best[2];
# use Data::Dumper; print Dumper (@best);
my ($offset, $best) = @best[2,3];
$body .= $indent . "/* Offset $offset gives the best switch position. */\n";
my $do_front_chop = $offset == 0 && $namelen > 2;
if ($do_front_chop) {
$body .= $indent . "switch (*" . $self->name_param() . "++) {\n";
} else {
$body .= $indent . "switch (" . $self->name_param() . "[$offset]) {\n";
}
foreach my $char (sort keys %$best) {
confess sprintf "'$char' is %d bytes long, not 1", length $char
if length ($char) != 1;
confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255;
$body .= $indent . "case '" . C_stringify ($char) . "':\n";
foreach my $thisone (sort {
# Deal with the case of an item actually being an array ref to 1 or 2
# hashrefs. Don't assign to $a or $b, as they're aliases to the orignal
my $l = ref $a eq 'ARRAY' ? ($a->[0] || $->[1]) : $a;
my $r = ref $b eq 'ARRAY' ? ($b->[0] || $->[1]) : $b;
# Sort by weight first
($r->{weight} || 0) <=> ($l->{weight} || 0)
# Sort equal weights by name
or $l->{name} cmp $r->{name}}
# If this looks evil, maybe it is. $items is a
# hashref, and we're doing a hash slice on it
@{$items}{@{$best->{$char}}}) {
# warn "You are here";
if ($do_front_chop) {
$body .= $self->match_clause ({indent => 2 + length $indent,
checked_at => \$char}, $thisone);
} else {
$body .= $self->match_clause ({indent => 2 + length $indent,
checked_at => $offset}, $thisone);
}
}
$body .= $indent . " break;\n";
}
$body .= $indent . "}\n";
return $body;
}
sub C_constant_return_type {
"static int";
}
sub C_constant_prefix_param {
'';
}
sub C_constant_prefix_param_defintion {
'';
}
sub name_param_definition {
"const char *" . $_[0]->name_param;
}
sub namelen_param {
'len';
}
sub namelen_param_definition {
'size_t ' . $_[0]->namelen_param;
}
sub C_constant_other_params {
'';
}
sub C_constant_other_params_defintion {
'';
}
=item params WHAT
An "internal" method, subject to change, currently called to allow an
overriding class to cache information that will then be passed into all
the C<*param*> calls. (Yes, having to read the source to make sense of this is
considered a known bug). I<WHAT> is be a hashref of types the constant
function will return. In ExtUtils::Constant::XS this method is used to
returns a hashref keyed IV NV PV SV to show which combination of pointers will
be needed in the C argument list generated by
C_constant_other_params_definition and C_constant_other_params
=cut
sub params {
'';
}
=item dogfood arg_hashref, ITEM...
An internal function to generate the embedded perl code that will regenerate
the constant subroutines. Parameters are the same as for C_constant.
Currently the base class does nothing and returns an empty string.
=cut
sub dogfood {
''
}
=item normalise_items args, default_type, seen_types, seen_items, ITEM...
Convert the items to a normalised form. For 8 bit and Unicode values converts
the item to an array of 1 or 2 items, both 8 bit and UTF-8 encoded.
=cut
sub normalise_items
{
my $self = shift;
my $args = shift;
my $default_type = shift;
my $what = shift;
my $items = shift;
my @new_items;
foreach my $orig (@_) {
my ($name, $item);
if (ref $orig) {
# Make a copy which is a normalised version of the ref passed in.
$name = $orig->{name};
my ($type, $macro, $value) = @$orig{qw (type macro value)};
$type ||= $default_type;
$what->{$type} = 1;
$item = {name=>$name, type=>$type};
undef $macro if defined $macro and $macro eq $name;
$item->{macro} = $macro if defined $macro;
undef $value if defined $value and $value eq $name;
$item->{value} = $value if defined $value;
foreach my $key (qw(default pre post def_pre def_post weight
not_constant)) {
my $value = $orig->{$key};
$item->{$key} = $value if defined $value;
# warn "$key $value";
}
} else {
$name = $orig;
$item = {name=>$name, type=>$default_type};
$what->{$default_type} = 1;
}
warn +(ref ($self) || $self)
. "doesn't know how to handle values of type $_ used in macro $name"
unless $self->valid_type ($item->{type});
# tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c
# doesn't work. Upgrade to 5.8
# if ($name !~ tr/\0-\177//c || $] < 5.005_50) {
if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50
|| $args->{disable_utf8_duplication}) {
# No characters outside 7 bit ASCII.
if (exists $items->{$name}) {
die "Multiple definitions for macro $name";
}
$items->{$name} = $item;
} else {
# No characters outside 8 bit. This is hardest.
if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') {
confess "Unexpected ASCII definition for macro $name";
}
# Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/;
# if ($name !~ tr/\0-\377//c) {
if ($name =~ tr/\0-\377// == length $name) {
# if ($] < 5.007) {
# $name = pack "C*", unpack "U*", $name;
# }
$item->{utf8} = 'no';
$items->{$name}[1] = $item;
push @new_items, $item;
# Copy item, to create the utf8 variant.
$item = {%$item};
}
# Encode the name as utf8 bytes.
unless (is_perl56) {
utf8::encode($name);
} else {
# warn "Was >$name< " . length ${name};
$name = pack 'C*', unpack 'C*', $name . pack 'U*';
# warn "Now '${name}' " . length ${name};
}
if ($items->{$name}[0]) {
die "Multiple definitions for macro $name";
}
$item->{utf8} = 'yes';
$item->{name} = $name;
$items->{$name}[0] = $item;
# We have need for the utf8 flag.
$what->{''} = 1;
}
push @new_items, $item;
}
@new_items;
}
=item C_constant arg_hashref, ITEM...
A function that returns a B<list> of C subroutine definitions that return
the value and type of constants when passed the name by the XS wrapper.
I<ITEM...> gives a list of constant names. Each can either be a string,
which is taken as a C macro name, or a reference to a hash with the following
keys
=over 8
=item name
The name of the constant, as seen by the perl code.
=item type
The type of the constant (I<IV>, I<NV> etc)
=item value
A C expression for the value of the constant, or a list of C expressions if
the type is aggregate. This defaults to the I<name> if not given.
=item macro
The C pre-processor macro to use in the C<#ifdef>. This defaults to the
I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
array is passed then the first element is used in place of the C<#ifdef>
line, and the second element in place of the C<#endif>. This allows
pre-processor constructions such as
#if defined (foo)
#if !defined (bar)
...
#endif
#endif
to be used to determine if a constant is to be defined.
A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
test is omitted.
=item default
Default value to use (instead of C<croak>ing with "your vendor has not
defined...") to return if the macro isn't defined. Specify a reference to
an array with type followed by value(s).
=item pre
C code to use before the assignment of the value of the constant. This allows
you to use temporary variables to extract a value from part of a C<struct>
and return this as I<value>. This C code is places at the start of a block,
so you can declare variables in it.
=item post
C code to place between the assignment of value (to a temporary) and the
return from the function. This allows you to clear up anything in I<pre>.
Rarely needed.
=item def_pre
=item def_post
Equivalents of I<pre> and I<post> for the default value.
=item utf8
Generated internally. Is zero or undefined if name is 7 bit ASCII,
"no" if the name is 8 bit (and so should only match if SvUTF8() is false),
"yes" if the name is utf8 encoded.
The internals automatically clone any name with characters 128-255 but none
256+ (ie one that could be either in bytes or utf8) into a second entry
which is utf8 encoded.
=item weight
Optional sorting weight for names, to determine the order of
linear testing when multiple names fall in the same case of a switch clause.
Higher comes earlier, undefined defaults to zero.
=back
In the argument hashref, I<package> is the name of the package, and is only
used in comments inside the generated C code. I<subname> defaults to
C<constant> if undefined.
I<default_type> is the type returned by C<ITEM>s that don't specify their
type. It defaults to the value of C<default_type()>. I<types> should be given
either as a comma separated list of types that the C subroutine I<subname>
will generate or as a reference to a hash. I<default_type> will be added to
the list if not present, as will any types given in the list of I<ITEM>s. The
resultant list should be the same list of types that C<XS_constant> is
given. [Otherwise C<XS_constant> and C<C_constant> may differ in the number of
parameters to the constant function. I<indent> is currently unused and
ignored. In future it may be used to pass in information used to change the C
indentation style used.] The best way to maintain consistency is to pass in a
hash reference and let this function update it.
I<breakout> governs when child functions of I<subname> are generated. If there
are I<breakout> or more I<ITEM>s with the same length of name, then the code
to switch between them is placed into a function named I<subname>_I<len>, for
example C<constant_5> for names 5 characters long. The default I<breakout> is
3. A single C<ITEM> is always inlined.
=cut
# The parameter now BREAKOUT was previously documented as:
#
# I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
# this length, and that the constant name passed in by perl is checked and
# also of this length. It is used during recursion, and should be C<undef>
# unless the caller has checked all the lengths during code generation, and
# the generated subroutine is only to be called with a name of this length.
#
# As you can see it now performs this function during recursion by being a
# scalar reference.
sub C_constant {
my ($self, $args, @items) = @_;
my ($package, $subname, $default_type, $what, $indent, $breakout) =
@{$args}{qw(package subname default_type types indent breakout)};
$package ||= 'Foo';
$subname ||= 'constant';
# I'm not using this. But a hashref could be used for full formatting without
# breaking this API
# $indent ||= 0;
my ($namelen, $items);
if (ref $breakout) {
# We are called recursively. We trust @items to be normalised, $what to
# be a hashref, and pinch %$items from our parent to save recalculation.
($namelen, $items) = @$breakout;
} else {
$items = {};
if (is_perl56) {
# Need proper Unicode preserving hash keys.
require ExtUtils::Constant::Aaargh56Hash;
tie %$items, 'ExtUtils::Constant::Aaargh56Hash';
}
$breakout ||= 3;
$default_type ||= $self->default_type();
if (!ref $what) {
# Convert line of the form IV,UV,NV to hash
$what = {map {$_ => 1} split /,\s*/, ($what || '')};
# Figure out what types we're dealing with, and assign all unknowns to the
# default type
}
@items = $self->normalise_items ({}, $default_type, $what, $items, @items);
# use Data::Dumper; print Dumper @items;
}
my $params = $self->params ($what);
# Probably "static int"
my ($body, @subs);
$body = $self->C_constant_return_type($params) . "\n$subname ("
# Eg "pTHX_ "
. $self->C_constant_prefix_param_defintion($params)
# Probably "const char *name"
. $self->name_param_definition($params);
# Something like ", STRLEN len"
$body .= ", " . $self->namelen_param_definition($params)
unless defined $namelen;
$body .= $self->C_constant_other_params_defintion($params);
$body .= ") {\n";
if (defined $namelen) {
# We are a child subroutine. Print the simple description
my $comment = 'When generated this function returned values for the list'
. ' of names given here. However, subsequent manual editing may have'
. ' added or removed some.';
$body .= $self->switch_clause ({indent=>2, comment=>$comment},
$namelen, $items, @items);
} else {
# We are the top level.
$body .= " /* Initially switch on the length of the name. */\n";
$body .= $self->dogfood ({package => $package, subname => $subname,
default_type => $default_type, what => $what,
indent => $indent, breakout => $breakout},
@items);
$body .= ' switch ('.$self->namelen_param().") {\n";
# Need to group names of the same length
my @by_length;
foreach (@items) {
push @{$by_length[length $_->{name}]}, $_;
}
foreach my $i (0 .. $#by_length) {
next unless $by_length[$i]; # None of this length
$body .= " case $i:\n";
if (@{$by_length[$i]} == 1) {
my $only_thing = $by_length[$i]->[0];
if ($only_thing->{utf8}) {
if ($only_thing->{utf8} eq 'yes') {
# With utf8 on flag item is passed in element 0
$body .= $self->match_clause (undef, [$only_thing]);
} else {
# With utf8 off flag item is passed in element 1
$body .= $self->match_clause (undef, [undef, $only_thing]);
}
} else {
$body .= $self->match_clause (undef, $only_thing);
}
} elsif (@{$by_length[$i]} < $breakout) {
$body .= $self->switch_clause ({indent=>4},
$i, $items, @{$by_length[$i]});
} else {
# Only use the minimal set of parameters actually needed by the types
# of the names of this length.
my $what = {};
foreach (@{$by_length[$i]}) {
$what->{$_->{type}} = 1;
$what->{''} = 1 if $_->{utf8};
}
$params = $self->params ($what);
push @subs, $self->C_constant ({package=>$package,
subname=>"${subname}_$i",
default_type => $default_type,
types => $what, indent => $indent,
breakout => [$i, $items]},
@{$by_length[$i]});
$body .= " return ${subname}_$i ("
# Eg "aTHX_ "
. $self->C_constant_prefix_param($params)
# Probably "name"
. $self->name_param($params);
$body .= $self->C_constant_other_params($params);
$body .= ");\n";
}
$body .= " break;\n";
}
$body .= " }\n";
}
my $notfound = $self->return_statement_for_notfound();
$body .= " $notfound\n" if $notfound;
$body .= "}\n";
return (@subs, $body);
}
1;
__END__
=back
=head1 BUGS
Not everything is documented yet.
Probably others.
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
others
Constant/XS.pm 0000644 00000014321 15272605367 0007243 0 ustar 00 package ExtUtils::Constant::XS;
use strict;
use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56);
use Carp;
use ExtUtils::Constant::Utils 'perl_stringify';
require ExtUtils::Constant::Base;
@ISA = qw(ExtUtils::Constant::Base Exporter);
@EXPORT_OK = qw(%XS_Constant %XS_TypeSet);
$VERSION = '0.03';
$is_perl56 = ($] < 5.007 && $] > 5.005_50);
=head1 NAME
ExtUtils::Constant::XS - generate C code for XS modules' constants.
=head1 SYNOPSIS
require ExtUtils::Constant::XS;
=head1 DESCRIPTION
ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C
code for XS modules' constants.
=head1 BUGS
Nothing is documented.
Probably others.
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
others
=cut
# '' is used as a flag to indicate non-ascii macro names, and hence the need
# to pass in the utf8 on/off flag.
%XS_Constant = (
'' => '',
IV => 'PUSHi(iv)',
UV => 'PUSHu((UV)iv)',
NV => 'PUSHn(nv)',
PV => 'PUSHp(pv, strlen(pv))',
PVN => 'PUSHp(pv, iv)',
SV => 'PUSHs(sv)',
YES => 'PUSHs(&PL_sv_yes)',
NO => 'PUSHs(&PL_sv_no)',
UNDEF => '', # implicit undef
);
%XS_TypeSet = (
IV => '*iv_return = ',
UV => '*iv_return = (IV)',
NV => '*nv_return = ',
PV => '*pv_return = ',
PVN => ['*pv_return = ', '*iv_return = (IV)'],
SV => '*sv_return = ',
YES => undef,
NO => undef,
UNDEF => undef,
);
sub header {
my $start = 1;
my @lines;
push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
foreach (sort keys %XS_Constant) {
next if $_ eq '';
push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
}
push @lines, << 'EOT';
#ifndef NVTYPE
typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
#endif
#ifndef aTHX_
#define aTHX_ /* 5.6 or later define this for threading support. */
#endif
#ifndef pTHX_
#define pTHX_ /* 5.6 or later define this for threading support. */
#endif
EOT
return join '', @lines;
}
sub valid_type {
my ($self, $type) = @_;
return exists $XS_TypeSet{$type};
}
# This might actually be a return statement
sub assignment_clause_for_type {
my $self = shift;
my $args = shift;
my $type = $args->{type};
my $typeset = $XS_TypeSet{$type};
if (ref $typeset) {
die "Type $type is aggregate, but only single value given"
if @_ == 1;
return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset;
} elsif (defined $typeset) {
confess "Aggregate value given for type $type"
if @_ > 1;
return "$typeset$_[0];";
}
return ();
}
sub return_statement_for_type {
my ($self, $type) = @_;
# In the future may pass in an options hash
$type = $type->{type} if ref $type;
"return PERL_constant_IS$type;";
}
sub return_statement_for_notdef {
# my ($self) = @_;
"return PERL_constant_NOTDEF;";
}
sub return_statement_for_notfound {
# my ($self) = @_;
"return PERL_constant_NOTFOUND;";
}
sub default_type {
'IV';
}
sub macro_from_name {
my ($self, $item) = @_;
my $macro = $item->{name};
$macro = $item->{value} unless defined $macro;
$macro;
}
sub macro_from_item {
my ($self, $item) = @_;
my $macro = $item->{macro};
$macro = $self->macro_from_name($item) unless defined $macro;
$macro;
}
# Keep to the traditional perl source macro
sub memEQ {
"memEQ";
}
sub params {
my ($self, $what) = @_;
foreach (sort keys %$what) {
warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
}
my $params = {};
$params->{''} = 1 if $what->{''};
$params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
$params->{NV} = 1 if $what->{NV};
$params->{PV} = 1 if $what->{PV} || $what->{PVN};
$params->{SV} = 1 if $what->{SV};
return $params;
}
sub C_constant_prefix_param {
"aTHX_ ";
}
sub C_constant_prefix_param_defintion {
"pTHX_ ";
}
sub namelen_param_definition {
'STRLEN ' . $_[0] -> namelen_param;
}
sub C_constant_other_params_defintion {
my ($self, $params) = @_;
my $body = '';
$body .= ", int utf8" if $params->{''};
$body .= ", IV *iv_return" if $params->{IV};
$body .= ", NV *nv_return" if $params->{NV};
$body .= ", const char **pv_return" if $params->{PV};
$body .= ", SV **sv_return" if $params->{SV};
$body;
}
sub C_constant_other_params {
my ($self, $params) = @_;
my $body = '';
$body .= ", utf8" if $params->{''};
$body .= ", iv_return" if $params->{IV};
$body .= ", nv_return" if $params->{NV};
$body .= ", pv_return" if $params->{PV};
$body .= ", sv_return" if $params->{SV};
$body;
}
sub dogfood {
my ($self, $args, @items) = @_;
my ($package, $subname, $default_type, $what, $indent, $breakout) =
@{$args}{qw(package subname default_type what indent breakout)};
my $result = <<"EOT";
/* When generated this function returned values for the list of names given
in this section of perl code. Rather than manually editing these functions
to add or remove constants, which would result in this comment and section
of code becoming inaccurate, we recommend that you edit this section of
code, and use it to regenerate a new set of constant functions which you
then use to replace the originals.
Regenerate these constant functions by feeding this entire source file to
perl -x
#!$^X -w
use ExtUtils::Constant qw (constant_types C_constant XS_constant);
EOT
$result .= $self->dump_names ({default_type=>$default_type, what=>$what,
indent=>0, declare_types=>1},
@items);
$result .= <<'EOT';
print constant_types(), "\n"; # macro defs
EOT
$package = perl_stringify($package);
$result .=
"foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
# The form of the indent parameter isn't defined. (Yet)
if (defined $indent) {
require Data::Dumper;
$Data::Dumper::Terse=1;
$Data::Dumper::Terse=1; # Not used once. :-)
chomp ($indent = Data::Dumper::Dumper ($indent));
$result .= $indent;
} else {
$result .= 'undef';
}
$result .= ", $breakout" . ', @names) ) {
print $_, "\n"; # C constant subs
}
print "\n#### XS Section:\n";
print XS_constant ("' . $package . '", $types);
__END__
*/
';
$result;
}
1;
Constant/Utils.pm 0000644 00000006701 15272605367 0010014 0 ustar 00 package ExtUtils::Constant::Utils;
use strict;
use vars qw($VERSION @EXPORT_OK @ISA);
use Carp;
@ISA = 'Exporter';
@EXPORT_OK = qw(C_stringify perl_stringify);
$VERSION = '0.03';
use constant is_perl55 => ($] < 5.005_50);
use constant is_perl56 => ($] < 5.007 && $] > 5.005_50);
use constant is_sane_perl => $] > 5.007;
=head1 NAME
ExtUtils::Constant::Utils - helper functions for ExtUtils::Constant
=head1 SYNOPSIS
use ExtUtils::Constant::Utils qw (C_stringify);
$C_code = C_stringify $stuff;
=head1 DESCRIPTION
ExtUtils::Constant::Utils packages up utility subroutines used by
ExtUtils::Constant, ExtUtils::Constant::Base and derived classes. All its
functions are explicitly exportable.
=head1 USAGE
=over 4
=item C_stringify NAME
A function which returns a 7 bit ASCII correctly \ escaped version of the
string passed suitable for C's "" or ''. It will die if passed Unicode
characters.
=cut
# Hopefully make a happy C identifier.
sub C_stringify {
local $_ = shift;
return unless defined $_;
# grr 5.6.1
confess "Wide character in '$_' intended as a C identifier"
if tr/\0-\377// != length;
# grr 5.6.1 moreso because its regexps will break on data that happens to
# be utf8, which includes my 8 bit test cases.
$_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if is_perl56;
s/\\/\\\\/g;
s/([\"\'])/\\$1/g; # Grr. fix perl mode.
s/\n/\\n/g; # Ensure newlines don't end up in octal
s/\r/\\r/g;
s/\t/\\t/g;
s/\f/\\f/g;
s/\a/\\a/g;
unless (is_perl55) {
# This will elicit a warning on 5.005_03 about [: :] being reserved unless
# I cheat
my $cheat = '([[:^print:]])';
if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
s/$cheat/sprintf "\\%03o", ord $1/ge;
} else {
s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
}
s/$cheat/sprintf "\\%03o", ord $1/ge;
} else {
require POSIX;
s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
}
$_;
}
=item perl_stringify NAME
A function which returns a 7 bit ASCII correctly \ escaped version of the
string passed suitable for a perl "" string.
=cut
# Hopefully make a happy perl identifier.
sub perl_stringify {
local $_ = shift;
return unless defined $_;
s/\\/\\\\/g;
s/([\"\'])/\\$1/g; # Grr. fix perl mode.
s/\n/\\n/g; # Ensure newlines don't end up in octal
s/\r/\\r/g;
s/\t/\\t/g;
s/\f/\\f/g;
s/\a/\\a/g;
unless (is_perl55) {
# This will elicit a warning on 5.005_03 about [: :] being reserved unless
# I cheat
my $cheat = '([[:^print:]])';
if (is_sane_perl) {
if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
s/$cheat/sprintf "\\x{%X}", ord $1/ge;
} else {
s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
}
} else {
# Grr 5.6.1. And I don't think I can use utf8; to force the regexp
# because 5.005_03 will fail.
# This is grim, but I also can't split on //
my $copy;
foreach my $index (0 .. length ($_) - 1) {
my $char = substr ($_, $index, 1);
$copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char;
}
$_ = $copy;
}
s/$cheat/sprintf "\\%03o", ord $1/ge;
} else {
# Turns out "\x{}" notation only arrived with 5.6
s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge;
require POSIX;
s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
}
$_;
}
1;
__END__
=back
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
others
Constant/ProxySubs.pm 0000644 00000046412 15272605367 0010675 0 ustar 00 package ExtUtils::Constant::ProxySubs;
use strict;
use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv
%type_to_C_value %type_is_a_problem %type_num_args
%type_temporary);
use Carp;
require ExtUtils::Constant::XS;
use ExtUtils::Constant::Utils qw(C_stringify);
use ExtUtils::Constant::XS qw(%XS_TypeSet);
$VERSION = '0.08';
@ISA = 'ExtUtils::Constant::XS';
%type_to_struct =
(
IV => '{const char *name; I32 namelen; IV value;}',
NV => '{const char *name; I32 namelen; NV value;}',
UV => '{const char *name; I32 namelen; UV value;}',
PV => '{const char *name; I32 namelen; const char *value;}',
PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}',
YES => '{const char *name; I32 namelen;}',
NO => '{const char *name; I32 namelen;}',
UNDEF => '{const char *name; I32 namelen;}',
'' => '{const char *name; I32 namelen;} ',
);
%type_from_struct =
(
IV => sub { $_[0] . '->value' },
NV => sub { $_[0] . '->value' },
UV => sub { $_[0] . '->value' },
PV => sub { $_[0] . '->value' },
PVN => sub { $_[0] . '->value', $_[0] . '->len' },
YES => sub {},
NO => sub {},
UNDEF => sub {},
'' => sub {},
);
%type_to_sv =
(
IV => sub { "newSViv($_[0])" },
NV => sub { "newSVnv($_[0])" },
UV => sub { "newSVuv($_[0])" },
PV => sub { "newSVpv($_[0], 0)" },
PVN => sub { "newSVpvn($_[0], $_[1])" },
YES => sub { '&PL_sv_yes' },
NO => sub { '&PL_sv_no' },
UNDEF => sub { '&PL_sv_undef' },
'' => sub { '&PL_sv_yes' },
SV => sub {"SvREFCNT_inc($_[0])"},
);
%type_to_C_value =
(
YES => sub {},
NO => sub {},
UNDEF => sub {},
'' => sub {},
);
sub type_to_C_value {
my ($self, $type) = @_;
return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
}
# TODO - figure out if there is a clean way for the type_to_sv code to
# attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add
# SvREFCNT_inc
%type_is_a_problem =
(
# The documentation says *mortal SV*, but we now need a non-mortal copy.
SV => 1,
);
%type_temporary =
(
SV => ['SV *'],
PV => ['const char *'],
PVN => ['const char *', 'STRLEN'],
);
$type_temporary{$_} = [$_] foreach qw(IV UV NV);
while (my ($type, $value) = each %XS_TypeSet) {
$type_num_args{$type}
= defined $value ? ref $value ? scalar @$value : 1 : 0;
}
$type_num_args{''} = 0;
sub partition_names {
my ($self, $default_type, @items) = @_;
my (%found, @notfound, @trouble);
while (my $item = shift @items) {
my $default = delete $item->{default};
if ($default) {
# If we find a default value, convert it into a regular item and
# append it to the queue of items to process
my $default_item = {%$item};
$default_item->{invert_macro} = 1;
$default_item->{pre} = delete $item->{def_pre};
$default_item->{post} = delete $item->{def_post};
$default_item->{type} = shift @$default;
$default_item->{value} = $default;
push @items, $default_item;
} else {
# It can be "not found" unless it's the default (invert the macro)
# or the "macro" is an empty string (ie no macro)
push @notfound, $item unless $item->{invert_macro}
or !$self->macro_to_ifdef($self->macro_from_item($item));
}
if ($item->{pre} or $item->{post} or $item->{not_constant}
or $type_is_a_problem{$item->{type}}) {
push @trouble, $item;
} else {
push @{$found{$item->{type}}}, $item;
}
}
# use Data::Dumper; print Dumper \%found;
(\%found, \@notfound, \@trouble);
}
sub boottime_iterator {
my ($self, $type, $iterator, $hash, $subname, $push) = @_;
my $extractor = $type_from_struct{$type};
die "Can't find extractor code for type $type"
unless defined $extractor;
my $generator = $type_to_sv{$type};
die "Can't find generator code for type $type"
unless defined $generator;
my $athx = $self->C_constant_prefix_param();
if ($push) {
return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
while ($iterator->name) {
he = $subname($athx $hash, $iterator->name,
$iterator->namelen, %s);
av_push(push, newSVhek(HeKEY_hek(he)));
++$iterator;
}
EOBOOT
} else {
return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
while ($iterator->name) {
$subname($athx $hash, $iterator->name,
$iterator->namelen, %s);
++$iterator;
}
EOBOOT
}
}
sub name_len_value_macro {
my ($self, $item) = @_;
my $name = $item->{name};
my $value = $item->{value};
$value = $item->{name} unless defined $value;
my $namelen = length $name;
if ($name =~ tr/\0-\377// != $namelen) {
# the hash API signals UTF-8 by passing the length negated.
utf8::encode($name);
$namelen = -length $name;
}
$name = C_stringify($name);
my $macro = $self->macro_from_item($item);
($name, $namelen, $value, $macro);
}
sub WriteConstants {
my $self = shift;
my $ARGS = {@_};
my ($c_fh, $xs_fh, $c_subname, $default_type, $package)
= @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)};
my $xs_subname
= exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant';
my $options = $ARGS->{PROXYSUBS};
$options = {} unless ref $options;
my $push = $options->{push};
my $explosives = $options->{croak_on_read};
my $croak_on_error = $options->{croak_on_error};
my $autoload = $options->{autoload};
{
my $exclusive = 0;
++$exclusive if $explosives;
++$exclusive if $croak_on_error;
++$exclusive if $autoload;
# Until someone patches this (with test cases):
carp ("PROXYSUBS options 'autoload', 'croak_on_read' and 'croak_on_error' cannot be used together")
if $exclusive > 1;
}
# Strictly it requires Perl_caller_cx
carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later")
if $croak_on_error && $^V < v5.13.5;
# Strictly this is actually 5.8.9, but it's not well tested there
my $can_do_pcs = $] >= 5.009;
# Until someone patches this (with test cases)
carp ("PROXYSUBS option 'push' requires v5.10 or later")
if $push && !$can_do_pcs;
# Until someone patches this (with test cases)
carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together")
if $explosives && $push;
# If anyone is insane enough to suggest a package name containing %
my $package_sprintf_safe = $package;
$package_sprintf_safe =~ s/%/%%/g;
# All the types we see
my $what = {};
# A hash to lookup items with.
my $items = {};
my @items = $self->normalise_items ({disable_utf8_duplication => 1},
$default_type, $what, $items,
@{$ARGS->{NAMES}});
# Partition the values by type. Also include any defaults in here
# Everything that doesn't have a default needs alternative code for
# "I'm missing"
# And everything that has pre or post code ends up in a private block
my ($found, $notfound, $trouble)
= $self->partition_names($default_type, @items);
my $pthx = $self->C_constant_prefix_param_defintion();
my $athx = $self->C_constant_prefix_param();
my $symbol_table = C_stringify($package) . '::';
$push = C_stringify($package . '::' . $push) if $push;
my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : '';
print $c_fh $self->header();
if ($autoload || $croak_on_error) {
print $c_fh <<'EOC';
/* This allows slightly more efficient code on !USE_ITHREADS: */
#ifdef USE_ITHREADS
# define COP_FILE(c) CopFILE(c)
# define COP_FILE_F "s"
#else
# define COP_FILE(c) CopFILESV(c)
# define COP_FILE_F SVf
#endif
EOC
}
my $return_type = $push ? 'HE *' : 'void';
print $c_fh <<"EOADD";
static $return_type
${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
EOADD
if (!$can_do_pcs) {
print $c_fh <<'EO_NOPCS';
if (namelen == namelen) {
EO_NOPCS
} else {
print $c_fh <<"EO_PCS";
HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL,
0);
SV *sv;
if (!he) {
Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
name);
}
sv = HeVAL(he);
if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) {
/* Someone has been here before us - have to make a real sub. */
EO_PCS
}
# This piece of code is common to both
print $c_fh <<"EOADD";
newCONSTSUB(hash, ${cast_CONSTSUB}name, value);
EOADD
if ($can_do_pcs) {
print $c_fh <<'EO_PCS';
} else {
SvUPGRADE(sv, SVt_RV);
SvRV_set(sv, value);
SvROK_on(sv);
SvREADONLY_on(value);
}
EO_PCS
} else {
print $c_fh <<'EO_NOPCS';
}
EO_NOPCS
}
print $c_fh " return he;\n" if $push;
print $c_fh <<'EOADD';
}
EOADD
print $c_fh $explosives ? <<"EXPLODE" : "\n";
static int
Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
{
PERL_UNUSED_ARG(mg);
Perl_croak(aTHX_
"Your vendor has not defined $package_sprintf_safe macro %"SVf
" used", sv);
NORETURN_FUNCTION_END;
}
static MGVTBL not_defined_vtbl = {
Im_sorry_Dave, /* get - I'm afraid I can't do that */
Im_sorry_Dave, /* set */
0, /* len */
0, /* clear */
0, /* free */
0, /* copy */
0, /* dup */
};
EXPLODE
{
my $key = $symbol_table;
# Just seems tidier (and slightly more space efficient) not to have keys
# such as Fcntl::
$key =~ s/::$//;
my $key_len = length $key;
print $c_fh <<"MISSING";
#ifndef SYMBIAN
/* Store a hash of all symbols missing from the package. To avoid trampling on
the package namespace (uninvited) put each package's hash in our namespace.
To avoid creating lots of typeblogs and symbol tables for sub-packages, put
each package's hash into one hash in our namespace. */
static HV *
get_missing_hash(pTHX) {
HV *const parent
= get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI);
/* We could make a hash of hashes directly, but this would confuse anything
at Perl space that looks at us, and as we're visible in Perl space,
best to play nice. */
SV *const *const ref
= hv_fetch(parent, "$key", $key_len, TRUE);
HV *new_hv;
if (!ref)
return NULL;
if (SvROK(*ref))
return (HV*) SvRV(*ref);
new_hv = newHV();
SvUPGRADE(*ref, SVt_RV);
SvRV_set(*ref, (SV *)new_hv);
SvROK_on(*ref);
return new_hv;
}
#endif
MISSING
}
print $xs_fh <<"EOBOOT";
BOOT:
{
#ifdef dTHX
dTHX;
#endif
HV *symbol_table = get_hv("$symbol_table", GV_ADD);
EOBOOT
if ($push) {
print $xs_fh <<"EOC";
AV *push = get_av(\"$push\", GV_ADD);
HE *he;
EOC
}
my %iterator;
$found->{''}
= [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
foreach my $type (sort keys %$found) {
my $struct = $type_to_struct{$type};
my $type_to_value = $self->type_to_C_value($type);
my $number_of_args = $type_num_args{$type};
die "Can't find structure definition for type $type"
unless defined $struct;
my $lc_type = $type ? lc($type) : 'notfound';
my $struct_type = $lc_type . '_s';
my $array_name = 'values_for_' . $lc_type;
$iterator{$type} = 'value_for_' . $lc_type;
# Give the notfound struct file scope. The others are scoped within the
# BOOT block
my $struct_fh = $type ? $xs_fh : $c_fh;
print $c_fh "struct $struct_type $struct;\n";
print $struct_fh <<"EOBOOT";
static const struct $struct_type $array_name\[] =
{
EOBOOT
foreach my $item (@{$found->{$type}}) {
my ($name, $namelen, $value, $macro)
= $self->name_len_value_macro($item);
my $ifdef = $self->macro_to_ifdef($macro);
if (!$ifdef && $item->{invert_macro}) {
carp("Attempting to supply a default for '$name' which has no conditional macro");
next;
}
if ($item->{invert_macro}) {
print $struct_fh $self->macro_to_ifndef($macro);
print $struct_fh
" /* This is the default value: */\n" if $type;
} else {
print $struct_fh $ifdef;
}
print $struct_fh " { ", join (', ', "\"$name\"", $namelen,
&$type_to_value($value)),
" },\n",
$self->macro_to_endif($macro);
}
# Terminate the list with a NULL
print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
print $xs_fh <<"EOBOOT" if $type;
const struct $struct_type *$iterator{$type} = $array_name;
EOBOOT
}
delete $found->{''};
my $add_symbol_subname = $c_subname . '_add_symbol';
foreach my $type (sort keys %$found) {
print $xs_fh $self->boottime_iterator($type, $iterator{$type},
'symbol_table',
$add_symbol_subname, $push);
}
print $xs_fh <<"EOBOOT";
if (C_ARRAY_LENGTH(values_for_notfound) > 1) {
#ifndef SYMBIAN
HV *const ${c_subname}_missing = get_missing_hash(aTHX);
#endif
const struct notfound_s *value_for_notfound = values_for_notfound;
do {
EOBOOT
print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
SV *tripwire = newSV(0);
sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0);
SvPV_set(tripwire, (char *)value_for_notfound->name);
if(value_for_notfound->namelen >= 0) {
SvCUR_set(tripwire, value_for_notfound->namelen);
} else {
SvCUR_set(tripwire, -value_for_notfound->namelen);
SvUTF8_on(tripwire);
}
SvPOKp_on(tripwire);
SvREADONLY_on(tripwire);
assert(SvLEN(tripwire) == 0);
$add_symbol_subname($athx symbol_table, value_for_notfound->name,
value_for_notfound->namelen, tripwire);
EXPLODE
/* Need to add prototypes, else parsing will vary by platform. */
HE *he = (HE*) hv_common_key_len(symbol_table,
value_for_notfound->name,
value_for_notfound->namelen,
HV_FETCH_LVALUE, NULL, 0);
SV *sv;
#ifndef SYMBIAN
HEK *hek;
#endif
if (!he) {
Perl_croak($athx
"Couldn't add key '%s' to %%$package_sprintf_safe\::",
value_for_notfound->name);
}
sv = HeVAL(he);
if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) {
/* Nothing was here before, so mark a prototype of "" */
sv_setpvn(sv, "", 0);
} else if (SvPOK(sv) && SvCUR(sv) == 0) {
/* There is already a prototype of "" - do nothing */
} else {
/* Someone has been here before us - have to make a real
typeglob. */
/* It turns out to be incredibly hard to deal with all the
corner cases of sub foo (); and reporting errors correctly,
so lets cheat a bit. Start with a constant subroutine */
CV *cv = newCONSTSUB(symbol_table,
${cast_CONSTSUB}value_for_notfound->name,
&PL_sv_yes);
/* and then turn it into a non constant declaration only. */
SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
CvCONST_off(cv);
CvXSUB(cv) = NULL;
CvXSUBANY(cv).any_ptr = NULL;
}
#ifndef SYMBIAN
hek = HeKEY_hek(he);
if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek),
HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE,
&PL_sv_yes, HEK_HASH(hek)))
Perl_croak($athx "Couldn't add key '%s' to missing_hash",
value_for_notfound->name);
#endif
DONT
print $xs_fh " av_push(push, newSVhek(hek));\n"
if $push;
print $xs_fh <<"EOBOOT";
} while ((++value_for_notfound)->name);
}
EOBOOT
foreach my $item (@$trouble) {
my ($name, $namelen, $value, $macro)
= $self->name_len_value_macro($item);
my $ifdef = $self->macro_to_ifdef($macro);
my $type = $item->{type};
my $type_to_value = $self->type_to_C_value($type);
print $xs_fh $ifdef;
if ($item->{invert_macro}) {
print $xs_fh
" /* This is the default value: */\n" if $type;
print $xs_fh "#else\n";
}
my $generator = $type_to_sv{$type};
die "Can't find generator code for type $type"
unless defined $generator;
print $xs_fh " {\n";
# We need to use a temporary value because some really troublesome
# items use C pre processor directives in their values, and in turn
# these don't fit nicely in the macro-ised generator functions
my $counter = 0;
printf $xs_fh " %s temp%d;\n", $_, $counter++
foreach @{$type_temporary{$type}};
print $xs_fh " $item->{pre}\n" if $item->{pre};
# And because the code in pre might be both declarations and
# statements, we can't declare and assign to the temporaries in one.
$counter = 0;
printf $xs_fh " temp%d = %s;\n", $counter++, $_
foreach &$type_to_value($value);
my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
${c_subname}_add_symbol($athx symbol_table, "%s",
$namelen, %s);
EOBOOT
print $xs_fh " $item->{post}\n" if $item->{post};
print $xs_fh " }\n";
print $xs_fh $self->macro_to_endif($macro);
}
if ($] >= 5.009) {
print $xs_fh <<EOBOOT;
/* As we've been creating subroutines, we better invalidate any cached
methods */
mro_method_changed_in(symbol_table);
}
EOBOOT
} else {
print $xs_fh <<EOBOOT;
/* As we've been creating subroutines, we better invalidate any cached
methods */
++PL_sub_generation;
}
EOBOOT
}
return if !defined $xs_subname;
if ($croak_on_error || $autoload) {
print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA';
void
$xs_subname(sv)
INPUT:
SV * sv;
PREINIT:
const PERL_CONTEXT *cx = caller_cx(0, NULL);
/* cx is NULL if we've been called from the top level. PL_curcop isn't
ideal, but it's much cheaper than other ways of not going SEGV. */
const COP *cop = cx ? cx->blk_oldcop : PL_curcop;
EOC
void
AUTOLOAD()
PROTOTYPE: DISABLE
PREINIT:
SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv));
const COP *cop = PL_curcop;
EOA
print $xs_fh <<"EOC";
PPCODE:
#ifndef SYMBIAN
/* It's not obvious how to calculate this at C pre-processor time.
However, any compiler optimiser worth its salt should be able to
remove the dead code, and hopefully the now-obviously-unused static
function too. */
HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1)
? get_missing_hash(aTHX) : NULL;
if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
", used at %" COP_FILE_F " line %d\\n", sv,
COP_FILE(cop), CopLINE(cop));
} else
#endif
{
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro at %"
COP_FILE_F " line %d\\n", sv, COP_FILE(cop), CopLINE(cop));
}
croak_sv(sv_2mortal(sv));
EOC
} else {
print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
void
$xs_subname(sv)
INPUT:
SV * sv;
PPCODE:
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
", used", sv);
PUSHs(sv_2mortal(sv));
EXPLODE
void
$xs_subname(sv)
INPUT:
SV * sv;
PPCODE:
#ifndef SYMBIAN
/* It's not obvious how to calculate this at C pre-processor time.
However, any compiler optimiser worth its salt should be able to
remove the dead code, and hopefully the now-obviously-unused static
function too. */
HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1)
? get_missing_hash(aTHX) : NULL;
if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
", used", sv);
} else
#endif
{
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
sv);
}
PUSHs(sv_2mortal(sv));
DONT
}
}
1;
typemap 0000644 00000023015 15272605367 0006164 0 ustar 00 # basic C types
int T_IV
unsigned T_UV
unsigned int T_UV
long T_IV
unsigned long T_UV
short T_IV
unsigned short T_UV
char T_CHAR
unsigned char T_U_CHAR
char * T_PV
unsigned char * T_PV
const char * T_PV
caddr_t T_PV
wchar_t * T_PV
wchar_t T_IV
# bool_t is defined in <rpc/rpc.h>
bool_t T_IV
size_t T_UV
ssize_t T_IV
time_t T_NV
unsigned long * T_OPAQUEPTR
char ** T_PACKEDARRAY
void * T_PTR
Time_t * T_PV
SV * T_SV
# These are the backwards-compatibility AV*/HV* typemaps that
# do not decrement refcounts. Locally override with
# "AV* T_AVREF_REFCOUNT_FIXED", "HV* T_HVREF_REFCOUNT_FIXED",
# "CV* T_CVREF_REFCOUNT_FIXED", "SVREF T_SVREF_REFCOUNT_FIXED",
# to get the fixed versions.
SVREF T_SVREF
CV * T_CVREF
AV * T_AVREF
HV * T_HVREF
IV T_IV
UV T_UV
NV T_NV
I32 T_IV
I16 T_IV
I8 T_IV
STRLEN T_UV
U32 T_U_LONG
U16 T_U_SHORT
U8 T_UV
Result T_U_CHAR
Boolean T_BOOL
float T_FLOAT
double T_DOUBLE
SysRet T_SYSRET
SysRetLong T_SYSRET
FILE * T_STDIO
PerlIO * T_INOUT
FileHandle T_PTROBJ
InputStream T_IN
InOutStream T_INOUT
OutputStream T_OUT
bool T_BOOL
#############################################################################
INPUT
T_SV
$var = $arg
T_SVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv)){
$var = SvRV(xsub_tmp_sv);
}
else{
Perl_croak(aTHX_ \"%s: %s is not a reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_SVREF_REFCOUNT_FIXED
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv)){
$var = SvRV(xsub_tmp_sv);
}
else{
Perl_croak(aTHX_ \"%s: %s is not a reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_AVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
$var = (AV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_AVREF_REFCOUNT_FIXED
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
$var = (AV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_HVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
$var = (HV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak(aTHX_ \"%s: %s is not a HASH reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_HVREF_REFCOUNT_FIXED
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
$var = (HV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak(aTHX_ \"%s: %s is not a HASH reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_CVREF
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){
$var = (CV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak(aTHX_ \"%s: %s is not a CODE reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_CVREF_REFCOUNT_FIXED
STMT_START {
SV* const xsub_tmp_sv = $arg;
SvGETMAGIC(xsub_tmp_sv);
if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){
$var = (CV*)SvRV(xsub_tmp_sv);
}
else{
Perl_croak(aTHX_ \"%s: %s is not a CODE reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\");
}
} STMT_END
T_SYSRET
$var NOT IMPLEMENTED
T_UV
$var = ($type)SvUV($arg)
T_IV
$var = ($type)SvIV($arg)
T_INT
$var = (int)SvIV($arg)
T_ENUM
$var = ($type)SvIV($arg)
T_BOOL
$var = (bool)SvTRUE($arg)
T_U_INT
$var = (unsigned int)SvUV($arg)
T_SHORT
$var = (short)SvIV($arg)
T_U_SHORT
$var = (unsigned short)SvUV($arg)
T_LONG
$var = (long)SvIV($arg)
T_U_LONG
$var = (unsigned long)SvUV($arg)
T_CHAR
$var = (char)*SvPV_nolen($arg)
T_U_CHAR
$var = (unsigned char)SvUV($arg)
T_FLOAT
$var = (float)SvNV($arg)
T_NV
$var = ($type)SvNV($arg)
T_DOUBLE
$var = (double)SvNV($arg)
T_PV
$var = ($type)SvPV_nolen($arg)
T_PTR
$var = INT2PTR($type,SvIV($arg))
T_PTRREF
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type,tmp);
}
else
Perl_croak(aTHX_ \"%s: %s is not a reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\")
T_REF_IV_REF
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type *, tmp);
}
else
Perl_croak(aTHX_ \"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_REF_IV_PTR
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type, tmp);
}
else
Perl_croak(aTHX_ \"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_PTROBJ
if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type,tmp);
}
else
Perl_croak(aTHX_ \"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_PTRDESC
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
${type}_desc = (\U${type}_DESC\E*) tmp;
$var = ${type}_desc->ptr;
}
else
Perl_croak(aTHX_ \"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_REFREF
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type,tmp);
}
else
Perl_croak(aTHX_ \"%s: %s is not a reference\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\")
T_REFOBJ
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type,tmp);
}
else
Perl_croak(aTHX_ \"%s: %s is not of type %s\",
${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
\"$var\", \"$ntype\")
T_OPAQUE
$var = *($type *)SvPV_nolen($arg)
T_OPAQUEPTR
$var = ($type)SvPV_nolen($arg)
T_PACKED
$var = XS_unpack_$ntype($arg)
T_PACKEDARRAY
$var = XS_unpack_$ntype($arg)
T_ARRAY
U32 ix_$var = $argoff;
$var = $ntype(items -= $argoff);
while (items--) {
DO_ARRAY_ELEM;
ix_$var++;
}
/* this is the number of elements in the array */
ix_$var -= $argoff
T_STDIO
$var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
T_IN
$var = IoIFP(sv_2io($arg))
T_INOUT
$var = IoIFP(sv_2io($arg))
T_OUT
$var = IoOFP(sv_2io($arg))
#############################################################################
OUTPUT
T_SV
$arg = $var;
T_SVREF
$arg = newRV((SV*)$var);
T_SVREF_REFCOUNT_FIXED
$arg = newRV_noinc((SV*)$var);
T_AVREF
$arg = newRV((SV*)$var);
T_AVREF_REFCOUNT_FIXED
$arg = newRV_noinc((SV*)$var);
T_HVREF
$arg = newRV((SV*)$var);
T_HVREF_REFCOUNT_FIXED
$arg = newRV_noinc((SV*)$var);
T_CVREF
$arg = newRV((SV*)$var);
T_CVREF_REFCOUNT_FIXED
$arg = newRV_noinc((SV*)$var);
T_IV
sv_setiv($arg, (IV)$var);
T_UV
sv_setuv($arg, (UV)$var);
T_INT
sv_setiv($arg, (IV)$var);
T_SYSRET
if ($var != -1) {
if ($var == 0)
sv_setpvn($arg, "0 but true", 10);
else
sv_setiv($arg, (IV)$var);
}
T_ENUM
sv_setiv($arg, (IV)$var);
T_BOOL
$arg = boolSV($var);
T_U_INT
sv_setuv($arg, (UV)$var);
T_SHORT
sv_setiv($arg, (IV)$var);
T_U_SHORT
sv_setuv($arg, (UV)$var);
T_LONG
sv_setiv($arg, (IV)$var);
T_U_LONG
sv_setuv($arg, (UV)$var);
T_CHAR
sv_setpvn($arg, (char *)&$var, 1);
T_U_CHAR
sv_setuv($arg, (UV)$var);
T_FLOAT
sv_setnv($arg, (double)$var);
T_NV
sv_setnv($arg, (NV)$var);
T_DOUBLE
sv_setnv($arg, (double)$var);
T_PV
sv_setpv((SV*)$arg, $var);
T_PTR
sv_setiv($arg, PTR2IV($var));
T_PTRREF
sv_setref_pv($arg, Nullch, (void*)$var);
T_REF_IV_REF
sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var));
T_REF_IV_PTR
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
T_PTROBJ
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
T_PTRDESC
sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
T_REFREF
NOT_IMPLEMENTED
T_REFOBJ
NOT IMPLEMENTED
T_OPAQUE
sv_setpvn($arg, (char *)&$var, sizeof($var));
T_OPAQUEPTR
sv_setpvn($arg, (char *)$var, sizeof(*$var));
T_PACKED
XS_pack_$ntype($arg, $var);
T_PACKEDARRAY
XS_pack_$ntype($arg, $var, count_$ntype);
T_ARRAY
{
U32 ix_$var;
EXTEND(SP,size_$var);
for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
ST(ix_$var) = sv_newmortal();
DO_ARRAY_ELEM
}
}
T_STDIO
{
GV *gv = newGVgen("$Package");
PerlIO *fp = PerlIO_importFILE($var,0);
if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &PL_sv_undef;
}
T_IN
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &PL_sv_undef;
}
T_INOUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &PL_sv_undef;
}
T_OUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &PL_sv_undef;
}
CBuilder/Base.pm 0000644 00000024113 15272605367 0007463 0 ustar 00 package ExtUtils::CBuilder::Base;
use strict;
use File::Spec;
use File::Basename;
use Cwd ();
use Config;
use Text::ParseWords;
use IO::File;
use Data::Dumper;$Data::Dumper::Indent=1;
use IPC::Cmd qw(can_run);
use File::Temp qw(tempfile);
use vars qw($VERSION);
$VERSION = '0.280206';
# More details about C/C++ compilers:
# http://developers.sun.com/sunstudio/documentation/product/compiler.jsp
# http://gcc.gnu.org/
# http://publib.boulder.ibm.com/infocenter/comphelp/v101v121/index.jsp
# http://msdn.microsoft.com/en-us/vstudio/default.aspx
my %cc2cxx = (
# first line order is important to support wrappers like in pkgsrc
cc => [ 'c++', 'CC', 'aCC', 'cxx', ], # Sun Studio, HP ANSI C/C++ Compilers
gcc => [ 'g++' ], # GNU Compiler Collection
xlc => [ 'xlC' ], # IBM C/C++ Set, xlc without thread-safety
xlc_r => [ 'xlC_r' ], # IBM C/C++ Set, xlc with thread-safety
cl => [ 'cl' ], # Microsoft Visual Studio
);
sub new {
my $class = shift;
my $self = bless {@_}, $class;
$self->{properties}{perl} = $class->find_perl_interpreter
or warn "Warning: Can't locate your perl binary";
while (my ($k,$v) = each %Config) {
$self->{config}{$k} = $v unless exists $self->{config}{$k};
}
$self->{config}{cc} = $ENV{CC} if defined $ENV{CC};
$self->{config}{ccflags} = join(" ", $self->{config}{ccflags}, $ENV{CFLAGS})
if defined $ENV{CFLAGS};
$self->{config}{cxx} = $ENV{CXX} if defined $ENV{CXX};
$self->{config}{cxxflags} = $ENV{CXXFLAGS} if defined $ENV{CXXFLAGS};
$self->{config}{ld} = $ENV{LD} if defined $ENV{LD};
$self->{config}{ldflags} = join(" ", $self->{config}{ldflags}, $ENV{LDFLAGS})
if defined $ENV{LDFLAGS};
unless ( exists $self->{config}{cxx} ) {
my ($ccpath, $ccbase, $ccsfx ) = fileparse($self->{config}{cc}, qr/\.[^.]*/);
foreach my $cxx (@{$cc2cxx{$ccbase}}) {
if( can_run( File::Spec->catfile( $ccpath, $cxx, $ccsfx ) ) ) {
$self->{config}{cxx} = File::Spec->catfile( $ccpath, $cxx, $ccsfx );
last;
}
if( can_run( File::Spec->catfile( $cxx, $ccsfx ) ) ) {
$self->{config}{cxx} = File::Spec->catfile( $cxx, $ccsfx );
last;
}
if( can_run( $cxx ) ) {
$self->{config}{cxx} = $cxx;
last;
}
}
unless ( exists $self->{config}{cxx} ) {
$self->{config}{cxx} = $self->{config}{cc};
my $cflags = $self->{config}{ccflags};
$self->{config}{cxxflags} = '-x c++';
$self->{config}{cxxflags} .= " $cflags" if defined $cflags;
}
}
return $self;
}
sub find_perl_interpreter {
my $perl;
File::Spec->file_name_is_absolute($perl = $^X)
or -f ($perl = $Config::Config{perlpath})
or ($perl = $^X); # XXX how about using IPC::Cmd::can_run here?
return $perl;
}
sub add_to_cleanup {
my $self = shift;
foreach (@_) {
$self->{files_to_clean}{$_} = 1;
}
}
sub cleanup {
my $self = shift;
foreach my $file (keys %{$self->{files_to_clean}}) {
unlink $file;
}
}
sub get_config {
return %{ $_[0]->{config} };
}
sub object_file {
my ($self, $filename) = @_;
# File name, minus the suffix
(my $file_base = $filename) =~ s/\.[^.]+$//;
return "$file_base$self->{config}{obj_ext}";
}
sub arg_include_dirs {
my $self = shift;
return map {"-I$_"} @_;
}
sub arg_nolink { '-c' }
sub arg_object_file {
my ($self, $file) = @_;
return ('-o', $file);
}
sub arg_share_object_file {
my ($self, $file) = @_;
return ($self->split_like_shell($self->{config}{lddlflags}), '-o', $file);
}
sub arg_exec_file {
my ($self, $file) = @_;
return ('-o', $file);
}
sub arg_defines {
my ($self, %args) = @_;
return map "-D$_=$args{$_}", keys %args;
}
sub compile {
my ($self, %args) = @_;
die "Missing 'source' argument to compile()" unless defined $args{source};
my $cf = $self->{config}; # For convenience
my $object_file = $args{object_file}
? $args{object_file}
: $self->object_file($args{source});
my $include_dirs_ref =
(exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY")
? [ $args{include_dirs} ]
: $args{include_dirs};
my @include_dirs = $self->arg_include_dirs(
@{ $include_dirs_ref || [] },
$self->perl_inc(),
);
my @defines = $self->arg_defines( %{$args{defines} || {}} );
my @extra_compiler_flags =
$self->split_like_shell($args{extra_compiler_flags});
my @cccdlflags = $self->split_like_shell($cf->{cccdlflags});
my @ccflags = $self->split_like_shell($args{'C++'} ? $cf->{cxxflags} : $cf->{ccflags});
my @optimize = $self->split_like_shell($cf->{optimize});
my @flags = (
@include_dirs,
@defines,
@cccdlflags,
@extra_compiler_flags,
$self->arg_nolink,
@ccflags,
@optimize,
$self->arg_object_file($object_file),
);
my @cc = $self->split_like_shell($args{'C++'} ? $cf->{cxx} : $cf->{cc});
$self->do_system(@cc, @flags, $args{source})
or die "error building $object_file from '$args{source}'";
return $object_file;
}
sub have_compiler {
my ($self, $is_cplusplus) = @_;
my $have_compiler_flag = $is_cplusplus ? "have_cxx" : "have_cc";
my $suffix = $is_cplusplus ? ".cc" : ".c";
return $self->{$have_compiler_flag} if defined $self->{$have_compiler_flag};
my $result;
my $attempts = 3;
# tmpdir has issues for some people so fall back to current dir
# don't clobber existing files (rare, but possible)
my ( $FH, $tmpfile ) = tempfile( "compilet-XXXXX", SUFFIX => $suffix );
binmode $FH;
if ( $is_cplusplus ) {
print $FH "class Bogus { public: int boot_compilet() { return 1; } };\n";
}
else {
print $FH "int boot_compilet() { return 1; }\n";
}
close $FH;
my ($obj_file, @lib_files);
eval {
local $^W = 0;
local $self->{quiet} = 1;
$obj_file = $self->compile('C++' => $is_cplusplus, source => $tmpfile);
@lib_files = $self->link(objects => $obj_file, module_name => 'compilet');
};
$result = $@ ? 0 : 1;
foreach (grep defined, $tmpfile, $obj_file, @lib_files) {
1 while unlink;
}
return $self->{$have_compiler_flag} = $result;
}
sub have_cplusplus {
push @_, 1;
goto &have_compiler;
}
sub lib_file {
my ($self, $dl_file) = @_;
$dl_file =~ s/\.[^.]+$//;
$dl_file =~ tr/"//d;
return "$dl_file.$self->{config}{dlext}";
}
sub exe_file {
my ($self, $dl_file) = @_;
$dl_file =~ s/\.[^.]+$//;
$dl_file =~ tr/"//d;
return "$dl_file$self->{config}{_exe}";
}
sub need_prelink { 0 }
sub extra_link_args_after_prelink { return }
sub prelink {
my ($self, %args) = @_;
my ($dl_file_out, $mksymlists_args) = _prepare_mksymlists_args(\%args);
require ExtUtils::Mksymlists;
# dl. abbrev for dynamic library
ExtUtils::Mksymlists::Mksymlists( %{ $mksymlists_args } );
# Mksymlists will create one of these files
return grep -e, map "$dl_file_out.$_", qw(ext def opt);
}
sub _prepare_mksymlists_args {
my $args = shift;
($args->{dl_file} = $args->{dl_name}) =~ s/.*::// unless $args->{dl_file};
my %mksymlists_args = (
DL_VARS => $args->{dl_vars} || [],
DL_FUNCS => $args->{dl_funcs} || {},
FUNCLIST => $args->{dl_func_list} || [],
IMPORTS => $args->{dl_imports} || {},
NAME => $args->{dl_name}, # Name of the Perl module
DLBASE => $args->{dl_base}, # Basename of DLL file
FILE => $args->{dl_file}, # Dir + Basename of symlist file
VERSION => (defined $args->{dl_version} ? $args->{dl_version} : '0.0'),
);
return ($args->{dl_file}, \%mksymlists_args);
}
sub link {
my ($self, %args) = @_;
return $self->_do_link('lib_file', lddl => 1, %args);
}
sub link_executable {
my ($self, %args) = @_;
return $self->_do_link('exe_file', lddl => 0, %args);
}
sub _do_link {
my ($self, $type, %args) = @_;
my $cf = $self->{config}; # For convenience
my $objects = delete $args{objects};
$objects = [$objects] unless ref $objects;
my $out = $args{$type} || $self->$type($objects->[0]);
my @temp_files;
@temp_files =
$self->prelink(%args, dl_name => $args{module_name})
if $args{lddl} && $self->need_prelink;
my @linker_flags = (
$self->split_like_shell($args{extra_linker_flags}),
$self->extra_link_args_after_prelink(
%args, dl_name => $args{module_name}, prelink_res => \@temp_files
)
);
my @output = $args{lddl}
? $self->arg_share_object_file($out)
: $self->arg_exec_file($out);
my @shrp = $self->split_like_shell($cf->{shrpenv});
my @ld = $self->split_like_shell($cf->{ld});
$self->do_system(@shrp, @ld, @output, @$objects, @linker_flags)
or die "error building $out from @$objects";
return wantarray ? ($out, @temp_files) : $out;
}
sub do_system {
my ($self, @cmd) = @_;
print "@cmd\n" if !$self->{quiet};
return !system(@cmd);
}
sub split_like_shell {
my ($self, $string) = @_;
return () unless defined($string);
return @$string if UNIVERSAL::isa($string, 'ARRAY');
$string =~ s/^\s+|\s+$//g;
return () unless length($string);
# Text::ParseWords replaces all 'escaped' characters with themselves, which completely
# breaks paths under windows. As such, we forcibly replace backwards slashes with forward
# slashes on windows.
$string =~ s@\\@/@g if $^O eq 'MSWin32';
return Text::ParseWords::shellwords($string);
}
# if building perl, perl's main source directory
sub perl_src {
# N.B. makemaker actually searches regardless of PERL_CORE, but
# only squawks at not finding it if PERL_CORE is set
return unless $ENV{PERL_CORE};
my $Updir = File::Spec->updir;
my $dir = File::Spec->curdir;
# Try up to 5 levels upwards
for (0..10) {
if (
-f File::Spec->catfile($dir,"config_h.SH")
&&
-f File::Spec->catfile($dir,"perl.h")
&&
-f File::Spec->catfile($dir,"lib","Exporter.pm")
) {
return Cwd::realpath( $dir );
}
$dir = File::Spec->catdir($dir, $Updir);
}
warn "PERL_CORE is set but I can't find your perl source!\n";
return ''; # return empty string if $ENV{PERL_CORE} but can't find dir ???
}
# directory of perl's include files
sub perl_inc {
my $self = shift;
$self->perl_src() || File::Spec->catdir($self->{config}{archlibexp},"CORE");
}
sub DESTROY {
my $self = shift;
local($., $@, $!, $^E, $?);
$self->cleanup();
}
1;
# vim: ts=2 sw=2 et:
CBuilder/Platform/darwin.pm 0000644 00000001004 15272605367 0011653 0 ustar 00 package ExtUtils::CBuilder::Platform::darwin;
use strict;
use ExtUtils::CBuilder::Platform::Unix;
use vars qw($VERSION @ISA);
$VERSION = '0.280206';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub compile {
my $self = shift;
my $cf = $self->{config};
# -flat_namespace isn't a compile flag, it's a linker flag. But
# it's mistakenly in Config.pm as both. Make the correction here.
local $cf->{ccflags} = $cf->{ccflags};
$cf->{ccflags} =~ s/-flat_namespace//;
$self->SUPER::compile(@_);
}
1;
CBuilder/Platform/Windows.pm 0000644 00000021517 15272605367 0012034 0 ustar 00 package ExtUtils::CBuilder::Platform::Windows;
use strict;
use warnings;
use File::Basename;
use File::Spec;
use ExtUtils::CBuilder::Base;
use IO::File;
use vars qw($VERSION @ISA);
$VERSION = '0.280206';
@ISA = qw(ExtUtils::CBuilder::Base);
=begin comment
The compiler-specific packages implement functions for generating properly
formatted commandlines for the compiler being used. Each package
defines two primary functions 'format_linker_cmd()' &
'format_compiler_cmd()' that accepts a list of named arguments (a
hash) and returns a list of formatted options suitable for invoking the
compiler. By default, if the compiler supports scripting of its
operation then a script file is built containing the options while
those options are removed from the commandline, and a reference to the
script is pushed onto the commandline in their place. Scripting the
compiler in this way helps to avoid the problems associated with long
commandlines under some shells.
=end comment
=cut
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
my $cf = $self->{config};
# Inherit from an appropriate compiler driver class
my $driver = "ExtUtils::CBuilder::Platform::Windows::" . $self->_compiler_type;
eval "require $driver" or die "Could not load compiler driver: $@";
unshift @ISA, $driver;
return $self;
}
sub _compiler_type {
my $self = shift;
my $cc = $self->{config}{cc};
return ( $cc =~ /cl(\.exe)?$/ ? 'MSVC'
: $cc =~ /bcc32(\.exe)?$/ ? 'BCC'
: 'GCC');
}
sub split_like_shell {
# Since Windows will pass the whole command string (not an argument
# array) to the target program and make the program parse it itself,
# we don't actually need to do any processing here.
(my $self, local $_) = @_;
return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
return unless defined() && length();
return ($_);
}
sub do_system {
# See above
my $self = shift;
my $cmd = join(" ",
grep length,
map {$a=$_;$a=~s/\t/ /g;$a=~s/^\s+|\s+$//;$a}
grep defined, @_);
return $self->SUPER::do_system($cmd);
}
sub arg_defines {
my ($self, %args) = @_;
s/"/\\"/g foreach values %args;
return map qq{"-D$_=$args{$_}"}, keys %args;
}
sub compile {
my ($self, %args) = @_;
my $cf = $self->{config};
die "Missing 'source' argument to compile()" unless defined $args{source};
$args{include_dirs} = [ $args{include_dirs} ]
if exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY";
my ($basename, $srcdir) =
( File::Basename::fileparse($args{source}, '\.[^.]+$') )[0,1];
$srcdir ||= File::Spec->curdir();
my @defines = $self->arg_defines( %{ $args{defines} || {} } );
my %spec = (
srcdir => $srcdir,
builddir => $srcdir,
basename => $basename,
source => $args{source},
output => $args{object_file} || File::Spec->catfile($srcdir, $basename) . $cf->{obj_ext},
cc => $cf->{cc},
cflags => [
$self->split_like_shell($cf->{ccflags}),
$self->split_like_shell($cf->{cccdlflags}),
$self->split_like_shell($args{extra_compiler_flags}),
],
optimize => [ $self->split_like_shell($cf->{optimize}) ],
defines => \@defines,
includes => [ @{$args{include_dirs} || []} ],
perlinc => [
$self->perl_inc(),
$self->split_like_shell($cf->{incpath}),
],
use_scripts => 1, # XXX provide user option to change this???
);
$self->normalize_filespecs(
\$spec{source},
\$spec{output},
$spec{includes},
$spec{perlinc},
);
my @cmds = $self->format_compiler_cmd(%spec);
while ( my $cmd = shift @cmds ) {
$self->do_system( @$cmd )
or die "error building $cf->{dlext} file from '$args{source}'";
}
(my $out = $spec{output}) =~ tr/'"//d;
return $out;
}
sub need_prelink { 1 }
sub link {
my ($self, %args) = @_;
my $cf = $self->{config};
my @objects = ( ref $args{objects} eq 'ARRAY' ? @{$args{objects}} : $args{objects} );
my $to = join '', (File::Spec->splitpath($objects[0]))[0,1];
$to ||= File::Spec->curdir();
(my $file_base = $args{module_name}) =~ s/.*:://;
my $output = $args{lib_file} ||
File::Spec->catfile($to, "$file_base.$cf->{dlext}");
# if running in perl source tree, look for libs there, not installed
my $lddlflags = $cf->{lddlflags};
my $perl_src = $self->perl_src();
$lddlflags =~ s/\Q$cf->{archlibexp}\E[\\\/]CORE/$perl_src/ if $perl_src;
my %spec = (
srcdir => $to,
builddir => $to,
startup => [ ],
objects => \@objects,
libs => [ ],
output => $output,
ld => $cf->{ld},
libperl => $cf->{libperl},
perllibs => [ $self->split_like_shell($cf->{perllibs}) ],
libpath => [ $self->split_like_shell($cf->{libpth}) ],
lddlflags => [ $self->split_like_shell($lddlflags) ],
other_ldflags => [ $self->split_like_shell($args{extra_linker_flags} || '') ],
use_scripts => 1, # XXX provide user option to change this???
);
unless ( $spec{basename} ) {
($spec{basename} = $args{module_name}) =~ s/.*:://;
}
$spec{srcdir} = File::Spec->canonpath( $spec{srcdir} );
$spec{builddir} = File::Spec->canonpath( $spec{builddir} );
$spec{output} ||= File::Spec->catfile( $spec{builddir},
$spec{basename} . '.'.$cf->{dlext} );
$spec{manifest} ||= File::Spec->catfile( $spec{builddir},
$spec{basename} . '.'.$cf->{dlext}.'.manifest');
$spec{implib} ||= File::Spec->catfile( $spec{builddir},
$spec{basename} . $cf->{lib_ext} );
$spec{explib} ||= File::Spec->catfile( $spec{builddir},
$spec{basename} . '.exp' );
if ($cf->{cc} eq 'cl') {
$spec{dbg_file} ||= File::Spec->catfile( $spec{builddir},
$spec{basename} . '.pdb' );
}
elsif ($cf->{cc} eq 'bcc32') {
$spec{dbg_file} ||= File::Spec->catfile( $spec{builddir},
$spec{basename} . '.tds' );
}
$spec{def_file} ||= File::Spec->catfile( $spec{srcdir} ,
$spec{basename} . '.def' );
$spec{base_file} ||= File::Spec->catfile( $spec{srcdir} ,
$spec{basename} . '.base' );
$self->add_to_cleanup(
grep defined,
@{[ @spec{qw(manifest implib explib dbg_file def_file base_file map_file)} ]}
);
foreach my $opt ( qw(output manifest implib explib dbg_file def_file map_file base_file) ) {
$self->normalize_filespecs( \$spec{$opt} );
}
foreach my $opt ( qw(libpath startup objects) ) {
$self->normalize_filespecs( $spec{$opt} );
}
(my $def_base = $spec{def_file}) =~ tr/'"//d;
$def_base =~ s/\.def$//;
$self->prelink( dl_name => $args{module_name},
dl_file => $def_base,
dl_base => $spec{basename} );
my @cmds = $self->format_linker_cmd(%spec);
while ( my $cmd = shift @cmds ) {
$self->do_system( @$cmd );
}
$spec{output} =~ tr/'"//d;
return wantarray
? grep defined, @spec{qw[output manifest implib explib dbg_file def_file map_file base_file]}
: $spec{output};
}
# canonize & quote paths
sub normalize_filespecs {
my ($self, @specs) = @_;
foreach my $spec ( grep defined, @specs ) {
if ( ref $spec eq 'ARRAY') {
$self->normalize_filespecs( map {\$_} grep defined, @$spec )
} elsif ( ref $spec eq 'SCALAR' ) {
$$spec =~ tr/"//d if $$spec;
next unless $$spec;
$$spec = '"' . File::Spec->canonpath($$spec) . '"';
} elsif ( ref $spec eq '' ) {
$spec = '"' . File::Spec->canonpath($spec) . '"';
} else {
die "Don't know how to normalize " . (ref $spec || $spec) . "\n";
}
}
}
# directory of perl's include files
sub perl_inc {
my $self = shift;
my $perl_src = $self->perl_src();
if ($perl_src) {
File::Spec->catdir($perl_src, "lib", "CORE");
} else {
File::Spec->catdir($self->{config}{archlibexp},"CORE");
}
}
1;
__END__
=head1 NAME
ExtUtils::CBuilder::Platform::Windows - Builder class for Windows platforms
=head1 DESCRIPTION
This module implements the Windows-specific parts of ExtUtils::CBuilder.
Most of the Windows-specific stuff has to do with compiling and
linking C code. Currently we support the 3 compilers perl itself
supports: MSVC, BCC, and GCC.
This module inherits from C<ExtUtils::CBuilder::Base>, so any functionality
not implemented here will be implemented there. The interfaces are
defined by the L<ExtUtils::CBuilder> documentation.
=head1 AUTHOR
Ken Williams <ken@mathforum.org>
Most of the code here was written by Randy W. Sims <RandyS@ThePierianSpring.org>.
=head1 SEE ALSO
perl(1), ExtUtils::CBuilder(3), ExtUtils::MakeMaker(3)
=cut
CBuilder/Platform/cygwin.pm 0000644 00000001640 15272605367 0011675 0 ustar 00 package ExtUtils::CBuilder::Platform::cygwin;
use strict;
use File::Spec;
use ExtUtils::CBuilder::Platform::Unix;
use vars qw($VERSION @ISA);
$VERSION = '0.280206';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
# TODO: If a specific exe_file name is requested, if the exe created
# doesn't have that name, we might want to rename it. Apparently asking
# for an exe of "foo" might result in "foo.exe". Alternatively, we should
# make sure the return value is correctly "foo.exe".
# C.f http://rt.cpan.org/Public/Bug/Display.html?id=41003
sub link_executable {
my $self = shift;
return $self->SUPER::link_executable(@_);
}
sub link {
my ($self, %args) = @_;
my $lib = $self->{config}{useshrplib} ? 'libperl.dll.a' : 'libperl.a';
$args{extra_linker_flags} = [
File::Spec->catfile($self->perl_inc(), $lib),
$self->split_like_shell($args{extra_linker_flags})
];
return $self->SUPER::link(%args);
}
1;
CBuilder/Platform/Windows/GCC.pm 0000644 00000010222 15272605367 0012417 0 ustar 00 package ExtUtils::CBuilder::Platform::Windows::GCC;
use vars qw($VERSION);
$VERSION = '0.280206';
sub format_compiler_cmd {
my ($self, %spec) = @_;
foreach my $path ( @{ $spec{includes} || [] },
@{ $spec{perlinc} || [] } ) {
$path = '-I' . $path;
}
# split off any -arguments included in cc
my @cc = split / (?=-)/, $spec{cc};
return [ grep {defined && length} (
@cc, '-c' ,
@{$spec{includes}} ,
@{$spec{cflags}} ,
@{$spec{optimize}} ,
@{$spec{defines}} ,
@{$spec{perlinc}} ,
'-o', $spec{output} ,
$spec{source} ,
) ];
}
sub format_linker_cmd {
my ($self, %spec) = @_;
my $cf = $self->{config};
# The Config.pm variable 'libperl' is hardcoded to the full name
# of the perl import library (i.e. 'libperl56.a'). GCC will not
# find it unless the 'lib' prefix & the extension are stripped.
$spec{libperl} =~ s/^(?:lib)?([^.]+).*$/-l$1/;
unshift( @{$spec{other_ldflags}}, '-nostartfiles' )
if ( $spec{startup} && @{$spec{startup}} );
# From ExtUtils::MM_Win32:
#
## one thing for GCC/Mingw32:
## we try to overcome non-relocateable-DLL problems by generating
## a (hopefully unique) image-base from the dll's name
## -- BKS, 10-19-1999
File::Basename::basename( $spec{output} ) =~ /(....)(.{0,4})/;
$spec{image_base} = sprintf( "0x%x0000", unpack('n', $1 ^ $2) );
%spec = $self->write_linker_script(%spec)
if $spec{use_scripts};
foreach my $path ( @{$spec{libpath}} ) {
$path = "-L$path";
}
my @cmds; # Stores the series of commands needed to build the module.
my $DLLTOOL = $cf->{dlltool} || 'dlltool';
push @cmds, [
$DLLTOOL, '--def' , $spec{def_file},
'--output-exp' , $spec{explib}
];
# split off any -arguments included in ld
my @ld = split / (?=-)/, $spec{ld};
push @cmds, [ grep {defined && length} (
@ld ,
'-o', $spec{output} ,
"-Wl,--base-file,$spec{base_file}" ,
"-Wl,--image-base,$spec{image_base}" ,
@{$spec{lddlflags}} ,
@{$spec{libpath}} ,
@{$spec{startup}} ,
@{$spec{objects}} ,
@{$spec{other_ldflags}} ,
$spec{libperl} ,
@{$spec{perllibs}} ,
$spec{explib} ,
$spec{map_file} ? ('-Map', $spec{map_file}) : ''
) ];
push @cmds, [
$DLLTOOL, '--def' , $spec{def_file},
'--output-exp' , $spec{explib},
'--base-file' , $spec{base_file}
];
push @cmds, [ grep {defined && length} (
@ld ,
'-o', $spec{output} ,
"-Wl,--image-base,$spec{image_base}" ,
@{$spec{lddlflags}} ,
@{$spec{libpath}} ,
@{$spec{startup}} ,
@{$spec{objects}} ,
@{$spec{other_ldflags}} ,
$spec{libperl} ,
@{$spec{perllibs}} ,
$spec{explib} ,
$spec{map_file} ? ('-Map', $spec{map_file}) : ''
) ];
return @cmds;
}
sub write_linker_script {
my ($self, %spec) = @_;
my $script = File::Spec->catfile( $spec{srcdir},
$spec{basename} . '.lds' );
$self->add_to_cleanup($script);
print "Generating script '$script'\n" if !$self->{quiet};
my $SCRIPT = IO::File->new( ">$script" )
or die( "Could not create script '$script': $!" );
print $SCRIPT ( 'SEARCH_DIR(' . $_ . ")\n" )
for @{delete $spec{libpath} || []};
# gcc takes only one startup file, so the first object in startup is
# specified as the startup file and any others are shifted into the
# beginning of the list of objects.
if ( $spec{startup} && @{$spec{startup}} ) {
print $SCRIPT 'STARTUP(' . shift( @{$spec{startup}} ) . ")\n";
unshift @{$spec{objects}},
@{delete $spec{startup} || []};
}
print $SCRIPT 'INPUT(' . join( ',',
@{delete $spec{objects} || []}
) . ")\n";
print $SCRIPT 'INPUT(' . join( ' ',
(delete $spec{libperl} || ''),
@{delete $spec{perllibs} || []},
) . ")\n";
#it is important to keep the order 1.linker_script - 2.other_ldflags
unshift @{$spec{other_ldflags}}, '"' . $script . '"';
return %spec;
}
1;
CBuilder/Platform/Windows/BCC.pm 0000644 00000006637 15272605367 0012431 0 ustar 00 package ExtUtils::CBuilder::Platform::Windows::BCC;
use vars qw($VERSION);
$VERSION = '0.280206';
sub format_compiler_cmd {
my ($self, %spec) = @_;
foreach my $path ( @{ $spec{includes} || [] },
@{ $spec{perlinc} || [] } ) {
$path = '-I' . $path;
}
%spec = $self->write_compiler_script(%spec)
if $spec{use_scripts};
return [ grep {defined && length} (
$spec{cc}, '-c' ,
@{$spec{includes}} ,
@{$spec{cflags}} ,
@{$spec{optimize}} ,
@{$spec{defines}} ,
@{$spec{perlinc}} ,
"-o$spec{output}" ,
$spec{source} ,
) ];
}
sub write_compiler_script {
my ($self, %spec) = @_;
my $script = File::Spec->catfile( $spec{srcdir},
$spec{basename} . '.ccs' );
$self->add_to_cleanup($script);
print "Generating script '$script'\n" if !$self->{quiet};
my $SCRIPT = IO::File->new( ">$script" )
or die( "Could not create script '$script': $!" );
# XXX Borland "response files" seem to be unable to accept macro
# definitions containing quoted strings. Escaping strings with
# backslash doesn't work, and any level of quotes are stripped. The
# result is is a floating point number in the source file where a
# string is expected. So we leave the macros on the command line.
print $SCRIPT join( "\n",
map { ref $_ ? @{$_} : $_ }
grep defined,
delete(
@spec{ qw(includes cflags optimize perlinc) } )
);
push @{$spec{includes}}, '@"' . $script . '"';
return %spec;
}
sub format_linker_cmd {
my ($self, %spec) = @_;
foreach my $path ( @{$spec{libpath}} ) {
$path = "-L$path";
}
push( @{$spec{startup}}, 'c0d32.obj' )
unless ( $spec{starup} && @{$spec{startup}} );
%spec = $self->write_linker_script(%spec)
if $spec{use_scripts};
return [ grep {defined && length} (
$spec{ld} ,
@{$spec{lddlflags}} ,
@{$spec{libpath}} ,
@{$spec{other_ldflags}} ,
@{$spec{startup}} ,
@{$spec{objects}} , ',',
$spec{output} , ',',
$spec{map_file} , ',',
$spec{libperl} ,
@{$spec{perllibs}} , ',',
$spec{def_file}
) ];
}
sub write_linker_script {
my ($self, %spec) = @_;
# To work around Borlands "unique" commandline syntax,
# two scripts are used:
my $ld_script = File::Spec->catfile( $spec{srcdir},
$spec{basename} . '.lds' );
my $ld_libs = File::Spec->catfile( $spec{srcdir},
$spec{basename} . '.lbs' );
$self->add_to_cleanup($ld_script, $ld_libs);
print "Generating scripts '$ld_script' and '$ld_libs'.\n" if !$self->{quiet};
# Script 1: contains options & names of object files.
my $LD_SCRIPT = IO::File->new( ">$ld_script" )
or die( "Could not create linker script '$ld_script': $!" );
print $LD_SCRIPT join( " +\n",
map { @{$_} }
grep defined,
delete(
@spec{ qw(lddlflags libpath other_ldflags startup objects) } )
);
# Script 2: contains name of libs to link against.
my $LD_LIBS = IO::File->new( ">$ld_libs" )
or die( "Could not create linker script '$ld_libs': $!" );
print $LD_LIBS join( " +\n",
(delete $spec{libperl} || ''),
@{delete $spec{perllibs} || []},
);
push @{$spec{lddlflags}}, '@"' . $ld_script . '"';
push @{$spec{perllibs}}, '@"' . $ld_libs . '"';
return %spec;
}
1;
CBuilder/Platform/Windows/MSVC.pm 0000644 00000006202 15272605367 0012576 0 ustar 00 package ExtUtils::CBuilder::Platform::Windows::MSVC;
use vars qw($VERSION);
$VERSION = '0.280206';
sub arg_exec_file {
my ($self, $file) = @_;
return "/OUT:$file";
}
sub format_compiler_cmd {
my ($self, %spec) = @_;
foreach my $path ( @{ $spec{includes} || [] },
@{ $spec{perlinc} || [] } ) {
$path = '-I' . $path;
}
%spec = $self->write_compiler_script(%spec)
if $spec{use_scripts};
return [ grep {defined && length} (
$spec{cc},'-nologo','-c',
@{$spec{includes}} ,
@{$spec{cflags}} ,
@{$spec{optimize}} ,
@{$spec{defines}} ,
@{$spec{perlinc}} ,
"-Fo$spec{output}" ,
$spec{source} ,
) ];
}
sub write_compiler_script {
my ($self, %spec) = @_;
my $script = File::Spec->catfile( $spec{srcdir},
$spec{basename} . '.ccs' );
$self->add_to_cleanup($script);
print "Generating script '$script'\n" if !$self->{quiet};
my $SCRIPT = IO::File->new( ">$script" )
or die( "Could not create script '$script': $!" );
print $SCRIPT join( "\n",
map { ref $_ ? @{$_} : $_ }
grep defined,
delete(
@spec{ qw(includes cflags optimize defines perlinc) } )
);
push @{$spec{includes}}, '@"' . $script . '"';
return %spec;
}
sub format_linker_cmd {
my ($self, %spec) = @_;
my $cf = $self->{config};
foreach my $path ( @{$spec{libpath}} ) {
$path = "-libpath:$path";
}
my $output = $spec{output};
$spec{def_file} &&= '-def:' . $spec{def_file};
$spec{output} &&= '-out:' . $spec{output};
$spec{manifest} &&= '-manifest ' . $spec{manifest};
$spec{implib} &&= '-implib:' . $spec{implib};
$spec{map_file} &&= '-map:' . $spec{map_file};
%spec = $self->write_linker_script(%spec)
if $spec{use_scripts};
my @cmds; # Stores the series of commands needed to build the module.
push @cmds, [ grep {defined && length} (
$spec{ld} ,
@{$spec{lddlflags}} ,
@{$spec{libpath}} ,
@{$spec{other_ldflags}} ,
@{$spec{startup}} ,
@{$spec{objects}} ,
$spec{map_file} ,
$spec{libperl} ,
@{$spec{perllibs}} ,
$spec{def_file} ,
$spec{implib} ,
$spec{output} ,
) ];
# Embed the manifest file if it exists
push @cmds, [
'if', 'exist', $spec{manifest}, 'mt', '-nologo', $spec{manifest}, '-outputresource:' . "$output;2"
];
return @cmds;
}
sub write_linker_script {
my ($self, %spec) = @_;
my $script = File::Spec->catfile( $spec{srcdir},
$spec{basename} . '.lds' );
$self->add_to_cleanup($script);
print "Generating script '$script'\n" if !$self->{quiet};
my $SCRIPT = IO::File->new( ">$script" )
or die( "Could not create script '$script': $!" );
print $SCRIPT join( "\n",
map { ref $_ ? @{$_} : $_ }
grep defined,
delete(
@spec{ qw(lddlflags libpath other_ldflags
startup objects libperl perllibs
def_file implib map_file) } )
);
push @{$spec{lddlflags}}, '@"' . $script . '"';
return %spec;
}
1;
CBuilder/Platform/os2.pm 0000644 00000005263 15272605367 0011105 0 ustar 00 package ExtUtils::CBuilder::Platform::os2;
use strict;
use ExtUtils::CBuilder::Platform::Unix;
use vars qw($VERSION @ISA);
$VERSION = '0.280206';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub need_prelink { 1 }
sub prelink {
# Generate import libraries (XXXX currently near .DEF; should be near DLL!)
my $self = shift;
my %args = @_;
my @res = $self->SUPER::prelink(%args);
die "Unexpected number of DEF files" unless @res == 1;
die "Can't find DEF file in the output"
unless $res[0] =~ m,^(.*)\.def$,si;
my $libname = "$1$self->{config}{lib_ext}"; # Put .LIB file near .DEF file
$self->do_system('emximp', '-o', $libname, $res[0]) or die "emxexp: res=$?";
return (@res, $libname);
}
sub _do_link {
my $self = shift;
my ($how, %args) = @_;
if ($how eq 'lib_file'
and (defined $args{module_name} and length $args{module_name})) {
# DynaLoader::mod2fname() is a builtin func
my $lib = DynaLoader::mod2fname([split /::/, $args{module_name}]);
# Now know the basename, find directory parts via lib_file, or objects
my $objs = ( (ref $args{objects}) ? $args{objects} : [$args{objects}] );
my $near_obj = $self->lib_file(@$objs);
my $ref_file = ( defined $args{lib_file} ? $args{lib_file} : $near_obj );
my $lib_dir = ($ref_file =~ m,(.*)[/\\],s ? "$1/" : '' );
my $exp_dir = ($near_obj =~ m,(.*)[/\\],s ? "$1/" : '' );
$args{dl_file} = $1 if $near_obj =~ m,(.*)\.,s; # put ExportList near OBJ
$args{lib_file} = "$lib_dir$lib.$self->{config}{dlext}"; # DLL file
# XXX _do_link does not have place to put libraries?
push @$objs, $self->perl_inc() . "/libperl$self->{config}{lib_ext}";
$args{objects} = $objs;
}
# Some 'env' do exec(), thus return too early when run from ksh;
# To avoid 'env', remove (useless) shrpenv
local $self->{config}{shrpenv} = '';
return $self->SUPER::_do_link($how, %args);
}
sub extra_link_args_after_prelink {
# Add .DEF file to the link line
my ($self, %args) = @_;
my @DEF = grep /\.def$/i, @{$args{prelink_res}};
die "More than one .def files created by 'prelink' stage" if @DEF > 1;
# XXXX No "$how" argument here, so how to test for dynamic link?
die "No .def file created by 'prelink' stage"
unless @DEF or not @{$args{prelink_res}};
my @after_libs = ($OS2::is_aout ? ()
: $self->perl_inc() . "/libperl_override$self->{config}{lib_ext}");
# , "-L", "-lperl"
(@after_libs, @DEF);
}
sub link_executable {
# ldflags is not expecting .exe extension given on command line; remove -Zexe
my $self = shift;
local $self->{config}{ldflags} = $self->{config}{ldflags};
$self->{config}{ldflags} =~ s/(?<!\S)-Zexe(?!\S)//;
return $self->SUPER::link_executable(@_);
}
1;
CBuilder/Platform/Unix.pm 0000644 00000002030 15272605367 0011312 0 ustar 00 package ExtUtils::CBuilder::Platform::Unix;
use strict;
use ExtUtils::CBuilder::Base;
use vars qw($VERSION @ISA);
$VERSION = '0.280206';
@ISA = qw(ExtUtils::CBuilder::Base);
sub link_executable {
my $self = shift;
# On some platforms (which ones??) $Config{cc} seems to be a better
# bet for linking executables than $Config{ld}. Cygwin is a notable
# exception.
local $self->{config}{ld} =
$self->{config}{cc} . " " . $self->{config}{ldflags};
return $self->SUPER::link_executable(@_);
}
sub link {
my $self = shift;
my $cf = $self->{config};
# Some platforms (notably Mac OS X 10.3, but some others too) expect
# the syntax "FOO=BAR /bin/command arg arg" to work in %Config
# (notably $Config{ld}). It usually works in system(SCALAR), but we
# use system(LIST). We fix it up here with 'env'.
local $cf->{ld} = $cf->{ld};
if (ref $cf->{ld}) {
unshift @{$cf->{ld}}, 'env' if $cf->{ld}[0] =~ /^\s*\w+=/;
} else {
$cf->{ld} =~ s/^(\s*\w+=)/env $1/;
}
return $self->SUPER::link(@_);
}
1;
CBuilder/Platform/dec_osf.pm 0000644 00000000650 15272605367 0011777 0 ustar 00 package ExtUtils::CBuilder::Platform::dec_osf;
use strict;
use ExtUtils::CBuilder::Platform::Unix;
use File::Spec;
use vars qw($VERSION @ISA);
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
$VERSION = '0.280206';
sub link_executable {
my $self = shift;
# $Config{ld} is 'ld' but that won't work: use the cc instead.
local $self->{config}{ld} = $self->{config}{cc};
return $self->SUPER::link_executable(@_);
}
1;
CBuilder/Platform/VMS.pm 0000644 00000025374 15272605367 0011054 0 ustar 00 package ExtUtils::CBuilder::Platform::VMS;
use strict;
use ExtUtils::CBuilder::Base;
use vars qw($VERSION @ISA);
$VERSION = '0.280206';
@ISA = qw(ExtUtils::CBuilder::Base);
use File::Spec::Functions qw(catfile catdir);
use Config;
# We do prelink, but don't want the parent to redo it.
sub need_prelink { 0 }
sub arg_defines {
my ($self, %args) = @_;
s/"/""/g foreach values %args;
my @config_defines;
# VMS can only have one define qualifier; add the one from config, if any.
if ($self->{config}{ccflags} =~ s{/ def[^=]+ =+ \(? ([^\/\)]*) } {}ix) {
push @config_defines, $1;
}
return '' unless keys(%args) || @config_defines;
return ('/define=('
. join(',',
@config_defines,
map "\"$_" . ( length($args{$_}) ? "=$args{$_}" : '') . "\"",
keys %args)
. ')');
}
sub arg_include_dirs {
my ($self, @dirs) = @_;
# VMS can only have one include list, add the one from config.
if ($self->{config}{ccflags} =~ s{/inc[^=]+(?:=)+(?:\()?([^\/\)]*)} {}i) {
unshift @dirs, $1;
}
return unless @dirs;
return ('/include=(' . join(',', @dirs) . ')');
}
# We override the compile method because we consume the includes and defines
# parts of ccflags in the process of compiling but don't save those parts
# anywhere, so $self->{config}{ccflags} needs to be reset for each compile
# operation.
sub compile {
my ($self, %args) = @_;
$self->{config}{ccflags} = $Config{ccflags};
$self->{config}{ccflags} = $ENV{CFLAGS} if defined $ENV{CFLAGS};
return $self->SUPER::compile(%args);
}
sub _do_link {
my ($self, $type, %args) = @_;
my $objects = delete $args{objects};
$objects = [$objects] unless ref $objects;
if ($args{lddl}) {
# prelink will call Mksymlists, which creates the extension-specific
# linker options file and populates it with the boot symbol.
my @temp_files = $self->prelink(%args, dl_name => $args{module_name});
# We now add the rest of what we need to the linker options file. We
# should replicate the functionality of C<ExtUtils::MM_VMS::dlsyms>,
# but there is as yet no infrastructure for handling object libraries,
# so for now we depend on object files being listed individually on the
# command line, which should work for simple cases. We do bring in our
# own version of C<ExtUtils::Liblist::Kid::ext> so that any additional
# libraries (including PERLSHR) can be added to the options file.
my @optlibs = $self->_liblist_ext( $args{'libs'} );
my $optfile = 'sys$disk:[]' . $temp_files[0];
open my $opt_fh, '>>', $optfile
or die "_do_link: Unable to open $optfile: $!";
for my $lib (@optlibs) {print $opt_fh "$lib\n" if length $lib }
close $opt_fh;
$objects->[-1] .= ',';
push @$objects, $optfile . '/OPTIONS,';
# This one not needed for DEC C, but leave for completeness.
push @$objects, $self->perl_inc() . 'perlshr_attr.opt/OPTIONS';
}
return $self->SUPER::_do_link($type, %args, objects => $objects);
}
sub arg_nolink { return; }
sub arg_object_file {
my ($self, $file) = @_;
return "/obj=$file";
}
sub arg_exec_file {
my ($self, $file) = @_;
return ("/exe=$file");
}
sub arg_share_object_file {
my ($self, $file) = @_;
return ("$self->{config}{lddlflags}=$file");
}
sub lib_file {
my ($self, $dl_file) = @_;
$dl_file =~ s/\.[^.]+$//;
$dl_file =~ tr/"//d;
$dl_file = $dl_file .= '.' . $self->{config}{dlext};
# Need to create with the same name as DynaLoader will load with.
if (defined &DynaLoader::mod2fname) {
my ($dev,$dir,$file) = File::Spec->splitpath($dl_file);
$file = DynaLoader::mod2fname([$file]);
$dl_file = File::Spec->catpath($dev,$dir,$file);
}
return $dl_file;
}
# The following is reproduced almost verbatim from ExtUtils::Liblist::Kid::_vms_ext.
# We can't just call that because it's tied up with the MakeMaker object hierarchy.
sub _liblist_ext {
my($self, $potential_libs,$verbose,$give_libs) = @_;
$verbose ||= 0;
my(@crtls,$crtlstr);
@crtls = ( ($self->{'config'}{'ldflags'} =~ m-/Debug-i ? $self->{'config'}{'dbgprefix'} : '')
. 'PerlShr/Share' );
push(@crtls, grep { not /\(/ } split /\s+/, $self->{'config'}{'perllibs'});
push(@crtls, grep { not /\(/ } split /\s+/, $self->{'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 ensure 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($lib,$locspec,$type);
foreach $lib (@crtls) {
if (($locspec,$type) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i) {
if (lc $type eq '/share') { $locspec .= $self->{'config'}{'exe_ext'}; }
elsif (lc $type eq '/library') { $locspec .= $self->{'config'}{'lib_ext'}; }
else { $locspec .= $self->{'config'}{'obj_ext'}; }
$locspec = 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(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib);
my $cwd = cwd();
my($so,$lib_ext,$obj_ext) = @{$self->{'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');
if ($self->{'config'}{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; }
warn "Potential libraries are '$potential_libs'\n" if $verbose;
# First, sort out directories and library names in the input
foreach $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(' ',$self->{'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 $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 = catdir($cwd,$dir);
}
}
@dirs = grep { length($_) } @dirs;
unshift(@dirs,''); # Check each $lib without additions first
LIB: foreach $lib (@libs) {
if (exists $libmap{$lib}) {
next unless length $libmap{$lib};
$lib = $libmap{$lib};
}
my(@variants,$variant,$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 $variant (@variants) {
my($fullname, $name);
foreach $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 "Note (probably harmless): "
."Plain object file $fullname found in library list\n";
$type = 'OBJ';
}
else {
warn "Note (probably 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 "Note (probably 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) {
# This has to precede any other CRTLs, so just make it first
if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; }
else { 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 "Note (probably 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};
$lib = join(' ',@fndlibs);
$ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib;
}
1;
CBuilder/Platform/aix.pm 0000644 00000001155 15272605367 0011157 0 ustar 00 package ExtUtils::CBuilder::Platform::aix;
use strict;
use ExtUtils::CBuilder::Platform::Unix;
use File::Spec;
use vars qw($VERSION @ISA);
$VERSION = '0.280206';
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub need_prelink { 1 }
sub link {
my ($self, %args) = @_;
my $cf = $self->{config};
(my $baseext = $args{module_name}) =~ s/.*:://;
my $perl_inc = $self->perl_inc();
# Massage some very naughty bits in %Config
local $cf->{lddlflags} = $cf->{lddlflags};
for ($cf->{lddlflags}) {
s/\Q$(BASEEXT)\E/$baseext/;
s/\Q$(PERL_INC)\E/$perl_inc/;
}
return $self->SUPER::link(%args);
}
1;
Embed.pm 0000644 00000031501 15272605367 0006133 0 ustar 00 require 5.002;
package ExtUtils::Embed;
require Exporter;
require FileHandle;
use Config;
use Getopt::Std;
use File::Spec;
#Only when we need them
#require ExtUtils::MakeMaker;
#require ExtUtils::Liblist;
use vars qw(@ISA @EXPORT $VERSION
@Extensions $Verbose $lib_ext
$opt_o $opt_s
);
use strict;
# This is not a dual-life module, so no need for development version numbers
$VERSION = '1.30';
@ISA = qw(Exporter);
@EXPORT = qw(&xsinit &ldopts
&ccopts &ccflags &ccdlflags &perl_inc
&xsi_header &xsi_protos &xsi_body);
#let's have Miniperl borrow from us instead
#require ExtUtils::Miniperl;
#*canon = \&ExtUtils::Miniperl::canon;
$Verbose = 0;
$lib_ext = $Config{lib_ext} || '.a';
sub is_cmd { $0 eq '-e' }
sub my_return {
my $val = shift;
if(is_cmd) {
print $val;
}
else {
return $val;
}
}
sub xsinit {
my($file, $std, $mods) = @_;
my($fh,@mods,%seen);
$file ||= "perlxsi.c";
my $xsinit_proto = "pTHX";
if (@_) {
@mods = @$mods if $mods;
}
else {
getopts('o:s:');
$file = $opt_o if defined $opt_o;
$std = $opt_s if defined $opt_s;
@mods = @ARGV;
}
$std = 1 unless scalar @mods;
if ($file eq "STDOUT") {
$fh = \*STDOUT;
}
else {
$fh = new FileHandle "> $file";
}
push(@mods, static_ext()) if defined $std;
@mods = grep(!$seen{$_}++, @mods);
print $fh &xsi_header();
print $fh "EXTERN_C void xs_init ($xsinit_proto);\n\n";
print $fh &xsi_protos(@mods);
print $fh "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n";
print $fh &xsi_body(@mods);
print $fh "}\n";
}
sub xsi_header {
return <<EOF;
#include <EXTERN.h>
#include <perl.h>
EOF
}
sub xsi_protos {
my(@exts) = @_;
my(@retval,%seen);
my $boot_proto = "pTHX_ CV* cv";
foreach $_ (@exts){
my($pname) = canon('/', $_);
my($mname, $cname);
($mname = $pname) =~ s!/!::!g;
($cname = $pname) =~ s!/!__!g;
my($ccode) = "EXTERN_C void boot_${cname} ($boot_proto);\n";
next if $seen{$ccode}++;
push(@retval, $ccode);
}
return join '', @retval;
}
sub xsi_body {
my(@exts) = @_;
my($pname,@retval,%seen);
my($dl) = canon('/','DynaLoader');
push(@retval, "\tchar *file = __FILE__;\n");
push(@retval, "\tdXSUB_SYS;\n") if $] > 5.002;
push(@retval, "\n");
foreach $_ (@exts){
my($pname) = canon('/', $_);
my($mname, $cname, $ccode);
($mname = $pname) =~ s!/!::!g;
($cname = $pname) =~ s!/!__!g;
if ($pname eq $dl){
# Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
# boot_DynaLoader is called directly in DynaLoader.pm
$ccode = "\t/* DynaLoader is a special case */\n\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n";
push(@retval, $ccode) unless $seen{$ccode}++;
} else {
$ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n";
push(@retval, $ccode) unless $seen{$ccode}++;
}
}
return join '', @retval;
}
sub static_ext {
unless (scalar @Extensions) {
my $static_ext = $Config{static_ext};
$static_ext =~ s/^\s+//;
@Extensions = sort split /\s+/, $static_ext;
unshift @Extensions, qw(DynaLoader);
}
@Extensions;
}
sub _escape {
my $arg = shift;
return $$arg if $^O eq 'VMS'; # parens legal in qualifier lists
$$arg =~ s/([\(\)])/\\$1/g;
}
sub _ldflags {
my $ldflags = $Config{ldflags};
_escape(\$ldflags);
return $ldflags;
}
sub _ccflags {
my $ccflags = $Config{ccflags};
_escape(\$ccflags);
return $ccflags;
}
sub _ccdlflags {
my $ccdlflags = $Config{ccdlflags};
_escape(\$ccdlflags);
return $ccdlflags;
}
sub ldopts {
require ExtUtils::MakeMaker;
require ExtUtils::Liblist;
my($std,$mods,$link_args,$path) = @_;
my(@mods,@link_args,@argv);
my($dllib,$config_libs,@potential_libs,@path);
local($") = ' ' unless $" eq ' ';
if (scalar @_) {
@link_args = @$link_args if $link_args;
@mods = @$mods if $mods;
}
else {
@argv = @ARGV;
#hmm
while($_ = shift @argv) {
/^-std$/ && do { $std = 1; next; };
/^--$/ && do { @link_args = @argv; last; };
/^-I(.*)/ && do { $path = $1 || shift @argv; next; };
push(@mods, $_);
}
}
$std = 1 unless scalar @link_args;
my $sep = $Config{path_sep} || ':';
@path = $path ? split(/\Q$sep/, $path) : @INC;
push(@potential_libs, @link_args) if scalar @link_args;
# makemaker includes std libs on windows by default
if ($^O ne 'MSWin32' and defined($std)) {
push(@potential_libs, $Config{perllibs});
}
push(@mods, static_ext()) if $std;
my($mod,@ns,$root,$sub,$extra,$archive,@archives);
print STDERR "Searching (@path) for archives\n" if $Verbose;
foreach $mod (@mods) {
@ns = split(/::|\/|\\/, $mod);
$sub = $ns[-1];
$root = File::Spec->catdir(@ns);
print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose;
foreach (@path) {
next unless -e ($archive = File::Spec->catdir($_,"auto",$root,"$sub$lib_ext"));
push @archives, $archive;
if(-e ($extra = File::Spec->catdir($_,"auto",$root,"extralibs.ld"))) {
local(*FH);
if(open(FH, $extra)) {
my($libs) = <FH>; chomp $libs;
push @potential_libs, split /\s+/, $libs;
}
else {
warn "Couldn't open '$extra'";
}
}
last;
}
}
#print STDERR "\@potential_libs = @potential_libs\n";
my $libperl;
if ($^O eq 'MSWin32') {
$libperl = $Config{libperl};
}
elsif ($^O eq 'os390' && $Config{usedl}) {
# Nothing for OS/390 (z/OS) dynamic.
} else {
$libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0]
|| ($Config{libperl} =~ /^lib(\w+)(\Q$lib_ext\E|\.\Q$Config{dlext}\E)$/
? "-l$1" : '')
|| "-lperl";
}
my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE');
$lpath = qq["$lpath"] if $^O eq 'MSWin32';
my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) =
MM->ext(join ' ', "-L$lpath", $libperl, @potential_libs);
my $ld_or_bs = $bsloadlibs || $ldloadlibs;
print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose;
my $ccdlflags = _ccdlflags();
my $ldflags = _ldflags();
my $linkage = "$ccdlflags $ldflags @archives $ld_or_bs";
print STDERR "ldopts: '$linkage'\n" if $Verbose;
return $linkage if scalar @_;
my_return("$linkage\n");
}
sub ccflags {
my $ccflags = _ccflags();
my_return(" $ccflags ");
}
sub ccdlflags {
my $ccdlflags = _ccdlflags();
my_return(" $ccdlflags ");
}
sub perl_inc {
my $dir = File::Spec->catdir($Config{archlibexp}, 'CORE');
$dir = qq["$dir"] if $^O eq 'MSWin32';
my_return(" -I$dir ");
}
sub ccopts {
ccflags . perl_inc;
}
sub canon {
my($as, @ext) = @_;
foreach(@ext) {
# might be X::Y or lib/auto/X/Y/Y.a
next if s!::!/!g;
s:^(lib|ext)/(auto/)?::;
s:/\w+\.\w+$::;
}
map(s:/:$as:, @ext) if ($as ne '/');
@ext;
}
__END__
=head1 NAME
ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications
=head1 SYNOPSIS
perl -MExtUtils::Embed -e xsinit
perl -MExtUtils::Embed -e ccopts
perl -MExtUtils::Embed -e ldopts
=head1 DESCRIPTION
ExtUtils::Embed provides utility functions for embedding a Perl interpreter
and extensions in your C/C++ applications.
Typically, an application B<Makefile> will invoke ExtUtils::Embed
functions while building your application.
=head1 @EXPORT
ExtUtils::Embed exports the following functions:
xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(),
ccdlflags(), xsi_header(), xsi_protos(), xsi_body()
=head1 FUNCTIONS
=over 4
=item xsinit()
Generate C/C++ code for the XS initializer function.
When invoked as C<`perl -MExtUtils::Embed -e xsinit --`>
the following options are recognized:
B<-o> E<lt>output filenameE<gt> (Defaults to B<perlxsi.c>)
B<-o STDOUT> will print to STDOUT.
B<-std> (Write code for extensions that are linked with the current Perl.)
Any additional arguments are expected to be names of modules
to generate code for.
When invoked with parameters the following are accepted and optional:
C<xsinit($filename,$std,[@modules])>
Where,
B<$filename> is equivalent to the B<-o> option.
B<$std> is boolean, equivalent to the B<-std> option.
B<[@modules]> is an array ref, same as additional arguments mentioned above.
=item Examples
perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket
This will generate code with an B<xs_init> function that glues the perl B<Socket::bootstrap> function
to the C B<boot_Socket> function and writes it to a file named F<xsinit.c>.
Note that B<DynaLoader> is a special case where it must call B<boot_DynaLoader> directly.
perl -MExtUtils::Embed -e xsinit
This will generate code for linking with B<DynaLoader> and
each static extension found in B<$Config{static_ext}>.
The code is written to the default file name B<perlxsi.c>.
perl -MExtUtils::Embed -e xsinit -- -o xsinit.c -std DBI DBD::Oracle
Here, code is written for all the currently linked extensions along with code
for B<DBI> and B<DBD::Oracle>.
If you have a working B<DynaLoader> then there is rarely any need to statically link in any
other extensions.
=item ldopts()
Output arguments for linking the Perl library and extensions to your
application.
When invoked as C<`perl -MExtUtils::Embed -e ldopts --`>
the following options are recognized:
B<-std>
Output arguments for linking the Perl library and any extensions linked
with the current Perl.
B<-I> E<lt>path1:path2E<gt>
Search path for ModuleName.a archives.
Default path is B<@INC>.
Library archives are expected to be found as
B</some/path/auto/ModuleName/ModuleName.a>
For example, when looking for B<Socket.a> relative to a search path,
we should find B<auto/Socket/Socket.a>
When looking for B<DBD::Oracle> relative to a search path,
we should find B<auto/DBD/Oracle/Oracle.a>
Keep in mind that you can always supply B</my/own/path/ModuleName.a>
as an additional linker argument.
B<--> E<lt>list of linker argsE<gt>
Additional linker arguments to be considered.
Any additional arguments found before the B<--> token
are expected to be names of modules to generate code for.
When invoked with parameters the following are accepted and optional:
C<ldopts($std,[@modules],[@link_args],$path)>
Where:
B<$std> is boolean, equivalent to the B<-std> option.
B<[@modules]> is equivalent to additional arguments found before the B<--> token.
B<[@link_args]> is equivalent to arguments found after the B<--> token.
B<$path> is equivalent to the B<-I> option.
In addition, when ldopts is called with parameters, it will return the argument string
rather than print it to STDOUT.
=item Examples
perl -MExtUtils::Embed -e ldopts
This will print arguments for linking with B<libperl> and
extensions found in B<$Config{static_ext}>. This includes libraries
found in B<$Config{libs}> and the first ModuleName.a library
for each extension that is found by searching B<@INC> or the path
specified by the B<-I> option.
In addition, when ModuleName.a is found, additional linker arguments
are picked up from the B<extralibs.ld> file in the same directory.
perl -MExtUtils::Embed -e ldopts -- -std Socket
This will do the same as the above example, along with printing additional arguments for linking with the B<Socket> extension.
perl -MExtUtils::Embed -e ldopts -- -std Msql -- -L/usr/msql/lib -lmsql
Any arguments after the second '--' token are additional linker
arguments that will be examined for potential conflict. If there is no
conflict, the additional arguments will be part of the output.
=item perl_inc()
For including perl header files this function simply prints:
-I$Config{archlibexp}/CORE
So, rather than having to say:
perl -MConfig -e 'print "-I$Config{archlibexp}/CORE"'
Just say:
perl -MExtUtils::Embed -e perl_inc
=item ccflags(), ccdlflags()
These functions simply print $Config{ccflags} and $Config{ccdlflags}
=item ccopts()
This function combines perl_inc(), ccflags() and ccdlflags() into one.
=item xsi_header()
This function simply returns a string defining the same B<EXTERN_C> macro as
B<perlmain.c> along with #including B<perl.h> and B<EXTERN.h>.
=item xsi_protos(@modules)
This function returns a string of B<boot_$ModuleName> prototypes for each @modules.
=item xsi_body(@modules)
This function returns a string of calls to B<newXS()> that glue the module B<bootstrap>
function to B<boot_ModuleName> for each @modules.
B<xsinit()> uses the xsi_* functions to generate most of its code.
=back
=head1 EXAMPLES
For examples on how to use B<ExtUtils::Embed> for building C/C++ applications
with embedded perl, see L<perlembed>.
=head1 SEE ALSO
L<perlembed>
=head1 AUTHOR
Doug MacEachern E<lt>F<dougm@osf.org>E<gt>
Based on ideas from Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and
B<minimod.pl> by Andreas Koenig E<lt>F<k@anna.in-berlin.de>E<gt> and Tim Bunce.
=cut
Install.pm 0000644 00000117263 15272605367 0006537 0 ustar 00 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
1.58
=cut
$VERSION = '1.58'; # <---- dont 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 occured. 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 occured and
anything depending on this module cannot proceed until a reboot
has occured.
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_VMS_noefs = $Is_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);
if( $Is_VMS ) {
my $vms_unix_rpt;
my $vms_efs;
my $vms_case;
if (eval { local $SIG{__DIE__}; 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_noefs = 0 if ($vms_efs);
}
# *note* CanMoveAtBoot is only incidentally the same condition as below
# this needs not hold true in the future.
my $Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
? (eval {require Win32API::File; 1} || 0)
: 0;
my $Inc_uninstall_warn_handler;
# install relative to here
my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
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 occured
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
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'";
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.
=back
=end _private
=cut
sub _unlink_or_rename { #XXX OS-SPECIFIC
my ( $file, $tryhard, $installing )= @_;
_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
=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 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_noefs) {
# There is a bug in catdir that is fixed when the EFS character
# set is enabled, which requires this VMS specific code.
$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
=end _private
=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
regardles 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 dont 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 occured.
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, $autosplit_dir);
pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
Copies each key of %from_to to its corresponding value efficiently.
Filenames with the extension .pm are autosplit into the $autosplit_dir.
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).
=cut
sub pm_to_blib {
my($fromto,$autodir,$pm_filter) = @_;
_mkpath($autodir,0,0755);
while(my($from, $to) = each %$fromto) {
if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
print "Skip $to (unchanged)\n";
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";
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";
}
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);
}
}
=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;
Miniperl.pm 0000644 00000016721 15272605367 0006705 0 ustar 00 # This File keeps the contents of miniperlmain.c.
#
# It was generated automatically by minimod.PL from the contents
# of miniperlmain.c. Don't edit this file!
#
# ANY CHANGES MADE HERE WILL BE LOST!
#
package ExtUtils::Miniperl;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&writemain);
$head= <<'EOF!HEAD';
/* miniperlmain.c
*
* Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
* 2004, 2005, 2006, 2007, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
/*
* The Road goes ever on and on
* Down from the door where it began.
*
* [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
* [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
*/
/* This file contains the main() function for the perl interpreter.
* Note that miniperlmain.c contains main() for the 'miniperl' binary,
* while perlmain.c contains main() for the 'perl' binary.
*
* Miniperl is like perl except that it does not support dynamic loading,
* and in fact is used to build the dynamic modules needed for the 'real'
* perl executable.
*/
#ifdef OEMVS
#ifdef MYMALLOC
/* sbrk is limited to first heap segment so make it big */
#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
#else
#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
#endif
#endif
#include "EXTERN.h"
#define PERL_IN_MINIPERLMAIN_C
#include "perl.h"
#include "XSUB.h"
static void xs_init (pTHX);
static PerlInterpreter *my_perl;
#if defined (atarist)
/* The Atari operating system doesn't have a dynamic stack. The
stack size is determined from this value. */
long _stksize = 64 * 1024;
#endif
#if defined(PERL_GLOBAL_STRUCT_PRIVATE)
/* The static struct perl_vars* may seem counterproductive since the
* whole idea PERL_GLOBAL_STRUCT_PRIVATE was to avoid statics, but note
* that this static is not in the shared perl library, the globals PL_Vars
* and PL_VarsPtr will stay away. */
static struct perl_vars* my_plvarsp;
struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; }
#endif
#ifdef NO_ENV_ARRAY_IN_MAIN
extern char **environ;
int
main(int argc, char **argv)
#else
int
main(int argc, char **argv, char **env)
#endif
{
dVAR;
int exitstatus, i;
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *plvarsp = init_global_struct();
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
my_vars = my_plvarsp = plvarsp;
# endif
#endif /* PERL_GLOBAL_STRUCT */
#ifndef NO_ENV_ARRAY_IN_MAIN
PERL_UNUSED_ARG(env);
#endif
#ifndef PERL_USE_SAFE_PUTENV
PL_use_safe_putenv = FALSE;
#endif /* PERL_USE_SAFE_PUTENV */
/* if user wants control of gprof profiling off by default */
/* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
PERL_GPROF_MONCONTROL(0);
#ifdef NO_ENV_ARRAY_IN_MAIN
PERL_SYS_INIT3(&argc,&argv,&environ);
#else
PERL_SYS_INIT3(&argc,&argv,&env);
#endif
#if defined(USE_ITHREADS)
/* XXX Ideally, this should really be happening in perl_alloc() or
* perl_construct() to keep libperl.a transparently fork()-safe.
* It is currently done here only because Apache/mod_perl have
* problems due to lack of a call to cancel pthread_atfork()
* handlers when shared objects that contain the handlers may
* be dlclose()d. This forces applications that embed perl to
* call PTHREAD_ATFORK() explicitly, but if and only if it hasn't
* been called at least once before in the current process.
* --GSAR 2001-07-20 */
PTHREAD_ATFORK(Perl_atfork_lock,
Perl_atfork_unlock,
Perl_atfork_unlock);
#endif
if (!PL_do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct(my_perl);
PL_perl_destruct_level = 0;
}
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
if (!exitstatus)
perl_run(my_perl);
#ifndef PERL_MICRO
/* Unregister our signal handler before destroying my_perl */
for (i = 0; PL_sig_name[i]; i++) {
if (rsignal_state(PL_sig_num[i]) == (Sighandler_t) PL_csighandlerp) {
rsignal(PL_sig_num[i], (Sighandler_t) SIG_DFL);
}
}
#endif
exitstatus = perl_destruct(my_perl);
perl_free(my_perl);
#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL) && !defined(NO_ENV_ARRAY_IN_MAIN)
/*
* The old environment may have been freed by perl_free()
* when PERL_TRACK_MEMPOOL is defined, but without having
* been restored by perl_destruct() before (this is only
* done if destruct_level > 0).
*
* It is important to have a valid environment for atexit()
* routines that are eventually called.
*/
environ = env;
#endif
#ifdef PERL_GLOBAL_STRUCT
free_global_struct(plvarsp);
#endif /* PERL_GLOBAL_STRUCT */
PERL_SYS_TERM();
exit(exitstatus);
return exitstatus;
}
/* Register any extra external extensions */
EOF!HEAD
$tail=<<'EOF!TAIL';
static void
xs_init(pTHX)
{
PERL_UNUSED_CONTEXT;
}
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
* indent-tabs-mode: t
* End:
*
* ex: set ts=8 sts=4 sw=4 noet:
*/
EOF!TAIL
sub writemain{
my(@exts) = @_;
my($pname);
my($dl) = canon('/','DynaLoader');
print $head;
foreach $_ (@exts){
my($pname) = canon('/', $_);
my($mname, $cname);
($mname = $pname) =~ s!/!::!g;
($cname = $pname) =~ s!/!__!g;
print "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n";
}
my ($tail1,$tail2,$tail3) = ( $tail =~ /\A(.*{\s*\n)(.*\n)(\s*\}.*)\Z/s );
print $tail1;
print "\tconst char file[] = __FILE__;\n";
print "\tdXSUB_SYS;\n" if $] > 5.002;
print $tail2;
foreach $_ (@exts){
my($pname) = canon('/', $_);
my($mname, $cname, $ccode);
($mname = $pname) =~ s!/!::!g;
($cname = $pname) =~ s!/!__!g;
print "\t{\n";
if ($pname eq $dl){
# Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
# boot_DynaLoader is called directly in DynaLoader.pm
$ccode = "\t/* DynaLoader is a special case */\n
\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n";
print $ccode unless $SEEN{$ccode}++;
} else {
$ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n";
print $ccode unless $SEEN{$ccode}++;
}
print "\t}\n";
}
print $tail3;
}
sub canon{
my($as, @ext) = @_;
foreach(@ext){
# might be X::Y or lib/auto/X/Y/Y.a
next if s!::!/!g;
s:^(lib|ext)/(auto/)?::;
s:/\w+\.\w+$::;
}
grep(s:/:$as:, @ext) if ($as ne '/');
@ext;
}
1;
__END__
=head1 NAME
ExtUtils::Miniperl, writemain - write the C code for perlmain.c
=head1 SYNOPSIS
C<use ExtUtils::Miniperl;>
C<writemain(@directories);>
=head1 DESCRIPTION
This whole module is written when perl itself is built from a script
called minimod.PL. In case you want to patch it, please patch
minimod.PL in the perl distribution instead.
writemain() takes an argument list of directories containing archive
libraries that relate to perl modules and should be linked into a new
perl binary. It writes to STDOUT a corresponding perlmain.c file that
is a plain C file containing all the bootstrap code to make the
modules associated with the libraries available from within perl.
The typical usage is from within a Makefile generated by
ExtUtils::MakeMaker. So under normal circumstances you won't have to
deal with this module directly.
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
Constant.pm 0000644 00000035132 15272605367 0006714 0 ustar 00 package ExtUtils::Constant;
use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS);
$VERSION = 0.23;
=head1 NAME
ExtUtils::Constant - generate XS code to import C header constants
=head1 SYNOPSIS
use ExtUtils::Constant qw (WriteConstants);
WriteConstants(
NAME => 'Foo',
NAMES => [qw(FOO BAR BAZ)],
);
# Generates wrapper code to make the values of the constants FOO BAR BAZ
# available to perl
=head1 DESCRIPTION
ExtUtils::Constant facilitates generating C and XS wrapper code to allow
perl modules to AUTOLOAD constants defined in C library header files.
It is principally used by the C<h2xs> utility, on which this code is based.
It doesn't contain the routines to scan header files to extract these
constants.
=head1 USAGE
Generally one only needs to call the C<WriteConstants> function, and then
#include "const-c.inc"
in the C section of C<Foo.xs>
INCLUDE: const-xs.inc
in the XS section of C<Foo.xs>.
For greater flexibility use C<constant_types()>, C<C_constant> and
C<XS_constant>, with which C<WriteConstants> is implemented.
Currently this module understands the following types. h2xs may only know
a subset. The sizes of the numeric types are chosen by the C<Configure>
script at compile time.
=over 4
=item IV
signed integer, at least 32 bits.
=item UV
unsigned integer, the same size as I<IV>
=item NV
floating point type, probably C<double>, possibly C<long double>
=item PV
NUL terminated string, length will be determined with C<strlen>
=item PVN
A fixed length thing, given as a [pointer, length] pair. If you know the
length of a string at compile time you may use this instead of I<PV>
=item SV
A B<mortal> SV.
=item YES
Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
=item NO
Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored).
=item UNDEF
C<undef>. The value of the macro is not needed.
=back
=head1 FUNCTIONS
=over 4
=cut
if ($] >= 5.006) {
eval "use warnings; 1" or die $@;
}
use strict;
use Carp qw(croak cluck);
use Exporter;
use ExtUtils::Constant::Utils qw(C_stringify);
use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet);
@ISA = 'Exporter';
%EXPORT_TAGS = ( 'all' => [ qw(
XS_constant constant_types return_clause memEQ_clause C_stringify
C_constant autoload WriteConstants WriteMakefileSnippet
) ] );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
=item constant_types
A function returning a single scalar with C<#define> definitions for the
constants used internally between the generated C and XS functions.
=cut
sub constant_types {
ExtUtils::Constant::XS->header();
}
sub memEQ_clause {
cluck "ExtUtils::Constant::memEQ_clause is deprecated";
ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1],
indent=>$_[2]});
}
sub return_clause ($$) {
cluck "ExtUtils::Constant::return_clause is deprecated";
my $indent = shift;
ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_);
}
sub switch_clause {
cluck "ExtUtils::Constant::switch_clause is deprecated";
my $indent = shift;
my $comment = shift;
ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment},
@_);
}
sub C_constant {
my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
= @_;
ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname,
default_type => $default_type,
types => $what, indent => $indent,
breakout => $breakout}, @items);
}
=item XS_constant PACKAGE, TYPES, XS_SUBNAME, C_SUBNAME
A function to generate the XS code to implement the perl subroutine
I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
This XS code is a wrapper around a C subroutine usually generated by
C<C_constant>, and usually named C<constant>.
I<TYPES> should be given either as a comma separated list of types that the
C subroutine C<constant> will generate or as a reference to a hash. It should
be the same list of types as C<C_constant> was given.
[Otherwise C<XS_constant> and C<C_constant> may have different ideas about
the number of parameters passed to the C function C<constant>]
You can call the perl visible subroutine something other than C<constant> if
you give the parameter I<XS_SUBNAME>. The C subroutine it calls defaults to
the name of the perl visible subroutine, unless you give the parameter
I<C_SUBNAME>.
=cut
sub XS_constant {
my $package = shift;
my $what = shift;
my $XS_subname = shift;
my $C_subname = shift;
$XS_subname ||= 'constant';
$C_subname ||= $XS_subname;
if (!ref $what) {
# Convert line of the form IV,UV,NV to hash
$what = {map {$_ => 1} split /,\s*/, ($what)};
}
my $params = ExtUtils::Constant::XS->params ($what);
my $type;
my $xs = <<"EOT";
void
$XS_subname(sv)
PREINIT:
#ifdef dXSTARG
dXSTARG; /* Faster if we have it. */
#else
dTARGET;
#endif
STRLEN len;
int type;
EOT
if ($params->{IV}) {
$xs .= " IV iv;\n";
} else {
$xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
}
if ($params->{NV}) {
$xs .= " NV nv;\n";
} else {
$xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
}
if ($params->{PV}) {
$xs .= " const char *pv;\n";
} else {
$xs .=
" /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
}
$xs .= << 'EOT';
INPUT:
SV * sv;
const char * s = SvPV(sv, len);
EOT
if ($params->{''}) {
$xs .= << 'EOT';
INPUT:
int utf8 = SvUTF8(sv);
EOT
}
$xs .= << 'EOT';
PPCODE:
EOT
if ($params->{IV} xor $params->{NV}) {
$xs .= << "EOT";
/* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
if you need to return both NVs and IVs */
EOT
}
$xs .= " type = $C_subname(aTHX_ s, len";
$xs .= ', utf8' if $params->{''};
$xs .= ', &iv' if $params->{IV};
$xs .= ', &nv' if $params->{NV};
$xs .= ', &pv' if $params->{PV};
$xs .= ', &sv' if $params->{SV};
$xs .= ");\n";
# If anyone is insane enough to suggest a package name containing %
my $package_sprintf_safe = $package;
$package_sprintf_safe =~ s/%/%%/g;
$xs .= << "EOT";
/* Return 1 or 2 items. First is error message, or undef if no error.
Second, if present, is found value */
switch (type) {
case PERL_constant_NOTFOUND:
sv =
sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s));
PUSHs(sv);
break;
case PERL_constant_NOTDEF:
sv = sv_2mortal(newSVpvf(
"Your vendor has not defined $package_sprintf_safe macro %s, used",
s));
PUSHs(sv);
break;
EOT
foreach $type (sort keys %XS_Constant) {
# '' marks utf8 flag needed.
next if $type eq '';
$xs .= "\t/* Uncomment this if you need to return ${type}s\n"
unless $what->{$type};
$xs .= " case PERL_constant_IS$type:\n";
if (length $XS_Constant{$type}) {
$xs .= << "EOT";
EXTEND(SP, 1);
PUSHs(&PL_sv_undef);
$XS_Constant{$type};
EOT
} else {
# Do nothing. return (), which will be correctly interpreted as
# (undef, undef)
}
$xs .= " break;\n";
unless ($what->{$type}) {
chop $xs; # Yes, another need for chop not chomp.
$xs .= " */\n";
}
}
$xs .= << "EOT";
default:
sv = sv_2mortal(newSVpvf(
"Unexpected return type %d while processing $package_sprintf_safe macro %s, used",
type, s));
PUSHs(sv);
}
EOT
return $xs;
}
=item autoload PACKAGE, VERSION, AUTOLOADER
A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
I<VERSION> is the perl version the code should be backwards compatible with.
It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
names that the constant() routine doesn't recognise.
=cut
# ' # Grr. syntax highlighters that don't grok pod.
sub autoload {
my ($module, $compat_version, $autoloader) = @_;
$compat_version ||= $];
croak "Can't maintain compatibility back as far as version $compat_version"
if $compat_version < 5;
my $func = "sub AUTOLOAD {\n"
. " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
. " # XS function.";
$func .= " If a constant is not found then control is passed\n"
. " # to the AUTOLOAD in AutoLoader." if $autoloader;
$func .= "\n\n"
. " my \$constname;\n";
$func .=
" our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
$func .= <<"EOT";
(\$constname = \$AUTOLOAD) =~ s/.*:://;
croak "&${module}::constant not defined" if \$constname eq 'constant';
my (\$error, \$val) = constant(\$constname);
EOT
if ($autoloader) {
$func .= <<'EOT';
if ($error) {
if ($error =~ /is not a valid/) {
$AutoLoader::AUTOLOAD = $AUTOLOAD;
goto &AutoLoader::AUTOLOAD;
} else {
croak $error;
}
}
EOT
} else {
$func .=
" if (\$error) { croak \$error; }\n";
}
$func .= <<'END';
{
no strict 'refs';
# Fixed between 5.005_53 and 5.005_61
#XXX if ($] >= 5.00561) {
#XXX *$AUTOLOAD = sub () { $val };
#XXX }
#XXX else {
*$AUTOLOAD = sub { $val };
#XXX }
}
goto &$AUTOLOAD;
}
END
return $func;
}
=item WriteMakefileSnippet
WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
A function to generate perl code for Makefile.PL that will regenerate
the constant subroutines. Parameters are named as passed to C<WriteConstants>,
with the addition of C<INDENT> to specify the number of leading spaces
(default 2).
Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
C<XS_FILE> are recognised.
=cut
sub WriteMakefileSnippet {
my %args = @_;
my $indent = $args{INDENT} || 2;
my $result = <<"EOT";
ExtUtils::Constant::WriteConstants(
NAME => '$args{NAME}',
NAMES => \\\@names,
DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
EOT
foreach (qw (C_FILE XS_FILE)) {
next unless exists $args{$_};
$result .= sprintf " %-12s => '%s',\n",
$_, $args{$_};
}
$result .= <<'EOT';
);
EOT
$result =~ s/^/' 'x$indent/gem;
return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE},
indent=>$indent,},
@{$args{NAMES}})
. $result;
}
=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
Writes a file of C code and a file of XS code which you should C<#include>
and C<INCLUDE> in the C and XS sections respectively of your module's XS
code. You probably want to do this in your C<Makefile.PL>, so that you can
easily edit the list of constants without touching the rest of your module.
The attributes supported are
=over 4
=item NAME
Name of the module. This must be specified
=item DEFAULT_TYPE
The default type for the constants. If not specified C<IV> is assumed.
=item BREAKOUT_AT
The names of the constants are grouped by length. Generate child subroutines
for each group with this number or more names in.
=item NAMES
An array of constants' names, either scalars containing names, or hashrefs
as detailed in L<"C_constant">.
=item PROXYSUBS
If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>.
=item C_FH
A filehandle to write the C code to. If not given, then I<C_FILE> is opened
for writing.
=item C_FILE
The name of the file to write containing the C code. The default is
C<const-c.inc>. The C<-> in the name ensures that the file can't be
mistaken for anything related to a legitimate perl package name, and
not naming the file C<.c> avoids having to override Makefile.PL's
C<.xs> to C<.c> rules.
=item XS_FH
A filehandle to write the XS code to. If not given, then I<XS_FILE> is opened
for writing.
=item XS_FILE
The name of the file to write containing the XS code. The default is
C<const-xs.inc>.
=item XS_SUBNAME
The perl visible name of the XS subroutine generated which will return the
constants. The default is C<constant>.
=item C_SUBNAME
The name of the C subroutine generated which will return the constants.
The default is I<XS_SUBNAME>. Child subroutines have C<_> and the name
length appended, so constants with 10 character names would be in
C<constant_10> with the default I<XS_SUBNAME>.
=back
=cut
sub WriteConstants {
my %ARGS =
( # defaults
C_FILE => 'const-c.inc',
XS_FILE => 'const-xs.inc',
XS_SUBNAME => 'constant',
DEFAULT_TYPE => 'IV',
@_);
$ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
croak "Module name not specified" unless length $ARGS{NAME};
# Do this before creating (empty) files, in case it fails:
require ExtUtils::Constant::ProxySubs if $ARGS{PROXYSUBS};
my $c_fh = $ARGS{C_FH};
if (!$c_fh) {
if ($] <= 5.008) {
# We need these little games, rather than doing things
# unconditionally, because we're used in core Makefile.PLs before
# IO is available (needed by filehandle), but also we want to work on
# older perls where undefined scalars do not automatically turn into
# anonymous file handles.
require FileHandle;
$c_fh = FileHandle->new();
}
open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
}
my $xs_fh = $ARGS{XS_FH};
if (!$xs_fh) {
if ($] <= 5.008) {
require FileHandle;
$xs_fh = FileHandle->new();
}
open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
}
# As this subroutine is intended to make code that isn't edited, there's no
# need for the user to specify any types that aren't found in the list of
# names.
if ($ARGS{PROXYSUBS}) {
$ARGS{C_FH} = $c_fh;
$ARGS{XS_FH} = $xs_fh;
ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS);
} else {
my $types = {};
print $c_fh constant_types(); # macro defs
print $c_fh "\n";
# indent is still undef. Until anyone implements indent style rules with
# it.
foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME},
subname => $ARGS{C_SUBNAME},
default_type =>
$ARGS{DEFAULT_TYPE},
types => $types,
breakout =>
$ARGS{BREAKOUT_AT}},
@{$ARGS{NAMES}})) {
print $c_fh $_, "\n"; # C constant subs
}
print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
$ARGS{C_SUBNAME});
}
close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH};
close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH};
}
1;
__END__
=back
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
others
=cut
CBuilder.pm 0000644 00000021254 15272605367 0006614 0 ustar 00 package ExtUtils::CBuilder;
use File::Spec ();
use File::Path ();
use File::Basename ();
use Perl::OSType qw/os_type/;
use vars qw($VERSION @ISA);
$VERSION = '0.280206';
$VERSION = eval $VERSION;
# We only use this once - don't waste a symbol table entry on it.
# More importantly, don't make it an inheritable method.
my $load = sub {
my $mod = shift;
eval "use $mod";
die $@ if $@;
@ISA = ($mod);
};
{
my @package = split /::/, __PACKAGE__;
my $ostype = os_type();
if (grep {-e File::Spec->catfile($_, @package, 'Platform', $^O) . '.pm'} @INC) {
$load->(__PACKAGE__ . "::Platform::$^O");
} elsif ( $ostype && grep {-e File::Spec->catfile($_, @package, 'Platform', $ostype) . '.pm'} @INC) {
$load->(__PACKAGE__ . "::Platform::$ostype");
} else {
$load->(__PACKAGE__ . "::Base");
}
}
1;
__END__
=head1 NAME
ExtUtils::CBuilder - Compile and link C code for Perl modules
=head1 SYNOPSIS
use ExtUtils::CBuilder;
my $b = ExtUtils::CBuilder->new(%options);
$obj_file = $b->compile(source => 'MyModule.c');
$lib_file = $b->link(objects => $obj_file);
=head1 DESCRIPTION
This module can build the C portions of Perl modules by invoking the
appropriate compilers and linkers in a cross-platform manner. It was
motivated by the C<Module::Build> project, but may be useful for other
purposes as well. However, it is I<not> intended as a general
cross-platform interface to all your C building needs. That would
have been a much more ambitious goal!
=head1 METHODS
=over 4
=item new
Returns a new C<ExtUtils::CBuilder> object. A C<config> parameter
lets you override C<Config.pm> settings for all operations performed
by the object, as in the following example:
# Use a different compiler than Config.pm says
my $b = ExtUtils::CBuilder->new( config =>
{ ld => 'gcc' } );
A C<quiet> parameter tells C<CBuilder> to not print its C<system()>
commands before executing them:
# Be quieter than normal
my $b = ExtUtils::CBuilder->new( quiet => 1 );
=item have_compiler
Returns true if the current system has a working C compiler and
linker, false otherwise. To determine this, we actually compile and
link a sample C library. The sample will be compiled in the system
tempdir or, if that fails for some reason, in the current directory.
=item have_cplusplus
Just like have_compiler but for C++ instead of C.
=item compile
Compiles a C source file and produces an object file. The name of the
object file is returned. The source file is specified in a C<source>
parameter, which is required; the other parameters listed below are
optional.
=over 4
=item C<object_file>
Specifies the name of the output file to create. Otherwise the
C<object_file()> method will be consulted, passing it the name of the
C<source> file.
=item C<include_dirs>
Specifies any additional directories in which to search for header
files. May be given as a string indicating a single directory, or as
a list reference indicating multiple directories.
=item C<extra_compiler_flags>
Specifies any additional arguments to pass to the compiler. Should be
given as a list reference containing the arguments individually, or if
this is not possible, as a string containing all the arguments
together.
=item C<C++>
Specifies that the source file is a C++ source file and sets appropriate
compiler flags
=back
The operation of this method is also affected by the
C<archlibexp>, C<cccdlflags>, C<ccflags>, C<optimize>, and C<cc>
entries in C<Config.pm>.
=item link
Invokes the linker to produce a library file from object files. In
scalar context, the name of the library file is returned. In list
context, the library file and any temporary files created are
returned. A required C<objects> parameter contains the name of the
object files to process, either in a string (for one object file) or
list reference (for one or more files). The following parameters are
optional:
=over 4
=item lib_file
Specifies the name of the output library file to create. Otherwise
the C<lib_file()> method will be consulted, passing it the name of
the first entry in C<objects>.
=item module_name
Specifies the name of the Perl module that will be created by linking.
On platforms that need to do prelinking (Win32, OS/2, etc.) this is a
required parameter.
=item extra_linker_flags
Any additional flags you wish to pass to the linker.
=back
On platforms where C<need_prelink()> returns true, C<prelink()>
will be called automatically.
The operation of this method is also affected by the C<lddlflags>,
C<shrpenv>, and C<ld> entries in C<Config.pm>.
=item link_executable
Invokes the linker to produce an executable file from object files. In
scalar context, the name of the executable file is returned. In list
context, the executable file and any temporary files created are
returned. A required C<objects> parameter contains the name of the
object files to process, either in a string (for one object file) or
list reference (for one or more files). The optional parameters are
the same as C<link> with exception for
=over 4
=item exe_file
Specifies the name of the output executable file to create. Otherwise
the C<exe_file()> method will be consulted, passing it the name of the
first entry in C<objects>.
=back
=item object_file
my $object_file = $b->object_file($source_file);
Converts the name of a C source file to the most natural name of an
output object file to create from it. For instance, on Unix the
source file F<foo.c> would result in the object file F<foo.o>.
=item lib_file
my $lib_file = $b->lib_file($object_file);
Converts the name of an object file to the most natural name of a
output library file to create from it. For instance, on Mac OS X the
object file F<foo.o> would result in the library file F<foo.bundle>.
=item exe_file
my $exe_file = $b->exe_file($object_file);
Converts the name of an object file to the most natural name of an
executable file to create from it. For instance, on Mac OS X the
object file F<foo.o> would result in the executable file F<foo>, and
on Windows it would result in F<foo.exe>.
=item prelink
On certain platforms like Win32, OS/2, VMS, and AIX, it is necessary
to perform some actions before invoking the linker. The
C<ExtUtils::Mksymlists> module does this, writing files used by the
linker during the creation of shared libraries for dynamic extensions.
The names of any files written will be returned as a list.
Several parameters correspond to C<ExtUtils::Mksymlists::Mksymlists()>
options, as follows:
Mksymlists() prelink() type
-------------|-------------------|-------------------
NAME | dl_name | string (required)
DLBASE | dl_base | string
FILE | dl_file | string
DL_VARS | dl_vars | array reference
DL_FUNCS | dl_funcs | hash reference
FUNCLIST | dl_func_list | array reference
IMPORTS | dl_imports | hash reference
VERSION | dl_version | string
Please see the documentation for C<ExtUtils::Mksymlists> for the
details of what these parameters do.
=item need_prelink
Returns true on platforms where C<prelink()> should be called
during linking, and false otherwise.
=item extra_link_args_after_prelink
Returns list of extra arguments to give to the link command; the arguments
are the same as for prelink(), with addition of array reference to the
results of prelink(); this reference is indexed by key C<prelink_res>.
=back
=head1 TO DO
Currently this has only been tested on Unix and doesn't contain any of
the Windows-specific code from the C<Module::Build> project. I'll do
that next.
=head1 HISTORY
This module is an outgrowth of the C<Module::Build> project, to which
there have been many contributors. Notably, Randy W. Sims submitted
lots of code to support 3 compilers on Windows and helped with various
other platform-specific issues. Ilya Zakharevich has contributed
fixes for OS/2; John E. Malmberg and Peter Prymmer have done likewise
for VMS.
=head1 SUPPORT
ExtUtils::CBuilder is maintained as part of the Perl 5 core. Please
submit any bug reports via the F<perlbug> tool included with Perl 5.
Bug reports will be included in the Perl 5 ticket system at
L<http://rt.perl.org>.
The Perl 5 source code is available at <http://perl5.git.perl.org/perl.git>
and ExtUtils-CBuilder may be found in the F<dist/ExtUtils-CBuilder> directory
of the repository.
=head1 AUTHOR
Ken Williams, kwilliams@cpan.org
Additional contributions by The Perl 5 Porters.
=head1 COPYRIGHT
Copyright (c) 2003-2005 Ken Williams. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
perl(1), Module::Build(3)
=cut
Installed.pm 0000644 00000034037 15272605367 0007045 0 ustar 00 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 = '1.999002';
$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 C</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 <Alan.Burlison@uk.sun.com>
=cut
Command.pm 0000644 00000016453 15272605367 0006506 0 ustar 00 package ExtUtils::Command;
use 5.00503;
use strict;
use Carp;
use File::Copy;
use File::Compare;
use File::Basename;
use File::Path qw(rmtree);
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 = '1.17';
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__}; 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();
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);
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;
croak("Too many arguments") if (@src > 1 && ! -d $dst);
my $nok = 0;
foreach my $src (@src) {
$nok ||= !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;
croak("Too many arguments") if (@src > 1 && ! -d $dst);
my $nok = 0;
foreach my $src (@src) {
$nok ||= !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) {
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();
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 };
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<ni-s@cpan.org>
Maintained by Michael G Schwern C<schwern@pobox.com> within the
ExtUtils-MakeMaker package and, as a separate CPAN package, by
Randy Kobes C<r.kobes@uwinnipeg.ca>.
=cut