NetNews Usenet Archive 1992 #27/NN_1992_27.iso/spool/comp/lang/pascal/6633

Internet Message Format | 1992-11-16 | 18.5 KB

Path: sparky!uunet!munnari.oz.au!uniwa!DIALix!babel!del
From: [e-mail] (D Elson)
Newsgroups: comp.lang.pascal
Subject: I need help writing a tsr
Distribution: world
Message-ID: <[e-mail]>
Date: Mon, 16 Nov 92 13:30:56 GMT
Organization:
Lines: 737


OK, since so many people have asked for it, here it is.

I haven't zipped/uuencoded it or nuthin, so you'll have to save
the mail message and cut the bits out with a text editor.

Here goes:

{$V-,I-,R-,F+} {Do not change these directives. }

Unit TSR;
{--------------------------------------------------------------------------

  Description:

    Part 1 of TSR implementation using Turbo Pascal.  To use this
    unit, you must have a modified version of TSRtest.PAS, including
    your TSR code in the appropriate procedure.

  References :

  Note :

    Avoid defining  local variables  inside an Interrupt routine, because
    they will be allocated inside the interrupted program's stack.

  Author     :   D Elson
                 [e-mail]
  Version    :   3.0
  Date       :   11/10/92

---------------------------------------------------------------------------}


{--------------------------------------------------------------------------}
Interface
{--------------------------------------------------------------------------}

Uses
  Dos,
  Crt,
  Machine;

Const
  OldStackSS    : Word = 0;    { SS save area of interrupted program }
  OldStackSP    : Word = 0;    { SP save area of interrupted program }
  OurStackSeg   : Word = 0;    { SS save area of this TSR program }
  OurStackSP    : Word = 0;    { SP save area of this TSR program }

  StackSW       : integer = -1;

{ StackSW indicates whether the Interrupt was issued from inside this
  TSR program:

  -1 : Outside this TSR - Switch the stack
   0 : Inside this TSR - Do not switch the stack  }


  TSROFF        : Boolean = FALSE;   { TRUE : Pop up has been disabled }


Type

  TTSRProc = procedure;

procedure PopSetUp(pr:TTSRProc;
                   SC,KM : Byte);
{ This sets up the popup procedure.  Pass in the procedure (which must
  take no parameters to be compatible with type TTSRProc), the Scan
  Code (SC), and the Key Mask (KM) }

procedure BeginPop;
{ Always call this at the beginning of your popup procedure. }

procedure EndPop;
{ Always call this at the end of your popup procedure. }

procedure install_int;
{ Call this to install an interrupt handler for your popup procedure. }

function  TSRExit : Boolean;
{ This exits the TSR program if it is possible, returns false if it is
  not possible.  It is not possible to exit the TSR program in the case
  that another TSR program has been loaded after this one. }

function  DupCheck(Var S: String; UserIntProc: Pointer) : Byte;
{ Checks whether the TSR procedure has been loaded.  If it hasn't, then
  DupCheck returns 0.  If it has, it returns the interrupt vector that is
  being used to communicate with the TSR.  This will be in the range
  $60 .. $67. }

procedure BeginInt;
InLine($ff/$06/stacksw/        { inc stacksw }
       $75/$10/                { jne +16 }
       $8c/$16/OldStackss/     { mov OldStackss,ss }
       $89/$26/OldStacksp/     { mov OldStacksp,sp }
       $8e/$16/OurStackseg/    { mov ss,OurStackseg }
       $8b/$26/OurStacksp);    { mov sp,OurStacksp }

procedure EndInt;
Inline($ff/$0e/stacksw/        { dec stacksw }
       $7d/$08/                { jge +8 }
       $8e/$16/OldStackSS/     { mov ss,OldStackss }
       $8b/$26/OldStacksp);    { mov sp,OldStacksp }

{--------------------------------------------------------------------------}
Implementation
{--------------------------------------------------------------------------}

Const
  TimerInt      = $1C;
  KbdInt        = $09;
  IdleInt       = $28;
  CritInt       = $24;

  PopFlag       : Boolean = FALSE;      { TRUE : ok To Pop up }

  Running       : Boolean = FALSE;      { TRUE : Pop up is already Running }

  EndDos        : Word = 0;

  Scancode      : Byte = 0;
  KeyMask       : Byte = 0;
{ These two constants define your hot key -- you can change them
  at your convenience.  Note that the ScanCode is not the ASCII
  value for the character but the code generated by the key-
  board.                                                         }

Var
  TimerVec,
  KbdVec,
  IdleVec,
  CritVec: Pointer;                 { Pointers to save original interrupts }

  DosSeg : Word;

  DOSBusy : Word;                   { Save DOS busy flag address here }

  OldDTASeg,
  OldDTAOfs,                        { Save interrupted program's DTA }

  OurDtaSeg,
  OurDtaOfs : Word;                 { Address of the TSR's DTA }

  SaveBreak : Byte;

  PopRtn : TTSRProc;                { Address of the user's pop-up routine }

  TSR_Byte,
  TSR_VEC       : Byte;        { TSR's communication Interrupt }
  TSR_PSP       : Word;        { TSR's PSP }
  INT_PSP       : Word;

  PSPArray      : array [1..2] of word;
  PSP_counter   : byte;

{--------------------------------------------------------------------------}

{ This replaces the existing critical error interrupt handler }

procedure NewCrit(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,Bp: Word);
  Interrupt;
{ Set ax = 0 to tell DOS to ignore the error and continue }
begin
  ax:=0;
end;

{ This chains into the DOS idle interrupt }

procedure NewIdle (Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP: Word);
  Interrupt;
{ If DOS is idling, and if pop-up is pending, then do pop-up }
begin
  CLI;
  BeginInt;
  STI;
  CallOldInt(IdleVec);     {Call old Interrupt 28 routine }
  if ( (PopFlag) and (Mem[DosSeg:DOSBusy] <> 0) ) then
    begin
    PopFlag := False;
    PopRtn;
    End;
  CLI;
  EndInt;
  STI;
end;

{ This chains into the current timer interrupt }

procedure NewClock (Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP: Word);
  Interrupt;

begin
  CLI;
  BeginInt;
  STI;
  CallOldInt (TimerVec);
  If (PopFlag) and (Mem[DosSeg:DosBusy] = 0) Then
    begin
    i8259A_EOI;
    PopFlag := False;
    PopRtn;
    end;
  CLI;
  EndInt;
  STI;
end;

{ This replaces the Keyboard interrupt routine.  It checks to see whether
  the hot key has been pressed, and sets PopFlag So that the NewClock and
  NewIdle routines can detect it. }

procedure NewKbd(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP: Word);
  Interrupt;

label
  TSRDown,
  KeyExit;

begin
  CLI;
  BeginInt;
  STI;
{ If the TSR is suspended, do not check }
  If TSROff then
    Goto TSRDown;

  If (Port[$60] = ScanCode) then
    if ((mem[0000:$0417] and keymask) = keymask) then
      begin
{     Reset the Keyboard }
      TSR_byte  := Port[$61];
      Port[$61] := TSR_Byte OR $80;
      Port[$61] := TSR_Byte;
{     Signal end of interrupt }
      CLI;
      i8259A_EOI;
      STI;
      If Not Running then
        PopFlag := True;
      Goto KeyExit;
      end;

TSRdown:
  CallOldInt(KbdVec);

KeyExit:
  CLI;
  EndInt;
  STI;
end;

{--------------------------------------------------------------------------}


{ Install the TSR'S Interrupts }

procedure Install_int;
begin
  SetIntVec(TimerInt, @NewClock);
  SetIntVec(IdleInt,  @NewIdle);
  SetIntVec(KbdInt,   @NewKbd);
  If Stacksw = -1 then
    SetIntVec($1B,SaveInt1B);
end;

{ Release any memory used by this TSR }

procedure rel_mem;
var
  r : registers;
begin
  While (Mem[EndDos:0] = $4d) do
    begin
    If MemW[EndDos:1] = TSR_PSP then
      begin
      R.AH := $49;
      R.ES := EndDos+1;
      MsDos(R);
      end;
    EndDos := EndDos + MemW[EndDos:3] + 1;
    end;
end;

{ Restore interrupts when terminating TSR }

function TSRExit : boolean;
var
  p,q,r,s,t : pointer;
begin
{ If the current interrupt vectors which the TSR steals are the same as
  the TSR's original ones, then there are no more programs in memory after
  this TSR, so it is safe to unload. }
  GetIntVec(TimerInt,p);
  GetIntVec(KbdInt,q);
  GetIntVec(IdleInt,r);
  If (p = @NewClock) and (q = @NewKbd) and (r = @NewIdle) then
    begin
{   Restore old vectors }
    SetIntVec(TimerInt,TimerVec);
    SetIntVec(KbdInt,KbdVec);
    SetIntVec(IdleInt,IdleVec);
    t := nil;
    SetIntVec(TSR_Vec,t);
{   Free all allocated memory }
    rel_mem;
    TSRExit := True;
    end
  else
    begin
    TSRExit := False;
    TSROFF  := True;
    end;
end;

{ Set up for pop-up routines -- Get the DOS busy flag, interrupts, etc. }

procedure PopSetup(pr:TTSRProc; SC,KM:byte);
var
  R   : Registers;
  adr : word;
  i   : integer;
begin
  ScanCode:=SC;
  KeyMask :=KM;
  Poprtn  :=pr;
  CheckBreak:=False;

{ Save Stack }
  OurStackSeg:=SSeg;
  Inline($89/$26/OurStackSP);

{ Save address of DOS busy flag }
  R.AH:=$34;
  MsDos(R);
  DosSeg:=R.ES;
  DosBusy:=R.BX;

{ Save address of Data Transfer Area }
  R.AH:=$2F;
  MsDos(R);
  OurDtaSeg:=R.ES;
  OurDtaOfs:=R.BX;

{ Save address of Program segment prefix }
  R.AH:=$51;
  MsDos(R);
  TSR_PSP:=R.BX;

  R.AH:=$52;
  MsDos(R);
  EndDos:=MemW[R.ES:R.BX-2];

  PSP_Counter :=0;
  adr:=0;
  While (PSP_Counter<2) and
        (((DosSeg shl 4) + adr) < (EndDos shl 4)) do
    begin
    If MemW[DosSeg:adr] = TSR_PSP then
      begin
      R.AH:=$50;
      R.BX:=TSR_PSP + 1;
      MsDos(R);
      if MemW[DosSeg:adr] = TSR_PSP+1 then
        PSP_counter := PSP_counter + 1;
      PSPArray[PSP_counter] := adr;
      R.AH:=$50;
      R.BX:=TSR_PSP;
      MsDos(R);
      end;
    adr:=adr+1;
    end;

{ Get interrupt vectors }

  GetIntVec(TimerInt,TimerVec);
  GetIntVec(KbdInt,KbdVec);
  GetIntVec(IdleInt,IdleVec);
  end;


procedure ResidentPSP;
var i:byte;
begin
  INT_PSP := MemW[DosSeg:PSParray[1]];
  for i:=1 to PSP_counter do
    MemW[DosSeg:PspArray[i]]:=tsr_psp;
end;

procedure RestorePSP;
var i:byte;
begin
  For i:=1 to PSP_counter do
    MemW[DosSeg:PSPArray[i]]:=INT_PSP;
end;

{ BeginPop.  Call this before the pop up routine and it will replace the
  DTA and Critical error handler }

procedure BeginPop;
var
  R : Registers;
begin
  Running := true;
  R.AH := $2F;
  MsDos(R);
  OldDTAseg:=R.ES;
  OldDTAofs:=R.BX;
  R.AH:=$1A;
  R.DS:=OurDtaSeg;
  R.DX:=OurDTAOfs;
  MsDos(R);

{ Get control-break setting }
  R.AX:=$3300;
  MsDos(r);
  SaveBreak:=R.DL;

{ Set Control-break off }
  R.AX:=$3301;
  R.DL:=0;
  MsDos(R);

{ Get current critical error interrupt address }
  GetIntVec(CritInt,CritVec);
  SetIntVec(CritInt,@NewCrit);
  ResidentPSP;
  end;

{ EndPOP -- does the reverse of the above }

procedure EndPop;
var
  R:Registers;
begin
  running:=false;

  R.AH:=$1A;                  { Restore DTA }
  R.DS:=OldDTASeg;
  R.DX:=OldDTAOfs;
  MsDos(R);

  R.AX:=$3301;                { Restore ctrl-break setting }
  R.DL:=SaveBreak;
  MsDos(R);

  SetIntVec(CritInt,CritVec);
  RestorePSP;
  end;

{ Check for duplicate copies of this TSR }

function DupCheck(var s:string; UserIntProc:pointer) : byte;
var
  vec:word;
  dif:word;
  ptr:pointer;
  PtrArr : array[1..2] of integer absolute ptr;
  RtnArr : array[1..2] of integer absolute UserIntProc;
  i      : byte;
  st     : string;

begin
{ Calculate the difference between the interrupt service routine and the
  data segment in the transient program. }
  dif := Dseg-rtnarr[2];
  For vec:=$60 to $67 do
    begin
    GetIntVec(vec,ptr);
    if ptr=nil then
      begin
      setintvec(vec,UserIntProc);
      TSR_VEC:=vec;
      DupCheck := 0;
      exit;
      end;
{ Find the signature, store it in a string, and compare with the
  signature passed in.  }
    Move(Mem[Ptrarr[2]+dif:ofs(s)],st,length(s)+1);
    if st=s then
      begin
      DupCheck:=vec;   { return the communication vector of the TSR }
      exit;
      end;
    end;
end;

begin
  stacksw := -1;
End.

{$V-,I-,R-,F+} {Do not change these directives. }
Unit Machine;
{--------------------------------------------------------------------------

  Description:

    Library of machine dependant and machine coded instructions.

  References :

  Author     :   D Elson
                 [e-mail]
  Version    :   2.0
  Date       :   11/11/92

---------------------------------------------------------------------------}

{--------------------------------------------------------------------------}
Interface
{--------------------------------------------------------------------------}

Procedure CLI; InLine($FA);             { Disable interrupts }

Procedure STI; InLine($FB);             { Enable interrupts  }

Procedure i8259A_EOI;                   { 8259A Generic end of interrupt }
  InLine($B0/$20/        { MOV AL,20 }
         $E6/$20);       { OUT 20,AL }

Procedure POPF; Inline($9D);            { Pop Flags after Intr 25/26 }

Function  Flags : byte;
  InLine($98/            { LAHF }
         $88/$E0);       { MOV AL,AH }

Procedure CallOldInt (Sub:pointer);
{ Use this procedure to call an interrupt routine }

{--------------------------------------------------------------------------}
Implementation
{--------------------------------------------------------------------------}

Procedure CallOldInt (Sub:pointer);
begin
InLine ($9C/                { PUSHF    ; push status flags  }
        $FF/$5E/$06);       { CALL DWORD PTR [BP+6] }
end;

end.

{$M 6000,600,600 }      (* These have to be the actual memory requirements
                           of this TSR.  The values are stack size, low heap
                           size, and maximum heap size.                   *)
{$V-,I-,R-,F+}          (* Do not change these directives *)

Program TSRTest;
{--------------------------------------------------------------------------

  Description:

    Test driver for TSR.PAS.  This program can be modified, to change:

      1) The TSR signature (TSR_Tmark)
      2) The ScanCode and Mask
      3) Procedure Do_Pop (the TSR body itself.

  References :

    Unit TSR;

  Author     :   D Elson
                 [e-mail]
  Version    :   3.0
  Date       :   11/11/92

---------------------------------------------------------------------------}

uses  Crt,
      Dos,
      Machine,
      TSR;

Const
  TSR_tmark : string[20] = 'DELSON001';
  ScanCode               = 78;      { See WATZITDO to find these }
  Mask                   = 08;      { = <ALT>                    }

Var
  TSR_int : byte;      { used for communication with the TSR }
  TSR_AX  : word;      { " }

Procedure Do_Pop;
{ This is the pop-up "Main program".  Replace this routine with the pop
  up routine you want to install. }
begin
  GotoXY(1,1);
  write('Hello, world');
end;

Procedure Pop_Call;
begin
  BeginPop;
  Do_Pop;
  EndPop;
end;

Function Upper (S : string) : string;
Var
  I : Integer;
  lcase : set of Char;
begin
  lcase := ['a'..'z'];

  for I := 1 to Length(S) do
    if S[I] in lcase then
      S[I] := Char(Ord(S[I]) - 32);
  Upper := S;
end;

Procedure Stop_TSR;
begin
  if TSRExit then
    writeln('... Pop up routine removed from memory')
  else
    writeln('Cannot de-install Pop-up -- other TSRs have been loaded');
end;

{ This interrupt is installed at start up.  Its purpose is to provide a
  way to communicate with the resident TSR through command line parameters.
  It also serves to prevent any subsequent installation of the same pop
  up program.  }

Procedure TSR_IntRtn(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP: Word);
  Interrupt;
begin
  TSR_AX := AX;
  CLI;
  BeginInt;
  STI;

  case TSR_AX of
  1: begin
     Stop_TSR;            { Terminate TSR and free memory }
     end;
  2: begin
     TSROFF := true;      { Suspend execution of TSR }
     writeln('Pop up routine suspended');
     end;
  3: begin
     TSROFF := false;
     writeln('Pop up routine restarted');
     end;
  end {case};

  CLI;
  EndInt;
  STI;
  end;


{--------------------------------------------------------------------------}
(*        Main program -- installation procedure                          *)
{--------------------------------------------------------------------------}

var
  r     : Registers;
  st    : String;

begin
  { Installation routine.  Checks to see if TSR already installed, if it
    is it returns the communication vector (INT 60 - 67) in TSR_int      }
  TSR_Int  := DupCheck(TSR_tmark,@TSR_intrtn);

  if TSR_int > 0 then
    begin
    If paramcount > 0 then
      begin
      st := Upper(ParamStr(1));
      if st = 'STOP'        then r.AX := 1
      else if st = 'HOLD'   then r.AX := 2
      else if st = 'GO'     then r.AX := 3
      else begin
           writeln('Invalid parameter -- parameters are:');
           writeln('  STOP -- unload the TSR');
           writeln('  HOLD -- suspend execution of the TSR');
           writeln('  GO   -- restart after a HOLD');
           exit;
           end;
      Intr(TSR_int,r);  { pass the parameter to the resident TSR }
      exit;
      end
    else
      begin
      Writeln('TSR already installed');
      exit;
      end;
    end;

  { Complete the installation of the TSR if sucessful so far }

  PopSetup(Pop_Call,ScanCode,Mask);    { Parameters are:  TSR dispatcher,
                                                    keyboard scan code,
                                                    keyboard mask.      }

  Writeln('TSR installed -- press <ALT> and ',
          'the numeric keypad <+> ',             { Put the real key in here }
          'to activate');
  install_int;
  Keep(0);
end.

------------------
Have fun, y'all.

UnStandard Disclaimer:  I make no claims as to the suitability of these
units, and if you stuff your system running them them don't bleed
on me.  TSRs are dangerous things -- I suggest you get TSRTEST.EXE
compiled and linked, then change it bit by bit so you can hunt
down your mistakes easier.

I will have a good stress tested version of this unit ready for the
people who are working with me on the PD pascal group, probably in
about a month or two.  I don't consider this unit highly stable at
the moment, and the documentation is lacking a little.

Sorry to all the people I didn't have time to reply to -- I had about
120 messages asking about these units, and I only got through about
15.  Please, have a good look at these units and attempt to solve any
problems you have with them using a good book on DOS (I suggest something
by Ray Duncan), before you all contact me.  It's not that I don't
appreciate the interest, it's just that I'd like some room in my mailbox
for other stuff.

Perhaps this shows that sometimes you should consider posting a request
to a group, rather than using private e-mail, so you can see if someone
has already made the request.  Sorry to rant and rave about it, but
it took quite a bit of my time just sorting through mail messages.

And since this appears to be popular -- can someone with FTP access
(I don't have it) please upload it to somewhere like garbo?  Timo?

Del
--
-----------------------------------+-------------------------------------
D Elson                            |  [e-mail] [e-mail]
-----------------------------------+-------------------------------------