DBIx::Class::InflateColumn::FS - Inflate/deflate columns to Path::Class::File objects

  __PACKAGE__->load_components(qw/InflateColumn::FS Core/);
  __PACKAGE__->add_columns(
      id => {
          data_type         => 'INT',
          is_auto_increment => 1,
      },
      file => {
          data_type => 'TEXT',
          is_fs_column => 1,
          fs_column_path => '/var/lib/myapp/myfiles',
      },
      file_2 => {
          data_type => 'TEXT',
          is_fs_column => 1,
          fs_column_path => '/var/lib/myapp/myfiles',
          fs_new_on_update => 1
      },
  );
  __PACKAGE__->set_primary_key('id');

  # in application code
  $rs->create({ file => $file_handle });

  $row = $rs->find({ id => $id });
  my $fh = $row->file->open('r');

  Mailing list: http://lists.scsys.co.uk/mailman/listinfo/dbix-class/

  IRC: irc.perl.org#dbix-class

package DBIx::Class::InflateColumn::FS;

use strict;
use warnings;
use DBIx::Class::UUIDColumns;
use File::Spec ();
use File::Path ();
use File::Copy ();
use Path::Class ();

our $VERSION = '0.01007';

sub inflate_result {
    my ($class, $source, $me, $prefetch) = @_;

    my $new = $class->next::method($source, $me, $prefetch);
    
    while ( my($column, $data) = each %{$new->{_column_data}} ) {
        if ( $source->has_column($column) && $source->column_info($column)->{is_fs_column} && defined $data ) {
            $new->{_fs_column_filename}{$column} = $data;
        }
    }
    
    return $new;
}

sub register_column {
    my ($self, $column, $info, @rest) = @_;
    $self->next::method($column, $info, @rest);
    return unless defined($info->{is_fs_column});

    $self->inflate_column($column => {
        inflate => sub { 
            my ($value, $obj) = @_;
            $obj->_inflate_fs_column($column, $value);
        },
        deflate => sub {
            my ($value, $obj) = @_;
            $obj->_deflate_fs_column($column, $value);
        },
    });
}

sub fs_file_name {
    my ($self, $column, $column_info) = @_;
    return DBIx::Class::UUIDColumns->get_uuid;
}

sub _fs_column_storage {
    my ( $self, $column ) = @_;

    my $column_info = $self->result_source->column_info($column);
    $self->throw_exception("$column is not an fs_column")
        unless $column_info->{is_fs_column};

    $self->{_fs_column_filename}{$column} ||= do {
        my $filename = $self->fs_file_name($column, $column_info);
        File::Spec->catfile($self->_fs_column_dirs($filename), $filename);
    };

    return Path::Class::File->new($column_info->{fs_column_path}, $self->{_fs_column_filename}{$column});
}

sub _fs_column_dirs {
    shift;
    my $filename = shift;

    return $filename =~ /(..)/;
}

sub copy {
    my ($self, $changes) = @_;

    $changes ||= {};
    my $col_data     = { %{$self->{_column_data}} };

    foreach my $col ( keys %$col_data ) {
        my $column_info = $self->result_source->column_info($col);
        if ( $column_info->{is_fs_column} && defined $col_data->{$col} ) {  # nothing special required for NULLs
            delete $col_data->{$col};
            
            # pass the original file to produce a copy on deflate
            $changes->{$col} = $self->get_inflated_column($col);
        }
    }

    my $temp = bless { _column_data => $col_data }, ref $self;
    $temp->result_source($self->result_source);

    return $temp->next::method($changes);
}

sub delete {
    my ( $self, @rest ) = @_;

    for my $column ( $self->columns ) {
        my $column_info = $self->result_source->column_info($column);
        if ( $column_info->{is_fs_column} ) {
            my $accessor = $column_info->{accessor} || $column;
            $self->$accessor && $self->$accessor->remove;
        }
    }

    return $self->next::method(@rest);
}

sub set_column {
    my ($self, $column, $new_value) = @_;

    if ( !defined $new_value && $self->result_source->column_info($column)->{is_fs_column}
            && $self->{_fs_column_filename}{$column} ) {
        $self->_fs_column_storage($column)->remove;
        delete $self->{_fs_column_filename}{$column};
    }

    return $self->next::method($column, $new_value);
}

sub set_inflated_column {
    my ($self, $column, $inflated) = @_;

    $self->next::method($column, $inflated);

    # reinflate
    if ( defined $inflated && ref $inflated && ref $inflated ne 'SCALAR'
            && $self->result_source->column_info($column)->{is_fs_column} ) {
        $inflated = $self->{_inflated_column}{$column} = $self->_fs_column_storage($column);
    }
    return $inflated;
}

sub _inflate_fs_column {
    my ( $self, $column, $value ) = @_;
    return unless defined $value;

    $self->{_fs_column_filename}{$column} = $value;
    return $self->_fs_column_storage($column);
}

sub _deflate_fs_column {
    my ( $self, $column, $value ) = @_;

    my $column_info = $self->result_source->column_info($column);

    # kill the old storage, rather than overwrite, if fs_new_on_update
    if ( $column_info->{fs_new_on_update} && $self->{_fs_column_filename}{$column} ) {
        my $oldfile = $self->_fs_column_storage($column);
        if ( $oldfile ne $value ) {
            $oldfile->remove;
            delete $self->{_fs_column_filename}{$column};
        }
    }
    
    my $file = $self->_fs_column_storage($column);
    if ( $value ne $file ) {
        File::Path::mkpath([$file->dir]);

        # get a filehandle if we were passed a Path::Class::File
        my $fh1 = eval { $value->openr } || $value;
        my $fh2 = $file->openw or die;
        File::Copy::copy($fh1, $fh2);

        $self->{_inflated_column}{$column} = $file;

        # ensure the column will be marked dirty
        $self->{_column_data}{$column} = undef;
    }
    return $self->{_fs_column_filename}{$column};
}

sub DESTROY {
    my $self = shift;

    return if $self->in_storage;

    # If fs columns were deflated, but the row was never stored, we need to delete the
    # backing files.
    while ( my ( $col, $data ) = each %{ $self->{_column_data} } ) {
        my $column_info = $self->result_source->column_info($col);
        if ( $column_info->{is_fs_column} && defined $data ) {
            my $accessor = $column_info->{accessor} || $col;
            $self->$accessor->remove;
        }
    }
}

sub table {
    my $self = shift;

    my $ret = $self->next::method(@_);
    if ( @_ && $self->result_source_instance->resultset_class
               eq 'DBIx::Class::ResultSet' ) {
        $self->result_source_instance
             ->resultset_class('DBIx::Class::InflateColumn::FS::ResultSet');
    }
    return $ret;
}

1;