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);
26 use parent 'Class::C3::Componentised';
34 via { _json_to_data ($_) };
38 via { _json_to_data($_) };
40 subtype DBICConnectInfo,
43 coerce DBICConnectInfo,
45 via { return _json_to_data($_) } ;
47 coerce DBICConnectInfo,
49 via { return _json_to_data($_) };
51 coerce DBICConnectInfo,
53 via { [ $_->{dsn}, $_->{user}, $_->{password} ] };
57 DBIx::Class::Admin - Administration object for schemas
61 use DBIx::Class::Admin;
64 my $admin = DBIx::Class::Admin->new(
65 schema_class=> 'MY::Schema',
67 connect_info => { dsn => $dsn, user => $user, password => $pass },
71 $admin->create('SQLite');
73 # create SQL diff for an upgrade
74 $admin->create('SQLite', {} , "1.0");
79 # install a version for an unversioned schema
80 $admin->install("3.0");
86 add a library search path
92 trigger => \&_set_inc,
96 my ($self, $lib) = @_;
97 push @INC, $lib->stringify;
102 the class of the schema to load
104 has 'schema_class' => (
112 A pre-connected schema object can be provided for manipulation
116 isa => 'DBIx::Class::Schema',
122 $self->ensure_class_loaded($self->schema_class);
124 $self->connect_info->[3]->{ignore_version} =1;
125 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
130 a resultset from the schema to operate on
139 a hash ref or json string to be used for identifying data to manipulate
149 a hash ref or json string to be used for inserting or updating data
159 a hash ref or json string to be used for passing additonal info to the ->search call
168 connect_info the arguments to provide to the connect call of the schema_class
172 has 'connect_info' => (
174 isa => DBICConnectInfo,
179 sub _build_connect_info {
181 return $self->_find_stanza($self->config, $self->config_stanza);
186 config_file provide a config_file to read connect_info from, if this is provided
187 config_stanze should also be provided to locate where the connect_info is in the config
188 The config file should be in a format readable by Config::General
198 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
199 designed for use with catalyst config files
201 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.
219 try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
221 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
223 # just grab the config from the config file
224 $cfg = $cfg->{$self->config_file};
230 The location where sql ddl files should be created or found for an upgrade.
240 Used for install, the version which will be 'installed' in the schema
249 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
258 Try and force certain operations.
267 Be less verbose about actions
285 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
289 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
290 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
292 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
294 Optional preversion can be supplied to generate a diff to be used by upgrade.
298 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
300 $preversion ||= $self->preversion();
302 my $schema = $self->schema();
303 # create the dir if does not exist
304 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
306 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
313 =item Arguments: <none>
317 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
318 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
323 my $schema = $self->schema();
324 if (!$schema->get_db_version()) {
325 # schema is unversioned
326 die "could not determin current schema version, please either install or deploy";
328 my $ret = $schema->upgrade();
337 =item Arguments: $version
341 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
342 database. install will take a version and add the version tracking tables and 'install' the version. No
343 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
344 already versioned databases.
347 my ($self, $version) = @_;
349 my $schema = $self->schema();
350 $version ||= $self->version();
351 if (!$schema->get_db_version() ) {
352 # schema is unversioned
353 print "Going to install schema version\n";
354 my $ret = $schema->install($version);
355 print "retun is $ret\n";
357 elsif ($schema->get_db_version() and $self->force ) {
358 warn "forcing install may not be a good idea";
359 if($self->_confirm() ) {
361 $self->schema->_set_db_version({ version => $version});
365 die "schema already has a version not installing, try upgrade instead";
374 =item Arguments: $args
378 deploy will create the schema at the connected database. C<$args> are passed straight to
379 L<DBIx::Class::Schema/deploy>.
382 my ($self, $args) = @_;
383 my $schema = $self->schema();
384 if (!$schema->get_db_version() ) {
385 # schema is unversioned
386 $schema->deploy( $args, $self->sql_dir)
387 or die "could not deploy schema";
389 die "there already is a database with a version here, try upgrade instead";
394 # FIXME ensure option spec compatability
395 #die('Do not use the where option with the insert op') if ($where);
396 #die('Do not use the attrs option with the insert op') if ($attrs);
402 =item Arguments: $rs, $set
406 insert takes the name of a resultset from the schema_class and a hashref of data to insert
411 my ($self, $rs, $set) = @_;
413 $rs ||= $self->resultset();
414 $set ||= $self->set();
415 my $resultset = $self->schema->resultset($rs);
416 my $obj = $resultset->create( $set );
417 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
425 =item Arguments: $rs, $set, $where
429 update takes the name of a resultset from the schema_class, a hashref of data to update and
430 a where hash used to form the search for the rows to update.
433 my ($self, $rs, $set, $where) = @_;
435 $rs ||= $self->resultset();
436 $where ||= $self->where();
437 $set ||= $self->set();
438 my $resultset = $self->schema->resultset($rs);
439 $resultset = $resultset->search( ($where||{}) );
441 my $count = $resultset->count();
442 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
444 if ( $self->force || $self->_confirm() ) {
445 $resultset->update_all( $set );
450 #die('Do not use the set option with the delete op') if ($set);
455 =item Arguments: $rs, $where, $attrs
459 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
460 The found data is deleted and cannot be recovered.
463 my ($self, $rs, $where, $attrs) = @_;
465 $rs ||= $self->resultset();
466 $where ||= $self->where();
467 $attrs ||= $self->attrs();
468 my $resultset = $self->schema->resultset($rs);
469 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
471 my $count = $resultset->count();
472 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
474 if ( $self->force || $self->_confirm() ) {
475 $resultset->delete_all();
483 =item Arguments: $rs, $where, $attrs
487 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
488 The found data is returned in a array ref where the first row will be the columns list.
492 my ($self, $rs, $where, $attrs) = @_;
494 $rs ||= $self->resultset();
495 $where ||= $self->where();
496 $attrs ||= $self->attrs();
497 my $resultset = $self->schema->resultset($rs);
498 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
501 my @columns = $resultset->result_source->columns();
502 push @data, [@columns];#
504 while (my $row = $resultset->next()) {
506 foreach my $column (@columns) {
507 push( @fields, $row->get_column($column) );
509 push @data, [@fields];
517 print "Are you sure you want to do this? (type YES to confirm) \n";
518 # mainly here for testing
519 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
520 my $response = <STDIN>;
521 return 1 if ($response=~/^YES/);
526 my ($self, $cfg, $stanza) = @_;
527 my @path = split /::/, $stanza;
528 while (my $path = shift @path) {
529 if (exists $cfg->{$path}) {
530 $cfg = $cfg->{$path};
533 die "could not find $stanza in config, $path did not seem to exist";
541 my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
542 my $ret = $json->jsonToObj($json_str);
548 Gordon Irving <goraxe@cpan.org>
550 with code taken from dbicadmin by
551 Aran Deltac <bluefeet@cpan.org>
556 You may distribute this code under the same terms as Perl itself.