The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl
use warnings;
use strict;
use DBICx::TestDatabase;
use Test::More tests => 19;
use Path::Class qw/file/;
use File::Compare;
use lib qw(t/lib);

my $schema = DBICx::TestDatabase->new('My::TestSchema');
my $rs = $schema->resultset('Book');

# we'll use *this* file as our content
# TODO: Copy it or create something else so errant tests don't inadvertently
# delete it!
my $file = file($0);

my $book = $rs->create({
    name => 'Alice in Wonderland',
    cover_image => $file,
});

isa_ok( $book->cover_image, 'Path::Class::File' );
isnt( $book->cover_image, $file, 'storage is a different file' );
ok( compare($book->cover_image, $file) == 0, 'file contents equivalent');

# setting a file to itself should be a no-op
my $storage = Path::Class::File->new($book->cover_image);
$book->update({ cover_image => $storage });

is( $storage, $book->cover_image, 'setting storage to self' );

# deleting the row should delete the associated file
$book->delete;
ok( ! -e $storage, 'file successfully deleted' );

# multiple rows
my ($book1, $book2) = map {
    $rs->create({ name => $_, cover_image => $file })
} qw/Book1 Book2/;

isnt( $book1->cover_image, $book2->cover_image, 'rows have different storage' );

$rs->delete;
ok ( ! -e $book1->cover_image, "storage deleted for row 1" );
ok ( ! -e $book2->cover_image, "storage deleted for row 2" );


# null fs_column
$book = $rs->create({ name => 'No cover image', cover_image => undef });

ok ( !defined $book->cover_image, 'null fs_column' );


# file handle
open my $fh, '<', $0 or die "failed to open $0 for read: $!\n";

$book->cover_image($fh);
$book->update;
close $fh or die;

ok( compare($book->cover_image, $0) == 0, 'store from filehandle' );

# setting fs_column to null should delete storage
$book = $rs->create({ name => 'Here today, gone tomorrow',
        cover_image => $file });
$storage = $book->cover_image;
ok( -e $storage, 'storage exists before nulling' );
$book->update({ cover_image => undef });
ok( ! -e $storage, 'does not exist after nulling' );

$book->update({ cover_image => $file });
$book->update({ id => 999 });
$book->discard_changes;
ok( -e $book->cover_image, 'storage renamed on PK change' );

#--------------------------------- test copy ---------------------------------
my $orig_column_data = { %{$book->{_column_data}} };
my $copy = $book->copy;
isnt( $copy->cover_image, $book->cover_image, 'copy has its own file backing' );
ok( compare($copy->cover_image, $book->cover_image) == 0, 'copy contents correct' );

# an update of book shouldn't change the source's _column_data
is_deeply ( $book->{_column_data}, $orig_column_data, 'copy source unchanged' );

# Regression test (failed on a prior implementation of copy)
$book = $rs->find({ id => 1, });
ok( eval{ $copy = $book->copy }, 'copy works with selected elements' );

#----------------------------- infinite recursion ----------------------------
$book = $rs->create({
    name          => 'The Never Ending Story',
    cover_image   => $file,
    cover_image_2 => $file,
});

my $cover_image = $book->cover_image->stringify;
my $cover_image_2 = $book->cover_image->stringify;
$book->update({ cover_image => $file, cover_image_2 => $file });
is( $book->cover_image, $cover_image, 'backing filename did not change' );
isnt( $book->cover_image_2, $cover_image_2, 'backing filename did change for fs_new_on_update column' );