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{DBIC_TRACE} = 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