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
1 package base;
2
3 use strict 'vars';
4 use vars qw($VERSION);
5 $VERSION = '2.19';
6 $VERSION = eval $VERSION;
7
8 # constant.pm is slow
9 sub SUCCESS () { 1 }
10
11 sub PUBLIC     () { 2**0  }
12 sub PRIVATE    () { 2**1  }
13 sub INHERITED  () { 2**2  }
14 sub PROTECTED  () { 2**3  }
15
16
17 my $Fattr = \%fields::attr;
18
19 sub has_fields {
20     my($base) = shift;
21     my $fglob = ${"$base\::"}{FIELDS};
22     return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
23 }
24
25 sub has_attr {
26     my($proto) = shift;
27     my($class) = ref $proto || $proto;
28     return exists $Fattr->{$class};
29 }
30
31 sub get_attr {
32     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
33     return $Fattr->{$_[0]};
34 }
35
36 if ($] < 5.009) {
37     *get_fields = sub {
38         # Shut up a possible typo warning.
39         () = \%{$_[0].'::FIELDS'};
40         my $f = \%{$_[0].'::FIELDS'};
41
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');
46
47         return $f;
48     }
49 }
50 else {
51     *get_fields = sub {
52         # Shut up a possible typo warning.
53         () = \%{$_[0].'::FIELDS'};
54         return \%{$_[0].'::FIELDS'};
55     }
56 }
57
58 sub 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
68     my @bases;
69     foreach my $base (@_) {
70         if ( $inheritor eq $base ) {
71             warn "Class '$inheritor' tried to inherit from itself\n";
72         }
73
74         next if grep $_->isa($base), ($inheritor, @bases);
75
76         # Following blocks help isolate $SIG{__DIE__} changes
77         {
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.
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]
90                 die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
91                 unless (%{"$base\::"}) {
92                     require Carp;
93                     local $" = " ";
94                     Carp::croak(<<ERROR);
95 Base class package "$base" is empty.
96     (Perhaps you need to 'use' the module which defines that package first,
97     or make that module available in \@INC (\@INC contains: @INC).
98 ERROR
99                 }
100                 $sigdie = $SIG{__DIE__} || undef;
101             }
102             # Make sure a global $SIG{__DIE__} makes it out of the localization.
103             $SIG{__DIE__} = $sigdie if defined $sigdie;
104         }
105         push @bases, $base;
106
107         if ( has_fields($base) || has_attr($base) ) {
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             }
115         }
116     }
117     # Save this until the end so it's all or nothing if the above loop croaks.
118     push @{"$inheritor\::ISA"}, @bases;
119
120     if( defined $fields_base ) {
121         inherit_fields($inheritor, $fields_base);
122     }
123 }
124
125
126 sub 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 ) {
139         warn <<"END";
140 $derived is inheriting from $base but already has its own fields!
141 This will cause problems.  Be sure you use base BEFORE declaring fields.
142 END
143
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;
152         if ($fno = $dfields->{$k} and $fno != $v) {
153             require Carp;
154             Carp::croak ("Inherited fields can't override existing fields");
155         }
156
157         if( $battr->[$v] & PRIVATE ) {
158             $dattr->[$v] = PRIVATE | INHERITED;
159         }
160         else {
161             $dattr->[$v] = INHERITED | $battr->[$v];
162             $dfields->{$k} = $v;
163         }
164     }
165
166     foreach my $idx (1..$#{$battr}) {
167         next if defined $dattr->[$idx];
168         $dattr->[$idx] = $battr->[$idx] & INHERITED;
169     }
170 }
171
172
173 1;
174
175 __END__
176
177 =head1 NAME
178
179 base - Establish an ISA relationship with base classes at compile time
180
181 =head1 SYNOPSIS
182
183     package Baz;
184     use base qw(Foo Bar);
185
186 =head1 DESCRIPTION
187
188 Unless you are using the C<fields> pragma, consider this module discouraged
189 in favor of the lighter-weight C<parent>.
190
191 Allows you to both load one or more modules, while setting up inheritance from
192 those modules at the same time.  Roughly similar in effect to
193
194     package Baz;
195     BEGIN {
196         require Foo;
197         require Bar;
198         push @ISA, qw(Foo Bar);
199     }
200
201 When C<base> tries to C<require> a module, it will not die if it cannot find
202 the module's file, but will die on any other error.  After all this, should
203 your base class be empty, containing no symbols, C<base> will die. This is
204 useful for inheriting from classes in the same file as yourself but where
205 the filename does not match the base module name, like so:
206
207         # in Bar.pm
208         package Foo;
209         sub exclaim { "I can have such a thing?!" }
210
211         package Bar;
212         use base "Foo";
213
214 There is no F<Foo.pm>, but because C<Foo> defines a symbol (the C<exclaim>
215 subroutine), C<base> will not die when the C<require> fails to load F<Foo.pm>.
216
217 C<base> will also initialize the fields if one of the base classes has it.
218 Multiple inheritance of fields is B<NOT> supported, if two or more base classes
219 each have inheritable fields the 'base' pragma will croak. See L<fields>
220 for a description of this feature.
221
222 The base class' C<import> method is B<not> called.
223
224
225 =head1 DIAGNOSTICS
226
227 =over 4
228
229 =item Base class package "%s" is empty.
230
231 base.pm was unable to require the base package, because it was not
232 found in your path.
233
234 =item Class 'Foo' tried to inherit from itself
235
236 Attempting to inherit from yourself generates a warning.
237
238     package Foo;
239     use base 'Foo';
240
241 =back
242
243 =head1 HISTORY
244
245 This module was introduced with Perl 5.004_04.
246
247 =head1 CAVEATS
248
249 Due to the limitations of the implementation, you must use
250 base I<before> you declare any of your own fields.
251
252
253 =head1 SEE ALSO
254
255 L<fields>
256
257 =cut