CatalystX::CRUD::Model::File - filesystem CRUD model

 package MyApp::Model::Foo;
 use base qw( CatalystX::CRUD::Model::File );
 __PACKAGE__->config( 
    object_class    => 'MyApp::File',
    delegate_class  => 'Path::Class::File', # optional
    inc_path        => [ '/some/path', '/other/path' ],
 );

 1;

 # TODO regex vs exact match

    perldoc CatalystX::CRUD

package CatalystX::CRUD::Model::File;
use strict;
use warnings;
use base qw( CatalystX::CRUD::Model );
use File::Find;
use Carp;
use Data::Dump qw( dump );
use Path::Class;
use mro 'c3';

__PACKAGE__->mk_accessors(qw( inc_path ));

our $VERSION = '0.51';

# test whether symlink() works at compile time
my $SYMLINK_SUPPORTED = eval { symlink( "", "" ); 1 };

sub Xsetup {
    my ( $self, $c ) = @_;
    $self->{inc_path} ||= [ $c->config->{root} ];
    if ( $self->config->{delegate_class} ) {
        $self->object_class->delegate_class(
            $self->config->{delegate_class} );
    }
    $self->next::method($c);
}

sub fetch {
    my $self = shift;
    my $file = $self->new_object(@_);

    # look through inc_path
    for my $dir ( @{ $self->inc_path } ) {
        my $test = $self->object_class->delegate_class->new( $dir, $file );

        if ( -s $test ) {
            $file->{delegate} = $test;
            $file->read;
            last;
        }
    }

    #carp dump $file;

    # make sure delegate() has absolute path
    # while file() is relative to inc_path.
    if ( $file->dir eq '.' or !$file->dir->is_absolute ) {
        $file->{delegate}
            = $self->object_class->delegate_class->new( $self->inc_path->[0],
            $file );
    }

    #carp dump $file;

    return $file;
}

sub make_query {
    my ($self) = @_;
    return sub {1};
}

sub _find {
    my ( $self, $filter_sub, $root ) = @_;
    my %files;
    my $del_class = $self->object_class->delegate_class;
    my $find_sub  = sub {

        #warn "File::Find::Dir = $File::Find::dir";
        #warn "file = $_";
        #warn "name = $File::Find::name";

        my $dir = Path::Class::dir($File::Find::dir);
        my $f   = Path::Class::file($File::Find::name);
        return if $dir eq $f;

        return unless $filter_sub->( $root, $dir, $f );

        # we want the file path relative to $root
        # since that is the PK
        my $rel = $dir->relative($root);
        $rel =~ s!^\./!!;
        my $key = $del_class->new( $rel, $_ );

        #warn "$key => $f";

        $files{$key} = $f if -f $f;
    };
    find(
        {   follow => 1,
            wanted => $find_sub,
        },
        $root
    );
    return \%files;
}

sub search {
    my $self = shift;
    my $filter_sub = shift || $self->make_query;
    my @objects;
    for my $root ( @{ $self->inc_path } ) {
        my $files = $self->_find( $filter_sub, $root );
        for my $relative ( sort keys %$files ) {
            my $obj = $self->new_object(
                file     => $relative,
                delegate => $files->{$relative}
            );
            $obj->read;    # just like fetch()
            push @objects, $obj;
        }
    }
    return \@objects;
}

sub count {
    my $self       = shift;
    my $filter_sub = shift || $self->make_query;
    my $count      = 0;
    for my $root ( @{ $self->inc_path } ) {
        my $files = $self->_find( $filter_sub, $root );
        $count += scalar keys %$files;
    }

    return $count;
}

sub iterator {
    my $self  = shift;
    my $files = $self->search(@_);
    return CatalystX::CRUD::Iterator::File->new($files);
}

sub add_related {
    my ( $self, $file, $rel_name, $other_file_name ) = @_;

    if ( !$SYMLINK_SUPPORTED ) {
        $self->context->log->error(
            "symlink() is not supported on this system");
        return;
    }

    my $other_file = $self->fetch( file => $other_file_name );

    unless ( -r $other_file ) {
        $self->throw_error("no such file $other_file");
    }

    if ( $rel_name eq 'dir' ) {

        # if in the same dir, already related.
        if ( $other_file->dir eq $file->dir ) {
            $self->throw_error("relationship already exists");
        }

        # if not, create symlink
        my $link = $self->object_class->delegate_class->new( $file->dir,
            $other_file->basename );
        if ( !symlink( "$file", "$link" ) ) {
            $self->throw_error("failed to symlink $link => $file: $@");
        }

    }
    else {
        $self->throw_error("unsupported relationship name: $rel_name");
    }
}

sub rm_related {
    my ( $self, $file, $rel_name, $other_file_name ) = @_;

    if ( !$SYMLINK_SUPPORTED ) {
        $self->context->log->error(
            "symlink() is not supported on this system");
        return;
    }

    my $other_file = $self->fetch( file => $other_file_name );

    unless ( -r $other_file ) {
        $self->throw_error("no such file $other_file : $!");
    }

    if ( $rel_name eq 'dir' ) {
        my $link = $self->object_class->delegate_class->new( $file->dir,
            $other_file->basename );

        unless ( -l $link ) {
            $self->throw_error("$other_file is not a symlink");
        }

        unlink($link) or $self->throw_error("unlink for $link failed: $!");

        return 1;

    }
    else {
        $self->throw_error("unsupported relationship name: $rel_name");
    }

}

1;

__END__