|
0
|
1 # $Id: BiblioBase.pm,v 1.9 2002/10/22 07:45:11 lapp Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::Biblio::BiblioBase
|
|
|
4 #
|
|
|
5 # Cared for by Martin Senger <senger@ebi.ac.uk>
|
|
|
6 # For copyright and disclaimer see below.
|
|
|
7
|
|
|
8 # POD documentation - main docs before the code
|
|
|
9
|
|
|
10 =head1 NAME
|
|
|
11
|
|
|
12 Bio::Biblio::BiblioBase - An abstract base for other biblio classes
|
|
|
13
|
|
|
14 =head1 SYNOPSIS
|
|
|
15
|
|
|
16 # do not instantiate this class directly
|
|
|
17
|
|
|
18 =head1 DESCRIPTION
|
|
|
19
|
|
|
20 It is a base class where all other biblio data storage classes inherit
|
|
|
21 from. It does not reflect any real-world object, it exists only for
|
|
|
22 convenience, in order to have a place for shared code.
|
|
|
23
|
|
|
24 =head2 new()
|
|
|
25
|
|
|
26 The I<new()> class method constructs a new biblio storage object. It
|
|
|
27 accepts list of named arguments - the same names as attribute names
|
|
|
28 prefixed with a minus sign. Available attribute names are listed in
|
|
|
29 the documentation of the individual biblio storage objects.
|
|
|
30
|
|
|
31 =head2 Accessors
|
|
|
32
|
|
|
33 All attribute names can be used as method names. When used without any
|
|
|
34 parameter the method returns current value of the attribute (or
|
|
|
35 undef), when used with a value the method sets the attribute to this
|
|
|
36 value and also returns it back. The set method also checks if the type
|
|
|
37 of the new value is correct.
|
|
|
38
|
|
|
39 =head2 Custom classes
|
|
|
40
|
|
|
41 If there is a need for new attributes, create your own class which
|
|
|
42 usually inherits from I<Bio::Biblio::Ref>. For new types of providers
|
|
|
43 and journals, let your class inherit directly from this
|
|
|
44 I<Bio::Biblio::BiblioBase> class.
|
|
|
45
|
|
|
46 =head1 FEEDBACK
|
|
|
47
|
|
|
48 =head2 Mailing Lists
|
|
|
49
|
|
|
50 User feedback is an integral part of the evolution of this and other
|
|
|
51 Bioperl modules. Send your comments and suggestions preferably to
|
|
|
52 the Bioperl mailing list. Your participation is much appreciated.
|
|
|
53
|
|
|
54 bioperl-l@bioperl.org - General discussion
|
|
|
55 http://bioperl.org/MailList.shtml - About the mailing lists
|
|
|
56
|
|
|
57 =head2 Reporting Bugs
|
|
|
58
|
|
|
59 Report bugs to the Bioperl bug tracking system to help us keep track
|
|
|
60 of the bugs and their resolution. Bug reports can be submitted via
|
|
|
61 email or the web:
|
|
|
62
|
|
|
63 bioperl-bugs@bioperl.org
|
|
|
64 http://bugzilla.bioperl.org/
|
|
|
65
|
|
|
66 =head1 AUTHOR
|
|
|
67
|
|
|
68 Martin Senger (senger@ebi.ac.uk)
|
|
|
69
|
|
|
70 =head1 COPYRIGHT
|
|
|
71
|
|
|
72 Copyright (c) 2002 European Bioinformatics Institute. All Rights Reserved.
|
|
|
73
|
|
|
74 This module is free software; you can redistribute it and/or modify
|
|
|
75 it under the same terms as Perl itself.
|
|
|
76
|
|
|
77 =head1 DISCLAIMER
|
|
|
78
|
|
|
79 This software is provided "as is" without warranty of any kind.
|
|
|
80
|
|
|
81 =cut
|
|
|
82
|
|
|
83
|
|
|
84 # Let the code begin...
|
|
|
85
|
|
|
86
|
|
|
87 package Bio::Biblio::BiblioBase;
|
|
|
88 use strict;
|
|
|
89 use vars qw(@ISA $AUTOLOAD);
|
|
|
90
|
|
|
91 use Bio::Root::Root;
|
|
|
92
|
|
|
93 @ISA = qw(Bio::Root::Root);
|
|
|
94
|
|
|
95 # these methods should not be called here;
|
|
|
96 # they should be implemented by a subclass
|
|
|
97 sub _accessible { shift->throw_not_implemented(); }
|
|
|
98 sub _attr_type { shift->throw_not_implemented(); }
|
|
|
99
|
|
|
100 #
|
|
|
101 # deal with 'set_' and 'get_' methods
|
|
|
102 #
|
|
|
103 sub AUTOLOAD {
|
|
|
104 my ($self, $newval) = @_;
|
|
|
105
|
|
|
106 if ($AUTOLOAD =~ /.*::(\w+)/ && $self->_accessible ("_$1")) {
|
|
|
107 my $attr_name = "_$1";
|
|
|
108 my $attr_type = $self->_attr_type ($attr_name);
|
|
|
109 my $ref_sub =
|
|
|
110 sub {
|
|
|
111 my ($this, $new_value) = @_;
|
|
|
112 return $this->{$attr_name} unless defined $new_value;
|
|
|
113
|
|
|
114 # here we continue with 'set' method
|
|
|
115 my ($newval_type) = ref ($new_value) || 'string';
|
|
|
116 my ($expected_type) = $attr_type || 'string';
|
|
|
117 # $this->throw ("In method $AUTOLOAD, trying to set a value of type '$newval_type' but '$expected_type' is expected.")
|
|
|
118 $this->throw ($this->_wrong_type_msg ($newval_type, $expected_type, $AUTOLOAD))
|
|
|
119 unless ($newval_type eq $expected_type) or
|
|
|
120 UNIVERSAL::isa ($new_value, $expected_type);
|
|
|
121
|
|
|
122 $this->{$attr_name} = $new_value;
|
|
|
123 return $new_value;
|
|
|
124 };
|
|
|
125
|
|
|
126 no strict 'refs';
|
|
|
127 *{$AUTOLOAD} = $ref_sub;
|
|
|
128 use strict 'refs';
|
|
|
129 return $ref_sub->($self, $newval);
|
|
|
130 }
|
|
|
131
|
|
|
132 $self->throw ("No such method: $AUTOLOAD");
|
|
|
133 }
|
|
|
134
|
|
|
135 #
|
|
|
136
|
|
|
137 sub new {
|
|
|
138 my ($caller, @args) = @_;
|
|
|
139 my $class = ref ($caller) || $caller;
|
|
|
140
|
|
|
141 # create and bless a new instance
|
|
|
142 my ($self) = $class->SUPER::new (@args);
|
|
|
143
|
|
|
144 # make a hashtable from @args
|
|
|
145 my %param = @args;
|
|
|
146 @param { map { lc $_ } keys %param } = values %param; # lowercase keys
|
|
|
147
|
|
|
148 # set all @args into this object with 'set' values;
|
|
|
149 # change '-key' into '_key', and making keys lowercase
|
|
|
150 my $new_key;
|
|
|
151 foreach my $key (keys %param) {
|
|
|
152 ($new_key = $key) =~ s/-/_/og; # change it everywhere, why not
|
|
|
153 my $method = lc (substr ($new_key, 1)); # omitting the first '_'
|
|
|
154 no strict 'refs';
|
|
|
155 $method->($self, $param { $key });
|
|
|
156 }
|
|
|
157
|
|
|
158 # done
|
|
|
159 return $self;
|
|
|
160 }
|
|
|
161
|
|
|
162 #
|
|
|
163 # set methods test whether incoming value is of a correct type;
|
|
|
164 # here we return message explaining it
|
|
|
165 #
|
|
|
166 sub _wrong_type_msg {
|
|
|
167 my ($self, $given_type, $expected_type, $method) = @_;
|
|
|
168 my $msg = 'In method ';
|
|
|
169 if (defined $method) {
|
|
|
170 $msg .= $method;
|
|
|
171 } else {
|
|
|
172 $msg .= (caller(1))[3];
|
|
|
173 }
|
|
|
174 return ("$msg: Trying to set a value of type '$given_type' but '$expected_type' is expected.");
|
|
|
175 }
|
|
|
176
|
|
|
177 #
|
|
|
178 # probably just for debugging
|
|
|
179 # TBD: to decide...
|
|
|
180 #
|
|
|
181 sub print_me {
|
|
|
182 my ($self) = @_;
|
|
|
183 require Data::Dumper;
|
|
|
184 return Data::Dumper->Dump ( [$self], ['Citation']);
|
|
|
185 }
|
|
|
186
|
|
|
187 1;
|
|
|
188 __END__
|
