commit bbff9832e6385cf9fc4a48af82ed8a60b32b16c3 Author: denghao Date: Thu Sep 8 11:40:37 2022 +0300 Import Upstream version 0.14 diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..8ed251b --- /dev/null +++ b/CHANGES @@ -0,0 +1,33 @@ +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 .... diff --git a/Fmode.pm b/Fmode.pm new file mode 100644 index 0000000..7d45bb3 --- /dev/null +++ b/Fmode.pm @@ -0,0 +1,230 @@ +package 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 diff --git a/Fmode.xs b/Fmode.xs new file mode 100644 index 0000000..02bf2c8 --- /dev/null +++ b/Fmode.xs @@ -0,0 +1,121 @@ + +#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 + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..051652e --- /dev/null +++ b/MANIFEST @@ -0,0 +1,11 @@ +MANIFEST +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) diff --git a/META.json b/META.json new file mode 100644 index 0000000..ac883e0 --- /dev/null +++ b/META.json @@ -0,0 +1,31 @@ +{ + "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" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..0c712ba --- /dev/null +++ b/META.yml @@ -0,0 +1,19 @@ +--- +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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..b70489d --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,23 @@ +use 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); + diff --git a/README b/README new file mode 100644 index 0000000..edb2f70 --- /dev/null +++ b/README @@ -0,0 +1,11 @@ +Use 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 diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..a4ed73a --- /dev/null +++ b/t/basic.t @@ -0,0 +1,357 @@ +use 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: $!"; diff --git a/t/binmode.t b/t/binmode.t new file mode 100644 index 0000000..2e70d2a --- /dev/null +++ b/t/binmode.t @@ -0,0 +1,357 @@ +use 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: $!"; diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..783549b --- /dev/null +++ b/t/pod.t @@ -0,0 +1,12 @@ +eval "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(); +}