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