Skip to content

Commit ecb5010

Browse files
gbxyzgbxyz
committed
Merge branch 'master' into reverse-search
2 parents 5397ef4 + cbce3dc commit ecb5010

File tree

16 files changed

+235
-123
lines changed

16 files changed

+235
-123
lines changed

‎Changes‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,10 @@
11
Revision history for perl module Net::RDAP:
22

3+
0.34 - 2025-03-13
4+
- resolve issues with caching.
5+
- Net::RDAP::JCard->nodes() now emits a deprecation notice.
6+
- add Net::RDAP::Service->new_for_tld()
7+
38
0.33 - 2024-10-16
49
- use LWP::Online to skip tests that require an internet connection when
510
offline (thanks Petr Pisar)

‎lib/Net/RDAP.pm‎

Lines changed: 49 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -20,12 +20,13 @@ use Net::RDAP::SearchResult;
2020
use Net::RDAP::Service;
2121
use Net::RDAP::Values;
2222
use Net::RDAP::JCard;
23+
use POSIX qw(getpwuid);
2324
use vars qw($VERSION);
2425
use constant DEFAULT_CACHE_TTL => 3600;
2526
use strict;
2627
use warnings;
2728

28-
$VERSION = '0.33';
29+
$VERSION = '0.34';
2930

3031
=pod
3132
@@ -399,51 +400,40 @@ sub _get {
399400
# this is how long we allow things to be cached before checking
400401
# if they have been updated:
401402
#
402-
my $ttl = $self->{'cache_ttl'} || DEFAULT_CACHE_TTL;
403+
my $ttl = $self->{'use_cache'} ? ($self->{'cache_ttl'} || DEFAULT_CACHE_TTL) : 0;
403404

404405
#
405406
# path to local copy of the remote resource
406407
#
407-
my $file = sprintf(
408-
'%s/Net-RDAP-%s.json',
408+
my $file = File::Spec->catfile(
409409
File::Spec->tmpdir,
410-
sha256_hex($url->as_string),
410+
sprintf(
411+
'%s-%s.json',
412+
ref($self),
413+
sha256_hex(join(chr(0), (
414+
$VERSION,
415+
$url->as_string,
416+
getpwuid($<)
417+
)))
418+
)
411419
);
412420

413-
my ($response, $data);
414-
if (!$self->{'use_cache'}) {
415-
$response = $self->ua->request(GET($url));
416-
eval { $data = decode_json($response->decoded_content) };
421+
my $response = $self->ua->mirror($url, $file, $ttl);
417422

418-
} else {
419-
$response = $self->ua->mirror($url, $file, $ttl);
420-
eval { $data = decode_json(scalar(read_file($file))) };
421-
422-
}
423-
424-
return $self->rdap_from_response($url, $response, $data, %args);
425-
}
426-
427-
sub error_from_response {
428-
my ($self, $url, $response, $data) = @_;
429-
430-
if ($self->is_rdap($response) && defined($data->{'errorCode'})) {
431-
#
432-
# we got an RDAP response from the server which looks like
433-
# it's an error, so convert it and return:
434-
#
435-
return Net::RDAP::Error->new($data, $url);
423+
my $data = eval { decode_json(scalar(read_file($file))) };
436424

437-
} else {
438-
#
439-
# build our own error
440-
#
425+
if ($@) {
426+
chomp($@);
441427
return $self->error(
442-
'url' => $url,
443-
'errorCode' => $response->code,
444-
'title' => $response->status_line,
445-
'description' => [$response->status_line],
428+
url => $url,
429+
errorCode => 500,
430+
title => 'JSON parse error',
431+
description => [ $@ ],
446432
);
433+
434+
} else {
435+
return $self->rdap_from_response($url, $response, $data, %args);
436+
447437
}
448438
}
449439

@@ -453,18 +443,7 @@ sub rdap_from_response {
453443
if ($response->is_error) {
454444
return $self->error_from_response($url, $response, $data);
455445

456-
} elsif (!$self->is_rdap($response)) {
457-
#
458-
# we got something that isn't a valid RDAP response:
459-
#
460-
return $self->error(
461-
'url' => $url,
462-
'errorCode' => 500,
463-
'title' => 'Invalid Content-Type',
464-
'description' => [ sprintf("The Content-Type of the header is '%s', should be 'application/rdap+json'", $response->header('Content-Type')) ],
465-
);
466-
467-
} elsif (!defined($data) || 'HASH' ne ref($data)) {
446+
} elsif ('HASH' ne ref($data)) {
468447
#
469448
# response was not parseable as JSON:
470449
#
@@ -499,6 +478,29 @@ sub rdap_from_response {
499478
}
500479
}
501480

481+
sub error_from_response {
482+
my ($self, $url, $response, $data) = @_;
483+
484+
if ($self->is_rdap($response) && defined($data->{'errorCode'})) {
485+
#
486+
# we got an RDAP response from the server which looks like
487+
# it's an error, so convert it and return:
488+
#
489+
return Net::RDAP::Error->new($data, $url);
490+
491+
} else {
492+
#
493+
# build our own error
494+
#
495+
return $self->error(
496+
'url' => $url,
497+
'errorCode' => $response->code,
498+
'title' => $response->status_line,
499+
'description' => [$response->status_line],
500+
);
501+
}
502+
}
503+
502504
#
503505
# generate an RDAP object from an RDAP response
504506
#

‎lib/Net/RDAP/Base.pm‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -152,10 +152,11 @@ sub top {
152152
@chain = $object->chain;
153153
154154
Returns an array containing the hierarchy of objects that enclose this object.
155-
So for example, the registrar entity of host object of a domain name will have a
156-
chain that looks like C<[Net::RDAP::Object::Entity,
157-
Net::RDAP::Object::Nameserver, Net::RDAP::Object::Domain]>. If the object is the
158-
topmost object of the RDAP response, the array will be empty.
155+
So for example, the registrar entity of a nameserver object of a domain name
156+
will have a chain that looks like
157+
C<[Net::RDAP::Object::Entity, Net::RDAP::Object::Nameserver, Net::RDAP::Object::Domain]>.
158+
If the object is the topmost object of the RDAP response, the array will only
159+
contain that object.
159160
160161
=cut
161162

‎lib/Net/RDAP/JCard.pm‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
package Net::RDAP::JCard;
2+
use Carp;
23
use Net::RDAP::JCard::Property;
34
use Net::RDAP::JCard::Address;
45
use strict;
@@ -59,14 +60,16 @@ case-insensitively).
5960

6061
sub properties {
6162
my ($self, $type) = @_;
62-
6363
return grep { !$type || uc($type) eq uc($_->type) } @{$self->{properties}};
6464
}
6565

6666
#
6767
# DEPRECATED
6868
#
69-
sub nodes { shift->properties(@_) }
69+
sub nodes {
70+
carp("Warning: Net::RDAP::JCard::nodes() has been deprecated and will be removed in a future release.");
71+
return shift->properties(@_);
72+
}
7073

7174
=pod
7275

‎lib/Net/RDAP/JSON.pm‎

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
package Net::RDAP::JSON;
2+
use JSON qw(-no_export);
3+
use vars qw(@EXPORT $JSON);
4+
use base qw(Exporter);
5+
use strict;
6+
7+
@EXPORT = qw(encode_json decode_json to_json from_json);
8+
9+
$JSON = JSON->new->utf8->canonical;
10+
11+
sub encode_json { $JSON->encode(@_) }
12+
sub to_json { $JSON->encode(@_) }
13+
sub decode_json { $JSON->decode(@_) }
14+
sub from_json { $JSON->decode(@_) }
15+
16+
1;
17+
18+
__END__
19+
20+
=pod
21+
22+
=head1 NAME
23+
24+
L<Net::RDAP::JSON> - a wrapper to allow JSON backends to be switched.
25+
26+
=head1 DESCRIPTION
27+
28+
This module is a wrapper around L<JSON>. It exists to make it easier to switch
29+
the JSON module used by L<Net::RDAP>. You should not use it directly.
30+
31+
It exports the same default functions as L<JSON> (C<encode_json>,
32+
C<decode_json>, C<to_json> and C<from_json>), but ensures that UTF-8 and
33+
canonicalisation are enabled.
34+
35+
=head1 COPYRIGHT
36+
37+
Copyright 2024 Gavin Brown. For licensing information, please see the
38+
C<LICENSE> file in the L<Net::RDAP> distribution.
39+
40+
=cut

‎lib/Net/RDAP/Service.pm‎

Lines changed: 48 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,25 @@ sub new {
1414
}, $package);
1515
}
1616

17+
sub new_for_tld {
18+
my ($package, $tld) = @_;
19+
20+
foreach my $service (Net::RDAP::Registry->load_registry(Net::RDAP::Registry::DNS_URL)->services) {
21+
foreach my $zone ($service->registries) {
22+
if (lc($zone) eq lc($tld)) {
23+
return $package->new(Net::RDAP::Registry->get_best_url($service->urls));
24+
}
25+
}
26+
}
27+
28+
return undef;
29+
}
30+
31+
#
32+
# generate a URL given the params and fetch it. $type and $segments are used as
33+
# path segments ($segments must be an arrayref, and may be empty). %args is used
34+
# to construct query parameters.
35+
#
1736
sub fetch {
1837
my ($self, $type, $segments, %params) = @_;
1938

@@ -22,7 +41,7 @@ sub fetch {
2241
$uri->path_segments(grep { defined && length > 0 } (
2342
$uri->path_segments,
2443
$type,
25-
'ARRAY' eq ref($segments) ? @{$segments} : $segments
44+
@{$segments},
2645
));
2746

2847
$uri->query_form(%params);
@@ -36,10 +55,10 @@ sub fetch {
3655
sub search {
3756
my ($self, $type, %params) = @_;
3857

39-
if (exists($params{entity}) && 'HASH' eq ref($params{entity})) {
58+
if ('HASH' eq ref($params{entity})) {
4059
return $self->reverse_search($type, %{$params{entity}});
4160

42-
} elsif ('ips' eq $type && ($params{up} || $params{down} || $params{top} || $params{bottom})) {
61+
} elsif ('ips' eq $type && (any { exists($params{$_}) } qw(up down top bottom))) {
4362
return $self->rir_reverse_search($type, %params);
4463

4564
} else {
@@ -48,6 +67,12 @@ sub search {
4867
}
4968
}
5069

70+
sub reverse_search {
71+
my ($self, $type, %params) = @_;
72+
73+
return $self->fetch($type, [qw(reverse_search entity)], %params);
74+
}
75+
5176
sub rir_reverse_search {
5277
my ($self, $type, %params) = @_;
5378

@@ -65,27 +90,21 @@ sub rir_reverse_search {
6590
return undef;
6691
}
6792

68-
sub reverse_search {
69-
my ($self, $type, %params) = @_;
70-
71-
return $self->fetch($type, [qw(reverse_search entity)], %params);
72-
}
73-
74-
sub base { $_[0]->{'base'} }
75-
sub client { $_[0]->{'client'} }
93+
sub base { shift->{'base'} }
94+
sub client { shift->{'client'} }
7695

77-
sub help { $_[0]->fetch('help' ) }
78-
sub domain { $_[0]->fetch('domain', $_[1]->name ) }
79-
sub ip { $_[0]->fetch('ip', $_[1]->prefix ) }
80-
sub autnum { $_[0]->fetch('autnum', $_[1]->toasplain ) }
81-
sub entity { $_[0]->fetch('entity', $_[1]->handle ) }
82-
sub nameserver { $_[0]->fetch('nameserver', $_[1]->name ) }
96+
sub help { shift->fetch('help', [] ) }
97+
sub domain { shift->fetch('domain', [ pop->name ] ) }
98+
sub ip { shift->fetch('ip', [ pop->prefix ] ) }
99+
sub autnum { shift->fetch('autnum', [ pop->toasplain ] ) }
100+
sub entity { shift->fetch('entity', [ pop->handle ] ) }
101+
sub nameserver { shift->fetch('nameserver', [ pop->name ] ) }
83102

84-
sub domains { shift->search('domains', @_ ) }
85-
sub nameservers { shift->search('nameservers', @_ ) }
86-
sub entities { shift->search('entities', @_ ) }
87-
sub ips { shift->search('ips', @_ ) }
88-
sub autnums { shift->search('autnums', @_ ) }
103+
sub domains { shift->search('domains', @_ ) }
104+
sub nameservers { shift->search('nameservers', @_ ) }
105+
sub entities { shift->search('entities', @_ ) }
106+
sub ips { shift->search('ips', @_ ) }
107+
sub autnums { shift->search('autnums', @_ ) }
89108

90109
sub implements {
91110
my ($self, $token) = @_;
@@ -160,6 +179,13 @@ You can also provide a second argument which should be an existing
160179
L<Net::RDAP> instance. This is used when fetching resources from the
161180
server.
162181
182+
=head3 TLD Service Constructor
183+
184+
my $svc = Net::RDAP::Service->new_for_tld($tld);
185+
186+
This method searches the IANA registry for an entry for the TLD in C<$tld> and
187+
returns the corresponding L<Net::RDAP::Service> object.
188+
163189
=head2 Lookup Methods
164190
165191
You can do direct lookups of objects using the following methods:

0 commit comments

Comments
 (0)