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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.4 - (show annotations) (download)
Wed Jun 13 12:04:51 2007 UTC (17 years, 5 months ago) by wakaba
Branch: MAIN
Changes since 1.3: +7 -7 lines 
++ manakai/t/ChangeLog	13 Jun 2007 12:04:43 -0000
2007-06-13  Wakaba  <wakaba@suika.fam.cx>

	* DOM-DOMImplementation.t: New test.

2007-05-26  Wakaba  <wakaba@suika.fam.cx>

	* IMT-InternetMediaType.t: Tests for |add_parameter| are added.

++ manakai/lib/Message/IMT/ChangeLog	13 Jun 2007 12:03:40 -0000
	* InternetMediaType.pm (add_paremter): New method.

2007-05-26  Wakaba  <wakaba@suika.fam.cx>

++ manakai/lib/Message/DOM/ChangeLog	13 Jun 2007 12:02:59 -0000
2007-06-13  Wakaba  <wakaba@suika.fam.cx>

	* DOMImplementation.pm, Node.pm, DOMDocument.pm,
	DOMElement.pm, Attr.pm, DocumentType.pm,
	DOMCharacterData.pm, Text.pm, Comment.pm: Copied
	from <http://suika.fam.cx/gate/cvs/*checkout*/markup/html/whatpm/Whatpm/NanoDOM.pm?rev=1.9>.

2007-06-10  Wakaba  <wakaba@suika.fam.cx>

	* XMLParser.dis: Default to "1.0" if <?xml version=""?>
	specifies unknown value and trys to recover from the error.

++ manakai/lib/Message/URI/ChangeLog	13 Jun 2007 12:04:07 -0000
2007-06-13  Wakaba  <wakaba@suika.fam.cx>

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