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