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 '_confirm' => (
 161         is              => 'ro',
 162         isa             => 'Bool',
 163 );
 164
 165 sub create {
 166         my ($self, $sqlt_type, $sqlt_args) = @_;
 167         if ($self->has_preversion) {
 168                 print "attempting to create diff file for ".$self->preversion."\n";
 169         }
 170         my $schema = $self->schema();
 171         # create the dir if does not exist
 172         $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
 173
 174         $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args );
 175 }
 176
 177 sub upgrade {
 178         my ($self) = @_;
 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";
 183         } else {
 184                 $schema->upgrade();
 185         }
 186 }
 187
 188 sub install {
 189         my ($self, $version) = @_;
 190
 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";
 198         }
 199         elsif ($schema->get_db_version() and $self->force ) {
 200                 warn "forcing install may not be a good idea";
 201                 if($self->confirm() ) {
 202                         # FIXME private api
 203                         warn $version;
 204                         $self->schema->_set_db_version({ version => $version});
 205                 }
 206         }
 207         else {
 208                 die "schema already has a version not installing, try upgrade instead";
 209         }
 210
 211 }
 212
 213 sub deploy {
 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";
 220         } else {
 221                 die "there already is a database with a version here, try upgrade instead";
 222         }
 223 }
 224
 225 sub find_stanza {
 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};
 231                 }
 232                 else {
 233                         die "could not find $stanza in config, $path did not seem to exist";
 234                 }
 235         }
 236         return $cfg;
 237 }
 238
 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);
 242 sub insert_data {
 243         my ($self, $resultset, $set) = @_;
 244         my $obj = $resultset->create( $set );
 245     print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
 246 }
 247
 248 sub update_data {
 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 );
 255     }
 256 }
 257
 258 # FIXME
 259 #die('Do not use the set option with the delete op') if ($set);
 260 sub delete_data {
 261         my ($self, $resultset, $where, $attrs) = @_;
 262
 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();
 268     }
 269 }
 270
 271
 272 #FIXME
 273 # die('Do not use the set option with the select op') if ($set);
 274 sub select_data {
 275         my ($self, $resultset, $where, $attrs) = @_;
 276
 277
 278     $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 279 }
 280
 281 # TODO, make this more generic, for different data formats
 282 sub output_data {
 283         my ($self, $resultset) = @_;
 284
 285 #       eval {
 286 #               ensure_class_loaded 'Data::Tabular::Dumper';
 287 #       };
 288 #       if($@) {
 289 #               die "Data::Tabular::Dumper is needed for outputing data";
 290 #       }
 291         my $csv_class;
 292         # load compatible CSV generators
 293         foreach $csv_class (qw(Text::CSV_XS Text::CSV_PP)) {
 294                 eval { ensure_class_loaded $csv_class};
 295                 if($@) {
 296                         $csv_class = undef;
 297                         next;
 298                 }
 299         }
 300         if (not defined $csv_class) {
 301                 die ('The select op requires either the Text::CSV_XS or the Text::CSV_PP module');
 302         }
 303
 304     my $csv = $csv_class->new({
 305        sep_char => ( $self->csv_format eq 'tsv' ? "\t" : ',' ),
 306     });
 307
 308     my @columns = $resultset->result_source->columns();
 309     $csv->combine( @columns );
 310     print $csv->string()."\n";
 311     while (my $row = $resultset->next()) {
 312         my @fields;
 313         foreach my $column (@columns) {
 314             push( @fields, $row->get_column($column) );
 315         }
 316         $csv->combine( @fields );
 317         print $csv->string()."\n";
 318     }
 319 }
 320
 321 sub confirm {
 322     my ($self) = @_;
 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/);
 328     return;
 329 }
 330
 331 1;