+package base;
+
+use vars qw($VERSION);
+$VERSION = '2.01';
+
+# 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};
+}
+
+sub has_version {
+ my($base) = shift;
+ my $vglob = ${$base.'::'}{VERSION};
+ return $vglob && *$vglob{SCALAR};
+}
+
+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 show_fields {
+ my($base, $mask) = @_;
+ my $fields = \%{$base.'::FIELDS'};
+ return grep { ($Fattr->{$base}[$fields->{$_}] & $mask) == $mask}
+ keys %$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(<<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;
+
+ # A simple test like (defined %{"$base\::FIELDS"}) will
+ # sometimes produce typo warnings because it would create
+ # the hash if it was not present before.
+ #
+ # We don't just check to see if the base in question has %FIELDS
+ # defined, we also check to see if it has -inheritable- fields.
+ # Its perfectly alright to inherit from multiple classes that have
+ # %FIELDS as long as only one of them has fields to give.
+ if ( has_fields($base) || has_attr($base) ) {
+ # Check to see if there are fields to be inherited.
+ if ( show_fields($base, PUBLIC) or
+ show_fields($base, PROTECTED) ) {
+ # 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 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] = undef;
+ }
+ else {
+ $dattr->[$v] = INHERITED | $battr->[$v];
+
+ # Derived fields must be kept in the same position as the
+ # base in order to make "static" typing work with psuedo-hashes.
+ # Alas, this kills multiple field inheritance.
+ $dfields->{$k} = $v;
+ }
+ }
+}
+
+
+1;
+
+__END__
+
=head1 NAME
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<fields> 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<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.
When strict 'vars' is in scope, I<base> also lets you assign to @ISA
without having to declare @ISA with the 'vars' pragma first.
loading it, I<base> 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<fields>
-=cut
+=head1 CAVEATS
-package base;
+Due to the limitations of the pseudo-hash implementation, you must use
+base I<before> you declare any of your own fields.
-use 5.006_001;
-our $VERSION = "1.04";
-sub import {
- my $class = shift;
- my $fields_base;
- my $pkg = caller(0);
+=head1 SEE ALSO
- foreach my $base (@_) {
- next if $pkg->isa($base);
- my $vglob;
- if ($vglob = ${"$base\::"}{VERSION} and *$vglob{SCALAR}) {
- $$vglob = "-1, set by base.pm" unless defined $$vglob;
- } else {
- 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 defined ${"$base\::VERSION"};
- }
- push @{"$pkg\::ISA"}, $base;
-
- # 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<fields>
-1;
+=cut
package fields;
-=head1 NAME
-
-fields - compile-time class fields
-
-=head1 SYNOPSIS
-
- {
- package Foo;
- use fields qw(foo bar _Foo_private);
- sub new {
- my Foo $self = shift;
- unless (ref $self) {
- $self = fields::new($self);
- $self->{_Foo_private} = "this is Foo's secret";
- }
- $self->{foo} = 10;
- $self->{bar} = 20;
- return $self;
- }
- }
-
- my $var = Foo->new;
- $var->{foo} = 42;
-
- # this will generate an error
- $var->{zap} = 42;
-
- # subclassing
- {
- package Bar;
- use base 'Foo';
- use fields qw(baz _Bar_private); # not shared with Foo
- sub new {
- my $class = shift;
- my $self = fields::new($class);
- $self->SUPER::new(); # init base fields
- $self->{baz} = 10; # init own fields
- $self->{_Bar_private} = "this is Bar's secret";
- return $self;
- }
- }
-
-=head1 DESCRIPTION
-
-The C<fields> pragma enables compile-time verified class fields.
-
-NOTE: The current implementation keeps the declared fields in the %FIELDS
-hash of the calling package, but this may change in future versions.
-Do B<not> update the %FIELDS hash directly, because it must be created
-at compile-time for it to be fully useful, as is done by this pragma.
-
-The related C<base> pragma will combine fields from base classes and any
-fields declared using the C<fields> pragma. This enables field
-inheritance to work properly.
-
-Field names that start with an underscore character are made private to
-the class and are not visible to subclasses. Inherited fields can be
-overridden but will generate a warning if used together with the C<-w>
-switch.
-
-The following functions are supported:
-
-=over 8
-
-=item new
-
-fields::new() creates and blesses a restricted-hash comprised of the
-fields declared using the C<fields> pragma into the specified class.
-This makes it possible to write a constructor like this:
-
- package Critter::Sounds;
- use fields qw(cat dog bird);
-
- sub new {
- my $self = shift;
- $self = fields::new($self) unless ref $self;
- $self->{cat} = 'meow'; # scalar element
- @$self{'dog','bird'} = ('bark','tweet'); # slice
- return $self;
- }
-
-=item phash
-
-Pseudo-hashes have been removed from Perl as of 5.10. Consider using
-restricted hashes instead. Using fields::phash() will cause an error.
-
-=back
-
-=head1 SEE ALSO
-
-L<base>,
-
-=cut
-
-use 5.006_001;
+require 5.005;
use strict;
no strict 'refs';
-use warnings::register;
-our(%attr, $VERSION);
+unless( eval q{require warnings::register; warnings::register->import} ) {
+ *warnings::warnif = sub {
+ require Carp;
+ Carp::carp(@_);
+ }
+}
+use vars qw(%attr $VERSION);
-$VERSION = "1.04";
+$VERSION = '2.0';
-use Hash::Util qw(lock_keys);
+# constant.pm is slow
+sub PUBLIC () { 2**0 }
+sub PRIVATE () { 2**1 }
+sub INHERITED () { 2**2 }
+sub PROTECTED () { 2**3 }
-# some constants
-sub _PUBLIC () { 1 }
-sub _PRIVATE () { 2 }
# The %attr hash holds the attributes of the currently assigned fields
# per class. The hash is indexed by class names and the hash value is
if ($fno and $fno != $next) {
require Carp;
if ($fno < $fattr->[0]) {
+ if ($] < 5.006001) {
+ warn("Hides field '$f' in base class") if $^W;
+ } else {
warnings::warnif("Hides field '$f' in base class") ;
+ }
} else {
Carp::croak("Field name '$f' already in use");
}
}
$fields->{$f} = $next;
- $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC;
+ $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
$next += 1;
}
if (@$fattr > $next) {
}
}
-sub inherit { # called by base.pm when $base_fields is nonempty
- my($derived, $base) = @_;
- my $base_attr = $attr{$base};
- my $derived_attr = $attr{$derived} ||= [];
- # avoid possible typo warnings
- %{"$base\::FIELDS"} = () unless %{"$base\::FIELDS"};
- %{"$derived\::FIELDS"} = () unless %{"$derived\::FIELDS"};
- my $base_fields = \%{"$base\::FIELDS"};
- my $derived_fields = \%{"$derived\::FIELDS"};
-
- $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1;
- while (my($k,$v) = each %$base_fields) {
- my($fno);
- if ($fno = $derived_fields->{$k} and $fno != $v) {
- require Carp;
- Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
- }
- if ($base_attr->[$v] & _PRIVATE) {
- $derived_attr->[$v] = undef;
- } else {
- $derived_attr->[$v] = $base_attr->[$v];
- $derived_fields->{$k} = $v;
- }
- }
+sub inherit {
+ require base;
+ goto &base::inherit_fields;
}
sub _dump # sometimes useful for debugging
my $fattr = $attr{$pkg}[$no];
if (defined $fattr) {
my @a;
- push(@a, "public") if $fattr & _PUBLIC;
- push(@a, "private") if $fattr & _PRIVATE;
+ push(@a, "public") if $fattr & PUBLIC;
+ push(@a, "private") if $fattr & PRIVATE;
push(@a, "inherited") if $no < $attr{$pkg}[0];
print "\t(", join(", ", @a), ")";
}
}
}
-sub new {
+if ($] < 5.009) {
+ eval <<'EOC';
+ sub new {
my $class = shift;
$class = ref $class if ref $class;
+ return bless [\%{$class . "::FIELDS"}], $class;
+ }
+EOC
+} else {
+ eval <<'EOC';
+ sub new {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ use Hash::Util;
my $self = bless {}, $class;
- lock_keys(%$self, keys %{$class.'::FIELDS'});
+ Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'});
return $self;
+ }
+EOC
}
sub phash {
- die "Pseudo-hashes have been removed from Perl";
+ die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
+ my $h;
+ my $v;
+ if (@_) {
+ if (ref $_[0] eq 'ARRAY') {
+ my $a = shift;
+ @$h{@$a} = 1 .. @$a;
+ if (@_) {
+ $v = shift;
+ unless (! @_ and ref $v eq 'ARRAY') {
+ require Carp;
+ Carp::croak ("Expected at most two array refs\n");
+ }
+ }
+ }
+ else {
+ if (@_ % 2) {
+ require Carp;
+ Carp::croak ("Odd number of elements initializing pseudo-hash\n");
+ }
+ my $i = 0;
+ @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
+ $i = 0;
+ $v = [grep $i++ % 2, @_];
+ }
+ }
+ else {
+ $h = {};
+ $v = [];
+ }
+ [ $h, @$v ];
+
}
1;
+
+__END__
+
+=head1 NAME
+
+fields - compile-time class fields
+
+=head1 SYNOPSIS
+
+ {
+ package Foo;
+ use fields qw(foo bar _Foo_private);
+ sub new {
+ my Foo $self = shift;
+ unless (ref $self) {
+ $self = fields::new($self);
+ $self->{_Foo_private} = "this is Foo's secret";
+ }
+ $self->{foo} = 10;
+ $self->{bar} = 20;
+ return $self;
+ }
+ }
+
+ my $var = Foo->new;
+ $var->{foo} = 42;
+
+ # this will generate an error
+ $var->{zap} = 42;
+
+ # subclassing
+ {
+ package Bar;
+ use base 'Foo';
+ use fields qw(baz _Bar_private); # not shared with Foo
+ sub new {
+ my $class = shift;
+ my $self = fields::new($class);
+ $self->SUPER::new(); # init base fields
+ $self->{baz} = 10; # init own fields
+ $self->{_Bar_private} = "this is Bar's secret";
+ return $self;
+ }
+ }
+
+=head1 DESCRIPTION
+
+The C<fields> pragma enables compile-time verified class fields.
+
+NOTE: The current implementation keeps the declared fields in the %FIELDS
+hash of the calling package, but this may change in future versions.
+Do B<not> update the %FIELDS hash directly, because it must be created
+at compile-time for it to be fully useful, as is done by this pragma.
+
+ Only valid for perl before 5.9.0:
+
+ If a typed lexical variable holding a reference is used to access a
+ hash element and a package with the same name as the type has
+ declared class fields using this pragma, then the operation is
+ turned into an array access at compile time.
+
+
+The related C<base> pragma will combine fields from base classes and any
+fields declared using the C<fields> pragma. This enables field
+inheritance to work properly.
+
+Field names that start with an underscore character are made private to
+the class and are not visible to subclasses. Inherited fields can be
+overridden but will generate a warning if used together with the C<-w>
+switch.
+
+ Only valid for perls before 5.9.0:
+
+ The effect of all this is that you can have objects with named
+ fields which are as compact and as fast arrays to access. This only
+ works as long as the objects are accessed through properly typed
+ variables. If the objects are not typed, access is only checked at
+ run time.
+
+
+
+The following functions are supported:
+
+=over 8
+
+=item new
+
+B< perl before 5.9.0: > fields::new() creates and blesses a
+pseudo-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+B< perl 5.9.0 and higher: > fields::new() creates and blesses a
+restricted-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+
+This makes it possible to write a constructor like this:
+
+ package Critter::Sounds;
+ use fields qw(cat dog bird);
+
+ sub new {
+ my $self = shift;
+ $self = fields::new($self) unless ref $self;
+ $self->{cat} = 'meow'; # scalar element
+ @$self{'dog','bird'} = ('bark','tweet'); # slice
+ return $self;
+ }
+
+=item phash
+
+B< before perl 5.9.0: >
+
+ fields::phash() can be used to create and initialize a plain (unblessed)
+ pseudo-hash. This function should always be used instead of creating
+ pseudo-hashes directly.
+
+ If the first argument is a reference to an array, the pseudo-hash will
+ be created with keys from that array. If a second argument is supplied,
+ it must also be a reference to an array whose elements will be used as
+ the values. If the second array contains less elements than the first,
+ the trailing elements of the pseudo-hash will not be initialized.
+ This makes it particularly useful for creating a pseudo-hash from
+ subroutine arguments:
+
+ sub dogtag {
+ my $tag = fields::phash([qw(name rank ser_num)], [@_]);
+ }
+
+ fields::phash() also accepts a list of key-value pairs that will
+ be used to construct the pseudo hash. Examples:
+
+ my $tag = fields::phash(name => "Joe",
+ rank => "captain",
+ ser_num => 42);
+
+ my $pseudohash = fields::phash(%args);
+
+B< perl 5.9.0 and higher: >
+
+Pseudo-hashes have been removed from Perl as of 5.10. Consider using
+restricted hashes instead. Using fields::phash() will cause an error.
+
+=back
+
+=head1 SEE ALSO
+
+L<base>,
+
+=cut
projects / p5sagit/p5-mst-13.2.git / commitdiff