home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
bbs
/
samps.zip
/
CHAT4.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-11-14
|
16KB
|
685 lines
Program Chat4;
{$M 4096,0,2000}
{ Host Mode CHAT SERVER Version 2.0 by Martin Stubbs G8IMB }
Uses Crt,Dos;
const
CR = #$0D;
LF = #$0A;
CRLF = CR+LF;
SOH = $01;
DLE = $10;
ETB = $17;
type
line = string[80];
User_rec = record
User_call : String[6];
User_name : String[10];
end;
var
Ch : Char;
err : Integer;
Logged_in : Array [0..10] of Boolean; { Is someone on this channel }
Callsign : Array [0..10] of String[10]; { Connected callsign }
Conf : Array [0..10] of byte; { Which conference }
Name : Array [0..10] of String[10]; { Users name }
I : integer;
p : Integer;
Start_port : Integer;
No_ports : Integer;
resp_len : Integer;
Quit : Boolean;
xloc,yloc : Integer;
xkeep,ykeep: Integer;
Welcome_st : String[80];
Regs : Registers;
Cnf : text;
Log : text;
Users : File of User_rec;
Use_data : User_rec;
BPQbuff : Array [1..255] of byte;
OBuffer : String[255];
IBuffer : String[255];
locbuff : String[255];
Procedure Logout(n:Integer);Forward; { Forward declarations of procedures }
Procedure Login (n:Integer);Forward;
procedure DV_Nice; {Give time slice to next task}
begin
regs.ax := $1000;
Intr($15, regs);
end;
Procedure Display(St:String);
Begin
Window(1,5,80,21);
GotoXY(xkeep,ykeep);
Write(St);
xkeep := WhereX;
ykeep := WhereY;
Window(1,23,80,23);
GoToXy(Xloc,Yloc);
End;
Function Time:String;
Var
X : Word;
I : Integer;
Timarr: Array[1..6] of word;
Timst : Array[1..6] of string[4];
Begin
GetDate(Timarr[3],Timarr[2],Timarr[1],x);
GetTime(Timarr[4],Timarr[5],Timarr[6],x);
For I := 1 to 6 do
Begin
Str(Timarr[I]:2,Timst[I]);
End;
Time := timst[1]+'/'+timst[2]+'/'+timst[3]+' '+
timst[4]+':'+timst[5]+':'+timst[6];
End;
Function Poll(p:Integer):Boolean;
Var
Change : Boolean;
Begin
Change := False;
regs.ah := $04;
regs.al := Start_port + p;
intr($7F,regs);
If regs.dx = 1 then Change := True;
regs.ah := $05;
regs.al := Start_port + p;
intr($7F,regs);
If Change then Poll := True
else Poll := False;
End;
Function Get_resp(p:Integer):Boolean;
Var
I : Integer;
pass : Boolean;
Begin
regs.di := Ofs(BPQbuff);
regs.es := Seg(BPQbuff);
regs.ah := $03;
regs.al := Start_port + p;
intr($7F,regs);
If regs.cx > 0 then
Begin
IBuffer := '';
For I := 1 to regs.cx do
Begin
IBuffer := IBuffer + Chr(BPQbuff[I]);
If BPQbuff[I] = $0D then
IBuffer := IBuffer + #$0A;
End;
Get_resp := True;
End
else
Get_resp := False;
End;
Procedure Send(p:Integer);
var
Inp,Out : Integer;
Begin
For Inp := 1 to Length(OBuffer) do
Begin
BPQbuff[Inp] := Ord(OBuffer[Inp]); { Convert char to byte }
End;
regs.cx := Length(OBuffer);
regs.si := Ofs(BPQbuff);
regs.es := Seg(BPQbuff);
regs.ah := $02;
regs.al := Start_port + p;
intr($7F,regs);
end;
Function BPQ_loaded: Boolean;
Var
Seg ,ofs : word;
Seg1,ofs1 : word;
I : integer;
St : String[7];
Begin
Seg := 0;
Ofs := $01FC; { Address of Int $7F }
Ofs1 := memw[Seg:Ofs]; { Find address of BPQcode }
Seg1 := memw[Seg:ofs+2];
ofs1 := Ofs1 - 7;
St := '';
For I := 0 to 4 do
Begin
ofs := Ofs1 + I;
St := St + Chr(mem[Seg1:Ofs]); { Read byte from memory }
End;
BPQ_loaded := (St='G8BPQ'); { Does it match string }
End;
Procedure Get_Config;
Begin
Assign(Cnf,'Chat.cnf');
{$I-}
Reset(Cnf);
{$I+}
If IOresult <> 0 then
Begin
WriteLn('Configuration file - CHAT.CNF not found ');
Halt;
End;
Read(Cnf,Welcome_st); { Read 1 line from CNF file }
Close(Cnf);
End;
Procedure Log_data(St:String);
Begin
Assign(log,'Chat.log');
{$I-}
Append(log);
{$I+}
If IOresult <> 0 then
Rewrite(log);
Write(log,st+' '+Time+CR+LF);
Close(log);
End;
Procedure Find_name(p:Integer);
Var
Match : Boolean;
Begin
Match := False;
Assign(Users,'Chatuser.dat');
{$I-}
Reset(Users); { See if user file exists }
{$I+}
If IOresult <> 0 then
Rewrite(Users) { Create a new file }
else
With Use_data do
Begin
While (not match) and (not EOF(Users)) do
Begin
Read(Users,Use_data);
Match := (User_call=Callsign[p]);
End;
End; { With Use_data }
If (not match) then
Name[p] := 'New User'
else
Name[p] := Use_data.User_name;
Close(Users);
End;
Procedure setup; {read command line}
var
err: integer;
i: integer;
p: integer;
begin
If (ParamCount = 0) then
Begin
Display(' You must supply the port number as a parameter ');
Halt;
End
else
Begin
Val(Paramstr(1),i,err); If (err = 0) then Start_port := i;
Val(Paramstr(2),i,err); If (err = 0) then No_ports := i;
If (Start_port<1) or (No_ports>9) or (Start_port+No_ports>32) then
Begin
Display('Parameter error');
ClrScr;
Halt;
end
else
Display('Using Ports '+Chr(Start_port+$30)+' to '+
Chr(Start_port+$30+No_ports-1)+CRLF);
End;
Callsign[10] := 'Sysop'; { Set default sysop call }
Conf[10] := 0;
Window(1,1,80,3);
WriteLn(' 0 1 2 3 4 5 6 7',
' 8 9');
Log_data('Initialsed');
For I := 0 to No_ports - 1 do
Logged_In[I] := False;
For I := 0 to No_ports - 1 do
Begin
regs.cl := 0; { Application mask }
regs.dl := 16; { Application number }
regs.ah := $01;
regs.al := Start_port + I;
intr($7F,regs);
Callsign[I] := ' '; { Clear Callsign }
End;
End;
Procedure Login(n:integer);
Var
I : Integer;
P : Integer;
Begin
regs.ah := $08; { Get callsign }
regs.al := Start_port + n;
regs.di := Ofs(BPQbuff);
regs.es := Seg(BPQbuff);
intr($7F,regs);
Callsign[n] := '';
I := 1; { Strip callsign }
While (I < 9) and (Chr(BPQbuff[I]) <> '-') and
(Chr(BPQbuff[I]) <> ' ') do
Begin
Callsign[n] := Callsign[n] + Chr(BPQbuff[I]);
I := I + 1;
End;
Display('Call connected '+Callsign[n]+' Channel no. '+ chr(n+$30)+CRLF);
Find_name(n);
OBuffer := 'Hi ' + name[n] + ' ' + Welcome_st + CR;
Send(n);
OBuffer := '/W will give a list of Who is on. /H for help' + CR;
Send(n);
OBuffer := Callsign[n] + ' ' + name[n] + ' has join the group ' + CR;
For I := 0 to No_ports - 1 do
Begin
If Logged_in[I] then
Begin
Send(I);
End;
End;
Logged_in[n] := True; { Mark that user is logged in }
Conf[n] := 0;
Log_data(Callsign[n]+' connected');
Window(1,1,80,3);
GotoXY(8*n+1,2); Write(Callsign[n]);
GotoXY(8*n+1,3); Write(Name[n]);
Window(1,23,80,23);
GoToXy(Xloc,Yloc);
End;
Procedure Logout(n:integer);
Var
I : Integer;
Begin
logged_in[n] := False;
OBuffer := Callsign[n] + ' has disconnected ' + CR;
For I := 0 to No_ports - 1 do
Begin
If Logged_in[I] then
Begin
Send(I);
End;
End;
Log_data(Callsign[n]+' disconnected');
Window(1,1,80,3);
GotoXY(8*n+1,2);Write(' DISC ');
GotoXY(8*n+1,3);Write(' ');
Window(1,23,80,23);
GoToXy(Xloc,Yloc);
Display('Call disconnected '+Callsign[n]+' Channel no. '+Chr(n+$30)+CRLF);
End;
{ Procedure SendAll is used to send a user message to the other stations }
{ who are in his conference }
Procedure SendAll(n:integer);
Var
I : Integer;
Begin
OBuffer := '[' + callsign[n] + '] ' + IBuffer;
{ Send to anyone logged on who is in }
{ the same conference as sender }
For I := 0 to No_ports - 1 do
Begin
If (Logged_in[I]) and (I <> n) then
If (Conf[n] = Conf[I]) or (n = 10) then {send sysop msgs to all }
Begin
Send(I);
End;
End;
If conf[n] <> 0 then Write('(',Conf[n],')'); { Tell sysop the conf no. }
Display(OBuffer); { Send to local console }
End;
{ Procedure Shut_down is used to close down the node gracefully }
Procedure Shut_down;
Var
I : Integer;
Begin
For I := 0 to No_ports - 1 do
Begin
If Logged_in[I] then
Begin
IBuffer := 'Sorry .. Chat Node is closing down for a while ';
SendAll(10); { Use IBuffer cos of SendAll }
Delay(2000); { Wait for message to get there }
regs.cx := 2; { Disconnect stream }
regs.ah := $06;
regs.al := Start_port + I;
intr($7F,regs);
End;
End;
End;
Procedure Command(p:integer);
Var
Comm_let : Char;
Sbit,Cbit: String[2];
Match : boolean;
Begin
Comm_let := IBuffer[2];
Case Comm_let of
'b','B' : Begin
OBuffer := 'Thank you for calling ' + name[p] + CR;
Send(p);
Delay(1000);
regs.cx := 3;
regs.ah := $06;
regs.al := Start_port + p;
intr($7F,regs);
End;
'c','C' : Begin
Val(IBuffer[4],conf[p],err);
If (Conf[p] > 4) or (err <> 0) then
Begin
OBuffer := 'Error in conference number' + CR;
Send(p);
Conf[p] := 0;
End
Else
Begin
OBuffer := 'Conference channel has been changed' + CR;
Send(p);
End;
End;
'h','H','?': Begin
OBuffer := 'The commands which are available are :-' + CR;
Send(p);
OBuffer := '/? - To read this list' + CR;
Send(p);
OBuffer := '/B - To leave the chat node' + CR;
Send(p);
OBuffer := '/C n - To switch to conference stream n' + CR;
Send(p);
OBuffer := '/H - To read this list' + CR;
Send(p);
OBuffer := '/N Yourname - To register onto the node' + CR;
Send(p);
OBuffer := '/Q - To disconnect from the node completely' + CR;
Send(p);
OBuffer := '/W - To find who else is connected' + CR;
Send(p);
End;
'n','N' : Begin
Assign(Users,'Chatuser.dat');
Reset(Users);
With Use_data do
Begin
match := false;
While (not match) and (not EOF(users)) do
Begin
Read(Users,Use_data);
Match := (User_call=Callsign[p]);
End;
I := Pos(#$0D,IBuffer);
User_name := Copy(IBuffer,4,I-4);
User_call := Callsign[p];
Write(Users,Use_data);
OBuffer := 'Hello ' + User_name
+ ' thanks for registering' + CR;
Send(p);
Name[p] := User_name;
End; { With Use_data }
Close(Users);
End;
'q','Q': Begin
OBuffer := 'Thank you for calling ' + name[p] + CR;
Send(p);
Delay(1000);
regs.cx := 2;
regs.ah := $06;
regs.al := Start_port + p;
intr($7F,regs);
End;
'w','W' : Begin
OBuffer := 'List of current users ' + CR;
Send(p);
For I := 0 to No_ports - 1 do
Begin
If Logged_in[I] then
Begin
Str(I,Sbit);
Str(Conf[I],Cbit);
OBuffer := Callsign[I] + ' ' + name[I] +
' connected on port ' + Sbit + ' to conference ' +
Cbit + CR;
Send(p);
End;
End;
End;
else
Begin
OBuffer := 'Command not known';
Send(p);
End;
End; {Case end}
End;
{*************************** Start of main ******************************}
Begin
DirectVideo := False; { Write to screen using BIOS calls }
ClrScr;
xkeep := 1;
ykeep := 1;
xloc := 1;
yloc := 1;
For I := 1 to 255 do
BPQbuff[I] := 0;
GotoXY(1, 4); For I := 1 to 80 do Write('-');
GotoXY(1,22); For I := 1 to 80 do Write('-');
GoToXY(1,24); Write('/C - to close down node /Q - to chop node');
Display(' IMB Chat node'+CRLF);
If not BPQ_loaded then
Begin
Display('Version 4 BPQ node not loaded ');
Halt;
End;
Get_config;
setup;
For I := 0 to No_ports - 1 do
LogOut(I);
Quit := false;
locbuff := '';
Repeat
Repeat
For I := 0 to No_ports - 1 do
Begin
If (Poll(I)) then
If regs.cx <> 0 then Login(I)
else Logout(I);
If Get_resp(I) then
If IBuffer[1] = '/' then Command(I)
else Sendall(I);
End;
DV_Nice;
Until Keypressed;
Ch := Readkey;
Case Ch of
#00 : Begin { Special keys }
End;
#08 : Begin
xloc := xloc - 1;
Delete(locbuff,length(locbuff),1);
GotoXY(xloc,yloc); Write(' ');
GoToXY(xloc,yloc);
End;
#$0D : Begin
locbuff := locbuff + Ch;
xloc := 1;
If locbuff[1] = '/' then
Begin
Case locbuff[2] of
'0'..'9' : Begin { Send a message to just 1 station}
p := Ord(locbuff[2]) - $30;
Locbuff[1] := '*';
Locbuff[2] := '>';
OBuffer := '<* sysop '+locbuff;
Send(p);
End;
'c','C' : Begin { Polite close down of node }
Shut_down;
Delay(2000);
Quit := True;
End;
'q','Q' : Quit := True;
End; { case }
end { If / }
else
Begin
IBuffer := Locbuff + CRLF; { Load it into Ibuffer to be sent out }
Sendall(10);
End;
locbuff := ''; { Clear local buffer }
end; {#0D}
else
begin
GotoXY(xloc,yloc);Write(Ch);
locbuff := locbuff + Ch;
xloc := xloc + 1;
end;
end; {Case}
xloc := WhereX;
yloc := WhereY;
Until Quit;
For I := 0 to No_ports - 1 do
Begin
regs.dl := $00; { Set application flag to 0 }
regs.ah := $01;
regs.al := Start_port + I;
intr($7F,regs);
End;
end.