File Coverage

blib/lib/Beam/Make/DBI/Schema.pm
Criterion Covered Total %
statement 55 62 88.7
branch 1 4 25.0
condition n/a
subroutine 10 10 100.0
pod 2 2 100.0
total 68 78 87.1


line stmt bran cond sub pod time code
1             package Beam::Make::DBI::Schema;
2             our $VERSION = '0.002';
3             # ABSTRACT: A Beam::Make recipe to build database schemas
4              
5             #pod =head1 SYNOPSIS
6             #pod
7             #pod ### container.yml
8             #pod # A Beam::Wire container to configure a database connection to use
9             #pod sqlite:
10             #pod $class: DBI
11             #pod $method: connect
12             #pod $args:
13             #pod - dbi:SQLite:conversion.db
14             #pod
15             #pod ### Beamfile
16             #pod conversion.db:
17             #pod $class: Beam::Wire::DBI::Schema
18             #pod dbh: { $ref: 'container.yml:sqlite' }
19             #pod schema:
20             #pod - table: accounts
21             #pod columns:
22             #pod - account_id: VARCHAR(255) NOT NULL PRIMARY KEY
23             #pod - address: TEXT NOT NULL
24             #pod
25             #pod =head1 DESCRIPTION
26             #pod
27             #pod This L<Beam::Make> recipe class builds a database schema.
28             #pod
29             #pod =head1 SEE ALSO
30             #pod
31             #pod L<Beam::Make>, L<Beam::Wire>, L<DBI>
32             #pod
33             #pod =cut
34              
35 1     1   14 use v5.20;
  1         4  
36 1     1   6 use warnings;
  1         2  
  1         37  
37 1     1   9 use Moo;
  1         2  
  1         6  
38 1     1   408 use Time::Piece;
  1         2  
  1         6  
39 1     1   84 use List::Util qw( pairs );
  1         2  
  1         59  
40 1     1   6 use Digest::SHA qw( sha1_base64 );
  1         2  
  1         54  
41 1     1   12 use experimental qw( signatures postderef );
  1         2  
  1         5  
42              
43             extends 'Beam::Make::Recipe';
44              
45             #pod =attr dbh
46             #pod
47             #pod Required. The L<DBI> database handle to use. Can be a reference to a service
48             #pod in a L<Beam::Wire> container using C<< { $ref: "<container>:<service>" } >>.
49             #pod
50             #pod =cut
51              
52             has dbh => ( is => 'ro', required => 1 );
53              
54             #pod =attr schema
55             #pod
56             #pod A list of tables to create. Each table is a mapping with the following keys:
57             #pod
58             #pod =over
59             #pod
60             #pod =item table
61             #pod
62             #pod The name of the table to create.
63             #pod
64             #pod =item columns
65             #pod
66             #pod A list of key/value pairs of columns. The key is the column name, the value
67             #pod is the SQL to use for the column definition.
68             #pod
69             #pod =back
70             #pod
71             #pod =cut
72              
73             has schema => ( is => 'ro', required => 1 );
74              
75 1     1 1 3 sub make( $self, %vars ) {
  1         2  
  1         2  
  1         2  
76 1         4 my $dbh = $self->dbh;
77              
78             # Now, prepare the changes to be made
79 1         2 my @changes;
80 1         5 for my $table_schema ( $self->schema->@* ) {
81 2         36 my $table = $table_schema->{table};
82 2         6 my @columns = $table_schema->{columns}->@*;
83 2         11 my $table_info = $dbh->table_info( '', '%', qq{$table} )->fetchrow_arrayref;
84 2 50       809 if ( !$table_info ) {
85             push @changes, sprintf 'CREATE TABLE %s ( %s )', $dbh->quote_identifier( $table ),
86 5         100 join ', ', map { join ' ', $dbh->quote_identifier( $_->key ), $_->value }
87 2         18 map { pairs %$_ } @columns;
  5         1824  
88             }
89             else {
90 0         0 my $column_info = $dbh->column_info( '', '%', $table, '%' )->fetchall_hashref( 'COLUMN_NAME' );
91             # Compare columns and add if needed
92 0         0 for my $pair ( map { pairs %$_ } @columns ) {
  0         0  
93 0         0 my $column_name = $pair->key;
94 0         0 my $column_type = $pair->value;
95 0 0       0 if ( !$column_info->{ $column_name } ) {
96 0         0 push @changes, sprintf 'ALTER TABLE %s ADD COLUMN %s %s',
97             $table, $column_name, $column_type;
98             }
99             }
100             }
101             }
102              
103             # Now execute the changes
104 1         32 for my $change ( @changes ) {
105 2         11352 $dbh->do( $change );
106             }
107              
108 1         10384 $self->cache->set( $self->name, $self->_cache_hash );
109 1         6 return 0;
110             }
111              
112 10     10   16 sub _cache_hash( $self ) {
  10         18  
  10         14  
113 10         26 my $dbh = $self->dbh;
114 10         15 my %tables;
115 10         117 for my $table_info ( $dbh->table_info( '', '%', '%' )->fetchall_arrayref( {} )->@* ) {
116 47         6359 my $table_name = $table_info->{TABLE_NAME};
117 47         227 for my $column_info ( $dbh->column_info( '', '%', $table_name, '%' )->fetchall_arrayref( {} )->@* ) {
118 163         54323 my $column_name = $column_info->{COLUMN_NAME};
119 163         1864 push $tables{ $table_name }->@*, $column_name;
120             }
121             }
122             my $content = join ';',
123 10         239 map { sprintf '%s=%s', $_, join ',', sort $tables{ $_ }->@* } sort keys %tables;
  47         232  
124 10         154 return sha1_base64( $content );
125             }
126              
127 9     9 1 15 sub last_modified( $self ) {
  9         15  
  9         15  
128 9         43 return $self->cache->last_modified( $self->name, $self->_cache_hash );
129             }
130              
131             1;
132              
133             __END__
134              
135             =pod
136              
137             =head1 NAME
138              
139             Beam::Make::DBI::Schema - A Beam::Make recipe to build database schemas
140              
141             =head1 VERSION
142              
143             version 0.002
144              
145             =head1 SYNOPSIS
146              
147             ### container.yml
148             # A Beam::Wire container to configure a database connection to use
149             sqlite:
150             $class: DBI
151             $method: connect
152             $args:
153             - dbi:SQLite:conversion.db
154              
155             ### Beamfile
156             conversion.db:
157             $class: Beam::Wire::DBI::Schema
158             dbh: { $ref: 'container.yml:sqlite' }
159             schema:
160             - table: accounts
161             columns:
162             - account_id: VARCHAR(255) NOT NULL PRIMARY KEY
163             - address: TEXT NOT NULL
164              
165             =head1 DESCRIPTION
166              
167             This L<Beam::Make> recipe class builds a database schema.
168              
169             =head1 ATTRIBUTES
170              
171             =head2 dbh
172              
173             Required. The L<DBI> database handle to use. Can be a reference to a service
174             in a L<Beam::Wire> container using C<< { $ref: "<container>:<service>" } >>.
175              
176             =head2 schema
177              
178             A list of tables to create. Each table is a mapping with the following keys:
179              
180             =over
181              
182             =item table
183              
184             The name of the table to create.
185              
186             =item columns
187              
188             A list of key/value pairs of columns. The key is the column name, the value
189             is the SQL to use for the column definition.
190              
191             =back
192              
193             =head1 SEE ALSO
194              
195             L<Beam::Make>, L<Beam::Wire>, L<DBI>
196              
197             =head1 AUTHOR
198              
199             Doug Bell <preaction@cpan.org>
200              
201             =head1 COPYRIGHT AND LICENSE
202              
203             This software is copyright (c) 2020 by Doug Bell.
204              
205             This is free software; you can redistribute it and/or modify it under
206             the same terms as the Perl 5 programming language system itself.
207              
208             =cut