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