FileHandle-Fmode-0.14/0000755000076400010400000000000012371430024016125 5ustar sisyphusAdministratorsFileHandle-Fmode-0.14/CHANGES0000644000076400010400000000216412371427775017146 0ustar sisyphusAdministrators0.14 - Add metadata to Makefile.PL. - Define PERL_NO_GET_CONTEXT 0.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.14/Fmode.pm0000644000076400010400000001413112371427775017540 0ustar sisyphusAdministratorspackage 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.14'; #$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.14/Fmode.xs0000644000076400010400000000462412371427775017564 0ustar sisyphusAdministrators #ifdef __MINGW32__ #ifndef __USE_MINGW_ANSI_STDIO #define __USE_MINGW_ANSI_STDIO 1 #endif #endif #define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" SV * win32_fmode(pTHX_ FILE *stream ) { #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 */ return newSViv(stream->_flag); #else 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 #endif SV * perliol_readable(pTHX_ SV * handle) { #ifdef PERL580_OR_LATER 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"); #else croak("perliol_readable function works only with perl 5.8 or later"); #endif } SV * perliol_writable(pTHX_ SV * handle) { #ifdef PERL580_OR_LATER 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 croak("perliol_writable function works only with perl 5.8 or later"); #endif } SV * is_appendable(pTHX_ SV * handle) { #ifdef PERL561_OR_LATER IO *io; io = sv_2io(handle); if (IoTYPE(io) == IoTYPE_APPEND) return newSVuv(1); return newSVuv(0); #else 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 CODE: RETVAL = win32_fmode (aTHX_ stream); OUTPUT: RETVAL SV * perliol_readable (handle) SV * handle CODE: RETVAL = perliol_readable (aTHX_ handle); OUTPUT: RETVAL SV * perliol_writable (handle) SV * handle CODE: RETVAL = perliol_writable (aTHX_ handle); OUTPUT: RETVAL SV * is_appendable (handle) SV * handle CODE: RETVAL = is_appendable (aTHX_ handle); OUTPUT: RETVAL FileHandle-Fmode-0.14/Makefile.PL0000644000076400010400000000112512371427775020121 0ustar sisyphusAdministratorsuse ExtUtils::MakeMaker; my %options = ( NAME => 'FileHandle::Fmode', VERSION_FROM => 'Fmode.pm', LICENSE => 'perl', DEFINE => $] < 5.008 ? $] < 5.006001 ? '-DOLDPERL' : '-DPERL561_OR_LATER' : '-DPERL580_OR_LATER -DPERL561_OR_LATER', clean => { FILES => 'temp.txt temp2.txt' }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'https://github.com/sisyphus/filehandle-fmode.git', web => 'https://github.com/sisyphus/filehandle-fmode', }, }, }, ); WriteMakefile(%options); FileHandle-Fmode-0.14/MANIFEST0000644000076400010400000000037612371430024017264 0ustar sisyphusAdministratorsMANIFEST README CHANGES Makefile.PL Fmode.pm Fmode.xs t/basic.t t/binmode.t t/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) FileHandle-Fmode-0.14/META.json0000644000076400010400000000136412371430024017552 0ustar sisyphusAdministrators{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "FileHandle-Fmode", "no_index" : { "directory" : [ "t", "inc" ] }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/sisyphus/filehandle-fmode.git", "web" : "https://github.com/sisyphus/filehandle-fmode" } }, "version" : "0.14" } FileHandle-Fmode-0.14/META.yml0000644000076400010400000000067412371430023017404 0ustar sisyphusAdministrators--- abstract: unknown author: - unknown build_requires: {} dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: FileHandle-Fmode no_index: directory: - t - inc resources: repository: https://github.com/sisyphus/filehandle-fmode.git version: 0.14 FileHandle-Fmode-0.14/README0000644000076400010400000000025212371427775017027 0ustar sisyphusAdministratorsUse 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, Rob FileHandle-Fmode-0.14/t/0000755000076400010400000000000012371430023016367 5ustar sisyphusAdministratorsFileHandle-Fmode-0.14/t/basic.t0000644000076400010400000002602012371427775017661 0ustar sisyphusAdministratorsuse 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.14/t/binmode.t0000644000076400010400000002576512371427775020234 0ustar sisyphusAdministratorsuse 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.14/t/pod.t0000644000076400010400000000044612371427775017366 0ustar sisyphusAdministratorseval "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(); }