1*0Sstevel@tonic-gatepackage base; 2*0Sstevel@tonic-gate 3*0Sstevel@tonic-gateuse strict 'vars'; 4*0Sstevel@tonic-gateuse vars qw($VERSION); 5*0Sstevel@tonic-gate$VERSION = '2.05'; 6*0Sstevel@tonic-gate 7*0Sstevel@tonic-gate# constant.pm is slow 8*0Sstevel@tonic-gatesub SUCCESS () { 1 } 9*0Sstevel@tonic-gate 10*0Sstevel@tonic-gatesub PUBLIC () { 2**0 } 11*0Sstevel@tonic-gatesub PRIVATE () { 2**1 } 12*0Sstevel@tonic-gatesub INHERITED () { 2**2 } 13*0Sstevel@tonic-gatesub PROTECTED () { 2**3 } 14*0Sstevel@tonic-gate 15*0Sstevel@tonic-gate 16*0Sstevel@tonic-gatemy $Fattr = \%fields::attr; 17*0Sstevel@tonic-gate 18*0Sstevel@tonic-gatesub has_fields { 19*0Sstevel@tonic-gate my($base) = shift; 20*0Sstevel@tonic-gate my $fglob = ${"$base\::"}{FIELDS}; 21*0Sstevel@tonic-gate return( ($fglob && *$fglob{HASH}) ? 1 : 0 ); 22*0Sstevel@tonic-gate} 23*0Sstevel@tonic-gate 24*0Sstevel@tonic-gatesub has_version { 25*0Sstevel@tonic-gate my($base) = shift; 26*0Sstevel@tonic-gate my $vglob = ${$base.'::'}{VERSION}; 27*0Sstevel@tonic-gate return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 ); 28*0Sstevel@tonic-gate} 29*0Sstevel@tonic-gate 30*0Sstevel@tonic-gatesub has_attr { 31*0Sstevel@tonic-gate my($proto) = shift; 32*0Sstevel@tonic-gate my($class) = ref $proto || $proto; 33*0Sstevel@tonic-gate return exists $Fattr->{$class}; 34*0Sstevel@tonic-gate} 35*0Sstevel@tonic-gate 36*0Sstevel@tonic-gatesub get_attr { 37*0Sstevel@tonic-gate $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; 38*0Sstevel@tonic-gate return $Fattr->{$_[0]}; 39*0Sstevel@tonic-gate} 40*0Sstevel@tonic-gate 41*0Sstevel@tonic-gateif ($] < 5.009) { 42*0Sstevel@tonic-gate *get_fields = sub { 43*0Sstevel@tonic-gate # Shut up a possible typo warning. 44*0Sstevel@tonic-gate () = \%{$_[0].'::FIELDS'}; 45*0Sstevel@tonic-gate my $f = \%{$_[0].'::FIELDS'}; 46*0Sstevel@tonic-gate 47*0Sstevel@tonic-gate # should be centralized in fields? perhaps 48*0Sstevel@tonic-gate # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' } 49*0Sstevel@tonic-gate # is used here anyway, it doesn't matter. 50*0Sstevel@tonic-gate bless $f, 'pseudohash' if (ref($f) ne 'pseudohash'); 51*0Sstevel@tonic-gate 52*0Sstevel@tonic-gate return $f; 53*0Sstevel@tonic-gate } 54*0Sstevel@tonic-gate} 55*0Sstevel@tonic-gateelse { 56*0Sstevel@tonic-gate *get_fields = sub { 57*0Sstevel@tonic-gate # Shut up a possible typo warning. 58*0Sstevel@tonic-gate () = \%{$_[0].'::FIELDS'}; 59*0Sstevel@tonic-gate return \%{$_[0].'::FIELDS'}; 60*0Sstevel@tonic-gate } 61*0Sstevel@tonic-gate} 62*0Sstevel@tonic-gate 63*0Sstevel@tonic-gatesub import { 64*0Sstevel@tonic-gate my $class = shift; 65*0Sstevel@tonic-gate 66*0Sstevel@tonic-gate return SUCCESS unless @_; 67*0Sstevel@tonic-gate 68*0Sstevel@tonic-gate # List of base classes from which we will inherit %FIELDS. 69*0Sstevel@tonic-gate my $fields_base; 70*0Sstevel@tonic-gate 71*0Sstevel@tonic-gate my $inheritor = caller(0); 72*0Sstevel@tonic-gate 73*0Sstevel@tonic-gate foreach my $base (@_) { 74*0Sstevel@tonic-gate next if $inheritor->isa($base); 75*0Sstevel@tonic-gate 76*0Sstevel@tonic-gate if (has_version($base)) { 77*0Sstevel@tonic-gate ${$base.'::VERSION'} = '-1, set by base.pm' 78*0Sstevel@tonic-gate unless defined ${$base.'::VERSION'}; 79*0Sstevel@tonic-gate } 80*0Sstevel@tonic-gate else { 81*0Sstevel@tonic-gate local $SIG{__DIE__} = 'IGNORE'; 82*0Sstevel@tonic-gate eval "require $base"; 83*0Sstevel@tonic-gate # Only ignore "Can't locate" errors from our eval require. 84*0Sstevel@tonic-gate # Other fatal errors (syntax etc) must be reported. 85*0Sstevel@tonic-gate die if $@ && $@ !~ /^Can't locate .*? at \(eval /; 86*0Sstevel@tonic-gate unless (%{"$base\::"}) { 87*0Sstevel@tonic-gate require Carp; 88*0Sstevel@tonic-gate Carp::croak(<<ERROR); 89*0Sstevel@tonic-gateBase class package "$base" is empty. 90*0Sstevel@tonic-gate (Perhaps you need to 'use' the module which defines that package first.) 91*0Sstevel@tonic-gateERROR 92*0Sstevel@tonic-gate 93*0Sstevel@tonic-gate } 94*0Sstevel@tonic-gate ${$base.'::VERSION'} = "-1, set by base.pm" 95*0Sstevel@tonic-gate unless defined ${$base.'::VERSION'}; 96*0Sstevel@tonic-gate } 97*0Sstevel@tonic-gate push @{"$inheritor\::ISA"}, $base; 98*0Sstevel@tonic-gate 99*0Sstevel@tonic-gate if ( has_fields($base) || has_attr($base) ) { 100*0Sstevel@tonic-gate # No multiple fields inheritence *suck* 101*0Sstevel@tonic-gate if ($fields_base) { 102*0Sstevel@tonic-gate require Carp; 103*0Sstevel@tonic-gate Carp::croak("Can't multiply inherit %FIELDS"); 104*0Sstevel@tonic-gate } else { 105*0Sstevel@tonic-gate $fields_base = $base; 106*0Sstevel@tonic-gate } 107*0Sstevel@tonic-gate } 108*0Sstevel@tonic-gate } 109*0Sstevel@tonic-gate 110*0Sstevel@tonic-gate if( defined $fields_base ) { 111*0Sstevel@tonic-gate inherit_fields($inheritor, $fields_base); 112*0Sstevel@tonic-gate } 113*0Sstevel@tonic-gate} 114*0Sstevel@tonic-gate 115*0Sstevel@tonic-gate 116*0Sstevel@tonic-gatesub inherit_fields { 117*0Sstevel@tonic-gate my($derived, $base) = @_; 118*0Sstevel@tonic-gate 119*0Sstevel@tonic-gate return SUCCESS unless $base; 120*0Sstevel@tonic-gate 121*0Sstevel@tonic-gate my $battr = get_attr($base); 122*0Sstevel@tonic-gate my $dattr = get_attr($derived); 123*0Sstevel@tonic-gate my $dfields = get_fields($derived); 124*0Sstevel@tonic-gate my $bfields = get_fields($base); 125*0Sstevel@tonic-gate 126*0Sstevel@tonic-gate $dattr->[0] = @$battr; 127*0Sstevel@tonic-gate 128*0Sstevel@tonic-gate if( keys %$dfields ) { 129*0Sstevel@tonic-gate warn "$derived is inheriting from $base but already has its own ". 130*0Sstevel@tonic-gate "fields!\n". 131*0Sstevel@tonic-gate "This will cause problems.\n". 132*0Sstevel@tonic-gate "Be sure you use base BEFORE declaring fields\n"; 133*0Sstevel@tonic-gate } 134*0Sstevel@tonic-gate 135*0Sstevel@tonic-gate # Iterate through the base's fields adding all the non-private 136*0Sstevel@tonic-gate # ones to the derived class. Hang on to the original attribute 137*0Sstevel@tonic-gate # (Public, Private, etc...) and add Inherited. 138*0Sstevel@tonic-gate # This is all too complicated to do efficiently with add_fields(). 139*0Sstevel@tonic-gate while (my($k,$v) = each %$bfields) { 140*0Sstevel@tonic-gate my $fno; 141*0Sstevel@tonic-gate if ($fno = $dfields->{$k} and $fno != $v) { 142*0Sstevel@tonic-gate require Carp; 143*0Sstevel@tonic-gate Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); 144*0Sstevel@tonic-gate } 145*0Sstevel@tonic-gate 146*0Sstevel@tonic-gate if( $battr->[$v] & PRIVATE ) { 147*0Sstevel@tonic-gate $dattr->[$v] = PRIVATE | INHERITED; 148*0Sstevel@tonic-gate } 149*0Sstevel@tonic-gate else { 150*0Sstevel@tonic-gate $dattr->[$v] = INHERITED | $battr->[$v]; 151*0Sstevel@tonic-gate $dfields->{$k} = $v; 152*0Sstevel@tonic-gate } 153*0Sstevel@tonic-gate } 154*0Sstevel@tonic-gate 155*0Sstevel@tonic-gate unless( keys %$bfields ) { 156*0Sstevel@tonic-gate foreach my $idx (1..$#{$battr}) { 157*0Sstevel@tonic-gate $dattr->[$idx] = $battr->[$idx] & INHERITED; 158*0Sstevel@tonic-gate } 159*0Sstevel@tonic-gate } 160*0Sstevel@tonic-gate} 161*0Sstevel@tonic-gate 162*0Sstevel@tonic-gate 163*0Sstevel@tonic-gate1; 164*0Sstevel@tonic-gate 165*0Sstevel@tonic-gate__END__ 166*0Sstevel@tonic-gate 167*0Sstevel@tonic-gate=head1 NAME 168*0Sstevel@tonic-gate 169*0Sstevel@tonic-gatebase - Establish IS-A relationship with base classes at compile time 170*0Sstevel@tonic-gate 171*0Sstevel@tonic-gate=head1 SYNOPSIS 172*0Sstevel@tonic-gate 173*0Sstevel@tonic-gate package Baz; 174*0Sstevel@tonic-gate use base qw(Foo Bar); 175*0Sstevel@tonic-gate 176*0Sstevel@tonic-gate=head1 DESCRIPTION 177*0Sstevel@tonic-gate 178*0Sstevel@tonic-gateAllows you to both load one or more modules, while setting up inheritance from 179*0Sstevel@tonic-gatethose modules at the same time. Roughly similar in effect to 180*0Sstevel@tonic-gate 181*0Sstevel@tonic-gate package Baz; 182*0Sstevel@tonic-gate BEGIN { 183*0Sstevel@tonic-gate require Foo; 184*0Sstevel@tonic-gate require Bar; 185*0Sstevel@tonic-gate push @ISA, qw(Foo Bar); 186*0Sstevel@tonic-gate } 187*0Sstevel@tonic-gate 188*0Sstevel@tonic-gateIf any of the listed modules are not loaded yet, I<base> silently attempts to 189*0Sstevel@tonic-gateC<require> them (and silently continues if the C<require> failed). Whether to 190*0Sstevel@tonic-gateC<require> a base class module is determined by the absence of a global variable 191*0Sstevel@tonic-gate$VERSION in the base package. If $VERSION is not detected even after loading 192*0Sstevel@tonic-gateit, <base> will define $VERSION in the base package, setting it to the string 193*0Sstevel@tonic-gateC<-1, set by base.pm>. 194*0Sstevel@tonic-gate 195*0Sstevel@tonic-gateWill also initialize the fields if one of the base classes has it. 196*0Sstevel@tonic-gateMultiple inheritence of fields is B<NOT> supported, if two or more 197*0Sstevel@tonic-gatebase classes each have inheritable fields the 'base' pragma will 198*0Sstevel@tonic-gatecroak. See L<fields>, L<public> and L<protected> for a description of 199*0Sstevel@tonic-gatethis feature. 200*0Sstevel@tonic-gate 201*0Sstevel@tonic-gate=head1 HISTORY 202*0Sstevel@tonic-gate 203*0Sstevel@tonic-gateThis module was introduced with Perl 5.004_04. 204*0Sstevel@tonic-gate 205*0Sstevel@tonic-gate 206*0Sstevel@tonic-gate=head1 CAVEATS 207*0Sstevel@tonic-gate 208*0Sstevel@tonic-gateDue to the limitations of the implementation, you must use 209*0Sstevel@tonic-gatebase I<before> you declare any of your own fields. 210*0Sstevel@tonic-gate 211*0Sstevel@tonic-gate 212*0Sstevel@tonic-gate=head1 SEE ALSO 213*0Sstevel@tonic-gate 214*0Sstevel@tonic-gateL<fields> 215*0Sstevel@tonic-gate 216*0Sstevel@tonic-gate=cut 217