mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 07:19:27 +02:00
* GetDir fixed
This commit is contained in:
Tomas Hajny
parent
4ac6b9a7ca
commit
f041ede95b
@ -532,26 +532,23 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
|
||||
[public, alias: 'FPC_GETDIRIO'];
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
var
|
||||
temp : array[0..255] of char;
|
||||
sof : pchar;
|
||||
i : byte;
|
||||
IOR: word;
|
||||
begin
|
||||
sof:=pchar(@dir[4]);
|
||||
{ dir[1..3] will contain '[drivenr]:\', but is not supplied by DOS,
|
||||
so we let dos string start at dir[4]
|
||||
Get dir from drivenr : 0=default, 1=A etc }
|
||||
IOR := 0;
|
||||
asm
|
||||
movb drivenr,%dl
|
||||
movl sof,%esi
|
||||
mov $0x47,%ah
|
||||
int $0x21
|
||||
jnc .LGetDir
|
||||
movw %ax, IOR
|
||||
movw %ax, InOutRes
|
||||
.LGetDir:
|
||||
end;
|
||||
{ Now Dir should be filled with directory in ASCIIZ starting from dir[4] }
|
||||
@ -584,14 +581,8 @@ begin
|
||||
dir[1]:=chr(i);
|
||||
end;
|
||||
dir:=upcase(dir);
|
||||
GetDirIO := IOR;
|
||||
end;
|
||||
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
|
||||
begin
|
||||
InOutRes := GetDirIO (DriveNr, Dir);
|
||||
end;
|
||||
|
||||
{*****************************************************************************
|
||||
System Dependent Exit code
|
||||
@ -628,7 +619,10 @@ Begin
|
||||
End.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2001-03-10 09:57:51 hajny
|
||||
Revision 1.4 2001-03-21 21:08:20 hajny
|
||||
* GetDir fixed
|
||||
|
||||
Revision 1.3 2001/03/10 09:57:51 hajny
|
||||
* FExpand without IOResult change, remaining direct asm removed
|
||||
|
||||
Revision 1.2 2000/07/13 11:33:38 michael
|
||||
|
||||
@ -1280,15 +1280,12 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
|
||||
[public, alias: 'FPC_GETDIRIO'];
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
var
|
||||
temp : array[0..255] of char;
|
||||
i : longint;
|
||||
regs : trealregs;
|
||||
IOR: word;
|
||||
begin
|
||||
IOR := 0;
|
||||
regs.realedx:=drivenr;
|
||||
regs.realesi:=tb_offset;
|
||||
regs.realds:=tb_segment;
|
||||
@ -1301,7 +1298,7 @@ begin
|
||||
sysrealintr($21,regs);
|
||||
if (regs.realflags and carryflag) <> 0 then
|
||||
Begin
|
||||
IOR := lo(regs.realeax);
|
||||
GetInOutRes (lo(regs.realeax));
|
||||
exit;
|
||||
end
|
||||
else
|
||||
@ -1334,12 +1331,6 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
|
||||
begin
|
||||
GetInOutRes (GetDirIO (DriveNr, Dir));
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
SystemUnit Initialization
|
||||
@ -1426,7 +1417,10 @@ Begin
|
||||
End.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.5 2001-03-16 20:09:58 hajny
|
||||
Revision 1.6 2001-03-21 21:08:20 hajny
|
||||
* GetDir fixed
|
||||
|
||||
Revision 1.5 2001/03/16 20:09:58 hajny
|
||||
* universal FExpand
|
||||
|
||||
Revision 1.4 2001/02/20 21:31:12 peter
|
||||
|
||||
@ -18,11 +18,19 @@
|
||||
|
||||
|
||||
function GetDirIO (DriveNr: byte; var Dir: OpenString): word;
|
||||
[external name 'FPC_GETDIRIO'];
|
||||
|
||||
(* GetDirIO is supposed to return the root of the given drive *)
|
||||
(* in case of an error for compatibility of FExpand with TP/BP. *)
|
||||
(* Dir must be specified as OpenString since System has $P+. *)
|
||||
|
||||
var
|
||||
OldInOutRes: word;
|
||||
begin
|
||||
OldInOutRes := InOutRes;
|
||||
InOutRes := 0;
|
||||
GetDir (DriveNr, Dir);
|
||||
GetDirIO := InOutRes;
|
||||
InOutRes := OldInOutRes;
|
||||
end;
|
||||
|
||||
|
||||
function FExpand (const Path: PathStr): PathStr;
|
||||
@ -199,7 +207,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.4 2001-03-19 21:09:30 hajny
|
||||
Revision 1.5 2001-03-21 21:08:20 hajny
|
||||
* GetDir fixed
|
||||
|
||||
Revision 1.4 2001/03/19 21:09:30 hajny
|
||||
* one more problem in the Unix part
|
||||
|
||||
Revision 1.3 2001/03/19 21:05:42 hajny
|
||||
|
||||
@ -771,14 +771,12 @@ end;
|
||||
|
||||
{$ASMMODE ATT}
|
||||
|
||||
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
|
||||
[public, alias: 'FPC_GETDIRIO'];
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
|
||||
{Written by Michael Van Canneyt.}
|
||||
|
||||
var sof:Pchar;
|
||||
i:byte;
|
||||
IOR: word;
|
||||
|
||||
begin
|
||||
Dir [4] := #0;
|
||||
@ -788,14 +786,13 @@ begin
|
||||
{ supplied by DOS, so we let dos string start at }
|
||||
{ dir[4] }
|
||||
{ Get dir from drivenr : 0=default, 1=A etc... }
|
||||
IOR := 0;
|
||||
asm
|
||||
movb drivenr,%dl
|
||||
movl sof,%esi
|
||||
mov $0x47,%ah
|
||||
call syscall
|
||||
jnc .LGetDir
|
||||
movw %ax, IOR
|
||||
movw %ax, InOutRes
|
||||
.LGetDir:
|
||||
end;
|
||||
{ Now Dir should be filled with directory in ASCIIZ, }
|
||||
@ -829,13 +826,6 @@ begin
|
||||
dir[1]:=char(i);
|
||||
end;
|
||||
if not (FileNameCaseSensitive) then dir:=upcase(dir);
|
||||
GetDirIO := IOR;
|
||||
end;
|
||||
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
|
||||
begin
|
||||
InOutRes := GetDirIO (DriveNr, Dir);
|
||||
end;
|
||||
|
||||
|
||||
@ -964,7 +954,10 @@ begin
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.9 2001-03-10 09:57:51 hajny
|
||||
Revision 1.10 2001-03-21 21:08:20 hajny
|
||||
* GetDir fixed
|
||||
|
||||
Revision 1.9 2001/03/10 09:57:51 hajny
|
||||
* FExpand without IOResult change, remaining direct asm removed
|
||||
|
||||
Revision 1.8 2001/02/20 21:31:12 peter
|
||||
|
||||
@ -482,8 +482,7 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
|
||||
[public, alias: 'FPC_GETDIRIO'];
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
var
|
||||
thisdir : stat;
|
||||
rootino,
|
||||
@ -498,7 +497,6 @@ var
|
||||
mountpoint,validdir : boolean;
|
||||
predot : string[255];
|
||||
begin
|
||||
GetDirIO := 0;
|
||||
drivenr:=0;
|
||||
dir:='';
|
||||
thedir:='/'#0;
|
||||
@ -554,12 +552,6 @@ begin
|
||||
dir:=thedir
|
||||
end;
|
||||
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
|
||||
begin
|
||||
InOutRes := GetDirIO (DriveNr, Dir);
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
SystemUnit Initialization
|
||||
@ -754,7 +746,10 @@ End.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.6 2001-03-16 20:09:58 hajny
|
||||
Revision 1.7 2001-03-21 21:08:20 hajny
|
||||
* GetDir fixed
|
||||
|
||||
Revision 1.6 2001/03/16 20:09:58 hajny
|
||||
* universal FExpand
|
||||
|
||||
Revision 1.5 2001/02/20 21:31:12 peter
|
||||
|
||||
@ -640,23 +640,23 @@ begin
|
||||
dirfn(TDirFnType(@SetCurrentDirectory),s);
|
||||
end;
|
||||
|
||||
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
|
||||
[public, alias: 'FPC_GETDIRIO'];
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
const
|
||||
Drive:array[0..3]of char=(#0,':',#0,#0);
|
||||
var
|
||||
defaultdrive:boolean;
|
||||
DirBuf,SaveBuf:array[0..259] of Char;
|
||||
IOR: word;
|
||||
begin
|
||||
IOR := 0;
|
||||
defaultdrive:=drivenr=0;
|
||||
if not defaultdrive then
|
||||
begin
|
||||
byte(Drive[0]):=Drivenr+64;
|
||||
GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
|
||||
if SetCurrentDirectory(@Drive) <> 0 then
|
||||
IOR := word (GetLastError);
|
||||
begin
|
||||
errno := word (GetLastError);
|
||||
Errno2InoutRes;
|
||||
end;
|
||||
end;
|
||||
GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
|
||||
if not defaultdrive then
|
||||
@ -664,14 +664,6 @@ begin
|
||||
dir:=strpas(DirBuf);
|
||||
if not FileNameCaseSensitive then
|
||||
dir:=upcase(dir);
|
||||
GetDirIO := IOR;
|
||||
end;
|
||||
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
|
||||
begin
|
||||
errno := GetDirIO (DriveNr, Dir);
|
||||
Errno2InoutRes;
|
||||
end;
|
||||
|
||||
|
||||
@ -1438,7 +1430,10 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.7 2001-03-16 20:09:58 hajny
|
||||
Revision 1.8 2001-03-21 21:08:20 hajny
|
||||
* GetDir fixed
|
||||
|
||||
Revision 1.7 2001/03/16 20:09:58 hajny
|
||||
* universal FExpand
|
||||
|
||||
Revision 1.6 2001/02/20 21:31:12 peter
|
||||
|
||||
Loading…
Reference in New Issue
Block a user