[p5sagit/p5-mst-13.2.git] / lib / fields.pm

package fields;

require 5.005;
use strict;
no strict 'refs';
unless( eval q{require warnings::register; warnings::register->import} ) {
    *warnings::warnif = sub { 
        require Carp;
        Carp::carp(@_);
    }
}
use vars qw(%attr $VERSION);

$VERSION = '2.03';

# constant.pm is slow
sub PUBLIC     () { 2**0  }
sub PRIVATE    () { 2**1  }
sub INHERITED  () { 2**2  }
sub PROTECTED  () { 2**3  }


# 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
# an array reference.  The first element in the array is the lowest field
# number not belonging to a base class.  The remaining elements' indices
# are the field numbers.  The values are integer bit masks, or undef
# in the case of base class private fields (which occupy a slot but are
# otherwise irrelevant to the class).

sub import {
    my $class = shift;
    return unless @_;
    my $package = caller(0);
    # avoid possible typo warnings
    %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
    my $fields = \%{"$package\::FIELDS"};
    my $fattr = ($attr{$package} ||= [1]);
    my $next = @$fattr;

    # Quiet pseudo-hash deprecation warning for uses of fields::new.
    bless \%{"$package\::FIELDS"}, 'pseudohash';

    if ($next > $fattr->[0]
	and ($fields->{$_[0]} || 0) >= $fattr->[0])
    {
	# There are already fields not belonging to base classes.
	# Looks like a possible module reload...
	$next = $fattr->[0];
    }
    foreach my $f (@_) {
	my $fno = $fields->{$f};

	# Allow the module to be reloaded so long as field positions
	# have not changed.
	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;
	$next += 1;
    }
    if (@$fattr > $next) {
	# Well, we gave them the benefit of the doubt by guessing the
	# module was reloaded, but they appear to be declaring fields
	# in more than one place.  We can't be sure (without some extra
	# bookkeeping) that the rest of the fields will be declared or
	# have the same positions, so punt.
	require Carp;
	Carp::croak ("Reloaded module must declare all fields at once");
    }
}

sub inherit {
    require base;
    goto &base::inherit_fields;
}

sub _dump  # sometimes useful for debugging
{
    for my $pkg (sort keys %attr) {
	print "\n$pkg";
	if (@{"$pkg\::ISA"}) {
	    print " (", join(", ", @{"$pkg\::ISA"}), ")";
	}
	print "\n";
	my $fields = \%{"$pkg\::FIELDS"};
	for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
	    my $no = $fields->{$f};
	    print "   $no: $f";
	    my $fattr = $attr{$pkg}[$no];
	    if (defined $fattr) {
		my @a;
		push(@a, "public")    if $fattr & PUBLIC;
		push(@a, "private")   if $fattr & PRIVATE;
		push(@a, "inherited") if $fattr & INHERITED;
		print "\t(", join(", ", @a), ")";
	    }
	    print "\n";
	}
    }
}

if ($] < 5.009) {
  *new = sub {
    my $class = shift;
    $class = ref $class if ref $class;
    return bless [\%{$class . "::FIELDS"}], $class;
  }
} else {
  *new = sub {
    my $class = shift;
    $class = ref $class if ref $class;
    require Hash::Util;
    my $self = bless {}, $class;

    # The lock_keys() prototype won't work since we require Hash::Util :(
    &Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'});
    return $self;
  }
}

sub phash {
    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.

B<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.

B<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 4

=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 function is usable with or without pseudo-hashes.  It is the
recommended way to construct a fields-based object.

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 or fields::new() instead.  Using fields::phash()
will cause an error.

=back

=head1 SEE ALSO

L<base>

=cut
Commit	Line	Data
458fb581	1	package fields;
458fb581	2
dc6d0c4f	3	require 5.005;
67edfcd9	4	use strict;
67edfcd9	5	no strict 'refs';
dc6d0c4f	6	unless( eval q{require warnings::register; warnings::register->import} ) {
	7	*warnings::warnif = sub {
	8	require Carp;
	9	Carp::carp(@_);
	10	}
	11	}
	12	use vars qw(%attr $VERSION);
024bc14b	13
864f8ab4	14	$VERSION = '2.03';
024bc14b	15
dc6d0c4f	16	# constant.pm is slow
	17	sub PUBLIC () { 2**0 }
	18	sub PRIVATE () { 2**1 }
	19	sub INHERITED () { 2**2 }
	20	sub PROTECTED () { 2**3 }
024bc14b	21
024bc14b	22
67edfcd9	23	# The %attr hash holds the attributes of the currently assigned fields
	24	# per class. The hash is indexed by class names and the hash value is
	25	# an array reference. The first element in the array is the lowest field
	26	# number not belonging to a base class. The remaining elements' indices
	27	# are the field numbers. The values are integer bit masks, or undef
	28	# in the case of base class private fields (which occupy a slot but are
	29	# otherwise irrelevant to the class).
024bc14b	30
67edfcd9	31	sub import {
	32	my $class = shift;
	33	return unless @_;
	34	my $package = caller(0);
	35	# avoid possible typo warnings
	36	%{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
	37	my $fields = \%{"$package\::FIELDS"};
	38	my $fattr = ($attr{$package} \|\|= [1]);
	39	my $next = @$fattr;
024bc14b	40
864f8ab4	41	# Quiet pseudo-hash deprecation warning for uses of fields::new.
	42	bless \%{"$package\::FIELDS"}, 'pseudohash';
	43
67edfcd9	44	if ($next > $fattr->[0]
	45	and ($fields->{$_[0]} \|\| 0) >= $fattr->[0])
	46	{
	47	# There are already fields not belonging to base classes.
	48	# Looks like a possible module reload...
	49	$next = $fattr->[0];
	50	}
	51	foreach my $f (@_) {
	52	my $fno = $fields->{$f};
024bc14b	53
67edfcd9	54	# Allow the module to be reloaded so long as field positions
	55	# have not changed.
	56	if ($fno and $fno != $next) {
	57	require Carp;
	58	if ($fno < $fattr->[0]) {
dc6d0c4f	59	if ($] < 5.006001) {
	60	warn("Hides field '$f' in base class") if $^W;
	61	} else {
67edfcd9	62	warnings::warnif("Hides field '$f' in base class") ;
dc6d0c4f	63	}
67edfcd9	64	} else {
	65	Carp::croak("Field name '$f' already in use");
	66	}
	67	}
	68	$fields->{$f} = $next;
dc6d0c4f	69	$fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
67edfcd9	70	$next += 1;
	71	}
	72	if (@$fattr > $next) {
	73	# Well, we gave them the benefit of the doubt by guessing the
	74	# module was reloaded, but they appear to be declaring fields
	75	# in more than one place. We can't be sure (without some extra
	76	# bookkeeping) that the rest of the fields will be declared or
	77	# have the same positions, so punt.
	78	require Carp;
	79	Carp::croak ("Reloaded module must declare all fields at once");
	80	}
	81	}
	82
dc6d0c4f	83	sub inherit {
	84	require base;
	85	goto &base::inherit_fields;
67edfcd9	86	}
	87
	88	sub _dump # sometimes useful for debugging
	89	{
	90	for my $pkg (sort keys %attr) {
	91	print "\n$pkg";
	92	if (@{"$pkg\::ISA"}) {
	93	print " (", join(", ", @{"$pkg\::ISA"}), ")";
	94	}
	95	print "\n";
	96	my $fields = \%{"$pkg\::FIELDS"};
	97	for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
	98	my $no = $fields->{$f};
	99	print " $no: $f";
	100	my $fattr = $attr{$pkg}[$no];
	101	if (defined $fattr) {
	102	my @a;
dc6d0c4f	103	push(@a, "public") if $fattr & PUBLIC;
dc6d0c4f	104	push(@a, "private") if $fattr & PRIVATE;
864f8ab4	105	push(@a, "inherited") if $fattr & INHERITED;
67edfcd9	106	print "\t(", join(", ", @a), ")";
	107	}
	108	print "\n";
	109	}
	110	}
	111	}
	112
dc6d0c4f	113	if ($] < 5.009) {
864f8ab4	114	*new = sub {
67edfcd9	115	my $class = shift;
67edfcd9	116	$class = ref $class if ref $class;
dc6d0c4f	117	return bless [\%{$class . "::FIELDS"}], $class;
dc6d0c4f	118	}
dc6d0c4f	119	} else {
864f8ab4	120	*new = sub {
dc6d0c4f	121	my $class = shift;
dc6d0c4f	122	$class = ref $class if ref $class;
864f8ab4	123	require Hash::Util;
67edfcd9	124	my $self = bless {}, $class;
864f8ab4	125
	126	# The lock_keys() prototype won't work since we require Hash::Util :(
	127	&Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'});
67edfcd9	128	return $self;
dc6d0c4f	129	}
67edfcd9	130	}
	131
	132	sub phash {
dc6d0c4f	133	die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
	134	my $h;
	135	my $v;
	136	if (@_) {
	137	if (ref $_[0] eq 'ARRAY') {
	138	my $a = shift;
	139	@$h{@$a} = 1 .. @$a;
	140	if (@_) {
	141	$v = shift;
	142	unless (! @_ and ref $v eq 'ARRAY') {
	143	require Carp;
	144	Carp::croak ("Expected at most two array refs\n");
	145	}
	146	}
	147	}
	148	else {
	149	if (@_ % 2) {
	150	require Carp;
	151	Carp::croak ("Odd number of elements initializing pseudo-hash\n");
	152	}
	153	my $i = 0;
	154	@$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
	155	$i = 0;
	156	$v = [grep $i++ % 2, @_];
	157	}
	158	}
	159	else {
	160	$h = {};
	161	$v = [];
	162	}
	163	[ $h, @$v ];
	164
67edfcd9	165	}
	166
	167	1;
dc6d0c4f	168
	169	__END__
	170
	171	=head1 NAME
	172
	173	fields - compile-time class fields
	174
	175	=head1 SYNOPSIS
	176
	177	{
	178	package Foo;
	179	use fields qw(foo bar _Foo_private);
	180	sub new {
	181	my Foo $self = shift;
	182	unless (ref $self) {
	183	$self = fields::new($self);
	184	$self->{_Foo_private} = "this is Foo's secret";
	185	}
	186	$self->{foo} = 10;
	187	$self->{bar} = 20;
	188	return $self;
	189	}
	190	}
	191
	192	my $var = Foo->new;
	193	$var->{foo} = 42;
	194
	195	# this will generate an error
	196	$var->{zap} = 42;
	197
	198	# subclassing
	199	{
	200	package Bar;
	201	use base 'Foo';
	202	use fields qw(baz _Bar_private); # not shared with Foo
	203	sub new {
	204	my $class = shift;
	205	my $self = fields::new($class);
	206	$self->SUPER::new(); # init base fields
	207	$self->{baz} = 10; # init own fields
	208	$self->{_Bar_private} = "this is Bar's secret";
	209	return $self;
	210	}
	211	}
	212
	213	=head1 DESCRIPTION
	214
	215	The C<fields> pragma enables compile-time verified class fields.
	216
	217	NOTE: The current implementation keeps the declared fields in the %FIELDS
	218	hash of the calling package, but this may change in future versions.
	219	Do B<not> update the %FIELDS hash directly, because it must be created
	220	at compile-time for it to be fully useful, as is done by this pragma.
	221
864f8ab4	222	B<Only valid for perl before 5.9.0:>
dc6d0c4f	223
864f8ab4	224	If a typed lexical variable holding a reference is used to access a
	225	hash element and a package with the same name as the type has
	226	declared class fields using this pragma, then the operation is
	227	turned into an array access at compile time.
dc6d0c4f	228
	229
	230	The related C<base> pragma will combine fields from base classes and any
	231	fields declared using the C<fields> pragma. This enables field
	232	inheritance to work properly.
	233
	234	Field names that start with an underscore character are made private to
	235	the class and are not visible to subclasses. Inherited fields can be
	236	overridden but will generate a warning if used together with the C<-w>
	237	switch.
	238
864f8ab4	239	B<Only valid for perls before 5.9.0:>
dc6d0c4f	240
864f8ab4	241	The effect of all this is that you can have objects with named
	242	fields which are as compact and as fast arrays to access. This only
	243	works as long as the objects are accessed through properly typed
	244	variables. If the objects are not typed, access is only checked at
	245	run time.
dc6d0c4f	246
	247
	248	The following functions are supported:
	249
864f8ab4	250	=over 4
dc6d0c4f	251
	252	=item new
	253
	254	B< perl before 5.9.0: > fields::new() creates and blesses a
	255	pseudo-hash comprised of the fields declared using the C<fields>
	256	pragma into the specified class.
	257
	258	B< perl 5.9.0 and higher: > fields::new() creates and blesses a
	259	restricted-hash comprised of the fields declared using the C<fields>
	260	pragma into the specified class.
	261
864f8ab4	262	This function is usable with or without pseudo-hashes. It is the
864f8ab4	263	recommended way to construct a fields-based object.
dc6d0c4f	264
	265	This makes it possible to write a constructor like this:
	266
	267	package Critter::Sounds;
	268	use fields qw(cat dog bird);
	269
	270	sub new {
	271	my $self = shift;
	272	$self = fields::new($self) unless ref $self;
	273	$self->{cat} = 'meow'; # scalar element
	274	@$self{'dog','bird'} = ('bark','tweet'); # slice
	275	return $self;
	276	}
	277
	278	=item phash
	279
	280	B< before perl 5.9.0: >
	281
864f8ab4	282	fields::phash() can be used to create and initialize a plain (unblessed)
	283	pseudo-hash. This function should always be used instead of creating
	284	pseudo-hashes directly.
dc6d0c4f	285
864f8ab4	286	If the first argument is a reference to an array, the pseudo-hash will
	287	be created with keys from that array. If a second argument is supplied,
	288	it must also be a reference to an array whose elements will be used as
	289	the values. If the second array contains less elements than the first,
	290	the trailing elements of the pseudo-hash will not be initialized.
	291	This makes it particularly useful for creating a pseudo-hash from
	292	subroutine arguments:
dc6d0c4f	293
864f8ab4	294	sub dogtag {
	295	my $tag = fields::phash([qw(name rank ser_num)], [@_]);
	296	}
dc6d0c4f	297
864f8ab4	298	fields::phash() also accepts a list of key-value pairs that will
864f8ab4	299	be used to construct the pseudo hash. Examples:
dc6d0c4f	300
864f8ab4	301	my $tag = fields::phash(name => "Joe",
	302	rank => "captain",
	303	ser_num => 42);
dc6d0c4f	304
864f8ab4	305	my $pseudohash = fields::phash(%args);
dc6d0c4f	306
	307	B< perl 5.9.0 and higher: >
	308
	309	Pseudo-hashes have been removed from Perl as of 5.10. Consider using
864f8ab4	310	restricted hashes or fields::new() instead. Using fields::phash()
864f8ab4	311	will cause an error.
dc6d0c4f	312
	313	=back
	314
	315	=head1 SEE ALSO
	316
864f8ab4	317	L<base>
dc6d0c4f	318
dc6d0c4f	319	=cut