use warnings;
use Moose;
use DBI;
+use Encode qw/ decode_utf8 /;
use KiokuDB::GC::Naive;
use KiokuDB::TypeMap;
use KiokuDB::TypeMap::Entry::Naive;
like( $e->message, qr/Cannot directly delete non-Tradition object/,
"Exception has correct message" );
}
+
$f->delete( $uuid );
ok( !$f->exists( $uuid ), "Object is deleted from DB" );
ok( !$f->exists( $sid ), "Object stemma also deleted from DB" );
my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
my $scope = $g->new_scope;
is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
+ my $ntobj = $g->tradition( 'CX' );
+ my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
+ my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
+ is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
}
=end testing
=cut
+use Text::Tradition::TypeMap::Entry;
has +typemap => (
- is => 'rw',
- isa => 'KiokuDB::TypeMap',
- default => sub {
- KiokuDB::TypeMap->new(
- isa_entries => {
- "Graph" => KiokuDB::TypeMap::Entry::Naive->new,
- "Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new,
- }
- );
- },
+ is => 'rw',
+ isa => 'KiokuDB::TypeMap',
+ default => sub {
+ KiokuDB::TypeMap->new(
+ isa_entries => {
+ "Text::Tradition" =>
+ KiokuDB::TypeMap::Entry::Naive->new(),
+ "Graph" => Text::Tradition::TypeMap::Entry->new(),
+ "Graph::AdjacencyMap" => Text::Tradition::TypeMap::Entry->new(),
+ "Lingua::Features::Structure" => Text::Tradition::TypeMap::Entry->new,
+ "Lingua::Features::FeatureType" => Text::Tradition::TypeMap::Entry->new,
+ }
+ );
+ },
);
# Push some columns into the extra_args
return $class->$orig( $args );
};
-before [ qw/ store update insert delete / ] => sub {
+# before [ qw/ store update insert delete / ] => sub {
+before [ qw/ delete / ] => sub {
my $self = shift;
my @nontrad;
foreach my $obj ( @_ ) {
sub tradition {
my( $self, $id ) = @_;
my $obj = $self->lookup( $id );
- unless( ref( $obj ) eq 'Text::Tradition' ) {
+ unless( $obj ) {
+ # Try looking up by name.
+ foreach my $item ( $self->traditionlist ) {
+ if( $item->{'name'} eq $id ) {
+ $obj = $self->lookup( $item->{'id'} );
+ last;
+ }
+ }
+ }
+ if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
}
return $obj;
# If we are using DBI, we can do it the easy way; if not, the hard way.
# Easy way still involves making a separate DBI connection. Ew.
my @tlist;
- if( $self->dsn =~ /^dbi/ ) {
- $DB::single = 1;
+ if( $self->dsn =~ /^dbi:(\w+):/ ) {
+ my $dbtype = $1;
my @connection = @{$self->directory->backend->connect_info};
# Get rid of KiokuDB-specific arg
pop @connection if scalar @connection > 4;
- $connection[3]->{'sqlite_unicode'} = 1 if $connection[0] =~ /^dbi:SQLite/;
- $connection[3]->{'mysql_enable_utf8'} = 1 if $connection[0] =~ /^dbi:mysql/;
- $connection[3]->{'pg_enable_utf8'} = 1 if $connection[0] =~ /^dbi:Pg/;
+ $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
+ $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
my $dbh = DBI->connect( @connection );
my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
$q->execute();
while( my @row = $q->fetchrow_array ) {
+ my( $id, $name ) = @row;
+ # Horrible horrible hack
+ $name = decode_utf8( $name ) if $dbtype eq 'mysql';
push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
}
} else {