silence loud test
[dbsrgits/DBIx-Class-Historic.git] / script / dbicadmin
1 #!/usr/bin/perl
2 use strict;
3 use warnings;
4
5 use Getopt::Long;
6 use Pod::Usage;
7 use JSON::Any;
8
9
10 my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1);
11
12 GetOptions(
13     'schema=s'  => \my $schema_class,
14     'class=s'   => \my $resultset_class,
15     'connect=s' => \my $connect,
16     'op=s'      => \my $op,
17     'set=s'     => \my $set,
18     'where=s'   => \my $where,
19     'attrs=s'   => \my $attrs,
20     'format=s'  => \my $format,
21     'force'     => \my $force,
22     'trace'     => \my $trace,
23     'quiet'     => \my $quiet,
24     'help'      => \my $help,
25     'tlibs'      => \my $t_libs,
26 );
27
28 if ($t_libs) {
29     unshift( @INC, 't/lib', 'lib' );
30 }
31
32 pod2usage(1) if ($help);
33 $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} = 1 if ($trace);
34
35 die('No op specified') if(!$op);
36 die('Invalid op') if ($op!~/^insert|update|delete|select$/s);
37 my $csv_class;
38 if ($op eq 'select') {
39     $format ||= 'tsv';
40     die('Invalid format') if ($format!~/^tsv|csv$/s);
41     $csv_class = 'Text::CSV_XS';
42     eval{ require Text::CSV_XS };
43     if ($@) {
44         $csv_class = 'Text::CSV_PP';
45         eval{ require Text::CSV_PP };
46         die('The select op requires either the Text::CSV_XS or the Text::CSV_PP module') if ($@);
47     }
48 }
49
50 die('No schema specified') if(!$schema_class);
51 eval("require $schema_class");
52 die('Unable to load schema') if ($@);
53 $connect = $json->jsonToObj( $connect ) if ($connect);
54 my $schema = $schema_class->connect(
55     ( $connect ? @$connect : () )
56 );
57
58 die('No class specified') if(!$resultset_class);
59 my $resultset = eval{ $schema->resultset($resultset_class) };
60 die('Unable to load the class with the schema') if ($@);
61
62 $set = $json->jsonToObj( $set ) if ($set);
63 $where = $json->jsonToObj( $where ) if ($where);
64 $attrs = $json->jsonToObj( $attrs ) if ($attrs);
65
66 if ($op eq 'insert') {
67     die('Do not use the where option with the insert op') if ($where);
68     die('Do not use the attrs option with the insert op') if ($attrs);
69     my $obj = $resultset->create( $set );
70     print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$quiet);
71 }
72 elsif ($op eq 'update') {
73     $resultset = $resultset->search( ($where||{}) );
74     my $count = $resultset->count();
75     print "This action will modify $count ".ref($resultset)." records.\n" if (!$quiet);
76     if ( $force || confirm() ) {
77         $resultset->update_all( $set );
78     }
79 }
80 elsif ($op eq 'delete') {
81     die('Do not use the set option with the delete op') if ($set);
82     $resultset = $resultset->search( ($where||{}), ($attrs||()) );
83     my $count = $resultset->count();
84     print "This action will delete $count ".ref($resultset)." records.\n" if (!$quiet);
85     if ( $force || confirm() ) {
86         $resultset->delete_all();
87     }
88 }
89 elsif ($op eq 'select') {
90     die('Do not use the set option with the select op') if ($set);
91     my $csv = $csv_class->new({
92         sep_char => ( $format eq 'tsv' ? "\t" : ',' ),
93     });
94     $resultset = $resultset->search( ($where||{}), ($attrs||()) );
95     my @columns = $resultset->result_source->columns();
96     $csv->combine( @columns );
97     print $csv->string()."\n";
98     while (my $row = $resultset->next()) {
99         my @fields;
100         foreach my $column (@columns) {
101             push( @fields, $row->get_column($column) );
102         }
103         $csv->combine( @fields );
104         print $csv->string()."\n";
105     }
106 }
107
108 sub confirm {
109     print "Are you sure you want to do this? (type YES to confirm) ";
110     my $response = <STDIN>;
111     return 1 if ($response=~/^YES/);
112     return;
113 }
114
115 __END__
116
117 =head1 NAME
118
119 dbicadmin - Execute operations upon DBIx::Class objects.
120
121 =head1 SYNOPSIS
122
123   dbicadmin --op=insert --schema=My::Schema --class=Class --set=JSON
124   dbicadmin --op=update --schema=My::Schema --class=Class --set=JSON --where=JSON
125   dbicadmin --op=delete --schema=My::Schema --class=Class --where=JSON
126   dbicadmin --op=select --schema=My::Schema --class=Class --where=JSON --format=tsv
127
128 =head1 DESCRIPTION
129
130 This utility provides the ability to run INSERTs, UPDATEs, 
131 DELETEs, and SELECTs on any DBIx::Class object.
132
133 =head1 OPTIONS
134
135 =head2 op
136
137 The type of operation.  Valid values are insert, update, delete, 
138 and select.
139
140 =head2 schema
141
142 The name of your schema class.
143
144 =head2 class
145
146 The name of the class, within your schema, that you want to run 
147 the operation on.
148
149 =head2 connect
150
151 A JSON array to be passed to your schema class upon connecting.  
152 The array will need to be compatible with whatever the DBIC 
153 ->connect() method requires.
154
155 =head2 set
156
157 This option must be valid JSON data string and is passed in to 
158 the DBIC update() method.  Use this option with the update 
159 and insert ops.
160
161 =head2 where
162
163 This option must be valid JSON data string and is passed in as 
164 the first argument to the DBIC search() method.  Use this 
165 option with the update, delete, and select ops.
166
167 =head2 attrs
168
169 This option must be valid JSON data string and is passed in as 
170 the second argument to the DBIC search() method.  Use this 
171 option with the update, delete, and select ops.
172
173 =head2 help
174
175 Display this help page.
176
177 =head2 force
178
179 Suppresses the confirmation dialogues that are usually displayed 
180 when someone runs a DELETE or UPDATE action.
181
182 =head2 quiet
183
184 Do not display status messages.
185
186 =head2 trace
187
188 Turns on tracing on the DBI storage, thus printing SQL as it is 
189 executed.
190
191 =head2 tlibs
192
193 This option is purely for testing during the DBIC installation.  Do 
194 not use it.
195
196 =head1 JSON
197
198 JSON is a lightweight data-interchange format.  It allows you 
199 to express complex data structures for use in the where and 
200 set options.
201
202 This module turns on L<JSON>'s BareKey and QuotApos options so 
203 that your data can look a bit more readable.
204
205   --where={"this":"that"} # generic JSON
206   --where={this:'that'}   # with BareKey and QuoteApos
207
208 Consider wrapping your JSON in outer quotes so that you don't 
209 have to escape your inner quotes.
210
211   --where={this:\"that\"} # no outer quote
212   --where='{this:"that"}' # outer quoted
213
214 =head1 AUTHOR
215
216 Aran Deltac <bluefeet@cpan.org>
217
218 =head1 LICENSE
219
220 You may distribute this code under the same terms as Perl itself.
221