Skip Menu |
 

This queue is for tickets about the Directory-Queue CPAN distribution.

Report information
The Basics
Id: 76155
Status: resolved
Priority: 0/
Queue: Directory-Queue

People
Owner: LCONS [...] cpan.org
Requestors: feratilbeau [...] hotmail.com
Cc:
AdminCc:

Bug Information
Severity: Normal
Broken in: 1.5
Fixed in: (no value)



Subject: Win32
Hello Lionel, Tried on Windows, I got the following error messages. My guess is because Directory::Queue does not use File::Spec family and the $! values explicitely. C:\>perl -MDirectory::Queue::Simple -e "$queue = Directory::Queue::Simple->new(path => shift); $queue->add(\"test\"); foreach (1..2 ) {if (fork() == 0) {if ($first = $queue->first()) {$queue->lock($first)}}} sleep(2);" C:\Windows\Temp Directory::Queue::Simple: cannot link(C:\Windows\Temp/4f7579d0/4f7579e4880b74, C:\Windows\Temp/4f7579d0/4f7579e4880b74.lck): Invalid argument Directory::Queue::Simple: cannot link(C:\Windows\Temp/4f7579d0/4f7579e4880b74, C:\Windows\Temp/4f7579d0/4f7579e4880b74.lck): Invalid argument Since I tried only Directory::Queue::Simple, please find attached a proposal for this sub-module (and its parent Queue.pm), not validated under *ix btw -;! But the principle remains valid; may I suggest to use File::Spec and not explicit errno values in your package, so that your package gains portability ? I assumed "link" works every where. Thanks a lot, Cheers, Jean-Damien Durand.
Subject: Directory_Queue.diff
diff -Naur Directory-Queue-1.5.old/lib/Directory/Queue/Simple.pm Directory-Queue-1.5.new/lib/Directory/Queue/Simple.pm --- Directory-Queue-1.5.old/lib/Directory/Queue/Simple.pm 2012-01-24 09:58:01.000000000 +0100 +++ Directory-Queue-1.5.new/lib/Directory/Queue/Simple.pm 2012-03-30 10:19:06.979900600 +0200 @@ -22,6 +22,7 @@ use Directory::Queue qw(:DIR :FILE :RE :ST _fatal _name SYSBUFSIZE); use POSIX qw(:errno_h); +use File::Spec::Functions qw(catfile catdir); # # inheritance @@ -88,10 +89,10 @@ $dir = _add_dir($self); while (1) { $name = _name(); - $tmp = $self->{path} . "/" . $dir . "/" . $name . TEMPORARY_SUFFIX; + $tmp = catfile($self->{path}, $dir, $name . TEMPORARY_SUFFIX); $fh = _file_create($tmp, $self->{umask}); last if $fh; - _special_mkdir($self->{path} . "/" . $dir, $self->{umask}) if $! == ENOENT; + _special_mkdir(catdir($self->{path}, $dir), $self->{umask}) if ! -d catdir($self->{path}, $dir); } $length = length($$dataref); $offset = 0; @@ -111,13 +112,13 @@ while (1) { $name = _name(); - $new = $self->{path} . "/" . $dir . "/" . $name; + $new = catfile($self->{path}, $dir, $name); # N.B. we use link() + unlink() to make sure $new is never overwritten if (link($tmp, $new)) { unlink($tmp) or _fatal("cannot unlink(%s): %s", $tmp, $!); - return($dir . "/" . $name); + return(catfile($dir, $name)); } - _fatal("cannot link(%s, %s): %s", $tmp, $new, $!) unless $! == EEXIST; + _fatal("cannot link(%s, %s): %s", $tmp, $new, $!) unless -e $new; } } @@ -146,7 +147,7 @@ my($dir); $dir = _add_dir($self); - _special_mkdir($self->{path} . "/" . $dir, $self->{umask}); + _special_mkdir(catdir($self->{path}, $dir), $self->{umask}); return(_add_path($self, $path, $dir)); } @@ -157,19 +158,19 @@ sub get : method { my($self, $name) = @_; - return(${ _file_read($self->{path} . "/" . $name . LOCKED_SUFFIX, 0) }); + return(${ _file_read(catfile($self->{path}, $name . LOCKED_SUFFIX), 0) }); } sub get_ref : method { my($self, $name) = @_; - return(_file_read($self->{path} . "/" . $name . LOCKED_SUFFIX, 0)); + return(_file_read(catfile($self->{path}, $name . LOCKED_SUFFIX), 0)); } sub get_path : method { my($self, $name) = @_; - return($self->{path} . "/" . $name . LOCKED_SUFFIX); + return(catfile($self->{path}, $name . LOCKED_SUFFIX)); } # @@ -183,7 +184,7 @@ my($path, $lock, $time); $permissive = 1 unless defined($permissive); - $path = $self->{path} . "/" . $name; + $path = catfile($self->{path}, $name); $lock = $path . LOCKED_SUFFIX; if (link($path, $lock)) { # we also touch the element to indicate the lock time @@ -192,7 +193,7 @@ or _fatal("cannot utime(%d, %d, %s): %s", $time, $time, $path, $!); return(1); } - return(0) if $permissive and ($! == EEXIST or $! == ENOENT); + return(0) if $permissive and (-e $lock or ! -e $path); _fatal("cannot link(%s, %s): %s", $path, $lock, $!); } @@ -207,10 +208,13 @@ my($path, $lock); $permissive = 0 unless defined($permissive); - $path = $self->{path} . "/" . $name; + $path = catfile($self->{path}, $name); $lock = $path . LOCKED_SUFFIX; - return(1) if unlink($lock); - return(0) if $permissive and $! == ENOENT; + if (unlink($lock)) { + return(1); + } else { + return(0) if $permissive and -e $lock; + } _fatal("cannot unlink(%s): %s", $lock, $!); } @@ -222,7 +226,7 @@ my($self, $name) = @_; my($path, $lock); - $path = $self->{path} . "/" . $name; + $path = catfile($self->{path}, $name); $lock = $path . LOCKED_SUFFIX; unlink($path) or _fatal("cannot unlink(%s): %s", $path, $!); unlink($lock) or _fatal("cannot unlink(%s): %s", $lock, $!); @@ -243,7 +247,7 @@ } # count the elements inside foreach $name (@list) { - $count += grep(/^(?:$_ElementRegexp)$/o, _special_getdir($self->{path} . "/" . $name)); + $count += grep(/^(?:$_ElementRegexp)$/o, _special_getdir(catdir($self->{path}, $name))); } # that's all return($count); @@ -276,18 +280,18 @@ $oldlock = time() - $option{maxlock} if $option{maxlock}; if ($oldtemp or $oldlock) { foreach $name (@list) { - $path = $self->{path} . "/" . $name; + $path = catdir($self->{path}, $name); foreach $old (grep(/\./, _special_getdir($path))) { - @stat = stat($path . "/" . $old); + @stat = stat(catfile($path, $old)); unless (@stat) { - _fatal("cannot stat(%s/%s): %s", $path, $old, $!) unless $! == ENOENT; + _fatal("cannot stat(%s): %s", catfile($path, $old), $!) unless ! -e catfile($path, $old); next; } next if substr($old, -4) eq TEMPORARY_SUFFIX and $stat[ST_MTIME] >= $oldtemp; next if substr($old, -4) eq LOCKED_SUFFIX and $stat[ST_MTIME] >= $oldlock; - warn("* removing too old volatile file: $path/$old\n"); - next if unlink($path . "/" . $old); - _fatal("cannot unlink(%s/%s): %s", $path, $old, $!) unless $! == ENOENT; + warn("* removing too old volatile file: %s\n", catfile($path, $old)); + next if unlink(catfile($path, $old)); + _fatal("cannot unlink(%s): %s", catfile($path, $old), $!) unless ! -e catfile($path, $old); } } } @@ -296,7 +300,7 @@ if (@list > 1) { pop(@list); foreach $name (@list) { - $path = $self->{path} . "/" . $name; + $path = catdir($self->{path}, $name); _special_rmdir($path) unless _special_getdir($path); } } diff -Naur Directory-Queue-1.5.old/lib/Directory/Queue.pm Directory-Queue-1.5.new/lib/Directory/Queue.pm --- Directory-Queue-1.5.old/lib/Directory/Queue.pm 2012-01-24 09:58:01.000000000 +0100 +++ Directory-Queue-1.5.new/lib/Directory/Queue.pm 2012-03-30 10:06:53.356211900 +0200 @@ -24,11 +24,11 @@ our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(Exporter); @EXPORT = qw(); -@EXPORT_OK = qw(_fatal _name SYSBUFSIZE); +@EXPORT_OK = qw(_fatal _name _warn SYSBUFSIZE); %EXPORT_TAGS = ( "DIR" => [qw(_special_mkdir _special_rmdir _special_getdir)], "FILE" => [qw(_file_read _file_create _file_write)], - "RE" => [qw($_DirectoryRegexp $_ElementRegexp)], + "RE" => [qw($_DirectoryRegexp $_ElementRegexp $_CurdirOrUpdir)], "ST" => [qw(ST_DEV ST_INO ST_NLINK ST_MTIME)], ); Exporter::export_tags(); @@ -39,6 +39,8 @@ use POSIX qw(:errno_h :fcntl_h); use Time::HiRes qw(); +use File::Spec::Functions qw(curdir updir catfile catdir splitdir); +use File::Basename qw(dirname); # # global variables @@ -76,10 +78,12 @@ our( $_DirectoryRegexp, # regexp matching an intermediate directory $_ElementRegexp, # regexp matching an element + $_CurdirOrUpdir # regexp matching curdir or updir ); $_DirectoryRegexp = qr/[0-9a-f]{8}/; $_ElementRegexp = qr/[0-9a-f]{14}/; +$_CurdirOrUpdir = ($_ = '^(?:' . join('|', quotemeta(curdir), quotemeta(updir)) . ')$', qr/$_/); #+++############################################################################ # # @@ -100,6 +104,18 @@ } # +# report a warning with a sprintf() API +# + +sub _warn ($@) { + my($message, @arguments) = @_; + + $message = sprintf($message, @arguments) if @arguments; + $message =~ s/\s+$//; + warn(caller() . ": $message\n"); +} + +# # make sure a module is loaded # @@ -155,7 +171,7 @@ $success = mkdir($path); } return(1) if $success; - _fatal("cannot mkdir(%s): %s", $path, $!) unless $! == EEXIST and -d $path; + _fatal("cannot mkdir(%s): %s", $path, $!) unless -d $path; # RACE: someone else may have created it at the the same time return(0); } @@ -171,7 +187,7 @@ my($path) = @_; return(1) if rmdir($path); - _fatal("cannot rmdir(%s): %s", $path, $!) unless $! == ENOENT; + _fatal("cannot rmdir(%s): %s", $path, $!) unless ! -d $path; # RACE: someone else may have deleted it at the the same time return(0); } @@ -189,12 +205,12 @@ my($dh, @list); if (opendir($dh, $path)) { - @list = grep($_ !~ /^\.\.?$/, readdir($dh)); - closedir($dh) or _fatal("cannot closedir(%s): %s", $path, $!); + @list = grep($_ !~ /$_CurdirOrUpdir/, readdir($dh)); + closedir($dh) or _warn("cannot closedir(%s): %s", $path, $!); # It is not fatal to not being able to close a directory return(@list); } _fatal("cannot opendir(%s): %s", $path, $!) - unless $! == ENOENT and not $strict; + unless ! -d $path and not $strict; # RACE: someone else may have deleted it at the the same time return(); } @@ -224,7 +240,7 @@ $done = sysread($fh, $data, SYSBUFSIZE, length($data)); _fatal("cannot sysread(%s): %s", $path, $!) unless defined($done); } - close($fh) or _fatal("cannot close(%s): %s", $path, $!); + close($fh) or _warn("cannot close(%s): %s", $path, $!); # It is not fatal to not being able to close a file, although very suspicious return(\$data); } @@ -249,9 +265,9 @@ } return($fh) if $success; _fatal("cannot sysopen(%s, O_WRONLY|O_CREAT|O_EXCL): %s", $path, $!) - unless ($! == EEXIST or $! == ENOENT) and not $strict; - # RACE: someone else may have created the file (EEXIST) - # RACE: the containing directory may be mising (ENOENT) + unless (-e $path or ! -d dirname($path)) and not $strict; + # RACE: someone else may have created the file + # RACE: the containing directory may be mising return(0); } @@ -283,7 +299,7 @@ $length -= $done; $offset += $done; } - close($fh) or _fatal("cannot close(%s): %s", $path, $!); + close($fh) or _warn("cannot close(%s): %s", $path, $!); # It is not fatal to not being able to close a file, although very suspicious } #+++############################################################################ @@ -333,8 +349,8 @@ } # create the toplevel directory if needed $path = ""; - foreach $name (split(/\/+/, $self->{path})) { - $path .= $name . "/"; + foreach $name (grep {defined($_) && $_} splitdir($path)) { + $path .= catdir($path, $name); _special_mkdir($path, $self->{umask}) unless -d $path; } # store the queue unique identifier @@ -403,11 +419,11 @@ return(shift(@{ $self->{elts} })) if @{ $self->{elts} }; while (@{ $self->{dirs} }) { $dir = shift(@{ $self->{dirs} }); - foreach $name (_special_getdir($self->{path} . "/" . $dir)) { + foreach $name (_special_getdir(catdir($self->{path}, $dir))) { push(@list, $1) if $name =~ /^($_ElementRegexp)$/o; # untaint } next unless @list; - $self->{elts} = [ map("$dir/$_", sort(@list)) ]; + $self->{elts} = [ map(catdir($dir, $_), sort(@list)) ]; return(shift(@{ $self->{elts} })); } return(""); @@ -438,7 +454,7 @@ my($time, $path); $time = time(); - $path = $self->{path} . "/" . $element; + $path = catfile($self->{path}, $element); utime($time, $time, $path) or _fatal("cannot utime(%d, %d, %s): %s", $time, $time, $path, $!); }
Download (untitled) / with headers
text/plain 380b
Could you please tell me more about the OS you are using? Directory-Queue 1.5 seems to pass all tests on cpantesters for Windows (Win32): http://www.cpantesters.org/distro/D/Directory-Queue.html?osname=mswin32 I might consider using File::Spec if it is really needed but I must use the error codes of the POSIX functions I'm using in order to properly handle race conditions.
From: feratilbeau [...] hotmail.com
Download (untitled) / with headers
text/plain 229b
Le Lun 02 Avr 2012 02:28:01, LCONS a écrit : Show quoted text
> Could you please tell me more about the OS you are using?
This is windows 7, strawberry perl 5.12. Does the test suite of Directory-Queue adress concurrency (fork()) ?. Regards.
Download (untitled) / with headers
text/plain 396b
On Wed Apr 04 01:45:18 2012, jddfr74 wrote: Show quoted text
> This is windows 7, strawberry perl 5.12.
Ok, I'll try to get access to a Windows 7 box to reproduce the problem. For the record, what do you get when you execute Directory-Queue's built- in tests (i.e. make test)? Show quoted text
> Does the test suite of Directory-Queue adress concurrency (fork()) ?.
No. The built-in tests cover only the minimal functionality.
From: feratilbeau [...] hotmail.com
Download (untitled) / with headers
text/plain 1.7k
Show quoted text
> For the record, what do you get when you execute Directory-Queue's built- > in tests (i.e. make test)?
Show quoted text
cpan> test Directory::Queue
Running test for module 'Directory::Queue' Running make for L/LC/LCONS/Directory-Queue-1.5.tar.gz Fetching with LWP: http://cpan.strawberryperl.com/authors/id/L/LC/LCONS/Directory-Queue-1.5.tar.gz Fetching with LWP: http://cpan.strawberryperl.com/authors/id/L/LC/LCONS/CHECKSUMS Checksum for C:\perl-5.12\cpan\sources\authors\id\L\LC\LCONS\Directory-Queue-1.5.tar.gz ok Scanning cache C:\perl-5.12\cpan\build for sizes ............................................................................DONE CPAN.pm: Going to build L/LC/LCONS/Directory-Queue-1.5.tar.gz Checking if your kit is complete... Looks good Writing Makefile for Directory::Queue Could not read metadata file. Falling back to other methods to determine prerequisites cp lib/Directory/Queue/Simple.pm blib\lib\Directory\Queue\Simple.pm cp lib/Directory/Queue/Set.pm blib\lib\Directory\Queue\Set.pm cp lib/Directory/Queue.pm blib\lib\Directory\Queue.pm cp lib/Directory/Queue/Normal.pm blib\lib\Directory\Queue\Normal.pm cp lib/Directory/Queue/Null.pm blib\lib\Directory\Queue\Null.pm LCONS/Directory-Queue-1.5.tar.gz C:\perl-5.12\c\bin\dmake.exe -- OK Running make test C:\perl-5.12\perl\bin\perl.exe "-MExtUtils::Command::MM" "-e" "test_harness(0, 'blib\lib', 'blib\arch')" t/*.t t/1main.t ...... ok t/1null.t ...... ok t/1simple.t .... ok t/2frontend.t .. ok t/2set.t ....... ok t/2table.t ..... ok t/3pod.t ....... ok t/4podcov.t .... skipped: Test::Pod::Coverage 1.08 required for testing POD coverage All tests successful. Files=8, Tests=141, 4 wallclock secs ( 0.17 usr + 0.05 sys = 0.22 CPU) Result: PASS LCONS/Directory-Queue-1.5.tar.gz C:\perl-5.12\c\bin\dmake.exe test -- OK
Download (untitled) / with headers
text/plain 410b
After investigation, the problem comes from link() that does not return the right error code when called with an existing file path: I get EINVAL instead of EEXIST. AFAIK, this violates the POSIX standard: http://pubs.opengroup.org/onlinepubs/009695399/functions/link.html So, to me, this looks like a bug in Perl and/or Windows. Anyway, I will now see if I can find a reasonable workaround for this bug.
Download (untitled) / with headers
text/plain 166b
On Thu Apr 05 07:05:57 2012, LCONS wrote: Show quoted text
> So, to me, this looks like a bug in Perl and/or Windows.
Now reported as https://rt.cpan.org/Ticket/Display.html?id=76324
Download (untitled) / with headers
text/plain 122b
The underlying Perl bug has been fixed upstream (see Tony's comment on https://rt.cpan.org/Ticket/Display.html?id=76324).


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.