File Coverage

lib/Data/URIID/Result.pm
Criterion Covered Total %
statement 251 595 42.1
branch 77 330 23.3
condition 65 306 21.2
subroutine 35 54 64.8
pod 8 9 88.8
total 436 1294 33.6


line stmt bran cond sub pod time code
1             # Copyright (c) 2023-2025 Philipp Schafft
2              
3             # licensed under Artistic License 2.0 (see LICENSE file)
4              
5             # ABSTRACT: Extractor for identifiers from URIs
6              
7             package Data::URIID::Result;
8              
9 4     4   63 use v5.16;
  4         19  
10 4     4   27 use strict;
  4         7  
  4         117  
11 4     4   17 use warnings;
  4         5  
  4         330  
12              
13 4     4   112 use Carp;
  4         10  
  4         417  
14 4     4   26 use URI;
  4         8  
  4         97  
15 4     4   65 use URI::Escape;
  4         30  
  4         296  
16 4     4   71 use Scalar::Util qw(blessed);
  4         8  
  4         263  
17 4     4   24 use List::Util qw(any);
  4         9  
  4         334  
18 4     4   23 use Math::BigInt;
  4         8  
  4         49  
19 4     4   2615 use MIME::Base64;
  4         3670  
  4         308  
20              
21 4     4   29 use Data::Identifier;
  4         5  
  4         28  
22 4     4   2776 use Data::Identifier::Generate;
  4         26113  
  4         225  
23              
24 4     4   3473 use Data::URIID::Service;
  4         18  
  4         252  
25 4     4   2676 use Data::URIID::Digest;
  4         14  
  4         313  
26              
27             use constant {
28 4         763 ISEORDER_UOR => ['uuid', 'oid', 'uri'],
29             ISEORDER_RUO => ['uri', 'uuid', 'oid'],
30             METATYPE_ID => 'id',
31             METATYPE_DIGEST => 'digest',
32 4     4   32 };
  4         7  
33              
34 4     4   29 use constant RE_UUID => qr/^[0-9a-fA-F]{8}-(?:[0-9a-fA-F]{4}-){3}[0-9a-fA-F]{12}$/;
  4         8  
  4         405  
35 4     4   24 use constant RE_UINT => qr/^[1-9][0-9]*$/;
  4         8  
  4         296  
36              
37             our $VERSION = v0.20;
38              
39 4     4   23 use parent 'Data::URIID::Base';
  4         7  
  4         21  
40              
41             my %digest_name_converter = (
42             fc('md5') => 'md-5-128',
43             fc('sha1') => 'sha-1-160',
44             fc('sha-1') => 'sha-1-160',
45             (map {
46             fc('sha-'.$_) => 'sha-2-'.$_,
47             fc('sha3-'.$_) => 'sha-3-'.$_,
48             } qw(224 256 384 512)),
49             );
50              
51             my %attributes = (
52             action => {
53             source_type => 'ise',
54             },
55             displayname => {
56             source_type => 'string',
57             },
58             displaycolour => {},
59             description => {
60             source_type => 'string',
61             },
62             icon_text => {
63             source_type => 'string',
64             },
65             icon => {},
66             thumbnail => {},
67             website => {},
68             final_file_size => { # experimental
69             source_type => 'uint',
70             },
71             service => {},
72             best_service => {},
73             (map {$_ => {source_type => 'number'}} qw(altitude latitude longitude)),
74             space_object => {},
75              
76             sex_or_gender => {},
77              
78             media_subtype => {
79             source_type => 'media_subtype',
80             },
81              
82             roles => {},
83              
84             sources => {
85             cb => sub {
86             my ($self) = @_;
87             my Data::URIID $extractor = $self->extractor;
88             my %sources;
89              
90             foreach my $key (keys(%{$self->{offline_results}}), keys(%{$self->{online_results}})) {
91             if (scalar(keys %{$self->{offline_results}{$key} // {}}) || scalar(keys %{$self->{online_results}{$key} // {}})) {
92             $sources{$extractor->name_to_ise(service => $key)} = undef;
93             }
94             }
95              
96             return [map {$extractor->service($_)} sort keys %sources];
97             },
98             },
99              
100             # TODO: define type. # experimental
101             (map {$_ => {source_type => 'string'}} qw(date_of_birth date_of_death)),
102              
103             ext => {}, # experimental
104             tagged_as => {}, # experimental
105             );
106              
107             my %id_conv = (
108             uuid => [qw(wikidata-identifier fellig-identifier oid)],
109             oid => [qw(uuid)],
110             uri => [qw(wikidata-identifier uuid oid)],
111             doi => [qw(grove-art-online-identifier)],
112             );
113              
114             my %lookup_services;
115             my %lookup_services_digest;
116              
117             my %best_services = (
118             'wikidata-identifier' => 'wikidata',
119             'musicbrainz-identifier' => 'musicbrainz',
120             'british-museum-term' => 'britishmuseum',
121             'gnd-identifier' => 'dnb',
122             'fellig-box-number' => 'fellig',
123             'fellig-identifier' => 'fellig',
124             'youtube-video-identifier' => 'youtube',
125             'e621tagtype' => 'e621',
126             'wikimedia-commons-identifier' => 'wikimedia-commons',
127             'e621-post-identifier' => 'e621',
128             'e621-pool-identifier' => 'e621',
129             'osm-node' => 'osm',
130             'osm-way' => 'osm',
131             'osm-relation' => 'osm',
132             'xkcd-num' => 'xkcd',
133             'viaf-identifier' => 'viaf',
134             'open-library-identifier' => 'open-library',
135             #'unesco-thesaurus-identifier' => '',
136             #'isni' => '',
137             #'aev-identifier' => '',
138             'europeana-entity-identifier' => 'europeana',
139             'ngv-artist-identifier' => 'ngv',
140             'ngv-artwork-identifier' => 'ngv',
141             'geonames-identifier' => 'geonames',
142             'find-a-grave-identifier' => 'find-a-grave',
143             'libraries-australia-identifier'=> 'nla',
144             'nla-trove-people-identifier' => 'nla',
145             'agsa-creator-identifier' => 'agsa',
146             'amc-artist-identifier' => 'amc',
147             'a-p-and-p-artist-identifier' => 'a-p-and-p',
148             'tww-artist-identifier' => 'tww',
149             'factgrid-identifier' => 'factgrid',
150             'grove-art-online-identifier' => 'grove-art-online',
151             'wikitree-person-identifier' => 'wikitree-person',
152             'doi' => 'doi',
153             'iconclass-identifier' => 'iconclass',
154             'media-subtype-identifier' => 'iana',
155             #'gtin' => '',
156             #'small-identifier' => '',
157             #'language-tag-identifier' => '',
158             #'chat-0-word-identifier' => '',
159             'furaffinity-post-identifier' => 'furaffinity',
160             'imgur-post-identifier' => 'imgur',
161             'notalwaysright-post-identifier' => 'notalwaysright',
162             'fefe-blog-post-identifier' => 'fefe',
163             'ruthede-comic-post-identifier' => 'ruthede',
164             'danbooru2chanjp-post-identifier' => 'danbooru2chanjp',
165             );
166              
167             # Load extra services:
168             {
169             my $extra = Data::URIID::Service->_extra_lookup_services;
170             foreach my $service_name (keys %{$extra}) {
171             foreach my $type (@{$extra->{$service_name}}) {
172             $lookup_services{$type} //= [];
173             push(@{$lookup_services{$type}}, $service_name);
174             }
175             }
176             }
177             {
178             my $extra = Data::URIID::Service->_extra_lookup_services_digests;
179             foreach my $service_name (keys %{$extra}) {
180             foreach my $digest (@{$extra->{$service_name}}) {
181             $lookup_services_digest{$digest} //= [];
182             push(@{$lookup_services_digest{$digest}}, $service_name);
183             }
184             }
185             }
186              
187             my %url_templates = (
188             'wikidata' => [
189             ['wikidata-identifier' => 'https://www.wikidata.org/wiki/%s' => qr/^Q/ => [qw(documentation info edit)]],
190             ['wikidata-identifier' => 'https://www.wikidata.org/wiki/Property:%s' => qr/^P/ => [qw(documentation info edit)]],
191             ['wikidata-identifier' => 'https://www.wikidata.org/wiki/Special:EntityData/%s' => undef() => [qw(metadata)]],
192             ],
193             'wikimedia-commons' => [
194             ['wikimedia-commons-identifier' => 'https://commons.wikimedia.org/wiki/%s', undef, [qw(info render edit)]],
195             ],
196             'fellig' => [
197             map {
198             [$_ => sprintf('https://www.fellig.org/subject/best/any/%s/%%s', $_), undef, [qw(info render)]],
199             [$_ => sprintf('https://api.fellig.org/v0/overview/%s/%%s', $_), undef, [qw(metadata)]],
200             } qw(fellig-identifier fellig-box-number uuid oid uri wikidata-identifier e621-post-identifier e621-pool-identifier wikimedia-commons-identifier british-museum-term musicbrainz-identifier gnd-identifier e621tagtype)
201             ],
202             'youtube' => [
203             ['youtube-video-identifier' => 'https://www.youtube.com/watch?v=%s', undef, [qw(info render)]],
204             ['youtube-video-identifier' => 'https://www.youtube.com/embed/%s', undef, [qw(embed)]],
205             ],
206             'youtube-nocookie' => [
207             ['youtube-video-identifier' => 'https://www.youtube-nocookie.com/embed/%s', undef, [qw(embed)]],
208             ],
209             'e621' => [
210             ['e621tagtype' => 'https://e621.net/wiki_pages/show_or_new?title=%s', undef, [qw(info)]],
211             ['e621-post-identifier' => 'https://e621.net/posts/%u', undef, [qw(info render)]],
212             ['e621-post-identifier' => 'https://e621.net/posts.json?limit=1&tags=id:%u', undef, [qw(metadata)]],
213             ['e621-pool-identifier' => 'https://e621.net/pools/%u', undef, [qw(info render)]],
214             ['e621-pool-identifier' => 'https://e621.net/pools.json?search[id]=%u', undef, [qw(metadata)]],
215             ],
216             'dnb' => [
217             ['gnd-identifier' => 'https://d-nb.info/gnd/%s', undef, [qw(info)]],
218             ],
219             'britishmuseum' => [
220             ['british-museum-term' => 'https://www.britishmuseum.org/collection/term/%s', undef, [qw(info)]],
221             ],
222             'musicbrainz' => [
223             ['musicbrainz-identifier' => 'https://musicbrainz.org/mbid/%s', undef, [qw(info)]],
224             ['uuid' => 'https://musicbrainz.org/mbid/%s', undef, [qw(info)]],
225             ],
226             'osm' => [
227             map {
228             ['osm-'.$_ => sprintf('https://www.openstreetmap.org/%s/%%s', $_), undef, [qw(info render)]]
229             } qw(node way relation)
230             ],
231             'xkcd' => [
232             ['xkcd-num' => 'https://xkcd.com/%s/', undef, [qw(info render)]],
233             ['xkcd-num' => 'https://xkcd.com/%s/info.0.json', undef, [qw(metadata)]],
234             ],
235             'viaf' => [
236             ['viaf-identifier' => 'https://viaf.org/viaf/%s/', undef, [qw(info)]],
237             ],
238             'europeana' => [
239             ['europeana-entity-identifier' => 'https://data.europeana.eu/%s', undef, [qw(info)], {no_escape => 1}],
240             ],
241             'open-library' => [
242             ['open-library-identifier' => 'https://openlibrary.org/works/%s?mode=all', undef, [qw(info)]],
243             ['open-library-identifier' => 'https://openlibrary.org/works/%s.json', undef, [qw(metadata)]],
244             ],
245             'ngv' => [
246             ['ngv-artist-identifier' => 'https://www.ngv.vic.gov.au/explore/collection/artist/%s/', undef, [qw(info)]],
247             ['ngv-artwork-identifier' => 'https://www.ngv.vic.gov.au/explore/collection/work/%s/', undef, [qw(info)]],
248             ],
249             'geonames' => [
250             ['geonames-identifier' => 'https://www.geonames.org/%s', undef, [qw(info)]],
251             ],
252             'find-a-grave' => [
253             ['find-a-grave-identifier' => 'https://www.findagrave.com/memorial/%s', undef, [qw(info)]],
254             ],
255             'nla' => [
256             ['libraries-australia-identifier' => 'https://nla.gov.au/anbd.aut-an%s', undef, [qw(info)]],
257             ['nla-trove-people-identifier' => 'https://trove.nla.gov.au/people/%s', undef, [qw(info)]],
258             ],
259             'agsa' => [
260             ['agsa-creator-identifier' => 'https://www.agsa.sa.gov.au/collection-publications/collection/creators/_/%s/', undef, [qw(info)]],
261             ],
262             'amc' => [
263             ['amc-artist-identifier' => 'https://www.australianmusiccentre.com.au/artist/%s', undef, [qw(info)]],
264             ],
265             'a-p-and-p' => [
266             ['a-p-and-p-artist-identifier' => 'https://www.printsandprintmaking.gov.au/artists/%s/', undef, [qw(info)]],
267             ],
268             'tww' => [
269             ['tww-artist-identifier' => 'https://www.watercolourworld.org/artist/%s', undef, [qw(info)]],
270             ],
271             'factgrid' => [
272             ['factgrid-identifier' => 'https://database.factgrid.de/wiki/Item:%s' => qr/^Q/ => [qw(documentation info edit)]],
273             ['factgrid-identifier' => 'https://database.factgrid.de/wiki/Property:%s' => qr/^P/ => [qw(documentation info edit)]],
274             ['factgrid-identifier' => 'https://database.factgrid.de/wiki/Special:EntityData/%s' => undef() => [qw(metadata)]],
275             ],
276             'grove-art-online' => [
277             ['grove-art-online-identifier' => 'https://doi.org/10.1093/gao/9781884446054.article.%s', undef, [qw(info)]],
278             ],
279             'wikitree-person' => [
280             ['wikitree-person-identifier' => 'https://www.wikitree.com/wiki/%s', undef, [qw(info)]],
281             ],
282             'doi' => [
283             ['doi' => 'https://doi.org/%s', undef, [qw(info)], {no_escape => 1}],
284             ['doi' => 'https://dx.doi.org/%s', undef, [qw(metadata)], {no_escape => 1}],
285             ],
286             'iconclass' => [
287             ['iconclass-identifier' => 'https://iconclass.org/%s', undef, [qw(info)]],
288             ['iconclass-identifier' => 'https://iconclass.org/%s.jsonld', undef, [qw(metadata)]],
289             ],
290             'iana' => [
291             ['media-subtype-identifier' => 'https://www.iana.org/assignments/media-types/%s', undef, [qw(info)], {no_escape => 1}],
292             ],
293             'oidref' => [
294             ['oid' => 'https://oidref.com/%s' => undef, [qw(info)]],
295             ],
296             'furaffinity' => [
297             ['furaffinity-post-identifier' => 'https://www.furaffinity.net/view/%s/', undef, [qw(info render)]],
298             ],
299             'imgur' => [
300             ['imgur-post-identifier' => 'https://imgur.com/%s', undef, [qw(info render)]],
301             ],
302             'notalwaysright' => [
303             ['notalwaysright-post-identifier' => 'https://notalwaysright.com/x/%u/', undef, [qw(info render)]],
304             ],
305             'fefe' => [
306             ['fefe-blog-post-identifier' => 'https://blog.fefe.de/?ts=%s', undef, [qw(info render)]],
307             ['fefe-blog-post-identifier' => 'https://blog.fefe.de/rss.xml?ts=%s', undef, [qw(metadata)]],
308             ],
309             'schemaorg' => [
310             ['uri' => '%s', qr#^https://schema\.org/[^/]+$#, [qw(info)], {no_escape => 1}],
311             ],
312             'purlorg' => [
313             ['uri' => '%s', qr#^http://purl\.org/dc/(?:elements/1\.1|terms|dcam|dcmitype)/[^/]+$#, [qw(info)], {no_escape => 1}],
314             ],
315             'ruthede' => [
316             ['ruthede-comic-post-identifier' => 'https://ruthe.de/static/cartoon_%s.html', undef, [qw(info render)]],
317             ],
318             'danbooru2chanjp' => [
319             ['danbooru2chanjp-post-identifier' => 'https://danbooru.2chan.jp/index.php?page=post&s=view&id=%s', undef, [qw(info render)]],
320             ['danbooru2chanjp-post-identifier' => 'https://danbooru.2chan.jp/image_data.php?start=%s&limit=1', undef, [qw(metadata)]],
321             ],
322             'sirtxkeepcoolorg' => [
323             ['sirtx-numerical-identifier' => 'https://sirtx.keep-cool.org/lists.html#sni:%s', undef, [qw(info)]],
324             ],
325             );
326             my %digest_url_templates = (
327             'e621' => [
328             ['md-5-128' => 'https://e621.net/posts/random?tags=md5:%{digest}', [qw(info render)]],
329             ['md-5-128' => 'https://static1.e621.net/data/%{digest,0,2}/%{digest,2,2}/%{digest}.%{ext}', [qw(file-fetch fetch)]],
330             ['md-5-128' => 'https://e621.net/posts.json?limit=1&tags=md5:%{digest}', [qw(metadata)]],
331             ],
332             'fellig' => [
333             (map {[$_ => 'https://files.fellig.org/v2/by/'.$_.'/%{digest}.%{ext}', [qw(file-fetch fetch)]]}
334             qw(sha-3-224 sha-3-512 md-5-128),
335             ),
336             ],
337             );
338              
339             my $re_yt_vid = qr#[^/]{11}#;
340             my $re_uuid = qr/[0-9a-fA-F]{8}-(?:[0-9a-fA-F]{4}-){3}[0-9a-fA-F]{12}/;
341             my %url_parser = (
342             urn => [
343             {
344             path => qr/^uuid:($re_uuid)$/,
345             type => 'uuid',
346             id => \1,
347             },
348             {
349             path => qr/^oid:([1-3](?:\.(?:0|[1-9][0-9]*))+)$/,
350             type => 'oid',
351             id => \1,
352             },
353             {
354             path => qr/^isbn:([0-9]{13})$/,
355             type => 'gtin',
356             id => \1,
357             },
358             {
359             path => qr/^isbn:([0-9]{9}[0-9Xx])$/,
360             type => 'gtin',
361             id => sub {
362             my ($self, $uri, $rule, $res) = @_;
363             my $isbn = $res->[0];
364              
365             {
366             my @digits = split(//, $isbn);
367             my $check = pop(@digits);
368             my $sum = 0;
369              
370             for (my $i = 0; length(my $c = shift @digits); $i++) {
371             $sum += (ord($c) - ord('0')) * (10 - $i);
372             }
373              
374             if ($check eq 'X' || $check eq 'x') {
375             $check = 11;
376             }
377              
378             die 'Bad check' unless $check == (11 - ($sum % 11));
379             }
380              
381             {
382             $isbn =~ s/^([0-9]{9}).$/978$1/;
383              
384             my @digits = split(//, $isbn);
385             my $sum = 0;
386              
387             for (my $i = 0; length(my $c = shift @digits); $i++) {
388             $sum += (ord($c) - ord('0')) * ($i & 1 ? 3 : 1);
389             }
390              
391             return sprintf('%u%u', $isbn, 10 - ($sum % 10));
392             }
393             },
394             },
395             ],
396             tag => [
397             {
398             ise_order => ISEORDER_RUO,
399             type => 'uri',
400             id => sub {
401             my ($self, $uri, $rule, $res) = @_;
402             return $uri->as_string;
403             },
404             },
405             ],
406             acct => [
407             {
408             ise_order => ISEORDER_RUO,
409             type => 'uri',
410             id => sub {
411             my ($self, $uri, $rule, $res) = @_;
412             if (defined(my $opaque = eval {$uri->opaque})) {
413             if ($opaque =~ /^([^\@]+)\@[^\@]+$/) {
414             $self->{primary} //= {};
415             $self->{primary}{displayname} = uri_unescape($1);
416             }
417             }
418             return $uri->as_string;
419             },
420             },
421             ],
422             https => [
423             {
424             host => 'www.wikidata.org',
425             path => qr#^/entity/(?:Property:)?([QP][1-9][0-9]*)$#,
426             source => 'wikidata',
427             type => 'wikidata-identifier',
428             id => \1,
429             ise_order => ISEORDER_RUO,
430             },
431             {
432             host => 'www.wikidata.org',
433             path => qr#^/wiki/(?:Property:)?([QP][1-9][0-9]*)$#,
434             source => 'wikidata',
435             type => 'wikidata-identifier',
436             id => \1,
437             ise_order => ISEORDER_RUO,
438             action => 'info',
439             },
440             {
441             host => 'www.wikidata.org',
442             path => qr#^/wiki/Special:EntityData/([QP][1-9][0-9]*)(?:\.[a-z]+)?$#,
443             source => 'wikidata',
444             type => 'wikidata-identifier',
445             id => \1,
446             ise_order => ISEORDER_RUO,
447             action => 'metadata',
448             },
449             {
450             host => 'commons.wikimedia.org',
451             path => qr#^/wiki/(File(?:%3[Aa]|:)[^/]+)$#,
452             source => 'wikimedia-commons',
453             type => 'wikimedia-commons-identifier',
454             id => \1,
455             },
456             {
457             host => 'www.fellig.org',
458             path => qr#^/subject/(?:info|best)/[^/]+/(fellig-identifier|fellig-box-number|uuid|oid|uri|wikidata-identifier|e621-(?:post|pool)-identifier|wikimedia-commons-identifier|british-museum-term|musicbrainz-identifier|gnd-identifier|e621tagtype|[0-9a-fA-F]{8}-(?:[0-9a-fA-F]{4}-){3}[0-9a-fA-F]{12})/([^/]+)$#,
459             source => 'fellig',
460             type => \1,
461             id => \2,
462             action => 'info',
463             },
464             {
465             host => 'api.fellig.org',
466             path => qr#^/v0/(?:overview|full)/(fellig-identifier|fellig-box-number|uuid|oid|uri|wikidata-identifier|e621-(?:post|pool)-identifier|wikimedia-commons-identifier|british-museum-term|musicbrainz-identifier|gnd-identifier|e621tagtype|[0-9a-fA-F]{8}-(?:[0-9a-fA-F]{4}-){3}[0-9a-fA-F]{12})/([^/]+)$#,
467             source => 'fellig',
468             type => \1,
469             id => \2,
470             action => 'metadata',
471             },
472             {
473             host => qr#^(?:www\.)?youtube\.com$#,
474             path => qr#^/(?:embed|shorts|live)/($re_yt_vid)$#,
475             source => 'youtube',
476             type => 'youtube-video-identifier',
477             id => \1,
478             action => 'embed',
479             },
480             {
481             host => 'www.youtube-nocookie.com',
482             path => qr#^/embed/($re_yt_vid)$#,
483             source => 'youtube-nocookie',
484             type => 'youtube-video-identifier',
485             id => \1,
486             action => 'embed',
487             },
488             {
489             host => 'musicbrainz.org',
490             path => qr#^/[^/]+/($re_uuid)$#,
491             source => 'musicbrainz',
492             type => 'musicbrainz-identifier',
493             id => \1,
494             action => 'info',
495             },
496             {
497             host => 'd-nb.info',
498             path => qr#^/gnd/([\dX]+)$#,
499             source => 'dnb',
500             type => 'gnd-identifier',
501             id => \1,
502             action => 'info',
503             },
504             {
505             host => 'www.britishmuseum.org',
506             path => qr#^/collection/term/([A-Z]+[0-9]+)$#,
507             source => 'britishmuseum',
508             type => 'british-museum-term',
509             id => \1,
510             action => 'info',
511             },
512             {
513             host => 'e621.net',
514             path => qr#^/(?:posts|post/show)/([1-9][0-9]*)$#,
515             source => 'e621',
516             type => 'e621-post-identifier',
517             id => \1,
518             action => 'render',
519             },
520             {
521             host => 'e621.net',
522             path => qr#^/pools/([1-9][0-9]*)$#,
523             source => 'e621',
524             type => 'e621-pool-identifier',
525             id => \1,
526             action => 'render',
527             },
528             (map {{
529             host => 'www.openstreetmap.org',
530             path => qr#^/$_/([1-9][0-9]*)$#,
531             source => 'osm',
532             type => 'osm-'.$_,
533             id => \1,
534             action => 'info',
535             }} qw(node way relation)),
536             {
537             host => qr#^(?:www\.)?xkcd\.com$#,
538             path => qr#^/([1-9][0-9]*)/$#,
539             source => 'xkcd',
540             type => 'xkcd-num',
541             id => \1,
542             action => 'render',
543             },
544             {
545             host => qr#^(?:www\.)?xkcd\.com$#,
546             path => qr#^/([1-9][0-9]*)/info\.0\.json$#,
547             source => 'xkcd',
548             type => 'xkcd-num',
549             id => \1,
550             action => 'metadata',
551             },
552             {
553             host => 'www.ngv.vic.gov.au',
554             path => qr#^/explore/collection/artist/([1-9][0-9]*)/$#,
555             source => 'ngv',
556             type => 'ngv-artist-identifier',
557             id => \1,
558             action => 'info',
559             },
560             {
561             host => 'www.ngv.vic.gov.au',
562             path => qr#^/explore/collection/work/([1-9][0-9]*)/$#,
563             source => 'ngv',
564             type => 'ngv-artwork-identifier',
565             id => \1,
566             action => 'info',
567             },
568             {
569             host => qr#^(?:www|de|es|fr|fr-ca|it|nl|sv|pt)\.findagrave\.com$#,
570             path => qr#^/memorial/([1-9][0-9]*)(?:/[^/]*)?$#,
571             source => 'find-a-grave',
572             type => 'find-a-grave-identifier',
573             id => \1,
574             action => 'info',
575             },
576             {
577             host => 'nla.gov.au',
578             path => qr#^/anbd\.aut-an([1-9][0-9]*)$#,
579             source => 'nla',
580             type => 'libraries-australia-identifier',
581             id => \1,
582             action => 'info',
583             },
584             {
585             host => 'trove.nla.gov.au',
586             path => qr#^/people/([1-9][0-9]*)$#,
587             source => 'nla',
588             type => 'nla-trove-people-identifier',
589             id => \1,
590             action => 'info',
591             },
592             {
593             host => 'www.agsa.sa.gov.au',
594             path => qr#^/collection-publications/collection/creators/_/([1-9][0-9]*)/$#,
595             source => 'agsa',
596             type => 'agsa-creator-identifier',
597             id => \1,
598             action => 'info',
599             },
600             {
601             host => 'www.australianmusiccentre.com.au',
602             path => qr#^/artist/([a-z]+(-[a-z]+)+)$#,
603             source => 'amc',
604             type => 'amc-artist-identifier',
605             id => \1,
606             action => 'info',
607             },
608             {
609             host => 'www.printsandprintmaking.gov.au',
610             path => qr#^/artists/([1-9][0-9]*)/$#,
611             source => 'a-p-and-p',
612             type => 'a-p-and-p-artist-identifier',
613             id => \1,
614             action => 'info',
615             },
616             {
617             host => 'www.watercolourworld.org',
618             path => qr#/artist/([\p{L}\d]+(-[\p{L}\d]+)*)$#,
619             source => 'tww',
620             type => 'tww-artist-identifier',
621             id => \1,
622             action => 'info',
623             },
624             {
625             host => 'database.factgrid.de',
626             path => qr#^/entity/(?:Property:)?([QP][1-9][0-9]*)$#,
627             source => 'factgrid',
628             type => 'factgrid-identifier',
629             id => \1,
630             ise_order => ISEORDER_RUO,
631             },
632             {
633             host => 'database.factgrid.de',
634             path => qr#^/wiki/(?:Item|Property):([QP][1-9][0-9]*)$#,
635             source => 'factgrid',
636             type => 'factgrid-identifier',
637             id => \1,
638             ise_order => ISEORDER_RUO,
639             action => 'info',
640             },
641             {
642             host => 'database.factgrid.de',
643             path => qr#^/wiki/Special:EntityData/([QP][1-9][0-9]*)(?:\.[a-z]+)?$#,
644             source => 'factgrid',
645             type => 'factgrid-identifier',
646             id => \1,
647             ise_order => ISEORDER_RUO,
648             action => 'metadata',
649             },
650             {
651             host => 'www.wikitree.com',
652             path => qr#^/wiki/(\D+-[1-9][0-9]*)$#,
653             source => 'wikitree',
654             type => 'wikitree-person-identifier',
655             id => \1,
656             action => 'info',
657             },
658             {
659             host => 'doi.org',
660             path => qr#^/(10\.[0-9]{4,9}\/.+)$#,
661             source => 'doi',
662             type => 'doi',
663             id => \1,
664             action => 'info',
665             },
666             {
667             host => 'dx.doi.org',
668             path => qr#^/(10\.[0-9]{4,9}\/.+)$#,
669             source => 'doi',
670             type => 'doi',
671             id => \1,
672             action => 'metadata',
673             },
674             {
675             host => 'iconclass.org',
676             path => qr#^/(?:(?:de|en)/)?([0-9].*)\.[a-z]+$#,
677             source => 'iconclass',
678             type => 'iconclass-identifier',
679             id => \1,
680             action => 'metadata',
681             },
682             {
683             host => 'iconclass.org',
684             path => qr#^/(?:(?:de|en)/)?([0-9].*)$#,
685             source => 'iconclass',
686             type => 'iconclass-identifier',
687             id => \1,
688             action => 'info',
689             },
690             {
691             host => 'www.iana.org',
692             path => qr#^/assignments/media-types/([a-z0-9\.\-\+]+\/[a-z0-9\.\-\+]+)$#,
693             source => 'iana',
694             type => 'media-subtype-identifier',
695             id => \1,
696             action => 'info',
697             },
698             {
699             host => 'oidref.com',
700             path => qr#^/([0-2](?:\.[0-9]+)+)$#,
701             source => 'oidref',
702             type => 'oid',
703             id => \1,
704             action => 'info',
705             },
706             {
707             host => 'www.furaffinity.net',
708             path => qr#^/view/([1-9][0-9]*)/$#,
709             source => 'furaffinity',
710             type => 'furaffinity-post-identifier',
711             id => \1,
712             action => 'info',
713             },
714             {
715             host => 'imgur.com',
716             path => qr#^/([0-9a-zA-Z]{7})$#,
717             source => 'imgur',
718             type => 'imgur-post-identifier',
719             id => \1,
720             action => 'info',
721             },
722             {
723             host => 'i.imgur.com',
724             path => qr#^/([0-9a-zA-Z]{7})\.[a-z]{3,4}$#,
725             source => 'imgur',
726             type => 'imgur-post-identifier',
727             id => \1,
728             action => 'file-fetch',
729             },
730             {
731             host => 'notalwaysright.com',
732             path => qr#^/[^/]+/([0-9]+)/$#,
733             source => 'notalwaysright',
734             type => 'notalwaysright-post-identifier',
735             id => \1,
736             action => 'render',
737             },
738             {
739             host => 'blog.fefe.de',
740             path => qr#^/$#,
741             source => 'fefe',
742             type => 'fefe-blog-post-identifier',
743             action => 'render',
744             id => sub {
745             my ($self, $uri, $rule, $res) = @_;
746             if ($uri->query =~ /^ts=([0-9a-f]{8})$/) {
747             return $1;
748             }
749             return undef;
750             },
751             },
752             {
753             host => 'blog.fefe.de',
754             path => qr#^/rss\.xml$#,
755             source => 'fefe',
756             type => 'fefe-blog-post-identifier',
757             action => 'metadata',
758             id => sub {
759             my ($self, $uri, $rule, $res) = @_;
760             if ($uri->query =~ /^(?:html\&)?ts=([0-9a-f]{8})(?:\&html)?$/) {
761             return $1;
762             }
763             return undef;
764             },
765             },
766             {
767             host => 'schema.org',
768             path => qr#^/[^/]+$#,
769             source => 'schemaorg',
770             type => 'uri',
771             action => 'info',
772             id => sub {
773             my ($self, $uri, $rule, $res) = @_;
774             return $uri;
775             },
776             },
777             {
778             host => 'purl.org',
779             path => qr#^/dc/(?:elements/1\.1|terms|dcam|dcmitype)/[^/]+$#,
780             source => 'purlorg',
781             type => 'uri',
782             action => 'info',
783             id => sub {
784             my ($self, $uri, $rule, $res) = @_;
785             return $uri;
786             },
787             },
788             {
789             host => 'ruthe.de',
790             path => qr#^/cartoon/([1-9][0-9]*)/datum/asc/#,
791             source => 'ruthede',
792             type => 'ruthede-comic-post-identifier',
793             action => 'render',
794             id => \1,
795             },
796             {
797             host => 'ruthe.de',
798             path => qr#^/static/cartoon_([1-9][0-9]*)\.html$#,
799             source => 'ruthede',
800             type => 'ruthede-comic-post-identifier',
801             action => 'render',
802             id => \1,
803             },
804             {
805             host => 'danbooru.2chan.jp',
806             path => qr#^/index\.php$#,
807             source => 'danbooru2chanjp',
808             type => 'danbooru2chanjp-post-identifier',
809             action => 'render',
810             id => sub {
811             my ($self, $uri, $rule, $res) = @_;
812             my %query = $uri->query_form;
813             if (($query{page} // '') eq 'post' && ($query{s} // '') eq 'view' && defined($query{id})) {
814             return $query{id};
815             }
816             return undef;
817             }
818             },
819             {
820             host => 'danbooru.2chan.jp',
821             path => qr#^/image_data\.php$#,
822             source => 'danbooru2chanjp',
823             type => 'danbooru2chanjp-post-identifier',
824             action => 'metadata',
825             id => sub {
826             my ($self, $uri, $rule, $res) = @_;
827             my %query = $uri->query_form;
828             if (int($query{limit} // '0') == 1 && int($query{offset} // 0) == 0 && defined($query{start})) {
829             return $query{start};
830             }
831             return undef;
832             }
833             },
834             {
835             # urn:uuid:039e0bb7-5dd3-40ee-a98c-596ff6cce405
836             # https://sirtx.keep-cool.org/lists.html#sni:10
837             host => 'sirtx.keep-cool.org',
838             path => qr#^/lists\.html$#,
839             source => 'sirtxkeepcoolorg',
840             type => 'sirtx-numerical-identifier',
841             action => 'info',
842             id => sub {
843             my ($self, $uri, $rule, $res) = @_;
844             my $fragment = $uri->fragment;
845             if ($fragment =~ /^sni:([1-9][0-9]*|0)$/) {
846             return int $1;
847             }
848             return undef;
849             }
850             },
851             ],
852             );
853              
854             my %syntax = (
855             'uuid' => RE_UUID,
856             'oid' => qr/^[1-3](?:\.(?:0|[1-9][0-9]*))+$/,
857             'uri' => qr/^[a-zA-Z][a-zA-Z0-9\+\.\-]+:/,
858             'tagname' => qr/./,
859             'wikidata-identifier' => qr/^[QP][1-9][0-9]*$/,
860             'factgrid-identifier' => qr/^[QP][1-9][0-9]*$/,
861             'wikimedia-commons-identifier' => qr/^File:.*$/,
862             'musicbrainz-identifier' => RE_UUID,
863             'british-museum-term' => qr/^[A-Z]+[1-9][0-9]{0,5}$/, # TODO: Find good reference; See also: https://www.wikidata.org/wiki/Property:P1711#P1793
864             'gnd-identifier' => qr/^1[012]?\d{7}[0-9X]|[47]\d{6}-\d|[1-9]\d{0,7}-[0-9X]|3\d{7}[0-9X]$/, # https://www.wikidata.org/wiki/Property:P227#P1793
865             'fellig-box-number' => qr/^[1-9][0-9]{3}$/,
866             'fellig-identifier' => qr/^[A-Z]+[1-9][0-9]*$/,
867             'youtube-video-identifier' => qr/^.{11}$/,
868             'e621tagtype' => qr/./,
869             'e621tag' => qr/./,
870             'amc-artist-identifier' => qr/^[a-z]+(-[a-z]+)+$/,
871             'tww-artist-identifier' => qr/^[\p{L}\d]+(-[\p{L}\d]+)*$/,
872             'grove-art-online-identifier' => qr/^T(?:0|20|22)\d{5}$/,
873             'wikitree-person-identifier' => qr/^\D+-[1-9][0-9]*$/,
874             'doi' => qr/^10\.[0-9]{4,9}\/.+$/,
875             'iconclass-identifier' => qr/^[0-9].*$/,
876             'media-subtype-identifier' => qr/^[a-z0-9\.\-\+]+\/[a-z0-9\.\-\+]+$/,
877             'europeana-entity-identifier' => qr/^(?:place|agent|concept|organisation)\/base\/[1-9][0-9]+$/,
878             'open-library-identifier' => qr/^(?:(?:person|place|time):)?[^:\n]+$/,
879             'viaf-identifier' => qr/^[1-9][0-9]+$/,
880             'isni' => qr/^[0]{4} [0-9]{4} [0-9]{4} [0-9]{3}[0-9X]$/,
881             'aev-identifier' => qr/^[\w\/\d]+$/,
882             'unesco-thesaurus-identifier' => qr/^concept[0-9]+$/,
883             'gtin' => qr/^[0-9]{8}(?:[0-9]{4,6})?$/,
884             'language-tag-identifier' => qr/^[0-9a-zA-Z-]+$/,
885             'imgur-post-identifier' => qr/^[0-9a-zA-Z]{7}$/,
886             'fefe-blog-post-identifier' => qr/^[0-9a-f]{8}$/,
887             'danbooru2chanjp-tag' => qr/./,
888             (map {'osm-'.$_ => RE_UINT} qw(node way relation)),
889             (map {$_ => RE_UINT} qw(e621-post-identifier e621-pool-identifier xkcd-num ngv-artist-identifier ngv-artwork-identifier find-a-grave-identifier libraries-australia-identifier nla-trove-people-identifier agsa-creator-identifier a-p-and-p-artist-identifier geonames-identifier small-identifier chat-0-word-identifier sirtx-numerical-identifier furaffinity-post-identifier notalwaysright-post-identifier ruthede-comic-post-identifier danbooru2chanjp-post-identifier)),
890             );
891              
892             my %fellig_tables = (
893             U => 'users',
894             P => 'posts',
895             TXT => 'texts',
896             );
897              
898             my %media_subtype_to_ext = (
899             'application/gzip' => 'gz',
900             'application/json' => 'json',
901             'application/ogg' => 'ogg',
902             'application/pdf' => 'pdf',
903             'application/vnd.debian.binary-package' => 'deb',
904             'application/vnd.sirtx.vmv0' => 'vmv0',
905             'application/xml' => 'xml',
906             'audio/flac' => 'flac',
907             'audio/matroska' => 'mkv',
908             'audio/ogg' => 'oga',
909             'image/gif' => 'gif',
910             'image/jpeg' => 'jpg',
911             'image/png' => 'png',
912             'image/svg+xml' => 'svg',
913             'image/svg+xml' => 'svg',
914             'image/bmp' => 'bmp',
915             'image/vnd.wap.wbmp' => 'wbmp',
916             'text/html' => 'html',
917             'text/plain' => 'txt',
918             'video/matroska' => 'mkv',
919             'video/matroska-3d' => 'mkv',
920             'video/ogg' => 'ogv',
921             'video/webm' => 'webm',
922             );
923              
924              
925             # Private method.
926             sub new {
927 6     6 0 43 my ($pkg, %opts) = @_;
928 6         15 my URI $uri = $opts{uri};
929 6         11 my __PACKAGE__ $self;
930              
931 6 50       37 croak 'Passed undef as URI' unless defined $uri;
932 6 50       32 croak 'Passed a non-URI object' unless $uri->isa('URI');
933              
934 6         36 $opts{uri} = $uri->canonical;
935              
936 6         637 $self = bless \%opts, $pkg;
937              
938 6         32 $self->_lookup;
939 6         30 $self->_lookup_with_mode(mode => 'offline');
940 6         58 $self->_lookup_with_mode(mode => 'online');
941              
942 6         68 return $self;
943             }
944              
945             sub _set {
946 6     6   27 my ($self, $service, $type, $id, $ise_order, $action) = @_;
947 6         42 my Data::URIID $extractor = $self->extractor;
948 6         14 my $best_service;
949             my $type_name;
950              
951 6 50       20 if (defined $type) {
952 6         29 $type = $extractor->name_to_ise(type => $type);
953 6         24 $type_name = $extractor->ise_to_name(type => $type);
954              
955 6 50       91 croak 'Invalid syntax for identifier type' unless $id =~ $syntax{$type_name};
956             }
957              
958 6   100     48 $ise_order //= ISEORDER_UOR;
959 6 100       48 $service = $extractor->service($service) if defined $service;
960 6 100       64 $action = $extractor->name_to_ise(action => $action) if defined $action;
961              
962 6 100 50     69 if (defined(my $best_service_name = $best_services{$type_name // ''})) {
963 2         9 $best_service = $extractor->service($best_service_name);
964             }
965              
966 6 50 33     47 if (defined($type_name) && $type_name eq 'uri') {
967             # normalise a bit.
968 0         0 $id =~ s#^http://schema\.org/#https://schema\.org/#;
969             }
970              
971             $self->{primary} = {
972 6   50     11 %{$self->{primary}//{}},
  6         76  
973             service => $service,
974             type => $type,
975             id => $id,
976             ise_order => $ise_order,
977             action => $action,
978             best_service => $best_service,
979             };
980 6 50 33     49 if (defined($type) && defined($id)) {
981             $self->{id} = {
982 6         27 $type => $id,
983             };
984             }
985             }
986              
987             sub _lookup {
988 6     6   31 my ($self) = @_;
989 6         39 my URI $uri = $self->{uri};
990 6         24 my $scheme = $uri->scheme;
991 6         102 my $host = eval {$uri->host};
  6         127  
992 6         73 my $path = eval {$uri->path};
  6         28  
993 6         90 my $func;
994              
995             # handle HTTP and HTTPS alike.
996 6 100       41 $scheme = 'https' if $scheme eq 'http';
997              
998 6         14 foreach my $rule (@{$url_parser{$scheme}}) {
  6         31  
999 9         17 my @res;
1000 9         23 my %found = map {$_ => $rule->{$_}} qw(source type id ise_order action);
  45         177  
1001 9         18 my $ud;
1002              
1003 9 100       32 if (defined $rule->{host}) {
1004 3 50       9 next unless defined $host;
1005 3 50       9 if (ref($rule->{host})) {
1006 0 0       0 next unless $host =~ $rule->{host};
1007             } else {
1008 3 50       10 next unless $host eq $rule->{host};
1009             }
1010             }
1011 9 50       28 if (defined $rule->{path}) {
1012 9 100 66     140 next unless defined($path) && (@res = $path =~ $rule->{path});
1013             }
1014              
1015 6 50       25 if (defined $rule->{prepare}) {
1016 0         0 $ud = $rule->{prepare}->($self, $uri, $rule, \@res, \%found);
1017 0 0       0 next unless defined $ud;
1018             }
1019              
1020 6         22 foreach my $value (values %found) {
1021 30 100       133 if (my $ref = ref $value) {
1022 8 100       48 if ($ref eq 'SCALAR') {
    50          
1023 6         35 $value = uri_unescape($res[${$value} - 1]);
  6         42  
1024             } elsif ($ref eq 'CODE') {
1025 0         0 $value = $value->($self, $uri, $rule, \@res, $ud);
1026             }
1027             }
1028             }
1029              
1030 6         98 $self->_set(@found{qw(source type id ise_order action)});
1031 6         31 return;
1032             }
1033              
1034 0         0 $func = $self->can('_lookup__'.$scheme);
1035              
1036 0 0       0 croak 'Not implemented (unsupported scheme)' unless $func;
1037              
1038 0         0 $self->$func();
1039              
1040 0 0       0 croak 'Not implemented' unless defined $self->{primary};
1041             }
1042              
1043             sub _lookup_one {
1044 76     76   195 my ($self, $service, %opts) = @_;
1045 76         259 my Data::URIID $extractor = $self->extractor;
1046 76   50     166 my $mode = $opts{mode} // 'online';
1047 76   100     247 my $have = $self->{$mode.'_results'} //= {};
1048 76         100 my $res;
1049              
1050 76 100       212 return $have->{$service} if $have->{$service};
1051              
1052 26   100     44 $res = eval {
1053 26         92 my $_service = $extractor->service($service);
1054 26         171 my $_func = $_service->can(sprintf('_%s_lookup', $mode));
1055 26         135 $_service->$_func($self, %opts)
1056             } // {};
1057 26         65 $have->{$service} = $res;
1058              
1059 26   100     40 foreach my $id_type (keys %{$res->{id} // {}}) {
  26         159  
1060 18         56 my $ise = $extractor->name_to_ise(type => $id_type);
1061 18   66     96 $self->{id}{$ise} //= $res->{id}{$id_type};
1062             }
1063              
1064 26 50       83 if (defined $res->{url_overrides}) {
1065 0   0     0 $self->{url_overrides} //= {};
1066 0   0     0 $self->{url_overrides}{$service} //= $res->{url_overrides};
1067             }
1068              
1069 26         101 return $res;
1070             }
1071              
1072             sub _lookup_with_mode {
1073 12     12   44 my ($self, %opts) = @_;
1074 12         57 my Data::URIID $extractor = $self->extractor;
1075 12         28 my $mode = $opts{mode};
1076              
1077 12 100 66     105 return if $mode eq 'online' && !$extractor->online;
1078              
1079 6         22 foreach my $pass (0..2) {
1080 18         45 my %done;
1081 18         28 foreach my $id_type_ise (keys %{$self->{id}}) {
  18         87  
1082 46   50     96 my $id_type = eval {$extractor->ise_to_name(type => $id_type_ise)} // next;
  46         150  
1083 46         100 foreach my $service (@{$lookup_services{$id_type}}) {
  46         102  
1084 192 100       446 next if $done{$service};
1085 76         145 $done{$service} = 1;
1086 76         188 $self->_lookup_one($service, %opts);
1087             }
1088             }
1089 18         54 foreach my $digest (keys %lookup_services_digest) {
1090 18   50     85 $self->digest($digest, as => 'hex', default => undef) // next;
1091 0         0 foreach my $service (@{$lookup_services_digest{$digest}}) {
  0         0  
1092 0 0       0 next if $done{$service};
1093 0         0 $done{$service} = 1;
1094 0         0 $self->_lookup_one($service, %opts);
1095             }
1096             }
1097             }
1098             }
1099              
1100             sub _lookup__https {
1101 0     0   0 my ($self) = @_;
1102 0         0 my URI $uri = $self->{uri};
1103 0         0 my $host = $uri->host;
1104 0         0 my $path = $uri->path;
1105              
1106 0 0 0     0 if ($host eq 'www.youtube.com') {
    0 0        
    0 0        
    0 0        
    0 0        
    0          
    0          
1107 0 0       0 if (defined(my $v = {$uri->query_form}->{v})) {
1108 0         0 $self->_set(youtube => 'youtube-video-identifier' => $v);
1109             }
1110             } elsif ($host =~ /^[a-z]{2}\.wikipedia\.org$/) {
1111 0 0       0 if (scalar(my ($page) = $path =~ m#^/wiki/(.+)$#)) {
1112             # We need to do this very early as we cannot store it as an ID before we did an online lookup.
1113 0         0 my Data::URIID::Service $service = $self->extractor->service('wikipedia');
1114 0 0       0 if ($service->_is_online) {
1115 0         0 my $json = $service->_get_json(sprintf('https://%s/w/api.php', $host),
1116             query => {
1117             action => 'query',
1118             format => 'json',
1119             redirects => 1,
1120             prop => 'pageprops',
1121             ppprop => 'wikibase_item',
1122             titles => $page,
1123             });
1124 0 0       0 if (defined $json) {
1125 0         0 my $wikidata_identifier = eval {$json->{query}{pages}{(keys %{$json->{query}{pages}})[0]}{pageprops}{wikibase_item}};
  0         0  
  0         0  
1126 0 0       0 if (defined $wikidata_identifier) {
1127 0         0 $self->_set(wikipedia => 'wikidata-identifier' => $wikidata_identifier, undef, 'info');
1128             }
1129             }
1130             } else {
1131 0         0 croak 'Wikipedia URLs can only be lookedup in online mode';
1132             }
1133             }
1134             } elsif ($host eq 'xkcd.com' && ($path eq '/' || $path eq '/info.0.json')) {
1135             # We need to do this very early as we cannot store it as an ID before we did an online lookup.
1136 0         0 my Data::URIID::Service $service = $self->extractor->service('xkcd');
1137 0 0       0 if ($service->_is_online) {
1138 0         0 my $res = $self->_lookup_one($service->name, metadata_url => 'https://xkcd.com/info.0.json');
1139 0 0       0 $self->_set(xkcd => 'xkcd-num' => $res->{id}{'xkcd-num'}, undef, $path eq '/' ? 'render' : 'metadata') if defined $res->{id}{'xkcd-num'};
    0          
1140             }
1141             } elsif ($host eq 'uriid.org' && $path =~ m#^/(?:[0-9a-f]{8}-(?:[0-9a-f]{4}-){3}[0-9a-f]{12}|[a-z-]+|[a-zA-Z])/.+$#) {
1142 0         0 my ($prefix, $type, $id) = $uri->path_segments;
1143 0 0       0 if ($prefix eq '') {
1144 0         0 my Data::URIID::Service $uriid = $self->extractor->service('uriid');
1145 0         0 my $types = $uriid->_get_uriid_decompiled_types_json->{forward}{types};
1146 0         0 my $type_uuid;
1147 0 0       0 if ($type =~ RE_UUID) {
    0          
1148 0         0 $type_uuid = lc($type);
1149             } elsif (defined $types->{$type}{alias_for}) {
1150 0         0 $type_uuid = $types->{$type}{alias_for};
1151             }
1152 0         0 $self->_set(uriid => $type_uuid => $id, undef, 'info');
1153             }
1154             } elsif ($host eq 'uriid.org' || $host eq 'api.uriid.org') {
1155 0         0 my Data::URIID $extractor = $self->extractor;
1156 0         0 my %query = $uri->query_form;
1157 0 0       0 my $action = $host eq 'uriid.org' ? 'info' : 'metadata';
1158              
1159 0 0 0     0 if (defined($query{type}) && length($query{type}) && defined($query{id}) && length($query{id})) {
    0 0        
      0        
      0        
1160 0         0 my Data::URIID::Service $uriid = $extractor->service('uriid');
1161 0         0 my $types = $uriid->_get_uriid_decompiled_types_json->{forward}{types};
1162 0         0 my $type_uuid;
1163 0 0       0 if ($query{type} =~ RE_UUID) {
    0          
1164 0         0 $type_uuid = lc($query{type});
1165             } elsif (defined $types->{$query{type}}{alias_for}) {
1166 0         0 $type_uuid = $types->{$query{type}}{alias_for};
1167             }
1168 0         0 $self->_set(uriid => $type_uuid => $query{id}, undef, $action);
1169             } elsif (defined($query{for}) && length($query{for})) {
1170 0         0 my $old_online = $extractor->online;
1171 0         0 my $result;
1172 0         0 $extractor->online(0);
1173 0         0 $result = eval {$extractor->lookup($query{for})};
  0         0  
1174 0         0 $extractor->online($old_online);
1175 0 0       0 if (defined $result) {
1176 0         0 $self->_set(uriid => $result->id_type => $result->id, undef, $action);
1177             }
1178             }
1179             } elsif ($host eq 'static1.e621.net') {
1180 0         0 my @segments = $uri->path_segments;
1181 0 0 0     0 if (scalar(@segments) == 5 &&
      0        
      0        
      0        
      0        
1182             $segments[0] eq '' && $segments[1] eq 'data' &&
1183             length($segments[2]) == 2 && length($segments[3]) == 2 &&
1184             length($segments[4]) > 32) {
1185 0         0 my ($md5, $ext) = $segments[4] =~ /^([0-9a-f]{32})\.([0-9a-z]+)$/;
1186 0         0 $self->_set('e621', undef, undef, undef, 'file-fetch');
1187 0         0 $self->{primary}{ext} = $ext;
1188 0   0     0 $self->{primary}{digest} //= {};
1189 0         0 $self->{primary}{digest}{'md-5-128'} = $md5;
1190             }
1191 0 0 0     0 if (scalar(@segments) == 6 &&
      0        
      0        
      0        
      0        
      0        
1192             $segments[0] eq '' && $segments[1] eq 'data' &&
1193             $segments[2] eq 'preview' &&
1194             length($segments[3]) == 2 && length($segments[4]) == 2 &&
1195             length($segments[5]) > 32) {
1196 0         0 my ($md5, $ext) = $segments[5] =~ /^([0-9a-f]{32})\.([0-9a-z]+)$/;
1197 0         0 $self->_set('e621');
1198 0   0     0 $self->{primary}{digest} //= {};
1199 0         0 $self->{primary}{digest}{'md-5-128'} = $md5;
1200             }
1201             } elsif ($host eq 'files.fellig.org' || $host eq 'thumbnails.fellig.org') {
1202 0         0 my @segments = $uri->path_segments;
1203 0 0 0     0 if (scalar(@segments) == 5 &&
      0        
      0        
      0        
      0        
1204             $segments[0] eq '' && $segments[1] eq 'v2' && $segments[2] eq 'by' &&
1205             $segments[3] =~ /^[a-z]+-[0-9]+-[0-9]+$/ &&
1206             length($segments[4]) > 32) {
1207 0         0 my ($hash, $ext) = $segments[4] =~ /^([0-9a-f]{32,})\.([0-9a-z]+)$/;
1208 0 0       0 if (length($hash) == int(($segments[3] =~ /^[a-z]+-[0-9]+-([0-9]+)$/)[0]/4)) {
1209 0         0 $self->_set('fellig', undef, undef, undef, 'file-fetch');
1210 0         0 $self->{primary}{ext} = $ext;
1211 0   0     0 $self->{primary}{digest} //= {};
1212 0         0 $self->{primary}{digest}{$segments[3]} = $hash;
1213             }
1214             }
1215             }
1216             }
1217              
1218              
1219             sub id_type {
1220 12     12 1 32 my ($self, %opts) = @_;
1221 12         80 return $self->_cast_ise($self->{primary}{type}, 'ise', %opts);
1222             }
1223              
1224              
1225             sub _cast_id {
1226 86     86   279 my ($self, $src, $src_type, %opts) = @_;
1227 86   100     319 my $as = $opts{as} // 'raw';
1228              
1229 86 100 66     361 if ($as eq 'raw' || $as eq 'string' || $as eq $src_type) {
    50 66        
    0          
1230 66         369 return $src;
1231             } elsif ($as eq 'Data::Identifier') {
1232 20         101 return Data::Identifier->new($src_type => $src);
1233             } elsif ($as eq __PACKAGE__) {
1234 0         0 return $self->_as_lookup([$src_type => $src], %opts);
1235             } else {
1236 0         0 croak sprintf('Cannot convert identifier to type "%s"', $as);
1237             }
1238             }
1239              
1240             sub id {
1241 166     166 1 330 my ($self, $type, %opts);
1242              
1243 166 100       463 if (scalar(@_) % 2) {
1244 10         21 ($self, %opts) = @_;
1245 10         125 $type = $opts{type};
1246             } else {
1247 156         480 ($self, $type, %opts) = @_;
1248             }
1249              
1250 166 100       396 return $self->_cast_id($self->{primary}{id}, $self->{primary}{type}, %opts) unless defined $type;
1251              
1252             # We do a double convert of type here to ensure we have it the right way
1253             # independent of if we got name or ISE passed.
1254 156         1400 $type = $self->extractor->name_to_ise(type => $type);
1255 156 100       568 if (defined $self->{id}{$type}) {
    100          
1256 66         306 return $self->_cast_id($self->{id}{$type}, $type, %opts);
1257             } elsif (!$opts{_no_convert}) {
1258 10         27 my $primary_type_name = $self->extractor->ise_to_name(type => $self->{primary}{type});
1259 10         31 my $type_name = $self->extractor->ise_to_name(type => $type);
1260 10   50     57 $opts{_no_try} //= {};
1261 10         40 $opts{_no_try}{$type_name} = 1;
1262              
1263             # Do two passes: first try only IDs we already have, then try them in order of converters.
1264 10         23 foreach my $no_convert (1, 0) {
1265 10   50     19 foreach my $from ($primary_type_name, grep {$_ ne 'x'.$primary_type_name} @{$id_conv{$type_name} // []}) {
  26         72  
  10         74  
1266 10 50       30 next if $opts{_no_try}{$from};
1267 10         19 eval {
1268 10         26 my $id = $self->id($from, %opts, _no_convert => $no_convert, _no_try => {%{$opts{_no_try}}});
  10         84  
1269 10         96 my $func = $self->can(sprintf('_id_conv__%s__%s', $type_name =~ tr/-/_/r, $from =~ tr/-/_/r));
1270 10 50       53 $self->$func($type => $from => $id) if defined $func;
1271             };
1272 10 50       1830 return $self->_cast_id($self->{id}{$type}, $type, %opts) if defined $self->{id}{$type};
1273             }
1274             }
1275             }
1276              
1277 80         12287 croak 'Identifier type not supported';
1278             }
1279              
1280              
1281             sub _cast {
1282 2     2   10 my ($self, $key, $value, $source_type, $as, %opts) = @_;
1283 2 50       7 if ($as eq $source_type) {
1284 0         0 return $value;
1285             } else {
1286 2 50 33     45 if ($as eq 'string' && $source_type eq 'media_subtype') {
    50 33        
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
    0 0        
      0        
1287 0         0 return $value;
1288             } elsif ($as eq 'ise' && $source_type eq 'media_subtype') {
1289 0         0 return $self->_media_subtype_to_uuid($value);
1290 0         0 } elsif ($as eq 'string' && eval {$value->isa('URI')}) {
1291 0         0 return $value->as_string;
1292 0         0 } elsif ($as eq __PACKAGE__ && eval {$value->isa('URI')}) {
1293 0         0 return $self->_as_lookup([$value], %opts);
1294 0         0 } elsif ($as eq __PACKAGE__ && eval {$value->can('ise')}) {
1295 0         0 return $self->_as_lookup([ise => $value->ise], %opts);
1296 2         15 } elsif ($as eq 'ise' && eval {$value->can('ise')}) {
1297 2         9 return $value->ise;
1298 0         0 } elsif ($as eq 'rgb' && eval {$value->can('rgb')}) {
1299 0         0 return $value->rgb;
1300 0         0 } elsif (eval {$value->isa('Data::URIID::Base')} && defined(my $r = eval {$value->ise(as => $as)})) {
  0         0  
1301 0         0 return $r;
1302 0         0 } elsif (($as =~ /^[A-Z]/ || $as =~ /::/) && eval {$value->isa($as)}) {
1303 0         0 return $value;
1304             }
1305              
1306 0 0 0     0 if ($as eq __PACKAGE__ && defined(my $ise = eval{$self->attribute($key, %opts, as => 'ise')})) {
  0         0  
1307 0         0 return $self->_as_lookup([ise => $ise], %opts);
1308             }
1309             }
1310              
1311 0         0 croak sprintf('Cannot convert from type "%s" to "%s" for attribute "%s"', $source_type, $as, $key);
1312             }
1313             sub _cache_key {
1314 0     0   0 my ($self) = @_;
1315 0   0     0 return $self->{cache_key} //= sprintf('%s/%s', $self->{primary}{type}, $self->{primary}{id});
1316             }
1317             sub attribute {
1318 6     6 1 4045 my ($self, $key, %opts) = @_;
1319 6   33     65 my $info = $attributes{$key} // croak sprintf('Unknown attribute "%s"', $key);
1320 6   66     46 my $as = $opts{as} // $info->{default_as} // $info->{source_type};
      33        
1321 6         16 my $value = $self->{primary}{$key};
1322 6         27 my @value;
1323              
1324 6 50       29 if (defined(my $cb = $info->{cb})) {
1325 0         0 $value = $self->$cb($key, %opts);
1326 0 0       0 @value = @{$value} if ref($value) eq 'ARRAY';
  0         0  
1327             } else {
1328 6         11 my $default_value;
1329              
1330 6 100 66     32 unless (defined($value) || ref($value) eq 'ARRAY') {
1331 4   50     16 $self->{offline_results} //= {};
1332 4   50     13 $self->{online_results} //= {};
1333              
1334 4 50       13 @value = @{$value} if ref($value) eq 'ARRAY';
  0         0  
1335              
1336 4         9 foreach my $result ($self->{secondary}, values(%{$self->{offline_results}}), values(%{$self->{online_results}})) {
  4         15  
  4         42  
1337 20 50 33     114 next unless defined($result) && defined($result->{attributes});
1338 0 0       0 if (defined($value = $result->{attributes}->{$key})) {
1339 0 0       0 if (ref($value) eq 'HASH') {
1340 0         0 my $new;
1341 0         0 foreach my $language_tag ($self->extractor->_get_language_tags(%opts)) {
1342 0 0       0 $new = $value->{$language_tag} and last;
1343             }
1344 0         0 $default_value = $value->{'*'};
1345 0         0 $value = $new;
1346             }
1347              
1348 0 0       0 if (defined($value)) {
    0          
1349 0 0       0 if (ref($value) eq 'ARRAY') {
1350 0         0 push(@value, @{$value});
  0         0  
1351             } else {
1352 0         0 last;
1353             }
1354             } elsif (ref($default_value) eq 'ARRAY') {
1355 0         0 push(@value, @{$default_value});
  0         0  
1356             }
1357             }
1358             }
1359             }
1360              
1361 6   66     26 $value //= $default_value;
1362             }
1363              
1364 6 100       23 if (defined $value) {
1365 2   50     21 my $cache = ($self->{attributes_cache} //= {})->{$key} //= {};
      50        
1366 2         4 my $source_type;
1367              
1368 2   0     12 $source_type = ref($value[0]) || ref($value) || $info->{source_type} || 'raw';
1369 2   33     7 $as //= $source_type;
1370              
1371 2 50 25     13 if (ref($value) eq 'ARRAY' xor $opts{list}) {
1372 0         0 croak sprintf('Invalid list mode for attribute "%s"', $key);
1373             }
1374              
1375 2 50       6 if (ref($value) eq 'ARRAY') {
1376 0         0 my %uniq;
1377              
1378 0 0       0 return @{$cache->{$as}} if defined $cache->{$as};
  0         0  
1379              
1380 0         0 foreach my $item (@value) {
1381 0 0       0 if (blessed $item) {
1382 0         0 $uniq{$item->ise} = $item;
1383             } else {
1384 0         0 my __PACKAGE__ $result = $self->_as_lookup($item, %opts);
1385 0         0 $uniq{$result->_cache_key} = $result;
1386             }
1387             }
1388              
1389 0         0 $cache->{$as} = [map{$self->_cast($key => $_, $source_type => $as, %opts)} values %uniq];
  0         0  
1390 0         0 return @{$cache->{$as}};
  0         0  
1391             } else {
1392 2   33     49 return $cache->{$as} //= $self->_cast($key => $value, $source_type => $as, %opts);
1393             }
1394             }
1395              
1396 4 50       12 if (exists $opts{default}) {
1397 4 50       14 if ($opts{list}) {
1398 0         0 return @{$opts{default}};
  0         0  
1399             } else {
1400 4         28 return $opts{default};
1401             }
1402             }
1403              
1404 0         0 croak sprintf('No value found for attribute "%s"', $key);
1405             }
1406              
1407              
1408             sub digest {
1409 18     18 1 68 my ($self, $key, %opts) = @_;
1410 18   50     54 my $as = $opts{as} // 'hex';
1411 18         55 my $value;
1412              
1413             # convert L<Digest> name into utag name if needed:
1414 18   33     93 $key = $digest_name_converter{fc($key)} // $key;
1415              
1416             # Check utag name:
1417 18 50       123 if ($key !~ /^[a-z]+-[0-9]+-[1-9][0-9]*$/) {
1418 0         0 croak sprintf('Unknown digest format "%s"', $key);
1419             }
1420              
1421 18 50       67 unless (defined $value) {
1422 18   100     106 $self->{primary}{digest} //= {};
1423 18         37 $value = $self->{primary}{digest}{$key};
1424             }
1425              
1426 18 50       50 unless (defined $value) {
1427 18   50     42 $self->{offline_results} //= {};
1428 18   100     56 $self->{online_results} //= {};
1429              
1430 18         39 foreach my $result ($self->{secondary}, values(%{$self->{offline_results}}), values(%{$self->{online_results}})) {
  18         58  
  18         73  
1431 94 50 33     348 next unless defined($result) && defined($result->{digest});
1432 0 0       0 last if defined($value = $result->{digest}{$key});
1433             }
1434             }
1435              
1436 18 50       43 if (defined $value) {
1437 0 0 0     0 if ($as eq 'hex') {
    0          
    0          
    0          
    0          
    0          
1438 0         0 return $value;
1439             } elsif ($as eq 'binary') {
1440 0         0 return pack('H*', $value);
1441             } elsif ($as eq 'base64' || $as eq 'b64') {
1442 0         0 return MIME::Base64::encode(pack('H*', $value), '') =~ s/=+$//r;
1443             } elsif ($as eq 'base64_padded') {
1444 0         0 return MIME::Base64::encode(pack('H*', $value), '');
1445             } elsif ($as eq 'utag') {
1446 0 0       0 if (defined(my $size = eval {$self->attribute('final_file_size')})) {
  0         0  
1447 0         0 return sprintf('v0 %s bytes 0-%u/%u %s', $key, $size - 1, $size, $value);
1448             }
1449              
1450 0         0 return sprintf('v0 %s bytes 0-/* %s', $key, $value);
1451             } elsif ($as eq 'Digest') {
1452 0         0 return Data::URIID::Digest->_new($value);
1453             }
1454              
1455 0         0 croak sprintf('Cannot convert from type "%s" to "%s" for digest "%s"', 'hex', $as, $key);
1456             }
1457              
1458 18 50       123 return $opts{default} if exists $opts{default};
1459              
1460 0         0 croak sprintf('No value found for digest "%s"', $key);
1461             }
1462              
1463              
1464             sub available_keys {
1465 0     0 1 0 my ($self, $class) = @_;
1466              
1467 0 0       0 croak 'No class given' unless defined $class;
1468              
1469 0 0       0 if ($class eq 'attribute') {
    0          
1470 0         0 return keys %attributes;
1471             } elsif ($class eq 'digest') {
1472             # TODO: optimise this later.
1473 0   0     0 my %digest = %{$self->{primary}{digest} // {}};
  0         0  
1474              
1475 0   0     0 $self->{offline_results} //= {};
1476 0   0     0 $self->{online_results} //= {};
1477              
1478 0         0 foreach my $result ($self->{secondary}, values(%{$self->{offline_results}}), values(%{$self->{online_results}})) {
  0         0  
  0         0  
1479 0 0 0     0 next unless defined($result) && defined($result->{digest});
1480 0         0 %digest = (%digest, %{$result->{digest}});
  0         0  
1481             }
1482              
1483 0         0 return keys %digest;
1484             } else {
1485 0         0 croak 'Unknown class given: '.$class;
1486             }
1487             }
1488              
1489              
1490             sub _match_list {
1491 0     0   0 my ($self, $list, $value) = @_;
1492              
1493 0 0       0 return 1 unless defined $list;
1494 0 0       0 return 1 unless defined $value;
1495              
1496             {
1497 0         0 my $ref = ref($list);
  0         0  
1498 0 0       0 if (!$ref) {
    0          
1499 0         0 $list = [split/\s*,\s*|\s+/, $list];
1500             } elsif ($ref eq 'Regexp') {
1501 0         0 return $value =~ $list;
1502             }
1503             }
1504              
1505              
1506 0     0   0 return any {$_ eq $value} @{$list};
  0         0  
  0         0  
1507              
1508 0         0 return undef;
1509             }
1510              
1511             #@returns URI
1512             sub _render_url_template {
1513 0     0   0 my ($self, $metatype, $type, $value, $template, $opts, $base) = @_;
1514 0   0     0 my %map = (%{$base // {}}, type => $type, value => $value);
  0         0  
1515 0         0 my ($t_type, $t_template, $t_filter, $t_actions, $t_opts);
1516 0         0 my $url;
1517              
1518 0 0       0 if ($metatype eq METATYPE_ID) {
    0          
1519 0         0 $map{id} = $value;
1520 0 0       0 if (ref($template) eq 'ARRAY') {
1521             # 0 1 2 3 4
1522 0         0 ($t_type, $t_template, $t_filter, $t_actions, $t_opts) = @{$template};
  0         0  
1523             }
1524             } elsif ($metatype eq METATYPE_DIGEST) {
1525 0         0 $map{digest} = $value;
1526 0 0       0 if (ref($template) eq 'ARRAY') {
1527 0         0 ($t_type, $t_template, $t_actions) = @{$template};
  0         0  
1528             }
1529             }
1530              
1531 0 0 0     0 if (!defined($t_template) && ref($template) eq 'HASH') {
1532 0   0     0 $t_type = $template->{id_type} // $template->{digest} // $template->{type};
      0        
1533 0         0 $t_template = $template->{template};
1534 0         0 $t_filter = $template->{filter};
1535 0         0 $t_actions = $template->{action};
1536 0         0 $t_opts = $template->{options};
1537             }
1538              
1539 0 0       0 return undef unless defined $t_template;
1540 0 0       0 return undef unless $self->_match_list($t_type, $type);
1541 0 0       0 return undef unless $self->_match_list($t_filter, $value);
1542 0 0       0 return undef unless $self->_match_list($t_actions, $opts->{action});
1543              
1544 0 0       0 if (blessed($t_template)) {
    0          
    0          
1545 0 0       0 if ($t_template->can('process')) {
1546 0         0 $url = $t_template->process(\%map);
1547             } else {
1548 0         0 return undef;
1549             }
1550             } elsif ($metatype eq METATYPE_ID) {
1551 0   0     0 $t_opts //= {};
1552 0 0       0 $url = sprintf($t_template, $t_opts->{no_escape} ? $map{value} : uri_escape_utf8($map{value}));
1553             } elsif ($metatype eq METATYPE_DIGEST) {
1554 0         0 $url = $t_template;
1555 0   0     0 $url =~ s/%\{([a-z]+)(?:,([0-9]+)(?:,([0-9]+))?)?\}/uri_escape_utf8(substr($map{$1} || next, $2 || 0, $3 || 9999))/ge;
  0   0     0  
      0        
1556             } else {
1557 0         0 return undef;
1558             }
1559              
1560 0 0       0 return ref($url) ? $url : URI->new($url) if defined $url;
    0          
1561 0         0 return undef;
1562             }
1563              
1564             #@returns URI
1565             sub url {
1566 0     0 1 0 my ($self) = @_;
1567 0         0 my Data::URIID $extractor = $self->extractor;
1568 0         0 my $service;
1569             my %opts;
1570              
1571 0 0       0 if (scalar(@_) == 2) {
1572 0         0 $opts{service} = $_[1];
1573             } else {
1574 0         0 (undef, %opts) = @_;
1575             }
1576              
1577 0   0     0 $service = $opts{service} // $self->attribute('service');
1578              
1579             # Normalise name:
1580 0         0 $service = $extractor->service($service);
1581 0         0 $service = $extractor->ise_to_name(service => $service->ise);
1582              
1583             # Normalise action:
1584 0 0       0 if (defined $opts{action}) {
1585 0         0 $opts{action} = $extractor->name_to_ise(action => $opts{action});
1586 0         0 $opts{action} = $extractor->ise_to_name(action => $opts{action});
1587             }
1588              
1589 0   0     0 $opts{action} //= eval {$extractor->ise_to_name(action => $self->attribute('action', as => 'ise'))};
  0         0  
1590              
1591             # First pass: try original id type
1592 0 0       0 if (defined(my $id = eval {$self->id})) {
  0         0  
1593 0         0 my $id_type = $extractor->ise_to_name(type => $self->id_type);
1594              
1595 0   0     0 foreach my $template (@{$url_templates{$service} // []}) {
  0         0  
1596 0         0 my URI $uri = $self->_render_url_template(METATYPE_ID, $id_type => $id, $template, \%opts);
1597 0 0       0 return $uri if defined $uri;
1598             }
1599             }
1600              
1601             # Second pass: try in order of preference of the service
1602 0   0     0 foreach my $template (@{$url_templates{$service} // []}) {
  0         0  
1603             # 0 1 2 3 4
1604 0         0 my ($t_id_type, $t_template, $t_id_filter, $t_actions, $t_opts) = @{$template};
  0         0  
1605 0   0     0 my $id = eval { $self->id($t_id_type) } // next;
  0         0  
1606 0         0 my URI $uri = $self->_render_url_template(METATYPE_ID, $t_id_type => $id, $template, \%opts);
1607 0 0       0 return $uri if defined $uri;
1608             }
1609              
1610 0 0 0     0 if (defined($opts{action}) && $opts{action} eq 'info' && $service eq 'wikipedia') {
      0        
1611 0 0       0 if (defined(my $sitelinks = eval {$self->{online_results}{wikidata}{wikidata_sitelinks}})) {
  0         0  
1612 0         0 foreach my $language_tag ($extractor->_get_language_tags(%opts)) {
1613 0 0       0 if (defined(my $link = $sitelinks->{$language_tag.'wiki'})) {
1614 0 0       0 return URI->new($link->{url}) if defined $link->{url};
1615             }
1616             }
1617             }
1618             }
1619              
1620 0 0 0     0 if ($service eq 'uriid' && defined(my $type = eval {$self->id_type})) {
  0         0  
1621 0         0 my Data::URIID::Service $uriid = $extractor->service($service);
1622 0         0 my $types = $uriid->_get_uriid_decompiled_types_json;
1623              
1624 0   0     0 $type = $types->{backward}{$type} // $type;
1625              
1626 0 0 0     0 if (defined($opts{action}) && $opts{action} eq 'info') {
1627 0         0 my $u = URI->new("https://uriid.org/");
1628 0         0 $u->path_segments('', $type, $self->id);
1629 0         0 return $u;
1630             }
1631             }
1632              
1633             # Now try digest based:
1634             {
1635 0         0 my %base = (
  0         0  
1636             ext => $self->attribute('ext', default => undef),
1637             );
1638              
1639 0 0       0 unless (defined($base{ext})) {
1640 0         0 my $media_subtype = $self->attribute('media_subtype', as => 'media_subtype', default => undef);
1641 0 0       0 if (defined $media_subtype) {
1642 0         0 $base{ext} = $media_subtype_to_ext{$media_subtype};
1643             }
1644             }
1645              
1646 0         0 foreach my $digest ($self->available_keys('digest')) {
1647 0   0     0 my $value = $self->digest($digest, default => undef) // next;
1648              
1649 0         0 foreach my $template (@{$digest_url_templates{$service}}) {
  0         0  
1650 0         0 my URI $uri = $self->_render_url_template(METATYPE_DIGEST, $digest => $value, $template, \%opts, \%base);
1651 0 0       0 return $uri if defined $uri;
1652             }
1653             }
1654             }
1655              
1656 0 0 0     0 if (defined($self->{url_overrides}) && defined($self->{url_overrides}{$service})) {
1657 0 0       0 if (defined(my $action = $opts{action})) {
1658 0 0       0 if (defined(my $url = $self->{url_overrides}{$service}{$action})) {
1659 0         0 return URI->new($url);
1660             }
1661             }
1662             }
1663              
1664 0 0       0 return $opts{default} if exists $opts{default};
1665 0         0 croak 'Identifier does not generate a URL for the selected service';
1666             }
1667              
1668             sub _register_service__type {
1669 0     0   0 my ($self, $uri, $rule, $res, $ud) = @_;
1670 0         0 return $self->extractor->ise_to_name(type => $ud->{id}->type->uuid);
1671             }
1672             sub _register_service__id {
1673 0     0   0 my ($self, $uri, $rule, $res, $ud) = @_;
1674 0         0 return $ud->{id}->id;
1675             }
1676             sub _register_service__action {
1677 0     0   0 my ($self, $uri, $rule, $res, $ud) = @_;
1678 0         0 return $ud->{action};
1679             }
1680              
1681             sub _register_service {
1682 0     0   0 my ($pkg, $service, %opts) = @_;
1683              
1684 0 0       0 if (defined(my $id_templates = $opts{id_templates})) {
1685 0 0       0 if (scalar(@{$id_templates})) {
  0         0  
1686 0   0     0 my $url_templates = $url_templates{$service} //= [];
1687 0         0 push(@{$url_templates}, @{$id_templates});
  0         0  
  0         0  
1688             }
1689             }
1690              
1691 0 0       0 if (defined(my $digest_templates = $opts{digest_templates})) {
1692 0 0       0 if (scalar(@{$digest_templates})) {
  0         0  
1693 0   0     0 my $url_templates = $digest_url_templates{$service} //= [];
1694 0         0 push(@{$url_templates}, @{$digest_templates});
  0         0  
  0         0  
1695             }
1696             }
1697              
1698 0 0       0 if (defined(my $id_patterns = $opts{id_patterns})) {
1699 0         0 foreach my $pattern (@{$id_patterns}) {
  0         0  
1700             my $reg = {
1701             source => $service,
1702 0         0 (map {$_ => $pattern->{$_}} grep {defined $pattern->{$_}} qw(host path type action)),
  0         0  
1703             prepare => sub {
1704 0     0   0 my ($self, $uri, $rule, $res, $found) = @_;
1705 0         0 my %res = $pattern->{match}->($self, $uri, $pattern);
1706 0 0       0 return undef unless keys %res;
1707 0         0 return \%res;
1708             },
1709 0         0 };
1710              
1711 0   0     0 $reg->{type} //= \&_register_service__type;
1712 0   0     0 $reg->{id} //= \&_register_service__id;
1713 0   0     0 $reg->{action} //= \&_register_service__action;
1714              
1715 0 0       0 foreach my $scheme (map {split /\s*,\s*|\s+/} ref($pattern->{scheme}) ? @{$pattern->{scheme}} : $pattern->{scheme}) {
  0         0  
  0         0  
1716 0 0       0 $scheme = 'https' if $scheme eq 'http';
1717 0   0     0 push(@{$url_parser{$scheme} //= []}, $reg);
  0         0  
1718             }
1719             }
1720             }
1721             }
1722              
1723             # Converters:
1724              
1725             sub _media_subtype_to_uuid {
1726 184     184   396 my ($pkg, $media_subtype) = @_;
1727 184         230 state $uuids = {};
1728 184   33     1096 return $uuids->{$media_subtype} //= Data::Identifier::Generate->generic(namespace => '50d7c533-2d9b-4208-b560-bcbbf75ce3f9', input => lc $media_subtype)->uuid;
1729             }
1730              
1731             sub _id_conv__uuid__gtin {
1732 0     0   0 my ($self, $type_want, $type_name_have, $id) = @_;
1733 0         0 $self->{id}{$type_want} = Data::Identifier::Generate->generic(namespace => 'd95d8b1f-5091-4642-a6b0-a585313915f1', style => 'id-based', request => $id)->uuid;
1734             }
1735              
1736             sub _id_conv__uuid__media_subtype_identifier {
1737 0     0   0 my ($self, $type_want, $type_name_have, $id) = @_;
1738 0         0 $self->{id}{$type_want} = $self->_media_subtype_to_uuid($id);
1739             }
1740              
1741             sub _id_conv__uuid__language_tag_identifier {
1742 0     0   0 my ($self, $type_want, $type_name_have, $id) = @_;
1743 0         0 $self->{id}{$type_want} = Data::Identifier::Generate->generic(namespace => '47dd950c-9089-4956-87c1-54c122533219', style => 'id-based', request => $id)->uuid;
1744             }
1745              
1746             sub _id_conv__uuid__fellig_identifier {
1747 0     0   0 my ($self, $type_want, $type_name_have, $id) = @_;
1748 0         0 my ($table, $num) = $id =~ /^([A-Z]+)([1-9][0-9]*)$/;
1749 0   0     0 my $table_id = Data::Identifier::Generate->generic(namespace => '7a287954-9156-402f-ac3d-92f71956f1aa', input => $fellig_tables{$table} // croak 'Not supported')->uuid;
1750 0         0 $self->{id}{$type_want} = Data::Identifier::Generate->generic(namespace => '7f9670af-21d9-4aa5-afd5-6e9e01261d6c', input => sprintf('%s/%u', $table_id, $num))->uuid;
1751             }
1752              
1753             sub _id_conv__uuid__oid {
1754 2     2   6 my ($self, $type_want, $type_name_have, $id) = @_;
1755 2 50       12 if ($id =~ /^2\.25\.([1-9][0-9]*)$/) {
1756 2         20 my $hex = Math::BigInt->new($1)->as_hex;
1757 2         1638 $hex =~ s/^0x//;
1758 2         10 $hex = ('0' x (32 - length($hex))) . $hex;
1759 2         39 $hex =~ s/^(.{8})(.{4})(.{4})(.{4})(.{12})$/$1-$2-$3-$4-$5/;
1760 2         14 $self->{id}{$type_want} = $hex;
1761             }
1762             }
1763              
1764             sub _id_conv__oid__uuid {
1765 2     2   6 my ($self, $type_want, $type_name_have, $id) = @_;
1766 2         46 $self->{id}{$type_want} = sprintf('2.25.%s', Math::BigInt->new('0x'.$id =~ tr/-//dr))
1767             }
1768              
1769             sub _id_conv__uri__wikidata_identifier {
1770 2     2   7 my ($self, $type_want, $type_name_have, $id) = @_;
1771 2         10 $self->{id}{$type_want} = sprintf('http://www.wikidata.org/entity/%s', $id);
1772             }
1773              
1774             sub _id_conv__uri__uuid {
1775 4     4   14 my ($self, $type_want, $type_name_have, $id) = @_;
1776 4         34 $self->{id}{$type_want} = sprintf('urn:%s:%s', $type_name_have => $id);
1777             }
1778              
1779             *_id_conv__uri__oid = *_id_conv__uri__uuid;
1780              
1781             sub _id_conv__doi__grove_art_online_identifier {
1782 0     0   0 my ($self, $type_want, $type_name_have, $id) = @_;
1783 0         0 $self->{id}{$type_want} = sprintf('10.1093/gao/9781884446054.article.%s', $id);
1784             }
1785              
1786             sub _id_conv__uri__fefe_blog_post_identifier {
1787 0     0   0 my ($self, $type_want, $type_name_have, $id) = @_;
1788 0         0 $self->{id}{$type_want} = sprintf('https://blog.fefe.de/?ts=%s', $id);
1789             }
1790              
1791             # --- Overrides for Data::URIID::Base ---
1792             sub ise {
1793 6     6 1 135 my ($self, %opts) = @_;
1794              
1795             {
1796 6         15 my $type_name = $self->extractor->ise_to_name(type => $self->id_type);
  6         130  
1797 6 100 100     47 if ($type_name eq 'uuid' || $type_name eq 'oid' || $type_name eq 'uri') {
      66        
1798 4         15 return $self->_cast_ise($self->id, $type_name, %opts);
1799             }
1800             }
1801              
1802 2         5 foreach my $type (@{$self->{primary}{ise_order}}) {
  2         8  
1803 2         5 my $id = eval { $self->id($type) };
  2         7  
1804 2 50       14 return $self->_cast_ise($id, $type, %opts) if defined $id;
1805             }
1806              
1807 0 0         return $opts{default} if exists $opts{default};
1808 0           croak 'Identifier does not map to an ISE';
1809             }
1810              
1811             sub displayname {
1812 0     0 1   my ($self, %opts) = @_;
1813 0           my $v = $self->attribute('displayname', default => undef);
1814 0 0         return $v if defined $v;
1815 0           return $self->SUPER::displayname(%opts);
1816             }
1817              
1818             1;
1819              
1820             __END__
1821              
1822             =pod
1823              
1824             =encoding UTF-8
1825              
1826             =head1 NAME
1827              
1828             Data::URIID::Result - Extractor for identifiers from URIs
1829              
1830             =head1 VERSION
1831              
1832             version v0.20
1833              
1834             =head1 SYNOPSIS
1835              
1836             use Data::URIID;
1837              
1838             my $extractor = Data::URIID->new;
1839             my $result = $extractor->lookup( $URI );
1840              
1841             This module provides access to results from a lookup.
1842              
1843             This package inherits from L<Data::URIID::Base>.
1844              
1845             =head1 METHODS
1846              
1847             =head2 id_type
1848              
1849             my $id_type = $result->id_type( [%opts] );
1850              
1851             This method will return the ISE of the id's type if successful or C<die> otherwise.
1852              
1853             This takes the same options as L<Data::URIID::Base/ise>
1854              
1855             =head2 id
1856              
1857             my $id = $result->id;
1858             # or:
1859             my $id = $result->id( $type );
1860             # or:
1861             my $id = $result->id( %opts );
1862              
1863             This method will return the id if successful or C<die> otherwise.
1864              
1865             The following options are defined. All options are optional.
1866              
1867             =over
1868              
1869             =item C<as>
1870              
1871             Return the value as the given type.
1872             This is the package name of the type, C<raw> for plain perl strings.
1873             If the given type is not supported for the given attribute the function C<die>s.
1874              
1875             =item C<online>
1876              
1877             Overrides the L<Data::URIID/"online"> flag used for the lookup if C<as> is set to L<Data::URIID::Result>.
1878             This is very useful to prevent network traffic for auxiliary lookups.
1879              
1880             =item C<type>
1881              
1882             The type of the identifier to return.
1883              
1884             =back
1885              
1886             =head2 attribute
1887              
1888             my $value = $result->attribute( $key, [%opts] );
1889              
1890             Get a attribute of the result or the default or C<die>.
1891             Attributes are subject to the settings passed to L<Data::URIID/"new">.
1892             The default can be supplied via the C<default> option (see below).
1893              
1894             The following attributes are defined:
1895              
1896             =over
1897              
1898             =item C<action>
1899              
1900             The action the original URL was using.
1901              
1902             =item C<altitude>
1903              
1904             The altitude of the item.
1905             The reference system is not specified.
1906              
1907             =item C<best_service>
1908              
1909             The L<Data::URIID::Service> best used with this identifier.
1910             This is normally the service the identifier type originated from.
1911              
1912             =item C<date_of_birth>
1913              
1914             The date of birth of the person or object.
1915              
1916             B<Warning:> This is an experimental attribute and may be removed or changed later!
1917              
1918             =item C<date_of_death>
1919              
1920             The date of death of the person or object.
1921              
1922             B<Warning:> This is an experimental attribute and may be removed or changed later!
1923              
1924             =item C<description>
1925              
1926             A description of the subject.
1927              
1928             =item C<displaycolour>
1929              
1930             A colour that is commonly used to display alongside the item.
1931              
1932             =item C<displayname>
1933              
1934             A name that can be used to display the subject to the user.
1935              
1936             =item C<icon>
1937              
1938             An icon for the item.
1939              
1940             =item C<icon_text>
1941              
1942             A one character alternative to the icon.
1943             This character may be any unicode character.
1944             This also implies that a) the width of the character may vary, b) may use characters outside the range of any 8 bit encoding.
1945              
1946             =item C<latitude>
1947              
1948             The latitude of the item.
1949             The reference system is not specified.
1950              
1951             =item C<longitude>
1952              
1953             The longitude of the item.
1954             The reference system is not specified.
1955              
1956             =item C<media_subtype>
1957              
1958             Media subtype of the item.
1959              
1960             B<Warning:> This is an experimental attribute and may be removed or changed later!
1961              
1962             =item C<roles>
1963              
1964             List of roles returned by the lookup for the subject.
1965             This attribute requires C<list> to be set true.
1966              
1967             =item C<service>
1968              
1969             The L<Data::URIID::Service> the original URL was using.
1970              
1971             =item C<sources>
1972              
1973             The list of L<Data::URIID::Service> that returned data in the lookup. Useful to provide a bibliography.
1974             This attribute requires C<list> to be set true.
1975              
1976             =item C<sex_or_gender>
1977              
1978             The sex or gender of the object. This is useful when addressing people.
1979              
1980             =item C<space_object>
1981              
1982             The object in space (astronomical body) this item is on.
1983              
1984             =item C<thumbnail>
1985              
1986             A thumbnail image that can be used for the item.
1987              
1988             =item C<website>
1989              
1990             A website that represents the item. For example if the item is a company the website of that company.
1991              
1992             =back
1993              
1994             The following options are defined:
1995              
1996             =over
1997              
1998             =item C<as>
1999              
2000             Return the value as the given type.
2001             This is the package name of the type, C<string> for plain perl strings, or C<ise> for an ISE.
2002             If the given type is not supported for the given attribute the function C<die>s.
2003              
2004             =item C<default>
2005              
2006             Returns the given value if no value is found.
2007             This can also be set to C<undef> to allow returning C<undef> in case of no value found instead of C<die>-ing.
2008              
2009             =item C<language_tags>
2010              
2011             Overrides the default language tags from the C<$result-E<gt>extractor> object.
2012             May be an arrayref with a list of exact matches or a string that is parsed as a list (and supers being added).
2013              
2014             =item C<list>
2015              
2016             Sets the function in list mode. List mode is used for special attributes that are lists.
2017             In this mode this method will return a list. C<default> if used needs to be set to some array reference.
2018             This mode is only available with list mode keys.
2019              
2020             =item C<online>
2021              
2022             Overrides the L<Data::URIID/"online"> flag used for the lookup if C<as> is set to L<Data::URIID::Result>.
2023             This is very useful to prevent network traffic for auxiliary lookups.
2024              
2025             =back
2026              
2027             =head2 digest
2028              
2029             my $digest = $result->digest( $algorithm, [%opts] );
2030              
2031             Returns a digest of the referenced file or object. This refers to the result of URLs for the C<fetch> or C<file-fetch> actions.
2032              
2033             Supported algorithms depend on the providing service. Algorithm names are given in the universal tag form but
2034             aliases for names as by L<Digest> are supported.
2035              
2036             Common values include: C<md-5-128>, C<sha-1-160>, C<sha-2-256>, and C<sha-3-512>.
2037              
2038             The following options are defined:
2039              
2040             =over
2041              
2042             =item C<as>
2043              
2044             Return the value as the given type.
2045             This is the package name of the type, C<hex> for hex values, or C<base64> (or C<b64>) for Base64 encoding without padding
2046             and C<base64_padded> for Base64 encoding with padding.
2047             To get an object that is compatible with the L<Digest> API use C<Digest>. Do not try to use specific types such as C<Digest::MD5>.
2048             If the given type is not supported for the given attribute the function C<die>s.
2049              
2050             =item C<default>
2051              
2052             Returns the given value if no value is found.
2053             This can also be set to C<undef> to allow returning C<undef> in case of no value found instead of C<die>-ing.
2054              
2055             =back
2056              
2057             =head2 available_keys
2058              
2059             my @keys = $result->available_keys( $class );
2060              
2061             Returns the list of keys available for C<$class>.
2062             Currently C<attribute> for keys valid for L<"attribute"> and
2063             C<digest> for keys valid for L<"digest"> are supported.
2064              
2065             The caller must not assume that all values for keys returned by this method are actually set/available.
2066             This method may return an empty list.
2067              
2068             On any error this method will C<die>.
2069              
2070             =head2 url
2071              
2072             my $url = $result->url;
2073             # or:
2074             my $url = $result->url( $service );
2075             my $url = $result->url( service => $service ); # the same
2076             # or:
2077             my $url = $result->url( %options );
2078              
2079             Returns a URL for the resource on a given service.
2080             If no service is given the value returned by C<$result-E<gt>attribute('service')> is used.
2081              
2082             This method will return a URL (L<URI> object) if successful or C<die> otherwise.
2083              
2084             The following options are defined:
2085              
2086             =over
2087              
2088             =item C<action>
2089              
2090             Returns an URL for the given action.
2091             Defaults to C<$result-E<gt>attribute('action')>.
2092              
2093             =item C<default>
2094              
2095             Returns the given value if no value is found.
2096             This can also be set to C<undef> to allow returning C<undef> in case of no value found instead of C<die>-ing.
2097              
2098             =item C<service>
2099              
2100             Returns an URL for the given service.
2101             May be an service name, or L<Data::URIID::Service> object.
2102             Defaults to C<$result-E<gt>attribute('service')>.
2103              
2104             =item C<language_tags>
2105              
2106             Overrides the default language tags from the C<$result-E<gt>extractor> object.
2107             May be an arrayref with a list of exact matches or a string that is parsed as a list (and supers being added).
2108              
2109             =back
2110              
2111             =head1 AUTHOR
2112              
2113             Philipp Schafft <lion@cpan.org>
2114              
2115             =head1 COPYRIGHT AND LICENSE
2116              
2117             This software is Copyright (c) 2023-2025 by Philipp Schafft <lion@cpan.org>.
2118              
2119             This is free software, licensed under:
2120              
2121             The Artistic License 2.0 (GPL Compatible)
2122              
2123             =cut