CD Actual 14/CDACTUAL.iso/cdactual/demobin/share/program/Pascal/TSRSRC30.ZIP/RELEASE.PAS

Pascal/Delphi Source File | 1991-10-15 | 21.7 KB | 692 lines

{**************************************************************************
*   RELEASE - Releases memory above the last MARK call made.              *
*   Copyright (c) 1986,1991 Kim Kokkonen, TurboPower Software.            *
*   May be freely distributed and used but not sold except by permission. *
***************************************************************************
*   Version 1.0 2/8/86                                                    *
*     original public release                                             *
*     (thanks to Neil Rubenking for an outline of the method used)        *
*   :                                                                     *
*   long intervening history                                              *
*   :                                                                     *
*   Version 3.0 9/24/91                                                   *
*     make compatible with DOS 5                                          *
*     add Quiet option                                                    *
*     close open file handles of released blocks                          *
*     update for new WATCH behavior                                       *
*     increase number of supported memory blocks to 256                   *
*     add support for upper memory blocks                                 *
***************************************************************************
*   telephone: [phone], CompuServe: 76004,2611.                      *
*   requires Turbo version 6 to compile.                                  *
***************************************************************************}

{$R-,S-,I-,V-,B-,F-,A-,E-,N-,G-,X-}
{$M 16384,0,655360}

program ReleaseTSR;
  {-Restore system to state it had when a MARK was placed}

uses
  Dos,
  MemU,
  Ems;

const
  Version = '3.0';
  MarkID = 'M3.0 PARAMETER BLOCK FOLLOWS'; {Marking string for TSR MARK}
  FmarkID = 'FM3.0 TSR';          {Marking string for TSR file mark}
  NmarkID = 'MN3.0 TSR';          {Marking string for TSR NET file mark}

  ProtectChar = '!';          {Marks whose name begins with this will be
                              released ONLY if an exact name match occurs}

  {Offsets into resident copy of MARK.COM for data storage}
  MarkOffset = $103;          {Where markID is found in MARK TSR}
  FmarkOffset = $60;          {Where FmarkID is found in FMARK TSR}
  NmarkOffset = $60;          {Where NmarkID is found in MARKNET TSR}
  VectorOffset = $120;        {Where vector table is stored}
  EGAsavOffset = $520;        {Where the EGA save save is stored}
  IntComOffset = $528;        {Where the interapps comm area is stored}
  ParentOffset = $538;        {(TER) Where parent's PSP segment is stored}
  EMScntOffset = $53A;        {Where count of EMS active pages is stored}
  EMSmapOffset = $53C;        {Where the page map is stored}

var
  Blocks : BlockArray;
  markBlock, BlockMax : BlockType;
  CommandSeg : Word;
  StartMcb : Word;

  markName : String[127];

  FilMarkHandles, ReturnCode : Word;
  ShowHiMem, DealWithEMS, KeepMark, MemMark, FilMark, Quiet : Boolean;
  UmbLinkStatus : Boolean;
  Keys : string[16];
  SaveExit : pointer;

  TrappedBytes : LongInt;

  MarkEHandles : Word;
  CurrEHandles : Word;
  MarkEmsHandles : PageArrayPtr;
  CurrEmsHandles : PageArrayPtr;

  {Save areas read in from file mark}
  Vectors : array[0..1023] of Byte;
  EGAsavTable : array[0..7] of Byte;
  IntComTable : array[0..15] of Byte;
  ParentTable : array[0..1] of Byte;
  McbP : ^McbGroup;

  procedure SafeExit; far;
  var
    Status : Word;
  begin
    ExitProc := SaveExit;
    if HiMemAvailable(DosV) then
      Status := SetUmbLinkStatus(UmbLinkStatus);
  end;

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

  procedure NoRestoreHalt(ReturnCode : Word);
    {-Replace Turbo halt with one that doesn't restore any interrupts}
  begin
    SafeExit;
    Close(Output);
    asm
      mov ah,$4C
      mov al, byte(ReturnCode)
      int $21
    end;
  end;

  function FindMark(markName, MarkID : String;
                    MarkOffset : Word;
                    var MemMark, FilMark : Boolean;
                    var b : BlockType) : Boolean;
    {-Find the last memory block matching idstring at offset idoffset}
  var
    BPsp : Word;
    PassedFileMark : Boolean;

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

    function GetMarkName(segment : Word) : String;
      {-Return a cleaned up mark name from the segment's PSP}
    var
      tString : String;
      tlen : Byte absolute tString;
    begin
      Move(Mem[segment:$80], tString[0], 128);
      while (tlen > 0) and ((tString[1] = ' ') or (tString[1] = ^I)) do
        Delete(tString, 1, 1);
      while (tlen > 0) and ((tString[tlen] = ' ') or (tString[tlen] = ^I)) do
        dec(tlen);
      GetMarkName := StUpcase(tString);
    end;

    function MatchMemMark(segment : Word;
                          markName : String;
                          var b : BlockType) : Boolean;
      {-Return true if MemMark is unnamed or matches current name}
    var
      FoundIt : Boolean;
      tString : String;
    begin
      tString := GetMarkName(segment);
      if markName <> '' then begin
        FoundIt := (tString = markName);
        if not FoundIt and not ShowHiMem then
          if (tString <> '') and (tString[1] = ProtectChar) then
            {Current mark is protected, stop searching}
            b := 1;
      end else if (tString <> '') and (tString[1] = ProtectChar) then begin
        {Stored mark name is protected}
        FoundIt := False;
        {Stop checking}
        b := 1;
      end else if tString = '' then
        {Unnamed release and unnamed mark}
        FoundIt := True
      else begin
        {Unnamed release and named mark, match only if didn't pass file mark}
        FoundIt := not PassedFileMark;
        {Stop searching if no match}
        if not FoundIt then
          B := 1;
      end;
      if not FoundIt then
        dec(b);
      MatchMemMark := FoundIt;
    end;

    function MatchFilMark(segment : Word;
                          markName : String;
                          var b : BlockType) : Boolean;
      {-Return true if FilMark is unnamed or matches current name}
    var
      FoundIt : Boolean;
    begin
      if markName <> '' then begin
        FoundIt := (GetMarkName(segment) = markName);
        if FoundIt then
          {Assure named file exists}
          FoundIt := ExistFile(markName);
      end else begin
        {File marks must be named on RELEASE command line}
        FoundIt := False;
        PassedFileMark := True;
      end;
      if not FoundIt then
        dec(B);
      MatchFilMark := FoundIt;
    end;

  begin
    {Scan from the last block down to find the last MARK TSR}
    b := BlockMax;
    MemMark := False;
    FilMark := False;
    PassedFileMark := False;
    repeat
      BPsp := Blocks[B].Psp;
      if (Blocks[B].Mcb+1 <> BPsp) or (BPsp = PrefixSeg) then
        {Don't match any non-program block or this program}
        dec(b)
      else if HasIDstring(BPsp, NmarkID, NmarkOffset) then begin
        {A net mark, can't release it here}
        if ShowHiMem then
          {Keep looking}
          dec(b)
        else
          {Stop looking}
          b := 0;
      end else if HasIDstring(BPsp, MarkID, MarkOffset) then
        {An in-memory mark}
        MemMark := MatchMemMark(BPsp, markName, b)
      else if HasIDstring(BPsp, FmarkID, FmarkOffset) then
        {A file mark}
        FilMark := MatchFilMark(BPsp, markName, b)
      else
        {Not a mark}
        dec(b);
    until (b < 1) or MemMark or FilMark;
    FindMark := MemMark or FilMark;
  end;

  procedure ReadMarkFile(markName : String);
    {-Read the mark file info into memory}
  var
    McbCount : Word;
    f : file;
  begin
    Assign(f, markName);
    Reset(f, 1);
    if IoResult <> 0 then
      Abort('Error opening mark file');

    {Read the vector table from the mark file, into a temporary memory area}
    BlockRead(f, Vectors, 1024);

    {Read the BIOS miscellaneous save areas into temporary tables}
    BlockRead(f, EGAsavTable, 8);
    BlockRead(f, IntComTable, 16);
    BlockRead(f, ParentTable, 2);

    {Read the stored EMS handles, if any}
    BlockRead(f, MarkEHandles, SizeOf(Word));
    GetMem(MarkEmsHandles, SizeOf(HandlePageRecord)*MarkEHandles);
    BlockRead(f, MarkEmsHandles^, SizeOf(HandlePageRecord)*MarkEHandles);

    {Read the stored Mcb table}
    BlockRead(f, McbCount, SizeOf(Word));
    GetMem(McbP, SizeOf(Word)+2*SizeOf(Word)*McbCount);
    BlockRead(f, McbP^.Mcbs, 2*SizeOf(Word)*McbCount);
    McbP^.Count := McbCount;

    if IoResult <> 0 then
      Abort('Error reading mark file');
    Close(f);

    if not KeepMark then
      {Delete the mark file so it causes no mischief later}
      Erase(f);
  end;

  procedure InitMarkInfo;
    {-Set up information from mark in memory}
  var
    markPsp : Word;
  begin
    markPsp := Blocks[markBlock].psp;
    MarkEHandles := MemW[markPsp:EMScntOffset];
    MarkEmsHandles := Ptr(markPsp, EMSmapOffset);
    McbP := Ptr(markPsp, EMSmapOffset+4*MarkEHandles);
  end;

  procedure CopyVectors(markBlock : BlockType);
    {-Put interrupt vectors back into table}
  var
    markPsp : Word;
  begin
    {Interrupts off}
    inline($FA);

    {Restore the main interrupt vector table and the misc save areas}
    if FilMark then begin
      Move(Vectors, Mem[0:0], 1024);
      Move(EGAsavTable, Mem[$40:$A8], 8);
      Move(IntComTable, Mem[$40:$F0], 16);
      Move(ParentTable, Mem[PrefixSeg:$16], 2);
    end else begin
      markPsp := Blocks[markBlock].psp;
      Move(Mem[markPsp:VectorOffset], Mem[0:0], 1024);
      Move(Mem[markPsp:EGAsavOffset], Mem[$40:$A8], 8);
      Move(Mem[markPsp:IntComOffset], Mem[$40:$F0], 16);
      Move(Mem[markPsp:ParentOffset], Mem[PrefixSeg:$16], 2);
    end;

    {Interrupts on}
    inline($FB);

    {Move the old termination/break/error addresses into this program}
    Move(Mem[0:$88], Mem[PrefixSeg:$0A], 12);
  end;

  procedure MarkBlocks(markBlock : BlockType);
    {-Mark those blocks to be released}

    procedure BatchWarning(b : BlockType);
      {-Warn about the trapping effect of batch files}
    var
      t : BlockType;
    begin
      WriteLn('Memory space for TSRs installed prior to batch file');
      WriteLn('will not be released until batch file completes.');
      WriteLn;
      ReturnCode := 1;
      {Accumulate number of bytes temporarily trapped}
      for t := 1 to b do
        if Blocks[t].releaseIt then
          inc(TrappedBytes, LongInt(MemW[Blocks[t].mcb:3]) shl 4);
    end;

    procedure MarkBlocksAbove;
      {-Mark blocks above the mark}
    var
      markPsp : Word;
      b : BlockType;
    begin
      markPsp := Blocks[markBlock].psp;
      for b := 1 to BlockMax do
        with Blocks[b] do
          if (b >= markBlock) and (psp = CommandSeg) then begin
            {Don't release blocks owned by master COMMAND.COM}
            releaseIt := False;
            BatchWarning(b);
          end else if KeepMark then
            {Release all but RELEASE and the mark}
            releaseIt := (psp <> PrefixSeg) and (psp > markPsp)
          else
            releaseIt := (psp <> PrefixSeg) and (psp >= markPsp);
    end;

    procedure MarkUnallocatedBlocks;
      {-Mark blocks that weren't allocated at time of mark}
    var
      markPsp : Word;
      TopSeg : Word;
      b : BlockType;
      m : BlockType;
      Found : Boolean;
    begin
      markPsp := Blocks[markBlock].psp;

      {Find last low memory mcb}
      TopSeg := TopOfMemSeg-1;
      m := 1;
      Found := False;
      while (not Found) and (m <= McbP^.Count) do
        if McbP^.Mcbs[m].mcb >= TopSeg then
          Found := True
        else
          inc(m);

      {Mark out all mcbs associated with psp of last low memory mcb}
      TopSeg := McbP^.Mcbs[m-1].psp;
      if TopSeg <> markPsp then
        for m := 1 to McbP^.Count do
          with McbP^.Mcbs[m] do
            if psp = TopSeg then
              psp := 0;

      for b := 1 to BlockMax do
        with Blocks[b] do begin
          Found := False;
          m := 1;
          while (not Found) and (m <= McbP^.Count) do begin
            Found := (McbP^.Mcbs[m].psp <> 0) and (McbP^.Mcbs[m].mcb = mcb);
            inc(m);
          end;
          if Found then
            {was allocated at time of mark, keep it now unless a mark to be released}
            releaseIt := not KeepMark and (psp = markPsp)
          else if psp = CommandSeg then
            {Don't release blocks owned by master COMMAND.COM}
            releaseIt := False
          else
            {not allocated at time of mark}
            releaseIt := (psp <> 0) and (psp <> PrefixSeg);
        end;
    end;

  begin
    if ShowHiMem then
      MarkUnallocatedBlocks
    else
      MarkBlocksAbove;

    {$IFDEF Debug}
    for b := 1 to BlockMax do
      with Blocks[b] do
        WriteLn(b:3, ' ', HexW(psp), ' ', HexW(mcb), ' ', releaseIt);
    {$ENDIF}
  end;

  function ReleaseBlock(Segm : Word) : Word; assembler;
    {-Use DOS services to release memory block}
  asm
    mov ah,$49
    mov es,Segm
    int $21
    jc  @Done
    xor ax,ax
@Done:
  end;

  procedure ReleaseMem;
    {-Release DOS memory marked for release}
  var
    Status : Word;
    B : BlockType;
  begin
    for B := 1 to BlockMax do
      with Blocks[B] do
        if releaseIt then
          if ReleaseBlock(mcb+1) <> 0 then begin
            WriteLn('Could not release block at segment ', HexW(mcb+1));
            Abort('Memory may be a mess... Please reboot');
          end;
  end;

  procedure SetPSP(PSP : Word); assembler;
    {-Sets current PSP}
  asm
    mov bx,psp
    mov ax,$5000
    int $21
  end;

  procedure CloseHandles;
    {-Close any handles of blocks marked for release}
  type
    HandleTable = array[0..65520] of Byte;
  var
    O : Word;
    FileMax : Word;
    TablePtr : ^HandleTable;
    b : BlockType;
    H : Byte;
  begin
    for b := 1 to BlockMax do
      with Blocks[b] do
        if releaseIt and (psp = mcb+1) and (memw[psp:0] = $20CD) then begin
          {A released block with a program segment prefix}
          {set psp to this block}
          setpsp(psp);

          {Deal with expanded handle tables in DOS 3.0 and later}
          if DosV >= 3 then begin
            FileMax := MemW[Psp:$32];
            TablePtr := Pointer(MemL[Psp:$34]);
          end else begin
            FileMax := 20;
            TablePtr := Ptr(Psp, $18);
          end;

          for O := 0 to FileMax-1 do begin
            H := TablePtr^[O];
            case H of
              0, 1, 2, $FF : {standard handle or not open} ;
            else
              asm
                mov ah,$3E
                mov bx,O
                int $21      {ignore errors}
              end;
            end;
          end;
        end;

    {reset psp}
    setpsp(prefixseg);
  end;

  procedure RestoreEMSmap;
    {-Restore EMS to state at time of mark}
  var
    O, N, NHandle : Word;

    procedure EmsError;
    begin
      WriteLn('Program error or EMS device not responding');
      Abort('EMS memory may be a mess... Please reboot');
    end;

  begin
    {Get the existing EMS page map}
    GetMem(CurrEmsHandles, MaxHandles*SizeOf(HandlePageRecord));
    CurrEHandles := EmsHandles(CurrEmsHandles^);

    if CurrEHandles > MaxHandles then
      WriteLn('EMS handle count exceeds capacity of RELEASE -- no action taken')

    else if CurrEHandles <> 0 then begin
      {Compare the two maps and deallocate pages not in the stored map}
      for N := 1 to CurrEHandles do begin
        {Scan all current handles}
        NHandle := CurrEmsHandles^[N].Handle;
        if MarkEHandles > 0 then begin
          {See if current handle matches one stored by MARK}
          O := 1;
          while (MarkEmsHandles^[O].Handle <> NHandle) and (O <= MarkEHandles) do
            Inc(O);
          {If not, deallocate the current handle}
          if (O > MarkEHandles) then
            if not FreeEms(NHandle) then
              EmsError;
        end else
          {No handles stored by MARK, deallocate all current handles}
          if not FreeEms(NHandle) then
            EmsError;
      end;
    end;
  end;

  procedure GetOptions;
    {-Analyze command line for options}
  var
    i : Word;
    Status : Word;
    arg : String[127];

    procedure WriteCopyright;
    begin
      WriteLn('RELEASE ', Version, ', Copyright 1991 TurboPower Software');
    end;

    procedure WriteHelp;
      {-Show the options}
    begin
      WriteCopyright;
      WriteLn;
      WriteLn('RELEASE removes memory-resident programs from memory and restores the');
      WriteLn('interrupt vectors to their state as found prior to the installation of a MARK.');
      WriteLn('RELEASE manages both normal DOS memory and also Lotus/Intel Expanded Memory.');
      WriteLn('If WATCH has been installed, RELEASE will update the WATCH data area for the');
      WriteLn('TSRs released.');
      WriteLn;
      WriteLn('RELEASE accepts the following command line syntax:');
      WriteLn;
      WriteLn('  RELEASE [MarkName] [Options]');
      WriteLn;
      WriteLn('Options may be preceded by either / or -. Valid options are as follows:');
      WriteLn;
      WriteLn('  /E         do NOT access EMS memory.');
      WriteLn('  /K         release memory, but keep the mark in place.');
      WriteLn('  /Q         write no screen output.');
      WriteLn('  /S chars   stuff string (<16 chars) into keyboard buffer on exit.');
      WriteLn('  /U         consider upper memory blocks for release (DOS 5).');
      WriteLn('  /?         write this help screen.');
      WriteLn;
      WriteLn('When /U is requested, a MarkName must always be specified.');
      Halt(1);
    end;

  begin
    {Initialize defaults}
    markName := '';
    Keys := '';
    ReturnCode := 0;
    TrappedBytes := 00;

    KeepMark := False;
    Quiet := False;
    DealWithEMS := True;
    ShowHiMem := 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 Length(Arg) of
          1 : Abort('Missing command option following '+arg);
          2 : case UpCase(arg[2]) of
                '?' : WriteHelp;
                'E' : DealWithEMS := False;
                'K' : KeepMark := True;
                'Q' : Quiet := True;
                'S' : begin
                        if I >= ParamCount then
                          Abort('Key string missing');
                        inc(I);
                        Arg := ParamStr(I);
                        if Length(Arg) > 15 then
                          Abort('No more than 15 keys may be stuffed');
                        Keys := Arg+^M;
                      end;
                'U' : ShowHiMem := True;
              else
                Abort('Unknown command option: '+arg);
              end;
        else
          Abort('Unknown command option: '+arg);
        end
      else
        {Named mark}
        markName := stupcase(arg);
      inc(i);
    end;

    if not Quiet then
      WriteCopyright;

    {Initialize for high memory access}
    if HiMemAvailable(DosV) then begin
      UmbLinkStatus := GetUmbLinkStatus;
      Status := SetUmbLinkStatus(ShowHiMem);
      if ShowHiMem and (Status = 1) then
        Abort('To access upper memory you must have DOS=[HIGH,]UMB in CONFIG.SYS');
    end else
      ShowHiMem := False;
    SaveExit := ExitProc;
    ExitProc := @SafeExit;

    if ShowHiMem then
      if MarkName = '' then
        Abort('Upper memory releases must refer to named marks');
  end;

begin
  {Analyze command line for options}
  GetOptions;

  {Get all allocated memory blocks in normal memory}
  FindTheBlocks(Blocks, BlockMax, StartMcb, CommandSeg);

  {Find the last one marked with the MARK idstring, and MarkName if specified}
  if not FindMark(markName, MarkID, MarkOffset, MemMark, FilMark, markBlock) then
    Abort('No matching marker found, or protected marker encountered.');

  {Get file mark information into memory}
  if FilMark then
    ReadMarkFile(markName)
  else
    InitMarkInfo;

  {Mark those blocks to be released}
  MarkBlocks(markBlock);

  {Copy the vector table from the MARK copy}
  CopyVectors(markBlock);

  {Close open file handles}
  CloseHandles;

  {Release normal memory marked for release}
  ReleaseMem;

  {Deal with expanded memory}
  if DealWithEMS then
    if EMSpresent then
      RestoreEMSmap;

  {Write success message}
  if not Quiet then begin
    Write('Memory released after MARK');
    if markName <> '' then
      Write(' (', markName, ')');
    WriteLn;
    if ReturnCode <> 0 then
      WriteLn(TrappedBytes, ' bytes temporarily trapped until batch file completes');
  end;

  {Stuff keyboard buffer if requested}
  if Length(Keys) > 0 then
    StuffKeys(Keys, True);

  NoRestoreHalt(ReturnCode);
end.