Packet.pas

Previous  Top  Next

    
 

 

 

Code:

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Author:       Alexander Vaga

EMail:        alexander_vaga@hotmail.com

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;

 

const OL : booLean = false;

 

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;

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 Get_my_IP: string;

function Calc_Pass(PassIN : string):string;

function s(i : longint) : string;

procedure M(Memo:TMemo; s: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

     Result := p;

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 // xxxx 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))); // 00 4D 00 xx

    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;

 

(****************************************************************)

procedure StrToIP(sIP:string; var aIP:IParray);

var sTemp : string;

   aPos,bPos,cPos : integer;

begin

    longint(aIP) := 0if 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 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;

 

function s(i : longint) : string;

begin

    Result := inttostr(i);

end;

 

procedure M(Memo:TMemo; s:string);

begin

    Memo.Lines.Add(s);

end;

 

end.