{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        primary:   icq2000cc@hobi.ru
              secondary: alexander_vaga@hotmail.com
Web:          http://icq2000cc.hobi.ru
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit Packet;
interface
uses Types,SysUtils,Math,StdCtrls,
     Windows,Winsock;

function CreatePacket(ChID:byte; var SEQ:word) : PPack;
function PacketNew : PPack;
procedure PacketDelete(p:PPack);
procedure PacketAppend8(p : PPack; i : byte);
procedure PacketAppend16(p : PPack; i : word);
procedure PacketAppend32(p : PPack; i : longint);
procedure SetLengthPacket(p : PPack);
procedure TLVAppendStr(p : PPack; T:word;V:string);
function TLVReadStr(p : PPack; var V:string):word;
procedure TLVAppendWord(p : PPack; T:word;V:word);
procedure TLVAppendDWord(p : PPack; T:word;V:longint);
function TLVReadWord(p : PPack; var V:word):word;
function TLVReadDWord(p : PPack; var V:longint):word;
procedure TLVAppend(p : PPack; T:word;L:word;V:pointer);
procedure SNACAppend(p : PPack; FamilyID,SubTypeID:word);
function PacketRead8(p : PPack): byte;
function PacketRead16(p : PPack): word;
function PacketRead32(p : PPack): longint;
procedure PacketAdvance(p:PPack; i : integer);
procedure PacketAppendB_String(p:PPack; s:string);
procedure PacketAppendString(p:PPack; s:string);
procedure PacketAppendStringFE(p:PPack; s:string);
procedure PacketAppend(p:PPack; what:pointer; len:integer);
procedure PacketRead(p:PPack; Buf:pointer; length:integer);
function PacketReadString(p:PPack):string;
function PacketReadB_String(p:PPack):string;
procedure PacketBegin(p:PPack);
procedure PacketEnd(p:PPack);
procedure PacketGoto(p:PPack; i:integer);
function PacketPos(p:PPack):word;
function Swap(InWord:word):word;
function DSwap(InLong:longint):longint;assembler;
function Dim2Hex(what:pointer;len:integer):string;
function Dim2Str(what:pointer;len:integer):string;
function UniCase(sStr : string) : string;
procedure StrToIP(sIP:string; var aIP:IParray);
function IPtoStr(var aIP:IParray):string;
function UTC2LT(year,month,day,hour,min:integer) : TDateTime;
function Now2DateTime : TDateTime;
function SecsSince1970:longint;
function s(i : longint) : string;
procedure M(Memo:TMemo; s:string);
const OL : booLean = false;
function Get_my_IP: string;
function Calc_Pass(PassIN : string):string;

implementation

function CreatePacket(ChID:byte; var SEQ:word) : PPack;
var p : PPack;
begin
      p := PacketNew;
      PacketAppend8(p, $2A);
      PacketAppend8(p, ChID);
      PacketAppend16(p, swap(SEQ));  inc(SEQ);
      PacketAppend16(p, 0); // length - must be filled later
      Result := p;          // see SetLengthPacket()
end;

function PacketNew : PPack;
var p : PPack;
begin
   New(p);
   fillchar(p^,sizeof(Pack),0);
   p^.cursor :=0;
   p^.length :=0;
   PacketNew := p;
end;

procedure PacketDelete(p:PPack);
begin
     Dispose(p);
end;

procedure PacketAdvance(p:PPack; i : integer);
begin
     p^.cursor := p^.cursor+i;
     if p^.cursor > p^.length then
        p^.length := p^.cursor;
end;

procedure PacketAppend8(p : PPack; i : byte);
begin
     PBYTE(@(p^.data[p^.cursor]))^ := i;
     PacketAdvance(p,sizeof(byte));
end;

procedure PacketAppend16(p : PPack; i : word);
begin
     PWORD(@(p^.data[p^.cursor]))^ := i;
     PacketAdvance(p,sizeof(word));
end;

procedure PacketAppend32(p : PPack; i : longint);
begin
     PLONG(@(p^.data[p^.cursor]))^ := i;
     PacketAdvance(p,sizeof(longint));
end;

procedure SetLengthPacket(p : PPack);
begin
      PFLAP_HDR(@(p^.data))^.Len := swap(p^.length-sizeof(FLAP_HDR));
end;

procedure TLVAppendStr(p : PPack; T:word;V:string);
var i : integer;
begin
     PacketAppend16(p,swap(T));         // add TYPE
     PacketAppend16(p,swap(length(V))); // add LEN
     for i:=1 to Length(V) do           // add VALUE (variable)
       PacketAppend8(p,byte(V[i]));
end;

function TLVReadStr(p : PPack; var V:string):word;
var i,L : integer;
begin
     V:='';
     Result := swap(PacketRead16(p));
     L := swap(PacketRead16(p));
     for i:=1 to L do  // add VALUE (variable)
       V:=V+char(PacketRead8(p));
end;


procedure TLVAppendWord(p : PPack; T:word;V:word);
begin
     PacketAppend16(p,swap(T));             // add TYPE
     PacketAppend16(p,swap(sizeof(word)));  // add LEN
     PacketAppend16(p,swap(V));             // add VALUE
end;

function TLVReadWord(p : PPack; var V:word):word;
begin
     Result := swap(PacketRead16(p));  // get TYPE
     if swap(PacketRead16(p))<>0 then  // xxxx LEN (word=2)
       V := swap(PacketRead16(p));     // get 16-VALUE
end;

procedure TLVAppendDWord(p : PPack; T:word;V:longint);
begin
     PacketAppend16(p,swap(T));                // add TYPE
     PacketAppend16(p,swap(sizeof(longint)));  // add LEN
     PacketAppend32(p,dswap(V));               // add VALUE
end;

function TLVReadDWord(p : PPack; var V:longint):word;
begin
     Result := swap(PacketRead16(p));  // get TYPE
     if swap(PacketRead16(p))<>0 then  // LEN (word=2)
       V := dswap(PacketRead32(p));    // get 32-VALUE
end;

procedure TLVAppend(p : PPack; T:word;L:word;V:pointer);
begin
     PacketAppend16(p,swap(T));  // add TYPE
     PacketAppend16(p,swap(L));  // add LEN
     PacketAppend(p,V,L);        // add VALUE (variable)
end;

procedure SNACAppend(p : PPack; FamilyID,SubTypeID:word);
begin
     PacketAppend16(p, swap(FamilyID));
     PacketAppend16(p, swap(SubTypeID));
     PacketAppend16(p, swap($0000));

     PacketAppend16(p, Swap(random($FF)));
     PacketAppend16(p, Swap(SubTypeID));
end;

function PacketRead8(p : PPack): byte;
var val : byte;
begin
     	val := PBYTE(@(p^.data[p^.cursor]))^;
	PacketAdvance(p, sizeof(byte));
	Result := val;
end;

function PacketRead16(p : PPack): word;
var val : word;
begin
  	val := PWORD(@(p^.data[p^.cursor]))^;
	PacketAdvance(p, sizeof(word));
	Result := val;
end;

function PacketRead32(p : PPack): longint;
var val : longint;
begin
	val := PLONG(@(p^.data[p^.cursor]))^;
	PacketAdvance(p, sizeof(longint));
	Result := val;
end;

procedure PacketAppendB_String(p:PPack; s:string);
var i : integer;
begin
     PacketAppend8(p, length(s));
     for i:=1 to length(s) do
       PacketAppend8(p,byte(s[i]));
end;

procedure PacketAppendString(p:PPack; s:string);
var len : word;
    sStr : string;
    i : integer;
begin
    if s <> '' then begin
      sStr := s+#0;
      len := length(sStr);
      PacketAppend16(p, len);
      for i:=1 to len do begin
        PBYTE(@(p^.data[p^.cursor]))^ := byte(sStr[i]);
        PacketAdvance(p,sizeof(byte));
      end;
    end else begin
      PacketAppend16(p, 1);
      PacketAppend8(p,0);
    end;
end;

function PacketReadString(p:PPack):string;
var length : word;
    sTemp : string;
    dTemp : TByteArray;
begin
      length := PacketRead16(p);
      setlength(sTemp,length-1);
      PacketRead(p, @dTemp,length);
      if length = 1 then Result := ''
      else begin
        move(dTemp,sTemp[1],length-1); // -1 = without #00
        Result := sTemp;
      end;
end;

function PacketReadB_String(p:PPack):string;
var length : byte;
    dTemp : TByteArray;
begin
      length := PacketRead8(p);
      setlength(Result,length);
      PacketRead(p, @dTemp,length);
      move(dTemp,Result[1],length);
end;

procedure PacketAppend(p:PPack; what:pointer; len:integer);
begin
     move(what^, PBYTE(@(p^.data[p^.cursor]))^, len);
     PacketAdvance(p, len);
end;

procedure PacketRead(p:PPack; Buf:pointer; length:integer);
begin
     move(p^.data[p^.cursor],Buf^,length);
     PacketAdvance(p, length);
end;

procedure PacketAppendStringFE(p:PPack; s:string);
var len : integer;
begin
	if s <> '' then begin
	  len := length(s);
	   PacketAppend(p, PChar(s[1]), len);
	end;
	PacketAppend8(p, $FE);
end;

procedure PacketBegin(p:PPack);
begin
     p^.cursor := 0;
end;

procedure PacketEnd(p:PPack);
begin
     p^.cursor := p^.length;
end;

procedure PacketGoto(p:PPack; i:integer);
begin
	PacketBegin(p);
	PacketAdvance(p, i);
end;

function PacketPos(p:PPack):word;
begin
     result := p^.cursor;
end;


function Swap(InWord:word):word;
begin
     Result := (lo(InWord)shl 8)+hi(InWord);
end;


function DSwap(InLong:longint):longint;assembler;
asm
   MOV EAX,InLong
   BSWAP EAX
   MOV Result,EAX
end;


function Dim2Hex(what:pointer;len:integer):string;
var i : integer;
    b : byte;
begin
     Result:='';
     for i:=0 to len-1 do begin
       b:=PByteArray(what)^[i];
       Result := Result+inttohex(b,2)+' ';
     end;
end;

function Dim2Str(what:pointer;len:integer):string;
var i : integer;
    b : byte;
begin
     Result:='';
     for i:=0 to len-1 do begin
       b:=PByteArray(what)^[i];
       if b<32 then b:=byte('.');
       Result := Result+char(b)+'  ';
     end;
end;

(****************************************************************)
function UniCase(sStr : string) : string;
const UniBuf : array[0..$1F] of char =
( 'A','B','V','G','D','E','Z','Z','I','J','K','L','M','N','O','P',
  'R','S','T','U','F','H','C','C','S','S','.','I','.','E','J','Y' );
var i : integer;
begin
     Result := sStr;
     for i:=1 to length(Result) do
        if Result[i] in [#$C0..#$FF] then Result[i] := UniBuf[byte(Result[i])and$1F];
     Result := UpperCase(Result);
end;

(****************************************************************)
procedure StrToIP(sIP:string; var aIP:IParray);
var sTemp : string;
    aPos,bPos,cPos : integer;
begin
     longint(aIP) := 0;  if sIP = '' then exit;
     sTemp := sIP;
     aPos := pos('.',sTemp); if aPos = 0 then exit;
     sTemp[aPos] := 'a';
     bPos := pos('.',sTemp); if bPos = 0 then exit;
     sTemp[bPos] := 'b';
     cPos := pos('.',sTemp); if cPos = 0 then exit;
     sTemp[cPos] := 'c';
     try aIP[0] := strtoint(copy(sTemp,1,aPos-1)); except end;
     try aIP[1] := strtoint(copy(sTemp,aPos+1,bPos-aPos-1)); except end;
     try aIP[2] := strtoint(copy(sTemp,bPos+1,cPos-bPos-1)); except end;
     try aIP[3] := strtoint(copy(sTemp,cPos+1,length(sTemp)-cPos)); except end;
end;

(****************************************************************)
function IPtoStr(var aIP:IParray):string;
begin
     IPtoStr := s(aIP[0])+'.'+s(aIP[1])+'.'+s(aIP[2])+'.'+s(aIP[3]);
end;

(****************************************************************)
function UTC2LT(year,month,day,hour,min:integer) : TDateTime;
var r : longword;
    Time : TDateTime;
    TimeStamp : TTimeStamp;
    TZ_INFO   : TIME_ZONE_INFORMATION;
begin
    r := GetTimeZoneInformation(_Time_Zone_Information(TZ_INFO));
    TimeStamp := DateTimeToTimeStamp(EncodeDate(year,month,day)+EncodeTime(hour,min,0,0));
    Time := TimeStampToDateTime(TimeStamp);
    if r = TIME_ZONE_ID_UNKNOWN	then Result := Time
    else Result := Time-((TZ_INFO.Bias+60)/1440);
end;

(****************************************************************)
function Now2DateTime : TDateTime;
var Time : TDateTime;
    TimeStamp : TTimeStamp;
    year,month,day,hour,min,secs,msecs : word;
begin
    DecodeDate(Now, Year, Month, Day);
    DecodeTime(Now,Hour,Min,Secs,Msecs);
    TimeStamp := DateTimeToTimeStamp(EncodeDate(year,month,day)+EncodeTime(hour,min,0,0));
    Time := TimeStampToDateTime(TimeStamp);
    Result := Time;
end;

function SecsSince1970:longint;
var s1970, sNow : TTimeStamp;
begin
     s1970 := DateTimeToTimeStamp(EncodeDate(1970,1,1));
     sNow := DateTimeToTimeStamp(Now);
     SecsSince1970 := Floor(TimeStampToMSecs(sNow)/1000 - TimeStampToMSecs(s1970)/1000);
end;

function s(i : longint) : string;
begin Result := inttostr(i); end;

procedure M(Memo:TMemo; s:string);
begin Memo.Lines.Add(s); end;

function Get_my_IP: string;
var wVersionRequested : WORD;
    wsaData : TWSAData;
    p : PHostEnt;
    s : array[0..128] of char;
    p2 : pchar;
begin
     Result := '127.0.0.1';
     try {Start up WinSock}
      wVersionRequested := MAKEWORD(1, 1);
      WSAStartup(wVersionRequested, wsaData);
      try {Get the computer name}
        GetHostName(@s, 128);
        p := GetHostByName(@s);
        {Get the IpAddress}
        p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
        Result := p2;
      except end;
      try {Shut down WinSock} WSACleanup; except end;
     except end;
     OL := Result <> '127.0.0.1';
end;

(****************************************************************)
function Calc_Pass(PassIN : string):string;
const pass_tab : array[1..16] of byte =
      ($F3,$26,$81,$C4,$39,$86,$DB,$92,
       $71,$A3,$B9,$E6,$53,$7A,$95,$7C);
var i : integer;
begin
     Result := '';
     for i:=1 to length(PassIN) do
       Result := Result+char(byte(PassIN[i]) xor pass_tab[i]);
end;

end.