extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / lib / base.pm
1 package base;
2
3 use strict 'vars';
4 use vars qw($VERSION);
5 $VERSION = '2.06';
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         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__} = 'IGNORE';
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);
89 Base class package "$base" is empty.
90     (Perhaps you need to 'use' the module which defines that package first.)
91 ERROR
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
116 sub 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
162 1;
163
164 __END__
165
166 =head1 NAME
167
168 base - 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
177 Allows you to both load one or more modules, while setting up inheritance from
178 those 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
187 If any of the listed modules are not loaded yet, I<base> silently attempts to
188 C<require> them (and silently continues if the C<require> failed).  Whether to
189 C<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
191 it, <base> will define $VERSION in the base package, setting it to the string
192 C<-1, set by base.pm>.
193
194 Will also initialize the fields if one of the base classes has it.
195 Multiple inheritence of fields is B<NOT> supported, if two or more
196 base classes each have inheritable fields the 'base' pragma will
197 croak.  See L<fields>, L<public> and L<protected> for a description of
198 this feature.
199
200 =head1 DIAGNOSTICS
201
202 =over 4
203
204 =item Base class package "%s" is empty.
205
206 base.pm was unable to require the base package, because it was not
207 found in your path.
208
209 =back
210
211 =head1 HISTORY
212
213 This module was introduced with Perl 5.004_04.
214
215
216 =head1 CAVEATS
217
218 Due to the limitations of the implementation, you must use
219 base I<before> you declare any of your own fields.
220
221
222 =head1 SEE ALSO
223
224 L<fields>
225
226 =cut