phantom.pas

大量的汇编程序源代码

    isrc:=lsrc;
    if not back_1(a1^,isrc) then begin fail(3); exit; end;
    if not process_path(a1,isrc) then exit;
    mode:=sda4_rec(sda^).spop_mode and $7f;
    action:=sda4_rec(sda^).spop_act;
{ First, check if file must or must not exist }
    if ((((action and $f)=0) and (isrc<>0)) or
        (((action and $f0)=0) and (isrc=0))) then begin fail(5); exit; end;

    if ifile=0 then 
        begin
{ Creating new file }
            result:=2;
            ifile:=isrc;
            inc(isrc);
            if isrc=lsrc then begin fail(13); ifile:=0; exit; end;
            fillchar(file_name,13,#0);
            move(a1^[isrc],file_name,lsrc-isrc);
        end
    else

    if ifile=isrc then
        begin
{ Open/Truncate existing file }
            inc(isrc);
            fillchar(temp_name,13,#0);
            move(a1^[isrc],temp_name,lsrc-isrc);
            if temp_name<>file_name then begin fail(82); exit; end;
            if boolean(action and 2) then
                result:=3           { File existed, was replaced }
            else
                result:=1;          { File existed, was opened }
            if boolean(file_attr and $1) and
                ((result=3) or ((mode and 3)>0)) then
                begin fail(5); exit; end;   { It's a read only file }
            if (result=3) { and (file_opens>0) } then
                begin fail(5); exit; end;   { Truncating an open file }
        end
    else fail(5);

{ Initialize the supplied SFT entry }
    with sft_rec(ptr(r.es,r.di)^) do
        begin
            if result>1 then
                begin
                    file_attr:=byte(ptr(r.ss,r.sp)^); { Attr is top of stack }
                    f_size:=0;
                    file_size:=0;
                end;
            open_mode:=mode;
            cnvt2fcb(file_name,fcb_fn);
            { inc(file_opens); }
            f_pos:=0;
            f_time:=0;
            dev_info:=$8040 or drive_no; { Network drive, unwritten to }
            dir_sector:=0;
            dir_entryno:=0;
            devdrv_ptr:=nil;
            attr_byte:=file_attr;
            set_Owner(r.es,r.di);
        end;
end;

{ FindFirst - subfunction 1Bh }
procedure ffirst;
var isrc, lsrc : byte;
    sdb : sdb_ptr;
    der : dir_ptr;
    sa, fa : byte;
begin
    lsrc:=asclen(a1^);
    isrc:=lsrc;
    if not back_1(a1^,isrc) then begin fail(3); exit; end;
    if not process_path(a1,isrc) then exit;
    a2:=@max_path;
    if dos_major=3 then
        begin
            a1:=@sda3_rec(sda^).fcb_fn1;
            sdb:=@sda3_rec(sda^).sdb;
            der:=@sda3_rec(sda^).found_file;
            sa:=sda3_rec(sda^).srch_attr;
        end
    else
        begin
            a1:=@sda4_rec(sda^).fcb_fn1;
            sdb:=@sda4_rec(sda^).sdb;
            der:=@sda4_rec(sda^).found_file;
            sa:=sda4_rec(sda^).srch_attr;
        end;
    fa:=file_attr and $1e;
    inc(os(a2).o,succ(isrc));

{ First try and match volume label, if asked for }
    if ((sa=$08) or (boolean(sa and $08) and (isrc=iroot))) and
       match(a1^,vollab[1],sdb^,der^,0,isrc,sa) then exit;

{ Then try the one possible subdirectory, if asked for and if it exists }
    if boolean(sa and $10) and
       match(a1^,a2^,sdb^,der^,1,isrc,sa) then exit;

{ Finally try the one possible file, if asked for, if it exists, and if
  in this subdirectory }
    if (ifile=isrc) and 
       ((fa=0) or boolean(sa and fa)) and
       match(a1^,file_name,sdb^,der^,2,isrc,sa) then exit;

{ Otherwise report no more files }
    fail(18);
end;

{ FindFirst - subfunction 1Bh }
procedure fnext;
var fa : byte;
    sdb : sdb_ptr; der : dir_ptr;
begin
    if dos_major=3 then
        begin
            sdb:=@sda3_rec(sda^).sdb;
            der:=@sda3_rec(sda^).found_file;
        end
    else
        begin
            sdb:=@sda4_rec(sda^).sdb;
            der:=@sda4_rec(sda^).found_file;
        end;
    fa:=file_attr and $1e;
    inc(sdb^.dir_entry);
    case sdb^.dir_entry of
        1 : a2:=@max_path[succ(sdb^.par_clstr)];
        2 : a2:=@file_name;
        else begin fail(18); exit; end;
    end;

{ First try the one possible subdirectory, if it exists. FNext can never
  match a volume label }
    if (sdb^.dir_entry=1) and boolean(sdb^.srch_attr and $10) and
        match(a1^,a2^,sdb^,der^,
            sdb^.dir_entry,sdb^.par_clstr,sdb^.srch_attr) then exit;

{ Then try the one possible file, if exists, and if in this subdirectory }
    if sdb^.dir_entry=1 then
        begin a2:=@file_name; sdb^.dir_entry:=2; end;
    if (sdb^.dir_entry=2) and (ifile=sdb^.par_clstr) and
        ((fa=0) or boolean(sdb^.srch_attr and fa)) and
        match(a1^,a2^,sdb^,der^,
            sdb^.dir_entry,sdb^.par_clstr,sdb^.srch_attr) then exit;

{ Otherwise return no more files }
    fail(18);
end;

{ Seek From End Of File - subfunction 21h }
procedure skfmend;
var skamnt : longint;
begin
    skamnt:=(longint(r.cx)*65536)+r.dx;
    { if file_opens=0 then begin fail(5); exit; end; }

{ Update supplied SFT entry for file }
    with sft_rec(ptr(r.es,r.di)^) do
        begin
            f_pos:=f_size-skamnt;
            r.dx:=f_pos shr 16;
            r.ax:=f_pos and $ffff;
        end;
end;

function call_for_us(es,di:word):boolean;
var p:pointer;
begin
    if (fxn in [_close.._unlock,_seek]) then
        call_for_us:=(sft_rec(ptr(es,di)^).dev_info and $1f)=drive_no
    else
    if fxn=_inquiry then call_for_us:=true
    else
        begin
            if dos_major=3 then p:=sda3_rec(sda^).drive_cdsptr
            else p:=sda4_rec(sda^).drive_cdsptr;
            call_for_us:=cdsidptr(p)^=cdsidptr(@max_path)^;
        end;
end;

{ This is the main entry point for the redirector. The procedure is actually
  invoked from the Int 2F ISR stub via a PUSHF and a CALL FAR IMMEDIATE
  instruction to simulate an interrupt.  That way we have many of the
  registers on the stack and DS set up for us by the TP interrupt keyword.
  This procedure saves the registers into the regset variable, assesses if
  the call is for our drive, and if so, calls the appropriate routine. On
  exit, it restores the (possibly modified) register values. }
procedure redirector(_flags,_cs,_ip,_ax,_bx,_cx,_dx,_si,_di,_ds,_es,_bp:word);
    interrupt;
begin
    with r do
        begin
            isr^.our_drive:=false;
{ If we don't support the call, pretend we didn't see it...! }
            if lo(_ax)>fxn_map_max then exit
            else fxn:=fxn_map[lo(_ax)];
            if fxn=_unsupported then exit;
{ If the call isn't for our drive, jump out here... }
            if not call_for_us(_es,_di) then exit;
{ Set up our full copy of the registers }
            isr^.our_drive:=true;
            move(_bp,bp,18); ss:=isr^.save_ss; sp:=isr^.save_sp;
            cs:=isr^.save_cs; ip:=isr^.save_ip; flags:=isr^.real_fl;
            ax:=0; flags:=flags and not fcarry;
            set_fn1;
            case fxn of
                _inquiry    : r.ax:=$00ff;
                _rd         : rd;
                _md         : md;
                _cd         : cd;
                _close      : clsfil;
                _commit     : cmmtfil;
                _read       : readfil;
                _write      : writfil;
                _space      : dskspc;
                _setattr    : setfatt;
                _lock, _unlock : ; 
                _getattr    : getfatt;
                _rename     : renfil;
                _delete     : delfil;
                _open       : opnfil;
                _create     : creatfil;
                _specopen   : spopnfil;
                _ffirst     : ffirst;
                _fnext      : fnext;
                _seek       : skfmend;
            end;
{ Restore the registers, including any that we have modified.. }
            move(bp,_bp,18); isr^.save_ss:=ss; isr^.save_sp:=sp;
            isr^.save_cs:=cs; isr^.save_ip:=ip; isr^.real_fl:=flags;
        end;
end;

{ This procedure sets up our ISR stub as a structure on the heap. It
  also ensures that the structure is addressed from an offset of 0 so
  that the CS overridden offsets in the ISR code line up. Finally. it
  fixes in some values which are only available to us at run time,
  either because they are variable, or because of limitations of the
  language. }
procedure init_isr_code;
var p:pointer;
    i:pointer absolute isr;
begin
    getmem(isr,sizeof(isr_rec)+15);
    inc(os(isr).s,(os(isr).o+15) shr 4);
    isr^.ic:=isr_code;
    getintvec($2f,p);
    os(isr).o:=redir_entry; pointer(i^):=@redirector;
    os(isr).o:=our_ss_ofs; word(i^):=sseg;
    os(isr).o:=our_sp_ofs; word(i^):=our_sp;
    os(isr).o:=prev_hndlr; pointer(i^):=p;
    os(isr).o:=0;
end;

{ Do our initializations }
procedure init_vars;
    function installed_2f:byte;
        { mov ax,1100h   int 2fh }
        inline($b8/$00/$11/$cd/$2f);
begin
    if installed_2f=1 then
        failprog('Not OK to install a redirector...'); 
    drive_no:=byte(drive[1])-byte('@');
    our_sp:=sptr+$100;
    { file_opens:=0; }
{ Note that the assumption is that we lost 100h bytes of stack
  on entry to main }
{ Initialise and fix-up the master copy of the ISR code }
    init_isr_code;
    ifile:=0;
end;

{ This is where we do the initializations of the DOS structures
  that we need in order to fit the mould }
procedure set_path_entry;
var our_cds:pointer;
begin
    our_cds:=lol_rec(lol^).cds;
    if dos_major=3 then
        inc(os(our_cds).o,sizeof(cds3_rec)*pred(drive_no))
    else
        inc(os(our_cds).o,sizeof(cds4_rec)*pred(drive_no));
    if drive_no>lol_rec(lol^).last_drive then
        failprog('Drive letter higher than last drive...'); 

{ Edit the Current Directory Structure for our drive }
    with cds3_rec(our_cds^) do
        begin
            ascii2string(@curr_path,@strbuf,255);
            writeln('Curr path is ',strbuf);
            if (flags and $c000)<>0 then
                failprog('Drive already assigned.');
            flags:=flags or $c000;  { Network+Physical bits on ... }
            strbuf:=cds_id;
            strbuf[length(strbuf)-2]:=char(byte('@')+drive_no);
            move(strbuf[1],curr_path,byte(strbuf[0]));
            move(curr_path,max_path,byte(strbuf[0]));
            curr_path[byte(strbuf[0])]:=#0;
            max_path[byte(strbuf[0])]:=#0;
            root_ofs:=pred(length(strbuf));
            iroot:=root_ofs;
            lmax:=iroot;
        end;
end;

{ Use in place of Turbo's 'keep' procedure. It frees the environment
  and keeps the size of the TSR in memory smaller than 'keep' does }
procedure tsr;
var r:registers;
begin
    swapvectors;
    r.ax:=$4900;
    r.es:=memw[prefixseg:$2c];
    msdos(r);
    r.ax:=$3100;
    r.dx:=os(heapptr).s-prefixseg+1;
    msdos(r);
end;

procedure settle_down;
var p:pointer;
    i:integer;
    w:word;
begin
{ Plug ourselves into Int 2F }
    setintvec($2f,isr);
    writeln('Phantom drive installed as ',drive[1],':');
{ Find ourselves a free interrupt to call our own. Without it, future
  invocations of Phantom will not be able to unload us. }
    i:=$60;
    while (i<=$67) and (pointer(ptr(0,i shl 2)^)<>nil) do inc(i);
    if i=$68 then 
        begin
            writeln('No user intrs available. PHANTOM not unloadable..');
            tsr;
        end;
{ Have our new found interrupt point at the command line area of 
  our PSP. Complete our signature record, put it into the command line, 
  and go to sleep. }
    w:=$80;
    setintvec(i,ptr(prefixseg,w));
    our.psp:=prefixseg;
    our.drive_no:=drive_no;
    sig_rec(ptr(prefixseg,w)^):=our;
    tsr;
end;

{ Find the latest Phantom installed, unplug it from the Int 2F chain if
  possible, undo the dpb chain, make the CDS reflect an invalid drive,
  and free its memory.. }
procedure do_unload;
var i:integer; p, cds:pointer; w:word; r:registers;
begin
    i:=$67;
    while (i>=$60) and
      (sig_rec(pointer(ptr(0,i shl 2)^)^).signature<>our.signature) do
        dec(i);
    if i=$5f then 
        begin writeln(our.signature,' not found...'); halt; end;
    getintvec($2f,p);
    if os(p).o<>0 then 
        failprog('2F superceded...'); 
    os(p).o:=prev_hndlr;
    setintvec($2f,pointer(p^));
    getintvec(i,p);
    drive_no:=sig_rec(p^).drive_no;
    with r do
        begin
            ax:=$4900; es:=sig_rec(p^).psp;
            msdos(r);
            if boolean(flags and fcarry) then
                writeln('Could not free main memory...');
        end;
    setintvec(i,nil);
    cds:=lol_rec(lol^).cds;
    if dos_major=3 then
        inc(os(cds).o,sizeof(cds3_rec)*pred(drive_no))
    else
        inc(os(cds).o,sizeof(cds4_rec)*pred(drive_no));
    with cds3_rec(cds^) do flags:=flags and $3fff;
    writeln('Drive ',char(byte('@')+drive_no),': is now invalid.');
end;

begin { MAIN }
{ Check parameter count }
    if (paramcount<>1) then
        failprog('Usage is: PHANTOM drive-letter:'); 
    drive:=paramstr(1);
    drive[1]:=upcase(drive[1]);
{ If this is an unload request, go to it }
    if (drive='-u') or (drive='-U') then
        begin
            get_dos_vars;
            do_unload;
            halt;
        end;
{ Otherwise, check that it's a valid drive letter }
    if  (length(drive)>2) or
        not (drive[1] in ['A'..'Z']) or
        ((length(drive)=2) and (drive[2]<>':'))
            then failprog('Usage is: PHANTOM drive-letter:'); 
{ ... and set up shop }
    init_vars;
    get_dos_vars;
    set_path_entry;
    settle_down;
end.