JSONLD-0.005/ 000755 000765 000024 00000000000 13765312101 012575 5 ustar 00greg staff 000000 000000 JSONLD-0.005/inc/ 000755 000765 000024 00000000000 13765312076 013361 5 ustar 00greg staff 000000 000000 JSONLD-0.005/SIGNATURE 000644 000765 000024 00000004711 13765312101 014064 0 ustar 00greg staff 000000 000000 This file contains message digests of all files listed in MANIFEST,
signed via the Module::Signature module, version 0.81.
To verify the content in this distribution, first make sure you have
Module::Signature installed, then type:
% cpansign -v
It will check each file's integrity, as well as the signature's
validity. If "==> Signature verified OK! <==" is not displayed,
the distribution may already have been compromised, and you should
not run its Makefile.PL or Build.PL.
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
SHA1 383921a327fba5996d53a5670b60552cea2410ce Changes
SHA1 9352b8d24a802ce693ffc882e2a950140b42c862 MANIFEST
SHA1 61ad6eb44b73aa8528b890b6a0a6ff23e95bacd2 META.yml
SHA1 bd5b70b536496c33dc46830b4217535fc2ce6ec8 Makefile.PL
SHA1 aa9cf00713b223e48bed2d689b4088863eb7c7f9 README.md
SHA1 98c7471eea1dc975c7fb0c23429360709af667d9 bin/jsonld-compact
SHA1 bcc660197d0dbef42a7cb27b86d3f18543c0da28 bin/jsonld-expand
SHA1 9f330f63a8f5c0a0a77ea34231ffc01aed4de2a3 bin/jsonld-nq
SHA1 c3f8f9f2a209f80b7ca3c8af3a6b1b7b408ad620 inc/Module/Install.pm
SHA1 d001b4b9a48395a8c4134b234a0e1789138427c5 inc/Module/Install/AuthorTests.pm
SHA1 de30b539a326675c42e6ad360fddb05902d621be inc/Module/Install/Base.pm
SHA1 81fffeca82bcd7100d8435b139f0780fcc5cdf9c inc/Module/Install/Can.pm
SHA1 470809a1dbe03e197e74dde79c6af40b5f7f9b26 inc/Module/Install/DOAPChangeSets.pm
SHA1 b4dd9cb3cf0cb60390c575bd3405e2297d4a0b1a inc/Module/Install/Fetch.pm
SHA1 b84cf97b12f8e5ef37bea54e33ddce32dff804d1 inc/Module/Install/Makefile.pm
SHA1 0d9fd69718198fcd1560214c4f23fcaa44f8395e inc/Module/Install/Metadata.pm
SHA1 78f307119470d0c85d7d6496e76fc95cb939b462 inc/Module/Install/Scripts.pm
SHA1 99b8179fbd9e05422b161cf91abe198744188064 inc/Module/Install/Win32.pm
SHA1 6a91e14bbecc64e9c8e2261dfa4b360641d152e4 inc/Module/Install/WriteAll.pm
SHA1 b91aec4bdfd19e5f88e401fc319103342b89d811 lib/JSONLD.pm
SHA1 51ee239931a92a3be64fb21b50cce4c4d9d932a6 meta/changes.ttl
SHA1 b366e7addb62f2915ae0a13ba50ad28188c33f63 t/00.load.t
SHA1 8d62325b1ec6fcadd2237bbb698ade4ffaa54df4 t/simple.t
SHA1 a6f82497ea87a646305a407bbb1b126b420173c3 xt/compact.t
SHA1 17c83eb9789ff167ea1ad6ebe8a5c8f80af683f8 xt/earl.pl
SHA1 c6d9bd4c7fa83453df76a7e9f140adbfafa86983 xt/expand.t
SHA1 fbb88a9a40c21568b6d5ee2f477dcf1546932977 xt/to-rdf.t
-----BEGIN PGP SIGNATURE-----
Comment: GPGTools - http://gpgtools.org
iEYEARECAAYFAl/VlD4ACgkQhPK6VMqoyC2khgCgmLLB3wJUeKWW7nW4GLKDT4hx
e7sAn06PSsbFVRhsBorGrJIFT75pkHBY
=nx9g
-----END PGP SIGNATURE-----
JSONLD-0.005/bin/ 000755 000765 000024 00000000000 13765312076 013360 5 ustar 00greg staff 000000 000000 JSONLD-0.005/Changes 000644 000765 000024 00000001350 13765312063 014076 0 ustar 00greg staff 000000 000000 JSONLD
======
Created: 2019-10-28
Home page:
Bug tracker:
0.005 2020-12-12
- (Update) Fix package metadata (#4).
- (Update) Fix version references in README.md (#5).
0.004 2020-05-17
- (Update) Allow specifying a context file on the command line for
jsonld-expand.
- (Update) Improve handling of invalid JSONLD input.
- (Update) Track changes in the JSONLD spec.
- (Update) Use new IRI->rel method.
0.003 2020-03-08
- (Update) Remove use of Debug::ShowStuff for releases.
- (Update) Version number bump to fix PAUSE issues.
0.002 2020-01-26
- (Update) Updated documentation.
0.001 2020-01-25
- (Addition) First release.
JSONLD-0.005/MANIFEST 000644 000765 000024 00000001166 13765312076 013745 0 ustar 00greg staff 000000 000000 bin/jsonld-compact
bin/jsonld-expand
bin/jsonld-nq
Changes
inc/Module/Install.pm
inc/Module/Install/AuthorTests.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/DOAPChangeSets.pm
inc/Module/Install/Fetch.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/Scripts.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/JSONLD.pm
Makefile.PL
MANIFEST This list of files
META.yml
meta/changes.ttl
README.md
t/00.load.t
t/simple.t
xt/earl.pl
xt/compact.t
xt/expand.t
xt/to-rdf.t
SIGNATURE Public-key signature (added by MakeMaker)
JSONLD-0.005/meta/ 000755 000765 000024 00000000000 13765312076 013536 5 ustar 00greg staff 000000 000000 JSONLD-0.005/t/ 000755 000765 000024 00000000000 13765312076 013053 5 ustar 00greg staff 000000 000000 JSONLD-0.005/xt/ 000755 000765 000024 00000000000 13765312076 013243 5 ustar 00greg staff 000000 000000 JSONLD-0.005/PaxHeader/README.md 000644 000765 000024 00000000036 13764470423 016037 x ustar 00greg staff 000000 000000 30 mtime=1607627027.601738589
JSONLD-0.005/README.md 000644 000765 000024 00000005210 13764470423 014065 0 ustar 00greg staff 000000 000000 # JSONLD
## A Perl toolkit for interacting with JSON-LD data.
## VERSION
This document describes JSONLD version 0.004_01.
## SYNOPSIS
### Command Line Tools
% jsonld-expand input.jsonld
Prints the JSON-LD 1.1 *expansion* of the data in `input.jsonld` to standard out.
% jsonld-compact input.jsonld
Prints the JSON-LD 1.1 *compaction* of the data in `input.jsonld` to standard out.
% jsonld-nq input.jsonld
Prints the JSON-LD 1.1 *deserialization* of the data in `input.jsonld` to standard out in the N-Quads format.
### JSON-LD Perl API
use v5.14;
use JSON qw(decode_json);
use JSONLD;
my $infile = 'test.jsonld';
open(my $fh, '<:utf8', $infile) or die $!;
my $content = do { local($/); <$fh> };
my $data = decode_json($content);
my $jld = JSONLD->new();
my $expanded = $jld->expand($data);
## DESCRIPTION
This module implements part of the JSON-LD 1.1 standard for manipulating JSON
data as linked data.
This version provides full support for the JSON-LD 1.1 "Expansion" and
"toRdf" transformations (the latter primarily being useful through a subclass
of JSON-LD, such as that provided by L).
Partial support for the "Compaction" transformation is provided, but it
contains many known deficiencies. Full support for "Compaction" may be
forthcoming in a future release.
No other JSON-LD transformation are supported at this time.
## METHODS
`expand( $data )`
Returns the JSON-LD expansion of `$data`.
`to_rdf( $data )`
Returns the dataset generated by turning the JSON-LD expansion of
`$data` into RDF.
Note: this method must be called on a `JSONLD` subclass which
implements the RDF-related methods listed below.
See [AtteanX::Parser::JSONLD](https://metacpan.org/pod/AtteanX::Parser::JSONLD)
for an implementation of such a subclass.
* `default_graph()`
* `new_dataset()`
* `new_triple($s, $p, $o)`
* `new_quad($s, $p, $o, $g)`
* `new_iri($value)`
* `new_graphname($value)`
* `new_blank( [$id] )`
* `new_lang_literal($value, $lang)`
* `new_dt_literal($value, $datatype)`
* `add_quad($quad, $dataset)`
## BUGS
Please report any bugs or feature requests to through the GitHub web
interface at .
## SEE ALSO
*
* [AtteanX::Parser::JSONLD](https://metacpan.org/pod/AtteanX::Parser::JSONLD)
*
*
*
## AUTHOR
Gregory Todd Williams
## COPYRIGHT
Copyright (c) 2019--2020 Gregory Todd Williams. This program is free
software; you can redistribute it and/or modify it under the same terms
as Perl itself.
JSONLD-0.005/META.yml 000644 000765 000024 00000001747 13765312064 014067 0 ustar 00greg staff 000000 000000 ---
abstract: 'A toolkit for transforming JSON-LD data.'
author:
- 'Gregory Todd Williams C<< >>'
- 'Gregory Todd Williams '
build_requires:
Attean: 0
ExtUtils::MakeMaker: 6.59
Test::Exception: 0
Test::Modern: 0.012
Test::More: 0.88
configure_requires:
ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
generated_by: 'Module::Install version 1.19'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: JSONLD
no_index:
directory:
- inc
- t
- xt
requires:
Clone: 0
IRI: 0.01
JSON: 4.02
LWP: 0
LWP::Protocol::https: 0
List::Util: 1.33
Moo: 0
namespace::clean: 0
perl: 5.14.0
resources:
IRC: irc://irc.perl.org/#perlrdf
bugtracker: https://github.com/kasei/perl-jsonld/issues
homepage: http://search.cpan.org/dist/JSONLD/
license: http://dev.perl.org/licenses/
repository: http://github.com/kasei/perl-jsonld/
version: '0.005'
JSONLD-0.005/lib/ 000755 000765 000024 00000000000 13765312076 013356 5 ustar 00greg staff 000000 000000 JSONLD-0.005/Makefile.PL 000644 000765 000024 00000001730 13643711016 014553 0 ustar 00greg staff 000000 000000 use strict;
use warnings;
use lib '.';
use inc::Module::Install;
name 'JSONLD';
all_from 'lib/JSONLD.pm';
author 'Gregory Todd Williams ';
license 'perl';
test_requires 'Test::More' => 0.88;
test_requires 'Test::Exception' => 0;
test_requires 'Test::Modern' => 0.012;
test_requires 'Attean' => 0;
perl_version '5.014';
requires 'Clone' => 0;
requires 'IRI' => 0.010;
requires 'List::Util' => 1.33;
requires 'JSON' => 4.02;
requires 'LWP' => 0;
requires 'LWP::Protocol::https' => 0;
requires 'Moo' => 0;
requires 'namespace::clean' => 0;
resources(
'homepage' => "http://search.cpan.org/dist/JSONLD/",
'repository' => "http://github.com/kasei/perl-jsonld/",
'bugtracker' => "https://github.com/kasei/perl-jsonld/issues",
'IRC' => "irc://irc.perl.org/#perlrdf",
);
author_tests('xt');
install_script glob('bin/*');
write_doap_changes "meta/changes.ttl", "Changes", "turtle";
sign;
WriteAll;
JSONLD-0.005/lib/PaxHeader/JSONLD.pm 000644 000765 000024 00000000036 13765311746 016660 x ustar 00greg staff 000000 000000 30 mtime=1607832550.002791224
JSONLD-0.005/lib/JSONLD.pm 000644 000765 000024 00000426314 13765311746 014722 0 ustar 00greg staff 000000 000000 =head1 NAME
JSONLD - A toolkit for transforming JSON-LD data.
=head1 VERSION
This document describes JSONLD version 0.005.
=head1 SYNOPSIS
use v5.14;
use JSON;
use JSONLD;
my $infile = 'test.jsonld';
open(my $fh, '<', $infile) or die $!;
my $content = do { local($/); <$fh> };
my $data = JSON->new()->boolean_values(0, 1)->decode($content);
my $jld = JSONLD->new();
my $expanded = $jld->expand($data);
=head1 DESCRIPTION
This module implements part of the JSON-LD 1.1 standard for manipulating JSON
data as linked data.
This version provides full support for the JSON-LD 1.1 "Expansion" and
"toRdf" transformations (the latter primarily being useful through a subclass
of JSON-LD, such as that provided by L).
Partial support for the "Compaction" transformation is provided, but it
contains many known deficiencies. Full support for "Compaction" may be
forthcoming in a future release.
No other JSON-LD transformation are supported at this time.
=head1 METHODS
=over 4
=cut
package JSONLD {
use v5.14;
use autodie;
our $VERSION = '0.005';
use utf8;
use Moo;
use LWP;
use List::Util qw(all any);
use JSON;
use JSON qw(decode_json);
use IRI;
use FindBin qw($Bin);
use File::Spec;
use File::Glob qw(bsd_glob);
use Encode qw(encode decode_utf8);
use Data::Dumper;
use Clone 'clone';
use Carp qw(confess);
use B qw(svref_2object SVf_IOK SVf_POK SVf_NOK SVf_IOK);
use namespace::clean;
# use Debug::ShowStuff qw(indent println);
sub println ($) {}
sub indent {}
has 'base_iri' => (is => 'rw', required => 0, default => sub { IRI->new('http://example.org/') });
has 'processing_mode' => (is => 'ro', default => 'json-ld-1.1');
has 'max_remote_contexts' => (is => 'rw', default => 10);
has 'parsed_remote_contexts' => (is => 'rw', default => sub { +{} });
has 'rdf_direction' => (is => 'rw');
has 'identifier_map' => (is => 'rw', default => sub { +{} });
has 'next_identifier_id' => (is => 'rw', default => 0);
has 'default_language' => (is => 'rw');
has 'default_base_direction' => (is => 'rw');
our $debug = 0;
my %keywords = map { $_ => 1 } qw(: @base @container @context @direction @graph @id @import @included @index @json @language @list @nest @none @prefix @propagate @protected @reverse @set @type @value @version @vocab);
=item C<< compact( $data, [$context] ) >>
Returns the JSON-LD compaction of C<< $data >>, using the optionally supplied
C<< $context >>.
NOTE: Support for JSON-LD Compaction is not fully supported in this version.
=cut
sub compact {
my $self = shift;
my $d = shift;
my $context = shift // {};
my %args = $self->_default_options(@_);
my $expanded_input = do {
local($debug) = 0;
$self->expand($d, ordered => 0);
};
println(Data::Dumper->Dump([$context, $expanded_input], [qw(context expanded_input)])) if $debug;
my $ctx = {
'@base' => $self->base_iri->abs, # TODO: not sure this follows the spec, but it's what makes test t0089 pass
};
if (ref($context) eq 'HASH' and exists $context->{'@context'}) {
local($debug) = 0;
$ctx = $self->_4_1_2_ctx_processing($ctx, $context->{'@context'});
}
println(Data::Dumper->Dump([$ctx], ['activeCtx'])) if $debug;
my $inverseCtx = $self->_4_3_inverse_context_creation($ctx);
# warn "Compacting...";
my $c = $self->_compact($ctx, $inverseCtx, undef, $expanded_input, %args);
my $out_ctx = $context->{'@context'} || {};
if ((ref($out_ctx) eq 'HASH' and scalar(@{[keys %$out_ctx]})) or (ref($out_ctx) eq 'ARRAY' and scalar(@$out_ctx))) {
$c->{'@context'} = $context->{'@context'};
}
return $c;
}
=item C<< expand( $data, [expandContext => $ctx] ) >>
Returns the JSON-LD expansion of C<< $data >>.
If an C<< expandContext >> value is supplied, it is used to construct the
initial active context for the expansion process.
=cut
sub expand {
my $self = shift;
my $d = shift;
my %args = @_;
my $ctx = {
'@base' => $self->base_iri->abs, # TODO: not sure this follows the spec, but it's what makes test t0089 pass
};
if (my $ec = $args{expandContext}) {
if (ref($ec) eq 'HASH' and exists $ec->{'@context'}) {
$ec = $ec->{'@context'};
}
$ctx = $self->_4_1_2_ctx_processing($ctx, $ec);
}
# warn "Expanding...";
return $self->_expand($ctx, undef, $d);
}
=item C<< to_rdf( $data, [expandContext => $ctx] ) >>
Returns the dataset generated by turning the JSON-LD expansion of C<< $data >>
into RDF.
If an C<< expandContext >> value is supplied, it is passed to the C<< expand >>
function call that takes place internally prior to generating RDF.
Note: this method must be called on a C<< JSONLD >> subclass which implements
the RDF-related methods:
=over 4
=item * C<< default_graph() >>
=item * C<< new_dataset() >>
=item * C<< new_triple($s, $p, $o) >>
=item * C<< new_quad($s, $p, $o, $g) >>
=item * C<< new_iri($value) >>
=item * C<< new_graphname($value) >>
=item * C<< new_blank( [$id] ) >>
=item * C<< new_lang_literal($value, $lang) >>
=item * C<< new_dt_literal($value, $datatype) >>
=item * C<< add_quad($quad, $dataset) >>
=back
See L for an API that provides this functionality.
=cut
sub to_rdf {
my $self = shift;
my $obj = shift;
my $expandedInput = do {
local($debug) = 0;
$self->expand($obj, @_);
};
println "to rdf " . Data::Dumper->Dump([$expandedInput], ['expandedInput']) if $debug;
my $dataset = $self->new_dataset;
my $map = {};
$self->identifier_map({});
$self->next_identifier_id(0);
$self->_7_2_2_nodemap_generation($expandedInput, $map);
println(Data::Dumper->Dump([$map], ['node_map'])) if $debug;
$self->_8_1_2_to_rdf($map, $dataset);
return $dataset;
}
sub _compact {
my $self = shift;
my $activeCtx = shift;
my $inverseCtx = shift;
my $activeProp = shift;
my $element = shift;
my $result = $self->_6_1_2_compaction($activeCtx, $inverseCtx, $activeProp, $element, @_);
if (ref($result) eq 'ARRAY') {
# https://github.com/w3c/json-ld-api/issues/318
if (scalar(@$result) == 0) {
$result = {};
} else {
my $key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@graph');
$result = { $key => $result };
}
}
return $result;
}
sub _expand {
my $self = shift;
my $ctx = shift // {};
my $prop = shift;
my $d = shift;
my $expanded_output = $self->_5_1_2_expansion($ctx, $prop, $d, @_);
if (ref($expanded_output) eq 'HASH') {
my @keys = keys %$expanded_output;
if (scalar(@keys) == 1 and $keys[0] eq '@graph') {
println "_expand 7.1" if $debug;
$expanded_output = $expanded_output->{'@graph'};
}
}
unless (defined($expanded_output)) {
println "_expand 7.2" if $debug;
$expanded_output = [];
}
if (ref($expanded_output) ne 'ARRAY') {
println "_expand 7.3" if $debug;
$expanded_output = [$expanded_output];
}
return $expanded_output;
}
sub _default_options {
my $self = shift;
my %args = @_;
$args{compactArrays} //= 1;
$args{compactToRelative} //= 1;
$args{ordered} //= 0;
return %args;
}
sub _values_from_scalar_or_array {
my $value = shift;
if (ref($value) eq 'ARRAY') {
return @$value;
} else {
return $value;
}
}
sub _is_prefix_of {
my $v = shift;
my $big = shift;
return 0 unless defined($v);
return 0 unless defined($big);
return 0 if (length($v) > length($big));
return (substr($big, 0, length($v)) eq $v);
}
sub _is_scalar {
my $v = shift;
return 1 unless (ref($v));
return 1 if JSON::is_bool($v);
return 0;
}
sub _is_string {
my $v = shift;
return 0 unless defined($v);
return 0 if ref($v);
my $sv = svref_2object(\$v);
my $flags = $sv->FLAGS;
my $is_str = $flags & SVf_POK;
my $is_num = (($flags & SVf_NOK) or ($flags & SVf_IOK));
return ($is_str and not($is_num));
}
sub _is_integer {
my $v = shift;
return 0 unless (_is_numeric($v));
my $i = int($v);
my $f = $v - $i;
return ($f == 0);
}
sub _is_numeric {
my $v = shift;
return 0 unless defined($v);
return 0 if ref($v);
my $sv = svref_2object(\$v);
my $flags = $sv->FLAGS;
my $is_num = (($flags & SVf_NOK) or ($flags & SVf_IOK));
return $is_num;
}
sub _is_abs_iri {
my $self = shift;
my $value = shift;
return 0 unless (length($value));
my $i = eval { IRI->new($value) };
unless ($i) {
return 0;
}
my $is_abs = (defined($i->scheme) and $value eq $i->abs);
return $is_abs;
}
sub _is_iri {
my $self = shift;
my $value = shift;
my $i = eval { IRI->new(value => $value) };
my $err = $@;
my $is_iri = not($@);
return $is_iri;
}
sub _make_relative_iri {
my $base = shift;
my $rel = shift;
println "Make relative IRI from: " . Data::Dumper->Dump([$base->abs, $rel->abs], [qw(base rel)]) if $debug;
my $r = $rel->rel($base)->abs;
return $r;
}
sub _load_document {
my $self = shift;
my $url = shift;
my $profile = shift;
my $req_profile = shift;
my $ua = LWP::UserAgent->new();
my $resp = $ua->get($url);
return $resp;
}
sub _cm_contains {
my $self = shift;
my $container_mapping = shift;
my $value = shift;
if (ref($container_mapping)) {
Carp::cluck unless (ref($container_mapping) eq 'ARRAY');
foreach my $m (@$container_mapping) {
return 1 if ($m eq $value);
}
} else {
return (defined($container_mapping) and $container_mapping eq $value);
}
}
sub _cm_contains_any {
my $self = shift;
my $container_mapping = shift;
my @values = @_;
foreach my $value (@values) {
return 1 if ($self->_cm_contains($container_mapping, $value));
}
return 0;
}
sub _ctx_term_defn {
my $self = shift;
my $ctx = shift;
my $term = shift;
confess "Bad context type in _ctx_term_defn: " . ref($ctx) unless (ref($ctx) eq 'HASH');
no warnings 'uninitialized';
return $ctx->{'terms'}{$term};
}
sub _ctx_contains_protected_terms {
my $self = shift;
my $ctx = shift;
my @prot = $self->_ctx_protected_terms($ctx);
return scalar(@prot);
}
sub _ctx_protected_terms {
my $self = shift;
my $ctx = shift;
my @protected;
foreach my $term (keys %{ $ctx->{'terms'} }) {
push(@protected, $term) if $ctx->{'terms'}{$term}{'protected'};
}
return @protected;
}
sub _is_node_object {
my $self = shift;
my $value = shift;
return 0 unless (ref($value) eq 'HASH');
foreach my $p (qw(@value @list @set)) {
return 0 if (exists $value->{$p});
}
# TODO: check that value "is not the top-most map in the JSON-LD document consisting of no other entries than @graph and @context."
return 1;
}
sub _is_value_object {
my $self = shift;
my $value = shift;
return 0 unless (ref($value) eq 'HASH');
return (exists $value->{'@value'});
}
sub _is_default_object {
my $self = shift;
my $value = shift;
return 0 unless (ref($value) eq 'HASH');
return (exists $value->{'@default'});
}
sub _is_list_object {
my $self = shift;
my $value = shift;
return 0 unless (ref($value) eq 'HASH');
return (exists $value->{'@list'});
}
sub _is_graph_object {
my $self = shift;
my $value = shift;
return 0 unless (ref($value) eq 'HASH');
return (exists $value->{'@graph'});
}
sub _is_simple_graph_object {
my $self = shift;
my $value = shift;
return 0 unless ($self->_is_graph_object($value));
return (not exists $value->{'@id'});
}
sub _add_value {
my $self = shift;
my $object = shift;
my $key = shift;
my $value = shift;
unless (defined($value)) {
Carp::cluck "undefined value in add_value";
}
my %args = @_;
my $as_array = $args{'as_array'} // 0;
if ($as_array and ref($value) ne 'ARRAY') {
$value = [$value];
}
if (not exists $object->{$key}) {
$object->{$key} = $value;
} else {
if (ref($object->{$key}) ne 'ARRAY') {
$object->{$key} = [$object->{$key}];
}
if (ref($value) eq 'ARRAY') {
push(@{ $object->{$key} }, @$value);
} else {
push(@{ $object->{$key} }, $value);
}
}
}
sub _is_well_formed_graph_node {
my $self = shift;
my $value = shift;
return 1 if $self->_is_well_formed_iri($value);
return 1 if ($value =~ /^_:/);
return 0;
}
sub _is_well_formed_language {
my $self = shift;
my $value = shift;
my $ok = ($value =~ m/^[a-zA-Z]{1,8}(-[a-zA-Z0-9]{1,8})*$/);
if (not $ok) {
println "not a well-formed language: $value\n" if $debug;
}
return $ok;
}
sub _is_well_formed_datatype {
my $self = shift;
my $value = shift;
return 1 if ($value eq '@json');
return 1 if $self->_is_well_formed_iri($value);
return 0;
}
sub _is_well_formed_iri {
my $self = shift;
my $value = shift;
my $ok = ($self->_is_abs_iri($value));
if (not $ok) {
println "not a well-formed IRI: $value\n" if $debug;
}
return $ok;
}
sub _is_well_formed_graphname {
my $self = shift;
my $value = shift;
my $ok = ($self->_is_abs_iri($value) or ($value eq '@default') or ($value =~ /^_:(\w+)$/));
if (not $ok) {
println "not a well-formed graph name: $value\n" if $debug;
}
return $ok;
}
sub _is_well_formed {
my $self = shift;
my $value = shift;
println "TODO: _is_well_formed: $value" if $debug;
return 1;
}
sub _4_1_2_ctx_processing {
println "ENTER =================> _4_1_2_ctx_processing" if $debug;
my $__indent = indent();
my $self = shift;
my $activeCtx = shift;
my $localCtx = shift;
local($Data::Dumper::Indent) = 0;
println(Data::Dumper->Dump([$activeCtx], ['*activeCtx'])) if $debug;
println(Data::Dumper->Dump([$localCtx], ['*localCtx'])) if $debug;
my %args = @_;
my $propagate = $args{propagate} // 1;
my $remote_contexts = $args{remote_contexts} // [];
my $validate_scoped_context = $args{validate_scoped_context} // 1;
my $override_protected = $args{override_protected} // 0;
my $base_iri = $args{base_iri} // $self->base_iri->abs;
println "1" if $debug;
my $result = clone($activeCtx); # 1
confess "Bad active context type in _4_1_2_ctx_processing: " . Dumper($activeCtx) unless (ref($activeCtx) eq 'HASH');
if (ref($localCtx) eq 'HASH' and exists $localCtx->{'@propagate'}) {
println "2" if $debug;
$propagate = (!!$localCtx->{'@propagate'}); # 2
}
if (not($propagate) and not exists $result->{'previous_context'}) {
println "3" if $debug;
$result->{'previous_context'} = $activeCtx; # 3
}
if (ref($localCtx) ne 'ARRAY') {
println "4" if $debug;
$localCtx = [$localCtx]; # 4
}
println "5" if $debug;
foreach my $context (@$localCtx) {
my $__indent = indent();
println '-----------------------------------------------------------------' if $debug;
println "5 loop for each local context item" if $debug;
println(Data::Dumper->Dump([$context], ['*context'])) if $debug;
if (not(defined($context))) {
# 5.1
println "5.1" if $debug;
if (not($override_protected) and $self->_ctx_contains_protected_terms($activeCtx)) {
my @prot = $self->_ctx_protected_terms($activeCtx);
println "5.1.1 " . Data::Dumper->Dump([\@prot], ['protected_terms']) if $debug;
die 'invalid context nullification'; # 5.1.1
} else {
println "5.1.2 moving to next context" if $debug;
my $prev = $result;
$result = {
'@base' => $self->base_iri->abs, # TODO: not sure this follows the spec, but it's what makes test t0089 pass
};
if ($propagate) {
$result->{'previous_context'} = $prev;
}
next;
}
}
if (not(ref($context))) {
println "5.2 $context" if $debug;
println "5.2.1" if $debug;
$context = IRI->new(value => $context, base => $base_iri)->abs;
if (scalar(@$remote_contexts) > $self->max_remote_contexts) {
println "5.2.2" if $debug;
die 'context overflow';
}
my %already = map { $_ => 1 } @$remote_contexts;
if (not($validate_scoped_context) and $already{$context}) {
next;
}
unless ($already{$context}) {
push(@$remote_contexts, $context);
}
my $context_url = $context;
if (my $c = $self->parsed_remote_contexts->{$context}) {
println "5.2.3" if $debug;
$context = $c;
} else {
println "5.2.4 loading context from: $context_url" if $debug;
my $resp = $self->_load_document($context_url, 'http://www.w3.org/ns/json-ld#context', 'http://www.w3.org/ns/json-ld#context');
if (not $resp->is_success) {
println "5.2.5 " . $resp->status_line if $debug;
die 'loading remote context failed';
}
my $content = $resp->decoded_content;
$context = eval { decode_json(encode('UTF-8', $content))->{'@context'} };
if ($@) {
println "5.2.5 $@" if $debug;
die 'loading remote context failed';
}
$self->parsed_remote_contexts->{$context_url} = $context;
}
println "5.2.6" if $debug;
$result = $self->_4_1_2_ctx_processing($result, $context, remote_contexts => clone($remote_contexts), validate_scoped_context => $validate_scoped_context, base_iri => $context_url);
println "5.2.7 moving to next context" if $debug;
next;
}
if (ref($context) ne 'HASH') {
println "5.3" if $debug;
die "invalid_local_context"; # 5.3
}
println "5.4" if $debug; # no-op
if (exists $context->{'@version'}) {
println "5.5" if $debug;
my $v = $context->{'@version'};
if ($v ne '1.1') {
println "5.5.1" if $debug;
die 'invalid @version value'; # 5.5.1
}
if ($self->processing_mode eq 'json-ld-1.0') {
println "5.5.2" if $debug;
die 'processing mode conflict';
}
}
if (exists $context->{'@import'}) {
println "5.6" if $debug;
if ($self->processing_mode eq 'json-ld-1.0') {
println "5.6.1" if $debug;
die 'invalid context entry';
}
my $value = $context->{'@import'};
if (ref($value)) {
println "5.6.2" if $debug;
die 'invalid @import value';
}
println "5.6.3 resolving \@import $value" if $debug;
my $import = IRI->new(value => $value, base => $self->base_iri)->abs;
println "5.6.4 loading $import" if $debug;
my $resp = $self->_load_document($import, 'http://www.w3.org/ns/json-ld#context', 'http://www.w3.org/ns/json-ld#context');
if (not $resp->is_success) {
println "5.6.5" if $debug;
die 'loading remote context failed';
}
my $content = $resp->decoded_content;
my $j = eval { decode_json(encode('UTF-8', $content))->{'@context'} };
if ($@) {
println "5.6.5 $@" if $debug;
die 'loading remote context failed';
}
unless (ref($j) eq 'HASH') {
println "5.6.6" if $debug;
die 'invalid remote context';
}
my $import_context = $j;
if (exists $import_context->{'@import'}) {
println "5.6.7" if $debug;
die 'invalid context entry';
}
println "5.6.8" if $debug;
%$context = (%$import_context, %$context);
println(Data::Dumper->Dump([$context], ['context'])) if $debug;
}
if (exists $context->{'@base'} and scalar(@$remote_contexts) == 0) {
println "5.7" if $debug;
println "5.7.1" if $debug;
my $value = $context->{'@base'};
println(Data::Dumper->Dump([$result], ['result'])) if $debug;
if (not defined($value)) {
println "5.7.2" if $debug;
delete $result->{'@base'};
} elsif ($self->_is_abs_iri($value)) {
println "5.7.3 " . Data::Dumper->Dump([$value], ['base']) if $debug;
$result->{'@base'} = $value;
} elsif ($self->_is_iri($value) and defined($result->{'@base'})) {
println "5.7.4" if $debug;
my $base = IRI->new($result->{'@base'});
my $i = IRI->new(value => $value, base => $base);
$result->{'@base'} = $i->abs;
} else {
println "5.7.5" if $debug;
die 'invalid base IRI';
}
}
if (exists $context->{'@vocab'}) {
println "5.8" if $debug;
println "5.8.1" if $debug;
my $value = $context->{'@vocab'}; # 5.8.1
if (not defined($value)) {
println "5.8.2" if $debug;
delete $result->{'@vocab'}; # 5.8.2
} elsif ($value =~ /^_/ or $self->_is_iri($value)) {
println "5.8.3" if $debug;
my $iri = $self->_5_2_2_iri_expansion($result, $value, vocab => 1, documentRelative => 1);
$result->{'@vocab'} = $iri;
} else {
die 'invalid vocab mapping';
}
}
if (exists $context->{'@language'}) {
println "5.9" if $debug;
println "5.9.1 language = " . $context->{'@language'} if $debug;
my $value = $context->{'@language'};
if (not defined($value)) {
println "5.9.2" if $debug;
delete $result->{'@language'};
} elsif (_is_string($value)) {
println "5.9.3 value is a string" if $debug;
$result->{'@language'} = $value;
# TODO: validate language tag against BCP47
} else {
println "5.9.3 value is NOT a string" if $debug;
die 'invalid default language';
}
}
if (exists $context->{'@direction'}) {
println "5.10" if $debug;
if ($self->processing_mode eq 'json-ld-1.0') {
println "5.10.1" if $debug;
die 'invalid context entry';
}
println "5.10.2" if $debug;
my $value = $context->{'@direction'};
if (not defined($value)) {
println "5.10.3" if $debug;
delete $result->{'@direction'};
} elsif (_is_string($value)) {
println "5.10.4 \@direction = $value" if $debug;
if ($value ne 'ltr' and $value ne 'rtl') {
die 'invalid base direction';
}
$result->{'@direction'} = $value;
}
}
if (exists $context->{'@propagate'}) {
println "5.11" if $debug;
if ($self->processing_mode eq 'json-ld-1.0') {
println "5.11.1" if $debug;
die 'invalid context entry';
}
my $p = $context->{'@propagate'};
if ($p ne '1' and $p ne '0' and ref($p) ne 'JSON::PP::Boolean') { # boolean true or false
println "5.11.2" if $debug;
die 'invalid @propagate value';
}
println "5.11.3" if $debug;
}
println "5.12" if $debug;
my $defined = {}; # 5.12
my @keys = reverse sort grep { $_ !~ /^[@](base|direction|import|language|propagate|protected|version|vocab)$/ } keys %$context;
println "5.13" if $debug;
foreach my $key (@keys) {
my $__indent = indent();
println "5.13 [$key]" if $debug;
my $value = $context->{$key};
$self->_4_2_2_create_term_definition($result, $context, $key, $defined, protected => $context->{'@protected'}, override_protected => $override_protected, remote_contexts => clone($remote_contexts), validate_scoped_context => $validate_scoped_context, base_iri => $base_iri); # 5.13
}
}
local($Data::Dumper::Indent) = 1;
println "6 returning from _4_1_2_ctx_processing with " . Data::Dumper->Dump([$result], ['final_context']) if $debug;
return $result; # 6
}
sub _4_2_2_create_term_definition {
my $self = shift;
my $activeCtx = shift;
my $localCtx = shift;
my $term = shift;
my $defined = shift // {};
println "ENTER =================> _4_2_2_create_term_definition('$term')" if $debug;
my $__indent = indent();
local($Data::Dumper::Indent) = 0;
println(Data::Dumper->Dump([$activeCtx], ['*activeCtx'])) if $debug;
println(Data::Dumper->Dump([$localCtx], ['*localCtx'])) if $debug;
println(Data::Dumper->Dump([$defined], ['*defined'])) if $debug;
my %args = @_;
my $protected = $args{protected} // 0;
my $override_protected = $args{override_protected} // 0;
my $remote_contexts = $args{remote_contexts} // [];
my $validate_scoped_context = $args{validate_scoped_context} // 1;
my $base_iri = $args{base_iri} // $self->base_iri->abs;
# 4.2.2
if (exists ($defined->{$term})) {
# 1
println "1" if $debug;
if ($defined->{$term}) {
println "returning from _4_2_2_create_term_definition: term definition has already been created\n" if $debug;
return;
} elsif (exists $defined->{$term}) {
die "cyclic IRI mapping";
}
}
println "2 [setting defined{$term} = 0]" if $debug;
my $term_copy = $term;
if ($term_copy eq '') {
die 'invalid term definition';
} else {
$defined->{$term} = 0; # 2
}
println "3" if $debug;
my $value = clone($localCtx->{$term}); # 3
println "3 " . Data::Dumper->Dump([$value], ['value']) if $debug;
# NOTE: the language interaction between 4 and 5 here is a mess. Unclear what "Otherwise" applies to. Similarly with the "Otherwise" that begins 7 below.
if ($self->processing_mode eq 'json-ld-1.1' and $term eq '@type') {
# 4
println "4" if $debug;
unless (ref($value) eq 'HASH') {
die 'keyword redefinition';
}
my @keys = grep { $_ ne '@protected' } keys %$value;
die 'keyword redefinition' unless (scalar(@keys) == 1 and $keys[0] eq '@container');
die 'keyword redefinition' unless ($value->{'@container'} eq '@set');
} else {
# 5
println "5" if $debug;
if (exists $keywords{$term}) {
println "5 keyword redefinition: $term" if $debug;
die 'keyword redefinition';
}
if ($term =~ /^@[A-Za-z]+$/) {
# https://www.w3.org/2018/json-ld-wg/Meetings/Minutes/2019/2019-09-20-json-ld#section5-2
warn "create term definition attempted on a term that looks like a keyword: $term\n";
println "5 returning so as to ignore a term that has the form of a keyword: $term" if $debug;
return;
}
}
println "6" if $debug;
my $previous_defn = $self->_ctx_term_defn($activeCtx, $term); # 6
delete $activeCtx->{'terms'}{$term}; # https://github.com/w3c/json-ld-api/issues/176#issuecomment-545167708
my $simple_term;
if (not(defined($value))) {
println "7" if $debug;
$value = {'@id' => undef}; # 7
} elsif (_is_string($value)) {
# 8
println "8 value = {'\@id' => $value}" if $debug;
$value = {'@id' => $value};
$simple_term = 1;
} elsif (ref($value) eq 'HASH') {
println "9" if $debug;
$simple_term = 0; # 9
} else {
println "9" if $debug;
die "invalid_term_definition"; # 9
}
println "10" if $debug;
my $definition = {'__source_base_iri' => $base_iri}; # 10
if ($value->{'@protected'}) {
println "11" if $debug;
$definition->{'protected'} = 1; # 11
println "11 TODO processing mode of json-ld-1.0" if $debug;
} elsif (not exists $value->{'@protected'} and $protected) {
println "12" if $debug;
$definition->{'protected'} = 1; # 12
}
if (exists $value->{'@type'}) {
# 13
println "13" if $debug;
my $type = $value->{'@type'}; # 13.1
if (ref($type)) {
println "13.1" if $debug;
die "invalid_type_mapping"; # 13.1
}
println "13.2" if $debug;
$type = $self->_5_2_2_iri_expansion($activeCtx, $type, vocab => 1, localCtx => $localCtx, 'defined' => $defined); # 13.2
println(Data::Dumper->Dump([$type], ['type'])) if $debug;
if (($type eq '@json' or $type eq '@none') and $self->processing_mode eq 'json-ld-1.0') {
# https://github.com/w3c/json-ld-api/issues/259
println "13.3 " . Data::Dumper->Dump([$type], ['*type']) if $debug;
die 'invalid type mapping';
}
if ($type ne '@id' and $type ne '@vocab' and $type ne '@none' and $type ne '@json' and not($self->_is_abs_iri($type))) {
# TODO: handle case "nor, if processing mode is json-ld-1.1, @json nor @none"
println "13.4 " . Data::Dumper->Dump([$type], ['*type']) if $debug;
die 'invalid type mapping'; # 13.4
}
println "13.5" if $debug;
$definition->{'type_mapping'} = $type; # 13.5
}
if (exists $value->{'@reverse'}) {
# 14
println "14" if $debug;
if (exists $value->{'@id'} or exists $value->{'@nest'}) {
println "14.1" if $debug;
die 'invalid reverse property'; # 14.1
}
my $reverse = $value->{'@reverse'};
if (ref($reverse)) {
println "14.2" if $debug;
die 'invalid IRI mapping'; # 14.2
}
if ($reverse =~ /^@[A-Za-z]+$/) {
println "14.3" if $debug;
warn '@reverse value looks like a keyword: ' . $reverse; # 14.3
return;
} else {
# 14.4
println "14.4" if $debug;
my $m = $self->_5_2_2_iri_expansion($activeCtx, $reverse, vocab => 1, localCtx => $localCtx, 'defined' => $defined);
if (not($self->_is_abs_iri($m)) and $m !~ /^:/) {
die 'invalid IRI mapping';
}
$definition->{'iri_mapping'} = $m;
}
if (exists $value->{'@container'}) {
# 14.5
println "14.5" if $debug;
my $c = $value->{'@container'};
if ($c ne '@set' and $c ne '@index' and defined($c)) {
die 'invalid reverse property';
}
$definition->{'container_mapping'} = [$c];
}
println "14.6" if $debug;
$definition->{'reverse'} = 1; # 14.6
# 14.7
println "14.7 [setting defined{$term} = 1]" if $debug;
$activeCtx->{'terms'}{$term} = $definition;
$defined->{$term} = 1;
local($Data::Dumper::Indent) = 0;
println "returning from _4_2_2_create_term_definition: " . Dumper($activeCtx->{'terms'}{$term}) if $debug;
return;
}
println "15" if $debug;
$definition->{'reverse'} = 0; # 15
if (exists $value->{'@id'} and (not(defined($value->{'@id'})) or $value->{'@id'} ne $term)) {
# 16
println "16" if $debug;
if (not defined($value->{'@id'})) {
println "16.1" if $debug;
} else {
println "16.2" if $debug;
my $id = $value->{'@id'};
if (not _is_string($id)) {
println "16.2.1" if $debug;
die 'invalid IRI mapping'; # 16.2
}
if (defined($id) and not exists $keywords{$id} and $id =~ /^@[A-Za-z]+$/) {
println "16.2.2" if $debug;
warn "create term definition encountered an \@id that looks like a keyword: $id\n";
return;
} else {
println "16.2.3" if $debug;
my $iri = $self->_5_2_2_iri_expansion($activeCtx, $id, vocab => 1, localCtx => $localCtx, 'defined' => $defined);
if (not exists $keywords{$iri} and not $self->_is_abs_iri($iri) and $iri !~ /:/) {
die 'invalid IRI mapping';
}
if ($iri eq '@context') {
die 'invalid keyword alias';
}
$definition->{'iri_mapping'} = $iri;
}
if ($term =~ /.:./ or index($term, '/') >= 0) {
println "16.2.4" if $debug;
println "16.2.4.1" if $debug;
$defined->{$term} = 1;
my $iri = $self->_5_2_2_iri_expansion($activeCtx, $term, vocab => 1, localCtx => $localCtx, 'defined' => $defined);
if ($iri ne $definition->{'iri_mapping'}) {
println "16.2.4.2" if $debug;
die 'invalid IRI mapping'; # 16.5 ; NOTE: the text here doesn't discuss what parameters to pass to IRI expansion
}
}
if ($term !~ m{[:/]} and $simple_term and $definition->{'iri_mapping'} =~ m{[][:/?#@]$}) {
println "16.2.5" if $debug;
$definition->{'prefix_flag'} = 1;
}
# }
}
} elsif ($term =~ /.:/) {
# 17
println "17" if $debug;
my ($prefix, $suffix) = split(/:/, $term, 2);
if (exists $localCtx->{$prefix}) {
println "17.1" if $debug;
$self->_4_2_2_create_term_definition($activeCtx, $localCtx, $prefix, $defined); # 17.1
}
if (exists $activeCtx->{'terms'}{$prefix}) {
println "17.2" if $debug;
$definition->{'iri_mapping'} = $activeCtx->{'terms'}{$prefix}{'iri_mapping'} . $suffix; # 17.2
} else {
println "17.3" if $debug;
$definition->{'iri_mapping'} = $term; # 17.3
}
} elsif ($term =~ m{/}) {
println "18" if $debug;
println "18.1"; # if $debug;
println "18.2" if $debug;
$definition->{'iri_mapping'} = $self->_5_2_2_iri_expansion($activeCtx, $term, vocab => 1);
unless ($self->_is_iri($definition->{'iri_mapping'})) {
println "18.2 invalid IRI: " . $definition->{'iri_mapping'};
die 'invalid IRI mapping';
}
} elsif ($term eq '@type') {
println "19" if $debug;
$definition->{'iri_mapping'} = '@type'; # 19
} else {
# 20 ; NOTE: this section uses a passive voice "the IRI mapping of definition is set to ..." cf. 18 where it's active: "set the IRI mapping of definition to @type"
if (exists $activeCtx->{'@vocab'}) {
println "20" if $debug;
$definition->{'iri_mapping'} = $activeCtx->{'@vocab'} . $term;
} else {
println "20" if $debug;
die 'invalid IRI mapping';
}
}
if (exists $value->{'@container'}) {
# TODO: 21
println "21" if $debug;
println "21.1" if $debug;
my $container = $value->{'@container'}; # 21.1
# 21.1 error checking
my %acceptable = map { $_ => 1 } qw(@graph @id @index @language @list @set @type);
if (exists $acceptable{$container}) {
} elsif (ref($container) eq 'ARRAY') {
if (scalar(@$container) == 1) {
my ($c) = @$container;
unless (exists $acceptable{$c}) {
println "21.1(a)" if $debug;
die 'invalid container mapping';
}
} elsif (any { $_ =~ /^[@](id|index)$/ } @$container) { # any { $_ eq '@graph' } @$container
} elsif (any { $_ eq '@set' } @$container and any { $_ =~ /^[@](index|graph|id|type|language)$/ } @$container) {
} else {
println "21.1(b)" if $debug;
die 'invalid container mapping';
}
} else {
println "21.1(c)" if $debug;
die 'invalid container mapping';
}
if ($self->processing_mode eq 'json-ld-1.0') {
if (any { $container eq $_ } qw(@graph @id @type) or ref($container)) {
println "21.2" if $debug;
die 'invalid container mapping';
}
}
println "21.3" if $debug;
if (ref($container) eq 'ARRAY') {
$definition->{'container_mapping'} = $container; # 21.3
} else {
$definition->{'container_mapping'} = [$container]; # 21.3
}
if ($container eq '@type') {
println "21.4" if $debug;
if (not defined($definition->{'type_mapping'})) {
println "21.4.1" if $debug;
$definition->{'type_mapping'} = '@id';
}
my $tm = $definition->{'type_mapping'};
if ($tm ne '@id' and $tm ne '@vocab') {
println "21.4.2" if $debug;
die 'invalid type mapping';
}
}
}
if (exists $value->{'@index'}) {
println "22" if $debug;
my $container_mapping = $definition->{'container_mapping'};
if ($self->processing_mode eq 'json-ld-1.0' or not $self->_cm_contains($container_mapping, '@index')) {
println "22.1" if $debug;
die 'invalid term definition';
}
println "22.2" if $debug;
my $index = $value->{'@index'};
my $expanded = $self->_5_2_2_iri_expansion($activeCtx, $index, vocab => 1);
unless ($self->_is_abs_iri($expanded)) {
die 'invalid term definition';
}
println "22.3" if $debug;
$definition->{'index_mapping'} = $index;
}
if (exists $value->{'@context'}) {
println "23" if $debug;
if ($self->processing_mode eq 'json-ld-1.0') {
println "23.1" if $debug;
die 'invalid term definition';
}
println "23.2" if $debug;
my $context = $value->{'@context'};
println "23.3" if $debug;
# $self->_4_1_2_ctx_processing($activeCtx, $context, override_protected => 1, remote_contexts => clone($remote_contexts), validate_scoped_context => $validate_scoped_context, base_iri => $base_iri); # discard result
$self->_4_1_2_ctx_processing($activeCtx, $context, override_protected => 1, remote_contexts => clone($remote_contexts), validate_scoped_context => 0, base_iri => $base_iri); # discard result
# $self->_4_1_2_ctx_processing($activeCtx, $context, override_protected => 1); # discard result
$definition->{'@context'} = $context; # Note: not sure about the spec text wording here: "Set the local context of definition to context." What is the "local context" of a definition?
}
if (exists $value->{'@language'} and not exists $value->{'@type'}) {
println "24" if $debug;
println "24.1" if $debug;
my $language = $value->{'@language'};
if (defined($language) and ref($language)) {
die 'invalid language mapping';
}
# TODO: validate language tag against BCP47
println "24.2" if $debug;
# TODO: normalize language tag
$definition->{'language_mapping'} = $language;
}
if (exists $value->{'@direction'} and not exists $value->{'@type'}) {
println "25" if $debug;
my $direction = $value->{'@direction'};
println "25.1" if $debug;
if (not(defined($direction))) {
} elsif ($direction ne 'ltr' and $direction ne 'rtl') {
die 'invalid base direction';
}
$definition->{'direction_mapping'} = $direction;
}
if (exists $value->{'@nest'}) {
println "26" if $debug;
if ($self->processing_mode eq 'json-ld-1.0') {
println "26.1" if $debug;
die 'invalid term definition';
}
println "26.2" if $debug;
my $nv = $value->{'@nest'};
if (not(defined($nv)) or ref($nv)) {
die 'invalid @nest value';
} elsif (exists $keywords{$nv} and $nv ne '@nest') {
die 'invalid @nest value';
}
$definition->{'nest_value'} = $nv;
}
if (exists $value->{'@prefix'}) {
println "27" if $debug;
if ($self->processing_mode eq 'json-ld-1.0' or $term =~ m{[:/]}) {
println "27.1" if $debug;
die 'invalid term definition'; # 27.1
}
println "27.2" if $debug;
$definition->{'prefix_flag'} = $value->{'@prefix'};
unless (JSON::is_bool($value->{'@prefix'})) {
die 'invalid @prefix value';
}
if ($definition->{'prefix_flag'} and exists $keywords{$definition->{'iri_mapping'}}) {
println "27.3" if $debug;
die 'invalid term definition';
}
}
my @keys = grep { not m/^[@](id|reverse|container|context|language|nest|prefix|type|direction|protected|index)$/ } keys %$value;
if (scalar(@keys)) {
println "28 " . Data::Dumper->Dump([\@keys, $value], ['invalid_keys', 'value']) if $debug;
die 'invalid term definition'; # 28
}
if (not($override_protected) and $previous_defn->{'protected'}) {
# 29
println "29" if $debug;
my %cmp_a = map { $_ => $definition->{$_} } grep { $_ ne 'protected' } keys %$definition;
my %cmp_b = map { $_ => $previous_defn->{$_} } grep { $_ ne 'protected' } keys %$previous_defn;
my $j = JSON->new->canonical(1);
if ($j->encode(\%cmp_a) ne $j->encode(\%cmp_b)) {
println "29.1" if $debug;
die 'protected term redefinition'; # 29.1
}
println "29.2" if $debug;
$definition = $previous_defn; # 29.2
}
println "30 [setting defined{$term} = 1]" if $debug;
println "30 setting term definition " . Data::Dumper->Dump([$definition], [$term]) if $debug;
$activeCtx->{'terms'}{$term} = $definition; # 30
$defined->{$term} = 1; # 30
local($Data::Dumper::Indent) = 0;
println "returning from _4_2_2_create_term_definition: " . Dumper($activeCtx->{'terms'}{$term}) if $debug;
return;
}
sub _4_3_inverse_context_creation {
my $self = shift;
my $activeCtx = shift;
{
no warnings 'uninitialized';
println "ENTER =================> _4_3_inverse_context_creation" if $debug;
}
my $__indent = indent();
println "1" if $debug;
my $result = {};
println "2" if $debug;
my $default_language = '@none';
if (exists $activeCtx->{'@language'}) {
$default_language = lc($activeCtx->{'@language'});
}
println "3" if $debug;
foreach my $term (sort { length($a) <=> length($b) || $a cmp $b } keys %{ $activeCtx->{'terms'} }) {
my $__indent = indent();
println "3 [$term]" if $debug;
my $tdef = $self->_ctx_term_defn($activeCtx, $term);
if (not defined($tdef)) {
println "3.1" if $debug;
next;
}
println "3.2" if $debug;
my $container = '@none';
my $container_mapping = $tdef->{'container_mapping'} || [];
if (scalar(@$container_mapping)) {
$container = join('', sort @$container_mapping);
}
println "3.3" if $debug;
my $var = $tdef->{'iri_mapping'};
if (not exists $result->{$var}) {
println "3.4" if $debug;
$result->{$var} = {};
}
println "3.5" if $debug;
my $container_map = $result->{$var};
if (not exists $container_map->{$container}) {
println "3.6" if $debug;
$container_map->{$container} = {
'@language' => {},
'@type' => {},
'@any' => {
'@none' => $term
}
};
}
println "3.7" if $debug;
my $type_language_map = $container_map->{$container};
println "3.8" if $debug;
my $type_map = $type_language_map->{'@type'};
if ($tdef->{'reverse'}) {
println "3.9" if $debug;
if (not exists $type_map->{'@reverse'}) {
println "3.9.1" if $debug;
$type_map->{'@reverse'} = $term;
}
} elsif (($tdef->{'type_mapping'} // '') eq '@none') {
println "3.10" if $debug;
println "3.10.1" if $debug;
my $language_map = $type_language_map->{'@language'};
if (not exists $language_map->{'@any'}) {
println "3.10.2" if $debug;
$language_map->{'@any'} = $term;
}
if (not exists $type_map->{'@any'}) {
println "3.10.3" if $debug;
$type_map->{'@any'} = $term;
}
} elsif (exists $tdef->{'type_mapping'}) {
println "3.11" if $debug;
if (not exists $type_map->{$tdef->{'type_mapping'}}) {
println "3.11.1" if $debug;
$type_map->{$tdef->{'type_mapping'}} = $term;
}
}
println "3.12" if $debug;
my $language_map = $type_language_map->{'@language'};
my $lang_dir; # TODO: the spec says to create this in 3.13.1, but it's used at this level
if (exists $tdef->{'language_mapping'} and exists $tdef->{'direction_mapping'}) {
println "3.13" if $debug;
println "3.13.1" if $debug;
# my $lang_dir;
if (defined($tdef->{'language_mapping'}) and defined($tdef->{'direction_mapping'})) {
println "3.13.2" if $debug;
$lang_dir = lc(join('_', @{ $tdef }{qw(language_mapping direction_mapping)}));
} elsif (defined($tdef->{'language_mapping'})) {
println "3.13.3" if $debug;
$lang_dir = lc($tdef->{'language_mapping'});
} elsif (defined($tdef->{'direction_mapping'})) {
println "3.13.4" if $debug;
$lang_dir = '_' . lc($tdef->{'direction_mapping'});
} else {
println "3.13.5" if $debug;
$lang_dir = '@null';
}
if (not exists $language_map->{$lang_dir}) {
println "3.13.6" if $debug;
$language_map->{$lang_dir} = $term;
}
} elsif (exists $tdef->{'language_mapping'}) {
println "3.14" if $debug;
println "3.14.1" if $debug;
my $language = (not defined($tdef->{'language_mapping'})) ? '@null' : lc($tdef->{'language_mapping'});
if (not exists $language_map->{$language}) {
println "3.14.2" if $debug;
$language_map->{$language} = $term;
}
} elsif (exists $tdef->{'direction_mapping'}) {
println "3.15" if $debug;
println "3.15.1" if $debug;
my $direction = (not defined $tdef->{'direction_mapping'}) ? '@none' : '_' . $tdef->{'direction_mapping'};
if (not exists $language_map->{$direction}) {
println "3.15.2" if $debug;
$language_map->{$direction} = $term;
}
} elsif (exists $activeCtx->{'@direction'}) {
println "3.16" if $debug;
println "3.16.1" if $debug;
my $lang_dir = lc(join('_', $self->default_language, $self->default_base_direction));
if (not exists $language_map->{$lang_dir}) {
println "3.16.2" if $debug;
$language_map->{$lang_dir} = $term;
}
if (not exists $language_map->{'@none'}) {
println "3.16.3" if $debug;
$language_map->{'@none'} = $term;
}
if (not exists $type_map->{'@none'}) {
println "3.16.4" if $debug;
$type_map->{'@none'} = $term;
}
} else {
println "3.17" if $debug;
if (not exists $language_map->{lc $default_language}) {
println "3.17.1" if $debug;
$language_map->{lc $default_language} = $term;
}
if (not exists $language_map->{'@none'}) {
println "3.17.2" if $debug;
$language_map->{'@none'} = $term;
}
if (not exists $type_map->{'@none'}) {
println "3.17.3" if $debug;
$type_map->{'@none'} = $term;
}
}
}
println "4" if $debug;
return $result;
}
sub _4_4_2_term_selection {
my $self = shift;
my $inverseCtx = shift;
my $var = shift;
my $containers = shift;
my $type_language = shift;
my $preferred_values = shift;
println "ENTER =================> _4_4_2_term_selection" if $debug;
my $__indent = indent();
println "1" if $debug;
my $container_map = $inverseCtx->{$var};
println "2" if $debug;
foreach my $container (@$containers) {
println "2 [$container]" if $debug;
if (not exists $container_map->{$container}) {
println "2.1" if $debug;
next;
}
println "2.2" if $debug;
my $type_language_map = $container_map->{$container};
println "2.3" if $debug;
my $value_map = $type_language_map->{$type_language};
println "2.4" if $debug;
foreach my $item (@$preferred_values) {
if (not exists $value_map->{$item}) {
println "2.4.1" if $debug;
next;
}
println "2.4.2" if $debug;
return $value_map->{$item};
}
}
println "3" if $debug;
return;
}
sub _5_1_2_expansion {
my $self = shift;
my $activeCtx = shift;
my $activeProp = shift;
my $element = shift;
{
no warnings 'uninitialized';
println "ENTER =================> _5_1_2_expansion('$activeProp')" if $debug;
}
my $__indent = indent();
local($Data::Dumper::Indent) = 0;
println(Data::Dumper->Dump([$activeCtx], ['activeCtx'])) if $debug;
println(Data::Dumper->Dump([$activeProp], ['activeProp'])) if $debug;
println(Data::Dumper->Dump([$element], ['element'])) if $debug;
my %args = @_;
my $frameExpansion = $args{frameExpansion} // 0;
my $ordered = $args{ordered} // 0;
my $fromMap = $args{fromMap} // 0;
unless (defined($element)) {
println "1 returning from _5_1_2_expansion: undefined element" if $debug;
return; # 1
}
if (defined($activeProp) and $activeProp eq '@default') {
println "2" if $debug;
$frameExpansion = 0; # 2
}
my $property_scoped_ctx;
my $property_scoped_ctx_defined = 0;
my $tdef = $self->_ctx_term_defn($activeCtx, $activeProp);
if ($tdef and exists $tdef->{'@context'}) {
$property_scoped_ctx_defined = 1;
my $lctx = $tdef->{'@context'};
$property_scoped_ctx = $lctx; # 3
println "3 property-scoped context for property $activeProp: " . Data::Dumper->Dump([$property_scoped_ctx], [qw(context)]) if $debug;
}
if (_is_scalar($element)) {
# 4
println "4" if $debug;
if (not(defined($activeProp)) or $activeProp eq '@graph') {
println "4.1 returning from _5_1_2_expansion: free floating scalar" if $debug;
return; # 4.1
}
if ($property_scoped_ctx_defined) {
println "4.2" if $debug;
$activeCtx = $self->_4_1_2_ctx_processing($activeCtx, $property_scoped_ctx); # 4.2
println "after 4.2: " . Data::Dumper->Dump([$activeCtx], ['activeCtx']) if $debug;
}
println "4.3" if $debug;
my $v = $self->_5_3_2_value_expand($activeCtx, $activeProp, $element);
local($Data::Dumper::Indent) = 1;
println "4.3 returning from _5_1_2_expansion with " . Data::Dumper->Dump([$v], ['expandedValue']) if $debug;
return $v; # 4.3
}
if (ref($element) eq 'ARRAY') {
# 5
println "5" if $debug;
my @result; # 5.1
println "5.1" if $debug;
foreach my $item (@$element) {
# 5.2
println "5.2" if $debug;
println "5.2.1" if $debug;
my $expandedItem = $self->_5_1_2_expansion($activeCtx, $activeProp, $item, fromMap => $fromMap); # 5.2.1
println "5.2.1 expanded item = " . Dumper($expandedItem) if $debug;
# NOTE: 5.2.2 "container mapping" is in the term definition for active property, right? The text omits the term definition reference.
my $container_mapping = $tdef->{'container_mapping'};
# if (any { $_ eq '@list'} @$container_mapping and ref($expandedItem) eq 'ARRAY') {
if ($self->_cm_contains($container_mapping, '@list') and ref($expandedItem) eq 'ARRAY') {
println "5.2.2" if $debug;
$expandedItem = { '@list' => $expandedItem }; # 5.2.2
}
# 5.2.3
println "5.2.3" if $debug;
if (ref($expandedItem) eq 'ARRAY') {
push(@result, @$expandedItem);
} elsif (defined($expandedItem)) {
push(@result, $expandedItem);
}
}
local($Data::Dumper::Indent) = 1;
println "5.3 returning from _5_1_2_expansion with " . Data::Dumper->Dump([\@result], ['expanded_array_value']) if $debug;
return \@result; # 5.3
}
unless (ref($element) eq 'HASH') {
println "6" if $debug;
die "Unexpected non-map encountered during expansion: $element";
}
if (my $prevCtx = $activeCtx->{'previous_context'}) {
unless ($fromMap) {
my @keys = keys %$element;
my %expandedKeys = map { $_ => 1 } map { $self->_5_2_2_iri_expansion($activeCtx, $_, vocab => 1) } @keys;
unless (exists $expandedKeys{'@value'}) {
unless (scalar(@keys) == 1 and $self->_5_2_2_iri_expansion($activeCtx, $keys[0], vocab => 1) eq '@id') {
println "7" if $debug;
$activeCtx = $prevCtx; # 7
}
}
}
}
if ($property_scoped_ctx_defined) {
println "8" if $debug;
my %args;
if ($tdef and exists $tdef->{'__source_base_iri'}) {
$args{base_iri} = $tdef->{'__source_base_iri'};
}
local($Data::Dumper::Indent) = 1;
println "before 8: " . Data::Dumper->Dump([$activeCtx, $property_scoped_ctx], [qw'activeCtx property_scoped_ctx']) if $debug;
$activeCtx = $self->_4_1_2_ctx_processing($activeCtx, $property_scoped_ctx, %args, override_protected => 1); # 8
println "after 8: " . Data::Dumper->Dump([$activeCtx], ['activeCtx']) if $debug;
}
if (exists $element->{'@context'}) {
println "9" if $debug;
my $c = $element->{'@context'};
$activeCtx = $self->_4_1_2_ctx_processing($activeCtx, $c); # 9
}
println "10" if $debug;
my $type_scoped_ctx = clone($activeCtx); # 10
println "11" if $debug;
foreach my $key (sort keys %$element) {
my $__indent = indent();
my $value = $element->{$key};
# 11
println "11 [$key]" if $debug;
{
no warnings 'uninitialized';
unless ('@type' eq $self->_5_2_2_iri_expansion($activeCtx, $key, vocab => 1)) {
println "[skipping key $key in search of \@type]" if $debug;
next;
}
}
println "11 body [$key]" if $debug;
unless (ref($value) eq 'ARRAY') {
println "11.1 [$key]" if $debug;
$value = [$value]; # 11.1
}
my %tdefs = map { $_ => $self->_ctx_term_defn($type_scoped_ctx, $_) } grep { _is_string($_) } @$value; # https://github.com/w3c/json-ld-api/issues/304
# the clone here is necessary, because the implicit lexicographic sort will add the POK flag to integer scalars that would otherwise be just IOK. this causes the resulting JSON serialization to treat the scalar as a string.
foreach my $term (sort @{clone($value)}) {
println "11.2 attempting with [$term]" if $debug;
if (_is_string($term)) {
my $tdef = $tdefs{$term};
if (exists $tdef->{'@context'}) {
println "11.2" if $debug;
my $c = $tdef->{'@context'};
$activeCtx = $self->_4_1_2_ctx_processing($activeCtx, $c, propagate => 0);
local($Data::Dumper::Indent) = 1;
println "11.2 " . Data::Dumper->Dump([$activeCtx], ['activeCtx']) if $debug;
}
}
}
}
println "After 11, " . Data::Dumper->Dump([$element], ['element']) if $debug;
println "12" if $debug;
my $result = {}; # 12a
my $nests = {}; # 12b
my $input_type = '';
foreach my $key (sort keys %$element) {
my $expandedKey = $self->_5_2_2_iri_expansion($activeCtx, $key);
no warnings 'uninitialized';
if ($expandedKey eq '@type') {
$input_type = $self->_5_2_2_iri_expansion($activeCtx, $element->{$key});
last;
}
}
println "12 " . Data::Dumper->Dump([$input_type], ['*input_type']) if $debug;
$self->_5_1_2_expansion_step_13($activeCtx, $type_scoped_ctx, $result, $activeProp, $input_type, $nests, $ordered, $frameExpansion, $element);
println "after 13,14: " . Data::Dumper->Dump([$result], ['*result']) if $debug;
if (exists $result->{'@value'}) {
# 15
println "15" if $debug;
my @keys = keys %$result;
my %acceptable = map { $_ => 1 } qw(@direction @index @language @type @value);
foreach my $k (@keys) {
unless ($acceptable{$k}) {
println "15.1 [$k]" if $debug;
die 'invalid value object' ; # 15.1
}
}
if (exists $result->{'@language'} or exists $result->{'@direction'}) {
println "15.1 \@language handling" if $debug;
die 'invalid value object' if (exists $result->{'@type'}); # 15.1
}
# if (not(defined($result->{'@value'}))) {
if (defined($result->{'@type'}) and $result->{'@type'} eq '@json') {
println "15.2" if $debug;
# TODO: treat $result->{'@value'} as a JSON literal
} elsif (not(defined($result->{'@value'})) or (ref($result->{'@value'}) eq 'ARRAY' and not scalar(@{$result->{'@value'}}))) { # based on irc conversation with gkellog
println "15.3" if $debug;
return undef;
} elsif (ref($result->{'@value'}) and exists $result->{'@language'}) {
println "15.4" if $debug;
die 'invalid language-tagged value; ' . Dumper($result); # 15.4
} elsif (exists $result->{'@type'} and not($self->_is_iri($result->{'@type'}))) {
println "Not an IRI \@type: " . Dumper($result->{'@type'});
println "15.5" if $debug;
die 'invalid typed value: ' . Dumper($result); # 15.5
# } elsif (exists $result->{'@type'}) {
# my $types = $result->{'@type'};
# my @types = (ref($types) eq 'ARRAY') ? @$types : $types;
# foreach my $t (@types) {
# unless ($self->_is_iri($t)) {
# warn "Not an IRI \@type: " . Dumper($result->{'@type'});
# println "15.5" if $debug;
# die 'invalid typed value: ' . Dumper($result); # 15.5
# }
# }
}
println "15 resulting in " . Data::Dumper->Dump([$result], ['*result']) if $debug;
} elsif (exists $result->{'@type'} and ref($result->{'@type'}) ne 'ARRAY') {
println "16" if $debug;
$result->{'@type'} = [$result->{'@type'}]; # 16
println "16 resulting in " . Data::Dumper->Dump([$result], ['*result']) if $debug;
} elsif (exists $result->{'@set'} or exists $result->{'@list'}) {
# 17
println "17" if $debug;
my @keys = grep { $_ ne '@set' and $_ ne '@list' } keys %$result;
if (scalar(@keys)) {
println "17.1" if $debug;
die 'invalid set or list object' unless (scalar(@keys) == 1 and $keys[0] eq '@index'); # 17.1
}
if (exists $result->{'@set'}) {
println "17.2" if $debug;
$result = $result->{'@set'}; # 17.2
}
println "17 resulting in " . Data::Dumper->Dump([$result], ['*result']) if $debug;
}
println "after 17 resulting in " . Data::Dumper->Dump([$result], ['*result']) if $debug;
my @keys = (ref($result) eq 'HASH') ? keys %$result : ();
if (ref($result) eq 'HASH') { # NOTE: assuming based on the effects of 16.2 that this condition is necessary to guard against cases where $result is not a hashref.
if (scalar(@keys) == 1 and $keys[0] eq '@language') {
println "18" if $debug;
return undef;
}
println(Data::Dumper->Dump([$activeProp], ['activeProp'])) if $debug;
if (not(defined($activeProp)) or $activeProp eq '@graph') {
# 19
local($Data::Dumper::Indent) = 0;
println "19 " . Data::Dumper->Dump([$result, \@keys], ['*result', '*keys']) if $debug;
if (ref($result) eq 'HASH' and (scalar(@keys) == 0 or exists $result->{'@value'} or exists $result->{'@list'})) {
println "19.1" if $debug;
$result = undef; # 19.1
} elsif (ref($result) eq 'HASH' and scalar(@keys) == 1 and $keys[0] eq '@id') {
unless ($frameExpansion) {
println "19.2" if $debug;
$result = undef; # 19.2
}
}
}
println "19 resulting in " . Data::Dumper->Dump([$result], ['*result']) if $debug;
}
local($Data::Dumper::Indent) = 1;
println "20 returning from _5_1_2_expansion with final value " . Data::Dumper->Dump([$result], ['*result']) if $debug;
return $result; # 19
}
sub _5_1_2_expansion_step_13 {
my $self = shift;
my $activeCtx = shift;
my $type_scoped_ctx = shift;
my $result = shift;
my $activeProp = shift;
my $input_type = shift;
my $nests = shift;
my $ordered = shift;
my $frameExpansion = shift;
my $element = shift;
println "13 --- processing " . Data::Dumper->Dump([$element], ['element']) if ($debug);
foreach my $key (sort keys %$element) {
my $__indent = indent();
my $value = $element->{$key};
# 13
println '-----------------------------------------------------------------' if $debug;
println "13 [$key] " . Data::Dumper->Dump([$value], ['value']) if $debug;
if ($key eq '@context') {
println "13.1 going to next element key" if $debug;
next; # 13.1
}
local($Data::Dumper::Indent) = 1;
println(Data::Dumper->Dump([$activeCtx], ['activeCtx'])) if $debug;
println "13.2" if $debug;
my $expandedProperty = $self->_5_2_2_iri_expansion($activeCtx, $key, vocab => 1); # 13.2
println "13.2 " . Data::Dumper->Dump([$expandedProperty], ['expandedProperty']) if $debug;
println(Data::Dumper->Dump([$expandedProperty], ['expandedProperty'])) if $debug;
if (not(defined($expandedProperty)) or ($expandedProperty !~ /:/ and not exists $keywords{$expandedProperty})) {
println "13.3 going to next element key" if $debug;
next; # 13.3
}
my $expandedValue;
if (exists $keywords{$expandedProperty}) {
# 13.4
println "13.4 keyword: $expandedProperty" if $debug;
if (defined($activeProp) and $activeProp eq '@reverse') {
println "13.4.1" if $debug;
die 'invalid reverse property map'; # 13.4.1
}
if (exists $result->{$expandedProperty}) {
my $p = $result->{$expandedProperty};
if ($expandedProperty ne '@included' and $expandedProperty ne '@type') {
println "13.4.2 colliding: $expandedProperty" if $debug;
die 'colliding keywords'; # 13.4.2
}
}
# NOTE: another case of an "Otherwise" applying to a partial conjunction
if ($expandedProperty eq '@id') {
println "13.4.3" if $debug;
if (ref($value) or not defined($value)) {
println "13.4.3.1 invalid" if $debug;
die 'invalid @id value';
} else {
println "13.4.3.2" if $debug;
$expandedValue = $self->_5_2_2_iri_expansion($activeCtx, $value, documentRelative => 1);
println "13.4.3.2 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
}
if ($expandedProperty eq '@type') {
println "13.4.4" if $debug;
my $is_string = _is_string($value);
my $is_array = ref($value) eq 'ARRAY';
my $is_array_of_strings = ($is_array and all { _is_string($_) } @$value);
if (not($is_string) and not($is_array_of_strings)) {
println "13.4.4.1 invalid" if $debug;
die 'invalid type value';
}
if (ref($value) eq 'HASH' and scalar(%$value) == 0) {
println "13.4.4.2" if $debug;
$expandedValue = $value;
println "13.4.4.2 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
} elsif ($self->_is_default_object($value)) {
println "13.4.4.3" if $debug;
$expandedValue = { '@default' => $self->_5_2_2_iri_expansion($type_scoped_ctx, $value, vocab => 1, documentRelative => 1) };
println "13.4.4.3 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
} else {
println "13.4.4.4" if $debug;
if (ref($value)) {
$expandedValue = [map {$self->_5_2_2_iri_expansion($type_scoped_ctx, $_, vocab => 1, documentRelative => 1)} @$value];
} else {
$expandedValue = $self->_5_2_2_iri_expansion($type_scoped_ctx, $value, vocab => 1, documentRelative => 1);
}
println "13.4.4.4 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
if (my $t = $result->{'@type'}) {
println "13.4.4.5" if $debug;
if (ref($expandedValue) ne 'ARRAY') {
$expandedValue = [$expandedValue];
}
unshift(@$expandedValue, $t);
println "13.4.4.5 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
}
if ($expandedProperty eq '@graph') {
println "13.4.5" if $debug;
my $v = $self->_5_1_2_expansion($activeCtx, '@graph', $value, frameExpansion => $frameExpansion, ordered => $ordered);
$expandedValue = (ref($v) eq 'ARRAY') ? $v : [$v];
println("========================================================================") if $debug;
println("========================================================================") if $debug;
println("========================================================================") if $debug;
println(Dumper($expandedValue)) if $debug;
println "13.4.5 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
if ($expandedProperty eq '@included') {
println "13.4.6" if $debug;
if ($self->processing_mode eq 'json-ld-1.0') {
println "13.4.6.1" if $debug;
next;
}
println "13.4.6.2" if $debug;
$expandedValue = $self->_5_1_2_expansion($activeCtx, $activeProp, $value, frameExpansion => $frameExpansion, ordered => $ordered);
unless (ref($expandedValue) eq 'ARRAY') {
$expandedValue = [$expandedValue];
}
foreach my $v (@$expandedValue) {
unless ($self->_is_node_object($v)) {
println "13.4.6.3" if $debug;
die 'invalid @included value';
}
}
if (exists $result->{'@included'}) {
# https://github.com/w3c/json-ld-api/issues/333
println "13.4.6.4" if $debug;
unshift(@$expandedValue, @{ $result->{'@included'} });
}
println "13.4.6 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
} elsif ($expandedProperty eq '@value') {
println "13.4.7 " . Data::Dumper->Dump([$input_type], ['*input_type']) if $debug;
if ($input_type eq '@json') {
println "13.4.7.1" if $debug;
$expandedValue = $value; # 13.4.7.1
if ($self->processing_mode eq 'json-ld-1.0') {
die 'invalid value object value';
}
} elsif (not (_is_scalar($value) or not defined($value))) { # "if value is not a scalar or null, an invalid value object value error has been detected"
println "13.4.7.2 " . Data::Dumper->Dump([$value], ['*value']) if $debug; # NOTE: the language here is ambiguous: "if value is not a scalar or null"
die 'invalid value object value';
} else {
println "13.4.7.3" if $debug;
$expandedValue = $value;
}
unless (defined($expandedValue)) {
println "13.4.7.4" if $debug;
$result->{'@value'} = undef;
next;
}
println "13.4.7 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
# NOTE: again with the "Otherwise" that seems to apply to only half the conjunction
if ($expandedProperty eq '@language') {
println "13.4.8" if $debug;
if (ref($value)) {
println "13.4.8.1" if $debug;
if ($frameExpansion) {
println "13.4.8.1 TODO: frameExpansion support"; # if $debug;
}
die 'invalid language-tagged string';
}
println "13.4.8.2" if $debug;
$expandedValue = $value; # 13.4.8.2
# TODO: validate language tag against BCP47
println "13.4.8 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
if ($expandedProperty eq '@direction') {
println "13.4.9" if $debug;
if ($self->processing_mode eq 'json-ld-1.0') {
println "13.4.9.1" if $debug;
next;
}
if ($value ne 'ltr' and $value ne 'rtl') {
println "13.4.9.2" if $debug;
die 'invalid base direction';
}
println "13.4.9.3" if $debug;
$expandedValue = $value;
if ($frameExpansion) {
println "13.4.9.4 TODO: frameExpansion support"; # if $debug;
}
println "13.4.9 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
if ($expandedProperty eq '@index') {
println "13.4.10" if $debug;
if (ref($value)) {
println "13.4.10.1" if $debug;
die 'invalid @index value';
}
println "13.4.10.2" if $debug;
$expandedValue = $value;
println "13.4.10 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
if ($expandedProperty eq '@list') {
println "13.4.11" if $debug;
if (not defined($activeProp) or $activeProp eq '@graph') {
println "13.4.11.1" if $debug;
next;
}
println "13.4.11.2" if $debug;
$expandedValue = $self->_5_1_2_expansion($activeCtx, $activeProp, $value, frameExpansion => $frameExpansion, ordered => $ordered);
if (ref($expandedValue) ne 'ARRAY') {
# https://github.com/w3c/json-ld-api/issues/310
$expandedValue = [$expandedValue];
}
println "13.4.11 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
if ($expandedProperty eq '@set') {
println "13.4.12" if $debug;
$expandedValue = $self->_5_1_2_expansion($activeCtx, $activeProp, $value, frameExpansion => $frameExpansion, ordered => $ordered);
println "13.4.12 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
# NOTE: the language here is really confusing. the first conditional in 13.4.13 is the conjunction "expanded property is @reverse and value is not a map".
# however, by context it seems that really everything under 13.4.13 assumes expanded property is @reverse, and the first branch is dependent only on 'value is not a map'.
if ($expandedProperty eq '@reverse') {
println "13.4.13" if $debug;
if (ref($value) ne 'HASH') {
println "13.4.13.1" if $debug;
die 'invalid @reverse value';
}
println "13.4.13.2" if $debug;
$expandedValue = $self->_5_1_2_expansion($activeCtx, '@reverse', $value, frameExpansion => $frameExpansion, ordered => $ordered); # 13.4.13.1
println "13.4.13.2 " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
if (ref($expandedValue) eq 'HASH' and exists $expandedValue->{'@reverse'}) { # NOTE: spec text does not assert that expandedValue is a map
println "13.4.13.3" if $debug;
foreach my $property (keys %{ $expandedValue->{'@reverse'} }) {
my $__indent = indent();
println "13.4.13.3 [$property]" if $debug;
my $item = $expandedValue->{'@reverse'}{$property};
if (not exists $result->{$property}) {
println "13.4.13.3.1" if $debug;
$result->{$property} = [];
}
println "13.4.13.3.2" if $debug;
push(@{ $result->{$property} }, @$item);
}
}
if (ref($expandedValue) eq 'HASH') { # NOTE: spec text does not assert that expandedValue is a map
my @keys = grep { $_ ne '@reverse' } keys %$expandedValue;
if (scalar(@keys)) {
println "13.4.13.4" if $debug;
if (not exists $result->{'@reverse'}) {
println "13.4.13.4.1" if $debug;
$result->{'@reverse'} = {};
}
println "13.4.13.4.2" if $debug;
my $reverse_map = $result->{'@reverse'};
println "13.4.13.4.3" if $debug;
foreach my $property (grep { $_ ne '@reverse' } keys %{ $expandedValue }) {
my $__indent = indent();
println "13.4.13.4.3 [$property]" if $debug;
my $items = $expandedValue->{$property};
println "13.4.13.4.3.1" if $debug;
foreach my $item (@$items) {
my $__indent = indent();
if ($self->_is_value_object($item) or $self->_is_list_object($item)) {
println "13.4.13.4.3.1.1" if $debug;
die 'invalid reverse property value';
}
if (not exists $reverse_map->{$property}) {
println "13.4.13.4.3.1.2" if $debug;
$reverse_map->{$property} = [];
}
println "13.4.13.4.3.1.3" if $debug;
push(@{ $reverse_map->{$property} }, $item);
}
}
}
}
println "13.4.13.5 going to next element key" if $debug;
next; # 13.4.13.5
}
if ($expandedProperty eq '@nest') {
println "13.4.14 adding '$key' to nests" if $debug;
$nests->{$key} //= [];
next;
}
if ($frameExpansion) {
my %other_framings = map { $_ => 1 } qw(@explicit @default @embed @explicit @omitDefault @requireAll);
if ($other_framings{$expandedProperty}) {
println "13.4.15" if $debug;
$expandedValue = $self->_5_1_2_expansion($activeCtx, $activeProp, $value, frameExpansion => $frameExpansion, ordered => $ordered); # 13.4.15
println "13.4.15 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
}
println "before 13.4.16 " . Data::Dumper->Dump([$expandedValue, $expandedProperty, $input_type], [qw'expandedValue expandedProperty input_type']) if $debug;
unless (not(defined($expandedValue)) and $expandedProperty eq '@value' and $input_type ne '@json') {
println "13.4.16 setting " . Data::Dumper->Dump([$expandedValue], [$expandedProperty]) if $debug;
# println "$expandedProperty expanded value is " . Dumper($expandedValue) if $debug;
$result->{$expandedProperty} = $expandedValue; # https://github.com/w3c/json-ld-api/issues/270
println "13.4.16 resulting in " . Data::Dumper->Dump([$result], ['*result']) if $debug;
}
println "13.4.17 going to next element key" if $debug;
next; # 13.4.17
}
my $tdef = $self->_ctx_term_defn($activeCtx, $key);
println "13.5 initializing container mapping" if $debug;
my $container_mapping = $tdef->{'container_mapping'}; # 13.5
println(Data::Dumper->Dump([$container_mapping, $value], ['*container_mapping', '*value'])) if $debug;
if (exists($tdef->{'type_mapping'}) and $tdef->{'type_mapping'} eq '@json') {
println "13.6" if $debug;
$expandedValue = { '@value' => $value, '@type' => '@json' }; # 13.6
println "13.6 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
} elsif ($self->_cm_contains($container_mapping, '@language') and ref($value) eq 'HASH') {
println "13.7" if $debug;
println "13.7.1" if $debug;
$expandedValue = [];
println "13.7.2" if $debug;
my $direction = $activeCtx->{'@direction'};
if (exists $tdef->{'direction_mapping'}) {
println "13.7.3" if $debug;
$direction = $tdef->{'direction_mapping'};
}
println "13.7.4" if $debug;
for my $language (sort keys %$value) {
my $__indent = indent();
my $language_value = $value->{$language};
println "13.7.4 [$language]" if $debug;
if (ref($language_value) ne 'ARRAY') {
println "13.7.4.1" if $debug;
$language_value = [$language_value];
}
println "13.7.4.2" if $debug;
foreach my $item (@$language_value) {
my $__indent = indent();
unless (defined($item)) {
println "13.7.4.2.1" if $debug;
next;
}
if (ref($item)) {
println "13.7.4.2.2" if $debug;
die 'invalid language map value';
}
println "13.7.4.2.3" if $debug;
my $v = {'@value' => $item, '@language' => $language};
my $well_formed = 1; # TODO: check BCP47 well-formedness of $item
if ($item ne '@none' and not($well_formed)) {
warn "Language tag is not well-formed: $item";
}
# TODO: normalize language tag
my $expandedLanguage = $self->_5_2_2_iri_expansion($activeCtx, $language);
if ($language eq '@none' or $expandedLanguage eq '@none') {
println "13.7.4.2.4" if $debug;
delete $v->{'@language'};
}
if (defined($direction)) {
println "13.7.4.2.5" if $debug;
$v->{'@direction'} = $direction;
}
println "13.7.4.2.6" if $debug;
push(@$expandedValue, $v);
}
}
println "13.7 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
# } elsif ((exists $container_mapping->{'@index'} or exists $container_mapping->{'@type'} or exists $container_mapping->{'@id'}) and ref($value) eq 'HASH') {
} elsif ($self->_cm_contains_any($container_mapping, '@index', '@type', '@id') and ref($value) eq 'HASH') {
println "13.8" if $debug;
println "13.8.1" if $debug;
$expandedValue = [];
println "13.8.2" if $debug;
my $index_key = $tdef->{'index_mapping'} // '@index';
println "13.8.3" if $debug;
foreach my $index (sort keys %$value) {
my $__indent = indent();
my $index_value = $value->{$index};
println '-----------------------------------------------------------------' if $debug;
println "13.8.3 [$index]" if $debug;
my $map_context;
if ($self->_cm_contains_any($container_mapping, '@id', '@type')) {
println "13.8.3.1" if $debug;
$map_context = $activeCtx->{'previous_context'} // $activeCtx;
} else {
$map_context = $activeCtx;
}
my $index_tdef = $self->_ctx_term_defn($map_context, $index);
if ($self->_cm_contains_any($container_mapping, '@type') and exists $index_tdef->{'@context'}) {
println "13.8.3.2" if $debug;
$map_context = $self->_4_1_2_ctx_processing($map_context, $index_tdef->{'@context'});
} else {
println "13.8.3.3" if $debug;
$map_context = $activeCtx;
}
println "13.8.3.4" if $debug;
my $expanded_index = $self->_5_2_2_iri_expansion($activeCtx, $index, vocab => 1);
if (ref($index_value) ne 'ARRAY') {
println "13.8.3.5" if $debug;
$index_value = [$index_value];
}
println "13.8.3.6" if $debug;
$index_value = $self->_5_1_2_expansion($map_context, $key, $index_value, frameExpansion => $frameExpansion, ordered => $ordered);
println(Data::Dumper->Dump([$index_value], ['*index_value'])) if $debug;
println "13.8.3.7" if $debug;
foreach my $item (@$index_value) {
my $__indent = indent();
println '-----------------------------------------------------------------' if $debug;
println "13.8.3.7 [$item]" if $debug;
if ($self->_cm_contains($container_mapping, '@graph') and not $self->_is_graph_object($item)) {
println(Data::Dumper->Dump([$container_mapping], ['*container_mapping'])) if $debug;
println "13.8.3.7.1" if $debug;
$item = {'@graph' => (ref($item) eq 'ARRAY') ? $item : [$item]};
println(Data::Dumper->Dump([$item], ['*item'])) if $debug;
}
if ($self->_cm_contains($container_mapping, '@index') and $index_key ne '@index' and $expanded_index ne '@none') {
println "13.8.3.7.2 " . Data::Dumper->Dump([$index_key], ['index_key']) if $debug;
println "13.8.3.7.2.1" if $debug;
my $re_expanded_index = $self->_5_3_2_value_expand($activeCtx, $index_key, $index);
println "13.8.3.7.2.2" if $debug;
my $expanded_index_key = $self->_5_2_2_iri_expansion($activeCtx, $index_key, vocab => 1);
println "13.8.3.7.2.3" if $debug;
my $index_property_values = [$re_expanded_index];
if (exists $item->{$expanded_index_key}) {
my $v = $item->{$expanded_index_key};
if (ref($v) eq 'ARRAY') {
push(@{$index_property_values}, @$v);
} else {
push(@{$index_property_values}, $v);
}
}
println "13.8.3.7.2.4" if $debug;
$item->{$expanded_index_key} = $index_property_values;
if ($self->_is_value_object($item)) {
my @keys = sort keys %$item;
if (scalar(@keys) > 1) {
die 'invalid value object';
}
}
} elsif ($self->_cm_contains($container_mapping, '@index') and not exists $item->{'@index'} and $expanded_index ne '@none') {
println "13.8.3.7.3" if $debug;
$item->{'@index'} = $index;
println(Data::Dumper->Dump([$item], ['*item'])) if $debug;
} elsif ($self->_cm_contains($container_mapping, '@id') and not exists $item->{'@id'} and $expanded_index ne '@none') {
println "13.8.3.7.4" if $debug;
$expanded_index = $self->_5_2_2_iri_expansion($activeCtx, $index, documentRelative => 1);
$item->{'@id'} = $expanded_index;
} elsif ($self->_cm_contains($container_mapping, '@type') and $expanded_index ne '@none') {
println "13.8.3.7.5" if $debug;
my $types = [$expanded_index];
if (exists $item->{'@type'}) {
my $v = $item->{'@type'};
if (ref($v) eq 'ARRAY') {
push(@$types, @{$item->{'@type'}});
} else {
push(@$types, $v);
}
}
$item->{'@type'} = $types;
println "13.8.3.7.5 " . Data::Dumper->Dump([$types], ['types']) if $debug;
}
println "13.8.3.7.6" if $debug;
push(@$expandedValue, $item);
}
}
println "13.8 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
} else {
println "13.9" if $debug;
$expandedValue = $self->_5_1_2_expansion($activeCtx, $key, $value, frameExpansion => $frameExpansion, ordered => $ordered); # 13.9
println "13.9 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
# warn Dumper($expandedValue);
if (not(defined($expandedValue))) {
println "13.10 going to next element key" if $debug;
next; # 13.10
}
if ($self->_cm_contains($container_mapping, '@list') and not $self->_is_list_object($expandedValue)) {
# 13.11
println "13.11" if $debug;
unless (ref($expandedValue) eq 'ARRAY') {
$expandedValue = [$expandedValue];
}
$expandedValue = { '@list' => $expandedValue };
println "13.11 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
if ($self->_cm_contains($container_mapping, '@graph') and not($self->_cm_contains($container_mapping, '@id')) and not($self->_cm_contains($container_mapping, '@index'))) {
# https://github.com/w3c/json-ld-api/issues/311
# 13.12
println "13.12" if $debug;
if (ref($expandedValue) ne 'ARRAY') {
$expandedValue = [$expandedValue];
}
my @values;
foreach my $ev (@$expandedValue) {
println "13.12.1" if $debug;
my $av = (ref($ev) eq 'ARRAY') ? $ev : [$ev];
push(@values, {'@graph' => $av});
}
$expandedValue = \@values;
println "13.12 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
if ($tdef->{'reverse'}) {
# 13.13
println "13.13" if $debug;
unless (exists $result->{'@reverse'}) {
println "13.13.1" if $debug;
$result->{'@reverse'} = {};
}
println "13.13.2" if $debug;
my $reverse_map = $result->{'@reverse'};
if (ref($expandedValue) ne 'ARRAY') {
println "13.13.3" if $debug;
$expandedValue = [$expandedValue];
}
foreach my $item (@$expandedValue) {
println "13.13.4" if $debug;
if ($self->_is_value_object($item) or $self->_is_list_object($item)) {
println "13.13.4.1" if $debug;
die 'invalid reverse property value';
}
unless (exists $reverse_map->{$expandedProperty}) {
println "13.13.4.2" if $debug;
$reverse_map->{$expandedProperty} = [];
}
println "13.13.4.3" if $debug;
push(@{ $reverse_map->{$expandedProperty} }, $item);
}
println "13.13 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
} else {
# 13.14
println "13.14" if $debug;
unless (exists $result->{$expandedProperty}) {
println "13.14.1" if $debug;
$result->{$expandedProperty} = []; # 13.14.1
}
println "13.14.2 appending to result[$expandedProperty]: " . Data::Dumper->Dump([$expandedValue], ['expandedValue']) if $debug;
if (ref($expandedValue) eq 'ARRAY') {
push(@{$result->{$expandedProperty}}, @$expandedValue); # 13.14.2
} elsif (ref($expandedValue)) {
println "setting result[$expandedProperty]" if $debug;
push(@{$result->{$expandedProperty}}, $expandedValue); # 13.14.2
}
println "13.14 resulting in " . Data::Dumper->Dump([$expandedValue], ['*expandedValue']) if $debug;
}
}
$self->_5_1_2_expansion_step_14($activeCtx, $type_scoped_ctx, $result, $activeProp, $input_type, $nests, $ordered, $frameExpansion, $element);
}
sub _5_1_2_expansion_step_14 {
my $self = shift;
my $activeCtx = shift;
my $type_scoped_ctx = shift;
my $result = shift;
my $activeProp = shift;
my $input_type = shift;
my $nests = shift;
my $ordered = shift;
my $frameExpansion = shift;
my $element = shift;
# https://github.com/w3c/json-ld-api/issues/262
println "14" if $debug;
my @keys = sort keys %$nests; # https://github.com/w3c/json-ld-api/issues/295
foreach my $nesting_key (@keys) {
delete $nests->{$nesting_key};
# 14
my $__indent = indent();
println "14 [$nesting_key]" if $debug;
println "14.1" if $debug;
# next unless (exists $element->{$nesting_key});
my $nested_values = $element->{$nesting_key}; # 14.1
if (not defined $nested_values) {
$nested_values = [];
}
if (not(ref($nested_values)) or ref($nested_values) ne 'ARRAY') {
$nested_values = [$nested_values];
}
println "14.2" if $debug;
println(Data::Dumper->Dump([$nesting_key, $element, $nested_values], [qw(nesting_key element nested_values)])) if $debug;
foreach my $nested_value (@$nested_values) {
my $__indent = indent();
println '-----------------------------------------------------------------' if $debug;
println "14.2 loop iteration" if $debug;
if (ref($nested_value) ne 'HASH') {
println "14.2.1 " . Data::Dumper->Dump([$nested_value], ['*invalid_nest_value']) if $debug;
die 'invalid @nest value'; # 14.2.1
}
my @keys = keys %$nested_value;
my %expandedKeys = map { $_ => 1 } map { $self->_5_2_2_iri_expansion($activeCtx, $_) } @keys;
if (exists $expandedKeys{'@value'}) {
println "14.2.1 " . Data::Dumper->Dump([$nested_value], ['*invalid_nest_value']) if $debug;
die 'invalid @nest value';
}
println "14.2.2 ENTER =================> call to _5_1_2_expansion_step_13" if $debug;
my $__indent_2 = indent();
$self->_5_1_2_expansion_step_13($activeCtx, $type_scoped_ctx, $result, $activeProp, $input_type, $nests, $ordered, $frameExpansion, $nested_value); # 14.2.2
}
}
println "after 14 resulting in " . Data::Dumper->Dump([$result], ['*result']) if $debug;
}
sub _5_2_2_iri_expansion {
my $self = shift;
my $activeCtx = shift;
my $value = shift;
println "ENTER =================> _5_2_2_iri_expansion($value)" if $debug;
my $__indent = indent();
my %args = @_;
my %acceptable = map { $_ => 1 } qw(documentRelative vocab localCtx defined);
foreach my $k (keys %args) {
die "Not a recognized IRI expansion algorithm argument: $k" unless exists $acceptable{$k};
}
my $vocab = $args{vocab} // 0;
my $documentRelative = $args{documentRelative} // 0;
my $localCtx = $args{localCtx} // {};
my $defined = $args{'defined'} // {};
local($Data::Dumper::Indent) = 0;
println(Data::Dumper->Dump([$activeCtx], ['*activeCtx'])) if $debug;
println(Data::Dumper->Dump([$localCtx], ['*localCtx'])) if $debug;
println(Data::Dumper->Dump([$defined], ['*defined'])) if $debug;
# 5.2.2 algorithm
unless (defined($value) and not exists $keywords{$value}) {
println "1 returning from _5_2_2_iri_expansion: undefined/keyword value" if $debug;
return $value;
}
if ($value =~ /^@[A-Za-z]+$/) {
println "2" if $debug;
warn "IRI expansion attempted on a term that looks like a keyword: $value\n"; # 2
return;
}
if (defined($localCtx) and my $v = $localCtx->{$value}) {
unless ($defined->{$v}) {
println "3" if $debug;
$self->_4_2_2_create_term_definition($activeCtx, $localCtx, $value, $defined); # 3
}
}
if (my $tdef = $self->_ctx_term_defn($activeCtx, $value)) {
my $i = $tdef->{'iri_mapping'} // '';
if ($keywords{$i}) {
println "4 returning from _5_2_2_iri_expansion with a keyword: $i" if $debug;
return $i; # 4
}
}
if ($vocab and my $tdef = $self->_ctx_term_defn($activeCtx, $value)) {
my $i = $tdef->{'iri_mapping'};
println "5 returning from _5_2_2_iri_expansion with iri mapping from active context: $i" if $debug;
return $i; # 5
}
if ($value =~ /.:/) {
# 6
println "6" if $debug;
println "6.1" if $debug;
my ($prefix, $suffix) = split(/:/, $value, 2); # 6.1
if ($prefix eq '_' or $suffix =~ m{^//}) {
println "6.2 returning from _5_2_2_iri_expansion: already an absolute IRI or blank node identifier: $value" if $debug;
return $value; # 6.2
}
if ($localCtx and exists $localCtx->{$prefix} and not($defined->{$prefix})) {
println "6.3" if $debug;
$self->_4_2_2_create_term_definition($activeCtx, $localCtx, $prefix, $defined);
}
my $tdef = $self->_ctx_term_defn($activeCtx, $prefix);
if ($tdef and $tdef->{'iri_mapping'} and $tdef->{'prefix_flag'}) {
my $i = $tdef->{'iri_mapping'} . $suffix;
println "6.4 returning from _5_2_2_iri_expansion with concatenated iri mapping and suffix: $i" if $debug;
return $i;
}
if ($self->_is_abs_iri($value)) {
println "6.5 returning from _5_2_2_iri_expansion with absolute IRI: $value" if $debug;
return $value;
}
}
if ($vocab and exists $activeCtx->{'@vocab'}) {
my $i = $activeCtx->{'@vocab'} . $value;
println "7 returning from _5_2_2_iri_expansion with concatenated vocabulary mapping and value: $i" if $debug;
return $i;
} elsif ($documentRelative) {
# 8
println "8" if $debug;
my $base = $activeCtx->{'@base'};
if (defined $base) {
my $i = IRI->new(value => $value, base => $base);
$value = $i->abs;
}
}
println "9 returning from _5_2_2_iri_expansion with final value: $value" if $debug;
return $value; # 9
}
sub _5_3_2_value_expand {
my $self = shift;
my $activeCtx = shift;
my $activeProp = shift;
my $value = shift;
my $_vs = Data::Dumper->new([$value], ['value'])->Terse(1)->Dump([$value], ['value']);
println "ENTER =================> _5_3_2_value_expand($_vs)" if $debug;
my $__indent = indent();
my $tdef = $self->_ctx_term_defn($activeCtx, $activeProp);
if (exists $tdef->{'type_mapping'}) {
if ($tdef->{'type_mapping'} eq '@id' and _is_string($value)) {
my $iri = $self->_5_2_2_iri_expansion($activeCtx, $value, documentRelative => 1);
println "1 returning from _5_3_2_value_expand with new map containing \@id: $iri" if $debug;
return { '@id' => $iri }; # 1
}
if ($tdef->{'type_mapping'} eq '@vocab' and _is_string($value)) {
my $iri = $self->_5_2_2_iri_expansion($activeCtx, $value, vocab => 1, documentRelative => 1);
println "1 returning from _5_3_2_value_expand with new map containing vocab \@id: $iri" if $debug;
return { '@id' => $iri }; # 2
}
}
println "3" if $debug;
my $result = { '@value' => $value }; # 3
my $tm = $tdef->{'type_mapping'};
if (exists($tdef->{'type_mapping'}) and $tm ne '@id' and $tm ne '@vocab' and $tm ne '@none') {
println "4" if $debug;
$result->{'@type'} = $tm; # 4
} elsif (_is_string($value)) {
println "5" if $debug;
println "5.1" if $debug;
my $language = (exists $tdef->{'language_mapping'}) ? $tdef->{'language_mapping'} : $activeCtx->{'@language'}; # 5.1
println "5.2" if $debug;
my $direction = (exists $tdef->{'direction_mapping'}) ? $tdef->{'direction_mapping'} : $activeCtx->{'@direction'}; # 5.2
if (defined($language)) {
println "5.3" if $debug;
$result->{'@language'} = $language; # 5.3
}
if (defined($direction)) {
println "5.4" if $debug;
$result->{'@direction'} = $direction; # 5.4
}
}
println "6 returning from _5_3_2_value_expand with final result" if $debug;
return $result; # 6
}
sub _6_1_2_compaction {
my $self = shift;
my $activeCtx = shift;
my $inverseCtx = shift;
my $activeProp = shift;
my $element = shift;
{
no warnings 'uninitialized';
println "ENTER =================> _6_1_2_compaction('$activeProp')" if $debug;
}
my $__indent = indent();
# local($Data::Dumper::Indent) = 0;
# println(Data::Dumper->Dump([$activeCtx], ['activeCtx'])) if $debug;
# println(Data::Dumper->Dump([$activeProp], ['activeProp'])) if $debug;
println(Data::Dumper->Dump([$element], ['element'])) if $debug;
my %args = @_;
my $compactArrays = $args{compactArrays} // 0;
my $ordered = $args{ordered} // 0;
println "1" if $debug;
my $type_scoped_ctx = clone($activeCtx);
if (_is_scalar($element)) {
println "2 returning scalar " . Data::Dumper->Dump([$element], [qw(element)]) if $debug;
return $element;
}
if (ref($element) eq 'ARRAY') {
println "3" if $debug;
println "3.1" if $debug;
my $result = [];
println "3.2" if $debug;
foreach my $item (@$element) {
println "3.2.1" if $debug;
my $compactedItem = $self->_6_1_2_compaction($activeCtx, $inverseCtx, $activeProp, $item, %args);
if (defined($compactedItem)) {
println "3.2.2" if $debug;
push(@$result, $compactedItem);
}
}
my $not_graph = ($activeProp // '') ne '@graph';
my $not_set = ($activeProp // '') ne '@set';
my $tdef = $self->_ctx_term_defn($activeCtx, $activeProp);
my $container_mapping = $tdef->{'container_mapping'};
# https://github.com/w3c/json-ld-api/issues/334
# if (scalar(@$result) == 1 and $compactArrays and (($not_graph and $not_set) or (not($self->_cm_contains_any($container_mapping, '@list', '@set')) ))) {
if (scalar(@$result) == 1 and (($not_graph and $not_set) or (not($self->_cm_contains_any($container_mapping, '@list', '@set')) and $compactArrays))) {
# https://github.com/w3c/json-ld-api/issues/334
println "3.3" if $debug;
$result = $result->[0];
}
println "3.4 returning " . Data::Dumper->Dump([$result], [qw(result)]) if $debug;
return $result;
}
println "4 element is a map" if $debug;
if (exists $activeCtx->{'previous_context'}) {
if (not exists $element->{'@value'}) {
my @keys = keys %$element;
unless (scalar(@keys) == 1 and $keys[0] eq '@id') {
println "5" if $debug;
$activeCtx = $activeCtx->{'previous_context'};
}
}
}
my $tdef = $self->_ctx_term_defn($activeCtx, $activeProp);
if (exists $tdef->{'@context'}) {
println "6" if $debug;
println "6.1" if $debug;
$activeCtx = $self->_4_1_2_ctx_processing($activeCtx, $tdef->{'@context'}, override_protected => 1);
println "6.2" if $debug;
$inverseCtx = $self->_4_3_inverse_context_creation($activeCtx);
}
if (exists $element->{'@value'} or exists $element->{'@id'}) {
println "possibly 7" if $debug;
my $v = $self->_6_3_value_compaction($activeCtx, $inverseCtx, $activeProp, $element);
my $tm = $tdef->{'type_mapping'} // '';
if (_is_scalar($v) or $tm eq '@json') {
println "7 returning " . Data::Dumper->Dump([$v], [qw(result)]) if $debug;
return $v;
}
}
my $container_mapping = $tdef->{'container_mapping'};
if (_is_list_object($element) and $self->_cm_contains($container_mapping, '@list')) {
println "8" if $debug;
my $result = $self->_6_1_2_compaction($activeCtx, $inverseCtx, $activeProp, $element->{'@list'}, %args);
println "8 returning " . Data::Dumper->Dump([$result], [qw(result)]) if $debug;
return $result;
}
println "9" if $debug;
my $insideReverse = (defined($activeProp) and $activeProp eq '@reverse');
println "10" if $debug;
my $result = {};
if (exists $element->{'@type'}) {
println "11" if $debug;
my @types = _values_from_scalar_or_array($element->{'@type'});
# my @types = @{ $element->{'@type'} };
my @compacted_types = map { $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $_, vocab => 1) } @types;
foreach my $term (sort @compacted_types) {
println "11.1" if $debug;
my $tdef = $self->_ctx_term_defn($type_scoped_ctx, $term);
if (exists $tdef->{'@context'}) {
println "11.1.1" if $debug;
$activeCtx = $self->_4_1_2_ctx_processing($activeCtx, $tdef->{'@context'});
println "11.1.2" if $debug;
$inverseCtx = $self->_4_3_inverse_context_creation($activeCtx);
}
}
}
println "12" if $debug;
foreach my $expandedProperty (sort keys %$element) {
my $__indent = indent();
println "----------------------------------------------------------------" if $debug;
my $expandedValue = $element->{$expandedProperty};
println "12 [$expandedProperty]" if $debug;
my $tdef = $self->_ctx_term_defn($activeCtx, $activeProp) || {};
my $container_mapping = $tdef->{'container_mapping'};
if ($expandedProperty eq '@id') {
println "12.1" if $debug;
if (_is_string($expandedValue)) {
println "12.1.1" if $debug;
my $compactedValue = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedValue, vocab => 0);
println "12.1.2" if $debug;
my $alias = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedProperty, vocab => 1);
println "12.1.3" if $debug;
$result->{$alias} = $compactedValue;
next;
}
} elsif ($expandedProperty eq '@type') {
println "12.2" if $debug;
my $compactedValue;
if (_is_string($expandedValue)) {
println "12.2.1" if $debug;
$compactedValue = $self->_6_2_2_iri_compaction($type_scoped_ctx, $inverseCtx, $expandedValue, vocab => 1);
} else {
println "12.2.2" if $debug;
println "12.2.2.1" if $debug;
$compactedValue = [];
println "12.2.2.2" if $debug;
foreach my $expandedType (@{ $expandedValue }) {
println "12.2.2.2.1" if $debug;
my $term = $self->_6_2_2_iri_compaction($type_scoped_ctx, $inverseCtx, $expandedType, vocab => 1);
println "12.2.2.2.2" if $debug;
push(@{ $compactedValue }, $term);
}
println "12.2.2.3" if $debug;
if (scalar(@$compactedValue) == 1) {
$compactedValue = $compactedValue->[0];
}
}
println "12.2.3" if $debug;
my $alias = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedProperty, vocab => 1);
println "12.2.4" if $debug;
my $tdef = $self->_ctx_term_defn($activeCtx, $alias);
my $container_mapping = $tdef->{'container_mapping'};
my $as_array = ($self->_cm_contains($container_mapping, '@set'))
? 1
: not($compactArrays);
println "12.2.5" if $debug;
$self->_add_value($result, $alias, $compactedValue, as_array => $as_array);
println "12.2.6" if $debug;
next;
} elsif ($expandedProperty eq '@reverse') {
println "12.3" if $debug;
println "12.3.1" if $debug;
my $compactedValue = $self->_6_1_2_compaction($activeCtx, $inverseCtx, '@reverse', $expandedValue, compactArrays => $compactArrays, ordered => $ordered);
foreach my $property (keys %$compactedValue) {
println "12.3.2 [$property]" if $debug;
my $value = $compactedValue->{$property};
my $tdef = $self->_ctx_term_defn($activeCtx, $property);
if ($tdef->{'reverse'}) {
println "12.3.2.1" if $debug;
println "12.3.2.1.1" if $debug;
my $container_mapping = $tdef->{'container_mapping'};
my $as_array;
if ($self->_cm_contains($container_mapping, '@set')) {
$as_array = 1;
} else {
$as_array = not($compactArrays);
}
println "12.3.2.1.2" if $debug;
$self->_add_value($result, $property, $value, as_array => $as_array);
println "12.3.2.1.3" if $debug;
delete $compactedValue->{$property};
}
}
my @keys = keys %$compactedValue;
if (scalar(@keys)) {
println "12.3.3" if $debug;
println "12.3.3.1" if $debug;
my $alias = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@reverse', vocab => 1);
println "12.3.3.2" if $debug;
$result->{$alias} = $compactedValue;
}
println "12.3.4" if $debug;
next;
} elsif ($expandedProperty eq '@preserve') {
println "12.4" if $debug;
println "12.4.1" if $debug;
my $compactedValue = $self->_6_1_2_compaction($activeCtx, $inverseCtx, $activeProp, $expandedValue, compactArrays => $compactArrays, ordered => $ordered);
unless (ref($expandedValue) eq 'ARRAY' and scalar(@$expandedValue) == 0) {
println "12.4.2" if $debug;
$result->{'@preserve'} = $compactedValue;
}
} elsif ($expandedProperty eq '@index' and $self->_cm_contains($container_mapping, '@index')) {
println "12.5" if $debug;
next;
} elsif ($expandedProperty =~ /^@(direction|index|language|value)$/) {
println "12.6" if $debug;
println "12.6.1" if $debug;
my $alias = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedProperty, vocab => 1);
println "12.6.2" if $debug;
$result->{$alias} = $expandedValue;
next;
}
if (ref($expandedValue) eq 'ARRAY' and scalar(@$expandedValue) == 0) {
println "12.7" if $debug;
println "12.7.1" if $debug;
# https://github.com/w3c/json-ld-api/issues/357
my $item_active_property = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedProperty, value => $expandedValue, vocab => 1, 'reverse' => $insideReverse);
println "12.7.2" if $debug;
my $tdef = $self->_ctx_term_defn($activeCtx, $item_active_property);
my $nest_result;
if (exists $tdef->{'nest_value'}) {
my $nest_term = $tdef->{'nest_value'};
if ($nest_term ne '@nest') {
die 'invalid @nest value';
}
if (not exists $result->{$nest_term}) {
$result->{$nest_term} = {};
}
if (not exists $result->{$nest_term}{$item_active_property}) {
$result->{$nest_term}{$item_active_property} = [];
} elsif (ref($result->{$nest_term}{$item_active_property}) ne 'ARRAY') {
$result->{$nest_term}{$item_active_property} = [$result->{$nest_term}{$item_active_property}];
}
} else {
println "12.7.3" if $debug;
if (not exists $result->{$item_active_property}) {
$result->{$item_active_property} = [];
} elsif (ref($result->{$item_active_property}) ne 'ARRAY') {
$result->{$item_active_property} = [$result->{$item_active_property}];
}
}
}
println "12.8" if $debug;
foreach my $expandedItem (@$expandedValue) {
println "12.8.1" if $debug;
my $item_active_property = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedProperty, value => $expandedItem, vocab => 1, 'reverse' => $insideReverse);
println(Data::Dumper->Dump([$item_active_property], ['item_active_property'])) if $debug;
my $tdef = $self->_ctx_term_defn($activeCtx, $item_active_property);
my $nest_result;
if (exists $tdef->{'nest_value'}) {
println "12.8.2" if $debug;
my $nest_term = $tdef->{'nest_value'};
if ($nest_term ne '@nest') {
die 'invalid @nest value';
}
$nest_result = $result->{$nest_term} // {};
} else {
println "12.8.3" if $debug;
$nest_result = $result;
}
println "12.8.4 " . Data::Dumper->Dump([$container_mapping], [qw(container_mapping)]) if $debug;
my $container = undef;
my $container_mapping = $tdef->{'container_mapping'};
if (defined $container_mapping) {
# https://github.com/w3c/json-ld-api/issues/322
$container = [grep { $_ ne '@set' } @$container_mapping]; # TODO unfiled issue on this
# $container = (grep { $_ ne '@set' } @$container_mapping)[0];
}
println "12.8.5" if $debug;
my $as_array = ($self->_cm_contains($container_mapping, '@set') or $item_active_property eq '@graph' or $item_active_property eq '@list');
println "12.8.6" if $debug;
my $_element = ((ref($expandedItem) ne 'HASH' or not exists $expandedItem->{'@list'}) and (not($self->_is_graph_object($expandedItem)) or not exists($expandedItem->{'@list'})))
? $expandedItem
: $expandedItem->{'@list'};
my $compactedItem = $self->_6_1_2_compaction($activeCtx, $inverseCtx, $item_active_property, $_element, %args);
if ($self->_is_list_object($expandedItem)) {
println "12.8.7" if $debug;
if (ref($compactedItem) ne 'ARRAY') {
println "12.8.7.1" if $debug;
$compactedItem = [$compactedItem];
}
if (not $self->_cm_contains($container, '@list')) {
println "12.8.7.2" if $debug;
println "12.8.7.2.1" if $debug;
my $key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@list', value => $compactedItem);
$compactedItem = { $key => $compactedItem };
println "12.8.7.2.2" if $debug;
if (exists $expandedItem->{'@index'}) {
my $key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@index');
$compactedItem->{ $key } = $expandedItem->{'@index'};
}
}
}
if ($self->_is_graph_object($expandedItem)) {
println "12.8.8"; # if $debug;
if ($self->_cm_contains($container, '@graph') and $self->_cm_contains($container, '@id')) {
println "12.8.8.1" if $debug;
println "12.8.8.1.1" if $debug;
my $map_object = ($nest_result->{$item_active_property} //= {});
println "12.8.8.1.2" if $debug;
my $map_key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedItem->{'@id'} // '@none', vocab => (not exists $expandedItem->{'@id'}));
println "12.8.8.1.3" if $debug;
$self->_add_value($map_object, $map_key, $compactedItem, as_array => $as_array);
} elsif ($self->_cm_contains($container, '@graph') and $self->_cm_contains($container, '@index') and $self->_is_simple_graph_object($expandedItem)) {
println "12.8.8.2" if $debug;
println "12.8.8.2.1" if $debug;
my $map_object = ($nest_result->{$item_active_property} //= {});
println "12.8.8.2.2" if $debug;
my $map_key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedItem->{'@index'} // '@none');
println "12.8.8.2.3" if $debug;
$self->_add_value($map_object, $map_key, $compactedItem, as_array => $as_array);
} elsif ($container eq '@graph' and $self->_is_simple_graph_object($expandedItem)) {
println "12.8.8.3" if $debug;
if (ref($compactedItem) eq 'ARRAY' and scalar(@$compactedItem) > 1) {
println "12.8.8.3.1" if $debug;
my $k = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@included', value => $compactedItem);
$compactedItem = {$k => $compactedItem};
}
println "12.8.8.3.2" if $debug;
$self->_add_value($nest_result, $item_active_property, $compactedItem, as_array => $as_array);
} elsif ($container ne '@graph') {
println "12.8.8.4" if $debug;
println "12.8.8.4.1" if $debug;
my $key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@graph', vocab => 1);
$compactedItem = { $key => $compactedItem };
if (exists $expandedItem->{'@id'}) {
println "12.8.8.4.2" if $debug;
my $key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@id', vocab => 1);
my $value = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $expandedItem->{'@id'});
$compactedItem->{$key} = $value;
}
if (exists $expandedItem->{'@index'}) {
println "12.8.8.4.3" if $debug;
my $key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@index', vocab => 1);
$compactedItem->{$key} = $expandedItem->{'@index'};
}
println "12.8.8.4.4" if $debug;
$self->_add_value($nest_result, $item_active_property, $compactedItem, as_array => $as_array);
}
} elsif ($self->_cm_contains_any($container, '@language', '@index', '@id', '@type') and not $self->_cm_contains($container, '@graph')) {
# TODO: spec text here is really confused since the type of `container` is scalar: "Otherwise, if container includes @language, @index, @id, or @type and container does not include @graph"
println "12.8.9" if $debug;
println "12.8.9.1" if $debug;
my $map_object = ($nest_result->{$item_active_property} //= {});
println "12.8.9.2" if $debug;
my $compaction_value;
foreach my $k ('@language', '@index', '@id', '@type') {
$compaction_value = $k if ($self->_cm_contains_any($container, $k));
}
my $container_key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $compaction_value, vocab => 1);
println "12.8.9.3" if $debug;
my $tdef = $self->_ctx_term_defn($activeCtx, $item_active_property) // {};
my $index_key = $tdef->{'index_mapping'} // '@index';
my $map_key;
if ($self->_cm_contains_any($container, '@language') and exists $expandedItem->{'@value'}) {
println "12.8.9.4" if $debug;
$compactedItem = $expandedItem->{'@value'};
$map_key = $expandedItem->{'@language'};
} elsif ($self->_cm_contains_any($container, '@index') and $index_key eq '@index') {
println "12.8.9.5" if $debug;
$map_key = $expandedItem->{'@index'};
} elsif ($self->_cm_contains_any($container, '@index') and $index_key ne '@index') {
println "12.8.9.6" if $debug;
my @values = (ref($compactedItem) eq 'ARRAY')
? @{ $compactedItem->{$container_key} || [] }
: ($compactedItem->{$container_key});
$map_key = shift @values;
if (scalar(@values)) {
$compactedItem->{$container_key} = [@values];
} else {
delete $compactedItem->{$container_key};
}
} elsif ($self->_cm_contains_any($container, '@id')) {
println "12.8.9.7" if $debug;
$map_key = delete $compactedItem->{$container_key};
} elsif ($self->_cm_contains_any($container, '@type')) {
println "12.8.9.8" if $debug;
println "12.8.9.8.1" if $debug;
my @values = @{ $compactedItem->{$container_key} || [] };
$map_key = shift @values;
if (scalar(@values)) {
println "12.8.9.8.2" if $debug;
$compactedItem->{$container_key} = [@values];
} else {
println "12.8.9.8.3" if $debug;
delete $compactedItem->{$container_key};
}
my @keys = map { $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $_, vocab => 1) } keys %$compactedItem;
if (scalar(@keys) == 1 and $keys[0] eq '@id') {
println "12.8.9.8.4" if $debug;
$compactedItem = $self->_6_1_2_compaction($activeCtx, $inverseCtx, $item_active_property, {'@id' => $expandedItem});
}
}
if (not defined($map_key)) {
println "12.8.9.9" if $debug;
$map_key = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, '@none', vocab => 1);
}
println "12.8.9.10 adding value to [$map_key]" if $debug;
$self->_add_value($map_object, $map_key, $compactedItem, as_array => 1);
} else {
println "12.8.10" if $debug;
if (not($compactArrays) and $as_array and ref($compactedItem) ne 'ARRAY') {
println "12.8.10.1" if $debug;
$compactedItem = [$compactedItem];
}
if (not exists $result->{$item_active_property}) {
println "12.8.10.2" if $debug;
$nest_result->{$item_active_property} = $compactedItem;
} else {
println "12.8.10.3" if $debug;
if (ref($nest_result->{$item_active_property}) ne 'ARRAY') {
$nest_result->{$item_active_property} = [$nest_result->{$item_active_property}];
}
if (ref($compactedItem) eq 'ARRAY') {
push(@{$nest_result->{$item_active_property}}, @{ $compactedItem });
} else {
push(@{$nest_result->{$item_active_property}}, $compactedItem);
}
}
}
}
println "after this 12 loop body " . Data::Dumper->Dump([$result], [qw(result)]) if $debug;
}
println "13 returning " . Data::Dumper->Dump([$result], [qw(result)]) if $debug;
return $result;
}
sub _6_2_2_iri_compaction {
my $self = shift;
my $activeCtx = shift;
my $inverseCtx = shift;
my $var = shift;
my %args = @_;
my $value = $args{'value'};
my $vocab = $args{'vocab'} || 0;
my $reverse = $args{'reverse'} || 0;
{
no warnings 'uninitialized';
println "ENTER =================> _6_2_2_iri_compaction('$var')" if $debug;
}
my $__indent = indent();
# println(Data::Dumper->Dump([$activeCtx], ['activeCtx'])) if $debug;
# println(Data::Dumper->Dump([$inverseCtx], ['inverseCtx'])) if $debug;
unless (defined($var)) {
println "1 returning" if $debug;
return;
}
if ($vocab and exists $inverseCtx->{$var}) {
println "2" if $debug;
println "2.1" if $debug;
my $defaultLanguage;
if (defined $activeCtx->{'default_base_direction'}) {
println "2.1.1" if $debug;
$defaultLanguage = join('_', $activeCtx->{'@language'}, $activeCtx->{'default_base_direction'});
} else {
println "2.1.2" if $debug;
if (exists $activeCtx->{'@language'}) {
$defaultLanguage = lc($activeCtx->{'@language'});
} else {
$defaultLanguage = '@none';
}
}
if (ref($value) eq 'HASH' and exists $value->{'@preserve'}) {
println "2.2" if $debug;
$value = $value->{'@preserve'}[0];
}
println "2.3" if $debug;
my $containers = [];
println "2.4" if $debug;
my $type_language = '@language';
my $type_language_value = '@null';
if (ref($value) eq 'HASH' and exists $value->{'@index'} and not $self->_is_graph_object($value)) {
println "2.5" if $debug;
push(@$containers, '@index', '@index@set');
}
if ($reverse) {
println "2.6" if $debug;
$type_language = '@type';
$type_language_value = '@reverse';
push(@$containers, '@set');
} elsif ($self->_is_list_object($value)) {
println "2.7" if $debug;
if (not exists $value->{'@index'}) {
println "2.7.1" if $debug;
push(@$containers, '@list');
}
println "2.7.2" if $debug;
my $list = $value->{'@list'};
println "2.7.3" if $debug;
my $common_type;
my $common_language;
unless (scalar(@$list)) {
$common_language = $defaultLanguage;
}
println "2.7.4" if $debug;
foreach my $item (@$list) {
println "2.7.4.1" if $debug;
my $item_language = '@none';
my $item_type = '@none';
if (exists $item->{'@value'}) {
println "2.7.4.2" if $debug;
if (exists $item->{'@direction'}) {
println "2.7.4.2.1" if $debug;
$item_language = lc(join('_', $item->{'@language'} // '', $item->{'@direction'}));
} elsif (exists $item->{'@language'}) {
println "2.7.4.2.2" if $debug;
$item_language = lc($item->{'@language'});
} elsif (exists $item->{'@type'}) {
println "2.7.4.2.3" if $debug;
$item_type = $item->{'@type'};
} else {
println "2.7.4.2.4" if $debug;
$item_language = '@null';
}
} else {
println "2.7.4.3" if $debug;
$item_type = '@id';
}
if (not defined($common_language)) {
println "2.7.4.4" if $debug;
$common_language = $item_language;
} elsif ($item_language ne $common_language and exists $item->{'@value'}) {
println "2.7.4.5" if $debug;
$common_language = '@none';
}
if (not defined($common_type)) {
println "2.7.4.6" if $debug;
$common_type = $item_type;
} elsif ($item_type ne $common_type) {
println "2.7.4.7" if $debug;
$common_type = '@none';
}
if ($common_language eq '@none' and $common_type eq '@none') {
println "2.7.4.8" if $debug;
last;
}
}
if (not defined($common_language)) {
println "2.7.5" if $debug;
$common_language = '@none';
}
if (not defined($common_type)) {
println "2.7.6" if $debug;
$common_type = '@none';
}
if ($common_type ne '@none') {
println "2.7.7" if $debug;
$type_language = '@type';
$type_language_value = $common_type;
} else {
println "2.7.8" if $debug;
$type_language_value = $common_language;
}
} elsif ($self->_is_graph_object($value)) {
println "2.8" if $debug;
if (exists $value->{'@index'}) {
println "2.8.1" if $debug;
push(@$containers, '@graph@index', '@graph@index@set');
}
if (exists $value->{'@id'}) {
println "2.8.2" if $debug;
push(@$containers, '@graph@id', '@graph@id@set');
}
println "2.8.3" if $debug;
push(@$containers, '@graph', '@graph@set', '@set');
if (not exists $value->{'@index'}) {
println "2.8.4" if $debug;
push(@$containers, '@graph@index', '@graph@index@set');
}
if (not exists $value->{'@id'}) {
println "2.8.5" if $debug;
push(@$containers, '@graph@id', '@graph@id@set');
}
println "2.8.6" if $debug;
push(@$containers, '@index', '@index@set');
println "2.8.7" if $debug;
$type_language = '@type';
$type_language_value = '@id';
} else {
println "2.9" if $debug;
if ($self->_is_value_object($value)) {
println "2.9.1" if $debug;
if (exists $value->{'@direction'} and not exists $value->{'@index'}) {
println "2.9.1.1" if $debug;
$type_language_value = lc(join('_', $value->{'@language'} // '', $value->{'@direction'}));
push(@$containers, '@language', '@language@set');
} elsif (exists $value->{'@language'} and not exists $value->{'@index'}) {
println "2.9.1.2" if $debug;
$type_language_value = $value->{'@language'};
push(@$containers, '@language', '@language@set');
} elsif (exists $value->{'@type'}) {
println "2.9.1.3" if $debug;
$type_language_value = $value->{'@type'};
$type_language = '@type';
}
} else {
println "2.9.2" if $debug;
$type_language = '@type';
$type_language_value = '@id';
push(@$containers, '@id', '@id@set', '@type', '@set@type');
}
println "2.9.3" if $debug;
push(@$containers, '@set');
}
println "2.10" if $debug;
push(@$containers, '@none');
# unless (ref($value) eq 'HASH') {
# Carp::cluck "unexpected non-HASH in IRI Compaction: " . Dumper($value);
# }
# if ($self->processing_mode ne 'json-ld-1.0' and not(exists $value->{'@index'})) {
if ($self->processing_mode ne 'json-ld-1.0' and not(ref($value) eq 'HASH' and exists $value->{'@index'})) {
# TODO: spec is missing the ref 'HASH' check
println "2.11" if $debug;
push(@$containers, '@index', '@index@set');
}
my @keys = (ref($value) eq 'HASH') ? keys %$value : ();
if ($self->processing_mode ne 'json-ld-1.0' and scalar(@keys) == 1 and $keys[0] eq '@value') {
println "2.12" if $debug;
push(@$containers, '@language', '@language@set');
}
if (not defined($type_language_value)) {
println "2.13" if $debug;
$type_language_value = '@null';
}
println "2.14" if $debug;
my $preferred_values = [];
if ($type_language_value eq '@reverse') {
println "2.15" if $debug;
push(@$preferred_values, '@reverse');
}
if (($type_language_value eq '@id' or $type_language_value eq '@reverse') and ref($value) eq 'HASH' and exists $value->{'@id'}) {
# TODO: spec is missing the ref 'HASH' check
println "2.16" if $debug;
my $compact_iri = $self->_6_2_2_iri_compaction($activeCtx, $activeCtx, $value->{'@id'}, vocab => 1);
my $tdef = $self->_ctx_term_defn($activeCtx, $compact_iri);
if ($tdef and $tdef->{'iri_mapping'} eq $value->{'@id'}) {
println "2.16.1" if $debug;
push(@$preferred_values, '@vocab', '@id', '@none');
} else {
println "2.16.2" if $debug;
push(@$preferred_values, '@id', '@vocab', '@none');
}
} else {
println "2.17" if $debug;
push(@$preferred_values, $type_language_value, '@none');
if ($self->_is_list_object($value) and not scalar(@{ $value->{'@list'} })) {
# https://github.com/w3c/json-ld-api/issues/345
$type_language = '@any';
}
}
println "2.18" if $debug;
push(@$preferred_values, '@any');
my @underscored = map { substr($_, 1+index($_, '_')) } grep { /_/ } @$preferred_values;
if (scalar(@underscored)) {
println "2.19" if $debug;
push(@$preferred_values, @underscored);
}
println "2.20" if $debug;
my $term = $self->_4_4_2_term_selection($inverseCtx, $var, $containers, $type_language, $preferred_values);
if (defined($term)) {
println "2.21 returning: $term" if $debug;
return $term;
}
}
if ($vocab and exists $activeCtx->{'@vocab'}) {
println "3" if $debug;
my $vm = $activeCtx->{'@vocab'};
if (substr($var, 0, length($vm)) eq $vm and length($var) > length($vm)) {
println "3.1" if $debug;
my $suffix = substr($var, length($vm));
my $tdef = $self->_ctx_term_defn($activeCtx, $suffix);
unless ($tdef) {
println "3.1 returning: $suffix" if $debug;
return $suffix;
}
}
}
println "4" if $debug;
my $compact_iri = undef;
println "5" if $debug;
foreach my $term (keys %{ $activeCtx->{terms} }) {
println "5 [$term]" if $debug;
my $tdef = $self->_ctx_term_defn($activeCtx, $term);
my $iri_mapping = $tdef->{'iri_mapping'};
my $iri_is_prefix = _is_prefix_of($iri_mapping, $var);
if (not(defined($tdef)) or (($iri_mapping // '') eq $var) or not($iri_is_prefix) or (not(exists $tdef->{'prefix_flag'}) or not($tdef->{'prefix_flag'}))) {
println "5.1" if $debug;
next;
}
println "5.2" if $debug;
my $candidate = join(':', $term, substr($var, length($iri_mapping)));
println "5.3 candidate = $candidate" if $debug;
if (not defined($compact_iri)) {
println "5.3a" if $debug;
$compact_iri = $candidate;
} else {
my $shorter = (length($candidate) < length($compact_iri));
my $less = ((length($candidate) == length($compact_iri)) and (($candidate cmp $compact_iri) == -1));
my $cand_tdef = $self->_ctx_term_defn($activeCtx, $candidate);
my $no_tdef = not($cand_tdef);
println "5.3b CANDIDATE: $candidate" if $debug;
if (($shorter or $less) and $no_tdef) {
println "5.3b" if $debug;
$compact_iri = $candidate;
} elsif (exists $cand_tdef->{'iri_mapping'} and $cand_tdef->{'iri_mapping'} eq $var and not defined($value)) {
println "5.3c" if $debug;
$compact_iri = $candidate;
}
}
}
if (defined($compact_iri)) {
println "6 returning: $compact_iri" if $debug;
return $compact_iri;
}
my $iri = eval { IRI->new($var) };
unless ($@) {
my $scheme = $iri->scheme;
my $scheme_tdef = $self->_ctx_term_defn($activeCtx, $scheme);
if ($scheme_tdef and $scheme_tdef->{'prefix_flag'} and substr($var, length($scheme)+1, 2) ne '//') {
println "7" if $debug;
die 'IRI confused with prefix';
}
}
if (not $vocab) {
println "8" if $debug;
my $base = eval { (exists $activeCtx->{'@base'}) ? IRI->new($activeCtx->{'@base'}) : $self->base_iri };
unless ($@) {
eval {
my $iri = IRI->new($var);
$var = _make_relative_iri($base, $iri);
};
}
}
println "9 returning: $var" if $debug;
return $var;
}
sub _6_3_value_compaction {
my $self = shift;
my $activeCtx = shift;
my $inverseCtx = shift;
my $activeProp = shift;
my $value = shift;
{
no warnings 'uninitialized';
println "ENTER =================> _6_3_value_compaction('$activeProp')" if $debug;
}
my $__indent = indent();
println(Data::Dumper->Dump([$value], [qw(value)])) if $debug;
println "1" if $debug;
my $result = clone($value); # https://github.com/w3c/json-ld-api/issues/350
println "2" if $debug;
my $tdef = $self->_ctx_term_defn($activeCtx, $activeProp);
my $language = exists $tdef->{'language_mapping'}
? $tdef->{'language_mapping'}
: $activeCtx->{'@language'};
println "3" if $debug;
my $direction = exists $tdef->{'direction_mapping'}
? $tdef->{'direction_mapping'}
: $activeCtx->{'@direction'};
my @keys = grep { $_ ne '@id' and $_ ne '@index' } keys %$value;
my $type_mapping = $tdef->{'type_mapping'} // '';
my $container_mapping = $tdef->{'container_mapping'};
if (exists $value->{'@id'} and scalar(@keys) == 0) {
println "4" if $debug;
if ($type_mapping eq '@id') {
println "4.1" if $debug;
$result = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $value->{'@id'});
} elsif ($type_mapping eq '@vocab') {
println "4.2" if $debug;
$result = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $value->{'@id'}, vocab => 1);
}
} elsif (exists $value->{'@type'} and $value->{'@type'} eq $type_mapping) {
println "5" if $debug;
$result = $value->{'@value'};
} elsif ($type_mapping eq '@none' or (exists $value->{'@type'} and $value->{'@type'} ne $type_mapping)) {
println "6" if $debug;
if (exists $result->{'@type'}) {
println "6.1" if $debug;
my @types = (ref($value->{'@type'}) eq 'ARRAY') ? @{ $value->{'@type'} } : $value->{'@type'};
$result->{'@type'} = [ map { $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $_, vocab => 1) } @types ];
}
} elsif (not _is_string($value->{'@value'})) {
println "7" if $debug;
my @keys = keys %$value;
if (scalar(@keys) == 1 and $keys[0] eq '@value') {
# https://github.com/w3c/json-ld-api/issues/351
$result = $value->{'@value'};
} elsif (exists $value->{'@index'} and $self->_cm_contains($container_mapping, '@index')) {
println "7.1" if $debug;
$result = $value->{'@value'};
}
} else {
# https://github.com/w3c/json-ld-api/issues/313
println "maybe 8" if $debug;
my $vlang = $value->{'@language'} // '';
my $lang_both_undef = (not(defined($value->{'@language'})) and not(defined($language)));
my $lang_same = ($lang_both_undef or (defined($vlang) and defined($language) and lc($vlang) eq lc($language)));
my $lang_not_present = ((not defined($language)) and (not exists $value->{'@language'}));
my $dir = $value->{'@direction'};
my $dir_both_undef = (not(defined($value->{'@direction'})) and not(defined($direction)));
my $dir_same = ($dir_both_undef or ($dir eq $direction));
my $dir_not_present = ((not defined($direction)) and (not exists $value->{'@direction'}));
# if (($lang_same or $lang_not_present) and ($dir_same or $dir_not_present)) {
# println "8" if $debug;
# if ((exists $value->{'@index'} and $self->_cm_contains($container_mapping, '@index')) or not exists $value->{'@index'}) {
# println "8.1" if $debug;
# $result = $value->{'@value'};
# }
# }
my $lang_cmp_1 = (defined($language))
? lc($value->{'@language'}) eq $language
: not exists($value->{'@language'});
my $dir_cmp_1 = (defined($direction))
? $value->{'@direction'} eq $direction
: not exists($value->{'@direction'});
if ($lang_cmp_1 and $dir_cmp_1) {
println "8" if $debug;
if ((exists $value->{'@index'} and $self->_cm_contains($container_mapping, '@index')) or not exists $value->{'@index'}) {
println "8.1" if $debug;
$result = $value->{'@value'};
}
}
println "not 8" if $debug;
println(Data::Dumper->Dump([$lang_cmp_1, $language, $dir_cmp_1, $direction, $value], [qw(lang_cmp_1 language dir_cmp_1 direction value)])) if $debug;
}
if (ref($result) eq 'HASH') {
println "9" if $debug;
my @keys = keys %$result;
foreach my $k (@keys) {
my $__indent = indent();
println "----------------" if $debug;
println "9 [$k]" if $debug;
my $ck = $self->_6_2_2_iri_compaction($activeCtx, $inverseCtx, $k, vocab => 1);
$result->{$ck} = delete $result->{$k};
}
}
println "10" if $debug;
return $result;
}
sub _7_1_2_flattening {
my $self = shift;
my $element = shift;
my $context = shift;
my $ordered = shift // 0;
die;
}
sub _7_2_2_nodemap_generation {
println "ENTER =================> _7_2_2_nodemap_generation" if $debug;
my $__indent = indent();
my $self = shift;
my $element = shift;
my $map = shift;
my $activeGraph = shift // '@default';
println(Data::Dumper->Dump([$activeGraph], [qw(activeGraph)])) if $debug;
println(Data::Dumper->Dump([$element], [qw(element)])) if $debug;
my $activeSubject = shift;
my $activeProp = shift;
my $list = shift;
println "1" if $debug;
if (ref($element) eq 'ARRAY') {
foreach my $item (@$element) {
$self->_7_2_2_nodemap_generation($item, $map, $activeGraph, $activeSubject, $activeProp, $list);
}
return;
}
println "2" if $debug;
my $graph = ($map->{$activeGraph} ||= {});
my $node;
my $subjectNode;
if (not defined($activeSubject)) {
$node = undef;
} else {
$subjectNode = $graph->{$activeSubject};
}
unless (ref($element) eq 'HASH') {
Carp::cluck 'element is not a HASH';
}
if (exists $element->{'@type'}) {
println "3" if $debug;
# https://github.com/w3c/json-ld-api/issues/276
if (ref($element) and ref($element) ne 'HASH') {
Carp::cluck 'element is not a HASH';
}
if (ref($element->{'@type'})) {
foreach my $i (0 .. $#{ $element->{'@type'} }) {
my $item = $element->{'@type'}[$i];
if ($item =~ /^_:/) {
println "3.1" if $debug;
$element->{'@type'}[$i] = $self->_7_4_2_generate_blank_node_ident($item);
}
}
} else {
if ($element->{'@type'} =~ /^_:/) {
$element->{'@type'} = $self->_7_4_2_generate_blank_node_ident($element->{'@type'});
}
}
}
my $j = JSON->new()->canonical(1);
if (exists $element->{'@value'}) {
println "4" if $debug;
if (not defined($list)) {
println "4.1" if $debug;
no warnings 'uninitialized';
if (not exists $subjectNode->{$activeProp}) {
println "4.1.1" if $debug;
$subjectNode->{$activeProp} = [$element];
} else {
println "4.1.2" if $debug;
my $je = $j->encode($element);
my $exists = any { $j->encode($_) eq $je } @{ $subjectNode->{$activeProp} };
unless ($exists) {
push(@{ $subjectNode->{$activeProp} }, $element);
}
}
} else {
println "4.2" if $debug;
push(@{ $list->{'@list'} }, $element);
}
} elsif (exists $element->{'@list'}) {
println "5" if $debug;
println "5.1" if $debug;
my $result = {'@list' => []};
println "5.2" if $debug;
$self->_7_2_2_nodemap_generation($element->{'@list'}, $map, $activeGraph, $activeSubject, $activeProp, $result);
if (not defined($list)) {
println "5.3" if $debug;
println(Data::Dumper->Dump([$result], [qw(result)])) if $debug;
push(@{ $subjectNode->{$activeProp} }, $result);
} else {
println "5.4" if $debug;
push(@{ $list->{'@list'} }, $result);
}
} else {
println "6" if $debug;
my $id;
if (exists $element->{'@id'}) {
println "6.1" if $debug;
$id = delete $element->{'@id'};
if ($id =~ /^_:/) {
$id = $self->_7_4_2_generate_blank_node_ident($id);
}
} else {
println "6.2" if $debug;
$id = $self->_7_4_2_generate_blank_node_ident();
}
unless (exists $graph->{$id}) {
println "6.3" if $debug;
$graph->{$id} = { '@id' => $id };
}
println "6.4" if $debug;
$node = $graph->{$id};
if (ref($activeSubject) eq 'HASH') {
println "6.5" if $debug;
if (not exists $node->{$activeProp}) {
println "6.5.1" if $debug;
$node->{$activeProp} = [$activeSubject];
} else {
println "6.5.2" if $debug;
my $je = $j->encode($activeSubject);
my $exists = any { $j->encode($_) eq $je } @{ $node->{$activeProp} };
unless ($exists) {
push(@{ $node->{$activeProp} }, $activeSubject);
}
}
} elsif (defined($activeProp)) {
println "6.6" if $debug;
println "6.6.1" if $debug;
my $reference = { '@id' => $id };
if (not defined($list)) {
println "6.6.2" if $debug;
if (not exists $subjectNode->{$activeProp}) {
println "6.6.2.1" if $debug;
$subjectNode->{$activeProp} = [$reference];
} else {
println "6.6.2.2" if $debug;
my $je = $j->encode($reference);
my $exists = any { $j->encode($_) eq $je } @{ $subjectNode->{$activeProp} };
unless ($exists) {
push(@{ $subjectNode->{$activeProp} }, $reference);
}
}
} else {
push(@{ $list->{'@list'} }, $reference);
}
}
if (exists $element->{'@type'}) {
println "6.7" if $debug;
my %exists = map { $_ => 1 } @{ $node->{'@type'} };
push(@{ $node->{'@type'} }, grep { not exists $exists{$_} }@{ $element->{'@type'} });
delete $element->{'@type'};
}
if (exists $element->{'@index'}) {
println "6.8" if $debug;
println "6.8 TODO check if element has a pre-existing value" if $debug;
$node->{'@index'} = delete $element->{'@index'};
}
if (exists $element->{'@reverse'}) {
println "6.9" if $debug;
println "6.9.1" if $debug;
my $referenced_node = { '@id' => $id };
println "6.9.2" if $debug;
my $reverse_map = $element->{'@reverse'};
println "6.9.3" if $debug;
foreach my $property (keys %$reverse_map) {
println "6.9.3 [$property]" if $debug;
my $values = $reverse_map->{$property};
println "6.9.3.1" if $debug;
foreach my $value (@$values) {
println "6.9.3.1.1" if $debug;
$self->_7_2_2_nodemap_generation($value, $map, $activeGraph, $referenced_node, $property); # TODO: need to pass $list ?
}
}
println "6.9.3.4" if $debug;
delete $element->{'@reverse'};
}
if (exists $element->{'@graph'}) {
println "6.10" if $debug;
$self->_7_2_2_nodemap_generation($element->{'@graph'}, $map, $id);
delete $element->{'@graph'};
}
if (exists $element->{'@included'}) {
println "6.11" if $debug;
$self->_7_2_2_nodemap_generation($element->{'@included'}, $map, $activeGraph);
delete $element->{'@included'};
}
println "6.12" if $debug;
foreach my $property (sort keys %$element) {
println '----------------' if $debug;
println "6.12 [$property]" if $debug;
my $value = $element->{$property};
if ($property =~ /^_:/) {
println "6.12.1" if $debug;
$property = $self->_7_4_2_generate_blank_node_ident($property);
}
unless (exists $node->{$property}) {
println "6.12.2" if $debug;
$node->{$property} = [];
}
println "6.12.3" if $debug;
$self->_7_2_2_nodemap_generation($value, $map, $activeGraph, $id, $property);
}
}
}
sub _7_4_2_generate_blank_node_ident {
println "ENTER =================> _7_4_2_generate_blank_node_ident" if $debug;
my $__indent = indent();
my $self = shift;
my $ident = shift;
if (defined($ident) and exists $self->identifier_map->{$ident}) {
println "1" if $debug;
return $self->identifier_map->{$ident};
}
println "2" if $debug;
my $nid = $self->next_identifier_id;
$self->next_identifier_id($nid + 1);
my $bid = "_:b$nid";
if (defined($ident)) {
println "3" if $debug;
$self->identifier_map->{$ident} = $bid;
}
println "4" if $debug;
return $bid;
}
sub _8_1_2_to_rdf {
println "ENTER =================> _8_1_2_to_rdf" if $debug;
my $__indent = indent();
my $self = shift;
my $map = shift;
my $dataset = shift;
my %args = @_;
my $produce_genrdf = $args{'produceGeneralizedRdf'} || 0;
my $rdfDirection = $args{'rdfDirection'};
println "1" if $debug;
for my $graphName (keys %$map) {
my $__indent = indent();
println '----------------------' if $debug;
println "1 [$graphName]" if $debug;
my $graph = $map->{$graphName};
unless ($self->_is_well_formed_graphname($graphName)) {
println "1.1" if $debug;
next;
}
my $graph_iri;
println "1.2" if $debug;
if ($graphName eq '@default') {
$graph_iri = $self->default_graph();
} else {
$graph_iri = $self->new_graphname($graphName);
}
println "1.3" if $debug;
foreach my $subject (sort keys %$graph) {
my $__indent = indent();
println '----------------------' if $debug;
println "1.3 [$subject]" if $debug;
my $node = $graph->{$subject};
println "1.3.2" if $debug;
foreach my $property (sort keys %$node) {
println "1.3.2 [$property]" if $debug;
my $values = $node->{$property};
println(Dumper($property, $node)) if $debug;
if ($property eq '@type') {
println "1.3.2.1" if $debug;
foreach my $type (@$values) {
if ($self->_is_well_formed_graph_node($type)) {
my $q = $self->new_quad(
$self->new_graph_node($subject),
$self->new_iri('http://www.w3.org/1999/02/22-rdf-syntax-ns#type'),
$self->new_graph_node($type),
$graph_iri
);
$self->add_quad($q, $dataset);
}
}
} elsif (exists $keywords{$property}) {
println "1.3.2.2" if $debug;
next;
} elsif ($property =~ /^_:(.*)$/ and not $produce_genrdf) {
println "1.3.2.3" if $debug;
next;
} elsif (not $self->_is_well_formed_iri($property)) {
println "1.3.2.4" if $debug;
next;
} else {
println "1.3.2.5" if $debug;
foreach my $item (@$values) {
println "1.3.2.5.1" if $debug;
println "1.3.2.5.2" if $debug;
my $list_triples = [];
my $s = $self->_8_2_2_object_to_rdf({'@id' => $subject}, $list_triples);
my $o = $self->_8_2_2_object_to_rdf($item, $list_triples);
if ($o) {
println "1.3.2.5.3" if $debug;
my $q = $self->new_quad(
$s,
$self->new_iri($property),
$o,
$graph_iri
);
if ($q) {
$self->add_quad($q, $dataset);
}
}
println "1.3.2.5.4" if $debug;
foreach my $t (@$list_triples) {
my $q = $t->as_quad($graph_iri);
$self->add_quad($q, $dataset);
}
}
}
}
}
}
}
sub _8_2_2_object_to_rdf {
println "ENTER =================> _8_2_2_object_to_rdf" if $debug;
my $__indent = indent();
my $self = shift;
my $item = shift;
my $list_triples = shift;
if ($self->_is_node_object($item) and not $self->_is_well_formed_graph_node($item->{'@id'})) {
println "1" if $debug;
println "*** _8_2_2_object_to_rdf RETURNING NULL on " . Data::Dumper->Dump([$item], ['item']) if $debug;
return;
}
if ($self->_is_node_object($item)) {
my $value = $item->{'@id'};
println "2 $value" if $debug;
if ($value =~ /^_:(.*)$/) {
return $self->new_blank($1);
} else {
return $self->new_iri($value);
}
}
if ($self->_is_list_object($item)) {
println "3" if $debug;
return $self->_8_3_2_list_conversion($item->{'@list'}, $list_triples);
}
println "4" if $debug;
my $value = $item->{'@value'};
println "5" if $debug;
my $datatype = $item->{'@type'};
if (defined($datatype) and not $self->_is_well_formed_datatype($datatype)) { # https://github.com/w3c/json-ld-api/issues/282 ; https://github.com/w3c/json-ld-api/issues/298
println "6" if $debug;
println "*** _8_2_2_object_to_rdf RETURNING NULL" if $debug;
return;
}
if (exists $item->{'@language'} and not $self->_is_well_formed_language($item->{'@language'})) {
println "7" if $debug;
println "*** _8_2_2_object_to_rdf RETURNING NULL" if $debug;
return;
}
if (defined($datatype) and $datatype eq '@json') {
println "8" if $debug;
$value = decode_utf8(JSON->new->utf8->allow_nonref->canonical(1)->encode($value));
$datatype = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#JSON';
}
if (JSON::is_bool($value)) {
println "9" if $debug;
$value = $value ? 'true' : 'false';
unless ($datatype) {
$datatype = 'http://www.w3.org/2001/XMLSchema#boolean';
}
}
my $is_num = _is_numeric($value);
my $is_int = _is_integer($value);
my $int_repr = $is_num ? sprintf('%011.0f', $value) : '';
my $double_or_not_int = (not($is_int) or (defined($datatype) and $datatype eq 'http://www.w3.org/2001/XMLSchema#double'));
my $is_large_int = ($is_int and length($int_repr) >= 22 and $int_repr =~ /^[^-+0]/);
if ($is_large_int or ($is_num and $double_or_not_int)) {
# https://github.com/w3c/json-ld-api/issues/312
println "10" if $debug;
$value = sprintf('%E', $value);
$value =~ s/0+E/0E/;
$value =~ s/(\d)0E/$1E/;
$value =~ s/E[+]/E/;
$value =~ s/E0+([1-9])/E$1/;
$value =~ s/E0+/E0/;
unless ($datatype) {
$datatype = 'http://www.w3.org/2001/XMLSchema#double';
}
} elsif ($is_num) {
println "11" if $debug;
$value = sprintf('%011.0f', $value);
$value =~ s/^(-?)0+(\d)/$1$2/;
$value =~ s/^-0/0/;
unless ($datatype) {
$datatype = 'http://www.w3.org/2001/XMLSchema#integer';
}
}
if (not defined($datatype)) {
println "12" if $debug;
$datatype = (exists $item->{'@language'}) ? 'http://www.w3.org/1999/02/22-rdf-syntax-ns#langString' : 'http://www.w3.org/2001/XMLSchema#string';
}
my $literal;
if (exists $item->{'@direction'} and defined(my $dir = $self->rdf_direction)) {
println "13" if $debug;
if ($dir eq 'i18n-datatype') {
println "13.1" if $debug;
my $language = $item->{'@language'} // '';
# https://github.com/w3c/json-ld-api/issues/337
$datatype = 'https://www.w3.org/ns/i18n#' . join('_', lc($language), $item->{'@direction'});
$literal = $self->new_dt_literal($value, $datatype);
} elsif ($dir eq 'compound-literal') {
println "13.2" if $debug;
println "13.2.1" if $debug;
$literal = $self->new_blank();
println "13.2.2" if $debug;
println "TODO: spec text issue for literal construction";
my $t = $self->new_triple(
$literal,
$self->new_iri('http://www.w3.org/1999/02/22-rdf-syntax-ns#value'),
$self->new_dt_literal($item->{'@value'}, 'http://www.w3.org/2001/XMLSchema#string')
# $item->{'@value'} # TODO: should this be a term constructor call?
);
push(@$list_triples, $t);
if (exists $item->{'@language'}) {
println "13.2.3" if $debug;
println "TODO: spec text issue for literal construction";
my $t = $self->new_triple(
$literal,
$self->new_iri('http://www.w3.org/1999/02/22-rdf-syntax-ns#language'),
$self->new_dt_literal(lc($item->{'@language'}), 'http://www.w3.org/2001/XMLSchema#string')
# $item->{'@language'} # TODO: should this be a term constructor call?
);
push(@$list_triples, $t);
}
println "13.2.4" if $debug;
println "TODO: spec text issue for literal construction";
my $t2 = $self->new_triple(
$literal,
$self->new_iri('http://www.w3.org/1999/02/22-rdf-syntax-ns#direction'),
$self->new_dt_literal($item->{'@direction'}, 'http://www.w3.org/2001/XMLSchema#string')
# $item->{'@direction'} # TODO: should this be a term constructor call?
);
push(@$list_triples, $t2);
}
} else {
println "14" if $debug;
$literal = (exists $item->{'@language'})
? $self->new_lang_literal($value, lc($item->{'@language'} // ''))
: $self->new_dt_literal($value, $datatype);
}
println "15" if $debug;
return $literal;
}
sub _8_3_2_list_conversion {
println "ENTER =================> _8_3_2_list_conversion" if $debug;
my $__indent = indent();
my $self = shift;
my $list = shift;
my $list_triples = shift;
my $NIL = $self->new_iri('http://www.w3.org/1999/02/22-rdf-syntax-ns#nil');
if (scalar(@$list) == 0) {
println "1" if $debug;
return $NIL;
}
println "2" if $debug;
my $bnodes = [map { $self->new_blank() } @$list];
foreach my $i (0..$#{$bnodes}) {
my $subject = $bnodes->[$i];
my $item = $list->[$i];
println "3" if $debug;
println "3.1" if $debug;
my $embedded_triples = [];
println "3.2" if $debug;
my $object = $self->_8_2_2_object_to_rdf($item, $embedded_triples);
if (defined($object)) {
println "3.3" if $debug;
push(@$list_triples, $self->new_triple(
$subject,
$self->new_iri('http://www.w3.org/1999/02/22-rdf-syntax-ns#first'),
$object
));
}
println "3.4" if $debug;
my $rest = ($i == $#{$bnodes}) ? $NIL : $bnodes->[$i+1];
push(@$list_triples, $self->new_triple(
$subject,
$self->new_iri('http://www.w3.org/1999/02/22-rdf-syntax-ns#rest'),
$rest
));
println "3.5" if $debug;
push(@$list_triples, @$embedded_triples);
}
println "4" if $debug;
my $head = (scalar(@$bnodes)) ? $bnodes->[0] : $NIL;
return $head;
}
sub new_graph_node {
my $self = shift;
my $value = shift;
if ($value =~ /_:(.*)/) {
return $self->new_blank($1);
} else {
return $self->new_iri($value);
}
}
sub new_graphname {
my $self = shift;
Carp::cluck 'RDF term constructors must be overloaded in a JSONLD subclass';
}
sub default_graph {
my $self = shift;
Carp::cluck 'RDF default graph accessor must be overloaded in a JSONLD subclass';
}
sub new_dataset {
my $self = shift;
Carp::cluck 'RDF dataset constructors must be overloaded in a JSONLD subclass';
}
sub new_triple {
my $self = shift;
Carp::cluck 'RDF statement constructors must be overloaded in a JSONLD subclass';
}
sub new_quad {
my $self = shift;
Carp::cluck 'RDF statement constructors must be overloaded in a JSONLD subclass';
}
sub new_iri {
my $self = shift;
Carp::cluck 'RDF term constructors must be overloaded in a JSONLD subclass';
}
sub new_blank {
my $self = shift;
Carp::cluck 'RDF term constructors must be overloaded in a JSONLD subclass';
}
sub new_lang_literal {
my $self = shift;
Carp::cluck 'RDF term constructors must be overloaded in a JSONLD subclass';
}
sub new_dt_literal {
my $self = shift;
Carp::cluck 'RDF term constructors must be overloaded in a JSONLD subclass';
}
sub add_quad {
my $self = shift;
Carp::cluck 'RDF dataset methods must be overloaded in a JSONLD subclass';
}
}
1;
__END__
=back
=head1 BUGS
Please report any bugs or feature requests to through the GitHub web interface
at L.
=head1 SEE ALSO
=over 4
=item L
=item L
=item L
=item L
=item L
=back
=head1 AUTHOR
Gregory Todd Williams C<< >>
=head1 COPYRIGHT
Copyright (c) 2019--2020 Gregory Todd Williams.
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
JSONLD-0.005/xt/earl.pl 000644 000765 000024 00000006034 13660377122 014523 0 ustar 00greg staff 000000 000000 use strict;
use warnings;
no warnings 'redefine';
use Scalar::Util qw(blessed);
use DateTime::Format::W3CDTF;
sub init_earl {
my $name = 'JSONLD';
my $cpan_id = $name;
$cpan_id =~ s/::/-/g;
my $version = do { no strict 'refs'; ${"${name}::VERSION"} };
my $v_id = 'v_' . $version;
$v_id =~ s/[.]/-/;
my $out = '';
open( my $fh, '>', \$out );
# my $earl = {out => \$out, fh => $fh, name => $name, version => $v_id, subject => "my:$v_id" };
my $earl = {out => \$out, fh => $fh, name => $name, version => $v_id, subject => "my:project" };
my $w3c = DateTime::Format::W3CDTF->new;
my $dt = $w3c->format_datetime(DateTime->now);
print {$fh} <<"END";
\@prefix doap: .
\@prefix earl: .
\@prefix foaf: .
\@prefix rdf: .
\@prefix rdfs: .
\@prefix xml: .
\@prefix dct: .
\@prefix xsd: .
\@prefix my: .
<> foaf:primaryTopic my:project ;
dct:issued "${dt}"^^xsd:dateTime ;
foaf:maker ;
.
my:project
a doap:Project ;
doap:name "${name}" ;
doap:description "Perl module ${name}" ;
doap:homepage ;
doap:developer ;
doap:programming-language "Perl" ;
doap:release my:$v_id ;
doap:repository [
a doap:GitRepository ;
doap:browse ;
doap:location ;
]
.
my:$v_id a doap:Version ;
doap:name "${name} $version" ;
doap:revision "$version" ;
.
a foaf:Person ;
foaf:name "Gregory Todd Williams" ;
foaf:mbox ;
foaf:mbox_sha1sum "f80a0f19d2a0897b89f48647b2fb5ca1f0bc1cb8" ;
foaf:homepage ;
.
my:test-harness
a earl:Software ;
dct:title "${name} test harness" ;
foaf:maker ;
.
END
return $earl;
}
sub earl_pass_test {
my $earl = shift;
my $test = shift;
my $subject = $earl->{subject};
print {$earl->{fh}} <<"END";
[] a earl:Assertion;
earl:assertedBy my:test-harness ;
earl:result [
a earl:TestResult ;
earl:outcome earl:passed
] ;
earl:subject $subject ;
earl:test <$test> .
END
}
sub earl_fail_test {
my $earl = shift;
my $test = shift;
my $msg = shift;
my $subject = $earl->{subject};
no warnings 'uninitialized';
$msg =~ s/\n/\\n/g;
$msg =~ s/\t/\\t/g;
$msg =~ s/\r/\\r/g;
$msg =~ s/"/\\"/g;
print {$earl->{fh}} <<"END";
[] a earl:Assertion;
earl:assertedBy my:test-harness ;
earl:result [
a earl:TestResult ;
earl:outcome earl:failed ;
END
print {$earl->{fh}} qq[\t\trdfs:comment "$msg" ;\n] if (defined $msg);
print {$earl->{fh}} <<"END";
] ;
earl:subject $subject ;
earl:test <$test> ;
.
END
}
sub earl_output {
my $earl = shift;
close($earl->{fh});
return ${ $earl->{out} };
}
1;
__END__
JSONLD-0.005/xt/PaxHeader/compact.t 000644 000765 000024 00000000036 13764470521 017025 x ustar 00greg staff 000000 000000 30 mtime=1607627089.765306072
JSONLD-0.005/xt/compact.t 000644 000765 000024 00000010135 13764470521 015055 0 ustar 00greg staff 000000 000000 use v5.14;
use autodie;
use utf8;
use Carp qw(confess);
use Test::Exception;
use FindBin qw($Bin);
use File::Glob qw(bsd_glob);
use File::Spec;
use JSON qw(decode_json);
use Data::Dumper;
use JSONLD;
use open ':std', ':encoding(UTF-8)';
use Moo;
use Type::Tiny::Role;
use Test::More skip_all => 'JSON-LD 1.1 Compation is not currently supported';
our $debug = 0;
$JSONLD::debug = $debug;
our $PATTERN;
if ($debug) {
$PATTERN = qr/t0004/;
} else {
$PATTERN = /./;
}
my $REPORT_NEGATIVE_TESTS = 0;
sub load_json {
my $file = shift;
open(my $fh, '<:utf8', $file);
my $j = JSON->new();
return $j->decode(do { local($/); <$fh> });
}
sub _normalize {
# give array elements a predictable order (https://w3c.github.io/json-ld-api/tests/#json-ld-object-comparison)
my $data = shift;
my $preserve_order = shift || 0;
return $data unless (ref($data));
if (ref($data) eq 'ARRAY') {
my $j = JSON->new->canonical(1);
my @v = map { _normalize($_) } @$data;
unless ($preserve_order) {
@v = sort { $j->encode($a) cmp $j->encode($b) } @v;
}
return [@v];
} elsif (ref($data) eq 'HASH') {
my %hash;
foreach my $k (keys %$data) {
my $preseve_order = ($k eq '@list');
$hash{$k} = _normalize($data->{$k}, $preseve_order);
}
return \%hash;
} else {
die "Unexpected ref type: " . ref($data);
}
}
$Data::Dumper::Sortkeys = 1;
my $path = File::Spec->catfile( $Bin, 'data', 'json-ld-api-w3c' );
my $manifest = File::Spec->catfile($path, 'compact-manifest.jsonld');
my $d = load_json($manifest);
my $tests = $d->{'sequence'};
my $base = IRI->new(value => $d->{'baseIri'} // 'http://example.org/');
foreach my $t (@$tests) {
my $id = $t->{'@id'};
next unless ($id =~ $PATTERN);
my $input = $t->{'input'};
my $expect = $t->{'expect'} // '';
my $ctx = $t->{'context'};
my $name = $t->{'name'};
my $purpose = $t->{'purpose'};
my $options = $t->{'option'} // {};
my $_base = $options->{'base'};
my $spec_v = $options->{'specVersion'} // '';
my @types = @{ $t->{'@type'} };
my %types = map { $_ => 1 } @types;
my $test_base;
if (defined($_base)) {
$test_base = IRI->new(value => $_base, base => $base)->abs;
} else {
$test_base = IRI->new(value => $input, base => $base)->abs;
}
my $j = JSON->new->canonical(1);
note($id) if $debug;
if ($spec_v eq 'json-ld-1.0') {
diag("IGNORING JSON-LD-1.0-only test $id\n");
} elsif ($types{'jld:PositiveEvaluationTest'} or $types{'jld:NegativeEvaluationTest'}) {
my $positive = $types{'jld:PositiveEvaluationTest'};
my $jld = JSONLD->new(base_iri => IRI->new($test_base));
my $infile = File::Spec->catfile($path, $input);
my $outfile = File::Spec->catfile($path, $expect);
my $ctx_file = File::Spec->catfile($path, $ctx);
my $data = load_json($infile);
my $context = load_json($ctx_file);
if ($debug) {
warn "Input file: $infile\n";
warn "Output file: $outfile\n";
warn "INPUT:\n===============\n" . JSON->new->pretty->encode($data); # Dumper($data);
}
my $compacted = eval { $jld->compact($data, $context) };
if ($@) {
if ($positive) {
fail("$id: died: $@")
} else {
if ($REPORT_NEGATIVE_TESTS) {
pass("$id: NegativeEvaluationTest");
}
}
} else {
my $got = _normalize($j->encode($compacted));
if ($positive) {
my $expected = _normalize($j->encode(load_json($outfile)));
if ($debug) {
my @data = (
['EXPECTED', $expected],
['OUTPUT__', $got],
);
my @files;
foreach my $d (@data) {
my ($name, $data) = @$d;
warn "=======================\n";
my $filename = "/tmp/json-ld-$$-$name.out";
open(my $fh, '>', $filename) or die $!;
push(@files, $filename);
my $out = Data::Dumper->Dump([$j->decode($data)], ["*$name"]);
warn $out;
print {$fh} $out;
close($fh);
}
unless ($got eq $expected) {
system('/usr/local/bin/bbdiff', '--wait', '--resume', @files);
}
}
is($got, $expected, "$id: $name");
} else {
if ($REPORT_NEGATIVE_TESTS) {
fail("$id: expected failure but found success");
}
}
}
} else {
diag("Not a recognized evaluation test: " . Dumper(\@types));
next;
}
}
done_testing();
JSONLD-0.005/xt/expand.t 000644 000765 000024 00000013607 13660377065 014721 0 ustar 00greg staff 000000 000000 use v5.14;
use strict;
use warnings;
use autodie;
use utf8;
use Carp qw(confess);
use Test::More;
use Test::Exception;
use FindBin qw($Bin);
use File::Glob qw(bsd_glob);
use File::Spec;
use JSON;
use Data::Compare;
use Data::Dumper;
use JSONLD;
use B qw(svref_2object SVf_IOK SVf_POK SVf_NOK SVf_IOK);
use open ':std', ':encoding(UTF-8)';
use Data::Compare;
use Clone 'clone';
use Storable qw(freeze);
use Devel::Peek;
use lib qw(.);
require "xt/earl.pl";
use Moo;
use Type::Tiny::Role;
our $debug = 0;
$JSONLD::debug = $debug;
our $PATTERN;
if ($debug) {
$PATTERN = qr/t0034/;
} else {
$PATTERN = qr/./;
}
my $REPORT_NEGATIVE_TESTS = 1;
sub load_json {
my $file = shift;
open(my $fh, '<:utf8', $file);
my $j = JSON->new()->canonical(1);
return $j->decode(do { local($/); <$fh> });
}
sub _is_numeric {
my $v = shift;
return 0 unless defined($v);
return 0 if ref($v);
my $sv = svref_2object(\$v);
my $flags = $sv->FLAGS;
my $is_num = (($flags & SVf_NOK) or ($flags & SVf_IOK));
return $is_num;
}
sub _normalize {
# give array elements a predictable order (https://w3c.github.io/json-ld-api/tests/#json-ld-object-comparison)
my $data = shift;
my $preserve_order = shift || 0;
if (not ref($data)) {
if (_is_numeric($data)) {
return 1.0 * $data;
} else {
return $data;
}
} elsif (ref($data) eq 'JSON::PP::Boolean') {
my $bool = ($data) ? 1 : 0;
return \$bool;
} elsif (ref($data) eq 'ARRAY') {
my @v = map { _normalize($_, 0) } @$data;
unless ($preserve_order) {
local($Storable::canonical) = 1;
@v = map { $_->[0] }
sort { $a->[1] cmp $b->[1] }
map { [$_, freeze([$_])] } @v;
# map { Dump(freeze([$_])); [$_, freeze([$_])] } @v;
}
return [@v];
} elsif (ref($data) eq 'HASH') {
my %hash;
foreach my $k (keys %$data) {
my $preserve_order = ($k eq '@list');
$hash{$k} = _normalize(clone($data->{$k}), $preserve_order);
}
return \%hash;
} else {
die "Unexpected ref type: " . ref($data);
}
}
$Data::Dumper::Sortkeys = 1;
my $component = 'expand';
my $earl = init_earl();
my $path = File::Spec->catfile( $Bin, 'data', 'json-ld-api-w3c' );
my $manifest = File::Spec->catfile($path, "${component}-manifest.jsonld");
my $d = load_json($manifest);
my $base_url = "https://w3c.github.io/json-ld-api/tests/${component}-manifest";
my $jj = JSONLD->new(base_iri => IRI->new('file://' . $manifest));
my $tests = $d->{'sequence'};
my $base = IRI->new(value => $d->{'baseIri'} // 'http://example.org/');
foreach my $t (@$tests) {
my $id = $t->{'@id'};
next unless ($id =~ $PATTERN);
my $test_iri = $jj->expand($t, expandContext => [{'@base' => $base_url}, 'context.jsonld'])->[0]{'@id'};
my $input = $t->{'input'};
my $expect = $t->{'expect'} // '';
my $name = $t->{'name'};
my $purpose = $t->{'purpose'};
my $options = $t->{'option'} // {};
my $_base = $options->{'base'};
my $spec_v = $options->{'specVersion'} // '';
my $mode = $options->{'processingMode'} // 'json-ld-1.1';
my @types = @{ $t->{'@type'} };
my %types = map { $_ => 1 } @types;
my $infile = File::Spec->catfile($path, $input);
my %args;
if (my $expand = $options->{'expandContext'}) {
warn "Expand Context: $expand\n" if ($debug);
my $base = IRI->new(value => 'file://' . $manifest);
my $iri = IRI->new(value => $expand, base => $base);
$args{'expandContext'} = $iri->abs;
}
my $test_base;
if (defined($_base)) {
$test_base = IRI->new(value => $_base, base => $base)->abs;
} else {
$test_base = IRI->new(value => $input, base => $base)->abs;
}
my $j = JSON->new->canonical(1);
note($id) if $debug;
SKIP: {
skip("skipping IGNORING JSON-LD-1.0-only test $id", 1) if ($spec_v eq 'json-ld-1.0');
if ($types{'jld:PositiveEvaluationTest'} or $types{'jld:NegativeEvaluationTest'}) {
my $positive = $types{'jld:PositiveEvaluationTest'};
my $jld = JSONLD->new(base_iri => IRI->new($test_base), processing_mode => $mode);
my $infile = File::Spec->catfile($path, $input);
my $outfile = File::Spec->catfile($path, $expect);
my $data = load_json($infile);
if ($debug) {
warn "Input file: $infile\n";
warn "INPUT:\n===============\n" . JSON->new->pretty->encode($data); # Dumper($data);
}
my $expanded = eval { $jld->expand($data, %args) };
if ($@) {
if ($positive) {
earl_fail_test( $earl, $test_iri, $@ );
fail("$id: $@")
} else {
if ($REPORT_NEGATIVE_TESTS) {
earl_pass_test( $earl, $test_iri );
pass("$id: NegativeEvaluationTest");
}
}
} else {
my $got = _normalize($expanded);
if ($positive) {
my $expected = _normalize(load_json($outfile));
if ($debug) {
my @data = (
['EXPECTED', $expected],
['OUTPUT__', $got],
);
my @files;
foreach my $d (@data) {
my ($name, $data) = @$d;
warn "=======================\n";
my $filename = "/tmp/json-ld-$$-$name.out";
open(my $fh, '>', $filename) or die $!;
push(@files, $filename);
my $out = Data::Dumper->Dump([$data], ["*$name"]);
warn $out;
print {$fh} $out;
close($fh);
}
unless (Compare($got, $expected)) {
system('/usr/local/bin/bbdiff', '--wait', '--resume', @files);
}
}
my $pass = ok(Compare($got, $expected), "$id: $name");
if ($pass) {
earl_pass_test( $earl, $test_iri );
} else {
earl_fail_test( $earl, $test_iri, 'computed value differes from expected value' );
}
} else {
if ($REPORT_NEGATIVE_TESTS) {
earl_fail_test( $earl, $test_iri, 'expected failure but found success' );
fail("$id: expected failure but found success");
my $out = Data::Dumper->Dump([$j->decode($got)], ["got"]);
warn $out;
}
}
}
} else {
diag("Not a recognized evaluation test: " . Dumper(\@types));
next;
}
}
}
done_testing();
unless ($debug) {
my $output = earl_output($earl);
open(my $fh, '>:utf8', "jsonld-${component}-earl.ttl") or die $!;
print {$fh} $output;
close($fh);
}
JSONLD-0.005/xt/PaxHeader/to-rdf.t 000644 000765 000024 00000000036 13764470755 016603 x ustar 00greg staff 000000 000000 30 mtime=1607627245.083306842
JSONLD-0.005/xt/to-rdf.t 000644 000765 000024 00000021413 13764470755 014634 0 ustar 00greg staff 000000 000000 use v5.14;
use autodie;
use utf8;
use Carp qw(confess);
use Test::More;
use Test::Exception;
use FindBin qw($Bin);
use File::Glob qw(bsd_glob);
use File::Spec;
use JSON qw(decode_json);
use Data::Dumper;
use JSONLD;
use open ':std', ':encoding(UTF-8)';
use lib qw(.);
require "xt/earl.pl";
use Moo;
use Attean;
use Type::Tiny::Role;
our $debug = 0;
$JSONLD::debug = $debug;
our $PATTERN;
if ($debug) {
$PATTERN = qr/tjs09/;
# $PATTERN = qr/gtw/;
} else {
$PATTERN = qr/./;
}
my $REPORT_NEGATIVE_TESTS = 1;
package MyJSONLD {
use v5.18;
use autodie;
use Moo;
use Attean::RDF;
use Encode qw(decode_utf8 encode_utf8);
extends 'JSONLD';
use namespace::clean;
sub default_graph {
return iri('http://attean.example.org/default-graph');
}
sub add_quad {
my $self = shift;
my $quad = shift;
my $ds = shift;
$ds->add_quad($quad);
}
sub new_dataset {
my $self = shift;
my $store = Attean->get_store('Memory')->new();
return $store;
}
sub new_triple {
my $self = shift;
foreach my $v (@_) {
Carp::confess "not a term object" unless (ref($v));
}
return triple(@_);
}
sub new_quad {
my $self = shift;
foreach my $v (@_) {
unless (ref($v) and $v->does('Attean::API::Term')) {
# warn "not a term object: $v";
return;
}
}
return quad(@_);
}
sub skolem_prefix {
my $self = shift;
return 'tag:gwilliams@cpan.org,2019-12:JSONLD:skolem:';
}
sub new_graphname {
my $self = shift;
my $value = shift;
if ($value =~ /^_:(.+)$/) {
$value = $self->skolem_prefix() . $1;
}
return $self->new_iri($value);
}
sub new_iri {
my $self = shift;
return iri(shift);
}
sub new_blank {
my $self = shift;
return blank(@_);
}
sub new_lang_literal {
my $self = shift;
my $value = shift;
my $lang = shift;
return langliteral($value, $lang);
}
sub canonical_json {
my $class = shift;
my $value = shift;
my $j = JSON->new->utf8->allow_nonref->canonical(1);
my $v = $j->decode($value);
return $j->encode($v);
}
sub new_dt_literal {
my $self = shift;
my $value = shift;
my $dt = shift;
if ($dt eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#JSON') {
$value = decode_utf8($self->canonical_json(encode_utf8($value)));
}
return dtliteral($value, $dt);
}
}
sub load_nq {
my $file = shift;
open(my $fh, '<:utf8', $file) or die $!;
my $parser = Attean->get_parser('nquads')->new();
my $iter = $parser->parse_iter_from_io($fh);
my $miter = $iter->materialize;
# foreach my $st ($miter->elements) {
# say $st->as_string;
# }
my %seen;
return $miter->map(sub {
# canonicalize rdf:JSON literals
my $st = shift;
my $o = $st->object;
if ($o->does('Attean::API::Literal')) {
my $dt = $o->datatype;
if ($dt and $dt->value eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#JSON') {
my $value = $o->value;
my $stclass = ref($st);
my @nodes = $st->values;
$nodes[2] = MyJSONLD->new_dt_literal($value, 'http://www.w3.org/1999/02/22-rdf-syntax-ns#JSON');
$st = $stclass->new(@nodes);
}
}
return $st;
})->grep(sub {
my $st = shift;
$seen{ $st->as_string }++;
return ($seen{ $st->as_string } == 1);
})->materialize;
}
sub load_json {
my $file = shift;
open(my $fh, '<:utf8', $file);
my $j = JSON->new()->canonical(1);
return $j->decode(do { local($/); <$fh> });
}
my $component = 'toRdf';
my $earl = init_earl();
my $path = File::Spec->catfile( $Bin, 'data', 'json-ld-api-w3c' );
my $manifest = File::Spec->catfile($path, "${component}-manifest.jsonld");
my $d = load_json($manifest);
my $base_url = "https://w3c.github.io/json-ld-api/tests/${component}-manifest";
my $jj = JSONLD->new(base_iri => IRI->new('file://' . $manifest));
my $tests = $d->{'sequence'};
my $base = IRI->new(value => $d->{'baseIri'} // 'http://example.org/');
foreach my $t (@$tests) {
my $id = $t->{'@id'};
next unless ($id =~ $PATTERN);
my $test_iri = $jj->expand($t, expandContext => [{'@base' => $base_url}, 'context.jsonld'])->[0]{'@id'};
my $input = $t->{'input'};
my $expect = $t->{'expect'} // '';
my $name = $t->{'name'};
my $purpose = $t->{'purpose'};
my $options = $t->{'option'} // {};
my $_base = $options->{'base'};
my $spec_v = $options->{'specVersion'} // '';
my $mode = $options->{'processingMode'} // 'json-ld-1.1';
my $genRDF = $options->{'produceGeneralizedRdf'} // 0;
my @types = @{ $t->{'@type'} };
my %types = map { $_ => 1 } @types;
my %args;
warn "INPUT: $input\n" if ($debug);
my %expandArgs;
if (my $expand = $options->{'expandContext'}) {
my $base = IRI->new(value => 'file://' . $manifest);
my $iri = IRI->new(value => $expand, base => $base);
$expand = $iri->abs;
$expandArgs{'expandContext'} = $expand;
warn "CONTEXT: $expand\n" if ($debug);
}
if (my $rdfDir = $options->{'rdfDirection'}) {
$args{rdf_direction} = $rdfDir;
}
my $test_base;
if (defined($_base)) {
$test_base = IRI->new(value => $_base, base => $base)->abs;
} else {
$test_base = IRI->new(value => $input, base => $base)->abs;
}
my $j = JSON->new->canonical(1);
SKIP: {
skip("skipping IGNORING JSON-LD-1.0-only test $id", 1) if ($spec_v eq 'json-ld-1.0');
if ($genRDF) {
diag("IGNORING test producing Generalized RDF: $id\n");
} elsif ($types{'jld:PositiveEvaluationTest'} or $types{'jld:PositiveSyntaxTest'} or $types{'jld:NegativeEvaluationTest'}) {
note($id) if $debug;
my $positive = ($types{'jld:PositiveEvaluationTest'} || $types{'jld:PositiveSyntaxTest'});
my $evalTest = $types{'jld:PositiveEvaluationTest'};
my $jld = MyJSONLD->new(base_iri => IRI->new($test_base), processing_mode => $mode, %args);
my $infile = File::Spec->catfile($path, $input);
my $data = load_json($infile);
my $outfile = File::Spec->catfile($path, $expect);
if ($debug) {
warn "Input file: $infile\n";
if ($evalTest) {
warn "Output file: $outfile\n";
}
warn "INPUT:\n===============\n" . JSON->new->pretty->encode($data);
}
my $default_graph = $jld->default_graph();
my $got = eval {
my $qiter = $jld->to_rdf($data, %expandArgs)->get_quads()->materialize();
my $iter = Attean::CodeIterator->new(generator => sub {
my $q = $qiter->next;
return unless ($q);
my $g = $q->graph;
my $prefix = $jld->skolem_prefix();
if ($g->equals($default_graph)) {
return $q->as_triple;
} elsif (substr($g->value, 0, length($prefix)) eq $prefix) {
my $gb = $jld->new_blank(substr($g->value, length($prefix)));
my @terms = $q->values;
$terms[3] = $gb;
return $jld->new_quad(@terms);
} else {
return $q;
}
}, item_type => 'Attean::API::TripleOrQuad')->materialize;
};
if ($@) {
if ($positive) {
earl_fail_test( $earl, $test_iri, $@ );
fail("Died: $id: $@");
} else {
if ($REPORT_NEGATIVE_TESTS) {
earl_pass_test( $earl, $test_iri );
pass("$id: NegativeEvaluationTest");
}
}
next;
} else {
if ($evalTest) {
if ($positive) {
eval {
my $eqtest = Attean::BindingEqualityTest->new();
my $expected = load_nq($outfile);
# local $SIG{ALRM} = sub { die "timeout" };
# alarm(30);
my $ok = ok($eqtest->equals($got, $expected), "$id: $name");
# alarm(0);
if ($ok) {
earl_pass_test( $earl, $test_iri );
} else {
earl_fail_test( $earl, $test_iri, 'failed to find a graph isomorphism between computed and expected RDF triples' );
}
if ($debug) {
my @data = (
['EXPECTED', $expected],
['OUTPUT__', $got],
);
my @files;
my $ser = Attean->get_serializer('nquads')->new();
foreach my $d (@data) {
my ($name, $data) = @$d;
$data->reset;
warn "=======================\n";
my $filename = "/tmp/json-ld-$$-$name.out";
open(my $fh, '>', $filename) or die $!;
push(@files, $filename);
print {$fh} "# $name\n";
$ser->serialize_iter_to_io($fh, $data);
close($fh);
}
unless ($ok) {
system('/usr/local/bin/bbdiff', '--wait', '--resume', @files);
}
}
};
if ($@) {
earl_fail_test( $earl, $test_iri, $@ );
fail("$id: $@");
next;
}
} else {
if ($REPORT_NEGATIVE_TESTS) {
earl_fail_test( $earl, $test_iri, "expected failure but found success" );
fail("$id: expected failure but found success");
}
}
} else {
earl_pass_test( $earl, $test_iri );
pass("$id: PositiveSyntaxTest");
}
}
} elsif ($types{'jld:NegativeEvaluationTest'}){
diag("IGNORING NegativeEvaluationTest $id\n");
} else {
diag("Not a recognized evaluation test: " . Dumper(\@types));
next;
}
}
}
done_testing();
unless ($debug) {
my $output = earl_output($earl);
open(my $fh, '>:utf8', "jsonld-${component}-earl.ttl") or die $!;
print {$fh} $output;
close($fh);
}
JSONLD-0.005/t/simple.t 000644 000765 000024 00000000546 13607766043 014540 0 ustar 00greg staff 000000 000000 use Test::Modern;
use Test::Exception;
use v5.14;
use warnings;
no warnings 'redefine';
use JSONLD;
{
my $jld = JSONLD->new();
my $data = {
'@context' => { '@vocab' => 'http://example.org/', },
'foo' => 'bar',
};
my $e = $jld->expand($data);
is_deeply($e, [{
'http://example.org/foo' => [
{ '@value' => 'bar' }
]
}])
}
done_testing();
JSONLD-0.005/t/00.load.t 000644 000765 000024 00000000143 13607766043 014375 0 ustar 00greg staff 000000 000000 use Test::More tests => 1;
BEGIN {
use_ok( 'JSONLD' );
}
note( "Testing RDF $JSONLD::VERSION" );
JSONLD-0.005/meta/PaxHeader/changes.ttl 000644 000765 000024 00000000035 13765311731 017637 x ustar 00greg staff 000000 000000 29 mtime=1607832537.13336054
JSONLD-0.005/meta/changes.ttl 000644 000765 000024 00000005034 13765311731 015672 0 ustar 00greg staff 000000 000000 # -*-n3-*-
@prefix : .
@prefix dc: .
@prefix dcs: .
@prefix foaf: .
@prefix rdfs: .
@prefix xsd: .
@prefix dcterms: .
@prefix doap: .
@prefix my: .
<>
dc:title "Chagnes for JSONLD" ;
dc:subject my:project ;
dc:creator my:developer ;
dc:description "Changes for JSONLD" ;
.
my:project
a :Project ;
:name "JSONLD" ;
:shortdesc "JSON-LD Toolkit" ;
:programming-language "Perl" ;
:created "2019-10-28"^^xsd:date ;
:maintainer my:developer ;
:homepage ;
:bug-database ;
doap:download-page ;
doap:download-mirror ;
:release my:v_0-001 , my:v_0-002 , my:v_0-003 , my:v_0-004 , my:v_0-005 ;
.
my:v_0-005
a :Version ;
dc:issued "2020-12-12"^^xsd:date ;
:revision "0.005" ;
dcterms:replaces my:v_0-004 ;
dcs:changeset [
dcs:item
[ a dcs:Update ; rdfs:label "Fix package metadata (#4)." ] ,
[ a dcs:Update ; rdfs:label "Fix version references in README.md (#5)." ]
]
.
my:v_0-004
a :Version ;
dc:issued "2020-05-17"^^xsd:date ;
:revision "0.004" ;
dcterms:replaces my:v_0-003 ;
dcs:changeset [
dcs:item
[ a dcs:Update ; rdfs:label "Improve handling of invalid JSONLD input." ] ,
[ a dcs:Update ; rdfs:label "Track changes in the JSONLD spec." ] ,
[ a dcs:Update ; rdfs:label "Use new IRI->rel method." ] ,
[ a dcs:Update ; rdfs:label "Allow specifying a context file on the command line for jsonld-expand." ]
]
.
my:v_0-003
a :Version ;
dc:issued "2020-03-08"^^xsd:date ;
:revision "0.003" ;
dcterms:replaces my:v_0-002 ;
dcs:changeset [
dcs:item
[ a dcs:Update ; rdfs:label "Version number bump to fix PAUSE issues." ] ,
[ a dcs:Update ; rdfs:label "Remove use of Debug::ShowStuff for releases." ]
]
.
my:v_0-002
a :Version ;
dc:issued "2020-01-26"^^xsd:date ;
:revision "0.002" ;
dcterms:replaces my:v_0-001 ;
dcs:changeset [
dcs:item
[ a dcs:Update ; rdfs:label "Updated documentation." ]
]
.
my:v_0-001
a :Version ;
dc:issued "2020-01-25"^^xsd:date ;
:revision "0.001" ;
dcs:changeset [
dcs:item
[ a dcs:Addition ; rdfs:label "First release." ]
]
.
JSONLD-0.005/bin/jsonld-expand 000755 000765 000024 00000001756 13643711016 016055 0 ustar 00greg staff 000000 000000 #!/usr/bin/env perl
use v5.18;
use autodie;
use utf8;
use File::Spec;
use JSON;
use JSONLD;
use open ':std', ':encoding(UTF-8)';
my $data;
my $base;
my $j = JSON->new->pretty(1)->canonical(1)->allow_nonref(1);
my $context = {};
while (scalar(@ARGV) and $ARGV[0] =~ /^-(\w+)$/) {
my $flag = $1;
shift;
if ($flag eq 'v') {
$JSONLD::debug = 1;
} elsif ($flag eq 'c') {
my $file = shift;
open(my $fh, '<:utf8', $file);
my $j = JSON->new();
$context = $j->decode(do { local($/); <$fh> });
}
}
my %args;
if (scalar(@{ [keys %$context] })) {
$args{expandContext} = $context;
}
if (scalar(@ARGV)) {
my $file = shift;
open(my $fh, '<:utf8', $file);
$data = $j->decode(do { local($/); <$fh> });
$base = 'file://' . File::Spec->rel2abs($file);
} else {
$data = $j->decode(do { local($/); <> });
$base = 'http://base.example.org/';
}
my $jld = JSONLD->new(base_iri => IRI->new($base));
my $expanded = eval { $jld->expand($data, %args) };
if ($@) {
die $@;
}
print $j->encode($expanded);
JSONLD-0.005/bin/jsonld-nq 000755 000765 000024 00000004622 13643710726 015216 0 ustar 00greg staff 000000 000000 #!/usr/bin/env perl
use v5.18;
use autodie;
use utf8;
use File::Spec;
use JSON;
use JSONLD;
use Attean;
use open ':std', ':encoding(UTF-8)';
package MyJSONLD {
use v5.14;
use autodie;
use Moo;
use Attean::RDF;
extends 'JSONLD';
use namespace::clean;
sub default_graph {
return iri('http://attean.example.org/default-graph');
}
sub add_quad {
my $self = shift;
my $triple = shift;
my $ds = shift;
$ds->add_quad($triple);
}
sub new_dataset {
my $self = shift;
my $store = Attean->get_store('Memory')->new();
return $store;
}
sub new_triple {
my $self = shift;
foreach my $v (@_) {
Carp::confess "not a term object" unless (ref($v));
}
return triple(@_);
}
sub new_quad {
my $self = shift;
foreach my $v (@_) {
Carp::confess "not a term object: $v" unless (ref($v));
}
return quad(@_);
}
sub new_graphname {
my $self = shift;
my $value = shift;
if ($value =~ /^_:(.+)$/) {
$value = 'tag:gwilliams@cpan.org,2019-12:JSONLD:skolem:' . $1;
}
return $self->new_iri($value);
}
sub new_iri {
my $self = shift;
return iri(shift);
}
sub new_blank {
my $self = shift;
return blank(@_);
}
sub new_lang_literal {
my $self = shift;
my $value = shift;
my $lang = shift;
return langliteral($value, $lang);
}
sub new_dt_literal {
my $self = shift;
my $value = shift;
my $dt = shift;
return dtliteral($value, $dt);
}
}
my $data;
my $base;
my $j = JSON->new->pretty(1)->canonical(1)->allow_nonref(1);
while (scalar(@ARGV) and $ARGV[0] =~ /^-(\w+)$/) {
my $flag = $1;
shift;
if ($flag eq 'v') {
$JSONLD::debug = 1;
}
}
if (scalar(@ARGV)) {
my $file = shift;
open(my $fh, '<:utf8', $file);
$data = $j->decode(do { local($/); <$fh> });
$base = 'file://' . File::Spec->rel2abs($file);
} else {
$data = $j->decode(do { local($/); <> });
$base = 'http://base.example.org/';
}
my $jld = MyJSONLD->new(base_iri => IRI->new($base));
my $default_graph = $jld->default_graph();
my $iter = eval {
my $qiter = $jld->to_rdf($data)->get_quads()->materialize();
my $iter = Attean::CodeIterator->new(generator => sub {
my $q = $qiter->next;
return unless ($q);
if ($q->graph->equals($default_graph)) {
return $q->as_triple;
} else {
return $q;
}
}, item_type => 'Attean::API::TripleOrQuad')->materialize;
};
if ($@) {
die $@;
}
my $ser = Attean->get_serializer('nquads')->new();
$ser->serialize_iter_to_io(\*STDOUT, $iter);
JSONLD-0.005/bin/PaxHeader/jsonld-compact 000755 000765 000024 00000000036 13612230273 020160 x ustar 00greg staff 000000 000000 30 mtime=1579757755.652800732
JSONLD-0.005/bin/jsonld-compact 000755 000765 000024 00000001636 13612230273 016216 0 ustar 00greg staff 000000 000000 #!/usr/bin/env perl
use v5.18;
use autodie;
use utf8;
use File::Spec;
use JSON;
use JSONLD;
use open ':std', ':encoding(UTF-8)';
my $data;
my $base;
my $j = JSON->new->pretty(1)->canonical(1)->allow_nonref(1);
my $context = {};
while (scalar(@ARGV) and $ARGV[0] =~ /^-(\w+)$/) {
my $flag = $1;
shift;
if ($flag eq 'v') {
$JSONLD::debug = 1;
} elsif ($flag eq 'c') {
my $file = shift;
open(my $fh, '<:utf8', $file);
my $j = JSON->new();
$context = $j->decode(do { local($/); <$fh> });
}
}
if (scalar(@ARGV)) {
my $file = shift;
open(my $fh, '<:utf8', $file);
$data = $j->decode(do { local($/); <$fh> });
$base = 'file://' . File::Spec->rel2abs($file);
} else {
$data = $j->decode(do { local($/); <> });
$base = 'http://base.example.org/';
}
my $jld = JSONLD->new(base_iri => IRI->new($base));
my $expanded = eval { $jld->compact($data, $context) };
if ($@) {
die $@;
}
print $j->encode($expanded);
JSONLD-0.005/inc/Module/ 000755 000765 000024 00000000000 13765312076 014606 5 ustar 00greg staff 000000 000000 JSONLD-0.005/inc/Module/Install/ 000755 000765 000024 00000000000 13765312076 016214 5 ustar 00greg staff 000000 000000 JSONLD-0.005/inc/Module/Install.pm 000644 000765 000024 00000027145 13765312062 016556 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install;
# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
# 3. The installed version of inc::Module::Install loads
# 4. inc::Module::Install calls "require Module::Install"
# 5. The ./inc/ version of Module::Install loads
# } ELSE {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
# 3. The ./inc/ version of Module::Install loads
# }
use 5.006;
use strict 'vars';
use Cwd ();
use File::Find ();
use File::Path ();
use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
# different versions of modules.
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '1.19';
# Storage for the pseudo-singleton
$MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
# all of the following checks should be included in import(),
# to allow "eval 'require Module::Install; 1' to test
# installation of Module::Install. (RT #51267)
#-------------------------------------------------------------
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
# This reportedly fixes a rare Win32 UTC file time issue, but
# as this is a non-cross-platform XS module not in the core,
# we shouldn't really depend on it. See RT #24194 for detail.
# (Also, this module only supports Perl 5.6 and above).
eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
my $s = (stat($0))[9];
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
my $t = time;
if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
It was impossible to maintain duel backends, and has been deprecated.
Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
#-------------------------------------------------------------
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
#-------------------------------------------------------------
unless ( -f $self->{file} ) {
foreach my $key (keys %INC) {
delete $INC{$key} if $key =~ /Module\/Install/;
}
local $^W;
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
goto &{"$self->{name}::import"};
}
local $^W;
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{'inc/Module/Install.pm'};
delete $INC{'Module/Install.pm'};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::getcwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::getcwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
unless ($$sym =~ s/([^:]+)$//) {
# XXX: it looks like we can't retrieve the missing function
# via $$sym (usually $main::AUTOLOAD) in this case.
# I'm still wondering if we should slurp Makefile.PL to
# get some context or not ...
my ($package, $file, $line) = caller;
die <<"EOT";
Unknown function is found at $file line $line.
Execution of $file aborted due to runtime errors.
If you're a contributor to a project, you may need to install
some Module::Install extensions from CPAN (or other repository).
If you're a user of a module, please contact the author.
EOT
}
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
return;
} elsif ( $method =~ /^_/ and $self->can($method) ) {
# Dispatch to the root M:I class
return $self->$method(@_);
}
# Dispatch to the appropriate plugin
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
@exts = $self->{admin}->load_all_extensions;
}
my %seen;
foreach my $obj ( @exts ) {
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
$base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS';
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
$args{bundle} ||= 'inc/BUNDLES';
$args{base} ||= $base_path;
$class =~ s/^\Q$args{prefix}\E:://;
$args{name} ||= $class;
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
$should_reload = 1;
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { local $^W; require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} =
$should_reload ? delete $INC{$file} : $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( {no_chdir => 1, wanted => sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($File::Find::name);
my $in_pod = 0;
foreach ( split /\n/, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
$pkg = $1;
last;
}
}
}
push @found, [ $file, $pkg ];
}}, $path ) if -d $path;
@found;
}
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
binmode FH;
my $string = do { local $/; };
close FH or die "close($_[0]): $!";
return $string;
}
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
$string =~ s/^\n+//s;
return $string;
}
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2012 Adam Kennedy.
JSONLD-0.005/inc/Module/Install/Fetch.pm 000644 000765 000024 00000004627 13765312063 017610 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
JSONLD-0.005/inc/Module/Install/Metadata.pm 000644 000765 000024 00000043302 13765312063 020270 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::Metadata;
use strict 'vars';
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
};
my @scalar_keys = qw{
name
module_name
abstract
version
distribution_type
tests
installdirs
};
my @tuple_keys = qw{
configure_requires
build_requires
requires
recommends
bundles
resources
};
my @resource_keys = qw{
homepage
bugtracker
repository
};
my @array_keys = qw{
keywords
author
};
*authors = \&author;
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys { @array_keys }
foreach my $key ( @boolean_keys ) {
*$key = sub {
my $self = shift;
if ( defined wantarray and not @_ ) {
return $self->{values}->{$key};
}
$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
return $self;
};
}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} = shift;
return $self;
};
}
foreach my $key ( @array_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} ||= [];
push @{$self->{values}->{$key}}, @_;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}->{resources} };
}
return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} unless @_;
my @added;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @added, [ $module, $version ];
}
push @{ $self->{values}->{$key} }, @added;
return map {@$_} @added;
};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
my $value = @_ ? shift : 1;
if ( $self->{values}->{dynamic_config} ) {
# Once dynamic we never change to static, for safety
return 0;
}
$self->{values}->{dynamic_config} = $value ? 1 : 0;
return 1;
}
# Convenience command
sub static_config {
shift->dynamic_config(0);
}
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
# Normalize the version
$version = $self->_perl_version($version);
# We don't support the really old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
$self->{values}->{perl_version} = $version;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name or die(
"all_from called with no args without setting name() first"
);
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
unless ( -e $file ) {
die("all_from cannot find $file from $name");
}
}
unless ( -f $file ) {
die("The path '$file' does not exist, or is not a file");
}
$self->{values}{all_from} = $file;
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
$pod =~ s/\.pm$/.pod/i;
$pod = $file unless -e $pod;
# Pull the different values
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
$self->author_from($pod) unless @{$self->author || []};
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
return 1;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
return $self->{values}->{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML::Tiny', 0 );
require YAML::Tiny;
my $data = YAML::Tiny::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
} else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
# for version integrity check
$self->makemaker_args( VERSION_FROM => $file );
}
sub abstract_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
# Add both distribution and module name
sub name_from {
my ($self, $file) = @_;
if (
Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
[\s|;]*
/ixms
) {
my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
unless ( $self->module_name ) {
$self->module_name($module_name);
}
} else {
die("Cannot determine name from $file\n");
}
}
sub _extract_perl_version {
if (
$_[0] =~ m/
^\s*
(?:use|require) \s*
v?
([\d_\.]+)
\s* ;
/ixms
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
return $perl_version;
} else {
return;
}
}
sub perl_version_from {
my $self = shift;
my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
return;
}
}
sub author_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
# XXX: ugly but should work anyway...
if (eval "require Pod::Escapes; 1") {
# Pod::Escapes has a mapping table.
# It's in core of perl >= 5.9.3, and should be installed
# as one of the Pod::Simple's prereqs, which is a prereq
# of Pod::Text 3.x (see also below).
$author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
{
defined $2
? chr($2)
: defined $Pod::Escapes::Name2character_number{$1}
? chr($Pod::Escapes::Name2character_number{$1})
: do {
warn "Unknown escape: E<$1>";
"E<$1>";
};
}gex;
}
elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
# Pod::Text < 3.0 has yet another mapping table,
# though the table name of 2.x and 1.x are different.
# (1.x is in core of Perl < 5.6, 2.x is in core of
# Perl < 5.9.3)
my $mapping = ($Pod::Text::VERSION < 2)
? \%Pod::Text::HTML_Escapes
: \%Pod::Text::ESCAPES;
$author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
{
defined $2
? chr($2)
: defined $mapping->{$1}
? $mapping->{$1}
: do {
warn "Unknown escape: E<$1>";
"E<$1>";
};
}gex;
}
else {
$author =~ s{E}{<}g;
$author =~ s{E}{>}g;
}
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
#Stolen from M::B
my %license_urls = (
perl => 'http://dev.perl.org/licenses/',
apache => 'http://apache.org/licenses/LICENSE-2.0',
apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
artistic => 'http://opensource.org/licenses/artistic-license.php',
artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
lgpl => 'http://opensource.org/licenses/lgpl-license.php',
lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
bsd => 'http://opensource.org/licenses/bsd-license.php',
gpl => 'http://opensource.org/licenses/gpl-license.php',
gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
mit => 'http://opensource.org/licenses/mit-license.php',
mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
);
sub license {
my $self = shift;
return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$license = __extract_license($license) || lc $license;
$self->{values}->{license} = $license;
# Automatically fill in license URLs
if ( $license_urls{$license} ) {
$self->resources( license => $license_urls{$license} );
}
return 1;
}
sub _extract_license {
my $pod = shift;
my $matched;
return __extract_license(
($matched) = $pod =~ m/
(=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
(=head \d.*|=cut.*|)\z
/xms
) || __extract_license(
($matched) = $pod =~ m/
(=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
(=head \d.*|=cut.*|)\z
/xms
);
}
sub __extract_license {
my $license_text = shift or return;
my @phrases = (
'(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
'(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
'Artistic and GPL' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
'GNU lesser public license' => 'lgpl', 1,
'GNU library general public license' => 'lgpl', 1,
'GNU library public license' => 'lgpl', 1,
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'Mozilla Public License' => 'mozilla', 1,
'Q Public License' => 'open_source', 1,
'OpenSSL License' => 'unrestricted', 1,
'SSLeay License' => 'unrestricted', 1,
'zlib License' => 'open_source', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
return $license;
}
}
return '';
}
sub license_from {
my $self = shift;
if (my $license=_extract_license(Module::Install::_read($_[0]))) {
$self->license($license);
} else {
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
}
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(
https?\Q://rt.cpan.org/\E[^>]+|
https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
)>#gx;
my %links;
@links{@links}=();
@links=keys %links;
return @links;
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
my @links = _extract_bugtracker($content);
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
}
if ( @links > 1 ) {
warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
# Numify
$v = $v + 0;
}
return $v;
}
sub add_metadata {
my $self = shift;
my %hash = @_;
for my $key (keys %hash) {
warn "add_metadata: $key is not prefixed with 'x_'.\n" .
"Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
$self->{values}->{$key} = $hash{$key};
}
}
######################################################################
# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
sub write_mymeta_yaml {
my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
sub write_mymeta_json {
my $self = shift;
# We need JSON to write the MYMETA.json file
unless ( eval { require JSON; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.json\n";
Module::Install::_write(
'MYMETA.json',
JSON->new->pretty(1)->canonical->encode($meta),
);
}
sub _write_mymeta_data {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return undef unless -f 'META.yml';
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
my $requires = $val->{requires};
# Canonize to three-dot version after Perl 5.6
if ( $perl >= 5.006 ) {
$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
unshift @$requires, [ perl => $perl ];
}
# Load the advisory META.yml file
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashes
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
if ( exists $val->{requires} ) {
$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
}
if ( exists $val->{build_requires} ) {
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
return $meta;
}
1;
JSONLD-0.005/inc/Module/Install/AuthorTests.pm 000644 000765 000024 00000002215 13765312063 021033 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::AuthorTests;
use 5.005;
use strict;
use Module::Install::Base;
use Carp ();
#line 16
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.002';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
#line 42
sub author_tests {
my ($self, @dirs) = @_;
_add_author_tests($self, \@dirs, 0);
}
#line 56
sub recursive_author_tests {
my ($self, @dirs) = @_;
_add_author_tests($self, \@dirs, 1);
}
sub _wanted {
my $href = shift;
sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 }
}
sub _add_author_tests {
my ($self, $dirs, $recurse) = @_;
return unless $Module::Install::AUTHOR;
my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t';
# XXX: pick a default, later -- rjbs, 2008-02-24
my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests";
@dirs = grep { -d } @dirs;
if ($recurse) {
require File::Find;
my %test_dir;
File::Find::find(_wanted(\%test_dir), @dirs);
$self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir );
} else {
$self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs );
}
}
#line 107
1;
JSONLD-0.005/inc/Module/Install/Win32.pm 000644 000765 000024 00000003403 13765312063 017450 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::Win32;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
);
print "The required 'nmake' executable not found, fetching it...\n";
require File::Basename;
my $rv = $self->get_file(
url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
local_dir => File::Basename::dirname($^X),
size => 51928,
run => 'Nmake15.exe /o > nul',
check_for => 'Nmake.exe',
remove => 1,
);
die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
Since you are using Microsoft Windows, you will need the 'nmake' utility
before installation. It's available at:
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
or
ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
Please download the file manually, save it to a directory in %PATH% (e.g.
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
that directory, and run "Nmake15.exe" from there; that will create the
'nmake.exe' file needed by this module.
You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
}
1;
JSONLD-0.005/inc/Module/Install/DOAPChangeSets.pm 000644 000765 000024 00000000616 13765312063 021241 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::DOAPChangeSets;
use 5.008;
use parent qw(Module::Install::Base);
use strict;
our $VERSION = '0.206';
our $AUTHOR_ONLY = 1;
sub write_doap_changes {
my $self = shift;
$self->admin->write_doap_changes(@_) if $self->is_admin;
}
sub write_doap_changes_xml {
my $self = shift;
$self->admin->write_doap_changes_xml(@_) if $self->is_admin;
}
1;
__END__
#line 84
JSONLD-0.005/inc/Module/Install/WriteAll.pm 000644 000765 000024 00000002376 13765312063 020301 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::WriteAll;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
sub WriteAll {
my $self = shift;
my %args = (
meta => 1,
sign => 0,
inline => 0,
check_nmake => 1,
@_,
);
$self->sign(1) if $args{sign};
$self->admin->WriteAll(%args) if $self->is_admin;
$self->check_nmake if $args{check_nmake};
unless ( $self->makemaker_args->{PL_FILES} ) {
# XXX: This still may be a bit over-defensive...
unless ($self->makemaker(6.25)) {
$self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
}
}
# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
# we clean it up properly ourself.
$self->realclean_files('MYMETA.yml');
if ( $args{inline} ) {
$self->Inline->write;
} else {
$self->Makefile->write;
}
# The Makefile write process adds a couple of dependencies,
# so write the META.yml files after the Makefile.
if ( $args{meta} ) {
$self->Meta->write;
}
# Experimental support for MYMETA
if ( $ENV{X_MYMETA} ) {
if ( $ENV{X_MYMETA} eq 'JSON' ) {
$self->Meta->write_mymeta_json;
} else {
$self->Meta->write_mymeta_yaml;
}
}
return 1;
}
1;
JSONLD-0.005/inc/Module/Install/Can.pm 000644 000765 000024 00000006405 13765312063 017254 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::Can;
use strict;
use Config ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# Check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
require File::Spec;
my $abs = File::Spec->catfile($dir, $cmd);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# Can our C compiler environment build XS files
sub can_xs {
my $self = shift;
# Ensure we have the CBuilder module
$self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
# Do we have the configure_requires checker?
local $@;
eval "require ExtUtils::CBuilder;";
if ( $@ ) {
# They don't obey configure_requires, so it is
# someone old and delicate. Try to avoid hurting
# them by falling back to an older simpler test.
return $self->can_cc();
}
# Do we have a working C compiler
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
unless ( $builder->have_compiler ) {
# No working C compiler
return 0;
}
# Write a C file representative of what XS becomes
require File::Temp;
my ( $FH, $tmpfile ) = File::Temp::tempfile(
"compilexs-XXXXX",
SUFFIX => '.c',
);
binmode $FH;
print $FH <<'END_C';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
int main(int argc, char **argv) {
return 0;
}
int boot_sanexs() {
return 1;
}
END_C
close $FH;
# Can the C compiler access the same headers XS does
my @libs = ();
my $object = undef;
eval {
local $^W = 0;
$object = $builder->compile(
source => $tmpfile,
);
@libs = $builder->link(
objects => $object,
module_name => 'sanexs',
);
};
my $result = $@ ? 0 : 1;
# Clean up all the build files
foreach ( $tmpfile, $object, @libs ) {
next unless defined $_;
1 while unlink;
}
return $result;
}
# Can we locate a (the) C compiler
sub can_cc {
my $self = shift;
if ($^O eq 'VMS') {
require ExtUtils::CBuilder;
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
return $builder->have_compiler;
}
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
}
return;
}
# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
require ExtUtils::MM_Cygwin;
require ExtUtils::MM_Win32;
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
*ExtUtils::MM_Cygwin::maybe_command = sub {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
ExtUtils::MM_Win32->maybe_command($file);
} else {
ExtUtils::MM_Unix->maybe_command($file);
}
}
}
}
1;
__END__
#line 245
JSONLD-0.005/inc/Module/Install/Makefile.pm 000644 000765 000024 00000027437 13765312063 020300 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing or non-interactive session, always use defaults
if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
# Store a cleaned up version of the MakeMaker version,
# since we need to behave differently in a variety of
# ways based on the MM version.
my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
# If we are passed a param, do a "newer than" comparison.
# Otherwise, just return the MakeMaker version.
sub makemaker {
( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
}
# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
# as we only need to know here whether the attribute is an array
# or a hash or something else (which may or may not be appendable).
my %makemaker_argtype = (
C => 'ARRAY',
CONFIG => 'ARRAY',
# CONFIGURE => 'CODE', # ignore
DIR => 'ARRAY',
DL_FUNCS => 'HASH',
DL_VARS => 'ARRAY',
EXCLUDE_EXT => 'ARRAY',
EXE_FILES => 'ARRAY',
FUNCLIST => 'ARRAY',
H => 'ARRAY',
IMPORTS => 'HASH',
INCLUDE_EXT => 'ARRAY',
LIBS => 'ARRAY', # ignore ''
MAN1PODS => 'HASH',
MAN3PODS => 'HASH',
META_ADD => 'HASH',
META_MERGE => 'HASH',
PL_FILES => 'HASH',
PM => 'HASH',
PMLIBDIRS => 'ARRAY',
PMLIBPARENTDIRS => 'ARRAY',
PREREQ_PM => 'HASH',
CONFIGURE_REQUIRES => 'HASH',
SKIP => 'ARRAY',
TYPEMAPS => 'ARRAY',
XS => 'HASH',
# VERSION => ['version',''], # ignore
# _KEEP_AFTER_FLUSH => '',
clean => 'HASH',
depend => 'HASH',
dist => 'HASH',
dynamic_lib=> 'HASH',
linkext => 'HASH',
macro => 'HASH',
postamble => 'HASH',
realclean => 'HASH',
test => 'HASH',
tool_autosplit => 'HASH',
# special cases where you can use makemaker_append
CCFLAGS => 'APPENDABLE',
DEFINE => 'APPENDABLE',
INC => 'APPENDABLE',
LDDLFLAGS => 'APPENDABLE',
LDFROM => 'APPENDABLE',
);
sub makemaker_args {
my ($self, %new_args) = @_;
my $args = ( $self->{makemaker_args} ||= {} );
foreach my $key (keys %new_args) {
if ($makemaker_argtype{$key}) {
if ($makemaker_argtype{$key} eq 'ARRAY') {
$args->{$key} = [] unless defined $args->{$key};
unless (ref $args->{$key} eq 'ARRAY') {
$args->{$key} = [$args->{$key}]
}
push @{$args->{$key}},
ref $new_args{$key} eq 'ARRAY'
? @{$new_args{$key}}
: $new_args{$key};
}
elsif ($makemaker_argtype{$key} eq 'HASH') {
$args->{$key} = {} unless defined $args->{$key};
foreach my $skey (keys %{ $new_args{$key} }) {
$args->{$key}{$skey} = $new_args{$key}{$skey};
}
}
elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
$self->makemaker_append($key => $new_args{$key});
}
}
else {
if (defined $args->{$key}) {
warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
}
$args->{$key} = $new_args{$key};
}
}
return $args;
}
# For mm args that take multiple space-separated args,
# append an argument to the current list.
sub makemaker_append {
my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{$name} = defined $args->{$name}
? join( ' ', $args->{$name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
sub _wanted_t {
}
sub tests_recursive {
my $self = shift;
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
my %tests = map { $_ => 1 } split / /, ($self->tests || '');
require File::Find;
File::Find::find(
sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
$dir
);
$self->tests( join ' ', sort keys %tests );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
# Make sure we have a new enough MakeMaker
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
# This previous attempted to inherit the version of
# ExtUtils::MakeMaker in use by the module author, but this
# was found to be untenable as some authors build releases
# using future dev versions of EU:MM that nobody else has.
# Instead, #toolchain suggests we use 6.59 which is the most
# stable version on CPAN at time of writing and is, to quote
# ribasushi, "not terminally fucked, > and tested enough".
# TODO: We will now need to maintain this over time to push
# the version up as new versions are released.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
$args->{NAME} =~ s/-/::/g;
$args->{VERSION} = $self->version or die <<'EOT';
ERROR: Can't determine distribution version. Please specify it
explicitly via 'version' in Makefile.PL, or set a valid $VERSION
in a module, and provide its file path via 'version_from' (or
'all_from' if you prefer) in Makefile.PL.
EOT
if ( $self->tests ) {
my @tests = split ' ', $self->tests;
my %seen;
$args->{test} = {
TESTS => (join ' ', grep {!$seen{$_}++} @tests),
};
} elsif ( $Module::Install::ExtraTests::use_extratests ) {
# Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
# So, just ignore our xt tests here.
} elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
$args->{test} = {
TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
};
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = join ', ', @{$self->author || []};
}
if ( $self->makemaker(6.10) ) {
$args->{NO_META} = 1;
#$args->{NO_MYMETA} = 1;
}
if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
if ( $self->makemaker(6.31) and $self->license ) {
$args->{LICENSE} = $self->license;
}
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
# Merge both kinds of requires into BUILD_REQUIRES
my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
%$build_prereq = ( %$build_prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->configure_requires, $self->build_requires)
);
# Remove any reference to perl, BUILD_REQUIRES doesn't support it
delete $args->{BUILD_REQUIRES}->{perl};
# Delete bundled dists from prereq_pm, add it to Makefile DIR
my $subdirs = ($args->{DIR} || []);
if ($self->bundles) {
my %processed;
foreach my $bundle (@{ $self->bundles }) {
my ($mod_name, $dist_dir) = @$bundle;
delete $prereq->{$mod_name};
$dist_dir = File::Basename::basename($dist_dir); # dir for building this module
if (not exists $processed{$dist_dir}) {
if (-d $dist_dir) {
# List as sub-directory to be processed by make
push @$subdirs, $dist_dir;
}
# Else do nothing: the module is already present on the system
$processed{$dist_dir} = undef;
}
}
}
unless ( $self->makemaker('6.55_03') ) {
%$prereq = (%$prereq,%$build_prereq);
delete $args->{BUILD_REQUIRES};
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
if ( $self->makemaker(6.48) ) {
$args->{MIN_PERL_VERSION} = $perl_version;
}
}
if ($self->installdirs) {
warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
$args->{INSTALLDIRS} = $self->installdirs;
}
my %args = map {
( $_ => $args->{$_} ) } grep {defined($args->{$_} )
} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if ( my $preop = $self->admin->preop($user_preop) ) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
eval { flock MAKEFILE, LOCK_EX };
my $makefile = do { local $/; };
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
seek MAKEFILE, 0, SEEK_SET;
truncate MAKEFILE, 0;
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
#line 544
JSONLD-0.005/inc/Module/Install/Scripts.pm 000644 000765 000024 00000001011 13765312063 020166 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::Scripts;
use strict 'vars';
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub install_script {
my $self = shift;
my $args = $self->makemaker_args;
my $exe = $args->{EXE_FILES} ||= [];
foreach ( @_ ) {
if ( -f $_ ) {
push @$exe, $_;
} elsif ( -d 'script' and -f "script/$_" ) {
push @$exe, "script/$_";
} else {
die("Cannot find script '$_'");
}
}
}
1;
JSONLD-0.005/inc/Module/Install/Base.pm 000644 000765 000024 00000002147 13765312063 017424 0 ustar 00greg staff 000000 000000 #line 1
package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.19';
}
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
#line 42
sub new {
my $class = shift;
unless ( defined &{"${class}::call"} ) {
*{"${class}::call"} = sub { shift->_top->call(@_) };
}
unless ( defined &{"${class}::load"} ) {
*{"${class}::load"} = sub { shift->_top->load(@_) };
}
bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
local $@;
my $func = eval { shift->_top->autoload } or return;
goto &$func;
}
#line 75
sub _top {
$_[0]->{_top};
}
#line 90
sub admin {
$_[0]->_top->{admin}
or
Module::Install::Base::FakeAdmin->new;
}
#line 106
sub is_admin {
! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
use vars qw{$VERSION};
BEGIN {
$VERSION = $Module::Install::Base::VERSION;
}
my $fake;
sub new {
$fake ||= bless(\@_, $_[0]);
}
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 159