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);
23 #use DBIx::Class::Schema;
25 use parent 'Class::C3::Componentised';
29 ['lib|I:s' => 'Additonal library path to search in'],
30 ['schema|s:s' => 'The class of the schema to load', { required => 1 } ],
31 ['config-stanza|S:s' => 'Where in the config to find the connection_info, supply in form MyApp::Model::DB',],
32 ['config|C:s' => 'Supply the config file for parsing by Config::Any', { depends => 'config_stanza'} ],
33 ['connect-info|n:s%' => ' supply the connect info as additonal options ie -I dsn=<dsn> user=<user> password=<pass> '],
34 ['sql-dir|q:s' => 'The directory where sql diffs will be created'],
35 ['sql-type|t:s' => 'The RDBMs falvour you wish to use'],
36 ['version|v:i' => 'Supply a version install'],
37 ['preversion|p:s' => 'The previous version to diff against',],
39 'schema=s' => \my $schema_class,
40 'class=s' => \my $resultset_class,
41 'connect=s' => \my $connect,
44 'where=s' => \my $where,
45 'attrs=s' => \my $attrs,
46 'format=s' => \my $format,
47 'force' => \my $force,
48 'trace' => \my $trace,
49 'quiet' => \my $quiet,
51 'tlibs' => \my $t_libs,
61 trigger => \&_set_inc,
65 my ($self, $lib) = @_;
66 push @INC, $lib->stringify;
70 has 'schema_class' => (
79 isa => 'DBIx::Class::Schema',
87 $self->ensure_class_loaded($self->schema_class);
89 $self->connect_info->[3]->{ignore_version} =1;
90 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
93 has 'connect_info' => (
99 sub _build_connect_info {
101 return find_stanza($self->config, $self->config_stanza);
112 try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
114 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
116 # just grab the config from the config file
117 $cfg = $cfg->{$self->config_file};
126 has 'config_stanza' => (
152 predicate => 'has_preversion',
171 my ($self, $sqlt_type, $sqlt_args) = @_;
172 if ($self->has_preversion) {
173 print "attempting to create diff file for ".$self->preversion."\n";
175 my $schema = $self->schema();
176 # create the dir if does not exist
177 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
179 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args );
184 my $schema = $self->schema();
185 if (!$schema->get_db_version()) {
186 # schema is unversioned
187 die "could not determin current schema version, please either install or deploy";
189 my $ret = $schema->upgrade();
195 my ($self, $version) = @_;
197 my $schema = $self->schema();
198 $version ||= $self->version();
199 if (!$schema->get_db_version() ) {
200 # schema is unversioned
201 print "Going to install schema version\n";
202 my $ret = $schema->install($version);
203 print "retun is $ret\n";
205 elsif ($schema->get_db_version() and $self->force ) {
206 warn "forcing install may not be a good idea";
207 if($self->confirm() ) {
209 $self->schema->_set_db_version({ version => $version});
213 die "schema already has a version not installing, try upgrade instead";
219 my ($self, $args) = @_;
220 my $schema = $self->schema();
221 if (!$schema->get_db_version() ) {
222 # schema is unversioned
223 $schema->deploy( $args, $self->sql_dir)
224 or die "could not deploy schema";
226 die "there already is a database with a version here, try upgrade instead";
231 my ($self, $cfg, $stanza) = @_;
232 my @path = split /::/, $stanza;
233 while (my $path = shift @path) {
234 if (exists $cfg->{$path}) {
235 $cfg = $cfg->{$path};
238 die "could not find $stanza in config, $path did not seem to exist";
244 # FIXME ensure option spec compatability
245 #die('Do not use the where option with the insert op') if ($where);
246 #die('Do not use the attrs option with the insert op') if ($attrs);
248 my ($self, $rs, $set) = @_;
249 my $resultset = $self->schema->resultset($rs);
250 my $obj = $resultset->create( $set );
251 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
255 my ($self, $rs, $set, $where) = @_;
257 my $resultset = $self->schema->resultset($rs);
258 $resultset = $resultset->search( ($where||{}) );
260 my $count = $resultset->count();
261 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
263 if ( $self->force || $self->confirm() ) {
264 $resultset->update_all( $set );
269 #die('Do not use the set option with the delete op') if ($set);
271 my ($self, $rs, $where, $attrs) = @_;
273 my $resultset = $self->schema->resultset($rs);
274 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
276 my $count = $resultset->count();
277 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
279 if ( $self->force || $self->confirm() ) {
280 $resultset->delete_all();
285 my ($self, $rs, $where, $attrs) = @_;
287 my $resultset = $self->schema->resultset($rs);
288 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
291 my @columns = $resultset->result_source->columns();
292 push @data, [@columns];#
294 while (my $row = $resultset->next()) {
296 foreach my $column (@columns) {
297 push( @fields, $row->get_column($column) );
299 push @data, [@fields];
307 print "Are you sure you want to do this? (type YES to confirm) \n";
308 # mainly here for testing
309 return 1 if ($self->_confirm());
310 my $response = <STDIN>;
311 return 1 if ($response=~/^YES/);