1. Toby Inkster
  2. p5-moosex-semantic

Source

p5-moosex-semantic / lib / MooseX / Semantic / Util / SchemaImport.pm

package MooseX::Semantic::Util::SchemaImport;
use Data::Dumper;
use File::Path qw/ make_path /;
use File::Slurp;
use File::Temp qw/ tempfile tempdir /;
use Module::Load;
use Moose::Meta::Class;
use Moose;
use RDF::Query;
use RDF::Trine::Namespace qw(rdfs);
use RDF::Trine;
use Try::Tiny;

use MooseX::Semantic::Meta::Attribute::Trait;
use MooseX::Semantic::Types qw(TrineResource ArrayOfTrineResources UriStr TrineModel);

sub initialize_one_class_from_model {
    my ($factory_cls, %opts) = @_;
    my $model = $factory_cls->_get_model_for_opts( %opts );
    my $uri = $opts{uri};
    my $cls_to_load = $opts{type_map}->{$uri};
    $cls_to_load->meta->make_mutable;

    my @attributes;
    my $query_str = "
    PREFIX rdfs: <$rdfs>
    SELECT ?attr ?range WHERE { 
        ?attr rdfs:domain $uri . 
        ?attr rdfs:range ?range . 
        ?attr rdfs:label ?label .
        # ?attr ?prop ?obj . 
    }";
    my $query = RDF::Query->new( $query_str );
    my $iter = $query->execute($model);
    while (my $row = $iter->next) {
        # warn Dumper $row->{range};
        my $type;
        # TODO better type resolution, should at least calculate RDFS subtype entailments for range/domain
        if ($row->{range}->uri eq $rdfs->Literal->uri ) {
            # TODO or nothing TODO
            $type = 'Str';
        }
        else {
            # TODO map RDF 'maxOccurences' and 'minOccurences' to Moose
            # 'required' and ArrayRef or not ArrayRef
            if ($opts{type_map}->{ $row->{range} }){
                $type = sprintf 'ArrayRef[%s]', $opts{type_map}->{ $row->{range} };
            }
            else {
                $type = ArrayOfTrineResources;
            }
        }
        # TODO should be configurable probably
        my $attr_name = $row->{label} || $factory_cls->_get_short_name_from_url( $row->{attr} );
        # warn Dumper $attr_name;
        my $attribute = Moose::Meta::Attribute->new(
            $attr_name => (
                is => 'rw',
                isa => $type,
            )
        );
        MooseX::Semantic::Meta::Attribute::Trait->meta->apply($attribute);
        $attribute->uri( $row->{attr} );
        $cls_to_load->meta->add_attribute( $attribute );
        # warn sprintf 'Installed attribute for "%s" (%s)', $attr_name, $row->{attr} ;
    }
    $cls_to_load->meta->make_immutable;
}

sub initialize_classes_from_model {
    my ($factory_cls, %opts ) = @_;
    my $base_uri = $opts{base_uri};
    my %type_map = %{ $opts{type_map} || {} };


    # initialize classes - if they don't exist, create them
    while ( my ($uri, $cls_to_load) = each %type_map ) {
        try {
            load $cls_to_load;
        } catch {
            Moose::Meta::Class->initialize($cls_to_load)->superclasses("Moose::Object");
        };
        $opts{uri} = $uri;
        $factory_cls->initialize_one_class_from_model( %opts );
    }
}

# TODO
sub _get_short_name_from_url {
    my ($cls, $uri) = @_;
    $uri = UriStr->coerce( $uri );
    my ($last_segment) = ($uri =~ m!([^/#]+)$!);
    return $last_segment;
}

sub _get_model_for_opts {
    my ($factory_cls, %opts) = @_;
    my $model = $opts{model};
    my $parser = 'RDF::Trine::Parser';
    if ($opts{model_format}) {
        $parser = RDF::Trine::Parser->new( $opts{model_format} )
    }
    unless ($model) {
        $model = RDF::Trine::Model->temporary_model;
        if ($opts{model_uri}) {
            $parser->parse_url_into_model($opts{model_uri}, $model);
        }
        elsif ($opts{model_file}) {
            $parser->parse_file_into_model($opts{base_uri}, $opts{model_file}, $model);
        }
        elsif ($opts{model_string}) {
            $parser->parse_into_model( $opts{base_uri}, $opts{model_string}, $model);
        }
        else {
            die "Need model to import classes from!";
        }
    }
    return $model;
}

__PACKAGE__->meta->make_immutable;
1;