Commit | Line | Data |
9f3849c3 |
1 | # |
2 | #=============================================================================== |
3 | # |
4 | # FILE: Admin.pm |
5 | # |
6 | # DESCRIPTION: Administrative functions for DBIx::Class Schemata |
7 | # |
8 | # FILES: --- |
9 | # BUGS: --- |
10 | # NOTES: --- |
11 | # AUTHOR: Gordon Irving (), <Gordon.irving@sophos.com> |
12 | # VERSION: 1.0 |
13 | # CREATED: 28/11/09 12:27:15 GMT |
14 | # REVISION: --- |
15 | #=============================================================================== |
16 | |
17 | package DBIx::Class::Admin; |
18 | |
19 | use Moose; |
20 | use MooseX::Types; |
21 | use MooseX::Types::Moose qw/Int HashRef ArrayRef Str Any/; |
22 | use MooseX::Types::Path::Class qw(Dir File); |
23 | #use DBIx::Class::Schema; |
24 | use Try::Tiny; |
25 | use parent 'Class::C3::Componentised'; |
26 | |
27 | use Data::Dumper; |
28 | =c |
29 | ['lib|I:s' => 'Additonal library path to search in'], |
30 | ['schema|s:s' => 'The class of the schema to load', { required => 1 } ], |
31 | ['config-stanza|S:s' => 'Where in the config to find the connection_info, supply in form MyApp::Model::DB',], |
32 | ['config|C:s' => 'Supply the config file for parsing by Config::Any', { depends => 'config_stanza'} ], |
33 | ['connect-info|n:s%' => ' supply the connect info as additonal options ie -I dsn=<dsn> user=<user> password=<pass> '], |
34 | ['sql-dir|q:s' => 'The directory where sql diffs will be created'], |
35 | ['sql-type|t:s' => 'The RDBMs falvour you wish to use'], |
36 | ['version|v:i' => 'Supply a version install'], |
37 | ['preversion|p:s' => 'The previous version to diff against',], |
38 | |
39 | 'schema=s' => \my $schema_class, |
40 | 'class=s' => \my $resultset_class, |
41 | 'connect=s' => \my $connect, |
42 | 'op=s' => \my $op, |
43 | 'set=s' => \my $set, |
44 | 'where=s' => \my $where, |
45 | 'attrs=s' => \my $attrs, |
46 | 'format=s' => \my $format, |
47 | 'force' => \my $force, |
48 | 'trace' => \my $trace, |
49 | 'quiet' => \my $quiet, |
50 | 'help' => \my $help, |
51 | 'tlibs' => \my $t_libs, |
52 | =cut |
53 | |
54 | =head1 Attributes |
55 | |
56 | =cut |
57 | has lib => ( |
58 | is => 'ro', |
59 | isa => Dir, |
60 | coerce => 1, |
61 | trigger => \&_set_inc, |
62 | ); |
63 | |
64 | sub _set_inc { |
65 | my ($self, $lib) = @_; |
66 | push @INC, $lib->stringify; |
67 | } |
68 | |
69 | |
70 | has 'schema_class' => ( |
71 | is => 'ro', |
72 | isa => 'Str', |
73 | coerce => 1, |
74 | ); |
75 | |
76 | |
77 | has 'schema' => ( |
78 | is => 'ro', |
79 | isa => 'DBIx::Class::Schema', |
80 | lazy_build => 1, |
81 | ); |
82 | |
83 | |
84 | |
85 | sub _build_schema { |
86 | my ($self) = @_; |
87 | $self->ensure_class_loaded($self->schema_class); |
9f3849c3 |
88 | |
2ded40e7 |
89 | $self->connect_info->[3]->{ignore_version} =1; |
2ded40e7 |
90 | return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} ); |
9f3849c3 |
91 | } |
92 | |
93 | has 'connect_info' => ( |
94 | is => 'ro', |
95 | isa => ArrayRef, |
96 | lazy_build => 1, |
97 | ); |
98 | |
99 | sub _build_connect_info { |
100 | my ($self) = @_; |
101 | return find_stanza($self->config, $self->config_stanza); |
102 | } |
103 | |
104 | has config => ( |
105 | is => 'ro', |
106 | isa => HashRef, |
107 | lazy_build => 1, |
108 | ); |
109 | |
110 | sub _build_config { |
111 | my ($self) = @_; |
112 | try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; }; |
113 | |
114 | my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1}); |
115 | |
116 | # just grab the config from the config file |
117 | $cfg = $cfg->{$self->config_file}; |
118 | return $cfg; |
119 | } |
120 | |
121 | has config_file => ( |
122 | is => 'ro', |
123 | isa => File, |
124 | ); |
125 | |
126 | has 'config_stanza' => ( |
127 | is => 'ro', |
128 | isa => 'Str', |
129 | ); |
130 | |
131 | has 'sql_dir' => ( |
132 | is => 'ro', |
133 | isa => Dir, |
134 | coerce => 1, |
135 | ); |
136 | |
137 | |
138 | |
139 | has 'sql_type' => ( |
140 | is => 'ro', |
141 | isa => 'Str', |
142 | ); |
143 | |
144 | has version => ( |
912e2d5a |
145 | is => 'rw', |
9f3849c3 |
146 | isa => 'Str', |
147 | ); |
148 | |
149 | has preversion => ( |
150 | is => 'rw', |
151 | isa => 'Str', |
152 | predicate => 'has_preversion', |
153 | ); |
154 | |
912e2d5a |
155 | has force => ( |
156 | is => 'rw', |
157 | isa => 'Bool', |
158 | ); |
159 | |
64c012f4 |
160 | has quiet => ( |
161 | is => 'rw', |
162 | isa => 'Bool', |
163 | ); |
164 | |
912e2d5a |
165 | has '_confirm' => ( |
166 | is => 'ro', |
167 | isa => 'Bool', |
168 | ); |
169 | |
9f3849c3 |
170 | sub create { |
2ded40e7 |
171 | my ($self, $sqlt_type, $sqlt_args) = @_; |
9f3849c3 |
172 | if ($self->has_preversion) { |
173 | print "attempting to create diff file for ".$self->preversion."\n"; |
174 | } |
175 | my $schema = $self->schema(); |
9f3849c3 |
176 | # create the dir if does not exist |
177 | $self->sql_dir->mkpath() if ( ! -d $self->sql_dir); |
178 | |
2ded40e7 |
179 | $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args ); |
9f3849c3 |
180 | } |
181 | |
182 | sub upgrade { |
183 | my ($self) = @_; |
184 | my $schema = $self->schema(); |
185 | if (!$schema->get_db_version()) { |
186 | # schema is unversioned |
912e2d5a |
187 | die "could not determin current schema version, please either install or deploy"; |
9f3849c3 |
188 | } else { |
64c012f4 |
189 | my $ret = $schema->upgrade(); |
190 | return $ret; |
9f3849c3 |
191 | } |
192 | } |
193 | |
194 | sub install { |
912e2d5a |
195 | my ($self, $version) = @_; |
9f3849c3 |
196 | |
197 | my $schema = $self->schema(); |
912e2d5a |
198 | $version ||= $self->version(); |
199 | if (!$schema->get_db_version() ) { |
9f3849c3 |
200 | # schema is unversioned |
912e2d5a |
201 | print "Going to install schema version\n"; |
202 | my $ret = $schema->install($version); |
203 | print "retun is $ret\n"; |
204 | } |
205 | elsif ($schema->get_db_version() and $self->force ) { |
206 | warn "forcing install may not be a good idea"; |
207 | if($self->confirm() ) { |
208 | # FIXME private api |
912e2d5a |
209 | $self->schema->_set_db_version({ version => $version}); |
210 | } |
211 | } |
212 | else { |
213 | die "schema already has a version not installing, try upgrade instead"; |
9f3849c3 |
214 | } |
215 | |
216 | } |
217 | |
218 | sub deploy { |
2ded40e7 |
219 | my ($self, $args) = @_; |
9f3849c3 |
220 | my $schema = $self->schema(); |
221 | if (!$schema->get_db_version() ) { |
222 | # schema is unversioned |
2ded40e7 |
223 | $schema->deploy( $args, $self->sql_dir) |
224 | or die "could not deploy schema"; |
9f3849c3 |
225 | } else { |
912e2d5a |
226 | die "there already is a database with a version here, try upgrade instead"; |
9f3849c3 |
227 | } |
228 | } |
229 | |
230 | sub find_stanza { |
231 | my ($self, $cfg, $stanza) = @_; |
232 | my @path = split /::/, $stanza; |
233 | while (my $path = shift @path) { |
234 | if (exists $cfg->{$path}) { |
235 | $cfg = $cfg->{$path}; |
236 | } |
237 | else { |
238 | die "could not find $stanza in config, $path did not seem to exist"; |
239 | } |
240 | } |
241 | return $cfg; |
242 | } |
243 | |
244 | # FIXME ensure option spec compatability |
245 | #die('Do not use the where option with the insert op') if ($where); |
246 | #die('Do not use the attrs option with the insert op') if ($attrs); |
247 | sub insert_data { |
64c012f4 |
248 | my ($self, $rs, $set) = @_; |
249 | my $resultset = $self->schema->resultset($rs); |
9f3849c3 |
250 | my $obj = $resultset->create( $set ); |
251 | print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet); |
252 | } |
253 | |
254 | sub update_data { |
882931aa |
255 | my ($self, $rs, $set, $where) = @_; |
256 | |
257 | my $resultset = $self->schema->resultset($rs); |
258 | $resultset = $resultset->search( ($where||{}) ); |
259 | |
260 | my $count = $resultset->count(); |
261 | print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet); |
262 | |
263 | if ( $self->force || $self->confirm() ) { |
264 | $resultset->update_all( $set ); |
265 | } |
9f3849c3 |
266 | } |
267 | |
268 | # FIXME |
269 | #die('Do not use the set option with the delete op') if ($set); |
270 | sub delete_data { |
882931aa |
271 | my ($self, $rs, $where, $attrs) = @_; |
9f3849c3 |
272 | |
882931aa |
273 | my $resultset = $self->schema->resultset($rs); |
274 | $resultset = $resultset->search( ($where||{}), ($attrs||()) ); |
9f3849c3 |
275 | |
882931aa |
276 | my $count = $resultset->count(); |
277 | print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet); |
9f3849c3 |
278 | |
882931aa |
279 | if ( $self->force || $self->confirm() ) { |
280 | $resultset->delete_all(); |
281 | } |
9f3849c3 |
282 | } |
283 | |
882931aa |
284 | sub select_data { |
285 | my ($self, $rs, $where, $attrs) = @_; |
286 | |
287 | my $resultset = $self->schema->resultset($rs); |
288 | $resultset = $resultset->search( ($where||{}), ($attrs||()) ); |
289 | |
290 | my @data; |
291 | my @columns = $resultset->result_source->columns(); |
292 | push @data, [@columns];# |
293 | |
294 | while (my $row = $resultset->next()) { |
295 | my @fields; |
296 | foreach my $column (@columns) { |
297 | push( @fields, $row->get_column($column) ); |
298 | } |
299 | push @data, [@fields]; |
9f3849c3 |
300 | } |
301 | |
882931aa |
302 | return \@data; |
9f3849c3 |
303 | } |
304 | |
305 | sub confirm { |
882931aa |
306 | my ($self) = @_; |
64c012f4 |
307 | print "Are you sure you want to do this? (type YES to confirm) \n"; |
912e2d5a |
308 | # mainly here for testing |
309 | return 1 if ($self->_confirm()); |
310 | my $response = <STDIN>; |
882931aa |
311 | return 1 if ($response=~/^YES/); |
312 | return; |
9f3849c3 |
313 | } |
314 | |
315 | 1; |