1 package DBIx::Class::Admin;
4 use MooseX::Types -declare => [qw( DBICConnectInfo )];
5 use MooseX::Types::Moose qw/Int HashRef ArrayRef Str Any/;
6 use MooseX::Types::JSON qw(JSON);
7 use MooseX::Types::Path::Class qw(Dir File);
10 use Carp::Clan qw/^DBIx::Class/;
12 use parent 'Class::C3::Componentised';
13 use parent 'DBIx::Class::Schema';
17 use namespace::autoclean;
19 my @_deps = qw(Moose MooseX::Types MooseX::Types::JSON MooseX::Types::Path::Class Try::Tiny parent JSON::Any Class::C3::Componentised namespace::autoclean);
23 via { _json_to_data ($_) };
27 via { _json_to_data($_) };
29 subtype DBICConnectInfo,
32 coerce DBICConnectInfo,
34 via { return _json_to_data($_) } ;
36 coerce DBICConnectInfo,
38 via { return _json_to_data($_) };
40 coerce DBICConnectInfo,
42 via { [ $_->{dsn}, $_->{user}, $_->{password} ] };
47 DBIx::Class::Admin - Administration object for schemas
51 use DBIx::Class::Admin;
54 my $admin = DBIx::Class::Admin->new(
55 schema_class=> 'MY::Schema',
57 connect_info => { dsn => $dsn, user => $user, password => $pass },
61 $admin->create('SQLite');
63 # create SQL diff for an upgrade
64 $admin->create('SQLite', {} , "1.0");
69 # install a version for an unversioned schema
70 $admin->install("3.0");
76 the class of the schema to load
80 has 'schema_class' => (
89 A pre-connected schema object can be provided for manipulation
95 isa => 'DBIx::Class::Schema',
101 $self->ensure_class_loaded($self->schema_class);
103 $self->connect_info->[3]->{ignore_version} =1;
104 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
110 a resultset from the schema to operate on
122 a hash ref or json string to be used for identifying data to manipulate
135 a hash ref or json string to be used for inserting or updating data
148 a hash ref or json string to be used for passing additonal info to the ->search call
161 connect_info the arguments to provide to the connect call of the schema_class
165 has 'connect_info' => (
167 isa => DBICConnectInfo,
172 sub _build_connect_info {
174 return $self->_find_stanza($self->config, $self->config_stanza);
180 config_file provide a config_file to read connect_info from, if this is provided
181 config_stanze should also be provided to locate where the connect_info is in the config
182 The config file should be in a format readable by Config::General
195 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
196 designed for use with catalyst config files
200 has 'config_stanza' => (
208 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
209 config_stanza will still be required.
221 try { require Config::Any } catch { $self->throw_exception( "Config::Any is required to parse the config file"); };
223 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
225 # just grab the config from the config file
226 $cfg = $cfg->{$self->config_file};
233 The location where sql ddl files should be created or found for an upgrade.
246 Used for install, the version which will be 'installed' in the schema
258 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
270 Try and force certain operations.
282 Be less verbose about actions
303 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
307 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
308 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
310 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
312 Optional preversion can be supplied to generate a diff to be used by upgrade.
317 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
319 $preversion ||= $self->preversion();
321 my $schema = $self->schema();
322 # create the dir if does not exist
323 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
325 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
333 =item Arguments: <none>
337 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
338 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
344 my $schema = $self->schema();
345 if (!$schema->get_db_version()) {
346 # schema is unversioned
347 $self->throw_exception ("could not determin current schema version, please either install or deploy");
349 my $ret = $schema->upgrade();
359 =item Arguments: $version
363 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
364 database. install will take a version and add the version tracking tables and 'install' the version. No
365 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
366 already versioned databases.
371 my ($self, $version) = @_;
373 my $schema = $self->schema();
374 $version ||= $self->version();
375 if (!$schema->get_db_version() ) {
376 # schema is unversioned
377 print "Going to install schema version\n";
378 my $ret = $schema->install($version);
379 print "retun is $ret\n";
381 elsif ($schema->get_db_version() and $self->force ) {
382 carp "Forcing install may not be a good idea";
383 if($self->_confirm() ) {
384 $self->schema->_set_db_version({ version => $version});
388 $self->throw_exception ("schema already has a version not installing, try upgrade instead");
398 =item Arguments: $args
402 deploy will create the schema at the connected database. C<$args> are passed straight to
403 L<DBIx::Class::Schema/deploy>.
408 my ($self, $args) = @_;
409 my $schema = $self->schema();
410 if (!$schema->get_db_version() ) {
411 # schema is unversioned
412 $schema->deploy( $args, $self->sql_dir)
413 or $self->throw_exception ("could not deploy schema");
415 $self->throw_exception("there already is a database with a version here, try upgrade instead");
423 =item Arguments: $rs, $set
427 insert takes the name of a resultset from the schema_class and a hashref of data to insert
433 my ($self, $rs, $set) = @_;
435 $rs ||= $self->resultset();
436 $set ||= $self->set();
437 my $resultset = $self->schema->resultset($rs);
438 my $obj = $resultset->create( $set );
439 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
447 =item Arguments: $rs, $set, $where
451 update takes the name of a resultset from the schema_class, a hashref of data to update and
452 a where hash used to form the search for the rows to update.
457 my ($self, $rs, $set, $where) = @_;
459 $rs ||= $self->resultset();
460 $where ||= $self->where();
461 $set ||= $self->set();
462 my $resultset = $self->schema->resultset($rs);
463 $resultset = $resultset->search( ($where||{}) );
465 my $count = $resultset->count();
466 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
468 if ( $self->force || $self->_confirm() ) {
469 $resultset->update_all( $set );
478 =item Arguments: $rs, $where, $attrs
482 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
483 The found data is deleted and cannot be recovered.
488 my ($self, $rs, $where, $attrs) = @_;
490 $rs ||= $self->resultset();
491 $where ||= $self->where();
492 $attrs ||= $self->attrs();
493 my $resultset = $self->schema->resultset($rs);
494 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
496 my $count = $resultset->count();
497 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
499 if ( $self->force || $self->_confirm() ) {
500 $resultset->delete_all();
509 =item Arguments: $rs, $where, $attrs
513 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
514 The found data is returned in a array ref where the first row will be the columns list.
519 my ($self, $rs, $where, $attrs) = @_;
521 $rs ||= $self->resultset();
522 $where ||= $self->where();
523 $attrs ||= $self->attrs();
524 my $resultset = $self->schema->resultset($rs);
525 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
528 my @columns = $resultset->result_source->columns();
529 push @data, [@columns];#
531 while (my $row = $resultset->next()) {
533 foreach my $column (@columns) {
534 push( @fields, $row->get_column($column) );
536 push @data, [@fields];
544 print "Are you sure you want to do this? (type YES to confirm) \n";
545 # mainly here for testing
546 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
547 my $response = <STDIN>;
548 return 1 if ($response=~/^YES/);
553 my ($self, $cfg, $stanza) = @_;
554 my @path = split /::/, $stanza;
555 while (my $path = shift @path) {
556 if (exists $cfg->{$path}) {
557 $cfg = $cfg->{$path};
560 $self->throw_exception("could not find $stanza in config, $path did not seem to exist");
568 my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
569 my $ret = $json->jsonToObj($json_str);
577 foreach my $dep (@_deps) {
580 push @_missing_deps, $dep;
584 if (@_missing_deps > 0) {
585 die "The following dependecies are missing " . join ",", @_missing_deps;
594 See L<DBIx::Class/CONTRIBUTORS>.
598 You may distribute this code under the same terms as Perl itself