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         warn Dumper $self->connect_info();
  89
  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                      => 'ro',
 146         isa                     => 'Str',
 147 );
 148
 149 has preversion => (
 150         is                      => 'rw',
 151         isa                     => 'Str',
 152         predicate       => 'has_preversion',
 153 );
 154
 155 sub create {
 156         my ($self, $sqlt_type, ) = @_;
 157         if ($self->has_preversion) {
 158                 print "attempting to create diff file for ".$self->preversion."\n";
 159         }
 160         my $schema = $self->schema();
 161 #       warn "running with params sqlt_type = $sqlt_type, version = " .$schema->schema_version . " sql_dir = " . $self->sql_dir . " preversion = " . ($self->has_preversion ?  $self->preversion : "" ). "\n";
 162         # create the dir if does not exist
 163         $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
 164
 165         $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion );
 166 }
 167
 168 sub upgrade {
 169         my ($self) = @_;
 170         my $schema = $self->schema();
 171         if (!$schema->get_db_version()) {
 172                 # schema is unversioned
 173                 warn "could not determin current schema version, please either install or deploy";
 174         } else {
 175                 $schema->upgrade();
 176         }
 177 }
 178
 179 sub install {
 180         my ($self) = @_;
 181
 182         my $schema = $self->schema();
 183         if (!$schema->get_db_version()) {
 184                 # schema is unversioned
 185                 print "Going to install schema version";
 186                 $schema->install($self->version);
 187         } else {
 188                 warn "schema already has a version not installing, try upgrade instead";
 189         }
 190
 191 }
 192
 193 sub deploy {
 194         my ($self) = @_;
 195         my $schema = $self->schema();
 196         if (!$schema->get_db_version() ) {
 197                 # schema is unversioned
 198                 $schema->deploy();
 199         } else {
 200                 warn "there already is a database with a version here, try upgrade instead";
 201         }
 202 }
 203
 204 sub find_stanza {
 205         my ($self, $cfg, $stanza) = @_;
 206         my @path = split /::/, $stanza;
 207         while (my $path = shift @path) {
 208                 if (exists $cfg->{$path}) {
 209                         $cfg = $cfg->{$path};
 210                 }
 211                 else {
 212                         die "could not find $stanza in config, $path did not seem to exist";
 213                 }
 214         }
 215         return $cfg;
 216 }
 217
 218 # FIXME ensure option spec compatability
 219 #die('Do not use the where option with the insert op') if ($where);
 220 #die('Do not use the attrs option with the insert op') if ($attrs);
 221 sub insert_data {
 222         my ($self, $resultset, $set) = @_;
 223         my $obj = $resultset->create( $set );
 224     print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
 225 }
 226
 227 sub update_data {
 228         my ($self, $resultset, $set, $where) = @_;
 229     $resultset = $resultset->search( ($where||{}) );
 230     my $count = $resultset->count();
 231     print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
 232     if ( $self->force || $self->confirm() ) {
 233         $resultset->update_all( $set );
 234     }
 235 }
 236
 237 # FIXME
 238 #die('Do not use the set option with the delete op') if ($set);
 239 sub delete_data {
 240         my ($self, $resultset, $where, $attrs) = @_;
 241
 242     $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 243     my $count = $resultset->count();
 244     print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
 245     if ( $self->force || $self->confirm() ) {
 246         $resultset->delete_all();
 247     }
 248 }
 249
 250
 251 #FIXME
 252 # die('Do not use the set option with the select op') if ($set);
 253 sub select_data {
 254         my ($self, $resultset, $where, $attrs) = @_;
 255
 256
 257     $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 258 }
 259
 260 # TODO, make this more generic, for different data formats
 261 sub output_data {
 262         my ($self, $resultset) = @_;
 263
 264 #       eval {
 265 #               ensure_class_loaded 'Data::Tabular::Dumper';
 266 #       };
 267 #       if($@) {
 268 #               die "Data::Tabular::Dumper is needed for outputing data";
 269 #       }
 270         my $csv_class;
 271         # load compatible CSV generators
 272         foreach $csv_class (qw(Text::CSV_XS Text::CSV_PP)) {
 273                 eval { ensure_class_loaded $csv_class};
 274                 if($@) {
 275                         $csv_class = undef;
 276                         next;
 277                 }
 278         }
 279         if (not defined $csv_class) {
 280                 die ('The select op requires either the Text::CSV_XS or the Text::CSV_PP module');
 281         }
 282
 283     my $csv = $csv_class->new({
 284        sep_char => ( $self->csv_format eq 'tsv' ? "\t" : ',' ),
 285     });
 286
 287     my @columns = $resultset->result_source->columns();
 288     $csv->combine( @columns );
 289     print $csv->string()."\n";
 290     while (my $row = $resultset->next()) {
 291         my @fields;
 292         foreach my $column (@columns) {
 293             push( @fields, $row->get_column($column) );
 294         }
 295         $csv->combine( @fields );
 296         print $csv->string()."\n";
 297     }
 298 }
 299
 300 sub confirm {
 301     print "Are you sure you want to do this? (type YES to confirm) ";
 302     my $response = <STDIN>;
 303     return 1 if ($response=~/^YES/);
 304     return;
 305 }
 306
 307 1;