This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to base and fields 2.12, mostly by Michael G Schwern
[perl5.git] / lib / base.pm
CommitLineData
dc6d0c4f
JH
1package base;
2
864f8ab4 3use strict 'vars';
dc6d0c4f 4use vars qw($VERSION);
9e998a43 5$VERSION = '2.12';
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);
72
73 foreach my $base (@_) {
9b6f3a27
O
74 if ( $inheritor eq $base ) {
75 warn "Class '$inheritor' tried to inherit from itself\n";
76 }
77
dc6d0c4f
JH
78 next if $inheritor->isa($base);
79
80 if (has_version($base)) {
9e998a43
RGS
81 ${$base.'::VERSION'} = '-1, set by base.pm'
82 unless defined ${$base.'::VERSION'};
dc6d0c4f
JH
83 }
84 else {
9e998a43
RGS
85 my $sigdie;
86 {
87 local $SIG{__DIE__};
88 eval "require $base";
89 # Only ignore "Can't locate" errors from our eval require.
90 # Other fatal errors (syntax etc) must be reported.
91 die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
92 unless (%{"$base\::"}) {
93 require Carp;
94 Carp::croak(<<ERROR);
dc6d0c4f
JH
95Base class package "$base" is empty.
96 (Perhaps you need to 'use' the module which defines that package first.)
97ERROR
9e998a43
RGS
98 }
99 $sigdie = $SIG{__DIE__};
100 }
101 # Make sure a global $SIG{__DIE__} makes it out of the localization.
102 $SIG{__DIE__} = $sigdie if defined $sigdie;
dc6d0c4f
JH
103 ${$base.'::VERSION'} = "-1, set by base.pm"
104 unless defined ${$base.'::VERSION'};
105 }
106 push @{"$inheritor\::ISA"}, $base;
107
dc6d0c4f 108 if ( has_fields($base) || has_attr($base) ) {
9e998a43
RGS
109 # No multiple fields inheritance *suck*
110 if ($fields_base) {
111 require Carp;
112 Carp::croak("Can't multiply inherit fields");
113 } else {
114 $fields_base = $base;
115 }
dc6d0c4f
JH
116 }
117 }
118
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
45e8908f
EM
187Allows you to both load one or more modules, while setting up inheritance from
188those modules at the same time. Roughly similar in effect to
fb73857a 189
45e8908f 190 package Baz;
fb73857a 191 BEGIN {
dc6d0c4f
JH
192 require Foo;
193 require Bar;
194 push @ISA, qw(Foo Bar);
fb73857a
PP
195 }
196
9e998a43
RGS
197C<base> employs some heuristics to determine if a module has already been
198loaded, if it has it doesn't try again. If C<base> tries to C<require> the
199module it will not die if it cannot find the module's file, but will die on any
200other error. After all this, should your base class be empty, containing no
201symbols, it will die. This is useful for inheriting from classes in the same
202file as yourself, like so:
203
204 package Foo;
205 sub exclaim { "I can have such a thing?!" }
206
207 package Bar;
208 use base "Foo";
209
210If $VERSION is not detected even after loading it, <base> will define $VERSION
211in the base package, setting it to the string C<-1, set by base.pm>.
212
213C<base> will also initialize the fields if one of the base classes has it.
214Multiple inheritance of fields is B<NOT> supported, if two or more base classes
215each have inheritable fields the 'base' pragma will croak. See L<fields>,
216L<public> and L<protected> for a description of this feature.
217
218The base class' C<import> method is B<not> called.
45e8908f 219
f1192cee 220
36c726b3
JB
221=head1 DIAGNOSTICS
222
223=over 4
224
225=item Base class package "%s" is empty.
226
227base.pm was unable to require the base package, because it was not
228found in your path.
229
9e998a43 230=item Class 'Foo' tried to inherit from itself
36c726b3 231
9e998a43 232Attempting to inherit from yourself generates a warning.
b8bc843f 233
9e998a43
RGS
234 use Foo;
235 use base 'Foo';
fb73857a 236
9e998a43 237=back
9b6f3a27 238
9e998a43 239=head1 HISTORY
9b6f3a27 240
9e998a43 241This module was introduced with Perl 5.004_04.
fb73857a 242
dc6d0c4f 243=head1 CAVEATS
fb73857a 244
45e8908f 245Due to the limitations of the implementation, you must use
dc6d0c4f 246base I<before> you declare any of your own fields.
17f410f9 247
fb73857a 248
dc6d0c4f 249=head1 SEE ALSO
fb73857a 250
dc6d0c4f 251L<fields>
fb73857a 252
dc6d0c4f 253=cut