1 package DBIx::Class::Admin;
6 Moose MooseX::Types MooseX::Types::JSON MooseX::Types::Path::Class
7 Try::Tiny parent JSON::Any Class::C3::Componentised
12 foreach my $dep (@_deps) {
15 push @_missing_deps, $dep;
19 if (@_missing_deps > 0) {
20 die "The following dependecies are missing " . join ",", @_missing_deps;
25 use parent 'DBIx::Class::Schema';
26 use Carp::Clan qw/^DBIx::Class/;
28 use MooseX::Types::Moose qw/Int Str Any Bool/;
29 use DBIx::Class::Admin::Types qw/DBICConnectInfo DBICHashRef/;
30 use MooseX::Types::JSON qw(JSON);
31 use MooseX::Types::Path::Class qw(Dir File);
33 use JSON::Any qw(DWIW XS JSON);
34 use namespace::autoclean;
38 DBIx::Class::Admin - Administration object for schemas
44 $ dbicadmin --schema=MyApp::Schema \
45 --connect='["dbi:SQLite:my.db", "", ""]' \
48 $ dbicadmin --schema=MyApp::Schema --class=Employee \
49 --connect='["dbi:SQLite:my.db", "", ""]' \
50 --op=update --set='{ "name": "New_Employee" }'
52 use DBIx::Class::Admin;
55 my $admin = DBIx::Class::Admin->new(
56 schema_class=> 'MY::Schema',
58 connect_info => { dsn => $dsn, user => $user, password => $pass },
62 $admin->create('SQLite');
64 # create SQL diff for an upgrade
65 $admin->create('SQLite', {} , "1.0");
70 # install a version for an unversioned schema
71 $admin->install("3.0");
75 The following CPAN modules are required to use C<dbicadmin> and this module:
81 L<MooseX::Types::JSON>
83 L<MooseX::Types::Path::Class>
91 (L<JSON::DWIW> preferred for barekey support)
93 L<namespace::autoclean>
95 L<Getopt::Long::Descriptive>
103 the class of the schema to load
107 has 'schema_class' => (
115 A pre-connected schema object can be provided for manipulation
121 isa => 'DBIx::Class::Schema',
127 $self->ensure_class_loaded($self->schema_class);
129 $self->connect_info->[3]->{ignore_version} =1;
130 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
136 a resultset from the schema to operate on
148 a hash ref or json string to be used for identifying data to manipulate
161 a hash ref or json string to be used for inserting or updating data
174 a hash ref or json string to be used for passing additonal info to the ->search call
187 connect_info the arguments to provide to the connect call of the schema_class
191 has 'connect_info' => (
193 isa => DBICConnectInfo,
198 sub _build_connect_info {
200 return $self->_find_stanza($self->config, $self->config_stanza);
206 config_file provide a config_file to read connect_info from, if this is provided
207 config_stanze should also be provided to locate where the connect_info is in the config
208 The config file should be in a format readable by Config::General
221 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
222 designed for use with catalyst config files
226 has 'config_stanza' => (
234 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
235 config_stanza will still be required.
248 eval { require Config::Any }
249 or $self->throw_exception( "Config::Any is required to parse the config file");
251 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
253 # just grab the config from the config file
254 $cfg = $cfg->{$self->config_file};
261 The location where sql ddl files should be created or found for an upgrade.
274 Used for install, the version which will be 'installed' in the schema
286 Previouse version of the schema to create an upgrade diff for, the full sql for that version of the sql must be in the sql_dir
298 Try and force certain operations.
310 Be less verbose about actions
331 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
335 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
336 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
338 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
340 Optional preversion can be supplied to generate a diff to be used by upgrade.
345 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
347 $preversion ||= $self->preversion();
349 my $schema = $self->schema();
350 # create the dir if does not exist
351 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
353 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
361 =item Arguments: <none>
365 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
366 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
372 my $schema = $self->schema();
373 if (!$schema->get_db_version()) {
374 # schema is unversioned
375 $self->throw_exception ("could not determin current schema version, please either install or deploy");
377 my $ret = $schema->upgrade();
387 =item Arguments: $version
391 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
392 database. install will take a version and add the version tracking tables and 'install' the version. No
393 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
394 already versioned databases.
399 my ($self, $version) = @_;
401 my $schema = $self->schema();
402 $version ||= $self->version();
403 if (!$schema->get_db_version() ) {
404 # schema is unversioned
405 print "Going to install schema version\n";
406 my $ret = $schema->install($version);
407 print "retun is $ret\n";
409 elsif ($schema->get_db_version() and $self->force ) {
410 carp "Forcing install may not be a good idea";
411 if($self->_confirm() ) {
412 $self->schema->_set_db_version({ version => $version});
416 $self->throw_exception ("schema already has a version not installing, try upgrade instead");
426 =item Arguments: $args
430 deploy will create the schema at the connected database. C<$args> are passed straight to
431 L<DBIx::Class::Schema/deploy>.
436 my ($self, $args) = @_;
437 my $schema = $self->schema();
438 if (!$schema->get_db_version() ) {
439 # schema is unversioned
440 $schema->deploy( $args, $self->sql_dir)
441 or $self->throw_exception ("could not deploy schema");
443 $self->throw_exception("there already is a database with a version here, try upgrade instead");
451 =item Arguments: $rs, $set
455 insert takes the name of a resultset from the schema_class and a hashref of data to insert
461 my ($self, $rs, $set) = @_;
463 $rs ||= $self->resultset();
464 $set ||= $self->set();
465 my $resultset = $self->schema->resultset($rs);
466 my $obj = $resultset->create( $set );
467 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
475 =item Arguments: $rs, $set, $where
479 update takes the name of a resultset from the schema_class, a hashref of data to update and
480 a where hash used to form the search for the rows to update.
485 my ($self, $rs, $set, $where) = @_;
487 $rs ||= $self->resultset();
488 $where ||= $self->where();
489 $set ||= $self->set();
490 my $resultset = $self->schema->resultset($rs);
491 $resultset = $resultset->search( ($where||{}) );
493 my $count = $resultset->count();
494 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
496 if ( $self->force || $self->_confirm() ) {
497 $resultset->update_all( $set );
506 =item Arguments: $rs, $where, $attrs
510 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
511 The found data is deleted and cannot be recovered.
516 my ($self, $rs, $where, $attrs) = @_;
518 $rs ||= $self->resultset();
519 $where ||= $self->where();
520 $attrs ||= $self->attrs();
521 my $resultset = $self->schema->resultset($rs);
522 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
524 my $count = $resultset->count();
525 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
527 if ( $self->force || $self->_confirm() ) {
528 $resultset->delete_all();
537 =item Arguments: $rs, $where, $attrs
541 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
542 The found data is returned in a array ref where the first row will be the columns list.
547 my ($self, $rs, $where, $attrs) = @_;
549 $rs ||= $self->resultset();
550 $where ||= $self->where();
551 $attrs ||= $self->attrs();
552 my $resultset = $self->schema->resultset($rs);
553 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
556 my @columns = $resultset->result_source->columns();
557 push @data, [@columns];#
559 while (my $row = $resultset->next()) {
561 foreach my $column (@columns) {
562 push( @fields, $row->get_column($column) );
564 push @data, [@fields];
572 print "Are you sure you want to do this? (type YES to confirm) \n";
573 # mainly here for testing
574 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
575 my $response = <STDIN>;
576 return 1 if ($response=~/^YES/);
581 my ($self, $cfg, $stanza) = @_;
582 my @path = split /::/, $stanza;
583 while (my $path = shift @path) {
584 if (exists $cfg->{$path}) {
585 $cfg = $cfg->{$path};
588 $self->throw_exception("could not find $stanza in config, $path did not seem to exist");
596 See L<DBIx::Class/CONTRIBUTORS>.
600 You may distribute this code under the same terms as Perl itself