mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-14 12:29:18 +02:00
* changed getdir(ansistring):ansistring to
getdir(rawbytestring):rawbytestring so it can accept strings in any encoding and cleanly return results in DefaultRTLFileSystemCodePage + getdir(unicodestring):unicodestring * renamed the getdir implementation of all platforms except for embedded- without-ansistring-support to do_getdir(), and depending on the FPCRTL_FILESYSTEM_SINGLE_BYTE_API/FPCRTL_FILESYSTEM_TWO_BYTE_API define changed its shortstring parameter to ansistring or unicodestring. The do_getdir(rawbytestring) routine should just set the code page of the return value to DefaultFileSystemCodePage without conversion (not DefaultRTLFileSystemCodePage with conversion, that conversion is performed in getdir if necessary; this avoids double conversions in case getdir(unicodestring) is called) + generic getdir(shortstring) for platforms supporting either ansistrings or widestrings o platform maintainers: o OS/2: adjust code to supports paths > 255 characters if those are supported o Wii: adjust used callback to use rawbytestring to support paths > 255 characters and avoid shortstring->rawbytestring conversion overhead o Windows: GetCurrentDirectoryW is now always used (to prevent data loss) git-svn-id: branches/cpstrrtl@24993 -
This commit is contained in:
parent
679785f90c
commit
62ee16278b
@ -88,7 +88,7 @@ begin
|
|||||||
sys_chdir(s);
|
sys_chdir(s);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
var tmpbuf: array[0..255] of char;
|
var tmpbuf: array[0..255] of char;
|
||||||
begin
|
begin
|
||||||
checkCTRLC;
|
checkCTRLC;
|
||||||
@ -97,5 +97,8 @@ begin
|
|||||||
if not GetCurrentDirName(tmpbuf,256) then
|
if not GetCurrentDirName(tmpbuf,256) then
|
||||||
dosError2InOut(IoErr)
|
dosError2InOut(IoErr)
|
||||||
else
|
else
|
||||||
Dir:=strpas(tmpbuf);
|
begin
|
||||||
|
Dir:=tmpbuf;
|
||||||
|
SetCodePage(Dir,DefaultFileSystemCodePage,false);
|
||||||
|
end;
|
||||||
end;
|
end;
|
||||||
|
@ -34,7 +34,11 @@ begin
|
|||||||
InOutRes:=3;
|
InOutRes:=3;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
{$if defined(FPC_HAS_FEATURE_ANSISTRINGS)}
|
||||||
|
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
|
{$else FPC_HAS_FEATURE_ANSISTRINGS}
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||||
|
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
|
||||||
begin
|
begin
|
||||||
InOutRes:=3;
|
InOutRes:=3;
|
||||||
end;
|
end;
|
||||||
|
@ -163,7 +163,7 @@ end;
|
|||||||
|
|
||||||
{$ASMMODE ATT}
|
{$ASMMODE ATT}
|
||||||
|
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
|
|
||||||
{Written by Michael Van Canneyt.}
|
{Written by Michael Van Canneyt.}
|
||||||
|
|
||||||
@ -171,6 +171,7 @@ var sof:Pchar;
|
|||||||
i:byte;
|
i:byte;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
SetLength(Dir,260);
|
||||||
Dir [4] := #0;
|
Dir [4] := #0;
|
||||||
{ Used in case the specified drive isn't available }
|
{ Used in case the specified drive isn't available }
|
||||||
sof:=pchar(@dir[4]);
|
sof:=pchar(@dir[4]);
|
||||||
@ -189,7 +190,6 @@ begin
|
|||||||
end [ 'eax','edx','esi'];
|
end [ 'eax','edx','esi'];
|
||||||
{ Now Dir should be filled with directory in ASCIIZ, }
|
{ Now Dir should be filled with directory in ASCIIZ, }
|
||||||
{ starting from dir[4] }
|
{ starting from dir[4] }
|
||||||
dir[0]:=#3;
|
|
||||||
dir[2]:=':';
|
dir[2]:=':';
|
||||||
dir[3]:='\';
|
dir[3]:='\';
|
||||||
i:=4;
|
i:=4;
|
||||||
@ -199,10 +199,9 @@ begin
|
|||||||
{ convert path name to DOS }
|
{ convert path name to DOS }
|
||||||
if dir[i] in AllowDirectorySeparators then
|
if dir[i] in AllowDirectorySeparators then
|
||||||
dir[i]:=DirectorySeparator;
|
dir[i]:=DirectorySeparator;
|
||||||
dir[0]:=char(i);
|
|
||||||
inc(i);
|
inc(i);
|
||||||
end;
|
end;
|
||||||
{ upcase the string (FPC function) }
|
SetLength(dir,i-1);
|
||||||
if drivenr<>0 then { Drive was supplied. We know it }
|
if drivenr<>0 then { Drive was supplied. We know it }
|
||||||
dir[1]:=chr(64+drivenr)
|
dir[1]:=chr(64+drivenr)
|
||||||
else
|
else
|
||||||
@ -217,5 +216,7 @@ begin
|
|||||||
end ['eax'];
|
end ['eax'];
|
||||||
dir[1]:=char(i);
|
dir[1]:=char(i);
|
||||||
end;
|
end;
|
||||||
|
SetCodePage(dir,DefaultFileSystemCodePage,false);
|
||||||
|
{ upcase the string (FPC function) }
|
||||||
if not (FileNameCasePreserving) then dir:=upcase(dir);
|
if not (FileNameCasePreserving) then dir:=upcase(dir);
|
||||||
end;
|
end;
|
||||||
|
@ -34,7 +34,7 @@ begin
|
|||||||
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir(DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir(DriveNr: byte; var Dir: RawByteString);
|
||||||
begin
|
begin
|
||||||
|
|
||||||
end;
|
end;
|
||||||
|
@ -85,7 +85,7 @@ begin
|
|||||||
DosDir($3b,s,len);
|
DosDir($3b,s,len);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
var
|
var
|
||||||
temp : array[0..255] of char;
|
temp : array[0..255] of char;
|
||||||
i : longint;
|
i : longint;
|
||||||
@ -103,12 +103,14 @@ begin
|
|||||||
Begin
|
Begin
|
||||||
GetInOutRes (lo(regs.realeax));
|
GetInOutRes (lo(regs.realeax));
|
||||||
Dir := char (DriveNr + 64) + ':\';
|
Dir := char (DriveNr + 64) + ':\';
|
||||||
|
SetCodePage (Dir,DefaultFileSystemCodePage,false);
|
||||||
exit;
|
exit;
|
||||||
end
|
end
|
||||||
else
|
else
|
||||||
syscopyfromdos(longint(@temp),251);
|
syscopyfromdos(longint(@temp),251);
|
||||||
{ conversion to Pascal string including slash conversion }
|
{ conversion to Pascal string including slash conversion }
|
||||||
i:=0;
|
i:=0;
|
||||||
|
SetLength(dir,260);
|
||||||
while (temp[i]<>#0) do
|
while (temp[i]<>#0) do
|
||||||
begin
|
begin
|
||||||
if temp[i] in AllowDirectorySeparators then
|
if temp[i] in AllowDirectorySeparators then
|
||||||
@ -118,7 +120,8 @@ begin
|
|||||||
end;
|
end;
|
||||||
dir[2]:=':';
|
dir[2]:=':';
|
||||||
dir[3]:='\';
|
dir[3]:='\';
|
||||||
dir[0]:=char(i+3);
|
SetLength(dir,i+3);
|
||||||
|
SetCodePage(dir,DefaultFileSystemCodePage,false);
|
||||||
{ upcase the string }
|
{ upcase the string }
|
||||||
if not FileNameCasePreserving then
|
if not FileNameCasePreserving then
|
||||||
dir:=upcase(dir);
|
dir:=upcase(dir);
|
||||||
|
@ -1503,20 +1503,12 @@ end;
|
|||||||
{$i sysdir.inc}
|
{$i sysdir.inc}
|
||||||
{$endif FPC_HAS_FEATURE_FILEIO}
|
{$endif FPC_HAS_FEATURE_FILEIO}
|
||||||
|
|
||||||
{$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
|
|
||||||
Procedure getdir(drivenr:byte;Var dir:ansistring);
|
|
||||||
{ this is needed to also allow ansistrings, the shortstring version is
|
|
||||||
OS dependent }
|
|
||||||
var
|
|
||||||
s : shortstring;
|
|
||||||
begin
|
|
||||||
getdir(drivenr,s);
|
|
||||||
dir:=s;
|
|
||||||
end;
|
|
||||||
{$endif}
|
|
||||||
|
|
||||||
{$if defined(FPC_HAS_FEATURE_FILEIO)}
|
{$if defined(FPC_HAS_FEATURE_FILEIO)}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Procedure MkDir(Const s: String);
|
Procedure MkDir(Const s: String);
|
||||||
Var
|
Var
|
||||||
Buffer: Array[0..255] of Char;
|
Buffer: Array[0..255] of Char;
|
||||||
@ -1549,7 +1541,64 @@ Begin
|
|||||||
Buffer[Length(s)] := #0;
|
Buffer[Length(s)] := #0;
|
||||||
ChDir(@buffer[0],length(s));
|
ChDir(@buffer[0],length(s));
|
||||||
End;
|
End;
|
||||||
{$endif}
|
|
||||||
|
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
|
||||||
|
|
||||||
|
{$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
||||||
|
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
|
||||||
|
var
|
||||||
|
u: unicodestring;
|
||||||
|
begin
|
||||||
|
Do_getdir(drivenr,u);
|
||||||
|
widestringmanager.Unicode2AnsiMoveProc(pwidechar(u),dir,DefaultRTLFileSystemCodePage,length(u));
|
||||||
|
end;
|
||||||
|
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
||||||
|
|
||||||
|
Procedure getdir(drivenr:byte;Var dir:rawbytestring);
|
||||||
|
begin
|
||||||
|
Do_getdir(drivenr,dir);
|
||||||
|
{ we should return results in the DefaultRTLFileSystemCodePage -> convert if
|
||||||
|
necessary }
|
||||||
|
setcodepage(dir,DefaultRTLFileSystemCodePage,true);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ this one is only implemented elsewhere for systems *not* supporting
|
||||||
|
ansi/unicodestrings; for now assume there are no systems that support
|
||||||
|
unicodestrings but not ansistrings }
|
||||||
|
Procedure getdir(drivenr:byte;Var dir:shortstring);
|
||||||
|
var
|
||||||
|
s: rawbytestring;
|
||||||
|
begin
|
||||||
|
Do_getdir(drivenr,s);
|
||||||
|
if length(s)<=high(dir) then
|
||||||
|
dir:=s
|
||||||
|
else
|
||||||
|
inoutres:=3;
|
||||||
|
end;
|
||||||
|
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
|
||||||
|
|
||||||
|
|
||||||
|
{$if defined(FPC_HAS_FEATURE_WIDESTRINGS)}
|
||||||
|
|
||||||
|
{$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
|
||||||
|
procedure do_getdir(drivenr : byte;var dir : unicodestring);
|
||||||
|
var
|
||||||
|
s: rawbytestring;
|
||||||
|
begin
|
||||||
|
Do_getdir(drivenr,s);
|
||||||
|
dir:=s;
|
||||||
|
end;
|
||||||
|
{$endif FPCRTL_FILESYSTEM_TWO_BYTE_API}
|
||||||
|
|
||||||
|
|
||||||
|
Procedure getdir(drivenr:byte;Var dir:unicodestring);
|
||||||
|
begin
|
||||||
|
Do_getdir(drivenr,dir);
|
||||||
|
end;
|
||||||
|
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
|
||||||
|
|
||||||
|
{$endif FPC_HAS_FEATURE_FILEIO}
|
||||||
|
|
||||||
|
|
||||||
{*****************************************************************************
|
{*****************************************************************************
|
||||||
Resources support
|
Resources support
|
||||||
|
@ -1185,10 +1185,15 @@ Procedure mkdir(const s:string); overload;
|
|||||||
Procedure rmdir(const s:string); overload;
|
Procedure rmdir(const s:string); overload;
|
||||||
// the pchar versions are exported via alias for use in objpas
|
// the pchar versions are exported via alias for use in objpas
|
||||||
|
|
||||||
Procedure getdir(drivenr:byte;var dir:shortstring);
|
Procedure getdir(drivenr:byte;var dir:shortstring);overload;
|
||||||
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
|
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
|
||||||
Procedure getdir(drivenr:byte;var dir:ansistring);
|
// defaultrtlfilesystemcodepage is returned here
|
||||||
|
Procedure getdir(drivenr:byte;var dir: rawbytestring);overload;{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}
|
||||||
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
|
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
|
||||||
|
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
|
||||||
|
Procedure getdir(drivenr:byte;var dir: unicodestring);overload;
|
||||||
|
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
|
||||||
|
|
||||||
{$endif FPC_HAS_FEATURE_FILEIO}
|
{$endif FPC_HAS_FEATURE_FILEIO}
|
||||||
|
|
||||||
{*****************************************************************************
|
{*****************************************************************************
|
||||||
|
@ -98,22 +98,16 @@ begin
|
|||||||
InOutRes:=res;
|
InOutRes:=res;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure getDir (DriveNr: byte; var Dir: ShortString);
|
procedure do_getDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
|
|
||||||
var
|
var
|
||||||
fullPath: AnsiString;
|
|
||||||
pathHandleSize: Longint;
|
pathHandleSize: Longint;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if FSpGetFullPath(workingDirectorySpec, fullPath, false) <> noErr then
|
if FSpGetFullPath(workingDirectorySpec, Dir, false) <> noErr then
|
||||||
Halt(3); {exit code 3 according to MPW}
|
Halt(3); {exit code 3 according to MPW}
|
||||||
|
|
||||||
if Length(fullPath) <= 255 then {because dir is ShortString}
|
SetCodePage(Dir,DefaultFileSystemCodePage,false);
|
||||||
InOutRes := 0
|
|
||||||
else
|
|
||||||
InOutRes := 1; //TODO Exchange to something better
|
|
||||||
|
|
||||||
dir:= fullPath;
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
@ -83,7 +83,7 @@ begin
|
|||||||
if assigned(FIB) then dispose(FIB);
|
if assigned(FIB) then dispose(FIB);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
var tmpbuf: array[0..255] of char;
|
var tmpbuf: array[0..255] of char;
|
||||||
begin
|
begin
|
||||||
checkCTRLC;
|
checkCTRLC;
|
||||||
@ -91,5 +91,8 @@ begin
|
|||||||
if not GetCurrentDirName(tmpbuf,256) then
|
if not GetCurrentDirName(tmpbuf,256) then
|
||||||
dosError2InOut(IoErr)
|
dosError2InOut(IoErr)
|
||||||
else
|
else
|
||||||
Dir:=strpas(tmpbuf);
|
begin
|
||||||
|
Dir:=tmpbuf;
|
||||||
|
SetCodePage(Dir,DefaultFileSystemCodePage,false);
|
||||||
|
end;
|
||||||
end;
|
end;
|
||||||
|
@ -84,7 +84,7 @@ begin
|
|||||||
DosDir($3b,s,len);
|
DosDir($3b,s,len);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
var
|
var
|
||||||
temp : array[0..260] of char;
|
temp : array[0..260] of char;
|
||||||
i : longint;
|
i : longint;
|
||||||
@ -102,12 +102,14 @@ begin
|
|||||||
Begin
|
Begin
|
||||||
GetInOutRes (regs.AX);
|
GetInOutRes (regs.AX);
|
||||||
Dir := char (DriveNr + 64) + ':\';
|
Dir := char (DriveNr + 64) + ':\';
|
||||||
|
SetCodePage (Dir,DefaultFileSystemCodePage,false);
|
||||||
exit;
|
exit;
|
||||||
end
|
end
|
||||||
else
|
else
|
||||||
temp[252] := #0; { to avoid shortstring buffer overflow }
|
temp[252] := #0; { to avoid shortstring buffer overflow }
|
||||||
{ conversion to Pascal string including slash conversion }
|
{ conversion to Pascal string including slash conversion }
|
||||||
i:=0;
|
i:=0;
|
||||||
|
SetLength(dir,260);
|
||||||
while (temp[i]<>#0) do
|
while (temp[i]<>#0) do
|
||||||
begin
|
begin
|
||||||
if temp[i] in AllowDirectorySeparators then
|
if temp[i] in AllowDirectorySeparators then
|
||||||
@ -117,7 +119,8 @@ begin
|
|||||||
end;
|
end;
|
||||||
dir[2]:=':';
|
dir[2]:=':';
|
||||||
dir[3]:='\';
|
dir[3]:='\';
|
||||||
dir[0]:=char(i+3);
|
SetLength(dir,i+3);
|
||||||
|
SetCodePage (dir,DefaultFileSystemCodePage,false);
|
||||||
{ upcase the string }
|
{ upcase the string }
|
||||||
if not FileNameCasePreserving then
|
if not FileNameCasePreserving then
|
||||||
dir:=upcase(dir);
|
dir:=upcase(dir);
|
||||||
|
@ -121,7 +121,7 @@ begin
|
|||||||
InOutRes := 3;
|
InOutRes := 3;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir(DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir(DriveNr: byte; var Dir: UnicodeString);
|
||||||
begin
|
begin
|
||||||
{ for now we return simply the root directory }
|
{ for now we return simply the root directory }
|
||||||
Dir := DirectorySeparator;
|
Dir := DirectorySeparator;
|
||||||
|
@ -37,7 +37,7 @@ begin
|
|||||||
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir(DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir(DriveNr: byte; var Dir: RawByteString);
|
||||||
begin
|
begin
|
||||||
|
|
||||||
end;
|
end;
|
||||||
|
@ -54,7 +54,7 @@ begin
|
|||||||
SetFileError(Rc);
|
SetFileError(Rc);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure getdir(drivenr : byte;var dir : shortstring);
|
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
|
||||||
VAR P : ARRAY [0..255] OF CHAR;
|
VAR P : ARRAY [0..255] OF CHAR;
|
||||||
i : LONGINT;
|
i : LONGINT;
|
||||||
begin
|
begin
|
||||||
@ -63,8 +63,8 @@ begin
|
|||||||
i := _strlen (P);
|
i := _strlen (P);
|
||||||
if i > 0 then
|
if i > 0 then
|
||||||
begin
|
begin
|
||||||
|
SetLength (dir, i);
|
||||||
Move (P, dir[1], i);
|
Move (P, dir[1], i);
|
||||||
BYTE(dir[0]) := i;
|
|
||||||
DoDirSeparators(dir);
|
DoDirSeparators(dir);
|
||||||
// fix / after volume, the compiler needs that
|
// fix / after volume, the compiler needs that
|
||||||
// normaly root of a volumes is SERVERNAME/SYS:, change that
|
// normaly root of a volumes is SERVERNAME/SYS:, change that
|
||||||
@ -73,6 +73,7 @@ begin
|
|||||||
if (i > 0) then
|
if (i > 0) then
|
||||||
if i = Length (dir) then dir := dir + '/' else
|
if i = Length (dir) then dir := dir + '/' else
|
||||||
if dir [i+1] <> '/' then insert ('/',dir,i+1);
|
if dir [i+1] <> '/' then insert ('/',dir,i+1);
|
||||||
|
SetCodePage (dir,DefaultFileSystemCodePage,false);
|
||||||
END ELSE
|
END ELSE
|
||||||
InOutRes := 1;
|
InOutRes := 1;
|
||||||
end;
|
end;
|
||||||
|
@ -48,7 +48,7 @@ begin
|
|||||||
SetFileError (Res);
|
SetFileError (Res);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure getdir(drivenr : byte;var dir : shortstring);
|
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
|
||||||
var P : array [0..255] of CHAR;
|
var P : array [0..255] of CHAR;
|
||||||
i : LONGINT;
|
i : LONGINT;
|
||||||
begin
|
begin
|
||||||
@ -57,8 +57,8 @@ begin
|
|||||||
i := libc_strlen (P);
|
i := libc_strlen (P);
|
||||||
if i > 0 then
|
if i > 0 then
|
||||||
begin
|
begin
|
||||||
|
SetLength (dir, i);
|
||||||
Move (P, dir[1], i);
|
Move (P, dir[1], i);
|
||||||
BYTE(dir[0]) := i;
|
|
||||||
DoDirSeparators(dir);
|
DoDirSeparators(dir);
|
||||||
// fix / after volume, the compiler needs that
|
// fix / after volume, the compiler needs that
|
||||||
// normaly root of a volumes is SERVERNAME/SYS:, change that
|
// normaly root of a volumes is SERVERNAME/SYS:, change that
|
||||||
@ -67,6 +67,7 @@ begin
|
|||||||
if (i > 0) then
|
if (i > 0) then
|
||||||
if i = Length (dir) then dir := dir + '/' else
|
if i = Length (dir) then dir := dir + '/' else
|
||||||
if dir [i+1] <> '/' then insert ('/',dir,i+1);
|
if dir [i+1] <> '/' then insert ('/',dir,i+1);
|
||||||
|
SetCodePage (dir,DefaultFileSystemCodePage,false);
|
||||||
end else
|
end else
|
||||||
InOutRes := 1;
|
InOutRes := 1;
|
||||||
end;
|
end;
|
||||||
|
@ -89,12 +89,13 @@ end;
|
|||||||
|
|
||||||
{$ASMMODE ATT}
|
{$ASMMODE ATT}
|
||||||
|
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
{Written by Michael Van Canneyt.}
|
{Written by Michael Van Canneyt.}
|
||||||
var sof: Pchar;
|
var sof: Pchar;
|
||||||
i:byte;
|
i:byte;
|
||||||
l,l2:cardinal;
|
l,l2:cardinal;
|
||||||
begin
|
begin
|
||||||
|
setlength(Dir,255);
|
||||||
Dir [4] := #0;
|
Dir [4] := #0;
|
||||||
{ Used in case the specified drive isn't available }
|
{ Used in case the specified drive isn't available }
|
||||||
sof:=pchar(@dir[4]);
|
sof:=pchar(@dir[4]);
|
||||||
@ -102,12 +103,13 @@ begin
|
|||||||
{ supplied by DOS, so we let dos string start at }
|
{ supplied by DOS, so we let dos string start at }
|
||||||
{ dir[4] }
|
{ dir[4] }
|
||||||
{ Get dir from drivenr : 0=default, 1=A etc... }
|
{ Get dir from drivenr : 0=default, 1=A etc... }
|
||||||
|
{ TODO: if max path length is > 255, increase the setlength parameter above and
|
||||||
|
the 255 below }
|
||||||
l:=255-3;
|
l:=255-3;
|
||||||
InOutRes:=longint (DosQueryCurrentDir(DriveNr, sof^, l));
|
InOutRes:=longint (DosQueryCurrentDir(DriveNr, sof^, l));
|
||||||
{$WARNING Result code should be translated in some cases!}
|
{$WARNING Result code should be translated in some cases!}
|
||||||
{ Now Dir should be filled with directory in ASCIIZ, }
|
{ Now Dir should be filled with directory in ASCIIZ, }
|
||||||
{ starting from dir[4] }
|
{ starting from dir[4] }
|
||||||
dir[0]:=#3;
|
|
||||||
dir[2]:=':';
|
dir[2]:=':';
|
||||||
dir[3]:='\';
|
dir[3]:='\';
|
||||||
i:=4;
|
i:=4;
|
||||||
@ -117,9 +119,9 @@ begin
|
|||||||
{ convert path name to DOS }
|
{ convert path name to DOS }
|
||||||
if dir[i] in AllowDirectorySeparators then
|
if dir[i] in AllowDirectorySeparators then
|
||||||
dir[i]:=DirectorySeparator;
|
dir[i]:=DirectorySeparator;
|
||||||
dir[0]:=char(i);
|
|
||||||
inc(i);
|
inc(i);
|
||||||
end;
|
end;
|
||||||
|
setlength(dir,i-1);
|
||||||
{ upcase the string (FPC function) }
|
{ upcase the string (FPC function) }
|
||||||
if drivenr<>0 then { Drive was supplied. We know it }
|
if drivenr<>0 then { Drive was supplied. We know it }
|
||||||
dir[1]:=chr(64+drivenr)
|
dir[1]:=chr(64+drivenr)
|
||||||
@ -130,6 +132,7 @@ begin
|
|||||||
DosQueryCurrentDisk(l, l2);
|
DosQueryCurrentDisk(l, l2);
|
||||||
dir[1]:=chr(64+l);
|
dir[1]:=chr(64+l);
|
||||||
end;
|
end;
|
||||||
|
SetCodePage(dir,DefaultFileSystemCodePage,false);
|
||||||
if not (FileNameCasePreserving) then dir:=upcase(dir);
|
if not (FileNameCasePreserving) then dir:=upcase(dir);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
@ -32,7 +32,7 @@ begin
|
|||||||
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
begin
|
begin
|
||||||
|
|
||||||
end;
|
end;
|
||||||
|
@ -70,26 +70,32 @@ End;
|
|||||||
// !! In the libc versions, the alt code is already integrated in the libc code.
|
// !! In the libc versions, the alt code is already integrated in the libc code.
|
||||||
// !! Also significantly boosted buffersize. This will make failure of the
|
// !! Also significantly boosted buffersize. This will make failure of the
|
||||||
// !! dos legacy api's better visibile due to cut-off path, instead of "empty"
|
// !! dos legacy api's better visibile due to cut-off path, instead of "empty"
|
||||||
procedure getdir(drivenr : byte;var dir : shortstring);
|
|
||||||
|
|
||||||
|
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
|
||||||
var
|
var
|
||||||
buf : array[0..2047] of char;
|
buf : array[0..2047] of char;
|
||||||
|
{$ifndef FPC_USE_LIBC}
|
||||||
cwdinfo : stat;
|
cwdinfo : stat;
|
||||||
rootinfo : stat;
|
rootinfo : stat;
|
||||||
thedir,dummy : string[255];
|
thedir,dummy : rawbytestring;
|
||||||
dirstream : pdir;
|
dirstream : pdir;
|
||||||
d : pdirent;
|
d : pdirent;
|
||||||
name : string[255];
|
|
||||||
thisdir : stat;
|
thisdir : stat;
|
||||||
tmp : string[255];
|
tmp : rawbytestring;
|
||||||
|
{$endif FPC_USE_LIBC}
|
||||||
begin
|
begin
|
||||||
dir:='';
|
dir:='';
|
||||||
if Fpgetcwd(@buf[0],sizeof(buf))<>nil then
|
if Fpgetcwd(@buf[0],sizeof(buf))<>nil then
|
||||||
dir:=strpas(buf)
|
begin
|
||||||
|
dir:=buf;
|
||||||
|
{ the returned result by the OS is in the DefaultFileSystemCodePage ->
|
||||||
|
no conversion }
|
||||||
|
setcodepage(dir,DefaultFileSystemCodePage,false);
|
||||||
|
end
|
||||||
{$ifndef FPC_USE_LIBC}
|
{$ifndef FPC_USE_LIBC}
|
||||||
else
|
else
|
||||||
begin
|
begin
|
||||||
thedir:='';
|
|
||||||
dummy:='';
|
dummy:='';
|
||||||
|
|
||||||
{ get root directory information }
|
{ get root directory information }
|
||||||
@ -108,12 +114,12 @@ begin
|
|||||||
if dirstream=nil then
|
if dirstream=nil then
|
||||||
exit;
|
exit;
|
||||||
repeat
|
repeat
|
||||||
name:='';
|
thedir:='';
|
||||||
d:=Fpreaddir(dirstream);
|
d:=Fpreaddir(dirstream);
|
||||||
{ no more entries to read ... }
|
{ no more entries to read ... }
|
||||||
if not assigned(d) then
|
if not assigned(d) then
|
||||||
break;
|
break;
|
||||||
tmp:=dummy+'../'+strpas(d^.d_name) + #0;
|
tmp:=dummy+'../'+d^.d_name + #0;
|
||||||
if (Fpstat(@tmp[1],thisdir)=0) then
|
if (Fpstat(@tmp[1],thisdir)=0) then
|
||||||
begin
|
begin
|
||||||
{ found the entry for this directory name }
|
{ found the entry for this directory name }
|
||||||
@ -123,20 +129,32 @@ begin
|
|||||||
{ then do not set the name. }
|
{ then do not set the name. }
|
||||||
if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
|
if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
|
||||||
((d^.d_name[1]='.') and (d^.d_name[2]=#0))))) then
|
((d^.d_name[1]='.') and (d^.d_name[2]=#0))))) then
|
||||||
name:='/'+strpas(d^.d_name);
|
{ d^.d_name is an array[0..x] of char -> will be assigned the
|
||||||
|
ansi code page on conversion to ansistring -> also typecast
|
||||||
|
'/' to ansistring rather than rawbytestring so code pages match
|
||||||
|
(will be unconditionally set to DefaultFileSystemCodePage at
|
||||||
|
the end without conversion) }
|
||||||
|
thedir:=ansistring('/')+d^.d_name;
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
until (name<>'');
|
until (thedir<>'');
|
||||||
if Fpclosedir(dirstream)<0 then
|
if Fpclosedir(dirstream)<0 then
|
||||||
Exit;
|
Exit;
|
||||||
thedir:=name+thedir;
|
|
||||||
dummy:=dummy+'../';
|
dummy:=dummy+'../';
|
||||||
if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
|
if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
|
||||||
begin
|
begin
|
||||||
if thedir='' then
|
if thedir='' then
|
||||||
dir:='/'
|
dir:='/'
|
||||||
else
|
else
|
||||||
dir:=thedir;
|
begin
|
||||||
|
dir:=thedir;
|
||||||
|
{ try to ensure that "dir" has a refcount of 1, so that setcodepage
|
||||||
|
doesn't have to create a deep copy }
|
||||||
|
thedir:='';
|
||||||
|
end;
|
||||||
|
{ the returned result by the OS is in the DefaultFileSystemCodePage ->
|
||||||
|
no conversion }
|
||||||
|
setcodepage(dir,DefaultFileSystemCodePage,false);
|
||||||
exit;
|
exit;
|
||||||
end;
|
end;
|
||||||
until false;
|
until false;
|
||||||
|
@ -76,7 +76,7 @@ begin
|
|||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
procedure getdir(drivenr : byte;var dir : shortstring);
|
procedure do_getdir(drivenr : byte;var dir : RawByteString);
|
||||||
var
|
var
|
||||||
temp : array[0..255] of char;
|
temp : array[0..255] of char;
|
||||||
i : longint;
|
i : longint;
|
||||||
@ -94,12 +94,14 @@ begin
|
|||||||
Begin
|
Begin
|
||||||
GetInOutRes(lo(regs.realeax));
|
GetInOutRes(lo(regs.realeax));
|
||||||
Dir := char (DriveNr + 64) + ':\';
|
Dir := char (DriveNr + 64) + ':\';
|
||||||
|
SetCodePage(dir,DefaultFileSystemCodePage,false);
|
||||||
exit;
|
exit;
|
||||||
end
|
end
|
||||||
else
|
else
|
||||||
syscopyfromdos(longint(@temp),251);
|
syscopyfromdos(longint(@temp),251);
|
||||||
{ conversion to Pascal string including slash conversion }
|
{ conversion to Pascal string including slash conversion }
|
||||||
i:=0;
|
i:=0;
|
||||||
|
SetLength(Dir,255);
|
||||||
while (temp[i]<>#0) do
|
while (temp[i]<>#0) do
|
||||||
begin
|
begin
|
||||||
if temp[i] in AllowDirectorySeparators then
|
if temp[i] in AllowDirectorySeparators then
|
||||||
@ -109,7 +111,8 @@ begin
|
|||||||
end;
|
end;
|
||||||
dir[2]:=':';
|
dir[2]:=':';
|
||||||
dir[3]:='\';
|
dir[3]:='\';
|
||||||
dir[0]:=char(i+3);
|
SetLength(Dir,i+3);
|
||||||
|
SetCodePage(dir,DefaultFileSystemCodePage,false);
|
||||||
{ upcase the string }
|
{ upcase the string }
|
||||||
if not FileNameCasePreserving then
|
if not FileNameCasePreserving then
|
||||||
dir:=upcase(dir);
|
dir:=upcase(dir);
|
||||||
|
@ -39,10 +39,17 @@ begin
|
|||||||
FileIODevice.DirIO.DoChdir(strpas(s));
|
FileIODevice.DirIO.DoChdir(strpas(s));
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir(DriveNr: byte; var Dir: ShortString);
|
procedure GetDir(DriveNr: byte; var Dir: RawByteString);
|
||||||
|
var
|
||||||
|
TmpDir: ShortString;
|
||||||
begin
|
begin
|
||||||
|
{ TODO: convert callback to use rawbytestring to avoid conversion }
|
||||||
if FileIODevice.DirIO.DoGetdir <> nil then
|
if FileIODevice.DirIO.DoGetdir <> nil then
|
||||||
FileIODevice.DirIO.DoGetdir(DriveNr, Dir);
|
begin
|
||||||
|
FileIODevice.DirIO.DoGetdir(DriveNr, Dir);
|
||||||
|
Dir:=TmpDir;
|
||||||
|
SetCodePage(Dir,DefaultFileSystemCodePage,false);
|
||||||
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
@ -74,38 +74,44 @@ begin
|
|||||||
{$endif WINCE}
|
{$endif WINCE}
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
procedure do_GetDir (DriveNr: byte; var Dir: Unicodestring);
|
||||||
{$ifndef WINCE}
|
{$ifndef WINCE}
|
||||||
var
|
var
|
||||||
Drive:array[0..3]of char;
|
Drive:array[0..3]of char;
|
||||||
defaultdrive:boolean;
|
defaultdrive:boolean;
|
||||||
DirBuf,SaveBuf:array[0..259] of Char;
|
savebuf: UnicodeString;
|
||||||
|
len : integer;
|
||||||
{$endif WINCE}
|
{$endif WINCE}
|
||||||
begin
|
begin
|
||||||
{$ifndef WINCE}
|
{$ifndef WINCE}
|
||||||
defaultdrive:=drivenr=0;
|
defaultdrive:=drivenr=0;
|
||||||
if not defaultdrive then
|
if not defaultdrive then
|
||||||
begin
|
begin
|
||||||
byte(Drive[0]):=Drivenr+64;
|
Drive[0]:=widechar(Drivenr+64);
|
||||||
Drive[1]:=':';
|
Drive[1]:=':';
|
||||||
Drive[2]:=#0;
|
Drive[2]:=#0;
|
||||||
Drive[3]:=#0;
|
Drive[3]:=#0;
|
||||||
GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
|
len:=GetCurrentDirectoryW(0,nil); // in TChar
|
||||||
|
setlength(savebuf,len-1); // -1 because len is #0 inclusive
|
||||||
|
|
||||||
|
GetCurrentDirectoryW(len,punicodechar(SaveBuf)); // in TChar
|
||||||
if not SetCurrentDirectory(@Drive) then
|
if not SetCurrentDirectory(@Drive) then
|
||||||
begin
|
begin
|
||||||
errno := word (GetLastError);
|
errno := word (GetLastError);
|
||||||
Errno2InoutRes;
|
Errno2InoutRes;
|
||||||
Dir := char (DriveNr + 64) + ':\';
|
Dir := widechar (DriveNr + 64) + ':\';
|
||||||
SetCurrentDirectory(@SaveBuf);
|
SetCurrentDirectory(@SaveBuf);
|
||||||
Exit;
|
Exit;
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
|
|
||||||
|
len:=GetCurrentDirectoryW(0,nil);
|
||||||
|
setlength(dir,len-1); // -1 because len is #0 inclusive
|
||||||
|
GetCurrentDirectoryW(len,punicodechar(dir));
|
||||||
if not defaultdrive then
|
if not defaultdrive then
|
||||||
SetCurrentDirectory(@SaveBuf);
|
SetCurrentDirectory(@SaveBuf);
|
||||||
dir:=strpas(DirBuf);
|
|
||||||
if not FileNameCasePreserving then
|
if not FileNameCasePreserving then
|
||||||
dir:=upcase(dir);
|
dir:=upcase(dir);
|
||||||
{$else WINCE}
|
{$else WINCE}
|
||||||
Dir:='\';
|
Dir:='\';
|
||||||
{$endif WINCE}
|
{$endif WINCE}
|
||||||
|
@ -298,9 +298,6 @@ threadvar
|
|||||||
stdcall;external KernelDLL name 'RemoveDirectoryW';
|
stdcall;external KernelDLL name 'RemoveDirectoryW';
|
||||||
function SetCurrentDirectory(name : pointer) : longbool;
|
function SetCurrentDirectory(name : pointer) : longbool;
|
||||||
stdcall;external KernelDLL name 'SetCurrentDirectoryW';
|
stdcall;external KernelDLL name 'SetCurrentDirectoryW';
|
||||||
function GetCurrentDirectory(bufsize : longint;name : punicodechar) : longbool;
|
|
||||||
stdcall;external KernelDLL name 'GetCurrentDirectoryW';
|
|
||||||
|
|
||||||
{$else}
|
{$else}
|
||||||
function GetFileAttributes(p : pchar) : dword;
|
function GetFileAttributes(p : pchar) : dword;
|
||||||
stdcall;external KernelDLL name 'GetFileAttributesA';
|
stdcall;external KernelDLL name 'GetFileAttributesA';
|
||||||
@ -319,10 +316,10 @@ threadvar
|
|||||||
stdcall;external KernelDLL name 'RemoveDirectoryA';
|
stdcall;external KernelDLL name 'RemoveDirectoryA';
|
||||||
function SetCurrentDirectory(name : pointer) : longbool;
|
function SetCurrentDirectory(name : pointer) : longbool;
|
||||||
stdcall;external KernelDLL name 'SetCurrentDirectoryA';
|
stdcall;external KernelDLL name 'SetCurrentDirectoryA';
|
||||||
function GetCurrentDirectory(bufsize : longint;name : pchar) : longbool;
|
|
||||||
stdcall;external KernelDLL name 'GetCurrentDirectoryA';
|
|
||||||
|
|
||||||
{$endif}
|
{$endif}
|
||||||
|
function GetCurrentDirectoryW(bufsize : longint;name : punicodechar) : Dword;
|
||||||
|
stdcall;external KernelDLL name 'GetCurrentDirectoryW';
|
||||||
|
|
||||||
{ Console functions needed for WriteFile fix for bug 17550 }
|
{ Console functions needed for WriteFile fix for bug 17550 }
|
||||||
function GetConsoleMode(hConsoleHandle:thandle; lpMode:LPDWORD):BOOL;
|
function GetConsoleMode(hConsoleHandle:thandle; lpMode:LPDWORD):BOOL;
|
||||||
|
Loading…
Reference in New Issue
Block a user