File Coverage

lib/Badger/Filesystem.pm

Criterion	Covered	Total	%
statement	244	253	96.4
branch	97	140	69.2
condition	49	96	51.0
subroutine	55	60	91.6
pod	49	49	100.0
total	494	598	82.6

#========================================================================
#
# Badger::Filesystem
#
# DESCRIPTION
#   OO representation of a filesystem.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Filesystem;

use File::Spec;
use Cwd 'getcwd';
use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Prototype Badger::Filesystem::Base',
    import    => 'class',
    utils     => 'params is_object random_name',
    constants => 'HASH ARRAY TRUE REFS PKG',
    constant  => {
        virtual     => 0,
        NO_FILENAME => 1,
        FILESPEC    => 'File::Spec',
        FINDBIN     => 'FindBin',
        ROOTDIR     =>  File::Spec->rootdir,
        CURDIR      =>  File::Spec->curdir,
        UPDIR       =>  File::Spec->updir,
        FS          => 'Badger::Filesystem',
        VFS         => 'Badger::Filesystem::Virtual',
        UFS         => 'Badger::Filesystem::Universal',
        PATH        => 'Badger::Filesystem::Path',
        FILE        => 'Badger::Filesystem::File',
        DIRECTORY   => 'Badger::Filesystem::Directory',
        VISITOR     => 'Badger::Filesystem::Visitor',
    },
    exports   => {
        any         => 'FS PATH FILE DIR DIRECTORY cwd getcwd rel2abs abs2rel',
        tags        => {
            types   => 'Path File Dir Directory Cwd Bin',
            dirs    => 'ROOTDIR UPDIR CURDIR',
        },
        hooks       => {
            VFS     => sub {
                # load VFS module and call its export() method
                class(shift->VFS)->load->pkg->export(shift, shift)
            },
            UFS     => sub {
                # load UFS module and call its export() method
                class(shift->UFS)->load->pkg->export(shift, shift)
            },
            '$Bin'  => \&_export_findbin_hook,
        },
    },
    messages  => {
        open_failed   => 'Failed to open %s %s: %s',
        delete_failed => 'Failed to delete %s %s: %s',
        bad_volume    => 'Volume mismatch: %s vs %s',
        bad_stat      => 'Nothing known about %s',
        copy_failed   => 'Failed to %s file from %s to %s: %s',
        no_path       => 'Unable to determine location of %s',
    };

use Badger::Filesystem::File;
use Badger::Filesystem::Directory;

#-----------------------------------------------------------------------
# special export hooks to make $Bin available from FindBin
#-----------------------------------------------------------------------

sub _export_findbin_hook {
    my ($class, $target) = @_;
    class($class->FINDBIN)->load;
    $class->export_symbol($target, Bin => \$FindBin::Bin);
};


#-----------------------------------------------------------------------
# aliases
#-----------------------------------------------------------------------

*DIR          = \&DIRECTORY;              # constant class name
*Dir          = \&Directory;              # constructor sub
*dir          = \&directory;              # object method
*split_dir    = \&split_directory;        # ...because typing 'directory'
*join_dir     = \&join_directory;         #    gets tedious quickly
*collapse_dir = \&collapse_directory;
*dir_exists   = \&directory_exists;
*create_dir   = \&create_directory;
*delete_dir   = \&delete_directory;
*open_dir     = \&open_directory;
*read_dir     = \&read_directory;
*temp_dir     = \&temp_directory;
*dir_child    = \&directory_child;
*dir_children = \&directory_children;
*mkdir        = \&create_directory;
*rmdir        = \&delete_directory;
*touch        = \&touch_file;


#-----------------------------------------------------------------------
# In this base class definitive paths are the same as absolute paths.
# However, in subclasses (like Badger::Filesystem::Virtual) we want
# to differentiate between absolute paths in a virtual filesystem
# (e.g. /about/badger.html) and the definitive paths that they map to
# in a real file system (e.g. /home/abw/web/badger/about/badger.html).
# We make the further distinction between definitive paths used for
# reading or writing, and call the appropriate method to perform any
# virtual -> real mapping before operating on any file or directory.
# But like I said, these are just hooks for subclasses to use if they
# need them.  In the base class, we patch them straight into the plain
# old absolute() method.
#-----------------------------------------------------------------------

*definitive       = \&absolute;
*definitive_read  = \&absolute;
*definitive_write = \&absolute;


#-----------------------------------------------------------------------
# factory subroutines
#-----------------------------------------------------------------------

sub Path {
    return PATH unless @_;
    return @_ == 1 && is_object(PATH, $_[0])
        ? $_[0]                                 # return existing Path object
        : FS->path(@_);                         # or construct a new one
}

sub File {
    return FILE unless @_;
    return @_ == 1 && is_object(FILE, $_[0])
        ? $_[0]                                 # ditto for File object
        : FS->file(@_);
}

sub Directory {
    return DIRECTORY unless @_;
    return @_ == 1 && is_object(DIRECTORY, $_[0])
        ? $_[0]                                 # ditto for Directory object
        : FS->directory(@_);
}

sub Cwd {
    FS->directory
}

sub Bin {
    class(FINDBIN)->load;
    FS->directory($FindBin::Bin);
}


#-----------------------------------------------------------------------
# generated methods
#-----------------------------------------------------------------------

class->methods(
    # define methods for path/root/updir/curdir that access a prototype
    # object when called as class methods.
    map {
        my $name = $_;      # fresh copy of lexical for binding in closure
        $name => sub {
            $_[0]->prototype->{ $name };
        }
    }
    qw( rootdir updir curdir separator )
);


#-----------------------------------------------------------------------
# constructor methods
#-----------------------------------------------------------------------

sub init {
    my ($self, $config) = @_;

    # NEW CODE: trying to abstract out the file specification so that I
    # can slot in a Universal file spec decoy which always generates URIs
    my $spec = $self->{ spec }
             = $config->{ spec }
            || $config->{ filespec }
            || $self->FILESPEC;

    $self->debug("spec is $spec") if DEBUG;

    # The tokens used to represent the root directory ('/'), the
    # parent directory ('..') and current directory ('.') default to
    # constants grokked from File::Spec.  To determine the path separator
    # we have to resort to an ugly hack.  The File::Spec module hard-codes
    # the path separator in the catdir() method so we have to make a round-
    # trip through catdir() to grok the separator in a cross-platform manner
    $self->{ rootdir   } = $config->{ rootdir   } || $spec->rootdir;
    $self->{ updir     } = $config->{ updir     } || $spec->updir;
    $self->{ curdir    } = $config->{ curdir    } || $spec->curdir;
    $self->{ separator } = $config->{ separator } || do {
        my $sep = FILESPEC->catdir(('badger') x 2);
        $sep =~ s/badger//g;
        $sep;
    };

    # flag to indicate if directory scans should return all entries
    $self->{ all_entries } = $config->{ all_entries } || 0;

    # current working can be specified explicitly, otherwise we leave it
    # undefined and let cwd() call getcwd() determine it dynamically
    $self->{ cwd } = $config->{ cwd };

    # additional options, e.g. codec, encoding
    $self->init_options($config);

    return $self;
}

sub spec {
    return ref $_[0] eq HASH
        ? $_[0]->{ spec }
        : FILESPEC;
}

sub path {
    Path->new( shift->_child_args( path => @_ ) );
}

sub file {
    File->new( shift->_child_args( file => @_ ) );
}

sub directory {
    my $self = shift;
    my $args = $self->_child_args( directory => @_ );

    # default directory is the current working directory
    $args->{ path } = $self->cwd
        if exists $args->{ path } && ! defined $args->{ path };

    Directory->new($args);
}

sub root {
    my $self = shift->prototype;
    $self->directory($self->{ rootdir });
}

sub cwd {
    my $cwd;
    if (@_) {
        # called as an object or class method
        my $self = shift->prototype;
        # if we have a hard-coded cwd set then return that, otherwise call
        # getcwd to return the real current working directory.  NOTE: we don't
        # cache the dynamically resolved cwd as it'll change if chdir() is called
        $cwd = $self->{ cwd } || getcwd;
    }
    else {
        # called as a subroutine
        $cwd = getcwd;
    }
    # pass through File::Spec to sanitise path to local filesystem
    # convention - otherwise we get /forward/slashes on Win32
    FILESPEC->canonpath($cwd);
}


#-----------------------------------------------------------------------
# path manipulation methods
#-----------------------------------------------------------------------

sub merge_paths {
    my ($self, $base, $path) = @_;
    my $spec = $self->spec;
    my @p1   = $spec->splitpath($base);
    my @p2   = $spec->splitpath($path);

    # check volumes match
    if (defined $p2[0] and length $p2[0]) {
        $p1[0] ||= $p2[0];
        return $self->error_msg( bad_volume => $p1[0], $p1[0] )
            unless $p1[0] eq $p2[0];
    }
    shift(@p2);
    my $vol = shift(@p1) || '';
    my $file = pop @p2;

    $spec->catpath($vol, $spec->catdir(@p1, @p2), $file);
}

sub join_path {
    my $self = shift;
    my @args = map { defined($_) ? $_ : '' } @_[0..2];
    my $spec = $self->spec;
    $spec->canonpath( $spec->catpath(@args) );
}

sub join_directory {
    my $self = shift;
    my $dir  = @_ == 1 ? shift : [ @_ ];
    my $spec = $self->spec;
    $self->debug("join_dir(", ref $dir eq ARRAY ? '[' . join(', ', @$dir) . ']' : $dir, ")\n") if $DEBUG;
    ref $dir eq ARRAY
        ? $spec->catdir(@$dir)
        : $spec->canonpath($dir);
}

sub split_path {
    my $self  = shift;
    my $path  = $self->join_directory(@_);
    my @split = map { defined($_) ? $_ : '' } $self->spec->splitpath($path);
    $self->debug("split_path($path) => ", join(', ', @split), "\n") if $DEBUG;
    return wantarray ? @split : \@split;
}

sub split_directory {
    my $self  = shift;
    my $path  = $self->join_directory(@_);
    my @split = $self->spec->splitdir($path);
    return wantarray ? @split : \@split;
}

sub collapse_directory {
    my $self = shift->prototype;
    my @dirs = $self->split_directory(shift);
    my ($up, $cur) = @$self{qw( updir curdir )};
    my ($node, @path);
    while (@dirs) {
        $node = shift @dirs;
        if ($node eq $cur) {
            # do nothing
        }
        elsif ($node eq $up) {
            pop @path if @path;
        }
        else {
            push(@path, $node);
        }
    }
    $self->join_directory(@path);
}

sub slash_directory {
    my $self  = shift->prototype;
    my $path  = $self->absolute(shift);
    my $slash = $self->{ slashed } ||= do {
        my $sep = quotemeta $self->{ separator };
        qr/$sep$/;
    };
    $path .= $self->{ separator } unless $path =~ $slash;
    return $path;
}


#-----------------------------------------------------------------------
# absolute and relative path tests and transmogrifiers
#-----------------------------------------------------------------------

sub is_absolute {
    my $self = shift;
#    $self->debug("args: ", $self->dump_data(\@_));
    $self->spec->file_name_is_absolute(
        $self->join_directory(@_)
    ) ? 1 : 0;
}

sub is_relative {
    shift->is_absolute(@_) ? 0 : 1;
}

sub absolute {
    my $self = shift;
    my $path = $self->join_directory(shift);
    my $spec = $self->spec;
    return $path if $spec->file_name_is_absolute($path);
    $spec->catdir(shift || $self->cwd, $path);
}

sub relative {
    my $self = shift;
    $self->spec->abs2rel($self->join_directory(shift), shift || $self->cwd);
}


#-----------------------------------------------------------------------
# file/directory test methods
#-----------------------------------------------------------------------

sub path_exists {
    shift->stat_path(@_);
}

sub file_exists {
    my $self  = shift;
    my $stats = $self->stat_path(shift) || return;
    return -f _ ? $stats : 0;       # relies on cached stat
}

sub directory_exists {
    my $self = shift;
    my $stats = $self->stat_path(shift) || return;
    return -d _ ? $stats : 0;       # relies on cached stat
}

sub stat_path {
    my $self  = shift;
    my $path  = $self->definitive_read(shift) || return;
    my @stats = (stat($path), -r _, -w _, -x _, -o _, $path);

    return $self->error_msg( bad_stat => $self->{ path } )
        unless @stats;

    return wantarray
        ?  @stats
        : \@stats;
}

sub chmod_path {
    my $self = shift;
    my $path = $self->definitive_write(shift);
    chmod(shift, $path);
}


#-----------------------------------------------------------------------
# file manipulation methods
#-----------------------------------------------------------------------

sub create_file {
    my ($self, $path) = @_;
    unless (-e $self->definitive_write($path)) {
        $self->write_file($path); # calls definitive_write again
    }
    return 1;
}

sub touch_file {
    my ($self, $path) = @_;
    my $definitive = $self->definitive_write($path);
    if (-e $definitive) {
        my $now = time();
        utime $now, $now, $definitive;
    }
    else {
        $self->write_file($path); # calls definitive_write again
    }
}

sub delete_file {
    my $self = shift;
    my $path = $self->definitive_write(shift);
    unlink($path)
        || return $self->error_msg( delete_failed => file => $path => $! );
}

sub open_file {
    my $self = shift;
    my $name = shift;
    my $mode = $_[0] || 'r';            # leave it in @_ for IO::File
    my $opts = @_ && ref $_[-1] eq HASH ? pop(@_) : { };
    my $path = $mode eq 'r'
        ? $self->definitive_read($name)
        : $self->definitive_write($name);
    return $self->error_msg( no_path => $name )
        unless defined $path && length $path;

    require IO::File;
    $self->debug("about to open file $path (", join(', ', @_), ")\n") if $DEBUG;

    my $fh = IO::File->new($path, @_)
        || $self->error_msg( open_failed => file => $path => $! );

    $fh->binmode( $opts->{ encoding } )
        if $opts->{ encoding };

    return $fh;
}

sub read_file {
    my $self = shift;
    my $opts = @_ && ref $_[-1] eq HASH ? pop(@_) : { };
    my $fh   = $self->open_file(shift, 'r', $opts);
    return wantarray
        ? <$fh>
        : do { local $/ = undef; <$fh> };
}

sub write_file {
    my $self = shift;
    my $opts = @_ && ref $_[-1] eq HASH ? pop(@_) : { };
    my $fh   = $self->open_file(shift, 'w', $opts);
    return $fh unless @_;           # return handle if no args
    print $fh @_;                   # or print args and close
    $fh->close;
    return 1;
}

sub append_file {
    my $self = shift;
    my $opts = @_ && ref $_[-1] eq HASH ? pop(@_) : { };
    my $fh   = $self->open_file(shift, 'a', $opts);
    return $fh unless @_;           # return handle if no args
    print $fh @_;                   # or print args and close
    $fh->close;
    return 1;
}


sub copy_file {
    shift->_file_copy( copy => @_ );
}

sub move_file {
    shift->_file_copy( move => @_ );
}

sub _file_copy {
    require File::Copy;

    my ($self, $action, $from, $to, $params)
     = (shift, shift, shift, shift, params(@_));

    my $src
        = is_object(PATH, $from)    ? $from->definitive     # path object
        : ref($from)                ? $from                 # file handle
        : $self->definitive_read($from);                    # file path

    my $dest
        = is_object(PATH, $to)      ? $to->definitive       # as above
        : ref($to)                  ? $to
        : $self->definitive_write($to);

    my $code
        = $action eq 'copy' ? \&File::Copy::copy
        : $action eq 'move' ? \&File::Copy::move
        : return $self->error( invalid => action => $action );

    my $file;

   unless (ref $dest) {
        # NOTE: don't use $self->file($dest) because $self could be a
        # VFS and $dest is already a definitive path
        $file = File($dest);
        # capture our current working directory
        my $cwd = cwd;
        eval {
            # Change to the destination volume if one exists.
            # Should work for any volume except Windows shares
            # where resulting behavior is version dependent.
            chdir $file->volume if ($file->volume);
            # this code strips volume information
            $file->directory->must_exist(
                $params->{ mkdir    },
                $params->{ dir_mode },
            );
            # change back to the current working directory
            chdir $cwd;
        } or do {
            # capture any exception from above
            # change back to the oringial cwd
            # and rethrow the execption.
            if ($@) {
                chdir $cwd;
                die $@;
            }
        }
    }

    $code->($src, $dest)
        || return $self->error_msg( copy_failed => $action, $from, $to, $! );

    my $mode = $params->{ file_mode };
       $mode = $params->{ mode } unless defined $mode;

    $file->chmod($mode)
        if $file && defined $mode;

    return $file || $dest;
}


#-----------------------------------------------------------------------
# directory manipulation methods
#-----------------------------------------------------------------------

sub create_directory {
    my $self   = shift;
    my $path   = $self->definitive_write(shift);

    require File::Path;

    eval {
        local $Carp::CarpLevel = 1;
        File::Path::mkpath($path, 0, @_)
    } || return $self->error($@);
}

sub delete_directory {
    my $self = shift;
    my $path = $self->definitive_write(shift);

    require File::Path;
    File::Path::rmtree($path, @_)
}

sub open_directory {
    my $self = shift;
    my $path = $self->definitive_read(shift);

    require IO::Dir;
    $self->debug("Opening directory: $path\n") if $DEBUG;

    return IO::Dir->new($path, @_)
        || $self->error_msg( open_failed => directory => $path => $! );
}

sub read_directory {
    my $self = shift;
    my $dirh = $self->open_directory(shift);
    my $all  = shift;
    my ($path, @paths);
    while (defined ($path = $dirh->read)) {
        push(@paths, $path);
    }
    @paths = $self->spec->no_upwards(@paths)
        unless $all || ref $self && $self->{ all_entries };

    $dirh->close;
    return wantarray ? @paths : \@paths;
}

sub directory_child {
    my $self = shift;
    my $path = $self->join_directory(@_);
    stat $self->definitive_read($path);
    -d _ ? $self->directory($path) :
    -f _ ? $self->file($path) :
           $self->path($path);
}

sub directory_children {
    my $self  = shift;
    my $dir   = shift;
    my @paths = map {
        $self->directory_child($dir, $_)
    }   $self->read_directory($dir, @_);
    return wantarray ? @paths : \@paths;
}


#-----------------------------------------------------------------------
# temporary directory/file methods
#-----------------------------------------------------------------------

sub temp_directory {
    my $self = shift;
    return $self->directory( FILESPEC->tmpdir, @_ )->must_exist(1);
}

sub temp_file {
    my $self = shift;
    return $self->temp_directory->file( @_ ? @_ : random_name() )
}


#-----------------------------------------------------------------------
# visitor methods
#-----------------------------------------------------------------------

sub visitor {
    my $self  = shift;
    my $vtype = $self->VISITOR;
    class($vtype)->load;

    return @_ && is_object($vtype => $_[0])
        ? shift
        : $vtype->new(@_);
}

sub visit {
    shift->root->visit(@_);
}

sub collect {
    shift->visit(@_)->collect;
}

sub accept {
    shift->root->accept(@_);
}

#-----------------------------------------------------------------------
# internal methods
#-----------------------------------------------------------------------

sub _child_args {
    my $self = shift->prototype;
    my $type = shift;
    my $args = { %{ $self->{ options } } };

    if (@_ && ref $_[-1] eq HASH) {
        my $more = pop @_;
        @$args{ keys %$more } = values %$more;
    }

    if (@_ > 1) {
        $args->{ path } = [@_];
    }
    elsif (@_ == 1) {
        $args->{ path } = shift;
    }
    else {
        $args->{ path } = undef;
    }

    $args->{ filesystem } = $self;
    return $args;
}



1;

__END__