The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
#
# Tests for Data::Toolkit::Map in conjunction with Data::Toolkit::Entry

use strict;

use lib '../lib';

use Carp;
use Test::Simple tests => 21;

use Data::Toolkit::Entry;
use Data::Toolkit::Map;
use Data::Dumper;

my $verbose = 0;
ok (Data::Toolkit::Entry->debug($verbose) == $verbose, "Setting Entry debug level to $verbose");
ok (Data::Toolkit::Map->debug($verbose) == $verbose, "Setting Map debug level to $verbose");


my $map = Data::Toolkit::Map->new();
ok (($map and $map->isa( "Data::Toolkit::Map" )), "Create new Data::Toolkit::Map object");

my $entry = Data::Toolkit::Entry->new({ testMarker => 'xyzzy'});
ok (($entry and $entry->isa( "Data::Toolkit::Entry" )), "Create new Data::Toolkit::Entry object");

ok ($entry->add('surname',['Findlay']), "Add surname attribute");
ok ($entry->add('tele',['0111 222333444']), "Add tele attribute");
ok ($entry->add('fullname',['Andrew Findlay','A J Findlay','Dr A J Findlay']), "Add fullname attribute");

ok ( ($map->set('sn','surname') eq 'surname'), "Setting an attribute-to-attribute mapping");
my $list = $map->set('cn',['Andrew Findlay','A J Findlay']);
ok ( ((@$list) == 2), "Setting a fixed attribute mapping");

sub buildPhone {
	return ["+44 " . "1234 567890"];
}
ok ( $map->set('phone', \&buildPhone), "Setting a procedure mapping");
ok ( $map->set('mail', sub { return ["test" . '@' . "example.org"] }), "Setting a closure mapping");

ok (($map->generate('sn',$entry)->[0] eq 'Findlay'), "Generate using attribute mapping");
ok (($map->generate('cn',$entry)->[0] eq 'Andrew Findlay'), "Generate using fixed mapping");
ok (($map->generate('phone',$entry)->[0] eq '+44 1234 567890'), "Generate using procedure mapping");

sub normalisePhone {
	my $attrib = shift;
	my $entry = shift;

	my $phones = $entry->get('tele');

	my @result;
	while (my $phone = shift @$phones) {
		$phone =~ s/^0/+44 /;
		$phone =~ s/\(0\)//;
		push @result, $phone;
	}

	return \@result;
}
ok ( $map->set('phone', \&normalisePhone), "Resetting a procedure mapping");
# print "PHONE: " . $map->generate('phone',$entry)->[0] . "\n";
ok (($map->generate('phone',$entry)->[0] eq '+44 111 222333444'), "Generate using procedure mapping");

sub firstValue {
	my $source = shift;
	my $attrib = shift;
	my $entry = shift;

	my $list = $entry->get($source);
	return undef if !$list;
	return [ $list->[0] ];
}
ok ( $map->set('fn', sub { return firstValue( 'fullname', @_ ) } ), "Setting a complex closure mapping");
my $closeRes = $map->generate('fn',$entry);
# print "GOT: ", $closeRes->[0], "\n";

ok (( $closeRes->[0] eq 'A J Findlay'), "Closure mapping with parameters");

# print $entry->dump(), "\n";
# print "####\n";

# Data::Toolkit::Entry->debug(1);
# Data::Toolkit::Map->debug(1);

my $newEntry = $entry->map( $map );
# print $newEntry->dump(), "\n";

# print Dumper($newEntry->{config}), "\n";

# Note: this test prods inside the object: dont do it in real code!
ok ( ($newEntry->{config}->{testMarker} eq 'xyzzy'), "New entry contains copy of original config" );

#
# Check mapping where a procedure returns undef
#
my $ent2 = Data::Toolkit::Entry->new();
$ent2->set('att1', ['val1']);
$ent2->set('att2', ['val2']);

sub retNull {
	return undef;
}
my $map2 = Data::Toolkit::Map->new();
$map2->set('res1', 'att1');
$map2->set('res2', \&retNull);

# Apply map to entry, generating a new entry
my $ent3 = $ent2->map( $map2 );
# print Dumper($ent3), "\n";
ok ( ($ent3 and ($ent3->get('res1')->[0] eq 'val1')), "Basic test on map" );
ok ( ($ent3 and !defined($ent3->get('res2'))), "Test procedure returning null in map" );