* Patch from Giulio Bernardi to add more resource testing

git-svn-id: branches/resources@9698 -

.gitattributes

@@ -7623,7 +7623,15 @@ tests/test/units/system/tres.pp -text
 tests/test/units/system/tres1.rc -text
 tests/test/units/system/tres1.res -text
 tests/test/units/system/tres1.txt -text
+tests/test/units/system/tres1_it.txt svneol=native#text/plain
+tests/test/units/system/tres2.pp svneol=native#text/plain
 tests/test/units/system/tres2.txt -text
+tests/test/units/system/tres2ext.pp svneol=native#text/plain
+tests/test/units/system/tres3.pp svneol=native#text/plain
+tests/test/units/system/tres3ext.pp svneol=native#text/plain
+tests/test/units/system/tresb.rc svneol=native#text/plain
+tests/test/units/system/tresb.res -text
+tests/test/units/system/tresext.pp svneol=native#text/plain
 tests/test/units/system/tround.pp svneol=native#text/plain
 tests/test/units/system/tseg.pp svneol=native#text/plain
 tests/test/units/system/tsetstr.pp svneol=native#text/plain

tests/test/units/system/tres.pp

@@ -1,6 +1,6 @@
 { Test for resources support. }
 
-{%TARGET=win32,win64,wince,linux}
+{%TARGET=win32,win64,wince,linux,freebsd,darwin,netbsd,openbsd,solaris}
 
 {$mode objfpc}
 
@@ -14,8 +14,8 @@ end;
 
 function GetResource(ResourceName, ResourceType: PChar; PResSize: PLongInt = nil): pointer;
 var
-  hRes: TResourceHandle;
-  gRes: HGLOBAL;
+  hRes: TFPResourceHandle;
+  gRes: TFPResourceHGLOBAL;
 begin
   hRes:=FindResource(HINSTANCE, ResourceName, ResourceType);
   if hRes = 0 then

tests/test/units/system/tres1_it.txt

@@ -0,0 +1 @@
+test file (italian).

tests/test/units/system/tres2.pp

@@ -0,0 +1,91 @@
+{ Test for FindResourceEx function. }
+
+{%TARGET=win32,win64,linux,freebsd,darwin,netbsd,openbsd,solaris}
+
+{$mode objfpc}
+
+uses
+  sysutils;
+
+{$R tresb.res}
+
+procedure Fail(const Msg: string);
+begin
+  writeln(Msg);
+  Halt(1);
+end;
+
+function GetResource(ResourceType, ResourceName: PChar; ResLang : word; PResSize: PLongInt = nil): pointer;
+var
+  hRes: TFPResourceHandle;
+  gRes: TFPResourceHGLOBAL;
+begin
+  writeln('trying ',ResourceType,':',ResourceName,':',IntToHex(ResLang,4));
+  hRes:=FindResourceEx(HINSTANCE, ResourceType,ResourceName,ResLang);
+  if hRes = 0 then
+    Fail('FindResourceEx failed.');
+  gRes:=LoadResource(HINSTANCE, hRes);
+  if gRes = 0 then
+    Fail('LoadResource failed.');
+  if PResSize <> nil then begin
+    PResSize^:=SizeofResource(HINSTANCE, hRes);
+    if PResSize^ = 0 then
+      Fail('SizeofResource failed.');
+  end;
+  Result:=LockResource(gRes);
+  if Result = nil then
+    Fail('LockResource failed.');
+end;
+
+procedure DoTest;
+const
+  LANG_ENGLISH = $09;
+  SUBLANG_ENGLISH_US = $01;
+  LANG_ITALIAN = $10;
+  SUBLANG_ITALIAN = $01;
+  SUBLANG_ITALIAN_SWISS = $02;
+  LANG_GERMAN = $07;
+  SUBLANG_GERMAN = $01;
+var
+  s: string;
+  p: PChar;
+  sz: longint;
+begin
+  //us english, exact match
+  p:=GetResource('FILE','TestFile', MakeLangID(LANG_ENGLISH,SUBLANG_ENGLISH_US), @sz);
+  SetString(s, p, sz);
+  if s <> 'test file.' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+  
+  //italian, exact match
+  p:=GetResource('FILE','TestFile', MakeLangID(LANG_ITALIAN,SUBLANG_ITALIAN), @sz);
+  SetString(s, p, sz);
+  if s <> 'test file (italian).' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+
+  { On Windows, FindResourceEx behaviour varies between versions, so we
+    can't rely on the following tests }
+  {$IFNDEF WINDOWS}
+  //swiss italian , should fallback to italian
+  p:=GetResource('FILE','TestFile', MakeLangID(LANG_ITALIAN,SUBLANG_ITALIAN_SWISS), @sz);
+  SetString(s, p, sz);
+  if s <> 'test file (italian).' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+
+  //german, should fallback on the first resource found (english)
+  p:=GetResource('FILE','TestFile', MakeLangID(LANG_GERMAN,SUBLANG_GERMAN), @sz);
+  SetString(s, p, sz);
+  if s <> 'test file.' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+  {$ENDIF}
+end;
+
+begin
+  writeln('Resources test.');
+  DoTest;
+  writeln('Done.');
+end.

tests/test/units/system/tres2ext.pp

@@ -0,0 +1,92 @@
+{ Test for FindResourceEx function - external resources. }
+
+{%TARGET=darwin}
+{%OPT=-We}
+
+{$mode objfpc}
+
+uses
+  sysutils;
+
+{$R tresb.res}
+
+procedure Fail(const Msg: string);
+begin
+  writeln(Msg);
+  Halt(1);
+end;
+
+function GetResource(ResourceType, ResourceName: PChar; ResLang : word; PResSize: PLongInt = nil): pointer;
+var
+  hRes: TFPResourceHandle;
+  gRes: TFPResourceHGLOBAL;
+begin
+  writeln('trying ',ResourceType,':',ResourceName,':',IntToHex(ResLang,4));
+  hRes:=FindResourceEx(HINSTANCE, ResourceType,ResourceName,ResLang);
+  if hRes = 0 then
+    Fail('FindResourceEx failed.');
+  gRes:=LoadResource(HINSTANCE, hRes);
+  if gRes = 0 then
+    Fail('LoadResource failed.');
+  if PResSize <> nil then begin
+    PResSize^:=SizeofResource(HINSTANCE, hRes);
+    if PResSize^ = 0 then
+      Fail('SizeofResource failed.');
+  end;
+  Result:=LockResource(gRes);
+  if Result = nil then
+    Fail('LockResource failed.');
+end;
+
+procedure DoTest;
+const
+  LANG_ENGLISH = $09;
+  SUBLANG_ENGLISH_US = $01;
+  LANG_ITALIAN = $10;
+  SUBLANG_ITALIAN = $01;
+  SUBLANG_ITALIAN_SWISS = $02;
+  LANG_GERMAN = $07;
+  SUBLANG_GERMAN = $01;
+var
+  s: string;
+  p: PChar;
+  sz: longint;
+begin
+  //us english, exact match
+  p:=GetResource('FILE','TestFile', MakeLangID(LANG_ENGLISH,SUBLANG_ENGLISH_US), @sz);
+  SetString(s, p, sz);
+  if s <> 'test file.' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+  
+  //italian, exact match
+  p:=GetResource('FILE','TestFile', MakeLangID(LANG_ITALIAN,SUBLANG_ITALIAN), @sz);
+  SetString(s, p, sz);
+  if s <> 'test file (italian).' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+
+  { On Windows, FindResourceEx behaviour varies between versions, so we
+    can't rely on the following tests }
+  {$IFNDEF WINDOWS}
+  //swiss italian , should fallback to italian
+  p:=GetResource('FILE','TestFile', MakeLangID(LANG_ITALIAN,SUBLANG_ITALIAN_SWISS), @sz);
+  SetString(s, p, sz);
+  if s <> 'test file (italian).' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+
+  //german, should fallback on the first resource found (english)
+  p:=GetResource('FILE','TestFile', MakeLangID(LANG_GERMAN,SUBLANG_GERMAN), @sz);
+  SetString(s, p, sz);
+  if s <> 'test file.' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+  {$ENDIF}
+end;
+
+begin
+  writeln('Resources test.');
+  DoTest;
+  writeln('Done.');
+end.

tests/test/units/system/tres3.pp

@@ -0,0 +1,110 @@
+{ Test for resource enumeration functions. }
+
+{%TARGET=win32,win64,linux,freebsd,darwin,netbsd,openbsd,solaris}
+
+{$mode objfpc}
+
+uses
+  sysutils;
+
+{$R tresb.res}
+
+procedure Fail(const Msg: string);
+begin
+  writeln(Msg);
+  Halt(1);
+end;
+
+type
+  TResInfo = record
+    name : pchar;
+    _type : pchar;
+    langid : word;
+    found : boolean;
+  end;
+
+const
+  rescount = 3;
+
+var
+  reslst : array[1..rescount] of TResInfo =
+  (
+  (name : 'TESTFILE'; _type : 'FILE'; langid : $0409; found : false),
+  (name : 'TEST'; _type : 'TEXT'; langid : $0409; found : false),
+  (name : 'TESTFILE'; _type : 'FILE'; langid : $0410; found : false)
+  );
+
+function CompareDesc(d1, d2 : PChar) : boolean;
+begin
+  if Is_IntResource(d1) then
+    Result:=PtrUInt(d1)=PtrUInt(d2)
+  else
+    Result:=CompareChar0(d1[0],d2[0],MaxInt)=0;
+end;
+
+procedure ResFound(ResourceType, ResourceName : PChar; IDLanguage : word);
+var i : integer;
+begin
+  for i:=1 to rescount do
+  begin
+    if CompareDesc(reslst[i].name,ResourceName) and
+       CompareDesc(reslst[i]._type,ResourceType) and
+       (reslst[i].langid=IDLanguage) then
+         if reslst[i].found then
+           Fail('Resource found twice!')
+         else
+         begin
+           reslst[i].found:=true;
+           exit;
+         end;
+  end;
+  Fail('Resource not found!');
+end;
+
+function ResLangProc(ModuleHandle : TFPResourceHMODULE; ResourceType, ResourceName : PChar; IDLanguage : word; lParam : PtrInt) : LongBool; stdcall;
+begin
+  writeln('        Lang: ',IntToHex(IDLanguage,4));
+  Result:=true;
+  ResFound(ResourceType,ResourceName,IDLanguage);
+end;
+
+function ResNameProc(ModuleHandle : TFPResourceHMODULE; ResourceType, ResourceName : PChar; lParam : PtrInt) : LongBool; stdcall;
+begin
+  if Is_IntResource(ResourceName) then
+    writeln('    Name: ',PtrUint(ResourceName))
+  else
+    writeln('    Name: ',ResourceName);
+  EnumResourceLanguages(ModuleHandle,ResourceType,ResourceName,@ResLangProc,lParam);
+  Result:=true;
+end;
+
+function ResTypeProc(ModuleHandle : TFPResourceHMODULE; ResourceType : PChar; lParam : PtrInt) : LongBool; stdcall;
+begin
+  if Is_IntResource(ResourceType) then
+    writeln('Type: ',PtrUint(ResourceType))
+  else
+    writeln('Type: ',ResourceType);
+  EnumResourceNames(ModuleHandle,ResourceType,@ResNameProc,lParam);
+  Result:=true;
+end;
+
+procedure CheckFound;
+var i : integer;
+begin
+  for i:=1 to rescount do
+  begin
+    if not reslst[i].found then
+      Fail('Resource #'+IntToStr(i)+' was not found!');
+  end;
+end;
+
+procedure DoTest;
+begin
+  EnumResourceTypes(HINSTANCE,@ResTypeProc,0);
+end;
+
+begin
+  writeln('Resources test.');
+  DoTest;
+  writeln('Done.');
+end.

tests/test/units/system/tres3ext.pp

@@ -0,0 +1,111 @@
+{ Test for resource enumeration functions - external resources. }
+
+{%TARGET=darwin}
+{%OPT=-We}
+
+{$mode objfpc}
+
+uses
+  sysutils;
+
+{$R tresb.res}
+
+procedure Fail(const Msg: string);
+begin
+  writeln(Msg);
+  Halt(1);
+end;
+
+type
+  TResInfo = record
+    name : pchar;
+    _type : pchar;
+    langid : word;
+    found : boolean;
+  end;
+
+const
+  rescount = 3;
+
+var
+  reslst : array[1..rescount] of TResInfo =
+  (
+  (name : 'TESTFILE'; _type : 'FILE'; langid : $0409; found : false),
+  (name : 'TEST'; _type : 'TEXT'; langid : $0409; found : false),
+  (name : 'TESTFILE'; _type : 'FILE'; langid : $0410; found : false)
+  );
+
+function CompareDesc(d1, d2 : PChar) : boolean;
+begin
+  if Is_IntResource(d1) then
+    Result:=PtrUInt(d1)=PtrUInt(d2)
+  else
+    Result:=CompareChar0(d1[0],d2[0],MaxInt)=0;
+end;
+
+procedure ResFound(ResourceType, ResourceName : PChar; IDLanguage : word);
+var i : integer;
+begin
+  for i:=1 to rescount do
+  begin
+    if CompareDesc(reslst[i].name,ResourceName) and
+       CompareDesc(reslst[i]._type,ResourceType) and
+       (reslst[i].langid=IDLanguage) then
+         if reslst[i].found then
+           Fail('Resource found twice!')
+         else
+         begin
+           reslst[i].found:=true;
+           exit;
+         end;
+  end;
+  Fail('Resource not found!');
+end;
+
+function ResLangProc(ModuleHandle : TFPResourceHMODULE; ResourceType, ResourceName : PChar; IDLanguage : word; lParam : PtrInt) : LongBool; stdcall;
+begin
+  writeln('        Lang: ',IntToHex(IDLanguage,4));
+  Result:=true;
+  ResFound(ResourceType,ResourceName,IDLanguage);
+end;
+
+function ResNameProc(ModuleHandle : TFPResourceHMODULE; ResourceType, ResourceName : PChar; lParam : PtrInt) : LongBool; stdcall;
+begin
+  if Is_IntResource(ResourceName) then
+    writeln('    Name: ',PtrUint(ResourceName))
+  else
+    writeln('    Name: ',ResourceName);
+  EnumResourceLanguages(ModuleHandle,ResourceType,ResourceName,@ResLangProc,lParam);
+  Result:=true;
+end;
+
+function ResTypeProc(ModuleHandle : TFPResourceHMODULE; ResourceType : PChar; lParam : PtrInt) : LongBool; stdcall;
+begin
+  if Is_IntResource(ResourceType) then
+    writeln('Type: ',PtrUint(ResourceType))
+  else
+    writeln('Type: ',ResourceType);
+  EnumResourceNames(ModuleHandle,ResourceType,@ResNameProc,lParam);
+  Result:=true;
+end;
+
+procedure CheckFound;
+var i : integer;
+begin
+  for i:=1 to rescount do
+  begin
+    if not reslst[i].found then
+      Fail('Resource #'+IntToStr(i)+' was not found!');
+  end;
+end;
+
+procedure DoTest;
+begin
+  EnumResourceTypes(HINSTANCE,@ResTypeProc,0);
+end;
+
+begin
+  writeln('Resources test.');
+  DoTest;
+  writeln('Done.');
+end.

tests/test/units/system/tresb.rc

@@ -0,0 +1,11 @@
+#include <windres.h>
+
+LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
+
+TestFile FILE "tres1.txt"
+Test TEXT "tres2.txt"
+
+LANGUAGE LANG_ITALIAN, SUBLANG_ITALIAN
+TestFile FILE "tres1_it.txt"
+
+

tests/test/units/system/tresext.pp

@@ -0,0 +1,60 @@
+{ Test for resources support - external resources. }
+
+{%TARGET=darwin}
+{%OPT=-We}
+
+{$mode objfpc}
+
+{$R tres1.res}
+
+procedure Fail(const Msg: string);
+begin
+  writeln(Msg);
+  Halt(1);
+end;
+
+function GetResource(ResourceName, ResourceType: PChar; PResSize: PLongInt = nil): pointer;
+var
+  hRes: TFPResourceHandle;
+  gRes: TFPResourceHGLOBAL;
+begin
+  hRes:=FindResource(HINSTANCE, ResourceName, ResourceType);
+  if hRes = 0 then
+    Fail('FindResource failed.');
+  gRes:=LoadResource(HINSTANCE, hRes);
+  if gRes = 0 then
+    Fail('LoadResource failed.');
+  if PResSize <> nil then begin
+    PResSize^:=SizeofResource(HINSTANCE, hRes);
+    if PResSize^ = 0 then
+      Fail('SizeofResource failed.');
+  end;
+  Result:=LockResource(gRes);
+  if Result = nil then
+    Fail('LockResource failed.');
+end;
+
+procedure DoTest;
+var
+  s: string;
+  p: PChar;
+  sz: longint;
+begin
+  p:=GetResource('TestFile', 'FILE', @sz);
+  SetString(s, p, sz);
+  if s <> 'test file.' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+  
+  p:=GetResource('Test', 'TEXT', @sz);
+  SetString(s, p, sz);
+  if s <> 'Another test file.' then
+    Fail('Invalid resource loaded.');
+  writeln(s);
+end;
+
+begin
+  writeln('Resources test.');
+  DoTest;
+  writeln('Done.');
+end.