File Coverage

blib/lib/Directory/Queue.pm

Criterion	Covered	Total	%
statement	135	149	90.6
branch	39	62	62.9
condition	6	17	35.2
subroutine	24	24	100.0
pod	6	6	100.0
total	210	258	81.4

#+##############################################################################
#                                                                              #
# File: Directory/Queue.pm                                                     #
#                                                                              #
# Description: object oriented interface to a directory based queue            #
#                                                                              #
#-##############################################################################

#
# module definition
#

package Directory::Queue;
use strict;
use warnings;
our $VERSION  = "2.0";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.52 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use No::Worries::Die qw(dief);
use No::Worries::Export qw(export_control);
use No::Worries::Stat qw(ST_DEV ST_INO ST_NLINK ST_SIZE ST_MTIME);
use POSIX qw(:errno_h :fcntl_h);
use Time::HiRes qw();

#
# global variables
#

our(
    %_LoadedModule,             # hash of successfully loaded modules
);

#+++############################################################################
#                                                                              #
# Constants                                                                    #
#                                                                              #
#---############################################################################

#
# reasonable buffer size for file I/O operations
#

use constant SYSBUFSIZE => 1_048_576; # 1MB

#
# regular expressions
#

our(
    $_DirectoryRegexp,    # regexp matching an intermediate directory
    $_ElementRegexp,      # regexp matching an element
);

$_DirectoryRegexp = qr/[0-9a-f]{8}/;
$_ElementRegexp   = qr/[0-9a-f]{14}/;

#+++############################################################################
#                                                                              #
# Common Code                                                                  #
#                                                                              #
#---############################################################################

#
# make sure a module is loaded
#

sub _require ($) {
    my($module) = @_;

    return if $_LoadedModule{$module};
    eval("require $module"); ## no critic 'ProhibitStringyEval'
    if ($@) {
        $@ =~ s/\s+at\s.+?\sline\s+\d+\.?$//;
        dief("failed to load %s: %s", $module, $@);
    } else {
        $_LoadedModule{$module} = 1;
    }
}

#
# return the name of a new element to (try to) use with:
#  - 8 hexadecimal digits for the number of seconds since the Epoch
#  - 5 hexadecimal digits for the microseconds part
#  - 1 hexadecimal digit from the caller to further reduce name collisions
#
# properties:
#  - fixed size (14 hexadecimal digits)
#  - likely to be unique (with very high-probability)
#  - can be lexically sorted
#  - ever increasing (for a given process)
#  - reasonably compact
#  - matching $_ElementRegexp
#

sub _name ($) {
    return(sprintf("%08x%05x%01x", Time::HiRes::gettimeofday(), $_[0]));
}

#
# create a directory in adversary conditions:
#  - return true on success
#  - return false if the directory already exists
#  - die in case of any other error
#  - handle an optional umask
#

sub _special_mkdir ($$) {
    my($path, $umask) = @_;
    my($oldumask, $success);

    if (defined($umask)) {
        $oldumask = umask($umask);
        $success = mkdir($path);
        umask($oldumask);
    } else {
        $success = mkdir($path);
    }
    return(1) if $success;
    dief("cannot mkdir(%s): %s", $path, $!) unless $! == EEXIST and -d $path;
    # RACE: someone else may have created it at the the same time
    return(0);
}

#
# delete a directory in adversary conditions:
#  - return true on success
#  - return false if the path does not exist (anymore)
#  - die in case of any other error
#

sub _special_rmdir ($) {
    my($path) = @_;

    return(1) if rmdir($path);
    dief("cannot rmdir(%s): %s", $path, $!) unless $! == ENOENT;
    # RACE: someone else may have deleted it at the the same time
    return(0);
}

#
# get the contents of a directory in adversary conditions:
#  - return the list of names without . and ..
#  - return an empty list if the directory does not exist (anymore),
#    unless the optional second argument is true
#  - die in case of any other error
#

sub _special_getdir ($;$) {
    my($path, $strict) = @_;
    my($dh, @list);

    if (opendir($dh, $path)) {
        @list = grep($_ !~ /^\.\.?$/, readdir($dh));
        closedir($dh) or dief("cannot closedir(%s): %s", $path, $!);
        return(@list);
    }
    dief("cannot opendir(%s): %s", $path, $!)
        unless $! == ENOENT and not $strict;
    # RACE: someone else may have deleted it at the the same time
    return();
}

#
# create a file:
#  - return the file handle on success
#  - tolerate some errors unless the optional third argument is true
#  - die in case of any other error
#  - handle an optional umask
#

sub _create ($$;$) {
    my($path, $umask, $strict) = @_;
    my($fh, $oldumask, $success);

    if (defined($umask)) {
        $oldumask = umask($umask);
        $success = sysopen($fh, $path, O_WRONLY|O_CREAT|O_EXCL);
        umask($oldumask);
    } else {
        $success = sysopen($fh, $path, O_WRONLY|O_CREAT|O_EXCL);
    }
    return($fh) if $success;
    dief("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)
    return(0);
}

#
# "touch" a file or directory
#

sub _touch ($) {
    my($path) = @_;
    my($time);

    $time = time();
    utime($time, $time, $path)
        or dief("cannot utime(%d, %d, %s): %s", $time, $time, $path, $!);
}

#+++############################################################################
#                                                                              #
# Base Class                                                                   #
#                                                                              #
#---############################################################################

#
# helper to compute an "id" from the given path
#

sub _path2id ($) {
    my($path) = @_;
    my(@stat);

    # on some operating systems, we cannot rely on inode numbers :-(
    return($path) if $^O =~ /^(cygwin|dos|MSWin32)$/;
    # on others, we can: device number plus inode number should be unique
    @stat = stat($path);
    dief("cannot stat(%s): %s", $path, $!) unless @stat;
    return($stat[ST_DEV] . ":" . $stat[ST_INO]);
}

#
# object creator (wrapper)
#

sub new : method {
    my($class, %option) = @_;
    my($subclass);

    $option{"type"} ||= "Simple";
    $subclass = $class . "::" . $option{"type"};
    _require($subclass);
    delete($option{"type"});
    return($subclass->new(%option));
}

#
# object creator (inherited)
#

sub _new : method {
    my($class, %option) = @_;
    my($self, $path);

    # path is mandatory
    dief("missing option: path") unless defined($option{"path"});
    dief("not a directory: %s", $option{"path"})
        if -e $option{"path"} and not -d _;
    # build the object
    $self = {
        "path" => $option{"path"}, # toplevel path
        "dirs" => [],              # cached list of intermediate directories
        "elts" => [],              # cached list of elements
    };
    # check the integer options
    foreach my $name (qw(maxlock maxtemp rndhex umask)) {
        next unless defined($option{$name});
        dief("invalid %s: %s", $name, $option{$name})
            unless $option{$name} =~ /^\d+$/;
    }
    # handle the maxlock option
    if (defined($option{"maxlock"})) {
        $self->{"maxlock"} = $option{"maxlock"};
    } else {
        $self->{"maxlock"} = 600;
    }
    # handle the maxtemp option
    if (defined($option{"maxtemp"})) {
        $self->{"maxtemp"} = $option{"maxtemp"};
    } else {
        $self->{"maxtemp"} = 300;
    }
    # handle the rndhex option
    if (defined($option{"rndhex"})) {
        dief("invalid rndhex: %s", $option{"rndhex"})
            unless $option{"rndhex"} < 16;
        $self->{"rndhex"} = $option{"rndhex"};
    } else {
        $self->{"rndhex"} = int(rand(16));
    }
    # handle the umask option
    if (defined($option{"umask"})) {
        dief("invalid umask: %s", $option{"umask"})
            unless $option{"umask"} < 512;
        $self->{"umask"} = $option{"umask"};
    }
    # create the toplevel directory if needed
    $path = "";
    foreach my $name (split(/\/+/, $self->{"path"})) {
        $path .= $name . "/";
        _special_mkdir($path, $self->{"umask"}) unless -d $path;
    }
    # store the unique queue identifier
    $self->{"id"} = _path2id($self->{"path"});
    # that's it!
    bless($self, $class);
    return($self);
}

#
# copy/clone the object
#
# note:
#  - the main purpose is to copy/clone the iterator cached state
#  - the other attributes are _not_ cloned but this is not a problem
#    since they should not change
#

sub copy : method {
    my($self) = @_;
    my($copy);

    $copy = { %{ $self } };
    $copy->{"dirs"} = [];
    $copy->{"elts"} = [];
    bless($copy, ref($self));
    return($copy);
}

#
# return the toplevel path of the queue
#

sub path : method {
    my($self) = @_;

    return($self->{"path"});
}

#
# return a unique identifier for the queue
#

sub id : method {
    my($self) = @_;

    return($self->{"id"});
}

#
# return the name of the next element in the queue, using cached information
#

sub next : method { ## no critic 'ProhibitBuiltinHomonyms'
    my($self) = @_;
    my($dir, @list);

    return(shift(@{ $self->{"elts"} })) if @{ $self->{"elts"} };
    while (@{ $self->{"dirs"} }) {
        $dir = shift(@{ $self->{"dirs"} });
        foreach my $name (_special_getdir($self->{"path"} . "/" . $dir)) {
            push(@list, $1) if $name =~ /^($_ElementRegexp)$/o; # untaint
        }
        next unless @list;
        $self->{"elts"} = [ map("$dir/$_", sort(@list)) ];
        return(shift(@{ $self->{"elts"} }));
    }
    return("");
}

#
# return the first element in the queue and cache information about the next ones
#

sub first : method {
    my($self) = @_;
    my(@list);

    foreach my $name (_special_getdir($self->{"path"}, "strict")) {
        push(@list, $1) if $name =~ /^($_DirectoryRegexp)$/o; # untaint
    }
    $self->{"dirs"} = [ sort(@list) ];
    $self->{"elts"} = [];
    return($self->next());
}

#
# export control
#

sub import : method {
    my($pkg, %exported);

    $pkg = shift(@_);
    foreach my $name (
        qw(SYSBUFSIZE _name $_DirectoryRegexp $_ElementRegexp
           _special_getdir _special_mkdir _special_rmdir _create _touch)) {
        $exported{$name}++;
    }
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__END__