This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to base 2.02.
[perl5.git] / lib / base.pm
1 package base;
2
3 use vars qw($VERSION);
4 $VERSION = '2.02';
5
6 # constant.pm is slow
7 sub SUCCESS () { 1 }
8
9 sub PUBLIC     () { 2**0  }
10 sub PRIVATE    () { 2**1  }
11 sub INHERITED  () { 2**2  }
12 sub PROTECTED  () { 2**3  }
13
14
15 my $Fattr = \%fields::attr;
16
17 sub has_fields {
18     my($base) = shift;
19     my $fglob = ${"$base\::"}{FIELDS};
20     return $fglob && *$fglob{HASH};
21 }
22
23 sub has_version {
24     my($base) = shift;
25     my $vglob = ${$base.'::'}{VERSION};
26     return $vglob && *$vglob{SCALAR};
27 }
28
29 sub has_attr {
30     my($proto) = shift;
31     my($class) = ref $proto || $proto;
32     return exists $Fattr->{$class};
33 }
34
35 sub get_attr {
36     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
37     return $Fattr->{$_[0]};
38 }
39
40 sub get_fields {
41     # Shut up a possible typo warning.
42     () = \%{$_[0].'::FIELDS'};
43
44     return \%{$_[0].'::FIELDS'};
45 }
46
47 sub show_fields {
48     my($base, $mask) = @_;
49     my $fields = \%{$base.'::FIELDS'};
50     return grep { ($Fattr->{$base}[$fields->{$_}] & $mask) == $mask} 
51                 keys %$fields;
52 }
53
54
55 sub import {
56     my $class = shift;
57
58     return SUCCESS unless @_;
59
60     # List of base classes from which we will inherit %FIELDS.
61     my $fields_base;
62
63     my $inheritor = caller(0);
64
65     foreach my $base (@_) {
66         next if $inheritor->isa($base);
67
68         if (has_version($base)) {
69             ${$base.'::VERSION'} = '-1, set by base.pm' 
70               unless defined ${$base.'::VERSION'};
71         }
72         else {
73             local $SIG{__DIE__} = 'IGNORE';
74             eval "require $base";
75             # Only ignore "Can't locate" errors from our eval require.
76             # Other fatal errors (syntax etc) must be reported.
77             die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
78             unless (%{"$base\::"}) {
79                 require Carp;
80                 Carp::croak(<<ERROR);
81 Base class package "$base" is empty.
82     (Perhaps you need to 'use' the module which defines that package first.)
83 ERROR
84
85             }
86             ${$base.'::VERSION'} = "-1, set by base.pm"
87               unless defined ${$base.'::VERSION'};
88         }
89         push @{"$inheritor\::ISA"}, $base;
90
91         # A simple test like (defined %{"$base\::FIELDS"}) will
92         # sometimes produce typo warnings because it would create
93         # the hash if it was not present before.
94         #
95         # We don't just check to see if the base in question has %FIELDS
96         # defined, we also check to see if it has -inheritable- fields.
97         # Its perfectly alright to inherit from multiple classes that have 
98         # %FIELDS as long as only one of them has fields to give.
99         if ( has_fields($base) || has_attr($base) ) {
100             # Check to see if there are fields to be inherited.
101             if ( show_fields($base, PUBLIC) or
102                  show_fields($base, PROTECTED) ) {
103                 # No multiple fields inheritence *suck*
104                 if ($fields_base) {
105                     require Carp;
106                     Carp::croak("Can't multiply inherit %FIELDS");
107                 } else {
108                     $fields_base = $base;
109                 }
110             }
111         }
112     }
113
114     if( defined $fields_base ) {
115         inherit_fields($inheritor, $fields_base);
116     }
117 }
118
119
120 sub inherit_fields {
121     my($derived, $base) = @_;
122
123     return SUCCESS unless $base;
124
125     my $battr = get_attr($base);
126     my $dattr = get_attr($derived);
127     my $dfields = get_fields($derived);
128     my $bfields = get_fields($base);
129
130     $dattr->[0] = @$battr;
131
132     if( keys %$dfields ) {
133         warn "$derived is inheriting from $base but already has its own ".
134              "fields!\n".
135              "This will cause problems with pseudo-hashes.\n".
136              "Be sure you use base BEFORE declaring fields\n";
137     }
138
139     # Iterate through the base's fields adding all the non-private
140     # ones to the derived class.  Hang on to the original attribute
141     # (Public, Private, etc...) and add Inherited.
142     # This is all too complicated to do efficiently with add_fields().
143     while (my($k,$v) = each %$bfields) {
144         my $fno;
145         if ($fno = $dfields->{$k} and $fno != $v) {
146             require Carp;
147             Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
148         }
149
150         if( $battr->[$v] & PRIVATE ) {
151             $dattr->[$v] = undef;
152         }
153         else {
154             $dattr->[$v] = INHERITED | $battr->[$v];
155
156             # Derived fields must be kept in the same position as the
157             # base in order to make "static" typing work with psuedo-hashes.
158             # Alas, this kills multiple field inheritance.
159             $dfields->{$k} = $v;
160         }
161     }
162 }
163
164
165 1;
166
167 __END__
168
169 =head1 NAME
170
171 base - Establish IS-A relationship with base class at compile time
172
173 =head1 SYNOPSIS
174
175     package Baz;
176     use base qw(Foo Bar);
177
178 =head1 DESCRIPTION
179
180 Roughly similar in effect to
181
182     BEGIN {
183         require Foo;
184         require Bar;
185         push @ISA, qw(Foo Bar);
186     }
187
188 Will also initialize the fields if one of the base classes has it.
189 Multiple Inheritence of fields is B<NOT> supported, if two or more
190 base classes each have inheritable fields the 'base' pragma will
191 croak.  See L<fields>, L<public> and L<protected> for a description of
192 this feature.
193
194 When strict 'vars' is in scope, I<base> also lets you assign to @ISA
195 without having to declare @ISA with the 'vars' pragma first.
196
197 If any of the base classes are not loaded yet, I<base> silently
198 C<require>s them (but it won't call the C<import> method).  Whether to
199 C<require> a base class package is determined by the absence of a global
200 $VERSION in the base package.  If $VERSION is not detected even after
201 loading it, I<base> will define $VERSION in the base package, setting it to
202 the string C<-1, set by base.pm>.
203
204
205 =head1 HISTORY
206
207 This module was introduced with Perl 5.004_04.
208
209
210 =head1 CAVEATS
211
212 Due to the limitations of the pseudo-hash implementation, you must use
213 base I<before> you declare any of your own fields.
214
215
216 =head1 SEE ALSO
217
218 L<fields>
219
220 =cut