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',
166 my ($self, $sqlt_type, $sqlt_args) = @_;
167 if ($self->has_preversion) {
168 print "attempting to create diff file for ".$self->preversion."\n";
170 my $schema = $self->schema();
171 # create the dir if does not exist
172 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
174 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args );
179 my $schema = $self->schema();
180 if (!$schema->get_db_version()) {
181 # schema is unversioned
182 die "could not determin current schema version, please either install or deploy";
189 my ($self, $version) = @_;
191 my $schema = $self->schema();
192 $version ||= $self->version();
193 if (!$schema->get_db_version() ) {
194 # schema is unversioned
195 print "Going to install schema version\n";
196 my $ret = $schema->install($version);
197 print "retun is $ret\n";
199 elsif ($schema->get_db_version() and $self->force ) {
200 warn "forcing install may not be a good idea";
201 if($self->confirm() ) {
204 $self->schema->_set_db_version({ version => $version});
208 die "schema already has a version not installing, try upgrade instead";
214 my ($self, $args) = @_;
215 my $schema = $self->schema();
216 if (!$schema->get_db_version() ) {
217 # schema is unversioned
218 $schema->deploy( $args, $self->sql_dir)
219 or die "could not deploy schema";
221 die "there already is a database with a version here, try upgrade instead";
226 my ($self, $cfg, $stanza) = @_;
227 my @path = split /::/, $stanza;
228 while (my $path = shift @path) {
229 if (exists $cfg->{$path}) {
230 $cfg = $cfg->{$path};
233 die "could not find $stanza in config, $path did not seem to exist";
239 # FIXME ensure option spec compatability
240 #die('Do not use the where option with the insert op') if ($where);
241 #die('Do not use the attrs option with the insert op') if ($attrs);
243 my ($self, $resultset, $set) = @_;
244 my $obj = $resultset->create( $set );
245 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
249 my ($self, $resultset, $set, $where) = @_;
250 $resultset = $resultset->search( ($where||{}) );
251 my $count = $resultset->count();
252 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
253 if ( $self->force || $self->confirm() ) {
254 $resultset->update_all( $set );
259 #die('Do not use the set option with the delete op') if ($set);
261 my ($self, $resultset, $where, $attrs) = @_;
263 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
264 my $count = $resultset->count();
265 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
266 if ( $self->force || $self->confirm() ) {
267 $resultset->delete_all();
273 # die('Do not use the set option with the select op') if ($set);
275 my ($self, $resultset, $where, $attrs) = @_;
278 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
281 # TODO, make this more generic, for different data formats
283 my ($self, $resultset) = @_;
286 # ensure_class_loaded 'Data::Tabular::Dumper';
289 # die "Data::Tabular::Dumper is needed for outputing data";
292 # load compatible CSV generators
293 foreach $csv_class (qw(Text::CSV_XS Text::CSV_PP)) {
294 eval { ensure_class_loaded $csv_class};
300 if (not defined $csv_class) {
301 die ('The select op requires either the Text::CSV_XS or the Text::CSV_PP module');
304 my $csv = $csv_class->new({
305 sep_char => ( $self->csv_format eq 'tsv' ? "\t" : ',' ),
308 my @columns = $resultset->result_source->columns();
309 $csv->combine( @columns );
310 print $csv->string()."\n";
311 while (my $row = $resultset->next()) {
313 foreach my $column (@columns) {
314 push( @fields, $row->get_column($column) );
316 $csv->combine( @fields );
317 print $csv->string()."\n";
323 print "Are you sure you want to do this? (type YES to confirm) ";
324 # mainly here for testing
325 return 1 if ($self->_confirm());
326 my $response = <STDIN>;
327 return 1 if ($response=~/^YES/);