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

Pascal/Delphi Source File | 1991-10-15 | 18.4 KB | 701 lines

{**************************************************************************
*   MEMU - utility unit for TSR Utilities.                                *
*   Copyright (c) 1991 Kim Kokkonen, TurboPower Software.                 *
*   May be freely distributed and used but not sold except by permission. *
***************************************************************************}

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

unit MemU;
  {-Miscellaneous memory functions needed for TSR Utilities}

interface

{Following may change when WATCH reassembled. Check WATCH.MAP}
const
  {Offsets into resident copy of WATCH.COM for data storage}
  WatchOfs = $80;             {Location of length of command line}
  WatchOffset = $81;          {Location of start of command line}
  NextChange = $104;
  ChangeVectors = $580;
  OrigVectors = $980;
  CurrVectors = $D80;
  WatchId = 'TSR WATCHER';    {ID placed in WATCH command line}
  MaxChanges = 128;           {Maximum number of vector changes stored in WATCH}

const
  MaxBlocks = 256;            {Max number of DOS allocation blocks supported}

type
  OS =
    record
      O, S : Word;
    end;

  NameArray = array[1..8] of Char;

  McbPtr = ^Mcb;
  Mcb =
    record
      Id : Char;
      Psp : Word;
      Len : Word;
      Unused : array[1..3] of Byte;
      Name : NameArray;
    end;

  Block =
  record                      {Store info about each memory block}
    mcb : Word;
    psp : Word;
    releaseIt : Boolean;
  end;

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

  McbGroup =
  record
    Count : Word;
    Mcbs : array[1..MaxBlocks] of
           record
             mcb : Word;
             psp : Word;
           end;
  end;

  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;

const
  RBR = 0; {Receiver buffer register offset}
  THR = 0; {Transmitter buffer register offset}
  BRL = 0; {Baud rate low}
  BRH = 1; {Baud rate high}
  IER = 1; {Interrupt enable register}
  IIR = 2; {Interrupt identification register}
  LCR = 3; {Line control register}
  MCR = 4; {Modem control register}
  LSR = 5; {Line status register}
  MSR = 6; {Modem status register}

type
  {Structure of a device driver header}
  DeviceHeader =
    record
      NextHeaderOffset : Word;    {Offset address of next device in chain}
      NextHeaderSegment : Word;   {Segment address of next device in chain}
      Attributes : Word;          {Device attributes}
      StrategyEntPt : Word;       {Offset in current segment - strategy}
      InterruptEntPt : Word;      {Offset in current segment - interrupt}
      DeviceName : array[1..8] of Char; {Name of the device}
    end;
  DeviceHeaderPtr = ^DeviceHeader;
  DeviceArray = array[1..256] of DeviceHeaderPtr;

  FileRec =
    record
      OpenCnt : Word;
      OpenMode : Word;
      Attribute : Byte;
      Unknown1 : Word;
      DCB : Pointer;
      InitCluster : Word;
      Time : Word;
      Date : Word;
      Size : LongInt;
      Pos : LongInt;
      BeginCluster : Word;
      CurCluster : Word;
      Block : Word;
      Unknown2 : Byte;            {Varies with DOS version beyond here}
      Name : array[0..7] of Char;
      Ext : array[0..2] of Char;
      Unknown3 : array[0..5] of Byte;
      Owner : Word;
      Unknown4 : Word;
    end;

  SftRecPtr = ^SftRec;
  SftRec =
    record
      Next : SftRecPtr;
      Count : Word;
      Files : array[1..255] of FileRec;
    end;

  DosRec =
    record
      McbSeg : Word;
      FirstDPB : Pointer;
      FirstSFT : SftRecPtr;
      ClockDriver : Pointer;
      ConDriver : Pointer;
      MaxBlockBytes : Word;
      CachePtr : Pointer;
      DriveTable : Pointer;
      Unknown2 : Pointer;
      Unknown3 : Word;
      BlockDevices : Byte;
      LastDrive : Byte;
      NullDevice : DeviceHeader;
    end;
  DosRecPtr = ^DosRec;

  ComRec =  {State of the communications system}
    record
      Base : Word;
      IERReg : Byte;
      LCRReg : Byte;
      MCRReg : Byte;
      BRLReg : Byte;
      BRHReg : Byte;
    end;
  ComArray = array[1..2] of ComRec;

const
  Digits : array[0..$F] of Char = '0123456789ABCDEF';
  DosDelimSet : set of Char = ['\', ':', #0];

var
  DosV : Byte;       {Major DOS version number}
  DosList : Pointer; {Pointer to DOS list of lists}
  Mcb1 : McbPtr;     {First MCB in system}

function GetDosListPtr : Pointer;
  {-Return address of DOS list of lists}

function GetUmbLinkStatus : Boolean;
  {-Return status of DOS 5 upper memory block link}

function SetUmbLinkStatus(On : Boolean) : Word;
  {-Change state of DOS 5 upper memory block link}

function DosVersion : Byte;
  {-Return major DOS version number}

function TopOfMemSeg : Word;
  {-Return segment of top of memory}

function HiMemAvailable(DosV : Byte) : Boolean;
  {-Return True if HiMem is available}

function HexB(B : Byte) : String;
  {-Return hex string for byte}

function HexW(W : Word) : String;
  {-Return hex string for word}

function HexPtr(P : Pointer) : string;
  {-Return hex string for pointer}

function StUpcase(s : String) : String;
  {-Return the uppercase string}

function JustFilename(PathName : String) : String;
  {-Return just the filename of a pathname}

function JustName(PathName : String) : String;
  {-Return just the name (no extension, no path) of a pathname}

function Extend(S : String; Len : Byte) : String;
  {-Truncate or pad S to length Len}

function SmartExtend(S : String; Len : Byte) : String;
  {-Truncate or pad S to length Len; end with '...' if truncated}

function Asc2Str(Name : NameArray) : String;
  {-Convert array[1..8] of char to string}

procedure StripNonAscii(var S : String);
  {-Return an empty string if input contains non-ASCII characters}

function CommaIze(L : LongInt; Width : Byte) : String;
  {-Convert L to a string and add commas for thousands}

function HasEnvironment(M : McbPtr) : Boolean;
  {-Return True if M has an associated environment block}

function NameFromEnv(M : McbPtr) : String;
  {-Return M's name from its environment (already known to exist)}

function NameFromMcb(M : McbPtr) : String;
  {-Return name from the Mcb (DOS 4+ only)}

function MasterCommandSeg : Word;
  {-Return PSP segment of master COMMAND.COM}

function WatchPspSeg : Word;
  {-Find copy of WATCH.COM in memory, returning its PSP segment or zero}

procedure FindTheBlocks(var Blocks : BlockArray;
                        var BlockMax : BlockType;
                        var StartMcb : Word;
                        var CommandSeg : Word);
  {-Scan memory for the allocated memory blocks}

procedure StuffKey(W : Word);
  {-Stuff one key into the keyboard buffer}

procedure StuffKeys(Keys : string; ClearFirst : Boolean);
  {-Stuff up to 16 keys into keyboard buffer}

function ExistFile(path : String) : Boolean;
  {-Return true if file exists}

  {=======================================================================}

implementation

  function GetDosListPtr : Pointer; Assembler;
    {-Return address of DOS list of lists}
  asm
    mov     ah,$52
    int     $21
    mov     dx,es
    mov     ax,bx
  end;

  function GetUmbLinkStatus : Boolean; Assembler;
    {-Return status of DOS 5 upper memory block link}
  asm
    mov     ax,$5802
    int     $21
  end;

  function SetUmbLinkStatus(On : Boolean) : Word; Assembler;
    {-Change state of DOS 5 upper memory block link}
  asm
    mov     ax,$5803
    mov     bl,On
    xor     bh,bh
    int     $21
    jc      @1
    xor     ax,ax
@1:
  end;

  function DosVersion : Byte; Assembler;
    {-Return major DOS version number}
  asm
    mov     ah,$30
    int     $21
  end;

  function TopOfMemSeg : Word;
    {-Return segment of top of memory}
  var
    KBRAM : Word;
  begin
    asm
      int $12
      mov KBRAM,ax
    end;
    TopOfMemSeg := KBRAM shl 6;
  end;

  function HiMemAvailable(DosV : Byte) : Boolean;
    {-Return True if HiMem is available}
  begin
    HiMemAvailable := (DosV >= 5) and (DosV < 10);
  end;

  function HexB(B : Byte) : String;
    {-Return hex string for byte}
  begin
    HexB[0] := #2;
    HexB[1] := Digits[B shr 4];
    HexB[2] := Digits[B and $F];
  end;

  function HexW(W : Word) : String;
    {-Return hex string for word}
  begin
    HexW[0] := #4;
    HexW[1] := Digits[Hi(W) shr 4];
    HexW[2] := Digits[Hi(W) and $F];
    HexW[3] := Digits[Lo(W) shr 4];
    HexW[4] := Digits[Lo(W) and $F];
  end;

  function HexPtr(P : Pointer) : string;
    {-Return hex string for pointer}
  begin
    HexPtr := HexW(OS(P).S)+':'+HexW(OS(P).O);
  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 JustFilename(PathName : String) : String;
    {-Return just the filename of a pathname}
  var
    I : Word;
  begin
    I := Word(Length(PathName))+1;
    repeat
      Dec(I);
    until (PathName[I] in DosDelimSet) or (I = 0);
    JustFilename := Copy(PathName, I+1, 64);
  end;

  function JustName(PathName : String) : String;
    {-Return just the name (no extension, no path) of a pathname}
  var
    DotPos : Byte;
  begin
    PathName := JustFilename(PathName);
    DotPos := Pos('.', PathName);
    if DotPos > 0 then
      PathName := Copy(PathName, 1, DotPos-1);
    JustName := PathName;
  end;

  function Extend(S : String; Len : Byte) : String;
    {-Truncate or pad S to length Len}
  begin
    if Length(S) < Len then
      FillChar(S[Length(S)+1], Len-Length(S), ' ');
    S[0] := Char(Len);
    Extend := S;
  end;

  function SmartExtend(S : String; Len : Byte) : String;
    {-Truncate or pad S to length Len; end with '...' if truncated}
  begin
    if Length(S) > Len then
      SmartExtend := copy(S, 1, Len-3)+'...'
    else
      SmartExtend := Extend(S, Len);
  end;

  function Asc2Str(Name : NameArray) : String;
    {-Convert array[1..8] of char to string}
  var
    I : Integer;
  begin
    I := 1;
    while (I <= 8) and (Name[I] <> #0) and (Name[I] <> ' ') do begin
      Asc2Str[I] := Name[I];
      Inc(I);
    end;
    Asc2Str[0] := Char(I-1);
  end;

  procedure StripNonAscii(var S : String);
    {-Return an empty string if input contains non-ASCII characters}
  var
    I : Integer;
    Ok : Boolean;
  begin
    Ok := True;
    I := 1;
    while Ok and (I <= Length(S)) do begin
      case S[I] of
        #0..#31, #126..#255 : Ok := False;
      end;
      Inc(I);
    end;
    if not Ok then
      S := '';
  end;

  function CommaIze(L : LongInt; Width : Byte) : String;
    {-Convert L to a string and add commas for thousands}
  var
    I : Word;
    Len : Word;
    S : String[19];
  begin
    Str(L, S);
    Len := Length(S);
    I := Len;
    while I > 1 do begin
      if (Len+1-I) mod 3 = 0 then
        insert(',', S, I);
      dec(I);
    end;
    while Length(S) < Width do
      insert(' ', S, 1);
    CommaIze := S;
  end;

  function HasEnvironment(M : McbPtr) : Boolean;
    {-Return True if M has an associated environment block}
  var
    N : McbPtr;
    EnvSeg : Word;
    Done : Boolean;
  begin
    EnvSeg := MemW[M^.Psp:$2C];
    N := Mcb1;
    repeat
      if (N^.Psp = M^.Psp) and (EnvSeg = OS(N).S+1) then begin
        HasEnvironment := True;
        Exit;
      end;
      Done := (N^.Id = 'Z');
      N := Ptr(OS(N).S+N^.Len+1, 0);
    until Done;
    HasEnvironment := False;
  end;

  function NameFromEnv(M : McbPtr) : String;
    {-Return M's name from its environment (already known to exist)}
  type
    CharArray = array[0..32767] of Char;
    CharArrayPtr = ^CharArray;
  var
    E : Word;
    Eptr : CharArrayPtr;
    Name : String[79];
    Nlen : Byte absolute Name;
  begin
    Eptr := Ptr(MemW[M^.Psp:$2C], 0);
    E := 0;
    repeat
      if Eptr^[E] = #0 then begin
        Inc(E);
        if Eptr^[E] = #0 then begin
          {found end of environment}
          Inc(E, 3);
          Nlen := 0;
          while (Nlen < 63) and (Eptr^[E] <> #0) do begin
            Inc(Nlen);
            Name[Nlen] := Eptr^[E];
            Inc(E);
          end;
          StripNonAscii(Name);
          NameFromEnv := JustName(Name);
          Exit;
        end;
      end;
      Inc(E);
    until (E > 32767);
    NameFromEnv := '';
  end;

  function NameFromMcb(M : McbPtr) : String;
    {-Return name from the Mcb (DOS 4+ only)}
  var
    Name : String[79];
  begin
    Name := Asc2Str(M^.Name);
    StripNonAscii(Name);
    NameFromMcb := Name;
  end;

  function MasterCommandSeg : Word;
    {-Return PSP segment of master COMMAND.COM}
  var
    curmcb : mcbptr;
    mseg : word;
    par : word;
  begin
    {First block}
    curmcb := mcb1;
    repeat
      curmcb := ptr(OS(curmcb).s+curmcb^.len+1, 0);
      par := memw[curmcb^.psp:$16];
      mseg := OS(curmcb).s;
      if (par = curmcb^.psp) and (mseg+1 = curmcb^.psp) then begin
        MasterCommandSeg := curmcb^.psp;
        exit;
      end;
    until curmcb^.id = 'Z';
    MasterCommandSeg := 0;
  end;

  function WatchPspSeg : Word;
    {-Find copy of WATCH.COM in memory, returning its PSP segment or zero}
  label
    ExitPoint;
  var
    Status : Word;
    M : McbPtr;
    Done : Boolean;
    LinkStatus : Boolean;

    function HasIdString(Segment, Offset : Word; Id : String) : Boolean;
      {-Return True if Id appears at Segment:Offset}
    var
      P : ^String;
    begin
      P := Ptr(Segment, Offset);
      HasIdString := (P^ = Id);
    end;

  begin
    {Access high memory if available}
    if HiMemAvailable(DosV) then begin
      LinkStatus := GetUmbLinkStatus;
      Status := SetUmbLinkStatus(True);
    end;
    M := Mcb1;
    repeat
      if HasIdString(M^.Psp, WatchOfs, WatchId) then begin
        WatchPspSeg := M^.Psp;
        goto ExitPoint;
      end;
      Done := (M^.Id = 'Z');
      M := Ptr(OS(M).S+M^.Len+1, 0);
    until Done;
    {Not found if we get here}
    WatchPspSeg := 0;
ExitPoint:
    if HiMemAvailable(DosV) then
      Status := SetUmbLinkStatus(LinkStatus);
  end;

  procedure FindTheBlocks(var Blocks : BlockArray;
                          var BlockMax : BlockType;
                          var StartMcb : Word;
                          var CommandSeg : Word);
    {-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}

    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(BlockMax);
        gotFirst := True;
        with Blocks[BlockMax] do begin
          mcb := mcbSeg;
          psp := PspAdd;
        end;
        {Store master COMMAND.COM segment}
        if CommandSeg = 0 then
          if (McbSeg+1 = PspAdd) and (MemW[PspAdd:$16] = PspAdd) then
            CommandSeg := PspAdd;
      end;
    end;

  begin

    {Initialize}
    StartMCB := OS(MCB1).S;
    mcbSeg := StartMCB;
    gotFirst := False;
    gotLast := False;
    BlockMax := 0;
    CommandSeg := 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}
        gotLast := True;
    until gotLast;
  end;

  const
    KbdStart = $1E;
    KbdEnd = $3C;
  var
    KbdHead : Word absolute $40 : $1A;
    KbdTail : Word absolute $40 : $1C;

  procedure StuffKey(W : Word);
    {-Stuff one key into the keyboard buffer}
  var
    SaveKbdTail : Word;
  begin
    SaveKbdTail := KbdTail;
    if KbdTail = KbdEnd then
      KbdTail := KbdStart
    else
      Inc(KbdTail, 2);
    if KbdTail = KbdHead then
      KbdTail := SaveKbdTail
    else
      MemW[$40:SaveKbdTail] := W;
  end;

  procedure StuffKeys(Keys : string; ClearFirst : Boolean);
    {-Stuff up to 16 keys into keyboard buffer}
  var
    Len : Byte;
    I : Byte;
  begin
    if ClearFirst then
      KbdTail := KbdHead;
    Len := Length(Keys);
    if Len > 16 then
      Len := 16;
    for I := 1 to Length(Keys) do
      StuffKey(Ord(Keys[I]));
  end;

  function ExistFile(path : String) : Boolean;
    {-Return true if file exists}
  var
    f : file;
  begin
    Assign(f, path);
    Reset(f);
    if IoResult = 0 then begin
      ExistFile := True;
      Close(f);
    end else
      ExistFile := False;
  end;

begin
  DosV := DosVersion;
  DosList := GetDosListPtr;     {pointer to dos list of lists}
  Mcb1 := Ptr(MemW[OS(DosList).S:OS(DosList).O-2], 0); {first Mcb}
end.