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
CommitLineData
dc6d0c4f
JH
1package base;
2
3use vars qw($VERSION);
33d611b9 4$VERSION = '2.02';
dc6d0c4f
JH
5
6# constant.pm is slow
7sub SUCCESS () { 1 }
8
9sub PUBLIC () { 2**0 }
10sub PRIVATE () { 2**1 }
11sub INHERITED () { 2**2 }
12sub PROTECTED () { 2**3 }
13
14
15my $Fattr = \%fields::attr;
16
17sub has_fields {
18 my($base) = shift;
19 my $fglob = ${"$base\::"}{FIELDS};
20 return $fglob && *$fglob{HASH};
21}
22
23sub has_version {
24 my($base) = shift;
25 my $vglob = ${$base.'::'}{VERSION};
26 return $vglob && *$vglob{SCALAR};
27}
28
29sub has_attr {
30 my($proto) = shift;
31 my($class) = ref $proto || $proto;
32 return exists $Fattr->{$class};
33}
34
35sub get_attr {
36 $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
37 return $Fattr->{$_[0]};
38}
39
40sub get_fields {
41 # Shut up a possible typo warning.
42 () = \%{$_[0].'::FIELDS'};
43
44 return \%{$_[0].'::FIELDS'};
45}
46
47sub 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
55sub 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);
81Base class package "$base" is empty.
82 (Perhaps you need to 'use' the module which defines that package first.)
83ERROR
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
120sub 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
1651;
166
167__END__
168
fb73857a
PP
169=head1 NAME
170
171base - Establish IS-A relationship with base class at compile time
172
173=head1 SYNOPSIS
174
175 package Baz;
fb73857a
PP
176 use base qw(Foo Bar);
177
178=head1 DESCRIPTION
179
180Roughly similar in effect to
181
182 BEGIN {
dc6d0c4f
JH
183 require Foo;
184 require Bar;
185 push @ISA, qw(Foo Bar);
fb73857a
PP
186 }
187
dc6d0c4f
JH
188Will also initialize the fields if one of the base classes has it.
189Multiple Inheritence of fields is B<NOT> supported, if two or more
190base classes each have inheritable fields the 'base' pragma will
191croak. See L<fields>, L<public> and L<protected> for a description of
192this feature.
f1192cee 193
bcbfb61f 194When strict 'vars' is in scope, I<base> also lets you assign to @ISA
f1192cee
GA
195without having to declare @ISA with the 'vars' pragma first.
196
b8bc843f 197If any of the base classes are not loaded yet, I<base> silently
bcbfb61f
RGS
198C<require>s them (but it won't call the C<import> method). Whether to
199C<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
201loading it, I<base> will define $VERSION in the base package, setting it to
202the string C<-1, set by base.pm>.
b8bc843f 203
dc6d0c4f 204
b8bc843f
A
205=head1 HISTORY
206
fb73857a
PP
207This module was introduced with Perl 5.004_04.
208
fb73857a 209
dc6d0c4f 210=head1 CAVEATS
fb73857a 211
dc6d0c4f
JH
212Due to the limitations of the pseudo-hash implementation, you must use
213base I<before> you declare any of your own fields.
17f410f9 214
fb73857a 215
dc6d0c4f 216=head1 SEE ALSO
fb73857a 217
dc6d0c4f 218L<fields>
fb73857a 219
dc6d0c4f 220=cut