Re: [perl #20551] Documentation error for IO::Select

[p5sagit/p5-mst-13.2.git] / ext / IO / lib / IO / t / IO.t

#!/usr/bin/perl -w

BEGIN
{
	chdir 't' if -d 't';
	@INC = '../lib';
}

use strict;
use File::Path;
use File::Spec;
use Test::More tests => 18;

{
	local $INC{'XSLoader.pm'} = 1;
	local *XSLoader::load;

	my @load;
	*XSLoader::load = sub {
		push @load, \@_;
	};

	# use_ok() calls import, which we do not want to do
	require_ok( 'IO' );
	ok( @load, 'IO should call XSLoader::load()' );
	is( $load[0][0], 'IO', '... loading the IO library' );
	is( $load[0][1], $IO::VERSION, '... with the current .pm version' );
}

my @default = map { "IO/$_.pm" } qw( Handle Seekable File Pipe Socket Dir );
delete @INC{ @default };

my $warn = '' ;
local $SIG{__WARN__} = sub { $warn = "@_" } ;

{
    no warnings ;
    IO->import();
    is( $warn, '', "... import default, should not warn");
    $warn = '' ;
}

{
    local $^W = 0;
    IO->import();
    is( $warn, '', "... import default, should not warn");
    $warn = '' ;
}

{
    local $^W = 1;
    IO->import();
    like( $warn, qr/^parameterless "use IO" deprecated at/, 
              "... import default, should warn");
    $warn = '' ;
}

{
    use warnings 'deprecated' ;
    IO->import(); 
    like( $warn, qr/^parameterless "use IO" deprecated at/, 
              "... import default, should warn");
    $warn = '' ;
}

{
    use warnings ;
    IO->import();
    like( $warn, qr/^parameterless "use IO" deprecated at/, 
              "... import default, should warn");
    $warn = '' ;
}

foreach my $default (@default)
{
	ok( exists $INC{ $default }, "... import should default load $default" );
}

eval { IO->import( 'nothere' ) };
like( $@, qr/Can.t locate IO.nothere\.pm/, '... croaking on any error' );

my $fakedir = File::Spec->catdir( 'lib', 'IO' );
my $fakemod = File::Spec->catfile( $fakedir, 'fakemod.pm' );

my $flag;
if ( -d $fakedir or mkpath( $fakedir ))
{
	if (open( OUT, ">$fakemod"))
	{
		(my $package = <<'		END_HERE') =~ tr/\t//d;
		package IO::fakemod;

		sub import { die "Do not import!\n" }

		sub exists { 1 }

		1;
		END_HERE

		print OUT $package;
	}

	if (close OUT)
	{
		$flag = 1;
		push @INC, 'lib';
	}
}

SKIP:
{
	skip("Could not write to disk", 2 ) unless $flag;
	eval { IO->import( 'fakemod' ) };
	ok( IO::fakemod::exists(), 'import() should import IO:: modules by name' );
	is( $@, '', '... and should not call import() on imported modules' );
}

END
{
	1 while unlink $fakemod;
}