home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / NETCHA / NETCHAT.PAS next >
Encoding:
Pascal/Delphi Source File  |  1988-12-01  |  8.3 KB  |  245 lines
  1. {/////////////////////////////////////////////////////////////////////////////
  2. // NETCHAT (tm) Version 1.00A                              December 1, 1988 //
  3. // Copyright 1988 by L. Brett Glass, Systems Consultant                     //
  4. //                                                                          //
  5. // This source code is copyrighted and may NOT be published in any medium   //
  6. // without the express permission of the author.                            //
  7. //                                                                          //
  8. // Please address correspondence to:                                        //
  9. // L. Brett Glass, P.O Box 817, Palo Alto, CA 94302-0817                    //
  10. //////////////////////////////////////////////////////////////////////////////}
  11.  
  12. program NetChat; {Network Conference Program}
  13.  
  14. uses CRT,Network;
  15.  
  16. const {Manifest constants}
  17.   RCVNCBS = 4;    {Number of NCBs for receive operations}
  18.   RCVBUFS = 5;    {Number of receive buffers available. There is one
  19.                    more receive buffer than there are NCBs. This allows
  20.                    a new receive to be started with a fresh buffer while
  21.                    text from a previous receive is being displayed.}
  22.  
  23. type
  24.   RcvNCBNumber = 1..RCVNCBS; {Type for receive NCB numbers}
  25.   RcvBufNumber = 1..RCVBUFS; {Type for receive buffer numbers}
  26.   StringPtr = ^String;       {Pointer to a generic string}
  27.  
  28. const {Typed constants}
  29.   chatError : Byte = GOOD_RTN; {If program ended with an error, code goes here}
  30.   NetChatName : NetName = 'NETCHAT'#0#0#0#0#0#0#0#0#0; {Group name for chat}
  31.   rcvY : Byte = 1;            {Line for next received message}
  32.   sendX : Byte = 1;           {Character position for send message}
  33.  
  34.  
  35. var
  36.   receiveNCBs : array [RcvNCBNumber] of NCB;       {NCBs for receieve commands}
  37.   receiveBuffers : array [RcvBufNumber] of String; {Buffers for received text}
  38.   freeBuffer, tempBufferPtr : StringPtr; {Pointers to receive buffers}
  39.   sendNCB : NCB; {NCB for send commands}
  40.   sendBuffer : String; {Buffer for sends}
  41.   netChatNameNum : Byte; {Number of the name NETCHAT in our name table}
  42.   userName : String[40]; {Name of user}
  43.   editString : String[79]; {Buffer for the line editor}
  44.   ch : Char; {Character buffer for the line editor}
  45.   i : RcvNCBNumber;       {Loop counter}
  46.   oldExitProc : Pointer; {Original value of exitProc}
  47.  
  48. function AddGroupName(groupName : NetName; var nameNum : Byte) : Byte;
  49.   {Add the given group name. Return the number of the name and
  50.    the result code.}
  51.   var
  52.     addNCB : NCB;
  53.   begin  {AddGroupName}
  54.   InitNCB(addNCB);
  55.   with addNCB do
  56.     begin
  57.     command := ADD_GROUP_NAME;
  58.     name := groupName;
  59.     end;
  60.   AddGroupName := NetBIOS(addNCB);
  61.   nameNum := addNCB.num
  62.   end;   {AddGroupName}
  63.  
  64. procedure DeleteName(delName : NetName);
  65.   {Delete the given name.}
  66.   var
  67.     delNCB: NCB;
  68.   begin {DeleteName}
  69.   InitNCB(delNCB);
  70.   with delNCB do
  71.     begin
  72.     command := DELETE_NAME;
  73.     name := delName
  74.     end;
  75.   CallNetBIOS(delNCB)
  76.   end;  {DeleteName}
  77.  
  78. {$F+}
  79. procedure ExitChat;
  80.   {This Turbo Pascal exit procedure "cleans up" when the program exits.}
  81.   begin {ExitChat}
  82.   repeat until sendNCB.cmd_cplt <> COMMAND_PENDING; {Wait for send}
  83.   DeleteName(netChatName); {This kills all receive commands}
  84.   Window(1,1,80,25);
  85.   GotoXY(1,25);
  86.   Writeln;
  87.   if Length(editString) > 0 then
  88.     Writeln;
  89.   if chatError <> GOOD_RTN then
  90.     Writeln(^G'NetBIOS error ',chatError)
  91.   else
  92.     begin
  93.     Writeln('Thank you for using NetChat. This program is ShareWare. You may freely');
  94.     Writeln('redistribute the executable version of this program, provided that it');
  95.     Writeln('is not altered in any way. The license fee is $10 per network station');
  96.     Writeln('that runs the program.');
  97.     Writeln;
  98.     Writeln('Please address correspondence to:');
  99.     Writeln('L. Brett Glass, P.O Box 817, Palo Alto, CA 94302-0817')
  100.     end;
  101.   exitProc := oldExitProc
  102.   end;  {ExitChat}
  103. {$F-}
  104.  
  105. begin {NetChat}
  106. checkBreak := FALSE;  {Disable CRT unit break checking}
  107. Writeln('NETCHAT (tm) V1.00A, Copyright L. Brett Glass 1988');
  108. Write('Please enter your name: '); {Ask for name for attribution purposes}
  109. Readln(userName);
  110. if Length(userName) = 0 then {Let user back out by typing null string}
  111.   Halt;
  112. if Length(userName) > 38 then {If name too long, truncate it}
  113.   userName[0] := #38;
  114. userName := userName + ': '; {Add a colon and a space, just to be neat}
  115. {Clear the string that holds the user's message as it's being edited}
  116. editString := '';
  117. {Check for presence of a network}
  118. if not NetPresent then
  119.   begin
  120.   Writeln('Network or NetBIOS not installed.');
  121.   Halt
  122.   end;
  123. {Try to add the group name 'NETCHAT'}
  124. chatError := AddGroupName(netChatName,netChatNameNum);
  125. if chatError <> GOOD_RTN then
  126.   begin
  127.   Writeln('NetBIOS error ', chatError, ' adding group name; program aborting.');
  128.   Halt
  129.   end;
  130. {Set up a procedure to clean up when program exits}
  131. oldExitProc := exitProc;
  132. exitProc := @ExitChat;
  133. {Prepare the screen}
  134. ClrScr;
  135. GoToXY(1,24);
  136. Write('╠═ NETCHAT (tm) ══ Copyright 1988 L. Brett Glass'+
  137.       ' ══ Enter to send, ^C to Exit ═╣');
  138. Window(1,25,80,25);
  139. {Initialize all the receive NCBs we'll use}
  140. for i := 1 to RCVNCBS do
  141.   begin
  142.   InitNCB(receiveNCBs[i]);
  143.   with receiveNCBs[i] do
  144.     begin
  145.     command := RECEIVE_DATAGRAM_NO_WAIT;
  146.     bufPtr := @receiveBuffers[i];
  147.     len := SizeOf(String);
  148.     num := netChatNameNum
  149.     end
  150.   end;
  151. freeBuffer := @receiveBuffers[RCVBUFS]; {Extra buffer is free at the start}
  152. {Prepare the send NCB}
  153. InitNCB (sendNCB);
  154. with sendNCB do
  155.   begin
  156.   command := SEND_DATAGRAM_NO_WAIT;
  157.   bufPtr := @sendBuffer;
  158.   callName.name := netChatName;
  159.   num := netChatNameNum
  160.   end;
  161. {Start a receive command for each receive NCB}
  162. for i := 1 to RCVNCBS do
  163.   begin
  164.   case NetBIOS(receiveNCBs[i]) of
  165.     GOOD_RTN, COMMAND_PENDING: ; {These codes are OK}
  166.   else
  167.     chatError := receiveNCBs[i].retCode;
  168.     Halt
  169.     end
  170.   end;
  171. {Main loop}
  172. repeat
  173.   if KeyPressed then
  174.     begin
  175.     ch := ReadKey;
  176.     case ch of
  177.       ^C : Halt; {Exit program}
  178.       ^H : {Backspace}
  179.         if Length(editString) > 0 then
  180.           begin
  181.           Write(^H' '^H);
  182.           Dec(editString[0])
  183.           end;
  184.       ^M : {Send the string}
  185.         with sendNCB do
  186.           begin
  187.           repeat until cmd_cplt <> COMMAND_PENDING; {Wait for prev send}
  188.           if cmd_cplt <> GOOD_RTN then
  189.             begin
  190.             chatError := cmd_cplt;
  191.             Halt
  192.             end;
  193.           sendBuffer := userName + editString; {Add attribution}
  194.           len := Succ(Length(sendBuffer)); {Size the datagram}
  195.           case NetBIOS(sendNCB) of
  196.             GOOD_RTN, COMMAND_PENDING:; {These codes OK}
  197.           else
  198.             chatError := retCode;
  199.             Halt
  200.             end;
  201.           editString := '';
  202.           ClrScr {Clear the bottom one-line window}
  203.           end;
  204.       #0: ch := ReadKey;    {Ignore function keys}
  205.       #1..#31,#127,#255:;   {and non-printing characters}
  206.     else
  207.       {Check for full line. Add character if there is room}
  208.       if Length(editString) < Pred(SizeOf(editString)) then
  209.         begin
  210.         editString := editString + ch;
  211.         Write(ch)
  212.         end
  213.       end
  214.     end;
  215.   for i := 1 to RCVNCBS do
  216.     with receiveNCBs[i] do
  217.       case cmd_cplt of
  218.         COMMAND_PENDING:; {Do nothing; no message came in for this NCB}
  219.         GOOD_RTN: {Display a message from the network}
  220.           begin
  221.           tempBufferPtr := bufPtr; {Get msg address}
  222.           bufPtr := freeBuffer;    {Find the free buffer}
  223.           len := SizeOf(String);   {Set buffer length field back to max length}
  224.           case NetBIOS(receiveNCBs[i]) of {Immediately start another receive}
  225.             GOOD_RTN, COMMAND_PENDING:; {These codes OK}
  226.           else
  227.             chatError := retCode;
  228.             Halt
  229.             end;
  230.           sendX := WhereX;   {Save location on bottom line}
  231.           Window(1,1,80,23); {Move to the upper window and position cursor}
  232.           GoToXY(1,rcvY);
  233.           Write(^M^J,tempBufferPtr^); {Write the message}
  234.           rcvY := WhereY;    {Go back to the botton line}
  235.           Window(1,25,80,25);
  236.           GoToXY(sendX,1);
  237.           freeBuffer := tempBufferPtr;
  238.           end
  239.       else
  240.         chatError := cmd_cplt;
  241.         Halt
  242.         end
  243.   until FALSE
  244. end.  {NetChat}
  245.