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