effd414a4c5fb7d21d7c2b900e0c421a86fc4705
[perl.git] / ext / IO / t / IO.t
1 #!/usr/bin/perl -w
2
3 BEGIN {
4     if ($ENV{PERL_CORE}) {
5         require Config;
6         if ($Config::Config{'extensions'} !~ /\bSocket\b/) {
7                 print "1..0 # Skip: Socket not built - IO.pm uses Socket";
8                 exit 0;
9         }
10     }
11 }
12
13 use strict;
14 use File::Path;
15 use File::Spec;
16 require($ENV{PERL_CORE} ? "../../t/test.pl" : "./t/test.pl");
17 plan(tests => 18);
18
19 {
20         require XSLoader;
21
22         my @load;
23         local $^W;
24         local *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 }