lib/Bio/DB/GFF/Typename.pm

   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 use strict;
  29 use overload
  30   '""'     => 'asString',
  31   fallback => 1;
  32
  33
  34 use base qw(Bio::Root::Root Bio::Das::FeatureTypeI);
  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   my $package = shift;
  52   my ($method,$source) = @_;
  53   $method ||= '';
  54   $source ||= '';
  55   if ($source eq '' && $method =~ /^([\w\-\.]+):([\w\-\.]*)$/) {
  56     $method = $1;
  57     $source = $2;
  58   }
  59   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   my $self = shift;
  75   my $d = $self->[0];
  76   $self->[0] = shift if @_;
  77   $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   my $self = shift;
  94   my $d = $self->[1];
  95   $self->[1] = shift if @_;
  96   $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   $_[0]->[1] ? join ':',@{$_[0]} : $_[0]->[0];
 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   my $self = shift;
 132   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   my $self   = shift;
 151   my $target = shift;
 152   my ($method,$source);
 153
 154   if (UNIVERSAL::isa($target,'Bio::DB::GFF::Typename')) {
 155     ($method,$source) = ($target->method,$target->source);
 156   } else {
 157     ($method,$source) = split /:/,$target;
 158   }
 159
 160   $source ||= ''; # quash uninit variable warnings
 161
 162   return if $method ne '' && $self->method ne '' && $method ne $self->method;
 163   return if $source ne '' && $self->source ne '' && $source ne $self->source;
 164   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<bioperl>, L<Bio::DB::GFF>, L<Bio::DB::RelSegment>
 176
 177 =head1 AUTHOR
 178
 179 Lincoln Stein E<lt>lstein@cshl.orgE<gt>.
 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;