————package
Test::Script;
=pod
=head1 NAME
Test::Script - Basic cross-platform tests for scripts
=head1 DESCRIPTION
The intent of this module is to provide a series of basic tests for 80%
of the testing you will need to do for scripts in the F<script> (or F<bin>
as is also commonly used) paths of your Perl distribution.
Further, it aims to provide this functionality with perfect
platform-compatibility, and in a way that is as unobtrusive as possible.
That is, if the program works on a platform, then B<Test::Script>
should always work on that platform as well. Anything less than 100% is
considered unacceptable.
In doing so, it is hoped that B<Test::Script> can become a module that
you can safely make a dependency of all your modules, without risking that
your module won't on some platform because of the dependency.
Where a clash exists between wanting more functionality and maintaining
platform safety, this module will err on the side of platform safety.
=head1 FUNCTIONS
=cut
use
5.005;
use
strict;
use
Carp ();
use
Exporter ();
use
File::Spec ();
use
File::Spec::Unix ();
use
Probe::Perl ();
use
IPC::Run3 ();
use
Test::Builder ();
BEGIN {
$VERSION
=
'1.07'
;
@ISA
=
'Exporter'
;
@EXPORT
=
qw{
script_compiles
script_compiles_ok
script_runs
}
;
}
sub
import
{
my
$self
=
shift
;
my
$pack
=
caller
;
my
$test
= Test::Builder->new;
$test
->exported_to(
$pack
);
$test
->plan(
@_
);
foreach
(
@EXPORT
) {
$self
->export_to_level(1,
$self
,
$_
);
}
}
my
$perl
=
undef
;
sub
perl () {
$perl
or
$perl
= Probe::Perl->find_perl_interpreter;
}
sub
path ($) {
my
$path
=
shift
;
unless
(
defined
$path
) {
Carp::croak(
"Did not provide a script name"
);
}
if
( File::Spec::Unix->file_name_is_absolute(
$path
) ) {
Carp::croak(
"Script name must be relative"
);
}
File::Spec->catfile(
File::Spec->curdir,
split
/\//,
$path
);
}
#####################################################################
# Test Functions
=pod
=head2 script_compiles
script_compiles( 'script/foo.pl', 'Main script compiles' );
The C<script_compiles> test calls the script with "perl -c script.pl",
and checks that it returns without error.
The path it should be passed is a relative unix-format script name. This
will be localised when running C<perl -c> and if the test fails the local
name used will be shown in the diagnostic output.
Note also that the test will be run with the same L<perl> interpreter that
is running the test script (and not with the default system perl). This
will also be shown in the diagnostic output on failure.
=cut
sub
script_compiles {
my
$args
= _script(
shift
);
my
$unix
=
shift
@$args
;
my
$path
= path(
$unix
);
my
$cmd
= [ perl,
'-Mblib'
,
'-c'
,
$path
,
@$args
];
my
$stdin
=
''
;
my
$stdout
=
''
;
my
$stderr
=
''
;
my
$rv
= IPC::Run3::run3(
$cmd
, \
$stdin
, \
$stdout
, \
$stderr
);
my
$exit
= $? ? ($? >> 8) : 0;
my
$ok
= !! (
$rv
and
$exit
== 0 and
$stderr
=~ /syntax OK\s+\z/si
);
my
$test
= Test::Builder->new;
$test
->ok(
$ok
,
$_
[0] ||
"Script $unix compiles"
);
$test
->diag(
"$exit - $stderr"
)
unless
$ok
;
return
$ok
;
}
=pod
=head2 script_runs
script_runs( 'script/foo.pl', 'Main script runs' );
The C<script_runs> test executes the script with "perl script.pl" and checks
that it returns success.
The path it should be passed is a relative unix-format script name. This
will be localised when running C<perl -c> and if the test fails the local
name used will be shown in the diagnostic output.
The test will be run with the same L<perl> interpreter that is running the
test script (and not with the default system perl). This will also be shown
in the diagnostic output on failure.
=cut
sub
script_runs {
my
$args
= _script(
shift
);
my
$unix
=
shift
@$args
;
my
$path
= path(
$unix
);
my
$cmd
= [ perl,
'-Mblib'
,
$path
,
@$args
];
my
$stdin
=
''
;
my
$stdout
=
''
;
my
$stderr
=
''
;
my
$rv
= IPC::Run3::run3(
$cmd
, \
$stdin
, \
$stdout
, \
$stderr
);
my
$exit
= $? ? ($? >> 8) : 0;
my
$ok
= !! (
$rv
and
$exit
== 0 );
my
$test
= Test::Builder->new;
$test
->ok(
$ok
,
$_
[0] ||
"Script $unix runs"
);
$test
->diag(
"$exit - $stderr"
)
unless
$ok
;
return
$ok
;
}
######################################################################
# Support Functions
# Script params must be either a simple non-null string with the script
# name, or an array reference with one or more non-null strings.
sub
_script {
my
$in
=
shift
;
if
(
defined
_STRING(
$in
) ) {
return
[
$in
];
}
if
( _ARRAY(
$in
) ) {
unless
(
scalar
grep
{ not
defined
_STRING(
$_
) }
@$in
) {
return
$in
;
}
}
Carp::croak(
"Invalid command parameter"
);
}
# Inline some basic Params::Util functions
sub
_ARRAY ($) {
(
ref
$_
[0] eq
'ARRAY'
and @{
$_
[0]}) ?
$_
[0] :
undef
;
}
sub
_STRING ($) {
(
defined
$_
[0] and !
ref
$_
[0] and
length
(
$_
[0])) ?
$_
[0] :
undef
;
}
BEGIN {
# Alias to old name
*script_compiles_ok
=
*script_compiles
;
}
1;
=pod
=head1 SUPPORT
All bugs should be filed via the bug tracker at
For other issues, or commercial enhancement and support, contact the author.
=head1 AUTHOR
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
=head1 SEE ALSO
L<prove>, L<http://ali.as/>
=head1 COPYRIGHT
Copyright 2006 - 2009 Adam Kennedy.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut