1use 5.008;
2package base;
3
4use strict 'vars';
5our $VERSION = '2.27';
6$VERSION =~ tr/_//d;
7
8# simplest way to avoid indexing of the package: no package statement
9sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC }
10# instance is blessed array of coderefs to be removed from @INC at scope exit
11sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} }
12
13# constant.pm is slow
14sub SUCCESS () { 1 }
15
16sub PUBLIC     () { 2**0  }
17sub PRIVATE    () { 2**1  }
18sub INHERITED  () { 2**2  }
19sub PROTECTED  () { 2**3  }
20
21
22my $Fattr = \%fields::attr;
23
24sub has_fields {
25    my($base) = shift;
26    my $fglob = ${"$base\::"}{FIELDS};
27    return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 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
63if ($] < 5.008) {
64    *_module_to_filename = sub {
65        (my $fn = $_[0]) =~ s!::!/!g;
66        $fn .= '.pm';
67        return $fn;
68    }
69}
70else {
71    *_module_to_filename = sub {
72        (my $fn = $_[0]) =~ s!::!/!g;
73        $fn .= '.pm';
74        utf8::encode($fn);
75        return $fn;
76    }
77}
78
79
80sub import {
81    my $class = shift;
82
83    return SUCCESS unless @_;
84
85    # List of base classes from which we will inherit %FIELDS.
86    my $fields_base;
87
88    my $inheritor = caller(0);
89
90    my @bases;
91    foreach my $base (@_) {
92        if ( $inheritor eq $base ) {
93            warn "Class '$inheritor' tried to inherit from itself\n";
94        }
95
96        next if grep $_->isa($base), ($inheritor, @bases);
97
98        # Following blocks help isolate $SIG{__DIE__} and @INC changes
99        {
100            my $sigdie;
101            {
102                local $SIG{__DIE__};
103                my $fn = _module_to_filename($base);
104                my $dot_hidden;
105                eval {
106                    my $guard;
107                    if ($INC[-1] eq '.' && %{"$base\::"}) {
108                        # So:  the package already exists   => this an optional load
109                        # And: there is a dot at the end of @INC  => we want to hide it
110                        # However: we only want to hide it during our *own* require()
111                        # (i.e. without affecting nested require()s).
112                        # So we add a hook to @INC whose job is to hide the dot, but which
113                        # first checks checks the callstack depth, because within nested
114                        # require()s the callstack is deeper.
115                        # Since CORE::GLOBAL::require makes it unknowable in advance what
116                        # the exact relevant callstack depth will be, we have to record it
117                        # inside a hook. So we put another hook just for that at the front
118                        # of @INC, where it's guaranteed to run -- immediately.
119                        # The dot-hiding hook does its job by sitting directly in front of
120                        # the dot and removing itself from @INC when reached. This causes
121                        # the dot to move up one index in @INC, causing the loop inside
122                        # pp_require() to skip it.
123                        # Loaded coded may disturb this precise arrangement, but that's OK
124                        # because the hook is inert by that time. It is only active during
125                        # the top-level require(), when @INC is in our control. The only
126                        # possible gotcha is if other hooks already in @INC modify @INC in
127                        # some way during that initial require().
128                        # Note that this jiggery hookery works just fine recursively: if
129                        # a module loaded via base.pm uses base.pm itself, there will be
130                        # one pair of hooks in @INC per base::import call frame, but the
131                        # pairs from different nestings do not interfere with each other.
132                        my $lvl;
133                        unshift @INC,        sub { return if defined $lvl; 1 while defined caller ++$lvl; () };
134                        splice  @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () };
135                        $guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard';
136                    }
137                    require $fn
138                };
139                if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) {
140                    require Carp;
141                    Carp::croak(<<ERROR);
142Base class package "$base" is not empty but "$fn[0]" exists in the current directory.
143    To help avoid security issues, base.pm now refuses to load optional modules
144    from the current working directory when it is the last entry in \@INC.
145    If your software worked on previous versions of Perl, the best solution
146    is to use FindBin to detect the path properly and to add that path to
147    \@INC.  As a last resort, you can re-enable looking in the current working
148    directory by adding "use lib '.'" to your code.
149ERROR
150                }
151                # Only ignore "Can't locate" errors from our eval require.
152                # Other fatal errors (syntax etc) must be reported.
153                #
154                # changing the check here is fragile - if the check
155                # here isn't catching every error you want, you should
156                # probably be using parent.pm, which doesn't try to
157                # guess whether require is needed or failed,
158                # see [perl #118561]
159                die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s
160                          || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/;
161                unless (%{"$base\::"}) {
162                    require Carp;
163                    local $" = " ";
164                    Carp::croak(<<ERROR);
165Base class package "$base" is empty.
166    (Perhaps you need to 'use' the module which defines that package first,
167    or make that module available in \@INC (\@INC contains: @INC).
168ERROR
169                }
170                $sigdie = $SIG{__DIE__} || undef;
171            }
172            # Make sure a global $SIG{__DIE__} makes it out of the localization.
173            $SIG{__DIE__} = $sigdie if defined $sigdie;
174        }
175        push @bases, $base;
176
177        if ( has_fields($base) || has_attr($base) ) {
178            # No multiple fields inheritance *suck*
179            if ($fields_base) {
180                require Carp;
181                Carp::croak("Can't multiply inherit fields");
182            } else {
183                $fields_base = $base;
184            }
185        }
186    }
187    # Save this until the end so it's all or nothing if the above loop croaks.
188    push @{"$inheritor\::ISA"}, @bases;
189
190    if( defined $fields_base ) {
191        inherit_fields($inheritor, $fields_base);
192    }
193}
194
195
196sub inherit_fields {
197    my($derived, $base) = @_;
198
199    return SUCCESS unless $base;
200
201    my $battr = get_attr($base);
202    my $dattr = get_attr($derived);
203    my $dfields = get_fields($derived);
204    my $bfields = get_fields($base);
205
206    $dattr->[0] = @$battr;
207
208    if( keys %$dfields ) {
209        warn <<"END";
210$derived is inheriting from $base but already has its own fields!
211This will cause problems.  Be sure you use base BEFORE declaring fields.
212END
213
214    }
215
216    # Iterate through the base's fields adding all the non-private
217    # ones to the derived class.  Hang on to the original attribute
218    # (Public, Private, etc...) and add Inherited.
219    # This is all too complicated to do efficiently with add_fields().
220    while (my($k,$v) = each %$bfields) {
221        my $fno;
222        if ($fno = $dfields->{$k} and $fno != $v) {
223            require Carp;
224            Carp::croak ("Inherited fields can't override existing fields");
225        }
226
227        if( $battr->[$v] & PRIVATE ) {
228            $dattr->[$v] = PRIVATE | INHERITED;
229        }
230        else {
231            $dattr->[$v] = INHERITED | $battr->[$v];
232            $dfields->{$k} = $v;
233        }
234    }
235
236    foreach my $idx (1..$#{$battr}) {
237        next if defined $dattr->[$idx];
238        $dattr->[$idx] = $battr->[$idx] & INHERITED;
239    }
240}
241
242
2431;
244
245__END__
246
247=head1 NAME
248
249base - Establish an ISA relationship with base classes at compile time
250
251=head1 SYNOPSIS
252
253    package Baz;
254    use base qw(Foo Bar);
255
256=head1 DESCRIPTION
257
258Unless you are using the C<fields> pragma, consider this module discouraged
259in favor of the lighter-weight C<parent>.
260
261Allows you to both load one or more modules, while setting up inheritance from
262those modules at the same time.  Roughly similar in effect to
263
264    package Baz;
265    BEGIN {
266        require Foo;
267        require Bar;
268        push @ISA, qw(Foo Bar);
269    }
270
271When C<base> tries to C<require> a module, it will not die if it cannot find
272the module's file, but will die on any other error.  After all this, should
273your base class be empty, containing no symbols, C<base> will die. This is
274useful for inheriting from classes in the same file as yourself but where
275the filename does not match the base module name, like so:
276
277        # in Bar.pm
278        package Foo;
279        sub exclaim { "I can have such a thing?!" }
280
281        package Bar;
282        use base "Foo";
283
284There is no F<Foo.pm>, but because C<Foo> defines a symbol (the C<exclaim>
285subroutine), C<base> will not die when the C<require> fails to load F<Foo.pm>.
286
287C<base> will also initialize the fields if one of the base classes has it.
288Multiple inheritance of fields is B<NOT> supported, if two or more base classes
289each have inheritable fields the 'base' pragma will croak. See L<fields>
290for a description of this feature.
291
292The base class' C<import> method is B<not> called.
293
294
295=head1 DIAGNOSTICS
296
297=over 4
298
299=item Base class package "%s" is empty.
300
301base.pm was unable to require the base package, because it was not
302found in your path.
303
304=item Class 'Foo' tried to inherit from itself
305
306Attempting to inherit from yourself generates a warning.
307
308    package Foo;
309    use base 'Foo';
310
311=back
312
313=head1 HISTORY
314
315This module was introduced with Perl 5.004_04.
316
317=head1 CAVEATS
318
319Due to the limitations of the implementation, you must use
320base I<before> you declare any of your own fields.
321
322
323=head1 SEE ALSO
324
325L<fields>
326
327=cut
328