The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Test::More 'no_plan';
use strict;
use Bio::Phylo;
use Bio::Phylo::Factory;
use Bio::Phylo::IO 'parse';

my $fac = Bio::Phylo::Factory->new;

# test taxon destruction
{
    my $id;
    {
        my $taxon = $fac->create_taxon;
        $id = $taxon->get_id;
    }
    my $obj = Bio::Phylo->get_obj_by_id($id);
    ok(! $obj, 'test taxon destruction');
}

# test taxa destruction
{
    my $id;
    {
        my $taxa = $fac->create_taxa;
        $id = $taxa->get_id;
    }
    my $obj = Bio::Phylo->get_obj_by_id($id);
    ok(! $obj, 'test taxa destruction' );
}

# test taxon in taxa destruction
{
    my ( $taxon_id, $taxa_id );
    {
        my $taxa = $fac->create_taxa;
        my $taxon = $fac->create_taxon;
        $taxa->insert($taxon);
        ( $taxon_id, $taxa_id ) = ( $taxon->get_id, $taxa->get_id );
    }
    ok( ! Bio::Phylo->get_obj_by_id($taxon_id), 'test taxon in taxa destruction' );
    ok( ! Bio::Phylo->get_obj_by_id($taxa_id), 'test taxon in taxa destruction' );
}

# test node destruction
{
    my $id;
    {
        my $node = $fac->create_node;
        $id = $node->get_id;
    }
    ok( ! Bio::Phylo->get_obj_by_id($id), 'test node destruction' );
}

# test tree destruction
{
    my $id;
    {
        my $tree = $fac->create_tree;
        $id = $tree->get_id;
    }
    ok( ! Bio::Phylo->get_obj_by_id($id), 'test tree destruction' );
}

# test node in tree destruction
{
    my ( $node_id, $tree_id );
    {
        my $tree = $fac->create_tree;
        my $node = $fac->create_node;
        $tree->insert($node);
        ( $node_id, $tree_id ) = ( $node->get_id, $tree->get_id );
    }
    ok( ! Bio::Phylo->get_obj_by_id($node_id), 'test node in tree destruction' );
    ok( ! Bio::Phylo->get_obj_by_id($tree_id), 'test node in tree destruction' );
}

# test nodes in tree destruction
{
    my ( $n1, $n2, $t );
    {
        my $tree   = $fac->create_tree;
        my $child  = $fac->create_node;
        my $parent = $fac->create_node;
        $child->set_parent($parent);
        $tree->insert($child,$parent);
        ( $n1, $n2, $t ) = ( $child->get_id, $parent->get_id, $tree->get_id );
    }
    ok( ! Bio::Phylo->get_obj_by_id($n1), 'test nodes in tree destruction' );
    ok( ! Bio::Phylo->get_obj_by_id($n2), 'test nodes in tree destruction' );
    ok( ! Bio::Phylo->get_obj_by_id($t), 'test nodes in tree destruction' );
}

# test datum destruction
{
    my $id;
    {
        my $datum = $fac->create_datum;
        $id = $datum->get_id;
    }
    ok( ! Bio::Phylo->get_obj_by_id($id), 'test datum destruction' );
}

# test matrix destruction
{
    my $id;
    {
        my $matrix = $fac->create_matrix;
        $id = $matrix->get_id;
    }
    ok( ! Bio::Phylo->get_obj_by_id($id), 'test matrix destruction' );
}

# test datum in matrix destruction
{
    my ( $m, $d );
    {
        my $matrix = $fac->create_matrix;
        my $datum = $fac->create_datum;
        $matrix->insert($datum);
        ( $m, $d ) = ( $matrix->get_id, $datum->get_id );
    }
    ok( ! Bio::Phylo->get_obj_by_id($m), 'test datum in matrix destruction' );
    ok( ! Bio::Phylo->get_obj_by_id($d), 'test datum in matrix destruction' );
}

# test entire project
{
    my %ids;
    {
        my $proj = parse(
            '-format' => 'nexus',
            '-handle' => \*DATA,
            '-as_project' => 1,
        );
        sub visitor {
            my $obj = shift;
            if ( UNIVERSAL::can( $obj, 'get_id' ) ) {
                $ids{ $obj->get_id } = ref $obj;
            }
            if ( UNIVERSAL::can( $obj, 'visit' ) ) {
                $obj->visit(\&visitor);       
            }
        }
        $proj->visit(\&visitor);
        $ids{$proj->get_id} = ref $proj;
        for my $id ( sort { $a <=> $b } keys %ids ) {
            ok( ref Bio::Phylo->get_obj_by_id($id) eq $ids{$id}, "Found $ids{$id} $id" );
        }        
    }
    for my $id ( sort { $a <=> $b } keys %ids ) {
        ok( ! Bio::Phylo->get_obj_by_id($id), "$ids{$id} $id has been destroyed" );
    }
}



__DATA__
#NEXUS

BEGIN TAXA;
	TITLE Taxa;
	DIMENSIONS NTAX=3;
	TAXLABELS
		taxon_1 taxon_2 taxon_3 
	;
END;

BEGIN CHARACTERS;
	TITLE  Character_Matrix;
	DIMENSIONS  NCHAR=2;
	FORMAT DATATYPE = STANDARD GAP = - MISSING = ? SYMBOLS = "  0 1";
	MATRIX
		taxon_1  ??
		taxon_2  ??
		taxon_3  ??
	;
END;

BEGIN TREES;
	Title Default_Trees;
	LINK Taxa = Taxa;
	TRANSLATE
		1 taxon_1,
		2 taxon_2,
		3 taxon_3;
	TREE Default_symmetrical = (1,(2,3));
	TREE Default_bush = (1,2,3);
	TREE Default_ladder = (1,(2,3));
END;