perl/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
Revision:	1.1
Committed:	Thu Jun 30 14:27:09 2005 UTC (21 years, 2 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package fields;
2
3			require 5.005;
4			use strict;
5			no strict 'refs';
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);
13
14			$VERSION = '2.03';
15
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 }
21
22
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).
30
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;
40
41			# Quiet pseudo-hash deprecation warning for uses of fields::new.
42			bless \%{"$package\::FIELDS"}, 'pseudohash';
43
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};
53
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]) {
59			if ($] < 5.006001) {
60			warn("Hides field '$f' in base class") if $^W;
61			} else {
62			warnings::warnif("Hides field '$f' in base class") ;
63			}
64			} else {
65			Carp::croak("Field name '$f' already in use");
66			}
67			}
68			$fields->{$f} = $next;
69			$fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
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
83			sub inherit {
84			require base;
85			goto &base::inherit_fields;
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;
103			push(@a, "public") if $fattr & PUBLIC;
104			push(@a, "private") if $fattr & PRIVATE;
105			push(@a, "inherited") if $fattr & INHERITED;
106			print "\t(", join(", ", @a), ")";
107			}
108			print "\n";
109			}
110			}
111			}
112
113			if ($] < 5.009) {
114			*new = sub {
115			my $class = shift;
116			$class = ref $class if ref $class;
117			return bless [\%{$class . "::FIELDS"}], $class;
118			}
119			} else {
120			*new = sub {
121			my $class = shift;
122			$class = ref $class if ref $class;
123			require Hash::Util;
124			my $self = bless {}, $class;
125
126			# The lock_keys() prototype won't work since we require Hash::Util :(
127			&Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'});
128			return $self;
129			}
130			}
131
132			sub phash {
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
165			}
166
167			1;
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
222			B<Only valid for perl before 5.9.0:>
223
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.
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
239			B<Only valid for perls before 5.9.0:>
240
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.
246
247
248			The following functions are supported:
249
250			=over 4
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
262			This function is usable with or without pseudo-hashes. It is the
263			recommended way to construct a fields-based object.
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
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.
285
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:
293
294			sub dogtag {
295			my $tag = fields::phash([qw(name rank ser_num)], [@_]);
296			}
297
298			fields::phash() also accepts a list of key-value pairs that will
299			be used to construct the pseudo hash. Examples:
300
301			my $tag = fields::phash(name => "Joe",
302			rank => "captain",
303			ser_num => 42);
304
305			my $pseudohash = fields::phash(%args);
306
307			B< perl 5.9.0 and higher: >
308
309			Pseudo-hashes have been removed from Perl as of 5.10. Consider using
310			restricted hashes or fields::new() instead. Using fields::phash()
311			will cause an error.
312
313			=back
314
315			=head1 SEE ALSO
316
317			L<base>
318
319			=cut