#!/usr/bin/env perl
use strict;
use warnings;
use File::Basename;
use lib File::Basename::dirname(__FILE__)."/../../../../lib";
use lib File::Basename::dirname(__FILE__)."/../../..";
use URT;
use Test::More tests => 32;
use IO::File;
use File::Temp;
# The file tracking stuff is defined at the bottom of this file
my ($file_new, $file_open, $file_close, $file_DESTROY, $file_seek, $file_seek_pos, $file_tell, $file_getline);
IO::File::Tracker->config_callbacks(
'new' => sub { no warnings 'uninitialized'; $file_new++ },
'open' => sub { no warnings 'uninitialized'; $file_open++ },
'close' => sub { no warnings 'uninitialized'; $file_close++ },
'DESTROY' => sub { no warnings 'uninitialized'; $file_DESTROY++ },
'seek' => sub { no warnings 'uninitialized'; $file_seek_pos = $_[0]; $file_seek++ },
'tell' => sub { no warnings 'uninitialized'; $file_tell++ },
'getline' => sub { no warnings 'uninitialized'; $file_getline++ },
);
sub clear_trackers {
$file_new = 0;
$file_open = 0;
$file_close = 0;
$file_DESTROY = 0;
$file_seek = 0;
$file_seek_pos = undef;
$file_tell = 0;
$file_getline = 0;
};
# File data: id name is_upper
my @data = (
[1, 'AAA', 1],
[2, 'BBB', 1],
[3, 'CCC', 1],
[4, 'DDD', 1],
[5, 'EEE', 1],
[6, 'fff', 0],
[7, 'ggg', 0],
[8, 'hhh', 0],
[9, 'iii', 0],
);
my $datafile = File::Temp->new();
ok($datafile, 'Created temp file for data');
my $data_source = UR::DataSource::Filesystem->create(
path => $datafile->filename,
delimiter => "\t",
record_separator => "\n",
handle_class => 'IO::File::Tracker',
columns => ['letter_id','name','is_upper'],
);
ok($data_source, 'Create filesystem data source');
ok(UR::Object::Type->define(
class_name => 'URT::Letter',
id_by => [
letter_id => { is => 'Number' }
],
has => [
name => { is => 'String' },
is_upper => { is => 'Boolean' },
],
data_source_id => $data_source->id,
),
'Defined class for letters');
my @file_columns_in_order = ('id','name','is_upper');
my %sorters;
foreach my $cols ( [letter_id => 0], [name => 1], [is_upper => 2] ) {
my($key,$col) = @$cols;
$sorters{$key} = sub { no warnings 'numeric'; $a->[$col] <=> $b->[$col] or $a->[$col] cmp $b->[$col] };
}
foreach my $cols ( [letter_id => 0], [name => 1], [is_upper => 2] ) {
my($key,$col) = @$cols;
$sorters{'-'.$key} = sub { no warnings 'numeric'; $b->[$col] <=> $a->[$col] or $b->[$col] cmp $a->[$col] };
}
my($write_sorter, @write_data, @matches, @results, @expected, $sorter_sub);
# First, write out the file in id-sorted order.
# Don't tell the data source about any particular sorting.
&clear_trackers();
$sorter_sub = $sorters{'letter_id'};
@write_data = sort $sorter_sub @data;
ok(save_data_to_file($datafile, \@write_data), 'Save file in id-sorted order');
@matches = URT::Letter->get(1);
@results = map { [ @$_{@file_columns_in_order} ] } @matches;
is(scalar(@results), 1, 'Got one result matching id 1');
is_deeply($results[0],
[ 1, 'AAA', 1],
'Got the right data back');
is($file_new, 1, 'One new filehandle was created');
is($file_getline, 10, 'getline() was called 10 times'); # One additional at the end of the file
is($file_DESTROY, 1, 'DESTROY was called one time');
ok($data_source->sorted_columns(['letter_id']), 'Configure the data source to be sorted by letter_id');
URT::Letter->unload();
&clear_trackers();
@matches = URT::Letter->get(1);
@results = map { [ @$_{@file_columns_in_order} ] } @matches;
is(scalar(@results), 1, 'Got one result matching id 1');
is_deeply($results[0],
[ 1, 'AAA', 1],
'Got the right data back');
is($file_new, 1, 'One new filehandle was created');
is($file_getline, 2, 'getline() was called 2 times'); # had to read the 2nd line to know there were no more matches
is($file_DESTROY, 1, 'DESTROY was called one time');
URT::Letter->unload();
&clear_trackers();
@matches = URT::Letter->get('id <' => 5);
@results = map { [ @$_{@file_columns_in_order} ] } @matches;
is(scalar(@results), 4, 'Got 4 results with id < 5');
is_deeply(\@results,
[ [ 1, 'AAA', 1],
[ 2, 'BBB', 1],
[ 3, 'CCC', 1],
[ 4, 'DDD', 1] ],
'Got the right data back');
is($file_new, 1, 'One new filehandle was created');
is($file_getline, 5, 'getline() was called 5 times');
is($file_DESTROY, 1, 'DESTROY was called one time');
ok($data_source->sorted_columns(['-is_upper']), 'Configure the data source to be sorted by -is_upper');
URT::Letter->unload();
&clear_trackers();
@matches = URT::Letter->get('is_upper >' => 0);
@results = map { [ @$_{@file_columns_in_order} ] } @matches;
is(scalar(@results), 5, 'Got 5 results matching is_upper > 0');
is_deeply(\@results,
[ [ 1, 'AAA', 1],
[ 2, 'BBB', 1],
[ 3, 'CCC', 1],
[ 4, 'DDD', 1],
[ 5, 'EEE', 1] ],
'Got the right data back');
is($file_new, 1, 'One new filehandle was created');
is($file_getline, 6, 'getline() was called 6 times');
is($file_DESTROY, 1, 'DESTROY was called one time');
ok($data_source->sorted_columns(['name','-is_upper']),
'Configure the data source to be sorted by name and -is_upper');
URT::Letter->unload();
&clear_trackers();
@matches = URT::Letter->get('name between' => ['BBB','DDD']);
@results = map { [ @$_{@file_columns_in_order} ] } @matches;
is(scalar(@results), 3, 'Got 3 results matching name between BBB and DDD');
is_deeply(\@results,
[ [ 2, 'BBB', 1],
[ 3, 'CCC', 1],
[ 4, 'DDD', 1] ],
'Got the right data back');
is($file_new, 1, 'One new filehandle was created');
is($file_getline, 5, 'getline() was called 5 times');
is($file_DESTROY, 1, 'DESTROY was called one time');
sub save_data_to_file {
my($fh, $datalist) = @_;
$fh->seek(0,0);
$fh->print(map { $_ . "\n" }
map { join("\t", @$_) }
@$datalist);
truncate($fh, $fh->tell());
$fh->flush();
return 1;
}
package IO::File::Tracker;
our %callbacks;
sub config_callbacks {
my $class = shift;
my %set_callbacks = @_;
foreach my $key ( keys %set_callbacks) {
$callbacks{$key} = $set_callbacks{$key};
}
}
sub _call_cb {
my($op, @args) = @_;
my $cb = $callbacks{$op};
if ($cb) {
$cb->(@args);
}
}
use vars '$AUTOLOAD';
sub AUTOLOAD {
my $subname = $AUTOLOAD;
$subname =~ s/^.*:://;
my $super = IO::File->can($subname) || IO::Handle->can($subname);
if ($super) {
$super->(@_);
} else {
Carp::croak("Can't wrap method $subname because it is not implemented by IO::File");
}
}
BEGIN {
# Create overridden methods for the ones we want to track
no strict 'refs';
foreach my $subname (qw( new open close DESTROY seek tell getline ) ) {
my $subref = sub {
my $self = shift;
_call_cb($subname, @_);
my $super = IO::File->can($subname);
return $super->($self, @_);
};
my $fq_subname = 'IO::File::Tracker::'.$subname;
*$fq_subname = $subref;
}
}