lib/DBIx/Class/Admin.pm

   1 package DBIx::Class::Admin;
   2
   3 # check deps
   4 BEGIN {
   5     my @_deps = qw(
   6         Moose MooseX::Types MooseX::Types::JSON MooseX::Types::Path::Class
   7         Try::Tiny parent JSON::Any Class::C3::Componentised
   8         namespace::autoclean
   9     );
  10
  11     my @_missing_deps;
  12     foreach my $dep (@_deps) {
  13       eval "require $dep";
  14       if ($@) {
  15         push @_missing_deps, $dep;
  16       }
  17     }
  18
  19     if (@_missing_deps > 0) {
  20       die "The following dependecies are missing " . join ",", @_missing_deps;
  21     }
  22 }
  23
  24 use Moose;
  25 use parent 'DBIx::Class::Schema';
  26 use Carp::Clan qw/^DBIx::Class/;
  27
  28 use MooseX::Types::Moose qw/Int Str Any Bool/;
  29 use DBIx::Class::Admin::Types qw/DBICConnectInfo DBICHashRef/;
  30 use MooseX::Types::JSON qw(JSON);
  31 use MooseX::Types::Path::Class qw(Dir File);
  32 use Try::Tiny;
  33 use JSON::Any qw(DWIW XS JSON);
  34 use namespace::autoclean;
  35
  36 =head1 NAME
  37
  38 DBIx::Class::Admin - Administration object for schemas
  39
  40 =head1 SYNOPSIS
  41
  42   $ dbicadmin --help
  43
  44   $ dbicadmin --schema=MyApp::Schema \
  45     --connect='["dbi:SQLite:my.db", "", ""]' \
  46     --deploy
  47
  48   $ dbicadmin --schema=MyApp::Schema --class=Employee \
  49     --connect='["dbi:SQLite:my.db", "", ""]' \
  50     --op=update --set='{ "name": "New_Employee" }'
  51
  52   use DBIx::Class::Admin;
  53
  54   # ddl manipulation
  55   my $admin = DBIx::Class::Admin->new(
  56     schema_class=> 'MY::Schema',
  57     sql_dir=> $sql_dir,
  58     connect_info => { dsn => $dsn, user => $user, password => $pass },
  59   );
  60
  61   # create SQLite sql
  62   $admin->create('SQLite');
  63
  64   # create SQL diff for an upgrade
  65   $admin->create('SQLite', {} , "1.0");
  66
  67   # upgrade a database
  68   $admin->upgrade();
  69
  70   # install a version for an unversioned schema
  71   $admin->install("3.0");
  72
  73 =head1 REQUIREMENTS
  74
  75 The following CPAN modules are required to use C<dbicadmin> and this module:
  76
  77 L<Moose>
  78
  79 L<MooseX::Types>
  80
  81 L<MooseX::Types::JSON>
  82
  83 L<MooseX::Types::Path::Class>
  84
  85 L<Try::Tiny>
  86
  87 L<parent>
  88
  89 L<JSON::Any>
  90
  91 (L<JSON::DWIW> preferred for barekey support)
  92
  93 L<namespace::autoclean>
  94
  95 L<Getopt::Long::Descriptive>
  96
  97 L<Text::CSV>
  98
  99 =head1 Attributes
 100
 101 =head2 schema_class
 102
 103 the class of the schema to load
 104
 105 =cut
 106
 107 has 'schema_class' => (
 108   is    => 'ro',
 109   isa    => Str,
 110 );
 111
 112
 113 =head2 schema
 114
 115 A pre-connected schema object can be provided for manipulation
 116
 117 =cut
 118
 119 has 'schema' => (
 120   is      => 'ro',
 121   isa      => 'DBIx::Class::Schema',
 122   lazy_build  => 1,
 123 );
 124
 125 sub _build_schema {
 126   my ($self)  = @_;
 127   $self->ensure_class_loaded($self->schema_class);
 128
 129   $self->connect_info->[3]->{ignore_version} =1;
 130   return $self->schema_class->connect(@{$self->connect_info()} ); # ,  $self->connect_info->[3], { ignore_version => 1} );
 131 }
 132
 133
 134 =head2 resultset
 135
 136 a resultset from the schema to operate on
 137
 138 =cut
 139
 140 has 'resultset' => (
 141   is      => 'rw',
 142   isa      => Str,
 143 );
 144
 145
 146 =head2 where
 147
 148 a hash ref or json string to be used for identifying data to manipulate
 149
 150 =cut
 151
 152 has 'where' => (
 153   is      => 'rw',
 154   isa      => DBICHashRef,
 155   coerce    => 1,
 156 );
 157
 158
 159 =head2 set
 160
 161 a hash ref or json string to be used for inserting or updating data
 162
 163 =cut
 164
 165 has 'set' => (
 166   is      => 'rw',
 167   isa      => DBICHashRef,
 168   coerce    => 1,
 169 );
 170
 171
 172 =head2 attrs
 173
 174 a hash ref or json string to be used for passing additonal info to the ->search call
 175
 176 =cut
 177
 178 has 'attrs' => (
 179   is       => 'rw',
 180   isa      => DBICHashRef,
 181   coerce    => 1,
 182 );
 183
 184
 185 =head2 connect_info
 186
 187 connect_info the arguments to provide to the connect call of the schema_class
 188
 189 =cut
 190
 191 has 'connect_info' => (
 192   is      => 'ro',
 193   isa      => DBICConnectInfo,
 194   lazy_build  => 1,
 195   coerce    => 1,
 196 );
 197
 198 sub _build_connect_info {
 199   my ($self) = @_;
 200   return $self->_find_stanza($self->config, $self->config_stanza);
 201 }
 202
 203
 204 =head2 config_file
 205
 206 config_file provide a config_file to read connect_info from, if this is provided
 207 config_stanze should also be provided to locate where the connect_info is in the config
 208 The config file should be in a format readable by Config::General
 209
 210 =cut
 211
 212 has config_file => (
 213   is      => 'ro',
 214   isa      => File,
 215   coerce    => 1,
 216 );
 217
 218
 219 =head2 config_stanza
 220
 221 config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
 222 designed for use with catalyst config files
 223
 224 =cut
 225
 226 has 'config_stanza' => (
 227   is      => 'ro',
 228   isa      => Str,
 229 );
 230
 231
 232 =head2 config
 233
 234 Instead of loading from a file the configuration can be provided directly as a hash ref.  Please note
 235 config_stanza will still be required.
 236
 237 =cut
 238
 239 has config => (
 240   is      => 'ro',
 241   isa      => DBICHashRef,
 242   lazy_build  => 1,
 243 );
 244
 245 sub _build_config {
 246   my ($self) = @_;
 247
 248   eval { require Config::Any }
 249     or $self->throw_exception( "Config::Any is required to parse the config file");
 250
 251   my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
 252
 253   # just grab the config from the config file
 254   $cfg = $cfg->{$self->config_file};
 255   return $cfg;
 256 }
 257
 258
 259 =head2 sql_dir
 260
 261 The location where sql ddl files should be created or found for an upgrade.
 262
 263 =cut
 264
 265 has 'sql_dir' => (
 266   is      => 'ro',
 267   isa      => Dir,
 268   coerce    => 1,
 269 );
 270
 271
 272 =head2 version
 273
 274 Used for install, the version which will be 'installed' in the schema
 275
 276 =cut
 277
 278 has version => (
 279   is      => 'rw',
 280   isa      => Str,
 281 );
 282
 283
 284 =head2 preversion
 285
 286 Previouse version of the schema to create an upgrade diff for, the full sql for that version of the sql must be in the sql_dir
 287
 288 =cut
 289
 290 has preversion => (
 291   is      => 'rw',
 292   isa      => Str,
 293 );
 294
 295
 296 =head2 force
 297
 298 Try and force certain operations.
 299
 300 =cut
 301
 302 has force => (
 303   is      => 'rw',
 304   isa      => Bool,
 305 );
 306
 307
 308 =head2 quiet
 309
 310 Be less verbose about actions
 311
 312 =cut
 313
 314 has quiet => (
 315   is      => 'rw',
 316   isa      => Bool,
 317 );
 318
 319 has '_confirm' => (
 320   is    => 'bare',
 321   isa    => Bool,
 322 );
 323
 324
 325 =head1 METHODS
 326
 327 =head2 create
 328
 329 =over 4
 330
 331 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
 332
 333 =back
 334
 335 L<create> will generate sql for the supplied schema_class in sql_dir.  The flavour of sql to
 336 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
 337
 338 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
 339
 340 Optional preversion can be supplied to generate a diff to be used by upgrade.
 341
 342 =cut
 343
 344 sub create {
 345   my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
 346
 347   $preversion ||= $self->preversion();
 348
 349   my $schema = $self->schema();
 350   # create the dir if does not exist
 351   $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
 352
 353   $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
 354 }
 355
 356
 357 =head2 upgrade
 358
 359 =over 4
 360
 361 =item Arguments: <none>
 362
 363 =back
 364
 365 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
 366 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
 367
 368 =cut
 369
 370 sub upgrade {
 371   my ($self) = @_;
 372   my $schema = $self->schema();
 373   if (!$schema->get_db_version()) {
 374     # schema is unversioned
 375     $self->throw_exception ("could not determin current schema version, please either install or deploy");
 376   } else {
 377     my $ret = $schema->upgrade();
 378     return $ret;
 379   }
 380 }
 381
 382
 383 =head2 install
 384
 385 =over 4
 386
 387 =item Arguments: $version
 388
 389 =back
 390
 391 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
 392 database.  install will take a version and add the version tracking tables and 'install' the version.  No
 393 further ddl modification takes place.  Setting the force attribute to a true value will allow overriding of
 394 already versioned databases.
 395
 396 =cut
 397
 398 sub install {
 399   my ($self, $version) = @_;
 400
 401   my $schema = $self->schema();
 402   $version ||= $self->version();
 403   if (!$schema->get_db_version() ) {
 404     # schema is unversioned
 405     print "Going to install schema version\n";
 406     my $ret = $schema->install($version);
 407     print "retun is $ret\n";
 408   }
 409   elsif ($schema->get_db_version() and $self->force ) {
 410     carp "Forcing install may not be a good idea";
 411     if($self->_confirm() ) {
 412       $self->schema->_set_db_version({ version => $version});
 413     }
 414   }
 415   else {
 416     $self->throw_exception ("schema already has a version not installing, try upgrade instead");
 417   }
 418
 419 }
 420
 421
 422 =head2 deploy
 423
 424 =over 4
 425
 426 =item Arguments: $args
 427
 428 =back
 429
 430 deploy will create the schema at the connected database.  C<$args> are passed straight to
 431 L<DBIx::Class::Schema/deploy>.
 432
 433 =cut
 434
 435 sub deploy {
 436   my ($self, $args) = @_;
 437   my $schema = $self->schema();
 438   if (!$schema->get_db_version() ) {
 439     # schema is unversioned
 440     $schema->deploy( $args, $self->sql_dir)
 441       or $self->throw_exception ("could not deploy schema");
 442   } else {
 443     $self->throw_exception("there already is a database with a version here, try upgrade instead");
 444   }
 445 }
 446
 447 =head2 insert
 448
 449 =over 4
 450
 451 =item Arguments: $rs, $set
 452
 453 =back
 454
 455 insert takes the name of a resultset from the schema_class and a hashref of data to insert
 456 into that resultset
 457
 458 =cut
 459
 460 sub insert {
 461   my ($self, $rs, $set) = @_;
 462
 463   $rs ||= $self->resultset();
 464   $set ||= $self->set();
 465   my $resultset = $self->schema->resultset($rs);
 466   my $obj = $resultset->create( $set );
 467   print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
 468 }
 469
 470
 471 =head2 update
 472
 473 =over 4
 474
 475 =item Arguments: $rs, $set, $where
 476
 477 =back
 478
 479 update takes the name of a resultset from the schema_class, a hashref of data to update and
 480 a where hash used to form the search for the rows to update.
 481
 482 =cut
 483
 484 sub update {
 485   my ($self, $rs, $set, $where) = @_;
 486
 487   $rs ||= $self->resultset();
 488   $where ||= $self->where();
 489   $set ||= $self->set();
 490   my $resultset = $self->schema->resultset($rs);
 491   $resultset = $resultset->search( ($where||{}) );
 492
 493   my $count = $resultset->count();
 494   print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
 495
 496   if ( $self->force || $self->_confirm() ) {
 497     $resultset->update_all( $set );
 498   }
 499 }
 500
 501
 502 =head2 delete
 503
 504 =over 4
 505
 506 =item Arguments: $rs, $where, $attrs
 507
 508 =back
 509
 510 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
 511 The found data is deleted and cannot be recovered.
 512
 513 =cut
 514
 515 sub delete {
 516   my ($self, $rs, $where, $attrs) = @_;
 517
 518   $rs ||= $self->resultset();
 519   $where ||= $self->where();
 520   $attrs ||= $self->attrs();
 521   my $resultset = $self->schema->resultset($rs);
 522   $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 523
 524   my $count = $resultset->count();
 525   print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
 526
 527   if ( $self->force || $self->_confirm() ) {
 528     $resultset->delete_all();
 529   }
 530 }
 531
 532
 533 =head2 select
 534
 535 =over 4
 536
 537 =item Arguments: $rs, $where, $attrs
 538
 539 =back
 540
 541 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
 542 The found data is returned in a array ref where the first row will be the columns list.
 543
 544 =cut
 545
 546 sub select {
 547   my ($self, $rs, $where, $attrs) = @_;
 548
 549   $rs ||= $self->resultset();
 550   $where ||= $self->where();
 551   $attrs ||= $self->attrs();
 552   my $resultset = $self->schema->resultset($rs);
 553   $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 554
 555   my @data;
 556   my @columns = $resultset->result_source->columns();
 557   push @data, [@columns];#
 558
 559   while (my $row = $resultset->next()) {
 560     my @fields;
 561     foreach my $column (@columns) {
 562       push( @fields, $row->get_column($column) );
 563     }
 564     push @data, [@fields];
 565   }
 566
 567   return \@data;
 568 }
 569
 570 sub _confirm {
 571   my ($self) = @_;
 572   print "Are you sure you want to do this? (type YES to confirm) \n";
 573   # mainly here for testing
 574   return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
 575   my $response = <STDIN>;
 576   return 1 if ($response=~/^YES/);
 577   return;
 578 }
 579
 580 sub _find_stanza {
 581   my ($self, $cfg, $stanza) = @_;
 582   my @path = split /::/, $stanza;
 583   while (my $path = shift @path) {
 584     if (exists $cfg->{$path}) {
 585       $cfg = $cfg->{$path};
 586     }
 587     else {
 588       $self->throw_exception("could not find $stanza in config, $path did not seem to exist");
 589     }
 590   }
 591   return $cfg;
 592 }
 593
 594 =head1 AUTHOR
 595
 596 See L<DBIx::Class/CONTRIBUTORS>.
 597
 598 =head1 LICENSE
 599
 600 You may distribute this code under the same terms as Perl itself
 601
 602 =cut
 603
 604 1;