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

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

our $VERSION = '1.00';

=head1 NAME

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

=head1 SYNOPSIS

 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) { }

=head1 DESCRIPTION

This is a simple object tagger interface that provides relational
support for tagging objects (identified by string IDs) with arbitrary
string tags.

=head2 METHODS

=over 4

=item $tagger = Bio::DB::Tagger->new(@args)

Constructor for the tagger class. Arguments are:

  -dsn    <dsn>    A DBI data source, possibly including host and
                    password information

  -create <0|1>    If true, then database will be initialized with a
                    new schema. Database must already exist.

The dsn can be a preopened database handle or a dbi: data source
string.

=cut

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;
}

=item @objects = $tagger->search_tag($tag [,$value])

=item $object_arrayref = $tagger->search_tag($tag [,$value])

Return all object names and keys that are tagged with "$tag",
optionally qualified by tag value $value.

=cut

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;
}

=item $boolean = $tagger->has_tag($object,$tag [,$value])

Returns true if indicated object has the indicated tag, or the
indicated combination of tag and value.

=cut

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;
}

=item @tags = $tagger->get_tag($object,$tag)

Returns all the tags of type $tag.

=cut

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;
}

=item $tags = $tagger->tags()

=item @tags = $tagger->tags()

Return a list of all tags in the database. In a list context, returns
the list of tags. In an array context, returns an array ref.

=cut

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

=item $iterator = $tagger->tag_match('prefix')

Returns an iterator that matches all tags beginning with 'prefix'
(case insensitive). Call $iterator->next_tag() to get the next match.

=cut

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);
}

=item $iterator = $tagger->tag_match('prefix')

Returns an iterator that matches all tags beginning with 'prefix'
(case insensitive). Call $iterator->next_tag() to get the next match.

=cut

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);
}

=item $tags = $tagger->tag_counts()

=item @tags = $tagger->tag_counts()

Return a set of Bio::DB::Tagger::Tag objects representing all known
tags. The tag values correspond to the number of times that tag has
been used to tag objects.

=cut

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;
}

=item $result = $tagger->add_tag(@args);

Add a tag to the database. The following forms are accepted:

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

Add a Bio::DB::Tagger::Tag to the object named "$object_name".

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

The same as above using -option syntax.

 $tagger->add_tag(-object => $object_name,
                  -tag    => $tagname,
                  -value  => $tagvalue,
                  -author => $authorname);

Generate the tag from the options provided in B<-tag>, B<-value>
(optional) and B<-author> (optional), and then add the tag to the
object.

Returns true on success.

=cut

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]);
}

=item $result = $tagger->set_tags(@args);

Set the tags of an object, replacing all previous tags.

Arguments: B<-object>  Name of the object to tag.
           B<-tags>    List of Bio::DB::Tagger::Tag objects

Returns true on success.

=cut

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);
}

=item $result = $tagger->set_tag(@args);

Set a tag, replacing all previous tags of the same name.

Arguments: B<-object>  Name of the object to tag.
           B<-tag>     A Bio::DB::Tagger::Tag object, or tag name

Returns true on success.

=cut

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);
}

=item $result = $tagger->clear_tags($objectname);

Clear all tags from the indicated object. Returns true if the
operation was successful.

=cut

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

=item $result = $tagger->delete_tag($objectname,$tagname [,$tagvalue]);

Clear the one tag from the indicated object, filtering by tagname,
optionally by value.

=cut

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;
}

=item $result = $tagger->nuke_object($objectname);

Removes the object named $objectname. Returns true if the operation
was successful.

=cut

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

=item $result = $tagger->nuke_author($authorname);

Removes the author named $authorname. Returns true if the operation
was successful.

=cut

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

=item $result = $tagger->nuke_tag($tagname);

Removes the tag named $tagname. Returns true if the operation was
successful.

=cut

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;
    }
}

=item @tags = $tagger->get_tags($object_name [,$author])

Return all tags assigned to the indicated object, optionally
filtering by the author.

=cut

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;
}

=item $oid = $tagger->object_to_id($objectname [,$create] [,$key])

Fetch the object id (oid) of the object named "$objectname". If the
object doesn't exist, and $create is true, will create a new entry for
the object in the database.

=cut

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

=item $tid = $tagger->tag_to_id($tagname [,$create])

Fetch the tag id (tid) of the object named "$tagname". If the tag
doesn't exist, and $create is true, will create a new entry for the
tag in the database.

=cut

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

=item $aid = $tagger->author_to_id($authorname [,$create])

Fetch the author id (aid) of the object named "$authorname". If the
tag doesn't exist, and $create is true, will create a new entry for
the author in the database.

=cut

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;
}

=item $dbh = $tagger->dbh

Return underlying DBI handle.

=cut

sub dbh { return shift->{dbh} }

=item $tagger->initialize

Initialize the database with a fresh schema.

=cut

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;
}

=back

=cut

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 }


=head1 SEE ALSO

L<Bio::Graphics::Browser>, L<Bio::DB::SeqFeature::Store>

=head1 AUTHOR

Lincoln Stein E<lt>lincoln.stein@gmail.comE<gt>.

Copyright (c) 2009 Ontario Institute for Cancer Research

This package and its accompanying libraries is free software; you can
redistribute it and/or modify it under the terms of the GPL (either
version 1, or at your option, any later version) or the Artistic
License 2.0.  Refer to LICENSE for the full license text. In addition,
please see DISCLAIMER.txt for disclaimers of warranty.

=cut

1;

__END__