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