This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3177488eac0e0e44bc04bd9c3ec1aa52dc47bcca
[perl5.git] / lib / base.pm
1 package base;
2
3 use strict 'vars';
4 use vars qw($VERSION);
5 $VERSION = '2.03';
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 sub get_fields {
42     # Shut up a possible typo warning.
43     () = \%{$_[0].'::FIELDS'};
44
45     return \%{$_[0].'::FIELDS'};
46 }
47
48 sub import {
49     my $class = shift;
50
51     return SUCCESS unless @_;
52
53     # List of base classes from which we will inherit %FIELDS.
54     my $fields_base;
55
56     my $inheritor = caller(0);
57
58     foreach my $base (@_) {
59         next if $inheritor->isa($base);
60
61         if (has_version($base)) {
62             ${$base.'::VERSION'} = '-1, set by base.pm' 
63               unless defined ${$base.'::VERSION'};
64         }
65         else {
66             local $SIG{__DIE__} = 'IGNORE';
67             eval "require $base";
68             # Only ignore "Can't locate" errors from our eval require.
69             # Other fatal errors (syntax etc) must be reported.
70             die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
71             unless (%{"$base\::"}) {
72                 require Carp;
73                 Carp::croak(<<ERROR);
74 Base class package "$base" is empty.
75     (Perhaps you need to 'use' the module which defines that package first.)
76 ERROR
77
78             }
79             ${$base.'::VERSION'} = "-1, set by base.pm"
80               unless defined ${$base.'::VERSION'};
81         }
82         push @{"$inheritor\::ISA"}, $base;
83
84         if ( has_fields($base) || has_attr($base) ) {
85             # No multiple fields inheritence *suck*
86             if ($fields_base) {
87                 require Carp;
88                 Carp::croak("Can't multiply inherit %FIELDS");
89             } else {
90                 $fields_base = $base;
91             }
92         }
93     }
94
95     if( defined $fields_base ) {
96         inherit_fields($inheritor, $fields_base);
97     }
98 }
99
100
101 sub inherit_fields {
102     my($derived, $base) = @_;
103
104     return SUCCESS unless $base;
105
106     my $battr = get_attr($base);
107     my $dattr = get_attr($derived);
108     my $dfields = get_fields($derived);
109     my $bfields = get_fields($base);
110
111     $dattr->[0] = @$battr;
112
113     if( keys %$dfields ) {
114         warn "$derived is inheriting from $base but already has its own ".
115              "fields!\n".
116              "This will cause problems with pseudo-hashes.\n".
117              "Be sure you use base BEFORE declaring fields\n";
118     }
119
120     # Iterate through the base's fields adding all the non-private
121     # ones to the derived class.  Hang on to the original attribute
122     # (Public, Private, etc...) and add Inherited.
123     # This is all too complicated to do efficiently with add_fields().
124     while (my($k,$v) = each %$bfields) {
125         my $fno;
126         if ($fno = $dfields->{$k} and $fno != $v) {
127             require Carp;
128             Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
129         }
130
131         if( $battr->[$v] & PRIVATE ) {
132             $dattr->[$v] = PRIVATE | INHERITED;
133         }
134         else {
135             $dattr->[$v] = INHERITED | $battr->[$v];
136             $dfields->{$k} = $v;
137         }
138     }
139
140     unless( keys %$bfields ) {
141         foreach my $idx (1..$#{$battr}) {
142             $dattr->[$idx] = $battr->[$idx] & INHERITED;
143         }
144     }
145 }
146
147
148 1;
149
150 __END__
151
152 =head1 NAME
153
154 base - Establish IS-A relationship with base class at compile time
155
156 =head1 SYNOPSIS
157
158     package Baz;
159     use base qw(Foo Bar);
160
161 =head1 DESCRIPTION
162
163 Roughly similar in effect to
164
165     BEGIN {
166         require Foo;
167         require Bar;
168         push @ISA, qw(Foo Bar);
169     }
170
171 Will also initialize the fields if one of the base classes has it.
172 Multiple Inheritence of fields is B<NOT> supported, if two or more
173 base classes each have inheritable fields the 'base' pragma will
174 croak.  See L<fields>, L<public> and L<protected> for a description of
175 this feature.
176
177 When strict 'vars' is in scope, I<base> also lets you assign to @ISA
178 without having to declare @ISA with the 'vars' pragma first.
179
180 If any of the base classes are not loaded yet, I<base> silently
181 C<require>s them (but it won't call the C<import> method).  Whether to
182 C<require> a base class package is determined by the absence of a global
183 $VERSION in the base package.  If $VERSION is not detected even after
184 loading it, I<base> will define $VERSION in the base package, setting it to
185 the string C<-1, set by base.pm>.
186
187
188 =head1 HISTORY
189
190 This module was introduced with Perl 5.004_04.
191
192
193 =head1 CAVEATS
194
195 Due to the limitations of the pseudo-hash implementation, you must use
196 base I<before> you declare any of your own fields.
197
198
199 =head1 SEE ALSO
200
201 L<fields>
202
203 =cut