Bio::DB::Tagger - Simple object tagging system

 use Bio::DB::Tagger;
 my $tagger = Bio::DB::Tagger->new(-dsn    => 'dbi:mysql:tagdb',
                                   -create => 1);

 $tagger->add_tags(-object => $object_name,
                   -tags   => \@tags);

 $tagger->set_tags(-object => $object_name,
                   -key    => $object_key,
                   -tags   => \@tags);

 $tagger->add_tag(-object  => $object_name,
                  -tag     => 'venue',
                  -value   => 'mermaid parade',
                  -author  => 'lincoln.stein@gmail.com');

 $tagger->add_tag(-object  => $object_name,
                  -tag     => $tag);

 $tagger->add_tag($object_name => $tag);

 $tagger->clear_tags($object_name);                      # delete all tags attached to object
 $tagger->delete_tag($object_name,$tag_name [,$value]);  # delete one tag attached to object

 $tagger->nuke_tag($tag_name);                           # delete this tag completely
 $tagger->nuke_object($object_name);
 $tagger->nuke_author($author_name);

 my @tags  = $tagger->get_tags($object_name [,$author]);
 print "first tag = $tags[0]\n";              # Tag stringify interface
 print "tag value = ",$tags[0]->value,"\n";   # object interface
 print "tag author= ",$tags[0]->author,"\n";  # object interface

 my $hasit    = $tagger->has_tag($object_name,$tag);

 my @objects  = $tagger->search_tag($tag);

 my @tags  = $tagger->tags;

 my $iterator = $tagger->tag_match('prefix');
 while (my $tag = $iterator->next_tag) { }

package Bio::DB::Tagger;
# $Id$

use strict;
use warnings;
use Carp 'croak';
use DBI;
use Bio::DB::Tagger::Tag;

our $VERSION = '1.00';

sub new {
    my $class  = shift;

    unshift @_,'-dsn' if @_ == 1;
    my %args   = @_;
    my $dsn    = $args{-dsn};
    my $create = $args{-create};
    croak "Usage: $class->new(-dsn=>'dbi:...' [,-create=>1]"
	unless $dsn;

    my $dbh  = (ref $dsn && $dsn->isa('DBI::db'))
	          ? $dsn
                  : DBI->connect($dsn,undef,undef,{AutoCommit=>1});
    $dbh or croak "Could not connect to $dsn: ",DBI->errstr;
    
    my $driver  = $dbh->{Driver}{Name};
    my $package = __PACKAGE__.'::'.$driver;
    
    unless ($package->can('new') or eval "require $package; 1") {
	croak ($@,
	       "No Tagger interface for database driver $driver is available. ",
	       "Someone needs to write the package $package");
    }

    my $self = bless {dbh=>$dbh},$package;

    $self->initialize() if $create;
    return $self;
}

sub search_tag {
    my $self         = shift;
    my ($tag,$value) = @_;
    my $query = <<END;
SELECT distinct oname, okey
  FROM tag
   NATURAL JOIN tagname
   NATURAL JOIN object
  WHERE tname=?
END
;
    my @bind = ($tag);
    if (defined $value) {
	$query .= 'AND tvalue=?';
	push @bind,$value;
    }

    my $arrayref = $self->dbh->prepare($query)
	or croak $self->dbh->errstr;
    $arrayref->execute(@bind)
	or croak $self->dbh->errstr;

    my @result;
    while (my ($object,$key) = $arrayref->fetchrow_array) {
	push @result,
	Bio::DB::Tagger::Tag->new(-name=>$object,
				  -value=>$key);
    }
    return @result;
}

sub has_tag {
    my $self         = shift;
    my ($object,$tag,$value) = @_;
    my $query = <<END;
SELECT count(*)
  FROM tag
   NATURAL JOIN tagname
   NATURAL JOIN object
  WHERE oname=?
  AND   tname=?
END
;
    my $name = ref($tag) ? $tag->name : $tag;
    my @bind = ($object,$name);
    if (defined $value) {
	$query .= 'AND tvalue=?';
	push @bind,$value;
    }
    my ($count) = $self->dbh->selectrow_array($query,{},@bind)
	or croak $self->dbh->errstr;
    return $count;
}

sub get_tag {
    my $self         = shift;
    my ($object,$tag,$value) = @_;
    my $query = <<END;
SELECT distinct tname,tvalue,aname,tmodified
  FROM tag
   NATURAL JOIN tagname
   NATURAL JOIN author
   NATURAL JOIN object
  WHERE oname=?
  AND   tname=?
END
;
    my $name = ref($tag) ? $tag->name : $tag;
    my @bind = ($object,$name);

    my $sth = $self->dbh->prepare($query)
	or croak $self->dbh->errstr;
    $sth->execute(@bind)
	or croak $self->dbh->errstr;
    my @result;
    while (my ($tag,$value,$author,$modified) = $sth->fetchrow_array) {
	push @result,
	Bio::DB::Tagger::Tag->new(-name=>$tag,
				  -value=>$value,
				  -author=>$author,
				  -modified=>$modified);
    }
    return @result;
}

sub tags {
    my $self = shift;
    my $ary  = $self->dbh->selectcol_arrayref('SELECT tname FROM tagname');
    return wantarray ? @$ary : $ary;
}

sub tag_match {
    my $self   = shift;
    my $prefix = shift;
    my $sth   = $self->dbh->prepare(<<END) or croak $self->dbh->errstr;
SELECT tname 
  FROM tagname 
 WHERE tname LIKE ?
 ORDER BY tname
END
;
    $prefix =~ s/%/\\%/g;
    $prefix =~ s/_/\\_/g;
    $sth->execute($prefix.'%') or croak $sth->errstr;
    return Bio::DB::Tagger::Iterator->new($sth);
}

sub author_match {
    my $self   = shift;
    my $prefix = shift;
    my $sth   = $self->dbh->prepare(<<END) or croak $self->dbh->errstr;
SELECT aname
  FROM author
 WHERE aname LIKE ?
 ORDER BY aname
END
;
    $prefix =~ s/%/\\%/g;
    $prefix =~ s/_/\\_/g;
    $sth->execute($prefix.'%') or croak $sth->errstr;
    return Bio::DB::Tagger::Iterator->new($sth);
}

sub tag_counts {
    my $self = shift;
    my $sth  = $self->dbh->prepare(<<END) or croak $self->dbh->errstr;
SELECT tname,count(tname)
  FROM tag,tagname
 WHERE tag.tid=tagname.tid
 GROUP BY tag.tid
END
;
    $sth->execute() or croak $self->dbh->errstr;
    my @result;
    while (my($tagname,$count) = $sth->fetchrow_array) {
	push @result,
	Bio::DB::Tagger::Tag->new(-name  => $tagname,
				  -value => $count);
    }
    return wantarray ? @result : \@result;
}

sub add_tag {
    my $self = shift;
    my ($objectname,$tag,%args);

    if (@_ == 2) {
	$objectname = shift;
	$tag        = shift;
    } else {
	%args    = @_;
	$tag        = $args{-tag};
	$objectname = $args{-object};
    }
    unless (ref $tag && $tag->isa('Bio::DB::Tagger::Tag')) {
	$tag = Bio::DB::Tagger::Tag->new(-name  => $tag,
					 -value => $args{-value},
					 -author=> $args{-author}
	    );
    }
    
    croak 'usage: add_tag(-object=>$object_name,-tag=>$tag)'
	unless defined $objectname && $tag;
    return if $self->has_tag($objectname,$tag);
    $self->_set_tags($objectname,[$tag]);
}

sub set_tags {
    my $self = shift;
    my %args = @_;
    my $object = $args{-object};
    my $key    = $args{-key};
    my $tags   = $args{-tags};
    defined $object && $key && $tags && ref $tags eq 'ARRAY'
	or croak 'Usage: $tagger->set_tags(-object=>$object_name,-key=>$object_key,-tags=>[$tag1,$tag2...])';
    $self->_set_tags($object,$tags,1,$key);
}

sub set_tag {
    my $self = shift;
    my %args;
    if (@_ == 2) {
	%args = (-object=> shift(),
		 -tag   => shift());
    } else {
	%args = @_;
    }

    my $object = $args{-object};
    my $tag    = $args{-tag};
    defined $object && $tag
	or croak 'Usage: $tagger->set_tag(-object=>$object_name,-tag=>$tag)';
    $tag = Bio::DB::Tagger::Tag->new(-name=>$tag,
				     -value=>$args{-value},
				     -author=>$args{-author}
	)
	unless ref $tag;
    $self->delete_tag($object,$tag);
    $self->add_tag($object,$tag);
}

sub clear_tags {
    my $self       = shift;
    my $objectname = shift;
    $self->_set_tags($objectname,[],1);
}

sub delete_tag {
    my $self       = shift;
    my ($objectname,$tagname,$tagvalue) = @_;
    my $dbh  = $self->dbh;

    $dbh->begin_work;

    eval {
	my $query = <<END;
DELETE FROM tag
 USING tag,tagname,object
 WHERE tag.oid=object.oid
   AND tag.tid=tagname.tid
   AND object.oname=?
   AND tagname.tname=?
END
;
	my @bind = ($objectname,$tagname);
	if (defined $tagvalue) {
	    $query .= ' AND tag.value=?';
	    push @bind,$tagvalue;
	}
	$dbh->do($query,{},@bind) or die $dbh->errstr;

	# remove defunct tags
	my ($count)  = $dbh->selectrow_array(<<END);
SELECT count(*)
  FROM tag,tagname
  WHERE tag.tid=tagname.tid
    AND tagname.tname=?
END
;
	$self->nuke_tag($tagname)     if $count == 0;
	$dbh->commit;
    };
    if ($@) {
	warn $@;
	$dbh->rollback;
	return;
    }
    return 1;
}

sub nuke_object {
    my $self       = shift;
    my $objectname = shift;
    $self->_nuke_object($objectname,
			  'object',
			  'oname',
			  'oid');
}

sub nuke_author {
    my $self       = shift;
    my $authorname = shift;
    $self->_nuke_object($authorname,
			  'author',
			  'aname',
			  'aid');
}

sub nuke_tag {
    my $self    = shift;
    my $tagname = shift;
    $self->_nuke_object($tagname,
			'tagname',
			'tname',
			'tid');
}

sub _nuke_object {
    my $self       = shift;
    my ($name,$table,$namefield,$idfield) = @_;
    my $dbh        = $self->dbh;

    my $in_transaction = !$dbh->{AutoCommit};

    my $rows = 0;
    $dbh->begin_work unless $in_transaction;
    eval {
	my $query =<<END;
DELETE FROM $table,tag
      USING $table
      LEFT JOIN tag ON $table.$idfield=tag.$idfield
      WHERE $table.$namefield=?
END
;
	my $sth = $dbh->prepare($query);
	$rows = $sth->execute($name);
	$dbh->commit unless $in_transaction;
    };
    if ($@) {
	die $@ if $in_transaction;
	warn $@;
	$dbh->rollback unless $in_transaction;
	return;
    }
    return $rows;
}

sub _set_tags {
    my $self = shift;
    my ($objectname,$tags,$replace,$key) = @_;

    my $dbh = $self->dbh;
    $dbh->begin_work;
    eval {
	local $dbh->{RaiseError}=1;
	# create/get object id
	my $oid = $self->object_to_id($objectname,1,$key);
	$dbh->do("DELETE FROM tag WHERE oid=$oid")
	    if $replace;
	for my $tag (@$tags) {
	    my $tid = $self->tag_to_id($tag->name,1);
	    my $aid = $self->author_to_id($tag->author,1);
	    my $value = $tag->value;

	    my $sth = $dbh->prepare(
		"INSERT INTO tag (oid,tid,aid,tvalue) VALUES (?,?,?,?)"
		);
	    $sth->execute($oid,$tid,$aid,$value);
	}
	$dbh->commit;
    };
    if ($@) {
	warn $@;
	$dbh->rollback;
    }
}

sub get_tags {
    my $self           = shift;
    my ($oname,$aname) = @_;
    my $query = <<END;
SELECT distinct tname,tvalue,aname,tmodified
  FROM tag 
  NATURAL JOIN tagname
  NATURAL JOIN author
  NATURAL JOIN object
 WHERE  oname=?
END
;
    my @bind = ($oname);
    if (defined $aname) {
	$query .= ' AND aname=?';
	push @bind,$aname;
    }
    my $sth = $self->dbh->prepare($query)
	or croak $self->dbh->errstr;
    $sth->execute(@bind)
	or croak $self->dbh->errstr;
    my @result;
    while (my ($tag,$value,$author,$modified) = $sth->fetchrow_array) {
	push @result,
	Bio::DB::Tagger::Tag->new(-name=>$tag,
				  -value=>$value,
				  -author=>$author,
				  -modified=>$modified);
    }
    return @result;
}

sub object_to_id {
    my $self = shift;
    return $self->_name_to_id('object','oid','oname',@_);
}

sub tag_to_id {
    my $self = shift;
    return $self->_name_to_id('tagname','tid','tname',@_);
}

sub author_to_id {
    my $self = shift;
    return $self->_name_to_id('author','aid','aname',@_);
}

sub _name_to_id {
    my $self = shift;
    my ($table,$index_col,$name_col,$name,$create,$key) = @_;
    my ($id) = $self->dbh->selectrow_array(
	"SELECT $index_col FROM $table WHERE $name_col=?",
	{},
	$name);
    return $id if defined $id;
    return unless $create;

    # we get here if oid is undef
    local $self->dbh->{RaiseError}=1;

    my $sth = $self->dbh->prepare("INSERT INTO $table ($name_col) VALUES (?)");
    $sth    = $self->dbh->prepare("INSERT INTO $table ($name_col, okey) VALUES (?, $key)")
        if ($table eq 'object') && (defined $key);

    $sth->execute($name);
    # in case someone else got there before us!
    ($id) = $self->dbh->selectrow_array(
	"SELECT $index_col FROM $table WHERE $name_col=?",
	{},
	$name);
    return $id;
}

sub dbh { return shift->{dbh} }

sub initialize {
    my $self = shift;
    my $dbh        = $self->dbh;
    my @statements = $self->_table_definitions;
    my $result     = 1;
    for my $s (@statements) {
	next unless $s =~ /\S/;
	$result &&= $dbh->do($s);
    }
    return $result;
}

package Bio::DB::Tagger::Iterator;

sub new {
    my $class = shift;
    my $sth   = shift;
    return bless {sth=>$sth},ref $class || $class;
}

sub next_tag {
    my $self  = shift;
    my ($tag) = $self->{sth}->fetchrow_array or return;
    return $tag;
}

sub next { shift->next_tag }

1;

__END__