package fields;

use 5.005_64;
use strict;
no strict 'refs';
use warnings::register;
our(%attr, $VERSION);

$VERSION = "1.01";

# 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
# 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;

    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]) {
                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  { # 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 _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 $no < $attr{$pkg}[0];
		print "\t(", join(", ", @a), ")";
	    }
	    print "\n";
	}
    }
}

sub new {
    my $class = shift;
    $class = ref $class if ref $class;
    return bless [\%{$class . "::FIELDS"}], $class;
}

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