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