This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
base.pm
[perl5.git] / lib / base.pm
1 package base;
2
3 use strict 'vars';
4 use vars qw($VERSION);
5 $VERSION = '2.08';
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 && *$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             local $SIG{__DIE__};
86             eval "require $base";
87             # Only ignore "Can't locate" errors from our eval require.
88             # Other fatal errors (syntax etc) must be reported.
89             die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
90             unless (%{"$base\::"}) {
91                 require Carp;
92                 Carp::croak(<<ERROR);
93 Base class package "$base" is empty.
94     (Perhaps you need to 'use' the module which defines that package first.)
95 ERROR
96
97             }
98             ${$base.'::VERSION'} = "-1, set by base.pm"
99               unless defined ${$base.'::VERSION'};
100         }
101         push @{"$inheritor\::ISA"}, $base;
102
103         if ( has_fields($base) || has_attr($base) ) {
104             # No multiple fields inheritance *suck*
105             if ($fields_base) {
106                 require Carp;
107                 Carp::croak("Can't multiply inherit %FIELDS");
108             } else {
109                 $fields_base = $base;
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.\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] = PRIVATE | INHERITED;
152         }
153         else {
154             $dattr->[$v] = INHERITED | $battr->[$v];
155             $dfields->{$k} = $v;
156         }
157     }
158
159     foreach my $idx (1..$#{$battr}) {
160         next if defined $dattr->[$idx];
161         $dattr->[$idx] = $battr->[$idx] & INHERITED;
162     }
163 }
164
165
166 1;
167
168 __END__
169
170 =head1 NAME
171
172 base - Establish IS-A relationship with base classes at compile time
173
174 =head1 SYNOPSIS
175
176     package Baz;
177     use base qw(Foo Bar);
178
179 =head1 DESCRIPTION
180
181 Allows you to both load one or more modules, while setting up inheritance from
182 those modules at the same time.  Roughly similar in effect to
183
184     package Baz;
185     BEGIN {
186         require Foo;
187         require Bar;
188         push @ISA, qw(Foo Bar);
189     }
190
191 If any of the listed modules are not loaded yet, I<base> silently attempts to
192 C<require> them (and silently continues if the C<require> failed).  Whether to
193 C<require> a base class module is determined by the absence of a global variable
194 $VERSION in the base package.  If $VERSION is not detected even after loading
195 it, <base> will define $VERSION in the base package, setting it to the string
196 C<-1, set by base.pm>.
197
198 Will also initialize the fields if one of the base classes has it.
199 Multiple inheritance of fields is B<NOT> supported, if two or more
200 base classes each have inheritable fields the 'base' pragma will
201 croak.  See L<fields>, L<public> and L<protected> for a description of
202 this feature.
203
204 =head1 DIAGNOSTICS
205
206 =over 4
207
208 =item Base class package "%s" is empty.
209
210 base.pm was unable to require the base package, because it was not
211 found in your path.
212
213 =back
214
215 =head1 HISTORY
216
217 This module was introduced with Perl 5.004_04.
218
219 Attempting to inherit from yourself generates a warning:
220
221  use Foo;
222  use base 'Foo';
223
224  # Class 'Foo' tried to inherit from itself
225
226 =head1 CAVEATS
227
228 Due to the limitations of the implementation, you must use
229 base I<before> you declare any of your own fields.
230
231
232 =head1 SEE ALSO
233
234 L<fields>
235
236 =cut