summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/fields.pm
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/fields.pm
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff)
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/fields.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/fields.pm327
1 files changed, 0 insertions, 327 deletions
diff --git a/Master/tlpkg/tlperl/lib/fields.pm b/Master/tlpkg/tlperl/lib/fields.pm
deleted file mode 100755
index c90bc0a16c1..00000000000
--- a/Master/tlpkg/tlperl/lib/fields.pm
+++ /dev/null
@@ -1,327 +0,0 @@
-package fields;
-
-require 5.005;
-use strict;
-no strict 'refs';
-unless( eval q{require warnings::register; warnings::register->import; 1} ) {
- *warnings::warnif = sub {
- require Carp;
- Carp::carp(@_);
- }
-}
-use vars qw(%attr $VERSION);
-
-$VERSION = '2.14';
-
-# 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, _accessible_keys($class));
- return $self;
- }
-}
-
-sub _accessible_keys {
- my ($class) = @_;
- return (
- keys %{$class.'::FIELDS'},
- map(_accessible_keys($_), @{$class.'::ISA'}),
- );
-}
-
-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