home *** CD-ROM | disk | FTP | other *** search
/ ftp.wwiv.com / ftp.wwiv.com.zip / ftp.wwiv.com / pub / DOOR / DDPLUS67.ZIP / DDPLUS.PAS < prev    next >
Pascal/Delphi Source File  |  1994-11-21  |  34KB  |  1,296 lines
  1.  
  2. unit DDPlus;
  3. {$V-,F+}
  4.  
  5.  
  6. interface
  7. uses dos, crt, comio, ddscott, ddansi2, ddovr, ddovr2;
  8. type
  9.  CharOriginType=(localchar,remotechar);
  10.  strptr=^string;
  11. const
  12.  version= 'Version 6.6  ; 11-18-94';
  13.  
  14. { Changes: blame on Steve Lorenz                                             }
  15. { This program is a 'stripped' down version doordiver.  Most sysop things    }
  16. { and Term program flags have been eliminated. What has been enhanced are    }
  17. { the communication routines.                                                }
  18. { Documentation  What Documentation?  See Doordrivers docs or read the code. }
  19. { Here is a list of most of the additions:                                   }
  20. { Ansi color efficiency checking                                             }
  21. { IRQs 0-15 support                                                          }
  22. { Selectable Port Addresses                                                  }
  23. { DESQview support                                                           }
  24. { PCBoard 15 support                                                         }
  25. { Rip Detect or found on WC3.9+ or PCB15 dropfiles                           }
  26. { TriBBS dropfile support  (untested)                                        }
  27. { RBBS vs Super BBS Dorinfo types supported                                  }
  28. { CTS/RTS flow checking    (Not well documented but it works)                }
  29. { carrier detect on output                                                   }
  30. { lock baud and comm baud rates to 115,200                                   }
  31. { Windows,WindowsNT,OS/2,DOS 5.0+ time slice releasing.                      }
  32. { A Dos,Win, DV pause is taken after so many read cycles in read loop        }
  33. { fossil support to 38,400 using normal fossil calls.                        }
  34. { fossil support to 115,200 using X00 extended fossil calls.                 }
  35. { 6.1                                                                        }
  36. { Added mixture of tasker pause and loop cycles in Ripdetect and read char   }
  37. { to give a smoother response.                                               }
  38. { 6.2                                                                        }
  39. { Missed Done Routine in 6.1  - now doesn't close if local or Extd_Foss_OK       }
  40. { but buffered flag is set to true.                                          }
  41. { There was a file being written to when door timed out.  Some OS2 systems   }
  42. { complained of endless pages being written to their disk.  I'm taking this  }
  43. { out this version.  So if you have a use for it save it and put it back in. }
  44. {6.3                                                                         }
  45. { Wrong-O I guess a lot of you are using this file so I'm putting it back in.}
  46. { I guess only my versions will leave it out.                                }
  47. { Added /C to specify comport on command line.  Dropfile comport number will }
  48. { override this option.                                                      }
  49. {6.4                                                                         }
  50. { Cleaned up the multi-tasker routines to allow easier flag passage to other }
  51. { units. Added SpeedRead which can be used in other units for a timed input  }
  52. { response loop.                                                             }
  53. { Fixed deintializing wrong port in fossil                                   }
  54. { Now finds higher than 32000 speeds for WW4 and PCBoard dropfiles           }
  55. {6.5-6.6                                                                     }
  56. { Purges fossil buffer upon initialization for XFOSSIL only.  Added /V no    }
  57. { local vidio.  Colors the local screen to statback color when implemented.  }
  58. { select ctl file base on /Mx parm                                          }
  59.  
  60.  progname: string[60] = 'DDPlus 6.6 Door Game';
  61.  graphics_codes: array[1..4] of string[4] = ('','.ASC','.ANS','.MUS');
  62.  ack=#6;
  63.  nak=#21;
  64.  sot=#1;
  65. var
  66.  mintime: byte;                     {Minimum time left before user kicked off}
  67.  notime: string;                    {Out of time filename                    }
  68.  macro,macro_str: string;           {Used in the macro routines              }
  69.  node_num: byte;                    {Node number                             }
  70.  time_credit: integer;              {Time credit +/- (arrow keys)            }
  71.  CharOrigin: CharOrigInType;        {Where character came from               }
  72.  fouled_up: char;                   {Internal use                            }
  73.  localcol: boolean;                 {From .CTL file: Local color enabled     }
  74.  ansion: boolean;                   {Process ANSI locally                    }
  75.  time_check: boolean;               {Check time left - halt if < mintime     }
  76.  curlinenum: integer;               {current line num - used by <more>       }
  77.  stacked: string;                   {used internally - stacked commands      }
  78.  current_foreground: byte;          {current foreground color                }
  79.  current_background: byte;          {current background color                }
  80.  color_chg: boolean;                {send ANSI color change sequences?       }
  81.  default_fore: byte;                {default foreground color                }
  82.  default_back: byte;                {default background color                }
  83.  cdropped: boolean;                 {carrier dropped?                        }
  84.  bbs_time_left: integer;            {from DROP FILE: time left               }
  85.  com_port: byte;                    {from DROP FILE: com port                }
  86.  bbs_software: byte;                {from .CTL file: bbs type                }
  87.  baud_rate: longint;                {from DROP FILE: baud rate               }
  88.  statfore,statback: byte;           {status line foreground                  }
  89.  statline: boolean;                 {status line background                  }
  90.  graphics: byte;                    {from DROP FILE: graphics code           }
  91.  local: boolean;                    {from DROP FILE: local mode              }
  92.  user_number: word;           {from DROP FILE: user's access level     }
  93.  user_first_name: string[30];       {from DROP FILE: user's first name       }
  94.  user_last_name: string[30];        {from DROP FILE: user's last name        }
  95.  sysop_first_name: string[30];      {from .CTL file: sysop's first name      }
  96.  sysop_last_name: string[30];       {from .CTL file: sysop's last name       }
  97.  board_name: string[70];            {from .CTL file: board name              }
  98.  Pause_Code : string;
  99.  st_hr, st_mn, st_sc: word;         {used by timer calculations              }
  100.  color1: boolean;                   {from .CTL file: color1 mode             }
  101.  ESMOK : boolean;                   {/ESM use esm memory                     }
  102.  NetOK : boolean;                   {A Dos only network is present           }
  103.  NoLocal : boolean;                 { Local echo turned off (statback)       }
  104.  stackon: boolean;                  {process stacked commands?               }
  105.  badchar: string;                   {internal use                            }
  106.  fossilIO: boolean;                 {from .CTL file: fossil I/O used         }
  107.  maxtime: word;                     {from .CTL file: maximum time in door    }
  108.  user_access_level: word;
  109.  numlines: byte;                    {from .CTL file: number of lines/screen  }
  110.  oldtextmode: word;                 {original text mode                      }
  111.  GoRip      : byte;                 { enables force RIP }
  112.  lastsetfore: byte;                 {last set_foreground color               }
  113.  setforecheck: boolean;             {check repetetive set_foreground calls?  }
  114.  dropfilepath: string;              {from parm list                          }
  115.  cc          : integer;             { read cycle counter                     }
  116.  
  117.  soutput: text;                     {Simultanious output file                }
  118.  
  119.  proc_call_ptr: pointer;            {used internally                         }
  120.  nodirect: boolean;
  121.  lockbaud: longint;                 {lock baud rate                          }
  122.  com1,com2,com3,com4 : byte;        { temporary non-std comports             }
  123.  port1,port2,port3,port4:word;
  124.  irq1,irq2,irq3,irq4 : byte;
  125.  
  126. Procedure Displayfile(filen: string);
  127. Procedure DV_Aware_On;
  128. Procedure DV_Pause;
  129. Procedure Win_Pause;
  130. Procedure ReleaseTimeSlice;
  131. procedure close_async_port;
  132. procedure open_async_port;
  133. function  skeypressed: boolean;
  134. procedure sendtext(s: string);
  135. procedure sgoto_xy(x,y: integer);
  136. procedure sclrscr;
  137. procedure sclreol;
  138. procedure swrite(s: string);
  139. procedure swritec(ch: char);
  140. procedure swriteln(s: string);
  141. procedure sread_char(var ch: char);
  142. procedure sread(var s: string);
  143. procedure sread_num(var n: integer);
  144. procedure sread_num_byte(var b: byte);
  145. procedure sread_num_longint(var n: longint);
  146. Procedure speedread(var ch : char);
  147. function time_left: integer;
  148. procedure set_foreground(f: byte);
  149. procedure set_background(b: byte);
  150. procedure set_color(f,b: byte);
  151. procedure prompt(var s: string; le: integer; pc: boolean);
  152. Procedure elapsed(time1_hour, time1_min, time1_sec, time2_hour, time2_min,
  153.                   time2_sec: longint; var elap_hour, elap_min, elap_sec: word);
  154. procedure get_stacked(var s: string);
  155. procedure sread_char_filtered(var ch: char);
  156. procedure display_status;
  157. procedure DDAssignSoutput(var f: text);
  158. procedure InitDoorDriver(ConfigFileName: string);
  159. function Time_used: integer;
  160.  
  161. Implementation
  162. {$L DVAWARE.OBJ}
  163.  
  164. Procedure DV_Aware_On;       External;
  165. Procedure DV_Pause;          External;
  166.  
  167. var
  168.  buffered: boolean;
  169.  exitsave: pointer;
  170.  tcolor,bcolor: integer;
  171.  firsttime: boolean;
  172.  
  173. { This releases the virtual machine time slice for MSwindows, Dos 5.0, OS/2 }
  174.  
  175. procedure Win_Pause;
  176. var
  177.  Regs : Registers;
  178. begin
  179.  with Regs do
  180.  begin
  181.    Ax := $1680;
  182.    Intr($2F,Regs);
  183.  end;
  184. end;
  185.  
  186. Procedure ReleaseTimeSlice;
  187. var
  188.   A,B,C,D : word;
  189. begin
  190.   Case Tasker of
  191.     1    : DV_Pause;
  192.     2..5 : Win_Pause;
  193.   else
  194.     GetTime(A,B,C,D);
  195.   end;
  196. end;
  197.  
  198. Procedure DropMessage;
  199. begin;
  200.    writeln;
  201.    writeln('Carrier Dropped, returning to BBS.');
  202.    cdropped:=true;
  203.    halt;
  204. end;
  205.  
  206. procedure BlankScreenMessage;
  207. begin
  208.   gotoxy (trunc((80-length(progname))/2),10);
  209.   write(progname);
  210.   gotoxy (26,12);
  211.   write('Local screen mode turned off.');
  212.   gotoxy (1,1);
  213. end;
  214.  
  215. procedure textcolor(i: byte);
  216. begin;
  217.  if localcol then crt.textcolor(i);
  218.  tcolor:=i;
  219. end;
  220.  
  221. procedure textbackground(i: byte);
  222. begin;
  223.  if localcol then crt.textbackground(i);
  224.  bcolor:=i;
  225. end;
  226.  
  227. procedure elapsed(time1_hour, time1_min, time1_sec, time2_hour, time2_min,
  228.                   time2_sec: longint; var elap_hour, elap_min, elap_sec: word);
  229. var
  230.  a,b,c: longint;
  231. begin;
  232.  if time1_hour<time2_hour then time1_hour:=time1_hour+24;
  233.  a:=(time1_hour*3600)+(time1_min*60)+time1_sec;
  234.  b:=(time2_hour*3600)+(time2_min*60)+time2_sec;
  235.  c:=a-b;
  236.  if c>=3600 then elap_hour:=c div 3600 else elap_hour:=0;
  237.  c:=c-((c div 3600)*3600);
  238.  if c>=60 then elap_min:=c div 60 else elap_min:=0;
  239.  c:=c-((c div 60)*60);
  240.  elap_sec:=c;
  241. end;
  242.  
  243. function time_left: integer;
  244. var
  245.  hour, minute, second, sec100: word;
  246.  el_hr, el_mn, el_sc: word;
  247. begin;
  248.  gettime(hour, minute, second, sec100);
  249.  elapsed(hour, minute, second, st_hr, st_mn, st_sc, el_hr, el_mn, el_sc);
  250.  time_left:=time_credit+(bbs_time_left-((el_hr*60)+el_mn));
  251. end;
  252.  
  253. function time_used: integer;
  254. var
  255.  hour, minute, second, sec100: word;
  256.  el_hr, el_mn, el_sc: word;
  257. begin;
  258.  gettime(hour, minute, second, sec100);
  259.  elapsed(hour, minute, second, st_hr, st_mn, st_sc, el_hr, el_mn, el_sc);
  260.  time_used:=(el_hr*60)+el_mn;
  261. end;
  262.  
  263. procedure displayfile(filen: string);
  264. var
  265.  f: text;
  266.  a: string[255];
  267.  g, counter,b: integer;
  268.  c,quit,nonstop: boolean;
  269.  k,ch: char;
  270.  ansisave,moresave: boolean;
  271.  ofm: byte;
  272. begin;
  273.  ofm:=filemode;
  274.  filemode:=64;
  275.  {moresave:=morechk;}
  276.  ansisave:=ansion;
  277.  {morechk:=false;}
  278.  ansion:=true;
  279.  nonstop:=false;
  280.  quit:=false;
  281.  counter:=1;
  282.  c:=false;
  283.  g:=graphics;
  284.  k:=' ';
  285.  assign(f,'ERROR');
  286.  if pos('.',filen)<>0 then assign(f,filen) else begin;
  287.   while (g>=0) and (not c) do begin;
  288.    if exist(filen+graphics_codes[g]) then begin;
  289.     if (g=2) or (g=3) then nonstop:=true;
  290.     assign(f,filen+graphics_codes[g]);
  291.     c:=true;
  292.    end;
  293.    g:=g-1;
  294.   end;
  295.  end;
  296.  {$I-}
  297.  filemode:=66;
  298.  reset(f);
  299.  filemode:=2;
  300.  {$I+}
  301.  if ioresult<>0 then begin;
  302.   swriteln('File '+filen+' missing - please inform sysop');
  303.   {morechk:=moresave;}
  304.   ansion:=ansisave;
  305.   filemode:=ofm;
  306.   exit;
  307.  end;
  308.  while (not eof(f)) and (not quit) do begin;
  309.   if ch=#10 then counter:=counter+1;
  310.   if (counter=24) and (not nonstop) then begin;
  311.    counter:=1;
  312.    swrite('Continue,Stop,Non-stop ? ');
  313.    sread_char(ch);
  314.    for b:=1 to 26 do swrite(chr(8));
  315.    clreol;
  316.    if ch in ['S','s'] then Quit:=true;
  317.    if ch in ['N','n'] then nonstop:=true;
  318.   end;
  319.   read(f,ch);
  320.   if skeypressed then sread_char(k);
  321.   if k=^S then sread_char(k);
  322.   if (k=^k) or (k=^c) then begin;
  323.    close(f);
  324.    AsyncPurgeOutput;
  325.    swriteln('');
  326.    {morechk:=moresave;}
  327.    ansion:=ansisave;
  328.    filemode:=ofm;
  329.    exit;
  330.   end;
  331.   if not quit then swrite(ch);
  332.  end;
  333.  close(f);
  334.  {morechk:=moresave;}
  335.  ansion:=ansisave;
  336.  set_foreground(default_fore);
  337.  filemode:=ofm;
  338. end;
  339.  
  340. procedure display_status;
  341. var
  342.  a,b: integer;
  343.  c,d: word;
  344.  x,y: integer;
  345.  hour, minute, second, sec100, el_mn, el_hr, el_sc: word;
  346. begin;
  347.  x:=wherex;
  348.  y:=wherey;
  349.  cursoroff;
  350.  window(1,1,80,numlines);
  351.  a:=tcolor;
  352.  b:=bcolor;
  353.  textcolor(statfore);
  354.  textbackground(statback);
  355.  if firsttime then begin;
  356.   gotoxy(1,numlines);
  357.   clreol;
  358.   write(user_first_name+' '+user_last_name);
  359.   gotoxy(40-(length(progname+' - Node '+va(node_num)) div 2),numlines);
  360.   write(progname+' - Node '+va(node_num));
  361.   firsttime:=false;
  362.  end;
  363.  gettime(hour,minute,second,sec100);
  364.  elapsed(hour,minute,second,st_hr,st_mn,st_sc,el_hr,el_mn,el_sc);
  365.  c:=(bbs_time_left-1)+time_credit;
  366.  c:=c-((el_hr*60)+el_mn);
  367.  d:=60-el_sc;
  368.  gotoxy(70,numlines);
  369.  write(c,':',d,'   ');
  370.  if (time_left<mintime) and (time_check) then begin;
  371.   cursoron;
  372.   if notime<>'' then swriteln('(*** Time limit exceeded ***)');
  373.   swriteln('');
  374.   halt;
  375.  end;
  376.  textcolor(a);
  377.  textbackground(b);
  378.  window(1,1,80,numlines-1);
  379.  gotoxy(x,y);
  380.  If Not NoLocal then cursoron;
  381. end;
  382.  
  383. procedure SendText(s: string);
  384. var
  385.  a: integer;
  386. begin;
  387.  If (Not AsyncCarrierPresent) then DropMessage;
  388.  for a:=1 to length(s) do AsyncSendChar(s[a]);
  389. end;
  390.  
  391. procedure CharOut(ch: char);
  392. begin;
  393.  AsyncSendChar(ch);
  394. end;
  395.  
  396. function charin(var ch: char): boolean;
  397. begin;
  398.  if badchar<>'' then
  399.    begin;
  400.      ch:=badchar[1];
  401.      delete(badchar,1,1);
  402.      charin:=true;
  403.    end
  404.  else
  405.   if AsyncCharPresent then
  406.      begin;
  407.        AsyncReceiveChar(ch);
  408.        charin:=true;
  409.      end
  410.  else charin:=false;
  411. end;
  412.  
  413. procedure CloseDown;
  414. begin;
  415.   if buffered then
  416.      AsyncFlushOutput;
  417.   If Not Extd_Foss_OK then
  418.      AsyncCloseCom(com_port);
  419.   buffered := false;
  420. end;
  421.  
  422. procedure sclrscr;
  423. begin
  424.  if not local then sendtext(#27'[2J');
  425.  If NoLocal then
  426.    begin
  427.      TextColor(statfore);
  428.      TextBackGround(statback);
  429.    end;
  430.  
  431.  clrscr;
  432.  If NoLocal then BlankScreenMessage;
  433.  curlinenum:=1;
  434.  lastsetfore:=99;
  435. end;
  436.  
  437. procedure sclreol;
  438. begin;
  439.  if not local then sendtext(#27'[K');
  440.  clreol;
  441. end;
  442.  
  443. procedure swritec(ch: char);
  444. begin;
  445.  if not local then
  446.    AsyncSendChar(ch);
  447.  if NoLocal then
  448.     begin
  449.       gotoxy(Wherex+1,Wherey);
  450.       exit;
  451.     end;
  452.  if ansion then
  453.     ansi_write(ch)
  454.   else
  455.     write(ch);
  456. end;
  457.  
  458. procedure swrite(s: string);
  459. begin;
  460.  if hexon then hexfilt(s);
  461.  if not local then sendtext(s);
  462.  if NoLocal then
  463.   begin
  464.     GotoXY(wherex+length(s),wherey);
  465.     exit;
  466.   end;
  467.  
  468.  if ansion then
  469.      ansi_write_str(s)
  470.  else
  471.     write(s);
  472. end;
  473.  
  474. procedure swriteln(s: string);
  475. begin;
  476.  if hexon then hexfilt(s);
  477.  if not local then sendtext(s+#13+#10);
  478.  if NoLocal then
  479.   begin
  480.     GotoXY(wherex+length(s),wherey);
  481.     writeln;
  482.     exit;
  483.   end;
  484.  
  485.  if ansion then
  486.    begin
  487.      s:=s+#13+#10;
  488.      ansi_write_str(s);
  489.    end
  490.  else
  491.    writeln(s);
  492. end;
  493.  
  494. procedure DDexit;
  495. begin;
  496.  If not local then CloseDown;
  497.  if lastmode<>oldtextmode then textmode(oldtextmode);
  498.  cursoron;
  499.  { This should fix the problem OS/2 serial IO drivers are having exiting. }
  500.  exitproc:=exitsave;
  501. end;
  502.  
  503. Procedure CallProc;
  504. inline($FF/$1E/Proc_Call_Ptr);
  505.  
  506. procedure sread_ch(var c: char);
  507. var
  508.  a: char;
  509.  i : integer;
  510. begin;
  511.  cc:=0;
  512.  a:=chr(0);
  513.  charorigin:=localchar;
  514.  repeat;
  515.  
  516.   if not local then
  517.     begin
  518.       If (Not AsyncCarrierPresent) then DropMessage;
  519.       if charin(a) then charorigin:=remotechar;
  520.     end;
  521.  
  522.   if keypressed then
  523.     begin;
  524.        a:=readkey;
  525.        if (a=#0) and (keypressed) then
  526.         begin;
  527.           a:=readkey;
  528.         end;
  529.      end;
  530.  
  531.   If a = chr(0) then
  532.     If cc mod 100 = 99 then
  533.       ReleaseTimeSlice;
  534.  
  535.   inc(cc);
  536.   if statline then
  537.     begin;
  538.        if cc=1 then display_status;
  539.        if cc>1000 then cc:=0;
  540.     end;
  541.  until a<>chr(0);
  542.  c:=a;
  543. end;
  544.  
  545. procedure sread_char(var ch: char);
  546. var
  547.  ch1,ch2: char;
  548. begin;
  549.  curlinenum:=1;
  550.  repeat;
  551.   if macro<>'' then
  552.     begin;
  553.       ch:=macro[1];
  554.       delete(macro,1,1);
  555.     end
  556.   else
  557.     repeat;
  558.     ch:=#0;
  559.     if fouled_up<>#0 then
  560.       begin;
  561.         ch:=fouled_up;
  562.         fouled_up:=#0;
  563.       end
  564.     else
  565.       begin;
  566.         sread_ch(ch1);
  567.         if ch1=^N then
  568.           begin;
  569.             ch1:=#1;
  570.             macro:=macro_str;
  571.           end;
  572.         delay(20);
  573.         if (ch1=#27) and skeypressed then
  574.           begin;
  575.             sread_ch(ch2);
  576.             if ch2='[' then
  577.               begin;
  578.                 sread_ch(ch2);
  579.                 if (ch2 in ['1'..'9']) and (skeypressed) then
  580.                   sread_ch(ch2);
  581.                 case ch2 of
  582.                    'A' : ch:=^E;
  583.                    'B' : ch:=^X;
  584.                    'C' : ch:=^D;
  585.                    'D' : ch:=^S;
  586.                 end;
  587.               end
  588.             else
  589.               begin;
  590.                 ch:=ch1;
  591.                 fouled_up:=ch2;
  592.               end;
  593.            end
  594.          else
  595.            ch:=ch1;
  596.         end;
  597.   until ch<>#0;
  598.  until ch<>#1;
  599. end;
  600.  
  601. procedure sread_char_filtered(var ch: char);
  602. begin;
  603.  sread_char(ch);
  604.  if ch in [#1..#7,#10..#12,#14..#31,#127..#255] then ch:='.';
  605. end;
  606.  
  607. procedure get_stacked(var s: string);
  608. var
  609.  s2: string;
  610.  a: integer;
  611.  b: boolean;
  612. begin;
  613.  s:='';
  614.  s2:='';
  615.  b:=false;
  616.  if length(stacked)=0 then begin;
  617.   s:='';
  618.   exit;
  619.  end;
  620.  for a:=1 to length(stacked) do begin;
  621.   if stacked[a]=';' then b:=true else if not b then s:=s+stacked[a];
  622.   if b then s2:=s2+stacked[a];
  623.  end;
  624.  if length(s2)>=1 then delete(s2,1,1);
  625.  stacked:=s2;
  626. end;
  627.  
  628. procedure sread(var s: string);
  629. var
  630.  ch: char;
  631.  hexsave: boolean;
  632. begin;
  633.  hexsave:=hexon;
  634.  hexon:=false;
  635.  curlinenum:=1;
  636.  s:='';
  637.  get_stacked(s);
  638.  if s<>'' then swrite(s) else begin;
  639.   repeat;
  640.    sread_char_filtered(ch);
  641.    if (ch<>#8) and (ch<>^M) then begin;
  642.     s:=s+ch;
  643.     swrite(ch);
  644.    end;
  645.    if (ch=chr(8)) and (length(s)>0) then begin;
  646.     delete(s,length(s),1);
  647.     swrite(chr(8)+' '+chr(8));
  648.    end;
  649.   until (ch=^M);
  650.   if (pos(';',s)<>0) and (stackon) then begin;
  651.    stacked:=s;
  652.    get_stacked(s);
  653.   end;
  654.  end;
  655.  swriteln('');
  656.  hexon:=hexsave;
  657.  if hexon then hextodec(s);
  658. end;
  659.  
  660. procedure sread_num(var n: integer);
  661. var
  662.  x,y,code: integer;
  663.  s: string;
  664.  ch: char;
  665. begin;
  666.  sread(s);
  667.  val(s,n,x);
  668. end;
  669.  
  670. procedure sread_num_byte(var b: byte);
  671. var
  672.  x,y,code: integer;
  673.  s: string;
  674.  ch: char;
  675. begin;
  676.  sread(s);
  677.  val(s,b,x);
  678. end;
  679.  
  680. procedure sread_num_longint(var n: longint);
  681. var
  682.  x,y,code: integer;
  683.  s: string;
  684.  ch: char;
  685. begin;
  686.  sread(s);
  687.  val(s,n,x);
  688. end;
  689.  
  690.  { Speed read is a one time read of the comport.  What I have used it for }
  691.  { is part of another routine that reads for a number of seconds.  Here   }
  692.  { the caller must enter all his commands or info in that time allotment. }
  693.  { They cannot delay a multi-node game by not inputting a command.        }
  694.  
  695. Procedure SpeedRead(var ch : char);
  696. var
  697.   a : char;
  698. begin
  699.   inc(cc);
  700.   if statline then
  701.     begin;
  702.        if cc=1 then display_status;
  703.        if cc>1000 then cc:=0;
  704.     end;
  705.  
  706.   ch := chr(0);
  707.   a := chr(0);
  708.   If local then
  709.     begin
  710.       If KeyPressed then
  711.          a :=readkey;
  712.       If a <> chr(0) then
  713.          ch := a
  714.       else
  715.       If cc mod 100 = 99 then
  716.          ReleaseTimeSlice;
  717.       exit;
  718.     end;
  719.  
  720.   charorigin:=localchar;
  721.   If (Not AsyncCarrierPresent) then DropMessage;
  722.  
  723.   if charin(a) then
  724.     charorigin:=remotechar;
  725.  
  726.  
  727.   if (a<>chr(0)) then
  728.     ch := a
  729.   else
  730.   If cc mod 100 = 99 then
  731.    ReleaseTimeSlice;
  732. end;
  733.  
  734. function va(i: integer): string;
  735. var
  736.  s: string;
  737. begin;
  738.  str(i,s);
  739.  va:=s;
  740. end;
  741.  
  742. procedure set_foreground;  { f : byte }
  743. const
  744.   colorf: array[0..7] of integer = (30,34,32,36,31,35,33,37);
  745.   colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
  746. var
  747.  s,sb : string;
  748. begin;
  749.  if f > 31 then exit;
  750.  if (f = current_foreground) then exit;
  751.  if Not NoLocal then textcolor(f);
  752.  
  753.  if not local then
  754.    begin
  755.    if (f=7) and (current_background=0) then
  756.        sendtext(#27+'[0m')
  757.    else
  758.    begin
  759.    If current_background = 0 then
  760.      sb := ''
  761.    else
  762.      sb := ';'+va(colorb[current_background]);
  763.    case f of
  764.      0..7  :  begin
  765.                 s := va(colorf[f]);
  766.                 case current_foreground of
  767.                 { 0..7  : s := s;  }
  768.                   8..31 : s := '0;'+s+sb;
  769.                end;
  770.             end;
  771.      8..15 : begin
  772.                s := va(colorf[f-8]);
  773.                case current_foreground of
  774.                   0..7  : s := '1;'+s;
  775.               {   8..15 : s := s; }
  776.                  16..31 : s := '0;1;'+s+sb;
  777.                end;
  778.              end;
  779.     16..23 : begin
  780.                s := va(colorf[f-16]);
  781.                case current_foreground of
  782.                   0..7  : s := '5;'+s;
  783.                   8..15,
  784.                { 16..23 : s := s; }
  785.                  24..31 : s := '0;5;'+s+sb;
  786.                end;
  787.             end;
  788.     24..31 : begin
  789.                s := va(colorf[f-24]);
  790.                 case current_foreground of
  791.                   0..7  : s := '1;5;'+s;
  792.                   8..15 : s := '5;'+s;
  793.                  16..23 : s := '1;'+s;
  794.               {  24..31 : s := s; }
  795.                 end;
  796.             end;
  797.      end;
  798.        sendtext(#27+'['+s+'m');
  799.     end;
  800.   end;
  801.   current_foreground:=f;
  802. end;
  803.  
  804. procedure set_background;  { b : byte }
  805. const
  806.  colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
  807. begin;
  808.  if b > 7 then exit;
  809.  if (b = current_background) then exit;
  810.  if Not NoLocal then textbackground(b);
  811.  current_background:=b;
  812.  if not local then
  813.     if (current_foreground=7) and (b=0) then
  814.        sendtext(#27+'[0m')
  815.     else
  816.        sendtext(#27+'['+va(colorb[b])+'m');
  817. end;
  818.  
  819. Procedure Set_Color;     { f,b : byte }
  820. const
  821.   colorf: array[0..7] of integer = (30,34,32,36,31,35,33,37);
  822.   colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
  823. var
  824.  f1:byte;
  825.  s:string;
  826.  NoBackG_Ok : boolean;
  827. begin
  828.  if (f>31) or (b>7) then exit;
  829.  if (f=current_foreground) and (b=current_background) then exit;
  830.  if (f<>current_foreground) and (b<>current_background) then
  831.     begin
  832.       if Not NoLocal then
  833.         begin
  834.           textcolor(f);
  835.           textbackground(b);
  836.         end;
  837.       If not local then
  838.          If (f=7) and (b=0) then
  839.             sendtext(#27+'[0m')
  840.          else
  841.          begin
  842.           s := '[';
  843.           NoBackG_OK := false;
  844.           case f of
  845.             0..7  : begin
  846.                       f1:=f;
  847.                       case current_foreground of
  848.                       { 0..7  : s := s;  }
  849.                         8..31 : begin
  850.                                   s := s+'0;';
  851.                                   NoBackG_OK := true;
  852.                                 end;
  853.                       end;
  854.                     end;
  855.             8..15 : begin
  856.                       f1:=f-8;
  857.                       case current_foreground of
  858.                         0..7  : s := s+'1;';
  859.                     {   8..15 : s := s; }
  860.                        16..31 : begin
  861.                                   s := s+'0;1;';
  862.                                   NoBackG_OK := true;
  863.                                 end;
  864.                       end;
  865.                     end;
  866.            16..23 : begin
  867.                       f1:=f-16;
  868.                       case current_foreground of
  869.                         0..7  : s := s+'5;';
  870.                         8..15,
  871.                      { 16..23 : s := s; }
  872.                        24..31 : begin
  873.                                   s := s+'0;5;';
  874.                                   NoBackG_OK := true;
  875.                                 end;
  876.                      end;
  877.                    end;
  878.           24..31 : begin
  879.                      f1:=f-24;
  880.                      case current_foreground of
  881.                         0..7  : s := s+'1;5;';
  882.                         8..15 : s := s+'5;';
  883.                        16..23 : s := s+'1;';
  884.                     {  24..31 : s := s; }
  885.                      end;
  886.                    end;
  887.          end;
  888.          If NoBackG_OK and (b=0) then
  889.            sendtext(#27+s+va(colorf[f1])+'m')
  890.          else
  891.            sendtext(#27+s+va(colorf[f1])+';'+va(colorb[b])+'m');
  892.       end;
  893.       current_foreground:=f;
  894.       current_background:=b;
  895.     end
  896.      else
  897.      if (f<>current_foreground) then
  898.         set_foreground(f)
  899.      else
  900.        set_background(b);
  901. end;
  902.  
  903. procedure prompt;
  904. const
  905.  promptcol1=7;
  906.  promptcol2=1;
  907.  promptcol3=15;
  908. var
  909.  fg,bg: integer;
  910.  x,y,code: integer;
  911.  ch: char;
  912.  a: integer;
  913.  hexsave: boolean;
  914. begin;
  915.  hexsave:=hexon;
  916.  hexon:=false;
  917.  fg:=current_foreground;
  918.  bg:=current_background;
  919.  get_stacked(s);
  920.  if s<>'' then begin;
  921.   set_foreground(promptcol3);
  922.   while length(s)>le do delete(s,length(s),1);
  923.   swrite(s);
  924.   set_foreground(fg);
  925.  end else begin;
  926.   if not color_chg then pc:=false;
  927.   if pc then begin;
  928.    set_foreground(promptcol1);
  929.    set_background(promptcol2);
  930.    for a:=1 to le do swrite(' ');
  931.    for a:=1 to le do swrite(#8);
  932.    x:=wherex;
  933.    y:=wherey;
  934.   end;
  935.   s:='';
  936.   repeat;
  937.    sread_char_filtered(ch);                                 { read(kbd,ch);}
  938.    if (ch<>#8) and (ch<>^M) and (length(s)<le) then begin;
  939.     s:=s+ch;
  940.     swrite(ch);                                    { write(ch);}
  941.    end;
  942.    if length(s)>200 then delete(s,1,1);
  943.    if (ch=chr(8)) and (length(s)>0) then begin;
  944.     delete(s,length(s),1);
  945.     swrite(chr(8));                                { write(#8,' ',#8);}
  946.     swrite(' ');
  947.     swrite(#8);
  948.    end;
  949.   until (ch=^M) or (length(s)=999);
  950.   if pc then begin;
  951.    set_foreground(promptcol3);
  952.    set_background(bg);
  953.    while wherex>x do swrite(#8);
  954.    swrite(s);                                      { write(s);}
  955.    while wherex<x+le do swrite(' ');               { write(' ');}
  956.    set_foreground(fg);
  957.   end;
  958.   swriteln('');                                    { writeln('');}
  959.   if pos(';',s)<>0 then begin;
  960.    stacked:=s;
  961.    get_stacked(s);
  962.    while length(s)>le do delete(s,length(s),1);
  963.   end;
  964.  end;
  965.  hexon:=hexsave;
  966. end;
  967.  
  968. procedure sgoto_xy;
  969. var
  970.  s,s2: string;
  971. begin;
  972.  gotoxy(x,y);
  973.  curlinenum := y;
  974.  s:=#27+'[';
  975.  str(y,s2);
  976.  s:=s+s2;
  977.  str(x,s2);
  978.  s:=s+';'+s2+'f';
  979.  if not local then sendtext(s);
  980. end;
  981.  
  982. function skeypressed: boolean;
  983. var
  984.  b: boolean;
  985. begin;
  986.  b:=false;
  987.  if not local then b:=AsyncCharPresent;
  988.  if not b then b:=keypressed;
  989.  if macro<>'' then b:=true;
  990.  skeypressed:=b;
  991. end;
  992.  
  993. procedure close_async_port;
  994. begin;
  995.  if buffered then begin;
  996.    buffered:=false;
  997.    AsyncFlushOutput;
  998.    AsyncCloseUp;
  999.  end;
  1000. end;
  1001.  
  1002. procedure open_async_port;
  1003. begin;
  1004.  AsyncSelectPort(com_port);
  1005.  if lockbaud=0 then
  1006.   AsyncSetBaud(baud_rate)
  1007.  else
  1008.   AsyncSetBaud(lockbaud);
  1009.  buffered := true;   { Not set in original DD - this may not be the best }
  1010.                      { place for this but it does work in my tests       }
  1011. end;
  1012. {
  1013.   }
  1014. var
  1015.  nclastchar: char;
  1016.  
  1017. function NewCrtOutPut(var f: textrec): integer;
  1018. var
  1019.  p: integer;
  1020. begin;
  1021.  for p:=0 to f.bufpos-1 do swrite(f.bufptr^[p]);
  1022.  f.bufpos:=0;
  1023.  NewCrtOutPut:=0;
  1024. end;
  1025.  
  1026. function NewCrtInPut(var f: textrec): integer;
  1027. var
  1028.  p: integer;
  1029.  ch: char;
  1030. begin;
  1031.  with f do begin;
  1032.   p:=0;
  1033.   if nclastchar=#13 then begin; nclastchar:=' '; end else repeat;
  1034.    ch:=readkey;
  1035.    nclastchar:=ch;
  1036.    write(ch);
  1037.    bufptr^[p]:=ch;
  1038.    inc(p);
  1039.    if ch=#13 then write(#10);
  1040.    if ch=#8 then begin;
  1041.     write(' '#8);
  1042.     if p>0 then dec(p);
  1043.     if p>0 then dec(p);
  1044.    end;
  1045.   until (p=bufsize-1) or (ch=#13);
  1046.   bufpos:=0;
  1047.   bufend:=p;
  1048.  end;
  1049.  NewCrtInput:=0;
  1050. end;
  1051.  
  1052. function NewCrtIgnore(var f: textrec): integer;
  1053. begin;
  1054.  newcrtignore:=0;
  1055. end;
  1056.  
  1057. function NewCRTOpen(var f: textrec): integer;
  1058. begin;
  1059.  if f.mode=fmInput then begin;
  1060.   f.inoutfunc:=@NewCrtInput;
  1061.   f.flushfunc:=@NewCrtIgnore;
  1062.  end else begin;
  1063.   f.mode:=fmOutput;
  1064.   f.inoutfunc:=@NewCrtOutPut;
  1065.   f.flushfunc:=@NewCrtOutPut;
  1066.  end;
  1067.  NewCrtOpen:=0;
  1068. end;
  1069.  
  1070. Function RipDetect: boolean;
  1071. var
  1072.   i,j,k : integer;
  1073.   a : char;
  1074.   s : string;
  1075.   RipYes : boolean;
  1076. begin
  1077.  RipYes := false;
  1078.  If local then
  1079.    begin
  1080.      RipDetect := RipYes;
  1081.      exit;
  1082.    end;
  1083.  
  1084.  sendtext(#27+'[0;30m'+#13+#10);
  1085.  writeln;
  1086.  writeln('Checking for RIP');
  1087.  sendtext(#27'[!');
  1088.  delay(222);
  1089.  s := '';
  1090.  i := 0;
  1091.  j := 0;
  1092.  charorigin:=localchar;
  1093.  repeat;
  1094.  
  1095.    a:=chr(0);
  1096.    inc(i);
  1097.  
  1098.   If (Not AsyncCarrierPresent) then DropMessage;
  1099.  
  1100.   if charin(a) then
  1101.     charorigin:=remotechar;
  1102.   if (a<>chr(0)) then
  1103.     begin
  1104.       s := s+a;
  1105.       inc(j);
  1106.     end
  1107.   else
  1108.      begin
  1109.        If (i mod 50 = 0) then
  1110.          ReleaseTimeSlice;
  1111.      end;
  1112.   delay(2);
  1113.   until (i>666) or (j>13);
  1114.  
  1115.   If Copy(s,1,3) = 'RIP' then
  1116.     begin
  1117.       RipYes := true;
  1118.       writeln('Rip Detected');
  1119.       if charin(a) then
  1120.          charorigin:=remotechar;
  1121.     end;
  1122.  RipDetect := RipYes;
  1123.  Swriteln('');
  1124. end;
  1125.  
  1126. procedure DDAssignSOutput(var f: text);
  1127. begin;
  1128.  with textrec(f) do begin;
  1129.   handle   := $FFFF;
  1130.   mode     := fmclosed;
  1131.   bufsize  := sizeof(buffer);
  1132.   bufptr   := @buffer;
  1133.   OpenFunc := @NewCrtOpen;
  1134.   CloseFunc:= @NewCrtIgnore;
  1135.   Name[0]  := #0;
  1136.  end;
  1137. end;
  1138.  
  1139. Procedure MultiTaskMess;
  1140. begin
  1141.   Set_Color(2,0);
  1142.   Case Tasker of
  1143.     1 : writeln('DESQview Detected');
  1144.     2 : writeln('Windows 3.xx Detected');
  1145.     3 : writeln('OS/2 Detected');
  1146.     4 : writeln('Win/NT Detected');
  1147.     5 : writeln('Dos 5.0 with Network Detected');
  1148.     6 : writeln('Dos 5.0+ Detected');
  1149.   else
  1150.         writeln('No Multiplexer Detected');
  1151.   end;
  1152.   ReleaseTimeSlice;
  1153. end;
  1154.  
  1155. procedure InitDoorDriver(ConfigFileName: string);
  1156. Var
  1157.  i,a: byte;
  1158.  b: integer;
  1159.  junk: word;
  1160.  
  1161. begin;
  1162.  initddansi;
  1163.  oldtextmode:=lastmode;
  1164.  lastsetfore:=99;
  1165.  setforecheck:=false;
  1166.  badchar:='';
  1167.  ansion:=false;
  1168.  numlines:=25;
  1169.  cc:=0;
  1170.  clrscr;
  1171.  window(1,1,80,numlines-1);
  1172.  node_num:=1;
  1173.  statfore:=7;
  1174.  statback:=1;
  1175.  GoRip := 0;
  1176.  com_port:=0;
  1177.  fouled_up:=#0;
  1178.  stacked:='';
  1179.  hexon:=false;
  1180.  buffered:=false;
  1181.  cdropped:=false;
  1182.  exitsave:=exitproc;
  1183.  exitproc:=@DDexit;
  1184.  firsttime:=true;
  1185.  
  1186.  LoadPorts(port1,port2,port3,port4,irq1,irq2,irq3,irq4);
  1187.  Loadconfig( ConfigFileName,
  1188.              bbs_software,
  1189.              user_first_name,user_last_name,
  1190.              user_access_level,
  1191.              bbs_time_left,
  1192.              com_port,
  1193.              baud_rate,
  1194.              node_num,
  1195.              local,
  1196.              graphics,
  1197.              color1,
  1198.              color_chg,
  1199.              Extd_Foss_OK,
  1200.              board_name,
  1201.              pause_code,
  1202.              sysop_first_name,
  1203.              sysop_last_name,
  1204.              maxtime,
  1205.              localcol,
  1206.              statfore,
  1207.              statback,
  1208.              statline,
  1209.              ESMOK,NetOK,
  1210.              nolocal,
  1211.              fossilio,
  1212.              dropfilepath,
  1213.              GoRip,
  1214.              lockbaud,
  1215.              nodirect,
  1216.              port1,port2,port3,port4,irq1,irq2,irq3,irq4);
  1217.  
  1218.  numlines:=25;
  1219.  if nodirect then directvideo:=false;
  1220.  clrscr;
  1221.  window(1,1,80,numlines-1);
  1222.  textcolor(7);
  1223.  textbackground(0);
  1224.  default_fore:=7;
  1225.  default_back:=0;
  1226.  gettime(st_hr,st_mn,st_sc,junk);
  1227.  
  1228.  GetBBSInfo( bbs_software,
  1229.              user_first_name,user_last_name,
  1230.              user_access_level,
  1231.              bbs_time_left,
  1232.              com_port,
  1233.              baud_rate,
  1234.              node_num,
  1235.              local,
  1236.              graphics,
  1237.              color1,
  1238.              color_chg,
  1239.              board_name,
  1240.              sysop_first_name,
  1241.              sysop_last_name,
  1242.              maxtime,
  1243.              dropfilepath,
  1244.              lockbaud);
  1245.  
  1246.  ReSetPorts(port1,port2,port3,port4,irq1,irq2,irq3,irq4);
  1247.  if not local then
  1248.    begin;
  1249.     if FossilIO then AsyncSelectFossil else
  1250.       AsyncSelectInternal;
  1251.     Open_Async_Port;
  1252.    end;
  1253.  
  1254.  if fossilio and (initok=false) and (not local) then begin;
  1255.   writeln('');
  1256.   writeln('Fossil was not initialized properly! You should change to INTERNAL');
  1257.   writeln('communications routines.');
  1258.   delay(1500);
  1259.  end;
  1260.  
  1261.  If GoRip = 4 then
  1262.      graphics := 5;
  1263.  If Graphics <> 5 then
  1264.     If RipDetect then
  1265.           graphics := 5;
  1266.  
  1267.  DV_Aware_ON;
  1268.  current_foreground:=default_fore;
  1269.  current_background:=default_back;
  1270.  if graphics = 3 then
  1271.    begin
  1272.      set_foreground(statfore);
  1273.      set_background(statback);
  1274.    end;
  1275.  curlinenum:=1;
  1276.  time_check:=true;
  1277.  time_credit:=0;
  1278.  macro_str:='';
  1279.  macro:='';
  1280.  mintime:=1;
  1281.  notime:='';
  1282.  user_first_name:=stu(user_first_name);
  1283.  user_last_name:=stu(user_last_name);
  1284.  stackon:=true;
  1285.  if node_num=0 then node_num:=1;
  1286.  ddassignsoutput(soutput);
  1287.  rewrite(soutput);
  1288.  If Not NetOk then
  1289.    If (Tasker = 5) then inc(Tasker);
  1290.  MultiTaskMess;
  1291.  
  1292. end;
  1293.  
  1294. end.
  1295.  
  1296.