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 Carp::Clan qw/^DBIx::Class/;
28 use parent 'Class::C3::Componentised';
29 use parent 'DBIx::Class::Schema';
33 use namespace::autoclean;
35 my @_deps = qw(Moose MooseX::Types MooseX::Types::JSON MooseX::Types::Path::Class Try::Tiny parent JSON::Any Class::C3::Componentised namespace::autoclean);
39 via { _json_to_data ($_) };
43 via { _json_to_data($_) };
45 subtype DBICConnectInfo,
48 coerce DBICConnectInfo,
50 via { return _json_to_data($_) } ;
52 coerce DBICConnectInfo,
54 via { return _json_to_data($_) };
56 coerce DBICConnectInfo,
58 via { [ $_->{dsn}, $_->{user}, $_->{password} ] };
63 DBIx::Class::Admin - Administration object for schemas
67 use DBIx::Class::Admin;
70 my $admin = DBIx::Class::Admin->new(
71 schema_class=> 'MY::Schema',
73 connect_info => { dsn => $dsn, user => $user, password => $pass },
77 $admin->create('SQLite');
79 # create SQL diff for an upgrade
80 $admin->create('SQLite', {} , "1.0");
85 # install a version for an unversioned schema
86 $admin->install("3.0");
92 the class of the schema to load
96 has 'schema_class' => (
105 A pre-connected schema object can be provided for manipulation
111 isa => 'DBIx::Class::Schema',
117 $self->ensure_class_loaded($self->schema_class);
119 $self->connect_info->[3]->{ignore_version} =1;
120 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
126 a resultset from the schema to operate on
138 a hash ref or json string to be used for identifying data to manipulate
151 a hash ref or json string to be used for inserting or updating data
164 a hash ref or json string to be used for passing additonal info to the ->search call
177 connect_info the arguments to provide to the connect call of the schema_class
181 has 'connect_info' => (
183 isa => DBICConnectInfo,
188 sub _build_connect_info {
190 return $self->_find_stanza($self->config, $self->config_stanza);
196 config_file provide a config_file to read connect_info from, if this is provided
197 config_stanze should also be provided to locate where the connect_info is in the config
198 The config file should be in a format readable by Config::General
211 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
212 designed for use with catalyst config files
216 has 'config_stanza' => (
224 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
225 config_stanza will still be required.
237 try { require Config::Any } catch { $self->throw_exception( "Config::Any is required to parse the config file"); };
239 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
241 # just grab the config from the config file
242 $cfg = $cfg->{$self->config_file};
249 The location where sql ddl files should be created or found for an upgrade.
262 Used for install, the version which will be 'installed' in the schema
274 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
286 Try and force certain operations.
298 Be less verbose about actions
319 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
323 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
324 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
326 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
328 Optional preversion can be supplied to generate a diff to be used by upgrade.
333 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
335 $preversion ||= $self->preversion();
337 my $schema = $self->schema();
338 # create the dir if does not exist
339 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
341 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
349 =item Arguments: <none>
353 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
354 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
360 my $schema = $self->schema();
361 if (!$schema->get_db_version()) {
362 # schema is unversioned
363 $self->throw_exception ("could not determin current schema version, please either install or deploy");
365 my $ret = $schema->upgrade();
375 =item Arguments: $version
379 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
380 database. install will take a version and add the version tracking tables and 'install' the version. No
381 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
382 already versioned databases.
387 my ($self, $version) = @_;
389 my $schema = $self->schema();
390 $version ||= $self->version();
391 if (!$schema->get_db_version() ) {
392 # schema is unversioned
393 print "Going to install schema version\n";
394 my $ret = $schema->install($version);
395 print "retun is $ret\n";
397 elsif ($schema->get_db_version() and $self->force ) {
398 carp "Forcing install may not be a good idea";
399 if($self->_confirm() ) {
400 $self->schema->_set_db_version({ version => $version});
404 $self->throw_exception ("schema already has a version not installing, try upgrade instead");
414 =item Arguments: $args
418 deploy will create the schema at the connected database. C<$args> are passed straight to
419 L<DBIx::Class::Schema/deploy>.
424 my ($self, $args) = @_;
425 my $schema = $self->schema();
426 if (!$schema->get_db_version() ) {
427 # schema is unversioned
428 $schema->deploy( $args, $self->sql_dir)
429 or $self->throw_exception ("could not deploy schema");
431 $self->throw_exception("there already is a database with a version here, try upgrade instead");
439 =item Arguments: $rs, $set
443 insert takes the name of a resultset from the schema_class and a hashref of data to insert
449 my ($self, $rs, $set) = @_;
451 $rs ||= $self->resultset();
452 $set ||= $self->set();
453 my $resultset = $self->schema->resultset($rs);
454 my $obj = $resultset->create( $set );
455 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
463 =item Arguments: $rs, $set, $where
467 update takes the name of a resultset from the schema_class, a hashref of data to update and
468 a where hash used to form the search for the rows to update.
473 my ($self, $rs, $set, $where) = @_;
475 $rs ||= $self->resultset();
476 $where ||= $self->where();
477 $set ||= $self->set();
478 my $resultset = $self->schema->resultset($rs);
479 $resultset = $resultset->search( ($where||{}) );
481 my $count = $resultset->count();
482 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
484 if ( $self->force || $self->_confirm() ) {
485 $resultset->update_all( $set );
494 =item Arguments: $rs, $where, $attrs
498 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
499 The found data is deleted and cannot be recovered.
504 my ($self, $rs, $where, $attrs) = @_;
506 $rs ||= $self->resultset();
507 $where ||= $self->where();
508 $attrs ||= $self->attrs();
509 my $resultset = $self->schema->resultset($rs);
510 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
512 my $count = $resultset->count();
513 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
515 if ( $self->force || $self->_confirm() ) {
516 $resultset->delete_all();
525 =item Arguments: $rs, $where, $attrs
529 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
530 The found data is returned in a array ref where the first row will be the columns list.
535 my ($self, $rs, $where, $attrs) = @_;
537 $rs ||= $self->resultset();
538 $where ||= $self->where();
539 $attrs ||= $self->attrs();
540 my $resultset = $self->schema->resultset($rs);
541 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
544 my @columns = $resultset->result_source->columns();
545 push @data, [@columns];#
547 while (my $row = $resultset->next()) {
549 foreach my $column (@columns) {
550 push( @fields, $row->get_column($column) );
552 push @data, [@fields];
560 print "Are you sure you want to do this? (type YES to confirm) \n";
561 # mainly here for testing
562 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
563 my $response = <STDIN>;
564 return 1 if ($response=~/^YES/);
569 my ($self, $cfg, $stanza) = @_;
570 my @path = split /::/, $stanza;
571 while (my $path = shift @path) {
572 if (exists $cfg->{$path}) {
573 $cfg = $cfg->{$path};
576 $self->throw_exception("could not find $stanza in config, $path did not seem to exist");
584 my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
585 my $ret = $json->jsonToObj($json_str);
593 foreach my $dep (@_deps) {
596 push @_missing_deps, $dep;
600 if (@_missing_deps > 0) {
601 die "The following dependecies are missing " . join ",", @_missing_deps;
610 See L<DBIx::Class/CONTRIBUTORS>.
614 You may distribute this code under the same terms as Perl itself