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