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

+ added mkdir/chdir/rmdir(rawbytestring) and (unicodestring) to the system unit

Browse Source 
* renamed platform-specific pchar versions of those rouines to do_*() and
    changed them to either rawbytestring or unicodestring depending on the
    FPCRTL_FILESYSTEM_SINGLE_BYTE_API/FPCRTL_FILESYSTEM_TWO_BYTE_API setting
  * implemented generic shortstring versions of those routines on top of either
    rawbytestring or unicodestring depending on the API-kind (in case of the
    embedded target, if ansistring are not supported they will map directly
    to shortstring routines instead)
  * all platform-specific *dir() routines with rawbytestring parameters now
    receive their parameters in DefaultFileSystemCodePage
  - removed no longer required ansistring variants from the objpas unit
  - removed no longer required FPC_SYS_MKDIR etc aliases
  * factored out empty string and inoutres<>0 checks from platform-specific
    *dir() routines to generic ones
  o platform-specific notes:
   o amiga/morphos: check new pathconv(rawbytestring) function
   o macos TODO: convert PathArgToFSSpec (and the routines it calls) to
     rawbytestring
   o nativent: added SysUnicodeStringToNtStr() function
   o wii: convert dirio callbacks to use rawbytestring to avoid conversion
  + test for unicode mk/ch/rm/getdir()

git-svn-id: branches/cpstrrtl@25048 -
This commit is contained in:
Jonas Maebe 2013-07-04 22:28:37 +00:00
parent e26210f448
commit d66d15aad3
25 changed files with 540 additions and 404 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -12031,6 +12031,7 @@ tests/test/units/system/tassert6.pp svneol=native#text/plain
tests/test/units/system/tassert7.pp svneol=native#text/plain
tests/test/units/system/tassignd.pp svneol=native#text/plain
tests/test/units/system/tdir.pp svneol=native#text/plain
tests/test/units/system/tdir2.pp svneol=native#text/plain
tests/test/units/system/testmac.txt svneol=native#text/plain
tests/test/units/system/testpc.txt svneol=native#text/plain
tests/test/units/system/teststk.pp svneol=native#text/plain

42
rtl/amiga/sysdir.inc
View File

@ -3,7 +3,7 @@
Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski
member of the Free Pascal development team.
FPC Pascal system unit for the Win32 API.
FPC Pascal system unit for Amiga.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -18,15 +18,14 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure mkdir(s : pchar; len : sizeuint); [IOCheck, public, alias : 'FPC_SYS_MKDIR'];
procedure do_mkdir(const s : rawbytestring);
var
tmpStr : array[0..255] of char;
tmpStr : rawbytestring;
tmpLock: LongInt;
begin
checkCTRLC;
if (s='') or (InOutRes<>0) then exit;
tmpStr:=PathConv(s)+#0;
tmpLock:=dosCreateDir(@tmpStr);
tmpStr:=PathConv(s);
tmpLock:=dosCreateDir(pchar(tmpStr));
if tmpLock=0 then begin
dosError2InOut(IoErr);
exit;
@ -34,33 +33,35 @@ begin
UnLock(tmpLock);
end;
procedure rmdir(s : pchar; len : sizeuint); [IOCheck, public, alias : 'FPC_SYS_RMDIR'];
procedure do_rmdir(const s : rawbytestring);
var
tmpStr : array[0..255] of Char;
tmpStr : rawbytestring;
begin
checkCTRLC;
if (s='.') then InOutRes:=16;
If (s='') or (InOutRes<>0) then exit;
tmpStr:=PathConv(s)+#0;
if not dosDeleteFile(@tmpStr) then
if (s='.') then
begin
InOutRes:=16;
exit;
end;
tmpStr:=PathConv(s);
if not dosDeleteFile(pchar(tmpStr)) then
dosError2InOut(IoErr);
end;
procedure sys_chdir(s : pchar);
procedure do_ChDir(const s: rawbytestring);
var
tmpStr : array[0..255] of Char;
tmpStr : rawbytestring;
tmpLock: LongInt;
FIB : PFileInfoBlock;
begin
checkCTRLC;
If (s='') or (InOutRes<>0) then exit;
tmpStr:=PathConv(s)+#0;
tmpStr:=PathConv(s);
tmpLock:=0;
{ Changing the directory is a pretty complicated affair }
{ 1) Obtain a lock on the directory }
{ 2) CurrentDir the lock }
tmpLock:=Lock(@tmpStr,SHARED_LOCK);
tmpLock:=Lock(pchar(tmpStr),SHARED_LOCK);
if tmpLock=0 then begin
dosError2InOut(IoErr);
exit;
@ -81,13 +82,6 @@ begin
if assigned(FIB) then dispose(FIB);
end;
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
sys_chdir(s);
end;
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
var tmpbuf: array[0..255] of char;
begin

58
rtl/embedded/sysdir.inc
View File

@ -19,29 +19,49 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure mkdir(s: pchar;len:sizeuint);[IOCheck];
begin
InOutRes:=3;
end;
procedure rmdir(s: pchar;len:sizeuint);[IOCheck];
begin
InOutRes:=3;
end;
procedure chdir(s: pchar;len:sizeuint);[IOCheck];
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}
procedure do_mkdir(const s: rawbytestring);
begin
InOutRes:=3;
end;
procedure do_rmdir(const s: rawbytestring);
begin
InOutRes:=3;
end;
procedure do_chdir(const s: rawbytestring);
begin
InOutRes:=3;
end;
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
begin
InOutRes:=3;
end;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
procedure mkdir(const s: shortstring);
begin
InOutRes:=3;
end;
procedure rmdir(const s: shortstring);
begin
InOutRes:=3;
end;
procedure chdir(const s: shortstring);
begin
InOutRes:=3;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes:=3;
end;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}

66
rtl/emx/sysdir.inc
View File

@ -3,7 +3,7 @@
Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski
member of the Free Pascal development team.
FPC Pascal system unit for the Win32 API.
FPC Pascal system unit for EMX.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -19,7 +19,7 @@
Directory Handling
*****************************************************************************}
procedure DosDir (Func: byte; S: PChar);
procedure DosDir (Func: byte; S: rawbytestring);
begin
DoDirSeparators (S);
@ -33,17 +33,14 @@ begin
end ['eax', 'edx'];
end;
procedure MkDir (S: pchar; Len: SizeUInt); [IOCheck, public, alias: 'FPC_SYS_MKDIR'];
procedure do_MkDir (S: rawbytestring);
var
RC: cardinal;
begin
if not Assigned (S) or (Len = 0) or (InOutRes <> 0) then
Exit;
if os_mode = osOs2 then
begin
DoDirSeparators (S);
RC := DosCreateDir (S, nil);
RC := DosCreateDir (pchar(S), nil);
if RC <> 0 then
begin
InOutRes := RC;
@ -60,49 +57,46 @@ begin
end;
procedure RmDir (S: PChar; Len: SizeUInt); [IOCheck, public, alias: 'FPC_SYS_RMDIR'];
procedure do_RmDir (S: rawbytestring);
var
RC: cardinal;
begin
if Assigned (S) and (Len <> 0) and (InOutRes = 0) then
begin
if (Len = 1) and (S^ = '.') then
InOutRes := 16
else
if os_mode = osOs2 then
if S = '.' then
InOutRes := 16
else
if os_mode = osOs2 then
begin
DoDirSeparators (S);
RC := DosDeleteDir (pchar(S));
if RC <> 0 then
begin
DoDirSeparators (S);
RC := DosDeleteDir (S);
if RC <> 0 then
begin
InOutRes := RC;
Errno2InOutRes;
end;
end
else
{ Under EMX 0.9d DOS this routine call may sometimes fail }
{ The syscall documentation indicates clearly that this }
{ routine was NOT tested. }
DosDir ($3A, S);
end
InOutRes := RC;
Errno2InOutRes;
end;
end
else
{ Under EMX 0.9d DOS this routine call may sometimes fail }
{ The syscall documentation indicates clearly that this }
{ routine was NOT tested. }
DosDir ($3A, S);
end;
{$ASMMODE INTEL}
procedure ChDir (S: PChar; Len: SizeUInt); [IOCheck, public, alias: 'FPC_SYS_CHDIR'];
procedure do_ChDir (S: rawbytestring);
var
RC: cardinal;
Len: longint;
begin
if not Assigned (S) or (Len = 0) or (InOutRes <> 0) then
exit;
(* According to EMX documentation, EMX has only one current directory
for all processes, so we'll use native calls under OS/2. *)
Len := Length (S);
if os_Mode = osOS2 then
begin
if (Len >= 2) and (S [1] = ':') then
if (Len >= 2) and (S [2] = ':') then
begin
RC := DosSetDefaultDisk ((Ord (S^) and not ($20)) - $40);
RC := DosSetDefaultDisk ((Ord (S[1]) and not ($20)) - $40);
if RC <> 0 then
begin
InOutRes := RC;
@ -112,7 +106,7 @@ begin
if Len > 2 then
begin
DoDirSeparators (S);
RC := DosSetCurrentDir (S);
RC := DosSetCurrentDir (pchar(S));
if RC <> 0 then
begin
InOutRes := RC;
@ -123,7 +117,7 @@ begin
else
begin
DoDirSeparators (S);
RC := DosSetCurrentDir (S);
RC := DosSetCurrentDir (pchar(S));
if RC <> 0 then
begin
InOutRes:= RC;
@ -132,7 +126,7 @@ begin
end;
end
else
if (Len >= 2) and (S [1] = ':') then
if (Len >= 2) and (S [2] = ':') then
begin
asm
mov esi, S

6
rtl/gba/sysdir.inc
View File

@ -19,17 +19,17 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure mkdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
procedure do_mkdir(const s: rawbytestring);
begin
end;
procedure rmdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
procedure do_rmdir(const s: rawbytestring);
begin
end;
procedure chdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
procedure do_chdir(const s: rawbytestring);
begin
end;

45
rtl/go32v2/sysdir.inc
View File

@ -3,7 +3,7 @@
Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski
member of the Free Pascal development team.
FPC Pascal system unit for the Win32 API.
FPC Pascal system unit for go32v2.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -18,18 +18,20 @@
Directory Handling
*****************************************************************************}
procedure DosDir(func:byte;s:pchar;len:integer);
procedure DosDir(func:byte;s:rawbytestring);
var
regs : trealregs;
len : longint;
begin
DoDirSeparators(s);
{ True DOS does not like backslashes at end
Win95 DOS accepts this !!
but "\" and "c:\" should still be kept and accepted hopefully PM }
if (len>0) and (s[len-1]='\') and
Not ((len=1) or ((len=3) and (s[1]=':'))) then
s[len-1]:=#0;
syscopytodos(longint(s),len+1);
len:=length(s);
if (len>0) and (s[len]='\') and
Not ((len=1) or ((len=3) and (s[2]=':'))) then
s[len]:=#0;
syscopytodos(longint(pointer(s)),len+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
if LFNSupport then
@ -41,32 +43,31 @@ begin
GetInOutRes(lo(regs.realeax));
end;
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
Procedure do_MkDir(const s: rawbytestring);
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DosDir($39,s,len);
DosDir($39,s);
end;
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
Procedure do_RmDir(const s: rawbytestring);
begin
if (len=1) and (s[0] = '.' ) then
InOutRes := 16;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DosDir($3a,s,len);
if s='.' then
begin
InOutRes := 16;
exit;
end;
DosDir($3a,s);
end;
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
Procedure do_ChDir(const s: rawbytestring);
var
regs : trealregs;
len : longint;
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
len:=length(s);
{ First handle Drive changes }
if (len>=2) and (s[1]=':') then
if (len>=2) and (s[2]=':') then
begin
regs.realedx:=(ord(s[0]) and (not 32))-ord('A');
regs.realedx:=(ord(s[1]) and (not 32))-ord('A');
regs.realeax:=$0e00;
sysrealintr($21,regs);
regs.realeax:=$1900;
@ -82,7 +83,7 @@ begin
exit;
end;
{ do the normal dos chdir }
DosDir($3b,s,len);
DosDir($3b,s);
end;
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);

150
rtl/inc/system.inc
View File

@ -1501,46 +1501,7 @@ end;
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ OS dependent dir functions }
{$i sysdir.inc}
{$endif FPC_HAS_FEATURE_FILEIO}
{$if defined(FPC_HAS_FEATURE_FILEIO)}
Procedure MkDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
MkDir(@buffer[0],length(s));
End;
Procedure RmDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
RmDir(@buffer[0],length(s));
End;
Procedure ChDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
ChDir(@buffer[0],length(s));
End;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
@ -1554,6 +1515,30 @@ begin
end;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Procedure MkDir(Const s: RawByteString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_mkdir(S);
End;
Procedure RmDir(Const s: RawByteString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_rmdir(S);
End;
Procedure ChDir(Const s: RawByteString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_chdir(S);
End;
Procedure getdir(drivenr:byte;Var dir:rawbytestring);
begin
Do_getdir(drivenr,dir);
@ -1562,9 +1547,47 @@ begin
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 }
{ the generic shortstring ones are only implemented elsewhere for systems *not*
supporting ansi/unicodestrings; for now assume there are no systems that
support unicodestrings but not ansistrings }
{ avoid double string conversions }
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
function GetDirStrFromShortstring(const s: shortstring): RawByteString;
begin
GetDirStrFromShortstring:=ToSingleByteFileSystemEncodedFileName(ansistring(s));
end;
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
function GetDirStrFromShortstring(const s: shortstring): UnicodeString;
begin
GetDirStrFromShortstring:=s;
end;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Procedure MkDir(Const s: shortstring);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_mkdir(GetDirStrFromShortstring(S));
End;
Procedure RmDir(Const s: shortstring);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_rmdir(GetDirStrFromShortstring(S));
End;
Procedure ChDir(Const s: shortstring);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_chdir(GetDirStrFromShortstring(S));
End;
Procedure getdir(drivenr:byte;Var dir:shortstring);
var
s: rawbytestring;
@ -1581,6 +1604,26 @@ end;
{$if defined(FPC_HAS_FEATURE_WIDESTRINGS)}
{$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
{ overloads required for mkdir/rmdir/chdir to ensure that the string is
converted to the right code page }
procedure do_mkdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
do_mkdir(ToSingleByteFileSystemEncodedFileName(s));
end;
procedure do_rmdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
do_rmdir(ToSingleByteFileSystemEncodedFileName(s));
end;
procedure do_chdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
do_chdir(ToSingleByteFileSystemEncodedFileName(s));
end;
procedure do_getdir(drivenr : byte;var dir : unicodestring);
var
s: rawbytestring;
@ -1590,6 +1633,29 @@ begin
end;
{$endif FPCRTL_FILESYSTEM_TWO_BYTE_API}
Procedure MkDir(Const s: UnicodeString);[IOCheck];
Begin
if (s='') or (InOutRes <> 0) then
exit;
Do_mkdir(S);
End;
Procedure RmDir(Const s: UnicodeString);[IOCheck];
Begin
if (s='') or (InOutRes <> 0) then
exit;
Do_rmdir(S);
End;
Procedure ChDir(Const s: UnicodeString);[IOCheck];
Begin
if (s='') or (InOutRes <> 0) then
exit;
Do_chdir(S);
End;
Procedure getdir(drivenr:byte;Var dir:unicodestring);
begin

17
rtl/inc/systemh.inc
View File

@ -1178,24 +1178,29 @@ procedure SetTextCodePage(var T: Text; CodePage: TSystemCodePage);
Directory Management
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure chdir(const s:string); overload;
Procedure mkdir(const s:string); overload;
Procedure rmdir(const s:string); overload;
// the pchar versions are exported via alias for use in objpas
Procedure chdir(const s:shortstring); overload;
Procedure mkdir(const s:shortstring); overload;
Procedure rmdir(const s:shortstring); overload;
Procedure getdir(drivenr:byte;var dir:shortstring);overload;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure chdir(const s:rawbytestring); overload;
Procedure mkdir(const s:rawbytestring); overload;
Procedure rmdir(const s:rawbytestring); overload;
// 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 chdir(const s:unicodestring); overload;
Procedure mkdir(const s:unicodestring); overload;
Procedure rmdir(const s:unicodestring); overload;
Procedure getdir(drivenr:byte;var dir: unicodestring);overload;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif FPC_HAS_FEATURE_FILEIO}
{*****************************************************************************
Miscellaneous
*****************************************************************************}

16
rtl/macos/sysdir.inc
View File

@ -18,16 +18,14 @@
Directory Handling
*****************************************************************************}
procedure mkdir(const s:string);[IOCheck];
procedure do_mkdir(const s: rawbytestring);
var
spec: FSSpec;
createdDirID: Longint;
err: OSErr;
res: Integer;
begin
If (s='') or (InOutRes <> 0) then
exit;
{ TODO: convert PathArgToFSSpec (and the routines it calls) to rawbytestring }
res:= PathArgToFSSpec(s, spec);
if (res = 0) or (res = 2) then
begin
@ -38,7 +36,7 @@ begin
InOutRes:=res;
end;
procedure rmdir(const s:string);[IOCheck];
procedure do_rmdir(const s: rawbytestring);
var
spec: FSSpec;
@ -46,9 +44,6 @@ var
res: Integer;
begin
If (s='') or (InOutRes <> 0) then
exit;
res:= PathArgToFSSpec(s, spec);
if (res = 0) then
@ -65,15 +60,12 @@ begin
InOutRes:=res;
end;
procedure chdir(const s:string);[IOCheck];
procedure do_chdir(const s: rawbytestring);
var
spec, newDirSpec: FSSpec;
err: OSErr;
res: Integer;
begin
if (s='') or (InOutRes <> 0) then
exit;
res:= PathArgToFSSpec(s, spec);
if (res = 0) or (res = 2) then
begin

34
rtl/morphos/sysdir.inc
View File

@ -17,15 +17,14 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
Procedure do_MkDir(const s: rawbytestring);
var
tmpStr : array[0..255] of char;
tmpStr : rawbytestring;
tmpLock: LongInt;
begin
checkCTRLC;
if not assigned(s) or (len=0) or (InOutRes<>0) then exit;
tmpStr:=PathConv(strpas(s))+#0;
tmpLock:=dosCreateDir(@tmpStr);
tmpStr:=PathConv(s);
tmpLock:=dosCreateDir(pchar(tmpStr));
if tmpLock=0 then begin
dosError2InOut(IoErr);
exit;
@ -33,34 +32,35 @@ begin
UnLock(tmpLock);
end;
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
Procedure do_RmDir(const s: rawbytestring);
var
tmpStr : array[0..255] of Char;
tmpStr : rawbytestring;
begin
checkCTRLC;
if not assigned(s) or (len=0) then exit;
if (s='.') then InOutRes:=16;
If (s='') or (InOutRes<>0) then exit;
tmpStr:=PathConv(strpas(s))+#0;
if not dosDeleteFile(@tmpStr) then
if (s='.') then
begin
InOutRes:=16;
exit;
end;
tmpStr:=PathConv(s);
if not dosDeleteFile(pchar(tmpStr)) then
dosError2InOut(IoErr);
end;
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
Procedure do_ChDir(const s: rawbytestring);
var
tmpStr : array[0..255] of Char;
tmpStr : rawbytestring;
tmpLock: LongInt;
FIB : PFileInfoBlock;
begin
checkCTRLC;
if not assigned(s) or (len=0) or (InOutRes<>0) then exit;
tmpStr:=PathConv(strpas(s))+#0;
tmpStr:=PathConv(s);
tmpLock:=0;
{ Changing the directory is a pretty complicated affair }
{ 1) Obtain a lock on the directory }
{ 2) CurrentDir the lock }
tmpLock:=Lock(@tmpStr,SHARED_LOCK);
tmpLock:=Lock(pchar(tmpStr),SHARED_LOCK);
if tmpLock=0 then begin
dosError2InOut(IoErr);
exit;

43
rtl/msdos/sysdir.inc
View File

@ -18,19 +18,21 @@
Directory Handling
*****************************************************************************}
procedure DosDir(func:byte;s:pchar;len:integer);
procedure DosDir(func:byte;s: rawbytestring);
var
regs : Registers;
len : Longint;
begin
DoDirSeparators(s);
{ True DOS does not like backslashes at end
Win95 DOS accepts this !!
but "\" and "c:\" should still be kept and accepted hopefully PM }
if (len>0) and (s[len-1]='\') and
Not ((len=1) or ((len=3) and (s[1]=':'))) then
s[len-1]:=#0;
regs.DX:=Ofs(s^);
regs.DS:=Seg(s^);
len:=length(s);
if (len>0) and (s[len]='\') and
Not ((len=1) or ((len=3) and (s[2]=':'))) then
s[len]:=#0;
regs.DX:=Ofs(s[1]);
regs.DS:=Seg(s[1]);
if LFNSupport then
regs.AX:=$7100+func
else
@ -40,32 +42,31 @@ begin
GetInOutRes(regs.AX);
end;
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
Procedure do_MkDir(const s: rawbytestring);
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DosDir($39,s,len);
DosDir($39,s);
end;
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
Procedure do_RmDir(const s: rawbytestring);
begin
if (len=1) and (s[0] = '.' ) then
InOutRes := 16;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DosDir($3a,s,len);
if s='.' then
begin
InOutRes:=16;
exit;
end;
DosDir($3a,s);
end;
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
Procedure do_ChDir(const s: rawbytestring);
var
regs : Registers;
len : Longint;
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
len:=Length(s);
{ First handle Drive changes }
if (len>=2) and (s[1]=':') then
if (len>=2) and (s[2]=':') then
begin
regs.DX:=(ord(s[0]) and (not 32))-ord('A');
regs.DX:=(ord(s[1]) and (not 32))-ord('A');
regs.AX:=$0e00;
MsDos(regs);
regs.AX:=$1900;

29
rtl/nativent/sysdir.inc
View File

@ -17,7 +17,7 @@
Directory Handling
*****************************************************************************}
procedure MkDir(s: pchar; len: sizeuint); [IOCheck, public, alias : 'FPC_SYS_MKDIR'];
procedure do_MkDir(const s: UnicodeString);
var
objattr: TObjectAttributes;
name: TNtUnicodeString;
@ -25,10 +25,7 @@ var
iostatus: TIOStatusBlock;
h: THandle;
begin
if not Assigned(s) or (len <= 1) or (InOutRes <> 0) then
Exit;
SysPCharToNtStr(name, s, len);
SysUnicodeStringToNtStr(name, s);
{ first we try to create a directory object }
SysInitializeObjectAttributes(objattr, @name, OBJ_PERMANENT, 0, Nil);
@ -61,7 +58,7 @@ begin
SysFreeNtStr(name);
end;
procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
procedure do_RmDir(const s: UnicodeString);
var
ntstr: TNtUnicodeString;
objattr: TObjectAttributes;
@ -70,14 +67,18 @@ var
disp: TFileDispositionInformation;
res: LongInt;
begin
if (len = 1) and (s^ = '.') then
InOutRes := 16;
if not assigned(s) or (len = 0) or (InOutRes <> 0) then
Exit;
if (len = 2) and (s[0] = '.') and (s[1] = '.') then
InOutRes := 5;
if s = '.' then
begin
InOutRes := 16;
exit;
end;
if s = '..' then
begin
InOutRes := 5;
exit;
end;
SysPCharToNtStr(ntstr, s, len);
SysUnicodeStringToNtStr(ntstr, s);
SysInitializeObjectAttributes(objattr, @ntstr, 0, 0, Nil);
res := NtOpenDirectoryObject(@h, STANDARD_RIGHTS_REQUIRED, @objattr);
@ -115,7 +116,7 @@ begin
Errno2InoutRes;
end;
procedure ChDir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
procedure do_ChDir(const s: UnicodeString);
begin
{ for now this is not supported }
InOutRes := 3;

9
rtl/nds/sysdir.inc
View File

@ -19,21 +19,18 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure mkdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
procedure do_mkdir(const s: rawbytestring);
begin
if not assigned(s) or (len=0) or (InOutRes<>0) then exit;
end;
procedure rmdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
procedure do_rmdir(const s: rawbytestring);
begin
if not assigned(s) or (len=0) then exit;
end;
procedure chdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
procedure do_chdir(const s: rawbytestring);
begin
if not assigned(s) or (len=0) then exit;
end;

21
rtl/netware/sysdir.inc
View File

@ -17,12 +17,10 @@
Directory Handling
*****************************************************************************}
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
Procedure do_MkDir(s: rawbytestring);
var
Rc : longint;
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DoDirSeparators(s);
Rc := _mkdir(pchar(s));
if Rc <> 0 then
@ -30,13 +28,14 @@ begin
end;
procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
procedure do_RmDir(s: rawbytestring);
var Rc : longint;
begin
if (len=1) and (s^ = '.' ) then
InOutRes := 16;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
if s = '.' then
begin
InOutRes := 16;
exit;
end;
DoDirSeparators(s);
Rc := _rmdir(pchar(s));
if Rc <> 0 then
@ -44,16 +43,16 @@ begin
end;
procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
procedure do_ChDir(s: rawbytestring);
var RC: longint;
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DoDirSeparators(s);
RC := _chdir (pchar(s));
if Rc <> 0 then
SetFileError(Rc);
end;
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
VAR P : ARRAY [0..255] OF CHAR;
i : LONGINT;

11
rtl/netwlibc/sysdir.inc
View File

@ -17,20 +17,20 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
Procedure do_MkDir(const s: rawbytestring);
var Res: LONGINT;
BEGIN
Res := FpMkdir (s,S_IRWXU);
Res := FpMkdir (pchar(s),S_IRWXU);
if Res = 0 then
InOutRes:=0
else
SetFileError (Res);
end;
procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
procedure do_RmDir(const s: rawbytestring);
var Res: longint;
begin
Res := FpRmdir (s);
Res := FpRmdir (pchar(s));
if Res = 0 then
InOutRes:=0
else
@ -38,7 +38,7 @@ begin
end;
procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
procedure do_ChDir(const s: rawbytestring);
var Res: longint;
begin
Res := FpChdir (s);
@ -48,6 +48,7 @@ begin
SetFileError (Res);
end;
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
var P : array [0..255] of CHAR;
i : LONGINT;

33
rtl/objpas/objpas.pp
View File

@ -87,12 +87,6 @@ Var
Function ParamStr(Param : Integer) : Ansistring;
{$endif FPC_HAS_FEATURE_COMMANDARGS}
{$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
Procedure MkDir(s:ansistring);overload;
Procedure RmDir(s:ansistring);overload;
Procedure ChDir(s:ansistring);overload;
{$endif defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
{****************************************************************************
Resource strings.
****************************************************************************}
@ -130,9 +124,6 @@ Var
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure MkDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_MKDIR';
Procedure ChDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_CHDIR';
Procedure RmDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_RMDIR';
{ Untyped file support }
@ -233,30 +224,6 @@ Function ParamStr(Param : Integer) : ansistring;
end;
{$endif FPC_HAS_FEATURE_COMMANDARGS}
{$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
{ xxDirPChar procedures can adjust directory separators in supplied string (at least
Windows implementation does so). Therefore full copy of argument is needed,
just passing by value isn't enough because it won't copy a string literal. }
Procedure MkDir(s:ansistring);[IOCheck];
begin
UniqueString(s);
mkdirpchar(pchar(s),length(s));
end;
Procedure RmDir(s:ansistring);[IOCheck];
begin
UniqueString(s);
RmDirpchar(pchar(s),length(s));
end;
Procedure ChDir(s:ansistring);[IOCheck];
begin
UniqueString(s);
ChDirpchar(pchar(s),length(s));
end;
{$endif defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
{$ifdef FPC_HAS_FEATURE_RESOURCES}
{ ---------------------------------------------------------------------
ResourceString support

33
rtl/os2/sysdir.inc
View File

@ -19,14 +19,12 @@
Directory Handling
*****************************************************************************}
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
Procedure do_MkDir(s: rawbytestring);
var
Rc : word;
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DoDirSeparators(s);
Rc := DosCreateDir(s,nil);
Rc := DosCreateDir(pchar(s),nil);
if Rc <> 0 then
begin
InOutRes := Rc;
@ -34,16 +32,17 @@ begin
end;
end;
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
Procedure do_RmDir(s: rawbytestring);
var
Rc : word;
begin
if (len=1) and (s^ = '.' ) then
InOutRes := 16;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
if s = '.' then
begin
InOutRes := 16;
exit;
end;
DoDirSeparators(s);
Rc := DosDeleteDir(s);
Rc := DosDeleteDir(pchar(s));
if Rc <> 0 then
begin
InOutRes := Rc;
@ -53,23 +52,23 @@ end;
{$ASMMODE INTEL}
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
Procedure do_ChDir(s: rawbytestring);
var RC: cardinal;
Len: Longint;
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
if (Len >= 2) and (S[1] = ':') then
Len := Length (s);
if (Len >= 2) and (S[2] = ':') then
begin
RC := DosSetDefaultDisk ((Ord (S [0]) and not ($20)) - $40);
RC := DosSetDefaultDisk ((Ord (S [1]) and not ($20)) - $40);
if RC <> 0 then
InOutRes := RC
else
if Len > 2 then
begin
DoDirSeparators (s);
RC := DosSetCurrentDir (s);
RC := DosSetCurrentDir (pchar (s));
if RC <> 0 then
begin
InOutRes := RC;
@ -78,7 +77,7 @@ begin
end;
end else begin
DoDirSeparators (s);
RC := DosSetCurrentDir (s);
RC := DosSetCurrentDir (pchar (s));
if RC <> 0 then
begin
InOutRes:= RC;

6
rtl/symbian/sysdir.inc
View File

@ -17,17 +17,17 @@
Directory Handling
*****************************************************************************}
procedure mkdir(const s:string);[IOCHECK];
procedure do_mkdir(const s:rawbytestring);
begin
end;
procedure rmdir(const s:string);[IOCHECK];
procedure do_rmdir(const s:rawbytestring);
begin
end;
procedure chdir(const s:string);[IOCHECK];
procedure do_chdir(const s:rawbytestring);
begin
end;

42
rtl/unix/sysdir.inc
View File

@ -18,7 +18,6 @@
Directory Handling
*****************************************************************************}
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
const
{ read/write search permission for everyone }
MODE_MKDIR = S_IWUSR OR S_IRUSR OR
@ -26,39 +25,32 @@ const
S_IWOTH OR S_IROTH OR
S_IXUSR OR S_IXGRP OR S_IXOTH;
// len is not passed to the *nix functions because the unix API doesn't
// use length safeguards for these functions. (probably because there
// already is a length limit due to PATH_MAX)
Procedure Do_MkDir(s: rawbytestring);
Begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
If Fpmkdir(s, MODE_MKDIR)<0 Then
If Fpmkdir(pchar(s), MODE_MKDIR)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
Begin
if (len=1) and (s^ = '.') then
InOutRes := 16;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
If Fprmdir(s)<0 Then
Procedure Do_RmDir(s: rawbytestring);
begin
if (s='.') then
begin
InOutRes := 16;
exit;
end;
If Fprmdir(pchar(S))<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
Procedure do_ChDir(s: rawbytestring);
Begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
If Fpchdir(s)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
If Fpchdir(pchar(s))<0 Then
Errno2Inoutres;
{ file not exists is path not found under tp7 }
if InOutRes=2 then
InOutRes:=3;

26
rtl/watcom/sysdir.inc
View File

@ -2,11 +2,16 @@
Directory Handling
*****************************************************************************}
procedure DosDir(func:byte;const s:string);
procedure DosDir(func:byte;const s:rawbytestring);
var
buffer : array[0..255] of char;
regs : trealregs;
begin
if length(s)>255 then
begin
inoutres:=3;
exit;
end;
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(pchar(@buffer));
@ -29,30 +34,27 @@ begin
end;
procedure mkdir(const s : string);[IOCheck];
procedure do_mkdir(const s : rawbytestring);
begin
If (s='') or (InOutRes <> 0) then
exit;
DosDir($39,s);
end;
procedure rmdir(const s : string);[IOCheck];
procedure do_rmdir(const s : rawbytestring);
begin
if (s = '.' ) then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
if s = '.' then
begin
InOutRes := 16;
exit;
end;
DosDir($3a,s);
end;
procedure chdir(const s : string);[IOCheck];
procedure do_chdir(const s : rawbytestring);
var
regs : trealregs;
begin
If (s='') or (InOutRes <> 0) then
exit;
{ First handle Drive changes }
if (length(s)>=2) and (s[2]=':') then
begin

20
rtl/wii/sysdir.inc
View File

@ -18,28 +18,28 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure mkdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
procedure do_mkdir(const s: rawbytestring);
begin
if not assigned(s) or (len=0) or (InOutRes<>0) then exit;
{ TODO: convert callback to use rawbytestring to avoid conversion }
if FileIODevice.DirIO.DoMkdir <> nil then
FileIODevice.DirIO.DoMkdir(strpas(s));
FileIODevice.DirIO.DoMkdir(s);
end;
procedure rmdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
procedure do_rmdir(const s: rawbytestring);
begin
if not assigned(s) or (len=0) then exit;
{ TODO: convert callback to use rawbytestring to avoid conversion }
if FileIODevice.DirIO.DoRmdir <> nil then
FileIODevice.DirIO.DoRmdir(strpas(s));
FileIODevice.DirIO.DoRmdir(s);
end;
procedure chdir(s: pchar; len: sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
procedure do_chdir(const s: rawbytestring);
begin
if not assigned(s) or (len=0) then exit;
{ TODO: convert callback to use rawbytestring to avoid conversion }
if FileIODevice.DirIO.DoChdir <> nil then
FileIODevice.DirIO.DoChdir(strpas(s));
FileIODevice.DirIO.DoChdir(pchar(s));
end;
procedure GetDir(DriveNr: byte; var Dir: RawByteString);
procedure do_GetDir(DriveNr: byte; var Dir: RawByteString);
var
TmpDir: ShortString;
begin

53
rtl/win/sysdir.inc
View File

@ -20,53 +20,50 @@
type
TDirFnType=function(name:pointer):longbool;stdcall;
procedure dirfn(afunc : TDirFnType;s:pchar;len:integer);
function CreateDirectoryTrunc(name:pointer):longbool;stdcall;
begin
CreateDirectoryTrunc:=CreateDirectoryW(name,nil);
end;
procedure dirfn(afunc : TDirFnType;s:unicodestring);
begin
DoDirSeparators(s);
if not aFunc(s) then
if not aFunc(punicodechar(s)) then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function CreateDirectoryTrunc(name:pointer):longbool;stdcall;
Procedure do_MkDir(const s: UnicodeString);
begin
CreateDirectoryTrunc:=CreateDirectory(name,nil);
dirfn(TDirFnType(@CreateDirectoryTrunc),s);
end;
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
Procedure do_RmDir(const s: UnicodeString);
begin
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@CreateDirectoryTrunc),s,len);
end;
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
begin
if (len=1) and (s^ ='.') then
InOutRes := 16;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
{$ifdef WINCE}
if (len=2) and (s[0]='.') and (s[1]='.') then
InOutRes := 5;
{$endif WINCE}
dirfn(TDirFnType(@RemoveDirectory),s,len);
if (s ='.') then
begin
InOutRes := 16;
exit;
end;
{$ifdef WINCE}
if (s='..') then
begin
InOutRes := 5;
exit;
end;
{$endif WINCE}
dirfn(TDirFnType(@RemoveDirectoryW),s);
{$ifdef WINCE}
if (Inoutres=3) and (Pos(DirectorySeparator, s)<2) then
Inoutres:=2;
{$endif WINCE}
end;
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
Procedure do_ChDir(const s: UnicodeString);
begin
{$ifndef WINCE}
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@SetCurrentDirectory),s,len);
dirfn(TDirFnType(@SetCurrentDirectoryW),s);
if Inoutres=2 then
Inoutres:=3;
{$else WINCE}

19
rtl/win/sysos.inc
View File

@ -291,13 +291,6 @@ threadvar
lpSecurityAttributes:PSECURITYATTRIBUTES; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):THandle;
stdcall;external KernelDLL name 'CreateFileW';
{ Directory }
function CreateDirectory(name : pointer;sec : pointer) : longbool;
stdcall;external KernelDLL name 'CreateDirectoryW';
function RemoveDirectory(name:pointer):longbool;
stdcall;external KernelDLL name 'RemoveDirectoryW';
function SetCurrentDirectory(name : pointer) : longbool;
stdcall;external KernelDLL name 'SetCurrentDirectoryW';
{$else}
function GetFileAttributes(p : pchar) : dword;
stdcall;external KernelDLL name 'GetFileAttributesA';
@ -309,16 +302,12 @@ threadvar
lpSecurityAttributes:PSECURITYATTRIBUTES; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):THandle;
stdcall;external KernelDLL name 'CreateFileA';
{ Directory }
function CreateDirectory(name : pointer;sec : pointer) : longbool;
stdcall;external KernelDLL name 'CreateDirectoryA';
function RemoveDirectory(name:pointer):longbool;
stdcall;external KernelDLL name 'RemoveDirectoryA';
function SetCurrentDirectory(name : pointer) : longbool;
stdcall;external KernelDLL name 'SetCurrentDirectoryA';
{$endif}
{ Directory }
function CreateDirectoryW(name : pointer;sec : pointer) : longbool;
stdcall;external KernelDLL name 'CreateDirectoryW';
function RemoveDirectoryW(name:pointer):longbool;
stdcall;external KernelDLL name 'RemoveDirectoryW';
function SetCurrentDirectoryW(name : pointer) : longbool;
stdcall;external KernelDLL name 'SetCurrentDirectoryW';
function GetCurrentDirectoryW(bufsize : longint;name : punicodechar) : Dword;

29
rtl/wince/system.pp
View File

@ -94,9 +94,6 @@ function CreateFile(lpFileName:pchar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:pointer; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint;
function CreateDirectory(name : pointer;sec : pointer) : longbool;
function RemoveDirectory(name:pointer):longbool;
{$ifdef CPUARM}
{ the external directive isn't really necessary here because it is overridden by external (FK) }
@ -206,6 +203,12 @@ var
function MessageBox(w1:longint;l1,l2:PWideChar;w2:longint):longint;
cdecl; external 'coredll' name 'MessageBoxW';
function CreateDirectoryW(name : pwidechar;sec : pointer) : longbool;
cdecl; external KernelDLL name 'CreateDirectoryW';
function RemoveDirectoryW(name:pwidechar):longbool;
cdecl; external KernelDLL name 'RemoveDirectoryW';
{*****************************************************************************}
{$define FPC_SYSTEM_HAS_MOVE}
@ -424,10 +427,6 @@ function CreateFileW(lpFileName:pwidechar; dwDesiredAccess:DWORD; dwShareMode:DW
lpSecurityAttributes:pointer; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint;
cdecl; external KernelDLL name 'CreateFileW';
function CreateDirectoryW(name : pwidechar;sec : pointer) : longbool;
cdecl; external KernelDLL name 'CreateDirectoryW';
function RemoveDirectoryW(name:pwidechar):longbool;
cdecl; external KernelDLL name 'RemoveDirectoryW';
function GetFileAttributes(p : pchar) : dword;
var
@ -465,22 +464,6 @@ begin
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile);
end;
function CreateDirectory(name : pointer;sec : pointer) : longbool;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(name, -1, buf, SizeOf(buf));
CreateDirectory := CreateDirectoryW(buf, sec);
end;
function RemoveDirectory(name:pointer):longbool;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(name, -1, buf, SizeOf(buf));
RemoveDirectory := RemoveDirectoryW(buf);
end;
const
{$ifdef CPUARM}
UserKData = $FFFFC800;

135
tests/test/units/system/tdir2.pp Normal file
View File

@ -0,0 +1,135 @@
{ Program to test OS-specific features of the system unit }
{ routines to test: }
{ mkdir() }
{ chdir() }
{ rmdir() }
{ getdir() }
{ This program tests support for non-ASCII chaaracters in }
{ path names }
{ %target=win32,win64,darwin,freebsd,openbsd,netbsd,linux,morphos,haiku,aix,nativent }
Program tdir;
{$codepage utf-8}
{$I-}
{$ifdef unix}
uses
cwstring;
{$endif}
procedure test(value, required: longint);
begin
if value <> required then
begin
writeln('Got ',value,' instead of ',required);
halt(1);
end;
end;
procedure testansi;
const
dirname: utf8string = '鿆®';
var
orgdir, newdir: rawbytestring;
Begin
Writeln('rawbytestring tests');
Write('Getting current directory...');
getdir(0,orgdir);
test(IOResult,0);
WriteLn('Passed');
Write('creating new directory...');
mkdir(dirname);
test(IOResult,0);
WriteLn('Passed');
Write('changing to new directory...');
chdir(dirname);
test(IOResult, 0);
WriteLn('Passed!');
Write('Getting current directory again...');
getdir(0,newdir);
test(IOResult,0);
WriteLn('Passed');
Write('Checking whether the current directories are properly relative to each other...');
if newdir[length(newdir)]=DirectorySeparator then
setlength(newdir,length(newdir)-1);
setcodepage(newdir,CP_UTF8);
if copy(newdir,1,length(orgdir))<>orgdir then
test(0,1);
if copy(newdir,length(newdir)-length(dirname)+1,length(dirname))<>dirname then
test(2,3);
Writeln('Passed');
Write('going directory up ...');
chdir('..');
test(IOResult, 0);
WriteLn('Passed!');
Write('removing directory ...');
rmdir(dirname);
test(IOResult, 0);
WriteLn('Passed!');
end;
procedure testuni;
const
dirname: unicodestring = '鿆®';
var
orgdir, newdir: unicodestring;
Begin
Writeln('unicodestring tests');
Write('Getting current directory...');
getdir(0,orgdir);
test(IOResult,0);
WriteLn('Passed');
Write('creating new directory...');
mkdir(dirname);
test(IOResult,0);
WriteLn('Passed');
Write('changing to new directory...');
chdir(dirname);
test(IOResult, 0);
WriteLn('Passed!');
Write('Getting current directory again...');
getdir(0,newdir);
test(IOResult,0);
WriteLn('Passed');
Write('Checking whether the current directories are properly relative to each other...');
if newdir[length(newdir)]=DirectorySeparator then
setlength(newdir,length(newdir)-1);
if copy(newdir,1,length(orgdir))<>orgdir then
test(0,1);
if copy(newdir,length(newdir)-length(dirname)+1,length(dirname))<>dirname then
test(2,3);
Writeln('Passed');
Write('going directory up ...');
chdir('..');
test(IOResult, 0);
WriteLn('Passed!');
Write('removing directory ...');
rmdir(dirname);
test(IOResult, 0);
WriteLn('Passed!');
end;
begin
{ ensure that we get into trouble if at one point defaultsystemcodepage is used }
SetMultiByteConversionCodePage(CP_ASCII);
{ this test only works in its current form on systems that either use a two byte file system OS API, or whose 1-byte API supports UTF-8 }
SetMultiByteFileSystemCodePage(CP_UTF8);
SetMultiByteRTLFileSystemCodePage(CP_UTF8);
testansi;
testuni;
end.