view release on metacpan or  search on metacpan

lib/Text/Tradition/Directory.pm  view on Meta::CPAN

	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 => {
	# now that we fall back to YAML deflation, all attributes of
	# Text::Tradition will be serialized to YAML as individual objects
	# Except if we declare a specific entry type here
        "Text::Tradition" =>
          KiokuDB::TypeMap::Entry::MOP->new(),
	# We need users to be naive entries so that they hold
	# references to the original tradition objects, not clones
        "Text::Tradition::User" =>
          KiokuDB::TypeMap::Entry::MOP->new(),
        "Text::Tradition::Collation" =>
          KiokuDB::TypeMap::Entry::MOP->new(),
        "Text::Tradition::Witness" =>
          KiokuDB::TypeMap::Entry::MOP->new(),
        "Graph" => Text::Tradition::TypeMap::Entry->new(),
        "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
      }
    );
  },
);

has '_mysql_utf8_hack' => (
	is => 'ro',
	isa => 'Bool',
	default => undef,
);

# Push some columns into the extra_args
around BUILDARGS => sub {
	my $orig = shift;
	my $class = shift;
	my $args;
	if( @_ == 1 ) {
		$args = $_[0];
	} else {
		$args = { @_ };
	}
	my @column_args;
	if( $args->{'dsn'} =~ /^dbi:(\w+):/ ) { # We're using Backend::DBI
		my $dbtype = $1;
		@column_args = ( 'columns',
			[ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 },
			  'public' => { 'data_type' => 'bool', 'is_nullable' => 1 } ] );
		if( $dbtype eq 'mysql' && 
			exists $args->{extra_args}->{dbi_attrs} &&
			$args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} ) {
			# There is a bad interaction with MySQL in utf-8 mode.
			# Work around it here.
			# TODO fix the underlying storage problem
			$args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} = undef;
			$args->{_mysql_utf8_hack} = 1;
		}
	}
	my $ea = $args->{'extra_args'};
	if( ref( $ea ) eq 'ARRAY' ) {
		push( @$ea, @column_args );
	} elsif( ref( $ea ) eq 'HASH' ) {
		$ea = { %$ea, @column_args };
	} else {
		$ea = { @column_args };
	}
	$args->{'extra_args'} = $ea;

	return $class->$orig( $args );
};

override _build_directory => sub {
  my($self) = @_;
  Text::Tradition::Store->connect(@{ $self->_connect_args },
    resolver_constructor => sub {
      my($class) = @_;
      $class->new({ typemap => $self->directory->merged_typemap,
                    fallback_entry => Text::Tradition::TypeMap::Entry->new() });
  });
};

## These checks don't cover store($id, $obj)
# before [ qw/ store update insert delete / ] => sub {
before [ qw/ delete / ] => sub {
	my $self = shift;
	my @nontrad;
	foreach my $obj ( @_ ) {
		if( ref( $obj ) && !$obj->$_isa( 'Text::Tradition' )
            && !$obj->$_isa('Text::Tradition::User') ) {
			# Is it an id => Tradition hash?
			if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
				my( $k ) = keys %$obj;
				next if $obj->{$k}->$_isa('Text::Tradition');
			}
			push( @nontrad, $obj );
		}
	}
	if( @nontrad ) {
		throw( "Cannot directly save non-Tradition object of type "
			. ref( $nontrad[0] ) );
	}
};

# TODO Garbage collection doesn't work. Suck it up and live with the 
# inflated DB.
after delete => sub {
	my $self = shift;
	my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
	$self->directory->backend->delete( $gc->garbage->members );
};

sub save {
	my $self = shift;
	return $self->store( @_ );
}