/[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.1 - (hide annotations) (download)
Sun Mar 12 10:13:31 2006 UTC (18 years, 8 months ago) by wakaba
Branch: MAIN 
++ manakai/bin/ChangeLog	12 Mar 2006 10:03:19 -0000
2006-03-12  Wakaba  <wakaba@suika.fam.cx>

	* daf.pl: Don't require |Test| modules for bootstrap.

++ manakai/lib/Message/Util/ChangeLog	12 Mar 2006 10:09:14 -0000
2006-03-12  Wakaba  <wakaba@suika.fam.cx>

	* DIS.dis (loadResource): Sets the |srinfo| parameter
	of the |addTypeURI| method call.
	(addTypeURI): The |srinfo| parameter is added.  Sets
	the |srinfo| parameter of the |isSubsetOfURI| and |mergeAsAlias|
	method calls.

++ manakai/lib/Message/Util/DIS/ChangeLog	12 Mar 2006 10:09:53 -0000
2006-03-12  Wakaba  <wakaba@suika.fam.cx>

	* Perl.dis (getPerlModuleMemberCode): Write charset
	category properties.

++ manakai/lib/Message/URI/ChangeLog	12 Mar 2006 10:13:28 -0000
2006-03-12  Wakaba  <wakaba@suika.fam.cx>

	* Generic.pm: Added to the CVS repository since
	it is referenced from |../DOM/DOMCore.pm| and therefore
	it is required to execute the |daf| script.

++ manakai/lib/Message/Charset/ChangeLog	12 Mar 2006 10:06:26 -0000
2006-03-12  Wakaba  <wakaba@suika.fam.cx>

	* Encode.dis (createMCDecodeHandle): New
	parameter |onerror| is added.  Charsets |cs:XML.utf-8|, |cs:XML.utf-16|,
	and |xml-auto-charset:| are implemented.  Throws an error
	if the charset is not supported.
	(getURIFromCharsetName, getCharsetNameFromURI): Algorithmic URIs are
	supported.
	(onerror): Removed from |onoctetstreamerror|.
	(MCXMLDecodeHandle): Removed.
	(inputEncoding, hasBOM): New attributes.

++ manakai/lib/manakai/ChangeLog	12 Mar 2006 10:12:19 -0000
2006-03-12  Wakaba  <wakaba@suika.fam.cx>

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