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';
32 my @_deps = qw(Moose MooseX::Types MooseX::Types::JSON MooseX::Types::Path::Class Try::Tiny parent JSON::Any Class::C3::Componentised);
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} ] };
59 DBIx::Class::Admin - Administration object for schemas
63 use DBIx::Class::Admin;
66 my $admin = DBIx::Class::Admin->new(
67 schema_class=> 'MY::Schema',
69 connect_info => { dsn => $dsn, user => $user, password => $pass },
73 $admin->create('SQLite');
75 # create SQL diff for an upgrade
76 $admin->create('SQLite', {} , "1.0");
81 # install a version for an unversioned schema
82 $admin->install("3.0");
88 add a library search path
94 trigger => \&_set_inc,
98 my ($self, $lib) = @_;
99 push @INC, $lib->stringify;
104 the class of the schema to load
106 has 'schema_class' => (
114 A pre-connected schema object can be provided for manipulation
118 isa => 'DBIx::Class::Schema',
124 $self->ensure_class_loaded($self->schema_class);
126 $self->connect_info->[3]->{ignore_version} =1;
127 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
132 a resultset from the schema to operate on
141 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
161 a hash ref or json string to be used for passing additonal info to the ->search call
170 connect_info the arguments to provide to the connect call of the schema_class
174 has 'connect_info' => (
176 isa => DBICConnectInfo,
181 sub _build_connect_info {
183 return $self->_find_stanza($self->config, $self->config_stanza);
188 config_file provide a config_file to read connect_info from, if this is provided
189 config_stanze should also be provided to locate where the connect_info is in the config
190 The config file should be in a format readable by Config::General
200 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
201 designed for use with catalyst config files
203 has 'config_stanza' => (
210 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
211 config_stanza will still be required.
221 try { require 'Config::Any'; } catch { die "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};
232 The location where sql ddl files should be created or found for an upgrade.
242 Used for install, the version which will be 'installed' in the schema
251 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
260 Try and force certain operations.
269 Be less verbose about actions
287 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
291 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
292 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
294 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
296 Optional preversion can be supplied to generate a diff to be used by upgrade.
300 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
302 $preversion ||= $self->preversion();
304 my $schema = $self->schema();
305 # create the dir if does not exist
306 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
308 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
315 =item Arguments: <none>
319 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
320 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
325 my $schema = $self->schema();
326 if (!$schema->get_db_version()) {
327 # schema is unversioned
328 die "could not determin current schema version, please either install or deploy";
330 my $ret = $schema->upgrade();
339 =item Arguments: $version
343 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
344 database. install will take a version and add the version tracking tables and 'install' the version. No
345 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
346 already versioned databases.
349 my ($self, $version) = @_;
351 my $schema = $self->schema();
352 $version ||= $self->version();
353 if (!$schema->get_db_version() ) {
354 # schema is unversioned
355 print "Going to install schema version\n";
356 my $ret = $schema->install($version);
357 print "retun is $ret\n";
359 elsif ($schema->get_db_version() and $self->force ) {
360 warn "forcing install may not be a good idea";
361 if($self->_confirm() ) {
363 $self->schema->_set_db_version({ version => $version});
367 die "schema already has a version not installing, try upgrade instead";
376 =item Arguments: $args
380 deploy will create the schema at the connected database. C<$args> are passed straight to
381 L<DBIx::Class::Schema/deploy>.
384 my ($self, $args) = @_;
385 my $schema = $self->schema();
386 if (!$schema->get_db_version() ) {
387 # schema is unversioned
388 $schema->deploy( $args, $self->sql_dir)
389 or die "could not deploy schema";
391 die "there already is a database with a version here, try upgrade instead";
396 # FIXME ensure option spec compatability
397 #die('Do not use the where option with the insert op') if ($where);
398 #die('Do not use the attrs option with the insert op') if ($attrs);
404 =item Arguments: $rs, $set
408 insert takes the name of a resultset from the schema_class and a hashref of data to insert
413 my ($self, $rs, $set) = @_;
415 $rs ||= $self->resultset();
416 $set ||= $self->set();
417 my $resultset = $self->schema->resultset($rs);
418 my $obj = $resultset->create( $set );
419 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
427 =item Arguments: $rs, $set, $where
431 update takes the name of a resultset from the schema_class, a hashref of data to update and
432 a where hash used to form the search for the rows to update.
435 my ($self, $rs, $set, $where) = @_;
437 $rs ||= $self->resultset();
438 $where ||= $self->where();
439 $set ||= $self->set();
440 my $resultset = $self->schema->resultset($rs);
441 $resultset = $resultset->search( ($where||{}) );
443 my $count = $resultset->count();
444 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
446 if ( $self->force || $self->_confirm() ) {
447 $resultset->update_all( $set );
452 #die('Do not use the set option with the delete op') if ($set);
457 =item Arguments: $rs, $where, $attrs
461 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
462 The found data is deleted and cannot be recovered.
465 my ($self, $rs, $where, $attrs) = @_;
467 $rs ||= $self->resultset();
468 $where ||= $self->where();
469 $attrs ||= $self->attrs();
470 my $resultset = $self->schema->resultset($rs);
471 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
473 my $count = $resultset->count();
474 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
476 if ( $self->force || $self->_confirm() ) {
477 $resultset->delete_all();
485 =item Arguments: $rs, $where, $attrs
489 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
490 The found data is returned in a array ref where the first row will be the columns list.
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||()) );
503 my @columns = $resultset->result_source->columns();
504 push @data, [@columns];#
506 while (my $row = $resultset->next()) {
508 foreach my $column (@columns) {
509 push( @fields, $row->get_column($column) );
511 push @data, [@fields];
519 print "Are you sure you want to do this? (type YES to confirm) \n";
520 # mainly here for testing
521 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
522 my $response = <STDIN>;
523 return 1 if ($response=~/^YES/);
528 my ($self, $cfg, $stanza) = @_;
529 my @path = split /::/, $stanza;
530 while (my $path = shift @path) {
531 if (exists $cfg->{$path}) {
532 $cfg = $cfg->{$path};
535 die "could not find $stanza in config, $path did not seem to exist";
543 my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
544 my $ret = $json->jsonToObj($json_str);
552 foreach my $dep (@_deps) {
555 push @_missing_deps, $dep;
559 if (@_missing_deps > 0) {
560 die "The following dependecies are missing " . join ",", @_missing_deps;
567 Gordon Irving <goraxe@cpan.org>
569 with code taken from dbicadmin by
570 Aran Deltac <bluefeet@cpan.org>
575 You may distribute this code under the same terms as Perl itself.