This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
abbacb6b34295b37ac8af47b90ae158630b99b9a
[perl5.git] / lib / base.pm
1 package base;
2
3 use strict 'vars';
4 use vars qw($VERSION);
5 $VERSION = '2.13';
6
7 # constant.pm is slow
8 sub SUCCESS () { 1 }
9
10 sub PUBLIC     () { 2**0  }
11 sub PRIVATE    () { 2**1  }
12 sub INHERITED  () { 2**2  }
13 sub PROTECTED  () { 2**3  }
14
15
16 my $Fattr = \%fields::attr;
17
18 sub has_fields {
19     my($base) = shift;
20     my $fglob = ${"$base\::"}{FIELDS};
21     return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
22 }
23
24 sub has_version {
25     my($base) = shift;
26     my $vglob = ${$base.'::'}{VERSION};
27     return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
28 }
29
30 sub has_attr {
31     my($proto) = shift;
32     my($class) = ref $proto || $proto;
33     return exists $Fattr->{$class};
34 }
35
36 sub get_attr {
37     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
38     return $Fattr->{$_[0]};
39 }
40
41 if ($] < 5.009) {
42     *get_fields = sub {
43         # Shut up a possible typo warning.
44         () = \%{$_[0].'::FIELDS'};
45         my $f = \%{$_[0].'::FIELDS'};
46
47         # should be centralized in fields? perhaps
48         # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
49         # is used here anyway, it doesn't matter.
50         bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
51
52         return $f;
53     }
54 }
55 else {
56     *get_fields = sub {
57         # Shut up a possible typo warning.
58         () = \%{$_[0].'::FIELDS'};
59         return \%{$_[0].'::FIELDS'};
60     }
61 }
62
63 sub import {
64     my $class = shift;
65
66     return SUCCESS unless @_;
67
68     # List of base classes from which we will inherit %FIELDS.
69     my $fields_base;
70
71     my $inheritor = caller(0);
72     my @isa_classes;
73
74     my @bases;
75     foreach my $base (@_) {
76         if ( $inheritor eq $base ) {
77             warn "Class '$inheritor' tried to inherit from itself\n";
78         }
79
80         next if grep $_->isa($base), ($inheritor, @bases);
81
82         if (has_version($base)) {
83             ${$base.'::VERSION'} = '-1, set by base.pm' 
84               unless defined ${$base.'::VERSION'};
85         }
86         else {
87             my $sigdie;
88             {
89                 local $SIG{__DIE__};
90                 eval "require $base";
91                 # Only ignore "Can't locate" errors from our eval require.
92                 # Other fatal errors (syntax etc) must be reported.
93                 die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
94                 unless (%{"$base\::"}) {
95                     require Carp;
96                     local $" = " ";
97                     Carp::croak(<<ERROR);
98 Base class package "$base" is empty.
99     (Perhaps you need to 'use' the module which defines that package first,
100     or make that module available in \@INC (\@INC contains: @INC).
101 ERROR
102                 }
103                 $sigdie = $SIG{__DIE__};
104             }
105             # Make sure a global $SIG{__DIE__} makes it out of the localization.
106             $SIG{__DIE__} = $sigdie if defined $sigdie;
107             ${$base.'::VERSION'} = "-1, set by base.pm"
108               unless defined ${$base.'::VERSION'};
109         }
110         push @bases, $base;
111
112         if ( has_fields($base) || has_attr($base) ) {
113             # No multiple fields inheritance *suck*
114             if ($fields_base) {
115                 require Carp;
116                 Carp::croak("Can't multiply inherit fields");
117             } else {
118                 $fields_base = $base;
119             }
120         }
121     }
122     # Save this until the end so it's all or nothing if the above loop croaks.
123     push @{"$inheritor\::ISA"}, @isa_classes;
124
125     push @{"$inheritor\::ISA"}, @bases;
126
127     if( defined $fields_base ) {
128         inherit_fields($inheritor, $fields_base);
129     }
130 }
131
132
133 sub inherit_fields {
134     my($derived, $base) = @_;
135
136     return SUCCESS unless $base;
137
138     my $battr = get_attr($base);
139     my $dattr = get_attr($derived);
140     my $dfields = get_fields($derived);
141     my $bfields = get_fields($base);
142
143     $dattr->[0] = @$battr;
144
145     if( keys %$dfields ) {
146         warn <<"END";
147 $derived is inheriting from $base but already has its own fields!
148 This will cause problems.  Be sure you use base BEFORE declaring fields.
149 END
150
151     }
152
153     # Iterate through the base's fields adding all the non-private
154     # ones to the derived class.  Hang on to the original attribute
155     # (Public, Private, etc...) and add Inherited.
156     # This is all too complicated to do efficiently with add_fields().
157     while (my($k,$v) = each %$bfields) {
158         my $fno;
159         if ($fno = $dfields->{$k} and $fno != $v) {
160             require Carp;
161             Carp::croak ("Inherited fields can't override existing fields");
162         }
163
164         if( $battr->[$v] & PRIVATE ) {
165             $dattr->[$v] = PRIVATE | INHERITED;
166         }
167         else {
168             $dattr->[$v] = INHERITED | $battr->[$v];
169             $dfields->{$k} = $v;
170         }
171     }
172
173     foreach my $idx (1..$#{$battr}) {
174         next if defined $dattr->[$idx];
175         $dattr->[$idx] = $battr->[$idx] & INHERITED;
176     }
177 }
178
179
180 1;
181
182 __END__
183
184 =head1 NAME
185
186 base - Establish an ISA relationship with base classes at compile time
187
188 =head1 SYNOPSIS
189
190     package Baz;
191     use base qw(Foo Bar);
192
193 =head1 DESCRIPTION
194
195 Allows you to both load one or more modules, while setting up inheritance from
196 those modules at the same time.  Roughly similar in effect to
197
198     package Baz;
199     BEGIN {
200         require Foo;
201         require Bar;
202         push @ISA, qw(Foo Bar);
203     }
204
205 C<base> employs some heuristics to determine if a module has already been
206 loaded, if it has it doesn't try again. If C<base> tries to C<require> the
207 module it will not die if it cannot find the module's file, but will die on any
208 other error. After all this, should your base class be empty, containing no
209 symbols, it will die. This is useful for inheriting from classes in the same
210 file as yourself, like so:
211
212         package Foo;
213         sub exclaim { "I can have such a thing?!" }
214         
215         package Bar;
216         use base "Foo";
217
218 If $VERSION is not detected even after loading it, <base> will define $VERSION
219 in the base package, setting it to the string C<-1, set by base.pm>.
220
221 C<base> will also initialize the fields if one of the base classes has it.
222 Multiple inheritance of fields is B<NOT> supported, if two or more base classes
223 each have inheritable fields the 'base' pragma will croak. See L<fields>,
224 L<public> and L<protected> for a description of this feature.
225
226 The base class' C<import> method is B<not> called.
227
228
229 =head1 DIAGNOSTICS
230
231 =over 4
232
233 =item Base class package "%s" is empty.
234
235 base.pm was unable to require the base package, because it was not
236 found in your path.
237
238 =item Class 'Foo' tried to inherit from itself
239
240 Attempting to inherit from yourself generates a warning.
241
242     use Foo;
243     use base 'Foo';
244
245 =back
246
247 =head1 HISTORY
248
249 This module was introduced with Perl 5.004_04.
250
251 =head1 CAVEATS
252
253 Due to the limitations of the implementation, you must use
254 base I<before> you declare any of your own fields.
255
256
257 =head1 SEE ALSO
258
259 L<fields>
260
261 =cut