File Coverage

Bio/DB/GFF/Typename.pm
Criterion Covered Total %
statement 36 39 92.3
branch 8 14 57.1
condition 10 23 43.4
subroutine 9 9 100.0
pod 6 6 100.0
total 69 91 75.8


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Bio::DB::GFF::Typename -- The name of a feature type
4              
5             =head1 SYNOPSIS
6              
7             use Bio::DB::GFF;
8              
9             my $type = Bio::DB::GFF::Typename->new(similarity => 'BLAT_EST_GENOME');
10             my $segment = $segment->features($type);
11              
12             =head1 DESCRIPTION
13              
14             Bio::DB::GFF::Typename objects encapsulate the combination of feature
15             method and source used by the GFF flat file format. They can be used
16             in the Bio::DB::GFF modules wherever a feature type is called for.
17              
18             Since there are relatively few types and many features, this module
19             maintains a memory cache of unique types so that two features of the
20             same type will share the same Bio::DB::GFF::Typename object.
21              
22             =head1 METHODS
23              
24             =cut
25              
26             package Bio::DB::GFF::Typename;
27              
28 3     3   15 use strict;
  3         3  
  3         78  
29             use overload
30 3         12 '""' => 'asString',
31 3     3   12 fallback => 1;
  3         3  
32              
33              
34 3     3   189 use base qw(Bio::Root::Root Bio::Das::FeatureTypeI);
  3         6  
  3         714  
35              
36             # cut down on the number of equivalent objects we have to create
37             my %OBJECT_CACHE;
38              
39             =head2 new
40              
41             Title : new
42             Usage : $type = Bio::DB::GFF::Typename->new($method,$source)
43             Function: create a new Bio::DB::GFF::Typename object
44             Returns : a new Bio::DB::GFF::Typename object
45             Args : method and source
46             Status : Public
47              
48             =cut
49              
50             sub new {
51 1434     1434 1 1392 my $package = shift;
52 1434         1729 my ($method,$source) = @_;
53 1434   50     1748 $method ||= '';
54 1434   50     1665 $source ||= '';
55 1434 50 33     2022 if ($source eq '' && $method =~ /^([\w-\.]+):([\w-\.]*)$/) {
56 0         0 $method = $1;
57 0         0 $source = $2;
58             }
59 1434   100     2999 return $OBJECT_CACHE{"$method:$source"} ||= bless [$method,$source],$package;
60             }
61              
62             =head2 method
63              
64             Title : method
65             Usage : $method = $type->method([$newmethod])
66             Function: get or set the method
67             Returns : a method name
68             Args : new method name (optional)
69             Status : Public
70              
71             =cut
72              
73             sub method {
74 1023     1023 1 1004 my $self = shift;
75 1023         1122 my $d = $self->[0];
76 1023 100       1442 $self->[0] = shift if @_;
77 1023         1537 $d;
78             }
79              
80              
81             =head2 source
82              
83             Title : source
84             Usage : $source = $type->source([$newsource])
85             Function: get or set the source
86             Returns : a source name
87             Args : new source name (optional)
88             Status : Public
89              
90             =cut
91              
92             sub source {
93 330     330 1 344 my $self = shift;
94 330         358 my $d = $self->[1];
95 330 50       419 $self->[1] = shift if @_;
96 330         574 $d;
97             }
98              
99             =head2 asString
100              
101             Title : asString
102             Usage : $string = $type->asString
103             Function: get the method and source as a string
104             Returns : a string in "method:source" format
105             Args : none
106             Status : Public
107              
108             This method is used by operator overloading to overload the '""'
109             operator.
110              
111             =cut
112              
113             sub asString {
114 5168 50   5168 1 6722 $_[0]->[1] ? join ':',@{$_[0]} : $_[0]->[0];
  5168         16310  
115             }
116              
117             =head2 clone
118              
119             Title : clone
120             Usage : $new_clone = $type->clone;
121             Function: clone this object
122             Returns : a new Bio::DB::GFF::Typename object
123             Args : none
124             Status : Public
125              
126             This method creates an exact copy of the object.
127              
128             =cut
129              
130             sub clone {
131 107     107 1 117 my $self = shift;
132 107         288 return bless [@$self],ref $self;
133             }
134              
135             =head2 match
136              
137             Title : match
138             Usage : $boolean = $type->match($type_or_string)
139             Function: fuzzy match on types
140             Returns : a flag indicating that the argument matches the object
141             Args : a Bio::DB::GFF::typename object, or a string in method:source format
142             Status : Public
143              
144             This match allows Sequence:Link and Sequence: to match, but not
145             Sequence:Link and Sequence:Genomic_canonical.
146              
147             =cut
148              
149             sub match {
150 25     25 1 11592 my $self = shift;
151 25         42 my $target = shift;
152 25         37 my ($method,$source);
153              
154 25 50       120 if (UNIVERSAL::isa($target,'Bio::DB::GFF::Typename')) {
155 0         0 ($method,$source) = ($target->method,$target->source);
156             } else {
157 25         97 ($method,$source) = split /:/,$target;
158             }
159              
160 25   50     68 $source ||= ''; # quash uninit variable warnings
161              
162 25 50 33     149 return if $method ne '' && $self->method ne '' && $method ne $self->method;
      33        
163 25 50 33     80 return if $source ne '' && $self->source ne '' && $source ne $self->source;
      33        
164 25         272 1;
165             }
166              
167             1;
168              
169             =head1 BUGS
170              
171             This module is still under development.
172              
173             =head1 SEE ALSO
174              
175             L, L, L
176              
177             =head1 AUTHOR
178              
179             Lincoln Stein Elstein@cshl.orgE.
180              
181             Copyright (c) 2001 Cold Spring Harbor Laboratory.
182              
183             This library is free software; you can redistribute it and/or modify
184             it under the same terms as Perl itself.
185              
186             =cut
187              
188             1;