lib/ExtUtils/t/Mkbootstrap.t

   1 #!./perl -w
   2
   3 BEGIN {
   4         chdir 't' if -d 't';
   5         @INC = '../lib';
   6 }
   7
   8 use vars qw( $required );
   9 use Test::More tests => 18;
  10
  11 use_ok( 'ExtUtils::Mkbootstrap' );
  12
  13 # Mkbootstrap makes a backup copy of "$_[0].bs" if it exists and is non-zero
  14 my $file_is_ready;
  15 local *OUT;
  16 if (open(OUT, '>mkboot.bs')) {
  17         $file_is_ready = 1;
  18         print OUT 'meaningless text';
  19         close OUT;
  20 }
  21
  22 SKIP: {
  23         skip("could not make dummy .bs file: $!", 2) unless $file_is_ready;
  24
  25         Mkbootstrap('mkboot');
  26         ok( -s 'mkboot.bso', 'Mkbootstrap should backup the .bs file' );
  27         local *IN;
  28         if (open(IN, 'mkboot.bso')) {
  29                 chomp ($file_is_ready = <IN>);
  30                 close IN;
  31         }
  32
  33         is( $file_is_ready, 'meaningless text', 'backup should be a perfect copy' );
  34 }
  35
  36
  37 # if it doesn't exist or is zero bytes in size, it won't be backed up
  38 Mkbootstrap('fakeboot');
  39 ok( !( -f 'fakeboot.bso' ), 'Mkbootstrap should not backup an empty file' );
  40
  41
  42 my $out = tie *STDOUT, 'TieOut';
  43
  44 # with $Verbose set, it should print status messages about libraries
  45 $ExtUtils::Mkbootstrap::Verbose = 1;
  46 Mkbootstrap('');
  47 is( $out->read, "\tbsloadlibs=\n", 'should report libraries in Verbose mode' );
  48
  49 Mkbootstrap('', 'foo');
  50 like( $out->read, qr/bsloadlibs=foo/, 'should still report libraries' );
  51
  52
  53 # if ${_[0]}_BS exists, require it
  54 $file_is_ready = open(OUT, '>boot_BS');
  55
  56 SKIP: {
  57         skip("cannot open boot_BS for writing: $!", 1) unless $file_is_ready;
  58
  59         print OUT '$main::required = 1';
  60         close OUT;
  61         Mkbootstrap('boot');
  62
  63         ok( $required, 'baseext_BS file should be require()d' );
  64 }
  65
  66
  67 # if there are any arguments, open a file named baseext.bs
  68 $file_is_ready = open(OUT, '>dasboot.bs');
  69
  70 SKIP: {
  71         skip("cannot make dasboot.bs: $!", 5) unless $file_is_ready;
  72
  73         # if it can't be opened for writing, we want to prove that it'll die
  74         close OUT;
  75         chmod 0444, 'dasboot.bs';
  76
  77         SKIP: {
  78             skip("can write readonly files", 1) if -w 'dasboot.bs';
  79
  80             eval{ Mkbootstrap('dasboot', 1) };
  81             like( $@, qr/Unable to open dasboot\.bs/, 'should die given bad filename' );
  82         }
  83
  84         # now put it back like it was
  85         chmod 0777, 'dasboot.bs';
  86         eval{ Mkbootstrap('dasboot', 'myarg') };
  87         is( $@, '', 'should not die, given good filename' );
  88
  89         # red and reed (a visual pun makes tests worth reading)
  90         my $read = $out->read();
  91         like( $read, qr/Writing dasboot.bs/, 'should print status' );
  92         like( $read, qr/containing: my/, 'should print verbose status on request' );
  93
  94         # now be tricky, and set the status for the next skip block
  95         $file_is_ready = open(IN, 'dasboot.bs');
  96         ok( $file_is_ready, 'should have written a new .bs file' );
  97 }
  98
  99
 100 SKIP: {
 101         skip("cannot read .bs file: $!", 2) unless $file_is_ready;
 102
 103         my $file = do { local $/ = <IN> };
 104
 105         # filename should be in header
 106         like( $file, qr/# dasboot DynaLoader/, 'file should have boilerplate' );
 107
 108         # should print arguments within this array
 109         like( $file, qr/qw\(myarg\);/, 'should have written array to file' );
 110 }
 111
 112
 113 # overwrite this file (may whack portability, but the name's too good to waste)
 114 $file_is_ready = open(OUT, '>dasboot.bs');
 115
 116 SKIP: {
 117         skip("cannot make dasboot.bs again: $!", 1) unless $file_is_ready;
 118         close OUT;
 119
 120         # if $DynaLoader::bscode is set, write its contents to the file
 121         # localize the variable to prevent "used only once"
 122         local $DynaLoader::bscode;
 123         $DynaLoader::bscode = 'Wall';
 124         $ExtUtils::Mkbootstrap::Verbose = 0;
 125
 126         # if arguments contain '-l' or '-L' or '-R' print dl_findfile message
 127         eval{ Mkbootstrap('dasboot', '-Larry') };
 128         is( $@, '', 'should be able to open a file again');
 129
 130         $file_is_ready = open(IN, 'dasboot.bs');
 131 }
 132
 133 SKIP: {
 134         skip("cannot open dasboot.bs for reading: $!", 3) unless $file_is_ready;
 135
 136         my $file = do { local $/ = <IN> };
 137         is( $out->read, "Writing dasboot.bs\n", 'should hush without Verbose set' );
 138
 139         # and find our hidden tribute to a fine example
 140         like( $file, qr/dl_findfile.+Larry/s, 'should load libraries if needed' );
 141         like( $file, qr/Wall\n1;\n/ms, 'should write $DynaLoader::bscode if set' );
 142 }
 143
 144 close IN;
 145 close OUT;
 146
 147 END {
 148         # clean things up, even on VMS
 149         1 while unlink(qw( mkboot.bso boot_BS dasboot.bs .bs ));
 150 }
 151
 152 package TieOut;
 153
 154 sub TIEHANDLE {
 155         bless( \(my $scalar), $_[0]);
 156 }
 157
 158 sub PRINT {
 159         my $self = shift;
 160         $$self .= join('', @_);
 161 }
 162
 163 sub read {
 164         my $self = shift;
 165         return substr($$self, 0, length($$self), '');
 166 }