This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: Doc patches for File::Find
[perl5.git] / lib / base.pm
CommitLineData
dc6d0c4f
JH
1package base;
2
864f8ab4 3use strict 'vars';
dc6d0c4f 4use vars qw($VERSION);
45e8908f 5$VERSION = '2.04';
dc6d0c4f
JH
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};
864f8ab4 21 return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
dc6d0c4f
JH
22}
23
24sub has_version {
25 my($base) = shift;
26 my $vglob = ${$base.'::'}{VERSION};
864f8ab4 27 return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
dc6d0c4f
JH
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
41sub get_fields {
42 # Shut up a possible typo warning.
43 () = \%{$_[0].'::FIELDS'};
44
45 return \%{$_[0].'::FIELDS'};
46}
47
dc6d0c4f
JH
48sub 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);
74Base class package "$base" is empty.
75 (Perhaps you need to 'use' the module which defines that package first.)
76ERROR
77
78 }
79 ${$base.'::VERSION'} = "-1, set by base.pm"
80 unless defined ${$base.'::VERSION'};
81 }
82 push @{"$inheritor\::ISA"}, $base;
83
dc6d0c4f 84 if ( has_fields($base) || has_attr($base) ) {
864f8ab4
JH
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;
dc6d0c4f
JH
91 }
92 }
93 }
94
95 if( defined $fields_base ) {
96 inherit_fields($inheritor, $fields_base);
97 }
98}
99
100
101sub 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".
45e8908f 116 "This will cause problems.\n".
dc6d0c4f
JH
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 ) {
864f8ab4 132 $dattr->[$v] = PRIVATE | INHERITED;
dc6d0c4f
JH
133 }
134 else {
135 $dattr->[$v] = INHERITED | $battr->[$v];
dc6d0c4f
JH
136 $dfields->{$k} = $v;
137 }
138 }
864f8ab4
JH
139
140 unless( keys %$bfields ) {
141 foreach my $idx (1..$#{$battr}) {
142 $dattr->[$idx] = $battr->[$idx] & INHERITED;
143 }
144 }
dc6d0c4f
JH
145}
146
147
1481;
149
150__END__
151
fb73857a
PP
152=head1 NAME
153
45e8908f 154base - Establish IS-A relationship with base classes at compile time
fb73857a
PP
155
156=head1 SYNOPSIS
157
158 package Baz;
fb73857a
PP
159 use base qw(Foo Bar);
160
161=head1 DESCRIPTION
162
45e8908f
EM
163Allows you to both load one or more modules, while setting up inheritance from
164those modules at the same time. Roughly similar in effect to
fb73857a 165
45e8908f 166 package Baz;
fb73857a 167 BEGIN {
dc6d0c4f
JH
168 require Foo;
169 require Bar;
170 push @ISA, qw(Foo Bar);
fb73857a
PP
171 }
172
45e8908f
EM
173If any of the listed modules are not loaded yet, I<base> silently attempts to
174C<require> them (and silently continues if the C<require> failed). Whether to
175C<require> a base class module is determined by the absence of a global variable
176$VERSION in the base package. If $VERSION is not detected even after loading
177it, <base> will define $VERSION in the base package, setting it to the string
178C<-1, set by base.pm>.
179
dc6d0c4f 180Will also initialize the fields if one of the base classes has it.
45e8908f 181Multiple inheritence of fields is B<NOT> supported, if two or more
dc6d0c4f
JH
182base classes each have inheritable fields the 'base' pragma will
183croak. See L<fields>, L<public> and L<protected> for a description of
184this feature.
f1192cee 185
b8bc843f
A
186=head1 HISTORY
187
fb73857a
PP
188This module was introduced with Perl 5.004_04.
189
fb73857a 190
dc6d0c4f 191=head1 CAVEATS
fb73857a 192
45e8908f 193Due to the limitations of the implementation, you must use
dc6d0c4f 194base I<before> you declare any of your own fields.
17f410f9 195
fb73857a 196
dc6d0c4f 197=head1 SEE ALSO
fb73857a 198
dc6d0c4f 199L<fields>
fb73857a 200
dc6d0c4f 201=cut