home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 2 BBS / 02-BBS.zip / fossdumm.zip / SOURCE.ZIP / FOSSDUMM.PAS next >
Pascal/Delphi Source File  |  1993-06-15  |  8KB  |  346 lines
  1. (*Author : Michael Mrosowski*)
  2. (*Version: 0.1*)
  3. Program Dummy_Fossil;
  4. {$M 4096,0,0}
  5. {$S-}{$R-}{$I-}
  6.  
  7. uses dos,crt;
  8.  
  9. const
  10.   Bufflen = 1000;
  11.  
  12. var
  13.   IntTable : array[0..255] of Pointer absolute 0:0;
  14.   Old14 : Pointer;
  15.   SavePsp : word;
  16.   MyPsp   : word;
  17.   Pipe    : File;
  18.   Signal  : File of Byte;
  19.   OutBuffer,InBuffer : array[0..Bufflen-1] of byte;
  20.   OutCount,InCount,result  : integer;
  21.   OutsPerReQuest,CheckInput : integer;
  22.   regs       : registers;
  23.   Carrier    : Boolean;
  24.   LastStatus : Integer;
  25.  
  26. const
  27.   InputAvail   = $0108;
  28.   BufferOver   = $0208;
  29.   OutRoomAvail = $2008;
  30.   OutBuffEmpty = $4008;
  31.   CarrierDetect= $0088;
  32.  
  33.   MaxBuff = 10;
  34.   CheckInputEach = 50;
  35.   SendBack : byte = 1;
  36.   Stopit   : byte = 2;
  37.  
  38. Function GetPsp:word;
  39. begin
  40.   regs.ah:=$51;
  41.   Intr($21,regs);
  42.   GetPsp:=regs.bx;
  43. end;
  44.  
  45. Procedure SetPsp(newpsp:word);
  46. begin
  47.   regs.ah:=$50;
  48.   regs.bx:=newpsp;
  49.   Intr($21,regs);
  50. end;
  51.  
  52. Procedure WriteOut; (*writes Buffer out to Pipe*)
  53. begin
  54.   SavePsp:=GetPsp;
  55.   SetPsp(MyPsp);
  56.  
  57.   BlockWrite(Pipe,OutBuffer,OutCount,result);
  58.   Dec(OutCount,Result);
  59.  
  60.   SetPsp(SavePsp);                                           
  61. end;
  62.  
  63. Procedure ReadIn; (*Gets Data from Pipe*)
  64. var i   : integer;
  65.     sig : byte;
  66. begin
  67.   SavePsp:=GetPsp;
  68.   SetPsp(MyPsp);
  69.  
  70.   BlockRead(Pipe,InBuffer[InCount],Bufflen-Incount,Result);
  71.   i:=ioresult;
  72.   if (i=0) and (Result=0) then
  73.     Carrier:=FALSE;
  74.   if (i<>0) and (i<>5) then
  75.     Carrier:=FALSE;
  76.   LastStatus:=i;
  77.  
  78.   Inc(InCount,Result);
  79.   SetPsp(SavePsp);
  80. end;
  81.  
  82. Function Readchar:byte; (*Waits for remote pressed key*)
  83. begin
  84.   if OutCount>0 then
  85.     WriteOut;
  86.   while (InCount=0) and (Carrier) do
  87.     ReadIn;
  88.  
  89.   if Carrier then
  90.   begin
  91.     ReadChar:=InBuffer[0]; (*because only one char read max*)
  92.     Dec(InCount);
  93.     Move(InBuffer[1],InBuffer[0],Incount);
  94.   end
  95.   else ReadChar:=0;
  96. end;
  97.  
  98. Function BuffernotEmpty:boolean;
  99. begin
  100.   if InCount=0 then
  101.     if CheckInput>0 then
  102.       Dec(CheckInput)
  103.     else
  104.     begin
  105.       ReadIn;
  106.       CheckInput:=CheckInputEach;
  107.     end;
  108.   BuffernotEmpty:=InCount<>0;
  109. end;
  110.  
  111. Procedure ClosePipe;
  112. begin
  113.   SavePsp:=GetPsp;
  114.   SetPsp(MyPsp);
  115.  
  116.   Close(Pipe);
  117.  
  118.   SetPsp(SavePsp);
  119. end;
  120.  
  121. Procedure AddToOut(b:byte);
  122. begin
  123.   if OutCount<Bufflen then
  124.   begin
  125.     OutBuffer[OutCount]:=b;
  126.     Inc(OutCount);
  127.   end;
  128.   If OutCount>=MaxBuff then
  129.     WriteOut;
  130. end;
  131.  
  132. Procedure StrOut(s:string);
  133. var i:integer;
  134. begin
  135.   for i:=1 to length(s) do
  136.     AddToOut(ord(s[i]));
  137. end;
  138.  
  139. {For debugging only}
  140. Procedure ScreenStr(s:string;x,y:integer;attr:byte);
  141. var
  142.   addr:word;
  143.   i:integer;
  144. begin
  145.   addr:=(y-1)*160+(x-1)*2;
  146.   for i:=0 to length(s)-1 do begin
  147.     Mem[$b800:addr+i*2]:=ord(s[i+1]);
  148.     Mem[$b800:addr+(i*2)+1]:=attr;
  149.   end;
  150. end;
  151.  
  152. type str10 = string[10];
  153.  
  154. Function NumStr(n,len:integer):str10;
  155. var
  156.   addr:word;
  157.   i:integer;
  158.   s:str10;
  159. begin
  160.   s:='';
  161.   for i:=len downto 1 do begin
  162.     s:=chr(n mod 10+ord('0'))+s;
  163.     n:=n div 10;
  164.   end;
  165.   NumStr:=s;
  166. end;
  167.  
  168. const
  169.   funcstat : array[0..15] of integer = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  170.   hex : string[16] = '0123456789ABCDEF';
  171.  
  172. Procedure DebugOut(func:word;active:boolean);
  173. var i:integer;
  174. begin
  175.   for i:=0 to 15 do
  176.     if active and (i=func) then begin
  177.       inc(funcstat[i]);
  178.       if funcstat[i]>99 then funcstat[i]:=0;
  179.       ScreenStr(hex[i+1]+':'+Numstr(funcstat[i],2),i*5+1,1,15);
  180.     end
  181.     else
  182.       ScreenStr(hex[i+1]+':'+Numstr(funcstat[i],2),i*5+1,1,7);
  183.   ScreenStr('In:'+Numstr(InCount,2)+' Out:'+NumStr(OutCount,2)+
  184.             ' Chk:'+Numstr(CheckInput,2)+' Stat:'+Numstr(LastStatus,2),1,2,7);
  185. end;
  186.  
  187. (*The ISR for the dummy Fossil driver*)
  188. Procedure New14(Flags, CS, IP, AX, BX,CX, DX, SI, DI, DS, ES, BP: Word);
  189. interrupt;
  190. begin
  191.   {DebugOut(hi(ax),TRUE);}
  192.   case hi(ax) of
  193.     00 : begin (*Set Baud Rate*)
  194.            AX:=OutRoomAvail or OutBuffEmpty or CarrierDetect;
  195.          end;
  196.     01 : begin (*Transmit Wait*)
  197.            AddToOut(lo(ax));
  198.            if Carrier then
  199.              AX:=OutRoomAvail or CarrierDetect
  200.            else
  201.              AX:=0;
  202.            OutsPerRequest:=5;
  203.          end;
  204.     02 : begin (*Receive Wait*)
  205.            Ax:=ReadChar;
  206.          end;
  207.     03 : begin (*Request Status*)
  208.            if OutsPerRequest=0 then
  209.            begin
  210.              if (OutCount>0)  then WriteOut;
  211.              OutsPerRequest:=5;
  212.            end;
  213.            Dec(OutsPerRequest);
  214.  
  215.            if Carrier then
  216.              AX:=OutRoomAvail or OutBuffEmpty or CarrierDetect
  217.            else
  218.              AX:=0;
  219.            if BufferNotEmpty then
  220.              AX:=AX or InputAvail;
  221.          end;
  222.     04 : begin (*Init Driver*)
  223.            AX:=$1954; (*id*)
  224.            bx:=$100F; (*Doc ref:  10    Max funcs : 0x0F*)
  225.          end;
  226.     05 : begin (*Deinit Driver*)
  227.            If OutCount>0 then WriteOut;
  228.            ClosePipe;
  229.          end; 
  230.     06 : begin (*Return Timertick Parameters*)
  231.            Ax:=$121C;
  232.            Dx:=55;
  233.          end; 
  234.     08 : if Outcount>0 then
  235.          begin
  236.        {    WriteOut; (*Flush Buffer*)}
  237.          end;
  238.     09 : OutCount:=0;                 (*Purge Buffer*)
  239.    $0A : InCount:=0; (*Purge Input Buffer*)
  240.    $0B : begin       (*Transmit no Wait*)
  241.            AddToOut(lo(ax));
  242.            ax:=1; (*accepted*)
  243.            OutsPerRequest:=5;
  244.          end;
  245.    $0C : begin (*Non-Destructive Read-Ahead*)
  246.            If BufferNotEmpty then
  247.              ax:=InBuffer[0] (*Get first char, non destructive*)
  248.            else
  249.              Ax:=$FFFF; (*Not Avail*)
  250.          end;
  251.    $0D : begin
  252.            if Keypressed then
  253.            begin
  254.              Ax:=ord(Readkey);
  255.              if ax=0 then
  256.                ax:=ord(Readkey) shl 8;
  257.            end
  258.            else
  259.             Ax:=$FFFF;
  260.          end;
  261.    $0E : begin
  262.            Ax:=ord(Readkey);
  263.            if ax=0 then
  264.              ax:=ord(Readkey) shl 8;
  265.          end;
  266.    $0F : begin end; (*Enable/Disable Flow Control*)
  267.   end;
  268.   {DebugOut(hi(ax),FALSE);}
  269. end;
  270.  
  271.  
  272. Procedure  UnBlockPipe(var f:File);
  273. var info:word;
  274.     regs:registers;
  275.  
  276. begin
  277.   with regs do
  278.   begin
  279.     ax:=$5F34; (* LOCAL DosQNmPHandState *)
  280.     bx:=filerec(f).handle;
  281.     MsDos(Regs);
  282.     al:=0;
  283.     cx:=ax or (1 shl 15);
  284.     ax:=$5F34; (* LOCAL DosSetNmPHandState *)
  285.     bx:=filerec(f).handle;
  286.     MsDos(Regs);
  287.   end;
  288. end;
  289.  
  290. var ch:char;
  291.     commandline:string;
  292.     i : integer;
  293.  
  294. begin
  295.   if Paramcount>1 then
  296.   begin
  297.     commandline:='';
  298.     for i:=2 to Paramcount do
  299.       commandline:=commandline+' '+paramstr(i);
  300.     CheckInput:=CheckInputEach;
  301.     Writeln('Waiting for FOSSDUMM-Pipe to be installed. Press ESC to abort.');
  302.     assign(Pipe,'\PIPE\DUMMOUT.'+paramstr(1));
  303.     repeat
  304.       rewrite(Pipe,1);
  305.       if keypressed then
  306.         if readkey=#27 then
  307.         begin
  308.           writeln('FossDumm aborted');
  309.           Halt(1);
  310.         end;
  311.     until IoResult=0;
  312.     writeln('DUMMOUT installed');
  313.     assign(Signal,'\PIPE\DUMMSIG.'+paramstr(1));
  314.     repeat
  315.       rewrite(Signal);
  316.     until IoResult=0;
  317.     writeln('DUMMIN installed');
  318.     OutCount:=0;
  319.     InCount:=0;
  320.     OutsPerRequest:=5;
  321.     MyPsp:=GetPsp;
  322.  
  323.     UnBlockPipe(Pipe);
  324.     UnBlockPipe(File(Signal));
  325.  
  326.     Carrier:=TRUE;
  327.     Strout('starting DUMMFOSS... by Michael Mrosowski');
  328.     WriteOut;
  329.  
  330.     Writeln('DummFossil Installed');
  331.     Old14:=IntTable[$14];
  332.     IntTable[$14]:=@New14;
  333.     SwapVectors;
  334.     Exec(GetEnv('COMSPEC'),'/C '+commandline);
  335.     SwapVectors;
  336.     IntTable[$14]:=Old14;
  337.  
  338.     Write(Signal,StopIt);
  339.     Close(Signal);
  340.     i:=Ioresult;
  341.     if not Carrier then
  342.       Writeln('Carrier lost');
  343.   end
  344.   else writeln('Please pass the nodeno and program/batchfile to execute as parameter.');
  345. end.
  346.