Back

Delphi Units/Code
by James M Sandbrook of Tokoroa, New Zealand.

Here is a small project in a Zip file called TestFormat.
The purpose is to help understand the power of formatting strings in Delphi. Once compiled, the programmer can test different strings and see the result. It works with the routines :
 - Format
 - FormatFloat
 - FormatDateTime

It was written in Delphi 4 but should work or could be adapted to previous versions.
--
Bernard Marcelly
Antony (92) - FRANCE -  <marcelly@club-internet.fr>


Here is some simple code that could be used in the registration part of a shareware type program.
Sunil Gupta. sunil@magnetic.demon.co.uk (sunil gupta) http://www.magnetic.demon.co.uk/

Uses ideas of basic cryptography that I've read from Cryptography Theory & Practice ISBN0-8493-8521-0

unit Cryptlib;

(* copyright 1996 sunil@magnetic.demon.co.uk.
This function is placed into the public domain by the author.
for each character in input string find position in CIPHERKEY
index of new character is
(position^2 + last_calculated_index) MOD length(CIPHERKEY);

budding shareware writers could use this sort of
simple encryption to create 2 keys
1) based on user supplied details
2) based on some other information (not divulged)

at the very minimum change the CIPHERKEY *)

interface
uses sysutils;
function shareware_encode(the_string:string):string;

implementation
const
CIPHERKEY = 'ABCDEFGHIJKL0123456789MNOPQRSTUVWXYZ';
CIPHERLEN = 16;
 

{**********************************************************
*********************************************************}
function shareware_encode(the_string:string):string;
var
upper_string,clean_string, encoded_string:string;
inchar, outchar:char;
index,pos1,pos2,last_pos:integer;
key_len,max_len,upper_len:integer;
key:string;
today:tdatetime;
begin
{----------------------init-----------------------------}
key := uppercase(CIPHERKEY);
encoded_string := '';
key_len := length(key);
upper_string := uppercase(the_string);
last_pos := 0;

{-------------remove invalid characters-------------------}
clean_string := '';
for index := 1 to length(upper_string) do
if pos(upper_string[index],key) >0 then
clean_string := clean_string + upper_string[index];
upper_string := clean_string;

{----------make sure input string is the right length-----}
upper_len := length(upper_string);
if upper_len < CIPHERLEN then
begin
for index := 1 to (CIPHERLEN - upper_len) do
upper_string := upper_string + key[index];
end;

upper_len := length(upper_string);
if upper_len > CIPHERLEN then
begin
upper_string := copy(upper_string,1,CIPHERLEN);
end;

{--------nothing too complex, just encrypt each character------------}
for index:=1 to CIPHERLEN do
begin
inchar := upper_string[index];
pos1 := pos(inchar,key);

pos2 := ((pos1*pos1 + last_pos) MOD key_len);
inc(pos2);
last_pos:= pos2;

outchar := key[pos2];
encoded_string := encoded_string + outchar;

{- - - - - - - for ease of reading split every 4 characters - - - }
if (index mod 4 = 0) and (index < CIPHERLEN) then
encoded_string := encoded_string +'-';
end;
{---------------------all done ----------------}
shareware_encode := encoded_string;
end;
end.


 
{ THashTable unit - Delphi 1 version -      by kktos, May 1997.
     This code is FREEWARE.
     *** Please, if you enhance it, mail me at kktos@sirius.fr ***}
unit HashTabl;

interface

uses Classes;

type
 TDeleteType= (dtDelete, dtDetach);

{ Class THashList, from Delphi 2 TList source
 used internally, but you can use it for any purpose
}

 THashItem= record
  key: longint;
      obj: TObject;
 end;

 PHashItemList = ^THashItemList;
     THashItemList = array[0..0] of THashItem;

     THashList = class(TObject)
     private
         Flist:  PHashItemList;
         Fcount:   integer;
  Fcapacity: integer;
          memSize:  longint;
          FdeleteType: TDeleteType;

     protected
         procedure Error;
         function Get(Index: Integer): THashItem;
         procedure Grow;
         procedure Put(Index: Integer; const Item: THashItem);
         procedure SetCapacity(NewCapacity: Integer);
        procedure SetCount(NewCount: Integer);

     public
    constructor Create;
         destructor Destroy; override;

         function Add(const Item: THashItem): Integer;
         procedure Clear(dt: TDeleteType);
         procedure Detach(Index: Integer);
         procedure Delete(Index: Integer);
         function Expand: THashList;
         function IndexOf(key: longint): Integer;
         procedure Pack;

         property DeleteType: TDeleteType   read FdeleteType write
FdeleteType;
         property Capacity: Integer    read FCapacity  write
SetCapacity;
         property Count: Integer     read FCount  write SetCount;
  property Items[Index: Integer]: THashItem read Get   write Put;
default;
     end;

{ Class THashTable
 the real hashtable.
}

  THashTable= class(TObject)
  private
  Ftable: THashList;

  procedure Error;

  function getCount: integer;
          procedure setCount(count: integer);
  function getCapacity: integer;
          procedure setCapacity(capacity: integer);
  function getItem(index: integer): TObject;
          procedure setItem(index: integer; obj: TObject);
  function getDeleteType: TDeleteType;
          procedure setDeleteType(dt: TDeleteType);

  public
    constructor Create;
    destructor Destroy; override;

  procedure Add(const key: string; value: TObject);
      function Get(const key: string): TObject;
      procedure Detach(const key: string);
      procedure Delete(const key: string);
         procedure Clear(dt: TDeleteType);
      procedure Pack;

         property DeleteType: TDeleteType   read getDeleteType write
setDeleteType;
     property Count: integer      read getCount  write setCount;
         property Capacity: Integer    read getCapacity write
setCapacity;
         property Items[index: Integer]: TObject  read getItem  write
setItem;
          property Table: THashList    read Ftable;
  end;

function hash(key: Pointer; length: longint; level: longint): longint;

implementation

uses SysUtils, Consts;

type
 longArray= packed array[0..3] of byte;
 longArrayPtr= ^longArray;

 array12=  packed array[0..11] of byte;
 array12Ptr= ^array12;

     longPtr=  ^longint;
 

{ --- Class THashList ---
 brute copy of TList D2 source, with some minors changes
     no comment, see TList
}

{-----------------------------------------------------------------------------}

constructor THashList.Create;
begin
 FdeleteType:= dtDelete;
 FCapacity:= 0;
     FCount:= 0;
     memSize:= 4;
     Flist:= AllocMem(memSize);
     SetCapacity(100);
end;

{-----------------------------------------------------------------------------}

destructor THashList.Destroy;
begin
 Clear(FdeleteType);
     FreeMem(FList, memSize);
end;

{-----------------------------------------------------------------------------}

function THashList.Add(const Item: THashItem): Integer;
begin
 Result := FCount;
 if(Result = FCapacity) then Grow;
 FList^[Result].key:= Item.key;
 FList^[Result].obj:= Item.obj;
 Inc(FCount);
end;

{-----------------------------------------------------------------------------}

procedure THashList.Clear(dt: TDeleteType);
var
 i: integer;
begin
 if(dt=dtDelete) then
  for i := FCount - 1 downto 0 do
     if(Items[i].obj <> nil) then
        Items[i].obj.Free;
     {FreeMem(FList, memSize);
     memSize:= 4;
     Flist:= AllocMem(memSize);}
 FCapacity:= 0;
     FCount:= 0;
end;

{-----------------------------------------------------------------------------}

{ know BC++ ? remember TArray::Detach?
 if not, Detach remove the item from the list without disposing the
object
}
procedure THashList.Detach(Index: Integer);
begin
 if((Index < 0) or (Index >= FCount)) then Error;
 Dec(FCount);
 if(Index < FCount) then
  System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) *
SizeOf(THashItem));
end;

{-----------------------------------------------------------------------------}

{ know BC++ ? remember TArray::Destroy ? renames delete 'cause
destroy...
 if not, Delete remove the item from the list AND dispose the object
}
procedure THashList.Delete(Index: Integer);
begin
 if((Index < 0) or (Index >= FCount)) then Error;
 Dec(FCount);
 if(Index < FCount) then begin
  FList^[Index].obj.Free;
  System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) *
SizeOf(THashItem));
     end;
end;

{-----------------------------------------------------------------------------}

procedure THashList.Error;
begin
 raise EListError.CreateRes(SListIndexError);
end;

{-----------------------------------------------------------------------------}

function THashList.Expand: THashList;
begin
 if(FCount = FCapacity) then Grow;
 Result:= Self;
end;

{-----------------------------------------------------------------------------}

function THashList.Get(Index: Integer): THashItem;
begin
 if((Index < 0) or (Index >= FCount)) then Error;
 Result.key:= FList^[Index].key;
 Result.obj:= FList^[Index].obj;
end;

{-----------------------------------------------------------------------------}

procedure THashList.Grow;
var
  Delta: Integer;
begin
 if FCapacity > 8 then Delta := 16
     else if FCapacity > 4 then Delta := 8
     else Delta := 4;
 SetCapacity(FCapacity + Delta);
end;

{-----------------------------------------------------------------------------}

function THashList.IndexOf(key: longint): Integer;
begin
 Result := 0;
 while (Result < FCount) and (FList^[Result].key <> key) do Inc(Result);

 if Result = FCount then Result:= -1;
end;

{-----------------------------------------------------------------------------}

procedure THashList.Put(Index: Integer; const Item: THashItem);
begin
 if (Index < 0) or (Index >= FCount) then Error;
 FList^[Index].key:= Item.key;
 FList^[Index].obj:= Item.obj;
end;

{-----------------------------------------------------------------------------}

procedure THashList.Pack;
var
  i: Integer;
begin
 for i := FCount - 1 downto 0 do
    if Items[i].obj = nil then Delete(i);
end;

{-----------------------------------------------------------------------------}

procedure THashList.SetCapacity(NewCapacity: Integer);
begin
 if((NewCapacity < FCount) or (NewCapacity > MaxListSize)) then Error;
 if(NewCapacity <> FCapacity) then begin
  FList:= ReallocMem(FList, memSize, NewCapacity * SizeOf(THashItem));
      memSize:= NewCapacity * SizeOf(THashItem);
  FCapacity:= NewCapacity;
 end;
end;

{-----------------------------------------------------------------------------}

procedure THashList.SetCount(NewCount: Integer);
begin
 if((NewCount < 0) or (NewCount > MaxListSize)) then Error;
 if(NewCount > FCapacity) then SetCapacity(NewCount);
 if(NewCount > FCount) then
  FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(THashItem), 0);
 FCount:= NewCount;
end;
 
 

{ --- Class THashTable ---
 it's just a list of THashItems.
     you provide a key (string) and an object;
     a unique numeric key (longint) is compute (see hash);
     when you get an object, you provide string key, and as fast as
possible
     the object is here.
     Really fast;
     Really smart, because of string keys.
}
 

{-----------------------------------------------------------------------------}

constructor THashTable.Create;
begin
 inherited Create;
     Ftable:= THashList.Create;
end;

{-----------------------------------------------------------------------------}

destructor THashTable.Destroy;
begin
 Ftable.Free;
 inherited Destroy;
end;

{-----------------------------------------------------------------------------}

procedure THashTable.Error;
begin
 raise EListError.CreateRes(SListIndexError);
end;

{-----------------------------------------------------------------------------}

{
 Add 'value' object with key 'key'
}
procedure THashTable.Add(const key: string; value: TObject);
var
 item: THashItem;
begin
 item.key:= hash(pointer(longint(@key)+1),length(key),0);
     item.obj:= value;
 Ftable.Add(item);
end;

{-----------------------------------------------------------------------------}

{
 Get object with key 'key'
}
function THashTable.Get(const key: string): TObject;
var
 index: integer;
begin
 index:= Ftable.IndexOf(hash(pointer(longint(@key)+1),length(key),0));
 if(index<0) then Error;
     result:= Ftable[index].obj;
end;

{-----------------------------------------------------------------------------}

{
 Detach (remove item, do not dispose object) object with key 'key'
}
procedure THashTable.Detach(const key: string);
var
 index: integer;
begin
 index:= Ftable.IndexOf(hash(pointer(longint(@key)+1),length(key),0));
     if(index>=0) then
      Ftable.Detach(index);
end;

{-----------------------------------------------------------------------------}

{
 Delete (remove item, dispose object) object with key 'key'
}
procedure THashTable.Delete(const key: string);
var
 index: integer;
begin
 index:= Ftable.IndexOf(hash(pointer(longint(@key)+1),length(key),0));
     if(index>=0) then
      Ftable.Delete(index);
end;

{-----------------------------------------------------------------------------}

{
 Clear the list; i.e: remove all the items (detach or delete depending
of 'dt')
}
procedure THashTable.Clear(dt: TDeleteType);
begin
 Ftable.Clear(dt);
end;

{-----------------------------------------------------------------------------}

procedure THashTable.Pack;
begin
 Ftable.Pack;
end;

{-----------------------------------------------------------------------------}

function  THashTable.getCount: integer;    begin result:= Ftable.Count;
end;
procedure THashTable.setCount(count: integer);  begin Ftable.Count:=
count; end;
function  THashTable.getCapacity: integer;   begin result:=
Ftable.Capacity; end;
procedure THashTable.setCapacity(capacity: integer); begin
Ftable.Capacity:= capacity; end;
function  THashTable.getDeleteType: TDeleteType;  begin result:=
Ftable.DeleteType; end;
procedure THashTable.setDeleteType(dt: TDeleteType); begin
Ftable.DeleteType:= dt; end;
function  THashTable.getItem(index: integer): TObject; begin result:=
Ftable[index].obj; end;

{-----------------------------------------------------------------------------}

procedure THashTable.setItem(index: integer; obj: TObject);
var
 item: THashItem;
begin
 item.key:= Ftable[index].key;
     item.obj:= obj;
 Ftable[index]:= item;
end;

{-----------------------------------------------------------------------------}

{ original code from lookup2.c, by Bob Jenkins, December 1996
 http://ourworld.compuserve.com/homepages/bob_jenkins/
     PLEASE, let me know if there is problem with it, or if you have a
better one. THANKS.
}
function hash(key: Pointer; length: longint; level: longint): longint;
var
 a,b,c:  longint;
     len:   longint;
     k:    array12Ptr;
     lp:   longPtr;

begin
 k:= array12Ptr(key);
 len:= length;
     a:= $9E3779B9;
     b:= a;
     c:= level;

     if((longint(key) and 3) <> 0) then begin
      while(len>=12) do begin {unaligned}
   inc(a, (longint(k^[00]) +(longint(k^[01]) shl 8) + (longint(k^[02])
shl 16) + (longint(k^[03]) shl 24)));
               inc(b, (longint(k^[04]) +(longint(k^[05]) shl 8) +
(longint(k^[06]) shl 16) + (longint(k^[07]) shl 24)));
               inc(c, (longint(k^[08]) +(longint(k^[09]) shl 8) +
(longint(k^[10]) shl 16) + (longint(k^[11]) shl 24)));

               {mix(a,b,c);}
   inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 13);
   inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor
(a shl 8);
   inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 13);
   inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 12);
   inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor
(a shl 16);
   inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 5);
   inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 3);
       inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b
xor (a shl 10);
   inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 15);

               inc(longint(k),12);
               dec(len,12);
          end;
     end

     else begin
      while(len>=12) do begin {aligned}
           lp:= longPtr(k);
   inc(a, lp^); inc(lp,4);
   inc(b, lp^); inc(lp,4);
               inc(c, lp^);

               {mix(a,b,c);}
   inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 13);
   inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor
(a shl 8);
   inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 13);
   inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 12);
   inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor
(a shl 16);
   inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 5);
   inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 3);
       inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b
xor (a shl 10);
   inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 15);

               inc(longint(k),12);
               dec(len,12);
          end;
     end;

     inc(c,length);

 if(len>=11) then inc(c, (longint(k^[10]) shl 24));
 if(len>=10) then inc(c, (longint(k^[9]) shl 16));
 if(len>=9) then inc(c, (longint(k^[8]) shl 8));
 if(len>=8) then inc(b, (longint(k^[7]) shl 24));
 if(len>=7) then inc(b, (longint(k^[6]) shl 16));
 if(len>=6) then inc(b, (longint(k^[5]) shl 8));
 if(len>=5) then inc(b, longint(k^[4]));
 if(len>=4) then inc(a, (longint(k^[3]) shl 24));
 if(len>=3) then inc(a, (longint(k^[2]) shl 16));
 if(len>=2) then inc(a, (longint(k^[1]) shl 8));
 if(len>=1) then inc(a, longint(k^[0]));

     {mix(a,b,c);}
 inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 13);
 inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor
(a shl 8);
 inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 13);
 inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 12);
 inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b xor
(a shl 16);
 inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 5);
 inc(a , b xor $FFFFFFFF + 1); inc(a , c xor $FFFFFFFF + 1); a:= a xor
(c shr 3);
     inc(b , c xor $FFFFFFFF + 1); inc(b , a xor $FFFFFFFF + 1); b:= b
xor (a shl 10);
 inc(c , a xor $FFFFFFFF + 1); inc(c , b xor $FFFFFFFF + 1); c:= c xor
(b shr 15);

     result:= longint(c);
end;

end.

Back