view release on metacpan or  search on metacpan

lib/App/Kit/Obj/FS.pm  view on Meta::CPAN

};

# TODO: sort out conf file methods (or Config::Any etc):
#   read_json
#   write_json

#### same RSS/time as redefine-self plus 3.5% more ops ##
# sub cwd {
#     require Cwd;
#     shift;
#     goto &Cwd::cwd
# }
#
# sub cwd {
#     require Cwd;
#     no warnings 'redefine';
#     *cwd = sub {
#         shift;
#         goto &Cwd::cwd
#     };
#     shift;
#     goto &Cwd::cwd
# }
#
#
#### adds .75MB to RSS and 44.6% increase in opts, ick! ##
# sub cwd { shift->_cwd_code->(@_); }
#
# has _cwd_code => (
#     'is' => 'ro',
#     'lazy' => '1',
#     'default' => sub {
#         require Cwd;
#         return sub { shift; goto &Cwd::cwd }
#     },
# );

# TODO chdir related stuff:
# Sub::Defer::defer_sub __PACKAGE__ . '::chdir' => sub {
#     require Cwd;
#     return sub {
#         my $self = shift;
#         $self->starting_dir( $self->cwd );
#         goto &Cwd::chdir;
#     };
# };
#
# sub chbak {
#     my $self  = shift;
#     my $start = $self->starting_dir();
#     return 2 if !defined $start;
#
#     $self->chdir($start) || return;
#     $self->starting_dir(undef);
#
#     return 1;
# }

sub appdir {
    my ($self) = @_;
    return $self->spec->catdir( $self->bindir(), '.' . $self->_app->str->prefix . '.d' );
}

sub file_lookup {
    my ( $self, @rel_parts ) = @_;

    my $call = ref( $rel_parts[-1] ) ? pop(@rel_parts) : { 'inc' => [] };
    $call->{'inc'} = [] if !exists $call->{'inc'} || ref $call->{'inc'} ne 'ARRAY';

    my @paths;
    for my $base ( @{ $call->{'inc'} }, $self->appdir, @{ $self->inc } ) {
        next if !$base;
        push @paths, $self->spec->catfile( $base, @rel_parts );
    }

    return @paths if wantarray;

    my $path = '';
    for my $check (@paths) {
        if ( -e $check && -s _ ) {
            $path = $check;
            last;
        }
    }

    return $path if $path;
    return;
}

# Sub::Defer::defer_sub __PACKAGE__ . '::mkfile' => sub {
#     require File::Touch;
#     return sub {
#         my ($fs, $path) = @_;
#         $fs->mk_parent( $path ) || return;
#         eval { File::Touch::touch( $path ) } || return;
#         return 1;
#     };
# };

Sub::Defer::defer_sub __PACKAGE__ . '::mkpath' => sub {
    require File::Path::Tiny;
    return sub {
        shift;
        goto &File::Path::Tiny::mk;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::rmpath' => sub {
    require File::Path::Tiny;
    return sub {
        shift;
        goto &File::Path::Tiny::rm;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::empty_dir' => sub {
    require File::Path::Tiny;
    return sub {
        shift;
        goto &File::Path::Tiny::empty_dir;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::mk_parent' => sub {
    require File::Path::Tiny;
    return sub {
        shift;
        goto &File::Path::Tiny::mk_parent;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::tmpfile' => sub {
    require File::Temp;
    return sub {
        $_[0] = 'File::Temp';    # quicker than: shift; unshift(@_, 'Class::Name::Here');
        goto &File::Temp::new;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::tmpdir' => sub {
    require File::Temp;
    return sub {
        $_[0] = 'File::Temp';    # quicker than: shift; unshift(@_, 'Class::Name::Here');
        goto &File::Temp::newdir;
    };
};

has spec => (
    'is'      => 'ro',
    'lazy'    => '1',
    'default' => sub {
        require File::Spec;
        return 'File::Spec';
    },
);

has bindir => (
    'is'   => 'rw',
    'lazy' => '1',

    # 'isa'     => sub { die "'bindir' must be a directory" unless -d $_[1] },
    'default' => sub {

        # PSGI/Plack $0
        #   1. starman worker -Ilib … t/test.psgi
        #   2. 500 error: Cannot find current script 'starman worker -Ilib … t/test.psgi' at …/FindBin.pm line 166.
        local $0 = $0;
        if ( $0 =~ m/(\S+\.psgi)/ ) {
            $0 = $1;
        }
        require FindBin;
        require Cwd;
        return $FindBin::Bin || FindBin->again() || Cwd::cwd();
    },
);

has inc => (
    'is'      => 'rw',
    'default' => sub { [] },
    'isa'     => sub { die "'inc' must be an array ref" unless ref( $_[0] ) eq 'ARRAY' },
);

# has starting_dir => (
#     'is'      => 'rw',
#     'default' => sub { undef },
# );

Sub::Defer::defer_sub __PACKAGE__ . '::read_dir' => sub {
    require File::Slurp;
    return sub {
        shift;
        goto &File::Slurp::read_dir;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::read_file' => sub {
    require File::Slurp;
    return sub {
        shift;
        goto &File::Slurp::read_file;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::write_file' => sub {
    require File::Slurp;
    return sub {
        shift;
        goto &File::Slurp::write_file;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::get_iterator' => sub {
    require Path::Iter;
    return sub {
        shift;
        goto &Path::Iter::get_iterator;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::yaml_write' => sub {
    require YAML::Syck;

lib/App/Kit/Obj/FS.pm  view on Meta::CPAN

    my ( $fs, $path, $abs_ok, $trl_ok ) = @_;

    return if !defined($path) || !length($path);
    return if utf8::is_utf8($path);    # a Unicode string, see String::UnicodeUTF8

    my @parts = $fs->spec->splitdir($path);

    return if !$abs_ok && $parts[0] eq '';
    return if !$trl_ok && $parts[-1] eq '';

    for my $idx ( 0 .. $#parts ) {
        next if $idx == 0 && $parts[$idx] eq '';
        next if $idx == $#parts && $parts[$idx] eq '';
        return if !$fs->is_safe_part( $parts[$idx] );
    }

    return 1;
}

# TODO new FCR

1;

__END__

=encoding utf-8

=head1 NAME

App::Kit::Obj::FS - file system utility object

=head1 VERSION

This document describes App::Kit::Obj::FS version 0.1

=head1 SYNOPSIS

    my $fs = App::Kit::Obj::FS->new();
    my @guts = $fs->read_file(…);

=head1 DESCRIPTION

file system utility object

=head1 INTERFACE

=head2 new()

Returns the object.

Takes one required attribute: _app. It should be an L<App::Kit> object for it to use internally.

Has 3 optional attributes:

=head3 spec

Lazy loads L<File::Spec> and returns the class accessor for L<File::Spec> methods. Setting this via new() is probably not a good idea.

    my $dir = $fs->spec->catdir(…);

=head3 bindir

The applications main directory. Defaults to script’s directory or the current working directory.

Lazy loads L<FindBin> and L<Cwd>.

Works with .psgi files being run under Plack/PSGI.

=head3 inc

An array ref of paths for file_lookup() to use. Defaults to [].

=head2 cwd()

Lazy wrapper of L<Cwd>’s cwd().

=head2 appdir()

The directory that belongs to the app.

It is a directory in the object’s base path called .$prefix.d (where $prefix is the _app attributes’s ->str->prefix):

$fs->bindir()/.$str->prefix().d/

=head2 file_lookup()

In scalar context returns the first path that exists for the given arguments.

In array context returns all possible paths for the given arguments without any existence check.

The final argument can be a config hashref with the inc key whose value is an array of paths.

The arguments are the pieces of the path you are interested in that get put together in a portable way.

    my $conf = $fs->file_lookup('data', 'foo.json'); # e.g. …/my_app_bindir/.appkit.d/data/foo.json

The path is looked for in this order:

=over 4

1. the 'inc' paths in the given argument if any

2. appdir()

3. the objects’s inc attribute

=back

=head2 mkpath()

Lazy wrapper of L<File::Path::Tiny>’s mk().

=head2 rmpath()

Lazy wrapper of L<File::Path::Tiny>’s rm().

=head2 empty_dir()

Lazy wrapper of L<File::Path::Tiny>’s empty_dir().

=head2 mk_parent()

Lazy wrapper of L<File::Path::Tiny>’s mk_parent().

=head2 tmpfile()

Lazy wrapper of L<File::Temp>’s tmpfile().

=head2 tmpdir()

Lazy wrapper of L<File::Temp>’s tmpdir().

=head2 read_dir()

Lazy wrapper of L<File::Slurp>’s read_dir().

=head2 read_file()

Lazy wrapper of L<File::Slurp>’s read_file().

=head2 write_file()

Lazy wrapper of L<File::Slurp>’s write_file().

=head2 json_read()

Lazy wrapper to consistently load a JSON file to a data structure.

    my $data = $fs->read_json($file);

=head2 json_write()

Lazy wrapper to consistently write a data structure as a JSON file.

    $fs->write_json($file, $data);