FileHandle-Fmode-0.13/0000755000076400010400000000000012045657272014775 5ustar RobAdministratorsFileHandle-Fmode-0.13/CHANGES0000644000076400010400000000211212045417200015745 0ustar RobAdministrators0.13 - Apply patch from Xavier Guimard. (Ticket 80607) 0.12 - Apply patch from Diab Jerius. (Ticket #79983) 0.11 - Add copyright notice to the LICENSE section of the pod. 0.10 - Add is_FH() - which is just a (more intuitively named) alias for is_arg_ok(). Various minor adjustments to enable trouble-free building on pre-5.6. 0.09 - Correct error that prevents the module from building on perl 5.6.0. 0.08 - Add is_A() function. Rewrite internal functions to reduce (but not completely eradicate) repetition. 0.05 - (Hopefully) fix problems with Solaris and some other operating systems re testing for readability. 0.04 - Can now handle filehandles connected to memory objects. 0.03 - Rewrite the existing functions so that they die if: 1) the received argument is not an open filehandle; or 2) the received argument is a filehandle connected to a memory object. - Add the is_arg_ok() function. 0.02 - Minor changes for compatibility with pre-5.6 versions of perl, and some tidying up. 0.01 - ummm ....FileHandle-Fmode-0.13/Fmode.pm0000644000076400010400000001450612045423311016354 0ustar RobAdministratorspackage FileHandle::Fmode; use Fcntl qw(O_ACCMODE O_RDONLY O_WRONLY O_RDWR O_APPEND F_GETFL); use strict; require Exporter; require DynaLoader; *is_FH = \&is_arg_ok; our $VERSION = '0.13'; $VERSION = eval $VERSION; @FileHandle::Fmode::ISA = qw(Exporter DynaLoader); @FileHandle::Fmode::EXPORT_OK = qw(is_R is_W is_RO is_WO is_RW is_arg_ok is_A is_FH); %FileHandle::Fmode::EXPORT_TAGS = (all => [qw (is_R is_W is_RO is_WO is_RW is_arg_ok is_A is_FH)]); bootstrap FileHandle::Fmode $VERSION; my $is_win32 = $^O =~ /mswin32/i ? 1 : 0; sub is_arg_ok { my $fileno = eval{fileno($_[0])}; if($@) {return 0} if(defined($fileno)) { if($fileno == -1) { if($] < 5.007) {return 0} return 1; } return 1; } return 0; } sub is_RO { my $fileno = fileno($_[0]); if(!defined( $fileno)) {die "Not an open filehandle"} if( $fileno == -1) { if($] < 5.007) {die "Illegal fileno() return"} if(perliol_readable($_[0]) && !perliol_writable($_[0])) {return 1} return 0; } if($is_win32) { if(win32_fmode($_[0]) & 1) {return 1} return 0; } my $fmode = fcntl($_[0], F_GETFL, my $slush = 0); if(defined($fmode) && ($fmode & O_ACCMODE) == O_RDONLY) {return 1} return 0; } sub is_WO { my $fileno = fileno($_[0]); if(!defined( $fileno)) {die "Not an open filehandle"} if( $fileno == -1) { if($] < 5.007) {die "Illegal fileno() return"} if(!perliol_readable($_[0]) && perliol_writable($_[0])) {return 1} return 0; } if($is_win32) { if(win32_fmode($_[0]) & 2) {return 1} return 0; } my $fmode = fcntl($_[0], F_GETFL, my $slush = 0); if(defined($fmode) && ($fmode & O_ACCMODE) == O_WRONLY) {return 1} return 0; } sub is_W { if(is_WO($_[0]) || is_RW($_[0])) {return 1} return 0; } sub is_R { if(is_RO($_[0]) || is_RW($_[0])) {return 1} return 0; } sub is_RW { my $fileno = fileno($_[0]); if(!defined( $fileno)) {die "Not an open filehandle"} if( $fileno == -1) { if($] < 5.007) {die "Illegal fileno() return"} if(perliol_readable($_[0]) && perliol_writable($_[0])) {return 1} return 0; } if($is_win32) { if(win32_fmode($_[0]) & 128) {return 1} return 0; } my $fmode = fcntl($_[0], F_GETFL, my $slush = 0); if(defined($fmode) && ($fmode & O_ACCMODE) == O_RDWR) {return 1} return 0; } sub is_A { my $fileno = fileno($_[0]); if(!defined( $fileno)) {die "Not an open filehandle"} if( $fileno == -1) { if($] < 5.007) {die "Illegal fileno() return"} return is_appendable($_[0]); } if($is_win32) { if($] < 5.006001) {die "is_A not currently implemented on Win32 for pre-5.6.1 perl"} return is_appendable($_[0]); } my $fmode = fcntl($_[0], F_GETFL, my $slush = 0); if($fmode & O_APPEND) {return 1} return 0; } 1; __END__ =head1 NAME FileHandle::Fmode - determine whether a filehandle is opened for reading, writing, or both. =head1 SYNOPSIS use FileHandle::Fmode qw(:all); . . #$fh and FH are open filehandles print is_R($fh), "\n"; print is_W(\*FH), "\n"; =head1 FUNCTIONS $bool = is_FH($fh); $bool = is_FH(\*FH); This is just a (more intuitively named) alias for is_arg_ok(). Returns 1 if its argument is an open filehandle. Returns 0 if its argument is something other than an open filehandle. $bool = is_arg_ok($fh); $bool = is_arg_ok(\*FH); Returns 1 if its argument is an open filehandle. Returns 0 if its argument is something other than an open filehandle. Arguments to the following functions must be open filehandles. If any of those functions receive an argument that is not an open filehandle then the function dies with an appropriate error message. To ensure that your script won't suffer such a death, you could first check by passing the argument to is_FH(). Or you could wrap the function call in an eval{} block. Note that it may be possible that a filehandle opened for writing may become unwritable - if (eg) the disk becomes full. I don't know how the below functions would be affected by such an event. I suspect that they would be unaware of the change ... but I haven't actually checked. $bool = is_R($fh); $bool = is_R(\*FH); Returns true if the filehandle is readable. Else returns false. $bool = is_W($fh); $bool = is_W(\*FH); Returns true if the filehandle is writable. Else returns false $bool = is_RO($fh); $bool = is_RO(\*FH); Returns true if the filehandle is readable but not writable. Else returns false $bool = is_WO($fh); $bool = is_WO(\*FH); Returns true if the filehandle is writable but not readable. Else returns false $bool = is_RW($fh); $bool = is_RW(\*FH); Returns true if the filehandle is both readable and writable. Else returns false $bool = is_A($fh); $bool = is_A(\*FH); Returns true if the filehandle was opened for appending. Else returns false. Not currently implemented on Win32 with pre-5.6.1 versions of perl (and dies with appropriate error message if called on such a platform). =head1 CREDITS Inspired (hmmm ... is that the right word ?) by an idea from BrowserUK posted on PerlMonks in response to a question from dragonchild. Win32 code (including XS code) provided by BrowserUK. Zaxo presented the idea of using fcntl() in an earlier PerlMonks thread. Thanks to dragonchild and BrowserUK for steering this module in the right direction. Thanks to attn.steven.kuo for directing me to the perliol routines that enable us to query filehandles attached to memory objects. And thanks to Jost Krieger for helping to sort out the test failures that were occurring on Solaris (and some other operating systems too). =head1 TODO I don't know that anyone still runs pre-5.6.1 perl on Win32. However, if someone likes to tell me how is_A() could be made to work on pre-5.6.1 Win32 perl, I would be quite happy to implement it. =head1 LICENSE This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. Copyright 2006-2008, 2009, 2010, 2012 Sisyphus =head1 AUTHOR Sisyphus =cut FileHandle-Fmode-0.13/Fmode.xs0000644000076400010400000000432710710654502016377 0ustar RobAdministrators#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef _WIN32 /* * Win32 code supplied by BrowserUK * to work aroumd the MS C runtime library's * lack of a function to retrieve the file mode * used when a file is opened */ SV * win32_fmode( FILE *stream ) { return newSViv(stream->_flag); } #else SV * win32_fmode( FILE *stream ) { croak("win32_fmode() function works only with Win32"); } #endif #ifdef PERL580_OR_LATER /* * XS code to deal with filehandles * attached to memory objects supplied * by attn.steven.kuo. (Applies only * to perl 5.8 and later.) */ #include SV * perliol_readable(SV * handle) { IV flags; IO *io; PerlIO *f; io = sv_2io(handle); f = IoIFP(io); if(PerlIOValid(f)){ flags = PerlIOBase(f)->flags; if(flags & PERLIO_F_CANREAD) return newSVuv(1); return newSVuv(0); } croak("Couldn't validate the filehandle passed to perliol_readable()"); } SV * perliol_writable(SV * handle) { IV flags; IO *io; PerlIO *f; io = sv_2io(handle); f = IoIFP(io); if(PerlIOValid(f)){ flags = PerlIOBase(f)->flags; if(flags & PERLIO_F_CANWRITE) return newSVuv(1); return newSVuv(0); } croak("Couldn't validate the filehandle passed to perliol_writable()"); } #else SV * perliol_readable(SV * handle) { croak("perliol_readable() function works only with perl 5.8 or later"); } SV * perliol_writable( SV * handle ) { croak("perliol_writable() function works only with perl 5.8 or later"); } #endif #ifdef PERL561_OR_LATER SV * is_appendable(SV * handle) { IO *io; io = sv_2io(handle); if (IoTYPE(io) == IoTYPE_APPEND) return newSVuv(1); return newSVuv(0); } #else SV * is_appendable(SV * handle){ croak("is_appendable() function implemented only with perl 5.6.1 or later"); } #endif MODULE = FileHandle::Fmode PACKAGE = FileHandle::Fmode PROTOTYPES: DISABLE SV * win32_fmode (stream) FILE *stream SV * perliol_readable (handle) SV *handle SV * perliol_writable (handle) SV *handle SV * is_appendable (handle) SV *handle FileHandle-Fmode-0.13/Makefile.PL0000644000076400010400000000047711170333126016742 0ustar RobAdministratorsuse ExtUtils::MakeMaker; my %options = ( NAME => 'FileHandle::Fmode', VERSION_FROM => 'Fmode.pm', DEFINE => $] < 5.008 ? $] < 5.006001 ? '-DOLDPERL' : '-DPERL561_OR_LATER' : '-DPERL580_OR_LATER -DPERL561_OR_LATER', clean => { FILES => 'temp.txt temp2.txt' }, ); WriteMakefile(%options); FileHandle-Fmode-0.13/MANIFEST0000644000076400010400000000013510724415024016112 0ustar RobAdministratorsMANIFEST README CHANGES Makefile.PL Fmode.pm Fmode.xs t/basic.t t/binmode.t t/pod.t FileHandle-Fmode-0.13/README0000644000076400010400000000026310426317046015647 0ustar RobAdministratorsUse this module to check whether a filehandle is readable, writable, or readable/writable. Build in the usual way: perl Makefile.PL make test make install Cheers, RobFileHandle-Fmode-0.13/t/0000755000076400010400000000000011572110344015224 5ustar RobAdministratorsFileHandle-Fmode-0.13/t/basic.t0000644000076400010400000002657410702353750016514 0ustar RobAdministratorsuse strict; use FileHandle::Fmode qw(:all); # Same tests as binmode.t - but no binmode() on the handles print "1..52\n"; my $no_skip = ($] < 5.006001 && $^O =~ /mswin32/i) ? 0 : 1; my ($rd, $wr, $rw, $one, $undef, $null, $mem, $var); open(RD, "Makefile.PL") or die "Can't open Makefile.PL for reading: $!"; unless($] < 5.006) {open($rd, "Fmode.pm") or die "Can't open Fmode.pm for reading: $!";} else {$rd = \*RD} #binmode(RD); #binmode($rd); if(is_FH(\*RD) && is_arg_ok(\*RD) && is_R(\*RD) && is_RO(\*RD) && !is_W(\*RD) && !is_WO(\*RD) && !is_RW(\*RD)) {print "ok 1\n"} else {print "not ok 1\n"} if(is_FH($rd) && is_arg_ok($rd) && is_R($rd) && is_RO($rd) && !is_W($rd) && !is_WO($rd) && !is_RW($rd)) {print "ok 2\n"} else {print "not ok 2\n"} if($no_skip) { if(!is_A(\*RD) && !is_A($rd)) {print "ok 3\n"} else {print "not ok 3\n"} } else {print "ok 3 - skipped, pre-5.6.1 Win32 perl\n"} close(RD) or die "Can't close Makefile.PL after opening for reading: $!"; unless($] < 5.006) {close($rd) or die "Can't close Fmode.pm after opening for reading: $!";} open(RD, "temp.txt") or die "Can't open temp.txt for writing: $!"; unless($] < 5.006) {open($wr, ">temp2.txt") or die "Can't open temp2.txt for writing: $!";} else {$wr = \*WR} #binmode(WR); #binmode($wr); if(is_FH(\*WR) && is_arg_ok(\*WR) && is_W(\*WR) && is_WO(\*WR)) {print "ok 7\n"} else {print "not ok 7\n"} if(is_FH($wr) && is_arg_ok($wr) && is_W($wr) && is_WO($wr)) {print "ok 8\n"} else {print "not ok 8\n"} if(!is_RO(\*WR) && !is_R(\*WR) && !is_RW(\*WR)) {print "ok 9\n"} else {print "not ok 9\n"} if(!is_RO($wr) && !is_R($wr) && !is_RW($wr)) {print "ok 10\n"} else {print "not ok 10\n"} if($no_skip) { if(!is_A(\*WR) && !is_A($wr)) {print "ok 11\n"} else {print "not ok 11\n"} } else {print "ok 11 - skipped, pre-5.6.1 Win32 perl\n"} ##################################################### close(WR) or die "Can't close temp.txt after opening for writing: $!"; unless($] < 5.006) {close($wr) or die "Can't close temp2.txt after opening for writing: $!";} open(WR, ">>temp.txt") or die "Can't open temp.txt for writing: $!"; unless($] < 5.006) {open($wr, ">>temp2.txt") or die "Can't open temp2.txt for writing: $!";} else {$wr = \*WR} #binmode(WR); #binmode($wr); if(is_FH(\*WR) && is_arg_ok(\*WR) && is_W(\*WR) && is_WO(\*WR)) {print "ok 12\n"} else {print "not ok 12\n"} if(is_FH($wr) && is_arg_ok($wr) && is_W($wr) && is_WO($wr)) {print "ok 13\n"} else {print "not ok 13\n"} if(!is_RO(\*WR) && !is_R(\*WR) && !is_RW(\*WR)) {print "ok 14\n"} else {print "not ok 14\n"} if(!is_RO($wr) && !is_R($wr) && !is_RW($wr)) {print "ok 15\n"} else {print "not ok 15\n"} if($no_skip) { if(is_A(\*WR) && is_A($wr)) {print "ok 16\n"} else {print "not ok 16\n"} } else {print "ok 16 - skipped, pre-5.6.1 Win32 perl\n"} close(WR) or die "Can't close temp.txt after opening for appending: $!"; unless($] < 5.006) {close($wr) or die "Can't close temp2.txt after opening for appending: $!";} ##################################################### open(RW, "+>temp.txt") or die "Can't open temp.txt for reading/writing: $!"; unless($] < 5.006) {open($rw, "+>temp2.txt") or die "Can't open temp2.txt for reading/writing: $!";} else {$rw = \*RW} #binmode(RW); #binmode($rw); if(is_FH(\*RW) && is_arg_ok(\*RW) && is_RW(\*RW) && is_W(\*RW) && is_R(\*RW)) {print "ok 17\n"} else {print "not ok 17\n"} if(is_FH($rw) && is_arg_ok($rw) && is_RW($rw) && is_W($rw) && is_R($rw)) {print "ok 18\n"} else {print "not ok 18\n"} if(!is_RO(\*RW) && !is_WO(\*RW)) {print "ok 19\n"} else {print "not ok 19\n"} if(!is_RO($rw) && !is_WO($rw)) {print "ok 20\n"} else {print "not ok 20\n"} if($no_skip) { if(!is_A(\*RW) && !is_A($rw)) {print "ok 21\n"} else {print "not ok 21\n"} } else {print "ok 21 - skipped, pre-5.6.1 Win32 perl\n"} close(RW) or die "Can't close temp.txt after opening for reading/writing: $!"; unless($] < 5.006) {close($rw) or die "Can't close temp2.txt after opening for reading/writing: $!";} ##################################################### open(RW, "+>temp.txt") or die "Can't open temp.txt for reading/writing: $!"; unless($] < 5.006) {open($rw, "+>>temp2.txt") or die "Can't open temp2.txt for reading/writing: $!";} else {$rw = \*RW} #binmode(RW); #binmode($rw); if(is_FH(\*RW) && is_arg_ok(\*RW) && is_RW(\*RW) && is_W(\*RW) && is_R(\*RW)) {print "ok 27\n"} else {print "not ok 27\n"} if(is_FH($rw) && is_arg_ok($rw) && is_RW($rw) && is_W($rw) && is_R($rw)) {print "ok 28\n"} else {print "not ok 28\n"} if(!is_RO(\*RW) && !is_WO(\*RW)){print "ok 29\n"} else {print "not ok 29\n"} if(!is_RO($rw) && !is_WO($rw)) {print "ok 30\n"} else {print "not ok 30\n"} if($no_skip) { if(is_A(\*RW) && is_A($rw)) {print "ok 31\n"} else {print "not ok 31\n"} } else {print "ok 31 - skipped, pre-5.6.1 Win32 perl\n"} close(RW) or die "Can't close temp.txt after opening for reading/writing: $!"; unless($] < 5.006) {close($rw) or die "Can't close temp2.txt after opening for reading/writing: $!";} eval {is_R($undef)}; if($@ && !is_arg_ok($undef)){print "ok 32\n"} else {print "not ok 32\n"} eval {is_RO($undef)}; if($@){print "ok 33\n"} else {print "not ok 33\n"} eval {is_W($undef)}; if($@){print "ok 34\n"} else {print "not ok 34\n"} eval {is_WO($undef)}; if($@){print "ok 35\n"} else {print "not ok 35\n"} eval {is_RW($undef)}; if($@){print "ok 36\n"} else {print "not ok 36\n"} if($no_skip){ eval {is_A($undef)}; if($@){print "ok 37\n"} else {print "not ok 37\n"} } else {print "ok 37 - skipped, pre-5.6.1 Win32 perl\n"} $one = 1; eval {is_R($one)}; if($@ && !is_arg_ok($one)){print "ok 38\n"} else {print "not ok 38\n"} eval {is_RO($one)}; if($@){print "ok 39\n"} else {print "not ok 39\n"} eval {is_W($one)}; if($@){print "ok 40\n"} else {print "not ok 40\n"} eval {is_WO($one)}; if($@){print "ok 41\n"} else {print "not ok 41\n"} eval {is_RW($one)}; if($@){print "ok 42\n"} else {print "not ok 42\n"} if($no_skip){ eval {is_A($one)}; if($@){print "ok 43\n"} else {print "not ok 43\n"} } else {print "ok 43 - skipped, pre-5.6.1 Win32 perl\n"} if($] >= 5.007) { $var = ''; # Avoid "uninitialised" warnings. eval q{open($mem, '<', \$var) or die "Can't open memory object: $!";}; die $@ if $@; #binmode($mem); if(is_FH($mem) && is_arg_ok($mem) && is_R($mem) && is_RO($mem) && !is_W($mem) && !is_WO($mem) && !is_RW($mem) && !is_A($mem)) {print "ok 44\n"} else {print "not ok 44\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '>', \$var) or die "Can't open memory object: $!";}; die $@ if $@; #binmode($mem); if(is_arg_ok($mem) && !is_R($mem) && !is_RO($mem) && is_W($mem) && is_WO($mem) && !is_RW($mem) && !is_A($mem)) {print "ok 45\n"} else {print "not ok 45\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '>>', \$var) or die "Can't open memory object: $!";}; die $@ if $@; #binmode($mem); if(is_FH($mem) && is_arg_ok($mem) && !is_R($mem) && !is_RO($mem) && is_W($mem) && is_WO($mem) && !is_RW($mem) && is_A($mem)) {print "ok 46\n"} else {print "not ok 46\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '+>>', \$var) or die "Can't open memory object: $!";}; die $@ if $@; #binmode($mem); if(is_arg_ok($mem) && is_R($mem) && !is_RO($mem) && is_W($mem) && !is_WO($mem) && is_RW($mem) && is_A($mem)) {print "ok 47\n"} else {print "not ok 47\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '+>', \$var) or die "Can't open memory object: $!";}; die $@ if $@; #binmode($mem); if(is_FH($mem) && is_arg_ok($mem) && is_R($mem) && !is_RO($mem) && is_W($mem) && !is_WO($mem) && is_RW($mem) && !is_A($mem)) {print "ok 48\n"} else {print "not ok 48\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '+<', \$var) or die "Can't open memory object: $!";}; die $@ if $@; #binmode($mem); if(is_FH($mem) && is_arg_ok($mem) && is_R($mem) && !is_RO($mem) && is_W($mem) && !is_WO($mem) && is_RW($mem) && !is_A($mem)) {print "ok 49\n"} else {print "not ok 49\n"} close($mem) or die "Can't close memory object: $!"; } else { print "ok 44 - skipped - pre-5.8 perl\n"; print "ok 45 - skipped - pre-5.8 perl\n"; print "ok 46 - skipped - pre-5.8 perl\n"; print "ok 47 - skipped - pre-5.8 perl\n"; print "ok 48 - skipped - pre-5.8 perl\n"; print "ok 49 - skipped - pre-5.8 perl\n"; } open(RD, "Makefile.PL") or die "Can't open Makefile.PL for reading: $!"; #binmode(RD); eval{FileHandle::Fmode::perliol_readable(\*RD);}; if($] < 5.007) { if($@ =~ /perliol_readable/) {print "ok 50\n"} else {print "not ok 50\n"} } else { if($@) {print "not ok 50\n"} else {print "ok 50\n"} } close(RD) or die "Can't close Makefile.PL after opening for reading: $!"; open(WR, ">temp2.txt") or die "Can't open temp2.txt for writing: $!"; #binmode(WR); eval{FileHandle::Fmode::perliol_writable(\*WR);}; if($] < 5.007) { if($@ =~ /perliol_writable/) {print "ok 51\n"} else {print "not ok 51\n"} } else { if($@) {print "not ok 51\n"} else {print "ok 51\n"} } eval{FileHandle::Fmode::win32_fmode(\*WR);}; if($^O =~ /mswin32/i) { if($@) {print "not ok 52\n"} else {print "ok 52\n"} } else { if($@ =~ /win32_fmode/) {print "ok 52\n"} else {print "not ok 52\n"} } close(WR) or die "Can't close temp2.txt after opening for writing: $!"; FileHandle-Fmode-0.13/t/binmode.t0000644000076400010400000002654110702354106017036 0ustar RobAdministratorsuse strict; use FileHandle::Fmode qw(:all); # Same tests as basic.t - but binmode() on the handles print "1..52\n"; my $no_skip = ($] < 5.006001 && $^O =~ /mswin32/i) ? 0 : 1; my ($rd, $wr, $rw, $one, $undef, $null, $mem, $var); open(RD, "Makefile.PL") or die "Can't open Makefile.PL for reading: $!"; unless($] < 5.006) {open($rd, "Fmode.pm") or die "Can't open Fmode.pm for reading: $!";} else {$rd = \*RD} binmode(RD); binmode($rd); if(is_FH(\*RD) && is_arg_ok(\*RD) && is_R(\*RD) && is_RO(\*RD) && !is_W(\*RD) && !is_WO(\*RD) && !is_RW(\*RD)) {print "ok 1\n"} else {print "not ok 1\n"} if(is_FH($rd) && is_arg_ok($rd) && is_R($rd) && is_RO($rd) && !is_W($rd) && !is_WO($rd) && !is_RW($rd)) {print "ok 2\n"} else {print "not ok 2\n"} if($no_skip) { if(!is_A(\*RD) && !is_A($rd)) {print "ok 3\n"} else {print "not ok 3\n"} } else {print "ok 3 - skipped, pre-5.6.1 Win32 perl\n"} close(RD) or die "Can't close Makefile.PL after opening for reading: $!"; unless($] < 5.006) {close($rd) or die "Can't close Fmode.pm after opening for reading: $!";} open(RD, "temp.txt") or die "Can't open temp.txt for writing: $!"; unless($] < 5.006) {open($wr, ">temp2.txt") or die "Can't open temp2.txt for writing: $!";} else {$wr = \*WR} binmode(WR); binmode($wr); if(is_FH(\*WR) && is_arg_ok(\*WR) && is_W(\*WR) && is_WO(\*WR)) {print "ok 7\n"} else {print "not ok 7\n"} if(is_FH($wr) && is_arg_ok($wr) && is_W($wr) && is_WO($wr)) {print "ok 8\n"} else {print "not ok 8\n"} if(!is_RO(\*WR) && !is_R(\*WR) && !is_RW(\*WR)) {print "ok 9\n"} else {print "not ok 9\n"} if(!is_RO($wr) && !is_R($wr) && !is_RW($wr)) {print "ok 10\n"} else {print "not ok 10\n"} if($no_skip) { if(!is_A(\*WR) && !is_A($wr)) {print "ok 11\n"} else {print "not ok 11\n"} } else {print "ok 11 - skipped, pre-5.6.1 Win32 perl\n"} ##################################################### close(WR) or die "Can't close temp.txt after opening for writing: $!"; unless($] < 5.006) {close($wr) or die "Can't close temp2.txt after opening for writing: $!";} open(WR, ">>temp.txt") or die "Can't open temp.txt for writing: $!"; unless($] < 5.006) {open($wr, ">>temp2.txt") or die "Can't open temp2.txt for writing: $!";} else {$wr = \*WR} binmode(WR); binmode($wr); if(is_FH(\*WR) && is_arg_ok(\*WR) && is_W(\*WR) && is_WO(\*WR)) {print "ok 12\n"} else {print "not ok 12\n"} if(is_FH($wr) && is_arg_ok($wr) && is_W($wr) && is_WO($wr)) {print "ok 13\n"} else {print "not ok 13\n"} if(!is_RO(\*WR) && !is_R(\*WR) && !is_RW(\*WR)) {print "ok 14\n"} else {print "not ok 14\n"} if(!is_RO($wr) && !is_R($wr) && !is_RW($wr)) {print "ok 15\n"} else {print "not ok 15\n"} if($no_skip) { if(is_A(\*WR) && is_A($wr)) {print "ok 16\n"} else {print "not ok 16\n"} } else {print "ok 16 - skipped, pre-5.6.1 Win32 perl\n"} close(WR) or die "Can't close temp.txt after opening for appending: $!"; unless($] < 5.006) {close($wr) or die "Can't close temp2.txt after opening for appending: $!";} ##################################################### open(RW, "+>temp.txt") or die "Can't open temp.txt for reading/writing: $!"; unless($] < 5.006) {open($rw, "+>temp2.txt") or die "Can't open temp2.txt for reading/writing: $!";} else {$rw = \*RW} binmode(RW); binmode($rw); if(is_FH(\*RW) && is_arg_ok(\*RW) && is_RW(\*RW) && is_W(\*RW) && is_R(\*RW)) {print "ok 17\n"} else {print "not ok 17\n"} if(is_FH($rw) && is_arg_ok($rw) && is_RW($rw) && is_W($rw) && is_R($rw)) {print "ok 18\n"} else {print "not ok 18\n"} if(!is_RO(\*RW) && !is_WO(\*RW)) {print "ok 19\n"} else {print "not ok 19\n"} if(!is_RO($rw) && !is_WO($rw)) {print "ok 20\n"} else {print "not ok 20\n"} if($no_skip) { if(!is_A(\*RW) && !is_A($rw)) {print "ok 21\n"} else {print "not ok 21\n"} } else {print "ok 21 - skipped, pre-5.6.1 Win32 perl\n"} close(RW) or die "Can't close temp.txt after opening for reading/writing: $!"; unless($] < 5.006) {close($rw) or die "Can't close temp2.txt after opening for reading/writing: $!";} ##################################################### open(RW, "+>temp.txt") or die "Can't open temp.txt for reading/writing: $!"; unless($] < 5.006) {open($rw, "+>>temp2.txt") or die "Can't open temp2.txt for reading/writing: $!";} else {$rw = \*RW} binmode(RW); binmode($rw); if(is_FH(\*RW) && is_arg_ok(\*RW) && is_RW(\*RW) && is_W(\*RW) && is_R(\*RW)) {print "ok 27\n"} else {print "not ok 27\n"} if(is_FH($rw) && is_arg_ok($rw) && is_RW($rw) && is_W($rw) && is_R($rw)) {print "ok 28\n"} else {print "not ok 28\n"} if(!is_RO(\*RW) && !is_WO(\*RW)){print "ok 29\n"} else {print "not ok 29\n"} if(!is_RO($rw) && !is_WO($rw)) {print "ok 30\n"} else {print "not ok 30\n"} if($no_skip) { if(is_A(\*RW) && is_A($rw)) {print "ok 31\n"} else {print "not ok 31\n"} } else {print "ok 31 - skipped, pre-5.6.1 Win32 perl\n"} close(RW) or die "Can't close temp.txt after opening for reading/writing: $!"; unless($] < 5.006) {close($rw) or die "Can't close temp2.txt after opening for reading/writing: $!";} eval {is_R($undef)}; if($@ && !is_arg_ok($undef)){print "ok 32\n"} else {print "not ok 32\n"} eval {is_RO($undef)}; if($@){print "ok 33\n"} else {print "not ok 33\n"} eval {is_W($undef)}; if($@){print "ok 34\n"} else {print "not ok 34\n"} eval {is_WO($undef)}; if($@){print "ok 35\n"} else {print "not ok 35\n"} eval {is_RW($undef)}; if($@){print "ok 36\n"} else {print "not ok 36\n"} if($no_skip){ eval {is_A($undef)}; if($@){print "ok 37\n"} else {print "not ok 37\n"} } else {print "ok 37 - skipped, pre-5.6.1 Win32 perl\n"} $one = 1; eval {is_R($one)}; if($@ && !is_arg_ok($one)){print "ok 38\n"} else {print "not ok 38\n"} eval {is_RO($one)}; if($@){print "ok 39\n"} else {print "not ok 39\n"} eval {is_W($one)}; if($@){print "ok 40\n"} else {print "not ok 40\n"} eval {is_WO($one)}; if($@){print "ok 41\n"} else {print "not ok 41\n"} eval {is_RW($one)}; if($@){print "ok 42\n"} else {print "not ok 42\n"} if($no_skip){ eval {is_A($one)}; if($@){print "ok 43\n"} else {print "not ok 43\n"} } else {print "ok 43 - skipped, pre-5.6.1 Win32 perl\n"} if($] >= 5.007) { $var = ''; # Avoid "uninitialised" warnings. eval q{open($mem, '<', \$var) or die "Can't open memory object: $!";}; die $@ if $@; binmode($mem); if(is_FH($mem) && is_arg_ok($mem) && is_R($mem) && is_RO($mem) && !is_W($mem) && !is_WO($mem) && !is_RW($mem) && !is_A($mem)) {print "ok 44\n"} else {print "not ok 44\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '>', \$var) or die "Can't open memory object: $!";}; die $@ if $@; binmode($mem); if(is_arg_ok($mem) && !is_R($mem) && !is_RO($mem) && is_W($mem) && is_WO($mem) && !is_RW($mem) && !is_A($mem)) {print "ok 45\n"} else {print "not ok 45\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '>>', \$var) or die "Can't open memory object: $!";}; die $@ if $@; binmode($mem); if(is_FH($mem) && is_arg_ok($mem) && !is_R($mem) && !is_RO($mem) && is_W($mem) && is_WO($mem) && !is_RW($mem) && is_A($mem)) {print "ok 46\n"} else {print "not ok 46\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '+>>', \$var) or die "Can't open memory object: $!";}; die $@ if $@; binmode($mem); if(is_arg_ok($mem) && is_R($mem) && !is_RO($mem) && is_W($mem) && !is_WO($mem) && is_RW($mem) && is_A($mem)) {print "ok 47\n"} else {print "not ok 47\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '+>', \$var) or die "Can't open memory object: $!";}; die $@ if $@; binmode($mem); if(is_FH($mem) && is_arg_ok($mem) && is_R($mem) && !is_RO($mem) && is_W($mem) && !is_WO($mem) && is_RW($mem) && !is_A($mem)) {print "ok 48\n"} else {print "not ok 48\n"} close($mem) or die "Can't close memory object: $!"; eval q{open($mem, '+<', \$var) or die "Can't open memory object: $!";}; die $@ if $@; binmode($mem); if(is_FH($mem) && is_arg_ok($mem) && is_R($mem) && !is_RO($mem) && is_W($mem) && !is_WO($mem) && is_RW($mem) && !is_A($mem)) {print "ok 49\n"} else {print "not ok 49\n"} close($mem) or die "Can't close memory object: $!"; } else { print "ok 44 - skipped - pre-5.8 perl\n"; print "ok 45 - skipped - pre-5.8 perl\n"; print "ok 46 - skipped - pre-5.8 perl\n"; print "ok 47 - skipped - pre-5.8 perl\n"; print "ok 48 - skipped - pre-5.8 perl\n"; print "ok 49 - skipped - pre-5.8 perl\n"; } open(RD, "Makefile.PL") or die "Can't open Makefile.PL for reading: $!"; binmode(RD); eval{FileHandle::Fmode::perliol_readable(\*RD);}; if($] < 5.007) { if($@ =~ /perliol_readable/) {print "ok 50\n"} else {print "not ok 50\n"} } else { if($@) {print "not ok 50\n"} else {print "ok 50\n"} } close(RD) or die "Can't close Makefile.PL after opening for reading: $!"; open(WR, ">temp2.txt") or die "Can't open temp2.txt for writing: $!"; binmode(WR); eval{FileHandle::Fmode::perliol_writable(\*WR);}; if($] < 5.007) { if($@ =~ /perliol_writable/) {print "ok 51\n"} else {print "not ok 51\n"} } else { if($@) {print "not ok 51\n"} else {print "ok 51\n"} } eval{FileHandle::Fmode::win32_fmode(\*WR);}; if($^O =~ /mswin32/i) { if($@) {print "not ok 52\n"} else {print "ok 52\n"} } else { if($@ =~ /win32_fmode/) {print "ok 52\n"} else {print "not ok 52\n"} } close(WR) or die "Can't close temp2.txt after opening for writing: $!"; FileHandle-Fmode-0.13/t/pod.t0000644000076400010400000000046011771731366016211 0ustar RobAdministratorseval "use Test::Pod 1.00"; if($@) { print "1..1\n"; print "ok 1 - skipped, no sufficiently recent version of Test::Pod installed \n"; } else { warn "\nTest::Pod version: $Test::Pod::VERSION\n"; warn "\nPod::Simple version: $Pod::Simple::VERSION\n"; Test::Pod::all_pod_files_ok(); }