File Coverage

blib/lib/Test/SQLite.pm
Criterion Covered Total %
statement 41 41 100.0
branch 20 24 83.3
condition 15 15 100.0
subroutine 10 10 100.0
pod 1 1 100.0
total 87 91 95.6


line stmt bran cond sub pod time code
1             package Test::SQLite;
2             our $AUTHORITY = 'cpan:GENE';
3              
4             # ABSTRACT: SQLite setup/teardown for tests
5              
6             our $VERSION = '0.0407';
7              
8 1     1   800 use DBI;
  1         2  
  1         46  
9 1     1   537 use File::Copy;
  1         2386  
  1         54  
10 1     1   792 use File::Temp ();
  1         18319  
  1         33  
11              
12 1     1   538 use Moo;
  1         11641  
  1         7  
13 1     1   2343 use strictures 2;
  1         1630  
  1         42  
14 1     1   736 use namespace::clean;
  1         11706  
  1         6  
15              
16              
17             has database => (
18             is => 'ro',
19             isa => sub { die 'database does not exist' unless -e $_[0] },
20             predicate => 'has_database',
21             );
22              
23              
24             has schema => (
25             is => 'ro',
26             isa => sub { die 'schema does not exist' unless -e $_[0] },
27             predicate => 'has_schema',
28             );
29              
30              
31             has memory => (
32             is => 'ro',
33             predicate => 'has_memory',
34             );
35              
36              
37             has db_attrs => (
38             is => 'ro',
39             default => sub { return { RaiseError => 1, AutoCommit => 1 } },
40             );
41              
42              
43             has dsn => (
44             is => 'lazy',
45             init_arg => undef,
46             );
47              
48             sub _build_dsn {
49 4     4   38 my ($self) = @_;
50 4 100       77 return 'dbi:SQLite:dbname=' . ( $self->has_memory ? $self->_database : $self->_database->filename );
51             }
52              
53              
54             has dbh => (
55             is => 'lazy',
56             init_arg => undef,
57             );
58              
59             sub _build_dbh {
60 4     4   781 my ($self) = @_;
61 4         67 return DBI->connect( $self->dsn, '', '', $self->db_attrs );
62             }
63              
64             has _database => (
65             is => 'lazy',
66             init_arg => undef,
67             );
68              
69             sub _build__database {
70 4     4   86 my ($self) = @_;
71              
72 4 100       39 my $tempfile = $self->has_memory
73             ? ':memory:'
74             : File::Temp->new( unlink => 1, suffix => '.db', EXLOCK => 0 );
75              
76 4 100       1827 if ( $self->has_database ) {
    100          
77 1 50       6 copy( $self->database, $tempfile->filename )
78             or die "Can't copy " . $self->database . ": $!";
79             }
80             elsif ( $self->has_schema ) {
81 1 50       43 open my $schema, '<', $self->schema
82             or die "Can't read " . $self->schema . ": $!";
83              
84 1 50       10 my $dbh = DBI->connect( "dbi:SQLite:dbname=$tempfile", '', '', { RaiseError => 1, AutoCommit => 0 } )
85             or die "Can't connect to $tempfile: " . $DBI::errstr;
86              
87 1         384 my $sql = '';
88 1         22 while ( my $line = readline($schema) ) {
89 18 100       50 next if $line =~ /^\s*--/;
90 17 100       46 next if $line =~ /^\s*$/;
91              
92 14         29 $sql .= $line;
93              
94 14 100       37 if ( $line =~ /;/ ) {
95 3 50       20 $dbh->do($sql)
96             or die 'Error executing SQL for ' . $self->schema . ': ' . $dbh->errstr;
97              
98 3         957 $sql = '';
99             }
100             }
101              
102 1         11373 $dbh->commit;
103              
104 1         141 $dbh->disconnect;
105             }
106              
107 4         496 return $tempfile;
108             }
109              
110              
111             sub BUILD {
112 7     7 1 62 my ( $self, $args ) = @_;
113 7 100 100     148 die 'The schema, database and memory arguments may not be used together.'
      100        
      100        
      100        
      100        
114             if ( $self->has_database and $self->has_schema )
115             or ( $self->has_database and $self->has_memory )
116             or ( $self->has_schema and $self->has_memory );
117             }
118              
119             1;
120              
121             __END__