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   try { require Config::Any } catch { $self->throw_exception( "Config::Any is required to parse the config file"); };
 248
 249   my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
 250
 251   # just grab the config from the config file
 252   $cfg = $cfg->{$self->config_file};
 253   return $cfg;
 254 }
 255
 256
 257 =head2 sql_dir
 258
 259 The location where sql ddl files should be created or found for an upgrade.
 260
 261 =cut
 262
 263 has 'sql_dir' => (
 264   is      => 'ro',
 265   isa      => Dir,
 266   coerce    => 1,
 267 );
 268
 269
 270 =head2 version
 271
 272 Used for install, the version which will be 'installed' in the schema
 273
 274 =cut
 275
 276 has version => (
 277   is      => 'rw',
 278   isa      => Str,
 279 );
 280
 281
 282 =head2 preversion
 283
 284 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
 285
 286 =cut
 287
 288 has preversion => (
 289   is      => 'rw',
 290   isa      => Str,
 291 );
 292
 293
 294 =head2 force
 295
 296 Try and force certain operations.
 297
 298 =cut
 299
 300 has force => (
 301   is      => 'rw',
 302   isa      => Bool,
 303 );
 304
 305
 306 =head2 quiet
 307
 308 Be less verbose about actions
 309
 310 =cut
 311
 312 has quiet => (
 313   is      => 'rw',
 314   isa      => Bool,
 315 );
 316
 317 has '_confirm' => (
 318   is    => 'bare',
 319   isa    => Bool,
 320 );
 321
 322
 323 =head1 METHODS
 324
 325 =head2 create
 326
 327 =over 4
 328
 329 =item Arguments: $sqlt_type, \%sqlt_args, $preversion
 330
 331 =back
 332
 333 L<create> will generate sql for the supplied schema_class in sql_dir.  The flavour of sql to
 334 generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
 335
 336 Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
 337
 338 Optional preversion can be supplied to generate a diff to be used by upgrade.
 339
 340 =cut
 341
 342 sub create {
 343   my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
 344
 345   $preversion ||= $self->preversion();
 346
 347   my $schema = $self->schema();
 348   # create the dir if does not exist
 349   $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
 350
 351   $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
 352 }
 353
 354
 355 =head2 upgrade
 356
 357 =over 4
 358
 359 =item Arguments: <none>
 360
 361 =back
 362
 363 upgrade will attempt to upgrade the connected database to the same version as the schema_class.
 364 B<MAKE SURE YOU BACKUP YOUR DB FIRST>
 365
 366 =cut
 367
 368 sub upgrade {
 369   my ($self) = @_;
 370   my $schema = $self->schema();
 371   if (!$schema->get_db_version()) {
 372     # schema is unversioned
 373     $self->throw_exception ("could not determin current schema version, please either install or deploy");
 374   } else {
 375     my $ret = $schema->upgrade();
 376     return $ret;
 377   }
 378 }
 379
 380
 381 =head2 install
 382
 383 =over 4
 384
 385 =item Arguments: $version
 386
 387 =back
 388
 389 install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
 390 database.  install will take a version and add the version tracking tables and 'install' the version.  No
 391 further ddl modification takes place.  Setting the force attribute to a true value will allow overriding of
 392 already versioned databases.
 393
 394 =cut
 395
 396 sub install {
 397   my ($self, $version) = @_;
 398
 399   my $schema = $self->schema();
 400   $version ||= $self->version();
 401   if (!$schema->get_db_version() ) {
 402     # schema is unversioned
 403     print "Going to install schema version\n";
 404     my $ret = $schema->install($version);
 405     print "retun is $ret\n";
 406   }
 407   elsif ($schema->get_db_version() and $self->force ) {
 408     carp "Forcing install may not be a good idea";
 409     if($self->_confirm() ) {
 410       $self->schema->_set_db_version({ version => $version});
 411     }
 412   }
 413   else {
 414     $self->throw_exception ("schema already has a version not installing, try upgrade instead");
 415   }
 416
 417 }
 418
 419
 420 =head2 deploy
 421
 422 =over 4
 423
 424 =item Arguments: $args
 425
 426 =back
 427
 428 deploy will create the schema at the connected database.  C<$args> are passed straight to
 429 L<DBIx::Class::Schema/deploy>.
 430
 431 =cut
 432
 433 sub deploy {
 434   my ($self, $args) = @_;
 435   my $schema = $self->schema();
 436   if (!$schema->get_db_version() ) {
 437     # schema is unversioned
 438     $schema->deploy( $args, $self->sql_dir)
 439       or $self->throw_exception ("could not deploy schema");
 440   } else {
 441     $self->throw_exception("there already is a database with a version here, try upgrade instead");
 442   }
 443 }
 444
 445 =head2 insert
 446
 447 =over 4
 448
 449 =item Arguments: $rs, $set
 450
 451 =back
 452
 453 insert takes the name of a resultset from the schema_class and a hashref of data to insert
 454 into that resultset
 455
 456 =cut
 457
 458 sub insert {
 459   my ($self, $rs, $set) = @_;
 460
 461   $rs ||= $self->resultset();
 462   $set ||= $self->set();
 463   my $resultset = $self->schema->resultset($rs);
 464   my $obj = $resultset->create( $set );
 465   print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
 466 }
 467
 468
 469 =head2 update
 470
 471 =over 4
 472
 473 =item Arguments: $rs, $set, $where
 474
 475 =back
 476
 477 update takes the name of a resultset from the schema_class, a hashref of data to update and
 478 a where hash used to form the search for the rows to update.
 479
 480 =cut
 481
 482 sub update {
 483   my ($self, $rs, $set, $where) = @_;
 484
 485   $rs ||= $self->resultset();
 486   $where ||= $self->where();
 487   $set ||= $self->set();
 488   my $resultset = $self->schema->resultset($rs);
 489   $resultset = $resultset->search( ($where||{}) );
 490
 491   my $count = $resultset->count();
 492   print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
 493
 494   if ( $self->force || $self->_confirm() ) {
 495     $resultset->update_all( $set );
 496   }
 497 }
 498
 499
 500 =head2 delete
 501
 502 =over 4
 503
 504 =item Arguments: $rs, $where, $attrs
 505
 506 =back
 507
 508 delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
 509 The found data is deleted and cannot be recovered.
 510
 511 =cut
 512
 513 sub delete {
 514   my ($self, $rs, $where, $attrs) = @_;
 515
 516   $rs ||= $self->resultset();
 517   $where ||= $self->where();
 518   $attrs ||= $self->attrs();
 519   my $resultset = $self->schema->resultset($rs);
 520   $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 521
 522   my $count = $resultset->count();
 523   print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
 524
 525   if ( $self->force || $self->_confirm() ) {
 526     $resultset->delete_all();
 527   }
 528 }
 529
 530
 531 =head2 select
 532
 533 =over 4
 534
 535 =item Arguments: $rs, $where, $attrs
 536
 537 =back
 538
 539 select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
 540 The found data is returned in a array ref where the first row will be the columns list.
 541
 542 =cut
 543
 544 sub select {
 545   my ($self, $rs, $where, $attrs) = @_;
 546
 547   $rs ||= $self->resultset();
 548   $where ||= $self->where();
 549   $attrs ||= $self->attrs();
 550   my $resultset = $self->schema->resultset($rs);
 551   $resultset = $resultset->search( ($where||{}), ($attrs||()) );
 552
 553   my @data;
 554   my @columns = $resultset->result_source->columns();
 555   push @data, [@columns];#
 556
 557   while (my $row = $resultset->next()) {
 558     my @fields;
 559     foreach my $column (@columns) {
 560       push( @fields, $row->get_column($column) );
 561     }
 562     push @data, [@fields];
 563   }
 564
 565   return \@data;
 566 }
 567
 568 sub _confirm {
 569   my ($self) = @_;
 570   print "Are you sure you want to do this? (type YES to confirm) \n";
 571   # mainly here for testing
 572   return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
 573   my $response = <STDIN>;
 574   return 1 if ($response=~/^YES/);
 575   return;
 576 }
 577
 578 sub _find_stanza {
 579   my ($self, $cfg, $stanza) = @_;
 580   my @path = split /::/, $stanza;
 581   while (my $path = shift @path) {
 582     if (exists $cfg->{$path}) {
 583       $cfg = $cfg->{$path};
 584     }
 585     else {
 586       $self->throw_exception("could not find $stanza in config, $path did not seem to exist");
 587     }
 588   }
 589   return $cfg;
 590 }
 591
 592 =head1 AUTHOR
 593
 594 See L<DBIx::Class/CONTRIBUTORS>.
 595
 596 =head1 LICENSE
 597
 598 You may distribute this code under the same terms as Perl itself
 599
 600 =cut
 601
 602 1;