/[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.6 - (hide annotations) (download)
Sat Dec 30 12:00:42 2006 UTC (17 years, 10 months ago) by wakaba
Branch: MAIN
CVS Tags: manakai-release-0-4-0, HEAD
Changes since 1.5: +27 -22 lines 
++ manakai/lib/Message/Markup/ChangeLog	30 Dec 2006 11:55:48 -0000
	* Atom.dis, SuikaWiki.dis, H2H.dis, SuikaWikiConfig21.dis: |For|
	specifications are removed.

	* SuikaWikiConfig21.dis: |WithFor| and |DefaultFor|
	specifications are removed.
	(ForEmpty, ForLatest): Removed.

2006-12-30  Wakaba  <wakaba@suika.fam.cx>

++ manakai/lib/Message/Util/ChangeLog	30 Dec 2006 11:57:42 -0000
	* PerlCode.dis, DIS.dis, ManakaiNode.dis,
	ManakaiNodeTest.dis: |For| specifications are removed.

	* common.dis: New module.

	* DIS.dis, PerlCode.dis, ManakaiNode.dis: |Util:| resource
	definitions are removed (and moved to |common.dis|).

	* DIS.dis (ForEmpty, ForLatest): Removed.

	* DIS.dis: |WithFor| and |DefaultFor| are removed.

2006-12-30  Wakaba  <wakaba@suika.fam.cx>

++ manakai/lib/Message/Util/Error/ChangeLog	30 Dec 2006 11:59:28 -0000
2006-12-30  Wakaba  <wakaba@suika.fam.cx>

	* Core.dis, DOMException.dis: |WithFor|, |DefaultFor|,
	and |For| specificaitons are removed.

++ manakai/lib/Message/Util/Formatter/ChangeLog	30 Dec 2006 11:59:59 -0000
2006-12-30  Wakaba  <wakaba@suika.fam.cx>

	* Muf2003.dis: |WithFor|, |DefaultFor|, and |For|
	specifications are removed.

++ manakai/lib/Message/Util/DIS/ChangeLog	30 Dec 2006 11:58:54 -0000
	* Perl.dis, Value.dis, DNLite.dis,
	DPG.dis, Test.dis: |WithFor|, |For|, and |DefaultFor|
	specifications are removed.

2006-12-30  Wakaba  <wakaba@suika.fam.cx>

++ manakai/lib/Message/DOM/ChangeLog	30 Dec 2006 11:53:43 -0000
        SimpleLS.dis, DOMMain.dis, XDP.dis: |For| specifications
	are removed.

2006-12-30  Wakaba  <wakaba@suika.fam.cx>

	* CharacterData.dis, DOMCore.dis, DOMFeature.dis,
        GenericLS.dis, TreeCore.dis, DOMString.dis,
        XML.dis, Element.dis, Document.dis, TreeStore,dis,
        Traversal.dis, XDoctype.dis, XMLParser.dis, DOMLS.dis,
++ manakai/lib/Message/URI/ChangeLog	30 Dec 2006 11:54:30 -0000
	* Generic.dis: |For| specifications are removed.

2006-12-30  Wakaba  <wakaba@suika.fam.cx>

++ manakai/lib/Message/Charset/ChangeLog	30 Dec 2006 11:54:10 -0000
	* Encode.dis: |For| specifications are removed.

2006-12-30  Wakaba  <wakaba@suika.fam.cx>

++ manakai/lib/manakai/ChangeLog	30 Dec 2006 12:00:29 -0000
	* XML.dis: |DefaultFor| specification is removed.

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