/[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 - (show 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 #!/usr/bin/perl
2 ## This file is automatically generated
3 ## at 2006-12-30T11:56:30+00:00,
4 ## from file "../URI/Generic.dis",
5 ## module <http://suika.fam.cx/~wakaba/archive/2005/manakai/URI/Generic>,
6 ## for <http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#all>.
7 ## Don't edit by hand!
8 use strict;
9 require Message::DOM::DOMCore;
10 require Message::Util::Error::DOMException;
11 package Message::URI::Generic;
12 our $VERSION = 20061230.1156;
13 package Message::URI::IF::URIImplementation;
14 our $VERSION = 20061230.1156;
15 package Message::URI::Generic::ManakaiURIImplementation;
16 our $VERSION = 20061230.1156;
17 push our @ISA, 'Message::DOM::IF::DOMImplementation',
18 'Message::DOM::IF::DOMImplementation',
19 'Message::URI::IF::URIImplementation';
20 push @Message::DOM::DOMCore::ManakaiDOMImplementation::ISA, q<Message::URI::Generic::ManakaiURIImplementation> unless Message::DOM::DOMCore::ManakaiDOMImplementation->isa (q<Message::URI::Generic::ManakaiURIImplementation>);
21 sub create_uri_reference ($$) {
22 my ($self, $uri) = @_;
23 my $r;
24
25 {
26
27 if
28 (UNIVERSAL::isa ($uri,
29 'Message::URI::IF::URIReference'
30 )) {
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 }
48
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 }
66 $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 $Message::DOM::DOMFeature::ClassInfo->{q<Message::URI::Generic::ManakaiURIImplementation>}->{has_feature} = {'',
70 {'',
71 '1'},
72 'http://suika.fam.cx/www/2006/feature/min',
73 {'',
74 '1',
75 '3.0',
76 '1'},
77 'http://suika.fam.cx/www/2006/feature/uri',
78 {'',
79 '1',
80 '4.0',
81 '1'},
82 'http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#minimum',
83 {'',
84 '1',
85 '3.0',
86 '1'},
87 'xml',
88 {'',
89 '1',
90 '1.0',
91 '1',
92 '2.0',
93 '1',
94 '3.0',
95 '1'},
96 'xmlversion',
97 {'',
98 '1',
99 '1.0',
100 '1',
101 '1.1',
102 '1'}};
103 $Message::DOM::ClassPoint{q<Message::URI::Generic::ManakaiURIImplementation>} = 15.1;
104 package Message::URI::IF::URIReference;
105 our $VERSION = 20061230.1156;
106 package Message::URI::Generic::ManakaiURIReference;
107 our $VERSION = 20061230.1156;
108 push our @ISA, 'Message::URI::IF::URIReference';
109 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 'Message::URI::IF::URIReference'
120 )) {
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 }
137 $r}
138 sub uri_reference ($;$) {
139 if (@_ == 1) {my ($self) = @_;
140 my $r = '';
141
142 {
143
144
145 $r = $$self;
146
147
148 }
149 $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 }
173
174
175 ;}
176
177 ;
178
179
180 }
181 }
182 }
183 sub stringify ($) {
184 my ($self) = @_;
185 my $r = '';
186
187 {
188
189
190 $r = $$self;
191
192
193 }
194 $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 }
237 $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 }
264
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 }
290
291
292 ;}
293
294 ;
295 }
296
297
298 }
299 }
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 }
318 $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 }
345
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 }
371
372
373 ;}
374
375 ;
376 }
377 }
378
379
380 }
381 }
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 }
412
413
414 ;}
415
416 ;
417
418
419 }
420 $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 }
459
460
461 ;}
462
463 ;
464
465
466 }
467 }
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 }
500
501
502 ;}
503
504 ;
505
506
507 }
508 $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 }
546
547
548 ;}
549
550 ;
551
552
553 }
554 }
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 }
585
586
587 ;}
588
589 ;
590
591
592 }
593 $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 }
632
633
634 ;}
635
636 ;
637
638
639 }
640 }
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 }
655 $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 }
681
682
683 ;}
684
685 ;
686 }
687
688
689 }
690 }
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 }
709 $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 }
735
736
737 ;}
738
739 ;
740 }
741
742
743 }
744 }
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 }
763 $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 }
788
789
790 ;}
791
792 ;
793 }
794
795
796 }
797 }
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 }
823
824
825 ;}
826
827 ;
828
829
830 }
831 $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 }
862
863
864 ;}
865
866 ;
867
868
869 }
870 }
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 }
893
894
895 ;}
896
897 ;
898
899
900 }
901 $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 }
981
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 }
1004 $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 }
1031
1032
1033 ;}
1034
1035 ;
1036
1037
1038 }
1039 $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 }
1119
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 }
1142 $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 }
1169
1170
1171 ;}
1172
1173 ;
1174
1175
1176 }
1177 $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 }
1207
1208
1209 ;}
1210
1211 ;
1212
1213
1214 }
1215 $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 }
1242
1243
1244 ;}
1245
1246 ;
1247
1248
1249 }
1250 $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 }
1277
1278
1279 ;}
1280
1281 ;
1282
1283
1284 }
1285 $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 }
1301 $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 }
1328
1329
1330 ;}
1331
1332 ;
1333
1334
1335 }
1336 $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 }
1420
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 }
1443 $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 }
1470
1471
1472 ;}
1473
1474 ;
1475
1476
1477 }
1478 $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 }
1562
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 }
1585 $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 }
1612
1613
1614 ;}
1615
1616 ;
1617
1618
1619 }
1620 $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 }
1650
1651
1652 ;}
1653
1654 ;
1655
1656
1657 }
1658 $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 }
1685
1686
1687 ;}
1688
1689 ;
1690
1691
1692 }
1693 $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 }
1720
1721
1722 ;}
1723
1724 ;
1725
1726
1727 }
1728 $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 }
1755
1756
1757 ;}
1758
1759 ;
1760
1761
1762 }
1763 $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 }
1789
1790
1791 ;}
1792
1793 ;
1794
1795
1796 }
1797 $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 }
1820
1821
1822 ;}
1823
1824 ;
1825
1826
1827 }
1828 $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 }
2167
2168
2169 ;}
2170
2171 ;
2172
2173
2174 }
2175 $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 }
2199
2200
2201 ;}
2202
2203 ;
2204
2205
2206 }
2207 $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 }
2347
2348
2349 ;}
2350
2351 ;
2352
2353
2354 }
2355 $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 }
2379
2380
2381 ;}
2382
2383 ;
2384
2385
2386 }
2387 $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 }
2410
2411
2412 ;}
2413
2414 ;
2415
2416
2417 }
2418 $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 }
2463
2464
2465 ;}
2466
2467 ;
2468
2469
2470 }
2471 $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 }
2614
2615
2616 ;}
2617
2618 ;
2619
2620
2621 }
2622 $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 }
2637 $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 }
2665
2666
2667 ;}
2668
2669 ;
2670 }
2671
2672
2673 }
2674 $r}
2675 ,
2676 fallback => 1;
2677 $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 $Message::DOM::ClassPoint{q<Message::URI::Generic::ManakaiURIReference>} = 4;
2683 for ($Message::DOM::IF::DOMImplementation::){}
2684 ## 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