Skip to content

Instantly share code, notes, and snippets.

@mcast

mcast/.gitignore

Created November 25, 2011 18:05
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save mcast/1394091 to your computer and use it in GitHub Desktop.
Save mcast/1394091 to your computer and use it in GitHub Desktop.
Download ZIP
EU-I-relpath
Raw
.gitignore
Makefile
blib
pm_to_blib
Raw
.packlist
../EUIDummy.pm
Raw
README
ExtUtils-Install
Install perl modules into the source tree. Used by ExtUtils::MakeMaker and
Module::Build.
INSTALLATION
To install this module, run the following commands:
perl Makefile.PL
make
make test
make install
Alternatively, to install with Module::Build, you can use the following
commands:
perl Build.PL
./Build
./Build test
./Build install
Note that using Module::Build may make it more difficult to install on some
platforms, if a failure occurs try to use the Makefile.PL approach instead.
SUPPORT AND DOCUMENTATION
After installing, you can find documentation for this module with the
perldoc command.
perldoc ExtUtils::Install
You can also look for information at:
Search CPAN
http://search.cpan.org/dist/ExtUtils-Install
CPAN Request Tracker:
http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install
AnnoCPAN, annotated CPAN documentation:
http://annocpan.org/dist/ExtUtils-Install
CPAN Ratings:
http://cpanratings.perl.org/d/ExtUtils-Install
COPYRIGHT AND LICENCE
Copyright (C) 2006 Yves Orton, Michael Schwern, Alan Burlison,
Randy W. Sims and others.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
Raw
README.pod

TEST CASE

Bug report "ExtUtils::Installed fails to read packlist for relative @INC elements" at https://rt.cpan.org/Ticket/Display.html?id=72734

Failing test for ExtUtils::Installed 1.999_001 (ExtUtils-Install 1.54) - it doesn't like relative paths on @INC, they cause packlists to look empty.

Likely cause is not using "no_chdir" in File::Find, which I suspect also impacts performance on large trees (some ad-hoc stats included, but I haven't tried without).

Prerequisites

ExtUtils::Installed
Test::More
YAML if $SHOW_DEBUG is set

Strangeness

The .packlist contains relative paths. This is not normal but seems less broken than an incorrect absolute path, and doesn't cause any breakage. The alternative would be "tempdir" in File::Temp.

COPYRIGHT

Same as Perl 5; or otherwise on request.

ORIGIN

https://github.com/mca-wtsi/lib-vswitch/tree/distmix

Raw
BFD.pm
package MakeMaker::Test::Setup::BFD;
@ISA = qw(Exporter);
require Exporter;
@EXPORT = qw(setup_recurs teardown_recurs);
use strict;
use File::Path;
use File::Basename;
use MakeMaker::Test::Utils;
my $Is_VMS = $^O eq 'VMS';
my %Files = (
'Big-Dummy/lib/Big/Dummy.pm' => <<'END',
package Big::Dummy;
$VERSION = 0.01;
=head1 NAME
Big::Dummy - Try "our" hot dog's
=cut
1;
END
'Big-Dummy/Makefile.PL' => <<'END',
use ExtUtils::MakeMaker;
# This will interfere with the PREREQ_PRINT tests.
printf "Current package is: %s\n", __PACKAGE__ unless "@ARGV" =~ /PREREQ/;
WriteMakefile(
NAME => 'Big::Dummy',
VERSION_FROM => 'lib/Big/Dummy.pm',
EXE_FILES => [qw(bin/program)],
PREREQ_PM => { strict => 0 },
ABSTRACT_FROM => 'lib/Big/Dummy.pm',
AUTHOR => 'Michael G Schwern <schwern@pobox.com>',
);
END
'Big-Dummy/bin/program' => <<'END',
#!/usr/bin/perl -w
=head1 NAME
program - this is a program
=cut
1;
END
'Big-Dummy/t/compile.t' => <<'END',
print "1..2\n";
print eval "use Big::Dummy; 1;" ? "ok 1\n" : "not ok 1\n";
print "ok 2 - TEST_VERBOSE\n";
END
'Big-Dummy/Liar/t/sanity.t' => <<'END',
print "1..3\n";
print eval "use Big::Dummy; 1;" ? "ok 1\n" : "not ok 1\n";
print eval "use Big::Liar; 1;" ? "ok 2\n" : "not ok 2\n";
print "ok 3 - TEST_VERBOSE\n";
END
'Big-Dummy/Liar/lib/Big/Liar.pm' => <<'END',
package Big::Liar;
$VERSION = 0.01;
1;
END
'Big-Dummy/Liar/Makefile.PL' => <<'END',
use ExtUtils::MakeMaker;
my $mm = WriteMakefile(
NAME => 'Big::Liar',
VERSION_FROM => 'lib/Big/Liar.pm',
_KEEP_AFTER_FLUSH => 1
);
print "Big::Liar's vars\n";
foreach my $key (qw(INST_LIB INST_ARCHLIB)) {
print "$key = $mm->{$key}\n";
}
END
);
sub setup_recurs {
setup_mm_test_root();
chdir 'MM_TEST_ROOT:[t]' if $Is_VMS;
while(my($file, $text) = each %Files) {
# Convert to a relative, native file path.
$file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
my $dir = dirname($file);
mkpath $dir;
open(FILE, ">$file") || die "Can't create $file: $!";
print FILE $text;
close FILE;
# ensure file at least 1 second old for makes that assume
# files with the same time are out of date.
my $time = calibrate_mtime();
utime $time, $time - 1, $file;
}
return 1;
}
sub teardown_recurs {
foreach my $file (keys %Files) {
my $dir = dirname($file);
if( -e $dir ) {
rmtree($dir) || return;
}
}
return 1;
}
1;
Raw
Build.PL
use strict;
use Module::Build;
use lib qw(lib);
# On Win32 things work better if Win32API::File is available.
# Activestate builds have it by default, but the core distro doesn't
# so we recommend it on Win32.
#
# * BUT *
#
# We can't recommend it on the release system as it then goes in the YAML.pl
# and then non-Win32 CPAN clients think they need it get upset when it fails
# to build on their system.
#
# Until CPAN and Module::Build and the other infrastructure has a better
# way to deal with this we assume UNIX when building a release.
#
# The pre-build stage will moan on Win32 anyway.
my $Recommend_Win32API_File = $ENV{USERNAME} ne 'demerphq'
&& ($^O eq 'MSWin32' || $^O eq 'cygwin');
my $builder = Module::Build->new(
module_name => 'ExtUtils::Install',
license => 'perl',
dist_name => 'ExtUtils-Install',
dist_author => 'demerphq <yves@cpan.org>',
dist_version_from => 'lib/ExtUtils/Install.pm',
dynamic_config => 1,
installdirs => 'core',
build_requires => {
# 'Test::More' => 0, # This is bundled, but not in @INC for prereqs
},
requires => {
'perl' => '5.006',
# 'vars' => 0,
# 'AutoSplit' => 0,
# 'Exporter' => 0,
'Carp' => 0,
# 'Config' => 0,
'Cwd' => 0,
'File::Basename' => 0,
'File::Compare' => 0,
'File::Copy' => 0,
'File::Find' => 0,
'File::Path' => 0,
'File::Spec' => 0,
($^O eq 'VMS' ? ('VMS::Filespec' => 0) : ()),
'ExtUtils::MakeMaker' => 0,
},
recommends => {
($Recommend_Win32API_File ? ('Win32API::File' => 0) : ()),
},
);
$builder->create_build_script();
Raw
Builder.pm
package Test::Builder;
use 5.004;
# $^C was only introduced in 5.005-ish. We do this to prevent
# use of uninitialized value warnings in older perls.
$^C ||= 0;
use strict;
use vars qw($VERSION);
$VERSION = '0.32';
$VERSION = eval $VERSION; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
BEGIN {
use Config;
# Load threads::shared when threads are turned on
if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
# occassionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
my $data;
if( $type eq 'HASH' ) {
%$data = %{$_[0]};
}
elsif( $type eq 'ARRAY' ) {
@$data = @{$_[0]};
}
elsif( $type eq 'SCALAR' ) {
$$data = ${$_[0]};
}
else {
die "Unknown type: ".$type;
}
$_[0] = &threads::shared::share($_[0]);
if( $type eq 'HASH' ) {
%{$_[0]} = %$data;
}
elsif( $type eq 'ARRAY' ) {
@{$_[0]} = @$data;
}
elsif( $type eq 'SCALAR' ) {
${$_[0]} = $$data;
}
else {
die "Unknown type: ".$type;
}
return $_[0];
};
}
# 5.8.0's threads::shared is busted when threads are off.
# We emulate it here.
else {
*share = sub { return $_[0] };
*lock = sub { 0 };
}
}
=head1 NAME
Test::Builder - Backend for building test libraries
=head1 SYNOPSIS
package My::Test::Module;
use Test::Builder;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(ok);
my $Test = Test::Builder->new;
$Test->output('my_logfile');
sub import {
my($self) = shift;
my $pack = caller;
$Test->exported_to($pack);
$Test->plan(@_);
$self->export_to_level(1, $self, 'ok');
}
sub ok {
my($test, $name) = @_;
$Test->ok($test, $name);
}
=head1 DESCRIPTION
Test::Simple and Test::More have proven to be popular testing modules,
but they're not always flexible enough. Test::Builder provides the a
building block upon which to write your own test libraries I<which can
work together>.
=head2 Construction
=over 4
=item B<new>
my $Test = Test::Builder->new;
Returns a Test::Builder object representing the current state of the
test.
Since you only run one test per program C<new> always returns the same
Test::Builder object. No matter how many times you call new(), you're
getting the same object. This is called a singleton. This is done so that
multiple modules share such global information as the test counter and
where test output is going.
If you want a completely new Test::Builder object different from the
singleton, use C<create>.
=cut
my $Test = Test::Builder->new;
sub new {
my($class) = shift;
$Test ||= $class->create;
return $Test;
}
=item B<create>
my $Test = Test::Builder->create;
Ok, so there can be more than one Test::Builder object and this is how
you get it. You might use this instead of C<new()> if you're testing
a Test::Builder based module, but otherwise you probably want C<new>.
B<NOTE>: the implementation is not complete. C<level>, for example, is
still shared amongst B<all> Test::Builder objects, even ones created using
this method. Also, the method name may change in the future.
=cut
sub create {
my $class = shift;
my $self = bless {}, $class;
$self->reset;
return $self;
}
=item B<reset>
$Test->reset;
Reinitializes the Test::Builder singleton to its original state.
Mostly useful for tests run in persistent environments where the same
test might be run multiple times in the same process.
=cut
use vars qw($Level);
sub reset {
my ($self) = @_;
# We leave this a global because it has to be localized and localizing
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
$self->{Test_Died} = 0;
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Original_Pid} = $$;
share($self->{Curr_Test});
$self->{Curr_Test} = 0;
$self->{Test_Results} = &share([]);
$self->{Exported_To} = undef;
$self->{Expected_Tests} = 0;
$self->{Skip_All} = 0;
$self->{Use_Nums} = 1;
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
$self->_dup_stdhandles unless $^C;
return undef;
}
=back
=head2 Setting up tests
These methods are for setting up tests and declaring how many there
are. You usually only want to call one of these methods.
=over 4
=item B<exported_to>
my $pack = $Test->exported_to;
$Test->exported_to($pack);
Tells Test::Builder what package you exported your functions to.
This is important for getting TODO tests right.
=cut
sub exported_to {
my($self, $pack) = @_;
if( defined $pack ) {
$self->{Exported_To} = $pack;
}
return $self->{Exported_To};
}
=item B<plan>
$Test->plan('no_plan');
$Test->plan( skip_all => $reason );
$Test->plan( tests => $num_tests );
A convenient way to set up your tests. Call this and Test::Builder
will print the appropriate headers and take the appropriate actions.
If you call plan(), don't call any of the other methods below.
=cut
sub plan {
my($self, $cmd, $arg) = @_;
return unless $cmd;
if( $self->{Have_Plan} ) {
die sprintf "You tried to plan twice! Second plan at %s line %d\n",
($self->caller)[1,2];
}
if( $cmd eq 'no_plan' ) {
$self->no_plan;
}
elsif( $cmd eq 'skip_all' ) {
return $self->skip_all($arg);
}
elsif( $cmd eq 'tests' ) {
if( $arg ) {
return $self->expected_tests($arg);
}
elsif( !defined $arg ) {
die "Got an undefined number of tests. Looks like you tried to ".
"say how many tests you plan to run but made a mistake.\n";
}
elsif( !$arg ) {
die "You said to run 0 tests! You've got to run something.\n";
}
}
else {
require Carp;
my @args = grep { defined } ($cmd, $arg);
Carp::croak("plan() doesn't understand @args");
}
return 1;
}
=item B<expected_tests>
my $max = $Test->expected_tests;
$Test->expected_tests($max);
Gets/sets the # of tests we expect this test to run and prints out
the appropriate headers.
=cut
sub expected_tests {
my $self = shift;
my($max) = @_;
if( @_ ) {
die "Number of tests must be a postive integer. You gave it '$max'.\n"
unless $max =~ /^\+?\d+$/ and $max > 0;
$self->{Expected_Tests} = $max;
$self->{Have_Plan} = 1;
$self->_print("1..$max\n") unless $self->no_header;
}
return $self->{Expected_Tests};
}
=item B<no_plan>
$Test->no_plan;
Declares that this test will run an indeterminate # of tests.
=cut
sub no_plan {
my $self = shift;
$self->{No_Plan} = 1;
$self->{Have_Plan} = 1;
}
=item B<has_plan>
$plan = $Test->has_plan
Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
=cut
sub has_plan {
my $self = shift;
return($self->{Expected_Tests}) if $self->{Expected_Tests};
return('no_plan') if $self->{No_Plan};
return(undef);
};
=item B<skip_all>
$Test->skip_all;
$Test->skip_all($reason);
Skips all the tests, using the given $reason. Exits immediately with 0.
=cut
sub skip_all {
my($self, $reason) = @_;
my $out = "1..0";
$out .= " # Skip $reason" if $reason;
$out .= "\n";
$self->{Skip_All} = 1;
$self->_print($out) unless $self->no_header;
exit(0);
}
=back
=head2 Running tests
These actually run the tests, analogous to the functions in
Test::More.
$name is always optional.
=over 4
=item B<ok>
$Test->ok($test, $name);
Your basic test. Pass if $test is true, fail if $test is false. Just
like Test::Simple's ok().
=cut
sub ok {
my($self, $test, $name) = @_;
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
unless( $self->{Have_Plan} ) {
require Carp;
Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
}
lock $self->{Curr_Test};
$self->{Curr_Test}++;
# In case $name is a string overloaded object, force it to stringify.
$self->_unoverload_str(\$name);
$self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
You named your test '$name'. You shouldn't use numbers for your test names.
Very confusing.
ERR
my($pack, $file, $line) = $self->caller;
my $todo = $self->todo($pack);
$self->_unoverload_str(\$todo);
my $out;
my $result = &share({});
unless( $test ) {
$out .= "not ";
@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
}
else {
@$result{ 'ok', 'actual_ok' } = ( 1, $test );
}
$out .= "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
if( defined $name ) {
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
$out .= " - $name";
$result->{name} = $name;
}
else {
$result->{name} = '';
}
if( $todo ) {
$out .= " # TODO $todo";
$result->{reason} = $todo;
$result->{type} = 'todo';
}
else {
$result->{reason} = '';
$result->{type} = '';
}
$self->{Test_Results}[$self->{Curr_Test}-1] = $result;
$out .= "\n";
$self->_print($out);
unless( $test ) {
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
if( defined $name ) {
$self->diag(qq[ $msg test '$name'\n]);
$self->diag(qq[ in $file at line $line.\n]);
}
else {
$self->diag(qq[ $msg test in $file at line $line.\n]);
}
}
return $test ? 1 : 0;
}
sub _unoverload {
my $self = shift;
my $type = shift;
local($@,$!);
eval { require overload } || return;
foreach my $thing (@_) {
eval {
if( _is_object($$thing) ) {
if( my $string_meth = overload::Method($$thing, $type) ) {
$$thing = $$thing->$string_meth();
}
}
};
}
}
sub _is_object {
my $thing = shift;
return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
}
sub _unoverload_str {
my $self = shift;
$self->_unoverload(q[""], @_);
}
sub _unoverload_num {
my $self = shift;
$self->_unoverload('0+', @_);
for my $val (@_) {
next unless $self->_is_dualvar($$val);
$$val = $$val+0;
}
}
# This is a hack to detect a dualvar such as $!
sub _is_dualvar {
my($self, $val) = @_;
local $^W = 0;
my $numval = $val+0;
return 1 if $numval != 0 and $numval ne $val;
}
=item B<is_eq>
$Test->is_eq($got, $expected, $name);
Like Test::More's is(). Checks if $got eq $expected. This is the
string version.
=item B<is_num>
$Test->is_num($got, $expected, $name);
Like Test::More's is(). Checks if $got == $expected. This is the
numeric version.
=cut
sub is_eq {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
$self->_unoverload_str(\$got, \$expect);
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, 'eq', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'eq', $expect, $name);
}
sub is_num {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
$self->_unoverload_num(\$got, \$expect);
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, '==', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '==', $expect, $name);
}
sub _is_diag {
my($self, $got, $type, $expect) = @_;
foreach my $val (\$got, \$expect) {
if( defined $$val ) {
if( $type eq 'eq' ) {
# quote and force string context
$$val = "'$$val'"
}
else {
# force numeric context
$self->_unoverload_num($val);
}
}
else {
$$val = 'undef';
}
}
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
DIAGNOSTIC
}
=item B<isnt_eq>
$Test->isnt_eq($got, $dont_expect, $name);
Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
the string version.
=item B<isnt_num>
$Test->is_num($got, $dont_expect, $name);
Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
the numeric version.
=cut
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'ne', $dont_expect, $name);
}
sub isnt_num {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag($got, '!=', $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '!=', $dont_expect, $name);
}
=item B<like>
$Test->like($this, qr/$regex/, $name);
$Test->like($this, '/$regex/', $name);
Like Test::More's like(). Checks if $this matches the given $regex.
You'll want to avoid qr// if you want your tests to work before 5.005.
=item B<unlike>
$Test->unlike($this, qr/$regex/, $name);
$Test->unlike($this, '/$regex/', $name);
Like Test::More's unlike(). Checks if $this B<does not match> the
given $regex.
=cut
sub like {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '=~', $name);
}
sub unlike {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '!~', $name);
}
=item B<maybe_regex>
$Test->maybe_regex(qr/$regex/);
$Test->maybe_regex('/$regex/');
Convenience method for building testing functions that take regular
expressions as arguments, but need to work before perl 5.005.
Takes a quoted regular expression produced by qr//, or a string
representing a regular expression.
Returns a Perl value which may be used instead of the corresponding
regular expression, or undef if it's argument is not recognised.
For example, a version of like(), sans the useful diagnostic messages,
could be written as:
sub laconic_like {
my ($self, $this, $regex, $name) = @_;
my $usable_regex = $self->maybe_regex($regex);
die "expecting regex, found '$regex'\n"
unless $usable_regex;
$self->ok($this =~ m/$usable_regex/, $name);
}
=cut
sub maybe_regex {
my ($self, $regex) = @_;
my $usable_regex = undef;
return $usable_regex unless defined $regex;
my($re, $opts);
# Check for qr/foo/
if( ref $regex eq 'Regexp' ) {
$usable_regex = $regex;
}
# Check for '/foo/' or 'm,foo,'
elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
(undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
)
{
$usable_regex = length $opts ? "(?$opts)$re" : $re;
}
return $usable_regex;
};
sub _regex_ok {
my($self, $this, $regex, $cmp, $name) = @_;
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
unless (defined $usable_regex) {
$ok = $self->ok( 0, $name );
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
{
my $test;
my $code = $self->_caller_context;
local($@, $!);
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
$test = !$test if $cmp eq '!~';
local $Level = $Level + 1;
$ok = $self->ok( $test, $name );
}
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
%s
%13s '%s'
DIAGNOSTIC
}
return $ok;
}
=item B<cmp_ok>
$Test->cmp_ok($this, $type, $that, $name);
Works just like Test::More's cmp_ok().
$Test->cmp_ok($big_num, '!=', $other_big_num);
=cut
my %numeric_cmps = map { ($_, 1) }
("<", "<=", ">", ">=", "==", "!=", "<=>");
sub cmp_ok {
my($self, $got, $type, $expect, $name) = @_;
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
: '_unoverload_str';
$self->$unoverload(\$got, \$expect);
my $test;
{
local($@,$!); # don't interfere with $@
# eval() sometimes resets $!
my $code = $self->_caller_context;
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . "\$got $type \$expect;";
}
local $Level = $Level + 1;
my $ok = $self->ok($test, $name);
unless( $ok ) {
if( $type =~ /^(eq|==)$/ ) {
$self->_is_diag($got, $type, $expect);
}
else {
$self->_cmp_diag($got, $type, $expect);
}
}
return $ok;
}
sub _cmp_diag {
my($self, $got, $type, $expect) = @_;
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
%s
DIAGNOSTIC
}
sub _caller_context {
my $self = shift;
my($pack, $file, $line) = $self->caller(1);
my $code = '';
$code .= "#line $line $file\n" if defined $file and defined $line;
return $code;
}
=item B<BAIL_OUT>
$Test->BAIL_OUT($reason);
Indicates to the Test::Harness that things are going so badly all
testing should terminate. This includes running any additional test
scripts.
It will exit with 255.
=cut
sub BAIL_OUT {
my($self, $reason) = @_;
$self->{Bailed_Out} = 1;
$self->_print("Bail out! $reason");
exit 255;
}
=for deprecated
BAIL_OUT() used to be BAILOUT()
=cut
*BAILOUT = \&BAIL_OUT;
=item B<skip>
$Test->skip;
$Test->skip($why);
Skips the current test, reporting $why.
=cut
sub skip {
my($self, $why) = @_;
$why ||= '';
$self->_unoverload_str(\$why);
unless( $self->{Have_Plan} ) {
require Carp;
Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
}
lock($self->{Curr_Test});
$self->{Curr_Test}++;
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
'ok' => 1,
actual_ok => 1,
name => '',
type => 'skip',
reason => $why,
});
my $out = "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # skip";
$out .= " $why" if length $why;
$out .= "\n";
$self->_print($out);
return 1;
}
=item B<todo_skip>
$Test->todo_skip;
$Test->todo_skip($why);
Like skip(), only it will declare the test as failing and TODO. Similar
to
print "not ok $tnum # TODO $why\n";
=cut
sub todo_skip {
my($self, $why) = @_;
$why ||= '';
unless( $self->{Have_Plan} ) {
require Carp;
Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
}
lock($self->{Curr_Test});
$self->{Curr_Test}++;
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
'ok' => 1,
actual_ok => 0,
name => '',
type => 'todo_skip',
reason => $why,
});
my $out = "not ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # TODO & SKIP $why\n";
$self->_print($out);
return 1;
}
=begin _unimplemented
=item B<skip_rest>
$Test->skip_rest;
$Test->skip_rest($reason);
Like skip(), only it skips all the rest of the tests you plan to run
and terminates the test.
If you're running under no_plan, it skips once and terminates the
test.
=end _unimplemented
=back
=head2 Test style
=over 4
=item B<level>
$Test->level($how_high);
How far up the call stack should $Test look when reporting where the
test failed.
Defaults to 1.
Setting $Test::Builder::Level overrides. This is typically useful
localized:
{
local $Test::Builder::Level = 2;
$Test->ok($test);
}
=cut
sub level {
my($self, $level) = @_;
if( defined $level ) {
$Level = $level;
}
return $Level;
}
=item B<use_numbers>
$Test->use_numbers($on_or_off);
Whether or not the test should output numbers. That is, this if true:
ok 1
ok 2
ok 3
or this if false
ok
ok
ok
Most useful when you can't depend on the test output order, such as
when threads or forking is involved.
Test::Harness will accept either, but avoid mixing the two styles.
Defaults to on.
=cut
sub use_numbers {
my($self, $use_nums) = @_;
if( defined $use_nums ) {
$self->{Use_Nums} = $use_nums;
}
return $self->{Use_Nums};
}
=item B<no_diag>
$Test->no_diag($no_diag);
If set true no diagnostics will be printed. This includes calls to
diag().
=item B<no_ending>
$Test->no_ending($no_ending);
Normally, Test::Builder does some extra diagnostics when the test
ends. It also changes the exit code as described below.
If this is true, none of that will be done.
=item B<no_header>
$Test->no_header($no_header);
If set to true, no "1..N" header will be printed.
=cut
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
my $code = sub {
my($self, $no) = @_;
if( defined $no ) {
$self->{$attribute} = $no;
}
return $self->{$attribute};
};
no strict 'refs';
*{__PACKAGE__.'::'.$method} = $code;
}
=back
=head2 Output
Controlling where the test output goes.
It's ok for your test to change where STDOUT and STDERR point to,
Test::Builder's default output settings will not be affected.
=over 4
=item B<diag>
$Test->diag(@msgs);
Prints out the given @msgs. Like C<print>, arguments are simply
appended together.
Normally, it uses the failure_output() handle, but if this is for a
TODO test, the todo_output() handle is used.
Output will be indented and marked with a # so as not to interfere
with test output. A newline will be put on the end if there isn't one
already.
We encourage using this rather than calling print directly.
Returns false. Why? Because diag() is often used in conjunction with
a failing test (C<ok() || diag()>) it "passes through" the failure.
return ok(...) || diag(...);
=for blame transfer
Mark Fowler <mark@twoshortplanks.com>
=cut
sub diag {
my($self, @msgs) = @_;
return if $self->no_diag;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Smash args together like print does.
# Convert undef to 'undef' so its readable.
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
# Escape each line with a #.
$msg =~ s/^/# /gm;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
local $Level = $Level + 1;
$self->_print_diag($msg);
return 0;
}
=begin _private
=item B<_print>
$Test->_print(@msgs);
Prints to the output() filehandle.
=end _private
=cut
sub _print {
my($self, @msgs) = @_;
# Prevent printing headers when only compiling. Mostly for when
# tests are deparsed with B::Deparse
return if $^C;
my $msg = join '', @msgs;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->output;
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
$msg =~ s/\n(.)/\n# $1/sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
print $fh $msg;
}
=item B<_print_diag>
$Test->_print_diag(@msg);
Like _print, but prints to the current diagnostic filehandle.
=cut
sub _print_diag {
my $self = shift;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
print $fh @_;
}
=item B<output>
$Test->output($fh);
$Test->output($file);
Where normal "ok/not ok" test output should go.
Defaults to STDOUT.
=item B<failure_output>
$Test->failure_output($fh);
$Test->failure_output($file);
Where diagnostic output on test failures and diag() should go.
Defaults to STDERR.
=item B<todo_output>
$Test->todo_output($fh);
$Test->todo_output($file);
Where diagnostics about todo test failures and diag() should go.
Defaults to STDOUT.
=cut
sub output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Out_FH} = _new_fh($fh);
}
return $self->{Out_FH};
}
sub failure_output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Fail_FH} = _new_fh($fh);
}
return $self->{Fail_FH};
}
sub todo_output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Todo_FH} = _new_fh($fh);
}
return $self->{Todo_FH};
}
sub _new_fh {
my($file_or_fh) = shift;
my $fh;
if( _is_fh($file_or_fh) ) {
$fh = $file_or_fh;
}
else {
$fh = do { local *FH };
open $fh, ">$file_or_fh" or
die "Can't open test output log $file_or_fh: $!";
_autoflush($fh);
}
return $fh;
}
sub _is_fh {
my $maybe_fh = shift;
return 0 unless defined $maybe_fh;
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
# 5.5.4's tied() and can() doesn't like getting undef
UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
}
sub _autoflush {
my($fh) = shift;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
}
sub _dup_stdhandles {
my $self = shift;
$self->_open_testhandles;
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
_autoflush(\*TESTOUT);
_autoflush(\*STDOUT);
_autoflush(\*TESTERR);
_autoflush(\*STDERR);
$self->output(\*TESTOUT);
$self->failure_output(\*TESTERR);
$self->todo_output(\*TESTOUT);
}
my $Opened_Testhandles = 0;
sub _open_testhandles {
return if $Opened_Testhandles;
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
$Opened_Testhandles = 1;
}
=back
=head2 Test Status and Info
=over 4
=item B<current_test>
my $curr_test = $Test->current_test;
$Test->current_test($num);
Gets/sets the current test number we're on. You usually shouldn't
have to set this.
If set forward, the details of the missing tests are filled in as 'unknown'.
if set backward, the details of the intervening tests are deleted. You
can erase history if you really want to.
=cut
sub current_test {
my($self, $num) = @_;
lock($self->{Curr_Test});
if( defined $num ) {
unless( $self->{Have_Plan} ) {
require Carp;
Carp::croak("Can't change the current test number without a plan!");
}
$self->{Curr_Test} = $num;
# If the test counter is being pushed forward fill in the details.
my $test_results = $self->{Test_Results};
if( $num > @$test_results ) {
my $start = @$test_results ? @$test_results : 0;
for ($start..$num-1) {
$test_results->[$_] = &share({
'ok' => 1,
actual_ok => undef,
reason => 'incrementing test number',
type => 'unknown',
name => undef
});
}
}
# If backward, wipe history. Its their funeral.
elsif( $num < @$test_results ) {
$#{$test_results} = $num - 1;
}
}
return $self->{Curr_Test};
}
=item B<summary>
my @tests = $Test->summary;
A simple summary of the tests so far. True for pass, false for fail.
This is a logical pass/fail, so todos are passes.
Of course, test #1 is $tests[0], etc...
=cut
sub summary {
my($self) = shift;
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
=item B<details>
my @tests = $Test->details;
Like summary(), but with a lot more detail.
$tests[$test_num - 1] =
{ 'ok' => is the test considered a pass?
actual_ok => did it literally say 'ok'?
name => name of the test (if any)
type => type of test (if any, see below).
reason => reason for the above (if any)
};
'ok' is true if Test::Harness will consider the test to be a pass.
'actual_ok' is a reflection of whether or not the test literally
printed 'ok' or 'not ok'. This is for examining the result of 'todo'
tests.
'name' is the name of the test.
'type' indicates if it was a special test. Normal tests have a type
of ''. Type can be one of the following:
skip see skip()
todo see todo()
todo_skip see todo_skip()
unknown see below
Sometimes the Test::Builder test counter is incremented without it
printing any test output, for example, when current_test() is changed.
In these cases, Test::Builder doesn't know the result of the test, so
it's type is 'unkown'. These details for these tests are filled in.
They are considered ok, but the name and actual_ok is left undef.
For example "not ok 23 - hole count # TODO insufficient donuts" would
result in this structure:
$tests[22] = # 23 - 1, since arrays start from 0.
{ ok => 1, # logically, the test passed since it's todo
actual_ok => 0, # in absolute terms, it failed
name => 'hole count',
type => 'todo',
reason => 'insufficient donuts'
};
=cut
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
=item B<todo>
my $todo_reason = $Test->todo;
my $todo_reason = $Test->todo($pack);
todo() looks for a $TODO variable in your tests. If set, all tests
will be considered 'todo' (see Test::More and Test::Harness for
details). Returns the reason (ie. the value of $TODO) if running as
todo tests, false otherwise.
todo() is about finding the right package to look for $TODO in. It
uses the exported_to() package to find it. If that's not set, it's
pretty good at guessing the right package to look at based on $Level.
Sometimes there is some confusion about where todo() should be looking
for the $TODO variable. If you want to be sure, tell it explicitly
what $pack to use.
=cut
sub todo {
my($self, $pack) = @_;
$pack = $pack || $self->exported_to || $self->caller($Level);
return 0 unless $pack;
no strict 'refs';
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
=item B<caller>
my $package = $Test->caller;
my($pack, $file, $line) = $Test->caller;
my($pack, $file, $line) = $Test->caller($height);
Like the normal caller(), except it reports according to your level().
=cut
sub caller {
my($self, $height) = @_;
$height ||= 0;
my @caller = CORE::caller($self->level + $height + 1);
return wantarray ? @caller : $caller[0];
}
=back
=cut
=begin _private
=over 4
=item B<_sanity_check>
$self->_sanity_check();
Runs a bunch of end of test sanity checks to make sure reality came
through ok. If anything is wrong it will die with a fairly friendly
error message.
=cut
#'#
sub _sanity_check {
my $self = shift;
_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
'Somehow your tests ran without a plan!');
_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
'Somehow you got a different number of results than tests ran!');
}
=item B<_whoa>
_whoa($check, $description);
A sanity check, similar to assert(). If the $check is true, something
has gone horribly wrong. It will die with the given $description and
a note to contact the author.
=cut
sub _whoa {
my($check, $desc) = @_;
if( $check ) {
die <<WHOA;
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
=item B<_my_exit>
_my_exit($exit_num);
Perl seems to have some trouble with exiting inside an END block. 5.005_03
and 5.6.1 both seem to do odd things. Instead, this function edits $?
directly. It should ONLY be called from inside an END block. It
doesn't actually exit, that's your job.
=cut
sub _my_exit {
$? = $_[0];
return 1;
}
=back
=end _private
=cut
$SIG{__DIE__} = sub {
# We don't want to muck with death in an eval, but $^S isn't
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
# with it. Instead, we use caller. This also means it runs under
# 5.004!
my $in_eval = 0;
for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
$in_eval = 1 if $sub =~ /^\(eval\)/;
}
$Test->{Test_Died} = 1 unless $in_eval;
};
sub _ending {
my $self = shift;
$self->_sanity_check();
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
# Exit if plan() was never called. This is so "require Test::Simple"
# doesn't puke.
# Don't do an ending if we bailed out.
if( ($self->{Original_Pid} != $$) or
(!$self->{Have_Plan} && !$self->{Test_Died}) or
$self->{Bailed_Out}
)
{
_my_exit($?);
return;
}
# Figure out if we passed or failed and print helpful messages.
my $test_results = $self->{Test_Results};
if( @$test_results ) {
# The plan? We have no plan.
if( $self->{No_Plan} ) {
$self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
$self->{Expected_Tests} = $self->{Curr_Test};
}
# Auto-extended arrays and elements which aren't explicitly
# filled in with a shared reference will puke under 5.8.0
# ithreads. So we have to fill them in by hand. :(
my $empty_result = &share({});
for my $idx ( 0..$self->{Expected_Tests}-1 ) {
$test_results->[$idx] = $empty_result
unless defined $test_results->[$idx];
}
my $num_failed = grep !$_->{'ok'},
@{$test_results}[0..$self->{Curr_Test}-1];
my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
if( $num_extra < 0 ) {
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
$self->diag(<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
FAIL
}
elsif( $num_extra > 0 ) {
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
$self->diag(<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
FAIL
}
if ( $num_failed ) {
my $num_tests = $self->{Curr_Test};
my $s = $num_failed == 1 ? '' : 's';
my $qualifier = $num_extra == 0 ? '' : ' run';
$self->diag(<<"FAIL");
Looks like you failed $num_failed test$s of $num_tests$qualifier.
FAIL
}
if( $self->{Test_Died} ) {
$self->diag(<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
_my_exit( 255 ) && return;
}
my $exit_code;
if( $num_failed ) {
$exit_code = $num_failed <= 254 ? $num_failed : 254;
}
elsif( $num_extra != 0 ) {
$exit_code = 255;
}
else {
$exit_code = 0;
}
_my_exit( $exit_code ) && return;
}
elsif ( $self->{Skip_All} ) {
_my_exit( 0 ) && return;
}
elsif ( $self->{Test_Died} ) {
$self->diag(<<'FAIL');
Looks like your test died before it could output anything.
FAIL
_my_exit( 255 ) && return;
}
else {
$self->diag("No tests run!\n");
_my_exit( 255 ) && return;
}
}
END {
$Test->_ending if defined $Test and !$Test->no_ending;
}
=head1 EXIT CODES
If all your tests passed, Test::Builder will exit with zero (which is
normal). If anything failed it will exit with how many failed. If
you run less (or more) tests than you planned, the missing (or extras)
will be considered failures. If no tests were ever run Test::Builder
will throw a warning and exit with 255. If the test died, even after
having successfully completed all its tests, it will still be
considered a failure and will exit with 255.
So the exit codes are...
0 all tests successful
255 test died or all passed but wrong # of tests run
any other number how many failed (including missing or extras)
If you fail more than 254 tests, it will be reported as 254.
=head1 THREADS
In perl 5.8.0 and later, Test::Builder is thread-safe. The test
number is shared amongst all threads. This means if one thread sets
the test number using current_test() they will all be effected.
Test::Builder is only thread-aware if threads.pm is loaded I<before>
Test::Builder.
=head1 EXAMPLES
CPAN can provide the best examples. Test::Simple, Test::More,
Test::Exception and Test::Differences all use Test::Builder.
=head1 SEE ALSO
Test::Simple, Test::More, Test::Harness
=head1 AUTHORS
Original code by chromatic, maintained by Michael G Schwern
E<lt>schwern@pobox.comE<gt>
=head1 COPYRIGHT
Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
Michael G Schwern E<lt>schwern@pobox.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://www.perl.com/perl/misc/Artistic.html>
=cut
1;
Raw
can_write_dir.t
#!/usr/bin/perl -w
# Test the private _can_write_dir() function.
use strict;
use ExtUtils::Install;
use File::Spec;
{ package FS; our @ISA = qw(File::Spec); }
# Alias it for easier access
*can_write_dir = \&ExtUtils::Install::_can_write_dir;
use Test::More 'no_plan';
my $dne = FS->catdir(qw(does not exist));
ok ! -e $dne;
is_deeply [can_write_dir($dne)],
[1,
FS->curdir,
FS->catdir('does'),
FS->catdir('does', 'not'),
FS->catdir('does', 'not', 'exist')
];
my $abs_dne = FS->rel2abs($dne);
ok ! -e $abs_dne;
is_deeply [can_write_dir($abs_dne)],
[1,
FS->rel2abs(FS->curdir),
FS->rel2abs(FS->catdir('does')),
FS->rel2abs(FS->catdir('does', 'not')),
FS->rel2abs(FS->catdir('does', 'not', 'exist')),
];
SKIP: {
my $exists = FS->catdir(qw(exists));
my $subdir = FS->catdir(qw(exists subdir));
ok mkdir $exists;
END { rmdir $exists }
ok chmod 0555, $exists, 'make read only';
skip "Current user or OS cannot create directories that they cannot read", 6
if -w $exists; # these tests require a directory we cant read
is_deeply [can_write_dir($exists)], [0, $exists];
is_deeply [can_write_dir($subdir)], [0, $exists, $subdir];
ok chmod 0777, $exists, 'make writable';
ok -w $exists;
is_deeply [can_write_dir($exists)], [1, $exists];
is_deeply [can_write_dir($subdir)],
[1,
$exists,
$subdir
];
}
Raw
Changes
Revision history for ExtUtils-Install
1.54
This is a "no-change" version bump because I pushed the v1.53 change
and then realized that MakeMaker.t was a bad name for a file that would
end up in core where the EUMM tests and the EUI tests are in the same
directory. This renames it to InstallWithMM.t.
1.53
Final stage of the divorce from EUMM. Now the EUMM related tests are no
longer shared. Build.pl and Build.t go, and there shall be peace on earth.
At least until somebody patches EUMM/t/basic.t for something EUI related...
Thanks to M. Schwern for helping me work this one out. Cheers man.
1.52_03
Missed the t/Installed.t test from core. Bumped version number to allow
a new distro to be released.
1.52_02
Make _chmod verbose message use octal modes, thanks to BDFOY
Further changes from core, including lastest test file infrastructure
from EUMM.
Fixed a number of problems in ExtUtils::Installed, for various reasons
this includes a version bump to 1.999_001, which will eventually become
version 2.0. These problems related to finding modules that were installed
with either INSTALL_BASE or PREFIX. Hopefully this resolves these issues.
1.52_01 (core only release)
Changes from Core:
commit 3d55b451d9544fbd4c27c33287b76bee30328830
Author: John Malmberg
Date: Sun Feb 15 09:25:10 2009 -0600
ExtUtils::Install VMS extended character set support
Preview from https://rt.cpan.org/Ticket/Display.html?id=42149
1.52
Production rerelease of 1.51 to make the CPAN indexer happy about permissions
(hopefully).
SVN Revision 44.
1.51
Production release of 1.50_05. No other changes.
SVN revision 43.
1.50_05
SVN revision 42.
Fix broken test as reported by Craig Berry.
1.50_04
SVN revision 41.
Restructure tests to make it easier to maintain given it is distributed in various
ways in three different packages.
1.50_03
SVN revision 40.
Sigh, just after i released 1.50_02 I noticed that a test modified in it will fail
under VMS. So this is a fixup release for that alone.
1.50_02
SVN revision 39.
Synchronize with the changes that were made in blead perl
patch #33567. VMS changes by Craig Berry. See
http://public.activestate.com/cgi-bin/perlbrowse/p/33567
This was marked in the pod as 1.51 but not actually version bumped.
So I've marked it as 1.50_02 as a test release prior to putting it out
as the real 1.51
This release also restores the missing installed.t which was accidentally
missed by the MANIFEST having a duplicate entry for install.t instead.
Probably something should have warned about this, but I haven't worked out
what.
Includes changes from Activestate/ActivePerl:
- To make installation less chatty when not under verbose mode. See
http://rt.cpan.org/Public/Bug/Display.html?id=5903
- To install HTML documentation files under builds that set $Config{installhtmldir}
(and presumably also create HTML versions of the pod -- which is quite nice actually :-)
http://rt.cpan.org/Ticket/Display.html?id=37727
1.50_01
Version only released as part of bleadperl added in revision #33566.
Cygwin related changes by Steve Hay, and others, see
http://public.activestate.com/cgi-bin/perlbrowse/p/33566
and discussion at
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-03/msg00056.html
1.50
Previous patches to _have_write_access() were causing problems
on Cygwin. So now we skip using POSIX::access under cygwin.
Also added some =pod directives to make my favorite editor
highlight the pod properly.
1.49
Turns out that the new can_write_dir.t doesnt work properly under root
as root can read the files regardless as to their mode. So we skip those
tests when the effective UID is 0 indicating root.
1.48
We were getting N/A test results from CPAN testers due to the
presence of Config in the prequisities list. This has been corrected.
Also it was pointed out that EU_ALWAYS_COPY did not follow the naming
convention of other ExtUtils::Install environment variables. It has
been renamed EU_INSTALL_ALWAYS_COPY. Support remains for the original
deprecated environment variable but it will be removed in 1.50.
1.47
Fix build process so a new META.YML is produced each time. Also
add support for a new argument syntax to install() as well as
support for always copying installed files even when the old
file was identical. This is needed for some bundling mechanisms
and can be activated by setting the environment variable EU_ALWAYS_COPY
before the install process starts.
Add a newer cleaner interface to install() to allow named parameters
and easier external monitoring of what transpired.
1.46 2008-03-01 12:42:35
Apply patches from Michael G. Schwern (rt #33688, rt #31429, rt #31248)
and from Slaven Rezic (rt #33290). Also implemented the suggestion from
Schwern about not dieing when failing to remove a shadow file that is
later on in INC than the installed version. (rt #2928)
1.45 2008-02-27 13:55:27
Fix rt.cpan.org #32813, use catpath() to attach volume name
to dirs in _can_write_dir() when necessary to avoid cygwin
builds doing a hostname lookup.
1.44 2007-09-09 23:12:25
by Schwern
*** MAJOR BUG FIX ***
install() would always try to uninstall different versions of the
installed files when $uninstall_shadows was given whether it was true or false.
This meant "make install" and "Build install" would both always try to uninstall
differing versions of the modules. [rt.cpan.org 28672]
1.43 2007-07-21 00:09:24
Turns out some recent version, I haven't figured out which, causes
ExtUtils::MakeMaker to fail test. The failure is actually bogus, EUMM
is testing for output that we stopped producing except under verbose,
however it is a pain, so this release fixes the problem. It also adds
a new test file, a stripped down version of ExtUtils::MakeMakers
t/basic.t.
1.42 2007-07-20 22:43:04
This is just 1.41_04 as a production release.
1.41_04 2007-07-07 16:52:40
Reorganize how things work in Install so that we don't try to create
directories which exist but are not writable to us when they contain
files which we want to install which are writable by us.
http://rt.cpan.org/Public/Bug/Display.html?id=25627
Also fix a VMS issue as recommended by Craig Berry.
http://rt.cpan.org/Public/Bug/Display.html?id=22157
1.41_03 2007-02-11 15:13
Add an extra_libs parameter to ExtUtils::Installed->new() which allows
one to specify additional libs to search for installed modules.
Additional code cleanup and tweaks.
1.41_02 2007-02-03 21:10
Fix bug in _can_write_file().
1.41_01 2007-02-02 21:03
Integrated changes from
1. Steffen Mueller: make ExtUtils::Installed respect PERL5LIB and allow
overriding the current config and inc with something else.
2. Michael Schwern (RT#21949, RT#21948): Fix use lib and installdirs
and other EU::MakeMaker related changes.
3. ActiveState (RT#5903): Reduce install verbosity.
4. Craig Berry (RT#22157): Fix VMS related install failure.
5. Ken Williams (RT#16225): Make fake uninstall actually fake.
1.41 2006-07-02 16:09
Integrated ExtUtils::Packlist changes from Nicholas Clark to allow for
relocatable perls. Bumped version numbers on all files.
1.40 2006-04-30 15:04
Enhanced errorcatching and reporting. Fixed a problem with the INSTALL.SKIP
file. Changed the Makefile.PL so that when installing it would not use the same
stuff it was replacing. This doesn't affect building with Module::Build
currently.
Removed META.yml from distribution.
1.39 2006-04-14 18:53
- Fixed problem with the META.yml file being produced from a Win32 point of view.
IMO this is an error/failing in the design of the META.yml process. META.yml should
be created on the client side not on the distributor side. Now produces a
platform agnostic (ie UNIXy) META.yml.
- Reversed order of change file so newest entries go on top.
1.38 2006-04-02 17:31
- Removed MANIFEST.SKIP support (INSTALL.SKIP still supported), and
added support for providing a fallback skip file by using
ENV{EU_INSTALL_SITE_SKIP} as a fallback if there is not a distribution
specific skip file.
- Released under the ExtUtils-Install-1.38 Name
1.3702 2006-03-19 16:54
- Added support for skipping files during install based on a set of filter
rules. If there is an INSTALL.SKIP in the current directory when doing an
install then it is loaded, otherwise if there is a MANIFEST.SKIP then it is
loaded. If neither exists then no filtration occurs. The env variable
EU_INSTALL_IGNORE_SKIP may be set to a true value to override this behaviour.
This means that you can make .svn directories be ignored on install.
1.3701 2006-03-13 20:00
- Integrated patch from Randy Sims.
1. Fixes error during `perl Makefile.PL` because it MakeMaker can't
find the NAME section describing DISTNAME (which has the 'ex-'
prefix).
2. Win32API::File is recommended on MSWin32 && cygwin.
3. Under Perl5.005, ExtUtils::MM is not present in the version of
MakeMaker included. I don't know what version first includes it.
Needs research or better: eliminate need for it.
4. Test::More is bundled with the distro for its test suite. This
would be needed on Perl5.005, for example. It was listed as a
requirement, but the directory it's bundled in is not in @INC when
prereqs are checked. I removed the prereq from Build.PL &
Makefile.PL. Other options: 1) fixup @INC to include t/lib; or 2)
unbundle and add back to prereqs.
4. Update t/pod.t t/pod-coverage fixup of @INC so it can find
bundled Test::More.
- Fixed pod/coverage related issues.
- When trying to schedule a delete at reboot after renaming a dll out of
the way no error occurs if Win32API::File isn't available. Instead it
merely warns that the file should be hand deleted.
- Fixed install at reboot behaviour by making sure the temporar file is
writable after install (normally files installed are readonly)
1.37 2006-03-12 23:20
- Refactored reboot support. Integrated changes from Randy Sims
in p5p message 4413F4E9.7090802@thepierianspring.org
1.36 2006-03-11 12:42
- Extended Win32 support. Added ExtUtils::Install::MUST_REBOOT to
handle such scenario when rebooting.
- Released as ex-ExtUtils-Install by demerphq
1.35 Wed Feb 1 23:00:00 CST 2006
- First independent release; Extracted ExtUtils::Install,
ExtUtils::Installed, & ExtUtils::Packlist from MakeMaker.
- Changed the $VERSION of all modules to the same version number, a
number higher than all $VERSIONs.
Raw
EU-I.txt
I said ExtUtils::Installed does a lot of I/O, when I read the source.
Then I ran it, in a ballpark sort of way. PERL5LIB includes some
small NFS trees.
OS (Debian Lenny) Perl on local spinny disk, ~1.5 sec
Large local Perl install used by many project groups, on NFS
(533 packlists, 17k files mentioned; /software/perl-5.12.2 )
with a cold-ish cache, 5m 48s
with a hot cache, ~16s
'strace -c -tt -T -vx' for a later hotcache NFS run
% time seconds usecs/call calls errors syscall
------ ----------- ----------- --------- --------- ----------------
30.62 0.051497 1 51239 chdir
29.75 0.050034 1 38215 lstat64
29.07 0.048884 2 30843 44 open
5.06 0.008503 0 59720 getdents64
4.08 0.006857 1 11372 10383 stat64
0.79 0.001322 0 30799 close
0.49 0.000831 0 30756 fstat64
Noting also, on the strace'd run,
getdents64 tells which elements are directories, but we lstat anyway
File::Find might be faster without the chdir? Or maybe opendir would
be slower without.
9.97s lstat64
9.54s open,O_DIRECTORY (96.8% of all open calls)
9.26s chdir
2.24s getdents64
0.53s open file
Raw
EUIDummy.pm
package # junk package
EUIDummy;
1;
Raw
Install.pm
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.54
=cut
$VERSION = '1.54'; # <---- 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.
=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.
=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
=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.
=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 succesful. 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 procede.");
}
}
=pod
=head2 Functions
=begin _private
=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 dignostics 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
=over 4
=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 doesnt 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
occuring 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;
Raw
INSTALL.SKIP
# Avoid version control files.
\bRCS\b
\bCVS\b
\bSCCS\b
,v$
\B\.svn\b
\b_darcs\b
\.git
# Avoid temp and backup files.
~$
\.old$
\#$
\b\.#
\.bak$
\.tmp$
\.orig$
# Avoid Devel::Cover files.
\bcover_db\b
Raw
Install.t
#!/usr/bin/perl -w
# Test ExtUtils::Install.
BEGIN {
if( $ENV{PERL_CORE} ) {
@INC = ('../../lib', '../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
use strict;
use TieOut;
use File::Path;
use File::Spec;
use Test::More tests => 52;
use MakeMaker::Test::Setup::BFD;
BEGIN { use_ok('ExtUtils::Install') }
# ensure the env doesnt pollute our tests
local $ENV{EU_INSTALL_ALWAYS_COPY};
local $ENV{EU_ALWAYS_COPY};
# Check exports.
foreach my $func (qw(install uninstall pm_to_blib install_default)) {
can_ok(__PACKAGE__, $func);
}
ok( setup_recurs(), 'setup' );
END {
ok( chdir File::Spec->updir );
ok( teardown_recurs(), 'teardown' );
}
chdir 'Big-Dummy';
my $stdout = tie *STDOUT, 'TieOut';
pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
'blib/lib/auto'
);
END { rmtree 'blib' }
ok( -d 'blib/lib', 'pm_to_blib created blib dir' );
ok( -r 'blib/lib/Big/Dummy.pm', ' copied .pm file' );
ok( -r 'blib/lib/auto', ' created autosplit dir' );
is( $stdout->read, "cp lib/Big/Dummy.pm blib/lib/Big/Dummy.pm\n" );
pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
'blib/lib/auto'
);
ok( -d 'blib/lib', 'second run, blib dir still there' );
ok( -r 'blib/lib/Big/Dummy.pm', ' .pm file still there' );
ok( -r 'blib/lib/auto', ' autosplit still there' );
is( $stdout->read, "Skip blib/lib/Big/Dummy.pm (unchanged)\n" );
install( { 'blib/lib' => 'install-test/lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},
0, 1);
ok( ! -d 'install-test/lib/perl', 'install made dir (dry run)');
ok( ! -r 'install-test/lib/perl/Big/Dummy.pm',
' .pm file installed (dry run)');
ok( ! -r 'install-test/packlist', ' packlist exists (dry run)');
install( { 'blib/lib' => 'install-test/lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
} );
ok( -d 'install-test/lib/perl', 'install made dir' );
ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok(!-r 'install-test/lib/perl/Big/Dummy.SKIP', ' ignored .SKIP file' );
ok( -r 'install-test/packlist', ' packlist exists' );
open(PACKLIST, 'install-test/packlist' );
my %packlist = map { chomp; ($_ => 1) } <PACKLIST>;
close PACKLIST;
# On case-insensitive filesystems (ie. VMS), the keys of the packlist might
# be lowercase. :(
my $native_dummy = File::Spec->catfile(qw(install-test lib perl Big Dummy.pm));
is( keys %packlist, 1 );
is( lc((keys %packlist)[0]), lc $native_dummy, 'packlist written' );
# Test UNINST=1 preserving same versions in other dirs.
install( { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},
0, 0, 1);
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' UNINST=1 preserved same' );
chmod 0644, 'blib/lib/Big/Dummy.pm' or die $!;
open(DUMMY, ">>blib/lib/Big/Dummy.pm") or die $!;
print DUMMY "Extra stuff\n";
close DUMMY;
# Test UNINST=0 does not remove other versions in other dirs.
{
ok( -r 'install-test/lib/perl/Big/Dummy.pm', 'different install exists' );
local @INC = ('install-test/lib/perl');
local $ENV{PERL5LIB} = '';
install( { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},
0, 0, 0);
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( -r 'install-test/lib/perl/Big/Dummy.pm',
' UNINST=0 left different' );
}
# Test UNINST=1 only warning when failing to remove an irrelevent shadow file
{
my $tfile='install-test/lib/perl/Big/Dummy.pm';
local $ExtUtils::Install::Testing = $tfile;
local @INC = ('install-test/other_lib/perl','install-test/lib/perl');
local $ENV{PERL5LIB} = '';
ok( -r $tfile, 'different install exists' );
my @warn;
local $SIG{__WARN__}=sub { push @warn, @_; return };
my $ok=eval {
install( { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},
0, 0, 1);
1
};
ok($ok,' we didnt die');
ok(0+@warn," we did warn");
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( -r $tfile, ' UNINST=1 failed to remove different' );
}
# Test UNINST=1 dieing when failing to remove an relevent shadow file
{
my $tfile='install-test/lib/perl/Big/Dummy.pm';
local $ExtUtils::Install::Testing = $tfile;
local @INC = ('install-test/lib/perl','install-test/other_lib/perl');
local $ENV{PERL5LIB} = '';
ok( -r $tfile, 'different install exists' );
my @warn;
local $SIG{__WARN__}=sub { push @warn,@_; return };
my $ok=eval {
install( { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},
0, 0, 1);
1
};
ok(!$ok,' we did die');
ok(!@warn," we didnt warn");
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( -r $tfile,' UNINST=1 failed to remove different' );
}
# Test UNINST=1 removing other versions in other dirs.
{
local @INC = ('install-test/lib/perl');
local $ENV{PERL5LIB} = '';
install( { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},
0, 0, 1);
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( !-r 'install-test/lib/perl/Big/Dummy.pm',
' UNINST=1 removed different' );
}
Raw
Installapi2.t
#!/usr/bin/perl -w
# Test ExtUtils::Install.
BEGIN {
if( $ENV{PERL_CORE} ) {
@INC = ('../../lib', '../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
use strict;
use TieOut;
use File::Path;
use File::Spec;
use Test::More tests => 70;
use MakeMaker::Test::Setup::BFD;
BEGIN { use_ok('ExtUtils::Install') }
# Check exports.
foreach my $func (qw(install uninstall pm_to_blib install_default)) {
can_ok(__PACKAGE__, $func);
}
ok( setup_recurs(), 'setup' );
END {
ok( chdir File::Spec->updir );
ok( teardown_recurs(), 'teardown' );
}
# ensure the env doesnt pollute our tests
local $ENV{EU_INSTALL_ALWAYS_COPY};
local $ENV{EU_ALWAYS_COPY};
chdir 'Big-Dummy';
my $stdout = tie *STDOUT, 'TieOut';
pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
'blib/lib/auto'
);
END { rmtree 'blib' }
ok( -d 'blib/lib', 'pm_to_blib created blib dir' );
ok( -r 'blib/lib/Big/Dummy.pm', ' copied .pm file' );
ok( -r 'blib/lib/auto', ' created autosplit dir' );
is( $stdout->read, "cp lib/Big/Dummy.pm blib/lib/Big/Dummy.pm\n" );
pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
'blib/lib/auto'
);
ok( -d 'blib/lib', 'second run, blib dir still there' );
ok( -r 'blib/lib/Big/Dummy.pm', ' .pm file still there' );
ok( -r 'blib/lib/auto', ' autosplit still there' );
is( $stdout->read, "Skip blib/lib/Big/Dummy.pm (unchanged)\n" );
install( [
from_to=>{ 'blib/lib' => 'install-test/lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},
dry_run=>1]);
ok( ! -d 'install-test/lib/perl', 'install made dir (dry run)');
ok( ! -r 'install-test/lib/perl/Big/Dummy.pm',
' .pm file installed (dry run)');
ok( ! -r 'install-test/packlist', ' packlist exists (dry run)');
install([ from_to=> { 'blib/lib' => 'install-test/lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
} ]);
ok( -d 'install-test/lib/perl', 'install made dir' );
ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok(!-r 'install-test/lib/perl/Big/Dummy.SKIP', ' ignored .SKIP file' );
ok( -r 'install-test/packlist', ' packlist exists' );
open(PACKLIST, 'install-test/packlist' );
my %packlist = map { chomp; ($_ => 1) } <PACKLIST>;
close PACKLIST;
# On case-insensitive filesystems (ie. VMS), the keys of the packlist might
# be lowercase. :(
my $native_dummy = File::Spec->catfile(qw(install-test lib perl Big Dummy.pm));
is( keys %packlist, 1 );
is( lc((keys %packlist)[0]), lc $native_dummy, 'packlist written' );
# Test UNINST=1 preserving same versions in other dirs.
install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},uninstall_shadows=>1]);
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' UNINST=1 preserved same' );
chmod 0644, 'blib/lib/Big/Dummy.pm' or die $!;
open(DUMMY, ">>blib/lib/Big/Dummy.pm") or die $!;
print DUMMY "Extra stuff\n";
close DUMMY;
# Test UNINST=0 does not remove other versions in other dirs.
{
ok( -r 'install-test/lib/perl/Big/Dummy.pm', 'different install exists' );
local @INC = ('install-test/lib/perl');
local $ENV{PERL5LIB} = '';
install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
}]);
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( -r 'install-test/lib/perl/Big/Dummy.pm',
' UNINST=0 left different' );
}
# Test UNINST=1 only warning when failing to remove an irrelevent shadow file
{
my $tfile='install-test/lib/perl/Big/Dummy.pm';
local $ExtUtils::Install::Testing = $tfile;
local @INC = ('install-test/other_lib/perl','install-test/lib/perl');
local $ENV{PERL5LIB} = '';
ok( -r $tfile, 'different install exists' );
my @warn;
local $SIG{__WARN__}=sub { push @warn, @_; return };
my $ok=eval {
install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},
uninstall_shadows=>1]);
1
};
ok($ok,' we didnt die');
ok(0+@warn," we did warn");
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( -r $tfile, ' UNINST=1 failed to remove different' );
}
# Test UNINST=1 dieing when failing to remove an relevent shadow file
{
my $tfile='install-test/lib/perl/Big/Dummy.pm';
local $ExtUtils::Install::Testing = $tfile;
local @INC = ('install-test/lib/perl','install-test/other_lib/perl');
local $ENV{PERL5LIB} = '';
ok( -r $tfile, 'different install exists' );
my @warn;
local $SIG{__WARN__}=sub { push @warn,@_; return };
my $ok=eval {
install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},uninstall_shadows=>1]);
1
};
ok(!$ok,' we did die');
ok(!@warn," we didnt warn");
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( -r $tfile,' UNINST=1 failed to remove different' );
}
# Test UNINST=1 removing other versions in other dirs.
{
local @INC = ('install-test/lib/perl');
local $ENV{PERL5LIB} = '';
ok( -r 'install-test/lib/perl/Big/Dummy.pm','different install exists' );
install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},uninstall_shadows=>1]);
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( !-r 'install-test/lib/perl/Big/Dummy.pm',
' UNINST=1 removed different' );
}
# Test EU_ALWAYS_COPY triggers copy.
{
local @INC = ('install-test/lib/perl');
local $ENV{PERL5LIB} = '';
local $ENV{EU_INSTALL_ALWAYS_COPY}=1;
my $tfile='install-test/other_lib/perl/Big/Dummy.pm';
my $sfile='blib/lib/Big/Dummy.pm';
ok(-r $tfile,"install file already exists");
ok(-r $sfile,"source file already exists");
utime time-600, time-600, $sfile or die "utime '$sfile' failed:$!";
ok( (stat $tfile)[9]!=(stat $sfile)[9],' Times are different');
install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},result=>\my %result]);
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
SKIP: {
skip "Times not preserved during copy by default", 1 if $^O eq 'VMS';
ok( (stat $tfile)[9]==(stat $sfile)[9],' Times are same');
}
ok( !$result{install_unchanged},' $result{install_unchanged} should be empty');
}
# Test nothing is copied.
{
local @INC = ('install-test/lib/perl');
local $ENV{PERL5LIB} = '';
local $ENV{EU_INSTALL_ALWAYS_COPY}=0;
my $tfile='install-test/other_lib/perl/Big/Dummy.pm';
my $sfile='blib/lib/Big/Dummy.pm';
ok(-r $tfile,"install file already exists");
ok(-r $sfile,"source file already exists");
utime time-1200, time-1200, $sfile or die "utime '$sfile' failed:$!";
ok( (stat $tfile)[9]!=(stat $sfile)[9],' Times are different');
install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
read => 'install-test/packlist',
write => 'install-test/packlist'
},result=>\my %result]);
ok( -d 'install-test/other_lib/perl', 'install made other dir' );
ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
ok( -r 'install-test/packlist', ' packlist exists' );
ok( (stat $tfile)[9]!=(stat$sfile)[9],' Times are different');
ok( !$result{install},' nothing should have been installed');
ok( $result{install_unchanged},' install_unchanged should be populated');
}
Raw
Installed-relpath.t
#! perl
use strict;
use warnings;
END { show_debug() if $? && $ENV{SHOW_DEBUG} }
my $workaround = $ENV{WORKAROUND};
use Test::More tests => 4;
use ExtUtils::Installed;
use lib 't/tlib';
require_ok('EUIDummy'); # see that t/tlib works
my $incele = $INC[0];
if ($workaround) {
require Cwd;
require File::Spec;
$incele = File::Spec->catfile(Cwd::cwd(), $incele);
}
# scan only first element, lest it take minutes
my $eui = ExtUtils::Installed->new(inc_override => [ $incele ]);
my $pl = $eui->packlist('EUIDummy');
isa_ok($pl, 'ExtUtils::Packlist');
is(1, scalar keys %$pl, 'one .packlist entry');
my ($only) = keys %$pl;
$only = '(undef)' if !defined $only;
like($only, qr{/EUIDummy\.pm$}, 'lists our module');
sub show_debug {
require YAML;
diag YAML::Dump({ eui => $eui, eui_version => $ExtUtils::Installed::VERSION });
}
Raw
Installed.pm
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.999_002';
$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 { -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
my (undef, undef, $file) = File::Spec->splitpath($File::Find::name);
return if $file 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({ wanted => $sub, no_chdir => 1 }, $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();
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<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
Raw
Installed.t
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't' if -d 't';
@INC = '../lib';
}
else {
unshift @INC, 't/lib/';
}
}
chdir 't';
my $Is_VMS = $^O eq 'VMS';
use strict;
use Config;
use Cwd;
use File::Path;
use File::Basename;
use File::Spec;
use Test::More tests => 63;
BEGIN { use_ok( 'ExtUtils::Installed' ) }
my $mandirs = !!$Config{man1direxp} + !!$Config{man3direxp};
# saves having to qualify package name for class methods
my $ei = bless( {}, 'ExtUtils::Installed' );
# Make sure meta info is available
$ei->{':private:'}{Config} = \%Config;
$ei->{':private:'}{INC} = \@INC;
# _is_prefix
ok( $ei->_is_prefix('foo/bar', 'foo'),
'_is_prefix() should match valid path prefix' );
ok( !$ei->_is_prefix('\foo\bar', '\bar'),
'... should not match wrong prefix' );
# _is_type
ok( $ei->_is_type(0, 'all'), '_is_type() should be true for type of "all"' );
foreach my $path (qw( man1dir man3dir )) {
SKIP: {
my $dir = File::Spec->canonpath($Config{$path.'exp'});
skip("no man directory $path on this system", 2 ) unless $dir;
my $file = $dir . '/foo';
ok( $ei->_is_type($file, 'doc'), "... should find doc file in $path" );
ok( !$ei->_is_type($file, 'prog'), "... but not prog file in $path" );
}
}
# VMS 5.6.1 doesn't seem to have $Config{prefixexp}
my $prefix = $Config{prefix} || $Config{prefixexp};
# You can concatenate /foo but not foo:, which defaults in the current
# directory
$prefix = VMS::Filespec::unixify($prefix) if $Is_VMS;
# ActivePerl 5.6.1/631 has $Config{prefixexp} as 'p:' for some reason
$prefix = $Config{prefix} if $prefix eq 'p:' && $^O eq 'MSWin32';
ok( $ei->_is_type( File::Spec->catfile($prefix, 'bar'), 'prog'),
"... should find prog file under $prefix" );
SKIP: {
skip('no man directories on this system', 1) unless $mandirs;
is( $ei->_is_type('bar', 'doc'), 0,
'... should not find doc file outside path' );
}
ok( !$ei->_is_type('bar', 'prog'),
'... nor prog file outside path' );
ok( !$ei->_is_type('whocares', 'someother'), '... nor other type anywhere' );
# _is_under
ok( $ei->_is_under('foo'), '_is_under() should return true with no dirs' );
my @under = qw( boo bar baz );
ok( !$ei->_is_under('foo', @under), '... should find no file not under dirs');
ok( $ei->_is_under('baz', @under), '... should find file under dir' );
rmtree 'auto/FakeMod';
ok( mkpath('auto/FakeMod') );
END { rmtree 'auto' }
ok(open(PACKLIST, '>auto/FakeMod/.packlist'));
print PACKLIST 'list';
close PACKLIST;
ok(open(FAKEMOD, '>auto/FakeMod/FakeMod.pm'));
print FAKEMOD <<'FAKE';
package FakeMod;
use vars qw( $VERSION );
$VERSION = '1.1.1';
1;
FAKE
close FAKEMOD;
my $fake_mod_dir = File::Spec->catdir(cwd(), 'auto', 'FakeMod');
{
# avoid warning and death by localizing glob
local *ExtUtils::Installed::Config;
%ExtUtils::Installed::Config = (
%Config,
archlibexp => cwd(),
sitearchexp => $fake_mod_dir,
);
# necessary to fool new()
push @INC, $fake_mod_dir;
my $realei = ExtUtils::Installed->new();
isa_ok( $realei, 'ExtUtils::Installed' );
isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
is( $realei->{Perl}{version}, $Config{version},
'new() should set Perl version from %Config' );
ok( exists $realei->{FakeMod}, 'new() should find modules with .packlists');
isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
is( $realei->{FakeMod}{version}, '1.1.1',
'... should find version in modules' );
}
# Now try this using PERL5LIB
{
local $ENV{PERL5LIB} = join $Config{path_sep}, $fake_mod_dir;
local *ExtUtils::Installed::Config;
%ExtUtils::Installed::Config = (
%Config,
archlibexp => cwd(),
sitearchexp => cwd(),
);
my $realei = ExtUtils::Installed->new();
isa_ok( $realei, 'ExtUtils::Installed' );
isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
is( $realei->{Perl}{version}, $Config{version},
'new() should set Perl version from %Config' );
ok( exists $realei->{FakeMod},
'new() should find modules with .packlists using PERL5LIB'
);
isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
is( $realei->{FakeMod}{version}, '1.1.1',
'... should find version in modules' );
}
# Do the same thing as the last block, but with overrides for
# %Config and @INC.
{
my $config_override = { %Config::Config };
$config_override->{archlibexp} = cwd();
$config_override->{sitearchexp} = $fake_mod_dir;
$config_override->{version} = 'fake_test_version';
my @inc_override = (@INC, $fake_mod_dir);
my $realei = ExtUtils::Installed->new(
'config_override' => $config_override,
'inc_override' => \@inc_override,
);
isa_ok( $realei, 'ExtUtils::Installed' );
isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
is( $realei->{Perl}{version}, 'fake_test_version',
'new(config_override => HASH) overrides %Config' );
ok( exists $realei->{FakeMod}, 'new() with overrides should find modules with .packlists');
isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
is( $realei->{FakeMod}{version}, '1.1.1',
'... should find version in modules' );
}
# Check if extra_libs works.
{
my $realei = ExtUtils::Installed->new(
'extra_libs' => [ cwd() ],
);
isa_ok( $realei, 'ExtUtils::Installed' );
isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
ok( exists $realei->{FakeMod},
'new() with extra_libs should find modules with .packlists');
#{ use Data::Dumper; local $realei->{':private:'}{Config};
# warn Dumper($realei); }
isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
is( $realei->{FakeMod}{version}, '1.1.1',
'... should find version in modules' );
}
# modules
$ei->{$_} = 1 for qw( abc def ghi );
is( join(' ', $ei->modules()), 'abc def ghi',
'modules() should return sorted keys' );
# This didn't work for a long time due to a sort in scalar context oddity.
is( $ei->modules, 3, 'modules() in scalar context' );
# files
$ei->{goodmod} = {
packlist => {
($Config{man1direxp} ?
(File::Spec->catdir($Config{man1direxp}, 'foo') => 1) :
()),
($Config{man3direxp} ?
(File::Spec->catdir($Config{man3direxp}, 'bar') => 1) :
()),
File::Spec->catdir($prefix, 'foobar') => 1,
foobaz => 1,
},
};
eval { $ei->files('badmod') };
like( $@, qr/badmod is not installed/,'files() should croak given bad modname');
eval { $ei->files('goodmod', 'badtype' ) };
like( $@, qr/type must be/,'files() should croak given bad type' );
my @files;
SKIP: {
skip('no man directory man1dir on this system', 2)
unless $Config{man1direxp};
@files = $ei->files('goodmod', 'doc', $Config{man1direxp});
is( scalar @files, 1, '... should find doc file under given dir' );
is( (grep { /foo$/ } @files), 1, '... checking file name' );
}
SKIP: {
skip('no man directories on this system', 1) unless $mandirs;
@files = $ei->files('goodmod', 'doc');
is( scalar @files, $mandirs, '... should find all doc files with no dir' );
}
@files = $ei->files('goodmod', 'prog', 'fake', 'fake2');
is( scalar @files, 0, '... should find no doc files given wrong dirs' );
@files = $ei->files('goodmod', 'prog');
is( scalar @files, 1, '... should find doc file in correct dir' );
like( $files[0], qr/foobar[>\]]?$/, '... checking file name' );
@files = $ei->files('goodmod');
is( scalar @files, 2 + $mandirs, '... should find all files with no type specified' );
my %dirnames = map { lc($_) => dirname($_) } @files;
# directories
my @dirs = $ei->directories('goodmod', 'prog', 'fake');
is( scalar @dirs, 0, 'directories() should return no dirs if no files found' );
SKIP: {
skip('no man directories on this system', 1) unless $mandirs;
@dirs = $ei->directories('goodmod', 'doc');
is( scalar @dirs, $mandirs, '... should find all files files() would' );
}
@dirs = $ei->directories('goodmod');
is( scalar @dirs, 2 + $mandirs, '... should find all files files() would, again' );
@files = sort map { exists $dirnames{lc($_)} ? $dirnames{lc($_)} : '' } @files;
is( join(' ', @files), join(' ', @dirs), '... should sort output' );
# directory_tree
my $expectdirs =
($mandirs == 2) &&
(dirname($Config{man1direxp}) eq dirname($Config{man3direxp}))
? 3 : 2;
SKIP: {
skip('no man directories on this system', 1) unless $mandirs;
@dirs = $ei->directory_tree('goodmod', 'doc', $Config{man1direxp} ?
dirname($Config{man1direxp}) : dirname($Config{man3direxp}));
is( scalar @dirs, $expectdirs,
'directory_tree() should report intermediate dirs to those requested' );
}
my $fakepak = Fakepak->new(102);
$ei->{yesmod} = {
version => 101,
packlist => $fakepak,
};
# these should all croak
foreach my $sub (qw( validate packlist version )) {
eval { $ei->$sub('nomod') };
like( $@, qr/nomod is not installed/,
"$sub() should croak when asked about uninstalled module" );
}
# validate
is( $ei->validate('yesmod'), 'validated',
'validate() should return results of packlist validate() call' );
# packlist
is( ${ $ei->packlist('yesmod') }, 102,
'packlist() should report installed mod packlist' );
# version
is( $ei->version('yesmod'), 101,
'version() should report installed mod version' );
package Fakepak;
sub new {
my $class = shift;
bless(\(my $scalar = shift), $class);
}
sub validate {
return 'validated'
}
Raw
InstallWithMM.t
#!/usr/bin/perl -w
# Make sure EUI works with MakeMaker
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't' if -d 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Config;
use ExtUtils::MakeMaker;
use Test::More tests => 15;
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
use File::Find;
use File::Spec;
use File::Path;
my $make = make_run();
# Environment variables which interfere with our testing.
delete @ENV{qw(PREFIX LIB MAKEFLAGS)};
# Run Makefile.PL
{
my $perl = which_perl();
my $Is_VMS = $^O eq 'VMS';
chdir 't';
perl_lib;
my $Touch_Time = calibrate_mtime();
$| = 1;
ok( setup_recurs(), 'setup' );
END {
ok( chdir File::Spec->updir );
ok( teardown_recurs(), 'teardown' );
}
ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
diag("chdir failed: $!");
my @mpl_out = run(qq{$perl Makefile.PL "PREFIX=../dummy-install"});
END { rmtree '../dummy-install'; }
cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
diag(@mpl_out);
END { unlink makefile_name(), makefile_backup() }
}
# make
{
my $make_out = run($make);
is( $?, 0, 'make ran ok' ) ||
diag($make_out);
}
# Test 'make install VERBINST=1'
{
my $make_install_verbinst = make_macro($make, 'install', VERBINST => 1);
my $install_out = run($make_install_verbinst);
is( $?, 0, 'install' ) || diag $install_out;
like( $install_out, qr/^Installing /m );
like( $install_out, qr/^Writing /m );
ok( -r '../dummy-install', ' install dir created' );
my %files = ();
find( sub {
# do it case-insensitive for non-case preserving OSs
my $file = lc $_;
# VMS likes to put dots on the end of things that don't have them.
$file =~ s/\.$// if $Is_VMS;
$files{$file} = $File::Find::name;
}, '../dummy-install' );
ok( $files{'dummy.pm'}, ' Dummy.pm installed' );
ok( $files{'liar.pm'}, ' Liar.pm installed' );
ok( $files{'program'}, ' program installed' );
ok( $files{'.packlist'}, ' packlist created' );
ok( $files{'perllocal.pod'},' perllocal.pod created' );
}
Raw
Makefile.PL
BEGIN { require 5.006; }
use strict;
use lib qw(lib); # use ourself if possible not the existing stuff.
# On Win32 things work better if Win32API::File is available.
# Activestate builds have it by default, but the core distro doesn't
# so we recommend it on Win32.
#
# * BUT *
#
# We can't recommend it on the release system as it then goes in the YAML.pl
# and then non-Win32 CPAN clients think they need it get upset when it fails
# to build on their system.
#
# Until CPAN and Module::Build and the other infrastructure has a better
# way to deal with this we assume UNIX when building a release.
#
# The pre-build stage will moan on Win32 anyway.
my $Recommend_Win32API_File = $ENV{USERNAME} ne 'demerphq'
&& ($^O eq 'MSWin32' || $^O eq 'cygwin');
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'ExtUtils::Install',
AUTHOR => 'demerphq <yves@cpan.org>',
VERSION_FROM => 'lib/ExtUtils/Install.pm',
ABSTRACT => 'install files from here to there',
# This causes failure to locate ABSTRACT with DISTNAME below set to different name
# ABSTRACT_FROM => 'lib/ExtUtils/Install.pm',
DISTNAME => 'ExtUtils-Install',
PL_FILES => {}, # Avoid auto extracting 'Build.PL'
PREREQ_PM => {
# 'vars' => 0,
# 'AutoSplit' => 0,
# 'Exporter' => 0,
'Carp' => 0,
# 'Config' => 0,
'Cwd' => 0,
'File::Basename' => 0,
'File::Compare' => 0,
'File::Copy' => 0,
'File::Find' => 0,
'File::Path' => 0,
'File::Spec' => 0,
($^O eq 'VMS' ? ('VMS::Filespec' => 0) : ()),
($Recommend_Win32API_File ? ('Win32API::File' => 0) : ()),
'ExtUtils::MakeMaker' => 0,
# 'Test::More' => 0, # This is bundled, but not in @INC for prereqs
},
INSTALLDIRS => 'perl', # install into site not into lib.
#NO_META => 1,
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => 'ExtUtils-Install-*' },
);
{
package MY;
my($lib);
BEGIN {
$lib = File::Spec->canonpath('lib/');
}
# Make sure PERLRUN uses the MakeMaker about to be installed
# and not the currently installed one.
sub init_PERL {
my($self) = shift;
$self->SUPER::init_PERL;
$self->{ABSPERLRUN} .= qq{ "-I$lib"};
$self->{PERLRUN} .= qq{ "-I$lib"};
$self->{FULLPERLRUN} .= qq{ "-I$lib"};
}
}
Raw
MANIFEST
Build.PL
Changes
INSTALL.SKIP
lib/ExtUtils/Install.pm
lib/ExtUtils/Installed.pm
lib/ExtUtils/Packlist.pm
Makefile.PL
MANIFEST
MANIFEST.SKIP
META.yml
README
t/can_write_dir.t
t/Install.t
t/Installapi2.t
t/Installed.t
t/lib/MakeMaker/Test/Setup/BFD.pm
t/lib/MakeMaker/Test/Utils.pm
t/lib/Test/Builder.pm
t/lib/Test/Builder/Module.pm
t/lib/Test/More.pm
t/lib/Test/Simple.pm
t/lib/TieOut.pm
t/InstallWithMM.t
t/Packlist.t
t/pod-coverage.t
t/pod.t
Raw
MANIFEST.SKIP
# Avoid version control files.
\bRCS\b
\bCVS\b
\bSCCS\b
,v$
\B\.svn\b
\b_darcs\b
\.git
make_from_core.sh
# Avoid Makemaker generated and utility files.
\bMANIFEST\.bak
\bMakefile$
\bblib\b
\bMakeMaker-\d
\bpm_to_blib\.ts$
\bpm_to_blib$
\.gz$
\bblibdirs\.ts$ # 6.18 through 6.25 generated this
# Avoid Module::Build generated and utility files.
\bBuild$
\b_build\b
# Avoid temp and backup files.
~$
\.old$
\#$
\b\.#
\.bak$
\.tmp$
# Avoid Devel::Cover files.
\bcover_db\b
Raw
META.yml
--- #YAML:1.0
name: ExtUtils-Install
version: 1.54
abstract: install files from here to there
license: ~
author:
- demerphq <yves@cpan.org>
generated_by: ExtUtils::MakeMaker version 6.42
distribution_type: module
requires:
Carp: 0
Cwd: 0
ExtUtils::MakeMaker: 0
File::Basename: 0
File::Compare: 0
File::Copy: 0
File::Find: 0
File::Path: 0
File::Spec: 0
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
version: 1.3
Raw
Module.pm
package Test::Builder::Module;
use Test::Builder;
require Exporter;
@ISA = qw(Exporter);
$VERSION = '0.03';
use strict;
# 5.004's Exporter doesn't have export_to_level.
my $_export_to_level = sub {
my $pkg = shift;
my $level = shift;
(undef) = shift; # redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
};
=head1 NAME
Test::Builder::Module - Base class for test modules
=head1 SYNOPSIS
# Emulates Test::Simple
package Your::Module;
my $CLASS = __PACKAGE__;
use base 'Test::Builder::Module';
@EXPORT = qw(ok);
sub ok ($;$) {
my $tb = $CLASS->builder;
return $tb->ok(@_);
}
1;
=head1 DESCRIPTION
This is a superclass for Test::Builder-based modules. It provides a
handful of common functionality and a method of getting at the underlying
Test::Builder object.
=head2 Importing
Test::Builder::Module is a subclass of Exporter which means your
module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
all act normally.
A few methods are provided to do the C<use Your::Module tests => 23> part
for you.
=head3 import
Test::Builder::Module provides an import() method which acts in the
same basic way as Test::More's, setting the plan and controling
exporting of functions and variables. This allows your module to set
the plan independent of Test::More.
All arguments passed to import() are passed onto
C<< Your::Module->builder->plan() >> with the exception of
C<import =>[qw(things to import)]>.
use Your::Module import => [qw(this that)], tests => 23;
says to import the functions this() and that() as well as set the plan
to be 23 tests.
import() also sets the exported_to() attribute of your builder to be
the caller of the import() function.
Additional behaviors can be added to your import() method by overriding
import_extra().
=cut
sub import {
my($class) = shift;
my $test = $class->builder;
my $caller = caller;
$test->exported_to($caller);
$class->import_extra(\@_);
my(@imports) = $class->_strip_imports(\@_);
$test->plan(@_);
$class->$_export_to_level(1, $class, @imports);
}
sub _strip_imports {
my $class = shift;
my $list = shift;
my @imports = ();
my @other = ();
my $idx = 0;
while( $idx <= $#{$list} ) {
my $item = $list->[$idx];
if( defined $item and $item eq 'import' ) {
push @imports, @{$list->[$idx+1]};
$idx++;
}
else {
push @other, $item;
}
$idx++;
}
@$list = @other;
return @imports;
}
=head3 import_extra
Your::Module->import_extra(\@import_args);
import_extra() is called by import(). It provides an opportunity for you
to add behaviors to your module based on its import list.
Any extra arguments which shouldn't be passed on to plan() should be
stripped off by this method.
See Test::More for an example of its use.
B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
feels like a bit of an ugly hack in its current form.
=cut
sub import_extra {}
=head2 Builder
Test::Builder::Module provides some methods of getting at the underlying
Test::Builder object.
=head3 builder
my $builder = Your::Class->builder;
This method returns the Test::Builder object associated with Your::Class.
It is not a constructor so you can call it as often as you like.
This is the preferred way to get the Test::Builder object. You should
I<not> get it via C<< Test::Builder->new >> as was previously
recommended.
The object returned by builder() may change at runtime so you should
call builder() inside each function rather than store it in a global.
sub ok {
my $builder = Your::Class->builder;
return $builder->ok(@_);
}
=cut
sub builder {
return Test::Builder->new;
}
1;
Raw
More.pm
package Test::More;
use 5.004;
use strict;
# Can't use Carp because it might cause use_ok() to accidentally succeed
# even though the module being used forgot to use Carp. Yes, this
# actually happened.
sub _carp {
my($file, $line) = (caller(1))[1,2];
warn @_, " at $file line $line\n";
}
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
$VERSION = '0.62';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@ISA = qw(Test::Builder::Module);
@EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
cmp_ok
skip todo todo_skip
pass fail
eq_array eq_hash eq_set
$TODO
plan
can_ok isa_ok
diag
BAIL_OUT
);
=head1 NAME
Test::More - yet another framework for writing test scripts
=head1 SYNOPSIS
use Test::More tests => $Num_Tests;
# or
use Test::More qw(no_plan);
# or
use Test::More skip_all => $reason;
BEGIN { use_ok( 'Some::Module' ); }
require_ok( 'Some::Module' );
# Various ways to say "ok"
ok($this eq $that, $test_name);
is ($this, $that, $test_name);
isnt($this, $that, $test_name);
# Rather than print STDERR "# here's what went wrong\n"
diag("here's what went wrong");
like ($this, qr/that/, $test_name);
unlike($this, qr/that/, $test_name);
cmp_ok($this, '==', $that, $test_name);
is_deeply($complex_structure1, $complex_structure2, $test_name);
SKIP: {
skip $why, $how_many unless $have_some_feature;
ok( foo(), $test_name );
is( foo(42), 23, $test_name );
};
TODO: {
local $TODO = $why;
ok( foo(), $test_name );
is( foo(42), 23, $test_name );
};
can_ok($module, @methods);
isa_ok($object, $class);
pass($test_name);
fail($test_name);
BAIL_OUT($why);
# UNIMPLEMENTED!!!
my @status = Test::More::status;
=head1 DESCRIPTION
B<STOP!> If you're just getting started writing tests, have a look at
Test::Simple first. This is a drop in replacement for Test::Simple
which you can switch to once you get the hang of basic testing.
The purpose of this module is to provide a wide range of testing
utilities. Various ways to say "ok" with better diagnostics,
facilities to skip tests, test future features and compare complicated
data structures. While you can do almost anything with a simple
C<ok()> function, it doesn't provide good diagnostic output.
=head2 I love it when a plan comes together
Before anything else, you need a testing plan. This basically declares
how many tests your script is going to run to protect against premature
failure.
The preferred way to do this is to declare a plan when you C<use Test::More>.
use Test::More tests => $Num_Tests;
There are rare cases when you will not know beforehand how many tests
your script is going to run. In this case, you can declare that you
have no plan. (Try to avoid using this as it weakens your test.)
use Test::More qw(no_plan);
B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
think everything has failed. See L<CAVEATS and NOTES>).
In some cases, you'll want to completely skip an entire testing script.
use Test::More skip_all => $skip_reason;
Your script will declare a skip with the reason why you skipped and
exit immediately with a zero (success). See L<Test::Harness> for
details.
If you want to control what functions Test::More will export, you
have to use the 'import' option. For example, to import everything
but 'fail', you'd do:
use Test::More tests => 23, import => ['!fail'];
Alternatively, you can use the plan() function. Useful for when you
have to calculate the number of tests.
use Test::More;
plan tests => keys %Stuff * 3;
or for deciding between running the tests at all:
use Test::More;
if( $^O eq 'MacOS' ) {
plan skip_all => 'Test irrelevant on MacOS';
}
else {
plan tests => 42;
}
=cut
sub plan {
my $tb = Test::More->builder;
$tb->plan(@_);
}
# This implements "use Test::More 'no_diag'" but the behavior is
# deprecated.
sub import_extra {
my $class = shift;
my $list = shift;
my @other = ();
my $idx = 0;
while( $idx <= $#{$list} ) {
my $item = $list->[$idx];
if( defined $item and $item eq 'no_diag' ) {
$class->builder->no_diag(1);
}
else {
push @other, $item;
}
$idx++;
}
@$list = @other;
}
=head2 Test names
By convention, each test is assigned a number in order. This is
largely done automatically for you. However, it's often very useful to
assign a name to each test. Which would you rather see:
ok 4
not ok 5
ok 6
or
ok 4 - basic multi-variable
not ok 5 - simple exponential
ok 6 - force == mass * acceleration
The later gives you some idea of what failed. It also makes it easier
to find the test in your script, simply search for "simple
exponential".
All test functions take a name argument. It's optional, but highly
suggested that you use it.
=head2 I'm ok, you're not ok.
The basic purpose of this module is to print out either "ok #" or "not
ok #" depending on if a given test succeeded or failed. Everything
else is just gravy.
All of the following print "ok" or "not ok" depending on if the test
succeeded or failed. They all also return true or false,
respectively.
=over 4
=item B<ok>
ok($this eq $that, $test_name);
This simply evaluates any expression (C<$this eq $that> is just a
simple example) and uses that to determine if the test succeeded or
failed. A true expression passes, a false one fails. Very simple.
For example:
ok( $exp{9} == 81, 'simple exponential' );
ok( Film->can('db_Main'), 'set_db()' );
ok( $p->tests == 4, 'saw tests' );
ok( !grep !defined $_, @items, 'items populated' );
(Mnemonic: "This is ok.")
$test_name is a very short description of the test that will be printed
out. It makes it very easy to find a test in your script when it fails
and gives others an idea of your intentions. $test_name is optional,
but we B<very> strongly encourage its use.
Should an ok() fail, it will produce some diagnostics:
not ok 18 - sufficient mucus
# Failed test 'sufficient mucus'
# in foo.t at line 42.
This is actually Test::Simple's ok() routine.
=cut
sub ok ($;$) {
my($test, $name) = @_;
my $tb = Test::More->builder;
$tb->ok($test, $name);
}
=item B<is>
=item B<isnt>
is ( $this, $that, $test_name );
isnt( $this, $that, $test_name );
Similar to ok(), is() and isnt() compare their two arguments
with C<eq> and C<ne> respectively and use the result of that to
determine if the test succeeded or failed. So these:
# Is the ultimate answer 42?
is( ultimate_answer(), 42, "Meaning of Life" );
# $foo isn't empty
isnt( $foo, '', "Got some foo" );
are similar to these:
ok( ultimate_answer() eq 42, "Meaning of Life" );
ok( $foo ne '', "Got some foo" );
(Mnemonic: "This is that." "This isn't that.")
So why use these? They produce better diagnostics on failure. ok()
cannot know what you are testing for (beyond the name), but is() and
isnt() know what the test was and why it failed. For example this
test:
my $foo = 'waffle'; my $bar = 'yarblokos';
is( $foo, $bar, 'Is foo the same as bar?' );
Will produce something like this:
not ok 17 - Is foo the same as bar?
# Failed test 'Is foo the same as bar?'
# in foo.t at line 139.
# got: 'waffle'
# expected: 'yarblokos'
So you can figure out what went wrong without rerunning the test.
You are encouraged to use is() and isnt() over ok() where possible,
however do not be tempted to use them to find out if something is
true or false!
# XXX BAD!
is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
This does not check if C<exists $brooklyn{tree}> is true, it checks if
it returns 1. Very different. Similar caveats exist for false and 0.
In these cases, use ok().
ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
For those grammatical pedants out there, there's an C<isn't()>
function which is an alias of isnt().
=cut
sub is ($$;$) {
my $tb = Test::More->builder;
$tb->is_eq(@_);
}
sub isnt ($$;$) {
my $tb = Test::More->builder;
$tb->isnt_eq(@_);
}
*isn't = \&isnt;
=item B<like>
like( $this, qr/that/, $test_name );
Similar to ok(), like() matches $this against the regex C<qr/that/>.
So this:
like($this, qr/that/, 'this is like that');
is similar to:
ok( $this =~ /that/, 'this is like that');
(Mnemonic "This is like that".)
The second argument is a regular expression. It may be given as a
regex reference (i.e. C<qr//>) or (for better compatibility with older
perls) as a string that looks like a regex (alternative delimiters are
currently not supported):
like( $this, '/that/', 'this is like that' );
Regex options may be placed on the end (C<'/that/i'>).
Its advantages over ok() are similar to that of is() and isnt(). Better
diagnostics on failure.
=cut
sub like ($$;$) {
my $tb = Test::More->builder;
$tb->like(@_);
}
=item B<unlike>
unlike( $this, qr/that/, $test_name );
Works exactly as like(), only it checks if $this B<does not> match the
given pattern.
=cut
sub unlike ($$;$) {
my $tb = Test::More->builder;
$tb->unlike(@_);
}
=item B<cmp_ok>
cmp_ok( $this, $op, $that, $test_name );
Halfway between ok() and is() lies cmp_ok(). This allows you to
compare two arguments using any binary perl operator.
# ok( $this eq $that );
cmp_ok( $this, 'eq', $that, 'this eq that' );
# ok( $this == $that );
cmp_ok( $this, '==', $that, 'this == that' );
# ok( $this && $that );
cmp_ok( $this, '&&', $that, 'this && that' );
...etc...
Its advantage over ok() is when the test fails you'll know what $this
and $that were:
not ok 1
# Failed test in foo.t at line 12.
# '23'
# &&
# undef
It's also useful in those cases where you are comparing numbers and
is()'s use of C<eq> will interfere:
cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
=cut
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
$tb->cmp_ok(@_);
}
=item B<can_ok>
can_ok($module, @methods);
can_ok($object, @methods);
Checks to make sure the $module or $object can do these @methods
(works with functions, too).
can_ok('Foo', qw(this that whatever));
is almost exactly like saying:
ok( Foo->can('this') &&
Foo->can('that') &&
Foo->can('whatever')
);
only without all the typing and with a better interface. Handy for
quickly testing an interface.
No matter how many @methods you check, a single can_ok() call counts
as one test. If you desire otherwise, use:
foreach my $meth (@methods) {
can_ok('Foo', $meth);
}
=cut
sub can_ok ($@) {
my($proto, @methods) = @_;
my $class = ref $proto || $proto;
my $tb = Test::More->builder;
unless( @methods ) {
my $ok = $tb->ok( 0, "$class->can(...)" );
$tb->diag(' can_ok() called with no methods');
return $ok;
}
my @nok = ();
foreach my $method (@methods) {
local($!, $@); # don't interfere with caller's $@
# eval sometimes resets $!
eval { $proto->can($method) } || push @nok, $method;
}
my $name;
$name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
my $ok = $tb->ok( !@nok, $name );
$tb->diag(map " $class->can('$_') failed\n", @nok);
return $ok;
}
=item B<isa_ok>
isa_ok($object, $class, $object_name);
isa_ok($ref, $type, $ref_name);
Checks to see if the given C<< $object->isa($class) >>. Also checks to make
sure the object was defined in the first place. Handy for this sort
of thing:
my $obj = Some::Module->new;
isa_ok( $obj, 'Some::Module' );
where you'd otherwise have to write
my $obj = Some::Module->new;
ok( defined $obj && $obj->isa('Some::Module') );
to safeguard against your test script blowing up.
It works on references, too:
isa_ok( $array_ref, 'ARRAY' );
The diagnostics of this test normally just refer to 'the object'. If
you'd like them to be more specific, you can supply an $object_name
(for example 'Test customer').
=cut
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
my $tb = Test::More->builder;
my $diag;
$obj_name = 'The object' unless defined $obj_name;
my $name = "$obj_name isa $class";
if( !defined $object ) {
$diag = "$obj_name isn't defined";
}
elsif( !ref $object ) {
$diag = "$obj_name isn't a reference";
}
else {
# We can't use UNIVERSAL::isa because we want to honor isa() overrides
local($@, $!); # eval sometimes resets $!
my $rslt = eval { $object->isa($class) };
if( $@ ) {
if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
if( !UNIVERSAL::isa($object, $class) ) {
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
}
} else {
die <<WHOA;
WHOA! I tried to call ->isa on your object and got some weird error.
This should never happen. Please contact the author immediately.
Here's the error.
$@
WHOA
}
}
elsif( !$rslt ) {
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
}
}
my $ok;
if( $diag ) {
$ok = $tb->ok( 0, $name );
$tb->diag(" $diag\n");
}
else {
$ok = $tb->ok( 1, $name );
}
return $ok;
}
=item B<pass>
=item B<fail>
pass($test_name);
fail($test_name);
Sometimes you just want to say that the tests have passed. Usually
the case is you've got some complicated condition that is difficult to
wedge into an ok(). In this case, you can simply use pass() (to
declare the test ok) or fail (for not ok). They are synonyms for
ok(1) and ok(0).
Use these very, very, very sparingly.
=cut
sub pass (;$) {
my $tb = Test::More->builder;
$tb->ok(1, @_);
}
sub fail (;$) {
my $tb = Test::More->builder;
$tb->ok(0, @_);
}
=back
=head2 Module tests
You usually want to test if the module you're testing loads ok, rather
than just vomiting if its load fails. For such purposes we have
C<use_ok> and C<require_ok>.
=over 4
=item B<use_ok>
BEGIN { use_ok($module); }
BEGIN { use_ok($module, @imports); }
These simply use the given $module and test to make sure the load
happened ok. It's recommended that you run use_ok() inside a BEGIN
block so its functions are exported at compile-time and prototypes are
properly honored.
If @imports are given, they are passed through to the use. So this:
BEGIN { use_ok('Some::Module', qw(foo bar)) }
is like doing this:
use Some::Module qw(foo bar);
Version numbers can be checked like so:
# Just like "use Some::Module 1.02"
BEGIN { use_ok('Some::Module', 1.02) }
Don't try to do this:
BEGIN {
use_ok('Some::Module');
...some code that depends on the use...
...happening at compile time...
}
because the notion of "compile-time" is relative. Instead, you want:
BEGIN { use_ok('Some::Module') }
BEGIN { ...some code that depends on the use... }
=cut
sub use_ok ($;@) {
my($module, @imports) = @_;
@imports = () unless @imports;
my $tb = Test::More->builder;
my($pack,$filename,$line) = caller;
local($@,$!); # eval sometimes interferes with $!
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
# probably a version check. Perl needs to see the bare number
# for it to work with non-Exporter based modules.
eval <<USE;
package $pack;
use $module $imports[0];
USE
}
else {
eval <<USE;
package $pack;
use $module \@imports;
USE
}
my $ok = $tb->ok( !$@, "use $module;" );
unless( $ok ) {
chomp $@;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
{BEGIN failed--compilation aborted at $filename line $line.}m;
$tb->diag(<<DIAGNOSTIC);
Tried to use '$module'.
Error: $@
DIAGNOSTIC
}
return $ok;
}
=item B<require_ok>
require_ok($module);
require_ok($file);
Like use_ok(), except it requires the $module or $file.
=cut
sub require_ok ($) {
my($module) = shift;
my $tb = Test::More->builder;
my $pack = caller;
# Try to deterine if we've been given a module name or file.
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
local($!, $@); # eval sometimes interferes with $!
eval <<REQUIRE;
package $pack;
require $module;
REQUIRE
my $ok = $tb->ok( !$@, "require $module;" );
unless( $ok ) {
chomp $@;
$tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
Error: $@
DIAGNOSTIC
}
return $ok;
}
sub _is_module_name {
my $module = shift;
# Module names start with a letter.
# End with an alphanumeric.
# The rest is an alphanumeric or ::
$module =~ s/\b::\b//g;
$module =~ /^[a-zA-Z]\w*$/;
}
=back
=head2 Complex data structures
Not everything is a simple eq check or regex. There are times you
need to see if two data structures are equivalent. For these
instances Test::More provides a handful of useful functions.
B<NOTE> I'm not quite sure what will happen with filehandles.
=over 4
=item B<is_deeply>
is_deeply( $this, $that, $test_name );
Similar to is(), except that if $this and $that are references, it
does a deep comparison walking each data structure to see if they are
equivalent. If the two structures are different, it will display the
place where they start differing.
is_deeply() compares the dereferenced values of references, the
references themselves (except for their type) are ignored. This means
aspects such as blessing and ties are not considered "different".
is_deeply() current has very limited handling of function reference
and globs. It merely checks if they have the same referent. This may
improve in the future.
Test::Differences and Test::Deep provide more in-depth functionality
along these lines.
=cut
use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
sub is_deeply {
my $tb = Test::More->builder;
unless( @_ == 2 or @_ == 3 ) {
my $msg = <<WARNING;
is_deeply() takes two or three args, you gave %d.
This usually means you passed an array or hash instead
of a reference to it
WARNING
chop $msg; # clip off newline so carp() will put in line/file
_carp sprintf $msg, scalar @_;
return $tb->ok(0);
}
my($this, $that, $name) = @_;
$tb->_unoverload_str(\$that, \$this);
my $ok;
if( !ref $this and !ref $that ) { # neither is a reference
$ok = $tb->is_eq($this, $that, $name);
}
elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't
$ok = $tb->ok(0, $name);
$tb->diag( _format_stack({ vals => [ $this, $that ] }) );
}
else { # both references
local @Data_Stack = ();
if( _deep_check($this, $that) ) {
$ok = $tb->ok(1, $name);
}
else {
$ok = $tb->ok(0, $name);
$tb->diag(_format_stack(@Data_Stack));
}
}
return $ok;
}
sub _format_stack {
my(@Stack) = @_;
my $var = '$FOO';
my $did_arrow = 0;
foreach my $entry (@Stack) {
my $type = $entry->{type} || '';
my $idx = $entry->{'idx'};
if( $type eq 'HASH' ) {
$var .= "->" unless $did_arrow++;
$var .= "{$idx}";
}
elsif( $type eq 'ARRAY' ) {
$var .= "->" unless $did_arrow++;
$var .= "[$idx]";
}
elsif( $type eq 'REF' ) {
$var = "\${$var}";
}
}
my @vals = @{$Stack[-1]{vals}}[0,1];
my @vars = ();
($vars[0] = $var) =~ s/\$FOO/ \$got/;
($vars[1] = $var) =~ s/\$FOO/\$expected/;
my $out = "Structures begin differing at:\n";
foreach my $idx (0..$#vals) {
my $val = $vals[$idx];
$vals[$idx] = !defined $val ? 'undef' :
$val eq $DNE ? "Does not exist" :
ref $val ? "$val" :
"'$val'";
}
$out .= "$vars[0] = $vals[0]\n";
$out .= "$vars[1] = $vals[1]\n";
$out =~ s/^/ /msg;
return $out;
}
sub _type {
my $thing = shift;
return '' if !ref $thing;
for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
return $type if UNIVERSAL::isa($thing, $type);
}
return '';
}
=back
=head2 Diagnostics
If you pick the right test function, you'll usually get a good idea of
what went wrong when it failed. But sometimes it doesn't work out
that way. So here we have ways for you to write your own diagnostic
messages which are safer than just C<print STDERR>.
=over 4
=item B<diag>
diag(@diagnostic_message);
Prints a diagnostic message which is guaranteed not to interfere with
test output. Like C<print> @diagnostic_message is simply concatenated
together.
Handy for this sort of thing:
ok( grep(/foo/, @users), "There's a foo user" ) or
diag("Since there's no foo, check that /etc/bar is set up right");
which would produce:
not ok 42 - There's a foo user
# Failed test 'There's a foo user'
# in foo.t at line 52.
# Since there's no foo, check that /etc/bar is set up right.
You might remember C<ok() or diag()> with the mnemonic C<open() or
die()>.
B<NOTE> The exact formatting of the diagnostic output is still
changing, but it is guaranteed that whatever you throw at it it won't
interfere with the test.
=cut
sub diag {
my $tb = Test::More->builder;
$tb->diag(@_);
}
=back
=head2 Conditional tests
Sometimes running a test under certain conditions will cause the
test script to die. A certain function or method isn't implemented
(such as fork() on MacOS), some resource isn't available (like a
net connection) or a module isn't available. In these cases it's
necessary to skip tests, or declare that they are supposed to fail
but will work in the future (a todo test).
For more details on the mechanics of skip and todo tests see
L<Test::Harness>.
The way Test::More handles this is with a named block. Basically, a
block of tests which can be skipped over or made todo. It's best if I
just show you...
=over 4
=item B<SKIP: BLOCK>
SKIP: {
skip $why, $how_many if $condition;
...normal testing code goes here...
}
This declares a block of tests that might be skipped, $how_many tests
there are, $why and under what $condition to skip them. An example is
the easiest way to illustrate:
SKIP: {
eval { require HTML::Lint };
skip "HTML::Lint not installed", 2 if $@;
my $lint = new HTML::Lint;
isa_ok( $lint, "HTML::Lint" );
$lint->parse( $html );
is( $lint->errors, 0, "No errors found in HTML" );
}
If the user does not have HTML::Lint installed, the whole block of
code I<won't be run at all>. Test::More will output special ok's
which Test::Harness interprets as skipped, but passing, tests.
It's important that $how_many accurately reflects the number of tests
in the SKIP block so the # of tests run will match up with your plan.
If your plan is C<no_plan> $how_many is optional and will default to 1.
It's perfectly safe to nest SKIP blocks. Each SKIP block must have
the label C<SKIP>, or Test::More can't work its magic.
You don't skip tests which are failing because there's a bug in your
program, or for which you don't yet have code written. For that you
use TODO. Read on.
=cut
#'#
sub skip {
my($why, $how_many) = @_;
my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "skip() needs to know \$how_many tests are in the block"
unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
$tb->skip($why);
}
local $^W = 0;
last SKIP;
}
=item B<TODO: BLOCK>
TODO: {
local $TODO = $why if $condition;
...normal testing code goes here...
}
Declares a block of tests you expect to fail and $why. Perhaps it's
because you haven't fixed a bug or haven't finished a new feature:
TODO: {
local $TODO = "URI::Geller not finished";
my $card = "Eight of clubs";
is( URI::Geller->your_card, $card, 'Is THIS your card?' );
my $spoon;
URI::Geller->bend_spoon;
is( $spoon, 'bent', "Spoon bending, that's original" );
}
With a todo block, the tests inside are expected to fail. Test::More
will run the tests normally, but print out special flags indicating
they are "todo". Test::Harness will interpret failures as being ok.
Should anything succeed, it will report it as an unexpected success.
You then know the thing you had todo is done and can remove the
TODO flag.
The nice part about todo tests, as opposed to simply commenting out a
block of tests, is it's like having a programmatic todo list. You know
how much work is left to be done, you're aware of what bugs there are,
and you'll know immediately when they're fixed.
Once a todo test starts succeeding, simply move it outside the block.
When the block is empty, delete it.
B<NOTE>: TODO tests require a Test::Harness upgrade else it will
treat it as a normal failure. See L<CAVEATS and NOTES>).
=item B<todo_skip>
TODO: {
todo_skip $why, $how_many if $condition;
...normal testing code...
}
With todo tests, it's best to have the tests actually run. That way
you'll know when they start passing. Sometimes this isn't possible.
Often a failing test will cause the whole program to die or hang, even
inside an C<eval BLOCK> with and using C<alarm>. In these extreme
cases you have no choice but to skip over the broken tests entirely.
The syntax and behavior is similar to a C<SKIP: BLOCK> except the
tests will be marked as failing but todo. Test::Harness will
interpret them as passing.
=cut
sub todo_skip {
my($why, $how_many) = @_;
my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "todo_skip() needs to know \$how_many tests are in the block"
unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
$tb->todo_skip($why);
}
local $^W = 0;
last TODO;
}
=item When do I use SKIP vs. TODO?
B<If it's something the user might not be able to do>, use SKIP.
This includes optional modules that aren't installed, running under
an OS that doesn't have some feature (like fork() or symlinks), or maybe
you need an Internet connection and one isn't available.
B<If it's something the programmer hasn't done yet>, use TODO. This
is for any code you haven't written yet, or bugs you have yet to fix,
but want to put tests in your testing script (always a good idea).
=back
=head2 Test control
=over 4
=item B<BAIL_OUT>
BAIL_OUT($reason);
Incidates to the harness that things are going so badly all testing
should terminate. This includes the running any additional test scripts.
This is typically used when testing cannot continue such as a critical
module failing to compile or a necessary external utility not being
available such as a database connection failing.
The test will exit with 255.
=cut
sub BAIL_OUT {
my $reason = shift;
my $tb = Test::More->builder;
$tb->BAIL_OUT($reason);
}
=back
=head2 Discouraged comparison functions
The use of the following functions is discouraged as they are not
actually testing functions and produce no diagnostics to help figure
out what went wrong. They were written before is_deeply() existed
because I couldn't figure out how to display a useful diff of two
arbitrary data structures.
These functions are usually used inside an ok().
ok( eq_array(\@this, \@that) );
C<is_deeply()> can do that better and with diagnostics.
is_deeply( \@this, \@that );
They may be deprecated in future versions.
=over 4
=item B<eq_array>
my $is_eq = eq_array(\@this, \@that);
Checks if two arrays are equivalent. This is a deep check, so
multi-level structures are handled correctly.
=cut
#'#
sub eq_array {
local @Data_Stack;
_deep_check(@_);
}
sub _eq_array {
my($a1, $a2) = @_;
if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
warn "eq_array passed a non-array ref";
return 0;
}
return 1 if $a1 eq $a2;
my $ok = 1;
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
for (0..$max) {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
$ok = _deep_check($e1,$e2);
pop @Data_Stack if $ok;
last unless $ok;
}
return $ok;
}
sub _deep_check {
my($e1, $e2) = @_;
my $tb = Test::More->builder;
my $ok = 0;
# Effectively turn %Refs_Seen into a stack. This avoids picking up
# the same referenced used twice (such as [\$a, \$a]) to be considered
# circular.
local %Refs_Seen = %Refs_Seen;
{
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
$tb->_unoverload_str(\$e1, \$e2);
# Either they're both references or both not.
my $same_ref = !(!ref $e1 xor !ref $e2);
my $not_ref = (!ref $e1 and !ref $e2);
if( defined $e1 xor defined $e2 ) {
$ok = 0;
}
elsif ( $e1 == $DNE xor $e2 == $DNE ) {
$ok = 0;
}
elsif ( $same_ref and ($e1 eq $e2) ) {
$ok = 1;
}
elsif ( $not_ref ) {
push @Data_Stack, { type => '', vals => [$e1, $e2] };
$ok = 0;
}
else {
if( $Refs_Seen{$e1} ) {
return $Refs_Seen{$e1} eq $e2;
}
else {
$Refs_Seen{$e1} = "$e2";
}
my $type = _type($e1);
$type = 'DIFFERENT' unless _type($e2) eq $type;
if( $type eq 'DIFFERENT' ) {
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
$ok = 0;
}
elsif( $type eq 'ARRAY' ) {
$ok = _eq_array($e1, $e2);
}
elsif( $type eq 'HASH' ) {
$ok = _eq_hash($e1, $e2);
}
elsif( $type eq 'REF' ) {
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
elsif( $type eq 'SCALAR' ) {
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
elsif( $type ) {
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
$ok = 0;
}
else {
_whoa(1, "No type in _deep_check");
}
}
}
return $ok;
}
sub _whoa {
my($check, $desc) = @_;
if( $check ) {
die <<WHOA;
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
=item B<eq_hash>
my $is_eq = eq_hash(\%this, \%that);
Determines if the two hashes contain the same keys and values. This
is a deep check.
=cut
sub eq_hash {
local @Data_Stack;
return _deep_check(@_);
}
sub _eq_hash {
my($a1, $a2) = @_;
if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
warn "eq_hash passed a non-hash ref";
return 0;
}
return 1 if $a1 eq $a2;
my $ok = 1;
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
foreach my $k (keys %$bigger) {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
$ok = _deep_check($e1, $e2);
pop @Data_Stack if $ok;
last unless $ok;
}
return $ok;
}
=item B<eq_set>
my $is_eq = eq_set(\@this, \@that);
Similar to eq_array(), except the order of the elements is B<not>
important. This is a deep check, but the irrelevancy of order only
applies to the top level.
ok( eq_set(\@this, \@that) );
Is better written:
is_deeply( [sort @this], [sort @that] );
B<NOTE> By historical accident, this is not a true set comparison.
While the order of elements does not matter, duplicate elements do.
B<NOTE> eq_set() does not know how to deal with references at the top
level. The following is an example of a comparison which might not work:
eq_set([\1, \2], [\2, \1]);
Test::Deep contains much better set comparison functions.
=cut
sub eq_set {
my($a1, $a2) = @_;
return 0 unless @$a1 == @$a2;
# There's faster ways to do this, but this is easiest.
local $^W = 0;
# It really doesn't matter how we sort them, as long as both arrays are
# sorted with the same algorithm.
#
# Ensure that references are not accidentally treated the same as a
# string containing the reference.
#
# Have to inline the sort routine due to a threading/sort bug.
# See [rt.cpan.org 6782]
#
# I don't know how references would be sorted so we just don't sort
# them. This means eq_set doesn't really work with refs.
return eq_array(
[grep(ref, @$a1), sort( grep(!ref, @$a1) )],
[grep(ref, @$a2), sort( grep(!ref, @$a2) )],
);
}
=back
=head2 Extending and Embedding Test::More
Sometimes the Test::More interface isn't quite enough. Fortunately,
Test::More is built on top of Test::Builder which provides a single,
unified backend for any test library to use. This means two test
libraries which both use Test::Builder B<can be used together in the
same program>.
If you simply want to do a little tweaking of how the tests behave,
you can access the underlying Test::Builder object like so:
=over 4
=item B<builder>
my $test_builder = Test::More->builder;
Returns the Test::Builder object underlying Test::More for you to play
with.
=back
=head1 EXIT CODES
If all your tests passed, Test::Builder will exit with zero (which is
normal). If anything failed it will exit with how many failed. If
you run less (or more) tests than you planned, the missing (or extras)
will be considered failures. If no tests were ever run Test::Builder
will throw a warning and exit with 255. If the test died, even after
having successfully completed all its tests, it will still be
considered a failure and will exit with 255.
So the exit codes are...
0 all tests successful
255 test died or all passed but wrong # of tests run
any other number how many failed (including missing or extras)
If you fail more than 254 tests, it will be reported as 254.
B<NOTE> This behavior may go away in future versions.
=head1 CAVEATS and NOTES
=over 4
=item Backwards compatibility
Test::More works with Perls as old as 5.004_05.
=item Overloaded objects
String overloaded objects are compared B<as strings> (or in cmp_ok()'s
case, strings or numbers as appropriate to the comparison op). This
prevents Test::More from piercing an object's interface allowing
better blackbox testing. So if a function starts returning overloaded
objects instead of bare strings your tests won't notice the
difference. This is good.
However, it does mean that functions like is_deeply() cannot be used to
test the internals of string overloaded objects. In this case I would
suggest Test::Deep which contains more flexible testing functions for
complex data structures.
=item Threads
Test::More will only be aware of threads if "use threads" has been done
I<before> Test::More is loaded. This is ok:
use threads;
use Test::More;
This may cause problems:
use Test::More
use threads;
=item Test::Harness upgrade
no_plan and todo depend on new Test::Harness features and fixes. If
you're going to distribute tests that use no_plan or todo your
end-users will have to upgrade Test::Harness to the latest one on
CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
will work fine.
Installing Test::More should also upgrade Test::Harness.
=back
=head1 HISTORY
This is a case of convergent evolution with Joshua Pritikin's Test
module. I was largely unaware of its existence when I'd first
written my own ok() routines. This module exists because I can't
figure out how to easily wedge test names into Test's interface (along
with a few other problems).
The goal here is to have a testing utility that's simple to learn,
quick to use and difficult to trip yourself up with while still
providing more flexibility than the existing Test.pm. As such, the
names of the most common routines are kept tiny, special cases and
magic side-effects are kept to a minimum. WYSIWYG.
=head1 SEE ALSO
L<Test::Simple> if all this confuses you and you just want to write
some tests. You can upgrade to Test::More later (it's forward
compatible).
L<Test> is the old testing module. Its main benefit is that it has
been distributed with Perl since 5.004_05.
L<Test::Harness> for details on how your test results are interpreted
by Perl.
L<Test::Differences> for more ways to test complex data structures.
And it plays well with Test::More.
L<Test::Class> is like XUnit but more perlish.
L<Test::Deep> gives you more powerful complex data structure testing.
L<Test::Unit> is XUnit style testing.
L<Test::Inline> shows the idea of embedded testing.
L<Bundle::Test> installs a whole bunch of useful test modules.
=head1 AUTHORS
Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
from Joshua Pritikin's Test module and lots of help from Barrie
Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
the perl-qa gang.
=head1 BUGS
See F<http://rt.cpan.org> to report and view bugs.
=head1 COPYRIGHT
Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://www.perl.com/perl/misc/Artistic.html>
=cut
1;
Raw
Packlist.pm
package ExtUtils::Packlist;
use 5.00503;
use strict;
use Carp qw();
use Config;
use vars qw($VERSION $Relocations);
$VERSION = '1.43';
$VERSION = eval $VERSION;
# Used for generating filehandle globs. IO::File might not be available!
my $fhname = "FH1";
=begin _undocumented
=item mkfh()
Make a filehandle. Same kind of idea as Symbol::gensym().
=cut
sub mkfh()
{
no strict;
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
=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
Raw
Packlist.t
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't' if -d 't';
@INC = '../lib';
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
use Test::More tests => 34;
use_ok( 'ExtUtils::Packlist' );
is( ref(ExtUtils::Packlist::mkfh()), 'GLOB', 'mkfh() should return a FH' );
# new calls tie()
my $pl = ExtUtils::Packlist->new();
isa_ok( $pl, 'ExtUtils::Packlist' );
is( ref tied %$pl, 'ExtUtils::Packlist', 'obj should be tied underneath' );
$pl = ExtUtils::Packlist::TIEHASH( 'tieclass', 'packfile' );
is( ref($pl), 'tieclass', 'TIEHASH() should bless into class' );
is( $pl->{packfile}, 'packfile', 'TIEHASH() should store packfile name' );
ExtUtils::Packlist::STORE($pl, 'key', 'value');
is( $pl->{data}{key}, 'value', 'STORE() should stuff stuff in data member' );
$pl->{data}{foo} = 'bar';
is( ExtUtils::Packlist::FETCH($pl, 'foo'), 'bar', 'check FETCH()' );
# test FIRSTKEY and NEXTKEY
SKIP: {
$pl->{data}{bar} = 'baz';
skip('not enough keys to test FIRSTKEY', 2)
unless keys %{ $pl->{data} } > 2;
# get the first and second key
my ($first, $second) = keys %{ $pl->{data} };
# now get a couple of extra keys, to mess with the hash iterator
my $i = 0;
for (keys %{ $pl->{data} } ) {
last if $i++;
}
# finally, see if it really can get the first key again
is( ExtUtils::Packlist::FIRSTKEY($pl), $first,
'FIRSTKEY() should be consistent' );
is( ExtUtils::Packlist::NEXTKEY($pl), $second,
'and NEXTKEY() should also be consistent' );
}
ok( ExtUtils::Packlist::EXISTS($pl, 'bar'), 'EXISTS() should find keys' );
ExtUtils::Packlist::DELETE($pl, 'bar');
ok( !(exists $pl->{data}{bar}), 'DELETE() should delete cleanly' );
ExtUtils::Packlist::CLEAR($pl);
is( keys %{ $pl->{data} }, 0, 'CLEAR() should wipe out data' );
# DESTROY does nothing...
can_ok( 'ExtUtils::Packlist', 'DESTROY' );
# write is a little more complicated
eval { ExtUtils::Packlist::write({}) };
like( $@, qr/No packlist filename/, 'write() should croak without packfile' );
eval { ExtUtils::Packlist::write({}, 'eplist') };
my $file_is_ready = $@ ? 0 : 1;
ok( $file_is_ready, 'write() can write a file' );
local *IN;
SKIP: {
skip('cannot write files, some tests difficult', 3) unless $file_is_ready;
# set this file to read-only
chmod 0444, 'eplist';
SKIP: {
skip("cannot write readonly files", 1) if -w 'eplist';
eval { ExtUtils::Packlist::write({}, 'eplist') };
like( $@, qr/Can't open file/, 'write() should croak on open failure' );
}
#'now set it back (tick here fixes vim syntax highlighting ;)
chmod 0777, 'eplist';
# and some test data to be read
$pl->{data} = {
single => 1,
hash => {
foo => 'bar',
baz => 'bup',
},
'/./abc' => '',
};
eval { ExtUtils::Packlist::write($pl, 'eplist') };
is( $@, '', 'write() should normally succeed' );
is( $pl->{packfile}, 'eplist', 'write() should set packfile name' );
$file_is_ready = open(IN, 'eplist');
}
eval { ExtUtils::Packlist::read({}) };
like( $@, qr/^No packlist filename/, 'read() should croak without packfile' );
eval { ExtUtils::Packlist::read({}, 'abadfilename') };
like( $@, qr/^Can't open file/, 'read() should croak with bad packfile name' );
#'open packfile for reading
# and more read() tests
SKIP: {
skip("cannot open file for reading: $!", 5) unless $file_is_ready;
my $file = do { local $/ = <IN> };
like( $file, qr/single\n/, 'key with value should be available' );
like( $file, qr!/\./abc\n!, 'key with no value should also be present' );
like( $file, qr/hash.+baz=bup/, 'key with hash value should be present' );
like( $file, qr/hash.+foo=bar/, 'second embedded hash value should appear');
close IN;
eval{ ExtUtils::Packlist::read($pl, 'eplist') };
is( $@, '', 'read() should normally succeed' );
is( $pl->{data}{single}, undef, 'single keys should have undef value' );
is( ref($pl->{data}{hash}), 'HASH', 'multivalue keys should become hashes');
is( $pl->{data}{hash}{foo}, 'bar', 'hash values should be set' );
ok( exists $pl->{data}{'/abc'}, 'read() should resolve /./ to / in keys' );
# give validate a valid and an invalid file to find
$pl->{data} = {
eplist => 1,
fake => undef,
};
is( ExtUtils::Packlist::validate($pl), 1,
'validate() should find missing files' );
ExtUtils::Packlist::validate($pl, 1);
ok( !exists $pl->{data}{fake},
'validate() should remove missing files when prompted' );
# one more new() test, to see if it calls read() successfully
$pl = ExtUtils::Packlist->new('eplist');
}
# packlist_file, $pl should be set from write test
is( ExtUtils::Packlist::packlist_file({ packfile => 'pl' }), 'pl',
'packlist_file() should fetch packlist from passed hash' );
is( ExtUtils::Packlist::packlist_file($pl), 'eplist',
'packlist_file() should fetch packlist from ExtUtils::Packlist object' );
END {
1 while unlink qw( eplist );
}
Raw
pod-coverage.t
#!perl -T
BEGIN {
if( $ENV{PERL_CORE} ) {
@INC = ('../../lib', '../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
use Test::More;
use diagnostics;
# this is organized like this to avoid a "bug" in perls tainting.
# using an elsif throws an insecure dependency error.
my $skip_reason= "Skipping author tests. Set AUTHOR_TESTING=1 to run them.";
if ( $ENV{AUTHOR_TESTING} ) {
$skip_reason= "";
}
if ( !$skip_reason && ! eval "use Test::Pod::Coverage 1.08; use Pod::Coverage 0.17; 1" ) {
$skip_reason= "Test::Pod::Coverage 1.08 and Pod::Coverage 0.17 "
. "required for testing POD coverage";
}
$skip_reason and
plan skip_all => $skip_reason;
plan tests => 3;
pod_coverage_ok( "ExtUtils::Install");
pod_coverage_ok( "ExtUtils::Installed");
pod_coverage_ok( "ExtUtils::Packlist");
Raw
pod.t
#!perl -T
BEGIN {
if( $ENV{PERL_CORE} ) {
@INC = ('../../lib', '../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
use Test::More;
eval "use Test::Pod 1.14";
plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
all_pod_files_ok();
Raw
Simple.pm
package Test::Simple;
use 5.004;
use strict 'vars';
use vars qw($VERSION @ISA @EXPORT);
$VERSION = '0.62';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@ISA = qw(Test::Builder::Module);
@EXPORT = qw(ok);
my $CLASS = __PACKAGE__;
=head1 NAME
Test::Simple - Basic utilities for writing tests.
=head1 SYNOPSIS
use Test::Simple tests => 1;
ok( $foo eq $bar, 'foo is bar' );
=head1 DESCRIPTION
** If you are unfamiliar with testing B<read Test::Tutorial> first! **
This is an extremely simple, extremely basic module for writing tests
suitable for CPAN modules and other pursuits. If you wish to do more
complicated testing, use the Test::More module (a drop-in replacement
for this one).
The basic unit of Perl testing is the ok. For each thing you want to
test your program will print out an "ok" or "not ok" to indicate pass
or fail. You do this with the ok() function (see below).
The only other constraint is you must pre-declare how many tests you
plan to run. This is in case something goes horribly wrong during the
test and your test program aborts, or skips a test or whatever. You
do this like so:
use Test::Simple tests => 23;
You must have a plan.
=over 4
=item B<ok>
ok( $foo eq $bar, $name );
ok( $foo eq $bar );
ok() is given an expression (in this case C<$foo eq $bar>). If it's
true, the test passed. If it's false, it didn't. That's about it.
ok() prints out either "ok" or "not ok" along with a test number (it
keeps track of that for you).
# This produces "ok 1 - Hell not yet frozen over" (or not ok)
ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );
If you provide a $name, that will be printed along with the "ok/not
ok" to make it easier to find your test when if fails (just search for
the name). It also makes it easier for the next guy to understand
what your test is for. It's highly recommended you use test names.
All tests are run in scalar context. So this:
ok( @stuff, 'I have some stuff' );
will do what you mean (fail if stuff is empty)
=cut
sub ok ($;$) {
$CLASS->builder->ok(@_);
}
=back
Test::Simple will start by printing number of tests run in the form
"1..M" (so "1..5" means you're going to run 5 tests). This strange
format lets Test::Harness know how many tests you plan on running in
case something goes horribly wrong.
If all your tests passed, Test::Simple will exit with zero (which is
normal). If anything failed it will exit with how many failed. If
you run less (or more) tests than you planned, the missing (or extras)
will be considered failures. If no tests were ever run Test::Simple
will throw a warning and exit with 255. If the test died, even after
having successfully completed all its tests, it will still be
considered a failure and will exit with 255.
So the exit codes are...
0 all tests successful
255 test died or all passed but wrong # of tests run
any other number how many failed (including missing or extras)
If you fail more than 254 tests, it will be reported as 254.
This module is by no means trying to be a complete testing system.
It's just to get you started. Once you're off the ground its
recommended you look at L<Test::More>.
=head1 EXAMPLE
Here's an example of a simple .t file for the fictional Film module.
use Test::Simple tests => 5;
use Film; # What you're testing.
my $btaste = Film->new({ Title => 'Bad Taste',
Director => 'Peter Jackson',
Rating => 'R',
NumExplodingSheep => 1
});
ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' );
ok( $btaste->Title eq 'Bad Taste', 'Title() get' );
ok( $btaste->Director eq 'Peter Jackson', 'Director() get' );
ok( $btaste->Rating eq 'R', 'Rating() get' );
ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' );
It will produce output like this:
1..5
ok 1 - new() works
ok 2 - Title() get
ok 3 - Director() get
not ok 4 - Rating() get
# Failed test 'Rating() get'
# in t/film.t at line 14.
ok 5 - NumExplodingSheep() get
# Looks like you failed 1 tests of 5
Indicating the Film::Rating() method is broken.
=head1 CAVEATS
Test::Simple will only report a maximum of 254 failures in its exit
code. If this is a problem, you probably have a huge test script.
Split it into multiple files. (Otherwise blame the Unix folks for
using an unsigned short integer as the exit status).
Because VMS's exit codes are much, much different than the rest of the
universe, and perl does horrible mangling to them that gets in my way,
it works like this on VMS.
0 SS$_NORMAL all tests successful
4 SS$_ABORT something went wrong
Unfortunately, I can't differentiate any further.
=head1 NOTES
Test::Simple is B<explicitly> tested all the way back to perl 5.004.
Test::Simple is thread-safe in perl 5.8.0 and up.
=head1 HISTORY
This module was conceived while talking with Tony Bowden in his
kitchen one night about the problems I was having writing some really
complicated feature into the new Testing module. He observed that the
main problem is not dealing with these edge cases but that people hate
to write tests B<at all>. What was needed was a dead simple module
that took all the hard work out of testing and was really, really easy
to learn. Paul Johnson simultaneously had this idea (unfortunately,
he wasn't in Tony's kitchen). This is it.
=head1 SEE ALSO
=over 4
=item L<Test::More>
More testing functions! Once you outgrow Test::Simple, look at
Test::More. Test::Simple is 100% forward compatible with Test::More
(i.e. you can just use Test::More instead of Test::Simple in your
programs and things will still work).
=item L<Test>
The original Perl testing module.
=item L<Test::Unit>
Elaborate unit testing.
=item L<Test::Inline>, L<SelfTest>
Embed tests in your code!
=item L<Test::Harness>
Interprets the output of your test program.
=back
=head1 AUTHORS
Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
=head1 COPYRIGHT
Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://www.perl.com/perl/misc/Artistic.html>
=cut
1;
Raw
TieOut.pm
package TieOut;
sub TIEHANDLE {
my $scalar = '';
bless( \$scalar, $_[0]);
}
sub PRINT {
my $self = shift;
$$self .= join('', @_);
}
sub PRINTF {
my $self = shift;
my $fmt = shift;
$$self .= sprintf $fmt, @_;
}
sub FILENO {}
sub read {
my $self = shift;
my $data = $$self;
$$self = '';
return $data;
}
1;
Raw
Utils.pm
package MakeMaker::Test::Utils;
use File::Spec;
use strict;
use Config;
require Exporter;
our @ISA = qw(Exporter);
our $Is_VMS = $^O eq 'VMS';
our $Is_MacOS = $^O eq 'MacOS';
our @EXPORT = qw(which_perl perl_lib makefile_name makefile_backup
make make_run run make_macro calibrate_mtime
setup_mm_test_root
have_compiler slurp
$Is_VMS $Is_MacOS
run_ok
);
# Setup the code to clean out %ENV
{
# Environment variables which might effect our testing
my @delete_env_keys = qw(
PERL_MM_OPT
PERL_MM_USE_DEFAULT
HARNESS_TIMER
HARNESS_OPTIONS
HARNESS_VERBOSE
PREFIX
MAKEFLAGS
);
# Remember the ENV values because on VMS %ENV is global
# to the user, not the process.
my %restore_env_keys;
sub clean_env {
for my $key (@delete_env_keys) {
if( exists $ENV{$key} ) {
$restore_env_keys{$key} = delete $ENV{$key};
}
else {
delete $ENV{$key};
}
}
}
END {
while( my($key, $val) = each %restore_env_keys ) {
$ENV{$key} = $val;
}
}
}
clean_env();
=head1 NAME
MakeMaker::Test::Utils - Utility routines for testing MakeMaker
=head1 SYNOPSIS
use MakeMaker::Test::Utils;
my $perl = which_perl;
perl_lib;
my $makefile = makefile_name;
my $makefile_back = makefile_backup;
my $make = make;
my $make_run = make_run;
make_macro($make, $targ, %macros);
my $mtime = calibrate_mtime;
my $out = run($cmd);
my $have_compiler = have_compiler();
my $text = slurp($filename);
=head1 DESCRIPTION
A consolidation of little utility functions used through out the
MakeMaker test suite.
=head2 Functions
The following are exported by default.
=over 4
=item B<which_perl>
my $perl = which_perl;
Returns a path to perl which is safe to use in a command line, no
matter where you chdir to.
=cut
sub which_perl {
my $perl = $^X;
$perl ||= 'perl';
# VMS should have 'perl' aliased properly
return $perl if $Is_VMS;
$perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i;
my $perlpath = File::Spec->rel2abs( $perl );
unless( $Is_MacOS || -x $perlpath ) {
# $^X was probably 'perl'
# When building in the core, *don't* go off and find
# another perl
die "Can't find a perl to use (\$^X=$^X), (\$perlpath=$perlpath)"
if $ENV{PERL_CORE};
foreach my $path (File::Spec->path) {
$perlpath = File::Spec->catfile($path, $perl);
last if -x $perlpath;
}
}
return $perlpath;
}
=item B<perl_lib>
perl_lib;
Sets up environment variables so perl can find its libraries.
=cut
my $old5lib = $ENV{PERL5LIB};
my $had5lib = exists $ENV{PERL5LIB};
sub perl_lib {
# perl-src/t/
my $lib = $ENV{PERL_CORE} ? qq{../lib}
# ExtUtils-MakeMaker/t/
: qq{../blib/lib};
$lib = File::Spec->rel2abs($lib);
my @libs = ($lib);
push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
$ENV{PERL5LIB} = join($Config{path_sep}, @libs);
unshift @INC, $lib;
}
END {
if( $had5lib ) {
$ENV{PERL5LIB} = $old5lib;
}
else {
delete $ENV{PERL5LIB};
}
}
=item B<makefile_name>
my $makefile = makefile_name;
MakeMaker doesn't always generate 'Makefile'. It returns what it
should generate.
=cut
sub makefile_name {
return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
}
=item B<makefile_backup>
my $makefile_old = makefile_backup;
Returns the name MakeMaker will use for a backup of the current
Makefile.
=cut
sub makefile_backup {
my $makefile = makefile_name;
return $Is_VMS ? "$makefile".'_old' : "$makefile.old";
}
=item B<make>
my $make = make;
Returns a good guess at the make to run.
=cut
sub make {
my $make = $Config{make};
$make = $ENV{MAKE} if exists $ENV{MAKE};
return $make;
}
=item B<make_run>
my $make_run = make_run;
Returns the make to run as with make() plus any necessary switches.
=cut
sub make_run {
my $make = make;
$make .= ' -nologo' if $make eq 'nmake';
return $make;
}
=item B<make_macro>
my $make_cmd = make_macro($make, $target, %macros);
Returns the command necessary to run $make on the given $target using
the given %macros.
my $make_test_verbose = make_macro(make_run(), 'test',
TEST_VERBOSE => 1);
This is important because VMS's make utilities have a completely
different calling convention than Unix or Windows.
%macros is actually a list of tuples, so the order will be preserved.
=cut
sub make_macro {
my($make, $target) = (shift, shift);
my $is_mms = $make =~ /^MM(K|S)/i;
my $cmd = $make;
my $macros = '';
while( my($key,$val) = splice(@_, 0, 2) ) {
if( $is_mms ) {
$macros .= qq{/macro="$key=$val"};
}
else {
$macros .= qq{ $key=$val};
}
}
return $is_mms ? "$make$macros $target" : "$make $target $macros";
}
=item B<calibrate_mtime>
my $mtime = calibrate_mtime;
When building on NFS, file modification times can often lose touch
with reality. This returns the mtime of a file which has just been
touched.
=cut
sub calibrate_mtime {
open(FILE, ">calibrate_mtime.tmp") || die $!;
print FILE "foo";
close FILE;
my($mtime) = (stat('calibrate_mtime.tmp'))[9];
unlink 'calibrate_mtime.tmp';
return $mtime;
}
=item B<run>
my $out = run($command);
my @out = run($command);
Runs the given $command as an external program returning at least STDOUT
as $out. If possible it will return STDOUT and STDERR combined as you
would expect to see on a screen.
=cut
sub run {
my $cmd = shift;
use ExtUtils::MM;
# Unix, modern Windows and OS/2 from 5.005_54 up can handle can handle 2>&1
# This makes our failure diagnostics nicer to read.
if( MM->os_flavor_is('Unix') or
(MM->os_flavor_is('Win32') and !MM->os_flavor_is('Win9x')) or
($] > 5.00554 and MM->os_flavor_is('OS/2'))
) {
return `$cmd 2>&1`;
}
else {
return `$cmd`;
}
}
=item B<run_ok>
my @out = run_ok($cmd);
Like run() but it tests that the result exited normally.
The output from run() will be used as a diagnostic if it fails.
=cut
sub run_ok {
my $tb = Test::Builder->new;
my @out = run(@_);
$tb->cmp_ok( $?, '==', 0, "run(@_)" ) || $tb->diag(@out);
return wantarray ? @out : join "", @out;
}
=item B<setup_mm_test_root>
Creates a rooted logical to avoid the 8-level limit on older VMS systems.
No action taken on non-VMS systems.
=cut
sub setup_mm_test_root {
if( $Is_VMS ) {
# On older systems we might exceed the 8-level directory depth limit
# imposed by RMS. We get around this with a rooted logical, but we
# can't create logical names with attributes in Perl, so we do it
# in a DCL subprocess and put it in the job table so the parent sees it.
open( MMTMP, '>mmtesttmp.com' ) ||
die "Error creating command file; $!";
print MMTMP <<'COMMAND';
$ MM_TEST_ROOT = F$PARSE("SYS$DISK:[-]",,,,"NO_CONCEAL")-".][000000"-"]["-"].;"+".]"
$ DEFINE/JOB/NOLOG/TRANSLATION=CONCEALED MM_TEST_ROOT 'MM_TEST_ROOT'
COMMAND
close MMTMP;
system '@mmtesttmp.com';
1 while unlink 'mmtesttmp.com';
}
}
=item have_compiler
$have_compiler = have_compiler;
Returns true if there is a compiler available for XS builds.
=cut
sub have_compiler {
my $have_compiler = 0;
# ExtUtils::CBuilder prints its compilation lines to the screen.
# Shut it up.
use TieOut;
local *STDOUT = *STDOUT;
local *STDERR = *STDERR;
tie *STDOUT, 'TieOut';
tie *STDERR, 'TieOut';
eval {
require ExtUtils::CBuilder;
my $cb = ExtUtils::CBuilder->new;
$have_compiler = $cb->have_compiler;
};
return $have_compiler;
}
=item slurp
$contents = slurp($filename);
Returns the $contents of $filename.
Will die if $filename cannot be opened.
=cut
sub slurp {
my $filename = shift;
local $/ = undef;
open my $fh, $filename or die "Can't open $filename for reading: $!";
my $text = <$fh>;
close $fh;
return $text;
}
=back
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com>
=cut
1;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment