view release on metacpan or  search on metacpan

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

    },
);

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;
    return sub {
        my ( $self, $file, $ref ) = @_;

        local $YAML::Syck::ImplicitTyping = 0;
        local $YAML::Syck::SingleQuote    = 1;    # to keep from arbitrary quoting/unquoting (to help make diff's cleaner)
        local $YAML::Syck::SortKeys       = 1;    # to make diff's cleaner

        return YAML::Syck::DumpFile( $file, $ref );    # this does not keep the same $YAML::Syck:: vars apparently: shift;goto &YAML::Syck::DumpFile;

        # as of at least v1.27 it writes the characters without \x escaping so no need for:
        # return $self->write_file(
        #     $file,
        #     String::UnicodeUTF8::unescape_utf8( YAML::Syck::Dump($ref) )
        # );
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::yaml_read' => sub {
    require YAML::Syck;
    return sub {
        my ( $self, $file ) = @_;
        local $YAML::Syck::ImplicitTyping = 0;
        return YAML::Syck::LoadFile($file);    # this does not keep the same $YAML::Syck:: vars apparently: shift;goto &YAML::Syck::LoadFile;
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::json_write' => sub {
    require JSON::Syck;
    return sub {
        shift;
        goto &JSON::Syck::DumpFile;            # already does ♥ instead of \xe2\x99\xa5 (i.e. so no need for String::UnicodeUTF8::unescape_utf8() like w/ the YAML above)
    };
};

Sub::Defer::defer_sub __PACKAGE__ . '::json_read' => sub {
    require JSON::Syck;
    return sub {
        shift;
        goto &JSON::Syck::LoadFile;
    };
};

sub is_safe_part {
    my ( $fs, $part ) = @_;

    return if !defined($part) || !length($part) || $part eq $fs->spec->updir;
    return if scalar( $fs->spec->splitdir($part) ) != 1;
    return if utf8::is_utf8($part);    # a Unicode string, see String::UnicodeUTF8
    return if $part =~ m/[><|*&]/;     # some common shell meta characters

    my $cleaned = $fs->_app->str->trim( $part, 1 );
    return if $cleaned ne $part;

    return 1;
}

sub is_safe_path {
    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