paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
c66386067c
lazarus-ccr/components/onguard/source/ogutil.pas
brandysb c5c5822365 Remove fixed ShortDateFormat := 'yyyy-mm-dd' 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1267 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2010-08-01 12:56:00 +00:00

1870 lines
52 KiB
ObjectPascal
Raw Blame History

(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower OnGuard
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* Andrew Haines andrew@haines.name {AH.01}
* conversion to CLX {AH.01}
* December 30, 2003 {AH.01}
*
* Andrew Haines andrew@haines.name {AH.02}
* added conditional define "IBO_CONSOLE" {AH.02}
* this is to allow for making console {AH.02}
* applications with Kylix and not require {AH.02}
* X11 being linked in. {AH.02}
* January 07, 2004 {AH.02}
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* OGUTIL.PAS 1.13 *}
{* Copyright (c) 1996-02 TurboPower Software Co *}
{* All rights reserved. *}
{*********************************************************}
{$I onguard.inc}
unit ogutil;
{-general constants, types, and utility routines}
interface
uses
LCLIntf,lclproc
{$IFDEF LINUX} {AH.01}
,BaseUnix
{$ENDIF}
{$IFDEF WIN32}
{$ENDIF} {AH.01}
,SysUtils
{$IFNDEF IBO_CONSOLE},Dialogs{$ENDIF} {AH.02}
; {!!.08}
const
DefAutoCheck = True;
DefAutoDecrease = True;
DefCheckSize = True;
DefStoreCode = False;
DefStoreModifier = False;
DefStoreRegString = False;
const
OgVersionStr = '1.20';
const
{largest structure that can be created}
{$IFDEF Win32}
MaxStructSize = 1024 * 2000000; {2G}
{$ELSE}
MaxStructSize = 1024 * 64 - 1; {64K}
{$ENDIF}
type
PLongIntArray = ^TLongIntArray;
TLongIntArray = array [0..MaxStructSize div SizeOf(LongInt) - 1] of LongInt;
TLongIntRec = record
case Byte of
1: (Lo: Word;
Hi: Word);
2: (LoLo: Byte;
LoHi: Byte;
HiLo: Byte;
HiHi: Byte);
end;
(*
moved these here from onguard.pas since I needed them for console work
*)
{$IFDEF IBO_CONSOLE} {AH.02}
const
{magic values}
DaysCheckCode = $649B;
DateCheckCode = $A4CB;
NetCheckCode = $9341;
RegCheckCode = $D9F6;
SerialCheckCode = $3C69;
UsageCheckCode = $F3D5;
SpecialCheckCode = $9C5B;
type
{code tyes}
PCode = ^TCode;
TCode = packed record
CheckValue : Word; {magic value}
Expiration : Word; {expiration date or 0, if none}
case Byte of
0 : (FirstDate : Word; {for date code}
EndDate : Word);
1 : (Days : Word; {for days code}
LastAccess : Word);
2 : (RegString : LongInt); {for reg code}
3 : (SerialNumber : LongInt); {for serial number code}
4 : (UsageCount : Word; {for usage count code} {!!.02}
LastChange : Word); {!!.02}
5 : (Value : LongInt); {for specail codes}
6 : (NetIndex : LongInt); {for net codes}
end;
type
TCodeType = (ctDate, ctDays, ctRegistration, ctSerialNumber,
ctUsage, ctNetwork, ctSpecial, ctUnknown);
{order must match tab order for code generation notebook}
type
TKey = array [0..15] of Byte;
TKeyType = (ktRandom, ktMessageDigest, ktMessageDigestCS);
{order must match order for key generation combobox string list}
type
{contexts}
TTMDContext = array [0..279] of Byte;
TMD5Context = array [0..87] of Byte;
TMD5Digest = array [0..15] of Byte;
{bit mixing types}
T128Bit = array [0..3] of LongInt;
T256Bit = array [0..7] of LongInt;
const
DefCodeType = ctDate;
DefKeyType = ktRandom;
type
TEsMachineInfoSet = {!!.05}
set of (midUser, midSystem, midNetwork, midDrives); {!!.05}
type
{result of code verification}
TCodeStatus = (ogValidCode, {code is valid but may still be expired}
ogInvalidCode, {code is invalid}
ogPastEndDate, {end date has been reached}
ogDayCountUsed, {number of days authorized have been used}
ogRunCountUsed, {number of runs authorized have been used}
ogNetCountUsed, {number of authorized users has been exceeded}
ogCodeExpired); {expiration date has been reached}
function GetCodeType(const Key : TKey; const Code : TCode) : TCodeType;
{-return the type of code}
function GetExpirationDate(const Key : TKey; const Code : TCode) : TDateTime;
{-return the date this code expires}
procedure InitDateCode(const Key : TKey; StartDate, EndDate : TDateTime; var Code : TCode);
function IsDateCodeValid(const Key : TKey; const Code : TCode) : Boolean;
function GetDateCodeValue(const Key : TKey; const Code : TCode) : TDateTime;
function IsDateCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
procedure InitDaysCode(const Key : TKey; Days : Word; Expires : TDateTime; var Code : TCode);
function IsDaysCodeValid(const Key : TKey; const Code : TCode) : Boolean;
procedure DecDaysCode(const Key : TKey; var Code : TCode);
function GetDaysCodeValue(const Key : TKey; const Code : TCode) : LongInt;
function IsDaysCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
procedure InitRegCode(const Key : TKey; const RegStr : string; Expires : TDateTime; var Code : TCode);
function IsRegCodeValid(const Key : TKey; const Code : TCode) : Boolean;
function IsRegCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
procedure InitSerialNumberCode(const Key : TKey; Serial : LongInt; Expires : TDateTime; var Code : TCode);
function IsSerialNumberCodeValid(const Key : TKey; const Code : TCode) : Boolean;
function GetSerialNumberCodeValue(const Key : TKey; const Code : TCode) : LongInt;
function IsSerialNumberCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
procedure InitSpecialCode(const Key : TKey; Value : LongInt; Expires : TDateTime; var Code : TCode);
function IsSpecialCodeValid(const Key : TKey; const Code : TCode) : Boolean;
function GetSpecialCodeValue(const Key : TKey; const Code : TCode) : LongInt;
function IsSpecialCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
procedure InitUsageCode(const Key : TKey; Count : Word; Expires : TDateTime; var Code : TCode);
function IsUsageCodeValid(const Key : TKey; const Code : TCode) : Boolean;
procedure DecUsageCode(const Key : TKey; var Code : TCode);
function GetUsageCodeValue(const Key : TKey; const Code : TCode) : LongInt;
function IsUsageCodeExpired(const Key : TKey; const Code: TCode) : Boolean;
{generate key routines}
procedure GenerateRandomKeyPrim(var Key; KeySize : Cardinal);
procedure GenerateTMDKeyPrim(var Key; KeySize : Cardinal; const Str : string);
procedure GenerateMD5KeyPrim(var Key: TKey; const Str : string);
{modifier routines}
function CreateMachineID(MachineInfo : TEsMachineInfoSet) : LongInt; {!!.05}
function GenerateStringModifierPrim(const S : string) : LongInt;
function GenerateUniqueModifierPrim : LongInt;
function GenerateMachineModifierPrim : LongInt;
function GenerateDateModifierPrim(D : TDateTime) : LongInt;
procedure ApplyModifierToKeyPrim(Modifier : LongInt; var Key; KeySize : Cardinal);
{hash routines}
function StringHashElf(const Str : string) : LongInt;
{mixing routines}
procedure MixBlock(const Matrix : T128Bit; var Block; Encrypt : Boolean);
{utility routines}
function ExpandDate(D : Word) : TDateTime;
function ShrinkDate(D : TDateTime) : Word;
{compressed code routines}
{
procedure CompressCodes(const Codes : Pointer; CodesSize : Integer; var Buffer : Pointer; var BufSize : Integer);
function CompressCodesStr(const CodeStr : String): String;
procedure DecompressCodes(const Codes : Pointer; var Buffer : Pointer);
function DecompressCodesStr(const CodeStr : String; const OutEst : Integer): String;
}
const
BaseDate : LongInt = 0;
{$ENDIF}
function BufferToHex(const Buf; BufSize : Cardinal) : string;
function BufferToHexBytes(const Buf; BufSize : Cardinal) : string;
{$IFNDEF Win32}
function GetDiskSerialNumber(Drive : AnsiChar) : LongInt;
function MyHashElf(const Buf; BufSize : LongInt) : LongInt;
{$ENDIF}
function HexStringIsZero(const Hex : string) : Boolean;
function HexToBuffer(const Hex : string; var Buf; BufSize : Cardinal) : Boolean;
function Max(A, B : LongInt): LongInt;
function Min(A, B : LongInt) : LongInt;
procedure XorMem(var Mem1; const Mem2; Count : Cardinal);
function OgFormatDate(Value : TDateTime) : string; {!!.09}
{file related routines}
function GetFileSize(Handle : THandle) : Cardinal;
{$IFNDEF Win32}
function LockFile(hFile: THandle; dwFileOffsetLow, dwFileOffsetHigh: DWORD;
nNumberOfBytesToLockLow, nNumberOfBytesToLockHigh: DWORD): Boolean;
function UnlockFile(hFile: THandle; dwFileOffsetLow, dwFileOffsetHigh: DWORD;
nNumberOfBytesToUnlockLow, nNumberOfBytesToUnlockHigh: DWORD): Boolean;
{
function LockFile(Handle : THandle; FileOffsetLow, FileOffsetHigh,
LockCountLow, LockCountHigh : Word) : Boolean;
function UnlockFile(Handle : THandle; FileOffsetLow, FileOffsetHigh,
UnLockCountLow, UnLockCountHigh : Word) : Boolean;
}
function FlushFileBuffers(Handle : THandle) : Boolean;
{$ENDIF}
{$IFDEF LINUX}
function GetDriveType(drive:Integer): Integer;
function HiWord(I: DWORD):Word;
function CoCreateGuid(out guid: TGUID): HResult;
function timeGetTime: DWord;
{$ENDIF}
implementation
function BufferToHex(const Buf; BufSize : Cardinal) : string;
var
Bytes : TByteArray absolute Buf;
I : LongInt;
begin
Result := '';
for I := 0 to BufSize - 1 do
Result := Result + IntToHex(Bytes[I], 2);
end;
function BufferToHexBytes(const Buf; BufSize : Cardinal) : string;
var
Bytes : TByteArray absolute Buf;
I : LongInt;
HexStr : string;
begin
HexStr := '$';
Result := HexStr + IntToHex(Bytes[0], 2);
for I := 1 to BufSize - 1 do
Result := Result + ',' + HexStr + IntToHex(Bytes[I], 2);
end;
{$IFNDEF LINUX}
{$IFNDEF Win32}
type
PMediaIDRec = ^TMediaIDRec;
TMediaIDRec = packed record
InfoLevel : Word; {reserved for future use}
SerialNumber : LongInt; {disk serial number}
VolumeLabel : array[0..10] of AnsiChar; {disk volume label}
FileSystemID : array[0..7] of AnsiChar; {string for internal use by the OS}
end;
type
DPMIRegisters = record
DI : LongInt;
SI : LongInt;
BP : LongInt;
Reserved : LongInt;
case integer of
1 : ( BX : LongInt;
DX : LongInt;
CX : LongInt;
AX : LongInt;
Flags : Word;
ES : Word;
DS : Word;
FS : Word;
GS : Word;
IP : Word;
CS : Word;
SP : Word;
SS : Word );
2 : ( BL, BH : Byte; EBXH : Word;
DL, DH : Byte; EDXH : Word;
CL, CH : Byte; ECXH : Word;
AL, AH : Byte; EAXH : Word );
end;
OS = record
O, S : Word;
end;
function GetCPUFlags : Byte; assembler;
asm
lahf
mov al,ah
end;
function SimulateRealModeInt(IntNo : Byte; var Regs : DPMIRegisters) : Word; assembler;
asm
xor bx,bx
mov bl,IntNo
xor cx,cx {StackWords = 0}
les di,Regs
mov ax,0300h
int 31h
jc @@ExitPoint
xor ax,ax
@@ExitPoint:
end;
function GetMediaID(Drive : Byte; var MediaIDRec : TMediaIDRec) : Boolean;
type
DoubleWord = record LoWord, HiWord : Word; end;
var
L : LongInt;
RP, PP : PMediaIDRec;
Regs : DPMIRegisters;
begin
Result := False;
L := GlobalDosAlloc(SizeOf(TMediaIDRec));
if L = 0 then
Exit;
try
RP := Ptr(DoubleWord(L).HiWord, 0);
PP := Ptr(DoubleWord(L).LoWord, 0);
FillChar(Regs, SizeOf(Regs), 0);
with Regs do begin
DS := OS(RP).S;
DX := OS(RP).O;
AX := $440D;
BX := Drive;
CX := $0866;
Flags := GetCPUFlags;
end;
SimulateRealModeInt($21, Regs);
if not Odd(Regs.Flags) then begin
MediaIDRec := PP^;
Result := True;
end;
finally
GlobalDosFree(OS(PP).S);
end;
end;
function GetDiskSerialNumber(Drive : AnsiChar) : LongInt;
var
MR : TMediaIDRec;
begin
if GetMediaID(Ord(UpCase(Drive))-Ord('A')+1 ,MR) then
Result := MR.SerialNumber
else
Result := -1;
end;
{$ENDIF}
{$ENDIF}
{$IFDEF LINUX}
function MyHashElf(const Buf; BufSize : LongInt) : LongInt;
var
Bytes : TByteArray absolute Buf;
I, X : LongInt;
begin
Result := 0;
for I := 0 to BufSize - 1 do begin
Result := (Result shl 4) + Bytes[I];
X := Result and $F0000000;
if (X <> 0) then
Result := Result xor (X shr 24);
Result := Result and (not X);
end;
end;
function GetDiskSerialNumber(Drive : AnsiChar) : LongInt;
var
boot_partition : String;
drive_model : String;
iFileHandle : Integer;
Buffer : PChar;
iFileSize : Integer;
begin
// read /proc/cmdline
iFileHandle := FileOpen('/proc/cmdline', fmOpenRead or fmShareDenyNone);
iFileSize := FileSeek(iFileHandle,0,2);
Buffer := PChar(AllocMem(iFileSize+1));
FileSeek(iFileHandle,0,0);
FileRead(iFileHandle, Buffer^, iFileSize);
boot_partition := StrPas(Buffer);
FileClose(iFileHandle);
FreeMem(Buffer);
// get root=/dev/? into boot_partition
if Pos('root=/dev/', boot_partition) > 0 then
begin
Delete(boot_partition, 1, Pos('root=/dev/', boot_partition)-1);
if (Pos(' ', boot_partition) > 0) then
begin
boot_partition := Trim(LeftStr(boot_partition, Pos(' ', boot_partition)));
Delete(boot_partition, 1, 10);
boot_partition := LeftStr(boot_partition,3);
end;
end
else
begin
boot_partition := 'hda';
end;
if boot_partition[1] = 'h' then boot_partition := '/ide/' + boot_partition;
if boot_partition[1] = 's' then boot_partition := '/scsi/' + boot_partition;
// read /proc/ide/boot_partition/model
iFileHandle := FileOpen('/proc' + boot_partition + '/model', fmOpenRead or fmShareDenyNone);
iFileSize := FileSeek(iFileHandle,0,2);
Buffer := PChar(AllocMem(iFileSize+1));
FileSeek(iFileHandle,0,0);
FileRead(iFileHandle, Buffer^, iFileSize);
drive_model := StrPas(Buffer);
FileClose(iFileHandle);
FreeMem(Buffer);
// create a hash value of the drive_model to return an integer
Result := MyHashElf(drive_model[1], Length(drive_model));
end;
{$ENDIF}
function HexStringIsZero(const Hex : string) : Boolean;
var
I : Integer;
Str : string;
begin
Result := False;
Str := '';
for I := 1 to Length(Hex) do
if Upcase(Hex[I]) in ['0'..'9', 'A'..'F'] then
Str := Str + Hex[I];
for I := 1 to Length(Str) do
if Str[I] <> '0' then
Exit;
Result := True;
end;
function HexToBuffer(const Hex : string; var Buf; BufSize : Cardinal) : Boolean;
var
Bytes : TByteArray absolute Buf;
I, C : Integer;
Str : string;
begin
Result := False;
Str := '';
for I := 1 to Length(Hex) do
if Upcase(Hex[I]) in ['0'..'9', 'A'..'F'] then
Str := Str + Hex[I];
if (Cardinal(Length(Str) div 2) <> BufSize) then {!!.07}
Exit;
for I := 0 to BufSize - 1 do begin
Val('$' + Copy(Str, (I shl 1) + 1, 2), Bytes[I], C);
if (C <> 0) then
Exit;
end;
Result := True;
end;
function Max(A, B : LongInt) : LongInt;
begin
if A > B then
Result := A
else
Result := B;
end;
function Min(A, B : LongInt) : LongInt;
begin
if A < B then
Result := A
else
Result := B;
end;
{ Functions below were replaced by
not fully compatible but easier pure pascal version
to do it multiplatform}
(*
{$IFDEF Win32}
procedure XorMem(var Mem1; const Mem2; Count : Cardinal); register;
begin
asm
push esi
push edi
mov esi, eax //esi = Mem1
mov edi, edx //edi = Mem2
push ecx //save byte count
shr ecx, 2 //convert to dwords
jz @Continue
cld
@Loop1: //xor dwords at a time
mov eax, [edi]
xor [esi], eax
add esi, 4
add edi, 4
dec ecx
jnz @Loop1
@Continue: //handle remaining bytes (3 or less)
pop ecx
and ecx, 3
jz @Done
@Loop2: //xor remaining bytes
mov al, [edi]
xor [esi], al
inc esi
inc edi
dec ecx
jnz @Loop2
@Done:
pop edi
pop esi
end;
end;
{$ELSE}
{!!.02} {revised}
{$IFNDEF LINUX}
procedure XorMem(var Mem1; const Mem2; Count : Cardinal); assembler;
asm
push ds
push es
lds si, Mem2
les di, Mem1
mov cx, Count
jz @Done
cld
@Loop1:
mov al, ds:[si]
xor es:[di], al
inc si
inc di
dec cx
jnz @Loop1
@Done:
pop es
pop ds
end;
{$ENDIF}
{$ENDIF}
{$IFDEF LINUX}
procedure XorMem(var Mem1; const Mem2; Count : Cardinal); register;
begin
asm
push esi
push edi
mov esi, eax //esi = Mem1
mov edi, edx //edi = Mem2
push ecx //save byte count
shr ecx, 2 //convert to dwords
jz @Continue
cld
@Loop1: //xor dwords at a time
mov eax, [edi]
xor [esi], eax
add esi, 4
add edi, 4
dec ecx
jnz @Loop1
@Continue: //handle remaining bytes (3 or less)
pop ecx
and ecx, 3
jz @Done
@Loop2: //xor remaining bytes
mov al, [edi]
xor [esi], al
inc esi
inc edi
dec ecx
jnz @Loop2
@Done:
pop edi
pop esi
end;
end;
{$ENDIF}
*)
procedure XorMem(var Mem1; const Mem2; Count : Cardinal);
var
pB1,pB2 : PByte;
B1,B2 : Byte;
i : Cardinal;
begin
if Count = 0 then Exit;
i := 0;
pB1 := PByte(@Mem1);//Mem1
pB2 := PByte(@Mem2);//Mem2
while i < Count do
begin
B1 := pB1^;
B2 := pB2^;
pB1^ := B1 xor B2;
Inc(pB1);
Inc(pB2);
Inc(i);
end;
end;
{!!.09}
function OgFormatDate(Value : TDateTime) : string;
{convert date to string with 4-digit year and 2-digit month}
var
S : string;
begin
{ ShortDateFormat := 'yyyy-mm-dd';
S := ShortDateFormat;
if Pos('yyyy', S) = 0 then
Insert('yy', S, Pos('yy', S));
if Pos('MMM', S) > 0 then
Delete(S, Pos('MMM', S), 1);
}
Result := DateToStr(Value);//FormatDateTime(S, Value)
end;
{file related routines}
function GetFileSize(Handle : THandle) : Cardinal;
var
Save : LongInt;
begin
Save := FileSeek(Handle, 0, 0); {save current file position}
Result := FileSeek(Handle, 0, 2); {get file size}
FileSeek(Handle, Save, 0); {restore previous position}
end;
{$IFDEF LINUX}
{
these functions need to be fleshed out
probably find similar functions in Libc
}
(*
const
SEEK_SET = 0; { Seek from beginning of file. }
SEEK_CUR = 1; { Seek from current position. }
SEEK_END = 2; { Seek from end of file. }
{ Old BSD names for the same constants; just for compatibility. }
L_SET = SEEK_SET;
L_INCR = SEEK_CUR;
L_XTND = SEEK_END;
*)
{$ifdef FPC}
const
F_RDLCK = 0;
F_WRLCK = 1;
F_UNLCK = 2;
F_EXLCK = 4;
F_SHLCK = 8;
LOCK_SH = 1;
LOCK_EX = 2;
LOCK_NB = 4;
LOCK_UN = 8;
LOCK_MAND = 32;
LOCK_READ = 64;
LOCK_WRITE = 128;
LOCK_RW = 192;
EACCES = ESysEACCES;
EAGAIN = ESysEAGAIN;
{$endif}
function GetLastError: Integer;
begin
Result := FpGetErrno;
end;
procedure SetLastError(Value: Integer);
begin
FpSetErrno(Value);
end;
function LockFile(hFile: THandle; dwFileOffsetLow, dwFileOffsetHigh: DWORD; nNumberOfBytesToLockLow, nNumberOfBytesToLockHigh: DWORD): Boolean;
var
FLockInfo: {$ifdef FPC}BaseUnix.FLock{$else}TFLock{$endif};
FLastError: Cardinal;
begin
Result := false;
FLockInfo.l_type := F_WRLCK;
FLockInfo.l_whence := SEEK_SET;
FLockInfo.l_start := dwFileOffsetLow;
FLockInfo.l_len := nNumberOfBytesToLockLow;
FLockInfo.l_pid := {$ifdef FPC}fpgetpid{$else}getpid{$endif}();
Result := {$ifdef FPC}fpfcntl{$else}fcntl{$endif}(hFile, F_SETLK, FLockInfo) <> -1;
if not Result then
begin
FLastError := GetLastError();
if (FLastError = EACCES) or (FLastError = EAGAIN) then
SetLastError(ESysEACCES)
else
Result := True; // If errno is ENOLCK or EINVAL
end;
end;
function UnlockFile(hFile: THandle; dwFileOffsetLow, dwFileOffsetHigh: DWORD; nNumberOfBytesToUnlockLow, nNumberOfBytesToUnlockHigh: DWORD): Boolean;
var
FLockInfo: {$ifdef FPC}BaseUnix.FLock{$else}TFLock{$endif};
begin
FLockInfo.l_type := F_UNLCK;
FLockInfo.l_whence := SEEK_SET;
FLockInfo.l_start := dwFileOffsetLow;
FLockInfo.l_len := nNumberOfBytesToUnLockLow;
FLockInfo.l_pid := {$ifdef FPC}fpgetpid{$else}getpid{$endif}();
Result := {$ifdef FPC}fpfcntl{$else}fcntl{$endif}(hFile, F_SETLK, FLockInfo) <> -1;
end;
{
function LockFile(Handle : THandle;
FileOffsetLow, FileOffsetHigh,
LockCountLow, LockCountHigh : Word) : Boolean;
var
LockVar : TFlock;
begin
LockVar.l_whence := SEEK_SET;
LockVar.l_start := FileOffSetHigh;
LockVar.l_start := (LockVar.l_start shr 16) + FileOffSetLow;
LockVar.l_len := LockCountHigh;
LockVar.l_len := (LockVar.l_len shr 16) + LockCountLow;
LockVar.l_type := F_WRLCK;
if fcntl(Handle, F_SETLK, LockVar) = 0 then Result := True else Result := False;
end;
function UnlockFile(Handle : THandle;
FileOffsetLow, FileOffsetHigh,
UnLockCountLow, UnLockCountHigh : Word) : Boolean;
var
LockVar : TFlock;
begin
LockVar.l_whence := SEEK_SET;
LockVar.l_start := FileOffSetHigh;
LockVar.l_start := (LockVar.l_start shr 16) + FileOffSetLow;
LockVar.l_len := UnLockCountHigh;
LockVar.l_len := (LockVar.l_len shr 16) + UnLockCountLow;
LockVar.l_type := F_UNLCK;
if fcntl(Handle, F_SETLK, LockVar) = 0 then Result := True else Result := False;
end;
}
function FlushFileBuffers(Handle : THandle) : Boolean;
begin
Result := True;
end;
{$ENDIF}
(*
{$IFDEF Win32}
function RolByteX(I, C : Byte) : Byte; register;
asm
mov cl, dl
rol al, cl
end;
{$ELSE}
function RolByteX(I, C : Byte) : Byte; assembler;
asm
mov al, I
mov cl, C
rol al, cl
end;
{$ENDIF}
*)
{$IFDEF LINUX}
function GetDriveType(drive:Integer): Integer;
const
DRIVE_UNKNOWN = 0;
DRIVE_NO_ROOT_DIR = 1;
DRIVE_REMOVABLE = 2;
DRIVE_FIXED = 3;
DRIVE_REMOTE = 4;
DRIVE_CDROM = 5;
DRIVE_RAMDISK = 6;
var
f: TextFile;
fn : String;
media : String;
begin
Result := DRIVE_UNKNOWN;
// drive = 1-25 (A-Z)
//assuming IDE drives
//assuming C: = hda
case drive of
1: fn := '';
2: fn := '';
3: fn := 'hda';
4: fn := 'hdb';
5: fn := 'hdc';
6: fn := 'hdd';
7: fn := '';
8..25: fn := '';
end;
if fn = '' then
begin
Result := DRIVE_UNKNOWN;
end
else
begin
{$I-}
if fn[1] = 'h' then AssignFile(f, '/proc/ide/' + fn + '/media');
Reset(f);
media := '';
if IoResult=0 then ReadLn(f, media)
else
Exit;
{$I+}
if media = 'disk' then Result := DRIVE_FIXED;
if media = 'cdrom' then Result := DRIVE_CDROM;
if media = 'floppy' then Result := DRIVE_REMOVABLE;
CloseFile(f);
end;
end;
function HiWord(I: DWORD):Word;
begin
Result := I shl 16;
Result := I and $FFFF;
end;
function CoCreateGuid(out guid: TGUID): HResult;
begin
Result := CreateGuid(Guid);
end;
function timeGetTime: DWord;
begin
// returns the milliseconds since the machine was restarted
// will wrap around to 0 every 2^32 milliseconds (49.7 days)
Result := GetTickCount;
end;
{$ENDIF}
{$IFDEF IBO_CONSOLE}
{first 2048 bits of Pi in hexadecimal, low to high, without the leading "3"}
const
Pi2048: array [0..255] of Byte = (
$24, $3F, $6A, $88, $85, $A3, $08, $D3, $13, $19, $8A, $2E, $03, $70, $73, $44,
$A4, $09, $38, $22, $29, $9F, $31, $D0, $08, $2E, $FA, $98, $EC, $4E, $6C, $89,
$45, $28, $21, $E6, $38, $D0, $13, $77, $BE, $54, $66, $CF, $34, $E9, $0C, $6C,
$C0, $AC, $29, $B7, $C9, $7C, $50, $DD, $3F, $84, $D5, $B5, $B5, $47, $09, $17,
$92, $16, $D5, $D9, $89, $79, $FB, $1B, $D1, $31, $0B, $A6, $98, $DF, $B5, $AC,
$2F, $FD, $72, $DB, $D0, $1A, $DF, $B7, $B8, $E1, $AF, $ED, $6A, $26, $7E, $96,
$BA, $7C, $90, $45, $F1, $2C, $7F, $99, $24, $A1, $99, $47, $B3, $91, $6C, $F7,
$08, $01, $F2, $E2, $85, $8E, $FC, $16, $63, $69, $20, $D8, $71, $57, $4E, $69,
$A4, $58, $FE, $A3, $F4, $93, $3D, $7E, $0D, $95, $74, $8F, $72, $8E, $B6, $58,
$71, $8B, $CD, $58, $82, $15, $4A, $EE, $7B, $54, $A4, $1D, $C2, $5A, $59, $B5,
$9C, $30, $D5, $39, $2A, $F2, $60, $13, $C5, $D1, $B0, $23, $28, $60, $85, $F0,
$CA, $41, $79, $18, $B8, $DB, $38, $EF, $8E, $79, $DC, $B0, $60, $3A, $18, $0E,
$6C, $9E, $0E, $8B, $B0, $1E, $8A, $3E, $D7, $15, $77, $C1, $BD, $31, $4B, $27,
$78, $AF, $2F, $DA, $55, $60, $5C, $60, $E6, $55, $25, $F3, $AA, $55, $AB, $94,
$57, $48, $98, $62, $63, $E8, $14, $40, $55, $CA, $39, $6A, $2A, $AB, $10, $B6,
$B4, $CC, $5C, $34, $11, $41, $E8, $CE, $A1, $54, $86, $AF, $7C, $72, $E9, $93);
{mixing routines}
procedure Mix128(var X : T128Bit);
var
AA, BB, CC, DD : LongInt;
begin
AA := X[0]; BB := X[1]; CC := X[2]; DD := X[3];
AA := AA + DD; DD := DD + AA; AA := AA xor (AA shr 7);
BB := BB + AA; AA := AA + BB; BB := BB xor (BB shl 13);
CC := CC + BB; BB := BB + CC; CC := CC xor (CC shr 17);
DD := DD + CC; CC := CC + DD; DD := DD xor (DD shl 9);
AA := AA + DD; DD := DD + AA; AA := AA xor (AA shr 3);
BB := BB + AA; AA := AA + BB; BB := BB xor (BB shl 7);
CC := CC + BB; BB := BB + CC; CC := CC xor (DD shr 15);
DD := DD + CC; CC := CC + DD; DD := DD xor (DD shl 11);
X[0] := AA; X[1] := BB; X[2] := CC; X[3] := DD;
end;
{quick (block) mixer routine}
procedure MixBlock(const Matrix : T128bit; var Block; Encrypt : Boolean);
const
CKeyBox : array [False..True, 0..3, 0..2] of LongInt =
(((0, 3, 1), (2, 1, 3), (1, 0, 2), (3, 2, 0)),
((3, 2, 0), (1, 0, 2), (2, 1, 3), (0, 3, 1)));
var
Blocks : array [0..1] of LongInt absolute Block;
Work : LongInt;
Right : LongInt;
Left : LongInt;
R : LongInt;
AA, BB : LongInt;
CC, DD : LongInt;
begin
Right := Blocks[0];
Left := Blocks[1];
for R := 0 to 3 do begin
{transform the right side}
AA := Right;
BB := Matrix[CKeyBox[Encrypt, R, 0]];
CC := Matrix[CKeyBox[Encrypt, R, 1]];
DD := Matrix[CKeyBox[Encrypt, R, 2]];
{commented code does not affect results - removed for speed}
AA := AA + DD; DD := DD + AA; AA := AA xor (AA shr 7);
BB := BB + AA; AA := AA + BB; BB := BB xor (BB shl 13);
CC := CC + BB; BB := BB + CC; CC := CC xor (CC shr 17);
DD := DD + CC; CC := CC + DD; DD := DD xor (DD shl 9);
AA := AA + DD; DD := DD + AA; AA := AA xor (AA shr 3);
BB := BB + AA; {AA := AA + BB;} BB := BB xor (BB shl 7);
CC := CC + BB; {BB := BB + CC;} CC := CC xor (DD shr 15);
DD := DD + CC; {CC := CC + DD;} DD := DD xor (DD shl 11);
Work := Left xor DD;
Left := Right;
Right := Work;
end;
Blocks[0] := Left;
Blocks[1] := Right;
end;
function HashElf(const Buf; BufSize : LongInt) : LongInt;
var
Bytes : TByteArray absolute Buf;
I, X : LongInt;
begin
Result := 0;
for I := 0 to BufSize - 1 do begin
Result := (Result shl 4) + Bytes[I];
X := Result and $F0000000;
if (X <> 0) then
Result := Result xor (X shr 24);
Result := Result and (not X);
end;
end;
function StringHashElf(const Str : string) : LongInt;
begin
Result := HashElf(Str[1], Length(Str));
end;
{internal routines for MD5}
type
TMD5ContextEx = record
Count : array [0..1] of DWord; {number of bits handled mod 2^64}
State : array [0..3] of DWord; {scratch buffer}
Buf : array [0..63] of Byte; {input buffer}
end;
{message digest routines}
type
TMDContextEx = record
DigestIndex : LongInt;
Digest : array [0..255] of Byte;
KeyIndex : LongInt;
case Byte of
0: (KeyInts : array [0..3] of LongInt);
1: (Key : TKey);
end;
TBlock2048 = array [0..255] of Byte;
procedure InitTMD(var Context : TTMDContext);
var
ContextEx : TMDContextEx absolute Context;
begin
ContextEx.DigestIndex := 0;
TBlock2048(ContextEx.Digest) := TBlock2048(Pi2048);
ContextEx.KeyIndex := 0;
ContextEx.KeyInts[0] := $55555555;
ContextEx.KeyInts[1] := $55555555;
ContextEx.KeyInts[2] := $55555555;
ContextEx.KeyInts[3] := $55555555;
end;
procedure UpdateTMD(var Context : TTMDContext; const Buf; BufSize : LongInt);
var
ContextEx : TMDContextEx absolute Context;
BufBytes : TByteArray absolute Buf;
AA, BB : LongInt;
CC, DD : LongInt;
I, R : LongInt;
begin
for I := 0 to BufSize - 1 do
with ContextEx do begin
{update Digest}
Digest[DigestIndex] := Digest[DigestIndex] xor BufBytes[I];
DigestIndex := DigestIndex + 1;
if (DigestIndex = SizeOf(Digest)) then
DigestIndex := 0;
{update BlockKey}
Key[KeyIndex] := Key[KeyIndex] xor BufBytes[I];
KeyIndex := KeyIndex + 1;
if (KeyIndex = SizeOf(Key) div 2) then begin
AA := KeyInts[3];
BB := KeyInts[2];
CC := KeyInts[1];
DD := KeyInts[0];
{mix all the bits around for 4 rounds}
{achieves avalanche and eliminates funnels}
for R := 0 to 3 do begin
AA := AA + DD; DD := DD + AA; AA := AA xor (AA shr 7);
BB := BB + AA; AA := AA + BB; BB := BB xor (BB shl 13);
CC := CC + BB; BB := BB + CC; CC := CC xor (CC shr 17);
DD := DD + CC; CC := CC + DD; DD := DD xor (DD shl 9);
AA := AA + DD; DD := DD + AA; AA := AA xor (AA shr 3);
BB := BB + AA; AA := AA + BB; BB := BB xor (BB shl 7);
CC := CC + BB; BB := BB + CC; CC := CC xor (DD shr 15);
DD := DD + CC; CC := CC + DD; DD := DD xor (DD shl 11);
end;
KeyInts[0] := AA;
KeyInts[1] := BB;
KeyInts[2] := CC;
KeyInts[3] := DD;
KeyIndex := 0;
end;
end;
end;
procedure FinalizeTMD(var Context : TTMDContext; var Digest; DigestSize : LongInt);
const
Padding : array [0..7] of Byte = (1, 0, 0, 0, 0, 0, 0, 0);
var
ContextEx : TMDContextEx absolute Context;
I : Integer;
begin
{pad with "1", followed by as many "0"s as needed to fill the block}
UpdateTMD(Context, Padding, SizeOf(Padding) - ContextEx.KeyIndex);
{mix each block within Context with the key}
for I := 0 to (SizeOf(ContextEx.Digest) div SizeOf(TCode)) - 1 do
MixBlock(T128Bit(ContextEx.Key), PCode(@ContextEx.Digest[I * SizeOf(TCode)])^, True);
{return Digest of requested DigestSize}
{max digest is 2048-bit, although it could be greater if Pi2048 was larger}
Move(ContextEx.Digest, Digest, Min(SizeOf(ContextEx.Digest), DigestSize));
end;
{message digest hash}
procedure HashTMD(var Digest; DigestSize : LongInt; const Buf; BufSize : LongInt);
var
Context : TTMDContext;
begin
InitTMD(Context);
UpdateTMD(Context, Buf, BufSize);
FinalizeTMD(Context, Digest, DigestSize);
end;
{$IFDEF Win32}
{!!.05} {added}
function CreateMachineID(MachineInfo : TEsMachineInfoSet) : LongInt;
{ Obtains information from:
- Volume sizes (NOT free space)
- Volume serial numbers
- Registration name and company
- GetSystemInfo relevant info
- Network card ID (if available)
}
const
sCurVer = 'Software\Microsoft\Windows\CurrentVersion'; {!!.11}
sCurVerNT = 'Software\Microsoft\Windows NT\CurrentVersion'; {!!.11}
sRegOwner = 'RegisteredOwner'; {!!.11}
sRegOrg = 'RegisteredOrganization'; {!!.11}
type {!!.11}
TUuidCreateSequential = function (lpGUID : Pointer): HResult; stdcall; {!!.11}
var
hRPCTR4 : THandle; {!!.11}
UuidCreateSequential : TUuidCreateSequential; {!!.11}
I : DWord;
RegKey : HKEY;
GUID1 : TGUID;
GUID2 : TGUID;
Drive : AnsiChar;
SysInfo : TSystemInfo;
Context : TTMDContext;
UserInfoFound : Boolean; {!!.11}
Buf : array [0..1023] of Byte;
iController, iDrive, maxController : Integer;
BufStr : AnsiString;
begin
InitTMD(Context);
{include user specific information}
if midUser in MachineInfo then begin
{!!.11}
UserInfoFound := False;
{ first look for registered info in \Windows\CurrentVersion }
if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, sCurVer, 0,
KEY_QUERY_VALUE, RegKey) = ERROR_SUCCESS) then begin
I := SizeOf(Buf);
if RegQueryValueEx(RegKey, sRegOwner, nil, nil, @Buf, @I) = ERROR_SUCCESS then begin
UserInfoFound := True;
UpdateTMD(Context, Buf, I);
I := SizeOf(Buf);
if RegQueryValueEx(RegKey, sRegOrg, nil, nil, @Buf, @I) = ERROR_SUCCESS then
UpdateTMD(Context, Buf, I);
end;
RegCloseKey(RegKey); {!!.13}
end;
{!!.11}
{ if not found, then look in \Windows NT\CurrentVersion }
if not UserInfoFound then
if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, sCurVerNT, 0,
KEY_QUERY_VALUE, RegKey) = ERROR_SUCCESS) then begin
I := SizeOf(Buf);
if RegQueryValueEx(RegKey, sRegOwner, nil, nil, @Buf, @I) = ERROR_SUCCESS then begin
UpdateTMD(Context, Buf, I);
I := SizeOf(Buf);
if RegQueryValueEx(RegKey, sRegOrg, nil, nil, @Buf, @I) = ERROR_SUCCESS then
UpdateTMD(Context, Buf, I);
end;
RegCloseKey(RegKey); {!!.13}
end;
end;
if midSystem in MachineInfo then begin
{include system specific information}
GetSystemInfo(SysInfo);
PDWord(@Buf[0])^ := SysInfo.dwOemId;
PDWord(@Buf[4])^ := SysInfo.dwProcessorType;
UpdateTMD(Context, Buf, 8);
end;
if midNetwork in MachineInfo then begin
{include network ID}
CreateGuid(GUID1);
CreateGuid(GUID2);
{!!.11}
{ use UuidCreateSequential instead of CoCreateGuid if available }
hRPCTR4 := LoadLibrary('rpcrt4.dll');
if (hRPCTR4 <> 0) then begin
@UuidCreateSequential := GetProcAddress(hRPCTR4, 'UuidCreateSequential');
if Assigned(UuidCreateSequential) then begin
UuidCreateSequential(@GUID1);
UuidCreateSequential(@GUID2);
end;
FreeLibrary(hRPCTR4); {!!.13}
end;
{!!.11}
{check to see if "network" ID is available}
if (GUID1.D4[2] = GUID2.D4[2]) and
(GUID1.D4[3] = GUID2.D4[3]) and
(GUID1.D4[4] = GUID2.D4[4]) and
(GUID1.D4[5] = GUID2.D4[5]) and
(GUID1.D4[6] = GUID2.D4[6]) and
(GUID1.D4[7] = GUID2.D4[7]) then
UpdateTMD(Context, GUID1.D4[2], 6);
end;
if midDrives in MachineInfo then begin
{include drive specific information}
maxController := 15;
if Win32Platform<>VER_PLATFORM_WIN32_NT then maxController := 0;
for iController := 0 to maxController do
begin
for iDrive := 0 to 4 do
begin
BufStr := '';
if GetIdeDiskSerialNumber(iController,iDrive,BufStr) then
if BufStr<>'' then UpdateTMD(Context, BufStr[1], 5);
end;
end;
end;
FinalizeTMD(Context, Result, SizeOf(Result));
end;
{$ELSE}
{$IFNDEF LINUX}
function CreateMachineID(MachineInfo : TEsMachineInfoSet) : LongInt;
var
I : DWord;
RegKey : DWord;
GUID1 : TGUID;
GUID2 : TGUID;
Drive : Integer;
Context : TTMDContext;
Buf : array [0..1023] of Byte;
begin
InitTMD(Context);
{no user (midUser) information under Win16}
if midSystem in MachineInfo then begin
{include system specific information}
I := GetWindowsDirectory(@Buf, SizeOf(Buf));
UpdateTMD(Context, Buf, I);
I := GetSystemDirectory(@Buf, SizeOf(Buf));
UpdateTMD(Context, Buf, I);
PLongInt(@Buf[0])^ := GetWinFlags;
PLongInt(@Buf[4])^ := WinProcs.GetVersion;
UpdateTMD(Context, Buf, 8);
end;
if midNetwork in MachineInfo then begin
{include network ID}
CreateGuid(GUID1);
CreateGuid(GUID2);
{check to see if "network" ID is available}
if (GUID1.Data4[2] = GUID2.Data4[2]) and
(GUID1.Data4[3] = GUID2.Data4[3]) and
(GUID1.Data4[4] = GUID2.Data4[4]) and
(GUID1.Data4[5] = GUID2.Data4[5]) and
(GUID1.Data4[6] = GUID2.Data4[6]) and
(GUID1.Data4[7] = GUID2.Data4[7]) then
UpdateTMD(Context, GUID1.Data4[2], 6);
end;
if midDrives in MachineInfo then begin
{include drive specific information}
for Drive := 2 {C} to 25 {Z} do begin
if GetDriveType(Drive) = DRIVE_FIXED then begin
FillChar(Buf, Sizeof(Buf), 0);
Buf[0] := Drive;
{!!.06} {removed cluster information}
PLongInt(@Buf[1])^ := GetDiskSerialNumber(Chr(Drive+Ord('A')));{!!.06}
UpdateTMD(Context, Buf, 5);
end;
end;
end;
FinalizeTMD(Context, Result, SizeOf(Result));
end;
{$ELSE}
function CreateMachineID(MachineInfo : TEsMachineInfoSet) : LongInt;
var
I : DWord;
RegKey : DWord;
GUID1 : TGUID;
GUID2 : TGUID;
Drive : Integer;
Context : TTMDContext;
Buf : array [0..2047] of Byte;
iFileHandle : Integer;
begin
InitTMD(Context);
{include user specific information}
if midUser in MachineInfo then
begin
//[to do] find some organization specific info
end;
if midSystem in MachineInfo then
begin
{include system specific information}
iFileHandle := FileOpen('/proc/cpuinfo', fmopenRead or fmShareDenyNone);
I := FileSeek(iFileHandle,0,2);
FileSeek(iFileHandle,0,0);
if I < 2047 then
begin
FileRead(iFileHandle, Buf, I);
UpdateTMD(Context, Buf, I);
end;
FileClose(iFileHandle);
iFileHandle := FileOpen('/proc/sys/kernel/version', fmopenRead or fmShareDenyNone);
I := FileSeek(iFileHandle,0,2);
FileSeek(iFileHandle,0,0);
if I < 2047 then
begin
FileRead(iFileHandle, Buf, I);
UpdateTMD(Context, Buf, I);
end;
FileClose(iFileHandle);
iFileHandle := FileOpen('/proc/sys/kernel/osrelease', fmopenRead or fmShareDenyNone);
I := FileSeek(iFileHandle,0,2);
FileSeek(iFileHandle,0,0);
if I < 2047 then
begin
FileRead(iFileHandle, Buf, I);
UpdateTMD(Context, Buf, I);
end;
FileClose(iFileHandle);
iFileHandle := FileOpen('/proc/sys/kernel/hostname', fmopenRead or fmShareDenyNone);
I := FileSeek(iFileHandle,0,2);
FileSeek(iFileHandle,0,0);
if I < 2047 then
begin
FileRead(iFileHandle, Buf, I);
UpdateTMD(Context, Buf, I);
end;
FileClose(iFileHandle);
end;
if midNetwork in MachineInfo then
begin
{include network ID}
CreateGuid(GUID1);
CreateGuid(GUID2);
{check to see if "network" ID is available}
if (GUID1.D4[2] = GUID2.D4[2]) and
(GUID1.D4[3] = GUID2.D4[3]) and
(GUID1.D4[4] = GUID2.D4[4]) and
(GUID1.D4[5] = GUID2.D4[5]) and
(GUID1.D4[6] = GUID2.D4[6]) and
(GUID1.D4[7] = GUID2.D4[7]) then
UpdateTMD(Context, GUID1.D4[2], 6);
end;
if midDrives in MachineInfo then
begin
{include drive specific information}
for Drive := 2 {C} to 25 {Z} do begin
if GetDriveType(Drive) = 3 {DRIVE_FIXED} then begin
FillChar(Buf, Sizeof(Buf), 0);
Buf[0] := Drive;
{!!.06} {removed cluster information}
PLongInt(@Buf[1])^ := GetDiskSerialNumber(Chr(Drive+Ord('A')));{!!.06}
UpdateTMD(Context, Buf, 5);
end;
end;
end;
FinalizeTMD(Context, Result, SizeOf(Result));
end;
{$ENDIF}
{$ENDIF}
{key generation routines }
procedure GenerateRandomKeyPrim(var Key; KeySize: Cardinal);
var
Bytes : TByteArray absolute Key;
I : Integer;
begin
Randomize;
for I := 0 to KeySize - 1 do
Bytes[I] := Random(256);
end;
procedure GenerateTMDKeyPrim(var Key; KeySize: Cardinal; const Str: string);
var
I : Integer;
S2 : string;
begin
{strip accented characters from the string} {!!.06}
S2 := Str; {!!.06}
for I := Length(S2) downto 1 do {!!.06}
if Ord(S2[I]) > 127 then {!!.06}
Delete(S2, I, 1); {!!.06}
HashTMD(Key, KeySize, S2[1], Length(S2)); {!!.06}
end;
procedure GenerateMD5KeyPrim(var Key: TKey; const Str: string);
var
D : TMD5Digest;
I : Integer;
S2 : string;
begin
{strip accented characters from the string} {!!.06}
S2 := Str; {!!.06}
for I := Length(S2) downto 1 do {!!.06}
if Ord(S2[I]) > 127 then {!!.06}
Delete(S2, I, 1); {!!.06}
D := HashMD5(S2[1], Length(S2)); {!!.06}
Key := TKey(D);
end;
{modifier routines}
function GenerateStringModifierPrim(const S : string) : LongInt;
var
I : Integer; {!!.06}
Sig : array [0..4] of AnsiChar;
S2 : string; {!!.06}
begin
FillChar(Sig, SizeOf(Sig), 0);
{strip accented characters from the string} {!!.06}
S2 := S; {!!.06}
for I := Length(S2) downto 1 do {!!.06}
if Ord(S2[I]) > 127 then {!!.06}
Delete(S2, I, 1); {!!.06}
StrPLCopy(Sig, AnsiUpperCase(S2), Min(4, Length(S2))); {!!.06}
Result := PLongInt(@Sig[0])^;
end;
function GenerateUniqueModifierPrim : LongInt;
var
ID : TGUID;
begin
CreateGuid(ID);
Mix128(T128Bit(ID));
Result := T128Bit(ID)[3];
end;
{!!.05} {revised}
function GenerateMachineModifierPrim : LongInt;
begin
Result := CreateMachineID([midUser, midSystem, {midNetwork,} midDrives]);
end;
function GenerateDateModifierPrim(D : TDateTime) : LongInt;
begin
Result := Trunc(D);
TLongIntRec(Result).Hi := TLongIntRec(Result).Lo xor $AAAA;
end;
procedure ApplyModifierToKeyPrim(Modifier : LongInt; var Key; KeySize : Cardinal);
begin
if Modifier <> 0 then
XorMem(Key, Modifier, Min(SizeOf(Modifier), KeySize));
end;
{*** general routines ***}
function GetCodeType(const Key : TKey; const Code : TCode) : TCodeType;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
case Work.CheckValue of
DateCheckCode : Result := ctDate;
DaysCheckCode : Result := ctDays;
RegCheckCode : Result := ctRegistration;
SerialCheckCode : Result := ctSerialNumber;
UsageCheckCode : Result := ctUsage;
NetCheckCode : Result := ctNetwork;
SpecialCheckCode : Result := ctSpecial;
else
Result := ctUnknown;
end;
end;
function ExpandDate(D : Word) : TDateTime;
begin
if D > 0 then
Result := LongInt(D) + BaseDate
else
Result := EncodeDate(9999, 1, 1);
end;
function ShrinkDate(D : TDateTime) : Word;
begin
if (Trunc(D) = 0) or (Trunc(D) - BaseDate > High(Word)) then
Result := 0
else
Result := Trunc(D) - BaseDate;
end;
function GetExpirationDate(const Key : TKey; const Code : TCode) : TDateTime;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
case Work.CheckValue of
DateCheckCode : Result := ExpandDate(Work.EndDate);
DaysCheckCode : Result := ExpandDate(Work.Expiration);
RegCheckCode : Result := ExpandDate(Work.Expiration);
SerialCheckCode : Result := ExpandDate(Work.Expiration);
UsageCheckCode : Result := ExpandDate(Work.Expiration);
SpecialCheckCode : Result := ExpandDate(Work.Expiration);
else
Result := ExpandDate(0)
end;
end;
{*** date code ***}
procedure InitDateCode(const Key : TKey;
StartDate, EndDate : TDateTime; var Code : TCode);
begin
Code.CheckValue := DateCheckCode;
Code.Expiration := 0; {not used for date codes}
Code.FirstDate := ShrinkDate(StartDate);
Code.EndDate := ShrinkDate(EndDate);
MixBlock(T128bit(Key), Code, True);
end;
function IsDateCodeValid(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := (Work.CheckValue = DateCheckCode) and
(ExpandDate(Work.FirstDate) <= Date);
end;
function GetDateCodeValue(const Key : TKey; const Code : TCode) : TDateTime;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
{return the end date}
if (Work.CheckValue = DateCheckCode) and
(ExpandDate(Work.FirstDate) <= Date) then
Result := ExpandDate(Work.EndDate)
else
Result := 0;
end;
function IsDateCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
begin
Result := (GetDateCodeValue(Key, Code) < Date);
end;
{*** days code ***}
procedure InitDaysCode(const Key : TKey; Days : Word; Expires : TDateTime;
var Code : TCode);
begin
Code.CheckValue := DaysCheckCode;
Code.Expiration := ShrinkDate(Expires);
Code.Days := Days;
Code.LastAccess := ShrinkDate(Date);
MixBlock(T128bit(Key), Code, True);
end;
function IsDaysCodeValid(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := (Work.CheckValue = DaysCheckCode) and
(ExpandDate(Work.LastAccess) <= Date);
end;
procedure DecDaysCode(const Key : TKey; var Code : TCode);
var
X : LongInt;
begin
MixBlock(T128bit(Key), Code, False);
X := ShrinkDate(Date);
if (Code.LastAccess <> X) then begin
if Code.Days > 0 then {!!.02}
Code.Days := Max(0, Code.Days - 1); {!!.02}
Code.LastAccess := X;
end;
MixBlock(T128bit(Key), Code, True);
end;
function GetDaysCodeValue(const Key : TKey; const Code : TCode) : LongInt;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
if (Work.CheckValue = DaysCheckCode) and
(ExpandDate(Work.LastAccess) <= Date) then
Result := Work.Days
else
Result := 0;
end;
function IsDaysCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := (Work.Days = 0) or (ExpandDate(Work.Expiration) < Date);
end;
{*** registration code ***}
procedure InitRegCode(const Key : TKey; const RegStr : string; Expires : TDateTime; var Code : TCode);
var
S : string; {!!.06}
I : Integer; {!!.06}
begin
Code.CheckValue := RegCheckCode;
Code.Expiration := ShrinkDate(Expires);
{strip accented characters from the registration string} {!!.06}
S := RegStr; {!!.06}
for I := Length(S) downto 1 do {!!.06}
if Ord(S[I]) > 127 then {!!.06}
Delete(S, I, 1); {!!.06}
Code.RegString := StringHashElf(AnsiUpperCase(S)); {!!.06}
MixBlock(T128bit(Key), Code, True);
end;
function IsRegCodeValid(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := (Work.CheckValue = RegCheckCode);
end;
function IsRegCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := ExpandDate(Work.Expiration) < Date;
end;
{*** serial number code ***}
procedure InitSerialNumberCode(const Key : TKey; Serial : LongInt; Expires : TDateTime; var Code : TCode);
begin
Code.CheckValue := SerialCheckCode;
Code.Expiration := ShrinkDate(Expires);
Code.SerialNumber := Serial;
MixBlock(T128bit(Key), Code, True);
end;
function IsSerialNumberCodeValid(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := (Work.CheckValue = SerialCheckCode);
end;
function GetSerialNumberCodeValue(const Key : TKey; const Code : TCode) : LongInt;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
if Work.CheckValue = SerialCheckCode then
Result := Work.SerialNumber
else
Result := 0;
end;
function IsSerialNumberCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := ExpandDate(Work.Expiration) < Date;
end;
{*** special code ***}
procedure InitSpecialCode(const Key : TKey; Value : LongInt; Expires : TDateTime; var Code : TCode);
begin
Code.CheckValue := SpecialCheckCode;
Code.Expiration := ShrinkDate(Expires);
Code.Value := Value;
MixBlock(T128bit(Key), Code, True);
end;
function IsSpecialCodeValid(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := (Work.CheckValue = SpecialCheckCode);
end;
function GetSpecialCodeValue(const Key : TKey; const Code : TCode) : LongInt;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
if Work.CheckValue = SpecialCheckCode then
Result := Work.Value
else
Result := 0;
end;
function IsSpecialCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := ExpandDate(Work.Expiration) < Date;
end;
{*** usage code ***}
procedure InitUsageCode(const Key : TKey; Count : Word; Expires : TDateTime; var Code : TCode);
begin
Code.CheckValue := UsageCheckCode;
Code.Expiration := ShrinkDate(Expires);
Code.UsageCount := Count;
Code.LastChange := ShrinkDate(Date); {!!.02}
MixBlock(T128bit(Key), Code, True);
end;
function IsUsageCodeValid(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := (Work.CheckValue = UsageCheckCode) and {!!.02}
(ExpandDate(Work.LastChange) <= Date); {!!.02}
end;
procedure DecUsageCode(const Key : TKey; var Code : TCode);
var {!!.02}
D : Word; {!!.02}
begin
MixBlock(T128bit(Key), Code, False);
D := ShrinkDate(Date); {!!.02}
if Code.UsageCount > 0 then {!!.02}
Code.UsageCount := Max(0, Code.UsageCount - 1); {!!.02}
if (Code.LastChange < D) then {!!.02}
Code.LastChange := D; {!!.02}
MixBlock(T128bit(Key), Code, True);
end;
function GetUsageCodeValue(const Key : TKey; const Code : TCode) : LongInt;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
if (Work.CheckValue = UsageCheckCode) and {!!.02}
(ExpandDate(Work.LastChange) <= Date) then {!!.02}
Result := Work.UsageCount {!!.02}
else
Result := 0;
end;
function IsUsageCodeExpired(const Key : TKey; const Code : TCode) : Boolean;
var
Work : TCode;
begin
Work := Code;
MixBlock(T128bit(Key), Work, False);
Result := (Work.UsageCount = 0) or (ExpandDate(Work.Expiration) < Date);
end;
{$ENDIF}
initialization
{$IFDEF IBO_CONSOLE} {AH.02}
{from onguard.pas}
{record our baseline date}
BaseDate := Trunc(EncodeDate(1996, 1, 1));
{$ENDIF}
end.
Reference in New Issue View Git Blame Copy Permalink