ext/IO/t/IO.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN {
   4     unless(grep /blib/, @INC) {
   5         chdir 't' if -d 't';
   6         @INC = '../lib';
   7     }
   8         require Config;
   9         if ($Config::Config{'extensions'} !~ /\bSocket\b/) {
  10                 print "1..0 # Skip: Socket not built - IO.pm uses Socket";
  11                 exit 0;
  12         }
  13 }
  14
  15 use strict;
  16 use File::Path;
  17 use File::Spec;
  18 require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
  19 plan(tests => 18);
  20
  21 {
  22         require XSLoader;
  23
  24         my @load;
  25         local $^W;
  26         local *XSLoader::load = sub {
  27                 push @load, \@_;
  28         };
  29
  30         # use_ok() calls import, which we do not want to do
  31         require_ok( 'IO' );
  32         ok( @load, 'IO should call XSLoader::load()' );
  33         is( $load[0][0], 'IO', '... loading the IO library' );
  34         is( $load[0][1], $IO::VERSION, '... with the current .pm version' );
  35 }
  36
  37 my @default = map { "IO/$_.pm" } qw( Handle Seekable File Pipe Socket Dir );
  38 delete @INC{ @default };
  39
  40 my $warn = '' ;
  41 local $SIG{__WARN__} = sub { $warn = "@_" } ;
  42
  43 {
  44     no warnings ;
  45     IO->import();
  46     is( $warn, '', "... import default, should not warn");
  47     $warn = '' ;
  48 }
  49
  50 {
  51     local $^W = 0;
  52     IO->import();
  53     is( $warn, '', "... import default, should not warn");
  54     $warn = '' ;
  55 }
  56
  57 {
  58     local $^W = 1;
  59     IO->import();
  60     like( $warn, qr/^Parameterless "use IO" deprecated at/,
  61               "... import default, should warn");
  62     $warn = '' ;
  63 }
  64
  65 {
  66     use warnings 'deprecated' ;
  67     IO->import();
  68     like( $warn, qr/^Parameterless "use IO" deprecated at/,
  69               "... import default, should warn");
  70     $warn = '' ;
  71 }
  72
  73 {
  74     use warnings ;
  75     IO->import();
  76     like( $warn, qr/^Parameterless "use IO" deprecated at/,
  77               "... import default, should warn");
  78     $warn = '' ;
  79 }
  80
  81 foreach my $default (@default)
  82 {
  83         ok( exists $INC{ $default }, "... import should default load $default" );
  84 }
  85
  86 eval { IO->import( 'nothere' ) };
  87 like( $@, qr/Can.t locate IO.nothere\.pm/, '... croaking on any error' );
  88
  89 my $fakedir = File::Spec->catdir( 'lib', 'IO' );
  90 my $fakemod = File::Spec->catfile( $fakedir, 'fakemod.pm' );
  91
  92 my $flag;
  93 if ( -d $fakedir or mkpath( $fakedir ))
  94 {
  95         if (open( OUT, ">$fakemod"))
  96         {
  97                 (my $package = <<'              END_HERE') =~ tr/\t//d;
  98                 package IO::fakemod;
  99
 100                 sub import { die "Do not import!\n" }
 101
 102                 sub exists { 1 }
 103
 104                 1;
 105                 END_HERE
 106
 107                 print OUT $package;
 108         }
 109
 110         if (close OUT)
 111         {
 112                 $flag = 1;
 113                 push @INC, 'lib';
 114         }
 115 }
 116
 117 SKIP:
 118 {
 119         skip("Could not write to disk", 2 ) unless $flag;
 120         eval { IO->import( 'fakemod' ) };
 121         ok( IO::fakemod::exists(), 'import() should import IO:: modules by name' );
 122         is( $@, '', '... and should not call import() on imported modules' );
 123 }
 124
 125 END
 126 {
 127         1 while unlink $fakemod;
 128         rmdir $fakedir;
 129 }