1package base;
2
3use strict 'vars';
4use vars qw($VERSION);
5$VERSION = '2.07';
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};
21    return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
22}
23
24sub has_version {
25    my($base) = shift;
26    my $vglob = ${$base.'::'}{VERSION};
27    return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
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
41if ($] < 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}
55else {
56    *get_fields = sub {
57	# Shut up a possible typo warning.
58	() = \%{$_[0].'::FIELDS'};
59	return \%{$_[0].'::FIELDS'};
60    }
61}
62
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__};
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
99        if ( has_fields($base) || has_attr($base) ) {
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;
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".
131             "This will cause problems.\n".
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 ) {
147            $dattr->[$v] = PRIVATE | INHERITED;
148        }
149        else {
150            $dattr->[$v] = INHERITED | $battr->[$v];
151            $dfields->{$k} = $v;
152        }
153    }
154
155    foreach my $idx (1..$#{$battr}) {
156	next if defined $dattr->[$idx];
157	$dattr->[$idx] = $battr->[$idx] & INHERITED;
158    }
159}
160
161
1621;
163
164__END__
165
166=head1 NAME
167
168base - Establish IS-A relationship with base classes at compile time
169
170=head1 SYNOPSIS
171
172    package Baz;
173    use base qw(Foo Bar);
174
175=head1 DESCRIPTION
176
177Allows you to both load one or more modules, while setting up inheritance from
178those modules at the same time.  Roughly similar in effect to
179
180    package Baz;
181    BEGIN {
182        require Foo;
183        require Bar;
184        push @ISA, qw(Foo Bar);
185    }
186
187If any of the listed modules are not loaded yet, I<base> silently attempts to
188C<require> them (and silently continues if the C<require> failed).  Whether to
189C<require> a base class module is determined by the absence of a global variable
190$VERSION in the base package.  If $VERSION is not detected even after loading
191it, <base> will define $VERSION in the base package, setting it to the string
192C<-1, set by base.pm>.
193
194Will also initialize the fields if one of the base classes has it.
195Multiple inheritence of fields is B<NOT> supported, if two or more
196base classes each have inheritable fields the 'base' pragma will
197croak.  See L<fields>, L<public> and L<protected> for a description of
198this feature.
199
200=head1 DIAGNOSTICS
201
202=over 4
203
204=item Base class package "%s" is empty.
205
206base.pm was unable to require the base package, because it was not
207found in your path.
208
209=back
210
211=head1 HISTORY
212
213This module was introduced with Perl 5.004_04.
214
215
216=head1 CAVEATS
217
218Due to the limitations of the implementation, you must use
219base I<before> you declare any of your own fields.
220
221
222=head1 SEE ALSO
223
224L<fields>
225
226=cut
227