From bbff9832e6385cf9fc4a48af82ed8a60b32b16c3 Mon Sep 17 00:00:00 2001 From: denghao Date: Thu, 8 Sep 2022 11:40:37 +0300 Subject: [PATCH] Import Upstream version 0.14 --- CHANGES | 33 +++++ Fmode.pm | 230 +++++++++++++++++++++++++++++++++ Fmode.xs | 121 ++++++++++++++++++ MANIFEST | 11 ++ META.json | 31 +++++ META.yml | 19 +++ Makefile.PL | 23 ++++ README | 11 ++ t/basic.t | 357 ++++++++++++++++++++++++++++++++++++++++++++++++++++ t/binmode.t | 357 ++++++++++++++++++++++++++++++++++++++++++++++++++++ t/pod.t | 12 ++ 11 files changed, 1205 insertions(+) create mode 100644 CHANGES create mode 100644 Fmode.pm create mode 100644 Fmode.xs create mode 100644 MANIFEST create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 t/basic.t create mode 100644 t/binmode.t create mode 100644 t/pod.t 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(); +}