paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-08 09:28:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

* changed getdir(ansistring):ansistring to

Browse Source 
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:
Jonas Maebe 2013-06-27 21:37:47 +00:00
parent 679785f90c
commit 62ee16278b
21 changed files with 179 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
rtl/amiga/sysdir.inc
View File

@ -88,7 +88,7 @@ begin
sys_chdir(s);
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
var tmpbuf: array[0..255] of char;
begin
checkCTRLC;
@ -97,5 +97,8 @@ begin
if not GetCurrentDirName(tmpbuf,256) then
dosError2InOut(IoErr)
else
Dir:=strpas(tmpbuf);
begin
Dir:=tmpbuf;
SetCodePage(Dir,DefaultFileSystemCodePage,false);
end;
end;

4
rtl/embedded/sysdir.inc
View File

@ -34,7 +34,11 @@ begin
InOutRes:=3;
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);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
begin
InOutRes:=3;
end;

9
rtl/emx/sysdir.inc
View File

@ -163,7 +163,7 @@ end;
{$ASMMODE ATT}
procedure GetDir (DriveNr: byte; var Dir: ShortString);
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
{Written by Michael Van Canneyt.}
@ -171,6 +171,7 @@ var sof:Pchar;
i:byte;
begin
SetLength(Dir,260);
Dir [4] := #0;
{ Used in case the specified drive isn't available }
sof:=pchar(@dir[4]);
@ -189,7 +190,6 @@ begin
end [ 'eax','edx','esi'];
{ Now Dir should be filled with directory in ASCIIZ, }
{ starting from dir[4] }
dir[0]:=#3;
dir[2]:=':';
dir[3]:='\';
i:=4;
@ -199,10 +199,9 @@ begin
{ convert path name to DOS }
if dir[i] in AllowDirectorySeparators then
dir[i]:=DirectorySeparator;
dir[0]:=char(i);
inc(i);
end;
{ upcase the string (FPC function) }
SetLength(dir,i-1);
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=chr(64+drivenr)
else
@ -217,5 +216,7 @@ begin
end ['eax'];
dir[1]:=char(i);
end;
SetCodePage(dir,DefaultFileSystemCodePage,false);
{ upcase the string (FPC function) }
if not (FileNameCasePreserving) then dir:=upcase(dir);
end;

2
rtl/gba/sysdir.inc
View File

@ -34,7 +34,7 @@ begin
end;
procedure GetDir(DriveNr: byte; var Dir: ShortString);
procedure do_GetDir(DriveNr: byte; var Dir: RawByteString);
begin
end;

7
rtl/go32v2/sysdir.inc
View File

@ -85,7 +85,7 @@ begin
DosDir($3b,s,len);
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
var
temp : array[0..255] of char;
i : longint;
@ -103,12 +103,14 @@ begin
Begin
GetInOutRes (lo(regs.realeax));
Dir := char (DriveNr + 64) + ':\';
SetCodePage (Dir,DefaultFileSystemCodePage,false);
exit;
end
else
syscopyfromdos(longint(@temp),251);
{ conversion to Pascal string including slash conversion }
i:=0;
SetLength(dir,260);
while (temp[i]<>#0) do
begin
if temp[i] in AllowDirectorySeparators then
@ -118,7 +120,8 @@ begin
end;
dir[2]:=':';
dir[3]:='\';
dir[0]:=char(i+3);
SetLength(dir,i+3);
SetCodePage(dir,DefaultFileSystemCodePage,false);
{ upcase the string }
if not FileNameCasePreserving then
dir:=upcase(dir);

75
rtl/inc/system.inc
View File

@ -1503,20 +1503,12 @@ end;
{$i sysdir.inc}
{$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)}
Procedure MkDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
@ -1549,7 +1541,64 @@ Begin
Buffer[Length(s)] := #0;
ChDir(@buffer[0],length(s));
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

9
rtl/inc/systemh.inc
View File

@ -1185,10 +1185,15 @@ Procedure mkdir(const s:string); overload;
Procedure rmdir(const s:string); overload;
// 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}
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}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure getdir(drivenr:byte;var dir: unicodestring);overload;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif FPC_HAS_FEATURE_FILEIO}
{*****************************************************************************

12
rtl/macos/sysdir.inc
View File

@ -98,22 +98,16 @@ begin
InOutRes:=res;
end;
procedure getDir (DriveNr: byte; var Dir: ShortString);
procedure do_getDir (DriveNr: byte; var Dir: RawByteString);
var
fullPath: AnsiString;
pathHandleSize: Longint;
begin
if FSpGetFullPath(workingDirectorySpec, fullPath, false) <> noErr then
if FSpGetFullPath(workingDirectorySpec, Dir, false) <> noErr then
Halt(3); {exit code 3 according to MPW}
if Length(fullPath) <= 255 then {because dir is ShortString}
InOutRes := 0
else
InOutRes := 1; //TODO Exchange to something better
dir:= fullPath;
SetCodePage(Dir,DefaultFileSystemCodePage,false);
end;

7
rtl/morphos/sysdir.inc
View File

@ -83,7 +83,7 @@ begin
if assigned(FIB) then dispose(FIB);
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
var tmpbuf: array[0..255] of char;
begin
checkCTRLC;
@ -91,5 +91,8 @@ begin
if not GetCurrentDirName(tmpbuf,256) then
dosError2InOut(IoErr)
else
Dir:=strpas(tmpbuf);
begin
Dir:=tmpbuf;
SetCodePage(Dir,DefaultFileSystemCodePage,false);
end;
end;

7
rtl/msdos/sysdir.inc
View File

@ -84,7 +84,7 @@ begin
DosDir($3b,s,len);
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
procedure GetDir (DriveNr: byte; var Dir: RawByteString);
var
temp : array[0..260] of char;
i : longint;
@ -102,12 +102,14 @@ begin
Begin
GetInOutRes (regs.AX);
Dir := char (DriveNr + 64) + ':\';
SetCodePage (Dir,DefaultFileSystemCodePage,false);
exit;
end
else
temp[252] := #0; { to avoid shortstring buffer overflow }
{ conversion to Pascal string including slash conversion }
i:=0;
SetLength(dir,260);
while (temp[i]<>#0) do
begin
if temp[i] in AllowDirectorySeparators then
@ -117,7 +119,8 @@ begin
end;
dir[2]:=':';
dir[3]:='\';
dir[0]:=char(i+3);
SetLength(dir,i+3);
SetCodePage (dir,DefaultFileSystemCodePage,false);
{ upcase the string }
if not FileNameCasePreserving then
dir:=upcase(dir);

2
rtl/nativent/sysdir.inc
View File

@ -121,7 +121,7 @@ begin
InOutRes := 3;
end;
procedure GetDir(DriveNr: byte; var Dir: ShortString);
procedure do_GetDir(DriveNr: byte; var Dir: UnicodeString);
begin
{ for now we return simply the root directory }
Dir := DirectorySeparator;

2
rtl/nds/sysdir.inc
View File

@ -37,7 +37,7 @@ begin
end;
procedure GetDir(DriveNr: byte; var Dir: ShortString);
procedure do_GetDir(DriveNr: byte; var Dir: RawByteString);
begin
end;

5
rtl/netware/sysdir.inc
View File

@ -54,7 +54,7 @@ begin
SetFileError(Rc);
end;
procedure getdir(drivenr : byte;var dir : shortstring);
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
VAR P : ARRAY [0..255] OF CHAR;
i : LONGINT;
begin
@ -63,8 +63,8 @@ begin
i := _strlen (P);
if i > 0 then
begin
SetLength (dir, i);
Move (P, dir[1], i);
BYTE(dir[0]) := i;
DoDirSeparators(dir);
// fix / after volume, the compiler needs that
// normaly root of a volumes is SERVERNAME/SYS:, change that
@ -73,6 +73,7 @@ begin
if (i > 0) then
if i = Length (dir) then dir := dir + '/' else
if dir [i+1] <> '/' then insert ('/',dir,i+1);
SetCodePage (dir,DefaultFileSystemCodePage,false);
END ELSE
InOutRes := 1;
end;

5
rtl/netwlibc/sysdir.inc
View File

@ -48,7 +48,7 @@ begin
SetFileError (Res);
end;
procedure getdir(drivenr : byte;var dir : shortstring);
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
var P : array [0..255] of CHAR;
i : LONGINT;
begin
@ -57,8 +57,8 @@ begin
i := libc_strlen (P);
if i > 0 then
begin
SetLength (dir, i);
Move (P, dir[1], i);
BYTE(dir[0]) := i;
DoDirSeparators(dir);
// fix / after volume, the compiler needs that
// normaly root of a volumes is SERVERNAME/SYS:, change that
@ -67,6 +67,7 @@ begin
if (i > 0) then
if i = Length (dir) then dir := dir + '/' else
if dir [i+1] <> '/' then insert ('/',dir,i+1);
SetCodePage (dir,DefaultFileSystemCodePage,false);
end else
InOutRes := 1;
end;

9
rtl/os2/sysdir.inc
View File

@ -89,12 +89,13 @@ end;
{$ASMMODE ATT}
procedure GetDir (DriveNr: byte; var Dir: ShortString);
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
{Written by Michael Van Canneyt.}
var sof: Pchar;
i:byte;
l,l2:cardinal;
begin
setlength(Dir,255);
Dir [4] := #0;
{ Used in case the specified drive isn't available }
sof:=pchar(@dir[4]);
@ -102,12 +103,13 @@ begin
{ supplied by DOS, so we let dos string start at }
{ dir[4] }
{ 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;
InOutRes:=longint (DosQueryCurrentDir(DriveNr, sof^, l));
{$WARNING Result code should be translated in some cases!}
{ Now Dir should be filled with directory in ASCIIZ, }
{ starting from dir[4] }
dir[0]:=#3;
dir[2]:=':';
dir[3]:='\';
i:=4;
@ -117,9 +119,9 @@ begin
{ convert path name to DOS }
if dir[i] in AllowDirectorySeparators then
dir[i]:=DirectorySeparator;
dir[0]:=char(i);
inc(i);
end;
setlength(dir,i-1);
{ upcase the string (FPC function) }
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=chr(64+drivenr)
@ -130,6 +132,7 @@ begin
DosQueryCurrentDisk(l, l2);
dir[1]:=chr(64+l);
end;
SetCodePage(dir,DefaultFileSystemCodePage,false);
if not (FileNameCasePreserving) then dir:=upcase(dir);
end;

2
rtl/symbian/sysdir.inc
View File

@ -32,7 +32,7 @@ begin
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
begin
end;

44
rtl/unix/sysdir.inc
View File

@ -70,26 +70,32 @@ End;
// !! In the libc versions, the alt code is already integrated in the libc code.
// !! Also significantly boosted buffersize. This will make failure of the
// !! 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
buf : array[0..2047] of char;
{$ifndef FPC_USE_LIBC}
cwdinfo : stat;
rootinfo : stat;
thedir,dummy : string[255];
thedir,dummy : rawbytestring;
dirstream : pdir;
d : pdirent;
name : string[255];
thisdir : stat;
tmp : string[255];
tmp : rawbytestring;
{$endif FPC_USE_LIBC}
begin
dir:='';
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}
else
begin
thedir:='';
dummy:='';
{ get root directory information }
@ -108,12 +114,12 @@ begin
if dirstream=nil then
exit;
repeat
name:='';
thedir:='';
d:=Fpreaddir(dirstream);
{ no more entries to read ... }
if not assigned(d) then
break;
tmp:=dummy+'../'+strpas(d^.d_name) + #0;
tmp:=dummy+'../'+d^.d_name + #0;
if (Fpstat(@tmp[1],thisdir)=0) then
begin
{ found the entry for this directory name }
@ -123,20 +129,32 @@ begin
{ then do not set the name. }
if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
((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;
until (name<>'');
until (thedir<>'');
if Fpclosedir(dirstream)<0 then
Exit;
thedir:=name+thedir;
dummy:=dummy+'../';
if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
begin
if thedir='' then
dir:='/'
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;
end;
until false;

7
rtl/watcom/sysdir.inc
View File

@ -76,7 +76,7 @@ begin
end;
procedure getdir(drivenr : byte;var dir : shortstring);
procedure do_getdir(drivenr : byte;var dir : RawByteString);
var
temp : array[0..255] of char;
i : longint;
@ -94,12 +94,14 @@ begin
Begin
GetInOutRes(lo(regs.realeax));
Dir := char (DriveNr + 64) + ':\';
SetCodePage(dir,DefaultFileSystemCodePage,false);
exit;
end
else
syscopyfromdos(longint(@temp),251);
{ conversion to Pascal string including slash conversion }
i:=0;
SetLength(Dir,255);
while (temp[i]<>#0) do
begin
if temp[i] in AllowDirectorySeparators then
@ -109,7 +111,8 @@ begin
end;
dir[2]:=':';
dir[3]:='\';
dir[0]:=char(i+3);
SetLength(Dir,i+3);
SetCodePage(dir,DefaultFileSystemCodePage,false);
{ upcase the string }
if not FileNameCasePreserving then
dir:=upcase(dir);

11
rtl/wii/sysdir.inc
View File

@ -39,10 +39,17 @@ begin
FileIODevice.DirIO.DoChdir(strpas(s));
end;
procedure GetDir(DriveNr: byte; var Dir: ShortString);
procedure GetDir(DriveNr: byte; var Dir: RawByteString);
var
TmpDir: ShortString;
begin
{ TODO: convert callback to use rawbytestring to avoid conversion }
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;

24
rtl/win/sysdir.inc
View File

@ -74,38 +74,44 @@ begin
{$endif WINCE}
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
procedure do_GetDir (DriveNr: byte; var Dir: Unicodestring);
{$ifndef WINCE}
var
Drive:array[0..3]of char;
defaultdrive:boolean;
DirBuf,SaveBuf:array[0..259] of Char;
savebuf: UnicodeString;
len : integer;
{$endif WINCE}
begin
{$ifndef WINCE}
defaultdrive:=drivenr=0;
if not defaultdrive then
begin
byte(Drive[0]):=Drivenr+64;
Drive[0]:=widechar(Drivenr+64);
Drive[1]:=':';
Drive[2]:=#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
begin
errno := word (GetLastError);
Errno2InoutRes;
Dir := char (DriveNr + 64) + ':\';
Dir := widechar (DriveNr + 64) + ':\';
SetCurrentDirectory(@SaveBuf);
Exit;
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
SetCurrentDirectory(@SaveBuf);
dir:=strpas(DirBuf);
SetCurrentDirectory(@SaveBuf);
if not FileNameCasePreserving then
dir:=upcase(dir);
dir:=upcase(dir);
{$else WINCE}
Dir:='\';
{$endif WINCE}

7
rtl/win/sysos.inc
View File

@ -298,9 +298,6 @@ threadvar
stdcall;external KernelDLL name 'RemoveDirectoryW';
function SetCurrentDirectory(name : pointer) : longbool;
stdcall;external KernelDLL name 'SetCurrentDirectoryW';
function GetCurrentDirectory(bufsize : longint;name : punicodechar) : longbool;
stdcall;external KernelDLL name 'GetCurrentDirectoryW';
{$else}
function GetFileAttributes(p : pchar) : dword;
stdcall;external KernelDLL name 'GetFileAttributesA';
@ -319,10 +316,10 @@ threadvar
stdcall;external KernelDLL name 'RemoveDirectoryA';
function SetCurrentDirectory(name : pointer) : longbool;
stdcall;external KernelDLL name 'SetCurrentDirectoryA';
function GetCurrentDirectory(bufsize : longint;name : pchar) : longbool;
stdcall;external KernelDLL name 'GetCurrentDirectoryA';
{$endif}
function GetCurrentDirectoryW(bufsize : longint;name : punicodechar) : Dword;
stdcall;external KernelDLL name 'GetCurrentDirectoryW';
{ Console functions needed for WriteFile fix for bug 17550 }
function GetConsoleMode(hConsoleHandle:thandle; lpMode:LPDWORD):BOOL;