File Coverage

lib/App/DH.pm
Criterion Covered Total %
statement 53 59 89.8
branch 3 8 37.5
condition n/a
subroutine 15 16 93.7
pod 0 4 0.0
total 71 87 81.6


line stmt bran cond sub pod time code
1 2     2   63256 use 5.006; # our
  2         5  
  2         70  
2 2     2   8 use strict;
  2         3  
  2         51  
3 2     2   8 use warnings;
  2         8  
  2         111  
4              
5             package App::DH;
6              
7             our $VERSION = '0.003000';
8              
9             # ABSTRACT: Deploy your DBIx::Class Schema to DDL/Database via DBIx::Class::DeploymentHandler
10              
11             our $AUTHORITY = 'cpan:MSTROUT'; # AUTHORITY
12              
13 2     2   11 use Carp qw( croak );
  2         2  
  2         105  
14 2     2   1097 use DBIx::Class::DeploymentHandler;
  2         2466182  
  2         91  
15 2     2   14 use Moose qw( with has around );
  2         3  
  2         15  
16 2     2   10171 use MooseX::Getopt 0.48 ();
  2         309460  
  2         142  
17 2     2   1317 use PerlX::Maybe qw( maybe );
  2         3328  
  2         1681  
18              
19             with 'MooseX::Getopt';
20              
21              
22              
23              
24              
25              
26              
27              
28              
29              
30              
31              
32              
33              
34             has connection_name => (
35             traits => ['Getopt'],
36             is => ro =>,
37             isa => Str =>,
38             required => 1,
39             cmd_aliases => c =>,
40             default => sub { 'development' },
41             documentation => 'either a valid DBI DSN or an alias configured by DBIx::Class::Schema::Config',
42             );
43              
44              
45              
46              
47              
48              
49              
50              
51              
52             has force => (
53             traits => ['Getopt'],
54             is => ro =>,
55             isa => Bool =>,
56             default => sub { 0 },
57             cmd_aliases => f =>,
58             documentation => 'forcefully replace existing DDLs. [DANGER]',
59             );
60              
61              
62              
63              
64              
65              
66              
67              
68              
69              
70              
71              
72             has schema => (
73             traits => ['Getopt'],
74             is => ro =>,
75             isa => Str =>,
76             required => 1,
77             cmd_aliases => s =>,
78             documentation => 'the class name of the schema to generate DDLs/deploy for',
79             );
80              
81              
82              
83              
84              
85              
86              
87              
88              
89              
90              
91              
92              
93              
94             has include => (
95             traits => ['Getopt'],
96             is => ro =>,
97             isa => ArrayRef =>,
98             default => sub { [] },
99             cmd_aliases => I =>,
100             documentation => 'paths to load into INC',
101             );
102              
103              
104              
105              
106              
107              
108              
109              
110              
111              
112              
113              
114              
115              
116             has script_dir => (
117             traits => ['Getopt'],
118             is => ro =>,
119             isa => Str =>,
120             default => sub { 'share/ddl' },
121             cmd_aliases => o =>,
122             documentation => 'output path',
123             );
124              
125              
126              
127              
128              
129              
130              
131              
132              
133              
134              
135              
136              
137              
138              
139              
140             has database => (
141             traits => ['Getopt'],
142             is => 'ro',
143             lazy => 1,
144             builder => '_build_database',
145             isa => ArrayRef =>,
146             cmd_aliases => d =>,
147             documentation => 'SQL::Translator::Producer::* database backends to generate DDLs for',
148             );
149              
150              
151              
152              
153              
154              
155              
156              
157              
158              
159              
160             has target => (
161             traits => ['Getopt'],
162             isa => 'Str',
163             is => 'ro',
164             predicate => 'has_target',
165             cmd_aliases => 'v',
166             documentation => 'version to install/upgrade to',
167             );
168              
169             has _dh => ( is => 'ro', lazy => 1, builder => '_build__dh' );
170             has _schema => ( is => 'ro', lazy => 1, builder => '_build__schema' );
171              
172             sub _build__schema {
173 3     3   11 my ($self) = @_;
174 3         675 require lib;
175 3         570 lib->import($_) for @{ $self->include };
  3         116  
176 3         358 require Module::Runtime;
177 3         100 my $class = Module::Runtime::use_module( $self->schema );
178 3         6922 return $class->connect( $self->connection_name );
179             }
180              
181             sub _build__dh {
182 3     3   7 my ($self) = @_;
183 3         106 return DBIx::Class::DeploymentHandler->new(
184             {
185             schema => $self->_schema,
186             force_overwrite => $self->force,
187             script_directory => $self->script_dir,
188             databases => $self->database,
189             maybe to_version => $self->target,
190             },
191             );
192             }
193              
194             sub _build_database {
195 3     3   6 my ($self) = @_;
196 3         93 my $type = $self->_schema->storage->sqlt_type;
197              
198             # Note: This seemingly needless stringification
199             # exists to solve an incredibly complex problem on bleadperl
200             # with COW, and for some reason, the string sqlt_type
201             # returns as the flag 'IsCOW',
202             # which for some reason causes a warning when the invoking
203             # perl interpreter terminates.
204             #
205             # If you can solve the bug in bleadperl, I'll
206             # gladly remove the forced stringification of the COW string.
207             #
208             # -- kentnl @ Feb 16/2013
209             # -- perl (v5.17.9 (v5.17.8-156-g012528a))
210 3         8313 return ["$type"];
211             }
212              
213              
214              
215              
216              
217              
218              
219              
220              
221             sub cmd_write_ddl {
222 0     0 0 0 my ($self) = @_;
223 0         0 $self->_dh->prepare_install;
224 0         0 my $v = $self->_dh->schema_version;
225 0 0       0 if ( $v > 1 ) {
226 0         0 $self->_dh->prepare_upgrade(
227             {
228             from_version => $v - 1,
229             to_version => $v,
230             },
231             );
232             }
233 0         0 return;
234             }
235              
236              
237              
238              
239              
240              
241              
242              
243              
244             sub cmd_install {
245 1     1 0 2 my $self = shift;
246 1         23 $self->_dh->install;
247 1         77946 return;
248             }
249              
250              
251              
252              
253              
254              
255              
256              
257              
258             sub cmd_upgrade {
259 2     2 0 6 my $self = shift;
260 2         76 $self->_dh->upgrade;
261 2         70166 return;
262             }
263              
264             my (%cmds) = (
265             write_ddl => \&cmd_write_ddl,
266             install => \&cmd_install,
267             upgrade => \&cmd_upgrade,
268             );
269             my (%cmd_desc) = (
270             write_ddl => 'only write ddl files',
271             install => 'install to the specified database connection',
272             upgrade => 'upgrade the specified database connection',
273             );
274             my $list_cmds = join q[ ], sort keys %cmds;
275             my $list_cmds_opt = '(' . ( join q{|}, sort keys %cmds ) . ')';
276             my $list_cmds_usage =
277             ( join qq{\n}, q{}, qq{\tcommands:}, q{}, ( map { ( sprintf qq{\t%-30s%s}, $_, $cmd_desc{$_} ) } sort keys %cmds ), q{} );
278              
279              
280              
281              
282              
283              
284              
285              
286              
287              
288              
289              
290             around print_usage_text => sub {
291             my ( undef, undef, $usage ) = @_;
292             my ($text) = $usage->text();
293             $text =~ s{
294             ( long\s+options[.]+[]] )
295             } {
296             $1 . ' ' . $list_cmds_opt
297             }msex;
298             $text .= qq{\n} . $text . $list_cmds_usage . qq{\n};
299             print $text or croak q[Cannot write to STDOUT];
300             exit 0;
301             };
302              
303             sub run {
304 3     3 0 42 my ($self) = @_;
305 3         4 my ( $cmd, @what ) = @{ $self->extra_argv };
  3         91  
306 3 50       31 croak "Must supply a command\nCommands: $list_cmds\nFailed" unless $cmd;
307 3 50       10 croak "Extra argv detected - command only please\nFailed" if @what;
308 3 50       11 croak "No such command ${cmd}\nCommands: $list_cmds\nFailed"
309             unless exists $cmds{$cmd};
310 3         6 my $code = $cmds{$cmd};
311 3         37 return $self->$code();
312             }
313              
314             __PACKAGE__->meta->make_immutable;
315 2     2   13 no Moose;
  2         3  
  2         16  
316              
317             1;
318              
319             __END__
320              
321             =pod
322              
323             =encoding UTF-8
324              
325             =head1 NAME
326              
327             App::DH - Deploy your DBIx::Class Schema to DDL/Database via DBIx::Class::DeploymentHandler
328              
329             =head1 VERSION
330              
331             version 0.003000
332              
333             =head1 SYNOPSIS
334              
335             Basic usage:
336              
337             #!/usr/bin/env perl
338             #
339             # dh.pl
340              
341             use App::DH;
342             App::DH->new_with_options->run;
343              
344             --
345              
346             usage: dh.pl [-?cdfhIos] [long options...] (install|upgrade|write_ddl)
347             -h -? --usage --help Prints this usage information.
348             -c --connection_name either a valid DBI DSN or an alias
349             configured by DBIx::Class::Schema::Config
350             -f --force forcefully replace existing DDLs. [DANGER]
351             -s --schema the class name of the schema to generate
352             DDLs/deploy for
353             -I --include paths to load into @INC
354             -o --script_dir output path
355             -d --database database backends to generate DDLs for. See
356             SQL::Translator::Producer::* for valid values
357              
358             commands:
359              
360             install install to the specified database connection
361             upgrade upgrade the specified database connection
362             write_ddl only write ddl files
363              
364             If you don't like any of the defaults, you can subclass to override
365              
366             use App::DH;
367             {
368             package MyApp;
369             use Moose;
370             extends 'App::DH';
371              
372             has '+connection_name' => ( default => sub { 'production' } );
373             has '+schema' => ( default => sub { 'MyApp::Schema' } );
374             __PACKAGE__->meta->make_immutable;
375             }
376             MyApp->new_with_options->run;
377              
378             =head1 DESCRIPTION
379              
380             App::DH is a basic skeleton of a command line interface for the excellent
381             L<< C<DBIx::Class::DeploymentHandler>|DBIx::Class::DeploymentHandler >>, to make executing database deployment stages easier.
382              
383             =head1 COMMANDS
384              
385             =head2 write_ddl
386              
387             Only generate ddls for deploy/upgrade
388              
389             dh.pl [...params] write_ddl
390              
391             =head2 install
392              
393             Install to connection L</--connection_name>
394              
395             dh.pl [...params] install
396              
397             =head2 upgrade
398              
399             Upgrade connection L</--connection_name>
400              
401             dh.pl [...params] upgrade
402              
403             =head1 PARAMETERS
404              
405             =head2 --connection_name
406              
407             -c/--connection_name
408              
409             Specify the connection details to use for deployment.
410             Can be a name of a configuration in a C<DBIx::Class::Schema::Config> configuration if the L</--schema> uses it.
411              
412             --connection_name 'dbi:SQLite:/path/to/db'
413              
414             -cdevelopment
415              
416             =head2 --force
417              
418             Overwrite existing DDL files of the same version.
419              
420             -f/--force
421              
422             =head2 --schema
423              
424             -s/--schema
425              
426             The class name of the schema to load for DDL/Deployment
427              
428             -sMyProject::Schema
429             --schema MyProject::Schema
430              
431             =head2 --include
432              
433             -I/--include
434              
435             Add a given library path to @INC prior to loading C<schema>
436              
437             -I../lib
438             --include ../lib
439              
440             May be specified multiple times.
441              
442             =head2 --script_dir
443              
444             -o/--script_dir
445              
446             Specify where to write the per-backend DDL's.
447              
448             Default is ./share/ddl
449              
450             -o/tmp/ddl
451             --script_dir /tmp/ddl
452              
453             =head2 --database
454              
455             -d/--database
456              
457             Specify the C<SQL::Translator::Producer::*> backend to use for generating DDLs.
458              
459             -dSQLite
460             --database PostgreSQL
461              
462             Can be specified multiple times.
463              
464             Default is introspected from looking at whatever L</--connection_name> connects to.
465              
466             =head2 --target
467              
468             --target
469              
470             Specify which version to install/upgrade to.
471              
472             If not specified, defaults to the latest version.
473              
474             =for Pod::Coverage cmd_write_ddl
475             cmd_install
476             cmd_upgrade
477             run
478              
479             =head1 CREDITS
480              
481             This module is mostly code by mst, sponsored by L<nordaaker.com|http://nordaaker.com>, and I've only tidied it up and made it
482             more CPAN Friendly.
483              
484             =head1 SPONSORS
485              
486             The authoring of the initial incarnation of this code is kindly sponsored by L<nordaaker.com|http://nordaaker.com>.
487              
488             =head1 AUTHORS
489              
490             =over 4
491              
492             =item *
493              
494             kentnl - Kent Fredric (cpan:KENTNL) <kentnl@cpan.org>
495              
496             =item *
497              
498             mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
499              
500             =back
501              
502             =head1 COPYRIGHT AND LICENSE
503              
504             This software is copyright (c) 2015 by The App::DH Authors, Contributors, and Sponsors.
505              
506             This is free software; you can redistribute it and/or modify it under
507             the same terms as the Perl 5 programming language system itself.
508              
509             =cut