home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / bbs / samps.zip / CHAT4.PAS < prev    next >
Pascal/Delphi Source File  |  1990-11-14  |  16KB  |  685 lines
  1. Program  Chat4;
  2. {$M 4096,0,2000}
  3.         { Host Mode CHAT SERVER Version 2.0 by Martin Stubbs G8IMB }
  4.  
  5. Uses Crt,Dos;
  6.  
  7. const
  8.   CR     = #$0D;
  9.   LF     = #$0A;
  10.   CRLF   = CR+LF;
  11.   SOH    = $01;
  12.   DLE    = $10;
  13.   ETB    = $17;
  14.  
  15. type
  16.   line   = string[80];
  17.   User_rec = record
  18.                User_call : String[6];
  19.                User_name : String[10];
  20.               end;
  21.  
  22. var
  23.   Ch         : Char;
  24.   err        : Integer;
  25.   Logged_in  : Array [0..10] of Boolean;     { Is someone on this channel }
  26.   Callsign   : Array [0..10] of String[10];  { Connected callsign }
  27.   Conf       : Array [0..10] of byte;        { Which conference }
  28.   Name       : Array [0..10] of String[10];  { Users name       }
  29.   I          : integer;
  30.   p          : Integer;
  31.   Start_port : Integer;
  32.   No_ports   : Integer;
  33.   resp_len   : Integer;
  34.  
  35.   Quit       : Boolean;
  36.   xloc,yloc  : Integer;
  37.   xkeep,ykeep: Integer;
  38.   Welcome_st : String[80];
  39.  
  40.   Regs       : Registers;
  41.   Cnf        : text;
  42.   Log        : text;
  43.   Users      : File of User_rec;
  44.   Use_data   : User_rec;
  45.  
  46.   BPQbuff    : Array [1..255] of byte;
  47.   OBuffer    : String[255];
  48.   IBuffer    : String[255];
  49.   locbuff    : String[255];
  50.  
  51. Procedure Logout(n:Integer);Forward;  { Forward declarations of procedures }
  52. Procedure Login (n:Integer);Forward;
  53.  
  54. procedure DV_Nice;          {Give time slice to next task}
  55.   begin
  56.     regs.ax := $1000;
  57.     Intr($15, regs);
  58.   end;
  59.  
  60. Procedure Display(St:String);
  61. Begin
  62.  
  63.   Window(1,5,80,21);
  64.  
  65.   GotoXY(xkeep,ykeep);
  66.   Write(St);
  67.   xkeep := WhereX;
  68.   ykeep := WhereY;
  69.  
  70.   Window(1,23,80,23);
  71.   GoToXy(Xloc,Yloc);
  72. End;
  73.  
  74. Function Time:String;
  75. Var
  76.   X : Word;
  77.   I : Integer;
  78.   Timarr: Array[1..6] of word;
  79.   Timst : Array[1..6] of string[4];
  80.  
  81. Begin
  82.   GetDate(Timarr[3],Timarr[2],Timarr[1],x);
  83.   GetTime(Timarr[4],Timarr[5],Timarr[6],x);
  84.  
  85.   For I := 1 to 6 do
  86.   Begin
  87.     Str(Timarr[I]:2,Timst[I]);
  88.   End;
  89.  
  90.   Time := timst[1]+'/'+timst[2]+'/'+timst[3]+'  '+
  91.           timst[4]+':'+timst[5]+':'+timst[6];
  92. End;
  93.  
  94. Function Poll(p:Integer):Boolean;
  95. Var
  96.   Change : Boolean;
  97.  
  98. Begin
  99.   Change := False;
  100.  
  101.   regs.ah := $04;
  102.   regs.al := Start_port + p;
  103.   intr($7F,regs);
  104.  
  105.   If regs.dx = 1 then Change := True;
  106.  
  107.   regs.ah := $05;
  108.   regs.al := Start_port + p;
  109.   intr($7F,regs);
  110.  
  111.   If Change then Poll := True
  112.             else Poll := False;
  113.  
  114. End;
  115.  
  116. Function Get_resp(p:Integer):Boolean;
  117. Var
  118.   I    : Integer;
  119.   pass : Boolean;
  120.  
  121. Begin
  122.  
  123.   regs.di := Ofs(BPQbuff);
  124.   regs.es := Seg(BPQbuff);
  125.   regs.ah := $03;
  126.   regs.al := Start_port + p;
  127.   intr($7F,regs);
  128.  
  129.   If regs.cx > 0 then
  130.   Begin
  131.     IBuffer := '';
  132.     For I := 1 to regs.cx do
  133.     Begin
  134.       IBuffer := IBuffer + Chr(BPQbuff[I]);
  135.       If BPQbuff[I] = $0D then
  136.          IBuffer := IBuffer + #$0A;
  137.     End;
  138.     Get_resp := True;
  139.   End
  140.   else
  141.     Get_resp := False;
  142. End;
  143.  
  144. Procedure Send(p:Integer);
  145. var
  146.   Inp,Out : Integer;
  147.  
  148. Begin
  149.  
  150.   For Inp := 1 to Length(OBuffer) do
  151.   Begin
  152.     BPQbuff[Inp] := Ord(OBuffer[Inp]);  { Convert char to byte }
  153.   End;
  154.  
  155.   regs.cx := Length(OBuffer);
  156.   regs.si := Ofs(BPQbuff);
  157.   regs.es := Seg(BPQbuff);
  158.   regs.ah := $02;
  159.   regs.al := Start_port + p;
  160.   intr($7F,regs);
  161.  
  162. end;
  163.  
  164. Function BPQ_loaded: Boolean;
  165. Var
  166.   Seg ,ofs  : word;
  167.   Seg1,ofs1 : word;
  168.   I         : integer;
  169.   St        : String[7];
  170.  
  171. Begin
  172.   Seg := 0;
  173.   Ofs := $01FC;                        { Address of Int $7F      }
  174.   Ofs1 := memw[Seg:Ofs];               { Find address of BPQcode }
  175.   Seg1 := memw[Seg:ofs+2];
  176.  
  177.   ofs1 := Ofs1 - 7;
  178.   St := '';
  179.   For I := 0 to 4 do
  180.   Begin
  181.     ofs := Ofs1 + I;
  182.     St := St + Chr(mem[Seg1:Ofs]);     { Read byte from memory }
  183.   End;
  184.  
  185.   BPQ_loaded := (St='G8BPQ');          { Does it match string }
  186.  
  187. End;
  188.  
  189. Procedure Get_Config;
  190. Begin
  191.   Assign(Cnf,'Chat.cnf');
  192.   {$I-}
  193.   Reset(Cnf);
  194.   {$I+}
  195.   If IOresult <> 0 then
  196.   Begin
  197.     WriteLn('Configuration file - CHAT.CNF not found ');
  198.     Halt;
  199.   End;
  200.  
  201.   Read(Cnf,Welcome_st);           { Read 1 line from CNF file }
  202.   Close(Cnf);
  203.  
  204. End;
  205.  
  206.  
  207. Procedure Log_data(St:String);
  208. Begin
  209.   Assign(log,'Chat.log');
  210.   {$I-}
  211.   Append(log);
  212.   {$I+}
  213.   If IOresult <> 0 then
  214.     Rewrite(log);
  215.  
  216.   Write(log,st+' '+Time+CR+LF);
  217.   Close(log);
  218.  
  219. End;
  220.  
  221. Procedure Find_name(p:Integer);
  222. Var
  223.   Match : Boolean;
  224.  
  225. Begin
  226.   Match := False;
  227.   Assign(Users,'Chatuser.dat');
  228.   {$I-}
  229.   Reset(Users);                       { See if user file exists }
  230.   {$I+}
  231.   If IOresult <> 0 then
  232.     Rewrite(Users)                     { Create a new file }
  233.   else
  234.   With Use_data do
  235.   Begin
  236.     While (not match) and (not EOF(Users)) do
  237.     Begin
  238.       Read(Users,Use_data);
  239.       Match := (User_call=Callsign[p]);
  240.     End;
  241.   End; { With Use_data }
  242.  
  243.   If (not match) then
  244.      Name[p] := 'New User'
  245.   else
  246.      Name[p] := Use_data.User_name;
  247.  
  248.   Close(Users);
  249.  
  250. End;
  251.  
  252. Procedure setup;   {read command line}
  253. var
  254.     err: integer;
  255.       i: integer;
  256.       p: integer;
  257.  
  258. begin
  259.   If (ParamCount = 0) then
  260.   Begin
  261.     Display(' You must supply the port number as a parameter ');
  262.     Halt;
  263.   End
  264.   else
  265.   Begin
  266.  
  267.     Val(Paramstr(1),i,err); If (err = 0) then Start_port := i;
  268.     Val(Paramstr(2),i,err); If (err = 0) then No_ports := i;
  269.  
  270.     If (Start_port<1) or (No_ports>9) or (Start_port+No_ports>32) then
  271.     Begin
  272.       Display('Parameter error');
  273.       ClrScr;
  274.       Halt;
  275.     end
  276.     else
  277.       Display('Using Ports '+Chr(Start_port+$30)+' to '+
  278.                              Chr(Start_port+$30+No_ports-1)+CRLF);
  279.   End;
  280.  
  281.   Callsign[10] := 'Sysop';                 { Set default sysop call }
  282.   Conf[10] := 0;
  283.  
  284.   Window(1,1,80,3);
  285.   WriteLn('   0       1       2       3        4       5       6       7',
  286.           '      8        9');
  287.  
  288.   Log_data('Initialsed');
  289.  
  290.   For I := 0 to No_ports - 1 do
  291.     Logged_In[I] := False;
  292.  
  293.   For I := 0 to No_ports - 1 do
  294.   Begin
  295.     regs.cl := 0;                   { Application mask   }
  296.     regs.dl := 16;                  { Application number }
  297.     regs.ah := $01;
  298.     regs.al := Start_port + I;
  299.     intr($7F,regs);
  300.  
  301.     Callsign[I] := ' ';               { Clear Callsign }
  302.   End;
  303.  
  304. End;
  305.  
  306. Procedure Login(n:integer);
  307. Var
  308.    I : Integer;
  309.    P : Integer;
  310.  
  311. Begin
  312.  
  313.     regs.ah := $08;               { Get callsign }
  314.     regs.al := Start_port + n;
  315.     regs.di := Ofs(BPQbuff);
  316.     regs.es := Seg(BPQbuff);
  317.     intr($7F,regs);
  318.  
  319.     Callsign[n] := '';
  320.  
  321.     I := 1;                        { Strip callsign }
  322.     While (I < 9) and (Chr(BPQbuff[I]) <> '-') and
  323.                       (Chr(BPQbuff[I]) <> ' ') do
  324.     Begin
  325.       Callsign[n] := Callsign[n] + Chr(BPQbuff[I]);
  326.       I := I + 1;
  327.     End;
  328.  
  329.     Display('Call connected '+Callsign[n]+'  Channel no. '+ chr(n+$30)+CRLF);
  330.  
  331.     Find_name(n);
  332.  
  333.     OBuffer := 'Hi ' + name[n] + ' ' + Welcome_st + CR;
  334.     Send(n);
  335.     OBuffer := '/W  will give a list of Who is on.  /H for help' + CR;
  336.     Send(n);
  337.  
  338.     OBuffer := Callsign[n] + '  ' + name[n] + ' has join the group ' + CR;
  339.  
  340.     For I := 0 to No_ports - 1 do
  341.     Begin
  342.       If Logged_in[I] then
  343.       Begin
  344.         Send(I);
  345.       End;
  346.     End;
  347.  
  348.     Logged_in[n] := True;       { Mark that user is logged in }
  349.     Conf[n] := 0;
  350.  
  351.     Log_data(Callsign[n]+' connected');
  352.  
  353.     Window(1,1,80,3);
  354.  
  355.     GotoXY(8*n+1,2); Write(Callsign[n]);
  356.     GotoXY(8*n+1,3); Write(Name[n]);
  357.  
  358.     Window(1,23,80,23);
  359.     GoToXy(Xloc,Yloc);
  360.  
  361. End;
  362.  
  363. Procedure Logout(n:integer);
  364. Var
  365.   I    : Integer;
  366.  
  367. Begin
  368.   logged_in[n] := False;
  369.   OBuffer := Callsign[n] + ' has disconnected ' + CR;
  370.  
  371.   For I := 0 to No_ports - 1 do
  372.   Begin
  373.     If Logged_in[I] then
  374.     Begin
  375.        Send(I);
  376.     End;
  377.   End;
  378.  
  379.   Log_data(Callsign[n]+' disconnected');
  380.  
  381.   Window(1,1,80,3);
  382.  
  383.   GotoXY(8*n+1,2);Write('  DISC ');
  384.   GotoXY(8*n+1,3);Write('       ');
  385.  
  386.   Window(1,23,80,23);
  387.   GoToXy(Xloc,Yloc);
  388.  
  389.   Display('Call disconnected '+Callsign[n]+'  Channel no. '+Chr(n+$30)+CRLF);
  390.  
  391. End;
  392.  
  393. { Procedure SendAll is used to send a user message to the other stations }
  394. {                   who are in his conference                            }
  395.  
  396. Procedure SendAll(n:integer);
  397. Var
  398.   I : Integer;
  399.  
  400. Begin
  401.  
  402.   OBuffer := '[' + callsign[n] + '] ' + IBuffer;
  403.                                { Send to anyone logged on who is in }
  404.                                { the same conference as sender      }
  405.   For I := 0 to No_ports - 1 do
  406.   Begin
  407.     If (Logged_in[I]) and (I <> n) then
  408.       If (Conf[n] = Conf[I]) or (n = 10) then  {send sysop msgs to all }
  409.       Begin
  410.         Send(I);
  411.       End;
  412.   End;
  413.   If conf[n] <> 0 then Write('(',Conf[n],')');  { Tell sysop the conf no. }
  414.   Display(OBuffer);              { Send to local console }
  415.  
  416. End;
  417.  
  418. { Procedure Shut_down is used to close down the node gracefully          }
  419.  
  420. Procedure Shut_down;
  421. Var
  422.   I : Integer;
  423.  
  424. Begin
  425.   For I := 0 to No_ports - 1 do
  426.   Begin
  427.     If Logged_in[I] then
  428.     Begin
  429.        IBuffer := 'Sorry .. Chat Node is closing down for a while ';
  430.        SendAll(10);                   { Use IBuffer cos of SendAll }
  431.        Delay(2000);                   { Wait for message to get there }
  432.  
  433.        regs.cx := 2;                  { Disconnect stream }
  434.        regs.ah := $06;
  435.        regs.al := Start_port + I;
  436.        intr($7F,regs);
  437.      End;
  438.   End;
  439. End;
  440.  
  441. Procedure Command(p:integer);
  442. Var
  443.   Comm_let : Char;
  444.   Sbit,Cbit: String[2];
  445.   Match    : boolean;
  446.  
  447. Begin
  448.  
  449.   Comm_let := IBuffer[2];
  450.  
  451.   Case Comm_let of
  452.  
  453.   'b','B'        : Begin
  454.                      OBuffer := 'Thank you for calling ' + name[p] + CR;
  455.                      Send(p);
  456.                      Delay(1000);
  457.  
  458.                      regs.cx := 3;
  459.                      regs.ah := $06;
  460.                      regs.al := Start_port + p;
  461.                      intr($7F,regs);
  462.                    End;
  463.  
  464.  
  465.   'c','C'        : Begin
  466.                      Val(IBuffer[4],conf[p],err);
  467.                      If (Conf[p] > 4) or (err <> 0) then
  468.                      Begin
  469.                        OBuffer := 'Error in conference number' + CR;
  470.                        Send(p);
  471.                        Conf[p] := 0;
  472.                      End
  473.                      Else
  474.                      Begin
  475.                        OBuffer := 'Conference channel has been changed' + CR;
  476.                        Send(p);
  477.                      End;
  478.                    End;
  479.  
  480.   'h','H','?': Begin
  481.                  OBuffer := 'The commands which are available are :-' + CR;
  482.                  Send(p);
  483.                  OBuffer := '/?     - To read this list' + CR;
  484.                  Send(p);
  485.                  OBuffer := '/B     - To leave the chat node' + CR;
  486.                  Send(p);
  487.                  OBuffer := '/C n   - To switch to conference stream n' + CR;
  488.                  Send(p);
  489.                  OBuffer := '/H     - To read this list' + CR;
  490.                  Send(p);
  491.                  OBuffer := '/N Yourname - To register onto the node' + CR;
  492.                  Send(p);
  493.                  OBuffer := '/Q     - To disconnect from the node completely' + CR;
  494.                  Send(p);
  495.                  OBuffer := '/W     - To find who else is connected' + CR;
  496.                  Send(p);
  497.  
  498.                End;
  499.  
  500.   'n','N' : Begin
  501.  
  502.               Assign(Users,'Chatuser.dat');
  503.               Reset(Users);
  504.               With Use_data do
  505.               Begin
  506.                 match := false;
  507.                 While (not match) and (not EOF(users)) do
  508.                 Begin
  509.                   Read(Users,Use_data);
  510.                   Match := (User_call=Callsign[p]);
  511.                 End;
  512.  
  513.                 I := Pos(#$0D,IBuffer);
  514.                 User_name := Copy(IBuffer,4,I-4);
  515.                 User_call := Callsign[p];
  516.                 Write(Users,Use_data);
  517.                 OBuffer := 'Hello ' + User_name 
  518.                                     + ' thanks for registering' + CR;
  519.                 Send(p);
  520.                 Name[p] := User_name;
  521.               End; { With Use_data }
  522.               Close(Users);
  523.             End;
  524.  
  525.    'q','Q': Begin
  526.               OBuffer := 'Thank you for calling ' + name[p] + CR;
  527.               Send(p);
  528.               Delay(1000);
  529.  
  530.               regs.cx := 2;
  531.               regs.ah := $06;
  532.               regs.al := Start_port + p;
  533.               intr($7F,regs);
  534.             End;
  535.  
  536.   'w','W' : Begin
  537.               OBuffer := 'List of current users ' + CR;
  538.               Send(p);
  539.               For I := 0 to No_ports - 1 do
  540.               Begin
  541.                 If Logged_in[I] then
  542.                 Begin
  543.                   Str(I,Sbit);
  544.                   Str(Conf[I],Cbit);
  545.                   OBuffer := Callsign[I] + '  ' + name[I] +
  546.                        ' connected on port ' + Sbit + ' to conference ' +
  547.                        Cbit + CR;
  548.                   Send(p);
  549.                 End;
  550.               End;
  551.             End;
  552.             else
  553.             Begin
  554.               OBuffer := 'Command not known';
  555.               Send(p);
  556.             End;
  557.     End;  {Case end}
  558.  
  559. End;
  560.  
  561. {***************************  Start of main  ******************************}
  562. Begin
  563.  
  564.   DirectVideo := False;             { Write to screen using BIOS calls }
  565.  
  566.   ClrScr;
  567.   xkeep := 1;
  568.   ykeep := 1;
  569.   xloc := 1;
  570.   yloc := 1;
  571.  
  572.   For I := 1 to 255 do
  573.     BPQbuff[I] := 0;
  574.  
  575.   GotoXY(1, 4); For I := 1 to 80 do Write('-');
  576.   GotoXY(1,22); For I := 1 to 80 do Write('-');
  577.   GoToXY(1,24); Write('/C - to close down node    /Q - to chop node');
  578.  
  579.   Display(' IMB Chat node'+CRLF);
  580.  
  581.   If not BPQ_loaded then
  582.   Begin
  583.     Display('Version 4 BPQ node not loaded ');
  584.     Halt;
  585.   End;
  586.  
  587.   Get_config;
  588.  
  589.   setup;
  590.  
  591.   For I := 0 to No_ports - 1 do
  592.       LogOut(I);
  593.  
  594.   Quit := false;
  595.   locbuff := '';
  596.  
  597.   Repeat
  598.     Repeat
  599.       For I := 0 to No_ports - 1 do
  600.       Begin
  601.         If (Poll(I)) then
  602.            If regs.cx <> 0 then Login(I)
  603.                            else Logout(I);
  604.  
  605.         If Get_resp(I) then
  606.            If IBuffer[1] = '/' then Command(I)
  607.                                else Sendall(I);
  608.       End;
  609.  
  610.       DV_Nice;
  611.  
  612.     Until Keypressed;
  613.  
  614.     Ch := Readkey;
  615.  
  616.     Case Ch of
  617.  
  618.     #00 : Begin     { Special keys }
  619.  
  620.           End;
  621.  
  622.     #08 : Begin
  623.             xloc := xloc - 1;
  624.             Delete(locbuff,length(locbuff),1);
  625.             GotoXY(xloc,yloc); Write(' ');
  626.             GoToXY(xloc,yloc);
  627.           End;
  628.  
  629.     #$0D : Begin
  630.              locbuff := locbuff + Ch;
  631.              xloc := 1;
  632.  
  633.              If locbuff[1] = '/' then
  634.              Begin
  635.                Case locbuff[2] of
  636.                '0'..'9' : Begin           { Send a message to just 1 station}
  637.                             p := Ord(locbuff[2]) - $30;
  638.                             Locbuff[1] := '*';
  639.                             Locbuff[2] := '>';
  640.                             OBuffer := '<* sysop '+locbuff;
  641.                             Send(p);
  642.                           End;
  643.  
  644.                'c','C'  : Begin           { Polite close down of node }
  645.                             Shut_down;
  646.                             Delay(2000);
  647.                             Quit := True;
  648.                             End;
  649.  
  650.                'q','Q'  : Quit := True;
  651.  
  652.                End;    { case }
  653.              end       { If / }
  654.              else
  655.              Begin
  656.                IBuffer := Locbuff + CRLF;    { Load it into Ibuffer to be sent out }
  657.                Sendall(10);
  658.              End;
  659.  
  660.              locbuff := '';           { Clear local buffer }
  661.            end; {#0D}
  662.       else
  663.       begin
  664.         GotoXY(xloc,yloc);Write(Ch);
  665.         locbuff := locbuff + Ch;
  666.         xloc := xloc + 1;
  667.       end;
  668.     end;  {Case}
  669.  
  670.  
  671.     xloc := WhereX;
  672.     yloc := WhereY;
  673.  
  674.   Until Quit;
  675.  
  676.   For I := 0 to No_ports - 1 do
  677.   Begin
  678.     regs.dl := $00;                  { Set application flag to 0 }
  679.     regs.ah := $01;
  680.     regs.al := Start_port + I;
  681.     intr($7F,regs);
  682.   End;
  683.  
  684. end.
  685.