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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.3 - (hide annotations) (download)
Fri Mar 31 12:15:40 2006 UTC (18 years, 7 months ago) by wakaba
Branch: MAIN
CVS Tags: manakai-release-0-3-1
Changes since 1.2: +6 -6 lines 
++ manakai/lib/Message/Util/ChangeLog	31 Mar 2006 11:57:15 -0000
2006-03-31  Wakaba  <wakaba@suika.fam.cx>

	* Grove.dis (getNodeStemProp0Node): The |$opt| option
	parameter is added.
	(mg:nodeRefInterfaces): New property.

++ manakai/lib/Message/DOM/ChangeLog	31 Mar 2006 11:58:04 -0000
2006-03-31  Wakaba  <wakaba@suika.fam.cx>

	* DOMCore.dis (DOMStringList.==): New overloaded operator.

	* DOMFeature.dis (ManakaiHasFeatureByGetFeature): The
	class did not implement the |GetFeature| interface.
	(hasFeature): The |+| prefix was not taken into account.

	* TreeCore.dis (Node): The class now inherits
	the |ManakaiHasFeatureByGetFeature| class.  It now
	implements the |f:GetFeature| and |ecore:MUErrorTarget|
	interfaces.
	(CreateNodeRefMethod): The |mg:nodeRefInterfaces| option
	is supported.
	(lookupNamespaceURI, lookupPrefix, isDefaultNamespace): Reimplemented.
	(manakaiParentElement): New attribute.

	* XDoctype.dis (d:Feature): Old feature name |ManakaiDOM:XDoctype|
	is removed.
	(lookupPrefix): Old method implementation is removed.

	* XML.dis (CDATASection): The |mg:NodeRefRole| was
	missing because of the |DISCore:stopISARecursive| property.

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