perl modules shouldnt munge @INC; thats the job of the script
[dbsrgits/DBIx-Class-Historic.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
595cb2c7 235=head2 version
9f3849c3 236
595cb2c7 237Used for install, the version which will be 'installed' in the schema
e81f0fe2 238
595cb2c7 239=cut
e81f0fe2 240
9f3849c3 241has version => (
3b27cdac 242 is => 'rw',
243 isa => Str,
9f3849c3 244);
245
e81f0fe2 246
595cb2c7 247=head2 preversion
248
249Previouse 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 250
595cb2c7 251=cut
e81f0fe2 252
9f3849c3 253has preversion => (
3b27cdac 254 is => 'rw',
255 isa => Str,
9f3849c3 256);
257
e81f0fe2 258
595cb2c7 259=head2 force
260
261Try and force certain operations.
e81f0fe2 262
595cb2c7 263=cut
e81f0fe2 264
912e2d5a 265has force => (
3b27cdac 266 is => 'rw',
267 isa => Bool,
912e2d5a 268);
269
e81f0fe2 270
c57f1cf7 271=head2 quiet
595cb2c7 272
273Be less verbose about actions
e81f0fe2 274
595cb2c7 275=cut
e81f0fe2 276
64c012f4 277has quiet => (
3b27cdac 278 is => 'rw',
279 isa => Bool,
64c012f4 280);
281
912e2d5a 282has '_confirm' => (
3b27cdac 283 is => 'bare',
284 isa => Bool,
912e2d5a 285);
286
e81f0fe2 287
595cb2c7 288=head1 METHODS
289
290=head2 create
291
292=over 4
293
294=item Arguments: $sqlt_type, \%sqlt_args, $preversion
295
296=back
297
8f987bd5 298L<create> will generate sql for the supplied schema_class in sql_dir. The
299flavour of sql to generate can be controlled by supplying a sqlt_type which
300should be a L<SQL::Translator> name.
595cb2c7 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.
e81f0fe2 305
595cb2c7 306=cut
307
9f3849c3 308sub create {
a705b175 309 my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
595cb2c7 310
a705b175 311 $preversion ||= $self->preversion();
595cb2c7 312
a705b175 313 my $schema = $self->schema();
314 # create the dir if does not exist
315 $self->sql_dir->mkpath() if ( ! -d $self->sql_dir);
9f3849c3 316
a705b175 317 $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args );
9f3849c3 318}
319
e81f0fe2 320
595cb2c7 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>
e81f0fe2 331
595cb2c7 332=cut
333
9f3849c3 334sub upgrade {
a705b175 335 my ($self) = @_;
336 my $schema = $self->schema();
15de9f06 337
a705b175 338 if (!$schema->get_db_version()) {
339 # schema is unversioned
b718fd0a 340 $schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
a705b175 341 } else {
23737393 342 $schema->upgrade_directory ($self->sql_dir) if $self->sql_dir; # this will override whatever default the schema has
a705b175 343 my $ret = $schema->upgrade();
344 return $ret;
345 }
9f3849c3 346}
347
e81f0fe2 348
595cb2c7 349=head2 install
350
351=over 4
352
353=item Arguments: $version
354
355=back
356
a03b396b 357install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
358database. install will take a version and add the version tracking tables and 'install' the version. No
359further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
595cb2c7 360already versioned databases.
e81f0fe2 361
595cb2c7 362=cut
e81f0fe2 363
9f3849c3 364sub install {
a705b175 365 my ($self, $version) = @_;
366
367 my $schema = $self->schema();
368 $version ||= $self->version();
369 if (!$schema->get_db_version() ) {
370 # schema is unversioned
15de9f06 371 print "Going to install schema version\n" if (!$self->quiet);
a705b175 372 my $ret = $schema->install($version);
15de9f06 373 print "return is $ret\n" if (!$self->quiet);
a705b175 374 }
375 elsif ($schema->get_db_version() and $self->force ) {
585072bb 376 carp "Forcing install may not be a good idea";
a705b175 377 if($self->_confirm() ) {
a705b175 378 $self->schema->_set_db_version({ version => $version});
9c34993a 379 }
a705b175 380 }
381 else {
b718fd0a 382 $schema->throw_exception ("Schema already has a version. Try upgrade instead.\n");
a705b175 383 }
9f3849c3 384
385}
386
e81f0fe2 387
595cb2c7 388=head2 deploy
389
390=over 4
391
392=item Arguments: $args
393
394=back
395
a03b396b 396deploy will create the schema at the connected database. C<$args> are passed straight to
e81f0fe2 397L<DBIx::Class::Schema/deploy>.
398
595cb2c7 399=cut
e81f0fe2 400
9f3849c3 401sub deploy {
a705b175 402 my ($self, $args) = @_;
403 my $schema = $self->schema();
a03b396b 404 $schema->deploy( $args, $self->sql_dir );
9f3849c3 405}
406
bb464677 407=head2 insert
595cb2c7 408
409=over 4
410
411=item Arguments: $rs, $set
412
413=back
414
bb464677 415insert takes the name of a resultset from the schema_class and a hashref of data to insert
595cb2c7 416into that resultset
417
418=cut
e81f0fe2 419
bb464677 420sub insert {
a705b175 421 my ($self, $rs, $set) = @_;
bb464677 422
a705b175 423 $rs ||= $self->resultset();
424 $set ||= $self->set();
425 my $resultset = $self->schema->resultset($rs);
426 my $obj = $resultset->create( $set );
427 print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
9f3849c3 428}
429
595cb2c7 430
bb464677 431=head2 update
595cb2c7 432
e81f0fe2 433=over 4
595cb2c7 434
435=item Arguments: $rs, $set, $where
436
437=back
438
e81f0fe2 439update takes the name of a resultset from the schema_class, a hashref of data to update and
440a where hash used to form the search for the rows to update.
441
595cb2c7 442=cut
e81f0fe2 443
bb464677 444sub update {
a705b175 445 my ($self, $rs, $set, $where) = @_;
882931aa 446
a705b175 447 $rs ||= $self->resultset();
448 $where ||= $self->where();
449 $set ||= $self->set();
450 my $resultset = $self->schema->resultset($rs);
451 $resultset = $resultset->search( ($where||{}) );
882931aa 452
a705b175 453 my $count = $resultset->count();
454 print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet);
882931aa 455
a705b175 456 if ( $self->force || $self->_confirm() ) {
457 $resultset->update_all( $set );
458 }
9f3849c3 459}
460
e81f0fe2 461
bb464677 462=head2 delete
595cb2c7 463
464=over 4
465
466=item Arguments: $rs, $where, $attrs
467
468=back
469
e81f0fe2 470delete takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
595cb2c7 471The found data is deleted and cannot be recovered.
e81f0fe2 472
595cb2c7 473=cut
e81f0fe2 474
bb464677 475sub delete {
a705b175 476 my ($self, $rs, $where, $attrs) = @_;
9f3849c3 477
a705b175 478 $rs ||= $self->resultset();
479 $where ||= $self->where();
480 $attrs ||= $self->attrs();
481 my $resultset = $self->schema->resultset($rs);
482 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
9f3849c3 483
a705b175 484 my $count = $resultset->count();
485 print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet);
9f3849c3 486
a705b175 487 if ( $self->force || $self->_confirm() ) {
488 $resultset->delete_all();
489 }
9f3849c3 490}
491
e81f0fe2 492
bb464677 493=head2 select
595cb2c7 494
495=over 4
496
497=item Arguments: $rs, $where, $attrs
498
499=back
500
a03b396b 501select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
595cb2c7 502The found data is returned in a array ref where the first row will be the columns list.
503
504=cut
e81f0fe2 505
bb464677 506sub select {
a705b175 507 my ($self, $rs, $where, $attrs) = @_;
508
509 $rs ||= $self->resultset();
510 $where ||= $self->where();
511 $attrs ||= $self->attrs();
512 my $resultset = $self->schema->resultset($rs);
513 $resultset = $resultset->search( ($where||{}), ($attrs||()) );
514
515 my @data;
516 my @columns = $resultset->result_source->columns();
a03b396b 517 push @data, [@columns];#
a705b175 518
519 while (my $row = $resultset->next()) {
520 my @fields;
521 foreach my $column (@columns) {
522 push( @fields, $row->get_column($column) );
9c34993a 523 }
a705b175 524 push @data, [@fields];
525 }
9c34993a 526
a705b175 527 return \@data;
9f3849c3 528}
529
595cb2c7 530sub _confirm {
a705b175 531 my ($self) = @_;
15de9f06 532
a705b175 533 # mainly here for testing
534 return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
15de9f06 535
536 print "Are you sure you want to do this? (type YES to confirm) \n";
a705b175 537 my $response = <STDIN>;
15de9f06 538
539 return ($response=~/^YES/);
9f3849c3 540}
541
595cb2c7 542sub _find_stanza {
a705b175 543 my ($self, $cfg, $stanza) = @_;
544 my @path = split /::/, $stanza;
545 while (my $path = shift @path) {
546 if (exists $cfg->{$path}) {
547 $cfg = $cfg->{$path};
548 }
549 else {
b718fd0a 550 die ("Could not find $stanza in config, $path does not seem to exist.\n");
9c34993a 551 }
a705b175 552 }
553 return $cfg;
595cb2c7 554}
bb464677 555
47442cea 556=head1 AUTHOR
bb464677 557
e81f0fe2 558See L<DBIx::Class/CONTRIBUTORS>.
bb464677 559
560=head1 LICENSE
561
e81f0fe2 562You may distribute this code under the same terms as Perl itself
563
bb464677 564=cut
e81f0fe2 565
9f3849c3 5661;