package base; use strict 'vars'; use vars qw($VERSION); $VERSION = '2.04'; # 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]}; } sub get_fields { # 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__} = 'IGNORE'; 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(<[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; } } unless( keys %$bfields ) { foreach my $idx (1..$#{$battr}) { $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 silently attempts to C them (and silently continues if the C failed). Whether to C 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, 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 supported, if two or more base classes each have inheritable fields the 'base' pragma will croak. See L, L and L for a description of this feature. =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 you declare any of your own fields. =head1 SEE ALSO L =cut