1 package DBIx::Class::Admin;
5 use Carp::Clan qw/^DBIx::Class/;
7 croak('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') )
8 unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin');
12 use parent 'DBIx::Class::Schema';
14 use MooseX::Types::Moose qw/Int Str Any Bool/;
15 use DBIx::Class::Admin::Types qw/DBICConnectInfo DBICHashRef/;
16 use MooseX::Types::JSON qw(JSON);
17 use MooseX::Types::Path::Class qw(Dir File);
19 use JSON::Any qw(DWIW XS JSON);
20 use namespace::autoclean;
24 DBIx::Class::Admin - Administration object for schemas
30 $ dbicadmin --schema=MyApp::Schema \
31 --connect='["dbi:SQLite:my.db", "", ""]' \
34 $ dbicadmin --schema=MyApp::Schema --class=Employee \
35 --connect='["dbi:SQLite:my.db", "", ""]' \
36 --op=update --set='{ "name": "New_Employee" }'
38 use DBIx::Class::Admin;
41 my $admin = DBIx::Class::Admin->new(
42 schema_class=> 'MY::Schema',
44 connect_info => { dsn => $dsn, user => $user, password => $pass },
48 $admin->create('SQLite');
50 # create SQL diff for an upgrade
51 $admin->create('SQLite', {} , "1.0");
56 # install a version for an unversioned schema
57 $admin->install("3.0");
61 The Admin interface has additional requirements not currently part of
62 L<DBIx::Class>. See L<DBIx::Class::Optional::Dependencies> for more details.
68 the class of the schema to load
72 has 'schema_class' => (
80 A pre-connected schema object can be provided for manipulation
86 isa => 'DBIx::Class::Schema',
92 $self->ensure_class_loaded($self->schema_class);
94 $self->connect_info->[3]->{ignore_version} =1;
95 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
101 a resultset from the schema to operate on
113 a hash ref or json string to be used for identifying data to manipulate
126 a hash ref or json string to be used for inserting or updating data
139 a hash ref or json string to be used for passing additonal info to the ->search call
152 connect_info the arguments to provide to the connect call of the schema_class
156 has 'connect_info' => (
158 isa => DBICConnectInfo,
163 sub _build_connect_info {
165 return $self->_find_stanza($self->config, $self->config_stanza);
171 config_file provide a config_file to read connect_info from, if this is provided
172 config_stanze should also be provided to locate where the connect_info is in the config
173 The config file should be in a format readable by Config::General
186 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
187 designed for use with catalyst config files
191 has 'config_stanza' => (
199 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
200 config_stanza will still be required.
213 eval { require Config::Any }
214 or $self->throw_exception( "Config::Any is required to parse the config file");
216 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
218 # just grab the config from the config file
219 $cfg = $cfg->{$self->config_file};
226 The location where sql ddl files should be created or found for an upgrade.
239 Used for install, the version which will be 'installed' in the schema
251 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
263 Try and force certain operations.
275 Be less verbose about actions
296 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
300 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
301 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
303 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
305 Optional preversion can be supplied to generate a diff to be used by upgrade.
310 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
312 $preversion ||= $self->preversion();
314 my $schema = $self->schema();
315 # create the dir if does not exist
316 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
318 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
326 =item Arguments: <none>
330 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
331 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
337 my $schema = $self->schema();
338 if (!$schema->get_db_version()) {
339 # schema is unversioned
340 $self->throw_exception ("could not determin current schema version, please either install or deploy");
342 my $ret = $schema->upgrade();
352 =item Arguments: $version
356 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
357 database. install will take a version and add the version tracking tables and 'install' the version. No
358 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
359 already versioned databases.
364 my ($self, $version) = @_;
366 my $schema = $self->schema();
367 $version ||= $self->version();
368 if (!$schema->get_db_version() ) {
369 # schema is unversioned
370 print "Going to install schema version\n";
371 my $ret = $schema->install($version);
372 print "retun is $ret\n";
374 elsif ($schema->get_db_version() and $self->force ) {
375 carp "Forcing install may not be a good idea";
376 if($self->_confirm() ) {
377 $self->schema->_set_db_version({ version => $version});
381 $self->throw_exception ("schema already has a version not installing, try upgrade instead");
391 =item Arguments: $args
395 deploy will create the schema at the connected database. C<$args> are passed straight to
396 L<DBIx::Class::Schema/deploy>.
401 my ($self, $args) = @_;
402 my $schema = $self->schema();
403 if (!$schema->get_db_version() ) {
404 # schema is unversioned
405 $schema->deploy( $args, $self->sql_dir)
406 or $self->throw_exception ("could not deploy schema");
408 $self->throw_exception("there already is a database with a version here, try upgrade instead");
416 =item Arguments: $rs, $set
420 insert takes the name of a resultset from the schema_class and a hashref of data to insert
426 my ($self, $rs, $set) = @_;
428 $rs ||= $self->resultset();
429 $set ||= $self->set();
430 my $resultset = $self->schema->resultset($rs);
431 my $obj = $resultset->create( $set );
432 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
440 =item Arguments: $rs, $set, $where
444 update takes the name of a resultset from the schema_class, a hashref of data to update and
445 a where hash used to form the search for the rows to update.
450 my ($self, $rs, $set, $where) = @_;
452 $rs ||= $self->resultset();
453 $where ||= $self->where();
454 $set ||= $self->set();
455 my $resultset = $self->schema->resultset($rs);
456 $resultset = $resultset->search( ($where||{}) );
458 my $count = $resultset->count();
459 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
461 if ( $self->force || $self->_confirm() ) {
462 $resultset->update_all( $set );
471 =item Arguments: $rs, $where, $attrs
475 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
476 The found data is deleted and cannot be recovered.
481 my ($self, $rs, $where, $attrs) = @_;
483 $rs ||= $self->resultset();
484 $where ||= $self->where();
485 $attrs ||= $self->attrs();
486 my $resultset = $self->schema->resultset($rs);
487 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
489 my $count = $resultset->count();
490 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
492 if ( $self->force || $self->_confirm() ) {
493 $resultset->delete_all();
502 =item Arguments: $rs, $where, $attrs
506 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
507 The found data is returned in a array ref where the first row will be the columns list.
512 my ($self, $rs, $where, $attrs) = @_;
514 $rs ||= $self->resultset();
515 $where ||= $self->where();
516 $attrs ||= $self->attrs();
517 my $resultset = $self->schema->resultset($rs);
518 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
521 my @columns = $resultset->result_source->columns();
522 push @data, [@columns];#
524 while (my $row = $resultset->next()) {
526 foreach my $column (@columns) {
527 push( @fields, $row->get_column($column) );
529 push @data, [@fields];
537 print "Are you sure you want to do this? (type YES to confirm) \n";
538 # mainly here for testing
539 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
540 my $response = <STDIN>;
541 return 1 if ($response=~/^YES/);
546 my ($self, $cfg, $stanza) = @_;
547 my @path = split /::/, $stanza;
548 while (my $path = shift @path) {
549 if (exists $cfg->{$path}) {
550 $cfg = $cfg->{$path};
553 $self->throw_exception("could not find $stanza in config, $path did not seem to exist");
561 See L<DBIx::Class/CONTRIBUTORS>.
565 You may distribute this code under the same terms as Perl itself