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

Diff of /messaging/manakai/lib/Message/URI/Generic.dis

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Wed Mar 1 08:42:34 2006 UTC revision 1.2 by wakaba, Wed Mar 1 13:03:57 2006 UTC
# Line 10  Module: Line 10  Module:
10      The <DFN::manakai URI Generic Module> provides a set of interfaces      The <DFN::manakai URI Generic Module> provides a set of interfaces
11      to extract components of URIs.      to extract components of URIs.
12    
13      @enDesc:
14        @@ddid:src
15        @@For: ManakaiDOM|Perl
16        @@@:
17          Portions of the Perl implementation contained in the module
18          are derived from the example parser (April 7, 2004) available at
19          <URI::http://www.gbiv.com/protocols/uri/rev-2002/uri_test.pl>
20          that is placed in the Public Domain by Roy T. Fielding
21          and Day Software, Inc.
22    
23    @DISCore:author: DISCore|Wakaba    @DISCore:author: DISCore|Wakaba
24    @License: license|Perl+MPL    @License: license|Perl+MPL
25    @Date:    @Date:
# Line 437  IFClsDef: Line 447  IFClsDef:
447    
448    @Attr:    @Attr:
449      @@Name: uriReference      @@Name: uriReference
     @@Operator: DISPerl|AsStringMethod  
450      @@Operator:      @@Operator:
451        @@@: ""        @@@: ""
452        @@ContentType: DISPerl|Perl        @@ContentType: DISPerl|Perl
# Line 491  IFClsDef: Line 500  IFClsDef:
500                      q<about:>);                      q<about:>);
501          }          }
502    
503      @IntMethod:
504        @@Operator: DISPerl|AsStringMethod
505        @@Return:
506          @@@Type: String
507          @@@PerlDef:
508            $r = $$self;
509    
510      @@Test:      @@Test:
511        @@@QName: URIRef.stringify.test        @@@QName: URIRef.stringify.test
512        @@@PerlDef:        @@@PerlDef:
# Line 577  IFClsDef: Line 593  IFClsDef:
593    
594            = If <VAR::U> contains <CHAR::SOLIDUS>, <CHAR::QUESTION MARK>,            = If <VAR::U> contains <CHAR::SOLIDUS>, <CHAR::QUESTION MARK>,
595              and / or <CHAR::NUMBER SIGN>, then there is no scheme component.              and / or <CHAR::NUMBER SIGN>, then there is no scheme component.
596    
597              = If <VAR::U> is empty, then there is no scheme component.
598    
599            = Otherwise, <VAR::U> is the scheme component.            = Otherwise, <VAR::U> is the scheme component.
600                    
# Line 600  IFClsDef: Line 618  IFClsDef:
618          @@@@enDesc:          @@@@enDesc:
619            If there is no scheme component.            If there is no scheme component.
620        @@@PerlDef:        @@@PerlDef:
621          if ($$self =~ m!^([^/?#:]*):!) {          if ($$self =~ m!^([^/?#:]+):!) {
622            $r = $1;            $r = $1;
623          } else {          } else {
624            $r = null;            $r = null;
# Line 610  IFClsDef: Line 628  IFClsDef:
628          Replaces the scheme component of the DOM URI by the new value.          Replaces the scheme component of the DOM URI by the new value.
629          If the new value contains <CHAR::SOLIDUS>, <CHAR::QUESTION MARK>,          If the new value contains <CHAR::SOLIDUS>, <CHAR::QUESTION MARK>,
630          <CHAR::NUMBER SIGN>, and / or <CHAR::COLON>, then          <CHAR::NUMBER SIGN>, and / or <CHAR::COLON>, then
631          the result is undefined.          the result is undefined.  If the new value is empty,
632            then the result is undefined.
633    
634          If the original DOM URI has no scheme component, then          If the original DOM URI has no scheme component, then
635          the string obtained by concatenating the new scheme component          the string obtained by concatenating the new scheme component
# Line 621  IFClsDef: Line 640  IFClsDef:
640          and a <CHAR::COLON> following it are removed from the DOM URI.          and a <CHAR::COLON> following it are removed from the DOM URI.
641        @@@PerlDef:        @@@PerlDef:
642          if (defined $given) {          if (defined $given) {
643            unless ($given =~ m![/?#:]!) {            if (length $given and $given !~ m![/?#:]!) {
644              unless ($$self =~ s!^[^/?#:]*:!$given:!) {              unless ($$self =~ s!^[^/?#:]+:!$given:!) {
645                $$self = $given . ':' . $$self;                $$self = $given . ':' . $$self;
646                __DEEP{                __DEEP{
647                  $self-><M::ManakaiURIReference.onSchemeChanged>;                  $self-><M::ManakaiURIReference.onSchemeChanged>;
# Line 630  IFClsDef: Line 649  IFClsDef:
649              }              }
650            }            }
651          } else {          } else {
652            $$self =~ s!^[^/?#:]*:!!;            $$self =~ s!^[^/?#:]+:!!;
653            __DEEP{            __DEEP{
654              $self-><M::ManakaiURIReference.onSchemeChanged>;              $self-><M::ManakaiURIReference.onSchemeChanged>;
655            }__;            }__;
# Line 655  IFClsDef: Line 674  IFClsDef:
674            [q<%D9%82%D9%87%D9%88%D8%a9://coffee.example/>,            [q<%D9%82%D9%87%D9%88%D8%a9://coffee.example/>,
675             '%D9%82%D9%87%D9%88%D8%a9',             '%D9%82%D9%87%D9%88%D8%a9',
676             q<http://coffee.example/>, q<//coffee.example/>],             q<http://coffee.example/>, q<//coffee.example/>],
677              [q<:aa>, null, q<http::aa>, q<:aa>], # ilegal
678          ) {          ) {
679            $test->id ('get.'.$_->[0]);            $test->id ('get.'.$_->[0]);
680            my $uri1 = $impl-><M::URIImplementation.createURIReference>            my $uri1 = $impl-><M::URIImplementation.createURIReference>
# Line 670  IFClsDef: Line 690  IFClsDef:
690                     ($uri2-><AG::URIReference.uriReference>,                     ($uri2-><AG::URIReference.uriReference>,
691                      $_->[2]);                      $_->[2]);
692    
           $test->id ('empty.'.$_->[0]);  
           my $uri3 = $impl-><M::URIImplementation.createURIReference> ($uri1);  
           $uri3-><AS::URIReference.uriScheme> ('');  
           $test->assert_equals  
                    ($uri3-><AG::URIReference.uriReference>,  
                     $_->[3]);  
   
693            $test->id ('reset.'.$_->[0]);            $test->id ('reset.'.$_->[0]);
694            my $uri4 = $impl-><M::URIImplementation.createURIReference> ($uri1);            my $uri4 = $impl-><M::URIImplementation.createURIReference> ($uri1);
695            $uri4-><AS::URIReference.uriScheme> (null);            $uri4-><AS::URIReference.uriScheme> (null);
696            $test->assert_equals            $test->assert_equals
697                     ($uri4-><AG::URIReference.uriReference>,                     ($uri4-><AG::URIReference.uriReference>,
698                      $_->[4]);                      $_->[3]);
699          }          }
700    
701    @Attr:    @Attr:
# Line 698  IFClsDef: Line 711  IFClsDef:
711    
712            = Copy the DOM URI to the variable <VAR::U>.            = Copy the DOM URI to the variable <VAR::U>.
713    
714              = Removes the scheme component and the <CHAR::COLON>
715                following it, if any, from <VAR::U>.
716    
717            = If <VAR::U> contains a <CHAR::NUMBER SIGN>,            = If <VAR::U> contains a <CHAR::NUMBER SIGN>,
718              remove the character and any characters following it              remove the character and any characters following it
719              from <VAR::U>.              from <VAR::U>.
# Line 706  IFClsDef: Line 722  IFClsDef:
722              remove the character and any characters following it              remove the character and any characters following it
723              from <VAR::U>.              from <VAR::U>.
724    
           = If <VAR::U> contains a <CHAR::COLON> <EM::before>  
             any occurence of <CHAR::SOLIDUS>, then  
             remove the <CHAR::COLON> and any characters preceding it  
             from <VAR::U>.  
   
725            = If <VAR::U> begins with two <CHAR::SOLIDUS> characters,            = If <VAR::U> begins with two <CHAR::SOLIDUS> characters,
726              remove them from <VAR::U>.  <EM::Otherwise>,              remove them from <VAR::U>.  <EM::Otherwise>,
727              <VAR::U> has no authority component.              <VAR::U> has no authority component.
# Line 748  IFClsDef: Line 759  IFClsDef:
759          @@@@enDesc:          @@@@enDesc:
760            If there is no authority component.            If there is no authority component.
761        @@@PerlDef:        @@@PerlDef:
762          my $v = $$self;          if ($$self =~ m!^(?:[^:/?#]+:)?(?://([^/?#]*))?!) {
         $v =~ s/#.*\z//s;  
         $v =~ s/\?.*\z//s;  
         $v =~ s!^[^:/]*:!!s;  
         if ($$self =~ m!^//([^/]*)!) {  
763            $r = $1;            $r = $1;
764          } else {          } else {
765            $r = null;            $r = null;
# Line 780  IFClsDef: Line 787  IFClsDef:
787        @@@PerlDef:        @@@PerlDef:
788          if (defined $given) {          if (defined $given) {
789            unless ($given =~ m![/?#]!) {            unless ($given =~ m![/?#]!) {
790                unless ($$self =~ s!^((?:[^:/?#]+:)?)(?://[^/?#]*)?!$1//$given!) {
791                  $$self = '//' . $given;
792                  __DEEP{
793                    $self-><M::ManakaiURIReference.onAuthorityChanged>;
794                  }__;
795                }
796              }
797            } else {
798              if ($$self =~ s!^((?:[^:/?#]+:)?)(?://[^/?#]*)?!$1!) {
799              __DEEP{              __DEEP{
               my $v = '';  
               my $w = $self-><AG::URIReference.uriScheme>;  
               $v .= $w . ':' if defined $w;  
               $v .= '//' . $given;  
               $v .= $self-><AG::URIReference.uriPath>;  
               $w = $self-><AG::URIReference.uriQuery>;  
               $v .= '?' . $w if defined $w;  
               $w = $self-><AG::URIReference.uriFragment>;  
               $v .= '#' . $w if defined $w;  
               $$self = $v;  
800                $self-><M::ManakaiURIReference.onAuthorityChanged>;                $self-><M::ManakaiURIReference.onAuthorityChanged>;
801              }__;              }__;
802            }            }
         } else {  
           __DEEP{  
             my $v = '';  
             my $w = $self-><AG::URIReference.uriScheme>;  
             $v .= $w . ':' if defined $w;  
             $v .= $self-><AG::URIReference.uriPath>;  
             $w = $self-><AG::URIReference.uriQuery>;  
             $v .= '?' . $w if defined $w;  
             $w = $self-><AG::URIReference.uriFragment>;  
             $v .= '#' . $w if defined $w;  
             $$self = $v;  
             $self-><M::ManakaiURIReference.onAuthorityChanged>;  
           }__;  
803          }          }
804                    
805      @@Test:      @@Test:
# Line 822  IFClsDef: Line 815  IFClsDef:
815             q<http:///>, q<http:/>],             q<http:///>, q<http:/>],
816            [q<//example/>, 'example', q<//example/>, q<///>, q</>],            [q<//example/>, 'example', q<//example/>, q<///>, q</>],
817            [q</a:b/>, null, q<//example/a:b/>, q<///a:b/>, q</a:b/>],            [q</a:b/>, null, q<//example/a:b/>, q<///a:b/>, q</a:b/>],
818            [q<?aa:b>, null, q<//example?aa:b>, q<//?a:b>, q<?aa:b>],            [q<?aa:b>, null, q<//example?aa:b>, q<//?aa:b>, q<?aa:b>],
819            [q</aaaa#bb:cc>, null, q<//example/aaaa#bb:cc>,            [q</aaaa#bb:cc>, null, q<//example/aaaa#bb:cc>,
820             q<///aaaa#bb:cc>, q</aaaa#bb:cc>],             q<///aaaa#bb:cc>, q</aaaa#bb:cc>],
821            [q<http://%D9%82%D9%87%D9%88%D8%A9/>,            [q<http://%D9%82%D9%87%D9%88%D8%A9/>,
# Line 964  IFClsDef: Line 957  IFClsDef:
957                $auth =~ s/^[^\@\[\]]*\@//;                $auth =~ s/^[^\@\[\]]*\@//;
958              }              }
959              $self-><AS::URIReference.uriAuthority> ($auth);              $self-><AS::URIReference.uriAuthority> ($auth);
960              } else {
961                if (defined $given and $given !~ /[\/#?\@\[\]]/) {
962                  $self-><AS::URIReference.uriAuthority> ($given.'@');
963                }
964            }            }
965          }__;          }__;
966                    
# Line 983  IFClsDef: Line 980  IFClsDef:
980            [q<//u@example/>, 'u', q<//user@example/>,            [q<//u@example/>, 'u', q<//user@example/>,
981             q<//@example/>, q<//example/>],             q<//@example/>, q<//example/>],
982            [q</a:b/>, null, q<//user@/a:b/>, q<//@/a:b/>, q</a:b/>],            [q</a:b/>, null, q<//user@/a:b/>, q<//@/a:b/>, q</a:b/>],
983            [q<?aa:b>, null, q<//user@?aa:b>, q<//user@?a:b>, q<?aa:b>],            [q<?aa:b>, null, q<//user@?aa:b>, q<//@?aa:b>, q<?aa:b>],
984            [q</aaaa#bb:cc>, null, q<//user@/aaaa#bb:cc>,            [q</aaaa#bb:cc>, null, q<//user@/aaaa#bb:cc>,
985             q<//@/aaaa#bb:cc>, q</aaaa#bb:cc>],             q<//@/aaaa#bb:cc>, q</aaaa#bb:cc>],
986            [q<http://%D9%82%D9%87%D9%88%D8%A9@example/>,            [q<http://%D9%82%D9%87%D9%88%D8%A9@example/>,
# Line 1127  IFClsDef: Line 1124  IFClsDef:
1124                $v .= $1;                $v .= $1;
1125              }              }
1126              $self-><AS::URIReference.uriAuthority> ($v);              $self-><AS::URIReference.uriAuthority> ($v);
1127            } else {            } elsif ($given !~ /[\/\@:#?]/) {
1128              $self-><AS::URIReference.uriAuthority> ($given);              $self-><AS::URIReference.uriAuthority> ($given);
1129            }            }
1130          }__;          }__;
# Line 1145  IFClsDef: Line 1142  IFClsDef:
1142            [q<//example/>, 'example', q<//example/>, q<///>],            [q<//example/>, 'example', q<//example/>, q<///>],
1143            [q<//u@example/>, 'example', q<//u@example/>, q<//u@/>],            [q<//u@example/>, 'example', q<//u@example/>, q<//u@/>],
1144            [q</a:b/>, null, q<//example/a:b/>, q<///a:b/>],            [q</a:b/>, null, q<//example/a:b/>, q<///a:b/>],
1145            [q<?aa:b>, null, q<//example?aa:b>, q<//example?a:b>],            [q<?aa:b>, null, q<//example?aa:b>, q<//?aa:b>],
1146            [q</aaaa#bb:cc>, null, q<//example/aaaa#bb:cc>,            [q</aaaa#bb:cc>, null, q<//example/aaaa#bb:cc>,
1147             q<///aaaa#bb:cc>],             q<///aaaa#bb:cc>],
1148            [q<http://%D9%82%D9%87%D9%88%D8%A9/>,            [q<http://%D9%82%D9%87%D9%88%D8%A9/>,
# Line 1275  IFClsDef: Line 1272  IFClsDef:
1272                $auth =~ s/:[0-9]*\z//;                $auth =~ s/:[0-9]*\z//;
1273              }              }
1274              $self-><AS::URIReference.uriAuthority> ($auth);              $self-><AS::URIReference.uriAuthority> ($auth);
1275              } else {
1276                if (defined $given and $given =~ /\A[0-9]*\z/) {
1277                  $self-><AS::URIReference.uriAuthority> (':'.$given);
1278                }
1279            }            }
1280          }__;          }__;
1281                    
# Line 1294  IFClsDef: Line 1295  IFClsDef:
1295            [q<//u@example:3/>, '3', q<//u@example:2/>,            [q<//u@example:3/>, '3', q<//u@example:2/>,
1296             q<//u@example:/>, q<//u@example/>],             q<//u@example:/>, q<//u@example/>],
1297            [q</a:b/>, null, q<//:2/a:b/>, q<//:/a:b/>, q</a:b/>],            [q</a:b/>, null, q<//:2/a:b/>, q<//:/a:b/>, q</a:b/>],
1298            [q<?aa:b>, null, q<//:2?aa:b>, q<//:?a:b>, q<?aa:b>],            [q<?aa:b>, null, q<//:2?aa:b>, q<//:?aa:b>, q<?aa:b>],
1299            [q</aaaa#bb:cc>, null, q<//:2/aaaa#bb:cc>,            [q</aaaa#bb:cc>, null, q<//:2/aaaa#bb:cc>,
1300             q<//:/aaaa#bb:cc>, q</aaaa#bb:cc>],             q<//:/aaaa#bb:cc>, q</aaaa#bb:cc>],
           [q<http://example:%D9%82%D9%87%D9%88%D8%A9/>,  
            '%D9%82%D9%87%D9%88%D8%A9',  
            q<http://example:2/>, q<http://example:/>, q<http://example/>],  
           [q<http://example:%D9%82%D9%87%D9%88%D8%a9/>,  
            '%D9%82%D9%87%D9%88%D8%a9',  
            q<http://example:2/>, q<http://example:/>, q<http://example/>],  
1301            ['about:', null, q<about://:2>, q<about://:>, q<about:>],            ['about:', null, q<about://:2>, q<about://:>, q<about:>],
1302            ['http://a:b@c:3/', '3', q<http://a:b@c:2/>,            ['http://a:b@c:3/', '3', q<http://a:b@c:2/>,
1303             q<http://a:b@c:/>, q<http://a:b@c/>],             q<http://a:b@c:/>, q<http://a:b@c/>],
# Line 1357  IFClsDef: Line 1352  IFClsDef:
1352            = If <VAR::U> contains a <CHAR::QUESTION MARK>, remove            = If <VAR::U> contains a <CHAR::QUESTION MARK>, remove
1353              the character and any characters following it.              the character and any characters following it.
1354    
1355            = If <VAR::U> contains a <CHAR::COLON> with no preceding            = If <VAR::U> contains the scheme component and
1356              <CHAR::SOLIDUS> character, remove the <CHAR::COLON>              the <CHAR::COLON> character fllowing it, remove
1357              and any characters preceding it.              them from <VAR::U>.
1358    
1359            = If the first two characters are both <CHAR::SOLIDUS>,            = If <VAR::U> contains the authority component and
1360              remove those characters and any characters following it              the <CHAR::SOLIDUS> characters preceding it, remove
1361              <EM::before> the next occurence of <CHAR::SOLIDUS>, if any.              them from <VAR::U>.
1362    
1363            = Then, <VAR::U> is the path component.            = Then, <VAR::U> is the path component.
1364                    
# Line 1384  IFClsDef: Line 1379  IFClsDef:
1379            }            }
1380          }          }
1381        @@@PerlDef:        @@@PerlDef:
1382          __DEEP{          if ($$self =~ m!\A(?:[^:/?#]+:)?(?://[^/?#]*)?([^?#]*)!) {
1383            my $r = $$self;            $r = $1;
1384            $r =~ s/#.*\z//s;          }
           $r =~ s/\?.*\z//s;  
           $r =~ s!^[^:/]*:!!s;  
           $r =~ s!^//[^/]*!!s;  
         }__;  
1385      @@Set:      @@Set:
1386        @@@enDesc:        @@@enDesc:
1387          Replaces the path component of the DOM URI by the new value.          Replaces the path component of the DOM URI by the new value.
# Line 1409  IFClsDef: Line 1400  IFClsDef:
1400          If the new value contains <CHAR::QUESTION MARK> or          If the new value contains <CHAR::QUESTION MARK> or
1401          <CHAR::NUMBER SIGN>, the result is undefined.          <CHAR::NUMBER SIGN>, the result is undefined.
1402        @@@PerlDef:        @@@PerlDef:
1403          __DEEP{          if ($given !~ /[?#]/ and
1404            my $v = $$self;              $$self =~ m!^((?:[^:/?#]+:)?(?://[^/?#]*)?)[^?#]*((?:\?[^#]*)?(?:#.*)?)!s) {
1405            my $new = '';            $$self = $1.$given.$2;
1406            if ($v =~ s/(#.*)\z//s) {            __DEEP{
1407              $new = $1;              $self-><M::ManakaiURIReference.onPathChanged>;
1408            }            }__;
1409            if ($v =~ s/(\?.*)\z//s) {          }
             $new = $1 . $new;  
           }  
           $new = $given . $new;  
           if ($v =~ s!^((?:[^:/]*:)?(?://)?[^/]*)!!s) {  
             $new = $1 . $new;  
           }  
           $$self = $new;  
           $self-><M::ManakaiURIReference.onPathChanged>;  
         }__;  
1410                    
1411      @@Test:      @@Test:
1412        @@@QName: URIRef.uriPath.1.test        @@@QName: URIRef.uriPath.1.test
# Line 1435  IFClsDef: Line 1417  IFClsDef:
1417          for (          for (
1418            [q<http://example/>, '/', q<http://example/path>, q<http://example>],            [q<http://example/>, '/', q<http://example/path>, q<http://example>],
1419            [q<http://example/path>, '/path', q<http://example/path>,            [q<http://example/path>, '/path', q<http://example/path>,
1420             q<http://example/>],             q<http://example>],
1421            [q<//example/>, '/', q<//example/path>, q<//example/>],            [q<//example/>, '/', q<//example/path>, q<//example>],
1422            [q<//example/path>, '/path', q<//example/path>, q<//example/>],            [q<//example/path>, '/path', q<//example/path>, q<//example>],
1423            [q</path?query>, '/path', q</path?query>, q<?query>],            [q</path?query>, '/path', q</path?query>, q<?query>],
1424            [q<?query>, '', q</path?query>, q<?query>],            [q<?query>, '', q</path?query>, q<?query>],
1425            [q</aaaa#bb:cc>, '/aaaa', q</path#bb:cc>, q<#bb:cc>],            [q</aaaa#bb:cc>, '/aaaa', q</path#bb:cc>, q<#bb:cc>],
# Line 1450  IFClsDef: Line 1432  IFClsDef:
1432            ['about:', '', q<about:/path>, q<about:>],            ['about:', '', q<about:/path>, q<about:>],
1433            ['http://a:b@c:3/', '/', q<http://a:b@c:3/path>,            ['http://a:b@c:3/', '/', q<http://a:b@c:3/path>,
1434             q<http://a:b@c:3>],             q<http://a:b@c:3>],
1435            ['http://a:b@[c@d:4]:3/', '/', q<http://a:b@c:3/path>,            ['http://a:b@[c@d:4]:3/', '/', q<http://a:b@[c@d:4]:3/path>,
1436             q<http://a:b@c:3>],             q<http://a:b@[c@d:4]:3>],
1437          ) {          ) {
1438            $test->id ('get.'.$_->[0]);            $test->id ('get.'.$_->[0]);
1439            my $uri1 = $impl-><M::URIImplementation.createURIReference>            my $uri1 = $impl-><M::URIImplementation.createURIReference>
# Line 1523  IFClsDef: Line 1505  IFClsDef:
1505          @@@@enDesc:          @@@@enDesc:
1506            If there is no query component.            If there is no query component.
1507        @@@PerlDef:        @@@PerlDef:
1508          __DEEP{          if ($$self =~ m!^(?:[^:/?#]+:)?(?://[^/?#]*)?[^?#]*(?:\?([^#]*))?!s) {
1509            my $v = $$self;            $r = $1;
1510            $v =~ s/#.*\z//s;          } else {
1511            if ($v =~ /\?(.*)\z/) {            $r = null;
1512              $r = $1;          }
           } else {  
             $r = null;  
           }  
         }__;  
1513      @@Set:      @@Set:
1514        @@@enDesc:        @@@enDesc:
1515          Replaces the query component of the DOM URI by the new value.          Replaces the query component of the DOM URI by the new value.
# Line 1546  IFClsDef: Line 1524  IFClsDef:
1524          and a <CHAR::QUESTION MARK> character preceding it are removed          and a <CHAR::QUESTION MARK> character preceding it are removed
1525          from the DOM URI.          from the DOM URI.
1526        @@@PerlDef:        @@@PerlDef:
1527          __DEEP{          if ((not defined $given or $given !~ /#/) and
1528            my $v = $$self;              $$self =~ m!^((?:[^:/?#]+:)?(?://[^/?#]*)?[^?#]*)(?:\?[^#]*)?((?:#.*)?)!s) {
1529            my $f = '';            $$self = defined $given ? $1.'?'.$given.$2 : $1.$2;
1530            if ($v =~ s/(#.*)\z//s) {            __DEEP{
1531              $f = $v;              $self-><M::ManakaiURIReference.onQueryChanged>;
1532            }            }__;
1533            $v =~ s/\?.*\z//s;          }
           if (defined $given) {  
             $v .= '?' . $given . $f;  
           } else {  
             $v .= $f;  
           }  
           $$self = $v;  
           $self-><M::ManakaiURIReference.onQueryChanged>;  
         }__;  
           
1534      @@Test:      @@Test:
1535        @@@QName: URIRef.uriQuery.1.test        @@@QName: URIRef.uriQuery.1.test
1536        @@@PerlDef:        @@@PerlDef:
# Line 1664  IFClsDef: Line 1633  IFClsDef:
1633          @@@@enDesc:          @@@@enDesc:
1634            If there is no fragment component.            If there is no fragment component.
1635        @@@PerlDef:        @@@PerlDef:
1636          __DEEP{          if ($$self =~ m!^(?:[^:/?#]+:)?(?://[^/?#]*)?[^?#]*(?:\?[^#]*)?(?:#(.*))?!s) {
1637            my $v = $$self;            $r = $1;
1638            if ($v =~ /#(.*)\z/) {          } else {
1639              $r = $1;            $r = null;
1640            } else {          }
             $r = null;  
           }  
         }__;  
1641      @@Set:      @@Set:
1642        @@@enDesc:        @@@enDesc:
1643          Replaces the fragment component of the DOM URI by the new value.          Replaces the fragment component of the DOM URI by the new value.
# Line 1683  IFClsDef: Line 1649  IFClsDef:
1649          and a <CHAR::NUMBER SIGN> character preceding it are removed          and a <CHAR::NUMBER SIGN> character preceding it are removed
1650          from the DOM URI.          from the DOM URI.
1651        @@@PerlDef:        @@@PerlDef:
1652          __DEEP{          if ($$self =~ m!^((?:[^:/?#]+:)?(?://[^/?#]*)?[^?#]*(?:\?[^#]*)?)(?:#.*)?!s) {
1653            my $v = $$self;            $$self = defined $given ? $1 . '#' . $given : $1;
1654            $v =~ s/#.*\z//s;            __DEEP{
1655            if (defined $given) {              $self-><M::ManakaiURIReference.onFragmentChanged>;
1656              $$self = $v . '#' . $given;            }__;
1657            } else {          }
             $$self = $v;  
           }  
           $self-><M::ManakaiURIReference.onFragmentChanged>;  
         }__;  
1658                    
1659      @@Test:      @@Test:
1660        @@@QName: URIRef.uriFragment.1.test        @@@QName: URIRef.uriFragment.1.test
# Line 1717  IFClsDef: Line 1679  IFClsDef:
1679             q<http://example#fragment>, q<http://example#>, q<http://example>],             q<http://example#fragment>, q<http://example#>, q<http://example>],
1680            [q<http://example#%D9%82%D9%87%D9%88%D8%a9/>,            [q<http://example#%D9%82%D9%87%D9%88%D8%a9/>,
1681             '%D9%82%D9%87%D9%88%D8%a9/',             '%D9%82%D9%87%D9%88%D8%a9/',
1682             q<http://example#fragment>, q<http://example#>, q<http://example#>],             q<http://example#fragment>, q<http://example#>, q<http://example>],
1683            ['about:', null, q<about:#fragment>, q<about:#>, q<about:>],            ['about:', null, q<about:#fragment>, q<about:#>, q<about:>],
1684            ['about:a?b', null, q<about:a?b#fragment>, q<about:a?b#>,            ['about:a?b', null, q<about:a?b#fragment>, q<about:a?b#>,
1685             q<about:a?b>],             q<about:a?b>],
# Line 1807  IFClsDef: Line 1769  IFClsDef:
1769            If there is no <P::index>th path segment.            If there is no <P::index>th path segment.
1770        @@@PerlDef:        @@@PerlDef:
1771          __DEEP{          __DEEP{
1772            $r = [split '/', $self-><AG::URIReference.uriPath>]->[$index];            $r = [split m!/!, $self-><AG::URIReference.uriPath>, -1]->[$index];
1773              $r = '' if not defined $r and
1774                         ($index == 0 or $index == -1); # If path is empty
1775          }__;          }__;
1776    
1777      @@Test:      @@Test:
# Line 1909  IFClsDef: Line 1873  IFClsDef:
1873      @@Return:      @@Return:
1874        @@@PerlDef:        @@@PerlDef:
1875          __DEEP{          __DEEP{
1876            my @p = split '/', $self-><AG::URIReference.uriPath>;            my @p = split m!/!, $self-><AG::URIReference.uriPath>, -1;
1877            if (defined $newValue) {            if (defined $newValue) {
1878              $p[$index] = $newValue;              $p[$index] = $newValue;
1879            } else {            } else {
# Line 1950  IFClsDef: Line 1914  IFClsDef:
1914          $uri1-><M::URIReference.setURIPathSegment> (3, null);          $uri1-><M::URIReference.setURIPathSegment> (3, null);
1915          $test->assert_equals          $test->assert_equals
1916                   ($uri1-><AG::URIReference.uriReference>,                   ($uri1-><AG::URIReference.uriReference>,
1917                    q<http://foo.example/a/b>);                    q<http://foo.example/a/e>);
1918    
1919          $test->id (5);          $test->id (5);
1920          $uri1-><M::URIReference.setURIPathSegment> (1, null);          $uri1-><M::URIReference.setURIPathSegment> (1, null);
1921          $test->assert_equals          $test->assert_equals
1922                   ($uri1-><AG::URIReference.uriReference>,                   ($uri1-><AG::URIReference.uriReference>,
1923                    q<http://foo.example/b>);                    q<http://foo.example/e>);
1924    
1925          $test->id (6);          $test->id (6);
1926          $uri1-><M::URIReference.setURIPathSegment> (-1, 'd');          $uri1-><M::URIReference.setURIPathSegment> (-1, 'd');
# Line 2557  IFClsDef: Line 2521  IFClsDef:
2521        if ($in =~ s/(?:$ipv4|$h16)\z//o) {        if ($in =~ s/(?:$ipv4|$h16)\z//o) {
2522          if ($in =~ /\A(?>$h16:){6}\z/o or          if ($in =~ /\A(?>$h16:){6}\z/o or
2523              $in =~ /\A::(?>$h16:){0,5}\z/o or              $in =~ /\A::(?>$h16:){0,5}\z/o or
2524              $in =~ /\A$h16::(?>$h16:){4}\z/o or              $in =~ /\A${h16}::(?>$h16:){4}\z/o or
2525              $in =~ /\A$h16(?::$h16)?::(?>$h16:){3}\z/o or              $in =~ /\A$h16(?::$h16)?::(?>$h16:){3}\z/o or
2526              $in =~ /\A$h16(?::$h16){0,2}::(?>$h16:){2}\z/o or              $in =~ /\A$h16(?::$h16){0,2}::(?>$h16:){2}\z/o or
2527              $in =~ /\A$h16(?::$h16){0,3}::$h16:\z/o or              $in =~ /\A$h16(?::$h16){0,3}::$h16:\z/o or
# Line 2690  IFClsDef: Line 2654  IFClsDef:
2654          The newly created <IF::URIReference> object.          The newly created <IF::URIReference> object.
2655        @@@PerlDef:        @@@PerlDef:
2656          __DEEP{          __DEEP{
2657            my $v = $$self;            require Encode;
2658              my $v = Encode::encode ('utf8', $$self);
2659            $v =~ s{%([2-9A-Fa-f][0-9A-Fa-f])}            $v =~ s{%([2-9A-Fa-f][0-9A-Fa-f])}
2660                   {                   {
2661                     my $ch = hex $1;                     my $ch = hex $1;
# Line 2724  IFClsDef: Line 2689  IFClsDef:
2689                   }ge;                   }ge;
2690            $v =~ s{(            $v =~ s{(
2691              [\xC2-\xDF][\x80-\xBF] |                          # UTF8-2              [\xC2-\xDF][\x80-\xBF] |                          # UTF8-2
2692              \xE0[\xA0-\xBF][\x80-\xBF] |              [\xE0][\xA0-\xBF][\x80-\xBF] |
2693              [\xE1-\xEC][\x80-\xBF][\x80-\xBF] |              [\xE1-\xEC][\x80-\xBF][\x80-\xBF] |
2694              \xED[\x80-\x9F][\x80-\xBF] |              [\xED][\x80-\x9F][\x80-\xBF] |
2695              [\xEE\xEF][\x80-\xBF][\x80-\xBF] |                # UTF8-3              [\xEE\xEF][\x80-\xBF][\x80-\xBF] |                # UTF8-3
2696              \xF0[\x90-\xBF][\x80-\xBF][\x80-\xBF] |              [\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] |
2697              [\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |              [\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |
2698              \xF4[\x80-\x8F][\x80-\xBF][\x80-\xBF]             # UTF8-4              [\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] |           # UTF8-4
2699                [\x80-\xFF]
2700            )}{            )}{
2701              my $c = $1;              my $c = $1;
2702              require Encode;              if (length ($c) == 1) {
2703              my $ch = Encode::decode ('utf8', $c);                $c =~ s/(.)/sprintf '%%%02X', ord $1/ge;
             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}]/) {  
2704                $c;                $c;
2705              } else {              } else {
2706                $c =~ s/([\x80-\xFF])/sprintf '%%%02X', ord $1/ge;                my $ch = Encode::decode ('utf8', $c);
2707                $c;                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}]/) {
2708                    $c;
2709                  } else {
2710                    $c =~ s/([\x80-\xFF])/sprintf '%%%02X', ord $1/ge;
2711                    $c;
2712                  }
2713              }              }
2714            }gex;            }gex;
2715            $v =~ s/([<>"{}|\\\^`\x00-\x20\x7E-\xFF])/sprintf '%%%02X', ord $1/ge;            $v =~ s/([<>"{}|\\\^`\x00-\x20\x7F])/sprintf '%%%02X', ord $1/ge;
2716              $v = Encode::decode ('utf8', $v);
2717            $r = bless \$v, <ClassName::ManakaiURIReference>;            $r = bless \$v, <ClassName::ManakaiURIReference>;
2718          }__;          }__;
2719    
# Line 3097  IFClsDef: Line 3068  IFClsDef:
3068            in                     => q<eXAMPLE://a/./b/../b/%63/%7bfoo%7d>,            in                     => q<eXAMPLE://a/./b/../b/%63/%7bfoo%7d>,
3069            get_uri_reference      => q<eXAMPLE://a/./b/../b/%63/%7bfoo%7d>,            get_uri_reference      => q<eXAMPLE://a/./b/../b/%63/%7bfoo%7d>,
3070            get_uri_reference_3986 => q<eXAMPLE://a/./b/../b/%63/%7bfoo%7d>,            get_uri_reference_3986 => q<eXAMPLE://a/./b/../b/%63/%7bfoo%7d>,
3071            get_iri_reference      => q<eXAMPLE://a/./b/../b/%63/%7bfoo%7d>,            get_iri_reference      => q<eXAMPLE://a/./b/../b/c/%7bfoo%7d>,
3072            get_iri_reference_3987 => q<eXAMPLE://a/./b/../b/%63/%7bfoo%7d>,            get_iri_reference_3987 => q<eXAMPLE://a/./b/../b/c/%7bfoo%7d>,
3073            is_uri_reference => true, is_iri_reference => true,            is_uri_reference => true, is_iri_reference => true,
3074            is_uri_reference_3986 => true, is_iri_reference_3987 => true,            is_uri_reference_3986 => true, is_iri_reference_3987 => true,
3075            is_uri => true, is_iri => true,            is_uri => true, is_iri => true,
# Line 3317  IFClsDef: Line 3288  IFClsDef:
3288                             is_absolute_uri_3986 is_absolute_iri_3987                             is_absolute_uri_3986 is_absolute_iri_3987
3289                             is_empty_reference/) {                             is_empty_reference/) {
3290            $test->id ($_->{in}.'.'.$method);            $test->id ($_->{in}.'.'.$method);
3291            $test->assert_equals ($uri1->$method, $_->{$method});            my $tm = $_->{$method} ? 'assert_true' : 'assert_false';
3292              $test->$tm ($uri1->$method);
3293          }          }
3294        }        }
3295    
# Line 3429  IFClsDef: Line 3401  IFClsDef:
3401        @@@PerlDef:        @@@PerlDef:
3402          __DEEP{          __DEEP{
3403            ## -- Decomposition            ## -- Decomposition
3404            my @ref;   # Reference            my ($b_scheme, $b_auth, $b_path, $b_query, $b_frag);
3405            my @base;  # Base URI            my ($r_scheme, $r_auth, $r_path, $r_query, $r_frag);
3406    
3407            if ($$self =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!) {            if ($$self =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!s) {
3408              (@ref) = ($1, $2, $3, $4, $5);              ($r_scheme, $r_auth, $r_path, $r_query, $r_frag)
3409                  = ($1, $2, $3, $4, $5);
3410            } else { # unlikely happen            } else { # unlikely happen
3411              (@ref) = (null, null, '', null, null);              ($r_scheme, $r_auth, $r_path, $r_query, $r_frag)
3412                  = (null, null, '', null, null);
3413            }            }
3414            my $ba = ref $base eq 'SCALAR'            my $ba = ref $base eq 'SCALAR'
3415                       ? $base                       ? $base
# Line 3444  IFClsDef: Line 3418  IFClsDef:
3418                           : ref $base                           : ref $base
3419                               ? \"$base"                               ? \"$base"
3420                               : \$base;                               : \$base;
3421            if ($$ba =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!) {            if ($$ba =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!s) {
3422              (@base) = (defined $1 ? $1 : '', $2, $3, $4, $5);              ($b_scheme, $b_auth, $b_path, $b_query, $b_frag)
3423                  = (defined $1 ? $1 : '', $2, $3, $4, $5);
3424            } else { # unlikely happen            } else { # unlikely happen
3425              (@base) = ('', null, '', null, null);              ($b_scheme, $b_auth, $b_path, $b_query, $b_frag)
3426                  = ('', null, '', null, null);
3427            }            }
3428    
3429            ## -- Merge            ## -- Merge
3430            my $merge = sub ($$) {            my $path_merge = sub ($$) {
3431              my ($base, $ref) = @_;              my ($bpath, $rpath) = @_;
3432              if (defined $base->[1] and      # authority              if ($bpath eq '') {
3433                  length ($base->[2]) == 0) { # path                return '/'.$rpath;
               return "/" . $ref->[2];       # path  
             } else {  
               my $bp = $base->[2];          # path  
               $bp =~ s![^/]+\z!!g;  
               return $bp . $ref->[2];       # path  
3434              }              }
3435                $bpath =~ s/[^\/]*\z//;
3436                return $bpath . $rpath;
3437            }; # merge            }; # merge
3438    
3439            ## -- Removing Dot Segments            ## -- Removing Dot Segments
3440            my $remove_dot_segments = sub ($) {            my $remove_dot_segments = sub ($) {
3441              my @input = split m!/!, shift;              local $_ = shift;
3442              my @output;              my $buf = '';
3443              while (@input) {              L: while (length $_) {
3444                if (@input > 1 and ($input[0] eq '.' or $input[0] eq '..')) {                next L if s/^\.\.?\///;
3445                  shift @input;                next L if s/^\/\.(?:\/|\z)/\//;
3446                } elsif ($input[0] eq '' and defined $input[1] and $input[1] eq '.') {                if (s/^\/\.\.(\/|\z)/\//) {
3447                  splice @input, 1, 1;                  $buf =~ s/\/?[^\/]*$//;
3448                } elsif ($input[0] eq '' and defined $input[1] and $input[1] eq '..') {                  next L;
                 splice @input, 1, 1;  
                 pop @output;  
               } elsif (@input == 1 and ($input[0] eq '.' or $input[0] eq '..')) {  
                 shift @input;  
               } elsif (@input == 1) {  
                 push @output, shift @input;  
               } elsif ($input[0] eq '') {  
                 push @output, splice @input, 1, 1;  
               } else {  
                 push @output, shift @input;  
3449                }                }
3450                  last Z if s/^\.\.?\z//;
3451                  s/^(\/?[^\/]*)//;
3452                  $buf .= $1;
3453              }              }
3454              return join '/', @output;              return $buf;
3455            }; # remove_dot_segments            }; # remove_dot_segments
3456    
3457            ## -- Transform            ## -- Transformation
3458            my @t; # Target URI            my ($t_scheme, $t_auth, $t_path, $t_query, $t_frag);
3459    
3460            if ($nonStrict and $ref[0] eq $base[0]) {            if ($nonStrict and $r_scheme eq $b_scheme) {
3461              undef $ref[0];      # scheme              undef $r_scheme;
3462            }            }
3463    
3464            if (defined $ref[0]) {            if (defined $r_scheme) {
3465              $t[0] = $ref[0];    # scheme              $t_scheme = $r_scheme;
3466              $t[1] = $ref[1];    # authority              $t_auth   = $r_auth;
3467              $t[2] = $remove_dot_segments->($ref[2]); # path              $t_path   = $remove_dot_segments->($r_path);
3468              $t[3] = $ref[3];    # query              $t_query  = $r_query;
3469            } elsif (defined $ref[1]) {            } else {
3470              $t[0] = $base[0];   # scheme              if (defined $r_auth) {
3471              $t[1] = $ref[1];    # authority                $t_auth  = $r_auth;
3472              $t[2] = $remove_dot_segments->($ref[2]); # path                $t_path  = $remove_dot_segments->($r_path);
3473              $t[3] = $ref[3];    # query                $t_query = $r_query;
           } elsif ($ref[2] eq '') {  
             $t[0] = $base[0];   # scheme  
             $t[1] = $base[1];   # authority  
             $t[2] = $base[2];   # path  
             if (defined $ref[3]) {  
               $t[3] = $ref[3];  # query  
3474              } else {              } else {
3475                $t[3] = $base[3]; # query                if ($r_path =~ /\A\z/) {
3476                    $t_path = $b_path;
3477                    if (defined $r_query) {
3478                      $t_query = $r_query;
3479                    } else {
3480                      $t_query = $b_query;
3481                    }
3482                  } elsif ($r_path =~ /^\//) {
3483                    $t_path  = $remove_dot_segments->($r_path);
3484                    $t_query = $r_query;
3485                  } else {
3486                    $t_path  = $path_merge->($b_path, $r_path);
3487                    $t_path  = $remove_dot_segments->($t_path);
3488                    $t_query = $r_query;
3489                  }
3490                  $t_auth = $b_auth;
3491              }              }
3492            } elsif (substr ($ref[2], 0, 1) eq '/') {              $t_scheme = $b_scheme;
             $t[0] = $base[0];   # scheme  
             $t[1] = $base[1];   # authority  
             $t[2] = $remove_dot_segments->($ref[2]); # path  
             $t[3] = $ref[3];    # query  
           } else {  
             $t[0] = $base[0];   # scheme  
             $t[1] = $base[1];   # authority  
             $t[2] = $remove_dot_segments->($merge->(\@base, \@ref)); # path  
             $t[3] = $ref[3];    # query  
3493            }            }
3494            $t[4] = $ref[4];      # fragment            $t_frag = $r_frag;
3495    
3496            ## -- Recomposition            ## -- Recomposition
3497            my $result  = ''                                 ;            my $result  = ''                                      ;
3498            $result .=        $t[0] . ':' if defined $t[0];  # scheme;            $result .=        $t_scheme . ':' if defined $t_scheme;
3499            $result .= '//' . $t[1]       if defined $t[1];  # authority            $result .= '//' . $t_auth         if defined $t_auth  ;
3500            $result .=        $t[2]                       ;  # path            $result .=        $t_path                             ;
3501            $result .= '?'  . $t[3]       if defined $t[3];  # query            $result .= '?'  . $t_query        if defined $t_query ;
3502            $result .= '#'  . $t[4]       if defined $t[4];  # fragment            $result .= '#'  . $t_frag         if defined $t_frag  ;
3503    
3504            $r = bless \$result, <ClassName::ManakaiURIReference>;            $r = bless \$result, <ClassName::ManakaiURIReference>;
3505          }__;          }__;
# Line 3572  IFClsDef: Line 3538  IFClsDef:
3538          __CODE{createURIImplForTest:: $impl => $impl}__;          __CODE{createURIImplForTest:: $impl => $impl}__;
3539    
3540          for (          for (
3541              ## From RFC 3986
3542            ["g:h"           =>  "g:h"],            ["g:h"           =>  "g:h"],
3543            ["g"             =>  "http://a/b/c/g"],            ["g"             =>  "http://a/b/c/g"],
3544            ["./g"           =>  "http://a/b/c/g"],            ["./g"           =>  "http://a/b/c/g"],
# Line 3614  IFClsDef: Line 3581  IFClsDef:
3581            ["g#s/./x"       =>  "http://a/b/c/g#s/./x"],            ["g#s/./x"       =>  "http://a/b/c/g#s/./x"],
3582            ["g#s/../x"      =>  "http://a/b/c/g#s/../x"],            ["g#s/../x"      =>  "http://a/b/c/g#s/../x"],
3583            ["http:g"        =>  "http:g"],            ["http:g"        =>  "http:g"],
3584              ## From "http://www.gbiv.com/protocols/uri/test/rel_examples1.html"
3585              ["http:"         =>  "http:"],
3586              ## From "http://www.w3.org/2004/04/uri-rel-test.html"
3587              ["./g:h"         =>  "http://a/b/c/g:h"],
3588          ) {          ) {
3589            my $ref = $impl-><M::URIImplementation.createURIReference> ($_->[0]);            my $ref = $impl-><M::URIImplementation.createURIReference> ($_->[0]);
3590    
# Line 3642  IFClsDef: Line 3613  IFClsDef:
3613          my $impl;          my $impl;
3614          __CODE{createURIImplForTest:: $impl => $impl}__;          __CODE{createURIImplForTest:: $impl => $impl}__;
3615    
3616          my $ref = $impl-><M::URIImplementation.createURIReference>          ## From "http://www.gbiv.com/protocols/uri/test/rel_examples1.html"
                            ('http://a/b/c/d;p?q');  
3617    
3618          $test->id ('string');          $test->id (1);
3619            my $ref = $impl-><M::URIImplementation.createURIReference>
3620                               (q<http:g>);
3621          my $t1 = $ref-><M::URIReference.getAbsoluteReference>          my $t1 = $ref-><M::URIReference.getAbsoluteReference>
3622                           (q<http:g>);                           (q<http://a/b/c/d;p?q>, non_strict => true);
3623          $test->assert_equals ($t1-><AG::URIReference.uriReference>,          $test->assert_equals ($t1-><AG::URIReference.uriReference>,
3624                                q<http://a/b/c/g>, true);                                q<http://a/b/c/g>);
3625    
3626            $test->id (2);
3627            my $ref2 = $impl-><M::URIImplementation.createURIReference>
3628                               (q<http:>);
3629            my $t2 = $ref2-><M::URIReference.getAbsoluteReference>
3630                             (q<http://a/b/c/d;p?q>, non_strict => true);
3631            $test->assert_equals ($t2-><AG::URIReference.uriReference>,
3632                                  q<http://a/b/c/d;p?q>);
3633    
3634    @Method:    @Method:
3635      @@Name: getAbsoluteReference3987      @@Name: getAbsoluteReference3987
# Line 3853  IFClsDef: Line 3833  IFClsDef:
3833        @@@PerlDef:        @@@PerlDef:
3834          __DEEP{          __DEEP{
3835            my @base;            my @base;
3836            if ("$base" =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!) {            my $ba = ref $base eq 'SCALAR'
3837                         ? $base
3838                         : ref $base eq <ClassName::ManakaiURIReference>
3839                             ? $base
3840                             : ref $base
3841                                 ? \"$base"
3842                                 : \$base;
3843              if ($$ba =~ m!\A(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?\z!) {
3844              (@base) = (defined $1 ? $1 : '', $2, $3, $4, $5);              (@base) = (defined $1 ? $1 : '', $2, $3, $4, $5);
3845            } else { # unlikeley happen            } else { # unlikeley happen
3846              (@base) = ('', null, '', null, null);              (@base) = ('', null, '', null, null);
# Line 3894  IFClsDef: Line 3881  IFClsDef:
3881                  $t[2] eq $base[2] and                            # path                  $t[2] eq $base[2] and                            # path
3882                  ((not defined $t[3] and not defined $base[3]) or # query                  ((not defined $t[3] and not defined $base[3]) or # query
3883                   (defined $t[3] and defined $base[3] and $t[3] eq $base[3]))) {                   (defined $t[3] and defined $base[3] and $t[3] eq $base[3]))) {
3884                (@ref) = (null, null, null, null, $t[4]);                (@ref) = (null, null, '', null, $t[4]);
3885                last R;                last R;
3886              }              }
3887    
3888              ## Path              ## Path
3889              my @tpath = split m!/!, $t[2];              my @tpath = split m!/!, $t[2], -1;
3890              my @bpath = split m!/!, $base[2];              my @bpath = split m!/!, $base[2], -1;
3891              my $tp;              if (@tpath < 1 or @bpath < 1) {  ## No |/|
3892              my $tp2;                (@ref) = @t;
3893              while (@tpath and @bpath and $tpath[0] eq $bpath[0]) {                last R;
               $tp2 = $tp;  
               $tp = shift @tpath;  
               shift @bpath;  
3894              }              }
3895              unless (@bpath) {              my $bpl;
3896                unshift @tpath, $tp;  
3897                ($tp2, $tp) = (null, $tp2);              ## Removes common segments
3898                while (@tpath and @bpath and $tpath[0] eq $bpath[0]) {
3899                  shift @tpath;
3900                  $bpl = shift @bpath;
3901              }              }
3902              unless (@tpath) {   ## Avoid empty path component for compatibility  
3903                if ($tp eq '') {              if (@tpath == 0) {
3904                  unshift @tpath, '.';                if (@bpath == 0) { ## Avoid empty path for backward compatibility
3905                    unshift @tpath, $bpl;
3906                } else {                } else {
3907                  unshift @tpath, $tp;                  unshift @tpath, '..', $bpl;
3908                }                }
3909                } elsif (@bpath == 0) {
3910                  unshift @tpath, $bpl;
3911              }              }
3912              unshift @tpath, '..' x @bpath;  
3913              if (@tpath and ($tpath[0] =~ /:/ or              unshift @tpath, ('..') x (@bpath - 1) if @bpath > 1;
3914                              $tpath[0] eq '')) {  
3915                unshift @tpath, '.';              unshift @tpath, '.' if $tpath[0] eq '' or
3916              }                                     $tpath[0] =~ /:/;
3917    
3918              (@ref) = (null, null, (join '/', @tpath), $t[3], $t[4]);              (@ref) = (null, null, (join '/', @tpath), $t[3], $t[4]);
3919            } # R            } # R
3920    
# Line 3973  IFClsDef: Line 3964  IFClsDef:
3964          __CODE{createURIImplForTest:: $impl => $impl}__;          __CODE{createURIImplForTest:: $impl => $impl}__;
3965    
3966          for (          for (
3967            [q<http://www.example/>, q<http://www.example/>, q<.>],            [q<http://www.example/>, q<http://www.example/>, q<./>],
3968            [q<http://www.example/>, q<http://www2.example/>, q<http://www.example/>],            [q<http://www.example/>, q<http://www2.example/>, q<http://www.example/>],
3969            [q<http://a/b/c/e/f>, q<http://a/b/c/e>, q<e/f>],            [q<http://a/b/c/e/f>, q<http://a/b/c/e>, q<e/f>],
3970            [q<http://a/b/c/e>, q<http://a/b/c/e>, q<e>],            [q<http://a/b/c/e>, q<http://a/b/c/e>, q<e>],
# Line 3981  IFClsDef: Line 3972  IFClsDef:
3972            [q<http://a/b/c/d>, q<http://a/b/c/e>, q<d>],            [q<http://a/b/c/d>, q<http://a/b/c/e>, q<d>],
3973            [q<http://a/b/c/d/>, q<http://a/b/c/e>, q<d/>],            [q<http://a/b/c/d/>, q<http://a/b/c/e>, q<d/>],
3974            [q<http://a/b/c>, q<http://a/b/c/e>, q<../c>],            [q<http://a/b/c>, q<http://a/b/c/e>, q<../c>],
3975            [q<http://a/b/c/>, q<http://a/b/c/e>, q<../>],            [q<http://a/b/c/>, q<http://a/b/c/e>, q<./>],
3976            [q<http://a/b>, q<http://a/b/c/e>, q<../../>],            [q<http://a/b/>, q<http://a/b/c/e>, q<../>],
3977              [q<http://a/b>, q<http://a/b/c/e>, q<../../b>],
3978              [q<http://a/>, q<http://a/b/c/e>, q<../../>],
3979              [q<http://a>, q<http://a/b/c/e>, q<http://a>],
3980            [q<http://a/b/d/f>, q<http://a/b/c/e>, q<../d/f>],            [q<http://a/b/d/f>, q<http://a/b/c/e>, q<../d/f>],
3981            [q<about:blank>, q<http://a/>, q<about:blank>],            [q<about:blank>, q<http://a/>, q<about:blank>],
3982            [q<http://a/about:blank>, q<http://a/b>, q<./about:blank>],            [q<http://a/about:blank>, q<http://a/b>, q<./about:blank>],
3983            [q<http://a//>, q<http://a/>, q<./>],            [q<http://a//>, q<http://a/>, q<.//>],
3984            [q<a>, q<http://a/b/>, q<a>],            [q<a>, q<http://a/b/>, q<a>],
3985            [q<http://a/b#a>, q<http://a/b#b>, q<#a>],            [q<http://a/b#a>, q<http://a/b#b>, q<#a>],
3986            [q<http://a/c#a>, q<http://a/b#a>, q<c#a>],            [q<http://a/c#a>, q<http://a/b#a>, q<c#a>],
3987            [q<http://a/b/?c>, q<http://a/b/>, q<?c>],            [q<http://a/b/?c>, q<http://a/b/>, q<./?c>],
3988          ) {          ) {
3989            $test->id ($_->[0].'.'.$_->[1]);            $test->id ($_->[0].'.'.$_->[1]);
3990            my $ref = $impl-><M::URIImplementation.createURIReference> ($_->[0]);            my $ref = $impl-><M::URIImplementation.createURIReference> ($_->[0]);
# Line 4116  IFClsDef: Line 4110  IFClsDef:
4110        @@@PerlDef:        @@@PerlDef:
4111          my $v = $$self;          my $v = $$self;
4112          $r = bless \$v, <ClassName::ManakaiURIReference>;          $r = bless \$v, <ClassName::ManakaiURIReference>;
4113    
4114        @@Test:
4115          @@@QName: URIRef.clone.Test
4116          @@@PerlDef:
4117            my $impl;
4118            __CODE{createURIImplForTest:: $impl => $impl}__;
4119    
4120            my $ref = $impl-><M::URIImplementation.createURIReference> (q<a>);
4121    
4122            $test->id ('cloneURIRef');
4123            my $ref2 = $ref-><M::URIReference.cloneURIReference>;
4124            $test->assert_equals ($ref2-><AG::URIReference.uriReference>, q<a>);
4125    
4126            $test->id ('cloneURIRef.diff');
4127            $ref2-><AS::URIReference.uriReference> (q<b>);
4128            $test->assert_equals ($ref-><AG::URIReference.uriReference>, q<a>);
4129    
4130            $test->id ('clone');
4131            my $ref3 = $ref->clone;
4132            $test->assert_equals ($ref3-><AG::URIReference.uriReference>, q<a>);
4133    
4134            $test->id ('clone.diff');
4135            $ref3-><AS::URIReference.uriReference> (q<b>);
4136            $test->assert_equals ($ref-><AG::URIReference.uriReference>, q<a>);
4137  ##URIReference  ##URIReference
4138    
4139  ResourceDef:  ResourceDef:
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24