File Coverage

blib/lib/Yancy/Backend/Role/DBI.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package Yancy::Backend::Role::DBI;
2             our $VERSION = '1.088';
3             # ABSTRACT: Role for backends that use DBI
4              
5             #pod =head1 SYNOPSIS
6             #pod
7             #pod package Yancy::Backend::RDBMS;
8             #pod use Role::Tiny 'with';
9             #pod with 'Yancy::Backend::Role::DBI';
10             #pod # Return a database handle
11             #pod sub dbh { ... }
12             #pod
13             #pod =head1 DESCRIPTION
14             #pod
15             #pod This is a role that adds the below methods based on a C method
16             #pod that returns a L object and a C method that calls
17             #pod L with the correct arguments for the current database.
18             #pod
19             #pod =head1 SEE ALSO
20             #pod
21             #pod L
22             #pod
23             #pod =cut
24              
25 1     1   1877 use Mojo::Base '-role';
  1         3  
  1         14  
26 1     1   594 use List::Util qw( any );
  1         2  
  1         90  
27 1     1   616 use DBI ':sql_types';
  0            
  0            
28             use Mojo::JSON qw( true );
29              
30             requires 'dbh', 'table_info';
31              
32             # only specify non-string - code-ref called with column_info row
33             my $maybe_boolean = sub {
34             # how mysql does BOOLEAN - not a TINYINT, but INTEGER
35             my ( $c ) = @_;
36             ( ( $c->{mysql_type_name} // '' ) eq 'tinyint(1)' )
37             ? { type => 'boolean' }
38             : { type => 'integer' };
39             };
40             my %SQL2OAPITYPE = (
41             SQL_BIGINT() => { type => 'integer' },
42             SQL_BIT() => { type => 'boolean' },
43             SQL_TINYINT() => $maybe_boolean,
44             SQL_NUMERIC() => { type => 'number' },
45             SQL_DECIMAL() => { type => 'number' },
46             SQL_INTEGER() => $maybe_boolean,
47             SQL_SMALLINT() => { type => 'integer' },
48             SQL_FLOAT() => { type => 'number' },
49             SQL_REAL() => { type => 'number' },
50             SQL_DOUBLE() => { type => 'number' },
51             SQL_DATETIME() => { type => 'string', format => 'date-time' },
52             SQL_DATE() => { type => 'string', format => 'date' },
53             SQL_TIME() => { type => 'string', format => 'date-time' },
54             SQL_TIMESTAMP() => { type => 'string', format => 'date-time' },
55             SQL_BOOLEAN() => { type => 'boolean' },
56             SQL_TYPE_DATE() => { type => 'string', format => 'date' },
57             SQL_TYPE_TIME() => { type => 'string', format => 'date-time' },
58             SQL_TYPE_TIMESTAMP() => { type => 'string', format => 'date-time' },
59             SQL_TYPE_TIME_WITH_TIMEZONE() => { type => 'string', format => 'date-time' },
60             SQL_TYPE_TIMESTAMP_WITH_TIMEZONE() => { type => 'string', format => 'date-time' },
61             SQL_LONGVARBINARY() => { type => 'string', format => 'binary' },
62             SQL_VARBINARY() => { type => 'string', format => 'binary' },
63             SQL_BINARY() => { type => 'string', format => 'binary' },
64             SQL_BLOB() => { type => 'string', format => 'binary' },
65             SQL_VARCHAR() => sub {
66             my ( $c ) = @_;
67             # MySQL uses this type for BLOBs, too...
68             return { type => 'string', format => 'binary' }
69             if ( $c->{mysql_type_name} // '' ) =~ /blob/i;
70             return { type => 'string' };
71             },
72             );
73             # SQLite fallback
74             my %SQL2TYPENAME = (
75             SQL_BOOLEAN() => [ qw(boolean) ],
76             SQL_INTEGER() => [ qw(int integer smallint bigint tinyint rowid) ],
77             SQL_REAL() => [ qw(double float money numeric real) ],
78             SQL_TYPE_TIMESTAMP() => [ qw(timestamp datetime) ],
79             SQL_BLOB() => [ qw(blob longblob mediumblob tinyblob) ],
80             );
81             my %TYPENAME2SQL = map {
82             my $sql = $_;
83             map { $_ => $sql } @{ $SQL2TYPENAME{ $sql } };
84             } keys %SQL2TYPENAME;
85              
86             my %IGNORE_TABLE = (
87             mojo_migrations => 1,
88             minion_jobs => 1,
89             minion_workers => 1,
90             minion_locks => 1,
91             mojo_pubsub_listener => 1,
92             mojo_pubsub_listen => 1,
93             mojo_pubsub_notify => 1,
94             mojo_pubsub_queue => 1,
95             dbix_class_schema_versions => 1,
96             );
97              
98             sub fixup_default {
99             }
100              
101             sub column_info {
102             my ( $self, $table ) = @_;
103             return $self->dbh->column_info( @{$table}{qw( TABLE_CAT TABLE_SCHEM TABLE_NAME )}, '%' )->fetchall_arrayref({});
104             }
105              
106             sub read_schema {
107             my ( $self, @table_names ) = @_;
108             my %schema;
109             my $dbh = $self->dbh;
110             my @tables = @{ $self->table_info };
111             $_->{TABLE_NAME} =~ s/\W//g for @tables;
112             my %tables = map { $_->{TABLE_NAME} => $_ } @tables;
113             my $given_tables = !!@table_names;
114             @table_names = keys %tables if !@table_names;
115              
116             for my $table_name ( @table_names ) {
117             my $table = $tables{ $table_name };
118             my @table_id = @{$table}{qw( TABLE_CAT TABLE_SCHEM TABLE_NAME )};
119             # ; say "Got table $table_name";
120             $schema{ $table_name }{type} = 'object';
121             my $stats_info = $dbh->statistics_info( @table_id, 1, 1 )->fetchall_arrayref( {} );
122             my $columns = $self->column_info( $table );
123             my %is_pk = map {$_=>1} $dbh->primary_key( @table_id );
124             # ; use Data::Dumper;
125             # ; say Dumper $stats_info;
126             # ; say Dumper \%is_pk;
127             my @unique_columns = grep !$is_pk{ $_ },
128             map $_->{COLUMN_NAME},
129             grep !$_->{NON_UNIQUE}, # mysql
130             @$stats_info;
131             # ; say "Got columns";
132             # ; use Data::Dumper;
133             # ; say Dumper $columns;
134             for my $c ( @$columns ) {
135             # COLUMN_NAME DATA_TYPE TYPE_NAME IS_NULLABLE AUTO_INCREMENT
136             # COLUMN_DEF ORDINAL_POSITION ENUM
137             my $column = $c->{COLUMN_NAME} =~ s/['"`]//gr;
138             # the || is because SQLite doesn't give the DATA_TYPE
139             my $sqltype = $c->{DATA_TYPE} || $TYPENAME2SQL{ lc $c->{TYPE_NAME} };
140             my $typeref = $SQL2OAPITYPE{ $sqltype || '' } || { type => 'string' };
141             $typeref = $typeref->( $c ) if ref $typeref eq 'CODE';
142             my %oapitype = %$typeref;
143             if ( !$is_pk{ $column } && $c->{NULLABLE} ) {
144             $oapitype{ type } = [ $oapitype{ type }, 'null' ];
145             }
146             my $auto_increment = $c->{AUTO_INCREMENT};
147             my $default = $c->{COLUMN_DEF};
148             if ( defined $default ) {
149             $oapitype{ default } = $default;
150             }
151             $oapitype{readOnly} = true if $auto_increment;
152             $schema{ $table_name }{ properties }{ $column } = {
153             %oapitype,
154             'x-order' => $c->{ORDINAL_POSITION},
155             ( enum => $c->{ENUM} )x!!$c->{ENUM},
156             };
157             if ( ( $c->{IS_NULLABLE} eq 'NO' || $is_pk{ $column } ) && !$auto_increment && !defined $default ) {
158             push @{ $schema{ $table_name }{ required } }, $column;
159             }
160             }
161             # ; say "Got PKs for table $table_name: " . join ', ', keys %is_pk;
162             # ; say "Got uniques for table $table_name: " . join ', ', @unique_columns;
163             my ( $pk ) = keys %is_pk;
164             if ( @unique_columns == 1 and $unique_columns[0] ne 'id' ) {
165             # favour "natural" key over "surrogate" integer one, if exists
166             $schema{ $table_name }{ 'x-id-field' } = $unique_columns[0];
167             }
168             elsif ( $pk && $pk ne 'id' ) {
169             $schema{ $table_name }{ 'x-id-field' } = $pk;
170             }
171             if ( $IGNORE_TABLE{ $table_name } ) {
172             $schema{ $table_name }{ 'x-ignore' } = 1;
173             }
174             }
175              
176             # Foreign keys
177             for my $table_name ( @table_names ) {
178             my $table = $tables{ $table_name };
179             my @table_id = @{$table}{qw( TABLE_CAT TABLE_SCHEM TABLE_NAME )};
180             my @foreign_keys;
181             if ( my $sth = $dbh->foreign_key_info( (undef)x3, @table_id ) ) {
182             @foreign_keys = @{ $sth->fetchall_arrayref( {} ) };
183             }
184              
185             for my $fk ( @foreign_keys ) {
186             next unless $fk->{PKTABLE_NAME} || $fk->{UK_TABLE_NAME}; # ??? MySQL adds these?
187             # ; use Data::Dumper;
188             # ; say Dumper $fk;
189             s/\W//g for grep defined, values %$fk; # PostgreSQL quotes "user"
190             my $foreign_table = $fk->{PKTABLE_NAME} || $fk->{UK_TABLE_NAME};
191             my $foreign_column = $fk->{PKCOLUMN_NAME} || $fk->{UK_COLUMN_NAME};
192             next unless $schema{ $foreign_table }; # XXX Can't resolve a foreign key we can't find
193             my $foreign_id = $schema{ $foreign_table }{ 'x-id-field' } // 'id';
194             my $column = $fk->{FKCOLUMN_NAME} || $fk->{UK_COLUMN_NAME};
195             # XXX: We cannot do relationships with multiple keys yet
196             $schema{ $table_name }{ properties }{ $column }{ 'x-foreign-key' } = join '.', $foreign_table, $foreign_id;
197             }
198             }
199              
200             return $given_tables ? @schema{ @table_names } : \%schema;
201             }
202              
203             1;
204              
205             __END__