10 sub PRIVATE () { 2**1 }
11 sub INHERITED () { 2**2 }
12 sub PROTECTED () { 2**3 }
15 my $Fattr = \%fields::attr;
19 my $fglob = ${"$base\::"}{FIELDS};
20 return $fglob && *$fglob{HASH};
25 my $vglob = ${$base.'::'}{VERSION};
26 return $vglob && *$vglob{SCALAR};
31 my($class) = ref $proto || $proto;
32 return exists $Fattr->{$class};
36 $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
37 return $Fattr->{$_[0]};
41 # Shut up a possible typo warning.
42 () = \%{$_[0].'::FIELDS'};
44 return \%{$_[0].'::FIELDS'};
48 my($base, $mask) = @_;
49 my $fields = \%{$base.'::FIELDS'};
50 return grep { ($Fattr->{$base}[$fields->{$_}] & $mask) == $mask}
58 return SUCCESS unless @_;
60 # List of base classes from which we will inherit %FIELDS.
63 my $inheritor = caller(0);
65 foreach my $base (@_) {
66 next if $inheritor->isa($base);
68 if (has_version($base)) {
69 ${$base.'::VERSION'} = '-1, set by base.pm'
70 unless defined ${$base.'::VERSION'};
73 local $SIG{__DIE__} = 'IGNORE';
75 # Only ignore "Can't locate" errors from our eval require.
76 # Other fatal errors (syntax etc) must be reported.
77 die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
78 unless (%{"$base\::"}) {
81 Base class package "$base" is empty.
82 (Perhaps you need to 'use' the module which defines that package first.)
86 ${$base.'::VERSION'} = "-1, set by base.pm"
87 unless defined ${$base.'::VERSION'};
89 push @{"$inheritor\::ISA"}, $base;
91 # A simple test like (defined %{"$base\::FIELDS"}) will
92 # sometimes produce typo warnings because it would create
93 # the hash if it was not present before.
95 # We don't just check to see if the base in question has %FIELDS
96 # defined, we also check to see if it has -inheritable- fields.
97 # Its perfectly alright to inherit from multiple classes that have
98 # %FIELDS as long as only one of them has fields to give.
99 if ( has_fields($base) || has_attr($base) ) {
100 # Check to see if there are fields to be inherited.
101 if ( show_fields($base, PUBLIC) or
102 show_fields($base, PROTECTED) ) {
103 # No multiple fields inheritence *suck*
106 Carp::croak("Can't multiply inherit %FIELDS");
108 $fields_base = $base;
114 if( defined $fields_base ) {
115 inherit_fields($inheritor, $fields_base);
121 my($derived, $base) = @_;
123 return SUCCESS unless $base;
125 my $battr = get_attr($base);
126 my $dattr = get_attr($derived);
127 my $dfields = get_fields($derived);
128 my $bfields = get_fields($base);
130 $dattr->[0] = @$battr;
132 if( keys %$dfields ) {
133 warn "$derived is inheriting from $base but already has its own ".
135 "This will cause problems with pseudo-hashes.\n".
136 "Be sure you use base BEFORE declaring fields\n";
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) {
145 if ($fno = $dfields->{$k} and $fno != $v) {
147 Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
150 if( $battr->[$v] & PRIVATE ) {
151 $dattr->[$v] = undef;
154 $dattr->[$v] = INHERITED | $battr->[$v];
156 # Derived fields must be kept in the same position as the
157 # base in order to make "static" typing work with psuedo-hashes.
158 # Alas, this kills multiple field inheritance.
171 base - Establish IS-A relationship with base class at compile time
176 use base qw(Foo Bar);
180 Roughly similar in effect to
185 push @ISA, qw(Foo Bar);
188 Will also initialize the fields if one of the base classes has it.
189 Multiple Inheritence of fields is B<NOT> supported, if two or more
190 base classes each have inheritable fields the 'base' pragma will
191 croak. See L<fields>, L<public> and L<protected> for a description of
194 When strict 'vars' is in scope, I<base> also lets you assign to @ISA
195 without having to declare @ISA with the 'vars' pragma first.
197 If any of the base classes are not loaded yet, I<base> silently
198 C<require>s them (but it won't call the C<import> method). Whether to
199 C<require> a base class package is determined by the absence of a global
200 $VERSION in the base package. If $VERSION is not detected even after
201 loading it, I<base> will define $VERSION in the base package, setting it to
202 the string C<-1, set by base.pm>.
207 This module was introduced with Perl 5.004_04.
212 Due to the limitations of the pseudo-hash implementation, you must use
213 base I<before> you declare any of your own fields.