+ Added test for RFC3896 compliance of ResolveRelativeUri().

git-svn-id: trunk@20542 -

.gitattributes

@@ -9992,6 +9992,7 @@ tests/test/packages/cocoaint/tw20876.pp svneol=native#text/plain
 tests/test/packages/cocoaint/uw20875a.pp svneol=native#text/plain
 tests/test/packages/cocoaint/uw20875b.pp svneol=native#text/plain
 tests/test/packages/fcl-base/tascii85.pp svneol=native#text/plain
+tests/test/packages/fcl-base/testuri.pp svneol=native#text/plain
 tests/test/packages/fcl-base/tgettext1.pp svneol=native#text/plain
 tests/test/packages/fcl-db/assertions.pas svneol=native#text/plain
 tests/test/packages/fcl-db/dbftoolsunit.pas svneol=native#text/plain

tests/test/packages/fcl-base/testuri.pp

@@ -0,0 +1,154 @@
+program TestUri;
+{ Tests RFC3896 compliance of ResolveRelativeUri(). Also includes basic URI encode/decode test. }
+
+{$IFDEF FPC}
+{$MODE OBJFPC}{$H+}
+{$ENDIF}
+
+uses
+  uriparser;
+
+var
+  URI: TURI;
+  s: String;
+
+procedure TestParse;
+begin
+  with URI do
+  begin
+    Protocol := 'http';
+    Username := 'user';
+    Password := 'pass';
+    Host := 'localhost';
+    Port := 8080;
+    Path := '/test/dir';
+    Document := 'some index.html';
+    Params := 'param1=value1&param2=value2';
+    Bookmark := 'bookmark';
+    HasAuthority := True;
+  end;
+
+  s := EncodeURI(URI);
+  WriteLn(s);
+
+  Finalize(URI);
+  FillChar(URI, SizeOf(URI), 0);
+  Writeln;
+
+//  URI := ParseURI(s, 'defaultprotocol', 1234);
+  URI:=ParseURI('http://www.lazarus.freepascal.org/main.php');
+  with URI do
+  begin
+    WriteLn('Protocol: ', Protocol);
+    WriteLn('Username: ', Username);
+    WriteLn('Password: ', Password);
+    WriteLn('Host: ', Host);
+    WriteLn('Port: ', Port);
+    WriteLn('Path: ', Path);
+    WriteLn('Document: ', Document);
+    WriteLn('Params: ', Params);
+    WriteLn('Bookmark: ', Bookmark);
+  end;
+end;  
+
+type
+  urirec = record
+    a, b: string
+  end;
+
+const
+  Base = 'http://a/b/c/d;p?q';
+
+  tests: array[0..22] of urirec = (
+    (a: 'g:h'; b: 'g:h'),
+    (a: 'g';   b: 'http://a/b/c/g'),
+    (a: './g'; b: 'http://a/b/c/g'),
+    (a: 'g/';  b: 'http://a/b/c/g/'),
+    (a: '/g';  b: 'http://a/g'),
+    (a: '//g'; b: 'http://g'),
+    (a: '?y';  b: 'http://a/b/c/d;p?y'),
+    (a: 'g?y'; b: 'http://a/b/c/g?y'),
+    (a: '#s';  b: 'http://a/b/c/d;p?q#s'),
+    (a: 'g#s'; b: 'http://a/b/c/g#s'),
+    (a: 'g?y#s'; b: 'http://a/b/c/g?y#s'),
+    (a: ';x';  b: 'http://a/b/c/;x'),
+    (a: 'g;x'; b: 'http://a/b/c/g;x'),
+    (a: 'g;x?y#s'; b: 'http://a/b/c/g;x?y#s'),
+    (a: '';    b: 'http://a/b/c/d;p?q'),
+    (a: '.';   b: 'http://a/b/c/'),
+    (a: './';  b: 'http://a/b/c/'),
+    (a: '..';  b: 'http://a/b/'),
+    (a: '../'; b: 'http://a/b/'),
+    (a: '../g'; b: 'http://a/b/g'),
+    (a: '../..'; b: 'http://a/'),
+    (a: '../../'; b: 'http://a/'),
+    (a: '../../g'; b: 'http://a/g')
+  );
+
+  tests1: array[0..1] of urirec = (
+    (a: '../../../g';    b: 'http://a/g'),
+    (a: '../../../../g'; b: 'http://a/g')
+  );
+
+  tests2: array[0..5] of urirec = (
+    (a: '/./g';  b: 'http://a/g'),
+    (a: '/../g'; b: 'http://a/g'),
+    (a: 'g.';    b: 'http://a/b/c/g.'),
+    (a: '.g';    b: 'http://a/b/c/.g'),
+    (a: 'g..';   b: 'http://a/b/c/g..'),
+    (a: '..g';   b: 'http://a/b/c/..g')
+  );
+
+  tests3: array[0..5] of urirec = (
+    (a: './../g'; b: 'http://a/b/g'),
+    (a: './g/.';  b: 'http://a/b/c/g/'),
+    (a: 'g/./h';  b: 'http://a/b/c/g/h'),
+    (a: 'g/../h'; b: 'http://a/b/c/h'),
+    (a: 'g;x=1/./y';  b: 'http://a/b/c/g;x=1/y'),
+    (a: 'g;x=1/../y'; b: 'http://a/b/c/y')
+  );
+
+  tests4: array[0..3] of urirec = (
+    (a: 'g?y/./x';  b: 'http://a/b/c/g?y/./x'),
+    (a: 'g?y/../x'; b: 'http://a/b/c/g?y/../x'),
+    (a: 'g#s/./x';  b: 'http://a/b/c/g#s/./x'),
+    (a: 'g#s/../x'; b: 'http://a/b/c/g#s/../x')
+  );
+
+procedure Test(const Caption: string; const t: array of urirec);
+var
+  rslt: string;
+  i: Integer;
+  Failed: Boolean;
+begin
+  write(Caption, '...');
+  Failed := False;
+  for i := low(t) to high(t) do
+  begin
+    ResolveRelativeUri(Base, t[i].a, rslt);
+    if rslt <> t[i].b then
+    begin
+      if not Failed then writeln;
+      Failed := True;
+      writeln('Test ', i, ' mismatch, expected: ''', t[i].b, '''; got: ''', rslt, '''');
+    end;
+  end;
+  if not Failed then
+    writeln(' OK')
+  else
+  begin
+    writeln(' Failed!');
+    Halt(1);
+  end;  
+end;
+
+begin
+  TestParse;
+  Writeln;
+  Writeln('Now testing relative URI resolving:');
+  Test('Normal tests', tests);
+  Test('URI authority is not changed by using dot segments', tests1);
+  Test('Dot segments are removed only if they are complete path components', tests2);
+  Test('Testing some nonsensical forms of URI', tests3);
+  Test('Testing dot segments present in query or fragments', tests4);
+end.