phantom.pas

大量的汇编程序源代码

begin
    case fxn of
{ For these calls, a fully qualified file/directory name is given in the
  SDA first filename field. This field, incidentally, can also be referenced
  indirectly through the SDA first filename offset field into DOS's CS. }
        _rd .. _cd, _setattr .. _create, _ffirst, _specopen :
            if dos_major=3 then
                a1:=@sda3_rec(sda^).fn1
            else
                a1:=@sda4_rec(sda^).fn1;

{ These do not need a filename. The following is valid-ish... }
        _close .. _write, _seek : a1:=@sft_rec(ptr(r.es,r.di)^).fcb_fn;

{ For findnext, an fcb style filename template is available within the
  SDA search data block field }
        _fnext :
            if dos_major=3 then
                a1:=@sda3_rec(sda^).sdb.srch_tmpl
            else
                a1:=@sda4_rec(sda^).sdb.srch_tmpl;
    end;
end;

{ Back up a directory level, ie go back to the previous \ in a path string }
function back_1(var path:ascbuf; var i:byte):boolean;
begin
    if i=iroot then begin back_1:=false; exit; end;
    repeat dec(i) until (i=iroot) or (path[i]='\');
    back_1:=true;
end;

{ Check that the qualified pathname that is in a1 matches our full
  directory structure to length lsrc. If not, fail with 'Path not found' }
function process_path(a1 : ascptr; lsrc : byte):boolean;
var isrc : byte;
begin
    process_path:=false;
    isrc:=0; 
    for isrc:=0 to pred(lsrc) do
        if (isrc>lmax) or
            (a1^[isrc]<>max_path[isrc]) then
                begin fail(3); exit; end;
    inc(isrc);
    if max_path[isrc]<>'\' then fail(3)
    else process_path:=true;
end;

function the_time:longint; inline($b8/$0d/$12/$cd/$2f);

{ Change Directory - subfunction 05h }
procedure cd;
var lsrc : byte;
begin
    lsrc:=asclen(a1^);
    if lsrc=succ(iroot) then dec(lsrc); { Special case for root }
    if not process_path(a1,lsrc) then exit;
    if dos_major=3 then             { Copy in the new path into the CDS }
        move(max_path,cds3_rec(sda3_rec(sda^).drive_cdsptr^).curr_path,lsrc)
    else
        move(max_path,cds4_rec(sda4_rec(sda^).drive_cdsptr^).curr_path,lsrc);
    icur:=lsrc;
end;

{ Remove Directory - subfunction 01h }
procedure rd;
var lsrc : byte;
begin
    lsrc:=asclen(a1^);
    if not process_path(a1,lsrc) then exit;
    if lsrc=icur then begin fail(5); exit; end;
    if lsrc=ifile then begin fail(5); exit; end;
    if lsrc<>lmax then begin fail(5); exit; end;
    if not back_1(max_path,lmax) then begin fail(3); exit; end;
    max_path[succ(lmax)]:=#0;
end;

{ Make Directory - subfunction 03h }
procedure md;
var lsrc, isrc : byte;
begin
    lsrc:=asclen(a1^);
    isrc:=lsrc;
    if not back_1(a1^,isrc) then begin fail(5); exit; end;
    if not process_path(a1,isrc) then exit;
    if isrc<>lmax then begin fail(5); exit; end;
    move(a1^,max_path,lsrc);
    max_path[lsrc]:='\';
    max_path[succ(lsrc)]:=#0;
    lmax:=lsrc;
end;

{ pop di   push cs   mov ax, 1208h   int 2fh }
function dec_SFT(es, di: word):word; inline($5f/$0e/$b8/$08/$12/$cd/$2f);

{ pop di   push cs   mov ax, 120ch   int 2fh }
procedure set_Owner(es, di: word); inline($5f/$0e/$b8/$0c/$12/$cd/$2f);

{ Close File - subfunction 06h }
procedure clsfil;
begin
{ Clear down supplied SFT entry for file }
    with sft_rec(ptr(r.es,r.di)^) do
        begin
            if dec_SFT(r.es,r.di)=1 then
                begin
                    handle_cnt:=0;
                    dir_sector:=0; { ??? MSCDEX does it.. }
                    devdrv_ptr:=nil; { ??? MSCDEX does it.. }
                end;
            if boolean(open_mode and 3) and
               not boolean(dev_info and $40) then
                                { if new or updated file... }
                    if f_time=0 then file_time:=the_time
                    else file_time:=f_time;
        end;
end;

{ Commit File - subfunction 07h }
procedure cmmtfil;
begin
{ We support this but don't do anything... }
end;

{ Read from File - subfunction 08h }
procedure readfil;
begin

{ Fill the user's buffer (the DTA) from our internal; file buffer, 
  and update the suplied SFT for the file }
    with sft_rec(ptr(r.es,r.di)^) do
        begin
            { if (f_pos+r.cx)>f_size then r.cx:=f_size-f_pos; }
            if f_pos >= f_size then r.cx := 0
            else if (f_pos + r.cx) > f_size then r.cx := f_size - f_pos;
            if dos_major=3 then
                move(file_buffer[f_pos],sda3_rec(sda^).curr_dta^,r.cx)
            else
                move(file_buffer[f_pos],sda4_rec(sda^).curr_dta^,r.cx);
            inc(f_pos,r.cx);
        end;
end;

{ Write to File - subfunction 09h }
procedure writfil;
begin

{ Update our internal file buffer from the user buffer (the DTA) and 
  update the supplied SFT entry for the file }
    with sft_rec(ptr(r.es,r.di)^) do
        begin
            if boolean(file_attr and readonly) then
                begin fail(5); exit; end; 
            if (f_pos+r.cx)>maxfilesize then r.cx:=maxfilesize-f_pos;
            if dos_major=3 then
                move(sda3_rec(sda^).curr_dta^,file_buffer[f_pos],r.cx)
            else
                move(sda4_rec(sda^).curr_dta^,file_buffer[f_pos],r.cx);
            inc(f_pos,r.cx);
            if f_pos>file_size then file_size:=f_pos;
            f_size:=file_size;
            dev_info:=dev_info and (not $40);
        end;
end;

{ Get Disk Space - subfunction 0Ch }
procedure dskspc;
begin
{ Our 'disk' has 1 cluster containing 1 sector of maxfilesize bytes, and ... }
    r.ax:=1; 
    r.bx:=1;
    r.cx:=succ(maxfilesize);
{ ... its either all available or none! }
    r.dx:=ord(ifile=0);
end;

{ Set File Attributes - subfunction 0Eh }
procedure setfatt;
var lsrc, isrc : byte;
begin
    lsrc:=asclen(a1^);
    isrc:=lsrc;
    if not back_1(a1^,isrc) then begin fail(2); exit; end;
    if not process_path(a1,isrc) then exit;
    if isrc<>ifile then begin fail(2); exit; end;
    inc(isrc);
    fillchar(temp_name,13,#0);
    move(a1^[isrc],temp_name,lsrc-isrc);
    if temp_name<>file_name then begin fail(2); exit; end;
{    if file_opens>0 then fail(5) 
    else }  file_attr:=byte(ptr(r.ss,r.sp)^);
end;

{ Get File Attributes - subfunction 0Fh }
procedure getfatt;
var lsrc, isrc : byte;
begin
    lsrc:=asclen(a1^);
    isrc:=lsrc;
    if not back_1(a1^,isrc) then begin fail(2); exit; end;
    if not process_path(a1,isrc) then exit;
    if isrc<>ifile then begin fail(2); exit; end;
    inc(isrc);
    fillchar(temp_name,13,#0);
    move(a1^[isrc],temp_name,lsrc-isrc);
    if temp_name<>file_name then begin fail(2); exit; end;
{    if file_opens>0 then begin fail(5); exit; end; }
    r.ax:=file_attr;
end;

{ Rename File - subfunction 11h }
procedure renfil;
var lsrc, isrc, isav, i : byte;
    dot:boolean;
begin
    if dos_major=3 then
        a2:=ptr(r.ss,sda3_rec(sda^).fn2_csofs)
    else
        a2:=ptr(r.ss,sda4_rec(sda^).fn2_csofs);
    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;
    if isrc<>ifile then begin fail(2); exit; end;
    inc(isrc);
    fillchar(temp_name,13,#0);
    move(a1^[isrc],temp_name,lsrc-isrc);
{ Check that the current filename matches ours }
    if temp_name<>file_name then begin fail(2); exit; end;
    if boolean(file_attr and $7) then begin fail(5); exit; end;
{    if file_opens>0 then begin fail(5); exit; end; }
    lsrc:=asclen(a2^);
    isrc:=lsrc;
    if not back_1(a2^,isrc) then begin fail(3); exit; end;
    if not process_path(a2,isrc) then exit;
    ifile:=isrc;
    inc(isrc);
{ Put in the new file name }
    fillchar(file_name,13,#0);
    move(a2^[isrc],file_name,lsrc-isrc);
end;

{ This procedure does a wildcard match from the mask onto the target, and,
  if a hit, updates the search data block and found file areas supplied } 
function match(var m, t; var s : sdb_rec; var d : dir_rec;
                d_e, p_c : word; s_a : byte) : boolean;
var i, j : byte;
    mask : ascbuf absolute m;
    tgt : ascbuf absolute t;
begin
    i:=0; j:=0;
    if tgt[0] in ['\',#0] then begin match:=false; exit; end;
    while i<11 do
        case mask[i] of
            '?' :   if tgt[j] in [#0,'\','.'] then
                        if (i=8) and (tgt[j]='.') then inc(j) else inc(i)
                    else
                        begin inc(i); inc(j); end;
            ' ' :   if tgt[j] in ['.','\',#0] then inc(i)
                    else begin match:=false; exit; end;
            else    if (i=8) and (tgt[j]='.') then inc(j)
                    else
                    if tgt[j]=mask[i] then begin inc(i); inc(j); end
                    else begin match:=false; exit; end;
        end;
    if not (tgt[j] in ['\',#0]) then begin match:=false; exit; end;
    with s do
        begin
            move(mask,srch_tmpl,11);
            dir_entry:=d_e;
            srch_attr:=s_a;
            par_clstr:=p_c;
            drv_lett:=drive_no or $80;
        end;
    with d do
        begin
            i:=0; j:=0;
            fillchar(fname,11,' ');
            while not (tgt[i] in [#0,'\']) do
                if tgt[i] = '.' then begin j:=8; inc(i); end
                else begin fname[j]:=tgt[i]; inc(i); inc(j); end;
            case d_e of
                0 : fattr:=$08;
                1 : fattr:=$10;
                2 : fattr:=file_attr;
            end;
            time_lstupd:=file_time;
            date_lstupd:=file_date;
            case d_e of
                0, 1 : fsiz:=0;
                2 : fsiz:=file_size;
            end;
        end;
    match:=true;
end;

{ Delete File - subfunction 13h }
procedure delfil;
var isrc, lsrc : byte;
    sdb:sdb_rec;    { These are dummies for the match procedure to hit }
    der:dir_rec;
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;
    if isrc<>ifile then begin fail(2); exit; end;

    inc(os(a1).o,succ(isrc));
    cnvt2fcb(a1^,temp_name);
    if ((file_attr and $1f)>0) then begin fail(5); exit; end;
    if not match(temp_name,file_name,sdb,der,0,0,0) then
        begin fail(2); exit; end;
    { if file_opens=0 then } ifile:=0 { else fail(5) } ;
end;

{ Open Existing File - subfunction 16h }
procedure opnfil;
var isrc, lsrc : 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;
    if isrc<>ifile then begin fail(2); exit; end;
    inc(isrc);
    fillchar(temp_name,13,#0);
    move(a1^[isrc],temp_name,lsrc-isrc);
{ Check file names match }
    if temp_name<>file_name then begin fail(2); exit; end;

{ Initialize supplied SFT entry }
    with sft_rec(ptr(r.es,r.di)^) do
        begin
            file_attr:=byte(ptr(r.ss,r.sp)^);
            if dos_major=3 then
                open_mode:=sda3_rec(sda^).open_mode and $7f
            else
                open_mode:=sda4_rec(sda^).open_mode and $7f;
            cnvt2fcb(temp_name,fcb_fn);
         {   inc(file_opens); }
            f_size:=file_size;
            f_time:=file_time;
            dev_info:=$8040 or drive_no; { Network drive, unwritten to }
            dir_sector:=0;
            dir_entryno:=0;
            attr_byte:=file_attr;
            f_pos:=0;
            devdrv_ptr:=nil;
            set_Owner(r.es,r.di);
        end;
end;

{ Truncate/Create File - subfunction 17h }
procedure creatfil;
var isrc, lsrc : 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;

    if ifile=0 then 
        begin
{ Creating new file }
            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
{ 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(2); exit; end;
            if boolean(file_attr and $7) then begin fail(5); exit; end;
          {  if file_opens>0 then begin fail(5); exit; end; }
        end
    else fail(82);  { This provokes a 'ran out of dir entries' error }

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

{ Special Multi-Purpose Open File - subfunction 2Eh }
procedure spopnfil;
var isrc, lsrc : byte;
    action, mode, result : word;
begin
    lsrc:=asclen(a1^);