diff --git a/lib/Data/HAL/URI.pm b/lib/Data/HAL/URI.pm index 1b4388d..db86837 100644 --- a/lib/Data/HAL/URI.pm +++ b/lib/Data/HAL/URI.pm @@ -6,6 +6,64 @@ use URI qw(); our $VERSION = '1.000'; +my %uri_require_attempted = (); +my %uri_implements = (); +BEGIN { + ## no critic (TestingAndDebugging::ProhibitNoWarnings) + no warnings 'redefine'; + *URI::implementor = sub { + my($scheme, $impclass) = @_; + if (!$scheme || $scheme !~ /\A$URI::scheme_re\z/o) { + require URI::_generic; + return "URI::_generic"; + } + + $scheme = lc($scheme); + + if ($impclass) { + # Set the implementor class for a given scheme + my $old = $uri_implements{$scheme}; + $impclass->_init_implementor($scheme); + $uri_implements{$scheme} = $impclass; + return $old; + } + + my $ic = $uri_implements{$scheme}; + return $ic if $ic; + + # scheme not yet known, look for internal or + # preloaded (with 'use') implementation + $ic = "URI::$scheme"; # default location + + # turn scheme into a valid perl identifier by a simple transformation... + $ic =~ s/\+/_P/g; + $ic =~ s/\./_O/g; + $ic =~ s/\-/_/g; + + ## no critic (TestingAndDebugging::ProhibitNoStrict,TestingAndDebugging::ProhibitProlongedStrictureOverride) + no strict 'refs'; + # check we actually have one for the scheme: + unless (@{"${ic}::ISA"}) { + if (not exists $uri_require_attempted{$ic}) { + # Try to load it + my $_old_error = $@; + ## no critic (BuiltinFunctions::ProhibitStringyEval) + eval "require $ic"; + ## no critic (Variables::RequireLocalizedPunctuationVars) + die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; + $@ = $_old_error; + $uri_require_attempted{$ic} = 1; + } + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + return undef unless @{"${ic}::ISA"}; + } + + $ic->_init_implementor($scheme); + $uri_implements{$scheme} = $ic; + $ic; + }; +} + has('_original', is => 'rw', isa => Str); # just records what was passed to the constructor, this is a work-around for # URI->new being a lossy operation diff --git a/lib/Data/HAL/URI/NamespaceMap.pm b/lib/Data/HAL/URI/NamespaceMap.pm index f082d08..f2fb8d7 100644 --- a/lib/Data/HAL/URI/NamespaceMap.pm +++ b/lib/Data/HAL/URI/NamespaceMap.pm @@ -13,12 +13,11 @@ sub uri { my ($self, $abbr) = @_; if (my ($prefix, $reference) = $abbr =~ m/\A ($XML::RegExp::NCName) : (.*) \z/msx) { if ($self->namespace_uri($prefix)) { - return Data::HAL::URI->new( - _original => $abbr, - uri => URI::Template - ->new($self->namespace_uri($prefix)->as_string) - ->process(rel => URI::IRI->new($reference)->canonical->as_string), - ); + my $templated = URI::Template->new($self->namespace_uri($prefix)->as_string); + my $iri = URI::IRI->new($reference)->canonical->as_string; + $templated = $templated->process(rel => $iri); + my $haluri = Data::HAL::URI->new(_original => $abbr,uri => $templated,); + return $haluri; } } return; diff --git a/t/ngcp.t b/t/ngcp.t new file mode 100644 index 0000000..a6906bb --- /dev/null +++ b/t/ngcp.t @@ -0,0 +1,125 @@ +use strictures; +use Test::More import => [qw(done_testing is)]; +use Data::HAL qw(); +use boolean qw(true); + +my $resource_name = "domain"; +my $dispatch_path = "/api/domains/"; +my $request_path = "api/domains/"; +my $total_count = 2; +my $rows = 1; +my $page = 1; + +my @embedded = (); +my @links = (); +foreach my $id (1..1) { + my %resource = ( + domain => "domain".$id, + ); + my $hal = Data::HAL->new( + links => [ + Data::HAL::Link->new( + relation => 'curies', + href => 'http://purl.org/sipwise/ngcp-api/#rel-{rel}', + name => 'ngcp', + templated => true, + ), + Data::HAL::Link->new(relation => 'collection', href => sprintf("/api/%s/", $resource_name)), + Data::HAL::Link->new(relation => 'profile', href => 'http://purl.org/sipwise/ngcp-api/'), + Data::HAL::Link->new(relation => 'self', href => sprintf("%s%d", $dispatch_path, $id)), + #( map { $_->attribute->internal ? () : Data::HAL::Link->new(relation => 'ngcp:domainpreferences', href => sprintf("/api/domainpreferences/%d", $_->id), name => $_->attribute->attribute) } $item->provisioning_voip_domain->voip_dom_preferences->all ), + Data::HAL::Link->new(relation => 'ngcp:domainpreferences', href => sprintf("/api/domainpreferences/%d", $id)), + #$self->get_journal_relation_link($item->id), + ], + relation => 'ngcp:'.$resource_name, + ); + $resource{id} = int($id); + $hal->resource({%resource}); + #$hal->_forcearray(1); + push @embedded,$hal; + + my $link = Data::HAL::Link->new( + relation => 'ngcp:'.$resource_name, + href => sprintf('/%s%d', $request_path, $id), + ); + #$link->_forcearray(1); + push @links, $link; +} +push @links, + Data::HAL::Link->new( + relation => 'curies', + href => 'http://purl.org/sipwise/ngcp-api/#rel-{rel}', + name => 'ngcp', + templated => true, + ), + Data::HAL::Link->new(relation => 'profile', href => 'http://purl.org/sipwise/ngcp-api/'), + Data::HAL::Link->new(relation => 'self', href => sprintf('/%s?page=%s&rows=%s', $request_path, $page, $rows)); +if(($total_count / $rows) > $page ) { + push @links, Data::HAL::Link->new(relation => 'next', href => sprintf('/%s?page=%d&rows=%d', $request_path, $page + 1, $rows)); +} +if($page > 1) { + push @links, Data::HAL::Link->new(relation => 'prev', href => sprintf('/%s?page=%d&rows=%d', $request_path, $page - 1, $rows)); +} + +my $hal = Data::HAL->new( + embedded => [@embedded], + links => [@links], +); +$hal->resource({ + total_count => $total_count, +}); + +is(join(": ",$hal->http_headers(skip_links => 1))."\n",<as_json,<