local-lib5/lib/perl5/Test/Script.pm

   1 package Test::Script;
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 Test::Script - Basic cross-platform tests for scripts
   8
   9 =head1 DESCRIPTION
  10
  11 The intent of this module is to provide a series of basic tests for 80%
  12 of the testing you will need to do for scripts in the F<script> (or F<bin>
  13 as is also commonly used) paths of your Perl distribution.
  14
  15 Further, it aims to provide this functionality with perfect
  16 platform-compatibility, and in a way that is as unobtrusive as possible.
  17
  18 That is, if the program works on a platform, then B<Test::Script>
  19 should always work on that platform as well. Anything less than 100% is
  20 considered unacceptable.
  21
  22 In doing so, it is hoped that B<Test::Script> can become a module that
  23 you can safely make a dependency of all your modules, without risking that
  24 your module won't on some platform because of the dependency.
  25
  26 Where a clash exists between wanting more functionality and maintaining
  27 platform safety, this module will err on the side of platform safety.
  28
  29 =head1 FUNCTIONS
  30
  31 =cut
  32
  33 use 5.005;
  34 use strict;
  35 use Carp             ();
  36 use Exporter         ();
  37 use File::Spec       ();
  38 use File::Spec::Unix ();
  39 use Probe::Perl      ();
  40 use IPC::Run3        ();
  41 use Test::Builder    ();
  42
  43 use vars qw{$VERSION @ISA @EXPORT};
  44 BEGIN {
  45         $VERSION = '1.07';
  46         @ISA     = 'Exporter';
  47         @EXPORT  = qw{
  48                 script_compiles
  49                 script_compiles_ok
  50                 script_runs
  51         };
  52 }
  53
  54 sub import {
  55         my $self = shift;
  56         my $pack = caller;
  57         my $test = Test::Builder->new;
  58         $test->exported_to($pack);
  59         $test->plan(@_);
  60         foreach ( @EXPORT ) {
  61                 $self->export_to_level(1, $self, $_);
  62         }
  63 }
  64
  65 my $perl = undef;
  66
  67 sub perl () {
  68         $perl or
  69         $perl = Probe::Perl->find_perl_interpreter;
  70 }
  71
  72 sub path ($) {
  73         my $path = shift;
  74         unless ( defined $path ) {
  75                 Carp::croak("Did not provide a script name");
  76         }
  77         if ( File::Spec::Unix->file_name_is_absolute($path) ) {
  78                 Carp::croak("Script name must be relative");
  79         }
  80         File::Spec->catfile(
  81                 File::Spec->curdir,
  82                 split /\//, $path
  83         );
  84 }
  85
  86
  87
  88
  89
  90 #####################################################################
  91 # Test Functions
  92
  93 =pod
  94
  95 =head2 script_compiles
  96
  97     script_compiles( 'script/foo.pl', 'Main script compiles' );
  98
  99 The C<script_compiles> test calls the script with "perl -c script.pl",
 100 and checks that it returns without error.
 101
 102 The path it should be passed is a relative unix-format script name. This
 103 will be localised when running C<perl -c> and if the test fails the local
 104 name used will be shown in the diagnostic output.
 105
 106 Note also that the test will be run with the same L<perl> interpreter that
 107 is running the test script (and not with the default system perl). This
 108 will also be shown in the diagnostic output on failure.
 109
 110 =cut
 111
 112 sub script_compiles {
 113         my $args   = _script(shift);
 114         my $unix   = shift @$args;
 115         my $path   = path( $unix );
 116         my $cmd    = [ perl, '-Mblib', '-c', $path, @$args ];
 117         my $stdin  = '';
 118         my $stdout = '';
 119         my $stderr = '';
 120         my $rv     = IPC::Run3::run3( $cmd, \$stdin, \$stdout, \$stderr );
 121         my $exit   = $? ? ($? >> 8) : 0;
 122         my $ok     = !! (
 123                 $rv and $exit == 0 and $stderr =~ /syntax OK\s+\z/si
 124         );
 125
 126         my $test = Test::Builder->new;
 127         $test->ok( $ok, $_[0] || "Script $unix compiles" );
 128         $test->diag( "$exit - $stderr" ) unless $ok;
 129
 130         return $ok;
 131 }
 132
 133 =pod
 134
 135 =head2 script_runs
 136
 137     script_runs( 'script/foo.pl', 'Main script runs' );
 138
 139 The C<script_runs> test executes the script with "perl script.pl" and checks
 140 that it returns success.
 141
 142 The path it should be passed is a relative unix-format script name. This
 143 will be localised when running C<perl -c> and if the test fails the local
 144 name used will be shown in the diagnostic output.
 145
 146 The test will be run with the same L<perl> interpreter that is running the
 147 test script (and not with the default system perl). This will also be shown
 148 in the diagnostic output on failure.
 149
 150 =cut
 151
 152 sub script_runs {
 153         my $args   = _script(shift);
 154         my $unix   = shift @$args;
 155         my $path   = path( $unix );
 156         my $cmd    = [ perl, '-Mblib', $path, @$args ];
 157         my $stdin  = '';
 158         my $stdout = '';
 159         my $stderr = '';
 160         my $rv     = IPC::Run3::run3( $cmd, \$stdin, \$stdout, \$stderr );
 161         my $exit   = $? ? ($? >> 8) : 0;
 162         my $ok     = !! ( $rv and $exit == 0 );
 163
 164         my $test = Test::Builder->new;
 165         $test->ok( $ok, $_[0] || "Script $unix runs" );
 166         $test->diag( "$exit - $stderr" ) unless $ok;
 167
 168         return $ok;
 169 }
 170
 171
 172
 173
 174
 175 ######################################################################
 176 # Support Functions
 177
 178 # Script params must be either a simple non-null string with the script
 179 # name, or an array reference with one or more non-null strings.
 180 sub _script {
 181         my $in = shift;
 182         if ( defined _STRING($in) ) {
 183                 return [ $in ];
 184         }
 185         if ( _ARRAY($in) ) {
 186                 unless ( scalar grep { not defined _STRING($_) } @$in ) {
 187                         return $in;
 188                 }
 189         }
 190         Carp::croak("Invalid command parameter");
 191 }
 192
 193 # Inline some basic Params::Util functions
 194
 195 sub _ARRAY ($) {
 196         (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
 197 }
 198
 199 sub _STRING ($) {
 200         (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
 201 }
 202
 203 BEGIN {
 204         # Alias to old name
 205         *script_compiles_ok = *script_compiles;
 206 }
 207
 208 1;
 209
 210 =pod
 211
 212 =head1 SUPPORT
 213
 214 All bugs should be filed via the bug tracker at
 215
 216 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Script>
 217
 218 For other issues, or commercial enhancement and support, contact the author.
 219
 220 =head1 AUTHOR
 221
 222 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 223
 224 =head1 SEE ALSO
 225
 226 L<prove>, L<http://ali.as/>
 227
 228 =head1 COPYRIGHT
 229
 230 Copyright 2006 - 2009 Adam Kennedy.
 231
 232 This program is free software; you can redistribute
 233 it and/or modify it under the same terms as Perl itself.
 234
 235 The full text of the license can be found in the
 236 LICENSE file included with this module.
 237
 238 =cut