package members;

use strict;
no strict 'refs';

use XML;
use Message;

my %typedefs = ( index => { container => 1,
			    methods => [ qw( index_X_names index_Xs index_add_X index_remove_X index_X index_merge_Xs index_diff_Xs index_clear_Xs) ] },

		  list => { container => 1,
			    methods => [ qw( list_X_names list_Xs list_add_X list_remove_X list_X list_merge_Xs list_diff_Xs list_clear_Xs) ] },

		scalar => { methods => [ qw( scalar_X scalar_diff_X scalar_merge_X ) ] },

	      foldcase => { methods => [ qw( foldcase_X scalar_diff_X scalar_merge_X ) ] } );

my (%singular, %plural);

sub import {
	my ($package, @args) = @_;
	my $callpkg = caller;

	${"${callpkg}::Diff::entity_package"} = $callpkg;
	push @{"${callpkg}::Diff::ISA"}, qw(Diff);

	# make requested members, and accessors
	my @members;
	my @containers;
	my @attributes;
	my @short_attributes;
	my @long_attributes;
	my %class;
	
	while (my ($type, $members) = splice @args, 0, 2) {
		my ($long);
		if ($type eq 'text') {
			$type = "scalar";
			$long = 1;
		}
		my $typedef = $typedefs{$type} || die "unknown member type $type";

		for my $member (ref $members ? @$members : ($members)) {
			my ($class, $member_plural, $member_key, $default);

			($member, $default) = split '=', $member;
			($member, $class) = split ':', $member;

			if ($typedef->{container}) {
				($member_plural, $member) = split ' ', $member;
				$member_key = $member_plural;
				if ($member) {
					$plural{$member} = $member_plural;
					$singular{$member_plural} = $member;
				} else {
					$member = singular($member_plural);
				}
				push @containers, $member_key;
			} else {
				$member_key = $member;
				push @attributes, $member_key;
				if ($long) {
					push @long_attributes, $member_key;
				} else {
					push @short_attributes, $member_key;
				}
			}

			push @members, $member_key;
			$class ||= "\u$member";
			$class{$member_key} = { name => $class, default => $default };

			for my $method (@{$typedef->{methods}}) {
				(my $export_name = $method) =~ s/^[^_]+_//;

			        $export_name =~ s/Xs/$member_plural/ if $typedef->{container};
				$export_name =~ s/X/$member/;

#				print "local: $method\n";
#				print "export: $export_name\n";

				*{"${callpkg}::$export_name"} = sub { &$method($member, $member_plural, @_) };
			}
		}
	}

	{
		push @{"${callpkg}::members"}, @members;
		push @{"${callpkg}::containers"}, @containers;
		push @{"${callpkg}::attributes"}, @attributes;
		push @{"${callpkg}::short_attributes"}, @short_attributes;
		push @{"${callpkg}::long_attributes"}, @long_attributes;
		@{"${callpkg}::members"}{@members} = (1) x @members;
		@{"${callpkg}::containers"}{@containers} = (1) x @containers;
		@{"${callpkg}::attributes"}{@attributes} = (1) x @attributes;
		@{"${callpkg}::long_attributes"}{@long_attributes} = (1) x @long_attributes;
		@{"${callpkg}::short_attributes"}{@short_attributes} = (1) x @short_attributes;
		@{"${callpkg}::class"}{keys %class} = values %class;
	}
}

# (dodgy) conversion between singular and plural

sub plural {
	my $singular = shift;
	return $plural{$singular} || "${singular}s";
}

sub singular {
	my $plural = shift;
	return $singular{$plural} ||
		(($plural =~ s/s$// or die qq{"$plural" is not plural}), $plural);
}

# scalar methods

sub scalar_X {
	my ($X, $Xs, $this) = splice @_, 0, 3;

	if (@_) {
		$this->{$X} = shift;
	} else {
		return $this->{$X};
	}
}

sub scalar_merge_X {
	my ($X, $Xs, $dest, @source) = @_;

	my $source = shift @source;

	my $value = $source->$X();

	for (@source) {
		my $value_2 = $_->$X();
		if (defined $value != defined $value_2 || defined $value && $value ne $value_2) {
			for ($value, $value_2) { $_ = "undef" unless defined $_ }
			die "merge conflict: ".$source->name.qq{'s $X has different values "$value" and "$value_2"};
		}
	}

	$dest->$X($value);
}

sub scalar_diff_X {
	my ($X, $Xs, $old, $new, $diff) = @_;

	my ($old_value, $new_value) = map { $_->$X() } $old, $new;

	$diff->{change}{$X} = $new_value unless (defined($old_value) == defined($new_value)) && (!defined($old_value) || $old_value eq $new_value);
}

# foldcase method

sub foldcase_X {
	my ($X, $Xs, $this) = splice @_, 0, 3;

	if (@_) {
		$this->{$X} = lc shift;
	} else {
		die "dbischema internal error: foldcase invarient violated on $X `$this'" unless lc($this->{$X}) eq $this->{$X};
		return $this->{$X};
	}
}

# index methods

sub index_X_names {
	my ($X, $Xs, $this) = @_;

	my @ret = sort keys %{$this->{$Xs}};

	return wantarray ? @ret : \@ret;
}

sub index_Xs {
	my ($X, $Xs, $this) = splice @_, 0, 3;

	if (@_) {
		$this->{$Xs} = { map { $_->name, $_ } @_ };
	} else {
		my @ret = @{$this->{$Xs}}{sort keys %{$this->{$Xs}}};

		return wantarray ? @ret : \@ret;
	}
}

sub index_add_X {
	my ($X, $Xs, $this, $to_add) = @_;

	my $name = $to_add->name;
	exists $this->{$Xs}{$name} and
		fatal("cannot add $X `$name', already exists");

	$this->{$Xs}{$name} = $to_add;
}

sub index_remove_X {
	my ($X, $Xs, $this, $to_remove) = @_;

       	$to_remove = $to_remove->name if ref $to_remove;

       	delete $this->{$Xs}{$to_remove} or
		fatal("cannot remove $X `$to_remove', does not exist");
}

sub index_X {
	my ($X, $Xs, $this, $name) = splice @_, 0, 4;

	if (@_) {
		my $value = shift;
		if (defined $value) {
			$this->{$Xs}{$name} = $value;
		} else {
			delete $this->{$Xs}{$name};
		}
	} else {
		return $this->{$Xs}{$name};
	}
}

sub index_merge_Xs {
	my ($X, $Xs, $dest, @source) = @_;

	my $package = ref $dest;

	my %members;

	my $X_names = "${X}_names";

	for my $source (@source) {
		for my $name ($source->$X_names()) {
			push @{$members{$name}}, $source->$X($name);
		}
	}

	my $member_class = ${"${package}::class"}{$Xs}->{name};

	while (my ($name, $member_source) = each %members) {
		# create a new object to merge the member with this name into...

		my $member_dest = $member_class->new;

		# put it in the data structure
		$dest->$X($name, $member_dest);
		
		# call the merge method on it with @$members
		$member_dest->merge(@$member_source);
	}
}

sub index_diff_Xs {
	my ($X, $Xs, $old, $new, $diff) = @_;

#	my $package = ref $new;
#	my $member_package = ${"${package}::class"}{$Xs};

	my $X_names = "${X}_names";
	my %which = map {$_, 1} $old->$X_names();
	for ($new->$X_names()) { $which{$_} |= 2 }

	# create mapping from old fields to new fields for rename functionality
	my %old_to_new;
	for my $new_member ($new->$Xs()) {
		last unless $new_member->can('name') && $new_member->can('old');
		my $new_name = $new_member->name;
		if (my $olds = $new_member->old) {
			for my $old_name (split /,\s*/, $olds) {
				if (my $another_new = $old_to_new{$old_name}) {
					fatal("field `$new_name' mentions old name `$old_name' twice")
						if $another_new eq $new_name;
					fatal("fields `$new_name' and `$another_new' have same old name `$old_name'");
				}
				$old_to_new{$old_name} = $new_name;
			}
		}
	}

	my %inv_rename;

	# look for renames first
	while (my ($name, $which) = each %which) {
		if ($which == 1 and my $new_name = $old_to_new{$name}) {
			$diff->{rename}{$Xs}{$name} = $new_name;
			$inv_rename{$new_name} = $name;
		}
	}

	while (my ($name, $which) = each %which) {
#	for my $name (sort keys %which) {
#		my $which = $which{$name};
		my ($old_value, $new_value) = map {$_->$X($name)} $old, $new;
			
		if ($which == 3) {
			# common - check for diffs in element
		        if (my $element_diff = $old_value->diff($new_value)) {
				# there was a difference
				$diff->{change}{$Xs}{$name} = $element_diff;
			}
		} elsif ($which == 1) { # old only
			next if $old_to_new{$name}; # skip fields already renamed
			#push @{$diff->{remove}{$X}}, $name;
			$diff->{remove}{$Xs}{$name} = 1; #$old_value;
		} else { # $which == 2 - new only
			next if $inv_rename{$name}; # skip fields already renamed
			$diff->{add}{$Xs}{$name} = 1; #$new_value;
		}
	}
}

sub index_clear_Xs {
	my ($X, $Xs, $this) = splice @_, 0, 3;

	$this->{$Xs} = {};
}

# list methods

sub list_X_names {
	my ($X, $Xs, $this) = @_;

	return wantarray ? @{$this->{"${X}_names"}} : $this->{"${X}_names"};
}

sub list_Xs {
	my ($X, $Xs, $this) = splice @_, 0, 3;

	if (@_) {
		my @names = map {$_->name} @_;
		@{$this->{$Xs}} = {};
		@{$this->{$Xs}}{@names} = @_;
		$this->{"${X}_names"} = \@names;
	} else {
		my @ret = @{$this->{$Xs}}{@{$this->{"${X}_names"} || []}};
		return wantarray ? @ret : \@ret;
	}
}

sub list_add_X {
	my ($X, $Xs, $this, $to_add) = @_;

	my $name = $to_add->name;
	exists $this->{$Xs}{$name} and
		fatal("cannot add $X `$name', already exists");

	$this->{$Xs}{$name} = $to_add;
	push @{$this->{"${X}_names"}}, $name;
}

sub list_remove_X {
	my ($X, $Xs, $this, $to_remove) = @_;

       	$to_remove = $to_remove->name if ref $to_remove;

       	delete $this->{$Xs}{$to_remove} or
		fatal("cannot remove $X `$to_remove', does not exist");

	@{$this->{"${X}_names"}} = grep { $_ ne $to_remove } @{$this->{"${X}_names"}};
}

sub list_X {
	my ($X, $Xs, $this, $name) = splice @_, 0, 4;

	if (@_) {
		my $value = shift;
		if (defined $value) {
			$this->{$Xs}{$name} = $value;
			push @{$this->{"${X}_names"}}, $name;
		} else {
			delete $this->{$Xs}{$name};
			@{$this->{"${X}_names"}} = grep { $_ ne $name } @{$this->{"${X}_names"}};
		}
	} else {
		return $this->{$Xs}{$name};
	}
}

sub list_merge_Xs {
	my ($X, $Xs, $dest, @source) = @_;

	my $package = ref $dest;

	my %members;
	my @names;

	my $X_names = "${X}_names";

	for my $source (@source) {
		for my $name ($source->$X_names()) {
			push @names, $name unless exists $members{$name};
			push @{$members{$name}}, $source->$X($name);
		}
	}

	my $member_class = ${"${package}::class"}{$Xs}->{name};

	for my $name (@names) {
		my $member_source = $members{$name};
		# create a new object to merge the member with this name into...

		my $member_dest = $member_class->new;

		# put it in the data structure
		$dest->$X($name, $member_dest);
		
		# call the merge method on it with @$members
		my $method = "merge_$name";
		$member_dest->merge(@$member_source);
	}
}

sub list_diff_Xs {
	my ($X, $Xs, $old, $new, $diff) = splice @_;

	index_diff_Xs($X, $Xs, $old, $new, $diff);

	# now check if the order has changed

	my $order_changed = 0;

	my $X_names = "${X}_names";
	my ($order_old, $order_new) = map { $_->$X_names() } $old, $new;

	my $remove = $diff->{remove};

	my $i = 0;

	for my $old_name (@$order_old) {
		unless ($remove && $remove->{$old_name}) {
			my $new_name = $order_new->[$i++];
			if (! _same_possibly_with_rename($old_name, $new_name, $new->$X($new_name))) {
				$order_changed = 1;
				last;
			}
		}
	}

	$diff->{order}{$Xs} = 1 if $order_changed;
}

sub _same_possibly_with_rename {
	my ($old_name, $new_name, $new) = @_;
	return 1 if $old_name eq $new_name;
	return 0 unless $new->can('old');
	return grep { $_ eq $old_name } split /,\s*/, $new->old;
}

sub list_clear_Xs {
	my ($X, $Xs, $this) = splice @_, 0, 3;

	$this->{$Xs} = {};
	$this->{"${X}_names"} = ();
}

1
