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