program d2s;
{$D DDE<->TCP-Socket-Umsetzer h#s 05/04}
{$F-,A+,G+,K+,W-}
{$I-,Q-,R-,S-}
{$V+,B-,X+,T+,P+}
{$N-}
{$IFDEF Win32}
{$R d2s32}
uses Windows,Messages,Ddeml,ShellApi,WinSock,CommDlg, WUtils32;
type
TChar=Char;
{ UInt=Word;}
{$ELSE}
{$R d2s}
{$M $3000,$1000}
uses WinProcs,WinTypes,Win31,Ddeml,ShellApi,CommDlg, WinSock,WUtils,Tray16;
type
TChar=Char;
{ UInt=Word;}
{$ENDIF}
const
AppName: array[0..3] of TChar='D2S';
HelpFileName: array[0..7] of TChar='D2S.HLP';
FLASH=200; {ms Aufblitzen aktive Verbindung}
{************* Hauptprogramm *************************}
const
WM_IconChange=WM_User+1;
WM_ContinueInit=WM_User+2;
WM_Accept=WM_User+15;
WM_Recv=WM_User+16;
WM_Tray=WM_USER+17;
type
EStatistik=(E_CLIENT,E_SERVER,E_REQUEST,E_POKE,E_EXEC,E_ADVISE,E_ERROR);
SStatistik=set of EStatistik;
PStatistik=^TStatistik;
TStatistik=record
case integer of
0: (clients,servers,requests,pokes,execs,advises,errors: UInt);
1: (all: array[EStatistik] of UInt);
end;
var
Inst: LongInt; {Instanz-Variable ("Handle"), GLOBAL}
AppTitle: TS31; {='DDE<->Socket'}
MainWnd: HWnd;
Listbox: HWnd;
SetupDlg: HWnd; {dieser ist nicht-modal...}
KBHand: HWnd;
d2s_port: UInt;
Icons: array[0..3] of HIcon; {4 Icons für ruhend, verbunden, Fehler, OK}
CurIcon: Integer;
Statistik: record {Zugriffszähler}
ddeserv,tcpserv:TStatistik;
end;
Auswahl: Integer;
const
AcceptSock: TSocket=INVALID_SOCKET; {Für eingehende Verbindungen}
{************* Unterprogramme *************************}
procedure ChangeDdeIcon(NewIcon:Integer);
var
Msg:TMsg;
begin
if NewIcon>=2 then begin
SetTimer(MainWnd,102,FLASH,nil); {Timer neu starten}
end;
if CurIcon=NewIcon then exit;
CurIcon:=NewIcon;
PeekMessage(Msg,MainWnd,WM_IconChange,WM_IconChange,PM_Remove);
PostMessage(MainWnd,WM_IconChange,NewIcon,0);
end;
procedure ChangeDdeDisplay;
var
vsrec:record
s: PChar;
i: UInt;
end;
s: TS31;
begin
vsrec.s:=AppTitle;
vsrec.i:=Statistik.ddeserv.clients+Statistik.tcpserv.clients;
wvsprintf(s,'%s [%u]',vsrec);
SetWindowText(MainWnd,s);
if vsrec.i<>0 then begin
if CurIcon=0 then ChangeDdeIcon(1); {Nur wenn nicht schon aktiv}
end else begin
ChangeDdeIcon(0);
end;
end;
procedure IncStatistik(was:PUInt; um:Integer);
var
Stat,tcpStat: UInt;
PStat: PUint;
e: EStatistik;
match,tcpmatch: Boolean;
begin
if was<>nil then begin
if um=0 then exit;
Inc(was^,um);
{Ab jetzt so selten wie möglich SetDlgItemInt rufen}
if (was=@Statistik.ddeserv.clients)
or (was=@Statistik.tcpserv.clients)
then ChangeDdeDisplay;
end;
if Auswahl=-1 then exit; {Hauptfenster unsichtbar}
for e:=LOW(e) to HIGH(e) do begin
PStat:=@Statistik.ddeserv.all[e];
Stat:=PStat^;
match:=was=PStat;
PStat:=@Statistik.tcpserv.all[e];
tcpStat:=PStat^;
tcpmatch:=was=PStat;
case Auswahl of
0: begin Inc(Stat,tcpStat); match:=match or tcpmatch; end; {Addieren}
2: begin Stat:=tcpStat; match:=tcpmatch; end; {Ersetzen}
end;
if (was=nil) or match then SetDlgItemInt(MainWnd,102+UInt(e),Stat,false);
end;
end;
procedure AddError(nr: Integer; src:PChar);
var
s: TS255;
i,j: Integer;
begin
i:=LoadString({$IFNDEF Win32}Seg{$ENDIF}(HInstance),nr,s,sizeof(s));
if src<>nil then begin
lstrcpy(s+i,' (');
Inc(i,2);
Inc(i,EscapeStr(src,lstrlen(src),s+i,sizeof(s)-i-1));
lstrcpy(s+i,')');
end;
i:=SendMessageP(Listbox,LB_AddString,0,@s);
j:=SendMessage(Listbox,LB_GetCurSel,0,0);
{Automatisch rollen solange Anwender nicht darin schmökert}
if j=i-1 then SendMessage(Listbox,LB_SetCurSel,i,0);
if i>1000 then begin
SendMessage(Listbox,LB_DeleteString,0,0); {ältesten Fehler löschen}
if j=0 then SendMessage(Listbox,LB_SetCurSel,0,0);
end;
end;
procedure DdeError(Code:Integer);
var
s:TS15;
begin
wvsprintf(s,'%d',Code);
AddError(102,s);
end;
procedure SockError(Code:Integer);
var
vsrec:record
i:Integer;
p:PChar;
end;
s:TS63;
begin
LoadString({$IFNDEF Win32}Seg{$ENDIF}(HInstance),Code,s,HIGH(s)+1);
vsrec.i:=Code;
vsrec.p:=s;
vMBox(MainWnd,103,MB_OK or MB_IconExclamation,vsrec);
end;
function CreateStringHandle(Str:PChar):Hsz;
var Stringhandle: Hsz;
begin
Stringhandle:=DdeCreateStringHandle(Inst,Str,CP_WinAnsi);
CreateStringHandle:=StringHandle;
if StringHandle=0 then DdeError(2);
end;
procedure FreeStringHandle(Stringhandle:Hsz);
begin
if Stringhandle<>0 then
DdeFreeStringHandle(Inst,StringHandle);
end;
type
PArgv=^TArgv;
TArgv=array[0..10000] of PChar;
function split(s:PChar; d: Char; argc:PInteger):PArgv;
var
s0: PChar;
argv: PArgv;
i: Integer;
begin
{ 1. count colums }
s0:=s;
i:=1;
while s0^<>#0 do begin
if s0^=d then Inc(i);
s0:=AnsiNext(s0);
end;
if argc<>nil then argc^:=i;
{ 2. allocate memory }
{$IFDEF Win32}
argv:=PArgv(LocalAlloc(LPTR,(i+1)*sizeof(PPChar)));
{$ELSE}
argv:=Ptr(Seg(HInstance),LocalAlloc(LPTR,(i+1)*sizeof(PPChar)));
{$ENDIF}
split:=argv;
{ 3. fill argv and split s }
i:=0;
repeat
argv^[i]:=s;
while (s^<>d) do begin
if s^=#0 then exit;
s:=AnsiNext(s)
end;
s0:=AnsiNext(s);
s^:=#0;
s:=s0;
Inc(i)
until false;
end;
function SetAcceptPort(port:Word):Boolean;
label ok;
var
sa: TSockAddrIn;
begin
SetAcceptPort:=false;
if d2s_port=port then goto ok;
{neues Port, also neuer Accept-Socket}
if AcceptSock<>INVALID_SOCKET then begin
CloseSocket(AcceptSock);
end;
AcceptSock:=Socket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
if AcceptSock=INVALID_SOCKET then exit; {kein Socket frei!}
FillChar(sa,sizeof(sa),0);
sa.sin_family:=PF_INET;
sa.sin_port:=htons(port);
if bind(AcceptSock,sa,sizeof(sa))<>0 then exit;
listen(AcceptSock,5);
if WSAAsyncSelect(AcceptSock,MainWnd,WM_Accept,FD_Accept)<>0 then exit;
d2s_port:=port;
ok:
SetAcceptPort:=true;
end;
type
{ PIpRange=^TIpRange;}
TIpRange=record
a,e:DWord;
end;
var
IniFileName: TS255;
LogNum: UInt;
maxline: UInt;
ranges: array[0..9] of TIpRange;
DefDelim: array[0..9] of TChar;
procedure S2Range(var r:TIpRange; s:PChar);
var
hack: PChar;
he: PHostEnt;
begin
hack:=lstrchr(s,'-');
if hack<>nil then begin
hack^:=#0;
end;
r.a:=ntohl(inet_addr(s));
r.e:=r.a;
if r.a=DWord(INADDR_NONE) then begin
if hack<>nil then hack^:='-'; {mit Namen probieren}
he:=PHostEnt(GetHostByName(s));
if he=nil then exit;
r.a:=ntohl(PDWord(he^.h_addr_list^)^);
r.e:=r.a;
exit;
end;
if hack=nil then exit;
r.e:=ntohl(inet_addr(hack+1));
hack^:='-';
end;
{$IFDEF Win32}
function ValidRange(const r:TIpRange):Boolean;
begin
ValidRange:=(Cardinal(r.a)<=Cardinal(r.e)) and (r.e<>INADDR_None);
end;
{$ELSE}
function ValidRange(const r:TIpRange):Boolean; assembler;
asm {da fehlen die vorzeichenlosen LongInts}
les di,[r]
db $66
mov ax,LongRec(es:TIpRange[di].a).lo
db $66
mov dx,LongRec(es:TIpRange[di].e).lo
db $66
cmp dx,ax
jc @@err
db $66
inc dx
mov al,TRUE
jnz @@ok
@@err: mov al,FALSE
@@ok:
end;
{$ENDIF}
procedure Range2S(const r:TIpRange; s:PChar);
{Umwandlung in String, s muss 32 Zeichen Platz bieten!}
begin
lstrcpy(s,inet_ntoa({$IFDEF Win32}TInAddr{$ENDIF}(htonl(r.a))));
if r.e=r.a then exit;
lstrcat(s,'-');
lstrcat(s,inet_ntoa({$IFDEF Win32}TInAddr{$ENDIF}(htonl(r.e))));
end;
const
stMain: array[0..4] of TChar='Main';
stWinPos: array[0..7] of TChar='WinPos';
stMaxLine: array[0..8] of TChar='MaxLine';
stDefDelim: array[0..9] of TChar='DefDelim';
stPort: array[0..4] of TChar='Port';
stAcceptList: array[0..10]of TChar='AcceptList';
stLog: array[0..3] of TChar='Log';
stAutostart: array[0..9] of TChar='Autostart';
procedure LoadConfig;
var
i:Integer;
key:TS7;
buf:TS255;
begin
maxline:=GetPrivateProfileInt(stMain,stMaxLine,4096,IniFileName);
GetPrivateProfileString(stMain,stDefDelim,':',
DefDelim,HIGH(DefDelim)+1,IniFileName);
SetAcceptPort(GetPrivateProfileInt(stMain,stPort,2000,IniFileName));
for i:=0 to HIGH(ranges) do begin
{$IFDEF Win32}wsprintf1(key,'%d',PChar(i)){$ELSE}wvsprintf(key,'%d',i){$ENDIF};
if (GetPrivateProfileString(stAcceptList,key,'',buf,HIGH(buf)+1,
IniFileName)<>0) then S2Range(ranges[i],buf)
else ranges[i].a:=DWord(-1);
end;
end;
function strtol(s:PChar;se:PPChar):Integer;
label ende;
var
r,e:Integer;
c: Char;
sp: PChar;
begin
Val(s,r,e); {1. Versuch}
if e=0 then begin sp:=s+lstrlen(s); goto ende; end;
sp:=s+e-1;
c:=sp^; sp^:=#0;
Val(s,r,e); {2. Versuch}
sp^:=c;
ende:
if se<>nil then se^:=sp;
strtol:=r;
end;
procedure LoadWinPos;
var
wp:TWindowPlacement;
sp: PChar;
buf:TS63;
begin
if GetPrivateProfileString(stMain,stWinPos,'',buf,HIGH(buf)+1,IniFileName)
=0 then exit;
wp.length:=sizeof(wp);
GetWindowPlacement(MainWnd,@wp);
with wp.rcNormalPosition do begin
left :=strtol(buf,@sp);
top :=strtol(sp+1,@sp);
right :=strtol(sp+1,@sp);
bottom:=strtol(sp+1,@sp);
end;
SortRect(wp.rcNormalPosition);
if IsRectEmpty(wp.rcNormalPosition) then exit;
MoveRectIntoFullScreen(wp.rcNormalPosition);
wp.showCmd:=SW_Hide;
if (CmdShow in [SW_ShowNormal,SW_ShowNA,SW_Restore])
and (lstrcmpi(CmdLine,'/hidden')<>0) {Hintertür für Windows 3.x}
then wp.showCmd:=SW_ShowMinNoActive;
SetWindowPlacement(MainWnd,@wp);
end;
procedure SaveConfig;
var
i:Integer;
key:TS7;
buf:TS255;
begin
wvsprintf(buf,'%u',maxline);
WritePrivateProfileString(stMain,stMaxLine,buf,IniFileName);
WritePrivateProfileString(stMain,stDefDelim,DefDelim,IniFileName);
wvsprintf(buf,'%u',d2s_port);
WritePrivateProfileString(stMain,stPort,buf,IniFileName);
for i:=0 to HIGH(ranges) do begin
{$IFDEF Win32}wsprintf1(key,'%d',PChar(i)){$ELSE}wvsprintf(key,'%d',i){$ENDIF};
if ValidRange(ranges[i]) then begin
Range2S(ranges[i],buf);
WritePrivateProfileString(stAcceptList,key,buf,IniFileName);
end else begin
WritePrivateProfileString(stAcceptList,key,nil,IniFileName);
end;
end;
end;
procedure SaveWinPos;
var
wp:TWindowPlacement;
buf:TS63;
begin
wp.length:=sizeof(wp);
GetWindowPlacement(MainWnd,@wp);
wvsprintf(buf,'%d %d %d %d',wp.rcNormalPosition);
WritePrivateProfileString(stMain,stWinPos,buf,IniFileName);
end;
procedure vLog(format:PChar; var args);
var
key:TS7;
val:TS255;
begin
if format<>nil then begin
wvsprintf(key,'%03u',LogNum);
wvsprintf(val,format,args);
AddError(101,val);
WritePrivateProfileString(stLog,key,val,IniFileName);
end else begin
LogNum:=0;
WritePrivateProfileString(stLog,nil,nil,IniFileName);
end;
end;
function CheckIP(addr:DWord):Boolean;
{Testet gegebene IP-Adresse auf Gültigkeit bzgl. der IP-Bereiche}
var
i: Integer;
begin
CheckIP:=true;
addr:=ntohl(addr);
if addr=$7F000001 then exit; {localhost 127.0.0.1}
{$IFDEF Win32}
for i:=0 to HIGH(ranges) do
if (Cardinal(ranges[i].a)<=Cardinal(addr))
and (Cardinal(addr)<=Cardinal(ranges[i].e)) then exit;
CheckIP:=false;
{$ELSE}
asm db $66
mov dx,LongRec[addr].lo
mov si,offset ranges
cld
mov cx,TYPE ranges / TYPE TIpRange
@@l: db $66
lodsw
db $66
cmp dx,ax
db $66
lodsw
jc @@n
db $66
cmp ax,dx
jnc @@e
@@n: loop @@l
dec [@Result] {FALSE nach allen Bereichen}
@@e:
end;
{$ENDIF}
end;
(*
procedure AboutBox;
begin
vMBox(MainWnd,100{about},MB_IconAsterisk,Statistik);
end;
*)
{*******************************************
** Hilfsroutinen für Einstellungs-Dialog **
*******************************************}
procedure LoadAutostartListbox(w:HWnd);
{Autostart-Listbox direkt von INI-Datei laden (keine Speicher-Kopie)
w=Listbox-Handle}
const
TabStop:Integer=40; {besser automatisch berechnen!}
var
sp:PChar;
buf1,buf2: TS255;
i: Integer;
begin
GetPrivateProfileString(stAutostart,nil,'',buf1,HIGH(buf1)+1,IniFileName);
sp:=buf1;
SendMessageP(W,LB_SetTabStops,1,@TabStop);
repeat
i:=lstrlen(sp);
if i=0 then exit;
lstrcpy(buf2,sp);
buf2[i]:=#9;
Inc(i);
GetPrivateProfileString(stAutostart,sp,'',buf2+i,HIGH(buf2)+1-i,
IniFileName);
SendMessageP(W,LB_AddString,0,@buf2);
Inc(sp,i);
until false;
end;
procedure SaveAutostartListbox(w:HWnd);
{w=Listbox-Handle}
var
cnt,i: Integer;
sp2: PChar;
buf: TS255;
begin
cnt:=SendMessage(w,LB_GetCount,0,0);
WritePrivateProfileString(stAutostart,nil,nil,IniFileName);
for i:=0 to cnt-1 do begin
SendMessageP(W,LB_GetText,i,@buf);
sp2:=lstrchr(buf,#9);
if sp2=nil then continue;
sp2^:=#0; {zerhacken}
WritePrivateProfileString(stAutostart,buf,sp2+1,IniFileName);
end;
end;
function BrowseExecutable:Boolean;
{Ausführbares Programm (oder verknüpftes Dokument) auswählen
SetupDlg=Dialogfenster-Handle}
var
ofn:TOpenFileName;
sp: PChar;
fname,filter,initdir:TS255;
title:TS63;
begin
BrowseExecutable:=false;
GetDlgItemText(SetupDlg,111,fname,HIGH(fname)+1);
LoadString({$IFNDEF Win32}Seg{$ENDIF}(HInstance),111,filter,HIGH(filter)+1);
LoadString({$IFNDEF Win32}Seg{$ENDIF}(HInstance),112,title,HIGH(title)+1);
InitStruct(ofn,sizeof(ofn));
ofn.hwndOwner:=SetupDlg;
ofn.lpstrFile:=fname;
UInt(ofn.nMaxFile):=HIGH(fname)+1;
sp:=GetFileNamePtr(fname);
if sp<>fname then begin
lstrcpyn(initdir,fname,sp-fname);
ofn.lpstrInitialDir:=initdir;
lstrcpy(fname,sp);
end;
ofn.lpstrFilter:=filter;
ofn.lpstrTitle:=title;
UInt(ofn.flags):=OFN_FileMustExist or OFN_ShowHelp or OFN_HideReadOnly;
{hier: erst mal keine langen Dateinamen!}
if not GetOpenFileName(ofn) then exit;
SetDlgItemText(SetupDlg,111,fname);
BrowseExecutable:=true;
end;
var
Button3State: Integer; {0=?, 1=Add, 2=Change, 3=Delete}
procedure SetButton3State(st:Integer);
{Beschriftung des Buttons sowie globale Merkvariable setzen}
var
sp:PChar;
buf:TS63;
begin
if Button3State=st then exit;
Button3State:=st;
LoadString({$IFNDEF Win32}Seg{$ENDIF}(HInstance),114,buf,HIGH(buf)+1);
sp:=buf;
while st<>0 do begin
Inc(sp,lstrlen(sp)+1);
Dec(st);
end;
SetDlgItemText(SetupDlg,114,sp);
EnableDlgItem(SetupDlg,114,Bool(Button3State));
end;
procedure TextChanged;
{Immer wenn sich Text unter "Service" oder "Kommandozeile" ändert,
muss der veränderliche Button ggf. umbeschriftet werden}
var
i: Integer;
buf:TS63;
begin
if (GetDlgItemText(SetupDlg,111,buf,HIGH(buf))=0)
or (GetDlgItemText(SetupDlg,110,buf,HIGH(buf))=0)
then SetButton3State(0)
else begin {in "buf" ist der Service-Name}
lstrcat(buf,#9);
i:=SendDlgItemMsgP(SetupDlg,113,LB_FindString,UInt(-1),@buf);
SetButton3State(IfThenElse(Bool(i-LB_ERR),2,1)); {auf "Ändern"}
SendDlgItemMessage(SetupDlg,113,LB_SetCurSel,UInt(i),0);
end;
end;
procedure ListSelection;
{Immer wenn ein Autostart-Listen-Element ausgewählt wird,
werden die Edit-Felder aktualisiert und der Knopf auf "Löschen" gestellt}
var
i: Integer;
sp:PChar;
buf:TS255;
begin
i:=SendDlgItemMessage(SetupDlg,113,LB_GetCurSel,0,0);
if i<0 then exit;
SendDlgItemMsgP(SetupDlg,113,LB_GetText,i,@buf);
sp:=lstrchr(buf,#9);
if sp=nil then exit;
sp^:=#0;
SetDlgItemText(SetupDlg,110,buf);
SetDlgItemText(SetupDlg,111,sp+1);
SetButton3State(3); {auf Löschen}
end;
procedure HandleButton3State;
{Je nach Beschriftung des Buttons Aktion ausführen}
var
i,j: Integer;
lb:HWnd;
buf:TS255;
begin
i:=GetDlgItemText(SetupDlg,110,buf,HIGH(buf));
lstrcpy(buf+i,#9);
GetDlgItemText(SetupDlg,111,buf+i+1,HIGH(buf)-i);
lb:=GetDlgItem(SetupDlg,113);
j:=SendMessage(lb,LB_GetCurSel,0,0);
if Button3State>=2
then SendMessage(lb,LB_DeleteString,j,0);
case Button3State of
1: SendMessageP(lb,LB_AddString,0,@buf);
2: SendMessageP(lb,LB_InsertString,j,@buf);
end;
SetButton3State(0); {inaktiv}
end;
{***********************************************
** Einstellungs-Dialog-Prozedur (nichtmodal) **
***********************************************}
function SetupDlgProc(Wnd:HWnd; Msg,wParam:UInt; lParam:LongInt):Bool;
{$IFDEF Win32}stdcall{$ELSE}export{$ENDIF};
label Ende;
var
lPar: LongRec absolute lParam;
CommandID: Word absolute wParam;
CommandNFY: LongRec absolute {$IFDEF Win32}wParam{$ELSE}lParam{$ENDIF};
w: HWnd;
x: UInt;
i: Integer;
r: TIpRange;
s: TS31;
begin
SetupDlgProc:=false;
case Msg of
WM_InitDialog: begin
SetupDlg:=Wnd;
Button3State:=-1;
SetButton3State(0);
SetDlgItemInt(Wnd,101,d2s_port,false);
SetDlgItemInt(Wnd,102,maxline,false);
w:=GetDlgItem(Wnd,105);
for i:=0 to HIGH(ranges) do begin
if ValidRange(ranges[i]) then begin
Range2s(ranges[i],s);
SendMessageP(w,LB_AddString,0,@s);
end;
end;
SetDlgItemText(Wnd,107,DefDelim);
LoadAutostartListbox(GetDlgItem(Wnd,113));
SetupDlgProc:=true;
end;
WM_Activate: KBHand:=IfThenElse(Bool(wParam),Wnd,0);
WM_Command: case CommandID of
1,10: begin {OK, Übernehmen}
x:=GetDlgItemInt(Wnd,102,nil,false);
if (x<256) or (x>$4000) then begin
MBox0(Wnd,101,MB_OK);
SetEditFocus(GetDlgItem(Wnd,101));
exit;
end;
if not SetAcceptPort(GetDlgItemInt(Wnd,101,nil,false)) then begin
MBox0(Wnd,101,MB_OK);
SetEditFocus(GetDlgItem(Wnd,101));
exit;
end;
maxline:=x;
w:=GetDlgItem(Wnd,105);
for i:=0 to HIGH(ranges) do begin
if SendMessageP(w,LB_GetText,i,@s)=LB_ERR then break;
S2Range(ranges[i],s);
end;
GetDlgItemText(Wnd,107,DefDelim,HIGH(DefDelim)+1);
SaveAutostartListbox(GetDlgItem(Wnd,113));
SaveConfig;
if CommandID=1 then goto Ende;
end;
2: Ende: begin SetupDlg:=0; DestroyWindow(Wnd); end;
9: WinHelp(Wnd,HelpFileName,HELP_Context,108);
103: case CommandNFY.hi of {Eingabezeile}
EN_Change: EnableDlgItem(Wnd,104,true);
end;
104: begin {Knopf "Hinzufügen"}
GetDlgItemText(Wnd,103,s,HIGH(s)+1);
S2Range(r,s);
if ValidRange(r) then begin
SendDlgItemMsgP(Wnd,105,LB_AddString,0,@s);
EnableWindow(HWnd(lParam),false);
end else begin
MBox0(Wnd,101,MB_OK);
SetEditFocus(GetDlgItem(Wnd,103));
end;
end;
105: case CommandNFY.hi of {Liste}
LBN_SelChange: begin
i:=SendMessage(HWnd(lParam),LB_GetCurSel,0,0);
EnableDlgItem(Wnd,106,i>=0);
if i>=0 then begin
SendMessageP(HWnd(lParam),LB_GetText,i,@s);
SetDlgItemText(Wnd,103,s); {zum Editieren heranholen}
EnableDlgItem(Wnd,104,false);
end;
end;
end;
106: begin {Knopf "Löschen"}
w:=GetDlgItem(Wnd,105);
i:=SendMessage(w,LB_GetCurSel,0,0);
SendMessage(w,LB_DeleteString,i,0);
SendMessage(w,LB_SetCurSel,i,0); {nächste Zeile markieren}
end;
110,111: if CommandNFY.hi=EN_Change then TextChanged;
112: BrowseExecutable;
113: case CommandNFY.hi of {Autostart-Liste}
LBN_SelChange: ListSelection;
end;
114: HandleButton3State;
end;
end;
end;
var
traydata: TNotifyIconData;
procedure ShellNotify;
begin
if not Shell_NotifyIcon(NIM_Modify,@traydata) then begin
traydata.uFlags:=NIF_Icon or NIF_Tip or NIF_Message;
Shell_NotifyIcon(NIM_Add,@traydata);
end;
end;
type
PPAsync=^PAsync;
PAsync=^TAsync;
TAsync=record
next:PAsync;
h: LongInt; {Async-Transaktions-Handle}
c: Char; {Melde-Zeichen für asynchrone Transaktion}
{ d: Boolean; {Daten-Flag (für DdeRequest)}
end;
PConvData=^TConvData;
TConvData=record
next,prev: PConvData; {Verkettete Liste, zurzeit NIL wenn DDE-Server}
sock: TSocket; {socket for writing notifications}
conv: HConv; {DDE conversation, immer lokal!}
hszService: HSZ; {DDE service string handle}
hszTopic: HSZ; {DDE topic string handle}
block: UInt; {blockierte DDE-Transaktionen (in DDEMLs Queue)}
advises: UInt; {Aktive ADVISEs in dieser Konversation}
delim: char;
ddeserver: Boolean; {TRUE wenn DDE-Server, FALSE wenn TCP-Server}
connected: Boolean; {TRUE wenn "c" von der Gegenseite kam}
result: hDdeData;
async: PAsync; {Verkettete Liste der o.a. Elemente}
end;
procedure New_Async(var cd:TConvData; ah:LongInt; ac: Char);
{Erzeugt ein neues Async-Verwaltungselement und hängt es in die Liste.}
var
async:PAsync;
begin
new(async);
with async^ do begin
next:=cd.async;
h:=ah;
c:=ac;
end;
cd.async:=async;
end;
function Get_Async(var cd:TConvData; ah:LongInt):PAsync;
{Findet und liefert ein Async-Element und hängt es aus der Liste aus.
Das Element muss mit dispose() freigegeben werden!}
var
pre_async:PPAsync; {Adresse des vorherigen (Next-)Zeigers}
async:PAsync; {Betrachtetes Element}
begin
pre_async:=@cd.async;
Get_Async:=nil;
repeat
async:=pre_async^;
if async=nil then exit;
with async^ do begin
if h=ah then begin
pre_async^:=next; {aus Liste aushängen}
next:=nil; {Verfolgung verhindern}
Get_Async:=async;
exit;
end;
pre_async:=@next;
end;
until false;
end;
procedure AsyncClientTransaction(var cd:TConvData;
Data: Pointer; DataLen: Integer;
Item: PChar; DataType: Word; ac:Char);
var
Result:DWord;
ItemHsz:HSZ;
begin
if DataLen=-1 then DataLen:=lstrlen(Data)+1; {ohne oder mit Null?}
ItemHsz:=0;
if Item<>nil then ItemHsz:=CreateStringHandle(Item);
{ if Data<>nil then Data:=Pointer(DdeCreateDataHandle(inst,Data,DataLen,
0,ItemHsz,CF_TEXT,HDATA_AppOwned));}
if DdeClientTransaction(Data,{-1{}DataLen,cd.conv,ItemHsz,CF_TEXT,
DataType,TIMEOUT_ASYNC,@Result)<>0 then begin;
New_Async(cd,Result,ac);
end;
FreeStringHandle(ItemHsz);
end;
function GetCD(Conv:HConv):PConvData;
{Holt ConvData von der Konversation}
var
ci: TConvInfo;
begin
DdeQueryConvInfo(Conv,QID_Sync,@ci);
GetCD:=PConvData(ci.hUser);
end;
function CatStr(s:PChar; space:UInt; sz:HSZ; a:PChar; d:Char):PChar;
{$IFDEF Win32} pascal; {$ENDIF}
{entweder sz oder a ausgeben}
var
buf:TS255;
begin
if sz<>0 then begin
DdeQueryString(inst,sz,buf,HIGH(buf)+1,CP_WINANSI);
a:=buf;
end;
CatStr:=s+wvsprintf(s,'%c%s',d);
end;
procedure Notify(var cd:TConvData; c:Char;s1,s2:PChar);
var
ebuf:TS63;
e:UInt;
buf,bp:PChar;
begin
GetMem(buf,maxline);
bp:=buf;
bp^:=c;
Inc(bp);
bp:=CatStr(bp,maxline-(bp-buf)-2,cd.hszService,nil,cd.delim);
bp:=CatStr(bp,maxline-(bp-buf)-2,cd.hszTopic,nil,cd.delim);
if s1<>nil then bp:=CatStr(bp,maxline-(bp-buf)-2,0,s1,cd.delim);
if s2<>nil then bp:=CatStr(bp,maxline-(bp-buf)-2,0,s2,cd.delim);
if c='#' then begin
e:=DdeGetLastError(inst);
wvsprintf(ebuf,'Error 0x%X',e);
bp:=CatStr(bp,maxline-(bp-buf)-2,0,ebuf,cd.delim);
if (e<DMLERR_First) or (e>DMLERR_Last) then e:=DMLERR_Last+1;
LoadString({$IFNDEF Win32}Seg{$ENDIF}(HInstance),e,ebuf,HIGH(ebuf)+1);
bp:=CatStr(bp,maxline-(bp-buf)-2,0,ebuf,cd.delim);
end;
lstrcpy(bp,#13#10);
send(cd.sock,buf^,bp-buf+2,0);
FreeMem(buf,maxline);
end;
function GetStatistikPtr(cd:PConvData):PStatistik;
begin
GetStatistikPtr:=PStatistik(IfThenElseP(cd^.ddeserver,
PChar(@Statistik.ddeserv),PChar(@Statistik.tcpserv)));
end;
procedure IncAdvises(cd:PConvData; um:Integer);
begin
Inc(cd^.advises,um);
IncStatistik(@GetStatistikPtr(cd)^.advises,um);
end;
procedure HandleDisconnect(cd:PConvData);
begin
with cd^ do begin
prev^.next:=next;
next^.prev:=prev;
FreeStringHandle(hszTopic);
FreeStringHandle(hszService);
while async<>nil do dispose(Get_Async(cd^,async^.h));
end;
IncAdvises(cd,-cd^.advises);
if cd^.ddeserver then begin
IncStatistik(@Statistik.ddeserv.clients,-1);
end else begin
IncStatistik(@Statistik.tcpserv.servers,-1);
dispose(cd);
end;
end;
type
TGetOrFind=function(var cd0:TConvData; service,topic:PChar):PConvData;
function iFindConv(var cd0:TConvData; service,topic:PChar):PConvData;
{sucht eine passende Konversation in der Liste}
var
hs,ht:HSZ;
cd: PConvData;
begin
iFindConv:=nil;
cd:=cd0.next;
if cd=@cd0 then exit;
hs:=CreateStringHandle(service);
ht:=CreateStringHandle(topic);
repeat
if (DdeCmpStringHandles(cd^.hszService,hs)=0)
and (DdeCmpStringHandles(cd^.hszTopic,ht)=0) then break;
cd:=cd^.next;
until cd=@cd0;
FreeStringHandle(hs);
FreeStringHandle(ht);
if cd=@cd0 then exit;
iFindConv:=cd;
end;
function FindConv(var cd0:TConvData; service,topic:PChar):PConvData; far;
{wie oben, aber meckert bei Versagen}
var
cd: PConvData;
begin
cd:=iFindConv(cd0,service,topic);
if cd<>nil then begin FindConv:=cd; exit; end;
cd0.hszService:=CreateStringHandle(service); {Nur fürs Meckern!?!}
cd0.hszTopic:=CreateStringHandle(topic);
Notify(cd0,'#',nil,nil);
FreeStringHandle(cd0.hszService);
FreeStringHandle(cd0.hszTopic);
IncStatistik(@Statistik.tcpserv.errors,1);
FindConv:=nil;
end;
function GetConv(var cd0:TConvData; service,topic:PChar):PConvData; far;
{Sucht oder erstellt eine Konversation}
var
cd:PConvData;
buf:TS255;
begin
GetConv:=nil;
cd:=iFindConv(cd0,service,topic);
if cd<>nil then begin GetConv:=cd; exit; end;
new(cd); Move(cd0,cd^,sizeof(TConvData));
with cd^ do begin
{ sock:=cd0.sock;}
hszService:=CreateStringHandle(service);
hszTopic:=CreateStringHandle(topic);
{ delim:=cd0.delim;}
conv:=DdeConnect(inst,hszService,hszTopic,nil);
if conv=0 then begin
if (GetPrivateProfileString(stAutostart,service,'',
buf,HIGH(buf)+1,IniFileName)<>0)
and (ShellExecute(MainWnd,nil,buf,nil,nil,SW_Minimize)>32)
then conv:=DdeConnect(inst,hszService,hszTopic,nil); {2. Versuch}
end;
if conv=0 then begin
Notify(cd^,'#',nil,nil);
IncStatistik(@Statistik.tcpserv.errors,1);
FreeStringHandle(hszService);
FreeStringHandle(hszTopic);
dispose(cd);
exit;
end;
IncStatistik(@Statistik.tcpserv.servers,1);
DdeSetUserHandle(conv,QID_SYNC,LongInt(cd));
next:=cd0.next;
cd0.next:=cd;
prev:=next^.prev;
next^.prev:=cd;
end;
GetConv:=cd;
end;
type
TUrl=record
prot:PChar;
user:PChar;
pass:PChar;
host:PChar;
port:PChar;
rest:PChar;
end;
procedure ParseURL(s:PChar; var url:TUrl);
{Zerhackt übergebenen String in 6 Teile}
{String-Aufbau: "[prot://][user[:pass]@]host[:port][/rest]"}
var
sp:PChar;
begin
FillChar(url,sizeof(url),0);
sp:=lstrchr(s,':');
if (sp<>nil) and (PWord(sp+1)^=$2F2F) then begin
sp^:=#0;
url.prot:=s;
s:=sp+3;
end;
sp:=lstrchr(s,'/');
if sp<>nil then begin
sp^:=#0;
url.rest:=sp+1;
end;
sp:=lstrchr(s,'@');
if sp<>nil then begin
sp^:=#0;
url.user:=s;
s:=lstrchr(s,':');
if s<>nil then begin
s^:=#0;
url.pass:=s+1;
end;
s:=sp+1;
end;
url.host:=s;
sp:=lstrchr(s,':');
if sp<>nil then begin
sp^:=#0;
url.port:=sp+1;
end;
end;
function TcpConnect(host,port:PChar):TSocket;
{eröffnet Socket-Verbindung zu angegebenen Host:Port;
wenn HIWORD(port)=0 ist, dann ist LOWORD(port) das Port in Host Byte Order}
label err1,err2;
var
so: TSocket;
sa: TSockAddrIn;
se: PServEnt;
he: PHostEnt absolute se;
begin
so:=Socket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
if so=INVALID_SOCKET then goto err1;
FillChar(sa,sizeof(sa),0);
sa.sin_family:=AF_INET;
if LongRec(port).hi=0 then sa.sin_port:=htons(LongRec(port).lo)
else begin
se:=PServEnt(GetServByName(port,nil));
if se=nil then goto err2;
sa.sin_port:=se^.s_port;
end;
sa.sin_addr.s_addr:=inet_addr(host);
if LongInt(sa.sin_addr)=INADDR_NONE then begin
he:=PHostEnt(GetHostByName(host));
if he=nil then goto err2;
sa.sin_addr.s_addr:=PDWord(he^.h_addr_list^)^;
end;
if Connect(so,sa,sizeof(sa))<0 then goto err2;
TcpConnect:=so;
exit;
err2:
CloseSocket(so);
err1:
TcpConnect:=Invalid_Socket;
end;
type
PPSockData=^PSockData;
PSockData=^TSockData;
TSockData=record
next:PSockData;
cd0: TConvData;
last:PConvData; {Zuletzt verwendete Konversation}
llen:UInt;
idx: UInt;
skipchar: Char;
line:array[0..1] of Char;
end;
var
sd0: PSockData; {Verkettete Liste der Socket-Daten}
function FindSockData(sock:TSocket):PPSockData;
var
sdp:PPSockData;
sd:PSockData;
begin
sdp:=@sd0;
repeat
sd:=sdp^;
if sd=nil then break;
if sd^.cd0.sock=sock then break;
sdp:=@sd^.next;
until false;
FindSockData:=sdp;
end;
function NewSockData(sock:TSocket; AsServer:Boolean):PSockData;
{erzeugt neues SockData und hängt es in die globale Liste}
var
sd: PSockData;
begin
{$IFDEF Win32}
sd:=PSockData(GlobalAlloc(GPTR,sizeof(TSockData)-2+maxline));
{$ELSE}
sd:=Ptr(GlobalAlloc(GPTR,sizeof(TSockData)-2+maxline),0);
{$ENDIF}
if sd<>nil then with sd^ do begin
next:=sd0;
cd0.next:=@cd0;
cd0.prev:=@cd0;
cd0.sock:=sock;
cd0.ddeserver:=AsServer;
llen:=maxline;
sd0:=sd;
end;
NewSockData:=sd;
end;
function DdeCallback(CallType,Fmt:UInt; Conv:hConv; HSz1,HSz2:HSz;
Data:hDdeData; Data1,Data2: DWord): hDdeData;
{$IFDEF WIN32}stdcall{$ELSE}export{$ENDIF};
label unaccess,block;
const {zum Hinüberretten nach XTYP_Connect_Confirm}
ConnectingC:PConvData=nil;
var
{ EmpfChar: Char;}
{ Sum: Byte;}
{ sp,sp2,sp3: PChar;}
{i,ec,}ico: Integer;
cd: PConvData;
url:TUrl;
async: PAsync; {zur Behandlung von XTYP_Xact_Complete}
sock: TSocket;
sd: PSockData;
S{,buf}: array[0..255] of Char; {1 Byte extra für Null lassen}
begin
DdeCallback:=0;
ico:=2; {von Fehlschlag ausgehen}
cd:=nil;
if CallType<>XTYP_Connect then begin
cd:=GetCD(Conv); {Deskriptor holen}
if (cd<>nil) and (cd^.block<>0) then begin
Dec(cd^.block);
DdeCallback:=cd^.result; {asynchrones Ergebnis liefern}
ChangeDdeIcon(ico); {Erfolg oder Misserfolg anzeigen}
exit;
end;
end;
case CallType {and XTYP_Mask} of
XTYP_Connect: begin
{i:=}DdeQueryString(Inst,Hsz2,s,sizeof(s),CP_WinAnsi);
{In der Form "ndde://[user[:pass]@]host[:port]/remote_service"}
ParseURL(s,url);
if url.prot=nil then exit;
if lstrcmpi(url.prot,'ndde')<>0 then exit;
if (url.rest=nil) or (url.rest^=#0) then exit;
if url.port=nil then url.port:=PChar(d2s_port);
sock:=TcpConnect(url.host,url.port);
if sock=INVALID_SOCKET then exit;
sd:=NewSockData(sock,true);
{ new(cd); FillChar(cd^,sizeof(cd^),0);}
WSAAsyncSelect(sock,MainWnd,WM_Recv,FD_Read or FD_Close);
sd^.cd0.hszService:=CreateStringHandle(url.rest);
DdeKeepStringHandle(inst,hsz1); {brauchen Kopie}
sd^.cd0.hszTopic:=hsz1;
sd^.cd0.delim:=DefDelim[0];
ConnectingC:=@sd^.cd0;
Notify(sd^.cd0,'c',nil,nil);
DdeCallback:=1; {Verbindung okay melden, obwohl keine Bestätigung}
end;
XTYP_Connect_Confirm: begin
cd:=ConnectingC;
ConnectingC:=nil;
cd^.conv:=conv;
DdeSetUserHandle(Conv,QID_Sync,LongInt(cd)); {nachträgliche Zuordnung!}
IncStatistik(@Statistik.ddeserv.clients,1);
end;
XTYP_Disconnect: begin
if cd^.ddeserver then begin
WSAAsyncSelect(cd^.sock,MainWnd,0,0);
Closesocket(cd^.sock); {als DDE-Server und TCP-Client, Client tot}
end else begin
Notify(cd^,'d',nil,nil); {als TCP-Server und DDE-Client, Server tot}
FindSockData(cd^.sock)^^.last:=nil;
end;
HandleDisconnect(cd);
end;
XTYP_AdvStart: begin {nur DDE-Server}
IncAdvises(cd,1);
Notify(cd^,'a',PChar(hsz2),nil);
goto block;
end;
XTYP_AdvStart or XTYPF_NoData: begin {nur DDE-Server}
IncAdvises(cd,1);
Notify(cd^,'w',PChar(hsz2),nil);
goto block;
end;
XTYP_AdvStop,XTYP_AdvStop or XTYPF_NoData: begin {nur DDE-Server}
IncAdvises(cd,-1);
Notify(cd^,'u',PChar(hsz2),nil);
exit;
end;
XTYP_AdvData: begin {nur DDE-Client}
if data<>0 then begin
Notify(cd^,'m',PChar(hsz2),DdeAccessData(data,nil));
DdeUnaccessData(data);
end else begin
Notify(cd^,'m',PChar(hsz2),nil);
end;
DdeCallback:=DDE_fAck;
end;
XTYP_Request: begin {nur DDE-Server}
IncStatistik(@Statistik.ddeserv.requests,1);
if Fmt<>CF_Text then exit; {Kann nicht anders!}
Notify(cd^,'r',PChar(hsz2),nil);
goto block;
end;
XTYP_AdvReq: begin {nur DDE-Server}
{hm, hier brauchen wir wohl eine Liste der Advises??}
DdeCallback:=cd^.result; {bereitgestelltes Handle abliefern}
cd^.result:=0;
end;
XTYP_Execute: begin
IncStatistik(@Statistik.ddeserv.execs,1);
Notify(cd^,'e',nil,DdeAccessData(Data,nil));
goto unaccess;
end;
XTYP_Poke: begin {nur DDE-Server}
IncStatistik(@Statistik.ddeserv.pokes,1);
if Fmt<>CF_Text then exit; {Kann nicht anders!}
Notify(cd^,'p',PChar(hsz2),DdeAccessData(Data,nil));
unaccess:
DdeUnaccessData(Data);
block:
DdeCallback:=CBR_Block;
Inc(cd^.block);
exit;
end;
XTYP_Xact_Complete: begin {nur DDE-Client}
async:=Get_Async(cd^,data1);
if async=nil then begin
vLog('XTYP_XACT_COMPLETE: Kann Handle %#lX nicht finden!',data1);
exit;
end;
if data<>0 then begin {wenn Transaktion OK}
case async^.c of
'a','w': IncAdvises(cd,1);
'u': IncAdvises(cd,-1);
end;
if async^.c='r' then begin {mit Daten (Request)}
Notify(cd^,async^.c,PChar(hsz2),DdeAccessData(data,nil));
DdeUnaccessData(data);
end else begin {ohne Daten (alles andere)}
Notify(cd^,async^.c,PChar(hsz2),nil);
end;
ChangeDdeIcon(3);
end else begin
Notify(cd^,'#',PChar(hsz2),nil); {Fehlermeldung}
IncStatistik(@Statistik.tcpserv.errors,1);
ChangeDdeIcon(2);
end;
dispose(async);
end;
end;
end;
procedure HandleAccept;
var
cli: TSocket;
addrlen: Integer;
sa: TSockAddrIn;
sp: PChar;
{ sd: PSockData;}
begin
addrlen:=sizeof(sa);
cli:=accept(AcceptSock,WinSock.PSockAddr(@sa)^,addrlen);
sp:=inet_ntoa(sa.sin_addr{$IFNDEF Win32}.s_addr{$ENDIF});
if CheckIP(sa.sin_addr.s_addr) then begin
if NewSockData(cli,false)=nil then begin
vLog('No memory in HandleAccept() from %s',sp);
closesocket(cli);
exit;
end;
WSAAsyncSelect(cli,MainWnd,WM_Recv,FD_Read or FD_Close);
{ vLog('Connect from %s accepted',sp);}
IncStatistik(@Statistik.tcpserv.clients,1);
end else begin
closesocket(cli);
vLog('Connect from %s rejected',sp);
end;
end;
procedure EnableCallback(var cd:TConvData);
begin
DdeEnableCallback(Inst,cd.conv,
IfThenElse(Bool(cd.block-1),EC_EnableOne,EC_EnableAll));
end;
procedure HandleLine(var sd:TSockData);
label gem;
var
argv: PArgv;
argc: Integer;
cd: PConvData;
i: Integer;
xtyp: Word;
hItem: HSZ;
{ r: HDdeData;}
hexbuf: array[0..11] of Char;
procedure Args(GetOrFind:TGetOrFind; MinArgC:Integer);
begin
if argc<MinArgC then begin
cd:=sd.last;
i:=1; {nächstes Argument ist hier}
end else begin
cd:=GetOrFind(sd.cd0,argv^[1],argv^[2]);
i:=3; {nächstes Argument ist dort}
end;
if cd<>nil then sd.last:=cd; {Eintragung}
end;
begin
with sd do begin
if idx=0 then exit; {Leerzeilen stillschweigend durchfallen lassen}
if idx>1 then begin
cd0.delim:=line[1];
argv:=split(line,line[1],@argc);
end else argc:=1;
if cd0.ddeserver then case line[0] of
'c': begin
cd0.connected:=true;
end;
'a','w','e','p': begin
cd0.result:=DDE_FAck;
EnableCallback(cd0);
end;
'#': begin
IncStatistik(@Statistik.ddeserv.errors,1);
cd0.result:=DDE_FNotProcessed;
if cd0.connected then EnableCallback(cd0)
else begin
DdeDisconnect(cd0.conv);
HandleDisconnect(@cd0);
end;
end;
'm','r': begin
hItem:=CreateStringHandle(argv^[3]);
if argv^[4]<>nil then cd0.result:=DdeCreateDataHandle(
inst,argv^[4],lstrlen(argv^[3])+1,0,hItem,CF_Text,0)
else cd0.result:=0;
if line[0]='r' then EnableCallback(cd0)
else DdePostAdvise(inst,cd0.hszTopic,hItem);
{Hier fehlt noch das Retten der Daten hinüber zu XTYP_AdvReq}
FreeStringHandle(hItem);
end;
'd': begin
HandleDisconnect(@cd0);
end;
end else case line[0] of {DDE-Kunde}
'c': begin
Args(GetConv,3);
if cd<>nil then begin
wvsprintf(hexbuf,'0x%08X',cd^.conv);
Notify(cd^,'c',hexbuf,nil);
end;
end;
'a': begin
Args(GetConv,4);
xtyp:=XTYP_ADVSTART;
goto gem;
end;
'w': begin
Args(GetConv,4);
xtyp:=XTYP_ADVSTART or XTYPF_NODATA;
goto gem;
end;
'u': begin
Args(FindConv,4);
xtyp:=XTYP_ADVSTOP;
goto gem;
end;
'e': begin
IncStatistik(@Statistik.tcpserv.execs,1);
Args(GetConv,4);
if cd<>nil then while i<argc do begin
AsyncClientTransaction(cd^,argv^[i],-1,nil,XTYP_EXECUTE,line[0]);
Inc(i);
end;
end;
'p': begin
IncStatistik(@Statistik.tcpserv.pokes,1);
Args(GetConv,5);
if cd<>nil then while i<argc-1 do begin
AsyncClientTransaction(cd^,argv^[i+1],-1,argv^[i],XTYP_POKE,line[0]);
Inc(i,2);
end;
end;
'r': begin
IncStatistik(@Statistik.tcpserv.requests,1);
Args(GetConv,4);
xtyp:=XTYP_REQUEST;
gem: if cd<>nil then while i<argc do begin
AsyncClientTransaction(cd^,nil,0,argv^[i],xtyp,line[0]);
Inc(i);
end;
end;
'd': begin
Args(FindConv,3);
if cd<>nil then begin
DdeDisconnect(cd^.conv);
HandleDisconnect(cd);
last:=nil;
end;
end;
end{case};
LocalFree(UInt(argv));
idx:=0;
end;
end;
procedure HandleRecv(sock:TSocket);
label backstep,endline,default;
var
sd: PSockData;
c: Char;
begin
sd:=FindSockData(sock)^;
if sd=nil then exit;
with sd^ do repeat
if recv(sock,c,1,0)<>1
then exit; {einzelzeichenweise...}
if c<>skipchar then begin
case c of
#0: ; {kann nicht behandeln, ignorieren}
#127:goto backstep;
#8: backstep: if (idx<>0) then Dec(idx);
#10: begin skipchar:=#13; goto endline; end;
#13: begin skipchar:=#10; endline:
line[idx]:=#0; HandleLine(sd^);
end;
^U: idx:=0; {Zeile löschen}
#9: begin c:=' '; goto default; end;
else default: line[idx]:=c; Inc(idx);
end;
end;
skipchar:=#0;
if idx=llen then Dec(idx); {Zeichen abschneiden und auf \n warten}
until false;
end;
procedure HandleClose(sock:TSocket);
var
sdp:PPSockData;
sd: PSockData;
{ cd: PConvData;}
begin
sdp:=FindSockData(sock);
sd:=sdp^;
if sd=nil then exit;
with sd^ do begin
{alle DDETERM durchgehen!}
while cd0.next<>@cd0 do begin
DdeDisconnect(cd0.next^.conv);
HandleDisconnect(cd0.next);
end;
sdp^:=next;
end;
if sd^.cd0.ddeserver
then IncStatistik(@Statistik.ddeserv.servers,-1)
else IncStatistik(@Statistik.tcpserv.clients,-1);
GlobalFree({$IFDEF Win32}Integer(sd){$ELSE}PtrRec(sd).sel{$ENDIF});
CloseSocket(sock);
end;
procedure StartTelnet;
var
s: TS255;
r: THandle;
begin
wvsprintf(s,'telnet 127.0.0.1 %d',d2s_port);
if MBox1(MainWnd,106,MB_OKCancel,s)<>IDOK then exit;
r:=WinExec(s,SW_Show);
if r<=32 then MBox1(MainWnd,107,MB_OK,PChar(r));
end;
function CloseDlgProc(Wnd:HWnd; Msg,wParam:UInt; lParam:LongInt):Bool;
{$IFDEF Win32}stdcall{$ELSE}export{$ENDIF};
label Ende;
begin
CloseDlgProc:=false;
case Msg of
WM_InitDialog: begin
if IsIconic(MainWnd) then begin
ShowDlgItem(Wnd,1,SW_Hide);
end;
CloseDlgProc:=true;
end;
WM_Command: case Word(wParam) of
1: begin ShowWindow(MainWnd,SW_Minimize); goto Ende; end;
2: Ende: EndDialog(Wnd,IDCancel);
3: EndDialog(Wnd,IDOK);
4: begin ShowWindow(MainWnd,SW_Hide); goto Ende; end;
9: WinHelp(Wnd,HelpFileName,HELP_Context,109);
end;
end;
end;
procedure ZeroStatistik;
var
e: EStatistik;
p: PUInt;
begin
for e:=LOW(e) to HIGH(e) do
if e in [E_REQUEST,E_POKE,E_EXEC,E_ERROR] then begin
p:=@Statistik.ddeserv.all[e];
IncStatistik(p,-p^);
end;
end;
var
MinSize: TPoint; {Ausgangsgröße für Dialogfenster}
procedure GetMinSize;
var
wp:TWindowPlacement;
begin
wp.length:=sizeof(wp);
GetWindowPlacement(MainWnd,@wp);
MinSize.x:=wp.rcNormalPosition.right-wp.rcNormalPosition.left;
MinSize.y:=wp.rcNormalPosition.bottom-wp.rcNormalPosition.top;
end;
function MainDlgProc(Wnd:HWnd; Msg,wParam:UInt; lParam:LongInt):Bool;
{$IFDEF Win32}stdcall{$ELSE}export{$ENDIF};
label notray;
var
lPar: LongRec absolute lParam;
lParCmd: LongRec absolute {$IFDEF Win32}wParam{$ELSE}lParam{$ENDIF};
P: TPoint;
R: TRect;
m,sysm: HMenu;
i,j: Integer;
s: TS63;
wd: TWsaData;
begin
MainDlgProc:=false;
case Msg of
WM_InitDialog: begin
MainWnd:=Wnd;
Listbox:=GetDlgItem(Wnd,110);
sysm:=GetSystemMenu(Wnd,false);
DeleteMenu(sysm,SC_Maximize,0);
m:=LoadMenu({$IFNDEF Win32}Seg{$ENDIF}(HInstance),MakeIntResource(100)); {Tray-Menü}
for i:=0 to 3 do begin
j:=i shl 4 + $1B0;
GetMenuString(m,j,s,HIGH(s)+1,MF_ByCommand);
InsertMenu(sysm,i,MF_ByPosition or MF_String,j,s);
{Einstellungen... - Hilfe - Verschwinde!}
end;
DestroyMenu(m);
PostMessage(Wnd,WM_ContinueInit,0,0);
if Swap(Word(GetVersion))>=3*256+95 then begin
LoadString({$IFNDEF Win32}Seg{$ENDIF}(HInstance),110,s,sizeof(s)); {In den Tray!}
InsertMenu(sysm,4,MF_ByPosition or MF_String,$1F0,s);
if CmdShow in [SW_Minimize,SW_ShowMinimized,SW_ShowMinNoActive]
then PostMessage(Wnd,WM_SysCommand,$1F0,0);
end;
LoadString({$IFNDEF Win32}Seg{$ENDIF}(HInstance),105,s,sizeof(s));
PChar(lParam):=s;
Wnd:=GetDlgItem(Wnd,101);
for i:=0 to 2 do begin
SendMessage(Wnd,CB_AddString,0,lParam);
Inc(lParam,lstrlen(PChar(lParam))+1);
end;
SendMessage(Wnd,CB_SetCurSel,0,0);
GetMinSize; {... und KEIN Fokus setzen!}
LoadWinPos;
end;
WM_ContinueInit: begin
i:=WSAStartup($101,wd);
if i<>0 then SockError(i);
LoadConfig;
vLog(nil,{$IFDEF Win32}HInstance{$ELSE}Mem[0:0]{$ENDIF});
DdeNameService(inst,0,0,DNS_FilterOff);
end;
WM_Activate: KBHand:=IfThenElse(Bool(wParam),Wnd,0);
WM_GetMinMaxInfo: begin
PMinMaxInfo(lParam)^.ptMinTrackSize:=MinSize;
end;
WM_Size: if wParam=SIZE_Minimized then begin
Auswahl:=-1;
if traydata.cbSize<>0 then ShowWindow(Wnd,SW_Hide);
end else begin
GetWindowRect(Listbox,R); ScreenToClient(Wnd,PPoint(@R)^);
SetWindowPos(Listbox,0,0,0,
lPar.lo-8-R.left,lPar.hi-8-R.top,SWP_NoZOrder or SWP_NoMove);
{$IFDEF Win32}
SendMessage(Wnd,WM_Command,CBN_SelChange*$10000+101,GetDlgItem(Wnd,101));
{$ELSE}
SendMessageWW(Wnd,WM_Command,101,CBN_SelChange,GetDlgItem(Wnd,101));
{$ENDIF}
end;
WM_Timer: begin
KillTimer(Wnd,102);
if CurIcon<>0 then ChangeDdeIcon(1);
end;
WM_IconChange: begin
HIcon(lParam):=Icons[wParam];
SetClassUInt(Wnd,GCL_HIcon,HIcon(lParam));
InvalidateRect(Wnd,nil,true);
if traydata.cbSize<>0 then begin
traydata.hIcon:=HIcon(lParam);
traydata.uFlags:=NIF_Icon; {nur Icon ändern}
ShellNotify;
end;
end;
WM_SetText: if traydata.cbSize<>0 then begin
lstrcpy(traydata.szTip,PChar(lParam));
traydata.uFlags:=NIF_Tip; {nur Text ändern}
ShellNotify;
end;
WM_SysCommand: case wParam and $FFF0 of
$1A0..$1DF: SendMessage(Wnd,WM_Command,wParam and $FFF0,0);
$1E0: ShowWindow(Wnd,SW_Hide);
$1F0: begin
InitStruct(traydata,sizeof(traydata));
traydata.wnd:=Wnd;
traydata.uID:=110;
traydata.uFlags:=NIF_Icon or NIF_Tip or NIF_Message;
traydata.uCallbackMessage:=WM_Tray;
traydata.hIcon:=GetClassUInt(Wnd,GCL_HIcon);
GetWindowText(Wnd,traydata.szTip,HIGH(traydata.szTip)+1);
if Shell_NotifyIcon(NIM_Add,@traydata)
then ShowWindow(Wnd,SW_Hide)
else MBox0(Wnd,104,MB_OK); {"Widriges OS"}
end;
end;
WM_Tray: case UInt(lParam) of
WM_LButtonDown: begin
ShowWindow(Wnd,SW_Restore);
end;
WM_RButtonDown: begin
m:=LoadMenu({$IFNDEF Win32}Seg{$ENDIF}(HInstance),MakeIntResource(100));
sysm:=GetSubMenu(m,0);
GetCursorPos(P);
TrackPopupMenu(sysm,TPM_RightAlign or TPM_RightButton,
P.x,P.y,0,Wnd,nil); {BUG: Win98: 16bit: Menü in diesem Fall nach links}
DestroyMenu(m);
end;
end;
WM_Accept: HandleAccept;
WM_Recv: begin
if lPar.lo and FD_Read <>0 then HandleRecv(wParam);
if lPar.lo and FD_Close<>0 then HandleClose(wParam);
{Es muss auch noch FD_Write beackert werden, sonst kann
ein blockierendes send() den ganzen D2S-Umsetzer aufhalten!!}
end;
WM_Command: case Word(wParam) of
2: ShowWindow(Wnd,SW_Minimize); {besser als gar nichts}
3: SendMessage(Wnd,WM_Close,0,0); {vom System-Tray}
$1A0: ShowWindow(Wnd,SW_ShowNormal);
$1B0: if SetupDlg<>0 then SetActiveWindow(SetupDlg)
else CreateDialog({$IFNDEF Win32}Seg{$ENDIF}(HInstance),MakeIntResource(108),0,@SetupDlgProc);
$1C0: StartTelnet;
$1D0: WinHelp(Wnd,HelpFileName,HELP_Index,0);
$1E0: goto notray; {Verschwinde!}
$1F0: begin {Normales Fenster!}
if not IsWindowVisible(Wnd) then ShowWindow(Wnd,SW_Minimize);
notray:
Shell_NotifyIcon(NIM_Delete,@traydata);
traydata.cbSize:=0; {auch künftig deaktivieren}
end;
101: case lParCmd.hi of {Combobox}
CBN_SelChange: begin
Auswahl:=SendMessage(HWnd(lParam),CB_GetCurSel,0,0);
IncStatistik(nil,0); {Komplett neu zeichnen}
end;
end;
111: begin {Löschen}
SendMessage(Listbox,LB_ResetContent,0,0);
ZeroStatistik;
end;
end;
WM_Close: begin
if DialogBox({$IFNDEF Win32}Seg{$ENDIF}(HInstance),MakeIntResource(109),
Wnd,@CloseDlgProc)<>IDOK then exit;
i:=Statistik.ddeserv.clients+Statistik.tcpserv.clients;
if (i<>0)
and (MBox1(Wnd,109{WarnClose},MB_IconQuestion or MB_YesNo or MB_Sound,
PChar(i))<>IDYes)
then exit;
if traydata.cbSize<>0 then Shell_NotifyIcon(NIM_Delete,@traydata);
WinHelp(Wnd,HelpFileName,HELP_Quit,0);
SaveWinPos;
WSACleanup;
DestroyWindow(Wnd);
end;
WM_Destroy: PostQuitMessage(0);
end;
end;
const
wc: TWndClass=(
style: CS_DblClks;
lpfnWndProc: @DefDlgProc;
cbClsExtra: 0;
cbWndExtra: DlgWindowExtra;
hInstance: {$IFDEF Win32}0{$ELSE}Seg(HInstance){$ENDIF};
hIcon: 0;
hCursor: 0;
hbrBackground: COLOR_Background+1;
lpszMenuName: nil;
lpszClassName: AppName);
var
Msg:TMsg;
i: Integer;
{$IFDEF Win32}
si:TStartupInfo;
{$ENDIF}
begin
{$IFDEF Win32}
MainWnd:=FindWindow(AppName,nil);
if (MainWnd<>0) then begin
ShowWindow(MainWnd,SW_ShowMinimized);
SetActiveWindow(MainWnd);
exit;
end;
wc.hInstance:=HInstance;
GetStartupInfo(si);
CmdShow:=si.wShowWindow;
{$ELSE}
if HPrevInst<>0 then begin
ShowWindow(MemW[HPrevInst:Ofs(MainWnd)],SW_ShowMinimized);
SetActiveWindow(MemW[HPrevInst:Ofs(MainWnd)]);
exit;
end;
{$ENDIF}
GetModuleFileName({$IFDEF Win32}0{$ELSE}Seg(HInstance){$ENDIF},
IniFileName,HIGH(IniFileName)+1);
lstrcpy(GetFileNamePtr(IniFileName),'d2s.ini');
for i:=0 to HIGH(Icons) do Icons[i]:=LoadIcon(
{$IFNDEF Win32}Seg{$ENDIF}(HInstance),MakeIntResource(100+i));
wc.hIcon:=Icons[0];
wc.hCursor:=LoadCursor(0,IDC_Arrow);
RegisterClass(wc);
CreateDialog({$IFNDEF Win32}Seg{$ENDIF}(HInstance),
MakeIntResource(100),0,@MainDlgProc);
GetWindowText(MainWnd,AppTitle,HIGH(AppTitle)+1);
StdMBoxTitle:=AppTitle;
if DdeInitialize(
Inst,
DdeCallBack,
CBF_Skip_Registrations or CBF_Skip_Unregistrations,
0)<>DMLErr_No_Error
then DdeError(DMLErr_Sys_Error);
while GetMessage(Msg,0,0,0) do begin
if (KBHand<>0) and IsDialogMessage(KBHand,Msg) then continue;
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
DdeUninitialize(Inst);
for i:=0 to HIGH(Icons) do DestroyIcon(Icons[i]);
end.
| Detected encoding: OEM (CP437) | 1
|
|
|