Commit | Line | Data |
a94aa524 |
1 | #!/usr/bin/perl |
2 | use strict; |
3 | use warnings; |
4 | |
5 | use Getopt::Long; |
6 | use Pod::Usage; |
7 | use IO::File; |
8 | |
9 | $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} = 1; |
10 | |
11 | pod2usage(1) if (@ARGV<3); |
12 | |
13 | my $op = shift(@ARGV); |
14 | die('First argument must be insert, update, or delete') if ($op!~/^insert|update|delete$/s); |
15 | |
16 | my $schema_class = shift(@ARGV); |
17 | eval("require $schema_class"); |
18 | die('Unable to load schema module') if ($@); |
19 | my $schema = $schema_class->connect(); |
20 | |
21 | my $class = shift(@ARGV); |
22 | my $resultset = eval{ $schema->resultset($class) }; |
23 | die('Unable to load the class with the schema') if ($@); |
24 | |
25 | my $where = {}; |
26 | my $set = {}; |
27 | |
28 | GetOptions( |
29 | 'where=s' => $where, |
30 | 'set=s' => $set, |
31 | 'force' => \my $force, |
32 | 'help' => \my $help, |
33 | ); |
34 | |
35 | pod2usage(1) if ($help); |
36 | |
37 | if ($op eq 'insert') { |
38 | die('The insert operator and the where option do not mix') if (%$where); |
39 | my $obj = $resultset->create( $set ); |
40 | print "$schema_class\::$class ID: ".join(',',$obj->id())."\n"; |
41 | } |
42 | elsif ($op eq 'update') { |
43 | $resultset = $resultset->search( $where ); |
44 | my $count = $resultset->count(); |
45 | print "This action will modify $count $schema_class\::$class records.\n"; |
46 | if ( $force || confirm() ) { |
47 | $resultset->update_all( $set ); |
48 | } |
49 | } |
50 | elsif ($op eq 'delete') { |
51 | die('The delete operator and the set option do not mix') if (%$set); |
52 | $resultset = $resultset->search( $where ); |
53 | my $count = $resultset->count(); |
54 | print "This action will delete $count $schema_class\::$class records.\n"; |
55 | if ( $force || confirm() ) { |
56 | $resultset->delete_all(); |
57 | } |
58 | } |
59 | |
60 | sub confirm { |
61 | print "Are you sure you want to do this? (type YES to confirm) "; |
62 | my $response = <STDIN>; |
63 | return 1 if ($response=~/^YES/); |
64 | return; |
65 | } |
66 | |
67 | __END__ |
68 | |
69 | =head1 NAME |
70 | |
71 | dbicadmin - Execute simple actions upon DBIx::Class objects. |
72 | |
73 | =head1 SYNOPSIS |
74 | |
75 | dbicadmin insert My::Schema Class --set this=that |
76 | dbicadmin update My::Schema Class --set this=that --where those=these |
77 | dbicadmin delete My::Schema Class --where those=these |
78 | |
79 | =head1 DESCRIPTION |
80 | |
81 | This utility provides the ability to run INSERTs, UPDATEs, and |
82 | DELETEs on any DBIx::Class object. |
83 | |
84 | =head1 ARGUMENTS |
85 | |
86 | Before any options are passed this script expects three arguments. |
87 | |
88 | =head2 operation |
89 | |
90 | The type of operation. Valid values are insert, update, and delete. |
91 | |
92 | =head2 schema |
93 | |
94 | The name of your schema class. |
95 | |
96 | =head2 class |
97 | |
98 | The name of the class, within your schema, that you want to run |
99 | the operation on. |
100 | |
101 | =head1 OPTIONS |
102 | |
103 | =head2 help |
104 | |
105 | Display this help page. |
106 | |
107 | =head2 force |
108 | |
109 | Suppresses the confirmation dialogues that are usually displayed |
110 | when someone runs a DELETE or UPDATE action. |
111 | |
112 | =head2 where |
113 | |
114 | This option uses L<Getopt::Long>'s ability to specify a hash |
115 | structure with command line options. Basically, for every |
116 | clause that you want to include in the WHERE statement you |
117 | have a --where option specifying the clause. So, if you wanted |
118 | to specify two clauses you would do: |
119 | |
120 | --where this=that --where those=these |
121 | |
122 | And that will become something like: |
123 | |
124 | WHERE this="that" AND those="these" |
125 | |
126 | The insert does not suppor the where option and will croak if |
127 | you try to use it. |
128 | |
129 | =head2 set |
130 | |
131 | This works just like the where option except that the insert |
132 | operation does support it, but the delete operation does not. |
133 | |
134 | =head1 AUTHOR |
135 | |
136 | Aran Deltac <bluefeet@cpan.org> |
137 | |
138 | =head1 LICENSE |
139 | |
140 | You may distribute this code under the same terms as Perl itself. |
141 | |