mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-26 21:23:44 +02:00
80b0231616
Int21/7303 is not related to lfn, since it's supported by win9x even when in DOS mode, while it's not supported by WinNTs. The behaviour (inspired by djgpp) is then to try different methods: * if the drive is a cdrom unit, try to ask to MSCDEX (this is required for pure DOS) * else, try int21/7303 (it will work for non-cdrom drives under win9x when in DOS mode, and in Win9x dos box and FreeDOS) * else, last choice is old int21/36 (it will work in MSDOS and WinNTs, though in the latter case sizes are wrong for free space or disk size > 2GB, but it's the best we can do) This solves bug #11477 git-svn-id: trunk@11246 -
1024 lines
24 KiB
ObjectPascal
1024 lines
24 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 by the Free Pascal development team.
|
|
|
|
Dos unit for BP7 compatible RTL
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
{$inline on}
|
|
|
|
unit dos;
|
|
|
|
interface
|
|
|
|
Uses
|
|
Go32;
|
|
|
|
Type
|
|
searchrec = packed record
|
|
fill : array[1..21] of byte;
|
|
attr : byte;
|
|
time : longint;
|
|
{ reserved : word; not in DJGPP V2 }
|
|
size : longint;
|
|
name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) }
|
|
end;
|
|
|
|
{$DEFINE HAS_REGISTERS}
|
|
Registers = Go32.Registers;
|
|
|
|
{$i dosh.inc}
|
|
|
|
implementation
|
|
|
|
uses
|
|
strings;
|
|
|
|
{$DEFINE HAS_GETMSCOUNT}
|
|
{$DEFINE HAS_INTR}
|
|
{$DEFINE HAS_SETCBREAK}
|
|
{$DEFINE HAS_GETCBREAK}
|
|
{$DEFINE HAS_SETVERIFY}
|
|
{$DEFINE HAS_GETVERIFY}
|
|
{$DEFINE HAS_SWAPVECTORS}
|
|
{$DEFINE HAS_GETSHORTNAME}
|
|
{$DEFINE HAS_GETLONGNAME}
|
|
|
|
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
|
|
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
|
|
|
|
{$I dos.inc}
|
|
|
|
{******************************************************************************
|
|
--- Dos Interrupt ---
|
|
******************************************************************************}
|
|
|
|
var
|
|
dosregs : registers;
|
|
|
|
procedure LoadDosError;
|
|
var
|
|
r : registers;
|
|
SimpleDosError : word;
|
|
begin
|
|
if (dosregs.flags and fcarry) <> 0 then
|
|
begin
|
|
{ I got a extended error = 0
|
|
while CarryFlag was set from Exec function }
|
|
SimpleDosError:=dosregs.ax;
|
|
r.eax:=$5900;
|
|
r.ebx:=$0;
|
|
realintr($21,r);
|
|
{ conversion from word to integer !!
|
|
gave a Bound check error if ax is $FFFF !! PM }
|
|
doserror:=integer(r.ax);
|
|
case doserror of
|
|
0 : DosError:=integer(SimpleDosError);
|
|
19 : DosError:=150;
|
|
21 : DosError:=152;
|
|
end;
|
|
end
|
|
else
|
|
doserror:=0;
|
|
end;
|
|
|
|
|
|
procedure intr(intno : byte;var regs : registers);
|
|
begin
|
|
realintr(intno,regs);
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Info / Date / Time ---
|
|
******************************************************************************}
|
|
|
|
function dosversion : word;
|
|
begin
|
|
dosregs.ax:=$3000;
|
|
msdos(dosregs);
|
|
dosversion:=dosregs.ax;
|
|
end;
|
|
|
|
|
|
procedure getdate(var year,month,mday,wday : word);
|
|
begin
|
|
dosregs.ax:=$2a00;
|
|
msdos(dosregs);
|
|
wday:=dosregs.al;
|
|
year:=dosregs.cx;
|
|
month:=dosregs.dh;
|
|
mday:=dosregs.dl;
|
|
end;
|
|
|
|
|
|
procedure setdate(year,month,day : word);
|
|
begin
|
|
dosregs.cx:=year;
|
|
dosregs.dh:=month;
|
|
dosregs.dl:=day;
|
|
dosregs.ah:=$2b;
|
|
msdos(dosregs);
|
|
end;
|
|
|
|
|
|
procedure gettime(var hour,minute,second,sec100 : word);
|
|
begin
|
|
dosregs.ah:=$2c;
|
|
msdos(dosregs);
|
|
hour:=dosregs.ch;
|
|
minute:=dosregs.cl;
|
|
second:=dosregs.dh;
|
|
sec100:=dosregs.dl;
|
|
end;
|
|
|
|
|
|
procedure settime(hour,minute,second,sec100 : word);
|
|
begin
|
|
dosregs.ch:=hour;
|
|
dosregs.cl:=minute;
|
|
dosregs.dh:=second;
|
|
dosregs.dl:=sec100;
|
|
dosregs.ah:=$2d;
|
|
msdos(dosregs);
|
|
end;
|
|
|
|
|
|
function GetMsCount: int64;
|
|
begin
|
|
GetMsCount := int64 (MemL [$40:$6c]) * 55;
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Exec ---
|
|
******************************************************************************}
|
|
|
|
const
|
|
DOS_MAX_COMMAND_LINE_LENGTH = 126;
|
|
|
|
procedure exec(const path : pathstr;const comline : comstr);
|
|
type
|
|
realptr = packed record
|
|
ofs,seg : word;
|
|
end;
|
|
texecblock = packed record
|
|
envseg : word;
|
|
comtail : realptr;
|
|
firstFCB : realptr;
|
|
secondFCB : realptr;
|
|
{ iniStack : realptr;
|
|
iniCSIP : realptr;}
|
|
end;
|
|
var
|
|
current_dos_buffer_pos,
|
|
arg_ofs,
|
|
i,la_env,
|
|
la_p,la_c,la_e,
|
|
fcb1_la,fcb2_la : longint;
|
|
execblock : texecblock;
|
|
c,p : string;
|
|
|
|
function paste_to_dos(src : string;cr : boolean; n : longint) : boolean;
|
|
{Changed by Laaca - added parameter N}
|
|
var
|
|
c : pchar;
|
|
CLen : cardinal;
|
|
ls : longint;
|
|
begin
|
|
paste_to_dos:=false;
|
|
ls:=Length(src)-n;
|
|
if current_dos_buffer_pos+ls+3>transfer_buffer+tb_size then
|
|
RunError(217);
|
|
getmem(c,ls+3);
|
|
move(src[n],c^,ls+1);
|
|
if cr then
|
|
begin
|
|
c[ls+1]:=#13;
|
|
c[ls+2]:=#0;
|
|
end
|
|
else
|
|
c[ls+1]:=#0;
|
|
CLen := StrLen (C) + 1;
|
|
seg_move(get_ds,longint(c),dosmemselector,current_dos_buffer_pos,CLen);
|
|
current_dos_buffer_pos:=current_dos_buffer_pos+CLen;
|
|
freemem(c,ls+3);
|
|
paste_to_dos:=true;
|
|
end;
|
|
|
|
begin
|
|
{ create command line }
|
|
c:=comline;
|
|
if length(c)>DOS_MAX_COMMAND_LINE_LENGTH then
|
|
c[0]:=chr(DOS_MAX_COMMAND_LINE_LENGTH);
|
|
{ create path }
|
|
p:=path;
|
|
{ allow slash as backslash }
|
|
DoDirSeparators(p);
|
|
if LFNSupport then
|
|
GetShortName(p);
|
|
{ create buffer }
|
|
la_env:=transfer_buffer;
|
|
while (la_env and 15)<>0 do
|
|
inc(la_env);
|
|
current_dos_buffer_pos:=la_env;
|
|
{ copy environment }
|
|
for i:=1 to envcount do
|
|
paste_to_dos(envstr(i),false,1);
|
|
{the behaviour is still suboptimal because variable COMMAND is stripped out}
|
|
paste_to_dos(chr(0),false,1); { adds a double zero at the end }
|
|
la_p:=current_dos_buffer_pos;
|
|
paste_to_dos(p,false,0);
|
|
la_c:=current_dos_buffer_pos;
|
|
paste_to_dos(c,true,0);
|
|
la_e:=current_dos_buffer_pos;
|
|
fcb1_la:=la_e;
|
|
la_e:=la_e+16;
|
|
fcb2_la:=la_e;
|
|
la_e:=la_e+16;
|
|
{ allocate FCB see dosexec code }
|
|
arg_ofs:=1;
|
|
while (c[arg_ofs] in [' ',#9]) and
|
|
(arg_ofs<length(c)) do
|
|
inc(arg_ofs);
|
|
dosregs.ax:=$2901;
|
|
dosregs.ds:=(la_c+arg_ofs) shr 4;
|
|
dosregs.esi:=(la_c+arg_ofs) and 15;
|
|
dosregs.es:=fcb1_la shr 4;
|
|
dosregs.edi:=fcb1_la and 15;
|
|
msdos(dosregs);
|
|
{ allocate second FCB see dosexec code }
|
|
dosregs.ax:=$2901;
|
|
dosregs.ds:=(la_c+arg_ofs) shr 4;
|
|
dosregs.esi:=(la_c+arg_ofs) and 15;
|
|
dosregs.es:=fcb2_la shr 4;
|
|
dosregs.edi:=fcb2_la and 15;
|
|
msdos(dosregs);
|
|
with execblock do
|
|
begin
|
|
envseg:=la_env shr 4;
|
|
comtail.seg:=la_c shr 4;
|
|
comtail.ofs:=la_c and 15;
|
|
firstFCB.seg:=fcb1_la shr 4;
|
|
firstFCB.ofs:=fcb1_la and 15;
|
|
secondFCB.seg:=fcb2_la shr 4;
|
|
secondFCB.ofs:=fcb2_la and 15;
|
|
end;
|
|
seg_move(get_ds,longint(@execblock),dosmemselector,la_e,sizeof(texecblock));
|
|
dosregs.edx:=la_p and 15+1;
|
|
dosregs.ds:=la_p shr 4;
|
|
dosregs.ebx:=la_p and 15+la_e-la_p;
|
|
dosregs.es:=la_p shr 4;
|
|
dosregs.ax:=$4b00;
|
|
msdos(dosregs);
|
|
LoadDosError;
|
|
if DosError=0 then
|
|
begin
|
|
dosregs.ax:=$4d00;
|
|
msdos(dosregs);
|
|
LastDosExitCode:=DosRegs.al
|
|
end
|
|
else
|
|
LastDosExitCode:=0;
|
|
end;
|
|
|
|
|
|
procedure getcbreak(var breakvalue : boolean);
|
|
begin
|
|
dosregs.ax:=$3300;
|
|
msdos(dosregs);
|
|
breakvalue:=dosregs.dl<>0;
|
|
end;
|
|
|
|
|
|
procedure setcbreak(breakvalue : boolean);
|
|
begin
|
|
dosregs.ax:=$3301;
|
|
dosregs.dl:=ord(breakvalue);
|
|
msdos(dosregs);
|
|
end;
|
|
|
|
|
|
procedure getverify(var verify : boolean);
|
|
begin
|
|
dosregs.ah:=$54;
|
|
msdos(dosregs);
|
|
verify:=dosregs.al<>0;
|
|
end;
|
|
|
|
|
|
procedure setverify(verify : boolean);
|
|
begin
|
|
dosregs.ah:=$2e;
|
|
dosregs.al:=ord(verify);
|
|
msdos(dosregs);
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Disk ---
|
|
******************************************************************************}
|
|
|
|
type
|
|
ExtendedFat32FreeSpaceRec = packed record
|
|
RetSize : word; { $00 }
|
|
Strucversion : word; { $02 }
|
|
SecPerClus, { $04 }
|
|
BytePerSec, { $08 }
|
|
AvailClusters, { $0C }
|
|
TotalClusters, { $10 }
|
|
AvailPhysSect, { $14 }
|
|
TotalPhysSect, { $18 }
|
|
AvailAllocUnits, { $1C }
|
|
TotalAllocUnits : longword; { $20 }
|
|
Dummy, { $24 }
|
|
Dummy2 : longword; { $28 }
|
|
end; { $2C }
|
|
|
|
const
|
|
IOCTL_INPUT = 3; //For request header command field
|
|
CDFUNC_SECTSIZE = 7; //For cdrom control block func field
|
|
CDFUNC_VOLSIZE = 8; //For cdrom control block func field
|
|
|
|
type
|
|
TRequestHeader = packed record
|
|
length : byte; { $00 }
|
|
subunit : byte; { $01 }
|
|
command : byte; { $02 }
|
|
status : word; { $03 }
|
|
reserved1 : longword; { $05 }
|
|
reserved2 : longword; { $09 }
|
|
media_desc : byte; { $0D }
|
|
transf_ofs : word; { $0E }
|
|
transf_seg : word; { $10 }
|
|
numbytes : word; { $12 }
|
|
end; { $14 }
|
|
|
|
TCDSectSizeReq = packed record
|
|
func : byte; { $00 }
|
|
mode : byte; { $01 }
|
|
secsize : word; { $02 }
|
|
end; { $04 }
|
|
|
|
TCDVolSizeReq = packed record
|
|
func : byte; { $00 }
|
|
size : longword; { $01 }
|
|
end; { $05 }
|
|
|
|
|
|
function do_diskdata(drive : byte; Free : boolean) : Int64;
|
|
var
|
|
blocksize, freeblocks, totblocks : longword;
|
|
|
|
{ Get disk data via old int21/36 (GET FREE DISK SPACE). It's always supported
|
|
even if it returns wrong values for volumes > 2GB and for cdrom drives when
|
|
in pure DOS. Note that it's also the only way to get some data on WinNTs. }
|
|
function DiskData_36 : boolean;
|
|
begin
|
|
DiskData_36:=false;
|
|
dosregs.dl:=drive;
|
|
dosregs.ah:=$36;
|
|
msdos(dosregs);
|
|
if dosregs.ax=$FFFF then exit;
|
|
|
|
blocksize:=dosregs.ax*dosregs.cx;
|
|
freeblocks:=dosregs.bx;
|
|
totblocks:=dosregs.dx;
|
|
Diskdata_36:=true;
|
|
end;
|
|
|
|
{ Get disk data via int21/7303 (FAT32 - GET EXTENDED FREE SPACE ON DRIVE).
|
|
It is supported by win9x even in pure DOS }
|
|
function DiskData_7303 : boolean;
|
|
var
|
|
s : shortstring;
|
|
rec : ExtendedFat32FreeSpaceRec;
|
|
begin
|
|
DiskData_7303:=false;
|
|
s:=chr(drive+$40)+':\'+#0;
|
|
|
|
rec.Strucversion:=0;
|
|
rec.RetSize := 0;
|
|
dosmemput(tb_segment,tb_offset,Rec,sizeof(ExtendedFat32FreeSpaceRec));
|
|
dosmemput(tb_segment,tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1,s[1],4);
|
|
dosregs.dx:=tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1;
|
|
dosregs.ds:=tb_segment;
|
|
dosregs.di:=tb_offset;
|
|
dosregs.es:=tb_segment;
|
|
dosregs.cx:=Sizeof(ExtendedFat32FreeSpaceRec);
|
|
dosregs.ax:=$7303;
|
|
msdos(dosregs);
|
|
if (dosregs.flags and fcarry) <> 0 then
|
|
exit;
|
|
copyfromdos(rec,Sizeof(ExtendedFat32FreeSpaceRec));
|
|
if Rec.RetSize = 0 then
|
|
exit;
|
|
|
|
blocksize:=rec.SecPerClus*rec.BytePerSec;
|
|
freeblocks:=rec.AvailAllocUnits;
|
|
totblocks:=rec.TotalAllocUnits;
|
|
DiskData_7303:=true;
|
|
end;
|
|
|
|
{ Get disk data asking to MSCDEX. Pure DOS returns wrong values with
|
|
int21/7303 or int21/36 if the drive is a CDROM drive }
|
|
function DiskData_CDROM : boolean;
|
|
var req : TRequestHeader;
|
|
sectreq : TCDSectSizeReq;
|
|
sizereq : TCDVolSizeReq;
|
|
i : integer;
|
|
status,byteswritten : word;
|
|
drnum : byte;
|
|
begin
|
|
DiskData_CDROM:=false;
|
|
drnum:=drive-1; //for MSCDEX, 0 = a, 1 = b etc, unlike int21/36
|
|
|
|
{ Is this a CDROM drive? }
|
|
dosregs.ax:=$150b;
|
|
dosregs.cx:=drnum;
|
|
realintr($2f,dosregs);
|
|
if (dosregs.bx<>$ADAD) or (dosregs.ax=0) then
|
|
exit; // no, it isn't
|
|
|
|
{ Prepare the request header to send to the cdrom driver }
|
|
FillByte(req,sizeof(req),0);
|
|
req.length:=sizeof(req);
|
|
req.command:=IOCTL_INPUT;
|
|
req.transf_ofs:=tb_offset+sizeof(req); //CDROM control block will follow
|
|
req.transf_seg:=tb_segment; //the request header
|
|
req.numbytes:=sizeof(sectreq);
|
|
|
|
{ We're asking the sector size }
|
|
sectreq.func:=CDFUNC_SECTSIZE;
|
|
sectreq.mode:=0; //cooked
|
|
sectreq.secsize:=0;
|
|
|
|
for i:=1 to 2 do
|
|
begin
|
|
{ Send the request to the cdrom driver }
|
|
dosmemput(tb_segment,tb_offset,req,sizeof(req));
|
|
dosmemput(tb_segment,tb_offset+sizeof(req),sectreq,sizeof(sectreq));
|
|
dosregs.ax:=$1510;
|
|
dosregs.cx:=drnum;
|
|
dosregs.es:=tb_segment;
|
|
dosregs.bx:=tb_offset;
|
|
realintr($2f,dosregs);
|
|
dosmemget(tb_segment,tb_offset+3,status,2);
|
|
{ status = $800F means "disk changed". Try once more. }
|
|
if (status and $800F) <> $800F then break;
|
|
end;
|
|
dosmemget(tb_segment,tb_offset+$12,byteswritten,2);
|
|
if (status<>$0100) or (byteswritten<>sizeof(sectreq)) then
|
|
exit; //An error occurred
|
|
dosmemget(tb_segment,tb_offset+sizeof(req),sectreq,sizeof(sectreq));
|
|
|
|
{ Update the request header for the next request }
|
|
req.numbytes:=sizeof(sizereq);
|
|
|
|
{ We're asking the volume size (in blocks) }
|
|
sizereq.func:=CDFUNC_VOLSIZE;
|
|
sizereq.size:=0;
|
|
|
|
{ Send the request to the cdrom driver }
|
|
dosmemput(tb_segment,tb_offset,req,sizeof(req));
|
|
dosmemput(tb_segment,tb_offset+sizeof(req),sizereq,sizeof(sizereq));
|
|
dosregs.ax:=$1510;
|
|
dosregs.cx:=drnum;
|
|
dosregs.es:=tb_segment;
|
|
dosregs.bx:=tb_offset;
|
|
realintr($2f,dosregs);
|
|
dosmemget(tb_segment,tb_offset,req,sizeof(req));
|
|
if (req.status<>$0100) or (req.numbytes<>sizeof(sizereq)) then
|
|
exit; //An error occurred
|
|
dosmemget(tb_segment,tb_offset+sizeof(req)+1,sizereq.size,4);
|
|
|
|
blocksize:=sectreq.secsize;
|
|
freeblocks:=0; //always 0 for a cdrom
|
|
totblocks:=sizereq.size;
|
|
DiskData_CDROM:=true;
|
|
end;
|
|
|
|
begin
|
|
if drive=0 then
|
|
begin
|
|
dosregs.ax:=$1900; //get current default drive
|
|
msdos(dosregs);
|
|
drive:=dosregs.al+1;
|
|
end;
|
|
|
|
if not DiskData_CDROM then
|
|
if not DiskData_7303 then
|
|
if not DiskData_36 then
|
|
begin
|
|
do_diskdata:=-1;
|
|
exit;
|
|
end;
|
|
do_diskdata:=blocksize;
|
|
if free then
|
|
do_diskdata:=do_diskdata*freeblocks
|
|
else
|
|
do_diskdata:=do_diskdata*totblocks;
|
|
end;
|
|
|
|
function diskfree(drive : byte) : int64;
|
|
begin
|
|
diskfree:=Do_DiskData(drive,TRUE);
|
|
end;
|
|
|
|
function disksize(drive : byte) : int64;
|
|
begin
|
|
disksize:=Do_DiskData(drive,false);
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- LFNFindfirst LFNFindNext ---
|
|
******************************************************************************}
|
|
|
|
type
|
|
LFNSearchRec=packed record
|
|
attr,
|
|
crtime,
|
|
crtimehi,
|
|
actime,
|
|
actimehi,
|
|
lmtime,
|
|
lmtimehi,
|
|
sizehi,
|
|
size : longint;
|
|
reserved : array[0..7] of byte;
|
|
name : array[0..259] of byte;
|
|
shortname : array[0..13] of byte;
|
|
end;
|
|
|
|
procedure LFNSearchRec2Dos(const w:LFNSearchRec;hdl:longint;var d:Searchrec;from_findfirst : boolean);
|
|
var
|
|
Len : longint;
|
|
begin
|
|
With w do
|
|
begin
|
|
FillChar(d,sizeof(SearchRec),0);
|
|
if DosError=0 then
|
|
len:=StrLen(@Name)
|
|
else
|
|
len:=0;
|
|
d.Name[0]:=chr(len);
|
|
Move(Name[0],d.Name[1],Len);
|
|
d.Time:=lmTime;
|
|
d.Size:=Size;
|
|
d.Attr:=Attr and $FF;
|
|
if (DosError<>0) and from_findfirst then
|
|
hdl:=-1;
|
|
Move(hdl,d.Fill,4);
|
|
end;
|
|
end;
|
|
|
|
{$ifdef DEBUG_LFN}
|
|
const
|
|
LFNFileName : string = 'LFN.log';
|
|
LFNOpenNb : longint = 0;
|
|
LogLFN : boolean = false;
|
|
var
|
|
lfnfile : text;
|
|
{$endif DEBUG_LFN}
|
|
|
|
procedure LFNFindFirst(path:pchar;attr:longint;var s:searchrec);
|
|
var
|
|
i : longint;
|
|
w : LFNSearchRec;
|
|
begin
|
|
{ allow slash as backslash }
|
|
DoDirSeparators(path);
|
|
dosregs.si:=1; { use ms-dos time }
|
|
{ don't include the label if not asked for it, needed for network drives }
|
|
if attr=$8 then
|
|
dosregs.ecx:=8
|
|
else
|
|
dosregs.ecx:=attr and (not 8);
|
|
dosregs.edx:=tb_offset+Sizeof(LFNSearchrec)+1;
|
|
dosmemput(tb_segment,tb_offset+Sizeof(LFNSearchrec)+1,path^,strlen(path)+1);
|
|
dosregs.ds:=tb_segment;
|
|
dosregs.edi:=tb_offset;
|
|
dosregs.es:=tb_segment;
|
|
dosregs.ax:=$714e;
|
|
msdos(dosregs);
|
|
LoadDosError;
|
|
if DosError=2 then
|
|
DosError:=18;
|
|
{$ifdef DEBUG_LFN}
|
|
if (DosError=0) and LogLFN then
|
|
begin
|
|
Append(lfnfile);
|
|
inc(LFNOpenNb);
|
|
Writeln(lfnfile,LFNOpenNb,' LFNFindFirst called ',path);
|
|
close(lfnfile);
|
|
end;
|
|
{$endif DEBUG_LFN}
|
|
copyfromdos(w,sizeof(LFNSearchRec));
|
|
LFNSearchRec2Dos(w,dosregs.ax,s,true);
|
|
end;
|
|
|
|
|
|
procedure LFNFindNext(var s:searchrec);
|
|
var
|
|
hdl : longint;
|
|
w : LFNSearchRec;
|
|
begin
|
|
Move(s.Fill,hdl,4);
|
|
dosregs.si:=1; { use ms-dos time }
|
|
dosregs.edi:=tb_offset;
|
|
dosregs.es:=tb_segment;
|
|
dosregs.ebx:=hdl;
|
|
dosregs.ax:=$714f;
|
|
msdos(dosregs);
|
|
LoadDosError;
|
|
copyfromdos(w,sizeof(LFNSearchRec));
|
|
LFNSearchRec2Dos(w,hdl,s,false);
|
|
end;
|
|
|
|
|
|
procedure LFNFindClose(var s:searchrec);
|
|
var
|
|
hdl : longint;
|
|
begin
|
|
Move(s.Fill,hdl,4);
|
|
{ Do not call MsDos if FindFirst returned with an error }
|
|
if hdl=-1 then
|
|
begin
|
|
DosError:=0;
|
|
exit;
|
|
end;
|
|
dosregs.ebx:=hdl;
|
|
dosregs.ax:=$71a1;
|
|
msdos(dosregs);
|
|
LoadDosError;
|
|
{$ifdef DEBUG_LFN}
|
|
if (DosError=0) and LogLFN then
|
|
begin
|
|
Append(lfnfile);
|
|
Writeln(lfnfile,LFNOpenNb,' LFNFindClose called ');
|
|
close(lfnfile);
|
|
if LFNOpenNb>0 then
|
|
dec(LFNOpenNb);
|
|
end;
|
|
{$endif DEBUG_LFN}
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- DosFindfirst DosFindNext ---
|
|
******************************************************************************}
|
|
|
|
procedure dossearchrec2searchrec(var f : searchrec);
|
|
var
|
|
len : longint;
|
|
begin
|
|
{ Check is necessary!! OS/2's VDM doesn't clear the name with #0 if the }
|
|
{ file doesn't exist! (JM) }
|
|
if dosError = 0 then
|
|
len:=StrLen(@f.Name)
|
|
else len := 0;
|
|
Move(f.Name[0],f.Name[1],Len);
|
|
f.Name[0]:=chr(len);
|
|
end;
|
|
|
|
|
|
procedure DosFindfirst(path : pchar;attr : word;var f : searchrec);
|
|
var
|
|
i : longint;
|
|
begin
|
|
{ allow slash as backslash }
|
|
DoDirSeparators(path);
|
|
copytodos(f,sizeof(searchrec));
|
|
dosregs.edx:=tb_offset;
|
|
dosregs.ds:=tb_segment;
|
|
dosregs.ah:=$1a;
|
|
msdos(dosregs);
|
|
dosregs.ecx:=attr;
|
|
dosregs.edx:=tb_offset+Sizeof(searchrec)+1;
|
|
dosmemput(tb_segment,tb_offset+Sizeof(searchrec)+1,path^,strlen(path)+1);
|
|
dosregs.ds:=tb_segment;
|
|
dosregs.ah:=$4e;
|
|
msdos(dosregs);
|
|
copyfromdos(f,sizeof(searchrec));
|
|
LoadDosError;
|
|
dossearchrec2searchrec(f);
|
|
end;
|
|
|
|
|
|
procedure Dosfindnext(var f : searchrec);
|
|
begin
|
|
copytodos(f,sizeof(searchrec));
|
|
dosregs.edx:=tb_offset;
|
|
dosregs.ds:=tb_segment;
|
|
dosregs.ah:=$1a;
|
|
msdos(dosregs);
|
|
dosregs.ah:=$4f;
|
|
msdos(dosregs);
|
|
copyfromdos(f,sizeof(searchrec));
|
|
LoadDosError;
|
|
dossearchrec2searchrec(f);
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Findfirst FindNext ---
|
|
******************************************************************************}
|
|
|
|
procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
|
|
var
|
|
path0 : array[0..255] of char;
|
|
begin
|
|
doserror:=0;
|
|
strpcopy(path0,path);
|
|
if LFNSupport then
|
|
LFNFindFirst(path0,attr,f)
|
|
else
|
|
Dosfindfirst(path0,attr,f);
|
|
end;
|
|
|
|
|
|
procedure findnext(var f : searchRec);
|
|
begin
|
|
doserror:=0;
|
|
if LFNSupport then
|
|
LFNFindnext(f)
|
|
else
|
|
Dosfindnext(f);
|
|
end;
|
|
|
|
|
|
Procedure FindClose(Var f: SearchRec);
|
|
begin
|
|
DosError:=0;
|
|
if LFNSupport then
|
|
LFNFindClose(f);
|
|
end;
|
|
|
|
|
|
type swap_proc = procedure;
|
|
|
|
var
|
|
_swap_in : swap_proc;external name '_swap_in';
|
|
_swap_out : swap_proc;external name '_swap_out';
|
|
_exception_exit : pointer;external name '_exception_exit';
|
|
_v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on';
|
|
|
|
procedure swapvectors;
|
|
begin
|
|
if _exception_exit<>nil then
|
|
if _v2prt0_exceptions_on then
|
|
_swap_out()
|
|
else
|
|
_swap_in();
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- File ---
|
|
******************************************************************************}
|
|
|
|
|
|
Function FSearch(path: pathstr; dirlist: string): pathstr;
|
|
var
|
|
i,p1 : longint;
|
|
s : searchrec;
|
|
newdir : pathstr;
|
|
begin
|
|
{ check if the file specified exists }
|
|
findfirst(path,anyfile and not(directory),s);
|
|
if doserror=0 then
|
|
begin
|
|
findclose(s);
|
|
fsearch:=path;
|
|
exit;
|
|
end;
|
|
{ No wildcards allowed in these things }
|
|
if (pos('?',path)<>0) or (pos('*',path)<>0) then
|
|
fsearch:=''
|
|
else
|
|
begin
|
|
{ allow slash as backslash }
|
|
DoDirSeparators(dirlist);
|
|
repeat
|
|
p1:=pos(';',dirlist);
|
|
if p1<>0 then
|
|
begin
|
|
newdir:=copy(dirlist,1,p1-1);
|
|
delete(dirlist,1,p1);
|
|
end
|
|
else
|
|
begin
|
|
newdir:=dirlist;
|
|
dirlist:='';
|
|
end;
|
|
if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
|
|
newdir:=newdir+'\';
|
|
findfirst(newdir+path,anyfile and not(directory),s);
|
|
if doserror=0 then
|
|
newdir:=newdir+path
|
|
else
|
|
newdir:='';
|
|
until (dirlist='') or (newdir<>'');
|
|
fsearch:=newdir;
|
|
end;
|
|
findclose(s);
|
|
end;
|
|
|
|
|
|
{ change to short filename if successful DOS call PM }
|
|
function GetShortName(var p : String) : boolean;
|
|
var
|
|
c : array[0..255] of char;
|
|
begin
|
|
move(p[1],c[0],length(p));
|
|
c[length(p)]:=#0;
|
|
copytodos(c,length(p)+1);
|
|
dosregs.ax:=$7160;
|
|
dosregs.cx:=1;
|
|
dosregs.ds:=tb_segment;
|
|
dosregs.si:=tb_offset;
|
|
dosregs.es:=tb_segment;
|
|
dosregs.di:=tb_offset;
|
|
msdos(dosregs);
|
|
LoadDosError;
|
|
if DosError=0 then
|
|
begin
|
|
copyfromdos(c,256);
|
|
move(c[0],p[1],strlen(c));
|
|
p[0]:=char(strlen(c));
|
|
GetShortName:=true;
|
|
end
|
|
else
|
|
GetShortName:=false;
|
|
end;
|
|
|
|
|
|
{ change to long filename if successful DOS call PM }
|
|
function GetLongName(var p : String) : boolean;
|
|
var
|
|
c : array[0..255] of char;
|
|
begin
|
|
move(p[1],c[0],length(p));
|
|
c[length(p)]:=#0;
|
|
copytodos(c,length(p)+1);
|
|
dosregs.ax:=$7160;
|
|
dosregs.cx:=2;
|
|
dosregs.ds:=tb_segment;
|
|
dosregs.si:=tb_offset;
|
|
dosregs.es:=tb_segment;
|
|
dosregs.di:=tb_offset;
|
|
msdos(dosregs);
|
|
LoadDosError;
|
|
if DosError=0 then
|
|
begin
|
|
copyfromdos(c,256);
|
|
move(c[0],p[1],strlen(c));
|
|
p[0]:=char(strlen(c));
|
|
GetLongName:=true;
|
|
end
|
|
else
|
|
GetLongName:=false;
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Get/Set File Time,Attr ---
|
|
******************************************************************************}
|
|
|
|
procedure getftime(var f;var time : longint);
|
|
begin
|
|
dosregs.bx:=textrec(f).handle;
|
|
dosregs.ax:=$5700;
|
|
msdos(dosregs);
|
|
loaddoserror;
|
|
time:=(dosregs.dx shl 16)+dosregs.cx;
|
|
end;
|
|
|
|
|
|
procedure setftime(var f;time : longint);
|
|
begin
|
|
dosregs.bx:=textrec(f).handle;
|
|
dosregs.cx:=time and $ffff;
|
|
dosregs.dx:=time shr 16;
|
|
dosregs.ax:=$5701;
|
|
msdos(dosregs);
|
|
loaddoserror;
|
|
end;
|
|
|
|
|
|
procedure getfattr(var f;var attr : word);
|
|
begin
|
|
copytodos(filerec(f).name,strlen(filerec(f).name)+1);
|
|
dosregs.edx:=tb_offset;
|
|
dosregs.ds:=tb_segment;
|
|
if LFNSupport then
|
|
begin
|
|
dosregs.ax:=$7143;
|
|
dosregs.bx:=0;
|
|
end
|
|
else
|
|
dosregs.ax:=$4300;
|
|
msdos(dosregs);
|
|
LoadDosError;
|
|
Attr:=dosregs.cx;
|
|
end;
|
|
|
|
|
|
procedure setfattr(var f;attr : word);
|
|
begin
|
|
{ Fail for setting VolumeId. }
|
|
if ((attr and VolumeID)<>0) then
|
|
begin
|
|
doserror:=5;
|
|
exit;
|
|
end;
|
|
copytodos(filerec(f).name,strlen(filerec(f).name)+1);
|
|
dosregs.edx:=tb_offset;
|
|
dosregs.ds:=tb_segment;
|
|
if LFNSupport then
|
|
begin
|
|
dosregs.ax:=$7143;
|
|
dosregs.bx:=1;
|
|
end
|
|
else
|
|
dosregs.ax:=$4301;
|
|
dosregs.cx:=attr;
|
|
msdos(dosregs);
|
|
LoadDosError;
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Environment ---
|
|
******************************************************************************}
|
|
|
|
function envcount : longint;
|
|
var
|
|
hp : ppchar;
|
|
begin
|
|
hp:=envp;
|
|
envcount:=0;
|
|
while assigned(hp^) do
|
|
begin
|
|
inc(envcount);
|
|
inc(hp);
|
|
end;
|
|
end;
|
|
|
|
|
|
function envstr (Index: longint): string;
|
|
begin
|
|
if (index<=0) or (index>envcount) then
|
|
envstr:=''
|
|
else
|
|
envstr:=strpas(ppchar(pointer(envp)+SizeOf(PChar)*(index-1))^);
|
|
end;
|
|
|
|
|
|
Function GetEnv(envvar: string): string;
|
|
var
|
|
hp : ppchar;
|
|
hs : string;
|
|
eqpos : longint;
|
|
begin
|
|
envvar:=upcase(envvar);
|
|
hp:=envp;
|
|
getenv:='';
|
|
while assigned(hp^) do
|
|
begin
|
|
hs:=strpas(hp^);
|
|
eqpos:=pos('=',hs);
|
|
if upcase(copy(hs,1,eqpos-1))=envvar then
|
|
begin
|
|
getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
|
|
break;
|
|
end;
|
|
inc(hp);
|
|
end;
|
|
end;
|
|
|
|
{$ifdef DEBUG_LFN}
|
|
begin
|
|
LogLFN:=(GetEnv('LOGLFN')<>'');
|
|
assign(lfnfile,LFNFileName);
|
|
{$I-}
|
|
Reset(lfnfile);
|
|
if IOResult<>0 then
|
|
begin
|
|
Rewrite(lfnfile);
|
|
Writeln(lfnfile,'New lfn.log');
|
|
end;
|
|
close(lfnfile);
|
|
{$endif DEBUG_LFN}
|
|
|
|
end.
|