--- Merging r16320 into '.':

U    rtl/inc/variants.pp
--- Merging r16322 into '.':
A    tests/test/units/variants
A    tests/test/units/variants/tcustomvariant.pp
--- Merging r16323 into '.':
G    rtl/inc/variants.pp
--- Merging r16326 into '.':
U    packages/pthreads/src/pthrlinux.inc
--- Merging r16336 into '.':
U    rtl/unix/ipc.pp
U    rtl/linux/ostypes.inc
U    rtl/linux/ipccall.inc
U    rtl/linux/ipcsys.inc
--- Merging r16339 into '.':
G    rtl/unix/ipc.pp
G    rtl/linux/ipccall.inc
G    rtl/linux/ipcsys.inc
--- Merging r16341 into '.':
U    packages/fcl-web/src/base/fphttp.pp
--- Merging r16342 into 'tests/utils':
U    tests/utils/redir.pp
--- Merging r16343 into '.':
U    rtl/inc/exeinfo.pp
--- Merging r16345 into '.':
U    packages/fpmkunit/src/fpmkunit.pp

# revisions: 16320,16322,16323,16326,16336,16339,16341,16342,16343,16345
------------------------------------------------------------------------
r16320 | sergei | 2010-11-10 13:17:40 +0100 (Wed, 10 Nov 2010) | 2 lines
Changed paths:
   M /trunk/rtl/inc/variants.pp

+ variants.pp: implemented FindCustomVariantType(byTypeName overloaded version)
+ also implemented some trivial methods of TCustomVariantType and TInvokeableVariantType
------------------------------------------------------------------------
------------------------------------------------------------------------
r16322 | sergei | 2010-11-10 17:21:19 +0100 (Wed, 10 Nov 2010) | 1 line
Changed paths:
   A /trunk/tests/test/units/variants
   A /trunk/tests/test/units/variants/tcustomvariant.pp

+ Added a basic test for TCustomVariantType creation functionality.
------------------------------------------------------------------------
------------------------------------------------------------------------
r16323 | sergei | 2010-11-10 17:27:23 +0100 (Wed, 10 Nov 2010) | 3 lines
Changed paths:
   M /trunk/rtl/inc/variants.pp

* variants.pp, modified TCustomVariantType constructors to they pass basic tests (tests/units/variants/tcustomvariant.pp)
  * Changed allowed custom VarType range to $10F..$FFF (as specified in Delphi documentation).

------------------------------------------------------------------------
------------------------------------------------------------------------
r16326 | tom_at_work | 2010-11-11 19:45:42 +0100 (Thu, 11 Nov 2010) | 1 line
Changed paths:
   M /trunk/packages/pthreads/src/pthrlinux.inc

Remove linux only "Pascal-style" variants of pthreads header translation
------------------------------------------------------------------------
------------------------------------------------------------------------
r16336 | jonas | 2010-11-13 17:58:23 +0100 (Sat, 13 Nov 2010) | 16 lines
Changed paths:
   M /trunk/rtl/linux/ipccall.inc
   M /trunk/rtl/linux/ipcsys.inc
   M /trunk/rtl/linux/ostypes.inc
   M /trunk/rtl/unix/ipc.pp

  o fixed several Linux ipc bugs, based on patch by Ruben Chaer/
      Pablo Alfaro (mantis #14075, also fixes #13363):
    * ipc msgtyp is clong, not cint
    * TIPC_Perm and TSEMid_ds are different on 64 bit systems
    * fixed passing semun arguments (have to be passed by value, not reference)
    * fixed the order of parameters to msg* syscalls, and don't use
      TIPC_Kludge for msgrcv syscall (only for ipccall.inc variants)
    * use new operation variants on 64 bit platforms in ipccall.inc
  * introduced use kernel_mode/uid/gid_t types for use by the Linux ipc
    records
  * fixed type of TSEMid_ds.sem_base for Darwin
  * added {$packrecords c} to ipc unit, and {$packrecords 4} around
    certain structs for Darwin as in the C headers
  * fixed passing semun argument to semctl for libc platforms (by
    value, not reference)

------------------------------------------------------------------------
------------------------------------------------------------------------
r16339 | jonas | 2010-11-13 19:37:43 +0100 (Sat, 13 Nov 2010) | 3 lines
Changed paths:
   M /trunk/rtl/linux/ipccall.inc
   M /trunk/rtl/linux/ipcsys.inc
   M /trunk/rtl/unix/ipc.pp

  + semtimedop() for Linux, marked as "platform" (last part of patch from
    mantis #14075)

------------------------------------------------------------------------
------------------------------------------------------------------------
r16341 | joost | 2010-11-13 22:16:29 +0100 (Sat, 13 Nov 2010) | 1 line
Changed paths:
   M /trunk/packages/fcl-web/src/base/fphttp.pp

 * Make sure that the value of ActionVar is passed as actionname to the OnGetAction event
------------------------------------------------------------------------
------------------------------------------------------------------------
r16342 | pierre | 2010-11-14 11:38:03 +0100 (Sun, 14 Nov 2010) | 1 line
Changed paths:
   M /trunk/tests/utils/redir.pp

 * Fix windows code to avoid closing unopened files
------------------------------------------------------------------------
------------------------------------------------------------------------
r16343 | jonas | 2010-11-14 12:59:24 +0100 (Sun, 14 Nov 2010) | 3 lines
Changed paths:
   M /trunk/rtl/inc/exeinfo.pp

  * fixed potential buffer overflow errors (reported by Stian Skjelstad,
    mantis #17922)

------------------------------------------------------------------------
------------------------------------------------------------------------
r16345 | joost | 2010-11-14 14:07:21 +0100 (Sun, 14 Nov 2010) | 1 line
Changed paths:
   M /trunk/packages/fpmkunit/src/fpmkunit.pp

 * Added ability to specify absolute paths to install files into
------------------------------------------------------------------------

git-svn-id: branches/fixes_2_4@16566 -

.gitattributes

@@ -8954,6 +8954,7 @@ tests/test/units/sysutils/tfloattostr.pp svneol=native#text/plain
 tests/test/units/sysutils/tlocale.pp svneol=native#text/plain
 tests/test/units/sysutils/tsscanf.pp svneol=native#text/plain
 tests/test/units/sysutils/tstrtobool.pp svneol=native#text/plain
+tests/test/units/variants/tcustomvariant.pp svneol=native#text/plain
 tests/test/uprec6.pp svneol=native#text/plain
 tests/test/uprec7.pp svneol=native#text/plain
 tests/test/uprocext1.pp svneol=native#text/plain

.gitignore

@@ -6967,6 +6967,13 @@ tests/test/units/sysutils/*.s
 tests/test/units/sysutils/fpcmade.*
 tests/test/units/sysutils/units
 tests/test/units/units
+tests/test/units/variants/*.bak
+tests/test/units/variants/*.exe
+tests/test/units/variants/*.o
+tests/test/units/variants/*.ppu
+tests/test/units/variants/*.s
+tests/test/units/variants/fpcmade.*
+tests/test/units/variants/units
 tests/units/*.bak
 tests/units/*.exe
 tests/units/*.o

packages/fcl-web/src/base/fphttp.pp

@@ -397,15 +397,16 @@ end;
 function TCustomWebActions.GetActionName(ARequest: TRequest): String;
 
 begin
+  If (FActionVar<>'') then
+    Result:=ARequest.QueryFields.Values[FActionVar]
+  else
+    Result := '';
   If Assigned(FOnGetAction) then
     FOnGetAction(Self,ARequest,Result);
+  // GetNextPathInfo is only used after OnGetAction, so that the call to 
+  // GetNextPathInfo can be avoided in the event.
   If (Result='') then
-    begin
-    If (FActionVar<>'') then
-      Result:=ARequest.QueryFields.Values[FActionVar];
-    If (Result='') then
-      Result:=ARequest.GetNextPathInfo;
-    end;
+    Result:=ARequest.GetNextPathInfo;
 end;
 
 constructor TCustomWebActions.Create(AItemClass: TCollectionItemClass);

packages/fpmkunit/src/fpmkunit.pp

@@ -956,6 +956,7 @@ Function StringToMode(const S : String) : TCompilerMode;
 Function MakeTargetString(CPU : TCPU;OS: TOS) : String;
 Procedure StringToCPUOS(const S : String; Var CPU : TCPU; Var OS: TOS);
 Function FixPath (const APath : String) : String;
+Function IsRelativePath(const APath : String) : boolean;
 Procedure ChangeDir(const APath : String);
 Function Substitute(Const Source : String; Macros : Array of string) : String;
 Procedure SplitCommand(Const Cmd : String; Var Exe,Options : String);
@@ -1440,6 +1441,20 @@ begin
     end;
 end;
 
+function IsRelativePath(const APath: String): boolean;
+begin
+  if APath='' then
+    result := true
+{$ifdef unix}
+  else if APath[1] in AllowDirectorySeparators then
+    result := false
+{$else}
+  else if ExtractFileDrive(APath)<>'' then
+    result := false
+{$endif}
+  else
+    result := true;
+end;
 
 procedure ChangeDir(const APath : String);
 begin
@@ -3377,7 +3392,10 @@ begin
     For I:=0 to List.Count-1 do
       if List.Names[i]<>'' then
         begin
-          DestFileName:=DestDir+list.ValueFromIndex[i];
+          if IsRelativePath(list.ValueFromIndex[i]) then
+            DestFileName:=DestDir+list.ValueFromIndex[i]
+          else
+            DestFileName:=list.ValueFromIndex[i];
           CmdCreateDir(ExtractFilePath(DestFileName));
           SysCopyFile(List.names[i],DestFileName)
         end

packages/pthreads/src/pthrlinux.inc

@@ -309,96 +309,3 @@ type
   function sem_getvalue(__sem:Psem_t; __sval:pcint):cint;cdecl;external libthreads;
   function sem_timedwait(__sem: Psem_t; __abstime: Ptimespec):cint;cdecl; external libthreads;
 
-{ ---------------------------------------------------------------------
-     Overloaded versions with var args instead of pointers
-  ---------------------------------------------------------------------}
-
-  function pthread_create(var __thread:pthread_t; var __attr: pthread_attr_t; __start_routine:TStartRoutine; __arg:pointer):cint;cdecl; external libthreads;
-  function pthread_join(__th:pthread_t; var __thread_return:pointer):cint;cdecl; external libthreads;
-  function pthread_attr_init(var __attr: pthread_attr_t):cint;cdecl; external libthreads;
-  function pthread_attr_destroy(var __attr: pthread_attr_t):cint;cdecl; external libthreads;
-  function pthread_attr_setdetachstate(var __attr: pthread_attr_t; __detachstate:cint):cint;cdecl; external libthreads;
-  function pthread_attr_getdetachstate(var __attr: pthread_attr_t; var __detachstate:cint):cint;cdecl; external libthreads;
-  function pthread_attr_setschedparam(var __attr: pthread_attr_t; const __param: sched_param):cint;cdecl; external libthreads;
-  function pthread_attr_getschedparam(var __attr: pthread_attr_t; var __param: sched_param):cint;cdecl; external libthreads;
-  function pthread_attr_setschedpolicy(var __attr: pthread_attr_t; __policy:cint):cint;cdecl; external libthreads;
-  function pthread_attr_getschedpolicy(var __attr: pthread_attr_t; var __policy:cint):cint;cdecl; external libthreads;
-  function pthread_attr_setinheritsched(var __attr: pthread_attr_t; __inherit:cint):cint;cdecl; external libthreads;
-  function pthread_attr_getinheritsched(var __attr: pthread_attr_t; var __inherit: cint):cint;cdecl; external libthreads;
-  function pthread_attr_setscope(var __attr: pthread_attr_t; __scope:cint):cint;cdecl; external libthreads;
-  function pthread_attr_getscope(var __attr: pthread_attr_t; var __scope: cint):cint;cdecl; external libthreads;
-  function pthread_attr_setstackaddr(var __attr: pthread_attr_t; __stackaddr:pointer):cint;cdecl; external libthreads;
-  function pthread_attr_getstackaddr(var __attr: pthread_attr_t; var __stackaddr:pointer):cint;cdecl; external libthreads;
-  function pthread_attr_setstacksize(var __attr: pthread_attr_t; __stacksize:size_t):cint;cdecl; external libthreads;
-  function pthread_attr_getstacksize(var __attr: pthread_attr_t; var __stacksize: size_t):cint;cdecl; external libthreads;
-  function pthread_attr_getguardsize(var __attr: pthread_attr_t; var Guardsize: Cardinal): cint; cdecl;external libthreads;
-  function pthread_attr_setguardsize(var __attr: pthread_attr_t; Guardsize: Cardinal): cint; cdecl;external libthreads;
-  function pthread_setschedparam(__target_thread:pthread_t; __policy:cint; const __param: sched_param):cint;cdecl; external libthreads;
-  function pthread_getschedparam(__target_thread:pthread_t; var __policy: cint; var __param: sched_param):cint;cdecl; external libthreads;
-  function pthread_mutex_init(var __mutex: pthread_mutex_t; var __mutex_attr: pthread_mutexattr_t):cint;cdecl; external libthreads;
-  function pthread_mutex_destroy(var __mutex: pthread_mutex_t):cint;cdecl; external libthreads;
-  function pthread_mutex_trylock(var __mutex: pthread_mutex_t):cint;cdecl; external libthreads;
-  function pthread_mutex_lock(var __mutex: pthread_mutex_t):cint;cdecl; external libthreads;
-  function pthread_mutex_unlock(var __mutex: pthread_mutex_t):cint;cdecl; external libthreads;
-  function pthread_mutexattr_init(var __attr: pthread_mutexattr_t):cint;cdecl; external libthreads;
-  function pthread_mutexattr_destroy(var __attr: pthread_mutexattr_t):cint;cdecl; external libthreads;
-  function pthread_mutexattr_getpshared(var __attr: pthread_mutexattr_t; var __pshared: cint):cint;cdecl; external libthreads;
-  function pthread_mutexattr_setpshared(var __attr: pthread_mutexattr_t; __pshared:cint):cint;cdecl; external libthreads;
-  function pthread_mutexattr_settype(var __attr: pthread_mutexattr_t; Kind: cint): cint; cdecl;external libthreads;
-  function pthread_mutexattr_gettype(var __attr: pthread_mutexattr_t; var Kind: cint): cint; cdecl;external libthreads;
-  function pthread_cond_init(var __cond: pthread_cond_t;var __cond_attr: pthread_condattr_t):cint;cdecl; external libthreads;
-  function pthread_cond_destroy(var __cond: pthread_cond_t):cint;cdecl; external libthreads;
-  function pthread_cond_signal(var __cond: pthread_cond_t):cint;cdecl; external libthreads;
-  function pthread_cond_broadcast(var __cond: pthread_cond_t):cint;cdecl; external libthreads;
-  function pthread_cond_wait(var __cond: pthread_cond_t; var __mutex: pthread_mutex_t):cint;cdecl; external libthreads;
-  function pthread_cond_timedwait(var __cond: pthread_cond_t; var __mutex: pthread_mutex_t; var __abstime: timespec):cint;cdecl; external libthreads;
-  function pthread_condattr_init(var __attr: pthread_condattr_t):cint;cdecl; external libthreads;
-  function pthread_condattr_destroy(var __attr: pthread_condattr_t):cint;cdecl; external libthreads;
-  function pthread_condattr_getpshared(var __attr: pthread_condattr_t; var __pshared:cint):cint;cdecl; external libthreads;
-  function pthread_condattr_setpshared(var __attr: pthread_condattr_t; __pshared:cint):cint;cdecl; external libthreads;
-  function pthread_rwlock_init(var __rwlock: pthread_rwlock_t; var __attr: pthread_rwlockattr_t):cint;cdecl; external libthreads;
-  function pthread_rwlock_destroy(var __rwlock: pthread_rwlock_t):cint;cdecl;external libthreads;
-  function pthread_rwlock_rdlock(var __rwlock: pthread_rwlock_t):cint;cdecl;external libthreads;
-  function pthread_rwlock_tryrdlock(var __rwlock: pthread_rwlock_t):cint;cdecl;external libthreads;
-  function pthread_rwlock_timedrdlock(var __rwlock: pthread_rwlock_t; __abstime:Ptimespec):cint;cdecl;external libthreads;
-  function pthread_rwlock_wrlock(var __rwlock: pthread_rwlock_t):cint;cdecl;external libthreads;
-  function pthread_rwlock_trywrlock(var __rwlock: pthread_rwlock_t):cint;cdecl; external libthreads;
-  function pthread_rwlock_timedwrlock(var __rwlock: pthread_rwlock_t; __abstime:Ptimespec):cint;cdecl;external libthreads;
-  function pthread_rwlock_unlock(var __rwlock: pthread_rwlock_t):cint;cdecl;external libthreads;
-  function pthread_rwlockattr_init(var __attr: pthread_rwlockattr_t):cint;cdecl;external libthreads;
-  function pthread_rwlockattr_destroy(var __attr: pthread_rwlockattr_t):cint;cdecl;external libthreads;
-  function pthread_rwlockattr_getpshared(var __attr: pthread_rwlockattr_t; var __pshared: cint):cint;cdecl;external libthreads;
-  function pthread_rwlockattr_setpshared(var __attr: pthread_rwlockattr_t; __pshared:cint):cint;cdecl;external libthreads;
-  function pthread_rwlockattr_getkind_np(var __attr: pthread_rwlockattr_t; var __pref: cint):cint;cdecl;external libthreads;
-  function pthread_rwlockattr_setkind_np(var __attr: pthread_rwlockattr_t; __pref:cint):cint;cdecl;external libthreads;
-  function pthread_spin_init(var __lock: pthread_spinlock_t; __pshared:cint):cint;cdecl;external libthreads;
-  function pthread_spin_destroy(var __lock: pthread_spinlock_t):cint;cdecl;external libthreads;
-  function pthread_spin_lock(var __lock: pthread_spinlock_t):cint;cdecl;external libthreads;
-  function pthread_spin_trylock(var __lock: pthread_spinlock_t):cint;cdecl;external libthreads;
-  function pthread_spin_unlock(var __lock: pthread_spinlock_t):cint;cdecl;external libthreads;
-  function pthread_barrier_init(var __barrier: pthread_barrier_t;var __attr: pthread_barrierattr_t; __count:dword):cint;cdecl;external libthreads;
-  function pthread_barrier_destroy(var __barrier: pthread_barrier_t):cint;cdecl;external libthreads;
-  function pthread_barrierattr_init(var __attr: pthread_barrierattr_t):cint;cdecl;external libthreads;
-  function pthread_barrierattr_destroy(var __attr: pthread_barrierattr_t):cint;cdecl;external libthreads;
-  function pthread_barrierattr_getpshared(var __attr: pthread_barrierattr_t; var __pshared:cint):cint;cdecl;external libthreads;
-  function pthread_barrierattr_setpshared(var __attr: pthread_barrierattr_t; __pshared:cint):cint;cdecl;external libthreads;
-  function pthread_barrier_wait(var __barrier: pthread_barrier_t):cint;cdecl;external libthreads;
-  function pthread_key_create(var __key: pthread_key_t; __destr_function :TKeyValueDestructor):cint;cdecl; external libthreads;
-  function pthread_once(var __once_control: pthread_once_t; __init_routine:Tprocedure ):cint;cdecl; external libthreads;
-  function pthread_setcancelstate(__state:cint; var __oldstate:cint):cint;cdecl; external libthreads;
-  function pthread_setcanceltype(__type:cint;var __oldtype:cint):cint;cdecl; external libthreads;
-
-  procedure _pthread_cleanup_push(var __buffer: _pthread_cleanup_buffer; __routine:TPthreadCleanupRoutine; __arg:pointer);cdecl; external libthreads;
-  procedure _pthread_cleanup_pop(var __buffer:_pthread_cleanup_buffer; __execute:cint);cdecl; external libthreads;
-  function pthread_sigmask(__how:cint; var __newmask:__sigset_t; var __oldmask:__sigset_t):cint;cdecl; external libthreads;
-
-  function sem_init(var __sem: sem_t; __pshared:cint; __value:dword):cint;cdecl;external libthreads;
-  function sem_destroy(var __sem: sem_t):cint;cdecl;external libthreads;
-  function sem_close(var __sem: sem_t):cint;cdecl;external libthreads;
-  function sem_wait(var __sem: sem_t):cint;cdecl;external libthreads;
-  function sem_timedwait(var __sem: sem_t; var __abstime: timespec):cint;cdecl; external libthreads;
-  function sem_trywait(var __sem: sem_t):cint;cdecl;external libthreads;
-  function sem_post(var __sem: sem_t):cint;cdecl;external libthreads;
-  function sem_getvalue(var __sem: sem_t; var __sval:cint):cint;cdecl;external libthreads;
-
-

rtl/inc/exeinfo.pp

@@ -783,7 +783,7 @@ begin
      fillchar(secnamebuf,sizeof(secnamebuf),0);
      oldofs:=filepos(e.f);
      seek(e.f,e.secstrofs+elfsec.sh_name);
-     blockread(e.f,secnamebuf,sizeof(secnamebuf),bufsize);
+     blockread(e.f,secnamebuf,sizeof(secnamebuf)-1,bufsize);
      seek(e.f,oldofs);
      secname:=strpas(secnamebuf);
      if asecname=secname then
@@ -1137,7 +1137,7 @@ begin
   if length(dbgfn)=0 then
     exit;
   i:=align(length(dbgfn)+1,4);
-  if i>dbglinklen then
+  if (i+4)>dbglinklen then
     exit;
   move(dbglink[i],dbgcrc,4);
   { current dir }

rtl/inc/variants.pp

@@ -265,7 +265,7 @@ type
       CallDesc: PCallDesc; Params: Pointer); cdecl;
 
 Const
-  CMaxNumberOfCustomVarTypes = $06FF;
+  CMaxNumberOfCustomVarTypes = $0EFF;
   CMinVarType = $0100;
   CMaxVarType = CMinVarType + CMaxNumberOfCustomVarTypes;
   CIncVarType = $000F;
@@ -367,6 +367,7 @@ uses
 var
   customvarianttypes    : array of TCustomVariantType;
   customvarianttypelock : trtlcriticalsection;
+  customvariantcurrtype : LongInt;
 
 const
   { all variants for which vType and varComplexType = 0 do not require
@@ -3548,13 +3549,31 @@ function FindCustomVariantType(const aVarType: TVarType; out CustomVariantType:
   end;
 
 
-{$warnings off}
 function FindCustomVariantType(const TypeName: string;  out CustomVariantType: TCustomVariantType): Boolean; overload;
-
-begin
-  NotSupported('FindCustomVariantType');
-end;
-{$warnings on}
+  var
+    i: Integer;
+    tmp: TCustomVariantType;
+    ShortTypeName: shortstring;
+  begin
+    ShortTypeName:=TypeName;  // avoid conversion in the loop
+    result:=False;
+    EnterCriticalSection(customvarianttypelock);
+    try
+      for i:=low(customvarianttypes) to high(customvarianttypes) do
+        begin
+          tmp:=customvarianttypes[i];
+          result:=Assigned(tmp) and (tmp<>InvalidCustomVariantType) and
+            tmp.ClassNameIs(ShortTypeName);
+          if result then
+            begin
+              CustomVariantType:=tmp;
+              Exit;
+            end;
+        end;
+    finally
+      LeaveCriticalSection(customvarianttypelock);
+    end;
+  end;
 
 function Unassigned: Variant; // Unassigned standard constant
 begin
@@ -3569,30 +3588,37 @@ function Null: Variant;       // Null standard constant
     TVarData(Result).vType := varNull;
   end;
 
+procedure VarDispInvokeError;
+  begin
+    raise EVariantDispatchError(SDispatchError);
+  end;
 
 { ---------------------------------------------------------------------
     TCustomVariantType Class.
   ---------------------------------------------------------------------}
 
-{$warnings off}
+{ All TCustomVariantType descendants are singletons, they ignore automatic refcounting. }
 function TCustomVariantType.QueryInterface(const IID: TGUID; out Obj): HResult;  stdcall;
   begin
-    NotSupported('TCustomVariantType.QueryInterface');
+    if GetInterface(IID, obj) then
+      result := S_OK
+    else
+      result := E_NOINTERFACE;
   end;
 
 
 function TCustomVariantType._AddRef: Integer; stdcall;
   begin
-    NotSupported('TCustomVariantType._AddRef');
+    result := -1;
   end;
 
 
 function TCustomVariantType._Release: Integer; stdcall;
   begin
-    NotSupported('TCustomVariantType._Release');
+    result := -1;
   end;
 
-
+{$warnings off}
 procedure TCustomVariantType.SimplisticClear(var V: TVarData);
   begin
     NotSupported('TCustomVariantType.SimplisticClear');
@@ -3607,20 +3633,19 @@ end;
 
 procedure TCustomVariantType.RaiseInvalidOp;
 begin
-  NotSupported('TCustomVariantType.RaiseInvalidOp');
+  VarInvalidOp;
 end;
 
 
 procedure TCustomVariantType.RaiseCastError;
 begin
-  NotSupported('TCustomVariantType.RaiseCastError');
+  VarCastError;
 end;
 
 
 procedure TCustomVariantType.RaiseDispError;
-
 begin
-  NotSupported('TCustomVariantType.RaiseDispError');
+  VarDispInvokeError;
 end;
 
 
@@ -3649,7 +3674,7 @@ end;
 procedure TCustomVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
 
 begin
-  NotSupported('TCustomVariantType.DispInvoke');
+  RaiseDispError;
 end;
 
 
@@ -3788,24 +3813,53 @@ begin
 end;
 
 
-constructor TCustomVariantType.Create;
+procedure RegisterCustomVariantType(obj: TCustomVariantType; RequestedVarType: TVarType;
+  UseFirstAvailable: Boolean);
+var
+  index,L: Integer;
 begin
-  inherited Create;
   EnterCriticalSection(customvarianttypelock);
   try
-    SetLength(customvarianttypes,Length(customvarianttypes)+1);
-    customvarianttypes[High(customvarianttypes)]:=self;
-    FVarType:=CMinVarType+High(customvarianttypes);
+    L:=Length(customvarianttypes);
+    if UseFirstAvailable then
+    begin
+      repeat
+        inc(customvariantcurrtype);
+        if customvariantcurrtype>=CMaxVarType then
+          raise EVariantError.Create(SVarTypeTooManyCustom);
+      until ((customvariantcurrtype-CMinVarType)>=L) or
+        (customvarianttypes[customvariantcurrtype-CMinVarType]=nil);
+      RequestedVarType:=customvariantcurrtype;
+    end
+    else if (RequestedVarType<CFirstUserType) or (RequestedVarType>CMaxVarType) then
+      raise EVariantError.CreateFmt(SVarTypeOutOfRangeWithPrefix, ['$', RequestedVarType]);
+
+    index:=RequestedVarType-CMinVarType;
+    if index>=L then
+      SetLength(customvarianttypes,L+1);
+    if Assigned(customvarianttypes[index]) then
+    begin
+      if customvarianttypes[index]=InvalidCustomVariantType then
+        raise EVariantError.CreateFmt(SVarTypeNotUsableWithPrefix, ['$', RequestedVarType])
+      else
+        raise EVariantError.CreateFmt(SVarTypeAlreadyUsedWithPrefix,
+          ['$', RequestedVarType, customvarianttypes[index].ClassName]);
+    end;
+    customvarianttypes[index]:=obj;
+    obj.FVarType:=RequestedVarType;
   finally
     LeaveCriticalSection(customvarianttypelock);
   end;
 end;
 
+constructor TCustomVariantType.Create;
+begin
+  RegisterCustomVariantType(Self,0,True);
+end;
 
 constructor TCustomVariantType.Create(RequestedVarType: TVarType);
-
 begin
-  FVarType:=RequestedVarType;
+  RegisterCustomVariantType(Self,RequestedVarType,False);
 end;
 
 
@@ -3889,7 +3943,6 @@ end;
     TInvokeableVariantType implementation
   ---------------------------------------------------------------------}
 
-{$warnings off}
 procedure TInvokeableVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
 
 begin
@@ -3899,28 +3952,31 @@ end;
 function TInvokeableVariantType.DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
 
 begin
-  NotSupported('TInvokeableVariantType.DoFunction');
+  result := False;
 end;
 
 function TInvokeableVariantType.DoProcedure(const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
 begin
-  NotSupported('TInvokeableVariantType.DoProcedure');
+  result := False
 end;
 
 
 function TInvokeableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
   begin
-    NotSupported('TInvokeableVariantType.GetProperty');
+    result := False;
   end;
 
 
 function TInvokeableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean;
   begin
-    NotSupported('TInvokeableVariantType.SetProperty');
+    result := False;
   end;
-{$warnings on}
 
 
+{ ---------------------------------------------------------------------
+    TPublishableVariantType implementation
+  ---------------------------------------------------------------------}
+
 function TPublishableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
   begin
     Result:=true;
@@ -4424,6 +4480,8 @@ var
 
 Initialization
   InitCriticalSection(customvarianttypelock);
+  // start with one-less value, so first increment yields CFirstUserType
+  customvariantcurrtype:=CFirstUserType-1;
   SetSysVariantManager;
   SetClearVarToEmptyParam(TVarData(EmptyParam));
   VarClearProc:=@DoVarClear;

rtl/linux/ipccall.inc

@@ -25,37 +25,45 @@ begin
     end;
 end;
 
+{$ifdef linux_ipc32}
+const
+  ipc_api_select = 0;    // 16-bit gid/pid types and old structs
+{$else}
+const
+  ipc_api_select = $100; // 32-bit gid/pid types and newer structs
+{$endif}
+
 Const
-  CALL_SEMOP   = 1;
-  CALL_SEMGET  = 2;
-  CALL_SEMCTL  = 3;
-  CALL_MSGSND  = 11;
-  CALL_MSGRCV  = 12;
-  CALL_MSGGET  = 13;
-  CALL_MSGCTL  = 14;
-  CALL_SHMAT   = 21;
-  CALL_SHMDT   = 22;
-  CALL_SHMGET  = 23;
-  CALL_SHMCTL  = 24;
+  CALL_SEMOP      = 1 +ipc_api_select;
+  CALL_SEMGET     = 2 +ipc_api_select;
+  CALL_SEMCTL     = 3 +ipc_api_select;
+  CALL_SEMTIMEDOP = 4 +ipc_api_select;
+  CALL_MSGSND     = 11+ipc_api_select;
+  CALL_MSGRCV     = 12+ipc_api_select;
+  CALL_MSGGET     = 13+ipc_api_select;
+  CALL_MSGCTL     = 14+ipc_api_select;
+  CALL_SHMAT      = 21+ipc_api_select;
+  CALL_SHMDT      = 22+ipc_api_select;
+  CALL_SHMGET     = 23+ipc_api_select;
+  CALL_SHMCTL     = 24+ipc_api_select;
 
 { generic call that handles all IPC calls }
 
-function ipccall(Call,First,Second,Third : cint; P : Pointer) : ptrint;
+function ipccall(Call: cuint; First: cint; Second,Third : culong; P: pointer; Fifth: clong) : ptrint;
 begin
- ipccall:=do_syscall(syscall_nr_ipc,call,first,second,third,ptrint(P));
-// ipcerror:=fpgetErrno;
+ ipccall:=do_syscall(syscall_nr_ipc,TSysParam(call),TSysParam(first),TSysParam(second),TSysParam(third),TSysParam(P),TSysParam(Fifth));
 end;
 
 function shmget(key: Tkey; size:size_t; flag:cint):cint;
 begin
-  shmget:=ipccall (CALL_SHMGET,key,size,flag,nil);
+  shmget:=ipccall (CALL_SHMGET,key,size,flag,nil,0);
 end;
 
 Function shmat (shmid:cint; shmaddr:pointer; shmflg:cint):pointer;
 Var raddr : pchar;
     error : ptrint;
 begin
-  error:=ipccall(CALL_SHMAT,shmid,shmflg,cint(@raddr),shmaddr);
+  error:=ipccall(CALL_SHMAT,shmid,shmflg,cint(@raddr),shmaddr,0);
   If Error<0 then
     shmat:=pchar(error)
   else
@@ -64,55 +72,60 @@ end;
 
 function shmdt (shmaddr:pointer): cint;
 begin
-  shmdt:=ipccall(CALL_SHMDT,0,0,0,shmaddr);
+  shmdt:=ipccall(CALL_SHMDT,0,0,0,shmaddr,0);
 end;
 
 function shmctl(shmid:cint; cmd:cint; buf: pshmid_ds): cint;
 begin
- shmctl:=ipccall(CALL_SHMCTL,shmid,cmd,0,buf);
+ shmctl:=ipccall(CALL_SHMCTL,shmid,cmd,0,buf,0);
 end;
 
 function msgget(key:Tkey; msgflg:cint):cint;
 begin
-  msgget:=ipccall(CALL_MSGGET,key,msgflg,0,Nil);
+  msgget:=ipccall(CALL_MSGGET,key,msgflg,0,Nil,0);
 end;
 
 function msgsnd(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgflg:cint):cint;
 begin
-  msgsnd:=ipccall(Call_MSGSND,msqid,msgsz,msgflg,msgp);
+  msgsnd:=ipccall(Call_MSGSND,msqid,msgsz,msgflg,msgp,0);
 end;
 
-function msgrcv(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgtyp:cint; msgflg:cint):cint;
+function msgrcv(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgtyp:clong; msgflg:cint):cint;
 Type
   TIPC_Kludge = Record
     msgp   : pmsgbuf;
-    msgtyp : cint;
+    msgtyp : clong;
   end;
 Var
    tmp : TIPC_Kludge;
 begin
   tmp.msgp   := msgp;
   tmp.msgtyp := msgtyp;
-  msgrcv:=ipccall(CALL_MSGRCV,msqid,msgsz,msgflg,@tmp);
+  msgrcv:=ipccall(CALL_MSGRCV,msqid,msgsz,msgflg,@tmp,0);
 end;
 
 Function msgctl(msqid:cint; cmd: cint; buf: PMSQid_ds): cint;
 begin
-  msgctl:=ipccall(CALL_MSGCTL,msqid,cmd,0,buf);
+  msgctl:=ipccall(CALL_MSGCTL,msqid,cmd,0,buf,0);
 end;
 
 Function semget(key:Tkey; nsems:cint; semflg:cint): cint;
 begin
-  semget:=ipccall (CALL_SEMGET,key,nsems,semflg,Nil);
+  semget:=ipccall (CALL_SEMGET,key,nsems,semflg,Nil,0);
 end;
 
 Function semop(semid:cint; sops: psembuf; nsops:cuint): cint;
 begin
-  semop:=ipccall (CALL_SEMOP,semid,cint(nsops),0,Pointer(sops));
+  semop:=ipccall (CALL_SEMOP,semid,cint(nsops),0,Pointer(sops),0);
 end;
 
 Function semctl(semid:cint; semnum:cint; cmd:cint; var arg: tsemun): cint;
 begin
-  semctl:=ipccall(CALL_SEMCTL,semid,semnum,cmd,@arg);
+  semctl:=ipccall(CALL_SEMCTL,semid,semnum,cmd,@arg,0);
+end;
+
+Function semtimedop(semid:cint; sops: psembuf; nsops: cuint; timeOut: ptimespec): cint;
+begin
+  semtimedop:=ipccall(CALL_SEMTIMEDOP,semid,culong(nsops),culong(0),Pointer(sops),clong(timeOut));
 end;
 

rtl/linux/ipcsys.inc

@@ -53,21 +53,12 @@ end;
 
 function msgsnd(msqid:cint; msgp: pmsgbuf; msgsz: size_t; msgflg:cint):cint;
 begin
-  msgsnd:=do_syscall(syscall_nr_MSGSND,TSysParam(msqid),TSysParam(msgsz),TSysParam(msgflg),TSysParam(msgp));
+  msgsnd:=do_syscall(syscall_nr_MSGSND,TSysParam(msqid),TSysParam(msgp),TSysParam(msgsz),TSysParam(msgflg));
 end;
 
-function msgrcv(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgtyp:cint; msgflg:cint):cint;
-Type
-  TIPC_Kludge = Record
-    msgp   : pmsgbuf;
-    msgtyp : cint;
-  end;
-Var
-   tmp : TIPC_Kludge;
+function msgrcv(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgtyp:clong; msgflg:cint):cint;
 begin
-  tmp.msgp   := msgp;
-  tmp.msgtyp := msgtyp;
-  msgrcv:=do_syscall(syscall_nr_MSGRCV,TSysParam(msqid),TSysParam(msgsz),TSysParam(msgflg),TSysParam(@tmp));
+msgrcv:=do_syscall(syscall_nr_MSGRCV,TSysParam(msqid),TSysParam(msgp),TSysParam(msgsz),TSysParam(msgtyp),TSysParam(msgflg));
 end;
 
 Function msgctl(msqid:cint; cmd: cint; buf: PMSQid_ds): cint;
@@ -87,8 +78,12 @@ end;
 
 Function semctl(semid:cint; semnum:cint; cmd:cint; var arg: tsemun): cint;
 begin
-  semctl:=do_syscall(syscall_nr_SEMCTL,TSysParam(semid),TSysParam(semnum),TSysParam(cmd),TSysParam(@arg));
+  semctl:=do_syscall(syscall_nr_SEMCTL,TSysParam(semid),TSysParam(semnum),TSysParam(cmd),TSysParam(arg));
 end;
 
+Function semtimedop(semid:cint; sops: psembuf; nsops: cuint; timeOut: ptimespec): cint;
+begin
+  semtimedop:=do_syscall( syscall_nr_SEMTIMEDOP,TSysParam(semid),TSysParam(sops),TSysParam(nsops),TSysParam(timeOut));
+end;
 
 

rtl/linux/ostypes.inc

@@ -140,6 +140,16 @@ type
    kernel_off_t = clong;
    kernel_loff_t = clonglong;
 
+{$if defined(cpu32) and not(defined(cpupowerpc)) and not(defined(cpumips)) and not defined(cpumipsel))}
+   kernel_mode_t = cushort;
+   kernel_uid_t = cushort;
+   kernel_gid_t = cushort;
+{$else}
+   kernel_mode_t = cuint;
+   kernel_uid_t = cuint;
+   kernel_gid_t = cuint;
+{$endif}
+
    FLock     = Record
                 l_type  : cshort;       { lock type: read/write, etc. }
                 l_whence: cshort;       { type of l_start }

rtl/unix/ipc.pp

@@ -32,6 +32,8 @@ Uses
 //Var
 //  IPCError : longint;
 
+{$packrecords c}
+
 Type
 
    {$IFDEF FreeBSD}
@@ -76,6 +78,9 @@ Const
 
 type
   PIPC_Perm = ^TIPC_Perm;
+{$ifdef darwin}
+{$packrecords 4}
+{$endif}
 {$if defined(FreeBSD) or defined(Darwin)}
   TIPC_Perm = record
         cuid  : cushort;  { creator user id }
@@ -86,32 +91,48 @@ type
         seq   : cushort;  { sequence # (to generate unique msg/sem/shm id) }
         key   : key_t;    { user specified msg/sem/shm key }
   End;
+{$ifdef darwin}
+{$packrecords c}
+{$endif}
 {$else} // linux
-{$ifdef cpux86_64}
+
+{$ifdef cpu32}
+  {$ifndef linux_ipc64}
+    {$define linux_ipc32}
+  {$endif}
+{$endif}
+
+{$if not defined(linux_ipc32) and not defined(FPC_USE_LIBC)}
   TIPC_Perm = record
         key   : TKey;
-        uid   : uid_t;
-        gid   : gid_t;
-        cuid  : uid_t;
-        cgid  : gid_t;
-        mode  : mode_t;
-        __pad1    : cushort;
+        uid   : kernel_uid_t;
+        gid   : kernel_gid_t;
+        cuid  : kernel_uid_t;
+        cgid  : kernel_gid_t;
+        mode  : kernel_mode_t;
+{$if sizeof(kernel_mode_t) < 4}
+        __pad1    : array[1..4-sizeof(mode_t)];
+{$endif}
+{$ifdef cpupowerpc}
+        seq       : cuint;
+{$else}
         seq       : cushort;
+{$endif}
         __pad2    : cushort;
         __unused1 : culong;
         __unused2 : culong;
   End;
-{$else cpux86_64}  
+{$else not(linux_ipc32) and not(FPC_USE_LIBC)}
   TIPC_Perm = record
         key   : TKey;
-        uid   : uid_t;
-        gid   : gid_t;
-        cuid  : uid_t;
-        cgid  : gid_t;
-        mode  : mode_t;
+        uid   : kernel_uid_t;
+        gid   : kernel_gid_t;
+        cuid  : kernel_uid_t;
+        cgid  : kernel_gid_t;
+        mode  : kernel_mode_t;
         seq   : cushort;
   End;
-{$endif cpux86_64}
+{$endif not(linux_ipc32) and not(FPC_USE_LIBC)}
 {$endif}
 
 
@@ -140,6 +161,7 @@ Type
 {$endif}
 
 {$ifdef Darwin}
+{$packrecords 4}
   TShmid_ds = record
     shm_perm  : TIPC_Perm;
     shm_segsz : size_t;
@@ -151,6 +173,7 @@ Type
     shm_ctime : time_t;
     shm_internal : pointer;
   end;
+{$packrecords c}
 {$endif}
 
 {$ifdef Linux}
@@ -298,6 +321,7 @@ type
   end;
 {$else}
   {$ifdef Darwin}
+{$packrecords 4}
      PMSQid_ds = ^TMSQid_ds;
      TMSQid_ds = record
        msg_perm   : TIPC_perm;
@@ -316,6 +340,7 @@ type
        msg_pad3   : cint32;
        msg_pad4   : array [0..3] of cint32;
      end;
+{$packrecords c}
   {$else}
      PMSQid_ds = ^TMSQid_ds;
      TMSQid_ds = record
@@ -370,7 +395,7 @@ type
 
 Function msgget(key: TKey; msgflg:cint):cint; {$ifdef FPC_USE_LIBC} cdecl; external clib name 'msgget'; {$endif}
 Function msgsnd(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgflg:cint): cint; {$ifdef FPC_USE_LIBC} cdecl; external clib name 'msgsnd'; {$endif}
-Function msgrcv(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgtyp:cint; msgflg:cint): {$ifdef Darwin}ssize_t;{$else}cint;{$endif} {$ifdef FPC_USE_LIBC} cdecl; external clib name 'msgrcv'; {$endif}
+Function msgrcv(msqid:cint; msgp: PMSGBuf; msgsz: size_t; msgtyp:clong; msgflg:cint): {$ifdef Darwin}ssize_t;{$else}cint;{$endif} {$ifdef FPC_USE_LIBC} cdecl; external clib name 'msgrcv'; {$endif}
 Function msgctl(msqid:cint; cmd: cint; buf: PMSQid_ds): cint; {$ifdef FPC_USE_LIBC} cdecl; external clib name 'msgctl'; {$endif}
 
 { ----------------------------------------------------------------------
@@ -413,10 +438,24 @@ const
 
 type
 {$ifdef Linux}
+
+{$ifndef linux_ipc32}
+ PSEMid_ds = ^TSEMid_ds;
+ TSEMid_ds = record
+   sem_perm  : tipc_perm;
+   sem_otime : time_t;   // kernel
+   unused1   : culong;
+   sem_ctime : time_t;
+   unused2   : culong;
+   sem_nsems : culong;
+   unused3   : culong;
+   unused4   : culong;
+  end;
+{$else not linux_ipc32}
   PSEMid_ds = ^TSEMid_ds;
   TSEMid_ds = record
     sem_perm : tipc_perm;
-    sem_otime : time_t;
+    sem_otime : time_t;   // kernel
     sem_ctime : time_t;
     sem_base         : pointer;
     sem_pending      : pointer;
@@ -424,7 +463,8 @@ type
     undo             : pointer;
     sem_nsems : cushort;
   end;
-{$else}
+{$endif not linux_ipc32}
+{$else Linux}
    {$ifdef Darwin}
      PSEM = ^TSEM;
      TSEM = record
@@ -433,11 +473,11 @@ type
        semncnt : cushort;
        semzcnt : cushort;
      end;
-     
+{$packrecords 4}
      PSEMid_ds = ^TSEMid_ds;
      TSEMid_ds = record
              sem_perm : tipc_perm;
-             sem_base : PSEM;
+             sem_base : cint32;
              sem_nsems : cushort;
              sem_otime : time_t;
              sem_pad1 : cint32;
@@ -445,7 +485,7 @@ type
              sem_pad2 : cint32;
              sem_pad3 : array[0..3] of cint32;
           end;
-
+{$packrecords c}
    {$else}
      PSEM = ^TSEM;
      TSEM = record end; // opague
@@ -510,6 +550,9 @@ Type
 Function semget(key:Tkey; nsems:cint; semflg:cint): cint; {$ifdef FPC_USE_LIBC} cdecl; external clib name 'semget'; {$endif}
 Function semop(semid:cint; sops: psembuf; nsops: cuint): cint; {$ifdef FPC_USE_LIBC} cdecl; external clib name 'semop'; {$endif}
 Function semctl(semid:cint; semnum:cint; cmd:cint; var arg: tsemun): cint;
+{$ifdef linux}
+Function semtimedop(semid:cint; sops: psembuf; nsops: cuint; timeOut: ptimespec): cint; platform; {$ifdef FPC_USE_LIBC} cdecl; external name 'semtimedop'; {$endif}
+{$endif}
 
 implementation
 
@@ -533,7 +576,7 @@ Function real_semctl(semid:cint; semnum:cint; cmd:cint): cint; {$ifdef FPC_USE_L
 
 Function semctl(semid:cint; semnum:cint; cmd:cint; var arg: tsemun): cint;
   begin
-    semctl := real_semctl(semid,semnum,cmd,pointer(@arg));
+    semctl := real_semctl(semid,semnum,cmd,pointer(arg));
   end;
 {$endif}
 

tests/test/units/variants/tcustomvariant.pp

@@ -0,0 +1,137 @@
+// A basic test for TCustomVariantType creation/registration
+
+{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
+
+uses Variants, SysUtils;
+
+type
+  TTest = class(TCustomVariantType)
+    procedure Clear(var V: TVarData); override;
+    procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
+  end;
+
+procedure TTest.Clear(var V: TVarData);
+begin
+  SimplisticClear(V);
+end;
+
+procedure TTest.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
+begin
+  SimplisticCopy(Dest, Source, Indirect);
+end;
+
+
+var
+  cv, cv1: TCustomVariantType;
+  code: Integer;
+  Flag: Boolean;
+
+begin
+  Code := 0;
+  { Test #1. Create a TCustomVariantType, it should receive VarType=$10F }
+  cv := TTest.Create;
+  writeln('first vartype=', cv.VarType);
+  if cv.VarType <> $10F then
+    Code := Code or 1;
+
+  { Test #2. Try RequestedVarType that is too low, must be rejected. }
+  Flag := False;
+  try
+    TTest.Create($10E);
+  except
+    on E: Exception do
+    begin
+      writeln('Test 2: ', E.Message);
+      if E is EVariantError then
+        Flag := True;
+    end;
+  end;
+  if not Flag then
+    Code := Code or 2;
+
+  { Test #3. Try RequestedVarType that is too high, must be rejected. }
+  Flag := False;
+  try
+    TTest.Create($1000);
+  except
+    on E: Exception do
+    begin
+      writeln('Test 3: ', E.Message);
+      if E is EVariantError then
+        Flag := True;
+    end;
+  end;
+  if not Flag then
+    Code := Code or 4;
+
+  { Test #4. Try RequestVarType=$10F, must be rejected because this slot was occupied in test #1 }
+  Flag := False;
+  try
+    TTest.Create($10F);
+  except
+    on E: Exception do
+    begin
+      writeln('Test 4: ', E.Message);
+      if E is EVariantError then
+        Flag := True;
+    end;
+  end;
+  if not Flag then
+    Code := Code or 8;
+
+  { Test #5. Verify that our test type can be found VarType... }
+  cv1 := nil;
+  if (not FindCustomVariantType($10F, cv1)) or (cv1 <> cv) then
+    Code := Code or 16;
+
+  { Test #6. ... and by name (case-insensitive) }
+  cv1 := nil;
+  if (not FindCustomVariantType('TtEsT', cv1)) or (cv1 <> cv) then
+    Code := Code or 32;
+
+  { Test #7. Ok, now free cv and try again. The slot must remain occupied... }
+  cv.Free;
+  Flag := False;
+  try
+    TTest.Create($10F);
+  except
+    on E: Exception do
+    begin
+      writeln('Test 7: ', E.Message);
+      if E is EVariantError then
+        Flag := True;
+    end;
+  end;
+  if not Flag then
+    Code := Code or 64;
+
+  { Test #8. ...but the type should no longer be found. }
+  cv1 := nil;
+  if FindCustomVariantType($10F, cv1) then
+    Code := Code or 128;
+
+  { Test #9. also by name }
+  cv1 := nil;
+  if FindCustomVariantType('TtEsT', cv1) then
+    Code := Code or 256;
+
+  { Test #10. Request a valid slot, should succeed }
+  cv := TTest.Create($110);
+  if cv.VarType <> $110 then
+    Code := Code or 512;
+    
+  { Test #11. Now creating another customVariantType should skip the occupied slot.
+    Delphi 7 fails this test miserably. }
+  try
+    cv1 := TTest.Create;
+    if cv1.VarType <> $111 then
+      Code := Code or 1024;
+  except
+    Code := Code or 2048;
+  end;
+
+  if Code <> 0 then
+    writeln('Errors: ', Code);
+  Halt(Code);
+
+end.

tests/utils/redir.pp

@@ -265,8 +265,10 @@ end;
 {$endif}
 
 
+{$ifndef windows}
 var
   TempHOut, TempHIn,TempHError : longint;
+{$endif ndef windows}
 
 {
 For Unix the following functions exist
@@ -545,7 +547,9 @@ function ChangeRedirError(Const Redir : String; AppendToFile : Boolean) : Boolea
     fpdup2(TempHOut,StdOutputHandle);
 {$endif not windows}
     Close (FOUT^);
+{$ifndef windows}
     fpclose(TempHOut);
+{$endif ndef windows}
     RedirChangedOut:=false;
   end;
 
@@ -566,7 +570,9 @@ function ChangeRedirError(Const Redir : String; AppendToFile : Boolean) : Boolea
 {$endif not windows}
 {$endif}
     Close (FIn^);
+{$ifndef windows}
     fpclose(TempHIn);
+{$endif ndef windows}
     RedirChangedIn:=false;
   end;
 
@@ -667,7 +673,9 @@ function ChangeRedirError(Const Redir : String; AppendToFile : Boolean) : Boolea
     { don't close when redirected to STDOUT }
     if not RedirStdErrToStdOut then
       Close (FERR^);
+{$ifndef windows}
     fpclose(TempHError);
+{$endif ndef windows}
     RedirChangedError:=false;
   end;