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 MooseX::Types::Moose qw/Int Str Any Bool/;
13 use DBIx::Class::Admin::Types qw/DBICConnectInfo DBICHashRef/;
14 use MooseX::Types::JSON qw(JSON);
15 use MooseX::Types::Path::Class qw(Dir File);
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',
92 my @include_dirs = @{$self->include_dirs};
93 local @INC = (@include_dirs, @INC);
94 Class::MOP::load_class($self->schema_class);
96 $self->connect_info->[3]->{ignore_version} =1;
97 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
102 Extra include directories to look when loading C<schema_class>
106 has 'include_dirs' => (
114 a resultset from the schema to operate on
126 a hash ref or json string to be used for identifying data to manipulate
139 a hash ref or json string to be used for inserting or updating data
152 a hash ref or json string to be used for passing additonal info to the ->search call
165 connect_info the arguments to provide to the connect call of the schema_class
169 has 'connect_info' => (
171 isa => DBICConnectInfo,
176 sub _build_connect_info {
178 return $self->_find_stanza($self->config, $self->config_stanza);
184 config_file provide a config_file to read connect_info from, if this is provided
185 config_stanze should also be provided to locate where the connect_info is in the config
186 The config file should be in a format readable by Config::General
199 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
200 designed for use with catalyst config files
204 has 'config_stanza' => (
212 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
213 config_stanza will still be required.
226 try { require Config::Any }
227 catch { die ("Config::Any is required to parse the config file.\n") };
229 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
231 # just grab the config from the config file
232 $cfg = $cfg->{$self->config_file};
239 The location where sql ddl files should be created or found for an upgrade.
252 Used for install, the version which will be 'installed' in the schema
264 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
276 Try and force certain operations.
288 Be less verbose about actions
309 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
313 L<create> will generate sql for the supplied schema_class in sql_dir. The
314 flavour of sql to generate can be controlled by supplying a sqlt_type which
315 should be a L<SQL::Translator> name.
317 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
319 Optional preversion can be supplied to generate a diff to be used by upgrade.
324 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
326 $preversion ||= $self->preversion();
328 my $schema = $self->schema();
329 # create the dir if does not exist
330 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
332 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
340 =item Arguments: <none>
344 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
345 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
351 my $schema = $self->schema();
353 if (!$schema->get_db_version()) {
354 # schema is unversioned
355 $schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
357 $schema->upgrade_directory ($self->sql_dir) if $self->sql_dir; # this will override whatever default the schema has
358 my $ret = $schema->upgrade();
368 =item Arguments: $version
372 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
373 database. install will take a version and add the version tracking tables and 'install' the version. No
374 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
375 already versioned databases.
380 my ($self, $version) = @_;
382 my $schema = $self->schema();
383 $version ||= $self->version();
384 if (!$schema->get_db_version() ) {
385 # schema is unversioned
386 print "Going to install schema version\n" if (!$self->quiet);
387 my $ret = $schema->install($version);
388 print "return is $ret\n" if (!$self->quiet);
390 elsif ($schema->get_db_version() and $self->force ) {
391 carp "Forcing install may not be a good idea";
392 if($self->_confirm() ) {
393 $self->schema->_set_db_version({ version => $version});
397 $schema->throw_exception ("Schema already has a version. Try upgrade instead.\n");
407 =item Arguments: $args
411 deploy will create the schema at the connected database. C<$args> are passed straight to
412 L<DBIx::Class::Schema/deploy>.
417 my ($self, $args) = @_;
418 my $schema = $self->schema();
419 $schema->deploy( $args, $self->sql_dir );
426 =item Arguments: $rs, $set
430 insert takes the name of a resultset from the schema_class and a hashref of data to insert
436 my ($self, $rs, $set) = @_;
438 $rs ||= $self->resultset();
439 $set ||= $self->set();
440 my $resultset = $self->schema->resultset($rs);
441 my $obj = $resultset->create( $set );
442 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
450 =item Arguments: $rs, $set, $where
454 update takes the name of a resultset from the schema_class, a hashref of data to update and
455 a where hash used to form the search for the rows to update.
460 my ($self, $rs, $set, $where) = @_;
462 $rs ||= $self->resultset();
463 $where ||= $self->where();
464 $set ||= $self->set();
465 my $resultset = $self->schema->resultset($rs);
466 $resultset = $resultset->search( ($where||{}) );
468 my $count = $resultset->count();
469 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
471 if ( $self->force || $self->_confirm() ) {
472 $resultset->update_all( $set );
481 =item Arguments: $rs, $where, $attrs
485 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
486 The found data is deleted and cannot be recovered.
491 my ($self, $rs, $where, $attrs) = @_;
493 $rs ||= $self->resultset();
494 $where ||= $self->where();
495 $attrs ||= $self->attrs();
496 my $resultset = $self->schema->resultset($rs);
497 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
499 my $count = $resultset->count();
500 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
502 if ( $self->force || $self->_confirm() ) {
503 $resultset->delete_all();
512 =item Arguments: $rs, $where, $attrs
516 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
517 The found data is returned in a array ref where the first row will be the columns list.
522 my ($self, $rs, $where, $attrs) = @_;
524 $rs ||= $self->resultset();
525 $where ||= $self->where();
526 $attrs ||= $self->attrs();
527 my $resultset = $self->schema->resultset($rs);
528 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
531 my @columns = $resultset->result_source->columns();
532 push @data, [@columns];#
534 while (my $row = $resultset->next()) {
536 foreach my $column (@columns) {
537 push( @fields, $row->get_column($column) );
539 push @data, [@fields];
548 # mainly here for testing
549 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
551 print "Are you sure you want to do this? (type YES to confirm) \n";
552 my $response = <STDIN>;
554 return ($response=~/^YES/);
558 my ($self, $cfg, $stanza) = @_;
559 my @path = split /::/, $stanza;
560 while (my $path = shift @path) {
561 if (exists $cfg->{$path}) {
562 $cfg = $cfg->{$path};
565 die ("Could not find $stanza in config, $path does not seem to exist.\n");
573 See L<DBIx::Class/CONTRIBUTORS>.
577 You may distribute this code under the same terms as Perl itself