This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add diagnostics section to base.pm
[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
JH
154
155 unless( keys %$bfields ) {
156 foreach my $idx (1..$#{$battr}) {
157 $dattr->[$idx] = $battr->[$idx] & INHERITED;
158 }
159 }
dc6d0c4f
JH
160}
161
162
1631;
164
165__END__
166
fb73857a
PP
167=head1 NAME
168
45e8908f 169base - Establish IS-A relationship with base classes at compile time
fb73857a
PP
170
171=head1 SYNOPSIS
172
173 package Baz;
fb73857a
PP
174 use base qw(Foo Bar);
175
176=head1 DESCRIPTION
177
45e8908f
EM
178Allows you to both load one or more modules, while setting up inheritance from
179those modules at the same time. Roughly similar in effect to
fb73857a 180
45e8908f 181 package Baz;
fb73857a 182 BEGIN {
dc6d0c4f
JH
183 require Foo;
184 require Bar;
185 push @ISA, qw(Foo Bar);
fb73857a
PP
186 }
187
45e8908f
EM
188If any of the listed modules are not loaded yet, I<base> silently attempts to
189C<require> them (and silently continues if the C<require> failed). Whether to
190C<require> a base class module is determined by the absence of a global variable
191$VERSION in the base package. If $VERSION is not detected even after loading
192it, <base> will define $VERSION in the base package, setting it to the string
193C<-1, set by base.pm>.
194
dc6d0c4f 195Will also initialize the fields if one of the base classes has it.
45e8908f 196Multiple inheritence of fields is B<NOT> supported, if two or more
dc6d0c4f
JH
197base classes each have inheritable fields the 'base' pragma will
198croak. See L<fields>, L<public> and L<protected> for a description of
199this feature.
f1192cee 200
36c726b3
JB
201=head1 DIAGNOSTICS
202
203=over 4
204
205=item Base class package "%s" is empty.
206
207base.pm was unable to require the base package, because it was not
208found in your path.
209
210=back
211
b8bc843f
A
212=head1 HISTORY
213
fb73857a
PP
214This module was introduced with Perl 5.004_04.
215
fb73857a 216
dc6d0c4f 217=head1 CAVEATS
fb73857a 218
45e8908f 219Due to the limitations of the implementation, you must use
dc6d0c4f 220base I<before> you declare any of your own fields.
17f410f9 221
fb73857a 222
dc6d0c4f 223=head1 SEE ALSO
fb73857a 224
dc6d0c4f 225L<fields>
fb73857a 226
dc6d0c4f 227=cut