File Coverage

lib/Class/Usul/Schema.pm
Criterion Covered Total %
statement 41 228 17.9
branch 2 80 2.5
condition 0 46 0.0
subroutine 18 36 50.0
pod 13 13 100.0
total 74 403 18.3


line stmt bran cond sub pod time code
1             package Class::Usul::Schema;
2              
3 1     1   1203 use namespace::autoclean;
  1         19254  
  1         8  
4              
5 1         10 use Class::Usul::Constants qw( AS_PARA AS_PASSWORD EXCEPTION_CLASS COMMA
6 1     1   739 FAILED FALSE NUL OK QUOTED_RE SPC TRUE );
  1         4  
7 1     1   2668 use Class::Usul::Crypt::Util qw( encrypt_for_config );
  1         6  
  1         88  
8 1     1   11 use Class::Usul::Functions qw( distname ensure_class_loaded io throw trim );
  1         3  
  1         8  
9 1         24 use Class::Usul::Types qw( ArrayRef Bool HashRef Maybe NonEmptySimpleStr
10 1     1   2470 PositiveInt SimpleStr Str );
  1         8  
11 1     1   3915 use Data::Record;
  1         2042  
  1         44  
12 1     1   12 use Try::Tiny;
  1         4  
  1         99  
13 1     1   12 use Unexpected::Functions qw( inflate_placeholders Unspecified );
  1         4  
  1         16  
14 1     1   807 use Moo;
  1         4  
  1         11  
15 1     1   1311 use Class::Usul::Options;
  1         5  
  1         10  
16              
17             extends q(Class::Usul::Programs);
18             with q(Class::Usul::TraitFor::ConnectInfo);
19              
20             # Attribute constructors
21             my $_build_connect_options = sub {
22 0     0   0 my $self = shift;
23 0         0 my $copts = { password => NUL, user => NUL, };
24 0         0 my $text = 'Need the database administrators id and password';
25              
26 0         0 $self->output( $text, AS_PARA );
27              
28 0         0 my $prompt = '+Database administrator id';
29 0   0     0 my $user = $self->db_admin_ids->{ lc $self->driver } || NUL;
30              
31 0         0 $copts->{user} = $self->get_line( $prompt, $user, TRUE, 0 );
32 0         0 $prompt = '+Database administrator password';
33 0         0 $copts->{password} = $self->get_line( $prompt, AS_PASSWORD );
34 0         0 return $copts;
35             };
36              
37             my $_build_qdb = sub {
38 1     1   4 my $self = shift;
39 1         32 my $cmds = $self->ddl_commands->{ lc $self->driver };
40 1 50       113 my $code = $cmds ? $cmds->{ '-qualify_db' } : undef;
41              
42 1 50       9 return $code ? $code->( $self, $self->database ) : $self->database;
43             };
44              
45             my $_connect_info = sub {
46             my $self = shift;
47              
48             return $self->get_connect_info( $self, { database => $self->database } );
49             };
50              
51             my $_extract_from_dsn = sub {
52             my ($self, $field, $dsn) = @_;
53              
54             $self->options and $self->options->{bootstrap} and return;
55              
56             return (map { s{ \A $field [=] }{}mx; $_ }
57             grep { m{ \A $field [=] }mx }
58             split m{ [;] }mx, $dsn // $self->dsn)[ 0 ];
59             };
60              
61             my $_qualify_database_path = sub {
62             return $_[ 0 ]->config->datadir->catfile( $_[ 1 ].'.db' )->pathname;
63             };
64              
65             my $_rebuild_dsn = sub {
66             my $self = shift;
67             my $dsn = 'dbi:'.$self->driver.':database='.$self->_qualified_db;
68              
69             $self->host and $dsn .= ';host='.$self->host;
70             $self->port and $dsn .= ';port='.$self->port;
71              
72             return $self->_set_dsn( $dsn );
73             };
74              
75             my $_rebuild_qdb = sub {
76             my $self = shift; $self->_set__qualified_db( $self->$_build_qdb ); return;
77             };
78              
79             # Public attributes
80             option 'all' => is => 'ro', isa => Bool, default => FALSE,
81             documentation => 'Perform operation for all possible schema',
82             short => 'a';
83              
84             option 'database' => is => 'rwp', isa => NonEmptySimpleStr,
85             documentation => 'The database to connect to',
86             format => 's', lazy => TRUE, required => TRUE,
87             trigger => $_rebuild_qdb;
88              
89             option 'db_admin_accounts' => is => 'ro', isa => HashRef,
90             documentation => 'For each RDBMS the name of the system database',
91             default => sub { { mysql => 'mysql',
92             pg => 'postgres',
93             sqlite => NUL, } },
94             format => 's%';
95              
96             option 'db_admin_ids' => is => 'ro', isa => HashRef,
97             documentation => 'The default admin user ids for each RDBMS',
98             default => sub { { mysql => 'root',
99             pg => 'postgres',
100             sqlite => NUL, } },
101             format => 's%';
102              
103             option 'db_attr' => is => 'ro', isa => HashRef,
104             documentation => 'Default database connection attributes',
105             default => sub { { add_drop_table => TRUE,
106             no_comments => TRUE,
107             quote_identifiers => TRUE, } },
108             format => 's%';
109              
110             option 'dry_run' => is => 'ro', isa => Bool, default => FALSE,
111             documentation => 'Prints out commands, do not execute them',
112             short => 'd';
113              
114             option 'preversion' => is => 'rwp', isa => Str, default => NUL,
115             documentation => 'Previous schema version',
116             format => 's';
117              
118             option 'rdbms' => is => 'lazy', isa => ArrayRef, autosplit => COMMA,
119             documentation => 'List of supported RDBMSs',
120             default => sub { [ qw( MySQL PostgreSQL SQLite ) ] },
121             format => 's@';
122              
123             option 'schema_classes' => is => 'lazy', isa => HashRef, default => sub { {} },
124             documentation => 'The database schema classes',
125             format => 's%';
126              
127             option 'schema_version' => is => 'ro', isa => NonEmptySimpleStr,
128             documentation => 'Current schema version',
129             default => '0.1', format => 's';
130              
131             option 'unlink' => is => 'rwp', isa => Bool, default => FALSE,
132             documentation => 'If true remove DDL file before creating new ones';
133              
134             option 'yes' => is => 'ro', isa => Bool, default => FALSE,
135             documentation => 'When true flips the defaults for yes/no questions',
136             short => 'y';
137              
138             has 'connect_options' => is => 'lazy', isa => HashRef,
139             builder => $_build_connect_options;
140              
141             has 'ddl_commands' => is => 'lazy', isa => HashRef, builder => sub { {
142 1     1   62 'mysql' => {
143             'create_user' => "create user '[_2]'\@'%' identified by '[_3]';",
144             'create_db' => 'create database [_3] default '
145             . 'character set utf8 collate utf8_unicode_ci;',
146             'drop_db' => 'drop database if exists [_3];',
147             'drop_user' => "drop user '[_2]'\@'%';",
148             'exists_db' => 'select 1 from information_schema.SCHEMATA '
149             . "where SCHEMA_NAME = '[_3]';",
150             'exists_user' => 'select 1 from mysql.user '
151             . "where User = '[_2]' and Host = '%';",
152             'grant_all' => "grant all privileges on [_3].* to '[_2]'\@'%' "
153             . 'with grant option;',
154             '-execute_ddl' => 'mysql -A -h [_1] -u [_2] -p"[_3]" [_5]', },
155             'pg' => {
156             'create_user' => "create role [_2] login password '[_3]';",
157             'create_db' => "create database [_3] owner [_2] encoding 'UTF8';",
158             'drop_db' => 'drop database if exists [_3];',
159             'drop_user' => 'drop user if exists [_2];',
160             'exists_db' => "select 1 from pg_database where datname = '[_3]';",
161             'exists_user' => "select 1 from pg_user where usename = '[_2]';",
162             '-execute_ddl' => 'PGPASSWORD=[_3] '
163             . 'psql -h [_1] -q -t -U [_2] -w -c "[_4]"',
164             '-no_pipe' => TRUE, },
165             'sqlite' => {
166             '-execute_ddl' => "sqlite3 [_6] '[_4]'",
167             '-no_pipe' => TRUE,
168             '-qualify_db' => $_qualify_database_path, }, } };
169              
170             has 'driver' => is => 'rwp', isa => NonEmptySimpleStr,
171 1     1   102 builder => sub { (split m{ [:] }mx, $_[ 0 ]->dsn)[ 1 ] },
172             lazy => TRUE, trigger => $_rebuild_dsn;
173              
174             has 'dsn' => is => 'rwp', isa => NonEmptySimpleStr,
175 1     1   21 builder => sub { $_[ 0 ]->$_connect_info->[ 0 ] },
176             lazy => TRUE;
177              
178             has 'host' => is => 'rwp', isa => Maybe[SimpleStr],
179 1     1   14 builder => sub { $_[ 0 ]->$_extract_from_dsn( 'host' ) },
180             lazy => TRUE, trigger => $_rebuild_dsn;
181              
182             has 'password' => is => 'rwp', isa => SimpleStr,
183 1     1   2237 builder => sub { $_[ 0 ]->$_connect_info->[ 2 ] },
184             lazy => TRUE;
185              
186             has 'port' => is => 'rwp', isa => Maybe[PositiveInt],
187 1     1   13 builder => sub { $_[ 0 ]->$_extract_from_dsn( 'port' ) },
188             lazy => TRUE, trigger => $_rebuild_dsn;
189              
190             has 'user' => is => 'rwp', isa => SimpleStr,
191 1     1   669 builder => sub { $_[ 0 ]->$_connect_info->[ 1 ] },
192             lazy => TRUE;
193              
194             has '_qualified_db' => is => 'rwp', isa => NonEmptySimpleStr,
195             builder => $_build_qdb, lazy => TRUE, trigger => $_rebuild_dsn;
196              
197             # Private functions
198             my $_inflate = sub {
199             return inflate_placeholders [ 'undef', 'null', TRUE ], @_;
200             };
201              
202             my $_unquote = sub {
203             local $_ = $_[ 0 ]; s{ \A [\'\"] }{}mx; s{ [\'\"] \z }{}mx; return $_;
204             };
205              
206             # Private methods
207             my $_connect_attr = sub {
208             return { %{ $_[ 0 ]->$_connect_info->[ 3 ] }, %{ $_[ 0 ]->db_attr } };
209             };
210              
211             my $_create_ddl = sub {
212             my ($self, $schema_class, $dir) = @_;
213              
214             my $version = $self->schema_version;
215             my $schema = $schema_class->connect
216             ( $self->dsn, $self->user, $self->password, $self->$_connect_attr );
217              
218             if ($self->unlink) {
219             for my $path ($self->ddl_paths( $schema, $version, $dir )) {
220             $path->is_file and $path->unlink;
221             }
222             }
223              
224             $schema->create_ddl_dir
225             ( $self->rdbms, $version, $dir, $self->preversion, $self->$_connect_attr);
226             return;
227             };
228              
229             my $_list_population_classes = sub {
230             my ($self, $schema_class, $dir) = @_; my $res = [];
231              
232             my $dist = distname $schema_class;
233             my $extn = $self->config->extension;
234             my $re = qr{ \A $dist [-] \d+ [-] (.*) \Q$extn\E \z }mx;
235             my $io = io( $dir )->filter( sub { $_->filename =~ $re } );
236              
237             for my $path ($io->all_files) {
238             my ($class) = $path->filename =~ $re; push @{ $res }, [ $class, $path ];
239             }
240              
241             return $res;
242             };
243              
244             my $_deploy_and_populate = sub {
245             my ($self, $schema_class, $dir) = @_; my $res; my $schema;
246              
247             if ($self->dry_run) {
248             $self->output( "Would deploy schema ${schema_class} from ${dir}" );
249             $self->dumper( map { $_->basename }
250             $dir->filter( sub { m{ \.sql \z }mx } )->all_files );
251             }
252             else {
253             $self->info( "Deploying schema ${schema_class} and populating" );
254             $schema = $schema_class->connect
255             ( $self->dsn, $self->user, $self->password, $self->$_connect_attr );
256             $schema->storage->ensure_connected;
257             $schema->deploy( $self->$_connect_attr, $dir );
258             }
259              
260             my $split = Data::Record->new( { split => COMMA, unless => QUOTED_RE, } );
261              
262             for my $tuple (@{ $self->$_list_population_classes( $schema_class, $dir ) }){
263             $res->{ $tuple->[ 0 ] }
264             = $self->populate_class( $schema, $split, @{ $tuple } );
265             }
266              
267             return $res;
268             };
269              
270             my $_test_for_existance = sub {
271             my ($self, $copts, $test, @args) = @_;
272              
273             $test or return FALSE; $test = $_inflate->( $test, @args );
274              
275             my $r = $self->execute_ddl( $test, $copts, { out => 'buffer' } );
276              
277             $self->debug and $self->dumper( $r );
278              
279             return $r && $r->out =~ m{ 1 }mx ? TRUE : FALSE;
280             };
281              
282             # Public methods
283             sub create_database : method {
284 0     0 1   my $self = shift;
285 0           my $driver = $self->driver;
286 0           my $cmds = $self->ddl_commands->{ lc $driver };
287 0 0         my @dbs = $self->all ? keys %{ $self->schema_classes } : $self->database;
  0            
288 0           my $copts = $self->connect_options;
289              
290 0           for my $db (@dbs) {
291 0 0         my $ddl = $cmds->{create_db} or return FAILED;
292 0           my @args = ($self->host, $self->user, $db);
293              
294 0 0 0       my $r; not $self->$_test_for_existance( $copts, $cmds->{exists_db}, @args)
  0            
295             and $self->info( "Creating ${driver} database ${db}" )
296             and $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts );
297              
298 0 0 0       $self->debug and $r and $self->dumper( $r ); $r = FALSE;
  0            
299              
300             $ddl = $cmds->{grant_all}
301 0 0         and $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts );
302              
303 0 0 0       $self->debug and $r and $self->dumper( $r );
304             }
305              
306 0           return OK;
307             }
308              
309             sub create_ddl : method {
310 0     0 1   my $self = shift; $self->info( 'Creating DDL for '.$self->dsn );
  0            
311              
312 0           for my $schema_class (values %{ $self->schema_classes }) {
  0            
313 0           ensure_class_loaded $schema_class;
314 0 0 0       $self->dry_run and $self->output( "Would create ${schema_class}" )
315             and next;
316 0           $self->$_create_ddl( $schema_class, $self->config->sharedir );
317             }
318              
319 0           return OK;
320             }
321              
322             sub create_schema : method { # Create databases and edit credentials
323 0     0 1   my $self = shift;
324 0           my $default = $self->yes;
325 0           my $text = 'Schema creation requires a database, id and password. '
326             . 'For Postgres the driver is Pg and the port 5432. For '
327             . 'MySQL the driver is mysql and the port 3306';
328              
329 0           $self->output( $text, AS_PARA );
330 0 0         $self->yorn( '+Create database schema', $default, TRUE, 0 ) or return OK;
331 0           $self->edit_credentials;
332 0           $self->connect_options;
333 0           $self->drop_database;
334 0           $self->drop_user;
335 0           $self->create_user;
336 0           $self->create_database;
337 0           $self->deploy_and_populate;
338 0           return OK;
339             }
340              
341             sub create_user : method {
342 0     0 1   my $self = shift;
343 0           my $user = $self->user;
344 0           my $driver = $self->driver;
345 0           my $cmds = $self->ddl_commands->{ lc $driver };
346 0 0         my $ddl = $cmds->{create_user} or return FAILED;
347 0           my @args = ($self->host, $user, $self->password);
348 0           my $copts = $self->connect_options;
349              
350 0 0 0       my $r; not $self->$_test_for_existance( $copts, $cmds->{exists_user}, @args )
  0            
351             and $self->info( "Creating ${driver} user ${user}" )
352             and $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts );
353              
354 0 0 0       $self->debug and $r and $self->dumper( $r );
355 0           return OK;
356             }
357              
358             sub ddl_paths {
359 0     0 1   my ($self, $schema, $version, $dir) = @_; my @paths = ();
  0            
360              
361 0           for my $rdb (@{ $self->rdbms }) {
  0            
362 0           push @paths, io( $schema->ddl_filename( $rdb, $version, $dir ) );
363             }
364              
365 0           return @paths;
366             }
367              
368             sub deploy_and_populate : method {
369 0     0 1   my $self = shift;
370              
371 0           my @classes = $self->all ? values %{ $self->schema_classes }
372 0 0         : $self->schema_classes->{ $self->database };
373              
374 0           for my $schema_class (@classes) {
375 0           $self->info( "Deploy and populate ${schema_class}" );
376 0 0         $self->yorn( '+Continue', $self->yes, TRUE, 0 ) or next;
377 0           ensure_class_loaded $schema_class;
378 0 0         $schema_class->can( 'config' ) and $schema_class->config( $self->config );
379 0           $self->$_deploy_and_populate( $schema_class, $self->config->sharedir );
380             }
381              
382 0           return OK;
383             }
384              
385             sub deploy_file { # Deprecated
386 0     0 1   my $self = shift; return $self->populate_class( @_ );
  0            
387             };
388              
389             sub drop_database : method {
390 0     0 1   my $self = shift;
391 0           my $driver = $self->driver;
392 0           my $cmds = $self->ddl_commands->{ lc $driver };
393 0 0         my @dbs = $self->all ? keys %{ $self->schema_classes } : $self->database;
  0            
394 0           my $copts = $self->connect_options;
395              
396 0 0         $self->yorn( '+Really drop the database', $self->yes, TRUE, 0 ) or return OK;
397              
398 0           for my $db (@dbs) {
399 0 0         my $ddl = $cmds->{ 'drop_db' } or return FAILED;
400 0           my @args = ($self->host, $self->user, $db);
401              
402 0           $self->info( "Droping ${driver} database ${db}" );
403              
404 0           my $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts );
405              
406 0 0         $self->debug and $self->dumper( $r );
407             }
408              
409 0           return OK;
410             }
411              
412             sub drop_user : method {
413 0     0 1   my $self = shift;
414 0           my $user = $self->user;
415 0           my $driver = $self->driver;
416 0           my $cmds = $self->ddl_commands->{ lc $driver };
417 0 0         my $ddl = $cmds->{ 'drop_user' } or return FAILED;
418 0           my @args = ($self->host, $user, $self->database);
419 0           my $cmd_opts = { expected_rv => 1, out => 'buffer' };
420 0           my $copts = $self->connect_options;
421              
422 0 0         $self->yorn( '+Really drop the user', $self->yes, TRUE, 0 ) or return OK;
423 0 0         $self->$_test_for_existance( $copts, $cmds->{exists_user}, @args )
424             or return OK;
425 0           $self->info( "Droping ${driver} user ${user}" );
426              
427 0           my $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts, $cmd_opts );
428              
429 0 0         $self->debug and $self->dumper( $r );
430 0           return OK;
431             }
432              
433             sub edit_credentials : method {
434 0     0 1   my $self = shift;
435 0           my $self_cfg = $self->config;
436 0           my $db = $self->database;
437 0           my $bootstrap = $self->options->{bootstrap};
438 0 0         my $cfg_data = $bootstrap ? {} : $self->load_config_data( $self_cfg, $db );
439 0 0         my $copts = $bootstrap ? {}
440             : $self->extract_creds_from( $self_cfg, $db, $cfg_data );
441 0           my $stored_pw = $copts->{password};
442 0           my $prompts = { name => 'Database name',
443             driver => 'Driver type',
444             host => 'Host name',
445             port => 'Port number',
446             user => 'User name',
447             password => 'User password' };
448 0           my $defaults = { name => $db,
449             driver => '_field',
450             host => 'localhost',
451             port => '_field',
452             user => '_field',
453             password => NUL };
454              
455 0           for my $field (qw( name driver host port user password )) {
456 0           my $setter = "_set_${field}";
457 0           my $prompt = '+'.$prompts->{ $field };
458 0 0         my $is_pw = $field eq 'password' ? TRUE : FALSE;
459             my $value = $defaults->{ $field } ne '_field' ? $defaults->{ $field }
460 0 0         : $copts->{ $field };
461              
462 0           $value = $self->get_line( $prompt, $value, TRUE, 0, FALSE, $is_pw );
463 0 0 0       $field ne 'name' and $self->$setter( $value // NUL );
464 0 0         $is_pw and $value = encrypt_for_config $self_cfg, $value, $stored_pw;
465 0   0       $copts->{ $field } = $value // NUL;
466             }
467              
468 0           $cfg_data->{credentials}->{ $copts->{name} } = $copts;
469 0 0 0       $self->dry_run and $self->dumper( $cfg_data ) and return OK;
470 0           $self->dump_config_data( $self_cfg, $copts->{name}, $cfg_data );
471 0           return OK;
472             }
473              
474             sub execute_ddl {
475 0     0 1   my ($self, $ddl, $connect_opts, $cmd_opts) = @_;
476              
477 0   0       my $drvr = $connect_opts->{driver } // lc $self->driver;
478 0   0       my $db = $connect_opts->{database} // $self->db_admin_accounts->{ $drvr };
479 0   0       my $host = $connect_opts->{host } // $self->host || 'localhost';
480 0   0       my $user = $connect_opts->{user } // $self->db_admin_ids->{ $drvr };
481 0           my $pass = $connect_opts->{password};
482 0 0         my $cmds = $self->ddl_commands->{ $drvr }
483             or $self->fatal( 'Driver [_1] unknown', { args => [ $drvr ] } );
484 0           my $code = $cmds->{ '-qualify_db' };
485 0 0         my $qdb = $code ? $code->( $self, $db ) : $db;
486 0           my $cmd = $cmds->{ '-execute_ddl' };
487              
488 0           $cmd = $_inflate->( $cmd, $host, $user, $pass, $ddl, $db, $qdb );
489 0 0         $cmds->{ '-no_pipe' } or $cmd = "echo \"${ddl}\" | ${cmd}";
490 0 0 0       $self->dry_run and $self->output( $cmd ) and return;
491 0 0         $self->verbose and $self->output( $cmd );
492              
493 0   0       return $self->run_cmd( $cmd, { out => 'stdout', %{ $cmd_opts // {} } } );
  0            
494             }
495              
496             sub populate_class {
497 0     0 1   my ($self, $schema, $split, $class, $path) = @_; my $res;
  0            
498              
499 0 0         if ($class) { $self->output( "Populating ${class}" ) }
  0            
500 0           else { $self->fatal ( 'No class in [_1]', $path->filename ) }
501              
502 0           my $data = $self->file->dataclass_schema->load( $path );
503 0           my $flds = [ split SPC, $data->{fields} ];
504 0           my @rows = map { [ map { $_unquote->( trim $_ ) } $split->records( $_ ) ] }
  0            
505 0           @{ $data->{rows} };
  0            
506              
507             try {
508 0 0   0     if ($self->dry_run) { $self->dumper( $flds, \@rows ) }
  0            
509 0           else { $res = $schema->populate( $class, [ $flds, @rows ] ) }
510             }
511             catch {
512 0 0 0 0     if ($_->can( 'class' ) and $_->class eq 'ValidationErrors') {
513 0           $self->warning( "${_}" ) for (@{ $_->args });
  0            
514             }
515              
516 0           throw $_;
517 0           };
518              
519 0           return $res;
520             }
521              
522             sub repopulate_class : method {
523 0     0 1   my $self = shift;
524 0           my $dir = $self->config->sharedir;
525 0 0         my $class = $self->next_argv or throw Unspecified, [ 'class name' ];
526 0           my $schema_class = $self->schema_classes->{ $self->database };
527 0           my $tuples = $self->$_list_population_classes( $schema_class, $dir );
528 0           my $split = Data::Record->new( { split => COMMA, unless => QUOTED_RE, } );
529              
530 0           ensure_class_loaded $schema_class;
531              
532 0           my $schema = $schema_class->connect
533             ( $self->dsn, $self->user, $self->password, $self->$_connect_attr );
534              
535 0           for my $tuple (grep { $_->[ 0 ] =~ m{ \A $class \z }imx } @{ $tuples }) {
  0            
  0            
536 0           my $data = $self->file->dataclass_schema->load( $tuple->[ 1 ] );
537 0           my $flds = [ split SPC, $data->{fields} ];
538 0           my @rows = map { [ map { $_unquote->( trim $_ ) }
  0            
539 0           $split->records( $_ ) ] } @{ $data->{rows} };
  0            
540 0           my $rs = $schema->resultset( $tuple->[ 0 ] );
541              
542 0           for my $row (@rows) {
543 0           my $name = $row->[ 0 ]; my $type = $row->[ 1 ];
  0            
544              
545             try {
546 0     0     $rs->create( { name => $name, type_class => $type } );
547 0           $self->info( "Create a ${type} type called ${name}" );
548             }
549 0     0     catch {};
550             }
551             }
552              
553 0           return OK;
554             }
555              
556             1;
557              
558             __END__
559              
560             =pod
561              
562             =encoding utf8
563              
564             =head1 Name
565              
566             Class::Usul::Schema - Support for database schemas
567              
568             =head1 Synopsis
569              
570             package YourApp::Schema;
571              
572             use Moo;
573             use Class::Usul::Functions qw( arg_list );
574             use YourApp::Schema::Authentication;
575             use YourApp::Schema::Catalog;
576              
577             extends 'Class::Usul::Schema';
578              
579             my %DEFAULTS = ( database => 'library',
580             schema_classes => {
581             authentication => 'YourApp::Schema::Authentication',
582             catalog => 'YourApp::Schema::Catalog', }, );
583              
584             sub new_with_options {
585             my ($self, @args) = @_; my $attr = arg_list @args;
586              
587             return $self->next::method( %DEFAULTS, %{ $attr } );
588             }
589              
590             =head1 Description
591              
592             Methods used to install and uninstall database applications
593              
594             =head1 Configuration and Environment
595              
596             Defines the following attributes
597              
598             =over 3
599              
600             =item C<all>
601              
602             Optional boolean. Perform operation for all possible schema
603              
604             =item C<database>
605              
606             String which is required. The name of the database to connect to
607              
608             =item C<db_admin_accounts>
609              
610             Hash reference keyed by the lower case driver value. The hash's value is the
611             name of the administration database for that RDBMS
612              
613             =item C<db_admin_ids>
614              
615             Hash reference which defaults to C<< { mysql => 'root', pg => 'postgres', } >>
616             The default administration identity for each supported RDBMS
617              
618             =item C<db_attr>
619              
620             Hash reference which defaults to
621             C<< { add_drop_table => TRUE, no_comments => TRUE, } >>
622              
623             =item C<ddl_commands>
624              
625             A hash reference keyed by database driver. The DDL commands used to create
626             users and databases
627              
628             =item C<dry_run>
629              
630             A boolean that defaults for false. Can be set from the command line with
631             the C<-d> option. Prints out commands, do not execute them
632              
633             =item C<preversion>
634              
635             String which defaults to null. The previous schema version number
636              
637             =item C<rdbms>
638              
639             Array reference which defaults to C<< [ qw(MySQL PostgreSQL) ] >>. List
640             of supported RDBMS
641              
642             =item C<schema_classes>
643              
644             Hash reference which defaults to C<< {} >>. Keyed by model name, the DBIC
645             class names for each model
646              
647             =item C<schema_version>
648              
649             String which defaults to C<0.1>. The schema version number is used in the
650             DDL filenames
651              
652             =item C<unlink>
653              
654             Boolean which defaults to false. Unlink DDL files if they exist before
655             creating new ones
656              
657             =item C<yes>
658              
659             Boolean which defaults to false. When true flips the defaults for
660             yes/no questions
661              
662             =back
663              
664             =head1 Subroutines/Methods
665              
666             =head2 create_database - Creates a database
667              
668             $self->create_database;
669              
670             Understands how to do this for different RDBMSs, e.g. MySQL and PostgreSQL
671              
672             =head2 create_ddl - Dump the database schema definition
673              
674             $self->create_ddl;
675              
676             Creates the DDL for multiple RDBMs
677              
678             =head2 create_schema - Creates a database then deploys and populates the schema
679              
680             $self->create_schema;
681              
682             Calls L<edit_credentials>, L<create_database>, L<create_user>, and
683             L<deploy_and_populate>
684              
685             =head2 create_user - Creates a database user
686              
687             $self->create_user;
688              
689             Creates a database user
690              
691             =head2 deploy_and_populate - Create tables and populates them with initial data
692              
693             $self->deploy_and_populate;
694              
695             Called as part of the application install
696              
697             =head2 ddl_paths
698              
699             @paths = $self->ddl_paths( $schema, $version, $dir );
700              
701             Returns a list of io objects for each of the DDL files
702              
703             =head2 deploy_file
704              
705             Deprecated in favour of L</populate_class>
706              
707             =head2 driver
708              
709             $self->driver;
710              
711             The database driver string, derived from the L</dsn> method
712              
713             =head2 drop_database - Drops a database
714              
715             $self->drop_database;
716              
717             The database is selected by the C<database> attribute
718              
719             =head2 drop_user - Drops a user
720              
721             $self->drop_user;
722              
723             The user is selected by the C<user> attribute
724              
725             =head2 dsn
726              
727             $self->dsn;
728              
729             Returns the DSN from the call to
730             L<get_connect_info|Class::Usul::TraitFor::ConnectInfo/get_connect_info>
731              
732             =head2 edit_credentials - Edits the database login information
733              
734             $self->edit_credentials;
735              
736             Encrypts the database connection password before storage
737              
738             =head2 execute_ddl
739              
740             $self->execute_ddl( $ddl, \%connect_opts, \%command_opts );
741              
742             Executes the DDL
743              
744             =head2 host
745              
746             $self->host;
747              
748             Returns the hostname of the database server derived from the call to
749             L</dsn>
750              
751             =head2 password
752              
753             $self->password;
754              
755             The unencrypted password used to connect to the database
756              
757             =head2 populate_class
758              
759             $result = $self->populate_class( $schema, $split, $class, $path );
760              
761             Populates one table from a single file
762              
763             =head2 repopulate_class - Reloads the given class from the initial load data
764              
765             $self->repopulate_class;
766              
767             Specify the class to reload on the command line
768              
769             =head2 user
770              
771             $self->user;
772              
773             The user id used to connect to the database
774              
775             =head1 Diagnostics
776              
777             None
778              
779             =head1 Dependencies
780              
781             =over 3
782              
783             =item L<Class::Usul::TraitFor::ConnectInfo>
784              
785             =item L<Class::Usul::Programs>
786              
787             =back
788              
789             =head1 Incompatibilities
790              
791             There are no known incompatibilities in this module
792              
793             =head1 Bugs and Limitations
794              
795             There are no known bugs in this module.
796             Please report problems to the address below.
797             Patches are welcome
798              
799             =head1 Author
800              
801             Peter Flanigan, C<< <pjfl@cpan.org> >>
802              
803             =head1 License and Copyright
804              
805             Copyright (c) 2017 Peter Flanigan. All rights reserved
806              
807             This program is free software; you can redistribute it and/or modify it
808             under the same terms as Perl itself. See L<perlartistic>
809              
810             This program is distributed in the hope that it will be useful,
811             but WITHOUT WARRANTY; without even the implied warranty of
812             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
813              
814             =cut
815              
816             # Local Variables:
817             # mode: perl
818             # tab-width: 3
819             # End: