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 @INC = (@include_dirs, @INC);
94 Class::MOP::load_class($self->schema_class);
99 $self->connect_info->[3]{ignore_version} = 1;
100 return $self->schema_class->connect(@{$self->connect_info});
105 Extra include directories to look when loading C<schema_class>
109 has 'include_dirs' => (
117 a resultset from the schema to operate on
129 a hash ref or json string to be used for identifying data to manipulate
142 a hash ref or json string to be used for inserting or updating data
155 a hash ref or json string to be used for passing additonal info to the ->search call
168 connect_info the arguments to provide to the connect call of the schema_class
172 has 'connect_info' => (
174 isa => DBICConnectInfo,
179 sub _build_connect_info {
181 return $self->_find_stanza($self->config, $self->config_stanza);
187 config_file provide a config_file to read connect_info from, if this is provided
188 config_stanze should also be provided to locate where the connect_info is in the config
189 The config file should be in a format readable by Config::General
202 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
203 designed for use with catalyst config files
207 has 'config_stanza' => (
215 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
216 config_stanza will still be required.
229 try { require Config::Any }
230 catch { die ("Config::Any is required to parse the config file.\n") };
232 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
234 # just grab the config from the config file
235 $cfg = $cfg->{$self->config_file};
242 The location where sql ddl files should be created or found for an upgrade.
255 Used for install, the version which will be 'installed' in the schema
267 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
279 Try and force certain operations.
291 Be less verbose about actions
312 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
316 L<create> will generate sql for the supplied schema_class in sql_dir. The
317 flavour of sql to generate can be controlled by supplying a sqlt_type which
318 should be a L<SQL::Translator> name.
320 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
322 Optional preversion can be supplied to generate a diff to be used by upgrade.
327 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
329 $preversion ||= $self->preversion();
331 my $schema = $self->schema();
332 # create the dir if does not exist
333 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
335 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
343 =item Arguments: <none>
347 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
348 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
354 my $schema = $self->schema();
356 if (!$schema->get_db_version()) {
357 # schema is unversioned
358 $schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
360 $schema->upgrade_directory ($self->sql_dir) if $self->sql_dir; # this will override whatever default the schema has
361 my $ret = $schema->upgrade();
371 =item Arguments: $version
375 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
376 database. install will take a version and add the version tracking tables and 'install' the version. No
377 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
378 already versioned databases.
383 my ($self, $version) = @_;
385 my $schema = $self->schema();
386 $version ||= $self->version();
387 if (!$schema->get_db_version() ) {
388 # schema is unversioned
389 print "Going to install schema version\n" if (!$self->quiet);
390 my $ret = $schema->install($version);
391 print "return is $ret\n" if (!$self->quiet);
393 elsif ($schema->get_db_version() and $self->force ) {
394 carp "Forcing install may not be a good idea";
395 if($self->_confirm() ) {
396 $self->schema->_set_db_version({ version => $version});
400 $schema->throw_exception ("Schema already has a version. Try upgrade instead.\n");
410 =item Arguments: $args
414 deploy will create the schema at the connected database. C<$args> are passed straight to
415 L<DBIx::Class::Schema/deploy>.
420 my ($self, $args) = @_;
421 my $schema = $self->schema();
422 $schema->deploy( $args, $self->sql_dir );
429 =item Arguments: $rs, $set
433 insert takes the name of a resultset from the schema_class and a hashref of data to insert
439 my ($self, $rs, $set) = @_;
441 $rs ||= $self->resultset();
442 $set ||= $self->set();
443 my $resultset = $self->schema->resultset($rs);
444 my $obj = $resultset->create( $set );
445 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
453 =item Arguments: $rs, $set, $where
457 update takes the name of a resultset from the schema_class, a hashref of data to update and
458 a where hash used to form the search for the rows to update.
463 my ($self, $rs, $set, $where) = @_;
465 $rs ||= $self->resultset();
466 $where ||= $self->where();
467 $set ||= $self->set();
468 my $resultset = $self->schema->resultset($rs);
469 $resultset = $resultset->search( ($where||{}) );
471 my $count = $resultset->count();
472 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
474 if ( $self->force || $self->_confirm() ) {
475 $resultset->update_all( $set );
484 =item Arguments: $rs, $where, $attrs
488 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
489 The found data is deleted and cannot be recovered.
494 my ($self, $rs, $where, $attrs) = @_;
496 $rs ||= $self->resultset();
497 $where ||= $self->where();
498 $attrs ||= $self->attrs();
499 my $resultset = $self->schema->resultset($rs);
500 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
502 my $count = $resultset->count();
503 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
505 if ( $self->force || $self->_confirm() ) {
506 $resultset->delete_all();
515 =item Arguments: $rs, $where, $attrs
519 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
520 The found data is returned in a array ref where the first row will be the columns list.
525 my ($self, $rs, $where, $attrs) = @_;
527 $rs ||= $self->resultset();
528 $where ||= $self->where();
529 $attrs ||= $self->attrs();
530 my $resultset = $self->schema->resultset($rs);
531 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
534 my @columns = $resultset->result_source->columns();
535 push @data, [@columns];#
537 while (my $row = $resultset->next()) {
539 foreach my $column (@columns) {
540 push( @fields, $row->get_column($column) );
542 push @data, [@fields];
551 # mainly here for testing
552 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
554 print "Are you sure you want to do this? (type YES to confirm) \n";
555 my $response = <STDIN>;
557 return ($response=~/^YES/);
561 my ($self, $cfg, $stanza) = @_;
562 my @path = split /::/, $stanza;
563 while (my $path = shift @path) {
564 if (exists $cfg->{$path}) {
565 $cfg = $cfg->{$path};
568 die ("Could not find $stanza in config, $path does not seem to exist.\n");
576 See L<DBIx::Class/CONTRIBUTORS>.
580 You may distribute this code under the same terms as Perl itself