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 #warn Dumper ($self->connect_info(), $self->connect_info->[3], {ignore_version => 1 });
91 return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
94 has 'connect_info' => (
100 sub _build_connect_info {
102 return find_stanza($self->config, $self->config_stanza);
113 try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
115 my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
117 # just grab the config from the config file
118 $cfg = $cfg->{$self->config_file};
127 has 'config_stanza' => (
153 predicate => 'has_preversion',
157 my ($self, $sqlt_type, $sqlt_args) = @_;
158 if ($self->has_preversion) {
159 print "attempting to create diff file for ".$self->preversion."\n";
161 my $schema = $self->schema();
162 # warn "running with params sqlt_type = $sqlt_type, version = " .$schema->schema_version . " sql_dir = " . $self->sql_dir . " preversion = " . ($self->has_preversion ? $self->preversion : "" ). "\n";
163 # create the dir if does not exist
164 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
166 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args );
171 my $schema = $self->schema();
172 if (!$schema->get_db_version()) {
173 # schema is unversioned
174 warn "could not determin current schema version, please either install or deploy";
183 my $schema = $self->schema();
184 if (!$schema->get_db_version()) {
185 # schema is unversioned
186 print "Going to install schema version";
187 $schema->install($self->version);
189 warn "schema already has a version not installing, try upgrade instead";
195 my ($self, $args) = @_;
196 my $schema = $self->schema();
197 if (!$schema->get_db_version() ) {
198 # schema is unversioned
199 # warn "going to deploy";
200 # warn Dumper $schema->deployment_statements();
202 $schema->deploy( $args, $self->sql_dir)
203 or die "could not deploy schema";
205 warn "there already is a database with a version here, try upgrade instead";
210 my ($self, $cfg, $stanza) = @_;
211 my @path = split /::/, $stanza;
212 while (my $path = shift @path) {
213 if (exists $cfg->{$path}) {
214 $cfg = $cfg->{$path};
217 die "could not find $stanza in config, $path did not seem to exist";
223 # FIXME ensure option spec compatability
224 #die('Do not use the where option with the insert op') if ($where);
225 #die('Do not use the attrs option with the insert op') if ($attrs);
227 my ($self, $resultset, $set) = @_;
228 my $obj = $resultset->create( $set );
229 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
233 my ($self, $resultset, $set, $where) = @_;
234 $resultset = $resultset->search( ($where||{}) );
235 my $count = $resultset->count();
236 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
237 if ( $self->force || $self->confirm() ) {
238 $resultset->update_all( $set );
243 #die('Do not use the set option with the delete op') if ($set);
245 my ($self, $resultset, $where, $attrs) = @_;
247 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
248 my $count = $resultset->count();
249 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
250 if ( $self->force || $self->confirm() ) {
251 $resultset->delete_all();
257 # die('Do not use the set option with the select op') if ($set);
259 my ($self, $resultset, $where, $attrs) = @_;
262 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
265 # TODO, make this more generic, for different data formats
267 my ($self, $resultset) = @_;
270 # ensure_class_loaded 'Data::Tabular::Dumper';
273 # die "Data::Tabular::Dumper is needed for outputing data";
276 # load compatible CSV generators
277 foreach $csv_class (qw(Text::CSV_XS Text::CSV_PP)) {
278 eval { ensure_class_loaded $csv_class};
284 if (not defined $csv_class) {
285 die ('The select op requires either the Text::CSV_XS or the Text::CSV_PP module');
288 my $csv = $csv_class->new({
289 sep_char => ( $self->csv_format eq 'tsv' ? "\t" : ',' ),
292 my @columns = $resultset->result_source->columns();
293 $csv->combine( @columns );
294 print $csv->string()."\n";
295 while (my $row = $resultset->next()) {
297 foreach my $column (@columns) {
298 push( @fields, $row->get_column($column) );
300 $csv->combine( @fields );
301 print $csv->string()."\n";
306 print "Are you sure you want to do this? (type YES to confirm) ";
307 my $response = <STDIN>;
308 return 1 if ($response=~/^YES/);