Commits

Konstantin Baierer  committed 317f854

improved type hierarchy lookup, test module

  • Participants
  • Parent commits 7149ad8

Comments (0)

Files changed (6)

File lib/MooseX/Semantic/Role/RdfImport.pm

         elsif ( $cls->_find_parent_type( $attr_type, 'Object' )
                 || $cls->_find_parent_type( $attr_type, 'ClassName' )) {
 
-            my $attr_type_cls = $cls->_find_parent_type( $attr_type, $does_resource, undef );
+            my $attr_type_cls = $cls->_find_parent_type( $attr_type, $does_resource );
             my $recursive_inst_hash = $cls->_instantiate_one_object(
                 $model, $values[0], $attr_type_cls, $unfinished_resources
             );
             # which is (one level higher) ArrayRef[Something] and Something->does('...')
             # should make _find_parent_type more flexible
             if ( ! $attr_type->can('type_parameter')
-                || $attr_type->type_parameter eq 'Str'
-                || $cls->_find_parent_type( $attr_type->type_parameter, 'Num' )
-                || $cls->_find_parent_type( $attr_type->type_parameter, 'Bool' ))
+                || $cls->_find_parent_type( $attr_type->type_parameter, 'Str', max_depth=>0 )
+                || $cls->_find_parent_type( $attr_type->type_parameter, ['Num', 'Bool'] ))
             {
+            # if ($self->_find_parent_type(
                 $inst_hash->{$attr_name} = [@literal_values];
             }
-            elsif ( $cls->_find_parent_type( $attr_type->type_parameter, 'Object' ) 
+            elsif ( $cls->_find_parent_type( $attr_type->type_parameter, ['Object', 'ClassName'] ) 
                 || $cls->_find_parent_type( $attr_type->type_parameter, 'ClassName' ) ) {
 
-                my $subtype_cls = $cls->_find_parent_type( $attr_type, $does_resource, 1 );
+                my $subtype_cls = $cls->_find_parent_type( $attr_type, $does_resource, look_vertically => 1 );
                 $inst_hash->{$attr_name} = [
                     grep { defined $_ }
                         map { $cls->_instantiate_one_object(

File lib/MooseX/Semantic/Test.pm

+package MooseX::Semantic::Test;
+use RDF::Trine;
+use Term::ANSIColor;
+use String::Diff;
+use Data::Dumper;
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(ser ser_dump diff_models Dumper);  # symbols to export on request
+my ($red, $green, $reset) = map {color $_} qw(red green reset);
+%String::Diff::DEFAULT_MARKS = (
+        remove_open  => $red,
+        remove_close => $reset,
+        append_open  => $green,
+        append_close => $reset,
+        separator => '',
+    # separator    => '<-OLD|NEW->', # for diff_merge
+);
+
+sub ser {
+    my $format = shift || 'ntriples';
+    return RDF::Trine::Serializer->new($format);
+}
+sub ser_dump {
+    my $model = shift;
+    my $format = shift || 'ntriples';
+    ser->serialize_model_to_string( $model );
+}
+# warn Dumper( color 'blue' );
+sub diff_models {
+    my ($m1, $m2) = sort {$a->size < $b->size} @_;
+    my ($m1_str, $m2_str) = map{ser_dump($_)} $m1, $m2;
+    # my ($m1_str_lines, $m2_str_lines) = map{[split "\n", $_]} $m1_str, $m2_str;
+    # my ( $m1_lines, $m2_lines ) = map {
+        # my $m = $_;
+        # [ map { ser_dump($m) } split( '\n', $_ ) ]
+    # } $m1_str, $m2_str;
+    # warn Dumper $m2_str_lines;
+    my $diff = String::Diff::diff_merge($m1_str, $m2_str);
+    print $diff;
+}
+
+1;

File lib/MooseX/Semantic/Util/TypeConstraintWalker.pm

 use Data::Dumper;
 
 sub _find_parent_type {
-    my ($self, $attr_or_type_constraint, $needle, $look_vertically) = @_;
+    my ($self, $attr_or_type_constraint, $needle, %opts) = @_;
+    return unless $attr_or_type_constraint;
 
-    my ($attr, $type_constraint);
-    if (ref $attr_or_type_constraint eq 'Moose::Meta::Attribute') {
-        $attr = $attr_or_type_constraint;
-        return $self->_find_parent_type( $attr->type_constraint, $needle, $look_vertically );
+    $opts{match_all} //= 1;
+    $opts{match_any} //= 1;
+
+    my ($attr, $attr_name, $type_constraint);
+    my $type_ref = ref $attr_or_type_constraint;
+
+    if (ref $needle && ref ($needle) eq 'ARRAY') {
+        my $needles_searched_size = scalar @{$needle};
+        my @needles_matched = grep {$self->_find_parent_type($attr_or_type_constraint, $_, %opts)} @{$needle};
+        if ($opts{match_any}) {
+            return @needles_matched;
+        }
+        if ($opts{match_all}){
+            return $needles_searched_size == scalar @needles_matched;
+        }
+        # TODO
+        # return @needles_matched;
     }
-    elsif (ref $attr_or_type_constraint eq 'Moose::Meta::TypeConstraint'
-        || ref $attr_or_type_constraint eq 'Moose::Meta::TypeConstraint::Class'
-        || ref $attr_or_type_constraint eq 'Moose::Meta::TypeConstraint::Parameterized'
-        || ref $attr_or_type_constraint eq 'Moose::Meta::TypeConstraint::Parameterizable'
-        || ref $attr_or_type_constraint eq 'Moose::Meta::TypeConstraint::Role'
-    ) {
+
+    if ( ! ref $attr_or_type_constraint ) {
+        return unless $self->meta->has_attribute($attr_or_type_constraint);
+        $type_constraint = $self->meta->get_attribute($attr_or_type_constraint)->type_constraint;
+    }
+    elsif ($type_ref eq 'Moose::Meta::Attribute') {
+        $type_constraint = $attr_or_type_constraint->type_constraint;
+    }
+    elsif ($type_ref =~ m'^Moose::Meta::TypeConstraint') {
         $type_constraint = $attr_or_type_constraint;
-        my $type_name = $type_constraint->name;
-        if ($look_vertically && $type_constraint->can('type_parameter') && $type_constraint->type_parameter) {
-            return $self->_find_parent_type( $type_constraint->type_parameter, $needle, $look_vertically );
-        }
-        if (ref $needle && ref ($needle) eq 'CODE'){
-            if ($type_name->can('does') && $needle->( $type_constraint->name )) {
-                return $type_constraint->name 
-            }
-        }
-        elsif ($type_constraint->name eq $needle) {
-            return $needle;
-        }
-
-        if ($type_constraint->has_parent) {
-            return $self->_find_parent_type($type_constraint->parent, $needle, $look_vertically );
-        }
-        else {
-            return;
+    }
+    else {
+        # warn ref $attr_or_type_constraint;
+        # warn $attr_or_type_constraint;
+        return;
+    }
+    if ($opts{look_vertically}) {
+        if ($type_constraint->can('type_parameter') && $type_constraint->type_parameter) {
+            $type_constraint = $type_constraint->type_parameter;
         }
     }
+    return $self->_find_parent_type_for_type_constraint( $type_constraint, $needle, %opts );
+}
+
+sub _find_parent_type_for_type_constraint {
+    my ($self, $type_constraint, $needle, %opts) = @_;
+    $opts{max_depth} = 9999 unless defined $opts{max_depth};
+    $opts{max_width} = 9999 unless defined $opts{max_width};
+    $opts{current_depth} = 0 unless $opts{current_depth};
+    $opts{current_width} = 0 unless $opts{current_width};
+    # warn Dumper $type_constraint->name;
+    # warn Dumper \%opts;
+    # warn Dumper $opts{current_depth};
+
+    if (   ( $opts{current_depth} > $opts{max_depth} )
+        || ( $opts{current_width} > $opts{max_width} ) )
+    {
+        return;
+    }
+    $opts{current_depth}++;
+
+    my $type_name = $type_constraint->name;
+    if ($opts{look_vertically} && $type_constraint->can('type_parameter') && $type_constraint->type_parameter) {
+        $opts{current_width}++;
+        return $self->_find_parent_type_for_type_constraint( $type_constraint->type_parameter, $needle, %opts );
+    }
+    if (ref $needle && ref ($needle) eq 'CODE'){
+        if ($type_name->can('does') && $needle->( $type_constraint->name )) {
+            return $type_constraint->name 
+        }
+    }
+    elsif ($type_constraint->name eq $needle) {
+        return $needle;
+    }
+    if ($type_constraint->has_parent) {
+        return $self->_find_parent_type_for_type_constraint($type_constraint->parent, $needle, %opts );
+    }
     else {
-        warn ref $attr_or_type_constraint;
+        return;
     }
 }
 
-sub _find_parent_type_by_name {
-    my $self = shift;
-    my ($attr_name, $needle, $look_vertically) = @_;
-    my $attr = $self->meta->get_attribute($attr_name);
-    return unless $attr;
-    return $self->_find_parent_type( $attr, $needle, $look_vertically );
-}
-# sub _find_parent_subtype_by_name {
-#     my $self = shift;
-#     my ($attr_name, $needle) = @_;
-
-#     my $attr = $self->meta->get_attribute($attr_name);
-    # return unless $attr;
-    # warn "I LIVE 1";
-    # return unless $attr->type_constraint;
-    # warn "I LIVE 2";
-    # return unless $attr->type_constraint->can('type_parameter');
-    # warn "I LIVE 3";
-    # return unless $attr->type_constraint->type_parameter;
-    # warn "I LIVE 4";
-#     return $self->_find_parent_type( $attr->type_constraint->type_parameter, $needle );
-# }
-
-# sub _find_innermost_subtype {
-#     my ($self, $type_constraint) = @_;
-#     if ($type_constraint->can('type_parameter')
-#         && $type_constraint->type_parameter ) {
-#         return $self->_find_innermost_subtype( $type_constraint->type_parameter );
-#     }
-#     return $type_constraint;
-
-# sub _find_innermost_subtype_by_attr_name {
-#     my $self = shift;
-#     my ($attr_name) = @_;
-
-#     my $attr = $self->meta->get_attribute($attr_name);
-#     return $self->_find_innermost_subtype( $attr->type_constraint );
-# }
-
-# sub _find_parent_roleprovider {
-#     my $self = shift;
-#     my ($obj, $attr_name, $role) = @_;
-# }
 
 1;

File t/rdf_import/subtyped.t

+use Test::More tests => 1;
+use Test::Moose;
+use RDF::Trine;
+use Data::Dumper;
+use MooseX::Semantic::Test::Person;
+
+{ 
+    package PersonWithSubtypes;
+    use Moose;
+    use Moose::Util::TypeConstraints;
+    with ( 'MooseX::Semantic::Role::RdfImport', 'MooseX::Semantic::Util::TypeConstraintWalker',) ;
+    subtype 'LevelOne', as 'MooseX::Semantic::Test::Person';
+    subtype 'LevelTwo', as 'LevelOne';
+    subtype 'LevelThree', as 'LevelTwo';
+    subtype 'LevelFour', as 'LevelThree';
+    subtype 'ArrayOfLevelFour', as 'ArrayRef[LevelFour]';
+    subtype 'ArrayTooDeep', as 'ArrayRef[ArrayOfLevelFour]';
+    # subtype '
+    has semantic => (
+        is => 'rw',
+        isa => 'ArrayOfLevelFour'
+    );
+    has not_semantic => (
+        is => 'rw',
+        isa => 'ArrayTooDeep',
+    );
+    has also_semantic => (
+        is => 'rw',
+        isa => 'ArrayTooDeep',
+    );
+    1;
+}
+my $pkg = 'MooseX::Semantic::Test::Person';
+my $dontcare = $pkg->new;
+my $p = PersonWithSubtypes->new(
+    semantic=> [$dontcare],
+    not_semantic => [[$dontcare]],
+);
+ok( !$p->_find_parent_type( 'semantic', $pkg ),
+    'fail: without look_vertically' );
+ok( $p->_find_parent_type( 'semantic', $pkg,
+        look_vertically => 1 
+    ), 'win:  look_vertically => 1' 
+);
+ok( ! $p->_find_parent_type( 'semantic', $pkg,
+        look_vertically => 0,
+        max_depth => 5 
+    ), "fail: max_depth = 5, look_vertically = 0"
+);
+ok( $p->_find_parent_type( 'semantic', $pkg,
+        look_vertically => 1,
+        max_depth => 6 
+    ), "win: max depth = 6"
+);
+ok( ! $p->_find_parent_type( 'not_semantic', $pkg,
+        look_vertically => 0,
+    ), "fail: look_vertically = 0"
+);
+ok( ! $p->_find_parent_type( 'not_semantic', $pkg,
+        look_vertically => 0,
+    ), "fail: look_vertically = 1"
+);
+ok( $p->_find_parent_type( 'not_semantic', $pkg,
+        look_vertically => 1,
+        max_depth => 8 
+    ), "win: max_depth = 2, look_vertically = 1"
+);
+ok( $p->_find_parent_type( 'not_semantic', $pkg,
+        look_vertically => 1,
+    ), "win: look_vertically = 1"
+);
+ok( ! $p->_find_parent_type( 'not_semantic', $pkg,
+        look_vertically => 1,
+        max_width => 1,
+    ), "fail: look_vertically = 1"
+);
+ok( $p->_find_parent_type( 'not_semantic', $pkg,
+        look_vertically => 1,
+        max_width => 2,
+    ), "win: look_vertically = 2"
+);
+ok( $p->_find_parent_type( 'semantic', [qw(LevelTwo LevelThree)],
+        look_vertically => 1,
+        match_all => 1
+    ), "win: array matched all"
+);
+ok( ! $p->_find_parent_type( 'semantic', [qw(LevelTwo LevelThree NOFOUND)],
+        look_vertically => 1,
+        # max_width => 2,
+        match_any => 0,
+    ), "win array matched"
+);
+ok( $p->_find_parent_type( 'semantic', [qw(LevelTwo LevelThree NOFOUND)],
+        look_vertically => 1,
+        match_any => 1,
+    ), "win: array not all matched, but match_any = 1"
+);

File t/role_rdfimport.t

 use RDF::Trine;
 use Data::Dumper;
 use MooseX::Semantic::Test::Person;
+use MooseX::Semantic::Test qw(ser ser_dump diff_models);
 
 
 sub import_from_ttl {
     is( $person->generic_one_to_one_relation->rdf_about->uri, 'http://kasei.us/about/foaf.xrdf#greg', 'Object created');
     ok( !  $person->generic_one_to_one_relation->is_blank,, "Greg isn't a blank node");
 
-    # my $serializer = RDF::Trine::Serializer->new('ntriples');
-    # my $old_size = $serializer->serialize_model_to_string($test_model)->size;
+    ok(my $got_model = $person->export_to_model);
+
+    my $test_model_str = ser_dump($test_model);
+    # my $got_model_str = ser->serialize_model_to_string($got_model);
+    # warn Dumper [$test_model_str, $got_model_str];
+    diff_models($test_model, $got_model);
     my $old_size = $test_model->size;
-    my $new_size = $person->export_to_model->size;
+    my $new_size = $got_model;
     TODO: {
-        is($old_size - 1, $new_size, 'Same number of statements after round-trip (sans information lost on multiple values)');
+        cmp_ok($new_size, '>=', $old_size, 'Same number of statements after round-trip (sans information lost on multiple values)');
     }
 }
 
     ok( my $alice = MooseX::Semantic::Test::Person->new_from_model( $test_model, $base_uri . 'F' )
         , 'Alice can be loaded from RDF');
     ok( my $alice_model_str = $alice->export_to_string(format=>'ntriples') );
-    warn Dumper $alice_model_str;
+    # warn Dumper $alice_model_str;
 }
 
 &import_from_ttl;

File t/util_walker.t

-use Test::More tests => 6;
+use Test::More tests => 5;
 use Data::Dumper;
 use RDF::Trine qw(iri);
 use MooseX::Semantic::Test::Person;
     }
     my $f = Foo->new;
     # by attr
-    is( $f->_find_parent_type( $f->meta->get_attribute('val'), 'RefXYZ' ), undef, 'Invalid Type') ;
-    is( $f->_find_parent_type( $f->meta->get_attribute('val'), 'Ref' ), 1, 'Reference') ;
+    ok( ! $f->_find_parent_type( $f->meta->get_attribute('val'), 'RefXYZ' ), 'Invalid Type') ;
+    ok( $f->_find_parent_type( $f->meta->get_attribute('val'), 'Ref' ), 'Reference') ;
     # by type_constraint
-    is( $f->_find_parent_type( $f->meta->get_attribute('val')->type_constraint, 'Ref' ), 1, 'Reference') ;
+    ok( $f->_find_parent_type( $f->meta->get_attribute('val')->type_constraint, 'Ref' ), 'Reference') ;
     # by object and attr_name
-    is( $f->_find_parent_type_by_name( 'val', 'Ref' ), 1, 'Reference') ;
+    ok( $f->_find_parent_type( 'val', 'Ref' ), 'Reference') ;
     # warn Dumper $f->_find_parent_type( $f->meta->get_attribute('val'), 'RefZ' );
 }
 
     }
 
     my $b = Bar->new( val => [MooseX::Semantic::Test::Person->new] );
-    my $does_resource = sub { shift->can('does') && does('MooseX::Semantic::Role::Resource'); };
-    is ($b->_find_parent_type_by_name('val', $does_resource, 1), 'MooseX::Semantic::Test::Person');
+    my $does_resource = sub {my $a= shift;$a->can('does') && $a->does('MooseX::Semantic::Role::Resource'); };
+
+    is ($b->_find_parent_type('val', $does_resource, look_vertically => 1), 'MooseX::Semantic::Test::Person');
     # warn Dumper $does_resource->("MooseX::Semantic::Test::Person");
     # warn Dumper "MooseX::Semantic::Test::Person"->does('MooseX::Semantic::Role::Resource');
     # warn Dumper $b;