1 package DBIx::Class::Admin;
6 die('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') )
7 unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin');
11 use MooseX::Types::Moose qw/Int Str Any Bool/;
12 use DBIx::Class::Admin::Types qw/DBICConnectInfo DBICHashRef/;
13 use MooseX::Types::JSON qw(JSON);
14 use MooseX::Types::Path::Class qw(Dir File);
16 use JSON::Any qw(DWIW XS JSON);
17 use namespace::autoclean;
21 DBIx::Class::Admin - Administration object for schemas
27 $ dbicadmin --schema=MyApp::Schema \
28 --connect='["dbi:SQLite:my.db", "", ""]' \
31 $ dbicadmin --schema=MyApp::Schema --class=Employee \
32 --connect='["dbi:SQLite:my.db", "", ""]' \
33 --op=update --set='{ "name": "New_Employee" }'
35 use DBIx::Class::Admin;
38 my $admin = DBIx::Class::Admin->new(
39 schema_class=> 'MY::Schema',
41 connect_info => { dsn => $dsn, user => $user, password => $pass },
45 $admin->create('SQLite');
47 # create SQL diff for an upgrade
48 $admin->create('SQLite', {} , "1.0");
53 # install a version for an unversioned schema
54 $admin->install("3.0");
58 The Admin interface has additional requirements not currently part of
59 L<DBIx::Class>. See L<DBIx::Class::Optional::Dependencies> for more details.
65 the class of the schema to load
69 has 'schema_class' => (
77 A pre-connected schema object can be provided for manipulation
83 isa => 'DBIx::Class::Schema',
91 Class::MOP::load_class($self->schema_class);
92 $self->connect_info->[3]{ignore_version} = 1;
93 return $self->schema_class->connect(@{$self->connect_info});
98 a resultset from the schema to operate on
110 a hash ref or json string to be used for identifying data to manipulate
123 a hash ref or json string to be used for inserting or updating data
136 a hash ref or json string to be used for passing additional info to the ->search call
149 connect_info the arguments to provide to the connect call of the schema_class
153 has 'connect_info' => (
155 isa => DBICConnectInfo,
160 sub _build_connect_info {
162 return $self->_find_stanza($self->config, $self->config_stanza);
168 config_file provide a config_file to read connect_info from, if this is provided
169 config_stanze should also be provided to locate where the connect_info is in the config
170 The config file should be in a format readable by Config::Any.
183 config_stanza for use with config_file should be a '::' delimited 'path' to the connection information
184 designed for use with catalyst config files
188 has 'config_stanza' => (
196 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
197 config_stanza will still be required.
210 try { require Config::Any }
211 catch { die ("Config::Any is required to parse the config file.\n") };
213 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
215 # just grab the config from the config file
216 $cfg = $cfg->{$self->config_file};
223 The location where sql ddl files should be created or found for an upgrade.
236 The type of sql dialect to use for creating sql files from schema
247 Used for install, the version which will be 'installed' in the schema
259 Previous 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
271 Try and force certain operations.
283 Be less verbose about actions
300 Toggle DBIx::Class debug output
307 trigger => \&_trigger_trace,
311 my ($self, $new, $old) = @_;
312 $self->schema->storage->debug($new);
322 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
326 C<create> will generate sql for the supplied schema_class in sql_dir. The
327 flavour of sql to generate can be controlled by supplying a sqlt_type which
328 should be a L<SQL::Translator> name.
330 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
332 Optional preversion can be supplied to generate a diff to be used by upgrade.
337 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
339 $preversion ||= $self->preversion();
340 $sqlt_type ||= $self->sql_type();
342 my $schema = $self->schema();
343 # create the dir if does not exist
344 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
346 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
354 =item Arguments: <none>
358 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
359 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
365 my $schema = $self->schema();
367 if (!$schema->get_db_version()) {
368 # schema is unversioned
369 $schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
371 $schema->upgrade_directory ($self->sql_dir) if $self->sql_dir; # this will override whatever default the schema has
372 my $ret = $schema->upgrade();
382 =item Arguments: $version
386 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
387 database. install will take a version and add the version tracking tables and 'install' the version. No
388 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
389 already versioned databases.
394 my ($self, $version) = @_;
396 my $schema = $self->schema();
397 $version ||= $self->version();
398 if (!$schema->get_db_version() ) {
399 # schema is unversioned
400 print "Going to install schema version\n" if (!$self->quiet);
401 my $ret = $schema->install($version);
402 print "return is $ret\n" if (!$self->quiet);
404 elsif ($schema->get_db_version() and $self->force ) {
405 warn "Forcing install may not be a good idea\n";
406 if($self->_confirm() ) {
407 $self->schema->_set_db_version({ version => $version});
411 $schema->throw_exception ("Schema already has a version. Try upgrade instead.\n");
421 =item Arguments: $args
425 deploy will create the schema at the connected database. C<$args> are passed straight to
426 L<DBIx::Class::Schema/deploy>.
431 my ($self, $args) = @_;
432 my $schema = $self->schema();
433 $schema->deploy( $args, $self->sql_dir );
440 =item Arguments: $rs, $set
444 insert takes the name of a resultset from the schema_class and a hashref of data to insert
450 my ($self, $rs, $set) = @_;
452 $rs ||= $self->resultset();
453 $set ||= $self->set();
454 my $resultset = $self->schema->resultset($rs);
455 my $obj = $resultset->create( $set );
456 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
464 =item Arguments: $rs, $set, $where
468 update takes the name of a resultset from the schema_class, a hashref of data to update and
469 a where hash used to form the search for the rows to update.
474 my ($self, $rs, $set, $where) = @_;
476 $rs ||= $self->resultset();
477 $where ||= $self->where();
478 $set ||= $self->set();
479 my $resultset = $self->schema->resultset($rs);
480 $resultset = $resultset->search( ($where||{}) );
482 my $count = $resultset->count();
483 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
485 if ( $self->force || $self->_confirm() ) {
486 $resultset->update_all( $set );
495 =item Arguments: $rs, $where, $attrs
499 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
500 The found data is deleted and cannot be recovered.
505 my ($self, $rs, $where, $attrs) = @_;
507 $rs ||= $self->resultset();
508 $where ||= $self->where();
509 $attrs ||= $self->attrs();
510 my $resultset = $self->schema->resultset($rs);
511 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
513 my $count = $resultset->count();
514 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
516 if ( $self->force || $self->_confirm() ) {
517 $resultset->delete_all();
526 =item Arguments: $rs, $where, $attrs
530 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
531 The found data is returned in a array ref where the first row will be the columns list.
536 my ($self, $rs, $where, $attrs) = @_;
538 $rs ||= $self->resultset();
539 $where ||= $self->where();
540 $attrs ||= $self->attrs();
541 my $resultset = $self->schema->resultset($rs);
542 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
545 my @columns = $resultset->result_source->columns();
546 push @data, [@columns];#
548 while (my $row = $resultset->next()) {
550 foreach my $column (@columns) {
551 push( @fields, $row->get_column($column) );
553 push @data, [@fields];
562 # mainly here for testing
563 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
565 print "Are you sure you want to do this? (type YES to confirm) \n";
566 my $response = <STDIN>;
568 return ($response=~/^YES/);
572 my ($self, $cfg, $stanza) = @_;
573 my @path = split /::/, $stanza;
574 while (my $path = shift @path) {
575 if (exists $cfg->{$path}) {
576 $cfg = $cfg->{$path};
579 die ("Could not find $stanza in config, $path does not seem to exist.\n");
582 $cfg = $cfg->{connect_info} if exists $cfg->{connect_info};
588 See L<DBIx::Class/CONTRIBUTORS>.
592 You may distribute this code under the same terms as Perl itself