maint/dbicadmin

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