summaryrefslogtreecommitdiff
path: root/beagle/debian-rfs/usr/share/perl/5.10.1/fields.pm
diff options
context:
space:
mode:
authorManuel Traut <manut@mecka.net>2011-04-29 09:09:27 +0200
committerManuel Traut <manut@mecka.net>2011-04-29 09:09:27 +0200
commit5238ad5a0c4a9e1c8cd036f5de4055e39bd71297 (patch)
tree4407c087b9fb5432b1dc11e70b52dacfa0b99feb /beagle/debian-rfs/usr/share/perl/5.10.1/fields.pm
parent60ead65c41afba7e6aa4bbcf507a1d52f7a8fe9f (diff)
added debootstrap stuff
Signed-off-by: Manuel Traut <manut@mecka.net>
Diffstat (limited to 'beagle/debian-rfs/usr/share/perl/5.10.1/fields.pm')
-rw-r--r--beagle/debian-rfs/usr/share/perl/5.10.1/fields.pm177
1 files changed, 177 insertions, 0 deletions
diff --git a/beagle/debian-rfs/usr/share/perl/5.10.1/fields.pm b/beagle/debian-rfs/usr/share/perl/5.10.1/fields.pm
new file mode 100644
index 0000000..8cc942b
--- /dev/null
+++ b/beagle/debian-rfs/usr/share/perl/5.10.1/fields.pm
@@ -0,0 +1,177 @@
+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__
+