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);
15 use MooseX::Types::LoadableClass qw(LoadableClass);
17 use JSON::Any qw(DWIW XS JSON);
18 use namespace::autoclean;
22 DBIx::Class::Admin - Administration object for schemas
28 $ dbicadmin --schema=MyApp::Schema \
29 --connect='["dbi:SQLite:my.db", "", ""]' \
32 $ dbicadmin --schema=MyApp::Schema --class=Employee \
33 --connect='["dbi:SQLite:my.db", "", ""]' \
34 --op=update --set='{ "name": "New_Employee" }'
36 use DBIx::Class::Admin;
39 my $admin = DBIx::Class::Admin->new(
40 schema_class=> 'MY::Schema',
42 connect_info => { dsn => $dsn, user => $user, password => $pass },
46 $admin->create('SQLite');
48 # create SQL diff for an upgrade
49 $admin->create('SQLite', {} , "1.0");
54 # install a version for an unversioned schema
55 $admin->install("3.0");
59 The Admin interface has additional requirements not currently part of
60 L<DBIx::Class>. See L<DBIx::Class::Optional::Dependencies> for more details.
66 the class of the schema to load
70 has 'schema_class' => (
78 A pre-connected schema object can be provided for manipulation
84 isa => 'DBIx::Class::Schema',
91 $self->connect_info->[3]{ignore_version} = 1;
92 return $self->schema_class->connect(@{$self->connect_info});
97 a resultset from the schema to operate on
109 a hash ref or json string to be used for identifying data to manipulate
122 a hash ref or json string to be used for inserting or updating data
135 a hash ref or json string to be used for passing additional info to the ->search call
148 connect_info the arguments to provide to the connect call of the schema_class
152 has 'connect_info' => (
154 isa => DBICConnectInfo,
159 sub _build_connect_info {
161 return $self->_find_stanza($self->config, $self->config_stanza);
167 config_file provide a config_file to read connect_info from, if this is provided
168 config_stanze should also be provided to locate where the connect_info is in the config
169 The config file should be in a format readable by Config::Any.
182 config_stanza for use with config_file should be a '::' delimited 'path' to the connection information
183 designed for use with catalyst config files
187 has 'config_stanza' => (
195 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
196 config_stanza will still be required.
209 try { require Config::Any }
210 catch { die ("Config::Any is required to parse the config file.\n") };
212 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
214 # just grab the config from the config file
215 $cfg = $cfg->{$self->config_file};
222 The location where sql ddl files should be created or found for an upgrade.
235 The type of sql dialect to use for creating sql files from schema
246 Used for install, the version which will be 'installed' in the schema
258 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
270 Try and force certain operations.
282 Be less verbose about actions
299 Toggle DBIx::Class debug output
306 trigger => \&_trigger_trace,
310 my ($self, $new, $old) = @_;
311 $self->schema->storage->debug($new);
321 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
325 C<create> will generate sql for the supplied schema_class in sql_dir. The
326 flavour of sql to generate can be controlled by supplying a sqlt_type which
327 should be a L<SQL::Translator> name.
329 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
331 Optional preversion can be supplied to generate a diff to be used by upgrade.
336 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
338 $preversion ||= $self->preversion();
339 $sqlt_type ||= $self->sql_type();
341 my $schema = $self->schema();
342 # create the dir if does not exist
343 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
345 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
353 =item Arguments: <none>
357 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
358 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
364 my $schema = $self->schema();
366 if (!$schema->get_db_version()) {
367 # schema is unversioned
368 $schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
370 $schema->upgrade_directory ($self->sql_dir) if $self->sql_dir; # this will override whatever default the schema has
371 my $ret = $schema->upgrade();
381 =item Arguments: $version
385 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
386 database. install will take a version and add the version tracking tables and 'install' the version. No
387 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
388 already versioned databases.
393 my ($self, $version) = @_;
395 my $schema = $self->schema();
396 $version ||= $self->version();
397 if (!$schema->get_db_version() ) {
398 # schema is unversioned
399 print "Going to install schema version\n" if (!$self->quiet);
400 my $ret = $schema->install($version);
401 print "return is $ret\n" if (!$self->quiet);
403 elsif ($schema->get_db_version() and $self->force ) {
404 warn "Forcing install may not be a good idea\n";
405 if($self->_confirm() ) {
406 $self->schema->_set_db_version({ version => $version});
410 $schema->throw_exception ("Schema already has a version. Try upgrade instead.\n");
420 =item Arguments: $args
424 deploy will create the schema at the connected database. C<$args> are passed straight to
425 L<DBIx::Class::Schema/deploy>.
430 my ($self, $args) = @_;
431 my $schema = $self->schema();
432 $schema->deploy( $args, $self->sql_dir );
439 =item Arguments: $rs, $set
443 insert takes the name of a resultset from the schema_class and a hashref of data to insert
449 my ($self, $rs, $set) = @_;
451 $rs ||= $self->resultset();
452 $set ||= $self->set();
453 my $resultset = $self->schema->resultset($rs);
454 my $obj = $resultset->create( $set );
455 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
463 =item Arguments: $rs, $set, $where
467 update takes the name of a resultset from the schema_class, a hashref of data to update and
468 a where hash used to form the search for the rows to update.
473 my ($self, $rs, $set, $where) = @_;
475 $rs ||= $self->resultset();
476 $where ||= $self->where();
477 $set ||= $self->set();
478 my $resultset = $self->schema->resultset($rs);
479 $resultset = $resultset->search( ($where||{}) );
481 my $count = $resultset->count();
482 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
484 if ( $self->force || $self->_confirm() ) {
485 $resultset->update_all( $set );
494 =item Arguments: $rs, $where, $attrs
498 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
499 The found data is deleted and cannot be recovered.
504 my ($self, $rs, $where, $attrs) = @_;
506 $rs ||= $self->resultset();
507 $where ||= $self->where();
508 $attrs ||= $self->attrs();
509 my $resultset = $self->schema->resultset($rs);
510 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
512 my $count = $resultset->count();
513 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
515 if ( $self->force || $self->_confirm() ) {
516 $resultset->delete_all();
525 =item Arguments: $rs, $where, $attrs
529 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
530 The found data is returned in a array ref where the first row will be the columns list.
535 my ($self, $rs, $where, $attrs) = @_;
537 $rs ||= $self->resultset();
538 $where ||= $self->where();
539 $attrs ||= $self->attrs();
540 my $resultset = $self->schema->resultset($rs);
541 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
544 my @columns = $resultset->result_source->columns();
545 push @data, [@columns];#
547 while (my $row = $resultset->next()) {
549 foreach my $column (@columns) {
550 push( @fields, $row->get_column($column) );
552 push @data, [@fields];
561 # mainly here for testing
562 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
564 print "Are you sure you want to do this? (type YES to confirm) \n";
565 my $response = <STDIN>;
567 return ($response=~/^YES/);
571 my ($self, $cfg, $stanza) = @_;
572 my @path = split /::/, $stanza;
573 while (my $path = shift @path) {
574 if (exists $cfg->{$path}) {
575 $cfg = $cfg->{$path};
578 die ("Could not find $stanza in config, $path does not seem to exist.\n");
581 $cfg = $cfg->{connect_info} if exists $cfg->{connect_info};
587 See L<DBIx::Class/CONTRIBUTORS>.
591 You may distribute this code under the same terms as Perl itself