/[suikacvs]/messaging/manakai/lib/Message/URI/Generic.pm
Suika

Contents of /messaging/manakai/lib/Message/URI/Generic.pm

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.5 - (hide annotations) (download)
Sat Nov 4 12:25:15 2006 UTC (18 years ago) by wakaba
Branch: MAIN
CVS Tags: manakai-200612
Changes since 1.4: +27 -21 lines 
++ manakai/bin/ChangeLog	4 Nov 2006 11:58:05 -0000
2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* daf.pl: The |--debug| option no longer set
	obsoleted |$Message::DOM::DOMFeature::DEBUG| option.

++ manakai/lib/Message/Markup/ChangeLog	4 Nov 2006 12:14:20 -0000
2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* Atom.dis (AtomImplementation): It no
        longer inherits the |ManakaiDOMImplementation|; it
        is now expected to be implemented by |DOMImplementation|
        objects.
	(AtomDocument, AtomFeedDocument, AtomEntryDocument): It no
        longer inherits the |ManakaiDOMDocument|; it
        is now expected to be implemented by |Document|
        objects.

	* SuikaWikiConfig21.dis (SWCFGImplementation): It no
        longer inherits the |DOMImplementation|; it
        is now expected to be implemented by |DOMImplementation|
        objects.

++ manakai/lib/Message/Util/ChangeLog	4 Nov 2006 12:18:18 -0000
2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* DIS.dis (ManakaiDISImplementation): It no longer
	inherits |ManakaiDISImplementationValue|,
	|ManakaiDISImplementationPerl|, and |ManakaiSWCFGImplementation|
	interfaces.  The class is now expected to be implemented
	by |DOMImplementation| objects.

	* PerlCode.dis (addImplementedFeature, addImplementedElementType):
	New methods.
	(PCHasFeature, PCElementType): New interfaces.
	(PCDocument): It no longer inherits the |ManakaiDOMDocument|; it
        is now expected to be implemented by |Document|
        objects.
	(PCImplementation): It no longer inherits the |ManakaiDOMImplementation|;
	it is now expected to be implemented by |DOMImplementation|
	objects.

++ manakai/lib/Message/Util/DIS/ChangeLog	4 Nov 2006 12:24:32 -0000
2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* DNLite.dis (DISImplementationDNLite): It no
	longer inherits the |ManakaiDISImplementation|; it
        is now expected to be implemented by |DOMImplementation| objects.

	* DPG.dis (DPGDocument): It no longer inherits
	the |ManakaiDOMDocument| class; it is now expected to be
	implemented by all |Document| objects.

	* Perl.dis (DISImplementationPerl): It is now
	expected to be implemented by all |DOMImplementation| objects.
	(plCodeFragment): Support for the |p:require|
	property is added.  It no longer output |ClassInfo|
	for classes for specific element types; instead,
	it invoke |add_implemented_element_type| method.

	* Test.dis (DTImplementation): It no longer
	inherits the |MinimumImplementation| interface;
	instead, it is expected to be implemented
	by all |DOMImplementation| objects.

	* Value.dis (DISImplementationValue): It is now
	expected to be implemented by all |DOMImplementation| objects.

++ manakai/lib/Message/Util/AutoLoad/ChangeLog	4 Nov 2006 12:19:43 -0000
2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* Config.pm (register_all, save): Support for |feature|
	and |element_type| is added.

	* Registry-initial.pm: Updated.

	* .cvsignore: New file.


	* Registry-initial.pm: New module.
++ manakai/lib/Message/DOM/ChangeLog	4 Nov 2006 12:12:45 -0000
	explicitly inherits |urigen:ManakaiURIImplementation| (and
	the |f:ManakaiMinimumImplementation| class inherited
	by it).  The |f:Minimum| feature is ever implemented
	for compatibility (but is expected to be removed).
	Internal methods such as |___report_error| are copied from
	obsolete |f:MinimumImplementation| class.  DOM3
	methods |hasFeature| and |getFeature| are also
	moved from that class, but they now support no
	foreign classes.

	* DOMFeature.dis (ManakaiImplementationSource): It
	now |p:require|s |Message::Util::AutoLoad::Registry|.
	The class no longer support classes
	other than |ManakaiDOMImplementation|.  Note
	that the |ImplementationRegistry| object does continue
	to support foreign classes via foreign classes
	implementing |ImplementationSource|
	or |DOMImplementationSource| interface.
	(MinimumImplementation): Removed.

	* DOMLS.dis (ManakaiDOMImplementationLS): It no
	longer inherit the |ManakaiDOMImplementation|; it
	is now expected to be implemented by |DOMImplementation|
	objects.

	* DOMMain.dis (null): Removed.

	* Document.dis (___create_node_ref): It no
	longer support foreign classes other
	than |Message::DOM::Document::ManakaiDOMDocument|.
	Note that document format specific DOM
	interfaces, if supported, should be
	all instances of the |Document| interface
	in the implementation, as defined
	in the Web Applications 1.0 specification (where
	the |HTMLDocument| interface must be implemented
	by all |Document| objects, even if the |Document|
	contains no HTML element).

	* GenericLS.dis (GLSImplementation): It no
        longer inherit the |MinimumImplementation|; it
        is now expected to be implemented by |DOMImplementation|
        objects.
	(createGLSParser, createGLSSerializer): Load
	module implementing parser or serializer
	if necessary.

	* Traversal.dis (ManakaiDOMDocumentTraversal): It no
	longer inherits the |ManakaiDOMDocument|; it
	is now expected to be implemented by |Document|
	objects.

	* XDP.dis (XDPDocument): It no longer
	inherits the |Document|; it is now expected
	to be implemented by all |Document| objects.

	* XDoctype.dis (ManakaiDOMDocumentXDoctype): It no
        longer inherits the |ManakaiDOMDocument|; it
        is now expected to be implemented by |Document|
        objects.

2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* DOMCore.dis (ManakaiDOMImplementation): No longer
++ manakai/lib/Message/URI/ChangeLog	4 Nov 2006 12:14:59 -0000
2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* Generic.dis (URIImplementation): It no
	longer inherits the |MinimumImplementation|; it
	is now expected to be implemented by |DOMImplementation|
	objects.

++ manakai/lib/Message/Charset/ChangeLog	4 Nov 2006 11:56:24 -0000
2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* Encode.dis (MCEncodeImplementation): It no
	longer inherit the |MinimumImplementation|; it
	is now expected to be implemented by |DOMImplementation|
	objects.

++ manakai/lib/manakai/ChangeLog	4 Nov 2006 12:25:03 -0000
2006-11-04  Wakaba  <wakaba@suika.fam.cx>

	* DISPerl.dis (p:require, p:use): New properties.
1 wakaba 1.1 #!/usr/bin/perl
2     ## This file is automatically generated
3 wakaba 1.5 ## at 2006-11-04T10:07:34+00:00,
4     ## from file "Generic.dis",
5 wakaba 1.1 ## module <http://suika.fam.cx/~wakaba/archive/2005/manakai/URI/Generic>,
6     ## for <http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#ManakaiDOMLatest>.
7     ## Don't edit by hand!
8     use strict;
9 wakaba 1.5 require Message::DOM::DOMCore;
10 wakaba 1.1 require Message::Util::Error::DOMException;
11     package Message::URI::Generic;
12 wakaba 1.5 our $VERSION = 20061104.1007;
13 wakaba 1.2 package Message::URI::IFLatest::URIImplementation;
14 wakaba 1.5 our $VERSION = 20061104.1007;
15 wakaba 1.1 package Message::URI::Generic::ManakaiURIImplementation;
16 wakaba 1.5 our $VERSION = 20061104.1007;
17     push our @ISA, 'Message::DOM::IFLatest::DOMImplementation',
18     'Message::DOM::IF::DOMImplementation',
19     'Message::DOM::IFLatest::DOMImplementation',
20 wakaba 1.2 'Message::URI::IF::URIImplementation',
21     'Message::URI::IFLatest::URIImplementation';
22 wakaba 1.5 push @Message::DOM::DOMCore::ManakaiDOMImplementation::ISA, q<Message::URI::Generic::ManakaiURIImplementation> unless Message::DOM::DOMCore::ManakaiDOMImplementation->isa (q<Message::URI::Generic::ManakaiURIImplementation>);
23 wakaba 1.1 sub create_uri_reference ($$) {
24     my ($self, $uri) = @_;
25     my $r;
26    
27     {
28    
29     if
30     (UNIVERSAL::isa ($uri,
31 wakaba 1.2 'Message::URI::IFLatest::URIReference'
32 wakaba 1.1 )) {
33    
34    
35     {
36    
37     local $Error::Depth = $Error::Depth + 1;
38    
39     {
40    
41    
42    
43     $r = $uri->
44     clone_uri_reference
45     ;
46    
47    
48    
49 wakaba 1.4 }
50 wakaba 1.1
51    
52     ;}
53    
54     ;
55     } elsif (ref $uri eq 'SCALAR') {
56     $r = bless $uri,
57     'Message::URI::Generic::ManakaiURIReference'
58     ;
59     } else {
60     my $v = "$uri";
61     $r = bless \$v,
62     'Message::URI::Generic::ManakaiURIReference'
63     ;
64     }
65    
66    
67 wakaba 1.4 }
68 wakaba 1.1 $r}
69     $Message::DOM::ImplFeature{q<Message::URI::Generic::ManakaiURIImplementation>}->{q<http://suika.fam.cx/www/2006/feature/uri>}->{q<4.0>} ||= 1;
70     $Message::DOM::ImplFeature{q<Message::URI::Generic::ManakaiURIImplementation>}->{q<http://suika.fam.cx/www/2006/feature/uri>}->{q<>} = 1;
71 wakaba 1.5 $Message::DOM::DOMFeature::ClassInfo->{q<Message::URI::Generic::ManakaiURIImplementation>}->{has_feature} = {'',
72 wakaba 1.2 {'',
73     '1'},
74     'http://suika.fam.cx/www/2006/feature/uri',
75     {'',
76     '1',
77     '4.0',
78     '1'},
79 wakaba 1.5 'xml',
80 wakaba 1.2 {'',
81     '1',
82 wakaba 1.5 '1.0',
83     '1',
84     '2.0',
85     '1',
86 wakaba 1.2 '3.0',
87 wakaba 1.5 '1'},
88     'xmlversion',
89     {'',
90     '1',
91     '1.0',
92     '1',
93     '1.1',
94 wakaba 1.2 '1'}};
95 wakaba 1.5 $Message::DOM::ClassPoint{q<Message::URI::Generic::ManakaiURIImplementation>} = 12.1;
96 wakaba 1.1 $Message::DOM::ManakaiDOMImplementationSource::SourceClass{q<Message::URI::Generic::ManakaiURIImplementation>} = 1;
97 wakaba 1.2 $Message::DOM::DOMFeature::ClassInfo->{q<Message::DOM::DOMFeature::ManakaiMinimumImplementation>}->{compat_class}->{q<Message::URI::Generic::ManakaiURIImplementation>} = 1;
98     package Message::URI::IFLatest::URIReference;
99 wakaba 1.5 our $VERSION = 20061104.1007;
100 wakaba 1.1 package Message::URI::Generic::ManakaiURIReference;
101 wakaba 1.5 our $VERSION = 20061104.1007;
102 wakaba 1.2 push our @ISA, 'Message::URI::IF::URIReference',
103     'Message::URI::IFLatest::URIReference';
104 wakaba 1.1 sub _new ($$) {
105     my ($self, $uri) = @_;
106     my $r;
107    
108     {
109    
110     my
111     $v;
112     if (ref $uri) {
113     if (UNIVERSAL::isa ($uri,
114 wakaba 1.2 'Message::URI::IFLatest::URIReference'
115 wakaba 1.1 )) {
116     my $w = $$uri;
117     $v = \$w;
118     } elsif (ref $uri eq 'SCALAR') {
119     $v = $uri;
120     } else {
121     $v = \$uri;
122     }
123     } else {
124     $v = \$uri;
125     }
126     $r = bless $v,
127     'Message::URI::Generic::ManakaiURIReference'
128     ;
129    
130    
131 wakaba 1.4 }
132 wakaba 1.1 $r}
133     sub uri_reference ($;$) {
134     if (@_ == 1) {my ($self) = @_;
135     my $r = '';
136    
137     {
138    
139    
140     $r = $$self;
141    
142    
143 wakaba 1.4 }
144 wakaba 1.1 $r;
145     } else {my ($self, $given) = @_;
146    
147     {
148    
149    
150     $$self = $given;
151    
152    
153     {
154    
155     local $Error::Depth = $Error::Depth + 1;
156    
157     {
158    
159    
160    
161     $self->
162     _on_scheme_changed
163     ;
164    
165    
166    
167 wakaba 1.4 }
168 wakaba 1.1
169    
170     ;}
171    
172     ;
173    
174    
175 wakaba 1.4 }
176 wakaba 1.1 }
177     }
178     sub stringify ($) {
179     my ($self) = @_;
180     my $r = '';
181    
182     {
183    
184    
185     $r = $$self;
186    
187    
188 wakaba 1.4 }
189 wakaba 1.1 $r}
190     sub _on_scheme_changed ($) {
191     my ($self) = @_;
192    
193    
194     }
195     sub _on_authority_changed ($) {
196     my ($self) = @_;
197    
198    
199     }
200     sub _on_path_changed ($) {
201     my ($self) = @_;
202    
203    
204     }
205     sub _on_query_changed ($) {
206     my ($self) = @_;
207    
208    
209     }
210     sub _on_fragment_changed ($) {
211     my ($self) = @_;
212    
213    
214     }
215     sub uri_scheme ($;$) {
216     if (@_ == 1) {my ($self) = @_;
217     my $r = '';
218    
219     {
220    
221     if
222     ($$self =~ m!^([^/?#:]+):!) {
223     $r = $1;
224     } else {
225     $r =
226     undef
227     ;
228     }
229    
230    
231 wakaba 1.4 }
232 wakaba 1.1 $r;
233     } else {my ($self, $given) = @_;
234    
235     {
236    
237     if
238     (defined $given) {
239     if (length $given and $given !~ m![/?#:]!) {
240     unless ($$self =~ s!^[^/?#:]+:!$given:!) {
241     $$self = $given . ':' . $$self;
242    
243    
244     {
245    
246     local $Error::Depth = $Error::Depth + 1;
247    
248     {
249    
250    
251    
252     $self->
253     _on_scheme_changed
254     ;
255    
256    
257    
258 wakaba 1.4 }
259 wakaba 1.1
260    
261     ;}
262    
263     ;
264     }
265     }
266     } else {
267     $$self =~ s!^[^/?#:]+:!!;
268    
269    
270     {
271    
272     local $Error::Depth = $Error::Depth + 1;
273    
274     {
275    
276    
277    
278     $self->
279     _on_scheme_changed
280     ;
281    
282    
283    
284 wakaba 1.4 }
285 wakaba 1.1
286    
287     ;}
288    
289     ;
290     }
291    
292    
293 wakaba 1.4 }
294 wakaba 1.1 }
295     }
296     sub uri_authority ($;$) {
297     if (@_ == 1) {my ($self) = @_;
298     my $r = '';
299    
300     {
301    
302     if
303     ($$self =~ m!^(?:[^:/?#]+:)?(?://([^/?#]*))?!) {
304     $r = $1;
305     } else {
306     $r =
307     undef
308     ;
309     }
310    
311    
312 wakaba 1.4 }
313 wakaba 1.1 $r;
314     } else {my ($self, $given) = @_;
315    
316     {
317    
318     if
319     (defined $given) {
320     unless ($given =~ m![/?#]!) {
321     unless ($$self =~ s!^((?:[^:/?#]+:)?)(?://[^/?#]*)?!$1//$given!) {
322     $$self = '//' . $given;
323    
324    
325     {
326    
327     local $Error::Depth = $Error::Depth + 1;
328    
329     {
330    
331    
332    
333     $self->
334     _on_authority_changed
335     ;
336    
337    
338    
339 wakaba 1.4 }
340 wakaba 1.1
341    
342     ;}
343    
344     ;
345     }
346     }
347     } else {
348     if ($$self =~ s!^((?:[^:/?#]+:)?)(?://[^/?#]*)?!$1!) {
349    
350    
351     {
352    
353     local $Error::Depth = $Error::Depth + 1;
354    
355     {
356    
357    
358    
359     $self->
360     _on_authority_changed
361     ;
362    
363    
364    
365 wakaba 1.4 }
366 wakaba 1.1
367    
368     ;}
369    
370     ;
371     }
372     }
373    
374    
375 wakaba 1.4 }
376 wakaba 1.1 }
377     }
378     sub uri_userinfo ($;$) {
379     if (@_ == 1) {my ($self) = @_;
380     my $r = '';
381    
382     {
383    
384    
385     {
386    
387     local $Error::Depth = $Error::Depth + 1;
388    
389     {
390    
391    
392     my
393     $v = $self->
394     uri_authority
395     ;
396     if (defined $v and $v =~ /^([^@\[\]]*)\@/) {
397     $r = $1;
398     } else {
399     $r =
400     undef
401     ;
402     }
403    
404    
405    
406 wakaba 1.4 }
407 wakaba 1.1
408    
409     ;}
410    
411     ;
412    
413    
414 wakaba 1.4 }
415 wakaba 1.1 $r;
416     } else {my ($self, $given) = @_;
417    
418     {
419    
420    
421     {
422    
423     local $Error::Depth = $Error::Depth + 1;
424    
425     {
426    
427    
428     my
429     $auth = $self->
430     uri_authority
431     ;
432     if (defined $auth) {
433     if (defined $given) {
434     unless ($auth =~ s/^[^\@\[\]]*\@/$given\@/) {
435     $auth = $given . '@' . $auth;
436     }
437     } else {
438     $auth =~ s/^[^\@\[\]]*\@//;
439     }
440     $self->
441     uri_authority
442     ($auth);
443     } else {
444     if (defined $given and $given !~ /[\/#?\@\[\]]/) {
445     $self->
446     uri_authority
447     ($given.'@');
448     }
449     }
450    
451    
452    
453 wakaba 1.4 }
454 wakaba 1.1
455    
456     ;}
457    
458     ;
459    
460    
461 wakaba 1.4 }
462 wakaba 1.1 }
463     }
464     sub uri_host ($;$) {
465     if (@_ == 1) {my ($self) = @_;
466     my $r = '';
467    
468     {
469    
470    
471     {
472    
473     local $Error::Depth = $Error::Depth + 1;
474    
475     {
476    
477    
478     my
479     $v = $self->
480     uri_authority
481     ;
482     if (defined $v) {
483     $v =~ s/^[^@\[\]]*\@//;
484     $v =~ s/:[0-9]*\z//;
485     $r = $v;
486     } else {
487     $r =
488     undef
489     ;
490     }
491    
492    
493    
494 wakaba 1.4 }
495 wakaba 1.1
496    
497     ;}
498    
499     ;
500    
501    
502 wakaba 1.4 }
503 wakaba 1.1 $r;
504     } else {my ($self, $given) = @_;
505    
506     {
507    
508    
509     {
510    
511     local $Error::Depth = $Error::Depth + 1;
512    
513     {
514    
515    
516     my
517     $auth = $self->
518     uri_authority
519     ;
520     if (defined $auth) {
521     my $v = '';
522     if ($auth =~ /^([^\@\[\]]*\@)/) {
523     $v .= $1;
524     }
525     $v .= $given;
526     if ($auth =~ /(:[0-9]*)\z/) {
527     $v .= $1;
528     }
529     $self->
530     uri_authority
531     ($v);
532     } elsif ($given !~ /[\/\@:#?]/) {
533     $self->
534     uri_authority
535     ($given);
536     }
537    
538    
539    
540 wakaba 1.4 }
541 wakaba 1.1
542    
543     ;}
544    
545     ;
546    
547    
548 wakaba 1.4 }
549 wakaba 1.1 }
550     }
551     sub uri_port ($;$) {
552     if (@_ == 1) {my ($self) = @_;
553     my $r = '';
554    
555     {
556    
557    
558     {
559    
560     local $Error::Depth = $Error::Depth + 1;
561    
562     {
563    
564    
565     my
566     $v = $self->
567     uri_authority
568     ;
569     if (defined $v and $v =~ /:([0-9]*)\z/) {
570     $r = $1;
571     } else {
572     $r =
573     undef
574     ;
575     }
576    
577    
578    
579 wakaba 1.4 }
580 wakaba 1.1
581    
582     ;}
583    
584     ;
585    
586    
587 wakaba 1.4 }
588 wakaba 1.1 $r;
589     } else {my ($self, $given) = @_;
590    
591     {
592    
593    
594     {
595    
596     local $Error::Depth = $Error::Depth + 1;
597    
598     {
599    
600    
601     my
602     $auth = $self->
603     uri_authority
604     ;
605     if (defined $auth) {
606     if (defined $given) {
607     unless ($auth =~ s/:[0-9]*\z/:$given/) {
608     $auth = $auth . ':' . $given;
609     }
610     } else {
611     $auth =~ s/:[0-9]*\z//;
612     }
613     $self->
614     uri_authority
615     ($auth);
616     } else {
617     if (defined $given and $given =~ /\A[0-9]*\z/) {
618     $self->
619     uri_authority
620     (':'.$given);
621     }
622     }
623    
624    
625    
626 wakaba 1.4 }
627 wakaba 1.1
628    
629     ;}
630    
631     ;
632    
633    
634 wakaba 1.4 }
635 wakaba 1.1 }
636     }
637     sub uri_path ($;$) {
638     if (@_ == 1) {my ($self) = @_;
639     my $r = '';
640    
641     {
642    
643     if
644     ($$self =~ m!\A(?:[^:/?#]+:)?(?://[^/?#]*)?([^?#]*)!) {
645     $r = $1;
646     }
647    
648    
649 wakaba 1.4 }
650 wakaba 1.1 $r;
651     } else {my ($self, $given) = @_;
652    
653     {
654    
655     if
656     ($given !~ /[?#]/ and
657     $$self =~ m!^((?:[^:/?#]+:)?(?://[^/?#]*)?)[^?#]*((?:\?[^#]*)?(?:#.*)?)!s) {
658     $$self = $1.$given.$2;
659    
660    
661     {
662    
663     local $Error::Depth = $Error::Depth + 1;
664    
665     {
666    
667    
668    
669     $self->
670     _on_path_changed
671     ;
672    
673    
674    
675 wakaba 1.4 }
676 wakaba 1.1
677    
678     ;}
679    
680     ;
681     }
682    
683    
684 wakaba 1.4 }
685 wakaba 1.1 }
686     }
687     sub uri_query ($;$) {
688     if (@_ == 1) {my ($self) = @_;
689     my $r = '';
690    
691     {
692    
693     if
694     ($$self =~ m!^(?:[^:/?#]+:)?(?://[^/?#]*)?[^?#]*(?:\?([^#]*))?!s) {
695     $r = $1;
696     } else {
697     $r =
698     undef
699     ;
700     }
701    
702    
703 wakaba 1.4 }
704 wakaba 1.1 $r;
705     } else {my ($self, $given) = @_;
706    
707     {
708    
709     if
710     ((not defined $given or $given !~ /#/) and
711     $$self =~ m!^((?:[^:/?#]+:)?(?://[^/?#]*)?[^?#]*)(?:\?[^#]*)?((?:#.*)?)!s) {
712     $$self = defined $given ? $1.'?'.$given.$2 : $1.$2;
713    
714    
715     {
716    
717     local $Error::Depth = $Error::Depth + 1;
718    
719     {
720    
721    
722    
723     $self->
724     _on_query_changed
725     ;
726    
727    
728    
729 wakaba 1.4 }
730 wakaba 1.1
731    
732     ;}
733    
734     ;
735     }
736    
737    
738 wakaba 1.4 }
739 wakaba 1.1 }
740     }
741     sub uri_fragment ($;$) {
742     if (@_ == 1) {my ($self) = @_;
743     my $r = '';
744    
745     {
746    
747     if
748     ($$self =~ m!^(?:[^:/?#]+:)?(?://[^/?#]*)?[^?#]*(?:\?[^#]*)?(?:#(.*))?!s) {
749     $r = $1;
750     } else {
751     $r =
752     undef
753     ;
754     }
755    
756    
757 wakaba 1.4 }
758 wakaba 1.1 $r;
759     } else {my ($self, $given) = @_;
760    
761     {
762    
763     if
764     ($$self =~ m!^((?:[^:/?#]+:)?(?://[^/?#]*)?[^?#]*(?:\?[^#]*)?)(?:#.*)?!s) {
765     $$self = defined $given ? $1 . '#' . $given : $1;
766    
767    
768     {
769    
770     local $Error::Depth = $Error::Depth + 1;
771    
772     {
773    
774    
775    
776     $self->
777     _on_fragment_changed
778     ;
779    
780    
781    
782 wakaba 1.4 }
783 wakaba 1.1
784    
785     ;}
786    
787     ;
788     }
789    
790    
791 wakaba 1.4 }
792 wakaba 1.1 }
793     }
794     sub get_uri_path_segment ($$) {
795     my ($self, $index) = @_;
796     my $r = '';
797    
798     {
799    
800    
801     {
802    
803     local $Error::Depth = $Error::Depth + 1;
804    
805     {
806    
807    
808    
809     $r = [split m!/!, $self->
810     uri_path
811     , -1]->[$index];
812     $r = '' if not defined $r and
813     ($index == 0 or $index == -1); # If path is empty
814    
815    
816    
817 wakaba 1.4 }
818 wakaba 1.1
819    
820     ;}
821    
822     ;
823    
824    
825 wakaba 1.4 }
826 wakaba 1.1 $r}
827     sub set_uri_path_segment ($$;$) {
828     my ($self, $index, $newValue) = @_;
829    
830     {
831    
832    
833     {
834    
835     local $Error::Depth = $Error::Depth + 1;
836    
837     {
838    
839    
840     my
841     @p = split m!/!, $self->
842     uri_path
843     , -1;
844     if (defined $newValue) {
845     $p[$index] = $newValue;
846     } else {
847     splice @p, $index, 1;
848     }
849     no warnings 'uninitialized';
850     $self->
851     uri_path
852     (join '/', @p);
853    
854    
855    
856 wakaba 1.4 }
857 wakaba 1.1
858    
859     ;}
860    
861     ;
862    
863    
864 wakaba 1.4 }
865 wakaba 1.1 }
866     sub is_uri ($;$) {
867     if (@_ == 1) {my ($self) = @_;
868     my $r = 0;
869    
870     {
871    
872    
873     {
874    
875     local $Error::Depth = $Error::Depth + 1;
876    
877     {
878    
879    
880    
881     $r = $self->
882     is_uri_3986
883     ;
884    
885    
886    
887 wakaba 1.4 }
888 wakaba 1.1
889    
890     ;}
891    
892     ;
893    
894    
895 wakaba 1.4 }
896 wakaba 1.1 $r;
897     } else {my ($self) = @_;
898     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_uri';
899     }
900     }
901     sub is_uri_3986 ($;$) {
902     if (@_ == 1) {my ($self) = @_;
903     my $r = 0;
904    
905     {
906    
907     my
908     $v = $$self;
909     V: {
910     ## -- Scheme
911     unless ($v =~ s/^[A-Za-z][A-Za-z0-9+.-]*://s) {
912     last V;
913     }
914    
915     ## -- Fragment
916     if ($v =~ s/#(.*)\z//s) {
917     my $w = $1;
918     unless ($w =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/?-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}) {
919     last V;
920     }
921     }
922    
923     ## -- Query
924     if ($v =~ s/\?(.*)\z//s) {
925     my $w = $1;
926     unless ($w =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/?-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}) {
927     last V;
928     }
929     }
930    
931     ## -- Authority
932     if ($v =~ s!^//([^/]*)!!s) {
933     my $w = $1;
934     $w =~ s/^(?>[A-Za-z0-9._~!\$&'()*+,;=:-]|%[0-9A-Fa-f][0-9A-Fa-f])*\@//os;
935     $w =~ s/:[0-9]*\z//;
936     if ($w =~ /^\[(.*)\]\z/s) {
937     my $x = $1;
938     unless ($x =~ /\A[vV][0-9A-Fa-f]+\.[A-Za-z0-9._~!\$&'()*+,;=:-]+\z/) {
939     ## IPv6address
940     my $isv6;
941    
942    
943     {
944    
945     my
946     $ipv4 = qr/(?>0|1[0-9]{0,2}|2(?>[0-4][0-9]?|5[0-5]?|[6-9])?|[3-9][0-9]?)(?>\.(?>0|1[0-9]{0,2}|2(?>[0-4][0-9]?|5[0-5]?|[6-9])?|[3-9][0-9]?)){3}/;
947     my $h16 = qr/[0-9A-Fa-f]{1,4}/;
948     if ($x =~ s/(?:$ipv4|$h16)\z//o) {
949     if ($x =~ /\A(?>$h16:){6}\z/o or
950     $x =~ /\A::(?>$h16:){0,5}\z/o or
951     $x =~ /\A${h16}::(?>$h16:){4}\z/o or
952     $x =~ /\A$h16(?::$h16)?::(?>$h16:){3}\z/o or
953     $x =~ /\A$h16(?::$h16){0,2}::(?>$h16:){2}\z/o or
954     $x =~ /\A$h16(?::$h16){0,3}::$h16:\z/o or
955     $x =~ /\A$h16(?::$h16){0,4}::\z/o) {
956     $isv6 =
957     1
958     ;
959     }
960     } elsif ($x =~ s/$h16\z//o) {
961     if ($x eq '' or $x =~ /\A$h16(?>:$h16){0,5}\z/o) {
962     $isv6 =
963     1
964     ;
965     }
966     } elsif ($x =~ s/::\z//o) {
967     if ($x eq '' or $x =~ /\A$h16(?>:$h16){0,6}\z/o) {
968     $isv6 =
969     1
970     ;
971     }
972     }
973    
974    
975 wakaba 1.4 }
976 wakaba 1.1
977     ;
978     last V unless $isv6;
979     }
980     } else {
981     unless ($w =~ /\A(?>[A-Za-z0-9._~!\$&'()*+,;=-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z/) {
982     last V;
983     }
984     }
985     }
986    
987     ## -- Path
988     unless ($v =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}s) {
989     last V;
990     }
991    
992     $r =
993     1
994     ;
995     } # V
996    
997    
998 wakaba 1.4 }
999 wakaba 1.1 $r;
1000     } else {my ($self) = @_;
1001     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_uri_3986';
1002     }
1003     }
1004     sub is_relative_reference ($;$) {
1005     if (@_ == 1) {my ($self) = @_;
1006     my $r = 0;
1007    
1008     {
1009    
1010    
1011     {
1012    
1013     local $Error::Depth = $Error::Depth + 1;
1014    
1015     {
1016    
1017    
1018    
1019     $r = $self->
1020     is_relative_reference_3986
1021     ;
1022    
1023    
1024    
1025 wakaba 1.4 }
1026 wakaba 1.1
1027    
1028     ;}
1029    
1030     ;
1031    
1032    
1033 wakaba 1.4 }
1034 wakaba 1.1 $r;
1035     } else {my ($self) = @_;
1036     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_relative_reference';
1037     }
1038     }
1039     sub is_relative_reference_3986 ($;$) {
1040     if (@_ == 1) {my ($self) = @_;
1041     my $r = 0;
1042    
1043     {
1044    
1045     my
1046     $v = $$self;
1047     V: {
1048     ## -- No scheme
1049     if ($v =~ s!^[^/?#]*:!!s) {
1050     last V;
1051     }
1052    
1053     ## -- Fragment
1054     if ($v =~ s/#(.*)\z//s) {
1055     my $w = $1;
1056     unless ($w =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/?-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}) {
1057     last V;
1058     }
1059     }
1060    
1061     ## -- Query
1062     if ($v =~ s/\?(.*)\z//s) {
1063     my $w = $1;
1064     unless ($w =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/?-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}) {
1065     last V;
1066     }
1067     }
1068    
1069     ## -- Authority
1070     if ($v =~ s!^//([^/]*)!!s) {
1071     my $w = $1;
1072     $w =~ s/^(?>[A-Za-z0-9._~!\$&'()*+,;=:-]|%[0-9A-Fa-f][0-9A-Fa-f])*\@//os;
1073     $w =~ s/:[0-9]*\z//;
1074     if ($w =~ /^\[(.*)\]\z/s) {
1075     my $x = $1;
1076     unless ($x =~ /\A[vV][0-9A-Fa-f]+\.[A-Za-z0-9._~!\$&'()*+,;=:-]+\z/) {
1077     ## IPv6address
1078     my $isv6;
1079    
1080    
1081     {
1082    
1083     my
1084     $ipv4 = qr/(?>0|1[0-9]{0,2}|2(?>[0-4][0-9]?|5[0-5]?|[6-9])?|[3-9][0-9]?)(?>\.(?>0|1[0-9]{0,2}|2(?>[0-4][0-9]?|5[0-5]?|[6-9])?|[3-9][0-9]?)){3}/;
1085     my $h16 = qr/[0-9A-Fa-f]{1,4}/;
1086     if ($x =~ s/(?:$ipv4|$h16)\z//o) {
1087     if ($x =~ /\A(?>$h16:){6}\z/o or
1088     $x =~ /\A::(?>$h16:){0,5}\z/o or
1089     $x =~ /\A${h16}::(?>$h16:){4}\z/o or
1090     $x =~ /\A$h16(?::$h16)?::(?>$h16:){3}\z/o or
1091     $x =~ /\A$h16(?::$h16){0,2}::(?>$h16:){2}\z/o or
1092     $x =~ /\A$h16(?::$h16){0,3}::$h16:\z/o or
1093     $x =~ /\A$h16(?::$h16){0,4}::\z/o) {
1094     $isv6 =
1095     1
1096     ;
1097     }
1098     } elsif ($x =~ s/$h16\z//o) {
1099     if ($x eq '' or $x =~ /\A$h16(?>:$h16){0,5}\z/o) {
1100     $isv6 =
1101     1
1102     ;
1103     }
1104     } elsif ($x =~ s/::\z//o) {
1105     if ($x eq '' or $x =~ /\A$h16(?>:$h16){0,6}\z/o) {
1106     $isv6 =
1107     1
1108     ;
1109     }
1110     }
1111    
1112    
1113 wakaba 1.4 }
1114 wakaba 1.1
1115     ;
1116     last V unless $isv6;
1117     }
1118     } else {
1119     unless ($w =~ /\A(?>[A-Za-z0-9._~!\$&'()*+,;=-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z/) {
1120     last V;
1121     }
1122     }
1123     }
1124    
1125     ## -- Path
1126     unless ($v =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}s) {
1127     last V;
1128     }
1129    
1130     $r =
1131     1
1132     ;
1133     } # V
1134    
1135    
1136 wakaba 1.4 }
1137 wakaba 1.1 $r;
1138     } else {my ($self) = @_;
1139     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_relative_reference_3986';
1140     }
1141     }
1142     sub is_uri_reference ($;$) {
1143     if (@_ == 1) {my ($self) = @_;
1144     my $r = 0;
1145    
1146     {
1147    
1148    
1149     {
1150    
1151     local $Error::Depth = $Error::Depth + 1;
1152    
1153     {
1154    
1155    
1156    
1157     $r = $self->
1158     is_uri_reference_3986
1159     ;
1160    
1161    
1162    
1163 wakaba 1.4 }
1164 wakaba 1.1
1165    
1166     ;}
1167    
1168     ;
1169    
1170    
1171 wakaba 1.4 }
1172 wakaba 1.1 $r;
1173     } else {my ($self) = @_;
1174     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_uri_reference';
1175     }
1176     }
1177     sub is_uri_reference_3986 ($;$) {
1178     if (@_ == 1) {my ($self) = @_;
1179     my $r = 0;
1180    
1181     {
1182    
1183    
1184     {
1185    
1186     local $Error::Depth = $Error::Depth + 1;
1187    
1188     {
1189    
1190    
1191    
1192     $r = $self->
1193     is_uri_3986
1194     ||
1195     $self->
1196     is_relative_reference_3986
1197     ;
1198    
1199    
1200    
1201 wakaba 1.4 }
1202 wakaba 1.1
1203    
1204     ;}
1205    
1206     ;
1207    
1208    
1209 wakaba 1.4 }
1210 wakaba 1.1 $r;
1211     } else {my ($self) = @_;
1212     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_uri_reference_3986';
1213     }
1214     }
1215     sub is_absolute_uri ($;$) {
1216     if (@_ == 1) {my ($self) = @_;
1217     my $r = 0;
1218    
1219     {
1220    
1221    
1222     {
1223    
1224     local $Error::Depth = $Error::Depth + 1;
1225    
1226     {
1227    
1228    
1229    
1230     $r = $self->
1231     is_absolute_uri_3986
1232     ;
1233    
1234    
1235    
1236 wakaba 1.4 }
1237 wakaba 1.1
1238    
1239     ;}
1240    
1241     ;
1242    
1243    
1244 wakaba 1.4 }
1245 wakaba 1.1 $r;
1246     } else {my ($self) = @_;
1247     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_absolute_uri';
1248     }
1249     }
1250     sub is_absolute_uri_3986 ($;$) {
1251     if (@_ == 1) {my ($self) = @_;
1252     my $r = 0;
1253    
1254     {
1255    
1256    
1257     {
1258    
1259     local $Error::Depth = $Error::Depth + 1;
1260    
1261     {
1262    
1263    
1264    
1265     $r = $$self !~ /#/ && $self->
1266     is_uri_3986
1267     ;
1268    
1269    
1270    
1271 wakaba 1.4 }
1272 wakaba 1.1
1273    
1274     ;}
1275    
1276     ;
1277    
1278    
1279 wakaba 1.4 }
1280 wakaba 1.1 $r;
1281     } else {my ($self) = @_;
1282     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_absolute_uri_3986';
1283     }
1284     }
1285     sub is_empty_reference ($;$) {
1286     if (@_ == 1) {my ($self) = @_;
1287     my $r = 0;
1288    
1289     {
1290    
1291    
1292     $r = ($$self eq '');
1293    
1294    
1295 wakaba 1.4 }
1296 wakaba 1.1 $r;
1297     } else {my ($self) = @_;
1298     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_empty_reference';
1299     }
1300     }
1301     sub is_iri ($;$) {
1302     if (@_ == 1) {my ($self) = @_;
1303     my $r = 0;
1304    
1305     {
1306    
1307    
1308     {
1309    
1310     local $Error::Depth = $Error::Depth + 1;
1311    
1312     {
1313    
1314    
1315    
1316     $r = $self->
1317     is_iri_3987
1318     ;
1319    
1320    
1321    
1322 wakaba 1.4 }
1323 wakaba 1.1
1324    
1325     ;}
1326    
1327     ;
1328    
1329    
1330 wakaba 1.4 }
1331 wakaba 1.1 $r;
1332     } else {my ($self) = @_;
1333     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_iri';
1334     }
1335     }
1336     sub is_iri_3987 ($;$) {
1337     if (@_ == 1) {my ($self) = @_;
1338     my $r = 0;
1339    
1340     {
1341    
1342     my
1343     $v = $$self;
1344     V: {
1345     ## LRM, RLM, LRE, RLE, LRO, RLO, PDF
1346     ## U+200E, U+200F, U+202A - U+202E
1347     my $ucschar = q{\x{00A0}-\x{200D}\x{2010}-\x{2029}\x{202F}-\x{D7FF}\x{F900}-\x{FDCF}\x{FDF0}-\x{FFEF}\x{10000}-\x{1FFFD}\x{20000}-\x{2FFFD}\x{30000}-\x{3FFFD}\x{40000}-\x{4FFFD}\x{50000}-\x{5FFFD}\x{60000}-\x{6FFFD}\x{70000}-\x{7FFFD}\x{80000}-\x{8FFFD}\x{90000}-\x{9FFFD}\x{A0000}-\x{AFFFD}\x{B0000}-\x{BFFFD}\x{C0000}-\x{CFFFD}\x{D0000}-\x{DFFFD}\x{E1000}-\x{EFFFD}};
1348    
1349     ## -- Scheme
1350     unless ($v =~ s/^[A-Za-z][A-Za-z0-9+.-]*://s) {
1351     last V;
1352     }
1353    
1354     ## -- Fragment
1355     if ($v =~ s/#(.*)\z//s) {
1356     my $w = $1;
1357     unless ($w =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/?$ucschar-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}o) {
1358     last V;
1359     }
1360     }
1361    
1362     ## -- Query
1363     if ($v =~ s/\?(.*)\z//s) {
1364     my $w = $1;
1365     unless ($w =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/?$ucschar\x{E000}-\x{F8FF}\x{F0000}-\x{FFFFD}\x{100000}-\x{10FFFD}-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}o) {
1366     last V;
1367     }
1368     }
1369    
1370     ## -- Authority
1371     if ($v =~ s!^//([^/]*)!!s) {
1372     my $w = $1;
1373     $w =~ s/^(?>[A-Za-z0-9._~!\$&'()*+,;=:$ucschar-]|%[0-9A-Fa-f][0-9A-Fa-f])*\@//os;
1374     $w =~ s/:[0-9]*\z//;
1375     if ($w =~ /^\[(.*)\]\z/s) {
1376     my $x = $1;
1377     unless ($x =~ /\A[vV][0-9A-Fa-f]+\.[A-Za-z0-9._~!\$&'()*+,;=:-]+\z/) {
1378     ## IPv6address
1379     my $isv6;
1380    
1381    
1382     {
1383    
1384     my
1385     $ipv4 = qr/(?>0|1[0-9]{0,2}|2(?>[0-4][0-9]?|5[0-5]?|[6-9])?|[3-9][0-9]?)(?>\.(?>0|1[0-9]{0,2}|2(?>[0-4][0-9]?|5[0-5]?|[6-9])?|[3-9][0-9]?)){3}/;
1386     my $h16 = qr/[0-9A-Fa-f]{1,4}/;
1387     if ($x =~ s/(?:$ipv4|$h16)\z//o) {
1388     if ($x =~ /\A(?>$h16:){6}\z/o or
1389     $x =~ /\A::(?>$h16:){0,5}\z/o or
1390     $x =~ /\A${h16}::(?>$h16:){4}\z/o or
1391     $x =~ /\A$h16(?::$h16)?::(?>$h16:){3}\z/o or
1392     $x =~ /\A$h16(?::$h16){0,2}::(?>$h16:){2}\z/o or
1393     $x =~ /\A$h16(?::$h16){0,3}::$h16:\z/o or
1394     $x =~ /\A$h16(?::$h16){0,4}::\z/o) {
1395     $isv6 =
1396     1
1397     ;
1398     }
1399     } elsif ($x =~ s/$h16\z//o) {
1400     if ($x eq '' or $x =~ /\A$h16(?>:$h16){0,5}\z/o) {
1401     $isv6 =
1402     1
1403     ;
1404     }
1405     } elsif ($x =~ s/::\z//o) {
1406     if ($x eq '' or $x =~ /\A$h16(?>:$h16){0,6}\z/o) {
1407     $isv6 =
1408     1
1409     ;
1410     }
1411     }
1412    
1413    
1414 wakaba 1.4 }
1415 wakaba 1.1
1416     ;
1417     last V unless $isv6;
1418     }
1419     } else {
1420     unless ($w =~ /\A(?>[A-Za-z0-9._~!\$&'()*+,;=$ucschar-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z/o) {
1421     last V;
1422     }
1423     }
1424     }
1425    
1426     ## -- Path
1427     unless ($v =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/$ucschar-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}os) {
1428     last V;
1429     }
1430    
1431     $r =
1432     1
1433     ;
1434     } # V
1435    
1436    
1437 wakaba 1.4 }
1438 wakaba 1.1 $r;
1439     } else {my ($self) = @_;
1440     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_iri_3987';
1441     }
1442     }
1443     sub is_relative_iri_reference ($;$) {
1444     if (@_ == 1) {my ($self) = @_;
1445     my $r = 0;
1446    
1447     {
1448    
1449    
1450     {
1451    
1452     local $Error::Depth = $Error::Depth + 1;
1453    
1454     {
1455    
1456    
1457    
1458     $r = $self->
1459     is_relative_iri_reference_3987
1460     ;
1461    
1462    
1463    
1464 wakaba 1.4 }
1465 wakaba 1.1
1466    
1467     ;}
1468    
1469     ;
1470    
1471    
1472 wakaba 1.4 }
1473 wakaba 1.1 $r;
1474     } else {my ($self) = @_;
1475     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_relative_iri_reference';
1476     }
1477     }
1478     sub is_relative_iri_reference_3987 ($;$) {
1479     if (@_ == 1) {my ($self) = @_;
1480     my $r = 0;
1481    
1482     {
1483    
1484     my
1485     $v = $$self;
1486     V: {
1487     ## LRM, RLM, LRE, RLE, LRO, RLO, PDF
1488     ## U+200E, U+200F, U+202A - U+202E
1489     my $ucschar = q{\x{00A0}-\x{200D}\x{2010}-\x{2029}\x{202F}-\x{D7FF}\x{F900}-\x{FDCF}\x{FDF0}-\x{FFEF}\x{10000}-\x{1FFFD}\x{20000}-\x{2FFFD}\x{30000}-\x{3FFFD}\x{40000}-\x{4FFFD}\x{50000}-\x{5FFFD}\x{60000}-\x{6FFFD}\x{70000}-\x{7FFFD}\x{80000}-\x{8FFFD}\x{90000}-\x{9FFFD}\x{A0000}-\x{AFFFD}\x{B0000}-\x{BFFFD}\x{C0000}-\x{CFFFD}\x{D0000}-\x{DFFFD}\x{E1000}-\x{EFFFD}};
1490    
1491     ## -- No scheme
1492     if ($v =~ s!^[^/?#]*:!!s) {
1493     last V;
1494     }
1495    
1496     ## -- Fragment
1497     if ($v =~ s/#(.*)\z//s) {
1498     my $w = $1;
1499     unless ($w =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/?$ucschar-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}o) {
1500     last V;
1501     }
1502     }
1503    
1504     ## -- Query
1505     if ($v =~ s/\?(.*)\z//s) {
1506     my $w = $1;
1507     unless ($w =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/?$ucschar\x{E000}-\x{F8FF}\x{F0000}-\x{FFFFD}\x{100000}-\x{10FFFD}-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}o) {
1508     last V;
1509     }
1510     }
1511    
1512     ## -- Authority
1513     if ($v =~ s!^//([^/]*)!!s) {
1514     my $w = $1;
1515     $w =~ s/^(?>[A-Za-z0-9._~!\$&'()*+,;=:$ucschar-]|%[0-9A-Fa-f][0-9A-Fa-f])*\@//os;
1516     $w =~ s/:[0-9]*\z//;
1517     if ($w =~ /^\[(.*)\]\z/s) {
1518     my $x = $1;
1519     unless ($x =~ /\A[vV][0-9A-Fa-f]+\.[A-Za-z0-9._~!\$&'()*+,;=:-]+\z/) {
1520     ## IPv6address
1521     my $isv6;
1522    
1523    
1524     {
1525    
1526     my
1527     $ipv4 = qr/(?>0|1[0-9]{0,2}|2(?>[0-4][0-9]?|5[0-5]?|[6-9])?|[3-9][0-9]?)(?>\.(?>0|1[0-9]{0,2}|2(?>[0-4][0-9]?|5[0-5]?|[6-9])?|[3-9][0-9]?)){3}/;
1528     my $h16 = qr/[0-9A-Fa-f]{1,4}/;
1529     if ($x =~ s/(?:$ipv4|$h16)\z//o) {
1530     if ($x =~ /\A(?>$h16:){6}\z/o or
1531     $x =~ /\A::(?>$h16:){0,5}\z/o or
1532     $x =~ /\A${h16}::(?>$h16:){4}\z/o or
1533     $x =~ /\A$h16(?::$h16)?::(?>$h16:){3}\z/o or
1534     $x =~ /\A$h16(?::$h16){0,2}::(?>$h16:){2}\z/o or
1535     $x =~ /\A$h16(?::$h16){0,3}::$h16:\z/o or
1536     $x =~ /\A$h16(?::$h16){0,4}::\z/o) {
1537     $isv6 =
1538     1
1539     ;
1540     }
1541     } elsif ($x =~ s/$h16\z//o) {
1542     if ($x eq '' or $x =~ /\A$h16(?>:$h16){0,5}\z/o) {
1543     $isv6 =
1544     1
1545     ;
1546     }
1547     } elsif ($x =~ s/::\z//o) {
1548     if ($x eq '' or $x =~ /\A$h16(?>:$h16){0,6}\z/o) {
1549     $isv6 =
1550     1
1551     ;
1552     }
1553     }
1554    
1555    
1556 wakaba 1.4 }
1557 wakaba 1.1
1558     ;
1559     last V unless $isv6;
1560     }
1561     } else {
1562     unless ($w =~ /\A(?>[A-Za-z0-9._~!\$&'()*+,;=$ucschar-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z/o) {
1563     last V;
1564     }
1565     }
1566     }
1567    
1568     ## -- Path
1569     unless ($v =~ m{\A(?>[A-Za-z0-9._~!\$&'()*+,;=:\@/$ucschar-]|%[0-9A-Fa-f][0-9A-Fa-f])*\z}os) {
1570     last V;
1571     }
1572    
1573     $r =
1574     1
1575     ;
1576     } # V
1577    
1578    
1579 wakaba 1.4 }
1580 wakaba 1.1 $r;
1581     } else {my ($self) = @_;
1582     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_relative_iri_reference_3987';
1583     }
1584     }
1585     sub is_iri_reference ($;$) {
1586     if (@_ == 1) {my ($self) = @_;
1587     my $r = 0;
1588    
1589     {
1590    
1591    
1592     {
1593    
1594     local $Error::Depth = $Error::Depth + 1;
1595    
1596     {
1597    
1598    
1599    
1600     $r = $self->
1601     is_iri_reference_3987
1602     ;
1603    
1604    
1605    
1606 wakaba 1.4 }
1607 wakaba 1.1
1608    
1609     ;}
1610    
1611     ;
1612    
1613    
1614 wakaba 1.4 }
1615 wakaba 1.1 $r;
1616     } else {my ($self) = @_;
1617     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_iri_reference';
1618     }
1619     }
1620     sub is_iri_reference_3987 ($;$) {
1621     if (@_ == 1) {my ($self) = @_;
1622     my $r = 0;
1623    
1624     {
1625    
1626    
1627     {
1628    
1629     local $Error::Depth = $Error::Depth + 1;
1630    
1631     {
1632    
1633    
1634    
1635     $r = $self->
1636     is_iri_3987
1637     ||
1638     $self->
1639     is_relative_iri_reference_3987
1640     ;
1641    
1642    
1643    
1644 wakaba 1.4 }
1645 wakaba 1.1
1646    
1647     ;}
1648    
1649     ;
1650    
1651    
1652 wakaba 1.4 }
1653 wakaba 1.1 $r;
1654     } else {my ($self) = @_;
1655     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_iri_reference_3987';
1656     }
1657     }
1658     sub is_absolute_iri ($;$) {
1659     if (@_ == 1) {my ($self) = @_;
1660     my $r = 0;
1661    
1662     {
1663    
1664    
1665     {
1666    
1667     local $Error::Depth = $Error::Depth + 1;
1668    
1669     {
1670    
1671    
1672    
1673     $r = $self->
1674     is_absolute_iri_3987
1675     ;
1676    
1677    
1678    
1679 wakaba 1.4 }
1680 wakaba 1.1
1681    
1682     ;}
1683    
1684     ;
1685    
1686    
1687 wakaba 1.4 }
1688 wakaba 1.1 $r;
1689     } else {my ($self) = @_;
1690     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_absolute_iri';
1691     }
1692     }
1693     sub is_absolute_iri_3987 ($;$) {
1694     if (@_ == 1) {my ($self) = @_;
1695     my $r = 0;
1696    
1697     {
1698    
1699    
1700     {
1701    
1702     local $Error::Depth = $Error::Depth + 1;
1703    
1704     {
1705    
1706    
1707    
1708     $r = $$self !~ /#/ && $self->
1709     is_iri_3987
1710     ;
1711    
1712    
1713    
1714 wakaba 1.4 }
1715 wakaba 1.1
1716    
1717     ;}
1718    
1719     ;
1720    
1721    
1722 wakaba 1.4 }
1723 wakaba 1.1 $r;
1724     } else {my ($self) = @_;
1725     report Message::Util::Error::DOMException::CoreException -object => $self, '-type' => 'NO_MODIFICATION_ALLOWED_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#on' => 'get', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#subtype' => 'http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#READ_ONLY_ATTRIBUTE_ERR', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#class' => 'Message::URI::Generic::ManakaiURIReference', 'http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#attr' => 'is_absolute_iri_3987';
1726     }
1727     }
1728     sub get_uri_reference ($) {
1729     my ($self) = @_;
1730     my $r;
1731    
1732     {
1733    
1734    
1735     {
1736    
1737     local $Error::Depth = $Error::Depth + 1;
1738    
1739     {
1740    
1741    
1742    
1743     $r = $self->
1744     get_uri_reference_3986
1745     ;
1746    
1747    
1748    
1749 wakaba 1.4 }
1750 wakaba 1.1
1751    
1752     ;}
1753    
1754     ;
1755    
1756    
1757 wakaba 1.4 }
1758 wakaba 1.1 $r}
1759     sub get_uri_reference_3986 ($) {
1760     my ($self) = @_;
1761     my $r;
1762    
1763     {
1764    
1765    
1766     {
1767    
1768     local $Error::Depth = $Error::Depth + 1;
1769    
1770     {
1771    
1772    
1773     require
1774     Encode;
1775     my $v = Encode::encode ('utf8', $$self);
1776     $v =~ s/([<>"{}|\\\^`\x00-\x20\x7E-\xFF])/sprintf '%%%02X', ord $1/ge;
1777     $r = bless \$v,
1778     'Message::URI::Generic::ManakaiURIReference'
1779     ;
1780    
1781    
1782    
1783 wakaba 1.4 }
1784 wakaba 1.1
1785    
1786     ;}
1787    
1788     ;
1789    
1790    
1791 wakaba 1.4 }
1792 wakaba 1.1 $r}
1793     sub get_iri_reference ($) {
1794     my ($self) = @_;
1795     my $r;
1796    
1797     {
1798    
1799    
1800     {
1801    
1802     local $Error::Depth = $Error::Depth + 1;
1803    
1804     {
1805    
1806    
1807    
1808     $r = $self->
1809     get_iri_reference_3987
1810     ;
1811    
1812    
1813    
1814 wakaba 1.4 }
1815 wakaba 1.1
1816    
1817     ;}
1818    
1819     ;
1820    
1821    
1822 wakaba 1.4 }
1823 wakaba 1.1 $r}
1824     sub get_iri_reference_3987 ($) {
1825     my ($self) = @_;
1826     my $r;
1827    
1828     {
1829    
1830    
1831     {
1832    
1833     local $Error::Depth = $Error::Depth + 1;
1834    
1835     {
1836    
1837    
1838     require
1839     Encode;
1840     my $v = Encode::encode ('utf8', $$self);
1841     $v =~ s{%([2-9A-Fa-f][0-9A-Fa-f])}
1842     {
1843     my $ch = hex $1;
1844     if ([
1845     # 0x0 0x1 0x2 0x3 0x4 0x5 0x6 0x7
1846     # 0x8 0x9 0xA 0xB 0xC 0xD 0xE 0xF
1847    
1848     1
1849     ,
1850     1
1851     ,
1852     1
1853     ,
1854     1
1855     ,
1856     1
1857     ,
1858     1
1859     ,
1860     1
1861     ,
1862     1
1863     , # 0x00
1864    
1865     1
1866     ,
1867     1
1868     ,
1869     1
1870     ,
1871     1
1872     ,
1873     1
1874     ,
1875     1
1876     ,
1877     1
1878     ,
1879     1
1880     , # 0x08
1881    
1882     1
1883     ,
1884     1
1885     ,
1886     1
1887     ,
1888     1
1889     ,
1890     1
1891     ,
1892     1
1893     ,
1894     1
1895     ,
1896     1
1897     , # 0x10
1898    
1899     1
1900     ,
1901     1
1902     ,
1903     1
1904     ,
1905     1
1906     ,
1907     1
1908     ,
1909     1
1910     ,
1911     1
1912     ,
1913     1
1914     , # 0x18
1915    
1916     1
1917     ,
1918     1
1919     ,
1920     1
1921     ,
1922     1
1923     ,
1924     1
1925     ,
1926     1
1927     ,
1928     1
1929     ,
1930     1
1931     , # 0x20
1932    
1933     1
1934     ,
1935     1
1936     ,
1937     1
1938     ,
1939     1
1940     ,
1941     1
1942     ,
1943     0
1944     ,
1945     0
1946     ,
1947     1
1948     , # 0x28
1949    
1950     0
1951     ,
1952     0
1953     ,
1954     0
1955     ,
1956     0
1957     ,
1958     0
1959     ,
1960     0
1961     ,
1962     0
1963     ,
1964     0
1965     , # 0x30
1966    
1967     0
1968     ,
1969     0
1970     ,
1971     1
1972     ,
1973     1
1974     ,
1975     1
1976     ,
1977     1
1978     ,
1979     1
1980     ,
1981     1
1982     , # 0x38
1983    
1984     1
1985     ,
1986     0
1987     ,
1988     0
1989     ,
1990     0
1991     ,
1992     0
1993     ,
1994     0
1995     ,
1996     0
1997     ,
1998     0
1999     , # 0x40
2000    
2001     0
2002     ,
2003     0
2004     ,
2005     0
2006     ,
2007     0
2008     ,
2009     0
2010     ,
2011     0
2012     ,
2013     0
2014     ,
2015     0
2016     , # 0x48
2017    
2018     0
2019     ,
2020     0
2021     ,
2022     0
2023     ,
2024     0
2025     ,
2026     0
2027     ,
2028     0
2029     ,
2030     0
2031     ,
2032     0
2033     , # 0x50
2034    
2035     0
2036     ,
2037     0
2038     ,
2039     0
2040     ,
2041     1
2042     ,
2043     1
2044     ,
2045     1
2046     ,
2047     1
2048     ,
2049     0
2050     , # 0x58
2051    
2052     1
2053     ,
2054     0
2055     ,
2056     0
2057     ,
2058     0
2059     ,
2060     0
2061     ,
2062     0
2063     ,
2064     0
2065     ,
2066     0
2067     , # 0x60
2068    
2069     0
2070     ,
2071     0
2072     ,
2073     0
2074     ,
2075     0
2076     ,
2077     0
2078     ,
2079     0
2080     ,
2081     0
2082     ,
2083     0
2084     , # 0x68
2085    
2086     0
2087     ,
2088     0
2089     ,
2090     0
2091     ,
2092     0
2093     ,
2094     0
2095     ,
2096     0
2097     ,
2098     0
2099     ,
2100     0
2101     , # 0x70
2102    
2103     0
2104     ,
2105     0
2106     ,
2107     0
2108     ,
2109     1
2110     ,
2111     1
2112     ,
2113     1
2114     ,
2115     0
2116     ,
2117     1
2118     , # 0x78
2119     # 0x0 0x1 0x2 0x3 0x4 0x5 0x6 0x7
2120     # 0x8 0x9 0xA 0xB 0xC 0xD 0xE 0xF
2121     ]->[$ch]) {
2122     # PERCENT SIGN, reserved, not-allowed in ASCII
2123     '%'.$1;
2124     } else {
2125     chr $ch;
2126     }
2127     }ge;
2128     $v =~ s{(
2129     [\xC2-\xDF][\x80-\xBF] | # UTF8-2
2130     [\xE0][\xA0-\xBF][\x80-\xBF] |
2131     [\xE1-\xEC][\x80-\xBF][\x80-\xBF] |
2132     [\xED][\x80-\x9F][\x80-\xBF] |
2133     [\xEE\xEF][\x80-\xBF][\x80-\xBF] | # UTF8-3
2134     [\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] |
2135     [\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |
2136     [\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] | # UTF8-4
2137     [\x80-\xFF]
2138     )}{
2139     my $c = $1;
2140     if (length ($c) == 1) {
2141     $c =~ s/(.)/sprintf '%%%02X', ord $1/ge;
2142     $c;
2143     } else {
2144     my $ch = Encode::decode ('utf8', $c);
2145     if ($ch =~ /^[\x{00A0}-\x{200D}\x{2010}-\x{2029}\x{202F}-\x{D7FF}\x{F900}-\x{FDCF}\x{FDF0}-\x{FFEF}\x{10000}-\x{1FFFD}\x{20000}-\x{2FFFD}\x{30000}-\x{3FFFD}\x{40000}-\x{4FFFD}\x{50000}-\x{5FFFD}\x{60000}-\x{6FFFD}\x{70000}-\x{7FFFD}\x{80000}-\x{8FFFD}\x{90000}-\x{9FFFD}\x{A0000}-\x{AFFFD}\x{B0000}-\x{BFFFD}\x{C0000}-\x{CFFFD}\x{D0000}-\x{DFFFD}\x{E1000}-\x{EFFFD}]/) {
2146     $c;
2147     } else {
2148     $c =~ s/([\x80-\xFF])/sprintf '%%%02X', ord $1/ge;
2149     $c;
2150     }
2151     }
2152     }gex;
2153     $v =~ s/([<>"{}|\\\^`\x00-\x20\x7F])/sprintf '%%%02X', ord $1/ge;
2154     $v = Encode::decode ('utf8', $v);
2155     $r = bless \$v,
2156     'Message::URI::Generic::ManakaiURIReference'
2157     ;
2158    
2159    
2160    
2161 wakaba 1.4 }
2162 wakaba 1.1
2163    
2164     ;}
2165    
2166     ;
2167    
2168    
2169 wakaba 1.4 }
2170 wakaba 1.1 $r}
2171     sub get_absolute_reference ($$;%) {
2172     my ($self, $base, %opt) = @_;
2173     my $r;
2174    
2175     {
2176    
2177    
2178     {
2179    
2180     local $Error::Depth = $Error::Depth + 1;
2181    
2182     {
2183    
2184    
2185    
2186     $r = $self->
2187     get_absolute_reference_3986
2188    
2189     ($base, non_strict => $opt{non_strict});
2190    
2191    
2192    
2193 wakaba 1.4 }
2194 wakaba 1.1
2195    
2196     ;}
2197    
2198     ;
2199    
2200    
2201 wakaba 1.4 }
2202 wakaba 1.1 $r}
2203     sub get_absolute_reference_3986 ($$%) {
2204     my ($self, $base, %opt) = @_;
2205     my $r;
2206    
2207     {
2208    
2209    
2210     {
2211    
2212     local $Error::Depth = $Error::Depth + 1;
2213    
2214     {
2215    
2216    
2217    
2218     ## -- Decomposition
2219     my ($b_scheme, $b_auth, $b_path, $b_query, $b_frag);
2220     my ($r_scheme, $r_auth, $r_path, $r_query, $r_frag);
2221    
2222     if ($$self =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!s) {
2223     ($r_scheme, $r_auth, $r_path, $r_query, $r_frag)
2224     = ($1, $2, $3, $4, $5);
2225     } else { # unlikely happen
2226     ($r_scheme, $r_auth, $r_path, $r_query, $r_frag)
2227     = (
2228     undef
2229     ,
2230     undef
2231     , '',
2232     undef
2233     ,
2234     undef
2235     );
2236     }
2237     my $ba = ref $base eq 'SCALAR'
2238     ? $base
2239     : ref $base eq
2240     'Message::URI::Generic::ManakaiURIReference'
2241    
2242     ? $base
2243     : ref $base
2244     ? \"$base"
2245     : \$base;
2246     if ($$ba =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!s) {
2247     ($b_scheme, $b_auth, $b_path, $b_query, $b_frag)
2248     = (defined $1 ? $1 : '', $2, $3, $4, $5);
2249     } else { # unlikely happen
2250     ($b_scheme, $b_auth, $b_path, $b_query, $b_frag)
2251     = ('',
2252     undef
2253     , '',
2254     undef
2255     ,
2256     undef
2257     );
2258     }
2259    
2260     ## -- Merge
2261     my $path_merge = sub ($$) {
2262     my ($bpath, $rpath) = @_;
2263     if ($bpath eq '') {
2264     return '/'.$rpath;
2265     }
2266     $bpath =~ s/[^\/]*\z//;
2267     return $bpath . $rpath;
2268     }; # merge
2269    
2270     ## -- Removing Dot Segments
2271     my $remove_dot_segments = sub ($) {
2272     local $_ = shift;
2273     my $buf = '';
2274     L: while (length $_) {
2275     next L if s/^\.\.?\///;
2276     next L if s/^\/\.(?:\/|\z)/\//;
2277     if (s/^\/\.\.(\/|\z)/\//) {
2278     $buf =~ s/\/?[^\/]*$//;
2279     next L;
2280     }
2281     last Z if s/^\.\.?\z//;
2282     s/^(\/?[^\/]*)//;
2283     $buf .= $1;
2284     }
2285     return $buf;
2286     }; # remove_dot_segments
2287    
2288     ## -- Transformation
2289     my ($t_scheme, $t_auth, $t_path, $t_query, $t_frag);
2290    
2291     if ($opt{non_strict} and $r_scheme eq $b_scheme) {
2292     undef $r_scheme;
2293     }
2294    
2295     if (defined $r_scheme) {
2296     $t_scheme = $r_scheme;
2297     $t_auth = $r_auth;
2298     $t_path = $remove_dot_segments->($r_path);
2299     $t_query = $r_query;
2300     } else {
2301     if (defined $r_auth) {
2302     $t_auth = $r_auth;
2303     $t_path = $remove_dot_segments->($r_path);
2304     $t_query = $r_query;
2305     } else {
2306     if ($r_path =~ /\A\z/) {
2307     $t_path = $b_path;
2308     if (defined $r_query) {
2309     $t_query = $r_query;
2310     } else {
2311     $t_query = $b_query;
2312     }
2313     } elsif ($r_path =~ /^\//) {
2314     $t_path = $remove_dot_segments->($r_path);
2315     $t_query = $r_query;
2316     } else {
2317     $t_path = $path_merge->($b_path, $r_path);
2318     $t_path = $remove_dot_segments->($t_path);
2319     $t_query = $r_query;
2320     }
2321     $t_auth = $b_auth;
2322     }
2323     $t_scheme = $b_scheme;
2324     }
2325     $t_frag = $r_frag;
2326    
2327     ## -- Recomposition
2328     my $result = '' ;
2329     $result .= $t_scheme . ':' if defined $t_scheme;
2330     $result .= '//' . $t_auth if defined $t_auth ;
2331     $result .= $t_path ;
2332     $result .= '?' . $t_query if defined $t_query ;
2333     $result .= '#' . $t_frag if defined $t_frag ;
2334    
2335     $r = bless \$result,
2336     'Message::URI::Generic::ManakaiURIReference'
2337     ;
2338    
2339    
2340    
2341 wakaba 1.4 }
2342 wakaba 1.1
2343    
2344     ;}
2345    
2346     ;
2347    
2348    
2349 wakaba 1.4 }
2350 wakaba 1.1 $r}
2351     sub get_absolute_reference_3987 ($$;%) {
2352     my ($self, $base, %opt) = @_;
2353     my $r;
2354    
2355     {
2356    
2357    
2358     {
2359    
2360     local $Error::Depth = $Error::Depth + 1;
2361    
2362     {
2363    
2364    
2365    
2366     $r = $self->
2367     get_absolute_reference_3986
2368    
2369     ($base, non_strict => $opt{non_strict});
2370    
2371    
2372    
2373 wakaba 1.4 }
2374 wakaba 1.1
2375    
2376     ;}
2377    
2378     ;
2379    
2380    
2381 wakaba 1.4 }
2382 wakaba 1.1 $r}
2383     sub is_same_document_reference ($$) {
2384     my ($self, $base) = @_;
2385     my $r = 0;
2386    
2387     {
2388    
2389    
2390     {
2391    
2392     local $Error::Depth = $Error::Depth + 1;
2393    
2394     {
2395    
2396    
2397    
2398     $r = $self->
2399     is_same_document_reference_3986
2400     ($base);
2401    
2402    
2403    
2404 wakaba 1.4 }
2405 wakaba 1.1
2406    
2407     ;}
2408    
2409     ;
2410    
2411    
2412 wakaba 1.4 }
2413 wakaba 1.1 $r}
2414     sub is_same_document_reference_3986 ($$;%) {
2415     my ($self, $base, %opt) = @_;
2416     my $r = 0;
2417    
2418     {
2419    
2420    
2421     {
2422    
2423     local $Error::Depth = $Error::Depth + 1;
2424    
2425     {
2426    
2427    
2428     if
2429     (substr ($$self, 0, 1) eq '#') {
2430     $r =
2431     1
2432     ;
2433     } else {
2434     my $target = $self->
2435     get_absolute_reference_3986
2436    
2437     ($base, non_strict => $opt{non_strict})
2438     ->
2439     uri_reference
2440     ;
2441     $target =~ s/#.*\z//;
2442     my $ba = ref $base eq 'SCALAR'
2443     ? $$base
2444     : ref $base eq
2445     'Message::URI::Generic::ManakaiURIReference'
2446    
2447     ? $$base
2448     : ref $base
2449     ? "$base"
2450     : $base;
2451     $ba =~ s/#.*\z//;
2452     $r = ($target eq $ba);
2453     }
2454    
2455    
2456    
2457 wakaba 1.4 }
2458 wakaba 1.1
2459    
2460     ;}
2461    
2462     ;
2463    
2464    
2465 wakaba 1.4 }
2466 wakaba 1.1 $r}
2467     sub get_relative_reference ($$) {
2468     my ($self, $base) = @_;
2469     my $r;
2470    
2471     {
2472    
2473    
2474     {
2475    
2476     local $Error::Depth = $Error::Depth + 1;
2477    
2478     {
2479    
2480    
2481     my
2482     @base;
2483     my $ba = ref $base eq 'SCALAR'
2484     ? $base
2485     : ref $base eq
2486     'Message::URI::Generic::ManakaiURIReference'
2487    
2488     ? $base
2489     : ref $base
2490     ? \"$base"
2491     : \$base;
2492     if ($$ba =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!) {
2493     (@base) = (defined $1 ? $1 : '', $2, $3, $4, $5);
2494     } else { # unlikeley happen
2495     (@base) = ('',
2496     undef
2497     , '',
2498     undef
2499     ,
2500     undef
2501     );
2502     }
2503     my @t;
2504     my $t = $self->
2505     get_absolute_reference
2506     ($base);
2507     if ("$t" =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!) {
2508     (@t) = (defined $1 ? $1 : '', $2, $3, $4, $5);
2509     } else { # unlikeley happen
2510     (@t) = ('',
2511     undef
2512     , '',
2513     undef
2514     ,
2515     undef
2516     );
2517     }
2518    
2519     my @ref;
2520     R: {
2521     ## Scheme
2522     if ($base[0] ne $t[0]) {
2523     (@ref) = @t;
2524     last R;
2525     }
2526    
2527     ## Authority
2528     if (not defined $base[1] and not defined $t[1]) {
2529     (@ref) = @t;
2530     last R;
2531     } elsif (not defined $t[1]) {
2532     (@ref) = @t;
2533     last R;
2534     } elsif (not defined $base[1]) {
2535     (@ref) = @t;
2536     last R;
2537     } elsif ($base[1] ne $t[1]) {
2538     (@ref) = @t;
2539     last R;
2540     }
2541     ## NOTE: Avoid uncommon references.
2542    
2543     if (defined $t[4] and # fragment
2544     $t[2] eq $base[2] and # path
2545     ((not defined $t[3] and not defined $base[3]) or # query
2546     (defined $t[3] and defined $base[3] and $t[3] eq $base[3]))) {
2547     (@ref) = (
2548     undef
2549     ,
2550     undef
2551     , '',
2552     undef
2553     , $t[4]);
2554     last R;
2555     }
2556    
2557     ## Path
2558     my @tpath = split m!/!, $t[2], -1;
2559     my @bpath = split m!/!, $base[2], -1;
2560     if (@tpath < 1 or @bpath < 1) { ## No |/|
2561     (@ref) = @t;
2562     last R;
2563     }
2564     my $bpl;
2565    
2566     ## Removes common segments
2567     while (@tpath and @bpath and $tpath[0] eq $bpath[0]) {
2568     shift @tpath;
2569     $bpl = shift @bpath;
2570     }
2571    
2572     if (@tpath == 0) {
2573     if (@bpath == 0) { ## Avoid empty path for backward compatibility
2574     unshift @tpath, $bpl;
2575     } else {
2576     unshift @tpath, '..', $bpl;
2577     }
2578     } elsif (@bpath == 0) {
2579     unshift @tpath, $bpl;
2580     }
2581    
2582     unshift @tpath, ('..') x (@bpath - 1) if @bpath > 1;
2583    
2584     unshift @tpath, '.' if $tpath[0] eq '' or
2585     $tpath[0] =~ /:/;
2586    
2587     (@ref) = (
2588     undef
2589     ,
2590     undef
2591     , (join '/', @tpath), $t[3], $t[4]);
2592     } # R
2593    
2594     ## -- Recomposition
2595     my $result = '' ;
2596     $result .= $ref[0] . ':' if defined $ref[0]; # scheme;
2597     $result .= '//' . $ref[1] if defined $ref[1]; # authority
2598     $result .= $ref[2] ; # path
2599     $result .= '?' . $ref[3] if defined $ref[3]; # query
2600     $result .= '#' . $ref[4] if defined $ref[4]; # fragment
2601    
2602     $r = bless \$result,
2603     'Message::URI::Generic::ManakaiURIReference'
2604     ;
2605    
2606    
2607    
2608 wakaba 1.4 }
2609 wakaba 1.1
2610    
2611     ;}
2612    
2613     ;
2614    
2615    
2616 wakaba 1.4 }
2617 wakaba 1.1 $r}
2618     sub clone ($) {
2619     my ($self) = @_;
2620     my $r;
2621    
2622     {
2623    
2624     my
2625     $v = $$self;
2626     $r = bless \$v,
2627     'Message::URI::Generic::ManakaiURIReference'
2628     ;
2629    
2630    
2631 wakaba 1.4 }
2632 wakaba 1.1 $r}
2633     *clone_uri_reference = \&clone;
2634     use overload
2635     bool => sub () {1},
2636     '""' => 'stringify',
2637     'eq' => sub ($$) {
2638     my ($self, $v) = @_;
2639     my $r = 0;
2640    
2641     {
2642    
2643     if
2644     (defined $v) {
2645    
2646    
2647     {
2648    
2649     local $Error::Depth = $Error::Depth + 1;
2650    
2651     {
2652    
2653    
2654    
2655     $r = $v eq $$self;
2656    
2657    
2658    
2659 wakaba 1.4 }
2660 wakaba 1.1
2661    
2662     ;}
2663    
2664     ;
2665     }
2666    
2667    
2668 wakaba 1.4 }
2669 wakaba 1.1 $r}
2670     ,
2671     fallback => 1;
2672 wakaba 1.2 $Message::DOM::DOMFeature::ClassInfo->{q<Message::URI::Generic::ManakaiURIReference>}->{has_feature} = {'http://suika.fam.cx/www/2006/feature/uri',
2673     {'',
2674     '1',
2675     '4.0',
2676     '1'}};
2677 wakaba 1.1 $Message::DOM::ClassPoint{q<Message::URI::Generic::ManakaiURIReference>} = 4;
2678 wakaba 1.5 for ($Message::DOM::IF::DOMImplementation::, $Message::DOM::IFLatest::DOMImplementation::, $Message::URI::IF::URIImplementation::, $Message::URI::IF::URIReference::){}
2679 wakaba 1.1 ## License: <http://suika.fam.cx/~wakaba/archive/2004/8/18/license#Perl+MPL>
2680     1;
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24