Move base from ext/ to dist/
[perl.git] / dist / base / lib / base.pm
1 package base;
2
3 use strict 'vars';
4 use vars qw($VERSION);
5 $VERSION = '2.14';
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_version {
26     my($base) = shift;
27     my $vglob = ${$base.'::'}{VERSION};
28     return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
29 }
30
31 sub has_attr {
32     my($proto) = shift;
33     my($class) = ref $proto || $proto;
34     return exists $Fattr->{$class};
35 }
36
37 sub get_attr {
38     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
39     return $Fattr->{$_[0]};
40 }
41
42 if ($] < 5.009) {
43     *get_fields = sub {
44         # Shut up a possible typo warning.
45         () = \%{$_[0].'::FIELDS'};
46         my $f = \%{$_[0].'::FIELDS'};
47
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');
52
53         return $f;
54     }
55 }
56 else {
57     *get_fields = sub {
58         # Shut up a possible typo warning.
59         () = \%{$_[0].'::FIELDS'};
60         return \%{$_[0].'::FIELDS'};
61     }
62 }
63
64 sub 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);
73     my @isa_classes;
74
75     my @bases;
76     foreach my $base (@_) {
77         if ( $inheritor eq $base ) {
78             warn "Class '$inheritor' tried to inherit from itself\n";
79         }
80
81         next if grep $_->isa($base), ($inheritor, @bases);
82
83         if (has_version($base)) {
84             ${$base.'::VERSION'} = '-1, set by base.pm' 
85               unless defined ${$base.'::VERSION'};
86         }
87         else {
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;
97                     local $" = " ";
98                     Carp::croak(<<ERROR);
99 Base class package "$base" is empty.
100     (Perhaps you need to 'use' the module which defines that package first,
101     or make that module available in \@INC (\@INC contains: @INC).
102 ERROR
103                 }
104                 $sigdie = $SIG{__DIE__} || undef;
105             }
106             # Make sure a global $SIG{__DIE__} makes it out of the localization.
107             $SIG{__DIE__} = $sigdie if defined $sigdie;
108             ${$base.'::VERSION'} = "-1, set by base.pm"
109               unless defined ${$base.'::VERSION'};
110         }
111         push @bases, $base;
112
113         if ( has_fields($base) || has_attr($base) ) {
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             }
121         }
122     }
123     # Save this until the end so it's all or nothing if the above loop croaks.
124     push @{"$inheritor\::ISA"}, @isa_classes;
125
126     push @{"$inheritor\::ISA"}, @bases;
127
128     if( defined $fields_base ) {
129         inherit_fields($inheritor, $fields_base);
130     }
131 }
132
133
134 sub 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 ) {
147         warn <<"END";
148 $derived is inheriting from $base but already has its own fields!
149 This will cause problems.  Be sure you use base BEFORE declaring fields.
150 END
151
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;
160         if ($fno = $dfields->{$k} and $fno != $v) {
161             require Carp;
162             Carp::croak ("Inherited fields can't override existing fields");
163         }
164
165         if( $battr->[$v] & PRIVATE ) {
166             $dattr->[$v] = PRIVATE | INHERITED;
167         }
168         else {
169             $dattr->[$v] = INHERITED | $battr->[$v];
170             $dfields->{$k} = $v;
171         }
172     }
173
174     foreach my $idx (1..$#{$battr}) {
175         next if defined $dattr->[$idx];
176         $dattr->[$idx] = $battr->[$idx] & INHERITED;
177     }
178 }
179
180
181 1;
182
183 __END__
184
185 =head1 NAME
186
187 base - Establish an ISA relationship with base classes at compile time
188
189 =head1 SYNOPSIS
190
191     package Baz;
192     use base qw(Foo Bar);
193
194 =head1 DESCRIPTION
195
196 Unless you are using the C<fields> pragma, consider this module discouraged
197 in favor of the lighter-weight C<parent>.
198
199 Allows you to both load one or more modules, while setting up inheritance from
200 those modules at the same time.  Roughly similar in effect to
201
202     package Baz;
203     BEGIN {
204         require Foo;
205         require Bar;
206         push @ISA, qw(Foo Bar);
207     }
208
209 C<base> employs some heuristics to determine if a module has already been
210 loaded, if it has it doesn't try again. If C<base> tries to C<require> the
211 module it will not die if it cannot find the module's file, but will die on any
212 other error. After all this, should your base class be empty, containing no
213 symbols, it will die. This is useful for inheriting from classes in the same
214 file 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
222 If $VERSION is not detected even after loading it, <base> will define $VERSION
223 in the base package, setting it to the string C<-1, set by base.pm>.
224
225 C<base> will also initialize the fields if one of the base classes has it.
226 Multiple inheritance of fields is B<NOT> supported, if two or more base classes
227 each have inheritable fields the 'base' pragma will croak. See L<fields>,
228 L<public> and L<protected> for a description of this feature.
229
230 The base class' C<import> method is B<not> called.
231
232
233 =head1 DIAGNOSTICS
234
235 =over 4
236
237 =item Base class package "%s" is empty.
238
239 base.pm was unable to require the base package, because it was not
240 found in your path.
241
242 =item Class 'Foo' tried to inherit from itself
243
244 Attempting to inherit from yourself generates a warning.
245
246     use Foo;
247     use base 'Foo';
248
249 =back
250
251 =head1 HISTORY
252
253 This module was introduced with Perl 5.004_04.
254
255 =head1 CAVEATS
256
257 Due to the limitations of the implementation, you must use
258 base I<before> you declare any of your own fields.
259
260
261 =head1 SEE ALSO
262
263 L<fields>
264
265 =cut