ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/UTILITY/SYSTEM/TSRSRC31.ZIP/MARKNET.PAS

Pascal/Delphi Source File | 1991-11-04 | 18.3 KB | 677 lines

{**************************************************************************
*   MARKNET - stores system information in a file for later restoration.  *
*   Copyright (c) 1986,1991 Kim Kokkonen, TurboPower Software.            *
*   May be freely distributed and used but not sold except by permission. *
***************************************************************************
*   Version 2.7 3/4/89                                                    *
*     first public release                                                *
*     (based on FMARK 2.6)                                                *
*   Version 2.8 3/10/89                                                   *
*     store the DOS environment                                           *
*     store information about the async ports                             *
*   Version 2.9 5/4/89                                                    *
*     for consistency                                                     *
*   Version 3.0 7/21/91                                                   *
*     for compatibility with DOS 5                                        *
*     add Quiet option                                                    *
*     save BIOS LPT port data areas                                       *
*     save XMS allocation                                                 *
*     add code for tracking high memory                                   *
*   Version 3.1 11/4/91                                                   *
*     no change                                                           *
***************************************************************************
*   Telephone: [phone], CompuServe: 76004,2611.                      *
*   Requires Turbo Pascal 6 to compile.                                   *
***************************************************************************}

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

{.$DEFINE Debug}         {Activate for status messages}
{.$DEFINE MeasureStack}  {Activate to measure stack usage}

program MarkNet;

uses
  Dos,
  MemU,
  Xms,
  Ems;

const
  Version = '3.1';
  NmarkID = 'MN3.1 TSR';          {Marking string for TSR file mark}
  NetMarkID = 'MN31';             {ID at start of net mark file}
  NmarkOffset = $60;              {Where NmarkID is found in MARKNET TSR}

const
  MarkFOpen : Boolean = False;    {True while mark file is open}
  Quiet : Boolean = False;        {Set True to avoid screen output}

var
  MarkName : PathStr;             {Name of mark file}

  DevicePtr : ^DeviceHeader;      {Pointer to the next device header}
  DeviceSegment : Word;           {Current device segment}
  DeviceOffset : Word;            {Current device offset}
  MarkF : file;                   {Dump file}
  DosPtr : ^DosRec;               {Pointer to internal DOS table}
  CommandSeg : Word;              {PSP segment of primary COMMAND.COM}
  CommandPsp : array[1..$100] of Byte;
  FileTableA : array[1..5] of SftRecPtr;
  FileTableCnt : Word;
  FileRecSize : Word;
  EHandles : Word;                {For tracking EMS allocation}
  EmsPages : ^PageArray;
  XHandles : Word;                {For tracking XMS allocation}
  XmsPages : XmsHandlesPtr;
  McbG : McbGroup;                {Mcbs allocated as we go resident}

  SaveExit : Pointer;

  {$IFDEF MeasureStack}
  I : Word;
  {$ENDIF}

  procedure ExitHandler; far;
    {-Trap error exits (only)}
  begin
    ExitProc := SaveExit;
    if MarkFOpen then begin
      if IoResult = 0 then ;
      Close(MarkF);
      if IoResult = 0 then ;
      Erase(MarkF);
    end;
    {Turbo will swap back, so undo what we've done already}
    SwapVectors;
  end;

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

  procedure FindDevChain;
    {-Return segment, offset and pointer to NUL device}
  begin
    DosPtr := Ptr(OS(DosList).S, OS(DosList).O-2);
    DevicePtr := @DosPtr^.NullDevice;
    DeviceSegment := OS(DevicePtr).S;
    DeviceOffset := OS(DevicePtr).O;
  end;

  procedure CheckWriteError;
    {-Check for errors writing to mark file}
  begin
    if IoResult = 0 then
      Exit;
    Abort('Error writing to '+MarkName);
  end;

  procedure SaveStandardInfo;
    {-Save the ID string, the vectors, and so on}
  type
    IDArray = array[1..4] of Char;
  var
    ID : IDArray;
  begin
    {Write the ID string}
    {$IFDEF Debug}
    WriteLn('Writing mark file ID string');
    {$ENDIF}
    ID := NetMarkID;
    BlockWrite(MarkF, ID, SizeOf(IDArray));
    CheckWriteError;

    {Write the start address of the device chain}
    {$IFDEF Debug}
    WriteLn('Writing null device address');
    {$ENDIF}
    BlockWrite(MarkF, DevicePtr, SizeOf(Pointer));
    CheckWriteError;

    {Write the vector table}
    {$IFDEF Debug}
    WriteLn('Writing interrupt vector table');
    {$ENDIF}
    BlockWrite(MarkF, Mem[0:0], 1024);
    CheckWriteError;

    {Write miscellaneous save areas}
    {$IFDEF Debug}
    WriteLn('Writing EGA save table');
    {$ENDIF}
    BlockWrite(MarkF, Mem[$40:$A8], 8); {EGA save table}
    CheckWriteError;
    {$IFDEF Debug}
    WriteLn('Writing interapplications communication area');
    {$ENDIF}
    BlockWrite(MarkF, Mem[$40:$F0], 16); {Interapplications communication area}
    CheckWriteError;
    {$IFDEF Debug}
    WriteLn('Writing parent PSP segment');
    {$ENDIF}
    BlockWrite(MarkF, Mem[PrefixSeg:$16], 2); {Parent's PSP segment}
    CheckWriteError;
    {$IFDEF Debug}
    WriteLn('Writing BIOS printer table');
    {$ENDIF}
    BlockWrite(MarkF, Mem[$40:$8], 10); {Printer ports plus #printers}
    CheckWriteError;

    {Write EMS information}
    if EMSpresent then begin
      if MaxAvail < 2048 then
        Abort('Insufficient memory');
      GetMem(EmsPages, 2048);
      EHandles := EMSHandles(EmsPages^);
    end else
      EHandles := 0;
    {$IFDEF Debug}
    WriteLn('Writing EMS handle information');
    {$ENDIF}
    BlockWrite(MarkF, EHandles, SizeOf(Word));
    if EHandles <> 0 then
      BlockWrite(MarkF, EmsPages^, SizeOf(HandlePageRecord)*EHandles);
    CheckWriteError;

    {Write XMS information}
    if XmsInstalled then
      XHandles := GetXmsHandles(XmsPages)
    else
      XHandles := 0;
    {$IFDEF Debug}
    WriteLn('Writing XMS handle information');
    {$ENDIF}
    BlockWrite(MarkF, XHandles, SizeOf(Word));
    if XHandles <> 0 then
      BlockWrite(MarkF, XmsPages^, SizeOf(XmsHandleRecord)*XHandles);
    CheckWriteError;
  end;

  procedure SaveDevChain;
    {-Save the device driver chain}
  begin
    {$IFDEF Debug}
    WriteLn('Saving device driver chain');
    {$ENDIF}
    while OS(DevicePtr).O <> $FFFF do begin
      BlockWrite(MarkF, DevicePtr^, SizeOf(DeviceHeader));
      CheckWriteError;
      with DevicePtr^ do
        DevicePtr := Ptr(NextHeaderSegment, NextHeaderOffset);
    end;
  end;

  procedure BufferFileTable;
    {-Save an image of the system file table}
  var
    S : SftRecPtr;
    Size : Word;
  begin
    with DosPtr^ do begin
      S := FirstSFT;
      FileTableCnt := 0;
      while OS(S).O <> $FFFF do begin
        Inc(FileTableCnt);
        Size := 6+S^.Count*FileRecSize;
        if MaxAvail < Size then
          Abort('Insufficient memory');
        GetMem(FileTableA[FileTableCnt], Size);
        Move(S^, FileTableA[FileTableCnt]^, Size);
        S := S^.Next;
      end;
    end;
  end;

  procedure BufferAllocatedMcbs;
    {-Save an array of all allocated Mcbs}
  var
    M : McbPtr;
    Status : Word;
    LinkStatus : Boolean;
    Done : Boolean;
  begin
    {Access high memory if available}
    if HiMemAvailable(DosV) then begin
      LinkStatus := GetUmbLinkStatus;
      Status := SetUmbLinkStatus(True);
    end;
    McbG.Count := 0;
    M := Mcb1;
    repeat
      inc(McbG.Count);
      with McbG.Mcbs[McbG.Count] do begin
        mcb := OS(M).S;
        psp := M^.Psp;
      end;
      Done := (M^.Id = 'Z');
      M := Ptr(OS(M).S+M^.Len+1, 0);
    until Done;
    if HiMemAvailable(DosV) then
      Status := SetUmbLinkStatus(LinkStatus);
  end;

  procedure SaveDOSTable;
    {-Save the DOS internal variables table}
  var
    DosBase : Pointer;
    Size : Word;
  begin
    {$IFDEF Debug}
    WriteLn('Saving DOS data area at 0050:0000');
    {$ENDIF}
    BlockWrite(MarkF, mem[$50:$0], $200);
    CheckWriteError;
    DosBase := Ptr(OS(DosPtr).S, 0);
    Size := OS(DosPtr^.FirstSFT).O;
    {$IFDEF Debug}
    WriteLn('Saving DOS variables table at ', HexPtr(DosBase));
    {$ENDIF}
    BlockWrite(MarkF, Size, SizeOf(Word));
    BlockWrite(MarkF, DosBase^, Size);
    CheckWriteError;
  end;

  procedure SaveFileTable;
    {-Save the state of the file table}
  var
    I : Word;
    Size : Word;
  begin
    {$IFDEF Debug}
    WriteLn('Saving DOS file table at ', HexPtr(DosPtr^.FirstSFT));
    {$ENDIF}
    BlockWrite(MarkF, FileTableCnt, SizeOf(Word));
    for I := 1 to FileTableCnt do begin
      Size := 6+FileTableA[I]^.Count*FileRecSize;
      BlockWrite(MarkF, FileTableA[I]^, Size);
    end;
    CheckWriteError;
  end;

  procedure BufferCommandPSP;
    {-Save the PSP of COMMAND.COM}
  var
    PspPtr : Pointer;
  begin
    CommandSeg := MasterCommandSeg;
    PspPtr := Ptr(CommandSeg, 0);
    Move(PspPtr^, CommandPsp, $100);
  end;

  procedure SaveCommandPSP;
  begin
    {$IFDEF Debug}
    WriteLn('Saving COMMAND.COM PSP at ', HexW(CommandSeg), ':0000');
    {$ENDIF}
    BlockWrite(MarkF, CommandPsp, $100);
    CheckWriteError;
  end;

  procedure SaveCommandPatch;
    {-Restore the patch that NetWare applies to command.com}
  label
    ExitPoint;
  const
    Patch : array[0..14] of Char = ':/'#0'_______.___'#0;
  var
    Segm : Word;
    Ofst : Word;
    Indx : Word;
  begin
    for Segm := CommandSeg to PrefixSeg do
      for Ofst := 0 to 15 do begin
        Indx := 0;
        while (Indx <= 14) and (Patch[Indx] = Char(Mem[Segm:Ofst+Indx])) do
          Inc(Indx);
        if Indx > 14 then begin
          {$IFDEF Debug}
          WriteLn('Saving COMMAND patch address at ', HexW(Segm), ':', HexW(Ofst));
          {$ENDIF}
          goto ExitPoint;
        end;
      end;
    Segm := 0;
    Ofst := 0;
ExitPoint:
    BlockWrite(MarkF, Ofst, SizeOf(Word));
    BlockWrite(MarkF, Segm, SizeOf(Word));
    CheckWriteError;
  end;

  procedure FindEnv(CommandSeg : Word; var EnvSeg, EnvLen : Word);
    {-Return the segment and length of the master environment}
  var
    Mcb : Word;
  begin
    Mcb := CommandSeg-1;
    EnvSeg := MemW[CommandSeg:$2C];
    if EnvSeg = 0 then
      {Master environment is next block past COMMAND}
      EnvSeg := Commandseg+MemW[Mcb:3]+1;
    EnvLen := MemW[(EnvSeg-1):3] shl 4;
  end;

  procedure SaveDosEnvironment;
    {-Save the master copy of the DOS environment}
  var
    EnvSeg : Word;
    EnvLen : Word;
    P : Pointer;
  begin
    FindEnv(CommandSeg, EnvSeg, EnvLen);
    {$IFDEF Debug}
    WriteLn('Saving master environment, ', EnvLen, ' bytes at ', HexW(EnvSeg), ':0000');
    {$ENDIF}
    P := Ptr(EnvSeg, 0);
    BlockWrite(MarkF, EnvLen, SizeOf(Word));
    BlockWrite(MarkF, P^, EnvLen);
    CheckWriteError;
  end;

  procedure SaveCommState;
    {-Save the state of the communications controllers}
  var
    PicMask : Byte;
    Com : Byte;
    LCRSave : Byte;
    Base : Word;
    ComPortBase : array[1..2] of Word absolute $40:0; {Com port base addresses}

    procedure SaveReg(Offset : Byte);
      {-Save one communications register}
    var
      Reg : Byte;
    begin
      Reg := Port[Base+Offset];
      BlockWrite(MarkF, Reg, SizeOf(Byte));
      CheckWriteError;
    end;

  begin
    {$IFDEF Debug}
    WriteLn('Saving communications environment');
    {$ENDIF}

    {Save the 8259 interrupt enable mask}
    PicMask := Port[$21];
    BlockWrite(MarkF, PicMask, SizeOf(Byte));
    CheckWriteError;

    for Com := 1 to 2 do begin
      Base := ComPortBase[Com];

      {Save the Com port base address}
      BlockWrite(MarkF, Base, SizeOf(Word));
      CheckWriteError;

      if Base <> 0 then begin
        {Save the rest of the control state}
        SaveReg(IER);             {Interrupt enable register}
        SaveReg(LCR);             {Line control register}
        SaveReg(MCR);             {Modem control register}
        LCRSave := Port[Base+LCR]; {Save line control register}
        Port[Base+LCR] := LCRSave or $80; {Enable baud rate divisor registers}
        SaveReg(BRL);             {Baud rate divisor low}
        SaveReg(BRH);             {Baud rate divisor high}
        Port[Base+LCR] := LCRSave; {Restore line control register}
      end;
    end;
  end;

  procedure SaveAllocatedMcbs;
    {-Save list of allocated memory control blocks}
  begin
    {$IFDEF Debug}
    WriteLn('Saving memory allocation group');
    {$ENDIF}
    {Save the number of Mcbs}
    BlockWrite(MarkF, McbG.Count, SizeOf(Word));
    CheckWriteError;
    {Save the used Mcbs}
    BlockWrite(MarkF, McbG.Mcbs, 2*SizeOf(Word)*McbG.Count);
    CheckWriteError;
  end;

  function CompaqDOS30 : Boolean; assembler;
    {-Return true if Compaq DOS 3.0}
  asm
    mov ah,$34
    int $21
    cmp bx,$019C
    mov al,1
    jz @Done
    dec al
@Done:
  end;

  procedure ValidateDosVersion;
    {-Assure supported version of DOS and compute size of DOS internal filerec}
  var
    DosVer : Word;
  begin
    DosVer := DosVersion;
    case Lo(DosVer) of
      3 : if (Hi(DosVer) < $0A) and not CompaqDOS30 then
            {IBM DOS 3.0}
            FileRecSize := 56
          else
            {DOS 3.1+ or Compaq DOS 3.0}
            FileRecSize := 53;
      4, 5 : FileRecSize := 59;
    else
      Abort('Requires DOS 3, 4, or 5');
    end;
  end;

  procedure SaveIDStrings;
    {-Save identification strings within the PSP}
  var
    ID : String[10];
  begin
    Move(MarkName, Mem[PrefixSeg:$80], Length(MarkName)+1);
    Mem[PrefixSeg:$80+Length(MarkName)+1] := 13;
    ID := NmarkID;
    Move(ID[1], Mem[PrefixSeg:NmarkOffset], Length(ID));
  end;

  procedure CloseStandardFiles;
    {-Close all standard files}
  var
    H : Word;
  begin
    for H := 0 to 4 do
      asm
        mov ah,$3E
        mov bx,H
        int $21
      end;
  end;

  procedure GetOptions;
    {-Get command line options}
  var
    I : Word;
    Arg : String[127];

    procedure UnknownOption;
    begin
      WriteLn('Unknown command line option: ', Arg);
      Halt(1);
    end;

    procedure BadOption;
    begin
      WriteLn('Invalid command line option: ', Arg);
      Halt(1);
    end;

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

    procedure WriteHelp;
    begin
      WriteCopyright;
      WriteLn;
      WriteLn('MARKNET saves a picture of the PC system status in a file,');
      WriteLn('so that the state can later be restored by using RELNET.');
      WriteLn;
      WriteLn('MARKNET accepts the following command line syntax:');
      WriteLn;
      WriteLn('  MARKNET [Options] MarkFile');
      WriteLn;
      WriteLn('Options may be preceded by either / or -. Valid options are as follows:');
      WriteLn('     /Q     write no screen output.');
      WriteLn('     /?     write this help screen.');
      Halt(1);
    end;

  begin
    MarkName := '';
    I := 1;
    while I <= ParamCount do begin
      Arg := ParamStr(I);
      if Arg = '?' then
        WriteHelp
      else
        case Arg[1] of
          '-', '/' :
            case Length(Arg) of
              1 : BadOption;
              2 : case Upcase(Arg[2]) of
                    '?' : WriteHelp;
                    'Q' : Quiet := True;
                  else
                    BadOption;
                  end;
            else
              UnknownOption;
            end;
        else
          if Length(MarkName) <> 0 then
            BadOption
          else
            MarkName := StUpcase(Arg);
        end;
      Inc(I);
    end;
    {Assure mark file specified}
    if Length(MarkName) = 0 then
      WriteHelp;
    if not Quiet then
      WriteCopyright;
  end;

begin
  {$IFDEF MeasureStack}
  fillchar(mem[sseg:0], sptr-16, $AA);
  {$ENDIF}

  {Must run with standard DOS vectors}
  SwapVectors;
  SaveExit := ExitProc;
  ExitProc := @ExitHandler;

  {Get command line options}
  GetOptions;

  {Assure supported version of DOS}
  ValidateDosVersion;

  {Find the device driver chain and the DOS internal table}
  FindDevChain;

  {Save PSP region of COMMAND.COM}
  BufferCommandPSP;

  {Buffer the DOS file table}
  BufferFileTable;

  {Deallocate environment}
  asm
    mov es,PrefixSeg
    mov es,es:[$002C]
    mov ah,$49
    int $21
  end;

  {Buffer the allocated mcb array}
  BufferAllocatedMcbs;

  {Open the mark file}
  Assign(MarkF, MarkName);
  Rewrite(MarkF, 1);
  if IoResult <> 0 then
    Abort('Error creating '+MarkName);
  MarkFOpen := True;

  {Save ID string, interrupt vectors and other standard state information}
  SaveStandardInfo;

  {Save the device driver chain}
  SaveDevChain;

  {Save the DOS internal variables table}
  SaveDOSTable;

  {Save the DOS internal file management table}
  SaveFileTable;

  {Save the PSP of COMMAND.COM}
  SaveCommandPSP;

  {Save the location that NetWare may patch in COMMAND.COM}
  SaveCommandPatch;

  {Save the master copy of the DOS environment}
  SaveDosEnvironment;

  {Save the state of the communications controllers}
  SaveCommState;

  {Save list of allocated memory control blocks}
  SaveAllocatedMcbs;

  {Close mark file}
  Close(MarkF);
  CheckWriteError;

  {Move ID strings into place}
  SaveIDStrings;

  if not Quiet then
    WriteLn('Stored mark information in ', MarkName);

  {$IFDEF MeasureStack}
  I := 0;
  while I < SPtr-16 do
    if mem[sseg:i] <> $AA then begin
      writeln('unused stack ', i, ' bytes');
      I := SPtr;
    end else
      inc(I);
  {$ENDIF}

  Flush(Output);

  {Close file handles}
  CloseStandardFiles;

  {Go resident}
  asm
    mov dl,byte ptr markname
    xor dh,dh
    add dx,$0090
    mov cl,4
    shr dx,cl
    mov ax,$3100
    int $21
  end;
end.