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
1 package base;
2
3 use strict 'vars';
4 use vars qw($VERSION);
5 $VERSION = '2.18';
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 my %loaded; # track modules loaded via base.pm
59
60 sub 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);
69     my @isa_classes;
70
71     my @bases;
72     foreach my $base (@_) {
73         if ( $inheritor eq $base ) {
74             warn "Class '$inheritor' tried to inherit from itself\n";
75         }
76
77         next if grep $_->isa($base), ($inheritor, @bases);
78
79         if (! $loaded{$base}) {
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;
89                     local $" = " ";
90                     Carp::croak(<<ERROR);
91 Base class package "$base" is empty.
92     (Perhaps you need to 'use' the module which defines that package first,
93     or make that module available in \@INC (\@INC contains: @INC).
94 ERROR
95                 }
96                 $sigdie = $SIG{__DIE__} || undef;
97             }
98             # Make sure a global $SIG{__DIE__} makes it out of the localization.
99             $SIG{__DIE__} = $sigdie if defined $sigdie;
100             $loaded{$base}++;
101         }
102         push @bases, $base;
103
104         if ( has_fields($base) || has_attr($base) ) {
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             }
112         }
113     }
114     # Save this until the end so it's all or nothing if the above loop croaks.
115     push @{"$inheritor\::ISA"}, @isa_classes;
116
117     push @{"$inheritor\::ISA"}, @bases;
118
119     if( defined $fields_base ) {
120         inherit_fields($inheritor, $fields_base);
121     }
122 }
123
124
125 sub 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 ) {
138         warn <<"END";
139 $derived is inheriting from $base but already has its own fields!
140 This will cause problems.  Be sure you use base BEFORE declaring fields.
141 END
142
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;
151         if ($fno = $dfields->{$k} and $fno != $v) {
152             require Carp;
153             Carp::croak ("Inherited fields can't override existing fields");
154         }
155
156         if( $battr->[$v] & PRIVATE ) {
157             $dattr->[$v] = PRIVATE | INHERITED;
158         }
159         else {
160             $dattr->[$v] = INHERITED | $battr->[$v];
161             $dfields->{$k} = $v;
162         }
163     }
164
165     foreach my $idx (1..$#{$battr}) {
166         next if defined $dattr->[$idx];
167         $dattr->[$idx] = $battr->[$idx] & INHERITED;
168     }
169 }
170
171
172 1;
173
174 __END__
175
176 =head1 NAME
177
178 base - Establish an ISA relationship with base classes at compile time
179
180 =head1 SYNOPSIS
181
182     package Baz;
183     use base qw(Foo Bar);
184
185 =head1 DESCRIPTION
186
187 Unless you are using the C<fields> pragma, consider this module discouraged
188 in favor of the lighter-weight C<parent>.
189
190 Allows you to both load one or more modules, while setting up inheritance from
191 those modules at the same time.  Roughly similar in effect to
192
193     package Baz;
194     BEGIN {
195         require Foo;
196         require Bar;
197         push @ISA, qw(Foo Bar);
198     }
199
200 When C<base> tries to C<require> a module, it will not die if it cannot find
201 the module's file, but will die on any other error.  After all this, should
202 your base class be empty, containing no symbols, C<base> will die. This is
203 useful for inheriting from classes in the same file as yourself but where
204 the filename does not match the base module name, like so:
205
206         # in Bar.pm
207         package Foo;
208         sub exclaim { "I can have such a thing?!" }
209
210         package Bar;
211         use base "Foo";
212
213 There is no F<Foo.pm>, but because C<Foo> defines a symbol (the C<exclaim>
214 subroutine), C<base> will not die when the C<require> fails to load F<Foo.pm>.
215 C<base> keeps track of modules that were successfully used as a base and will
216 not C<require> them again.
217
218 C<base> will also initialize the fields if one of the base classes has it.
219 Multiple inheritance of fields is B<NOT> supported, if two or more base classes
220 each have inheritable fields the 'base' pragma will croak. See L<fields>
221 for a description of this feature.
222
223 The base class' C<import> method is B<not> called.
224
225
226 =head1 DIAGNOSTICS
227
228 =over 4
229
230 =item Base class package "%s" is empty.
231
232 base.pm was unable to require the base package, because it was not
233 found in your path.
234
235 =item Class 'Foo' tried to inherit from itself
236
237 Attempting to inherit from yourself generates a warning.
238
239     package Foo;
240     use base 'Foo';
241
242 =back
243
244 =head1 HISTORY
245
246 This module was introduced with Perl 5.004_04.
247
248 =head1 CAVEATS
249
250 Due to the limitations of the implementation, you must use
251 base I<before> you declare any of your own fields.
252
253
254 =head1 SEE ALSO
255
256 L<fields>
257
258 =cut