/[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.6 - (hide annotations) (download)
Sat Aug 11 13:06:39 2007 UTC (17 years, 3 months ago) by wakaba
Branch: MAIN
CVS Tags: manakai-release-0-4-0
Changes since 1.5: +15 -12 lines 
++ manakai/lib/Message/CGI/ChangeLog	11 Aug 2007 13:05:16 -0000
2007-08-11  Wakaba  <wakaba@suika.fam.cx>

	* ChangeLog: New file.

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