+ Reworked GUID creation

git-svn-id: trunk@43 -

.gitattributes

@@ -3349,6 +3349,7 @@ rtl/bsd/ostypes.inc svneol=native#text/plain
 rtl/bsd/powerpc/syscall.inc svneol=native#text/plain
 rtl/bsd/powerpc/syscallh.inc svneol=native#text/plain
 rtl/bsd/readme.txt svneol=native#text/plain
+rtl/bsd/suuid.inc svneol=native#text/plain
 rtl/bsd/sysbsd.pp svneol=native#text/plain
 rtl/bsd/sysctl.pp svneol=native#text/plain
 rtl/bsd/sysos.inc svneol=native#text/plain
@@ -3630,6 +3631,7 @@ rtl/linux/sparc/stat.inc svneol=native#text/plain
 rtl/linux/sparc/syscall.inc svneol=native#text/plain
 rtl/linux/sparc/syscallh.inc svneol=native#text/plain
 rtl/linux/sparc/sysnr.inc svneol=native#text/plain
+rtl/linux/suuid.inc svneol=native#text/plain
 rtl/linux/syslinux.pp svneol=native#text/plain
 rtl/linux/sysos.inc svneol=native#text/plain
 rtl/linux/sysosh.inc svneol=native#text/plain
@@ -4157,7 +4159,6 @@ rtl/unix/unixutil.pp svneol=native#text/plain
 rtl/unix/unxdeclh.inc svneol=native#text/plain
 rtl/unix/unxovl.inc svneol=native#text/plain
 rtl/unix/unxovlh.inc svneol=native#text/plain
-rtl/unix/uuid.inc svneol=native#text/plain
 rtl/unix/varutils.pp svneol=native#text/plain
 rtl/unix/video.pp svneol=native#text/plain
 rtl/unix/x86.pp svneol=native#text/plain

rtl/bsd/suuid.inc

@@ -0,0 +1,56 @@
+{
+    $Id: sysutils.pp,v 1.59 2005/03/25 22:53:39 jonas Exp $
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Sysutils unit for linux
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+
+Const 
+  RandomDevice  = '/dev/urandom';
+
+
+Function GetURandomBytes(Var Buf; NBytes : Integer) : Boolean;
+
+Var
+  fd,I : Integer;
+  P : PByte;
+  
+begin
+  P:=@Buf;
+  fd:=FileOpen(RandomDevice,fmOpenRead);
+  Result:=(fd>=0);
+  if Result then
+    Try
+      While (NBytes>0) do
+        begin
+        I:=FileRead(fd,P^,nbytes);
+        If I>0 then
+          begin
+          Inc(P,I);
+          Dec(NBytes,I);
+          end;
+        end;  
+    Finally
+      FileClose(Fd);
+    end;
+end;
+
+
+Function SysCreateGUID(out GUID : TGUID) : Integer;
+
+begin
+  if not GetUrandomBytes(Guid,SizeOf(GUID)) then
+    GetRandomBytes(GUID,SizeOf(Guid));  
+  Result:=0;    
+end;

rtl/linux/suuid.inc

@@ -0,0 +1,83 @@
+{
+    $Id: sysutils.pp,v 1.59 2005/03/25 22:53:39 jonas Exp $
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Sysutils unit for linux
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+
+Const 
+  KernelUUID       = '/proc/sys/kernel/random/uuid';
+
+
+Procedure GetURandomBytes(Var Buf; NBytes : Integer);
+
+Var
+  fd,I : Integer;
+  P : PByte;
+  
+begin
+  P:=@Buf;
+  fd:=FileOpen('/dev/urandom',fmOpenRead);
+  if (fd>=0) then
+    Try
+      While (NBytes>0) do
+        begin
+        I:=FileRead(fd,P^,nbytes);
+        If I>0 then
+          begin
+          Inc(P,I);
+          Dec(NBytes,I);
+          end;
+        end;  
+    Finally
+      FileClose(Fd);
+    end
+  else
+    GetRandomBytes(Buf,NBytes);
+end;
+
+
+Function CreateKernelGUID(Var GUID : TGUID) : Boolean;
+
+Const
+  UUIDLen = 36;
+
+Var
+  fd: Longint;
+  S : String;
+  
+begin
+  fd:=FileOpen(KernelUUID,fmOpenRead);
+  Result:=(Fd>=0);
+  if Result then
+    begin
+    SetLength(S,UUIDLen);
+    SetLength(S,FileRead(fd,S[1],UUIDLen));
+    Result:=(Length(S)=UUIDLen);
+    If Result then
+      begin
+      GUID:=StringToGUID('{'+S+'}');
+      //Writeln('Kernel ID = ',GuidToString(GUID));
+      end;
+    end;
+end;
+
+Function SysCreateGUID(out GUID : TGUID) : Integer;
+
+begin
+  if not CreateKernelGUID(Guid) then
+    GetRandomBytes(GUID,SizeOf(Guid));  
+  Result:=0;    
+end;
+

rtl/objpas/sysutils/sysutilh.inc

@@ -164,11 +164,19 @@ type
    procedure Beep;
    function SysErrorMessage(ErrorCode: Integer): String;
 
+Type
+   TCreateGUIDFunc = Function(Out GUID : TGUID) : Integer;
+
+Var
+   OnCreateGUID : TCreateGUIDFunc = Nil;
+  
    Function CreateGUID(out GUID : TGUID) : Integer;
 
 type
   TTerminateProc = Function: Boolean;
 
+  
+
   procedure AddTerminateProc(TermProc: TTerminateProc);
   function CallTerminateProcs: Boolean;
 

rtl/objpas/sysutils/sysutils.inc

@@ -495,14 +495,24 @@ begin
     P[i]:=Random(256);
 end;
 
+{$IFDEF HASCREATEGUID}
+Function SysCreateGUID(out GUID : TGUID) : Integer; forward;
+{$ENDIF}
 
-{$IFNDEF HASCREATEGUID}
 Function CreateGUID(out GUID : TGUID) : Integer;
 begin
-  Result:=0;
+  If Assigned(OnCreateGUID) then
+    Result:=OnCreateGUID(GUID)
+  else
+    begin
+    {$IFDEF HASCREATEGUID}
+    Result:=SysCreateGUID(GUID);
+    {$ELSE}
     GetRandomBytes(GUID,SizeOf(Guid));  
+    Result:=0;
+    {$ENDIF}    
+    end;
 end;
-{$ENDIF}
 
 {
   Revision 1.1  2003/10/06 21:01:06  peter

rtl/unix/sysutils.pp

@@ -64,10 +64,8 @@ Type
 { Include platform independent implementation part }
 {$i sysutils.inc}
 
-{ Include CreateGUID function } 
+{ Include SysCreateGUID function }
-
+{$i suuid.inc}
-{$i uuid.inc}
-
 
 Const
 {Date Translation}

rtl/unix/uuid.inc

@@ -1,370 +0,0 @@
-{
-    $Id: sysutils.pp,v 1.59 2005/03/25 22:53:39 jonas Exp $
-    This file is part of the Free Pascal run time library.
-    Copyright (c) 1999-2000 by Florian Klaempfl
-    member of the Free Pascal development team
-
-    Sysutils unit for linux
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-
-Const 
-  KernelUUID       = '/proc/sys/kernel/random/uuid';
-  PreferKernelUUID = False;
-  
-
-Procedure GetURandomBytes(Var Buf; NBytes : Integer);
-
-Var
-  fd,I : Integer;
-  P : PByte;
-  
-begin
-  P:=@Buf;
-  fd:=FileOpen('/dev/urandom',fmOpenRead);
-  if (fd>=0) then
-    Try
-      While (NBytes>0) do
-        begin
-        I:=FileRead(fd,P^,nbytes);
-        If I>0 then
-          begin
-          Inc(P,I);
-          Dec(NBytes,I);
-          end;
-        end;  
-    Finally
-      FileClose(Fd);
-    end
-  else
-    GetRandomBytes(Buf,NBytes);
-end;
-
-Const 
-  MAX_ADJUSTMENT = 10;
-  IPPROTO_IP     = 0;
-  AF_INET        = 2;
-  SOCK_DGRAM     = 2; 
-  IF_NAMESIZE    = 16;
-  SIOCGIFCONF    = $8912;
-  SIOCGIFHWADDR  = $8927;
-  
-Type
-{$ifdef FreeBSD}
-{$DEFINE SOCK_HAS_SINLEN}               // BSD definition of scoketaddr
-{$endif}
-{$ifdef SOCK_HAS_SINLEN}
-  sa_family_t=cuchar;
-{$else}
-  sa_family_t=cushort;
-{$endif}
-Type
-  in_addr = packed record
-             case boolean of
-             true: (s_addr  : cuint32);         // inaddr_t=cuint32
-             false: (s_bytes : packed array[1..4] of byte);
-  end;
-        
-  TSockAddr = packed Record // if sa_len is defined, sa_family_t is smaller
-  {$ifdef SOCK_HAS_SINLEN}
-     sa_len     : cuchar;
-  {$endif}
-    case integer of
-      0: (sa_family: sa_family_t;
-          sa_data: packed array[0..13] of Byte);
-      1: (sin_family: sa_family_t;
-          sin_port: cushort;
-          sin_addr: in_addr;
-          sin_zero: packed array[0..7] of Byte);
-      end;
-
-  PSockAddr = ^TSockAddr;
-  Sockaddr  = TSockAddr;                // Kylix compat
-  {$packrecords c}
-  tifr_ifrn = record
-    case integer of
-      0 : (ifrn_name: array [0..IF_NAMESIZE-1] of char);
-  end;
-  tifmap = record
-    mem_start : cardinal;
-    mem_end   : cardinal;
-    base_addr : word;
-    irq       : byte;
-    dma       : byte;
-    port      : byte;
-  end;
-  TIFrec = record
-    ifr_ifrn : tifr_ifrn;
-    case integer of
-      0 : (ifru_addr      : TSockAddr);
-      1 : (ifru_dstaddr   : TSockAddr);
-      2 : (ifru_broadaddr : TSockAddr);
-      3 : (ifru_netmask   : TSockAddr);
-      4 : (ifru_hwaddr    : TSockAddr);
-      5 : (ifru_flags     : word); 
-      6 : (ifru_ivalue    : longint);
-      7 : (ifru_mtu       : longint);
-      8 : (ifru_map       : tifmap);
-      9 : (ifru_slave     : Array[0..IF_NAMESIZE-1] of char);
-      10 : (ifru_newname  : Array[0..IF_NAMESIZE-1] of char);
-      11 : (ifru_data     : pointer);
-  end; 
-  TIFConf = record
-    ifc_len : longint;
-    case integer of
-      0 : (ifcu_buf : pointer);
-      1 : (ifcu_req : ^tifrec);
-  end;
-
-  tuuid = record 
-    time_low : cardinal;
-    time_mid : Word;
-    time_hi_and_version : Word;
-    clock_seq : Word;
-    node : Array[0..5] of byte;
-  end;
-
-Function SocketCall(SockCallNr,a1,a2,a3,a4,a5,a6:longint):longint;
-var
-  Args:array[1..6] of longint;
-begin
-  args[1]:=a1;
-  args[2]:=a2;
-  args[3]:=a3;
-  args[4]:=a4;
-  args[5]:=a5;
-  args[6]:=a6;
-  SocketCall:=do_Syscall(syscall_nr_socketcall,sockcallnr,longint(@args));
-end;
-                          
-function SocketCall(SockCallNr,a1,a2,a3:longint):longint;
-begin
-   SocketCall:=SocketCall(SockCallNr,a1,a2,a3,0,0,0);
-end;
-                  
-function  fpsocket (domain:cint; xtype:cint; protocol: cint):cint;
-begin
-  fpSocket:=SocketCall(1,Domain,xtype,Protocol);
-end;
-
-Var
-  MacAddr      : Packed Array[1..6] of byte = (0,0,0,0,0,0);
-  MacAddrTried : Byte = 0 ;
-  Last   : TTimeVal = (tv_sec:0;tv_usec:0);
-  ClockSeq   : Word = 0;
-  AdjustMent : Integer = 0;
-  
-Function GetMacAddr : Boolean;
-
-var
-  i,j,n,Sd : Integer;
-  buf : Array[0..1023] of byte;
-  ifc : TIfConf;
-  ifr : TIFRec;
-  ifp : ^TIFRec;
-  p   : PChar;
-begin
-  Result:=MacAddrTried>0;
-  If Result then
-    Result:=MacAddrTried>1
-  else  
-    begin
-    MacAddrTried:=1;
-    sd:=fpSocket(AF_INET,SOCK_DGRAM,IPPROTO_IP);
-    if (sd<0) then 
-      exit;
-    Try
-      ifc.ifc_len:=Sizeof(Buf);
-      ifc.ifcu_buf:=@buf;
-      if fpioctl(sd, SIOCGIFCONF, @ifc)<0 then
-        Exit;
-      n:= ifc.ifc_len;  
-      i:=0;
-      While (Not Result) and (I<N) do
-        begin
-        ifp:=@PByte(ifc.ifcu_buf)[i];
-        move(ifp^.ifr_ifrn.ifrn_name,ifr.ifr_ifrn.ifrn_name,IF_NAMESIZE);
-        if (fpioctl(sd, SIOCGIFHWADDR, @ifr) >= 0) then
-          begin
-          P:=Pchar(@ifr.ifru_hwaddr.sa_data);
-          Result:=(p[0]<>#0) or (p[1]<>#0) or (p[2]<>#0) 
-                  or (p[3]<>#0) or (p[4]<>#0) or (p[5]<>#0);
-          If Result Then
-            begin
-            Move(P^,MacAddr,SizeOf(MacAddr));  
-            MacAddrTried:=2;
-            // DumpMacAddr;
-            end;
-          end;
-        I:=I+sizeof(tifrec);
-        end;
-    Finally  
-      fileClose(sd);
-    end;
-    end;
-end;
-
-  
-Function GetClock(Var ClockHigh,ClockLow : Cardinal; Var RetClockSeq : Word) : boolean;
-
-Var
-  TV       : TTImeVal;
-  ClockReg : QWord;  
-  OK       : Boolean; 
-
-begin
-  OK:=True;
-  Repeat
-    FPGetTimeOfDay(@Tv,Nil);
-    If (Last.tv_sec=0) and (last.tv_sec=0) then
-      begin
-      GetRandomBytes(ClockSeq,SizeOf(ClockSeq));
-      ClockSeq:=ClockSeq and $1FFF;
-      last:=TV;
-      Dec(last.tv_sec);
-      end;
-    if (tv.tv_sec<last.tv_sec) or 
-        ((tv.tv_sec=last.tv_sec) and (tv.tv_usec<last.tv_usec)) then
-      begin
-      ClockSeq:=(ClockSeq+1) and $1FFF;
-      Adjustment:=0;
-      Last:=Tv;
-      end
-    else if (tv.tv_sec=last.tv_sec) and (tv.tv_usec=last.tv_usec) then
-      begin
-      If Adjustment>=MAX_ADJUSTMENT then
-        OK:=False
-      else  
-        inc(AdjustMent);
-      end
-    else
-      begin
-      AdjustMent:=0;
-      Last:=tv;
-      end;
-  Until OK;  
-  ClockReg:=tv.tv_usec*10+adjustment;
-  Inc(ClockReg,tv.tv_sec*10000000);
-  Inc(ClockReg,($01B21DD2 shl 32) + $13814000);
-  ClockHigh   :=Hi(ClockReg);
-  ClockLow    :=Lo(ClockReg);
-  RetClockSeq :=ClockSeq;
-  Result      :=True;                  
-end;
-
-Procedure UUIDPack(Const UU : TUUID; Var GUID : TGUID);
-
-Var
-  tmp : Cardinal;
-  P   : PByte;
-  
-begin
-  P:=@GUID;
-  
-  tmp:=uu.time_low;
-  P[3]:=tmp and $FF;
-  tmp:=tmp shr 8;
-  P[2]:=tmp and $FF;
-  tmp:=tmp shr 8;
-  P[1]:=tmp and $FF;
-  tmp:=tmp shr 8;
-  P[0]:=tmp and $FF;
-  
-  tmp:=uu.time_mid;
-  P[5]:=tmp and $FF;
-  tmp:=tmp shr 8;
-  P[4]:=tmp and $FF;
-  
-  tmp:=uu.time_hi_and_version;
-  P[7]:=tmp and $FF;
-  tmp:=tmp shr 8;
-  P[6]:=tmp and $FF;
-  
-  tmp:=uu.clock_seq;
-  P[9]:=tmp and $FF;
-  tmp:=tmp shr 8;
-  P[8]:=tmp and $FF;
-  
-  Move(uu.node,P[10],6);
-end;
-
-Procedure DumpMacAddr;
-
-var
-  I : Integer;
-begin
-  Write('Mac Addr: ');
-  For i:=1 to 6 do
-    write(hexstr(MacAddr[i],2),':');
-end;
-
-Function CreateMacGUID(Var GUID : TGUID) : Boolean;
-
-Var
-  UU       : TUUId;
-  ClockMid : Cardinal;
-
-begin
-  Result:=GetMacAddr;
-  If Result then
-    begin
-    // DumpMacAddr;
-    // Writeln;
-    GetClock(ClockMid,uu.time_low,uu.clock_seq);
-    uu.Clock_seq:=uu.Clock_seq or $8000;
-    uu.time_mid:=lo(clockMid);
-    uu.time_hi_and_version:=hi(ClockMid) or $1000;
-    move(MacAddr,uu.node,sizeof(MacAddr));
-    UUIDPack(UU,GUID);
-    end;
-end;
-
-Function CreateKernelGUID(Var GUID : TGUID) : Boolean;
-
-Const
-  UUIDLen = 36;
-
-Var
-  fd: Longint;
-  S : String;
-  
-begin
-  fd:=FileOpen(KernelUUID,fmOpenRead);
-  Result:=(Fd>=0);
-  if Result then
-    begin
-    SetLength(S,UUIDLen);
-    SetLength(S,FileRead(fd,S[1],UUIDLen));
-    Result:=(Length(S)=UUIDLen);
-    If Result then
-      begin
-      GUID:=StringToGUID('{'+S+'}');
-      //Writeln('Kernel ID = ',GuidToString(GUID));
-      end;
-    end;
-end;
-
-Function CreateGUID(out GUID : TGUID) : Integer;
-
-begin
-  if PreferKernelUUID then
-    begin
-    if not CreateKernelGUID(Guid) then
-      if not CreateMACGuid(Guid) then
-        GetRandomBytes(GUID,SizeOf(Guid));  
-    end
-  else  
-    if not CreateMACGuid(Guid) then
-      if not CreateKernelGUID(Guid) then
-        GetRandomBytes(GUID,SizeOf(Guid));  
-  Result:=0;    
-end;
-

rtl/win32/sysutils.pp

@@ -62,16 +62,20 @@ implementation
     sysconst;
 
 {$define HASCREATEGUID}
-function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid';
-
-function CreateGUID(out Guid: TGUID): HResult;
-begin
-  Result := CoCreateGuid(Guid);
-end;
 
 { Include platform independent implementation part }
 {$i sysutils.inc}
 
+{ UUID generation. }
+
+function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid';
+
+function SysCreateGUID(out Guid: TGUID): Integer;
+begin
+  Result := Integer(CoCreateGuid(Guid));
+end;
+
+
 {****************************************************************************
                               File Functions
 ****************************************************************************}