{
    This file is part of the Free Pascal packages.
    Copyright (c) 1999-2006 by the Free Pascal development team

    Implements a UUID generation algorithm (RFC 4122)

    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.

 **********************************************************************}

unit uuid;

interface

{$mode objfpc}
{$h+}

uses
  SysUtils, DateUtils, md5, sha1;



(******************************************************************************
 * types and constants
 ******************************************************************************)

type
{$ifdef VER2_0}
       uuid_t = packed record
          case integer of
             1 : (
                  Data1 : DWord;
                  Data2 : word;
                  Data3 : word;
                  Data4 : array[0..7] of byte;
                 );
             2 : (
                  D1 : DWord;
                  D2 : word;
                  D3 : word;
                  D4 : array[0..7] of byte;
                 );
             3 : ( { uuid fields according to RFC4122 }
                  time_low : dword;     // The low field of the timestamp
                  time_mid : word;                      // The middle field of the timestamp
                  time_hi_and_version : word;           // The high field of the timestamp multiplexed with the version
                  clock_seq_hi_and_reserved : byte;     // The high field of the clock sequence multiplexed with the var
                  clock_seq_low : byte;                 // The low field of the clock sequence
                  node : array[0..5] of byte;           // The spatially unique node identifier
                 );
       end;
{$else VER2_0}
  uuid_t          = TGuid;
{$endif VER2_0}
  uuid_time_t     = qword;
  uuid_node_t     = array[0..5] of byte;
  unsigned16      = word;

  uuid_state      = record
    ts   : uuid_time_t;   // saved timestamp
    node : uuid_node_t;   // saved node ID
    cs   : unsigned16;    // saved clock sequence
  end;

const
  UUID_VERSION_1  = $1;   // The time-based version specified in this document.
  UUID_VERSION_2  = $2;   // DCE Security version, with embedded POSIX UIDs.
  UUID_VERSION_3  = $3;   // The name-based version specified in this document that uses MD5 hashing.
  UUID_VERSION_4  = $4;   // The randomly or pseudo-randomly generated version specified in this document.
  UUID_VERSION_5  = $5;   // The name-based version specified in this document that uses SHA-1 hashing.

{ set the following to the number of 100ns ticks of the actual resolution of your system's clock }
  UUIDS_PER_TICK  = 1024;



(******************************************************************************
 * core uuid functions
 ******************************************************************************)

{ uuid_initialize -- used to initialize the uuid_create function }
procedure uuid_initialize(const state: uuid_state);

{ uuid_create -- generator a UUID }
function uuid_create(out uuid: uuid_t): boolean;

{ uuid_finalize -- returns the current state }
procedure uuid_finalize(out state: uuid_state);

{ uuid_create_md5_from_name -- create a version 3 (MD5) UUID using a "name" from a "name space" }
procedure uuid_create_md5_from_name(out uuid: uuid_t; const nsid: uuid_t; const name: string);

{ uuid_create_sha1_from_name -- create a version 5 (SHA-1) UUID using a "name" from a "name space" }
procedure uuid_create_sha1_from_name(out uuid: uuid_t; const nsid: uuid_t; const name: string);

{ uuid_compare --  Compare two UUID's "lexically" }
function uuid_compare(const u1, u2: uuid_t): integer;



(******************************************************************************
 * auxilary functions
 ******************************************************************************)

{ read_state -- read UUID generator state from non-volatile store }
function read_state(out clockseq: unsigned16; out timestamp: uuid_time_t; out node: uuid_node_t): boolean;

{ write_state -- save UUID generator state back to non-volatile storage }
procedure write_state(var clockseq: unsigned16; const timestamp: uuid_time_t; const node: uuid_node_t);

{ format_uuid_v1 -- make a UUID from the timestamp, clockseq, and node ID }
procedure format_uuid_v1(out uuid: uuid_t; const clockseq: unsigned16; const timestamp: uuid_time_t; const node: uuid_node_t);

{ format_uuid_v3or5 -- make a UUID from a (pseudo)random 128-bit number }
procedure format_uuid_v3or5(out uuid: uuid_t; const hash: pointer; const v: integer);

{ get_current_time -- get time as 60-bit 100ns ticks since UUID epoch. Compensate for the fact that real clock resolution is less than 100ns. }
procedure get_current_time(out timestamp: uuid_time_t);



(******************************************************************************
 * system functions
 ******************************************************************************)

{ get_system_time -- system dependent call to get the current system time. Returned as 100ns ticks since UUID epoch, but resolution may be less than 100ns. }
procedure get_system_time(out timestamp: uuid_time_t);

{ true_random -- generate a crypto-quality random number. }
function true_random: unsigned16;

implementation


{ uuid_initialize }

var
  current_state : uuid_state;
  current_node  : uuid_node_t;

procedure uuid_initialize(const state: uuid_state);
begin
  Randomize;
  current_node[0] := Random($100);
  current_node[1] := Random($100);
  current_node[2] := Random($100);
  current_node[3] := Random($100);
  current_node[4] := Random($100);
  current_node[5] := Random($100);
  current_state := state;
end;


{ uuid_finalize }

procedure uuid_finalize(out state: uuid_state);
begin
  state := current_state;
end;


{ uuid_create }

function uuid_create(out uuid: uuid_t): boolean;
var
  timestamp: uuid_time_t;
  last_time: uuid_time_t;
  clockseq: unsigned16;
  last_node: uuid_node_t;
  f: boolean;
begin
  (* acquire system-wide lock so we're alone *)
// LOCK;

  (* get time, node ID, saved state from non-volatile storage *)
  get_current_time(timestamp);
  f := read_state(clockseq, last_time, last_node);

  (* if no NV state, or if clock went backwards, or node ID
     changed (e.g., new network card) change clockseq *)
   if not f or not CompareMem(@current_node, @last_node, sizeof(uuid_node_t)) then
     clockseq := true_random() else
   if timestamp < last_time then
     clockseq := clockseq + 1;

   (* save the state for next time *)
   write_state(clockseq, timestamp, current_node);

// UNLOCK;

   (* stuff fields into the UUID *)
   format_uuid_v1(uuid, clockseq, timestamp, current_node);

   Result := true;
end;


{ uuid_create_md5_from_name }

procedure uuid_create_md5_from_name(out uuid: uuid_t; const nsid: uuid_t; const name: string);
var
  net_nsid: uuid_t;
  c: TMDContext;
  hash: TMDDigest;
begin
  (* put name space ID in network byte order so it hashes the same
     no matter what endian machine we're on *)
  net_nsid := nsid;
  net_nsid.time_low := ntobe(net_nsid.time_low);
  net_nsid.time_mid := ntobe(net_nsid.time_mid);
  net_nsid.time_hi_and_version := ntobe(net_nsid.time_hi_and_version);

  MDInit(c, MD_VERSION_5);
  MDUpdate(c, net_nsid, sizeof(net_nsid));
  MDUpdate(c, pchar(name)^, Length(name));
  MDFinal(c, hash);

  (* the hash is in network byte order at this point *)
  format_uuid_v3or5(uuid, @hash, UUID_VERSION_3);
end;


{ uuid_create_sha1_from_name }

procedure uuid_create_sha1_from_name(out uuid: uuid_t; const nsid: uuid_t; const name: string);
var
  net_nsid: uuid_t;
  c: TSHA1Context;
  hash: TSHA1Digest;
begin
  (* put name space ID in network byte order so it hashes the same
     no matter what endian machine we're on *)
  net_nsid := nsid;
  net_nsid.time_low := ntobe(net_nsid.time_low);
  net_nsid.time_mid := ntobe(net_nsid.time_mid);
  net_nsid.time_hi_and_version := ntobe(net_nsid.time_hi_and_version);

  SHA1Init(c);
  SHA1Update(c, net_nsid, sizeof(net_nsid));
  SHA1Update(c, pchar(name)^, Length(name));
  SHA1Final(c, hash);

  (* the hash is in network byte order at this point *)
  format_uuid_v3or5(uuid, @hash, UUID_VERSION_5);
end;


{ uuid_compare }

function uuid_compare(const u1, u2: uuid_t): integer;
begin
  Result := pinteger(@u1)[0] - pinteger(@u2)[0];
  if Result <> 0 then Exit;
  Result := pinteger(@u1)[1] - pinteger(@u2)[1];
  if Result <> 0 then Exit;
  Result := pinteger(@u1)[2] - pinteger(@u2)[2];
  if Result <> 0 then Exit;
  Result := pinteger(@u1)[3] - pinteger(@u2)[3];
end;


{ read_state }

function read_state(out clockseq: unsigned16; out timestamp: uuid_time_t; out node: uuid_node_t): boolean;
begin
  clockseq := current_state.cs;
  timestamp := current_state.ts;
  node := current_state.node;
  Result := true;
end;


{ write_state }

procedure write_state(var clockseq: unsigned16; const timestamp: uuid_time_t; const node: uuid_node_t);
begin
  (* always save state to volatile shared state *)
  current_state.cs := clockseq;
  current_state.ts := timestamp;
  current_state.node := node;
end;


{ format_uuid_v1 }

procedure format_uuid_v1(out uuid: uuid_t; const clockseq: unsigned16; const timestamp: uuid_time_t; const node: uuid_node_t);
begin
  uuid.time_low := timestamp and $FFFFFFFF;
  uuid.time_mid := (timestamp shr 32) and $FFFF;
  uuid.time_hi_and_version := (timestamp shr 48) and $0FFF;
  uuid.time_hi_and_version := uuid.time_hi_and_version or (UUID_VERSION_1 shl 12);
  uuid.clock_seq_low := clockseq and $FF;
  uuid.clock_seq_hi_and_reserved := (clockseq shr 8) and $3F;
  uuid.clock_seq_hi_and_reserved := uuid.clock_seq_hi_and_reserved or $80;
  uuid.node := node;
end;


{ format_uuid_v3or5 }

procedure format_uuid_v3or5(out uuid: uuid_t; const hash: pointer; const v: integer);
begin
  (* convert UUID to local byte order *)
  move(hash^, uuid, sizeof(uuid));
  uuid.time_low := beton(uuid.time_low);
  uuid.time_mid := beton(uuid.time_mid);
  uuid.time_hi_and_version := beton(uuid.time_hi_and_version);

  (* put in the variant and version bits *)
  uuid.time_hi_and_version := uuid.time_hi_and_version and $0FFF;
  uuid.time_hi_and_version := uuid.time_hi_and_version or (v shl 12);
  uuid.clock_seq_hi_and_reserved := $3F;
  uuid.clock_seq_hi_and_reserved := uuid.clock_seq_hi_and_reserved or $80;
end;


{ get_current_time }

var
  time_last: uuid_time_t;
  uuids_this_tick: unsigned16 = UUIDS_PER_TICK;

procedure get_current_time(out timestamp: uuid_time_t);
var
  time_now: uuid_time_t;
begin
  while true do
  begin
    get_system_time(time_now);

    (* if clock reading changed since last UUID generated, *)
    if time_last <> time_now then
    begin
      (* reset count of uuids gen'd with this clock reading *)
      uuids_this_tick := 0;
      time_last := time_now;
      Break;
    end;

    if uuids_this_tick < UUIDS_PER_TICK then
    begin
      uuids_this_tick := uuids_this_tick + 1;
      Break;
    end;

    (* going too fast for our clock; spin *)
  end;

  (* add the count of uuids to low order bits of the clock reading *)
  timestamp := time_now + uuids_this_tick;
end;


{ get_system_time }

procedure get_system_time(out timestamp: uuid_time_t);
var
  Epoch:TDateTime;
begin
  Epoch := EncodeDateTime(1582, 10, 15, 0, 0, 0, 0);
  timestamp := 10000*MilliSecondsBetween(Epoch, Now);
end;


{ true_random }

function true_random: unsigned16;
begin
  Result := Random($10000);
end;

end.