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; |
90 | #warn Dumper ($self->connect_info(), $self->connect_info->[3], {ignore_version => 1 }); |
91 | return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} ); |
9f3849c3 |
92 | } |
93 | |
94 | has 'connect_info' => ( |
95 | is => 'ro', |
96 | isa => ArrayRef, |
97 | lazy_build => 1, |
98 | ); |
99 | |
100 | sub _build_connect_info { |
101 | my ($self) = @_; |
102 | return find_stanza($self->config, $self->config_stanza); |
103 | } |
104 | |
105 | has config => ( |
106 | is => 'ro', |
107 | isa => HashRef, |
108 | lazy_build => 1, |
109 | ); |
110 | |
111 | sub _build_config { |
112 | my ($self) = @_; |
113 | try { require 'Config::Any'; } catch { die "Config::Any is required to parse the config file"; }; |
114 | |
115 | my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1}); |
116 | |
117 | # just grab the config from the config file |
118 | $cfg = $cfg->{$self->config_file}; |
119 | return $cfg; |
120 | } |
121 | |
122 | has config_file => ( |
123 | is => 'ro', |
124 | isa => File, |
125 | ); |
126 | |
127 | has 'config_stanza' => ( |
128 | is => 'ro', |
129 | isa => 'Str', |
130 | ); |
131 | |
132 | has 'sql_dir' => ( |
133 | is => 'ro', |
134 | isa => Dir, |
135 | coerce => 1, |
136 | ); |
137 | |
138 | |
139 | |
140 | has 'sql_type' => ( |
141 | is => 'ro', |
142 | isa => 'Str', |
143 | ); |
144 | |
145 | has version => ( |
146 | is => 'ro', |
147 | isa => 'Str', |
148 | ); |
149 | |
150 | has preversion => ( |
151 | is => 'rw', |
152 | isa => 'Str', |
153 | predicate => 'has_preversion', |
154 | ); |
155 | |
156 | sub create { |
2ded40e7 |
157 | my ($self, $sqlt_type, $sqlt_args) = @_; |
9f3849c3 |
158 | if ($self->has_preversion) { |
159 | print "attempting to create diff file for ".$self->preversion."\n"; |
160 | } |
161 | my $schema = $self->schema(); |
162 | # warn "running with params sqlt_type = $sqlt_type, version = " .$schema->schema_version . " sql_dir = " . $self->sql_dir . " preversion = " . ($self->has_preversion ? $self->preversion : "" ). "\n"; |
163 | # create the dir if does not exist |
164 | $self->sql_dir->mkpath() if ( ! -d $self->sql_dir); |
165 | |
2ded40e7 |
166 | $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $self->preversion, $sqlt_args ); |
9f3849c3 |
167 | } |
168 | |
169 | sub upgrade { |
170 | my ($self) = @_; |
171 | my $schema = $self->schema(); |
172 | if (!$schema->get_db_version()) { |
173 | # schema is unversioned |
174 | warn "could not determin current schema version, please either install or deploy"; |
175 | } else { |
176 | $schema->upgrade(); |
177 | } |
178 | } |
179 | |
180 | sub install { |
181 | my ($self) = @_; |
182 | |
183 | my $schema = $self->schema(); |
184 | if (!$schema->get_db_version()) { |
185 | # schema is unversioned |
186 | print "Going to install schema version"; |
187 | $schema->install($self->version); |
188 | } else { |
189 | warn "schema already has a version not installing, try upgrade instead"; |
190 | } |
191 | |
192 | } |
193 | |
194 | sub deploy { |
2ded40e7 |
195 | my ($self, $args) = @_; |
9f3849c3 |
196 | my $schema = $self->schema(); |
197 | if (!$schema->get_db_version() ) { |
198 | # schema is unversioned |
2ded40e7 |
199 | # warn "going to deploy"; |
200 | # warn Dumper $schema->deployment_statements(); |
201 | |
202 | $schema->deploy( $args, $self->sql_dir) |
203 | or die "could not deploy schema"; |
9f3849c3 |
204 | } else { |
205 | warn "there already is a database with a version here, try upgrade instead"; |
206 | } |
207 | } |
208 | |
209 | sub find_stanza { |
210 | my ($self, $cfg, $stanza) = @_; |
211 | my @path = split /::/, $stanza; |
212 | while (my $path = shift @path) { |
213 | if (exists $cfg->{$path}) { |
214 | $cfg = $cfg->{$path}; |
215 | } |
216 | else { |
217 | die "could not find $stanza in config, $path did not seem to exist"; |
218 | } |
219 | } |
220 | return $cfg; |
221 | } |
222 | |
223 | # FIXME ensure option spec compatability |
224 | #die('Do not use the where option with the insert op') if ($where); |
225 | #die('Do not use the attrs option with the insert op') if ($attrs); |
226 | sub insert_data { |
227 | my ($self, $resultset, $set) = @_; |
228 | my $obj = $resultset->create( $set ); |
229 | print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet); |
230 | } |
231 | |
232 | sub update_data { |
233 | my ($self, $resultset, $set, $where) = @_; |
234 | $resultset = $resultset->search( ($where||{}) ); |
235 | my $count = $resultset->count(); |
236 | print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet); |
237 | if ( $self->force || $self->confirm() ) { |
238 | $resultset->update_all( $set ); |
239 | } |
240 | } |
241 | |
242 | # FIXME |
243 | #die('Do not use the set option with the delete op') if ($set); |
244 | sub delete_data { |
245 | my ($self, $resultset, $where, $attrs) = @_; |
246 | |
247 | $resultset = $resultset->search( ($where||{}), ($attrs||()) ); |
248 | my $count = $resultset->count(); |
249 | print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet); |
250 | if ( $self->force || $self->confirm() ) { |
251 | $resultset->delete_all(); |
252 | } |
253 | } |
254 | |
255 | |
256 | #FIXME |
257 | # die('Do not use the set option with the select op') if ($set); |
258 | sub select_data { |
259 | my ($self, $resultset, $where, $attrs) = @_; |
260 | |
261 | |
262 | $resultset = $resultset->search( ($where||{}), ($attrs||()) ); |
263 | } |
264 | |
265 | # TODO, make this more generic, for different data formats |
266 | sub output_data { |
267 | my ($self, $resultset) = @_; |
268 | |
269 | # eval { |
270 | # ensure_class_loaded 'Data::Tabular::Dumper'; |
271 | # }; |
272 | # if($@) { |
273 | # die "Data::Tabular::Dumper is needed for outputing data"; |
274 | # } |
275 | my $csv_class; |
276 | # load compatible CSV generators |
277 | foreach $csv_class (qw(Text::CSV_XS Text::CSV_PP)) { |
278 | eval { ensure_class_loaded $csv_class}; |
279 | if($@) { |
280 | $csv_class = undef; |
281 | next; |
282 | } |
283 | } |
284 | if (not defined $csv_class) { |
285 | die ('The select op requires either the Text::CSV_XS or the Text::CSV_PP module'); |
286 | } |
287 | |
288 | my $csv = $csv_class->new({ |
289 | sep_char => ( $self->csv_format eq 'tsv' ? "\t" : ',' ), |
290 | }); |
291 | |
292 | my @columns = $resultset->result_source->columns(); |
293 | $csv->combine( @columns ); |
294 | print $csv->string()."\n"; |
295 | while (my $row = $resultset->next()) { |
296 | my @fields; |
297 | foreach my $column (@columns) { |
298 | push( @fields, $row->get_column($column) ); |
299 | } |
300 | $csv->combine( @fields ); |
301 | print $csv->string()."\n"; |
302 | } |
303 | } |
304 | |
305 | sub confirm { |
306 | print "Are you sure you want to do this? (type YES to confirm) "; |
307 | my $response = <STDIN>; |
308 | return 1 if ($response=~/^YES/); |
309 | return; |
310 | } |
311 | |
312 | 1; |