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 use MooseX::Types::Moose qw/Int HashRef ArrayRef Str Any/;
22 use MooseX::Types::Path::Class qw(Dir File);
24 use parent 'Class::C3::Componentised';
28 # ['lib|I:s' => 'Additonal library path to search in'],
29 # ['schema|s:s' => 'The class of the schema to load', { required => 1 } ],
30 # ['config-stanza|S:s' => 'Where in the config to find the connection_info, supply in form MyApp::Model::DB',],
31 # ['config|C:s' => 'Supply the config file for parsing by Config::Any', { depends => 'config_stanza'} ],
32 # ['connect-info|n:s%' => ' supply the connect info as additonal options ie -I dsn=<dsn> user=<user> password=<pass> '],
33 # ['sql-dir|q:s' => 'The directory where sql diffs will be created'],
34 # ['sql-type|t:s' => 'The RDBMs falvour you wish to use'],
35 # ['version|v:i' => 'Supply a version install'],
36 # ['preversion|p:s' => 'The previous version to diff against',],
38 # 'schema=s' => \my $schema_class,
39 # 'class=s' => \my $resultset_class,
40 # 'connect=s' => \my $connect,
42 # 'set=s' => \my $set,
43 # 'where=s' => \my $where,
44 # 'attrs=s' => \my $attrs,
45 # 'format=s' => \my $format,
46 # 'force' => \my $force,
47 # 'trace' => \my $trace,
48 # 'quiet' => \my $quiet,
49 # 'help' => \my $help,
50 # 'tlibs' => \my $t_libs,
55 DBIx::Class::Admin - Administration object for schemas
59 use DBIx::Class::Admin;
62 my $admin = DBIx::Class::Admin->new(
63 schema_class=> 'MY::Schema',
65 connect_info => { dsn => $dsn, user => $user, password => $pass },
69 $admin->create('SQLite');
71 # create SQL diff for an upgrade
72 $admin->create('SQLite', {} , "1.0");
77 # install a version for an unversioned schema
78 $admin->install("3.0");
84 add a library search path
90 trigger => \&_set_inc,
94 my ($self, $lib) = @_;
95 push @INC, $lib->stringify;
100 the class of the schema to load
102 has 'schema_class' => (
110 A pre-connected schema object can be provided for manipulation
114 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 connect_info the arguments to provide to the connect call of the schema_class
132 has 'connect_info' => (
138 sub _build_connect_info {
140 return $self->_find_stanza($self->config, $self->config_stanza);
145 config_file provide a config_file to read connect_info from, if this is provided
146 config_stanze should also be provided to locate where the connect_info is in the config
147 The config file should be in a format readable by Config::General
157 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
158 designed for use with catalyst config files
160 has 'config_stanza' => (
167 Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
168 config_stanza will still be required.
178 try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
180 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
182 # just grab the config from the config file
183 $cfg = $cfg->{$self->config_file};
189 The location where sql ddl files should be created or found for an upgrade.
199 Used for install, the version which will be 'installed' in the schema
208 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
217 Try and force certain operations.
226 Be less verbose about actions
244 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
248 L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
249 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
251 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
253 Optional preversion can be supplied to generate a diff to be used by upgrade.
257 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
259 $preversion ||= $self->preversion();
261 my $schema = $self->schema();
262 # create the dir if does not exist
263 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
265 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
272 =item Arguments: <none>
276 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
277 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
282 my $schema = $self->schema();
283 if (!$schema->get_db_version()) {
284 # schema is unversioned
285 die "could not determin current schema version, please either install or deploy";
287 my $ret = $schema->upgrade();
296 =item Arguments: $version
300 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
301 database. install will take a version and add the version tracking tables and 'install' the version. No
302 further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
303 already versioned databases.
306 my ($self, $version) = @_;
308 my $schema = $self->schema();
309 $version ||= $self->version();
310 if (!$schema->get_db_version() ) {
311 # schema is unversioned
312 print "Going to install schema version\n";
313 my $ret = $schema->install($version);
314 print "retun is $ret\n";
316 elsif ($schema->get_db_version() and $self->force ) {
317 warn "forcing install may not be a good idea";
318 if($self->_confirm() ) {
320 $self->schema->_set_db_version({ version => $version});
324 die "schema already has a version not installing, try upgrade instead";
333 =item Arguments: $args
337 deploy will create the schema at the connected database. C<$args> are passed straight to
338 L<DBIx::Class::Schema/deploy>.
341 my ($self, $args) = @_;
342 my $schema = $self->schema();
343 if (!$schema->get_db_version() ) {
344 # schema is unversioned
345 $schema->deploy( $args, $self->sql_dir)
346 or die "could not deploy schema";
348 die "there already is a database with a version here, try upgrade instead";
353 # FIXME ensure option spec compatability
354 #die('Do not use the where option with the insert op') if ($where);
355 #die('Do not use the attrs option with the insert op') if ($attrs);
361 =item Arguments: $rs, $set
365 insert_data takes the name of a resultset from the schema_class and a hashref of data to insert
370 my ($self, $rs, $set) = @_;
371 my $resultset = $self->schema->resultset($rs);
372 my $obj = $resultset->create( $set );
373 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
381 =item Arguments: $rs, $set, $where
385 update_data takes the name of a resultset from the schema_class, a hashref of data to update and
386 a where hash used to form the search for the rows to update.
389 my ($self, $rs, $set, $where) = @_;
391 my $resultset = $self->schema->resultset($rs);
392 $resultset = $resultset->search( ($where||{}) );
394 my $count = $resultset->count();
395 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
397 if ( $self->force || $self->_confirm() ) {
398 $resultset->update_all( $set );
403 #die('Do not use the set option with the delete op') if ($set);
408 =item Arguments: $rs, $where, $attrs
412 delete_data takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
413 The found data is deleted and cannot be recovered.
416 my ($self, $rs, $where, $attrs) = @_;
418 my $resultset = $self->schema->resultset($rs);
419 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
421 my $count = $resultset->count();
422 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
424 if ( $self->force || $self->_confirm() ) {
425 $resultset->delete_all();
433 =item Arguments: $rs, $where, $attrs
437 select_data takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
438 The found data is returned in a array ref where the first row will be the columns list.
442 my ($self, $rs, $where, $attrs) = @_;
444 my $resultset = $self->schema->resultset($rs);
445 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
448 my @columns = $resultset->result_source->columns();
449 push @data, [@columns];#
451 while (my $row = $resultset->next()) {
453 foreach my $column (@columns) {
454 push( @fields, $row->get_column($column) );
456 push @data, [@fields];
464 print "Are you sure you want to do this? (type YES to confirm) \n";
465 # mainly here for testing
466 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
467 my $response = <STDIN>;
468 return 1 if ($response=~/^YES/);
473 my ($self, $cfg, $stanza) = @_;
474 my @path = split /::/, $stanza;
475 while (my $path = shift @path) {
476 if (exists $cfg->{$path}) {
477 $cfg = $cfg->{$path};
480 die "could not find $stanza in config, $path did not seem to exist";