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         return $self->schema_class->connect(@{$self->connect_info()} ); # ,  $self->connect_info->[3], { ignore_version => 1} );
  91 }
  92
  93 has 'connect_info' => (
  94         is                      => 'ro',
  95         isa                     => ArrayRef,
  96         lazy_build      => 1,
  97 );
  98
  99 sub _build_connect_info {
 100         my ($self) = @_;
 101         return find_stanza($self->config, $self->config_stanza);
 102 }
 103
 104 has config => (
 105         is                      => 'ro',
 106         isa                     => HashRef,
 107         lazy_build      => 1,
 108 );
 109
 110 sub _build_config {
 111         my ($self) = @_;
 112         try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; };
 113
 114         my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
 115
 116         # just grab the config from the config file
 117         $cfg = $cfg->{$self->config_file};
 118         return $cfg;
 119 }
 120
 121 has config_file => (
 122         is                      => 'ro',
 123         isa                     => File,
 124 );
 125
 126 has 'config_stanza' => (
 127         is                      => 'ro',
 128         isa                     => 'Str',
 129 );
 130
 131 has 'sql_dir' => (
 132         is                      => 'ro',
 133         isa                     => Dir,
 134         coerce          => 1,
 135 );
 136
 137
 138
 139 has 'sql_type' => (
 140         is                      => 'ro',
 141         isa                     => 'Str',
 142 );
 143
 144 has version => (
 145         is                      => 'rw',
 146         isa                     => 'Str',
 147 );
 148
 149 has preversion => (
 150         is                      => 'rw',
 151         isa                     => 'Str',
 152         predicate       => 'has_preversion',
 153 );
 154
 155 has force => (
 156         is                      => 'rw',
 157         isa                     => 'Bool',
 158 );
 159
 160 has quiet => (
 161         is                      => 'rw',
 162         isa                     => 'Bool',
 163 );
 164
 165 has '_confirm' => (
 166         is              => 'ro',
 167         isa             => 'Bool',
 168 );
 169
 170 sub create {
 171         my ($self, $sqlt_type, $sqlt_args) = @_;
 172         if ($self->has_preversion) {
 173                 print "attempting to create diff file for ".$self->preversion."\n";
 174         }
 175         my $schema = $self->schema();
 176         # create the dir if does not exist
 177         $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
 178
 179         $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args );
 180 }
 181
 182 sub upgrade {
 183         my ($self) = @_;
 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";
 188         } else {
 189                 my $ret = $schema->upgrade();
 190                 return $ret;
 191         }
 192 }
 193
 194 sub install {
 195         my ($self, $version) = @_;
 196
 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";
 204         }
 205         elsif ($schema->get_db_version() and $self->force ) {
 206                 warn "forcing install may not be a good idea";
 207                 if($self->confirm() ) {
 208                         # FIXME private api
 209                         $self->schema->_set_db_version({ version => $version});
 210                 }
 211         }
 212         else {
 213                 die "schema already has a version not installing, try upgrade instead";
 214         }
 215
 216 }
 217
 218 sub deploy {
 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";
 225         } else {
 226                 die "there already is a database with a version here, try upgrade instead";
 227         }
 228 }
 229
 230 sub find_stanza {
 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};
 236                 }
 237                 else {
 238                         die "could not find $stanza in config, $path did not seem to exist";
 239                 }
 240         }
 241         return $cfg;
 242 }
 243
 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);
 247 sub insert_data {
 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);
 252 }
 253
 254 sub update_data {
 255         my ($self, $rs, $set, $where) = @_;
 256
 257         my $resultset = $self->schema->resultset($rs);
 258         $resultset = $resultset->search( ($where||{}) );
 259
 260         my $count = $resultset->count();
 261         print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
 262
 263         if ( $self->force || $self->confirm() ) {
 264                 $resultset->update_all( $set );
 265         }
 266 }
 267
 268 # FIXME
 269 #die('Do not use the set option with the delete op') if ($set);
 270 sub delete_data {
 271         my ($self, $rs, $where, $attrs) = @_;
 272
 273         my $resultset = $self->schema->resultset($rs);
 274         $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 275
 276         my $count = $resultset->count();
 277         print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
 278
 279         if ( $self->force || $self->confirm() ) {
 280                 $resultset->delete_all();
 281         }
 282 }
 283
 284 sub select_data {
 285         my ($self, $rs, $where, $attrs) = @_;
 286
 287         my $resultset = $self->schema->resultset($rs);
 288         $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 289
 290         my @data;
 291         my @columns = $resultset->result_source->columns();
 292         push @data, [@columns];#
 293
 294         while (my $row = $resultset->next()) {
 295                 my @fields;
 296                 foreach my $column (@columns) {
 297                         push( @fields, $row->get_column($column) );
 298                 }
 299                 push @data, [@fields];
 300         }
 301
 302         return \@data;
 303 }
 304
 305 sub confirm {
 306         my ($self) = @_;
 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/);
 312         return;
 313 }
 314
 315 1;