TopWare Tools/TOOLS.iso/tools/top1318/gepackt.exe/UTILITY/SOURCE/REMADI.PAS

Pascal/Delphi Source File | 1993-12-30 | 14.0 KB | 413 lines

{$R-}    {Bereichsprüfung aus}
{$B+}    {vollständige Auswertung boolscher Ausdrücke}
{$S+}    {Stackprüfung an}
{$I+}    {I/O-Prüfung an}
{$N-}    {kein numerischer Coprozessor}
{$M 10000,0,655360} {3.0-Standardvorgaben für Stack&Heap}

{ $u-}

uses
  umcb,autocopy,Dos;

type
  strtyp = array [1..10000] of char;
  string2 =string[2];
  string4 = string[4];
{***********************************************************}
{*                                                         *}
{*         UMWANDLUNG EINES BYTES IN EINE HEX-ZAHL         *}
{*                                                         *}
{***********************************************************}

  FUNCTION HEX1(B:BYTE):STRING2;
    CONST
      ASCII = '0123456789ABCDEF';
    VAR
      B1,B2 : BYTE;
    BEGIN
      B2:=B AND $0F;
      B1:=(B AND $F0) DIV 16;
      HEX1:=COPY(ASCII,B1+1,1)+COPY(ASCII,B2+1,1);
    END;

{***********************************************************}
{*                                                         *}
{*  UMWANDLUNG EINER INTEGER-ZAHL IN EINE HEX-ZAHL         *}
{*                                                         *}
{***********************************************************}

  FUNCTION HEXINT(I:INTEGER):STRING4;
    BEGIN
{      if i=0 then hexint:='    ' else}
      HEXINT:=HEX1(HI(I))+HEX1(LO(I));
    END;


function int(i : integer) : real;

  begin
    if i<0 then int:= 65536.0-i else int:=i;
  end;

type
  dword  = array [0..1] of word;
  mcbzeigertyp = ^mcbtyp;
  mcbtyp = record
             id : char;
             psp,len : word;
           end;
  pspzeigertyp = ^psptyp;
  psptyp = record
             int20   : word;
             freemem : word;
             dos     : byte;
             bioscall : array [0..4] of byte;
             int22,int23,
             int24   : dword;
             pid     : word;
             filestruc : array [$18..$2b] of byte;
             envseg  : word;
             stack   : dword;
             files   : word;
             fileptr : dword;
             dos1    : array [$38..$4f] of byte;
             doscall : dword;
             dos2    : array [$53..$5b] of byte;
           end;
  envstrtyp = array [1..$7fff] of char;
  batstrtyp = record
                b  : array [0..4] of byte;
                ff : array [1..20] of byte;
                name : array [1..128] of char;
              end;

  procedure get_first_mcb(var mcb : mcbzeigertyp);

(*    type
      cpuregtyp                        = registers;
      dos1typ                          = record
                                           dos             : array [1..3] of byte;
                                           nul             : word;
                                           dummy           : array [1..10] of byte;
                                         end;
      dos2typ                          = record
                                           dos             : array [1..4] of byte;
                                           nul             : word;
                                           dummy           : array [1..10] of byte;
                                         end;
      deviceztyp                       = ^devicetyp;
      devicezeigertyp                  = record
                                           case boolean of
                                             false  : (zeiger          : deviceztyp);
                                             true   : (offset,segment  : word);
                                         end;

      devicetyp                        = record
                                           next            : devicezeigertyp;
                                           attr,strat,intr : word;
                                           name            : array [1..8] of char;
                                         end;

    var
      cpureg                           : cpuregtyp;
      mcb1                             : mcbzeigertyp;
      psp                              : pspzeigertyp;
      st                               : boolean;
      mcbi                             : record
                                           offset,segment  : word;
                                         end absolute mcb;
      fcb                              : record
                                           disk            : byte;
                                           name            : array [1..11] of char;
                                           blkpos,blklen   : word;
                                           filelen         : array [0..1] of word;
                                           date,time       : word;
                                           case boolean of
                                             false         : (dos2 : dos1typ);
                                             true          : (dos3 : dos2typ);
                                         end;
      device,nul                       : devicezeigertyp;

    begin
      with cpureg do with fcb do begin
        name:='NUL        ';
        disk:=0;
        dx:=ofs(fcb);
        ds:=seg(fcb);
        ah:=$f;
        msdos(Dos.Registers(cpureg));
        dx:=ofs(fcb);
        ds:=seg(fcb);
    ah:=$10;
        msdos(Dos.Registers(cpureg));
    st:=al<>0;
        if not st then begin
          ah:=$30;
          msdos(Dos.Registers(cpureg));
          case al of
            2 : nul.zeiger:=ptr(dos2.nul,0);
            3 : nul.zeiger:=ptr(dos3.nul,0);
            else st:=true;
          end;
          if st then nul.zeiger:=ptr($40,0);
          repeat
            nul.offset:=succ(nul.offset);
          until (nul.offset=0) or (nul.zeiger^.name='NUL     ');
          st:=nul.offset=0;
          if not st then begin
            nul.segment:=nul.segment+nul.offset shr 4;
            nul.offset:=nul.offset and $f;
            device.zeiger:=nul.zeiger;
            repeat
              device.zeiger:=device.zeiger^.next.zeiger;
            until (device.zeiger^.next.zeiger=ptr($ffff,$ffff)) or (device.zeiger^.next.segment<nul.segment);
            st:=(device.segment<=nul.segment) or (device.zeiger^.next.zeiger=ptr($ffff,$ffff));
            if not st then mcb:=ptr(pred(seg(device.zeiger^)),0);
          end;
        end;
      end;
      mcb1:=ptr(seg(mcb^)+succ(mcb^.len),0);
      if (mcb^.id<>'M') or (mcb1^.id<>'M') or st then begin
        mcb:=ptr($40,0);
          while true do begin
          mcb1:=ptr(seg(mcb^)+succ(mcb^.len),0);
          if (mcb^.id='M') and (mcb1^.id='M') then begin
        psp:=ptr(1+(seg(mcb^)),0);
            if (psp^.int20=$20cd) and (seg(psp^)=psp^.pid) then exit;
        psp:=ptr(1+(seg(mcb1^)),0);
        if (psp^.int20=$20cd) and (seg(psp^)=psp^.pid) then exit;
      end;
      mcbi.segment:=succ(mcbi.segment);
    end;
      end;
    end;*)
    begin
      mcb:=pointer(mcbadr);
    end;

const
  max = $1fff;
  comstr : string[10] ='COMSPEC=';
  gueltig : set of char = [' '..#255];

var
  mcbs : array [1..max] of ^mcbtyp;
  envstr : ^envstrtyp;
  batstr : ^batstrtyp absolute envstr;
  mcb,mcb1  : mcbzeigertyp;
  psp  : psptyp;
  ch : char;
  s : string[127];
  str : ^strtyp;
  recs : registers;
  st,envst,comst : boolean;
  intr : pointer;
  st1,st2,st3,st4 : boolean;
  i,j,n,i1,i2 : word;
{    intrtable                        : array [0..255] of record
                                         case boolean of
                                           false    : (zeiger : pointer);
                                           true     : (lo,hi  : word);
                                       end;                           }
type
  string128 = string[128];

function gross(s : string128) : string128;

  var
    i                                  : byte;

  begin
    for i:=1 to length(s) do s[i]:=upcase(s[i]);
    gross:=s;
  end;

procedure remove(w : word);

  begin
    with recs do begin
      ah:=$49;
      es:=w;
      msdos(recs);
    end;
  end;

begin
  if paramstr(1)='?' then begin
    writeln('Bei Aufruf ohne Parameter werden die ADI-Treiber DSGENOA und PPDRV entfernt.');
    writeln('Bei Angabe der Adresse eines MCB als Hexzahl, wird dieser Speicherbereich');
    writeln('freigegeben. (Die Adressen werden von dem Programm MEM ausgegben.)');
    writeln('Von allen Programmen, die hinter der Option /e angegeben werden, wird das');
    writeln('Environment freigegeben.');
    writeln('Mit der Option /c kann der 1. Command.com aus dem Speicher entfernt werden,');
    writeln('aber nur dann, wenn kein anderes Programm vor ihm in Speicher steht.');
    halt;
  end;
  if (paramcount>0) and (copy(paramstr(1),1,1)<>'/') then begin
    for i:=1 to paramcount do begin
      s:=paramstr(i);
      j:=0;
      repeat
        ch:=upcase(s[1]);
        if s<>'' then case ch of
          '0'..'9' : j:=(j shl 4) + ord(ch) - ord('0');
          'A'..'F' : j:=(j shl 4) + ord(ch) - ord('A') + 10;
          else halt;
        end;
        delete(s,1,1);
      until s='';
      st:=false;
      mcb:=ptr(j,0);
      with mcb^ do begin
        if (id='Z') or (id='M') then begin
          st1:=true;
          if memw[psp:$2c]=succ(j) then memw[psp:$2c]:=0
          else if psp=succ(j) then begin
            for n:=0 to $40 do begin
              getintvec(n,intr);
              i1:=seg(intr^);
              if (i1>=psp) and (i1<psp+len) then st1:=false;
            end;
            remove(memw[psp:$2c]);
            if st1 then for n:=$41 to 255 do begin
              getintvec(n,intr);
              i1:=seg(intr^);
              if (i1>=psp) and (i1<psp+len) then setintvec(n,ptr(0,0));
            end;
          end;
          if st1 then remove(succ(j));
        end;
      end;
    end;
    halt;
  end;
  st2:=gross(paramstr(1))='/C';
  st3:=false;
  st4:=true;
  j:=0;
  i:=$0;
  n:=0;
  i1:=$00;
  comst:=false;
  get_first_mcb(mcb);
  n:=0;
{  writeln;
  writeln('T  Treiber   P  Programm   D  Data    E  Environment');
  writeln;}
  repeat
    n:=succ(n);
    mcb1:=mcb;
    with mcb^ do if (id='M') or (id='Z') then begin
{      if n mod 20 =1 then writeln('mcb   id  len   psp   env   next  lpsp  int20 ');
      write(hexint(seg(mcb^)),id:4,hexint(len):6,hexint(psp):6);
      if psp and $ff80=0 then write('':6) else write(hexint(memw[psp:$2c]):6);
      write(hexint(seg(mcb^)+succ(len)):6);
      if psp and $ff80=0 then write('':14)
      else write(hexint(memw[psp:16]):6,'  ',hexint(memw[psp:0]),'  ');}
      j:=memw[psp:$2c];
      st:=false;
      s:='';
      envstr:=ptr(1+(seg(mcb^)),0);
      with batstr^ do begin
        i1:=3;
        while (i1<21) and not st do begin
          st:=ff[i1]<>$ff;
          i1:=succ(i1);
        end;
        i1:=1;
        while not st and (i1<128) and (name[i1] in gueltig) do begin
          s:=s+name[i1];
          i1:=succ(i1);
        end;
        if name[i1]<>#0 then s:='';
      end;
      if st and (memw[pred(memw[psp:$2c]):1]=psp) then begin
        i1:=0;
        while (i1<2000) and (memw[j:i1]<>0) do i1:=succ(i1);
        while (i1<2000) and (memw[j:i1]<>1) do i1:=succ(i1);
        i1:=i1+2;
        if i1<2000 then begin
          i2:=0;
          while (i2<80) and (chr(mem[j:i1+i2]) in gueltig) do begin
            s:=s+chr(mem[j:i1+i2]);
            i2:=succ(i2);
          end;
          if mem[j:i1+i2]<>0 then s:='';
        end;
      end;
      if psp<$60 then s:='dos';
      if (psp=memw[psp:$16]) then s:='COMMAND.COM';
      st:=false;
      i1:=1;
      i2:=1;
      j:=1;
      envst:=memw[psp:$2c]=seg(envstr^);
      if psp<>8 then while (not st or (envstr^[i1]<>#0)) and (i1<=int(len)*16) and (i1>=0) and not envst do begin
        st:=envstr^[i1]=#0;
        if envstr^[i1]=comstr[i2] then begin
          i2:=succ(i2);
          envst:=i2>length(comstr);
        end
        else begin
          i2:=1;
          j:=succ(j);
          i1:=j;
        end;
        i1:=succ(i1);
      end;
      if psp=0 then begin
{        write(' ');}
        s:='frei';
      end
      else if envst then {write('E')}
      else if psp=8 then {write('T')}
      else if psp=1+(seg(mcb^)) then {write('P')} begin
        st1:=false;
        if (pos('COMMAND.COM',s)>0) and st4 then st3:=true
        else st4:=false;
        if not st2 then for j:=2 to paramcount do if pos(gross(paramstr(j)),s)>0 then st1:=true;
        if (pos('DSGENOA.EXE',S)+pos('PPDRV.EXE',s)+pos('DSADI.EXE',s)
        +pos('TPACK.COM',s)+pos('CEGADI8.EXE',s)+pos('CEGADI6.EXE',s)>0) or st1 then begin
      remove(memw[psp:$2c]);
          if not st1 then begin
            remove(psp);
            if pos('PPDRV.EXE',S)=0 then setintvec($7a,ptr(0,0))
            else setintvec($7b,ptr(0,0));
            writeln('remove adi-treiber ',s{,hexint(psp):6,hexint(len):6,hexint(memw[psp:$2c]):6});
          end
          else begin
            memw[psp:$2c]:=0;
            writeln('remove environment ',s);
          end;
        end;
      end
      else if st2 and (pos('COMMAND.COM',s)>0) and st3 then begin
        j:=pred(psp);
        i1:=memw[psp:$2c];
        i2:=mcbzeigertyp(ptr(j,0))^.len+psp;
        if i1<>0 then halt;
        if mcbzeigertyp(ptr(i2,0))^.psp=psp then remove(succ(i2));
        remove(psp);
    remove(1+(seg(mcb^)));
        writeln('remove 1. command.com');
{        writeln;
        writeln(' psp=',hexint(psp):6,' env=',hexint(i1):6,
                ' mcb=',hexint(seg(mcb^)):6,' next mcb=',hexint(i2):6,
                ' psp next mcb=',hexint(mcbzeigertyp(ptr(i2,0))^.psp));
        writeln(s,' D',hexint(psp):6);
        readln;}
        halt;
      end;
{      writeln(' ',s); }
    end;
    mcb:=ptr((seg(mcb^))+succ(mcb^.len),0);
    if (mcb^.id<>'M') and (seg(mcb^)<$c000) then begin
      mcb:=ptr($c000,0);
      while ((mcb^.id<>'M') or (seg(mcb^)+succ(mcb^.len)<$c000)) and (seg(mcb^)<$ffff) do begin
        inc(memw[seg(mcb):ofs(mcb)+2]);
      end;
    end;
  until mcb1^.id<>'M';
end.