| Subject: | Pure Perl version of DBM::Deep (no dependencies on non-core XS modules) |
| Date: | Wed, 17 Oct 2007 23:19:03 -0700 (PDT) |
| To: | bug-DBM-Deep [...] rt.cpan.org |
| From: | Steven Samelson <stevensamelson [...] yahoo.com> |
Message body is not shown because sender requested not to inline it.
use strict;
use FileHandle::Fmode_PP qw(:all);
# Same tests as binmode.t - but no binmode() on the handles
print "1..43\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: $!";
open($rd, "Fmode.pm") or die "Can't open Fmode.pm for reading: $!";
#binmode(RD);
#binmode($rd);
if(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_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: $!";
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: $!";
open($rd, "<Fmode.pm") or die "Can't open Fmode.pm for reading: $!";
#binmode(RD);
#binmode($rd);
if(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_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: $!";
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: $!";
open($wr, ">temp2.txt") or die "Can't open temp2.txt for writing: $!";
#binmode(WR);
#binmode($wr);
if(is_arg_ok(\*WR) && is_W(\*WR) && is_WO(\*WR)) {print "ok 7\n"}
else {print "not ok 7\n"}
if(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: $!";
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: $!";
open($wr, ">>temp2.txt") or die "Can't open temp2.txt for writing: $!";
#binmode(WR);
#binmode($wr);
if(is_arg_ok(\*WR) && is_W(\*WR) && is_WO(\*WR)) {print "ok 12\n"}
else {print "not ok 12\n"}
if(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: $!";
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: $!";
open($rw, "+>temp2.txt") or die "Can't open temp2.txt for reading/writing: $!";
#binmode(RW);
#binmode($rw);
if(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_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: $!";
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: $!";
open($rw, "+<temp2.txt") or die "Can't open temp2.txt for reading/writing: $!";
#binmode(RW);
#binmode($rw);
if(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_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: $!";
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: $!";
open($rw, "+>>temp2.txt") or die "Can't open temp2.txt for reading/writing: $!";
#binmode(RW);
#binmode($rw);
if(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_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: $!";
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"}
## This example demonstrates how to tell if a file is blocked from writing because it's
## locked or being written to by another process by using systwrite.
# This BEGIN block is likely not needed, and makes no difference in Windows
BEGIN {
# Load IO::Socket in memory if it is not loaded yet
if ( $^O eq 'MSWin32' ) {
*EWOULDBLOCK = sub () { 10036 };
}
else {
require Errno;
import Errno qw(EWOULDBLOCK);
}
}
my $file = "test.txt";
open $fh, ">$file";
my $rc = syswrite($fh, "hello");
while (1){
if ( $rc > 0 ) { # Test if some data was written
print "Can write to the file OK\n";
last;
}
# Blocking occured
elsif ( $! == EWOULDBLOCK ) { # would block, not an error
print "Temporarily can't write to $file: $!\n";
sleep(1);
}
# An error occured because the file can't be written to
else {
print "Can't write to $file: $!\n" ;
exit;
}
}
close $fh;
DBM::Deep version 1.0006
DBM::Deep currently has a single XS module dependency, FileHandle::Fmode, requiring a compiler to build it. All other required modules are "pure Perl" (either core Perl or no XS).
Previous versions of DBM::Deep (<1.000) did not have any non-core XS dependencies. Therefore, prior users of DBM::Deep on OS's that do not have compilers (e.g., Windows), or those using shared accounts that do not have permissions to use a compiler (e.g., shared web hosting accounts), will have difficulty upgrading or using the current version.
In discussions with the author of FileHandle::Fmode, he relayed that this module actually uses Perl only statements on *nix-style OS's. He therefore offered a pure Perl replacement, which is attached ("filehandle-fmode_PP.pm"), and a test script ("fmode_PP.t"). Only the "is_W()" function from this module however may be needed for DBM::Deep..
On Windows, testing a filehandle with the "syswrite" function indicates if a filehandle is locked or being written to more accurately than FileHandle::Fmode, which indicates a filehandle is writable even when it has been locked for writing using "flock" and "LOCK_EX" by another process. An example of detecting if a filehandle is writable using syswrite is attached ("test_fh_syswrite.txt").
Thanks for considering removing FileHandle::Fmode as an XS dependency,
-Steven
Show quoted text
__________________________________________________
Do You Yahoo!?
Tired of spam? Yahoo! Mail has the best spam protection around
http://mail.yahoo.com