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 local @INC = (@{$self->include_dirs}, @INC);
93 Class::MOP::load_class($self->schema_class);
95 $self->connect_info->[3]->{ignore_version} =1;
96 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
101 Extra include directories to look when loading C<schema_class>
105 has 'include_dirs' => (
113 a resultset from the schema to operate on
125 a hash ref or json string to be used for identifying data to manipulate
138 a hash ref or json string to be used for inserting or updating data
151 a hash ref or json string to be used for passing additonal info to the ->search call
164 connect_info the arguments to provide to the connect call of the schema_class
168 has 'connect_info' => (
170 isa => DBICConnectInfo,
175 sub _build_connect_info {
177 return $self->_find_stanza($self->config, $self->config_stanza);
183 config_file provide a config_file to read connect_info from, if this is provided
184 config_stanze should also be provided to locate where the connect_info is in the config
185 The config file should be in a format readable by Config::General
198 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
199 designed for use with catalyst config files
203 has 'config_stanza' => (
211 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
212 config_stanza will still be required.
225 eval { require Config::Any }
226 or die ("Config::Any is required to parse the config file.\n");
228 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
230 # just grab the config from the config file
231 $cfg = $cfg->{$self->config_file};
238 The location where sql ddl files should be created or found for an upgrade.
251 Used for install, the version which will be 'installed' in the schema
263 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
275 Try and force certain operations.
287 Be less verbose about actions
308 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
312 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
313 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
315 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
317 Optional preversion can be supplied to generate a diff to be used by upgrade.
322 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
324 $preversion ||= $self->preversion();
326 my $schema = $self->schema();
327 # create the dir if does not exist
328 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
330 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
338 =item Arguments: <none>
342 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
343 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
349 my $schema = $self->schema();
350 if (!$schema->get_db_version()) {
351 # schema is unversioned
352 $schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
354 my $ret = $schema->upgrade();
364 =item Arguments: $version
368 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
369 database. install will take a version and add the version tracking tables and 'install' the version. No
370 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
371 already versioned databases.
376 my ($self, $version) = @_;
378 my $schema = $self->schema();
379 $version ||= $self->version();
380 if (!$schema->get_db_version() ) {
381 # schema is unversioned
382 print "Going to install schema version\n";
383 my $ret = $schema->install($version);
384 print "retun is $ret\n";
386 elsif ($schema->get_db_version() and $self->force ) {
387 carp "Forcing install may not be a good idea";
388 if($self->_confirm() ) {
389 $self->schema->_set_db_version({ version => $version});
393 $schema->throw_exception ("Schema already has a version. Try upgrade instead.\n");
403 =item Arguments: $args
407 deploy will create the schema at the connected database. C<$args> are passed straight to
408 L<DBIx::Class::Schema/deploy>.
413 my ($self, $args) = @_;
414 my $schema = $self->schema();
415 $schema->deploy( $args, $self->sql_dir );
422 =item Arguments: $rs, $set
426 insert takes the name of a resultset from the schema_class and a hashref of data to insert
432 my ($self, $rs, $set) = @_;
434 $rs ||= $self->resultset();
435 $set ||= $self->set();
436 my $resultset = $self->schema->resultset($rs);
437 my $obj = $resultset->create( $set );
438 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
446 =item Arguments: $rs, $set, $where
450 update takes the name of a resultset from the schema_class, a hashref of data to update and
451 a where hash used to form the search for the rows to update.
456 my ($self, $rs, $set, $where) = @_;
458 $rs ||= $self->resultset();
459 $where ||= $self->where();
460 $set ||= $self->set();
461 my $resultset = $self->schema->resultset($rs);
462 $resultset = $resultset->search( ($where||{}) );
464 my $count = $resultset->count();
465 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
467 if ( $self->force || $self->_confirm() ) {
468 $resultset->update_all( $set );
477 =item Arguments: $rs, $where, $attrs
481 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
482 The found data is deleted and cannot be recovered.
487 my ($self, $rs, $where, $attrs) = @_;
489 $rs ||= $self->resultset();
490 $where ||= $self->where();
491 $attrs ||= $self->attrs();
492 my $resultset = $self->schema->resultset($rs);
493 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
495 my $count = $resultset->count();
496 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
498 if ( $self->force || $self->_confirm() ) {
499 $resultset->delete_all();
508 =item Arguments: $rs, $where, $attrs
512 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
513 The found data is returned in a array ref where the first row will be the columns list.
518 my ($self, $rs, $where, $attrs) = @_;
520 $rs ||= $self->resultset();
521 $where ||= $self->where();
522 $attrs ||= $self->attrs();
523 my $resultset = $self->schema->resultset($rs);
524 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
527 my @columns = $resultset->result_source->columns();
528 push @data, [@columns];#
530 while (my $row = $resultset->next()) {
532 foreach my $column (@columns) {
533 push( @fields, $row->get_column($column) );
535 push @data, [@fields];
543 print "Are you sure you want to do this? (type YES to confirm) \n";
544 # mainly here for testing
545 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
546 my $response = <STDIN>;
547 return 1 if ($response=~/^YES/);
552 my ($self, $cfg, $stanza) = @_;
553 my @path = split /::/, $stanza;
554 while (my $path = shift @path) {
555 if (exists $cfg->{$path}) {
556 $cfg = $cfg->{$path};
559 die ("Could not find $stanza in config, $path does not seem to exist.\n");
567 See L<DBIx::Class/CONTRIBUTORS>.
571 You may distribute this code under the same terms as Perl itself