package methods;

use strict;
use Diff;

no strict 'refs';

use XML;

my @methods = qw( new init xml xml_parse recurse members containers attributes long_attributes short_attributes merge diff xml_member_diff report_member_diff abstract realize );

sub import {
	my $package = shift;
	my $callpkg = caller(0);

	# copy requested methods into package

	for my $method (@_ ? @_ : @methods) {
		*{"${callpkg}::$method"} = $package->can($method) ||
			die qq{you requested an unknown method "$method"};

		if (my $init_method = $package->can("init_$method")) {
			$init_method->($callpkg);
		}
	}
}

# methods for direct export

sub new {
	my $package = shift;
	return (bless {}, $package)->methods::init(@_);
}

sub init {
	my ($this, %args) = @_;
	my $package = ref $this;

	while (my ($name, $value) = each %args) {
		$name = lc $name;
		if ($this->can($name)) {
			$this->$name(ref $value eq "ARRAY" ? @$value : ($value));
		} else {
          		die "$package->new( $name => ... ) not understood";
		}
	}
	return $this;
}

sub init_xml {
	my ($callpkg) = @_;
	return if defined ${"${callpkg}::xml_element"};
	$callpkg =~ s/.*:://;
	my $element = lc $callpkg;
	${"${callpkg}::xml_element"} = $element;
	${"${callpkg}::Diff::xml_element"} = "${element}:diff";
	$XMLParser::class_by_element{$element} = $callpkg;
	$XMLParser::class_by_element{"${element}:diff"} = "${callpkg}::Diff";
}

sub xml {
	my ($this) = @_;
	my $package = ref $this;

	my $xml_description = "";
	my $xml_long_attributes = "";

	my %long_attributes = $this->methods::long_attributes;
	for my $name (sort keys %long_attributes) {
		my $val = $long_attributes{$name};
		$val .= "\n" unless $val =~ /\n$/s;
		if ($name eq "description") {
			$xml_description = $val;
		} else {
			$xml_long_attributes .= "<$name>\n".XML->indent($val)."</$name>\n";
		}
	}

	my $xml_components = join '', $this->methods::recurse;
	
	my $xml_content = $xml_description . $xml_long_attributes . $xml_components;

	if (my $element = ${"${package}::xml_element"}) {
		$element = "$element/" if $xml_content eq '';

		my $xml = XML->tag($element, $this->methods::short_attributes);

		$xml .= XML->indent($xml_content) .
			XML->tag("/$element")
				if $xml_content ne '';
		return $xml;
	} else {
		return $xml_components;
	}
}

sub xml_parse {
	my $this = shift;
	$this = $this->new unless ref $this;
	my $elements = ref $_[0] ? shift : \@_;
	my $package = ref $this;
	my $this_element = ${"${package}::xml_element"};
	my $expecting = defined $this_element ? "</$this_element>" : "end of document";
	
	while (@$elements) {
		my $token = shift @$elements;
		my ($type, $data, @attributes) = @$token;
		if ($type eq 'end') {
			die "XML syntax: found </$data>, expecting $expecting" if $data ne $this_element;
			last;
		} elsif ($type eq 'start') {
			if (my ($container, $class) = $package->methods::container_class_by_xml_element($data)) {
				$container = members::singular($container);
				my $add_method = "add_$container";
				my $obj = $class->new(@attributes);
				$this->$add_method($obj);
				$obj->xml_parse($elements);
			} elsif (${"${package}::long_attributes"}{$data}) {
				my $name = $data;
				my $token = shift @$elements;
				my ($type, $data, @attributes) = @$token;
				if ($type eq 'end') {
					die "XML syntax: found </$data>, expecting text";
				} elsif ($type eq 'start') {
					die "XML syntax: found <$data>, expecting text";
				} elsif ($type eq 'text') {
					$this->$name($data);
				}
				$token = shift @$elements;
				($type, $data, @attributes) = @$token;
				if ($type eq 'end') {
					die "XML syntax: found </$data>, expecting </$name>" unless $data eq $name;
				} elsif ($type eq 'start') {
					die "XML syntax: found <$data>, expecting </$name>";
				} elsif ($type eq 'text') {
					die "XML internal error: two consecutive text elements";
				}
			} else {
				die "XML syntax: found <$data>, expecting $expecting";
			}
		} elsif ($type eq 'text') {
			$this->can('description') or die "XML syntax: found text, expecting $expecting";
			$this->description($data);
		} else {
			die "internal error: invalid XML tag type `$type'";
		}
	}
}

sub container_class_by_xml_element {
	my ($package, $element) = @_;
	return @{(${"${package}::container_class_by_xml_element"} ||= do {
		my (%container_class_by_element);
		for my $container ($package->methods::containers) {
			my $class = ${"${package}::class"}{$container}{name};
			my $element = eval "use $class; \$${class}::xml_element";
			die "$@" if $@;
			$container_class_by_element{$element} = [$container, $class];
		}
		\%container_class_by_element;
	})->{$element} || []};
}

sub recurse {
	my ($this, @apply_to) = @_;
	my $package = ref $this;

	my $method = (caller(1))[3];
	$method =~ s/.*:://;

	@apply_to = $package->methods::containers unless @apply_to;

	my @ret = map { $_->$method() }
		map { $this->$_() }
			@apply_to;

	return wantarray ? @ret : \@ret;
}

sub members {
	my ($this, $type) = @_;
	$type ||= "members";

	my $package = ref $this;

	if ($package) {
		# a call on the object, we return its members in a key-value list
		my @ret = map {
			my $value = scalar($this->$_());
			defined $value ? ($_, $value) : ()
		} @{"${package}::$type"};

		return wantarray ? @ret : \@ret;
	} else {
		# a call on the class, we return the list of attribute names
		return wantarray ? @{"${this}::$type"} : \@{"${this}::$type"};
	}
}

sub containers {
	my ($this) = @_;
	return $this->methods::members("containers");
}

sub attributes {
	my ($this) = @_;
	return $this->methods::members("attributes");
}

sub short_attributes {
	my ($this) = @_;
	return $this->methods::members("short_attributes");
}

sub long_attributes {
	my ($this) = @_;
	return $this->methods::members("long_attributes");
}


# TODO: resolve more merge conflicts?

sub merge {
	my ($dest, @source) = @_;

	$dest = $dest->new unless ref $dest;

	my $package = ref $dest;

	my @members = $package->methods::members;

	for my $source (@source) {
		my $package_2 = ref $source;
		die qq{cannot merge entities of different classes "$package" and "$package_2" to give "}.$source->name. q{"} if $package ne $package_2;
	}

	# merge members
	for my $member (@members) {
		my $method = "merge_$member";
		$dest->$method(@source);
	}

	return $dest;
}

#use Data::Dumper;

#TODO: add diff options, so can choose which parts of diff would be included.
#Also, get it to return things that are the same in case that would be helpful

#TODO: What about renaming entries? we were going to use an 'renamed' field...
# what happens if two fields are swapped, or something - can be ambiguous

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

	my $package_old = ref $old;
	my $package = ref $new;
	die qq{cannot compare objects of different classes "$package_old", "$package"} unless $package_old eq $package;

	my ($name, $name_old);
	if ($new->can('name')) {
		$name_old = $old->name;
		$name = $new->name;
		# TODO support for rename...
		die qq{cannot compare objects "$name_old", "$name" with different names} unless $name_old eq $name;
	}

	my $diff = "${package}::Diff"->new($name);

	# compare members
	for my $member ($package->methods::members) {
		next if $member eq "old"; # we don't want to diff the `old' fields!
		my $method = "diff_$member";
		$old->$method($new, $diff);
	}

	my $n = keys %$diff;
	if ($n && (! $$diff{name} || $n >= 2)) {
		return $diff;
	}
	return undef;
}

sub xml_member_diff {
	my ($package, $diff) = @_;

#	print "member diff package: $package\n";
	
#	use Data::Dumper;
#	print Dumper $diff;
#	print "\n";

	my $xml = "";

	my @members = $package->methods::members;

#	print "package: $package ; members: @members\n";

	for my $member (@members) {
		next unless exists $diff->{$member};
		my $diff_member = $diff->{$member};
		$diff_member = '' unless defined $diff_member;

		if (ref $diff_member) {
			for my $name (sort keys %{$diff_member}) {
				my $value = $diff_member->{$name};
				my $member_sing = members::singular($member);
				if ($value eq "1") { # don't rename a field to '1'!
					# for the references, in <remove> and <add>
					$xml .= XML->tag("$member_sing/", name => $name);
				} elsif (!ref $value) {
					# for the <rename>, $value is the new name
					$xml .= XML->tag("$member_sing/", old => $name, name => $value);
				} elsif (ref($value) =~ /::Diff$/) {
					# this happens for nested Diff objects, in <change>
					$xml .= $value->xml($name);
				} else {
					# this used to happen, for embedded objects, in <add> and <remove>
					die "this should not happen";
					my $element_xml = $value->xml();
					$xml .= $element_xml;
				}
			}
		} else {
			$xml .= XML->tag("$member/", value => $diff_member);
		}
	}

	return $xml;
}

sub report_member_diff {
	my ($package, $diff) = @_;

#	print "member diff package: $package\n";
	
#	use Data::Dumper;
#	print Dumper $diff;
#	print "\n";

	my $report = "";

	my @members = $package->methods::members;

#	print "package: $package ; members: @members\n";

	for my $member (@members) {
		next unless exists $diff->{$member};
		my $diff_member = $diff->{$member};
		$diff_member = '' unless defined $diff_member;

		if (ref $diff_member) {
			for my $name (sort keys %{$diff_member}) {
				my $value = $diff_member->{$name};
				my $member_sing = members::singular($member);
				if ($value eq "1") { # don't rename a field to '1'!
					# for the references, in <remove> and <add>
					$report .= "$member_sing `$name'\n";
				} elsif (!ref $value) {
					# for the <rename>, $value is the new name
					$report .= "$member_sing `$name' -> `$value'\n";
				} elsif (ref($value) =~ /::Diff$/) {
					# this happens for nested Diff objects, in <change>
					$report .= $value->report($name);
				} else {
					# this used to happen, for embedded objects, in <add> and <remove>
					die "this should not happen";
				}
			}
		} else {
			$report .= "$member = $diff_member\n";
		}
	}

	return $report;
}

sub abstract {
	my ($this) = @_;

	$this->recurse;
}

sub realize {
	my ($this) = @_;

	$this->recurse;
}

1
