package SKOS::Simple;
{
$SKOS::Simple::VERSION = '0.09_01';
}
#ABSTRACT: Create simple SKOS data with entailment
use strict;
use warnings;
use Scalar::Util qw(blessed reftype);
use Turtle::Writer;
use Carp;
=head1 DESCRIPTION
This module provides a simple class to create and handle classifications,
thesauri and similar systems in Simple Knowledge Organization System (SKOS)
data model. Most features of SKOS, as specified at
L<http://www.w3.org/TR/skos-reference/>, are supported. In addition there
are some useful constraints, which mostly derive from best-practice.
In contrast to other RDF-related modules, SKOS::Simple does not depend on
any non-core Perl modules, so you can install it by just copying one file.
The module implements basic entailment rules of the SKOS standard without
the burden of a full RDF reasoning engine. Actually, you can use this
module without having to deal with any details of RDF.
The current version of this class is optimized form creating and serializing
valid SKOS schemes, but not for reading and modifying them. A common use case
of SKOS::Simple is to transform a given terminology from some custom format
to SKOS, which is then L<serialized|/"SERIALIZATION METHODS"> in Terse RDF
Triple language (Turtle). You can then publish the Turtle data and/or process
them with general RDF and SKOS tools.
=head1 SYNOPSIS
my $skos = SKOS::Simple->new(
base => 'http://example.com/kos/',
title => 'My little Knowledge Organization System',
hierarchy => 'tree' # check classification constraints
);
$skos->addConcept( pref => { en => 'foo', ru => 'baz' } );
$skos->addConcept( notation => '42.X-23' );
print $skos->turtle;
=cut
use base 'Exporter';
our @EXPORT_OK = qw(skos);
our %NAMESPACES = (
rdf => 'http://www.w3.org/1999/02/22-rdf-syntax-ns#',
skos => 'http://www.w3.org/2004/02/skos/core#',
dc => 'http://purl.org/dc/elements/1.1/',
foaf => 'http://xmlns.com/foaf/0.1/',
void => 'http://rdfs.org/ns/void#',
dct => 'http://purl.org/dc/terms/',
xsd => 'http://www.w3.org/2001/XMLSchema#',
skosxl => 'http://www.w3.org/2008/05/skos-xl#',
owl => 'http://www.w3.org/2002/07/owl#',
);
=head1 SKOS CONFORMANCE
The following classes and properties from the SKOS vocabulary are supported.
The numbers in brackets (B<[Sxx]>) refer to integrity conditions from the
SKOS specification. Additional constraints are marked by numbers like B<[Cxx]>.
=over 4
=item L<Concepts|http://www.w3.org/TR/skos-reference/#concepts>
Instances of C<skos:Concept> B<[S1]> are not represented as objects but as
parts of a SKOS::Simple object, so every Concepts must belong to a Concept
Scheme B<[C1]>. You can attach Concepts to a scheme with L</addConcept>.
=item L<Concept Schemes|http://www.w3.org/TR/skos-reference/#notations>
Instances of C<skos:ConceptScheme> are implemented as objects of type
SKOS::Simple B<[S2]>. Concepts added to a scheme are automatically connected
to the scheme via C<skos:inScheme> B<[S3-S4]> (only serialized if requested).
Concepts can be selected as top concepts (C<skos:hasTopConcept> /
C<skos:topConceptOf> B<[S5-S8]>). In contrast to the SKOS specification,
(L<see 4.6.3|http://www.w3.org/TR/skos-reference/#L2446>) the top concepts
of a scheme cannot have broader concepts in the same scheme B<[C2]>.
Concepts and concept schemes must be disjoint B<[S9]>. This is ensured only
if you do not use a C<scheme> but a C<base> parameter.
=item L<Lexical Labels|http://www.w3.org/TR/skos-reference/#labels>
The label types C<skos:prefLabel>, C<skos:altLabel>, and C<skos:hiddenLabel>
are supported. In addition this module supports the label properties
C<dc:title> and C<dc:identifier>, which are not explicitly included in the
SKOS reference.
C<rdfs:label> as super-property of C<skos:prefLabel>, C<skos:altLabel>,
and C<skos:hiddenLabel> will be supported in a later version.
=item L<Notations|http://www.w3.org/TR/skos-reference/#notations>
Notations (C<skos:notation>) must be unique per concept and scheme
B<[C3]>.
=cut
our %LABEL_PROPERTIES = map { $_ => 1 } qw(prefLabel altLabel hiddenLabel);
our %LABEL_TYPES = (
pref => 'skos:prefLabel', # TODO: sub-property of rdfs:label
alt => 'skos:altLabel', # dito
hidden => 'skos:hiddenLabel', # dito
title => 'dc:title'
);
=item L<Semantic Relations|http://www.w3.org/TR/skos-reference/#semantic-relations>
So called "semantic" relations (C<skos:semanticRelation>) include
C<skos:broader>, C<skos:narrower>, and C<skos:related>.
The C<skos:broaderTransitive> and C<skos:narrowerTransitive> are currently
not supported.
With this module you can only model semantic relations between concepts
in the same scheme.
=cut
our %RELATION_PROPERTIES = map { $_ => 1 } qw(semanticRelation
broader narrower related broaderTransitive narrowerTransitive);
=item L<Documentation properties|http://www.w3.org/TR/skos-reference/#notes>
C<skos:note>, C<skos:changeNote>, C<skos:definition>, C<skos:editorialNote>,
C<skos:example>, C<skos:historyNote> and C<skos:scopeNote> can be used to
document concepts. In contrast to the SKOS specification their range is
limited to literal values B<[C4]>.
=cut
our %NOTE_PROPERTIES = map { $_ => 1 } qw(note
changeNote definition editorialNote example historyNote scopeNote);
=back
Concept Collections (C<skos:Collection>, C<skos:OrderedCollection>,
C<skos:member>, C<skos:memberList>) and SKOS extension for labels
(C<skosxl:Label> etc.) are not supported. Mapping Properties
(C<skos:mappingRelation>, C<skos:closeMatch>, C<skos:exactMatch>,
C<skos:broadMatch>, C<skos:narrowMatch>, C<skos:relatedMatch>) will
probably be implemented in another module.
=cut
our %MAPPING_PROPERTIES = map { $_ => 1 } qw(mappingRelation
closeMatch exactMatch broadMatch narrowMatch relatedMatch);
# dublin core elements
our %DC_PROPERTIES = map { $_ => "dc:$_" }
qw(contributor coverage creator date description format identifier
language publisher relation rights source subject title type);
# To add RDF data beyond the SKOS data model, you can use the
# L<serializing methods|/"EXPORTABLE FUNCTIONS">.
=head1 ADDITIONAL CONSTRAINTS
The current version of this module aims at classifications.
Support for thesauri will be implemented later.
An instance of SKOS::Simple holds exactely one skos:ConceptScheme with
the following properties:
=over 4
=item *
All concepts share a common URI base. By default this common prefix is
also the URI of the concept scheme as whole.
=item *
All concepts must be identifyable by a unique string, that is refered
to as the concept identifier. The URI of a concept is build of the
common URI prefix and the concept's identifier. The identifier must
either be the skos:notation (so every concept must have one), or the
skos:prefLabel in one fixed language for all concepts. The only exception
to this rule are filters, for instance to uri-encode the prefLabel/notation.
=item *
Empty strings as literal values are ignored. In most cases you can use
C<undef> and C<""> interchangeably.
=item *
All notations have the same Datatype URI (this may be changed).
=item *
The range of all documentation properties (C<skos:note>, C<skos:example>,
C<skos:scopeNote> etc.) is the plain literals instead of any resource.
=item *
I<...sure there are some more limitations...>
=back
=head1 METHODS
=head2 new( [ %properties ] )
Creates a new concept scheme with the following properties:
=over 4
=item base
The URI prefix that is used for all concepts (not required but recommended).
=item scheme
The URI of the whole concept scheme (C<skos:conceptScheme>).
By default the C<base> property is used as concept scheme URI.
=item title
Title(s) of the concept scheme. Must be either a string or a
hash that maps language tags to strings.
=item namespaces
An optional hash with additional namespaces. You can also override standard
namespaces (e.g. C<skos>). All namespaces explicitly specified by this
parameter are always included as C<< @prefix >> in the Turtle output.
=item language
Language tag of the default language. By default set to C<en>.
=item hierarchy
Either C<tree> or C<thesaurus> or the empty string for no hierarchy check
(default). At the moment only C<tree> is supported.
=item identity
Specifies which property is used as concept identifier. Possible
values are C<label> (C<skos:prefLabel>), C<notation> (C<skos:notation>,
and C<identifier> (C<dc:identifier>). If no value is given, you must
either specify C<label> or C<notation> as C<unique>.
=item label
Specifies how to encode concept labels. Possible values are C<pref>
(C<skos:prefLabel>), which is the default value and implied if
C<< identify => 'label' >>, C<alt> (C<skos:altLabel>,
C<hidden> (C<skos:hiddenLabel>) and C<title> (C<dc:title>).
=item notation
Specifies whether to check notations to be unique (C<unique>) and/or
mandatory (C<mandatory>) per concept. C<< identity => 'notation' >>
implies C<< notation => 'unique' >>.
=item properties
Additional properties as structured Turtle. Triples with predicates
C<a>, C<dc:title>, and C<skos:...> are not allowed but removed.
=item description
not supported yet.
=back
=cut
sub new {
my $class = shift;
my (%arg) = @_;
my $self = bless( {
concepts => { },
prop => { },
related => { },
top => { }, # ids of top concepts
u_notation => { },
u_label => { },
hierarchy => ($arg{hierarchy} || ""), # tree|thesaurus|
base => ($arg{base} || ""),
scheme => ($arg{scheme} || ""),
title => ($arg{title} || ""),
namespaces => ($arg{namespaces} || { }), # TODO: count usage (?)
language => ($arg{language} || "en"), # TODO: check tag
description => ($arg{description} || ""), # TODO: add
idescape => $arg{idescape} || sub { $_[0]; }, # TODO: uri-escape
identity => ($arg{identity} || ""),
label => ($arg{label} || ""), # label type
notation => ($arg{notation} || ""),
}, $class );
# TODO: croak "base of scheme missing" unless $self->{base};
croak "base must be an URI" unless uri_or_empty($self->{base});
croak "scheme must be an URI" unless uri_or_empty($self->{scheme});
$self->{scheme} = "" if $self->{scheme} eq $self->{base};
#### identifier, label, notation
if ( !$self->{identity} ) {
if ( $self->{label} eq 'unique' ) {
$self->{identity} = 'label';
} elsif ( $self->{notation} eq 'unique' ) {
$self->{identity} = 'notation';
} else {
# TODO: do we want this?
$self->{identity} = 'label';
# croak "concept identification not specified";
}
} elsif ( !(grep { $self->{identity} eq $_ } qw(label notation identifier)) ) {
croak "concept identification must be 'label', 'notation', or 'identifier'";
} # NOTE: we may add 'id' (internal id) as another method
if ( $self->{label} ) {
croak "label type must be one of " . join(", ", keys %LABEL_TYPES)
unless ( grep { $self->{label} eq $_ } keys %LABEL_TYPES );
} else {
$self->{label} = 'pref';
}
if ( $self->{notation} ) {
croak "notation type can only be 'unique' or 'mandatory'"
unless ( grep { $self->{notation} eq $_ } qw(unique mandatory) );
}
# mandatory namespaces
$self->{namespaces}->{skos} = $NAMESPACES{skos}
unless $self->{namespaces}->{skos};
$self->{namespaces}->{void} = $NAMESPACES{void}
if ( $arg{void} and not $self->{namespaces}->{void} );
$self->{namespaces}->{dc} = $NAMESPACES{dc}
if ( ($self->{title} || $self->{description}) && not $self->{namespaces}->{dc});
# Add default language, if title without language given
my $lang = $self->{language};
if ($self->{title} && not ref($self->{title}) && $lang) {
$self->{title} = { $lang => $self->{title} };
}
my @types = ('skos:ConceptScheme');
if ( my $pattern = delete $arg{idpattern} ) {
$self->{idregexp} = qr/^$pattern$/;
my $basepattern = $self->{base};
$basepattern =~ s/[.]/\\./g;
$basepattern =~ s/[?]/\\?/g; # TODO: escape more nasty stuff in base URI
$self->{idpattern} = "^$basepattern$pattern\$";
}
# TODO: license (dct:license)
if ( $arg{void} ) {
$self->{void} = 1; # TODO: document this
push @types, 'void:Dataset' if $arg{void};
$self->{prop}->{'void:uriSpace'} = turtle_uri($self->{base});
$self->{prop}->{'void:rootResource'} = turtle_uri($self->{base});
if ( $self->{idpattern} ) {
$self->{prop}->{'void:uriRegexPattern'} = turtle_literal($self->{idpattern});
}
}
# TODO: allow additional types
$self->{prop}->{a} = \@types;
# additional properties
if ( $arg{properties} ) {
my $p = $arg{properties};
my $a = delete $p->{a};
# TODO: also filter other namespaces and full URI forms
my @s = grep { $_ =~ /skos:/ } keys %$p;
delete $p->{$_} for @s;
while ( my ($key, $value) = each %$p ) {
$self->{prop}->{$key} = $value;
}
}
$self->{prop}->{'dc:title'} =
$self->{title} eq '' ? '' : turtle_literal_list( $self->{title} );
my $page = (delete $arg{page} || "");
$self->{prop}->{'foaf:page'} =
$page eq '' ? '' : turtle_uri( $page );
$self->{namespaces}->{foaf} = $NAMESPACES{foaf}
if ( $page ne "" and not $self->{namespaces}->{foaf} );
return $self;
}
sub _values {
# TODO: also allow hashref (?)
my @values = map { (reftype($_) && reftype($_) eq 'ARRAY') ? @$_ : $_ } @_;
@values = grep { $_ and $_ ne '' } @values;
return @values;
}
=head2 addConcept ( %properties )
Adds a concept with given properties. Only the identifying property to be
used as concept id (C<notation>, C<label>, C<identifier>, or C<id> ) is
mandatory. If there already is a concept with the same id, both are merged!
Returns the id of the added or modfied concept.
=cut
sub addConcept {
my $self = shift;
# ensures we have an 'id' and 'label' is a hashref
my $arg = $self->conceptentification( @_ );
my $id = $arg->{id};
my $lang = $self->{language};
# TODO: check: Concepts and concept schemes must be disjoint [S9].
# only for internal use
my $nocheck = delete $arg->{_nocheck};
# connections to other concepts
my @related = _values( delete $arg->{related} );
my @broader = _values( delete $arg->{broader} );
my @narrower = _values( delete $arg->{narrower} );
my $concept = $self->{concepts}->{$id};
unless ($self->{concepts}->{$id}) {
$concept = $self->{concepts}->{$id} = {
notation => "",
broader => { },
narrower => { },
related => { },
};
}
my $notation = delete $arg->{notation};
$notation = "" unless defined $notation;
my $identifier = delete $arg->{identifier};
if ( defined $identifier ) {
$concept->{identifier} = $identifier;
$self->{uses_dc} = 1;
}
if ( $self->{notation} ) { # 'mandatory' or 'unique'
$concept->{notation} = $notation
if ( defined $notation and $notation ne '' );
croak 'Concepts must have a notation'
if $concept->{notation} eq '';
if ( $self->{notation} eq 'unique' ) {
# TODO: check uniqueness, if notation is not already the idtype
# croak 'Concepts must be unique per notation'
# if $self->{u_notation}->{ $notation };
# $self->{u_notation}->{ $notation } = $id;
}
}
$concept->{notation} = $notation unless $notation eq "";
# add label properties
foreach my $type ( keys %LABEL_TYPES ) {
my $label = delete $arg->{$type};
next unless defined $label;
# TODO: add to existing labels, check for unqiueness, mandatory etc.
$concept->{$type} = $label;
}
# add documentation/note properties
foreach my $name ( keys %NOTE_PROPERTIES ) {
my @values = _values( delete $arg->{$name} );
if ( @values ) {
push @{ $concept->{$name} }, @values;
}
# TODO: entail skos:note
}
# additional constraint of SKOS::Simple
croak "concept <$id> cannot have broader if it is top concept!"
if ( @broader && $self->{top}->{$id} );
# add inverse relations
foreach my $i (@related) {
next if $concept->{related}->{$i};
$self->addConcept( related => $id, _nocheck => 1, id => $i )
unless $nocheck;
$concept->{related}->{$i} = 1;
}
foreach my $i (@broader) {
next if $concept->{broader}->{$i};
if ( $self->{hierarchy} eq 'tree' ) {
croak "tree property violated by <$id> skos:broader <$i>"
if %{$concept->{broader}};
} # TODO: if 'multi[tree]': detect loops
$self->addConcept( narrower => $id, _nocheck => 1, id => $i )
unless $nocheck;
$concept->{broader}->{$i} = 1;
}
foreach my $i (@narrower) {
next if $concept->{narrower}->{$i};
$self->addConcept( broader => $id, _nocheck => 1, id => $i )
unless $nocheck;
$concept->{narrower}->{$i} = 1;
}
return $id;
}
=head2 topConcepts ( [ @ids ] )
Marks one or more concepts as top concepts. The given concepts must
already exist and must not have any broader concepts. Without parameters,
this methods returns a list of all top concept identifiers. Unless you
explicitly specify top concepts, a list of I<all> concepts without broader
concepts is returned. As soon as you explicitly set some top concepts,
they will be the I<only> top concepts. You can reset the top concepts
to all concepts without broader concepts, provide C<undef> as only argument.
=cut
sub topConcepts {
my $self = shift;
unless ( @_ ) {
return keys %{ $self->{top} } if %{ $self->{top} };
return grep {
not %{$self->{concepts}->{$_}->{broader}}
} keys %{$self->{concepts}};
}
if ( @_ == 1 && not defined $_[0] ) {
$self->{top} = { };
return;
}
foreach my $id ( @_ ) {
croak "Unknown concept <$id>" unless $self->{concepts}->{$id};
next if $self->{top}->{$id};
croak "Concept <$id> must not have broader to be top concept"
if keys %{ $self->{concepts}->{broader} };
$self->{top}->{$id} = 1;
}
}
=head2 concept ( %properties )
Returns the identifier of a concept with given notation and/or label.
It is not checked whether the given concept exists in this scheme.
Returns either a string or an empty string if no identifier is given.
=cut
sub concept {
my $id = "";
eval {
my $arg = shift->conceptentification( @_ );
$id = $arg->{id};
};
return $id;
}
=head2 hasConcept ( $id | %properties )
Returns whether there is a concept of a given id. Instead of providing
a specific concept C<id> you can also use unique properties (C<notation>,
C<label>, C<identifier>) depending on the scheme's settings.
=cut
sub hasConcept {
my $self = shift;
my $id = (@_ == 1) ? $_[0] : $self->concept( @_ );
return exists $self->{concepts}->{$id}
if defined $id and $id ne "";
return 0;
}
=head2 concepts
Returns a list of all concept's ids.
=cut
sub concepts {
my $self = shift;
return keys %{ $self->{concepts} };
}
=head2 size
Returns the total number of concepts.
=cut
sub size {
my $self = shift;
return scalar keys %{ $self->{concepts} };
}
=head2 conceptentification ( %properties )
Checks and possibly expands some given concept properties to ensure that
there is a valid concept id. Returns a hashref that contains the concept
id (field C<id>) or croaks. Depending on the identification settings of
this scheme you must pass at least one of C<notation>, C<label>,
C<identifier>, C<id>.
=cut
sub conceptentification {
my ($self, %arg) = @_;
my $idtype = $self->{identity};
my $labeltype = $self->{label};
my $lang = $self->{language};
$arg{label} = '' unless defined $arg{label};
# rename 'label' parameter if given
if ( $arg{label} ne '' ) {
# TODO: what if arg{labeltype} is also given? better croak
$arg{$labeltype} = $arg{label};
}
# set a label's default language if only a string was given
# expand label property to be a hashref on undef
foreach my $type ( 'label', keys %LABEL_TYPES ) {
next unless defined $arg{$type} and $arg{$type} ne '';
unless ( ref($arg{$type}) ) { # HASH
if ( $arg{$type} eq "" ) {
delete $arg{$type};
} else {
$arg{$type} = { $lang => $arg{$type} };
}
}
}
$arg{id} = "" unless defined $arg{id};
$arg{$idtype} = "" unless defined $arg{$idtype};
if ( $arg{id} ne "" ) {
# derive property from id
if ( $idtype eq 'notation' or $idtype eq 'identifier' ) {
if ( $arg{$idtype} ne "" and $arg{$idtype} ne $arg{id} ) {
croak "concept id cannot be both '" . $arg{id}
. "' and '" . $arg{$idtype} . "'";
}
$arg{$idtype} = $arg{id};
} else { # $idtype eq 'label'
$arg{label} = { } if $arg{label} eq '';
my $l = $arg{label}->{$lang};
croak "concept id cannot be both '" . $arg{id} . "' and label '$l'"
if ( defined $l and $l ne "" and $l ne $arg{id} );
$arg{label}->{$lang} = $arg{id};
}
} else {
# derive id from property (TODO: url-encode if needed)
if ( $idtype eq 'notation' ) {
$arg{id} = $arg{notation};
} elsif ( $idtype eq 'identifier' ) {
$arg{id} = $arg{identifier};
} else { # $idtype eq 'label'
$arg{id} = $arg{$labeltype}->{ $lang } if $arg{$labeltype};
}
}
$arg{id} = $self->{idescape}->( $arg{id} );
if ( $self->{idregexp} ) {
croak "identifier " . $arg{id} . " does not fit to pattern"
unless $arg{id} =~ $self->{idregexp};
}
croak "Missing $idtype as concept identifier" if $arg{id} eq "";
# TODO: check $arg{id} for well-formedness as URI part
return \%arg;
}
=head2 addHashref ( $hashref )
experimental.
=cut
sub addHashref {
my ($self, $hash) = @_;
my $base = $self->{base}; # may be ""
# ignores all but the following predicates
my %predicates = (
$NAMESPACES{rdf}.'type' => 'a',
$NAMESPACES{dc}.'identifier' => 'id'
);
my @pnames = (
keys %NOTE_PROPERTIES,
keys %RELATION_PROPERTIES,
keys %LABEL_PROPERTIES, 'notation' );
foreach my $p (@pnames) {
$predicates{ $NAMESPACES{skos}.$p } = $p;
}
foreach my $subject ( keys %$hash ) {
my $subj = $subject;
next unless ($subj =~ s/^$base//);
# TODO: $self->{scheme} as subject
my %concept = (); # => $subj );
$concept{notation} = $subj; # TODO: remove
my $is_concept = 0; # TODO: check
foreach my $predicate ( keys %{$hash->{$subject}} ) {
my $p = $predicates{ $predicate } || next;
foreach my $object ( @{ $hash->{$subject}->{$predicate} } ) {
my $obj;
if ( $p =~ /^(narrower|broader)$/ ) {
next unless $object->{type} eq 'uri';
$obj = $object->{value};
#print "$obj\n";
next unless ($obj =~ s/^$base//);
push @{$concept{$p}}, $obj;
} elsif ( $p =~ /^(prefLabel)/ ) {
$obj = $object->{value}; # TODO: language
$concept{label} = $obj; # TODO: unique
} elsif ( $p eq 'definition' ) {
}
# TODO: map
#print "$subj $p\n";
}
}
if ( %concept ) {
$self->addConcept( %concept );
}
}
}
=head1 SERIALIZATION METHODS
The following methods serialize the concept scheme or parts of it in
L<Terse RDF Triple language|http://www.w3.org/TeamSubmission/turtle/>
(RDF/Turtle). A valid serialization must start with some namespace
declarations, and a base declaration. Both are only included by the
C<turtle> method, but they can also be requested independently.
All return values end with a newline unless it is the empty string.
A later version may also support 'hashref' format for serializing.
=head2 turtle ( [ %options ] )
Returns a full Turtle serialization of this concept scheme.
The return value is equivalent to calling C<turtleNamespaces>,
C<turtleBase>, C<turtleScheme>, and C<turtleConcepts>.
The parameter C<< lean => 1 >> enables a lean serialization, which
does not include infereable RDF statements. Other parameters are
passed to C<turtleScheme> and C<turtleConcepts> as well.
=cut
sub turtle {
my ($self,%opt) = @_;
return join( "\n",
$self->turtleNamespaces,
$self->turtleBase ,
$self->turtleScheme( %opt ) ,
$self->turtleConcepts( %opt ) );
}
=head2 turtleNamespaces
Returns Turtle syntax namespace declarations for this scheme.
=cut
sub turtleNamespaces {
my $self = shift;
if ( $self->{uses_dc} and not $self->{namespaces}->{dc} ) {
$self->{namespaces}->{dc} = $NAMESPACES{dc};
}
my @lines;
foreach my $name (keys %{$self->{namespaces}}) {
push @lines, "\@prefix $name: <" . $self->{namespaces}->{$name} . "> .";
}
return join("\n", @lines) . "\n";
}
=head2 turtleBase
Returns a Turtle URI base declaration for this scheme.
An empty string is returned if no URI base is set.
=cut
sub turtleBase {
my $self = shift;
return "" if $self->{base} eq "";
return "\@base <" . $self->{base} . "> .\n"
}
=head2 turtleScheme ( [ top => 0 ] )
Returns RDF statements about the concept scheme in Turtle syntax.
Details about concepts or namespace/base declarations are not included.
The option C<< top => 0 >> (enabled by default) can be used to supress
serializing the C<skos:hasTopConcept> property.
=cut
sub turtleScheme {
my ($self,%opt) = @_;
$opt{top} = 1 unless exists $opt{top};
# note that lean => 1 does not imply top => 0 !
if ( $opt{top} ) {
my @top = $self->topConcepts();
$self->{prop}->{'skos:hasTopConcept'} = [ map { "<$_>" } @top ];
} else {
delete $self->{prop}->{'skos:hasTopConcept'}
}
return turtle_statement( "<" . $self->{scheme} . ">", %{$self->{prop}} );
}
=head2 turtleConcept ( $id [, %options ] )
Returns a concept in Turtle syntax. With option C<< top => 0 >> you can disable
serializing the C<skos:topConceptOf> property. By default, each concept is
connected to its concept scheme with either C<skos:topConceptOf>, or with
C<skos:inScheme>. With option C<< scheme => 0 >> you can disable serializing
the latter property. With C<< scheme => 2 >> the property C<skos:inScheme>
is also included in the serialization if C<skos:topConceptOf> is given,
although the former can be derived as super-property of the latter.
=cut
sub turtleConcept {
my ($self,$id,%opt) = @_;
$opt{top} = 1 unless exists $opt{top};
$opt{top} = 0 if $opt{lean};
$opt{scheme} = 1 unless exists $opt{scheme};
my $c = $self->{concepts}->{$id};
my %stm = ( 'a' => 'skos:Concept' );
# TODO: Support multiple notations
if ( $c->{notation} ne '' ) {
$stm{'skos:notation'} = turtle_literal( $c->{notation} );
}
# Concept Labels: pref, alt, hidden, title
while ( my ($type,$property) = each %LABEL_TYPES ) {
next unless $c->{$type};
my $label = turtle_literal_list( $c->{$type} );
$stm{$property} = $label;
# TODO: entail rdfs:label if requested (pref, alt, hidden)
}
foreach my $rel (qw(broader narrower related)) {
next unless %{$c->{$rel}};
$stm{"skos:$rel"} = [ map { "<$_>" } keys %{$c->{$rel}} ];
}
my $is_top = 0;
if ( $opt{top} ) {
if ( (keys %{ $self->{top} }) ? $self->{top}->{$id} : not %{$c->{broader}} ) {
$stm{"skos:topConceptOf"} = "<" . $self->{scheme} . ">";
$is_top = 1;
}
}
# [S7] skos:topConceptOf is a sub-property of skos:inScheme
if ( $opt{scheme} - $is_top > 0 ) {
# TODO: with 'lean' => 1 and not top => 0
# this is implied if the concept is topConcept
$stm{'skos:inScheme'} = '<' . $self->{scheme} . '>';
}
if ( defined $c->{identifier} and $c->{identifier} ne "" ) {
$stm{'dc:identifier'} = turtle_literal( $c->{identifier} );
}
# TODO: S17 - infer skos:note only if requested
foreach my $name ( keys %NOTE_PROPERTIES ) {
next unless $c->{$name};
$stm{"skos:$name"} = turtle_literal_list( $c->{$name} );
}
return turtle_statement( "<$id>", %stm );
}
=head2 turtleConcepts ( [ %options ] )
Returns all concepts in Turtle syntax.
=cut
sub turtleConcepts {
my ($self,%opt) = @_;
delete $opt{id};
return join( "\n",
map { $self->turtleConcept( $_, %opt ) }
keys %{ $self->{concepts} } );
}
=head1 EXPORTABLE FUNCTIONS
=head2 skos
This is just a shortcut for C<< SKOS::Simple->new >>.
=cut
sub skos {
SKOS::Simple->new(@_)
}
=head2 is_uri ( $uri )
Copied from L<Data::Validate::URI>, originally by Richard Sonnen.
=cut
sub is_uri{
my $self = shift if ref($_[0]);
my $value = shift;
return unless defined($value);
# check for illegal characters
return if $value =~ /[^a-z0-9\:\/\?\#\[\]\@\!\$\&\'\(\)\*\+\,\;\=\.\-\_\~\%]/i;
# check for hex escapes that aren't complete
return if $value =~ /%[^0-9a-f]/i;
return if $value =~ /%[0-9a-f](:?[^0-9a-f]|$)/i;
# from RFC 3986
my($scheme, $authority, $path, $query, $fragment) =
($value =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|);
# scheme and path are required, though the path can be empty
return unless (defined($scheme) && length($scheme) && defined($path));
# if authority is present, the path must be empty or begin with a /
if(defined($authority) && length($authority)){
return unless(length($path) == 0 || $path =~ m!^/!);
} else {
# if authority is not present, the path must not start with //
return if $path =~ m!^//!;
}
# scheme must begin with a letter, then consist of letters, digits, +, ., or -
return unless lc($scheme) =~ m!^[a-z][a-z0-9\+\-\.]*$!;
# re-assemble the URL per section 5.3 in RFC 3986
my $out = $scheme . ':';
if(defined $authority && length($authority)){
$out .= '//' . $authority;
}
$out .= $path;
if(defined $query && length($query)){
$out .= '?' . $query;
}
if(defined $fragment && length($fragment)){
$out .= '#' . $fragment;
}
return $out;
}
=head2 uri_or_empty ( $uri )
Checks whether the passed parameter is either an URI or undefined.
=cut
sub uri_or_empty {
return (not defined $_[0] or $_[0] eq '' or is_uri($_[0]));
}
1;
=head1 SEE ALSO
The SKOS ontology and its semantics is defined in
L<http://www.w3.org/TR/skos-primer> and
L<http://www.w3.org/TR/skos-reference>. Turtle format
is specified at http://www.w3.org/TeamSubmission/turtle/.
See also L<Biblio::Thesaurus> for a similar module.
=cut