script/dblookup.pl

   1 #!/usr/bin/env perl
   2
   3 use lib 'lib';
   4 use strict;
   5 use warnings;
   6 use File::Basename;
   7 use Getopt::Long;
   8 use Text::Tradition;
   9 use Text::Tradition::Directory;
  10
  11 binmode( STDOUT, ':utf8' );
  12 binmode( STDERR, ':utf8' );
  13
  14 my( $name, $delete, $dbuser, $dbpass );
  15 my( $list, $dsn ) = ( 1, 'dbi:SQLite:dbname=db/traditions.db' );
  16
  17 GetOptions(
  18         'r|rename=s' => \$name,
  19         'd|delete' => \$delete,
  20         'dsn=s' => \$dsn,
  21         'u|user=s' => \$dbuser,
  22         'p|pass=s' => \$dbpass,
  23         );
  24
  25 my @uuids = @ARGV;  # UUID is whatever is left over
  26 my %dbargs = ( 'dsn' => $dsn );
  27 $dbargs{'extra_args'} = { 'user' => $dbuser } if $dbuser;
  28 $dbargs{'extra_args'}->{'password'} = $dbpass if $dbpass;
  29 my $kdb = Text::Tradition::Directory->new( %dbargs );
  30 $list = !$delete;
  31
  32 if( $delete ) {
  33         print STDERR "Must specify the UUID of a tradition to delete\n" unless @uuids;
  34         my $scope = $kdb->new_scope();
  35         foreach my $uuid ( @uuids ) {
  36                 if( $kdb->exists( $uuid ) ) {
  37                         $kdb->delete( $uuid );
  38                 } else {
  39                         print STDERR "No object found with ID $uuid\n";
  40                 }
  41         }
  42 }
  43
  44 if( $name ) {
  45         print STDERR "Must specify the UUID of a tradition to rename\n" unless @uuids;
  46         if( @uuids > 1 ) {
  47                 print STDERR "Multiple traditions given for rename - do you really want to do that?\n";
  48         } else {
  49                 my $scope = $kdb->new_scope();
  50                 my $tradition = $kdb->lookup( $uuids[0] );
  51                 if( $tradition ) {
  52                         $tradition->name( $name );
  53                         $kdb->save( $tradition );
  54                 } else {
  55                         print STDERR "Unable to find tradition @uuids to rename\n";
  56                 }
  57         }
  58 }
  59
  60 # Now list the DB contents if appropriate.
  61 if( $list ) {
  62         my $scope = $kdb->new_scope();
  63         foreach my $tref ( $kdb->traditionlist ) {
  64                 my $tid = $tref->{'id'};
  65                 # If no IDs were given on the command line, list all traditions.
  66                 if( @uuids ) {
  67                         next unless grep { $_ eq $tid } @uuids;
  68                 }
  69                 my $t = $kdb->lookup( $tid );
  70                 print STDERR "$tid: Tradition '" . $t->name . "'\n";
  71                 my @wits = map { $_->sigil } $t->witnesses;
  72                 print STDERR "...with witnesses @wits\n";
  73                 my $c = $t->collation;
  74                 print STDERR "...collation has " . scalar( $c->readings ) . " readings\n";
  75                 print STDERR "...collation has " . scalar( $c->paths ) . " paths\n";
  76                 print STDERR "...collation has " . scalar( $c->relationships ) . " relationship links\n";
  77                 foreach my $s ( $t->stemmata ) {
  78                         print STDERR "...associated stemma has graph " . $s->graph . "\n";
  79                 }
  80         }
  81 }