// 이전에 했던 무식한 반복루프에 의한 것이 아닌

// 메시지 패킷으로 주고 받기를 시도합니다....

// SendData라 평션에서 메모리 스트림을 생성하지만

// 파괴시키지는 않았습니다.

// 이유는 sendStream후 free할려고 하면 에러가 자꾸 발생해서

// 그냥 나둬 버렸습니다....

// 고수님들의 고견 기다립니다....

unit uXSocket;



interface



uses

windows, messages, sysutils, classes, scktcomp, Dialogs, stdctrls, controls;



const

mtText = $FF00000000000000; // 텍스트

ctText = 'FF00000000000000';



mtData = $FF00000000000001; // 데이타

ctData = 'FF00000000000001';



mtDataEnd = $FF00000000000002; // 데이타 종료시...

ctDataEnd = 'FF00000000000002';



mtTransNM = $FF00000000000003; // 전송시파일명

ctTransNM = 'FF00000000000003'; // 전송시파일명



mtACK0 = $FF00000000000004; // 전송할 수 있는 상태

ctACK0 = 'FF00000000000004'; //



mtACK1 = $FF00000000000005; // 전송시 응답여부1

ctACK1 = 'FF00000000000005'; //



mtACK2 = $FF00000000000006; // 전송시 응답여부2

ctACK2 = 'FF00000000000006'; //



mtFILE = $FF00000000000007; // 파일보내도 되겄냐...

ctFILE = 'FF00000000000007'; //



mtLens = 1024;



type

Pekit = record

msgtp : String[16];

postion : Integer;

buffsize: integer;

dat: array[0..mtLens-1] of char;

end;



Function FrontToBack(vValue: String): String;

Function RPos(Const vSubStr: String; Const vValue: String): Integer;

Function GetMemoLine(memo:TCustomMemo): Integer;

Function GetMemoCol(memo:TCustomMemo): Integer;

Function Memo2Str(sList: TCustomMemo; itemi: Integer): String;

Procedure AddStr(var Vvalue: String; vStr:Array of String);

Function Strings2Str(sList: TStrings; itemi: Integer): String;

function Int2Hex(nFmt: Integer): String;

Function Int642Hex(nFmt: Int64): String;



//=-=-=-=-==-=-=-=-=-=-==-=-=-=-=-=-==-=-=-=-=-=-==-=-=-=-=-=-==-=-=-=-=-=-==-=-

// 소켓관련 파일 송수신 루틴 및 텍스트 자료 전송....

//=-=-=-=-==-=-=-=-=-=-==-=-=-=-=-=-==-=-=-=-=-=-==-=-=-=-=-=-==-=-=-=-=-=-==-=-

Function SendData(clSocket: TCustomWinSocket; theData: String; nFmt: int64=mtText): Boolean; overload;

Function SendData(clSocket: TCustomWinSocket; theData: pChar; nFmt: int64): Integer; overload;

Procedure SendString(clSocket: TCustomWinSocket; theData: String; nFmt: int64);

Procedure SocketReceive(clSocket: TCustomWinSocket; ssdata : Pekit);

Procedure SocketSend(clSocket: TCustomWinSocket; ssdata : Pekit; sPathFile: String);



var

defaultDownFolder: String;

DownLoadFile: Integer;

old_pekit: pekit;



implementation



Function FrontToBack(vValue: String): String;

var

iz, mLen: Integer;

Begin

mLen := Length(vValue);

SetLength(Result, mLen);

For iz := mLen downto 1 do Result[iz] := vValue[mLen+1-iz];

End;



Function RPos(Const vSubStr: String; Const vValue: String): Integer;

Begin

Result := pos(vSubStr, FrontToBack(vValue));

if Result > 0 Then Result := Length(vValue)+1-Result;

End;



Function GetMemoLine(memo:TCustomMemo): Integer;

var

LineNum:LongInt;

begin

LineNum:=SendMessage(Memo.Handle, EM_LINEFROMCHAR, Memo.SelStart, 0);

Result := LineNum+1;

end;



Function GetMemoCol(memo:TCustomMemo): Integer;

var

LineNum, CharseBeforeLine:LongInt;

begin

LineNum:=SendMessage(Memo.Handle, EM_LINEFROMCHAR, Memo.SelStart, 0);

CharseBeforeLine := SendMessage(Memo.Handle, EM_LINEINDEX, LineNum, 0);

Result := Memo.SelStart - CharseBeforeLine + 1;

end;





Function Int2Hex(nFmt: Integer): String;

var

z: Integer;

u, uh, ul: Byte;

Begin

result := '';

for z := 3 downto 0 do Begin

u := (nFmt shr (z * 8)) and $FF;

uh := (u shr 4) and $F;

ul := u and $F;

if uh >= 10 Then result := Result + Chr(Byte('A')+uh-10)

else result := Result + Chr(Byte('0')+uh);

if ul >= 10 Then result := Result + Chr(Byte('A')+ul-10)

else result := Result + Chr(Byte('0')+ul);

End;

End;



Function Int642Hex(nFmt: Int64): String;

var

z: Integer;

u, uh, ul: Byte;

Begin

result := '';

for z := 7 downto 0 do Begin

u := (nFmt shr (z * 8)) and $FF;

uh := (u shr 4) and $F;

ul := u and $F;

if uh >= 10 Then result := Result + Chr(Byte('A')+uh-10)

else result := Result + Chr(Byte('0')+uh);

if ul >= 10 Then result := Result + Chr(Byte('A')+ul-10)

else result := Result + Chr(Byte('0')+ul);

End;

End;



Procedure AddStr(var Vvalue: String; vStr:Array of String);

var

i : Integer;

Begin

For i := Low(vStr) to High(vStr) do Vvalue := VValue + vStr[i];

End;



Function Strings2Str(sList: TStrings; itemi: Integer): String;

var

iz: Integer;

Begin

for iz := itemi to sList.Count-1 do AddStr(Result, [sList.Strings[iz]]);

End;



Function Memo2Str(sList: TCustomMemo; itemi: Integer): String;

var

iz, iu: Integer;

Begin

iu := 0;

if itemi < 0 Then iu := GetMemoLine(sList)

else if itemi >= 0 Then iu := itemi;

for iz := iu to sList.Lines.Count-1 do AddStr(Result, [sList.Lines.Strings[iz]]);

End;



Function SendData(clSocket: TCustomWinSocket; theData: String; nFmt: int64): Boolean;

var

lvs : TMemoryStream;

p : Pekit;

Begin

lvs := TMemoryStream.Create;

Zeromemory(@p,sizeof(pekit));

p.msgtp := int642Hex(nFmt);

p.buffsize := Length(theData);

strpcopy(@p.dat, theData);

lvs.Write(p, sizeof(p));

lvs.Position := 0;

Result := clSocket.Sendstream(lvs);

// 작업이 끝나면 자동으로 Free되는 것 같음....

// 그래서 Free를 안했는데 Free하면 에러발생

// 이루틴으로 인하여 전송중에 에러 발생....

end;



Function SendData(clSocket: TCustomWinSocket; theData: PChar; nFmt: int64): Integer;

var

p : Pekit;

Begin

Zeromemory(@p,sizeof(pekit));

p.msgtp := int642Hex(nFmt);

p.buffsize := StrLen(theData);

strpcopy(p.dat, theData);

Result := clSocket.SendBuf(p, sizeof(Pekit));

end;



Procedure SendString(clSocket: TCustomWinSocket; theData: String; nFmt: int64);

var

px : String;

Begin

px := int642Hex(nFmt) + theData;

clSocket.SendText(px)

end;



////////////////////////////////////////////////////////////////////////////////

// 파일을 받는 쪽에서 보내는 쪽으로의 메세지 송출

Procedure SocketReceive(clSocket: TCustomWinSocket; ssdata : Pekit);

var

pathandFile: String;

Begin

// 파일보낸다라고 보냈을때 그럼 보내라는 패킷을 날린다....

if ssdata.msgtp = ctFILE Then Begin

SendData(clSocket, ssdata.dat, mtACK0);

Exit;

End;

// 파일명을 보냈다라고 했을때 조치후 잘받았다라는 패킷을 날린다....

if ssdata.msgtp = ctTransNM Then Begin

pathandFile := (*defaultDownFolder +*) strpas(ssdata.dat);

DownLoadFile := FileCreate(pathandFile);

if DownLoadFile = -1 Then Exit;

FileSeek(DownLoadFile, 0, 0);

SendData(clSocket, ssdata.dat, mtACK1);

end

else if ssdata.msgtp = ctData Then Begin // 데이타를 보냈으니 조치후 잘받았다를 보낸다....

if DownLoadFile = -1 Then Exit;

FileWrite(DownLoadFile, ssdata.dat, ssdata.buffsize);

SendData(clSocket, ssdata.dat, mtACK1);

End

else if ssdata.msgtp = ctDataEnd Then Begin // 데이타의 마지막부분을 받았을 경우는 조치후

if DownLoadFile = -1 Then Exit; // 파일송수신은 끝이다라 메시지를 보낸다....

FileWrite(DownLoadFile, ssdata.dat, ssdata.buffsize);

FileClose(DownLoadFile);

SendData(clSocket, ssdata.dat, mtACK2);

End;

End;



////////////////////////////////////////////////////////////////////////////////

// 파일보내는 쪽에서 받는 쪽으로의 송출

Procedure SocketSend(clSocket: TCustomWinSocket; ssdata : Pekit; sPathFile: String);

var

nread: Integer;

Begin

// 파일명을 보내라는 메세지가 날라왔을때.....

// 파일명을 보낸다....

if ssdata.msgtp = ctACK0 Then Begin // 파일 받기 준비완료...

DownLoadFile := FileOpen(sPathFile, fmOpenread or fmShareDenyNone);

if DownLoadFile = -1 Then Exit;

FileSeek(DownLoadFile, 0, 0);

SendData(clSocket, sPathFile, mtTransNM);

End else if ssdata.msgtp = ctACK1 Then Begin // 파일명을 받아서 초기확 완료되었으니 데이타좀 보내줘라는

if DownLoadFile = -1 Then Exit; // 메시지가 왔을때 데이터를 보낸다....

nread := FileRead(DownLoadFile, ssdata.dat, sizeof(ssdata.dat));

if nread < mtLens Then SendData(clSocket, @ssdata.dat, mtDataEnd)

else SendData(clSocket, @ssdata.dat, mtData);

end else if ssdata.msgtp = ctACK2 Then Begin // 데이타를 다받았으니 종료해도 되라는 메시지를 받았을때....

if DownLoadFile = -1 Then Exit;

FileClose(DownLoadFile);

End;

//ZeroMemory(@old_pekit, sizeof(pekit));

//old_pekit.msgtp := ssdata.msgtp;

//old_pekit.buffsize := ssdata.buffsize;

End;



initialization

defaultDownFolder := 'C:';

finalization

end.





// 질문입니다요....

// 파일 전송에 관련된 API를 이 싸이트의 여러질문과 답변을 근거로

// 한번 만들어봤습니다요...

// 파일 송수신을 하기 위해서 F12키를 누르면

// 그때부터 패킷에 의한 동작을 수행하는데 수행중 메모리 오류가 발생합니다...

// 관련하여 소스를 첨언드립니다....

// 단축키 부분

// 아래에 계속 이어집니다.....

procedure TChatForm.Memo1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if Key = VK_F11 Then begin

if IsServer Then

SendData(ServerSocket.Socket.Connections[0], Strings2Str(Memo1.Lines, -1))

else

SendData(ClientSocket.Socket, Strings2Str(Memo1.Lines, -1));

end

else if Key = VK_F12 Then Begin

if IsServer Then begin

Senddata(ServerSocket.Socket.Connections[0], 'c:cismainmenu.exe', mtFile);

End

else Begin

Senddata(ClientSocket.Socket, 'c:cismainmenu.exe', mtFile);

End;

End;

end;



// 메시지를 받는 부분의 이벤트 동작

procedure TChatForm.ClientSocketRead(Sender: TObject;

Socket: TCustomWinSocket);

var

ssdata:Pekit;

begin

socket.ReceiveBuf(ssdata, sizeof(ssdata));

if ssdata.msgtp = ctText Then Begin

Memo2.Lines.Add(strpas(ssdata.dat));

End

else if (ssdata.msgtp = ctData) or (ssdata.msgtp = ctDataEnd)

or (ssdata.msgtp = ctTransNm) Then Begin

SocketReceive(Socket, ssdata);

End

else if (ssdata.msgtp = ctACK0) or (ssdata.msgtp = ctACK1)

or (ssdata.msgtp = ctACK2) Then Begin

socketSend(Socket, ssdata, 'c:cismainmenu.exe');

end;

end;



// 메시지를 받는 부분의 이벤트 동작

procedure TChatForm.ServerSocketClientRead(Sender: TObject;

Socket: TCustomWinSocket);

var

ssdata:Pekit;

begin

socket.ReceiveBuf(ssdata, sizeof(ssdata));

if ssdata.msgtp = ctText Then Begin

Memo2.Lines.Add(strpas(ssdata.dat));

End

else if (ssdata.msgtp = ctFILE) or (ssdata.msgtp = ctData) or (ssdata.msgtp = ctDataEnd)

or (ssdata.msgtp = ctTransNm) Then Begin

SocketReceive(Socket, ssdata);

End

else if (ssdata.msgtp = ctACK0) or (ssdata.msgtp = ctACK1)

or (ssdata.msgtp = ctACK2) Then Begin

socketSend(Socket, ssdata, 'c:cismainmenu.exe');

end;

end;