diff options
author | jonas <jonas@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2013-07-04 22:28:37 +0000 |
---|---|---|
committer | jonas <jonas@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2013-07-04 22:28:37 +0000 |
commit | 703e176f36dc415eeb013f3b84c7265f878c455b (patch) | |
tree | a1524954d423971421170267686271c8c40fad18 | |
parent | 91e95a1a064b68fb6bd765e325ee979ea1d6b1d0 (diff) | |
download | fpc-703e176f36dc415eeb013f3b84c7265f878c455b.tar.gz |
+ added mkdir/chdir/rmdir(rawbytestring) and (unicodestring) to the system unit
* 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: http://svn.freepascal.org/svn/fpc/branches/cpstrrtl@25048 3ad0048d-3df7-0310-abae-a5850022a9f2
-rw-r--r-- | rtl/amiga/sysdir.inc | 42 | ||||
-rw-r--r-- | rtl/embedded/sysdir.inc | 30 | ||||
-rw-r--r-- | rtl/emx/sysdir.inc | 66 | ||||
-rw-r--r-- | rtl/gba/sysdir.inc | 6 | ||||
-rw-r--r-- | rtl/go32v2/sysdir.inc | 45 | ||||
-rw-r--r-- | rtl/inc/system.inc | 138 | ||||
-rw-r--r-- | rtl/inc/systemh.inc | 17 | ||||
-rw-r--r-- | rtl/macos/sysdir.inc | 16 | ||||
-rw-r--r-- | rtl/morphos/sysdir.inc | 34 | ||||
-rw-r--r-- | rtl/msdos/sysdir.inc | 43 | ||||
-rw-r--r-- | rtl/nativent/sysdir.inc | 29 | ||||
-rw-r--r-- | rtl/nds/sysdir.inc | 9 | ||||
-rw-r--r-- | rtl/netware/sysdir.inc | 21 | ||||
-rw-r--r-- | rtl/netwlibc/sysdir.inc | 11 | ||||
-rw-r--r-- | rtl/objpas/objpas.pp | 33 | ||||
-rw-r--r-- | rtl/os2/sysdir.inc | 33 | ||||
-rw-r--r-- | rtl/symbian/sysdir.inc | 6 | ||||
-rw-r--r-- | rtl/unix/sysdir.inc | 42 | ||||
-rw-r--r-- | rtl/watcom/sysdir.inc | 26 | ||||
-rw-r--r-- | rtl/wii/sysdir.inc | 20 | ||||
-rw-r--r-- | rtl/win/sysdir.inc | 53 | ||||
-rw-r--r-- | rtl/win/sysos.inc | 19 | ||||
-rw-r--r-- | rtl/wince/system.pp | 29 | ||||
-rw-r--r-- | tests/test/units/system/tdir2.pp | 135 |
24 files changed, 519 insertions, 384 deletions
diff --git a/rtl/amiga/sysdir.inc b/rtl/amiga/sysdir.inc index 8f0c23b5d8..afe85788c1 100644 --- a/rtl/amiga/sysdir.inc +++ b/rtl/amiga/sysdir.inc @@ -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 diff --git a/rtl/embedded/sysdir.inc b/rtl/embedded/sysdir.inc index d09d914e2d..e4f62b37ea 100644 --- a/rtl/embedded/sysdir.inc +++ b/rtl/embedded/sysdir.inc @@ -19,29 +19,49 @@ {***************************************************************************** Directory Handling *****************************************************************************} -procedure mkdir(s: pchar;len:sizeuint);[IOCheck]; +{$if defined(FPC_HAS_FEATURE_ANSISTRINGS)} +procedure do_mkdir(const s: rawbytestring); begin InOutRes:=3; end; -procedure rmdir(s: pchar;len:sizeuint);[IOCheck]; +procedure do_rmdir(const s: rawbytestring); begin InOutRes:=3; end; -procedure chdir(s: pchar;len:sizeuint);[IOCheck]; +procedure do_chdir(const s: rawbytestring); begin InOutRes:=3; end; -{$if defined(FPC_HAS_FEATURE_ANSISTRINGS)} 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); -{$endif FPC_HAS_FEATURE_ANSISTRINGS} begin InOutRes:=3; end; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} diff --git a/rtl/emx/sysdir.inc b/rtl/emx/sysdir.inc index 5aeba91021..901bc85742 100644 --- a/rtl/emx/sysdir.inc +++ b/rtl/emx/sysdir.inc @@ -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 diff --git a/rtl/gba/sysdir.inc b/rtl/gba/sysdir.inc index 39314f61d7..c454e5b1fc 100644 --- a/rtl/gba/sysdir.inc +++ b/rtl/gba/sysdir.inc @@ -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; diff --git a/rtl/go32v2/sysdir.inc b/rtl/go32v2/sysdir.inc index 134eaa5a68..6137de042d 100644 --- a/rtl/go32v2/sysdir.inc +++ b/rtl/go32v2/sysdir.inc @@ -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); diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc index 12ef258aa4..19b57a9966 100644 --- a/rtl/inc/system.inc +++ b/rtl/inc/system.inc @@ -1501,58 +1501,43 @@ end; {$ifdef FPC_HAS_FEATURE_FILEIO} { OS dependent dir functions } {$i sysdir.inc} -{$endif FPC_HAS_FEATURE_FILEIO} - -{$if defined(FPC_HAS_FEATURE_FILEIO)} - +{$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 MkDir(Const s: String); -Var - Buffer: Array[0..255] of Char; +Procedure MkDir(Const s: RawByteString);[IOCheck]; Begin If (s='') or (InOutRes <> 0) then exit; - Move(s[1], Buffer, Length(s)); - Buffer[Length(s)] := #0; - MkDir(@buffer[0],length(s)); + Do_mkdir(S); End; -Procedure RmDir(Const s: String); -Var - Buffer: Array[0..255] of Char; + +Procedure RmDir(Const s: RawByteString);[IOCheck]; Begin If (s='') or (InOutRes <> 0) then exit; - Move(s[1], Buffer, Length(s)); - Buffer[Length(s)] := #0; - RmDir(@buffer[0],length(s)); + Do_rmdir(S); End; -Procedure ChDir(Const s: String); -Var - Buffer: Array[0..255] of Char; + +Procedure ChDir(Const s: RawByteString);[IOCheck]; Begin If (s='') or (InOutRes <> 0) then exit; - Move(s[1], Buffer, Length(s)); - Buffer[Length(s)] := #0; - ChDir(@buffer[0],length(s)); + Do_chdir(S); End; -{$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 @@ -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 diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc index 847d6d3666..f1b5674ddd 100644 --- a/rtl/inc/systemh.inc +++ b/rtl/inc/systemh.inc @@ -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 *****************************************************************************} diff --git a/rtl/macos/sysdir.inc b/rtl/macos/sysdir.inc index 42c5226c9f..cd68dff8cc 100644 --- a/rtl/macos/sysdir.inc +++ b/rtl/macos/sysdir.inc @@ -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 diff --git a/rtl/morphos/sysdir.inc b/rtl/morphos/sysdir.inc index 1d1555c197..11f9d2512d 100644 --- a/rtl/morphos/sysdir.inc +++ b/rtl/morphos/sysdir.inc @@ -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; diff --git a/rtl/msdos/sysdir.inc b/rtl/msdos/sysdir.inc index 9ac513a535..eb8c941840 100644 --- a/rtl/msdos/sysdir.inc +++ b/rtl/msdos/sysdir.inc @@ -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; diff --git a/rtl/nativent/sysdir.inc b/rtl/nativent/sysdir.inc index 0a3407ffe7..9fa78f2f55 100644 --- a/rtl/nativent/sysdir.inc +++ b/rtl/nativent/sysdir.inc @@ -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; diff --git a/rtl/nds/sysdir.inc b/rtl/nds/sysdir.inc index 95a1ac5fbd..95ef09904a 100644 --- a/rtl/nds/sysdir.inc +++ b/rtl/nds/sysdir.inc @@ -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; diff --git a/rtl/netware/sysdir.inc b/rtl/netware/sysdir.inc index bc51efc770..204e316922 100644 --- a/rtl/netware/sysdir.inc +++ b/rtl/netware/sysdir.inc @@ -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; diff --git a/rtl/netwlibc/sysdir.inc b/rtl/netwlibc/sysdir.inc index 20091a18c6..4fcdd11109 100644 --- a/rtl/netwlibc/sysdir.inc +++ b/rtl/netwlibc/sysdir.inc @@ -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; diff --git a/rtl/objpas/objpas.pp b/rtl/objpas/objpas.pp index c0e343161e..a026e58786 100644 --- a/rtl/objpas/objpas.pp +++ b/rtl/objpas/objpas.pp @@ -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 diff --git a/rtl/os2/sysdir.inc b/rtl/os2/sysdir.inc index ea44f50dca..9a0c6bf27b 100644 --- a/rtl/os2/sysdir.inc +++ b/rtl/os2/sysdir.inc @@ -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; diff --git a/rtl/symbian/sysdir.inc b/rtl/symbian/sysdir.inc index be95ab2d7d..dbdbebb5ed 100644 --- a/rtl/symbian/sysdir.inc +++ b/rtl/symbian/sysdir.inc @@ -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; diff --git a/rtl/unix/sysdir.inc b/rtl/unix/sysdir.inc index c70d198d8c..1b2316b36a 100644 --- a/rtl/unix/sysdir.inc +++ b/rtl/unix/sysdir.inc @@ -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; diff --git a/rtl/watcom/sysdir.inc b/rtl/watcom/sysdir.inc index eaba0a6f1f..f5ff8e862f 100644 --- a/rtl/watcom/sysdir.inc +++ b/rtl/watcom/sysdir.inc @@ -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 diff --git a/rtl/wii/sysdir.inc b/rtl/wii/sysdir.inc index fe3ac27b0d..a96a8ac6cc 100644 --- a/rtl/wii/sysdir.inc +++ b/rtl/wii/sysdir.inc @@ -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 diff --git a/rtl/win/sysdir.inc b/rtl/win/sysdir.inc index d0aafc11cd..34ea24c42a 100644 --- a/rtl/win/sysdir.inc +++ b/rtl/win/sysdir.inc @@ -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} diff --git a/rtl/win/sysos.inc b/rtl/win/sysos.inc index 7fad23a1ce..53d1d8d826 100644 --- a/rtl/win/sysos.inc +++ b/rtl/win/sysos.inc @@ -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; diff --git a/rtl/wince/system.pp b/rtl/wince/system.pp index 2e9cf52625..ff93dae8b3 100644 --- a/rtl/wince/system.pp +++ b/rtl/wince/system.pp @@ -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; diff --git a/tests/test/units/system/tdir2.pp b/tests/test/units/system/tdir2.pp new file mode 100644 index 0000000000..8dac0d535e --- /dev/null +++ b/tests/test/units/system/tdir2.pp @@ -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. |