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