2 #===============================================================================
6 # DESCRIPTION: Administrative functions for DBIx::Class Schemata
11 # AUTHOR: Gordon Irving (), <Gordon.irving@sophos.com>
13 # CREATED: 28/11/09 12:27:15 GMT
15 #===============================================================================
17 package DBIx::Class::Admin;
20 use MooseX::Types -declare => [qw( DBICConnectInfo )];
21 use MooseX::Types::Moose qw/Int HashRef ArrayRef Str Any/;
22 use MooseX::Types::JSON qw(JSON);
23 use MooseX::Types::Path::Class qw(Dir File);
26 use parent 'Class::C3::Componentised';
30 use namespace::autoclean;
32 my @_deps = qw(Moose MooseX::Types MooseX::Types::JSON MooseX::Types::Path::Class Try::Tiny parent JSON::Any Class::C3::Componentised namespace::autoclean);
36 via { _json_to_data ($_) };
40 via { _json_to_data($_) };
42 subtype DBICConnectInfo,
45 coerce DBICConnectInfo,
47 via { return _json_to_data($_) } ;
49 coerce DBICConnectInfo,
51 via { return _json_to_data($_) };
53 coerce DBICConnectInfo,
55 via { [ $_->{dsn}, $_->{user}, $_->{password} ] };
60 DBIx::Class::Admin - Administration object for schemas
64 use DBIx::Class::Admin;
67 my $admin = DBIx::Class::Admin->new(
68 schema_class=> 'MY::Schema',
70 connect_info => { dsn => $dsn, user => $user, password => $pass },
74 $admin->create('SQLite');
76 # create SQL diff for an upgrade
77 $admin->create('SQLite', {} , "1.0");
82 # install a version for an unversioned schema
83 $admin->install("3.0");
89 add a library search path
97 trigger => \&_set_inc,
101 my ($self, $lib) = @_;
102 push @INC, $lib->stringify;
108 the class of the schema to load
112 has 'schema_class' => (
121 A pre-connected schema object can be provided for manipulation
127 isa => 'DBIx::Class::Schema',
133 $self->ensure_class_loaded($self->schema_class);
135 $self->connect_info->[3]->{ignore_version} =1;
136 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
142 a resultset from the schema to operate on
154 a hash ref or json string to be used for identifying data to manipulate
167 a hash ref or json string to be used for inserting or updating data
180 a hash ref or json string to be used for passing additonal info to the ->search call
193 connect_info the arguments to provide to the connect call of the schema_class
197 has 'connect_info' => (
199 isa => DBICConnectInfo,
204 sub _build_connect_info {
206 return $self->_find_stanza($self->config, $self->config_stanza);
212 config_file provide a config_file to read connect_info from, if this is provided
213 config_stanze should also be provided to locate where the connect_info is in the config
214 The config file should be in a format readable by Config::General
227 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
228 designed for use with catalyst config files
232 has 'config_stanza' => (
240 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
241 config_stanza will still be required.
253 try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
255 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
257 # just grab the config from the config file
258 $cfg = $cfg->{$self->config_file};
265 The location where sql ddl files should be created or found for an upgrade.
278 Used for install, the version which will be 'installed' in the schema
290 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
302 Try and force certain operations.
314 Be less verbose about actions
335 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
339 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
340 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
342 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
344 Optional preversion can be supplied to generate a diff to be used by upgrade.
349 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
351 $preversion ||= $self->preversion();
353 my $schema = $self->schema();
354 # create the dir if does not exist
355 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
357 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
365 =item Arguments: <none>
369 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
370 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
376 my $schema = $self->schema();
377 if (!$schema->get_db_version()) {
378 # schema is unversioned
379 die "could not determin current schema version, please either install or deploy";
381 my $ret = $schema->upgrade();
391 =item Arguments: $version
395 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
396 database. install will take a version and add the version tracking tables and 'install' the version. No
397 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
398 already versioned databases.
403 my ($self, $version) = @_;
405 my $schema = $self->schema();
406 $version ||= $self->version();
407 if (!$schema->get_db_version() ) {
408 # schema is unversioned
409 print "Going to install schema version\n";
410 my $ret = $schema->install($version);
411 print "retun is $ret\n";
413 elsif ($schema->get_db_version() and $self->force ) {
414 warn "forcing install may not be a good idea";
415 if($self->_confirm() ) {
417 $self->schema->_set_db_version({ version => $version});
421 die "schema already has a version not installing, try upgrade instead";
431 =item Arguments: $args
435 deploy will create the schema at the connected database. C<$args> are passed straight to
436 L<DBIx::Class::Schema/deploy>.
441 my ($self, $args) = @_;
442 my $schema = $self->schema();
443 if (!$schema->get_db_version() ) {
444 # schema is unversioned
445 $schema->deploy( $args, $self->sql_dir)
446 or die "could not deploy schema";
448 die "there already is a database with a version here, try upgrade instead";
453 # FIXME ensure option spec compatability
454 #die('Do not use the where option with the insert op') if ($where);
455 #die('Do not use the attrs option with the insert op') if ($attrs);
462 =item Arguments: $rs, $set
466 insert takes the name of a resultset from the schema_class and a hashref of data to insert
472 my ($self, $rs, $set) = @_;
474 $rs ||= $self->resultset();
475 $set ||= $self->set();
476 my $resultset = $self->schema->resultset($rs);
477 my $obj = $resultset->create( $set );
478 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
486 =item Arguments: $rs, $set, $where
490 update takes the name of a resultset from the schema_class, a hashref of data to update and
491 a where hash used to form the search for the rows to update.
496 my ($self, $rs, $set, $where) = @_;
498 $rs ||= $self->resultset();
499 $where ||= $self->where();
500 $set ||= $self->set();
501 my $resultset = $self->schema->resultset($rs);
502 $resultset = $resultset->search( ($where||{}) );
504 my $count = $resultset->count();
505 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
507 if ( $self->force || $self->_confirm() ) {
508 $resultset->update_all( $set );
513 #die('Do not use the set option with the delete op') if ($set);
520 =item Arguments: $rs, $where, $attrs
524 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
525 The found data is deleted and cannot be recovered.
530 my ($self, $rs, $where, $attrs) = @_;
532 $rs ||= $self->resultset();
533 $where ||= $self->where();
534 $attrs ||= $self->attrs();
535 my $resultset = $self->schema->resultset($rs);
536 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
538 my $count = $resultset->count();
539 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
541 if ( $self->force || $self->_confirm() ) {
542 $resultset->delete_all();
551 =item Arguments: $rs, $where, $attrs
555 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
556 The found data is returned in a array ref where the first row will be the columns list.
561 my ($self, $rs, $where, $attrs) = @_;
563 $rs ||= $self->resultset();
564 $where ||= $self->where();
565 $attrs ||= $self->attrs();
566 my $resultset = $self->schema->resultset($rs);
567 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
570 my @columns = $resultset->result_source->columns();
571 push @data, [@columns];#
573 while (my $row = $resultset->next()) {
575 foreach my $column (@columns) {
576 push( @fields, $row->get_column($column) );
578 push @data, [@fields];
586 print "Are you sure you want to do this? (type YES to confirm) \n";
587 # mainly here for testing
588 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
589 my $response = <STDIN>;
590 return 1 if ($response=~/^YES/);
595 my ($self, $cfg, $stanza) = @_;
596 my @path = split /::/, $stanza;
597 while (my $path = shift @path) {
598 if (exists $cfg->{$path}) {
599 $cfg = $cfg->{$path};
602 die "could not find $stanza in config, $path did not seem to exist";
610 my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
611 my $ret = $json->jsonToObj($json_str);
619 foreach my $dep (@_deps) {
622 push @_missing_deps, $dep;
626 if (@_missing_deps > 0) {
627 die "The following dependecies are missing " . join ",", @_missing_deps;
636 See L<DBIx::Class/CONTRIBUTORS>.
640 You may distribute this code under the same terms as Perl itself