/[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 - (hide 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 wakaba 1.2 package Message::URI::URIReference;
2 wakaba 1.1 use strict;
3 wakaba 1.4 our $VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4 wakaba 1.2
5 wakaba 1.1 require Message::Util::Error::DOMException;
6    
7 wakaba 1.4 package Message::IF::URIImplementation;
8 wakaba 1.2 package Message::DOM::DOMImplementation;
9 wakaba 1.4 push our @ISA, 'Message::IF::URIImplementation';
10 wakaba 1.1
11 wakaba 1.2 sub create_uri_reference ($$) {
12 wakaba 1.4 if (UNIVERSAL::isa ($_[1], 'Message::IF::URIReference')) {
13 wakaba 1.2 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 wakaba 1.1 } else {
19 wakaba 1.2 my $v = "$_[1]";
20     return bless \$v, 'Message::URI::URIReference';
21 wakaba 1.1 }
22     }
23    
24 wakaba 1.2 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 wakaba 1.4 package Message::IF::URIReference;
29 wakaba 1.2 package Message::URI::URIReference;
30 wakaba 1.4 push our @ISA, 'Message::IF::URIReference';
31 wakaba 1.1
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 wakaba 1.2
766     ## TODO: An attribute that returns the number of path segments is necessary.
767    
768 wakaba 1.1 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 wakaba 1.2 $r = bless \$v, 'Message::URI::URIReference';
1680 wakaba 1.1 }
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 wakaba 1.2 pack 'C', $ch;
2023 wakaba 1.1 }
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 wakaba 1.2 $r = bless \$v, 'Message::URI::URIReference';
2053 wakaba 1.1 }
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 wakaba 1.2 : ref $base eq 'Message::URI::URIReference'
2132 wakaba 1.1 ? $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 wakaba 1.2 $r = bless \$result, 'Message::URI::URIReference';
2226 wakaba 1.1
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 wakaba 1.2 : ref $base eq 'Message::URI::URIReference'
2331 wakaba 1.1 ? $$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 wakaba 1.2 : ref $base eq 'Message::URI::URIReference'
2370 wakaba 1.1 ? $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 wakaba 1.2 $r = bless \$result, 'Message::URI::URIReference';
2485 wakaba 1.1
2486    
2487    
2488     }
2489    
2490    
2491     ;}
2492    
2493     ;
2494    
2495    
2496     }
2497     $r}
2498 wakaba 1.2
2499 wakaba 1.3 sub ___report_error ($$) {
2500     $_[1]->throw;
2501     } # ___report_error
2502    
2503 wakaba 1.1 sub clone ($) {
2504 wakaba 1.2 my $self = shift;
2505     my $v = $$self;
2506     return bless \$v, ref $self;
2507     } # clone
2508 wakaba 1.1
2509 wakaba 1.2 *clone_uri_reference = \&clone;
2510 wakaba 1.1
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 wakaba 1.2
2550     1;
2551 wakaba 1.1 ## License: <http://suika.fam.cx/~wakaba/archive/2004/8/18/license#Perl+MPL>
2552 wakaba 1.4 ## $Date: 2007/05/26 06:34:46 $
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24