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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.5 - (hide annotations) (download)
Mon Jul 16 11:58:02 2007 UTC (17 years, 4 months ago) by wakaba
Branch: MAIN
Changes since 1.4: +39 -333 lines 
++ manakai/lib/Message/DOM/ChangeLog	16 Jul 2007 11:37:33 -0000
2007-07-16  Wakaba  <wakaba@suika.fam.cx>

	* DOMElement.pm: Incorrect module was referenced.

	* DOMImplementation.pm: References to
	the |Message::Charset::Encode| module has been removed.

++ manakai/lib/Message/URI/ChangeLog	16 Jul 2007 11:57:14 -0000
2007-07-16  Wakaba  <wakaba@suika.fam.cx>

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