X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fbase.pm;h=3177488eac0e0e44bc04bd9c3ec1aa52dc47bcca;hb=2c227d667bcf910e7fef2feea02fec7046f3cb13;hp=681e8f03e8d67b9bd2ea7939f25702652f4d5519;hpb=7668bf4dc1ed94a756f3bd5e7cb95caf14c88e1f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/base.pm b/lib/base.pm index 681e8f0..3177488 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -1,3 +1,154 @@ +package base; + +use strict 'vars'; +use vars qw($VERSION); +$VERSION = '2.03'; + +# 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 with pseudo-hashes.\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 class at compile time @@ -12,82 +163,41 @@ base - Establish IS-A relationship with base class at compile time Roughly similar in effect to BEGIN { - require Foo; - require Bar; - push @ISA, qw(Foo Bar); + require Foo; + require Bar; + push @ISA, qw(Foo Bar); } -Will also initialize the %FIELDS hash if one of the base classes has -it. Multiple inheritance of %FIELDS is not supported. The 'base' -pragma will croak if multiple base classes have a %FIELDS hash. See -L for a description of this feature. +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. -When strict 'vars' is in scope I also let you assign to @ISA +When strict 'vars' is in scope, I also lets you assign to @ISA without having to declare @ISA with the 'vars' pragma first. If any of the base classes are not loaded yet, I silently -Cs them. Whether to C a base class package is -determined by the absence of a global $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>. +Cs them (but it won't call the C method). Whether to +C a base class package is determined by the absence of a global +$VERSION in the base package. If $VERSION is not detected even after +loading it, I will define $VERSION in the base package, setting it to +the string C<-1, set by base.pm>. + =head1 HISTORY This module was introduced with Perl 5.004_04. -=head1 SEE ALSO - -L -=cut +=head1 CAVEATS -package base; +Due to the limitations of the pseudo-hash implementation, you must use +base I you declare any of your own fields. -use 5.005_64; -our $VERSION = "1.01"; -sub import { - my $class = shift; - my $fields_base; - my $pkg = caller(0); - - foreach my $base (@_) { - next if $pkg->isa($base); - push @{"$pkg\::ISA"}, $base; - my $vglob; - unless (${*{"$base\::VERSION"}{SCALAR}}) { - 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("Base class package \"$base\" is empty.\n", - "\t(Perhaps you need to 'use' the module ", - "which defines that package first.)"); - } - ${"$base\::VERSION"} = "-1, set by base.pm" - unless ${*{"$base\::VERSION"}{SCALAR}}; - } +=head1 SEE ALSO - # A simple test like (defined %{"$base\::FIELDS"}) will - # sometimes produce typo warnings because it would create - # the hash if it was not present before. - my $fglob; - if ($fglob = ${"$base\::"}{"FIELDS"} and *$fglob{HASH}) { - if ($fields_base) { - require Carp; - Carp::croak("Can't multiply inherit %FIELDS"); - } else { - $fields_base = $base; - } - } - } - if ($fields_base) { - require fields; - fields::inherit($pkg, $fields_base); - } -} +L -1; +=cut