TT#34313 workaround for perl URI require_attempt logic bug

- the stats come from the perl URI module, which tries to require an
"implementor" for URIs with the "ngcp:" scheme
- such does not exist, so one solution is to add a dumm
yimplementationidentical to URI::_foreign
- after looking at the URI module, it turned out there is already a
built-in logic to prevent repeated require attempts
- it turned out there is a bug with this part, which can be fixed in
upstream code by inserting below line 140 of URI.pm v '1.71:

$uri_require_attempted{$ic} = 1;

- until this is fixed in the upstream code of the module, this is a
workaround in Data::HAL, which will effectively address the symptoms

- a testcase to verify the ngcp api response was used during debugging,
also added to Data::HAL testsuite

Change-Id: I84a7b38b79d2fe191fdd798b46b043f8540fb29a

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

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;

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",<<EOS,"sample http headers");
+Content-Type: application/hal+json; profile="http://purl.org/sipwise/ngcp-api/"; charset=utf-8
+EOS
+is($hal->as_json,<<EOS,"sample json");
+{
+   "_embedded" : {
+      "ngcp:domain" : {
+         "_links" : {
+            "collection" : {
+               "href" : "/api/domain/"
+            },
+            "curies" : {
+               "href" : "http://purl.org/sipwise/ngcp-api/#rel-{rel}",
+               "name" : "ngcp",
+               "templated" : true
+            },
+            "ngcp:domainpreferences" : {
+               "href" : "/api/domainpreferences/1"
+            },
+            "profile" : {
+               "href" : "http://purl.org/sipwise/ngcp-api/"
+            },
+            "self" : {
+               "href" : "/api/domains/1"
+            }
+         },
+         "domain" : "domain1",
+         "id" : 1
+      }
+   },
+   "_links" : {
+      "curies" : {
+         "href" : "http://purl.org/sipwise/ngcp-api/#rel-{rel}",
+         "name" : "ngcp",
+         "templated" : true
+      },
+      "next" : {
+         "href" : "/api/domains/?page=2&rows=1"
+      },
+      "ngcp:domain" : {
+         "href" : "/api/domains/1"
+      },
+      "profile" : {
+         "href" : "http://purl.org/sipwise/ngcp-api/"
+      },
+      "self" : {
+         "href" : "/api/domains/?page=1&rows=1"
+      }
+   },
+   "total_count" : 2
+}
+EOS
+
+done_testing;