Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TSRSRC29.ZIP/DISABLE.PAS

Pascal/Delphi Source File | 1993-01-04 | 24.1 KB | 782 lines

{**************************************************************************
*   Activates or deactivates TSRs, while leaving them in memory.          *
*   Copyright (c) 1987 Kim Kokkonen, TurboPower Software.                 *
*   Released to the public domain for personal, non-commercial use only.  *
***************************************************************************
*   version 2.3 5/4/87                                                    *
*     first release. version number matches other TSR Utilities           *
*   version 2.4 5/17/87                                                   *
*     fix a bug during reactivate with more than one TSR deactivated      *
*     turn off interrupts during disable and restore                      *
*   version 2.5 6/2/87                                                    *
*     make warning messages a little more useful                          *
*   version 2.6 1/15/89                                                   *
*     convert to Turbo Pascal 5.0                                         *
*   version 2.7                                                           *
*     skipped                                                             *
*   version 2.8 3/10/89                                                   *
*     add option just to check for a TSR                                  *
*   version 2.9 3/18/89                                                   *
*     fix bug in countvecs                                                *
*     check for overlapping patches before disabling                      *
*       (takes care of problem with SK+)                                  *
*     add /O override option to disable TSR even if overlaps detected     *
***************************************************************************
*   telephone: [phone], CompuServe: 72457,2131.                      *
*   requires Turbo version 5 to compile.                                  *
***************************************************************************}

{$R-,S-}

program DisableTSR;
  {-Deactivate and reactivate memory resident programs}
  {-Leaving them in memory all the while}

uses
  Dos;

const
  Version = '2.9';
  MaxBlocks = 128;            {Max number of DOS allocation blocks supported}

  WatchID = 'TSR WATCHER';    {Marking string for WATCH}

  {Offsets into resident copy of WATCH.COM for data storage}
  WatchOffset = $81;
  NextChange = $104;
  ChangeVectors = $220;
  OrigVectors = $620;
  CurrVectors = $A20;
  MaxChanges = 128;           {Maximum number of vector changes stored in WATCH}

type
  {.F-}
  Block =
  record                      {Store info about each memory block}
    mcb : Word;
    psp : Word;
  end;

  BlockType = 0..MaxBlocks;
  BlockArray = array[BlockType] of Block;

  ChangeBlock =
  record                      {Store info about each vector takeover}
    VecNum : byte;
    case ID : byte of
      0, 1 : (VecOfs, VecSeg : Word);
      2    : (SaveCode : array[1..6] of byte);
      $FF  : (PspAdd : Word);
  end;
  {
  ID is interpreted as follows:
    00 = ChangeBlock holds the new pointer for vector vecnum
    01 = ChangeBlock holds pointer for vecnum but the block is disabled
    02 = ChangeBlock holds the code underneath the vector patch
    FF = ChangeBlock holds the segment of a new PSP
  }
  ChangeArray = array[0..maxchanges] of changeblock;

  HexString = string[4];
  Pathname = string[79];
  {.F+}

var
  Blocks : BlockArray;
  WatchBlock, BlockNum : BlockType;
  Regs : Registers;
  Changes : ChangeArray;
  ChangeMax, ActualMax, WatchSeg, PspHex, StartMCB : Word;
  Action : (aDeactivate, aActivate, aCheckFor);
  Override : Boolean;
  TsrName : Pathname;

  procedure Abort(msg : String; ErrorLevel : Byte);
    {-Halt in case of error}
  begin
    WriteLn(msg);
    Halt(ErrorLevel);
  end;

  function StUpcase(s : String) : String;
    {-Return the uppercase string}
  var
    i : Byte;
  begin
    for i := 1 to Length(s) do
      s[i] := UpCase(s[i]);
    StUpcase := s;
  end;

  function HexW(i : Word) : HexString;
    {-Return HexW representation of Word}
  const
    hc : array[0..15] of Char = '0123456789ABCDEF';
  var
    l, h : Byte;
  begin
    l := Lo(i);
    h := Hi(i);
    HexW[0] := #4;
    HexW[1] := hc[h shr 4];
    HexW[2] := hc[h and $F];
    HexW[3] := hc[l shr 4];
    HexW[4] := hc[l and $F];
  end;

  procedure FindTheBlocks;
    {-Scan memory for the allocated memory blocks}
  const
    MidBlockID = $4D;         {Byte DOS uses to identify part of MCB chain}
    EndBlockID = $5A;         {Byte DOS uses to identify last block of MCB chain}
  var
    mcbSeg : Word;         {Segment address of current MCB}
    nextSeg : Word;        {Computed segment address for the next MCB}
    gotFirst : Boolean;       {True after first MCB is found}
    gotLast : Boolean;        {True after last MCB is found}
    idbyte : Byte;            {Byte that DOS uses to identify an MCB}

    function GetStartMCB : Word;
      {-Return the first MCB segment}
    begin
      Regs.ah := $52;
      MsDos(Regs);
      GetStartMCB := MemW[Regs.es:(Regs.bx-2)];
    end;

    procedure StoreTheBlock(var mcbSeg, nextSeg : Word;
                            var gotFirst, gotLast : Boolean);
      {-Store information regarding the memory block}
    var
      nextID : Byte;
      PspAdd : Word;       {Segment address of the current PSP}
      mcbLen : Word;       {Size of the current memory block in paragraphs}

    begin

      PspAdd := MemW[mcbSeg:1]; {Address of program segment prefix for MCB}
      mcbLen := MemW[mcbSeg:3]; {Size of the MCB in paragraphs}
      nextSeg := Succ(mcbSeg+mcbLen); {Where the next MCB should be}
      nextID := Mem[nextSeg:0];

      if gotLast or (nextID = EndBlockID) or (nextID = MidBlockID) then begin
        inc(BlockNum);
        gotFirst := True;
        with Blocks[BlockNum] do begin
          mcb := mcbSeg;
          psp := PspAdd;
        end;
      end;

    end;

  begin

    {Initialize}
    StartMCB := GetStartMCB;
    mcbSeg := StartMCB;
    gotFirst := False;
    gotLast := False;
    BlockNum := 0;

    {Scan all memory until the last block is found}
    repeat
      idbyte := Mem[mcbSeg:0];
      if idbyte = MidBlockID then begin
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
        if gotFirst then
          mcbSeg := nextSeg
        else
          inc(mcbSeg);
      end else if gotFirst and (idbyte = EndBlockID) then begin
        gotLast := True;
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
      end else
        {Start block was invalid}
        Abort('Corrupted allocation chain or program error....', 255);
    until gotLast;

  end;

  function FindMark(markId : String;
                    markoffset : Word;
                    var b : BlockType) : Boolean;
    {-Find the last memory block matching idstring at offset idoffset}
  var
    found : Boolean;

    function HasIDstring(segment : Word;
                         idString : String;
                         idOffset : Word) : Boolean;
      {-Return true if idstring is found at segment:idoffset}
    var
      tString : String;
      len : Byte;
    begin
      len := Length(idString);
      tString[0] := Chr(len);
      Move(Mem[segment:idOffset], tString[1], len);
      HasIDstring := (tString = idString);
    end;

  begin
    {Scan from the last block down}
    b := BlockNum;
    found := False;
    repeat
      if Blocks[b].psp = PrefixSeg then
        {Assure this program's command line is not matched}
        b := Pred(b)
      else if HasIDstring(Blocks[b].psp, markId, markoffset) then
        {mark found}
        found := True
      else
        {Not a mark}
        b := Pred(b);
    until (b < 1) or found;
    FindMark := found;
  end;

  function ExecutableBlock(PspHex : Word) : Boolean;
    {-Return true if psphex corresponds to an executable code block}
  var
    b : BlockType;
  begin
    for b := BlockNum downto 1 do
      {Search back to find executable rather than environment block}
      if Blocks[b].psp = PspHex then begin
        ExecutableBlock := True;
        Exit;
      end;
    ExecutableBlock := False;
  end;

  procedure InitChangeArray(WatchBlock : BlockType);
    {-Initialize information regarding the WATCH data block}
  var
    watchindex : Word;
    p : ^ChangeBlock;
  begin
    {Store the segment of the WATCH data area}
    WatchSeg := Blocks[WatchBlock].psp;

    {Maximum offset in WATCH data area}
    ActualMax := MemW[WatchSeg:NextChange];

    {Transfer changes from WATCH into a buffer array}
    watchindex := 0;
    ChangeMax := 0;
    while watchindex < ActualMax do begin
      p := Ptr(WatchSeg, ChangeVectors+watchindex);
      Move(p^, Changes[ChangeMax], SizeOf(ChangeBlock));
      watchindex := watchindex+SizeOf(ChangeBlock);
      if watchindex < ActualMax then
        inc(ChangeMax);
    end;
  end;

  procedure PutWatch(chg : ChangeBlock; var watchindex : Word);
    {-Put a change block back into WATCH}
  var
    p : ^ChangeBlock;
  begin
    p := Ptr(WatchSeg, ChangeVectors+watchindex);
    Move(chg, p^, SizeOf(ChangeBlock));
    watchindex := watchindex+SizeOf(ChangeBlock);
  end;

  procedure ActivateTSR(PspHex : Word);
    {-Patch out the active interrupt vectors of a specified TSR}
  var
    nextchg, chg, watchindex : Word;
    checking, didsomething : Boolean;
  begin
    didsomething := False;
    watchindex := 0;
    chg := 0;

    {Scan looking for the specified PSP}
    while chg <= ChangeMax do begin
      with Changes[chg] do
        case ID of

          $FF :               {This record starts a new PSP}
            begin
              checking := (PspAdd = PspHex);
              nextchg := Succ(chg);
              if checking then
                {Turn off interrupts}
                inline($FA)
              else
                {Turn on interrupts}
                inline($FB);
            end;

          $01 :               {This record has an inactive vector redefinition}
            if checking then begin
              {We're in the proper PSP}
              didsomething := True;
              {Change the ID to indicate that vector is active}
              ID := 0;
              {Put the original vector code back in place}
              nextchg := Succ(chg);
              if (Changes[nextchg].ID <> 2) or (Changes[nextchg].VecNum <> VecNum) then
                Abort('Program error in Activate, patch record not found', 255);
              {Restore the patched over code}
              Move(Changes[nextchg].SaveCode, Mem[VecSeg:VecOfs], 6);
              {Don't output the following patch record}
              inc(nextchg);
            end else
              nextchg := Succ(chg);

        else
          nextchg := Succ(chg);
        end;

      {Put the change block back into WATCH}
      PutWatch(Changes[chg], watchindex);
      {Advance to the next change record}
      chg := nextchg;
    end;

    {Store the count back into WATCH}
    MemW[WatchSeg:NextChange] := watchindex;

    if not(didsomething) then
      Abort('No changes were needed to activate '+HexW(PspHex), 1);

  end;

  procedure DeactivateTSR(PspHex : Word);
    {-Patch out the active interrupt vectors of a specified TSR}
  var
    newchange : ChangeBlock;
    chg, watchindex, curpsp : Word;
    putrec, checking, didsomething : Boolean;
    name : pathname;

    procedure PutPatch(vecn : Byte; vecs, veco, curpsp : Word);
      {-Patch vector entry point with JMP to previous controlling vector}
    label
      90;
    var
      vec : ^Word;
      chg : Word;
    begin
      {Get the original vector from WATCH}
      Move(Mem[WatchSeg:(OrigVectors+(vecn shl 2))], vec, 4);

      {Scan the Changes array to look for redefinition of this vector}
      for chg := 0 to ChangeMax do begin
        with Changes[chg] do
          case ID of
            0, 1 :            {This is or was a redefined vector}
              if vecn = VecNum then
                {It's the vector we're interested in}
                {Store the latest value of the vector}
                Move(VecOfs, vec, 4);
            $FF :             {This record starts a new PSP}
              if PspAdd = curpsp then
                {Stop when we get to the PSP that is being disabled}
                goto 90;
          end;
      end;
90:
      {Patch the vector entry point into a JMP FAR vec}
      Mem[vecs:veco] := $EA;
      Move(vec, Mem[vecs:Succ(veco)], 4);
    end;

    function CountVecs(chg : Word) : Word;
      {-Return count of vectors taken over by the PSP starting at changeblock chg}
    var
      count : Word;
      ID : Byte;
    begin
      count := 0;
      repeat
        {Skip over the first one, which defines the current PSP}
        inc(chg);
        ID := Changes[chg].ID;
        if (ID = 0) and (chg <= ChangeMax) then {!!}
          inc(count);
      until (ID = $FF) or (chg >= ChangeMax); {!!}
      CountVecs := count;
    end;

    function ValidToPatch(chg : Word) : Boolean;
      {-Assure that there is space to place 6-byte patches}
    var
      First : Word;
      Next : Word;
      I : Word;
      J : Word;
      IAddr : LongInt;
      JAddr : LongInt;
    begin
      ValidToPatch := True;
      if Override then
        Exit;

      {First vector to patch}
      First := chg+1;

      {Last vector to patch}
      Next := First;
      while (Next <= ChangeMax) and (Changes[Next].ID <> $FF) do
        inc(Next);

      {Any to patch?}
      if Next = First then
        Exit;

      {Compare each pair to assure enough space for patch}
      for I := First to Next-1 do begin
        with Changes[I] do
          IAddr := (LongInt(VecSeg) shl 4)+VecOfs;
        for J := First to Next-1 do
          if I <> J then begin
            with Changes[J] do
              JAddr := (LongInt(VecSeg) shl 4)+VecOfs;
            if Abs(IAddr-JAddr) < 6 then begin
              ValidToPatch := False;
              Exit;
            end;
          end;
      end;
    end;

  begin

    {Scan looking for the specified PSP}
    didsomething := False;
    watchindex := 0;

    for chg := 0 to ChangeMax do begin
      putrec := True;
      with Changes[chg] do
        case ID of

          $FF :               {This record starts a new PSP}
            begin
              checking := (PspAdd = PspHex);
              if checking then begin
                {Store the current PSP}
                curpsp := PspAdd;
                {Make sure WATCH has room for the extra changes}
                if watchindex+(CountVecs(chg)*SizeOf(ChangeBlock)) >
                MaxChanges*SizeOf(ChangeBlock) then
                  Abort('Insufficient space in WATCH data area', 255);
                {Make sure the patches will be valid}
                if not ValidToPatch(chg) then
                  Abort('Insufficient space between vectors to patch TSR', 255);
                {Turn off interrupts}
                inline($FA);
              end else
                {Turn on interrupts}
                inline($FB);
            end;

          $00 :               {This record has an active vector redefinition}
            if checking then begin
              {We're in the proper PSP}
              didsomething := True;

              {Change the ID to indicate that vector is inactive}
              ID := 1;
              {Output the record now so that the new record can immediately follow}
              PutWatch(Changes[chg], watchindex);
              putrec := False;

              {Output a new change record so we can reactivate later}
              {Indicate this is a patch record}
              newchange.ID := 2;
              {Save which vector it goes with}
              newchange.VecNum := VecNum;
              {Save the code we'll patch over}
              Move(Mem[VecSeg:VecOfs], newchange.SaveCode, 6);
              {Output the record to the WATCH area}
              PutWatch(newchange, watchindex);
              {Patch in a JMP to the previous vector}
              PutPatch(VecNum, VecSeg, VecOfs, curpsp);
            end;

        end;
      if putrec then
        {Put the change block back into WATCH}
        PutWatch(Changes[chg], watchindex);
    end;

    {Store the count back into WATCH}
    MemW[WatchSeg:NextChange] := watchindex;

    if not(didsomething) then
      Abort('No changes were needed to deactivate '+tsrname, 1);

  end;

  procedure GetOptions;
    {-Analyze command line for options}
  var
    arg : String;
    arglen : Byte absolute arg;
    i, code : Word;

    procedure WriteHelp;
      {-Show the options}
    begin
      WriteLn;
      WriteLn('DISABLE allows you to selectively disable and reenable a TSR while leaving it');
      WriteLn('in memory. To run DISABLE, you must have previously installed the TSR utility');
      WriteLn('WATCH.');
      WriteLn;
      WriteLn('DISABLE is command-line driven. You specify a single TSR by its name (if you');
      WriteLn('are running DOS 3.0 or later) or by its address as determined from a MAPMEM');
      WriteLn('report. Addresses must be preceded by a dollar sign "$" and specified in hex.');
      WriteLn;
      WriteLn('DISABLE accepts the following command line syntax:');
      WriteLn;
      WriteLn('  DISABLE TSRname|$PSPaddress [Options]');
      WriteLn;
      WriteLn('Options may be preceded by either / or -. Valid options are as follows:');
      WriteLn;
      WriteLn('     /A     reActivate the specified TSR.');
      WriteLn('     /C     Check whether TSR is installed.');
      WriteLn('     /O     Disable the TSR even if dangerous (Override).');
      WriteLn('     /?     Write this help screen.');
      Halt(1);
    end;

    function DOSversion : Byte;
      {-return the major version number of DOS}
    var
      reg : Registers;
    begin
      reg.ah := $30;
      MsDos(reg);
      DOSversion := reg.al;
    end;

    function Owner(envseg : Word) : Pathname;
      {-return the name of the owner program of an MCB}
    type
      chararray = array[0..32767] of Char;
    var
      e : ^chararray;
      i : Word;
      t : Pathname;

      function LongPos(m : Pathname; var s : chararray) : Word;
        {-return the position number of m in s, or 0 if not found}
      var
        mlen : Byte absolute m;
        mc : Char;
        ss : Pathname;
        i, maxindex : Word;
        found : Boolean;
      begin
        i := 0;
        maxindex := SizeOf(s)-mlen;
        ss[0] := m[0];
        if mlen > 0 then begin
          mc := m[1];
          repeat
            while (s[i] <> mc) and (i <= maxindex) do
              inc(i);
            if s[i] = mc then begin
              Move(s[i], ss[1], Length(m));
              found := (ss = m);
              if not(found) then
                inc(i);
            end;
          until found or (i > maxindex);
          if not(found) then
            i := 0;
        end;
        LongPos := i;
      end;

      procedure StripNonAscii(var t : Pathname);
        {-return an empty string if t contains any non-printable characters}
      var
        ipos : Byte;
        goodname : Boolean;
      begin
        goodname := True;
        for ipos := 1 to Length(t) do
          if (t[ipos] <> #0) and ((t[ipos] < ' ') or (t[ipos] > '}')) then
            goodname := False;
        if not(goodname) then
          t := '';
      end;

      procedure StripPathname(var pname : Pathname);
        {-remove leading drive or path name from the input}
      var
        spos, cpos, rpos : Byte;
      begin
        spos := Pos('\', pname);
        cpos := Pos(':', pname);
        if spos+cpos = 0 then
          Exit;
        if spos <> 0 then begin
          {find the last slash in the pathname}
          rpos := Length(pname);
          while (rpos > 0) and (pname[rpos] <> '\') do
            rpos := Pred(rpos);
        end else
          rpos := cpos;
        Delete(pname, 1, rpos);
      end;

      procedure StripExtension(var pname : Pathname);
        {-remove the file extension}
      var
        dotpos : Byte;
      begin
        dotpos := Pos('.', pname);
        if dotpos <> 0 then
          Delete(pname, dotpos, 64);
      end;

    begin
      {point to the environment string}
      e := Ptr(envseg, 0);

      {find end of the standard environment}
      i := LongPos(#0#0, e^);
      if i = 0 then begin
        {something's wrong, exit gracefully}
        Owner := '';
        Exit;
      end;

      {end of environment found, get the program name that follows it}
      t := '';
      i := i+4;               {skip over #0#0#args}
      repeat
        t := t+e^[i];
        inc(i);
      until (Length(t) > 64) or (e^[i] = #0);

      StripNonAscii(t);
      if t = '' then
        Owner := 'N/A'
      else begin
        StripPathname(t);
        StripExtension(t);
        if t = '' then
          t := 'N/A';
        Owner := StUpcase(t);
      end;

    end;

    function FindOwner(name : String) : Word;
      {-Return segment of executable block with specified name}
    var
      b : BlockType;
    begin
      name := StUpcase(name);
      {Scan the blocks in reverse order}
      for b := BlockNum downto 1 do
        with Blocks[b] do
          if Succ(mcb) = psp then
            {This block is an executable block}
            if Owner(MemW[psp:$2C]) = name then begin
              {Found it}
              FindOwner := psp;
              Exit;
            end;
      FindOwner := $FFFF;
    end;

  begin
    {Initialize defaults}
    PspHex := 0;
    Action := aDeactivate;
    Override := False;

    i := 1;
    while i <= ParamCount do begin
      arg := ParamStr(i);
      if (arg[1] = '?') then
        WriteHelp
      else if (arg[1] = '-') or (arg[1] = '/') then
        case arglen of
          1 : Abort('Missing command option following '+arg, 254);
          2 : case UpCase(arg[2]) of
                '?' : WriteHelp;
                'A' : Action := aActivate;
                'C' : Action := aCheckFor;
                'E' : Action := aActivate;
                'O' : Override := True;
              else
                Abort('Unknown command option: '+arg, 254);
              end;
        else
          Abort('Unknown command option: '+arg, 254);
        end
      else begin
        {TSR to change}
        if arg[1] = '$' then begin
          {Treat as hex address}
          Val(arg, PspHex, code);
          if code <> 0 then
            Abort('Invalid hex address specification: '+arg, 254);
        end else if DOSversion >= 3 then
          {Treat as PSP owner name - scan to find proper PSP}
          PspHex := FindOwner(arg)
        else
          Abort('Must have DOS 3.0+ to find TSRs by name', 254);
        TsrName := StUpcase(arg);
      end;
      inc(i);
    end;

    if PspHex = 0 then
      Abort('No TSR name or address specified', 254)
    else if PspHex = $FFFF then
      Abort('No such TSR found', 2);
  end;

begin
  WriteLn('DISABLE ', Version, ', by TurboPower Software');

  {Get all allocated memory blocks in normal memory}
  {Must do first to support TSRs by name in GetOptions}
  FindTheBlocks;

  {Analyze command line for options}
  GetOptions;

  {Find the watch block}
  if not FindMark(WatchID, WatchOffset, WatchBlock) then
    Abort('WATCH must be installed in order to use DISABLE', 255);

  {Assure PspHex corresponds to an executable block}
  if not ExecutableBlock(PspHex) then
    Abort('No such TSR found', 2);

  {Initialize information regarding the WATCH data block}
  InitChangeArray(WatchBlock);

  {Activate or deactivate the TSR}
  case Action of
    aDeactivate:DeactivateTSR(PspHex);
    aActivate:ActivateTSR(PspHex);
  end;

  {Write success message}
  case Action of
    aDeactivate:Write('Deactivated');
    aActivate:Write('Activated');
    aCheckFor:Write('Found');
  end;
  Write(' ');
  if TsrName[1] = '$' then
    Write('TSR at ');
  WriteLn(TsrName);

end.