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} ] };
55 # ['lib|I:s' => 'Additonal library path to search in'],
56 # ['schema|s:s' => 'The class of the schema to load', { required => 1 } ],
57 # ['config-stanza|S:s' => 'Where in the config to find the connection_info, supply in form MyApp::Model::DB',],
58 # ['config|C:s' => 'Supply the config file for parsing by Config::Any', { depends => 'config_stanza'} ],
59 # ['connect-info|n:s%' => ' supply the connect info as additonal options ie -I dsn=<dsn> user=<user> password=<pass> '],
60 # ['sql-dir|q:s' => 'The directory where sql diffs will be created'],
61 # ['sql-type|t:s' => 'The RDBMs falvour you wish to use'],
62 # ['version|v:i' => 'Supply a version install'],
63 # ['preversion|p:s' => 'The previous version to diff against',],
65 # 'schema=s' => \my $schema_class,
66 # 'class=s' => \my $resultset_class,
67 # 'connect=s' => \my $connect,
69 # 'set=s' => \my $set,
70 # 'where=s' => \my $where,
71 # 'attrs=s' => \my $attrs,
72 # 'format=s' => \my $format,
73 # 'force' => \my $force,
74 # 'trace' => \my $trace,
75 # 'quiet' => \my $quiet,
76 # 'help' => \my $help,
77 # 'tlibs' => \my $t_libs,
82 DBIx::Class::Admin - Administration object for schemas
86 use DBIx::Class::Admin;
89 my $admin = DBIx::Class::Admin->new(
90 schema_class=> 'MY::Schema',
92 connect_info => { dsn => $dsn, user => $user, password => $pass },
96 $admin->create('SQLite');
98 # create SQL diff for an upgrade
99 $admin->create('SQLite', {} , "1.0");
104 # install a version for an unversioned schema
105 $admin->install("3.0");
111 add a library search path
117 trigger => \&_set_inc,
121 my ($self, $lib) = @_;
122 push @INC, $lib->stringify;
127 the class of the schema to load
129 has 'schema_class' => (
137 A pre-connected schema object can be provided for manipulation
141 isa => 'DBIx::Class::Schema',
147 $self->ensure_class_loaded($self->schema_class);
149 $self->connect_info->[3]->{ignore_version} =1;
150 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
155 a resultset from the schema to operate on
164 a hash ref or json string to be used for identifying data to manipulate
174 a hash ref or json string to be used for inserting or updating data
184 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);
211 config_file provide a config_file to read connect_info from, if this is provided
212 config_stanze should also be provided to locate where the connect_info is in the config
213 The config file should be in a format readable by Config::General
223 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
224 designed for use with catalyst config files
226 has 'config_stanza' => (
233 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
234 config_stanza will still be required.
244 try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
246 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
248 # just grab the config from the config file
249 $cfg = $cfg->{$self->config_file};
255 The location where sql ddl files should be created or found for an upgrade.
265 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
283 Try and force certain operations.
292 Be less verbose about actions
310 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
314 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
315 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
317 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
319 Optional preversion can be supplied to generate a diff to be used by upgrade.
323 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
325 $preversion ||= $self->preversion();
327 my $schema = $self->schema();
328 # create the dir if does not exist
329 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
331 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
338 =item Arguments: <none>
342 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
343 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
348 my $schema = $self->schema();
349 if (!$schema->get_db_version()) {
350 # schema is unversioned
351 die "could not determin current schema version, please either install or deploy";
353 my $ret = $schema->upgrade();
362 =item Arguments: $version
366 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
367 database. install will take a version and add the version tracking tables and 'install' the version. No
368 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
369 already versioned databases.
372 my ($self, $version) = @_;
374 my $schema = $self->schema();
375 $version ||= $self->version();
376 if (!$schema->get_db_version() ) {
377 # schema is unversioned
378 print "Going to install schema version\n";
379 my $ret = $schema->install($version);
380 print "retun is $ret\n";
382 elsif ($schema->get_db_version() and $self->force ) {
383 warn "forcing install may not be a good idea";
384 if($self->_confirm() ) {
386 $self->schema->_set_db_version({ version => $version});
390 die "schema already has a version not installing, try upgrade instead";
399 =item Arguments: $args
403 deploy will create the schema at the connected database. C<$args> are passed straight to
404 L<DBIx::Class::Schema/deploy>.
407 my ($self, $args) = @_;
408 my $schema = $self->schema();
409 if (!$schema->get_db_version() ) {
410 # schema is unversioned
411 $schema->deploy( $args, $self->sql_dir)
412 or die "could not deploy schema";
414 die "there already is a database with a version here, try upgrade instead";
419 # FIXME ensure option spec compatability
420 #die('Do not use the where option with the insert op') if ($where);
421 #die('Do not use the attrs option with the insert op') if ($attrs);
427 =item Arguments: $rs, $set
431 insert takes the name of a resultset from the schema_class and a hashref of data to insert
436 my ($self, $rs, $set) = @_;
438 $rs ||= $self->resultset();
439 $set ||= $self->set();
440 my $resultset = $self->schema->resultset($rs);
441 my $obj = $resultset->create( $set );
442 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
450 =item Arguments: $rs, $set, $where
454 update takes the name of a resultset from the schema_class, a hashref of data to update and
455 a where hash used to form the search for the rows to update.
458 my ($self, $rs, $set, $where) = @_;
460 $rs ||= $self->resultset();
461 $where ||= $self->where();
462 $set ||= $self->set();
463 my $resultset = $self->schema->resultset($rs);
464 $resultset = $resultset->search( ($where||{}) );
466 my $count = $resultset->count();
467 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
469 if ( $self->force || $self->_confirm() ) {
470 $resultset->update_all( $set );
475 #die('Do not use the set option with the delete op') if ($set);
480 =item Arguments: $rs, $where, $attrs
484 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
485 The found data is deleted and cannot be recovered.
488 my ($self, $rs, $where, $attrs) = @_;
490 $rs ||= $self->resultset();
491 $where ||= $self->where();
492 $attrs ||= $self->attrs();
493 my $resultset = $self->schema->resultset($rs);
494 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
496 my $count = $resultset->count();
497 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
499 if ( $self->force || $self->_confirm() ) {
500 $resultset->delete_all();
508 =item Arguments: $rs, $where, $attrs
512 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
513 The found data is returned in a array ref where the first row will be the columns list.
517 my ($self, $rs, $where, $attrs) = @_;
519 $rs ||= $self->resultset();
520 $where ||= $self->where();
521 $attrs ||= $self->attrs();
522 my $resultset = $self->schema->resultset($rs);
523 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
526 my @columns = $resultset->result_source->columns();
527 push @data, [@columns];#
529 while (my $row = $resultset->next()) {
531 foreach my $column (@columns) {
532 push( @fields, $row->get_column($column) );
534 push @data, [@fields];
542 print "Are you sure you want to do this? (type YES to confirm) \n";
543 # mainly here for testing
544 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
545 my $response = <STDIN>;
546 return 1 if ($response=~/^YES/);
551 my ($self, $cfg, $stanza) = @_;
552 my @path = split /::/, $stanza;
553 while (my $path = shift @path) {
554 if (exists $cfg->{$path}) {
555 $cfg = $cfg->{$path};
558 die "could not find $stanza in config, $path did not seem to exist";
566 my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
567 my $ret = $json->jsonToObj($json_str);
573 Gordon Irving <goraxe@cpan.org>
575 with code taken from dbicadmin by
576 Aran Deltac <bluefeet@cpan.org>
581 You may distribute this code under the same terms as Perl itself.