mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 18:07:56 +02:00
+ Added uuid package
git-svn-id: trunk@44 -
This commit is contained in:
michael
parent
180fd52858
commit
5e01930edc
7
.gitattributes
vendored
7
.gitattributes
vendored
@ -3033,6 +3033,13 @@ packages/extra/utmp/Makefile -text
|
||||
packages/extra/utmp/Makefile.fpc svneol=native#text/plain
|
||||
packages/extra/utmp/testutmp.pp svneol=native#text/plain
|
||||
packages/extra/utmp/utmp.pp svneol=native#text/plain
|
||||
packages/extra/uuid/Makefile svneol=native#text/plain
|
||||
packages/extra/uuid/Makefile.fpc svneol=native#text/plain
|
||||
packages/extra/uuid/README svneol=native#text/plain
|
||||
packages/extra/uuid/libuuid.pp svneol=native#text/plain
|
||||
packages/extra/uuid/testlibuid.pp svneol=native#text/plain
|
||||
packages/extra/uuid/testuid.pp svneol=native#text/plain
|
||||
packages/extra/uuid/uuid.pp svneol=native#text/plain
|
||||
packages/extra/winunits/Makefile -text
|
||||
packages/extra/winunits/Makefile.fpc svneol=native#text/plain
|
||||
packages/extra/winunits/activex.pp svneol=native#text/plain
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/05/05]
|
||||
# Don't edit, this file is generated by FPCMake Version 1.9.8 [2005/04/10]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-emx i386-watcom i386-netwlibc m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd arm-linux
|
||||
@ -231,7 +231,7 @@ UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
|
||||
endif
|
||||
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
|
||||
ifeq ($(FULL_TARGET),i386-linux)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt uuid
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),i386-go32v2)
|
||||
override TARGET_DIRS+=unzip
|
||||
@ -261,7 +261,7 @@ ifeq ($(FULL_TARGET),i386-netwlibc)
|
||||
override TARGET_DIRS+=unzip zlib
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),m68k-linux)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt uuid
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),m68k-freebsd)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses fpgtk tcl imlib gnome1
|
||||
@ -279,7 +279,7 @@ ifeq ($(FULL_TARGET),m68k-palmos)
|
||||
override TARGET_DIRS+=palmunits
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),powerpc-linux)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt uuid
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),powerpc-netbsd)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses fpgtk tcl imlib gnome1
|
||||
@ -288,19 +288,19 @@ ifeq ($(FULL_TARGET),powerpc-darwin)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses fpgtk tcl imlib gnome1
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),sparc-linux)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt uuid
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),sparc-netbsd)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses fpgtk tcl imlib gnome1
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),x86_64-linux)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt uuid
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),x86_64-freebsd)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses fpgtk tcl imlib gnome1
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),arm-linux)
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt
|
||||
override TARGET_DIRS+=unzip zlib x11 opengl gtk gtk2 syslog forms svgalib ggi libpng libgd utmp bfd gdbm ncurses tcl cdrom imlib gnome1 fpgtk unixutil newt uuid
|
||||
endif
|
||||
override INSTALL_FPCPACKAGE=y
|
||||
override INSTALL_FPCSUBDIR=packages/extra
|
||||
@ -1362,6 +1362,7 @@ TARGET_DIRS_GNOME1=1
|
||||
TARGET_DIRS_FPGTK=1
|
||||
TARGET_DIRS_UNIXUTIL=1
|
||||
TARGET_DIRS_NEWT=1
|
||||
TARGET_DIRS_UUID=1
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),i386-go32v2)
|
||||
TARGET_DIRS_UNZIP=1
|
||||
@ -1497,6 +1498,7 @@ TARGET_DIRS_GNOME1=1
|
||||
TARGET_DIRS_FPGTK=1
|
||||
TARGET_DIRS_UNIXUTIL=1
|
||||
TARGET_DIRS_NEWT=1
|
||||
TARGET_DIRS_UUID=1
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),m68k-freebsd)
|
||||
TARGET_DIRS_UNZIP=1
|
||||
@ -1592,6 +1594,7 @@ TARGET_DIRS_GNOME1=1
|
||||
TARGET_DIRS_FPGTK=1
|
||||
TARGET_DIRS_UNIXUTIL=1
|
||||
TARGET_DIRS_NEWT=1
|
||||
TARGET_DIRS_UUID=1
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),powerpc-netbsd)
|
||||
TARGET_DIRS_UNZIP=1
|
||||
@ -1659,6 +1662,7 @@ TARGET_DIRS_GNOME1=1
|
||||
TARGET_DIRS_FPGTK=1
|
||||
TARGET_DIRS_UNIXUTIL=1
|
||||
TARGET_DIRS_NEWT=1
|
||||
TARGET_DIRS_UUID=1
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),sparc-netbsd)
|
||||
TARGET_DIRS_UNZIP=1
|
||||
@ -1705,6 +1709,7 @@ TARGET_DIRS_GNOME1=1
|
||||
TARGET_DIRS_FPGTK=1
|
||||
TARGET_DIRS_UNIXUTIL=1
|
||||
TARGET_DIRS_NEWT=1
|
||||
TARGET_DIRS_UUID=1
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),x86_64-freebsd)
|
||||
TARGET_DIRS_UNZIP=1
|
||||
@ -1752,6 +1757,7 @@ TARGET_DIRS_GNOME1=1
|
||||
TARGET_DIRS_FPGTK=1
|
||||
TARGET_DIRS_UNIXUTIL=1
|
||||
TARGET_DIRS_NEWT=1
|
||||
TARGET_DIRS_UUID=1
|
||||
endif
|
||||
ifdef TARGET_DIRS_UNZIP
|
||||
unzip_all:
|
||||
@ -2788,6 +2794,51 @@ newt:
|
||||
$(MAKE) -C newt all
|
||||
.PHONY: newt_all newt_debug newt_smart newt_release newt_units newt_examples newt_shared newt_install newt_sourceinstall newt_exampleinstall newt_distinstall newt_zipinstall newt_zipsourceinstall newt_zipexampleinstall newt_zipdistinstall newt_clean newt_distclean newt_cleanall newt_info newt_makefiles newt
|
||||
endif
|
||||
ifdef TARGET_DIRS_UUID
|
||||
uuid_all:
|
||||
$(MAKE) -C uuid all
|
||||
uuid_debug:
|
||||
$(MAKE) -C uuid debug
|
||||
uuid_smart:
|
||||
$(MAKE) -C uuid smart
|
||||
uuid_release:
|
||||
$(MAKE) -C uuid release
|
||||
uuid_units:
|
||||
$(MAKE) -C uuid units
|
||||
uuid_examples:
|
||||
$(MAKE) -C uuid examples
|
||||
uuid_shared:
|
||||
$(MAKE) -C uuid shared
|
||||
uuid_install:
|
||||
$(MAKE) -C uuid install
|
||||
uuid_sourceinstall:
|
||||
$(MAKE) -C uuid sourceinstall
|
||||
uuid_exampleinstall:
|
||||
$(MAKE) -C uuid exampleinstall
|
||||
uuid_distinstall:
|
||||
$(MAKE) -C uuid distinstall
|
||||
uuid_zipinstall:
|
||||
$(MAKE) -C uuid zipinstall
|
||||
uuid_zipsourceinstall:
|
||||
$(MAKE) -C uuid zipsourceinstall
|
||||
uuid_zipexampleinstall:
|
||||
$(MAKE) -C uuid zipexampleinstall
|
||||
uuid_zipdistinstall:
|
||||
$(MAKE) -C uuid zipdistinstall
|
||||
uuid_clean:
|
||||
$(MAKE) -C uuid clean
|
||||
uuid_distclean:
|
||||
$(MAKE) -C uuid distclean
|
||||
uuid_cleanall:
|
||||
$(MAKE) -C uuid cleanall
|
||||
uuid_info:
|
||||
$(MAKE) -C uuid info
|
||||
uuid_makefiles:
|
||||
$(MAKE) -C uuid makefiles
|
||||
uuid:
|
||||
$(MAKE) -C uuid all
|
||||
.PHONY: uuid_all uuid_debug uuid_smart uuid_release uuid_units uuid_examples uuid_shared uuid_install uuid_sourceinstall uuid_exampleinstall uuid_distinstall uuid_zipinstall uuid_zipsourceinstall uuid_zipexampleinstall uuid_zipdistinstall uuid_clean uuid_distclean uuid_cleanall uuid_info uuid_makefiles uuid
|
||||
endif
|
||||
ifdef TARGET_DIRS_WINUNITS
|
||||
winunits_all:
|
||||
$(MAKE) -C winunits all
|
||||
|
||||
@ -6,7 +6,7 @@ dirs_linux=unzip zlib \
|
||||
x11 opengl gtk gtk2 syslog \
|
||||
forms svgalib ggi libpng libgd \
|
||||
utmp bfd gdbm ncurses tcl cdrom \
|
||||
imlib gnome1 fpgtk unixutil newt
|
||||
imlib gnome1 fpgtk unixutil newt uuid
|
||||
dirs_netbsd=unzip zlib \
|
||||
x11 opengl gtk syslog \
|
||||
forms svgalib ggi libpng libgd \
|
||||
|
||||
1551
packages/extra/uuid/Makefile
Normal file
1551
packages/extra/uuid/Makefile
Normal file
File diff suppressed because it is too large
Load Diff
26
packages/extra/uuid/Makefile.fpc
Normal file
26
packages/extra/uuid/Makefile.fpc
Normal file
@ -0,0 +1,26 @@
|
||||
#
|
||||
# Makefile.fpc for gdbm bindings
|
||||
#
|
||||
|
||||
[package]
|
||||
name=uuid
|
||||
version=2.0.0
|
||||
|
||||
[target]
|
||||
units=uuid libuuid
|
||||
examples=testuid testlibuid
|
||||
|
||||
[require]
|
||||
package=rtl
|
||||
|
||||
[install]
|
||||
examplesubdir=uuid
|
||||
fpcpackage=y
|
||||
|
||||
[default]
|
||||
fpcdir=../../..
|
||||
|
||||
[rules]
|
||||
testuid$(EXEEXT): testuid.pp uuid$(PPUEXT)
|
||||
|
||||
testlibuid$(EXEEXT): testlibuid.pp libuuid$(PPUEXT)
|
||||
19
packages/extra/uuid/README
Normal file
19
packages/extra/uuid/README
Normal file
@ -0,0 +1,19 @@
|
||||
This package contains 2 units
|
||||
|
||||
uuid:
|
||||
|
||||
creates a GUID based on the MAC address and Time on a linux machine.
|
||||
The implementation is 100% native object pascal code.
|
||||
|
||||
Libuuid:
|
||||
creates a GUID based on the MAC address and Time on a linux machine.
|
||||
The implementation uses the libuuid.so.1 library, which should
|
||||
be present on most linux systems. The library is loaded dynamically.
|
||||
|
||||
Both units set the OnCreateGUID event handler of SysUtils.
|
||||
|
||||
The test programs show the usage, tested on SuSE 9.2.
|
||||
|
||||
Enjoy,
|
||||
|
||||
Michael.
|
||||
60
packages/extra/uuid/libuuid.pp
Normal file
60
packages/extra/uuid/libuuid.pp
Normal file
@ -0,0 +1,60 @@
|
||||
{$mode objfpc}
|
||||
{$H+}
|
||||
Unit Libuuid;
|
||||
|
||||
interface
|
||||
|
||||
uses SysUtils,dynlibs;
|
||||
|
||||
Var
|
||||
LibUUIDName : String = 'libuuid.so.1';
|
||||
ProcName : String = 'uuid_generate_time';
|
||||
|
||||
function CCreateGUID(out Guid: TGUID): Integer;
|
||||
|
||||
Implementation
|
||||
|
||||
|
||||
Type
|
||||
TGenProc = procedure (out Guid: TGUID);cdecl;
|
||||
|
||||
var
|
||||
Handle : TLibHandle;
|
||||
GenFunc : TGenProc;
|
||||
|
||||
Function InitLibrary : Boolean;
|
||||
|
||||
begin
|
||||
Result:=(Handle<>NilHandle);
|
||||
If Not result then
|
||||
begin
|
||||
Handle:=LoadLibrary(LibUUIDName);
|
||||
Result:=(Handle<>NilHandle);
|
||||
if Result then
|
||||
begin
|
||||
GenFunc:=TGenProc(GetProcedureAddress(Handle, ProcName));
|
||||
Result:=(GenFunc<>nil);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function CCreateGUID(out Guid: TGUID): HResult;
|
||||
|
||||
begin
|
||||
Result := -1;
|
||||
if InitLibrary then
|
||||
begin
|
||||
GenFunc(Guid);
|
||||
Result := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
If InitLibrary then
|
||||
OnCreateGUID:=@CCreateGUID;
|
||||
Finalization
|
||||
if (Handle<>NilHandle) then
|
||||
UnLoadLibrary(Handle)
|
||||
end.
|
||||
14
packages/extra/uuid/testlibuid.pp
Normal file
14
packages/extra/uuid/testlibuid.pp
Normal file
@ -0,0 +1,14 @@
|
||||
program testlibuid;
|
||||
|
||||
uses sysutils,libuuid;
|
||||
|
||||
Var
|
||||
T : TGUID;
|
||||
P : PByte;
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
// GetURandomBytes(T,SizeOf(T));
|
||||
CreateGUID(T);
|
||||
Writeln(GUIDToString(T));
|
||||
end.
|
||||
14
packages/extra/uuid/testuid.pp
Normal file
14
packages/extra/uuid/testuid.pp
Normal file
@ -0,0 +1,14 @@
|
||||
program testuid;
|
||||
|
||||
uses sysutils,uuid;
|
||||
|
||||
Var
|
||||
T : TGUID;
|
||||
P : PByte;
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
// GetURandomBytes(T,SizeOf(T));
|
||||
CreateGUID(T);
|
||||
Writeln(GUIDToString(T));
|
||||
end.
|
||||
257
packages/extra/uuid/uuid.pp
Normal file
257
packages/extra/uuid/uuid.pp
Normal file
@ -0,0 +1,257 @@
|
||||
{$mode objfpc}
|
||||
{$H+}
|
||||
unit uuid;
|
||||
|
||||
Interface
|
||||
|
||||
uses SysUtils;
|
||||
|
||||
Function CreateMacGUID(Out GUID : TGUID) : Integer;
|
||||
|
||||
|
||||
Implementation
|
||||
|
||||
uses unixtype, sockets, baseunix, unix;
|
||||
|
||||
Const
|
||||
MAX_ADJUSTMENT = 10;
|
||||
IPPROTO_IP = 0;
|
||||
// AF_INET = 2;
|
||||
// SOCK_DGRAM = 2;
|
||||
IF_NAMESIZE = 16;
|
||||
SIOCGIFCONF = $8912;
|
||||
SIOCGIFHWADDR = $8927;
|
||||
|
||||
Type
|
||||
{$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;
|
||||
|
||||
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;
|
||||
|
||||
Procedure GetRandomBytes(Var Buf; NBytes : Integer);
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
P : PByte;
|
||||
|
||||
begin
|
||||
P:=@Buf;
|
||||
Randomize;
|
||||
For I:=0 to NBytes-1 do
|
||||
P[i]:=Random(256);
|
||||
end;
|
||||
|
||||
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(Out GUID : TGUID) : Integer;
|
||||
|
||||
Var
|
||||
UU : TUUId;
|
||||
ClockMid : Cardinal;
|
||||
|
||||
begin
|
||||
Result:=Ord(not GetMacAddr);
|
||||
If (Result=0) 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;
|
||||
|
||||
initialization
|
||||
OnCreateGUID:=@CreateMacGUID;
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user