t/test.pm

   1 # (X)Emacs mode: -*- cperl -*-
   2
   3 package test;
   4
   5 =head1 NAME
   6
   7 test - tools for helping in test suites (not including running externalprograms).
   8
   9 =head1 SYNOPSIS
  10
  11   use FindBin               1.42 qw( $Bin );
  12   use Test                  1.13 qw( ok plan );
  13
  14   BEGIN { unshift @INC, $Bin };
  15
  16   use test                  qw(   evcheck runcheck );
  17
  18   BEGIN {
  19     plan tests  => 3,
  20          todo   => [],
  21          ;
  22   }
  23
  24   ok evcheck(sub {
  25                open my $fh, '>', 'foo';
  26                print $fh "$_\n"
  27                  for 'Bulgaria', 'Cholet';
  28                close $fh;
  29              }, 'write foo'), 1, 'write foo';
  30
  31 =head1 DESCRIPTION
  32
  33 This package provides some variables, and sets up an environment, for test
  34 scripts, such as those used in F<t/>.
  35
  36 This package does not including running external programs; that is provided by
  37 C<test2.pm>.  This is so that suites not needing that can include only
  38 test.pm, and so not require the presence of C<IPC::Run>.
  39
  40 Setting up the environment includes:
  41
  42 =over 4
  43
  44 =item Prepending F<blib/script> onto the path
  45
  46 =item Pushing the module F<lib/> dir onto the @INC var
  47
  48 For internal C<use> calls.
  49
  50 =item Changing directory to a temporary directory
  51
  52 To avoid cluttering the local dir, and/or allowing the local directory
  53 structure to affect matters.
  54
  55 =item Cleaning up the temporary directory afterwards
  56
  57 Unless TEST_DEBUG is set in the environment.
  58
  59 =back
  60
  61 =cut
  62
  63 # ----------------------------------------------------------------------------
  64
  65 # Pragmas -----------------------------
  66
  67 use 5.00503;
  68 use strict;
  69 use vars qw( @EXPORT_OK );
  70
  71 # Inheritance -------------------------
  72
  73 use base qw( Exporter );
  74
  75 =head2 EXPORTS
  76
  77 The following symbols are exported upon request:
  78
  79 =over 4
  80
  81 =item evcheck
  82
  83 =back
  84
  85 =cut
  86
  87 @EXPORT_OK = qw( evcheck );
  88
  89 # Utility -----------------------------
  90
  91 use Carp                          qw( carp croak );
  92 use Cwd                      2.01 qw( cwd );
  93 use Env                           qw( PATH );
  94 use Fatal                    1.02 qw( close open seek sysopen unlink );
  95 use Fcntl                    1.03 qw( :DEFAULT );
  96 use File::Basename                qw( basename );
  97 use File::Path             1.0401 qw( mkpath rmtree );
  98 use File::Spec                0.6 qw( );
  99 use File::Temp                    qw( tempdir );
 100 use FindBin                  1.42 qw( $Bin );
 101 #use POSIX                    1.02 qw( );
 102 use Test                    1.122 qw( ok skip );
 103
 104 # ----------------------------------------------------------------------------
 105
 106 # -------------------------------------
 107 # PACKAGE CONSTANTS
 108 # -------------------------------------
 109
 110 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
 111
 112 # -------------------------------------
 113 # PACKAGE ACTIONS
 114 # -------------------------------------
 115
 116 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
 117
 118 $| = 1;
 119
 120 # -------------------------------------
 121 # PACKAGE FUNCTIONS
 122 # -------------------------------------
 123
 124 =head2 evcheck
 125
 126 Eval code, return status
 127
 128 =over 4
 129
 130 =item ARGUMENTS
 131
 132 =over 4
 133
 134 =item code
 135
 136 Coderef to eval
 137
 138 =item name
 139
 140 Name to use in error messages
 141
 142 =back
 143
 144 =item RETURNS
 145
 146 =over 4
 147
 148 =item okay
 149
 150 1 if eval was okay, 0 if not.
 151
 152 =back
 153
 154 =back
 155
 156 =cut
 157
 158 sub evcheck {
 159   my ($code, $name) = @_;
 160
 161   my $ok = 0;
 162
 163   eval {
 164     &$code;
 165     $ok = 1;
 166   }; if ( $@ ) {
 167     carp "Code $name failed: $@\n"
 168       if $ENV{TEST_DEBUG};
 169     $ok = 0;
 170   }
 171
 172   return $ok;
 173 }
 174
 175 # -------------------------------------
 176
 177 # defined further up to use in constants
 178
 179 # ----------------------------------------------------------------------------
 180
 181 =head1 EXAMPLES
 182
 183 Z<>
 184
 185 =head1 BUGS
 186
 187 Z<>
 188
 189 =head1 REPORTING BUGS
 190
 191 Email the author.
 192
 193 =head1 AUTHOR
 194
 195 Martyn J. Pearce C<fluffy@cpan.org>
 196
 197 =head1 COPYRIGHT
 198
 199 Copyright (c) 2001, 2002, 2004 Martyn J. Pearce.  This program is free
 200 software; you can redistribute it and/or modify it under the same terms as
 201 Perl itself.
 202
 203 =head1 SEE ALSO
 204
 205 Z<>
 206
 207 =cut
 208
 209 1; # keep require happy.
 210
 211 __END__