This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
use base problem
[perl5.git] / lib / base.pm
CommitLineData
dc6d0c4f
JH
1package base;
2
864f8ab4 3use strict 'vars';
dc6d0c4f 4use vars qw($VERSION);
6df974e5 5$VERSION = '2.13';
dc6d0c4f
JH
6
7# constant.pm is slow
8sub SUCCESS () { 1 }
9
10sub PUBLIC () { 2**0 }
11sub PRIVATE () { 2**1 }
12sub INHERITED () { 2**2 }
13sub PROTECTED () { 2**3 }
14
15
16my $Fattr = \%fields::attr;
17
18sub has_fields {
19 my($base) = shift;
20 my $fglob = ${"$base\::"}{FIELDS};
28994922 21 return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
dc6d0c4f
JH
22}
23
24sub has_version {
25 my($base) = shift;
26 my $vglob = ${$base.'::'}{VERSION};
864f8ab4 27 return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
dc6d0c4f
JH
28}
29
30sub has_attr {
31 my($proto) = shift;
32 my($class) = ref $proto || $proto;
33 return exists $Fattr->{$class};
34}
35
36sub get_attr {
37 $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
38 return $Fattr->{$_[0]};
39}
40
8731c5d9 41if ($] < 5.009) {
42 *get_fields = sub {
9e998a43
RGS
43 # Shut up a possible typo warning.
44 () = \%{$_[0].'::FIELDS'};
45 my $f = \%{$_[0].'::FIELDS'};
dc6d0c4f 46
9e998a43
RGS
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');
8731c5d9 51
9e998a43 52 return $f;
8731c5d9 53 }
54}
55else {
56 *get_fields = sub {
9e998a43
RGS
57 # Shut up a possible typo warning.
58 () = \%{$_[0].'::FIELDS'};
59 return \%{$_[0].'::FIELDS'};
8731c5d9 60 }
dc6d0c4f
JH
61}
62
dc6d0c4f
JH
63sub 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);
6df974e5 72 my @isa_classes;
dc6d0c4f 73
00ed247a 74 my @bases;
dc6d0c4f 75 foreach my $base (@_) {
9b6f3a27
O
76 if ( $inheritor eq $base ) {
77 warn "Class '$inheritor' tried to inherit from itself\n";
78 }
79
00ed247a 80 next if grep $_->isa($base), ($inheritor, @bases);
dc6d0c4f
JH
81
82 if (has_version($base)) {
9e998a43
RGS
83 ${$base.'::VERSION'} = '-1, set by base.pm'
84 unless defined ${$base.'::VERSION'};
dc6d0c4f
JH
85 }
86 else {
9e998a43
RGS
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;
5565990a 96 local $" = " ";
9e998a43 97 Carp::croak(<<ERROR);
dc6d0c4f 98Base class package "$base" is empty.
5565990a
RGS
99 (Perhaps you need to 'use' the module which defines that package first,
100 or make that module available in \@INC (\@INC contains: @INC).
dc6d0c4f 101ERROR
9e998a43 102 }
bd3d0583 103 $sigdie = $SIG{__DIE__} || undef;
9e998a43
RGS
104 }
105 # Make sure a global $SIG{__DIE__} makes it out of the localization.
106 $SIG{__DIE__} = $sigdie if defined $sigdie;
dc6d0c4f
JH
107 ${$base.'::VERSION'} = "-1, set by base.pm"
108 unless defined ${$base.'::VERSION'};
109 }
00ed247a 110 push @bases, $base;
dc6d0c4f 111
dc6d0c4f 112 if ( has_fields($base) || has_attr($base) ) {
9e998a43
RGS
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 }
dc6d0c4f
JH
120 }
121 }
6df974e5
RD
122 # Save this until the end so it's all or nothing if the above loop croaks.
123 push @{"$inheritor\::ISA"}, @isa_classes;
dc6d0c4f 124
00ed247a
MS
125 push @{"$inheritor\::ISA"}, @bases;
126
dc6d0c4f
JH
127 if( defined $fields_base ) {
128 inherit_fields($inheritor, $fields_base);
129 }
130}
131
132
133sub 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 ) {
9e998a43
RGS
146 warn <<"END";
147$derived is inheriting from $base but already has its own fields!
148This will cause problems. Be sure you use base BEFORE declaring fields.
149END
150
dc6d0c4f
JH
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;
9e998a43
RGS
159 if ($fno = $dfields->{$k} and $fno != $v) {
160 require Carp;
161 Carp::croak ("Inherited fields can't override existing fields");
162 }
dc6d0c4f
JH
163
164 if( $battr->[$v] & PRIVATE ) {
864f8ab4 165 $dattr->[$v] = PRIVATE | INHERITED;
dc6d0c4f
JH
166 }
167 else {
168 $dattr->[$v] = INHERITED | $battr->[$v];
dc6d0c4f
JH
169 $dfields->{$k} = $v;
170 }
171 }
864f8ab4 172
446e776f 173 foreach my $idx (1..$#{$battr}) {
9e998a43
RGS
174 next if defined $dattr->[$idx];
175 $dattr->[$idx] = $battr->[$idx] & INHERITED;
864f8ab4 176 }
dc6d0c4f
JH
177}
178
179
1801;
181
182__END__
183
fb73857a
PP
184=head1 NAME
185
9e998a43 186base - Establish an ISA relationship with base classes at compile time
fb73857a
PP
187
188=head1 SYNOPSIS
189
190 package Baz;
fb73857a
PP
191 use base qw(Foo Bar);
192
193=head1 DESCRIPTION
194
45e8908f
EM
195Allows you to both load one or more modules, while setting up inheritance from
196those modules at the same time. Roughly similar in effect to
fb73857a 197
45e8908f 198 package Baz;
fb73857a 199 BEGIN {
dc6d0c4f
JH
200 require Foo;
201 require Bar;
202 push @ISA, qw(Foo Bar);
fb73857a
PP
203 }
204
9e998a43
RGS
205C<base> employs some heuristics to determine if a module has already been
206loaded, if it has it doesn't try again. If C<base> tries to C<require> the
207module it will not die if it cannot find the module's file, but will die on any
208other error. After all this, should your base class be empty, containing no
209symbols, it will die. This is useful for inheriting from classes in the same
210file 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
218If $VERSION is not detected even after loading it, <base> will define $VERSION
219in the base package, setting it to the string C<-1, set by base.pm>.
220
221C<base> will also initialize the fields if one of the base classes has it.
222Multiple inheritance of fields is B<NOT> supported, if two or more base classes
223each have inheritable fields the 'base' pragma will croak. See L<fields>,
224L<public> and L<protected> for a description of this feature.
225
226The base class' C<import> method is B<not> called.
45e8908f 227
f1192cee 228
36c726b3
JB
229=head1 DIAGNOSTICS
230
231=over 4
232
233=item Base class package "%s" is empty.
234
235base.pm was unable to require the base package, because it was not
236found in your path.
237
9e998a43 238=item Class 'Foo' tried to inherit from itself
36c726b3 239
9e998a43 240Attempting to inherit from yourself generates a warning.
b8bc843f 241
9e998a43
RGS
242 use Foo;
243 use base 'Foo';
fb73857a 244
9e998a43 245=back
9b6f3a27 246
9e998a43 247=head1 HISTORY
9b6f3a27 248
9e998a43 249This module was introduced with Perl 5.004_04.
fb73857a 250
dc6d0c4f 251=head1 CAVEATS
fb73857a 252
45e8908f 253Due to the limitations of the implementation, you must use
dc6d0c4f 254base I<before> you declare any of your own fields.
17f410f9 255
fb73857a 256
dc6d0c4f 257=head1 SEE ALSO
fb73857a 258
dc6d0c4f 259L<fields>
fb73857a 260
dc6d0c4f 261=cut