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;
21 -declare => [qw( DBICConnectInfo )];
22 use MooseX::Types::Moose qw/Int HashRef ArrayRef Str Any/;
23 use MooseX::Types::JSON qw(JSON);
24 use MooseX::Types::Path::Class qw(Dir File);
27 use parent 'Class::C3::Componentised';
31 use namespace::autoclean;
33 my @_deps = qw(Moose MooseX::Types MooseX::Types::JSON MooseX::Types::Path::Class Try::Tiny parent JSON::Any Class::C3::Componentised namespace::autoclean);
37 via { _json_to_data ($_) };
41 via { _json_to_data($_) };
43 subtype DBICConnectInfo,
46 coerce DBICConnectInfo,
48 via { return _json_to_data($_) } ;
50 coerce DBICConnectInfo,
52 via { return _json_to_data($_) };
54 coerce DBICConnectInfo,
56 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
95 trigger => \&_set_inc,
99 my ($self, $lib) = @_;
100 push @INC, $lib->stringify;
105 the class of the schema to load
107 has 'schema_class' => (
115 A pre-connected schema object can be provided for manipulation
119 isa => 'DBIx::Class::Schema',
125 $self->ensure_class_loaded($self->schema_class);
127 $self->connect_info->[3]->{ignore_version} =1;
128 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
133 a resultset from the schema to operate on
142 a hash ref or json string to be used for identifying data to manipulate
152 a hash ref or json string to be used for inserting or updating data
162 a hash ref or json string to be used for passing additonal info to the ->search call
171 connect_info the arguments to provide to the connect call of the schema_class
175 has 'connect_info' => (
177 isa => DBICConnectInfo,
182 sub _build_connect_info {
184 return $self->_find_stanza($self->config, $self->config_stanza);
189 config_file provide a config_file to read connect_info from, if this is provided
190 config_stanze should also be provided to locate where the connect_info is in the config
191 The config file should be in a format readable by Config::General
201 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
202 designed for use with catalyst config files
204 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.
222 try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
224 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
226 # just grab the config from the config file
227 $cfg = $cfg->{$self->config_file};
233 The location where sql ddl files should be created or found for an upgrade.
243 Used for install, the version which will be 'installed' in the schema
252 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
261 Try and force certain operations.
270 Be less verbose about actions
288 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
292 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
293 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
295 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
297 Optional preversion can be supplied to generate a diff to be used by upgrade.
301 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
303 $preversion ||= $self->preversion();
305 my $schema = $self->schema();
306 # create the dir if does not exist
307 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
309 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
316 =item Arguments: <none>
320 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
321 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
326 my $schema = $self->schema();
327 if (!$schema->get_db_version()) {
328 # schema is unversioned
329 die "could not determin current schema version, please either install or deploy";
331 my $ret = $schema->upgrade();
340 =item Arguments: $version
344 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
345 database. install will take a version and add the version tracking tables and 'install' the version. No
346 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
347 already versioned databases.
350 my ($self, $version) = @_;
352 my $schema = $self->schema();
353 $version ||= $self->version();
354 if (!$schema->get_db_version() ) {
355 # schema is unversioned
356 print "Going to install schema version\n";
357 my $ret = $schema->install($version);
358 print "retun is $ret\n";
360 elsif ($schema->get_db_version() and $self->force ) {
361 warn "forcing install may not be a good idea";
362 if($self->_confirm() ) {
364 $self->schema->_set_db_version({ version => $version});
368 die "schema already has a version not installing, try upgrade instead";
377 =item Arguments: $args
381 deploy will create the schema at the connected database. C<$args> are passed straight to
382 L<DBIx::Class::Schema/deploy>.
385 my ($self, $args) = @_;
386 my $schema = $self->schema();
387 if (!$schema->get_db_version() ) {
388 # schema is unversioned
389 $schema->deploy( $args, $self->sql_dir)
390 or die "could not deploy schema";
392 die "there already is a database with a version here, try upgrade instead";
397 # FIXME ensure option spec compatability
398 #die('Do not use the where option with the insert op') if ($where);
399 #die('Do not use the attrs option with the insert op') if ($attrs);
405 =item Arguments: $rs, $set
409 insert takes the name of a resultset from the schema_class and a hashref of data to insert
414 my ($self, $rs, $set) = @_;
416 $rs ||= $self->resultset();
417 $set ||= $self->set();
418 my $resultset = $self->schema->resultset($rs);
419 my $obj = $resultset->create( $set );
420 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
428 =item Arguments: $rs, $set, $where
432 update takes the name of a resultset from the schema_class, a hashref of data to update and
433 a where hash used to form the search for the rows to update.
436 my ($self, $rs, $set, $where) = @_;
438 $rs ||= $self->resultset();
439 $where ||= $self->where();
440 $set ||= $self->set();
441 my $resultset = $self->schema->resultset($rs);
442 $resultset = $resultset->search( ($where||{}) );
444 my $count = $resultset->count();
445 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
447 if ( $self->force || $self->_confirm() ) {
448 $resultset->update_all( $set );
453 #die('Do not use the set option with the delete op') if ($set);
458 =item Arguments: $rs, $where, $attrs
462 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
463 The found data is deleted and cannot be recovered.
466 my ($self, $rs, $where, $attrs) = @_;
468 $rs ||= $self->resultset();
469 $where ||= $self->where();
470 $attrs ||= $self->attrs();
471 my $resultset = $self->schema->resultset($rs);
472 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
474 my $count = $resultset->count();
475 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
477 if ( $self->force || $self->_confirm() ) {
478 $resultset->delete_all();
486 =item Arguments: $rs, $where, $attrs
490 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
491 The found data is returned in a array ref where the first row will be the columns list.
495 my ($self, $rs, $where, $attrs) = @_;
497 $rs ||= $self->resultset();
498 $where ||= $self->where();
499 $attrs ||= $self->attrs();
500 my $resultset = $self->schema->resultset($rs);
501 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
504 my @columns = $resultset->result_source->columns();
505 push @data, [@columns];#
507 while (my $row = $resultset->next()) {
509 foreach my $column (@columns) {
510 push( @fields, $row->get_column($column) );
512 push @data, [@fields];
520 print "Are you sure you want to do this? (type YES to confirm) \n";
521 # mainly here for testing
522 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
523 my $response = <STDIN>;
524 return 1 if ($response=~/^YES/);
529 my ($self, $cfg, $stanza) = @_;
530 my @path = split /::/, $stanza;
531 while (my $path = shift @path) {
532 if (exists $cfg->{$path}) {
533 $cfg = $cfg->{$path};
536 die "could not find $stanza in config, $path did not seem to exist";
544 my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
545 my $ret = $json->jsonToObj($json_str);
553 foreach my $dep (@_deps) {
556 push @_missing_deps, $dep;
560 if (@_missing_deps > 0) {
561 die "The following dependecies are missing " . join ",", @_missing_deps;
568 Gordon Irving <goraxe@cpan.org>
570 with code taken from dbicadmin by
571 Aran Deltac <bluefeet@cpan.org>
576 You may distribute this code under the same terms as Perl itself.