perl/lib/base.pm

package base;

use strict 'vars';
use vars qw($VERSION);
$VERSION = '2.07';

# constant.pm is slow
sub SUCCESS () { 1 }

sub PUBLIC     () { 2**0  }
sub PRIVATE    () { 2**1  }
sub INHERITED  () { 2**2  }
sub PROTECTED  () { 2**3  }


my $Fattr = \%fields::attr;

sub has_fields {
    my($base) = shift;
    my $fglob = ${"$base\::"}{FIELDS};
    return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
}

sub has_version {
    my($base) = shift;
    my $vglob = ${$base.'::'}{VERSION};
    return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
}

sub has_attr {
    my($proto) = shift;
    my($class) = ref $proto || $proto;
    return exists $Fattr->{$class};
}

sub get_attr {
    $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
    return $Fattr->{$_[0]};
}

if ($] < 5.009) {
    *get_fields = sub {
        # Shut up a possible typo warning.
        () = \%{$_[0].'::FIELDS'};
        my $f = \%{$_[0].'::FIELDS'};

        # should be centralized in fields? perhaps
        # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
        # is used here anyway, it doesn't matter.
        bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');

        return $f;
    }
}
else {
    *get_fields = sub {
        # Shut up a possible typo warning.
        () = \%{$_[0].'::FIELDS'};
        return \%{$_[0].'::FIELDS'};
    }
}

sub import {
    my $class = shift;

    return SUCCESS unless @_;

    # List of base classes from which we will inherit %FIELDS.
    my $fields_base;

    my $inheritor = caller(0);

    foreach my $base (@_) {
        next if $inheritor->isa($base);

        if (has_version($base)) {
            ${$base.'::VERSION'} = '-1, set by base.pm' 
              unless defined ${$base.'::VERSION'};
        }
        else {
            local $SIG{__DIE__};
            eval "require $base";
            # Only ignore "Can't locate" errors from our eval require.
            # Other fatal errors (syntax etc) must be reported.
            die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
            unless (%{"$base\::"}) {
                require Carp;
                Carp::croak(<<ERROR);
Base class package "$base" is empty.
    (Perhaps you need to 'use' the module which defines that package first.)
ERROR

            }
            ${$base.'::VERSION'} = "-1, set by base.pm"
              unless defined ${$base.'::VERSION'};
        }
        push @{"$inheritor\::ISA"}, $base;

        if ( has_fields($base) || has_attr($base) ) {
            # No multiple fields inheritence *suck*
            if ($fields_base) {
                require Carp;
                Carp::croak("Can't multiply inherit %FIELDS");
            } else {
                $fields_base = $base;
            }
        }
    }

    if( defined $fields_base ) {
        inherit_fields($inheritor, $fields_base);
    }
}


sub inherit_fields {
    my($derived, $base) = @_;

    return SUCCESS unless $base;

    my $battr = get_attr($base);
    my $dattr = get_attr($derived);
    my $dfields = get_fields($derived);
    my $bfields = get_fields($base);

    $dattr->[0] = @$battr;

    if( keys %$dfields ) {
        warn "$derived is inheriting from $base but already has its own ".
             "fields!\n".
             "This will cause problems.\n".
             "Be sure you use base BEFORE declaring fields\n";
    }

    # Iterate through the base's fields adding all the non-private
    # ones to the derived class.  Hang on to the original attribute
    # (Public, Private, etc...) and add Inherited.
    # This is all too complicated to do efficiently with add_fields().
    while (my($k,$v) = each %$bfields) {
        my $fno;
        if ($fno = $dfields->{$k} and $fno != $v) {
            require Carp;
            Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
        }

        if( $battr->[$v] & PRIVATE ) {
            $dattr->[$v] = PRIVATE | INHERITED;
        }
        else {
            $dattr->[$v] = INHERITED | $battr->[$v];
            $dfields->{$k} = $v;
        }
    }

    foreach my $idx (1..$#{$battr}) {
        next if defined $dattr->[$idx];
        $dattr->[$idx] = $battr->[$idx] & INHERITED;
    }
}


1;

__END__

=head1 NAME

base - Establish IS-A relationship with base classes at compile time

=head1 SYNOPSIS

    package Baz;
    use base qw(Foo Bar);

=head1 DESCRIPTION

Allows you to both load one or more modules, while setting up inheritance from
those modules at the same time.  Roughly similar in effect to

    package Baz;
    BEGIN {
        require Foo;
        require Bar;
        push @ISA, qw(Foo Bar);
    }

If any of the listed modules are not loaded yet, I<base> silently attempts to
C<require> them (and silently continues if the C<require> failed).  Whether to
C<require> a base class module is determined by the absence of a global variable
$VERSION in the base package.  If $VERSION is not detected even after loading
it, <base> will define $VERSION in the base package, setting it to the string
C<-1, set by base.pm>.

Will also initialize the fields if one of the base classes has it.
Multiple inheritence of fields is B<NOT> supported, if two or more
base classes each have inheritable fields the 'base' pragma will
croak.  See L<fields>, L<public> and L<protected> for a description of
this feature.

=head1 DIAGNOSTICS

=over 4

=item Base class package "%s" is empty.

base.pm was unable to require the base package, because it was not
found in your path.

=back

=head1 HISTORY

This module was introduced with Perl 5.004_04.


=head1 CAVEATS

Due to the limitations of the implementation, you must use
base I<before> you declare any of your own fields.


=head1 SEE ALSO

L<fields>

=cut
Revision:	1.1
Committed:	Thu Jun 30 14:27:08 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package base;
2
3			use strict 'vars';
4			use vars qw($VERSION);
5			$VERSION = '2.07';
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__};
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