File Coverage

blib/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/ScriptHelpers.pm
Criterion Covered Total %
statement 51 55 92.7
branch 7 12 58.3
condition 5 15 33.3
subroutine 13 14 92.8
pod 2 2 100.0
total 78 98 79.5


line stmt bran cond sub pod time code
1             package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers;
2             $DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers::VERSION = '0.002233';
3             # ABSTRACT: CodeRef Transforms for common use-cases in DBICDH Migrations
4              
5 1     1   79635 use strict;
  1         10  
  1         25  
6 1     1   4 use warnings;
  1         3  
  1         33  
7              
8 1         7 use Sub::Exporter::Progressive -setup => {
9             exports => [qw(dbh schema_from_schema_loader)],
10 1     1   407 };
  1         848  
11              
12 1     1   100 use List::Util 'first';
  1         2  
  1         56  
13 1     1   404 use Text::Brew 'distance';
  1         1158  
  1         54  
14 1     1   435 use Try::Tiny;
  1         1641  
  1         48  
15 1     1   362 use DBIx::Class::DeploymentHandler::LogImporter qw(:dlog);
  1         3  
  1         14  
16              
17             sub dbh {
18 2     2 1 24153 my ($code) = @_;
19             sub {
20 2     2   5 my ($schema, $versions) = @_;
21             $schema->storage->dbh_do(sub {
22 2         423 $code->($_[1], $versions)
23             })
24 2         48 }
25 2         22 }
26              
27             sub _rearrange_connect_info {
28 6     6   91 my ($storage) = @_;
29              
30 6         31 my $nci = $storage->_normalize_connect_info($storage->connect_info);
31              
32             return {
33 11     11   199184 dbh_maker => sub { $storage->dbh },
34 6         352 map %{$nci->{$_}}, grep { $_ ne 'arguments' } keys %$nci,
  6         45  
  12         35  
35             };
36             }
37              
38             my $count = 0;
39             sub schema_from_schema_loader {
40 6     6 1 88038 my ($opts, $code) = @_;
41              
42 6 50 33     75 die 'schema_from_schema_loader requires options!'
      33        
43             unless $opts && ref $opts && ref $opts eq 'HASH';
44              
45             die 'schema_from_schema_loader requires naming settings to be set!'
46 6 50       31 unless $opts->{naming};
47              
48             warn 'using "current" naming in a deployment script is begging for problems. Just Say No.'
49             if $opts->{naming} eq 'current' ||
50 6 50 33 0   42 (ref $opts->{naming} eq 'HASH' && first { $_ eq 'current' } values %{$opts->{naming}});
  0   33     0  
  0         0  
51              
52             $opts->{debug} = 1
53 6 50 33     40 if !exists $opts->{debug} && $ENV{DBICDH_TRACE};
54              
55             sub {
56 6     6   16 my ($schema, $versions) = @_;
57              
58 6         46 require DBIx::Class::Schema::Loader;
59              
60 6         138 $schema->storage->ensure_connected;
61 6         1218 my @ci = _rearrange_connect_info($schema->storage);
62              
63 6         48 my $new_schema = DBIx::Class::Schema::Loader::make_schema_at(
64             'SHSchema::' . $count++, $opts, \@ci
65             );
66              
67             Dlog_debug {
68 0         0 "schema_from_schema_loader generated the following sources: $_"
69 6         12281 } [ $new_schema->sources ];
70 6         272 my $sl_schema = $new_schema->connect(@ci);
71             try {
72 6         285 $code->($sl_schema, $versions)
73             } catch {
74 1 50       687 if (m/Can't find source for (.+?) at/) {
75             my @presentsources = map {
76 1 100       12 (distance($_, $1))[0] < 3 ? "$_ <== Possible Match\n" : "$_\n";
  2         310  
77             } $sl_schema->sources;
78              
79 1         2293 die <<"ERR";
80             $_
81             You are seeing this error because the DBIx::Class::ResultSource in your
82             migration script called "$1" is not part of the schema that ::Schema::Loader
83             has inferred from your existing database.
84              
85             To help you debug this issue, here's a list of the actual sources that the
86             schema available to your migration knows about:
87              
88             @presentsources
89             ERR
90             }
91 0           die $_;
92             }
93 6         12673 }
94 6         45 }
95              
96             1;
97              
98             __END__
99              
100             =pod
101              
102             =head1 NAME
103              
104             DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers - CodeRef Transforms for common use-cases in DBICDH Migrations
105              
106             =head1 SYNOPSIS
107              
108             use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers
109             'schema_from_schema_loader';
110              
111             schema_from_schema_loader({ naming => 'v4' }, sub {
112             my ($schema, $version_set) = @_;
113              
114             ...
115             });
116              
117             =head1 DESCRIPTION
118              
119             This package is a set of coderef transforms for common use-cases in migrations.
120             The subroutines are simply helpers for creating coderefs that will work for
121             L<DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator/PERL SCRIPTS>,
122             yet have some argument other than the current schema that you as a user might
123             prefer.
124              
125             =head1 EXPORTED SUBROUTINES
126              
127             =head2 dbh($coderef)
128              
129             dbh(sub {
130             my ($dbh, $version_set) = @_;
131              
132             ...
133             });
134              
135             For those times when you almost exclusively need access to "the bare metal".
136             Simply gives you the correct database handle and the expected version set.
137              
138             =head2 schema_from_schema_loader($sl_opts, $coderef)
139              
140             schema_from_schema_loader({ naming => 'v4' }, sub {
141             my ($schema, $version_set) = @_;
142              
143             ...
144             });
145              
146             Any time you write a perl migration script that uses a L<DBIx::Class::Schema>
147             you should probably use this. Otherwise you'll run into problems if you remove
148             a column from your schema yet still populate to it in an older population
149             script.
150              
151             Note that C<$sl_opts> requires that you specify something for the C<naming>
152             option.
153              
154             =head1 CUSTOM SCRIPT HELPERS
155              
156             If you find that in your scripts you need to always pass the same arguments to
157             your script helpers, you may want to define a custom set of script helpers. I
158             am not sure that there is a better way than just using Perl and other modules
159             that are already installed when you install L<DBIx::Class::DeploymentHandler>.
160              
161             The following is a pattern that will get you started; if anyone has ideas on
162             how to make this even easier let me know.
163              
164             package MyApp::DBICDH::ScriptHelpers;
165              
166             use strict;
167             use warnings;
168              
169             use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers
170             dbh => { -as => '_old_dbh' },
171             schema_from_schema_loader => { -as => '_old_sfsl' };
172              
173             use Sub::Exporter::Progressive -setup => {
174             exports => [qw(dbh schema_from_schema_loader)],
175             };
176              
177             sub dbh {
178             my $coderef = shift;
179              
180             _old_dbh(sub {
181             my ($dbh) = @_;
182             $dbh->do(q(SET search_path TO 'myapp_db'));
183              
184             $coderef->(@_);
185             });
186             }
187              
188             sub schema_from_schema_loader {
189             my ($config, $coderef) = @_;
190              
191             $config->{naming} ||= 'v7';
192              
193             _old_sfsl(sub {
194             my ($schema) = @_;
195             $schema->storage->dbh->do(q(SET search_path TO 'myapp_db'));
196              
197             $coderef->(@_);
198             });
199              
200             }
201              
202             The above will default the naming to C<v7> when using
203             C<schema_from_schema_loader>. And in both cases it will set the schema for
204             PostgreSQL. Of course if you do that you will not be able to switch to MySQL or
205             something else, so I recommended looking into my L<DBIx::Introspector> to only
206             do that for the database in question.
207              
208             =head1 AUTHOR
209              
210             Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
211              
212             =head1 COPYRIGHT AND LICENSE
213              
214             This software is copyright (c) 2019 by Arthur Axel "fREW" Schmidt.
215              
216             This is free software; you can redistribute it and/or modify it under
217             the same terms as the Perl 5 programming language system itself.
218              
219             =cut