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 | |
160 | has '_confirm' => ( |
161 | is => 'ro', |
162 | isa => 'Bool', |
163 | ); |
164 | |
9f3849c3 |
165 | sub create { |
2ded40e7 |
166 | my ($self, $sqlt_type, $sqlt_args) = @_; |
9f3849c3 |
167 | if ($self->has_preversion) { |
168 | print "attempting to create diff file for ".$self->preversion."\n"; |
169 | } |
170 | my $schema = $self->schema(); |
9f3849c3 |
171 | # create the dir if does not exist |
172 | $self->sql_dir->mkpath() if ( ! -d $self->sql_dir); |
173 | |
2ded40e7 |
174 | $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args ); |
9f3849c3 |
175 | } |
176 | |
177 | sub upgrade { |
178 | my ($self) = @_; |
179 | my $schema = $self->schema(); |
180 | if (!$schema->get_db_version()) { |
181 | # schema is unversioned |
912e2d5a |
182 | die "could not determin current schema version, please either install or deploy"; |
9f3849c3 |
183 | } else { |
184 | $schema->upgrade(); |
185 | } |
186 | } |
187 | |
188 | sub install { |
912e2d5a |
189 | my ($self, $version) = @_; |
9f3849c3 |
190 | |
191 | my $schema = $self->schema(); |
912e2d5a |
192 | $version ||= $self->version(); |
193 | if (!$schema->get_db_version() ) { |
9f3849c3 |
194 | # schema is unversioned |
912e2d5a |
195 | print "Going to install schema version\n"; |
196 | my $ret = $schema->install($version); |
197 | print "retun is $ret\n"; |
198 | } |
199 | elsif ($schema->get_db_version() and $self->force ) { |
200 | warn "forcing install may not be a good idea"; |
201 | if($self->confirm() ) { |
202 | # FIXME private api |
203 | warn $version; |
204 | $self->schema->_set_db_version({ version => $version}); |
205 | } |
206 | } |
207 | else { |
208 | die "schema already has a version not installing, try upgrade instead"; |
9f3849c3 |
209 | } |
210 | |
211 | } |
212 | |
213 | sub deploy { |
2ded40e7 |
214 | my ($self, $args) = @_; |
9f3849c3 |
215 | my $schema = $self->schema(); |
216 | if (!$schema->get_db_version() ) { |
217 | # schema is unversioned |
2ded40e7 |
218 | $schema->deploy( $args, $self->sql_dir) |
219 | or die "could not deploy schema"; |
9f3849c3 |
220 | } else { |
912e2d5a |
221 | die "there already is a database with a version here, try upgrade instead"; |
9f3849c3 |
222 | } |
223 | } |
224 | |
225 | sub find_stanza { |
226 | my ($self, $cfg, $stanza) = @_; |
227 | my @path = split /::/, $stanza; |
228 | while (my $path = shift @path) { |
229 | if (exists $cfg->{$path}) { |
230 | $cfg = $cfg->{$path}; |
231 | } |
232 | else { |
233 | die "could not find $stanza in config, $path did not seem to exist"; |
234 | } |
235 | } |
236 | return $cfg; |
237 | } |
238 | |
239 | # FIXME ensure option spec compatability |
240 | #die('Do not use the where option with the insert op') if ($where); |
241 | #die('Do not use the attrs option with the insert op') if ($attrs); |
242 | sub insert_data { |
243 | my ($self, $resultset, $set) = @_; |
244 | my $obj = $resultset->create( $set ); |
245 | print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet); |
246 | } |
247 | |
248 | sub update_data { |
249 | my ($self, $resultset, $set, $where) = @_; |
250 | $resultset = $resultset->search( ($where||{}) ); |
251 | my $count = $resultset->count(); |
252 | print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet); |
253 | if ( $self->force || $self->confirm() ) { |
254 | $resultset->update_all( $set ); |
255 | } |
256 | } |
257 | |
258 | # FIXME |
259 | #die('Do not use the set option with the delete op') if ($set); |
260 | sub delete_data { |
261 | my ($self, $resultset, $where, $attrs) = @_; |
262 | |
263 | $resultset = $resultset->search( ($where||{}), ($attrs||()) ); |
264 | my $count = $resultset->count(); |
265 | print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet); |
266 | if ( $self->force || $self->confirm() ) { |
267 | $resultset->delete_all(); |
268 | } |
269 | } |
270 | |
271 | |
272 | #FIXME |
273 | # die('Do not use the set option with the select op') if ($set); |
274 | sub select_data { |
275 | my ($self, $resultset, $where, $attrs) = @_; |
276 | |
277 | |
278 | $resultset = $resultset->search( ($where||{}), ($attrs||()) ); |
279 | } |
280 | |
281 | # TODO, make this more generic, for different data formats |
282 | sub output_data { |
283 | my ($self, $resultset) = @_; |
284 | |
285 | # eval { |
286 | # ensure_class_loaded 'Data::Tabular::Dumper'; |
287 | # }; |
288 | # if($@) { |
289 | # die "Data::Tabular::Dumper is needed for outputing data"; |
290 | # } |
291 | my $csv_class; |
292 | # load compatible CSV generators |
293 | foreach $csv_class (qw(Text::CSV_XS Text::CSV_PP)) { |
294 | eval { ensure_class_loaded $csv_class}; |
295 | if($@) { |
296 | $csv_class = undef; |
297 | next; |
298 | } |
299 | } |
300 | if (not defined $csv_class) { |
301 | die ('The select op requires either the Text::CSV_XS or the Text::CSV_PP module'); |
302 | } |
303 | |
304 | my $csv = $csv_class->new({ |
305 | sep_char => ( $self->csv_format eq 'tsv' ? "\t" : ',' ), |
306 | }); |
307 | |
308 | my @columns = $resultset->result_source->columns(); |
309 | $csv->combine( @columns ); |
310 | print $csv->string()."\n"; |
311 | while (my $row = $resultset->next()) { |
312 | my @fields; |
313 | foreach my $column (@columns) { |
314 | push( @fields, $row->get_column($column) ); |
315 | } |
316 | $csv->combine( @fields ); |
317 | print $csv->string()."\n"; |
318 | } |
319 | } |
320 | |
321 | sub confirm { |
912e2d5a |
322 | my ($self) = @_; |
323 | print "Are you sure you want to do this? (type YES to confirm) "; |
324 | # mainly here for testing |
325 | return 1 if ($self->_confirm()); |
326 | my $response = <STDIN>; |
9f3849c3 |
327 | return 1 if ($response=~/^YES/); |
328 | return; |
329 | } |
330 | |
331 | 1; |