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