lib/DBIx/Class/Admin.pm

   1 #
   2 #===============================================================================
   3 #
   4 #         FILE:  Admin.pm
   5 #
   6 #  DESCRIPTION:  Administrative functions for DBIx::Class Schemata
   7 #
   8 #        FILES:  ---
   9 #         BUGS:  ---
  10 #        NOTES:  ---
  11 #       AUTHOR:  Gordon Irving (), <Gordon.irving@sophos.com>
  12 #      VERSION:  1.0
  13 #      CREATED:  28/11/09 12:27:15 GMT
  14 #     REVISION:  ---
  15 #===============================================================================
  16
  17 package DBIx::Class::Admin;
  18
  19 use Moose;
  20 use MooseX::Types;
  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;
  24 use Try::Tiny;
  25 use parent 'Class::C3::Componentised';
  26
  27 use Data::Dumper;
  28 =c
  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',],
  38
  39     'schema=s'  => \my $schema_class,
  40     'class=s'   => \my $resultset_class,
  41     'connect=s' => \my $connect,
  42     'op=s'      => \my $op,
  43     'set=s'     => \my $set,
  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,
  50     'help'      => \my $help,
  51     'tlibs'      => \my $t_libs,
  52 =cut
  53
  54 =head1 Attributes
  55
  56 =cut
  57 has lib => (
  58         is              => 'ro',
  59         isa             => Dir,
  60         coerce  => 1,
  61         trigger => \&_set_inc,
  62 );
  63
  64 sub _set_inc {
  65         my ($self, $lib) = @_;
  66         push @INC, $lib->stringify;
  67 }
  68
  69
  70 has 'schema_class' => (
  71         is              => 'ro',
  72         isa             => 'Str',
  73         coerce  => 1,
  74 );
  75
  76
  77 has 'schema' => (
  78         is                      => 'ro',
  79         isa                     => 'DBIx::Class::Schema',
  80         lazy_build      => 1,
  81 );
  82
  83
  84
  85 sub _build_schema {
  86         my ($self)  = @_;
  87         $self->ensure_class_loaded($self->schema_class);
  88
  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} );
  92 }
  93
  94 has 'connect_info' => (
  95         is                      => 'ro',
  96         isa                     => ArrayRef,
  97         lazy_build      => 1,
  98 );
  99
 100 sub _build_connect_info {
 101         my ($self) = @_;
 102         return find_stanza($self->config, $self->config_stanza);
 103 }
 104
 105 has config => (
 106         is                      => 'ro',
 107         isa                     => HashRef,
 108         lazy_build      => 1,
 109 );
 110
 111 sub _build_config {
 112         my ($self) = @_;
 113         try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
 114
 115         my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
 116
 117         # just grab the config from the config file
 118         $cfg = $cfg->{$self->config_file};
 119         return $cfg;
 120 }
 121
 122 has config_file => (
 123         is                      => 'ro',
 124         isa                     => File,
 125 );
 126
 127 has 'config_stanza' => (
 128         is                      => 'ro',
 129         isa                     => 'Str',
 130 );
 131
 132 has 'sql_dir' => (
 133         is                      => 'ro',
 134         isa                     => Dir,
 135         coerce          => 1,
 136 );
 137
 138
 139
 140 has 'sql_type' => (
 141         is                      => 'ro',
 142         isa                     => 'Str',
 143 );
 144
 145 has version => (
 146         is                      => 'ro',
 147         isa                     => 'Str',
 148 );
 149
 150 has preversion => (
 151         is                      => 'rw',
 152         isa                     => 'Str',
 153         predicate       => 'has_preversion',
 154 );
 155
 156 sub create {
 157         my ($self, $sqlt_type, $sqlt_args) = @_;
 158         if ($self->has_preversion) {
 159                 print "attempting to create diff file for ".$self->preversion."\n";
 160         }
 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);
 165
 166         $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args );
 167 }
 168
 169 sub upgrade {
 170         my ($self) = @_;
 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";
 175         } else {
 176                 $schema->upgrade();
 177         }
 178 }
 179
 180 sub install {
 181         my ($self) = @_;
 182
 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);
 188         } else {
 189                 warn "schema already has a version not installing, try upgrade instead";
 190         }
 191
 192 }
 193
 194 sub deploy {
 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();
 201
 202                 $schema->deploy( $args, $self->sql_dir)
 203                         or die "could not deploy schema";
 204         } else {
 205                 warn "there already is a database with a version here, try upgrade instead";
 206         }
 207 }
 208
 209 sub find_stanza {
 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};
 215                 }
 216                 else {
 217                         die "could not find $stanza in config, $path did not seem to exist";
 218                 }
 219         }
 220         return $cfg;
 221 }
 222
 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);
 226 sub insert_data {
 227         my ($self, $resultset, $set) = @_;
 228         my $obj = $resultset->create( $set );
 229     print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
 230 }
 231
 232 sub update_data {
 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 );
 239     }
 240 }
 241
 242 # FIXME
 243 #die('Do not use the set option with the delete op') if ($set);
 244 sub delete_data {
 245         my ($self, $resultset, $where, $attrs) = @_;
 246
 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();
 252     }
 253 }
 254
 255
 256 #FIXME
 257 # die('Do not use the set option with the select op') if ($set);
 258 sub select_data {
 259         my ($self, $resultset, $where, $attrs) = @_;
 260
 261
 262     $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 263 }
 264
 265 # TODO, make this more generic, for different data formats
 266 sub output_data {
 267         my ($self, $resultset) = @_;
 268
 269 #       eval {
 270 #               ensure_class_loaded 'Data::Tabular::Dumper';
 271 #       };
 272 #       if($@) {
 273 #               die "Data::Tabular::Dumper is needed for outputing data";
 274 #       }
 275         my $csv_class;
 276         # load compatible CSV generators
 277         foreach $csv_class (qw(Text::CSV_XS Text::CSV_PP)) {
 278                 eval { ensure_class_loaded $csv_class};
 279                 if($@) {
 280                         $csv_class = undef;
 281                         next;
 282                 }
 283         }
 284         if (not defined $csv_class) {
 285                 die ('The select op requires either the Text::CSV_XS or the Text::CSV_PP module');
 286         }
 287
 288     my $csv = $csv_class->new({
 289        sep_char => ( $self->csv_format eq 'tsv' ? "\t" : ',' ),
 290     });
 291
 292     my @columns = $resultset->result_source->columns();
 293     $csv->combine( @columns );
 294     print $csv->string()."\n";
 295     while (my $row = $resultset->next()) {
 296         my @fields;
 297         foreach my $column (@columns) {
 298             push( @fields, $row->get_column($column) );
 299         }
 300         $csv->combine( @fields );
 301         print $csv->string()."\n";
 302     }
 303 }
 304
 305 sub confirm {
 306     print "Are you sure you want to do this? (type YES to confirm) ";
 307     my $response = <STDIN>;
 308     return 1 if ($response=~/^YES/);
 309     return;
 310 }
 311
 312 1;