view release on metacpan or  search on metacpan

lib/Class/Usul/Schema.pm  view on Meta::CPAN

   for my $tuple (@{ $self->$_list_population_classes( $schema_class, $dir ) }){
      $res->{ $tuple->[ 0 ] }
         = $self->populate_class( $schema, $split, @{ $tuple } );
   }

   return $res;
};

my $_test_for_existance = sub {
   my ($self, $copts, $test, @args) = @_;

   $test or return FALSE; $test = $_inflate->( $test, @args );

   my $r = $self->execute_ddl( $test, $copts, { out => 'buffer' } );

   $self->debug and $self->dumper( $r );

   return $r && $r->out =~ m{ 1 }mx ? TRUE : FALSE;
};

# Public methods
sub create_database : method {
   my $self   = shift;
   my $driver = $self->driver;
   my $cmds   = $self->ddl_commands->{ lc $driver };
   my @dbs    = $self->all ? keys %{ $self->schema_classes } : $self->database;
   my $copts  = $self->connect_options;

   for my $db (@dbs) {
      my $ddl  = $cmds->{create_db} or return FAILED;
      my @args = ($self->host, $self->user, $db);

      my $r; not $self->$_test_for_existance( $copts, $cmds->{exists_db}, @args)
         and $self->info( "Creating ${driver} database ${db}" )
         and $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts );

      $self->debug and $r and $self->dumper( $r ); $r = FALSE;

      $ddl = $cmds->{grant_all}
         and $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts );

      $self->debug and $r and $self->dumper( $r );
   }

   return OK;
}

sub create_ddl : method {
   my $self = shift; $self->info( 'Creating DDL for '.$self->dsn );

   for my $schema_class (values %{ $self->schema_classes }) {
      ensure_class_loaded  $schema_class;
      $self->dry_run and $self->output( "Would create ${schema_class}" )
                     and next;
      $self->$_create_ddl( $schema_class, $self->config->sharedir );
   }

   return OK;
}

sub create_schema : method { # Create databases and edit credentials
   my $self    = shift;
   my $default = $self->yes;
   my $text    = 'Schema creation requires a database, id and password. '
               . 'For Postgres the driver is Pg and the port 5432. For '
               . 'MySQL the driver is mysql and the port 3306';

   $self->output( $text, AS_PARA );
   $self->yorn( '+Create database schema', $default, TRUE, 0 ) or return OK;
   $self->edit_credentials;
   $self->connect_options;
   $self->drop_database;
   $self->drop_user;
   $self->create_user;
   $self->create_database;
   $self->deploy_and_populate;
   return OK;
}

sub create_user : method {
   my $self   = shift;
   my $user   = $self->user;
   my $driver = $self->driver;
   my $cmds   = $self->ddl_commands->{ lc $driver };
   my $ddl    = $cmds->{create_user} or return FAILED;
   my @args   = ($self->host, $user, $self->password);
   my $copts  = $self->connect_options;

   my $r; not $self->$_test_for_existance( $copts, $cmds->{exists_user}, @args )
      and $self->info( "Creating ${driver} user ${user}" )
      and $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts  );

   $self->debug and $r and $self->dumper( $r );
   return OK;
}

sub ddl_paths {
   my ($self, $schema, $version, $dir) = @_; my @paths = ();

   for my $rdb (@{ $self->rdbms }) {
      push @paths, io( $schema->ddl_filename( $rdb, $version, $dir ) );
   }

   return @paths;
}

sub deploy_and_populate : method {
   my $self = shift;

   my @classes = $self->all ? values %{ $self->schema_classes }
                            : $self->schema_classes->{ $self->database };

   for my $schema_class (@classes) {
      $self->info( "Deploy and populate ${schema_class}" );
      $self->yorn( '+Continue', $self->yes, TRUE, 0 ) or next;
      ensure_class_loaded $schema_class;
      $schema_class->can( 'config' ) and $schema_class->config( $self->config );
      $self->$_deploy_and_populate( $schema_class, $self->config->sharedir );
   }

   return OK;
}

sub deploy_file { # Deprecated
   my $self = shift; return $self->populate_class( @_ );
};

sub drop_database : method {
   my $self   = shift;
   my $driver = $self->driver;
   my $cmds   = $self->ddl_commands->{ lc $driver };
   my @dbs    = $self->all ? keys %{ $self->schema_classes } : $self->database;
   my $copts  = $self->connect_options;

   $self->yorn( '+Really drop the database', $self->yes, TRUE, 0 ) or return OK;

   for my $db (@dbs) {
      my $ddl  = $cmds->{ 'drop_db' } or return FAILED;
      my @args = ($self->host, $self->user, $db);

      $self->info( "Droping ${driver} database ${db}" );

      my $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts );

      $self->debug and $self->dumper( $r );
   }

   return OK;
}

sub drop_user : method {
   my $self     = shift;
   my $user     = $self->user;
   my $driver   = $self->driver;
   my $cmds     = $self->ddl_commands->{ lc $driver };
   my $ddl      = $cmds->{ 'drop_user' } or return FAILED;
   my @args     = ($self->host, $user, $self->database);
   my $cmd_opts = { expected_rv => 1, out => 'buffer' };
   my $copts    = $self->connect_options;

   $self->yorn( '+Really drop the user', $self->yes, TRUE, 0 ) or return OK;
   $self->$_test_for_existance( $copts, $cmds->{exists_user}, @args )
      or return OK;
   $self->info( "Droping ${driver} user ${user}" );

   my $r = $self->execute_ddl( $_inflate->( $ddl, @args ), $copts, $cmd_opts );

   $self->debug and $self->dumper( $r );
   return OK;
}

sub edit_credentials : method {
   my $self      = shift;
   my $self_cfg  = $self->config;
   my $db        = $self->database;
   my $bootstrap = $self->options->{bootstrap};
   my $cfg_data  = $bootstrap ? {} : $self->load_config_data( $self_cfg, $db );
   my $copts     = $bootstrap ? {}
                 : $self->extract_creds_from( $self_cfg, $db, $cfg_data );
   my $stored_pw = $copts->{password};
   my $prompts   = { name     => 'Database name',
                     driver   => 'Driver type',
                     host     => 'Host name',
                     port     => 'Port number',
                     user     => 'User name',
                     password => 'User password' };
   my $defaults  = { name     => $db,
                     driver   => '_field',
                     host     => 'localhost',
                     port     => '_field',
                     user     => '_field',
                     password => NUL };

   for my $field (qw( name driver host port user password )) {
      my $setter = "_set_${field}";
      my $prompt = '+'.$prompts->{ $field };
      my $is_pw  = $field eq 'password' ? TRUE : FALSE;
      my $value  = $defaults->{ $field } ne '_field' ? $defaults->{ $field }
                                                     :    $copts->{ $field };

      $value = $self->get_line( $prompt, $value, TRUE, 0, FALSE, $is_pw );
      $field ne 'name' and $self->$setter( $value // NUL );
      $is_pw and $value = encrypt_for_config $self_cfg, $value, $stored_pw;
      $copts->{ $field } = $value // NUL;
   }

   $cfg_data->{credentials}->{ $copts->{name} } = $copts;
   $self->dry_run and $self->dumper( $cfg_data ) and return OK;
   $self->dump_config_data( $self_cfg, $copts->{name}, $cfg_data );
   return OK;
}

sub execute_ddl {
   my ($self, $ddl, $connect_opts, $cmd_opts) = @_;

   my $drvr = $connect_opts->{driver  } // lc $self->driver;
   my $db   = $connect_opts->{database} // $self->db_admin_accounts->{ $drvr };
   my $host = $connect_opts->{host    } // $self->host || 'localhost';
   my $user = $connect_opts->{user    } // $self->db_admin_ids->{ $drvr };
   my $pass = $connect_opts->{password};
   my $cmds = $self->ddl_commands->{ $drvr }
      or $self->fatal( 'Driver [_1] unknown', { args => [ $drvr ] } );
   my $code = $cmds->{ '-qualify_db' };
   my $qdb  = $code ? $code->( $self, $db ) : $db;
   my $cmd  = $cmds->{ '-execute_ddl' };

   $cmd = $_inflate->( $cmd, $host, $user, $pass, $ddl, $db, $qdb );
   $cmds->{ '-no_pipe' } or $cmd = "echo \"${ddl}\" | ${cmd}";
   $self->dry_run and $self->output( $cmd ) and return;
   $self->verbose and $self->output( $cmd );

   return $self->run_cmd( $cmd, { out => 'stdout', %{ $cmd_opts // {} } } );
}

sub populate_class {
   my ($self, $schema, $split, $class, $path) = @_; my $res;

   if ($class) { $self->output( "Populating ${class}" ) }
   else        { $self->fatal ( 'No class in [_1]', $path->filename ) }

   my $data = $self->file->dataclass_schema->load( $path );
   my $flds = [ split SPC, $data->{fields} ];
   my @rows = map { [ map { $_unquote->( trim $_ ) } $split->records( $_ ) ] }
                 @{ $data->{rows} };

   try {
      if ($self->dry_run) { $self->dumper( $flds, \@rows ) }
      else { $res = $schema->populate( $class, [ $flds, @rows ] ) }
   }
   catch {
      if ($_->can( 'class' ) and $_->class eq 'ValidationErrors') {
         $self->warning( "${_}" ) for (@{ $_->args });
      }

      throw $_;
   };

   return $res;
}

sub repopulate_class : method {
   my $self = shift;
   my $dir = $self->config->sharedir;
   my $class = $self->next_argv or throw Unspecified, [ 'class name' ];
   my $schema_class = $self->schema_classes->{ $self->database };
   my $tuples = $self->$_list_population_classes( $schema_class, $dir );
   my $split = Data::Record->new( { split => COMMA, unless => QUOTED_RE, } );

lib/Class/Usul/Schema.pm  view on Meta::CPAN

=item C<ddl_commands>

A hash reference keyed by database driver. The DDL commands used to create
users and databases

=item C<dry_run>

A boolean that defaults for false. Can be set from the command line with
the C<-d> option. Prints out commands, do not execute them

=item C<preversion>

String which defaults to null. The previous schema version number

=item C<rdbms>

Array reference which defaults  to C<< [ qw(MySQL PostgreSQL) ] >>. List
of supported RDBMS

=item C<schema_classes>

Hash reference which defaults to C<< {} >>. Keyed by model name, the DBIC
class names for each model

=item C<schema_version>

String which defaults to C<0.1>. The schema version number is used in the
DDL filenames

=item C<unlink>

Boolean which defaults to false. Unlink DDL files if they exist before
creating new ones

=item C<yes>

Boolean which defaults to false. When true flips the defaults for
yes/no questions

=back

=head1 Subroutines/Methods

=head2 create_database - Creates a database

   $self->create_database;

Understands how to do this for different RDBMSs, e.g. MySQL and PostgreSQL

=head2 create_ddl - Dump the database schema definition

   $self->create_ddl;

Creates the DDL for multiple RDBMs

=head2 create_schema - Creates a database then deploys and populates the schema

   $self->create_schema;

Calls L<edit_credentials>, L<create_database>, L<create_user>, and
L<deploy_and_populate>

=head2 create_user - Creates a database user

   $self->create_user;

Creates a database user

=head2 deploy_and_populate - Create tables and populates them with initial data

   $self->deploy_and_populate;

Called as part of the application install

=head2 ddl_paths

   @paths = $self->ddl_paths( $schema, $version, $dir );

Returns a list of io objects for each of the DDL files

=head2 deploy_file

Deprecated in favour of L</populate_class>

=head2 driver

   $self->driver;

The database driver string, derived from the L</dsn> method

=head2 drop_database - Drops a database

   $self->drop_database;

The database is selected by the C<database> attribute

=head2 drop_user - Drops a user

   $self->drop_user;

The user is selected by the C<user> attribute

=head2 dsn

   $self->dsn;

Returns the DSN from the call to
L<get_connect_info|Class::Usul::TraitFor::ConnectInfo/get_connect_info>

=head2 edit_credentials - Edits the database login information

   $self->edit_credentials;

Encrypts the database connection password before storage

=head2 execute_ddl

   $self->execute_ddl( $ddl, \%connect_opts, \%command_opts );

Executes the DDL

=head2 host

   $self->host;

Returns the hostname of the database server derived from the call to
L</dsn>

=head2 password

   $self->password;

The unencrypted password used to connect to the database

=head2 populate_class

   $result = $self->populate_class( $schema, $split, $class, $path );

Populates one table from a single file

=head2 repopulate_class - Reloads the given class from the initial load data

   $self->repopulate_class;

Specify the class to reload on the command line

=head2 user

   $self->user;

The user id used to connect to the database

=head1 Diagnostics

None

=head1 Dependencies

=over 3

=item L<Class::Usul::TraitFor::ConnectInfo>

=item L<Class::Usul::Programs>

=back

=head1 Incompatibilities

There are no known incompatibilities in this module

=head1 Bugs and Limitations