ext/IO/t/IO.t

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