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