t/lib/MakeMaker/Test/Setup/BFD.pm

   1 package MakeMaker::Test::Setup::BFD;
   2
   3 @ISA = qw(Exporter);
   4 require Exporter;
   5 @EXPORT = qw(setup_recurs teardown_recurs);
   6
   7 use strict;
   8 use File::Path;
   9 use File::Basename;
  10
  11
  12 my %Files = (
  13              'Big-Dummy/lib/Big/Dummy.pm'     => <<'END',
  14 package Big::Dummy;
  15
  16 $VERSION = 0.01;
  17
  18 =head1 NAME
  19
  20 Big::Dummy - Try "our" hot dog's
  21
  22 =cut
  23
  24 1;
  25 END
  26
  27              'Big-Dummy/Makefile.PL'          => <<'END',
  28 use ExtUtils::MakeMaker;
  29
  30 # This will interfere with the PREREQ_PRINT tests.
  31 printf "Current package is: %s\n", __PACKAGE__ unless "@ARGV" =~ /PREREQ/;
  32
  33 WriteMakefile(
  34     NAME          => 'Big::Dummy',
  35     VERSION_FROM  => 'lib/Big/Dummy.pm',
  36     PREREQ_PM     => { strict => 0 },
  37     ABSTRACT_FROM => 'lib/Big/Dummy.pm',
  38     AUTHOR        => 'Michael G Schwern <schwern@pobox.com>',
  39 );
  40 END
  41
  42              'Big-Dummy/t/compile.t'          => <<'END',
  43 print "1..2\n";
  44
  45 print eval "use Big::Dummy; 1;" ? "ok 1\n" : "not ok 1\n";
  46 print "ok 2 - TEST_VERBOSE\n";
  47 END
  48
  49              'Big-Dummy/Liar/t/sanity.t'      => <<'END',
  50 print "1..3\n";
  51
  52 print eval "use Big::Dummy; 1;" ? "ok 1\n" : "not ok 1\n";
  53 print eval "use Big::Liar; 1;" ? "ok 2\n" : "not ok 2\n";
  54 print "ok 3 - TEST_VERBOSE\n";
  55 END
  56
  57              'Big-Dummy/Liar/lib/Big/Liar.pm' => <<'END',
  58 package Big::Liar;
  59
  60 $VERSION = 0.01;
  61
  62 1;
  63 END
  64
  65              'Big-Dummy/Liar/Makefile.PL'     => <<'END',
  66 use ExtUtils::MakeMaker;
  67
  68 my $mm = WriteMakefile(
  69               NAME => 'Big::Liar',
  70               VERSION_FROM => 'lib/Big/Liar.pm',
  71               _KEEP_AFTER_FLUSH => 1
  72              );
  73
  74 print "Big::Liar's vars\n";
  75 foreach my $key (qw(INST_LIB INST_ARCHLIB)) {
  76     print "$key = $mm->{$key}\n";
  77 }
  78 END
  79
  80             );
  81
  82
  83 sub _setup_bfd_test_root {
  84     if( $^O eq 'VMS' ) {
  85         # On older systems we might exceed the 8-level directory depth limit
  86         # imposed by RMS.  We get around this with a rooted logical, but we
  87         # can't create logical names with attributes in Perl, so we do it
  88         # in a DCL subprocess and put it in the job table so the parent sees it.
  89         open( BFDTMP, '>bfdtesttmp.com' ) ||
  90           die "Error creating command file; $!";
  91         print BFDTMP <<'COMMAND';
  92 $ BFD_TEST_ROOT = F$PARSE("SYS$DISK:[-]",,,,"NO_CONCEAL")-".][000000"-"]["-"].;"+".]"
  93 $ DEFINE/JOB/NOLOG/TRANSLATION=CONCEALED BFD_TEST_ROOT 'BFD_TEST_ROOT'
  94 COMMAND
  95         close BFDTMP;
  96
  97         system '@bfdtesttmp.com';
  98         1 while unlink 'bfdtesttmp.com';
  99     }
 100 }
 101
 102 sub setup_recurs {
 103     _setup_bfd_test_root();
 104
 105     while(my($file, $text) = each %Files) {
 106         # Convert to a relative, native file path.
 107         $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
 108
 109         my $dir = dirname($file);
 110         mkpath $dir;
 111         open(FILE, ">$file") || die "Can't create $file: $!";
 112         print FILE $text;
 113         close FILE;
 114     }
 115
 116     return 1;
 117 }
 118
 119 sub teardown_recurs {
 120     foreach my $file (keys %Files) {
 121         my $dir = dirname($file);
 122         if( -e $dir ) {
 123             rmtree($dir) || return;
 124         }
 125     }
 126     return 1;
 127 }
 128
 129
 130 1;