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