r25606 - in /branches/upstream/libfilehandle-fmode-perl: ./ current/ current/CHANGES current/Fmode.pm current/Fmode.xs current/MANIFEST current/Makefile.PL current/README current/t/ current/t/basic.t current/t/binmode.t
yvesago-guest at users.alioth.debian.org
yvesago-guest at users.alioth.debian.org
Fri Sep 26 10:25:23 UTC 2008
Author: yvesago-guest
Date: Fri Sep 26 10:25:16 2008
New Revision: 25606
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25606
Log:
[svn-inject] Installing original source of libfilehandle-fmode-perl
Added:
branches/upstream/libfilehandle-fmode-perl/
branches/upstream/libfilehandle-fmode-perl/current/
branches/upstream/libfilehandle-fmode-perl/current/CHANGES
branches/upstream/libfilehandle-fmode-perl/current/Fmode.pm
branches/upstream/libfilehandle-fmode-perl/current/Fmode.xs
branches/upstream/libfilehandle-fmode-perl/current/MANIFEST
branches/upstream/libfilehandle-fmode-perl/current/Makefile.PL
branches/upstream/libfilehandle-fmode-perl/current/README
branches/upstream/libfilehandle-fmode-perl/current/t/
branches/upstream/libfilehandle-fmode-perl/current/t/basic.t
branches/upstream/libfilehandle-fmode-perl/current/t/binmode.t
Added: branches/upstream/libfilehandle-fmode-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfilehandle-fmode-perl/current/CHANGES?rev=25606&op=file
==============================================================================
--- branches/upstream/libfilehandle-fmode-perl/current/CHANGES (added)
+++ branches/upstream/libfilehandle-fmode-perl/current/CHANGES Fri Sep 26 10:25:16 2008
@@ -1,0 +1,24 @@
+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 ....
Added: branches/upstream/libfilehandle-fmode-perl/current/Fmode.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfilehandle-fmode-perl/current/Fmode.pm?rev=25606&op=file
==============================================================================
--- branches/upstream/libfilehandle-fmode-perl/current/Fmode.pm (added)
+++ branches/upstream/libfilehandle-fmode-perl/current/Fmode.pm Fri Sep 26 10:25:16 2008
@@ -1,0 +1,218 @@
+package FileHandle::Fmode;
+use Fcntl qw(O_WRONLY O_RDWR O_APPEND F_GETFL);
+use strict;
+
+require Exporter;
+require DynaLoader;
+
+*is_FH = \&is_arg_ok;
+
+$FileHandle::Fmode::VERSION = 0.10;
+
+ at FileHandle::Fmode::ISA = qw(Exporter DynaLoader);
+
+ at 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 $FileHandle::Fmode::VERSION;
+
+my $is_win32 = $^O =~ /mswin32/i ? 1 : 0;
+
+sub is_arg_ok {
+ eval{$_ = fileno($_[0]);};
+ if($@) {return 0}
+ if(defined(fileno($_[0]))) {
+ if(fileno($_[0]) == -1) {
+ if($] < 5.007) {return 0}
+ return 1;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+sub is_RO {
+ if(!defined(fileno($_[0]))) {die "Not an open filehandle"}
+ if(fileno($_[0]) == -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_WRONLY) && !($fmode & O_RDWR)) {return 1}
+ return 0;
+}
+
+sub is_WO {
+ if(!defined(fileno($_[0]))) {die "Not an open filehandle"}
+ if(fileno($_[0]) == -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($fmode & 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 {
+ if(!defined(fileno($_[0]))) {die "Not an open filehandle"}
+ if(fileno($_[0]) == -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($fmode & O_RDWR) {return 1}
+ return 0;
+}
+
+sub is_A {
+ if(!defined(fileno($_[0]))) {die "Not an open filehandle"}
+ if(fileno($_[0]) == -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.
+
+ $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.
+
+=head1 AUTHOR
+
+
+ Sisyphus <sisyphus at cpan dot org>
+
+=cut
Added: branches/upstream/libfilehandle-fmode-perl/current/Fmode.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfilehandle-fmode-perl/current/Fmode.xs?rev=25606&op=file
==============================================================================
--- branches/upstream/libfilehandle-fmode-perl/current/Fmode.xs (added)
+++ branches/upstream/libfilehandle-fmode-perl/current/Fmode.xs Fri Sep 26 10:25:16 2008
@@ -1,0 +1,113 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef _WIN32
+
+/*
+ * Win32 code supplied by BrowserUK
+ * to work aroumd the MS C runtime library's
+ * lack of a function to retrieve the file mode
+ * used when a file is opened
+*/
+
+SV * win32_fmode( FILE *stream ) {
+ return newSViv(stream->_flag);
+}
+
+#else
+
+SV * win32_fmode( FILE *stream ) {
+ croak("win32_fmode() function works only with Win32");
+}
+
+#endif
+
+#ifdef PERL580_OR_LATER
+
+/*
+ * XS code to deal with filehandles
+ * attached to memory objects supplied
+ * by attn.steven.kuo. (Applies only
+ * to perl 5.8 and later.)
+*/
+
+#include <perliol.h>
+
+SV * perliol_readable(SV * handle) {
+ IV flags;
+ IO *io;
+ PerlIO *f;
+ io = sv_2io(handle);
+ f = IoIFP(io);
+ if(PerlIOValid(f)){
+ const IV flags = PerlIOBase(f)->flags;
+ if(flags & PERLIO_F_CANREAD) return newSVuv(1);
+ return newSVuv(0);
+ }
+ croak("Couldn't validate the filehandle passed to perliol_readable()");
+}
+
+SV * perliol_writable(SV * handle) {
+ IV flags;
+ IO *io;
+ PerlIO *f;
+ io = sv_2io(handle);
+ f = IoIFP(io);
+ if(PerlIOValid(f)){
+ flags = PerlIOBase(f)->flags;
+ if(flags & PERLIO_F_CANWRITE) return newSVuv(1);
+ return newSVuv(0);
+ }
+ croak("Couldn't validate the filehandle passed to perliol_writable()");
+}
+
+#else
+
+SV * perliol_readable(SV * handle) {
+ croak("perliol_readable() function works only with perl 5.8 or later");
+}
+SV * perliol_writable( SV * handle ) {
+ croak("perliol_writable() function works only with perl 5.8 or later");
+}
+
+#endif
+
+#ifdef PERL561_OR_LATER
+
+SV * is_appendable(SV * handle) {
+ IO *io;
+ io = sv_2io(handle);
+ if (IoTYPE(io) == IoTYPE_APPEND) return newSVuv(1);
+ return newSVuv(0);
+}
+
+#else
+
+SV * is_appendable(SV * handle){
+ croak("is_appendable() function implemented only with perl 5.6.1 or later");
+}
+
+#endif
+
+MODULE = FileHandle::Fmode PACKAGE = FileHandle::Fmode
+
+PROTOTYPES: DISABLE
+
+SV *
+win32_fmode (stream)
+ FILE *stream
+
+SV *
+perliol_readable (handle)
+ SV *handle
+
+SV *
+perliol_writable (handle)
+ SV *handle
+
+SV *
+is_appendable (handle)
+ SV *handle
+
+
Added: branches/upstream/libfilehandle-fmode-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfilehandle-fmode-perl/current/MANIFEST?rev=25606&op=file
==============================================================================
--- branches/upstream/libfilehandle-fmode-perl/current/MANIFEST (added)
+++ branches/upstream/libfilehandle-fmode-perl/current/MANIFEST Fri Sep 26 10:25:16 2008
@@ -1,0 +1,8 @@
+MANIFEST
+README
+CHANGES
+Makefile.PL
+Fmode.pm
+Fmode.xs
+t/basic.t
+t/binmode.t
Added: branches/upstream/libfilehandle-fmode-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfilehandle-fmode-perl/current/Makefile.PL?rev=25606&op=file
==============================================================================
--- branches/upstream/libfilehandle-fmode-perl/current/Makefile.PL (added)
+++ branches/upstream/libfilehandle-fmode-perl/current/Makefile.PL Fri Sep 26 10:25:16 2008
@@ -1,0 +1,12 @@
+use ExtUtils::MakeMaker;
+
+my %options = %{
+{
+ NAME => 'FileHandle::Fmode',
+ VERSION_FROM => 'Fmode.pm',
+ DEFINE => $] < 5.008 ? $] < 5.006001 ? '-DOLDPERL' : '-DPERL561_OR_LATER' : '-DPERL580_OR_LATER -DPERL561_OR_LATER',
+ clean => { FILES => 'temp.txt temp2.txt' },
+}
+};
+
+WriteMakefile(%options);
Added: branches/upstream/libfilehandle-fmode-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfilehandle-fmode-perl/current/README?rev=25606&op=file
==============================================================================
--- branches/upstream/libfilehandle-fmode-perl/current/README (added)
+++ branches/upstream/libfilehandle-fmode-perl/current/README Fri Sep 26 10:25:16 2008
@@ -1,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
Added: branches/upstream/libfilehandle-fmode-perl/current/t/basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfilehandle-fmode-perl/current/t/basic.t?rev=25606&op=file
==============================================================================
--- branches/upstream/libfilehandle-fmode-perl/current/t/basic.t (added)
+++ branches/upstream/libfilehandle-fmode-perl/current/t/basic.t Fri Sep 26 10:25:16 2008
@@ -1,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, "<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 4\n"}
+else {print "not ok 4\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 5\n"}
+else {print "not ok 5\n"}
+
+if($no_skip) {
+ if(!is_A(\*RD) && !is_A($rd)) {print "ok 6\n"}
+ else {print "not ok 6\n"}
+}
+else {print "ok 6 - 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(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 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 22\n"}
+else {print "not ok 22\n"}
+
+if(is_FH($rw) && is_arg_ok($rw) && is_RW($rw) && is_W($rw) && is_R($rw)) {print "ok 23\n"}
+else {print "not ok 23\n"}
+
+if(!is_RO(\*RW) && !is_WO(\*RW)) {print "ok 24\n"}
+else {print "not ok 24\n"}
+
+if(!is_RO($rw) && !is_WO($rw)) {print "ok 25\n"}
+else {print "not ok 25\n"}
+
+if($no_skip) {
+ if(!is_A(\*RW) && !is_A($rw)) {print "ok 26\n"}
+ else {print "not ok 26\n"}
+}
+else {print "ok 26 - 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: $!";
Added: branches/upstream/libfilehandle-fmode-perl/current/t/binmode.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfilehandle-fmode-perl/current/t/binmode.t?rev=25606&op=file
==============================================================================
--- branches/upstream/libfilehandle-fmode-perl/current/t/binmode.t (added)
+++ branches/upstream/libfilehandle-fmode-perl/current/t/binmode.t Fri Sep 26 10:25:16 2008
@@ -1,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, "<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 4\n"}
+else {print "not ok 4\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 5\n"}
+else {print "not ok 5\n"}
+
+if($no_skip) {
+ if(!is_A(\*RD) && !is_A($rd)) {print "ok 6\n"}
+ else {print "not ok 6\n"}
+}
+else {print "ok 6 - 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(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 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 22\n"}
+else {print "not ok 22\n"}
+
+if(is_FH($rw) && is_arg_ok($rw) && is_RW($rw) && is_W($rw) && is_R($rw)) {print "ok 23\n"}
+else {print "not ok 23\n"}
+
+if(!is_RO(\*RW) && !is_WO(\*RW)) {print "ok 24\n"}
+else {print "not ok 24\n"}
+
+if(!is_RO($rw) && !is_WO($rw)) {print "ok 25\n"}
+else {print "not ok 25\n"}
+
+if($no_skip) {
+ if(!is_A(\*RW) && !is_A($rw)) {print "ok 26\n"}
+ else {print "not ok 26\n"}
+}
+else {print "ok 26 - 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: $!";
More information about the Pkg-perl-cvs-commits
mailing list