FileHandle-Fmode-0.15/0000755060175106010010000000000014633550652013250 5ustar OwnerNoneFileHandle-Fmode-0.15/CHANGES0000755060175106010010000000242114633550574014250 0ustar OwnerNone0.15 - Doc improvements. - Avoid win32_fmode() when perl is built by UCRT compiler, as UCRT changes struct _iobuf. (Affects MSWin32 only.) 0.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.15/Fmode.pm0000755060175106010010000001452314633550574014653 0ustar OwnerNonepackage FileHandle::Fmode; use Fcntl qw(O_ACCMODE O_RDONLY O_WRONLY O_RDWR O_APPEND F_GETFL); use strict; use Config; use constant IS_WIN32 => $^O =~ /mswin32/i ? 1 : 0; use constant LIBC_IS_UCRT => $Config{libc} =~ /\-lucrt$|ucrt\.lib$/i ? 1 : 0; require Exporter; require DynaLoader; *is_FH = \&is_arg_ok; our $VERSION = '0.15'; #$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)]); FileHandle::Fmode->DynaLoader::bootstrap($VERSION); 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 || (IS_WIN32 && LIBC_IS_UCRT)) { if($] < 5.007) {die "Illegal fileno() return"} if(perliol_readable($_[0]) && !perliol_writable($_[0])) {return 1} return 0; } if(IS_WIN32 && !LIBC_IS_UCRT) { 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 || (IS_WIN32 && LIBC_IS_UCRT)) { if($] < 5.007) {die "Illegal fileno() return"} if(!perliol_readable($_[0]) && perliol_writable($_[0])) {return 1} return 0; } if(IS_WIN32 && !LIBC_IS_UCRT) { 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 || (IS_WIN32 && LIBC_IS_UCRT)) { if($] < 5.007) {die "Illegal fileno() return"} if(perliol_readable($_[0]) && perliol_writable($_[0])) {return 1} return 0; } if(IS_WIN32 && !LIBC_IS_UCRT) { 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 for example the disk runs full on Linux, a write attempt will fail, while is_W($fh) still reports true. The behavior for other platforms is not tested. $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 (or anywhere else). 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, 2024 Sisyphus =head1 AUTHOR Sisyphus =cut FileHandle-Fmode-0.15/Fmode.xs0000755060175106010010000000501314633550574014663 0ustar OwnerNone #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 # ifndef LIBC_IS_UCRT /* * 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 MSVCRT"); # endif #else croak("win32_fmode function works only with MS Windows"); #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.15/Makefile.PL0000755060175106010010000000136114633550574015231 0ustar OwnerNoneuse strict; use warnings; use ExtUtils::MakeMaker; my $defines = $] < 5.008 ? $] < 5.006001 ? '-DOLDPERL' : '-DPERL561_OR_LATER' : '-DPERL580_OR_LATER -DPERL561_OR_LATER'; $defines .= ' -DLIBC_IS_UCRT' if $Config::Config{libc} =~ /\-lucrt$|ucrt\.lib$/i; my %options = ( NAME => 'FileHandle::Fmode', VERSION_FROM => 'Fmode.pm', LICENSE => 'perl', clean => { FILES => 'temp.txt temp2.txt' }, LICENSE => 'perl', DEFINE => $defines, 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.15/MANIFEST0000755060175106010010000000037414633550652014410 0ustar OwnerNoneMANIFEST 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.15/META.json0000664060175106010010000000175714633550652014705 0ustar OwnerNone{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "FileHandle-Fmode", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/sisyphus/filehandle-fmode.git", "web" : "https://github.com/sisyphus/filehandle-fmode" } }, "version" : "0.15", "x_serialization_backend" : "JSON::PP version 4.04" } FileHandle-Fmode-0.15/META.yml0000664060175106010010000000105414633550650014521 0ustar OwnerNone--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' 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.15' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' FileHandle-Fmode-0.15/README0000755060175106010010000000025214633550574014135 0ustar OwnerNoneUse 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.15/t/0000755060175106010010000000000014633550650013511 5ustar OwnerNoneFileHandle-Fmode-0.15/t/basic.t0000755060175106010010000002626114633550574014776 0ustar OwnerNoneuse strict; use FileHandle::Fmode qw(:all); # Same tests as binmode.t - but no binmode() on the handles warn "\nIS_WIN32 : ", FileHandle::Fmode::IS_WIN32, "\n"; warn "LIBC_IS_UCRT : ", FileHandle::Fmode::LIBC_IS_UCRT, "\n"; 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 && !FileHandle::Fmode::LIBC_IS_UCRT) { 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.15/t/binmode.t0000755060175106010010000002603114633550574015325 0ustar OwnerNoneuse 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 && !FileHandle::Fmode::LIBC_IS_UCRT) { 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.15/t/pod.t0000755060175106010010000000044614633550574014474 0ustar OwnerNoneeval "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(); }