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);
34 use namespace::autoclean;
39 DBIx::Class::Admin - Administration object for schemas
45 $ dbicadmin --schema=MyApp::Schema \
46 --connect='["dbi:SQLite:my.db", "", ""]' \
49 $ dbicadmin --schema=MyApp::Schema --class=Employee \
50 --connect='["dbi:SQLite:my.db", "", ""]' \
51 --op=update --set='{"name":"New_Employee"}'
53 use DBIx::Class::Admin;
56 my $admin = DBIx::Class::Admin->new(
57 schema_class=> 'MY::Schema',
59 connect_info => { dsn => $dsn, user => $user, password => $pass },
63 $admin->create('SQLite');
65 # create SQL diff for an upgrade
66 $admin->create('SQLite', {} , "1.0");
71 # install a version for an unversioned schema
72 $admin->install("3.0");
76 The following CPAN modules are required to use C<dbicadmin> and this module:
82 L<MooseX::Types::JSON>
84 L<MooseX::Types::Path::Class>
92 L<namespace::autoclean>
94 L<Getopt::Long::Descriptive>
102 the class of the schema to load
106 has 'schema_class' => (
114 A pre-connected schema object can be provided for manipulation
120 isa => 'DBIx::Class::Schema',
126 $self->ensure_class_loaded($self->schema_class);
128 $self->connect_info->[3]->{ignore_version} =1;
129 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
135 a resultset from the schema to operate on
147 a hash ref or json string to be used for identifying data to manipulate
160 a hash ref or json string to be used for inserting or updating data
173 a hash ref or json string to be used for passing additonal info to the ->search call
186 connect_info the arguments to provide to the connect call of the schema_class
190 has 'connect_info' => (
192 isa => DBICConnectInfo,
197 sub _build_connect_info {
199 return $self->_find_stanza($self->config, $self->config_stanza);
205 config_file provide a config_file to read connect_info from, if this is provided
206 config_stanze should also be provided to locate where the connect_info is in the config
207 The config file should be in a format readable by Config::General
220 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
221 designed for use with catalyst config files
225 has 'config_stanza' => (
233 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
234 config_stanza will still be required.
246 try { require Config::Any } catch { $self->throw_exception( "Config::Any is required to parse the config file"); };
248 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
250 # just grab the config from the config file
251 $cfg = $cfg->{$self->config_file};
258 The location where sql ddl files should be created or found for an upgrade.
271 Used for install, the version which will be 'installed' in the schema
283 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
295 Try and force certain operations.
307 Be less verbose about actions
328 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
332 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
333 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
335 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
337 Optional preversion can be supplied to generate a diff to be used by upgrade.
342 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
344 $preversion ||= $self->preversion();
346 my $schema = $self->schema();
347 # create the dir if does not exist
348 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
350 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
358 =item Arguments: <none>
362 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
363 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
369 my $schema = $self->schema();
370 if (!$schema->get_db_version()) {
371 # schema is unversioned
372 $self->throw_exception ("could not determin current schema version, please either install or deploy");
374 my $ret = $schema->upgrade();
384 =item Arguments: $version
388 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
389 database. install will take a version and add the version tracking tables and 'install' the version. No
390 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
391 already versioned databases.
396 my ($self, $version) = @_;
398 my $schema = $self->schema();
399 $version ||= $self->version();
400 if (!$schema->get_db_version() ) {
401 # schema is unversioned
402 print "Going to install schema version\n";
403 my $ret = $schema->install($version);
404 print "retun is $ret\n";
406 elsif ($schema->get_db_version() and $self->force ) {
407 carp "Forcing install may not be a good idea";
408 if($self->_confirm() ) {
409 $self->schema->_set_db_version({ version => $version});
413 $self->throw_exception ("schema already has a version not installing, try upgrade instead");
423 =item Arguments: $args
427 deploy will create the schema at the connected database. C<$args> are passed straight to
428 L<DBIx::Class::Schema/deploy>.
433 my ($self, $args) = @_;
434 my $schema = $self->schema();
435 if (!$schema->get_db_version() ) {
436 # schema is unversioned
437 $schema->deploy( $args, $self->sql_dir)
438 or $self->throw_exception ("could not deploy schema");
440 $self->throw_exception("there already is a database with a version here, try upgrade instead");
448 =item Arguments: $rs, $set
452 insert takes the name of a resultset from the schema_class and a hashref of data to insert
458 my ($self, $rs, $set) = @_;
460 $rs ||= $self->resultset();
461 $set ||= $self->set();
462 my $resultset = $self->schema->resultset($rs);
463 my $obj = $resultset->create( $set );
464 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
472 =item Arguments: $rs, $set, $where
476 update takes the name of a resultset from the schema_class, a hashref of data to update and
477 a where hash used to form the search for the rows to update.
482 my ($self, $rs, $set, $where) = @_;
484 $rs ||= $self->resultset();
485 $where ||= $self->where();
486 $set ||= $self->set();
487 my $resultset = $self->schema->resultset($rs);
488 $resultset = $resultset->search( ($where||{}) );
490 my $count = $resultset->count();
491 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
493 if ( $self->force || $self->_confirm() ) {
494 $resultset->update_all( $set );
503 =item Arguments: $rs, $where, $attrs
507 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
508 The found data is deleted and cannot be recovered.
513 my ($self, $rs, $where, $attrs) = @_;
515 $rs ||= $self->resultset();
516 $where ||= $self->where();
517 $attrs ||= $self->attrs();
518 my $resultset = $self->schema->resultset($rs);
519 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
521 my $count = $resultset->count();
522 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
524 if ( $self->force || $self->_confirm() ) {
525 $resultset->delete_all();
534 =item Arguments: $rs, $where, $attrs
538 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
539 The found data is returned in a array ref where the first row will be the columns list.
544 my ($self, $rs, $where, $attrs) = @_;
546 $rs ||= $self->resultset();
547 $where ||= $self->where();
548 $attrs ||= $self->attrs();
549 my $resultset = $self->schema->resultset($rs);
550 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
553 my @columns = $resultset->result_source->columns();
554 push @data, [@columns];#
556 while (my $row = $resultset->next()) {
558 foreach my $column (@columns) {
559 push( @fields, $row->get_column($column) );
561 push @data, [@fields];
569 print "Are you sure you want to do this? (type YES to confirm) \n";
570 # mainly here for testing
571 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
572 my $response = <STDIN>;
573 return 1 if ($response=~/^YES/);
578 my ($self, $cfg, $stanza) = @_;
579 my @path = split /::/, $stanza;
580 while (my $path = shift @path) {
581 if (exists $cfg->{$path}) {
582 $cfg = $cfg->{$path};
585 $self->throw_exception("could not find $stanza in config, $path did not seem to exist");
593 See L<DBIx::Class/CONTRIBUTORS>.
597 You may distribute this code under the same terms as Perl itself