mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 07:39:25 +02:00
* new lfn check from mailinglist
* renamed win95 -> LFNSupport + tb_selector, tb_offset for easier access to transferbuffer
This commit is contained in:
peter
parent
bdfa9acbc7
commit
2f3bc2f300
@ -611,11 +611,11 @@ begin
|
||||
if path[i]='/' then path[i]:='\';
|
||||
dosregs.si:=1; { use ms-dos time }
|
||||
dosregs.ecx:=attr;
|
||||
dosregs.edx:=(transfer_buffer and 15) + Sizeof(LFNSearchrec)+1;
|
||||
dosmemput(transfer_buffer shr 4,(transfer_buffer and 15)+Sizeof(LFNSearchrec)+1,path^,strlen(path)+1);
|
||||
dosregs.ds:=transfer_buffer shr 4;
|
||||
dosregs.edi:=transfer_buffer and 15;
|
||||
dosregs.es:=transfer_buffer shr 4;
|
||||
dosregs.edx:=tb_offset+Sizeof(LFNSearchrec)+1;
|
||||
dosmemput(tb_selector,tb_offset+Sizeof(LFNSearchrec)+1,path^,strlen(path)+1);
|
||||
dosregs.ds:=tb_selector;
|
||||
dosregs.edi:=tb_offset;
|
||||
dosregs.es:=tb_selector;
|
||||
dosregs.ax:=$714e;
|
||||
msdos(dosregs);
|
||||
LoadDosError;
|
||||
@ -631,8 +631,8 @@ var
|
||||
begin
|
||||
Move(s.Fill,hdl,4);
|
||||
dosregs.si:=1; { use ms-dos time }
|
||||
dosregs.edi:=transfer_buffer and 15;
|
||||
dosregs.es:=transfer_buffer shr 4;
|
||||
dosregs.edi:=tb_offset;
|
||||
dosregs.es:=tb_selector;
|
||||
dosregs.ebx:=hdl;
|
||||
dosregs.ax:=$714f;
|
||||
msdos(dosregs);
|
||||
@ -680,14 +680,14 @@ begin
|
||||
for i:=0 to strlen(path) do
|
||||
if path[i]='/' then path[i]:='\';
|
||||
copytodos(f,sizeof(searchrec));
|
||||
dosregs.edx:=transfer_buffer and 15;
|
||||
dosregs.ds:=transfer_buffer shr 4;
|
||||
dosregs.edx:=tb_offset;
|
||||
dosregs.ds:=tb_selector;
|
||||
dosregs.ah:=$1a;
|
||||
msdos(dosregs);
|
||||
dosregs.ecx:=attr;
|
||||
dosregs.edx:=(transfer_buffer mod 16) + Sizeof(searchrec)+1;
|
||||
dosmemput(transfer_buffer div 16,(transfer_buffer mod 16) +Sizeof(searchrec)+1,path^,strlen(path)+1);
|
||||
dosregs.ds:=transfer_buffer div 16;
|
||||
dosregs.edx:=tb_offset+Sizeof(searchrec)+1;
|
||||
dosmemput(tb_selector,tb_offset+Sizeof(searchrec)+1,path^,strlen(path)+1);
|
||||
dosregs.ds:=tb_selector;
|
||||
dosregs.ah:=$4e;
|
||||
msdos(dosregs);
|
||||
copyfromdos(f,sizeof(searchrec));
|
||||
@ -699,8 +699,8 @@ end;
|
||||
procedure Dosfindnext(var f : searchrec);
|
||||
begin
|
||||
copytodos(f,sizeof(searchrec));
|
||||
dosregs.edx:=transfer_buffer mod 16;
|
||||
dosregs.ds:=transfer_buffer div 16;
|
||||
dosregs.edx:=tb_offset;
|
||||
dosregs.ds:=tb_selector;
|
||||
dosregs.ah:=$1a;
|
||||
msdos(dosregs);
|
||||
dosregs.ah:=$4f;
|
||||
@ -764,7 +764,7 @@ begin
|
||||
doserror:=0;
|
||||
strpcopy(path0,path);
|
||||
{$ifdef Go32V2}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
LFNFindFirst(path0,attr,f)
|
||||
else
|
||||
Dosfindfirst(path0,attr,f);
|
||||
@ -778,7 +778,7 @@ procedure findnext(var f : searchRec);
|
||||
begin
|
||||
doserror:=0;
|
||||
{$ifdef Go32V2}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
LFNFindnext(f)
|
||||
else
|
||||
Dosfindnext(f);
|
||||
@ -791,7 +791,7 @@ end;
|
||||
Procedure FindClose(Var f: SearchRec);
|
||||
begin
|
||||
{$ifdef Go32V2}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
LFNFindClose(f);
|
||||
{$endif}
|
||||
end;
|
||||
@ -877,7 +877,7 @@ end;
|
||||
for i:=1 to length(pa) do
|
||||
if pa[i]='/' then
|
||||
pa[i]:='\';
|
||||
|
||||
|
||||
if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
|
||||
begin
|
||||
{ we must get the right directory }
|
||||
@ -895,14 +895,14 @@ end;
|
||||
pa:=s+pa
|
||||
else
|
||||
pa:=s+'\'+pa;
|
||||
|
||||
|
||||
{ Turbo Pascal gives current dir on drive if only drive given as parameter! }
|
||||
if length(pa) = 2 then
|
||||
begin
|
||||
getdir(byte(pa[1])-64,s);
|
||||
pa := s;
|
||||
end;
|
||||
|
||||
|
||||
{First remove all references to '\.\'}
|
||||
while pos ('\.\',pa)<>0 do
|
||||
delete (pa,pos('\.\',pa),2);
|
||||
@ -918,9 +918,9 @@ end;
|
||||
delete (pa,j,i-j+3);
|
||||
end;
|
||||
until i=0;
|
||||
|
||||
|
||||
{ Turbo Pascal gets rid of a \.. at the end of the path }
|
||||
{ Now remove also any reference to '\..' at end of line
|
||||
{ Now remove also any reference to '\..' at end of line
|
||||
+ of course previous dir.. }
|
||||
i:=pos('\..',pa);
|
||||
if i<>0 then
|
||||
@ -937,7 +937,7 @@ end;
|
||||
{ Remove End . and \}
|
||||
if (length(pa)>0) and (pa[length(pa)]='.') then
|
||||
dec(byte(pa[0]));
|
||||
{ if only the drive + a '\' is left then the '\' should be left to prevtn the program
|
||||
{ if only the drive + a '\' is left then the '\' should be left to prevtn the program
|
||||
accessing the current directory on the drive rather than the root!}
|
||||
{ if the last char of path = '\' then leave it in as this is what TP does! }
|
||||
if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
|
||||
@ -1021,13 +1021,13 @@ var
|
||||
begin
|
||||
{$ifdef GO32V2}
|
||||
copytodos(filerec(f).name,strlen(filerec(f).name)+1);
|
||||
dosregs.edx:=transfer_buffer and 15;
|
||||
dosregs.ds:=transfer_buffer shr 4;
|
||||
dosregs.edx:=tb_offset;
|
||||
dosregs.ds:=tb_selector;
|
||||
{$else}
|
||||
strpcopy(n,filerec(f).name);
|
||||
dosregs.edx:=longint(@n);
|
||||
{$endif}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
begin
|
||||
dosregs.ax:=$7143;
|
||||
dosregs.bx:=0;
|
||||
@ -1048,13 +1048,13 @@ var
|
||||
begin
|
||||
{$ifdef GO32V2}
|
||||
copytodos(filerec(f).name,strlen(filerec(f).name)+1);
|
||||
dosregs.edx:=transfer_buffer mod 16;
|
||||
dosregs.ds:=transfer_buffer div 16;
|
||||
dosregs.edx:=tb_offset;
|
||||
dosregs.ds:=tb_selector;
|
||||
{$else}
|
||||
strpcopy(n,filerec(f).name);
|
||||
dosregs.edx:=longint(@n);
|
||||
{$endif}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
begin
|
||||
dosregs.ax:=$7143;
|
||||
dosregs.bx:=1;
|
||||
@ -1139,7 +1139,12 @@ End;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.8 1998-08-16 20:39:49 peter
|
||||
Revision 1.9 1998-08-26 10:04:01 peter
|
||||
* new lfn check from mailinglist
|
||||
* renamed win95 -> LFNSupport
|
||||
+ tb_selector, tb_offset for easier access to transferbuffer
|
||||
|
||||
Revision 1.8 1998/08/16 20:39:49 peter
|
||||
+ LFN Support
|
||||
|
||||
Revision 1.7 1998/08/16 09:12:13 michael
|
||||
|
||||
@ -159,6 +159,8 @@ unit go32;
|
||||
function get_run_mode : word;
|
||||
|
||||
function transfer_buffer : longint;
|
||||
function tb_selector : longint;
|
||||
function tb_offset : longint;
|
||||
function tb_size : longint;
|
||||
procedure copytodos(var addr; len : longint);
|
||||
procedure copyfromdos(var addr; len : longint);
|
||||
@ -560,34 +562,24 @@ end ['EAX','EDX'];
|
||||
{$endif VER0_99_5}
|
||||
|
||||
|
||||
function get_cs : word;
|
||||
|
||||
begin
|
||||
asm
|
||||
function get_cs : word;assembler;
|
||||
asm
|
||||
movw %cs,%ax
|
||||
movw %ax,__RESULT;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function get_ss : word;
|
||||
|
||||
begin
|
||||
asm
|
||||
function get_ss : word;assembler;
|
||||
asm
|
||||
movw %ss,%ax
|
||||
movw %ax,__RESULT;
|
||||
end;
|
||||
end;
|
||||
|
||||
function get_ds : word;
|
||||
|
||||
begin
|
||||
asm
|
||||
function get_ds : word;assembler;
|
||||
asm
|
||||
movw %ds,%ax
|
||||
movw %ax,__RESULT;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure test_int31(flag : longint);[alias : 'test_int31'];
|
||||
begin
|
||||
asm
|
||||
@ -1160,24 +1152,39 @@ end ['EAX','EDX'];
|
||||
end;
|
||||
end;
|
||||
|
||||
{$ifndef V0_6}
|
||||
|
||||
{*****************************************************************************
|
||||
Transfer Buffer
|
||||
*****************************************************************************}
|
||||
|
||||
function transfer_buffer : longint;
|
||||
|
||||
begin
|
||||
transfer_buffer := go32_info_block.linear_address_of_transfer_buffer;
|
||||
end;
|
||||
|
||||
function tb_size : longint;
|
||||
|
||||
function tb_selector : longint;
|
||||
begin
|
||||
tb_selector:=go32_info_block.linear_address_of_transfer_buffer shr 4;
|
||||
end;
|
||||
|
||||
|
||||
function tb_offset : longint;
|
||||
begin
|
||||
tb_offset:=go32_info_block.linear_address_of_transfer_buffer and $f;
|
||||
end;
|
||||
|
||||
|
||||
function tb_size : longint;
|
||||
begin
|
||||
tb_size := go32_info_block.size_of_transfer_buffer;
|
||||
end;
|
||||
|
||||
procedure copytodos(var addr; len : longint);
|
||||
|
||||
procedure copytodos(var addr; len : longint);
|
||||
begin
|
||||
if len>tb_size then runerror(217);
|
||||
if len>tb_size then
|
||||
runerror(217);
|
||||
{$ifdef GO32V2}
|
||||
seg_move(get_ds,longint(@addr),dosmemselector,transfer_buffer,len);
|
||||
{$else GO32V2}
|
||||
@ -1185,10 +1192,11 @@ end ['EAX','EDX'];
|
||||
{$endif GO32V2}
|
||||
end;
|
||||
|
||||
procedure copyfromdos(var addr; len : longint);
|
||||
|
||||
procedure copyfromdos(var addr; len : longint);
|
||||
begin
|
||||
if len > tb_size then runerror(217);
|
||||
if len>tb_size then
|
||||
runerror(217);
|
||||
{$ifdef GO32V2}
|
||||
seg_move(dosmemselector,transfer_buffer,get_ds,longint(@addr),len);
|
||||
{$else GO32V2}
|
||||
@ -1196,7 +1204,7 @@ end ['EAX','EDX'];
|
||||
{$endif GO32V2}
|
||||
end;
|
||||
|
||||
{$endif not V0_6}
|
||||
|
||||
|
||||
begin
|
||||
int31error:=0;
|
||||
@ -1218,7 +1226,12 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.10 1998-08-11 00:07:17 peter
|
||||
Revision 1.11 1998-08-26 10:04:02 peter
|
||||
* new lfn check from mailinglist
|
||||
* renamed win95 -> LFNSupport
|
||||
+ tb_selector, tb_offset for easier access to transferbuffer
|
||||
|
||||
Revision 1.10 1998/08/11 00:07:17 peter
|
||||
* $ifdef ver0_99_5 instead of has_property
|
||||
|
||||
Revision 1.9 1998/07/21 12:06:03 carl
|
||||
|
||||
@ -53,7 +53,7 @@ var
|
||||
|
||||
{$ifndef RTLLITE}
|
||||
{ System info }
|
||||
Win95 : boolean;
|
||||
LFNSupport : boolean;
|
||||
{$endif RTLLITE}
|
||||
|
||||
type
|
||||
@ -213,6 +213,18 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function tb_selector : longint;
|
||||
begin
|
||||
tb_selector:=go32_info_block.linear_address_of_transfer_buffer shr 4;
|
||||
end;
|
||||
|
||||
|
||||
function tb_offset : longint;
|
||||
begin
|
||||
tb_offset:=go32_info_block.linear_address_of_transfer_buffer and $f;
|
||||
end;
|
||||
|
||||
|
||||
function tb_size : longint;
|
||||
begin
|
||||
tb_size:=go32_info_block.size_of_transfer_buffer;
|
||||
@ -588,7 +600,7 @@ end;
|
||||
var
|
||||
opennames : array [0..max_files-1] of pchar;
|
||||
openfiles : array [0..max_files-1] of boolean;
|
||||
|
||||
|
||||
{$endif SYSTEMDEBUG}
|
||||
|
||||
procedure do_close(handle : longint);
|
||||
@ -611,10 +623,10 @@ var
|
||||
begin
|
||||
AllowSlash(p);
|
||||
syscopytodos(longint(p),strlen(p)+1);
|
||||
regs.realedx:=tb and 15;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realedx:=tb_offset;
|
||||
regs.realds:=tb_selector;
|
||||
{$ifndef RTLLITE}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
regs.realeax:=$7141
|
||||
else
|
||||
{$endif RTLLITE}
|
||||
@ -637,12 +649,12 @@ begin
|
||||
HandleError(217);
|
||||
sysseg_move(get_ds,longint(p2),dos_selector,tb,strlen(p2)+1);
|
||||
sysseg_move(get_ds,longint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1);
|
||||
regs.realedi:=tb and 15;
|
||||
regs.realedx:=tb and 15 + strlen(p2)+2;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.reales:=regs.realds;
|
||||
regs.realedi:=tb_offset;
|
||||
regs.realedx:=tb_offset + strlen(p2)+2;
|
||||
regs.realds:=tb_selector;
|
||||
regs.reales:=tb_selector;
|
||||
{$ifndef RTLLITE}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
regs.realeax:=$7156
|
||||
else
|
||||
{$endif RTLLITE}
|
||||
@ -669,8 +681,8 @@ begin
|
||||
size:=len;
|
||||
syscopytodos(addr+writesize,size);
|
||||
regs.realecx:=size;
|
||||
regs.realedx:=tb and 15;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realedx:=tb_offset;
|
||||
regs.realds:=tb_selector;
|
||||
regs.realebx:=h;
|
||||
regs.realeax:=$4000;
|
||||
sysrealintr($21,regs);
|
||||
@ -700,8 +712,8 @@ begin
|
||||
else
|
||||
size:=len;
|
||||
regs.realecx:=size;
|
||||
regs.realedx:=tb and 15;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realedx:=tb_offset;
|
||||
regs.realds:=tb_selector;
|
||||
regs.realebx:=h;
|
||||
regs.realeax:=$3f00;
|
||||
sysrealintr($21,regs);
|
||||
@ -796,8 +808,8 @@ var
|
||||
begin
|
||||
do_seek(handle,pos);
|
||||
regs.realecx:=0;
|
||||
regs.realedx:=tb and 15;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realedx:=tb_offset;
|
||||
regs.realds:=tb_selector;
|
||||
regs.realebx:=handle;
|
||||
regs.realeax:=$4000;
|
||||
sysrealintr($21,regs);
|
||||
@ -862,14 +874,14 @@ begin
|
||||
{ real dos call }
|
||||
syscopytodos(longint(p),strlen(p)+1);
|
||||
{$ifndef RTLLITE}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
regs.realeax:=$716c
|
||||
else
|
||||
{$endif RTLLITE}
|
||||
regs.realeax:=$6c00;
|
||||
regs.realedx:=action;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realesi:=tb and 15;
|
||||
regs.realds:=tb_selector;
|
||||
regs.realesi:=tb_offset;
|
||||
regs.realebx:=$2000+(flags and $ff);
|
||||
regs.realecx:=$20;
|
||||
sysrealintr($21,regs);
|
||||
@ -943,10 +955,10 @@ begin
|
||||
buffer[length(s)]:=#0;
|
||||
AllowSlash(pchar(@buffer));
|
||||
syscopytodos(longint(@buffer),length(s)+1);
|
||||
regs.realedx:=tb and 15;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realedx:=tb_offset;
|
||||
regs.realds:=tb_selector;
|
||||
{$ifndef RTLLITE}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
regs.realeax:=$7100+func
|
||||
else
|
||||
{$endif RTLLITE}
|
||||
@ -959,21 +971,24 @@ end;
|
||||
|
||||
procedure mkdir(const s : string);[IOCheck];
|
||||
begin
|
||||
If InOutRes <> 0 then exit;
|
||||
If InOutRes <> 0 then
|
||||
exit;
|
||||
DosDir($39,s);
|
||||
end;
|
||||
|
||||
|
||||
procedure rmdir(const s : string);[IOCheck];
|
||||
begin
|
||||
If InOutRes <> 0 then exit;
|
||||
If InOutRes <> 0 then
|
||||
exit;
|
||||
DosDir($3a,s);
|
||||
end;
|
||||
|
||||
|
||||
procedure chdir(const s : string);[IOCheck];
|
||||
begin
|
||||
If InOutRes <> 0 then exit;
|
||||
If InOutRes <> 0 then
|
||||
exit;
|
||||
DosDir($3b,s);
|
||||
end;
|
||||
|
||||
@ -985,10 +1000,10 @@ var
|
||||
regs : trealregs;
|
||||
begin
|
||||
regs.realedx:=drivenr;
|
||||
regs.realesi:=tb and 15;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realesi:=tb_offset;
|
||||
regs.realds:=tb_selector;
|
||||
{$ifndef RTLLITE}
|
||||
if Win95 then
|
||||
if LFNSupport then
|
||||
regs.realeax:=$7147
|
||||
else
|
||||
{$endif RTLLITE}
|
||||
@ -1034,13 +1049,24 @@ end;
|
||||
*****************************************************************************}
|
||||
|
||||
{$ifndef RTLLITE}
|
||||
function CheckWin95:boolean;
|
||||
function CheckLFN:boolean;
|
||||
var
|
||||
regs : TRealRegs;
|
||||
regs : TRealRegs;
|
||||
Buffers,
|
||||
RootName : pchar;
|
||||
begin
|
||||
regs.realeax:=$160a;
|
||||
sysrealintr($2f,regs);
|
||||
CheckWin95:=(regs.realeax=0) and ((regs.realebx and $ff00)=$400);
|
||||
RootName:='C:\'+#0;
|
||||
Buffers:=' '+#0;
|
||||
syscopytodos(longint(RootName),strlen(RootName)+1);
|
||||
regs.realeax:=$71a0;
|
||||
regs.reales:=tb_selector;
|
||||
regs.realedi:=tb_offset;
|
||||
regs.realecx:=strlen(Buffers)+1;
|
||||
regs.realds:=tb_selector;
|
||||
regs.realedx:=tb_offset;
|
||||
sysrealintr($21,regs);
|
||||
syscopyfromdos(longint(Buffers),strlen(Buffers)+1);
|
||||
CheckLFN:=(regs.realecx=255);
|
||||
end;
|
||||
{$endif RTLLITE}
|
||||
|
||||
@ -1057,14 +1083,19 @@ Begin
|
||||
{ Setup environment and arguments }
|
||||
Setup_Environment;
|
||||
Setup_Arguments;
|
||||
{ Use Win95 LFN }
|
||||
Win95:=CheckWin95;
|
||||
{ Use LFNSupport LFN }
|
||||
LFNSupport:=CheckLFN;
|
||||
{ Reset IO Error }
|
||||
InOutRes:=0;
|
||||
End.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.15 1998-08-19 10:56:34 pierre
|
||||
Revision 1.16 1998-08-26 10:04:03 peter
|
||||
* new lfn check from mailinglist
|
||||
* renamed win95 -> LFNSupport
|
||||
+ tb_selector, tb_offset for easier access to transferbuffer
|
||||
|
||||
Revision 1.15 1998/08/19 10:56:34 pierre
|
||||
+ added some special code for C interface
|
||||
to avoid loading of crt1.o or dpmiexcp.o from the libc.a
|
||||
|
||||
@ -1117,5 +1148,5 @@ End.
|
||||
* fix for smartlinking with _ARGS
|
||||
|
||||
Revision 1.3 1998/05/04 16:21:54 florian
|
||||
+ win95 flag to the interface moved
|
||||
+ LFNSupport flag to the interface moved
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user