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