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

* ansistring versions of mk/rm/chdir in objpas, Mantis 15010. The os-dependant routines of *nix/os2/win/dos have been converted

Browse Source 
git-svn-id: trunk@14211 -
This commit is contained in:
marco 2009-11-18 18:04:51 +00:00
parent 656f122bef
commit 17062d667c
7 changed files with 161 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
rtl/go32v2/sysdir.inc
View File

@ -18,21 +18,18 @@
Directory Handling
*****************************************************************************}
procedure DosDir(func:byte;const s:string);
procedure DosDir(func:byte;s:pchar;len:integer);
var
buffer : array[0..255] of char;
regs : trealregs;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(pchar(@buffer));
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 (length(s)>0) and (buffer[length(s)-1]='\') and
Not ((length(s)=1) or ((length(s)=3) and (s[2]=':'))) then
buffer[length(s)-1]:=#0;
syscopytodos(longint(@buffer),length(s)+1);
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);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
if LFNSupport then
@ -44,35 +41,32 @@ begin
GetInOutRes(lo(regs.realeax));
end;
procedure mkdir(const s : string);[IOCheck];
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
begin
If (s='') or (InOutRes <> 0) then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DosDir($39,s);
DosDir($39,s,len);
end;
procedure rmdir(const s : string);[IOCheck];
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
begin
if (s = '.' ) then
if (len=1) and (s[0] = '.' ) then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DosDir($3a,s);
DosDir($3a,s,len);
end;
procedure chdir(const s : string);[IOCheck];
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
var
regs : trealregs;
begin
If (s='') or (InOutRes <> 0) then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
{ First handle Drive changes }
if (length(s)>=2) and (s[2]=':') then
if (len>=2) and (s[1]=':') then
begin
regs.realedx:=(ord(s[1]) and (not 32))-ord('A');
regs.realedx:=(ord(s[0]) and (not 32))-ord('A');
regs.realeax:=$0e00;
sysrealintr($21,regs);
regs.realeax:=$1900;
@ -84,14 +78,13 @@ begin
end;
{ DosDir($3b,'c:') give Path not found error on
pure DOS PM }
if length(s)=2 then
if len=2 then
exit;
end;
{ do the normal dos chdir }
DosDir($3b,s);
DosDir($3b,s,len);
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
var
temp : array[0..255] of char;

63
rtl/inc/system.inc
View File

@ -588,21 +588,6 @@ Begin
End;
{*****************************************************************************
Directory support.
*****************************************************************************}
{$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
Procedure getdir(drivenr:byte;Var dir:ansistring);
{ this is needed to also allow ansistrings, the shortstring version is
OS dependent }
var
s : shortstring;
begin
getdir(drivenr,s);
dir:=s;
end;
{$endif}
{$ifopt R+}
{$define RangeCheckWasOn}
@ -1340,6 +1325,54 @@ end;
{ OS dependent dir functions }
{$i sysdir.inc}
{$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
Procedure getdir(drivenr:byte;Var dir:ansistring);
{ this is needed to also allow ansistrings, the shortstring version is
OS dependent }
var
s : shortstring;
begin
getdir(drivenr,s);
dir:=s;
end;
{$endif}
{$if defined(FPC_HAS_FEATURE_FILEIO)}
Procedure MkDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
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;
{$endif}
{*****************************************************************************
Resources support
*****************************************************************************}

9
rtl/inc/systemh.inc
View File

@ -874,16 +874,17 @@ Procedure SetTextLineEnding(var f:Text; Ending:string);
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure chdir(const s:string);
Procedure mkdir(const s:string);
Procedure rmdir(const s:string);
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 getdir(drivenr:byte;var dir:shortstring);
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure getdir(drivenr:byte;var dir:ansistring);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$endif FPC_HAS_FEATURE_FILEIO}
{*****************************************************************************
Miscellaneous
*****************************************************************************}

22
rtl/objpas/objpas.pp
View File

@ -70,6 +70,10 @@ Var
{ ParamStr should return also an ansistring }
Function ParamStr(Param : Integer) : Ansistring;
Procedure MkDir(const s:ansistring);overload;
Procedure RmDir(const s:ansistring);overload;
Procedure ChDir(const s:ansistring);overload;
{****************************************************************************
Resource strings.
****************************************************************************}
@ -104,6 +108,10 @@ Var
Compatibility routines.
****************************************************************************}
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 }
Procedure AssignFile(out f:File;const Name:string);
@ -207,6 +215,20 @@ begin
end;
Procedure MkDir(const s:ansistring);
begin
mkdirpchar(pchar(s),length(s));
end;
Procedure RmDir(const s:ansistring);
begin
RmDirpchar(pchar(s),length(s));
end;
Procedure ChDir(const s:ansistring);
begin
ChDirpchar(pchar(s),length(s));
end;
{ ---------------------------------------------------------------------
ResourceString support

75
rtl/os2/sysdir.inc
View File

@ -19,64 +19,57 @@
Directory Handling
*****************************************************************************}
procedure MkDir (const S: string);[IOCHECK];
var buffer:array[0..255] of char;
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
var
Rc : word;
begin
If (s='') or (InOutRes <> 0) then
exit;
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(Pchar(@buffer));
Rc := DosCreateDir(buffer,nil);
if Rc <> 0 then
begin
InOutRes := Rc;
Errno2Inoutres;
end;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DoDirSeparators(s);
Rc := DosCreateDir(s,nil);
if Rc <> 0 then
begin
InOutRes := Rc;
Errno2Inoutres;
end;
end;
procedure rmdir(const s : string);[IOCHECK];
var buffer:array[0..255] of char;
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
var
Rc : word;
begin
if (s = '.' ) then
if (len=1) and (s^ = '.' ) then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(Pchar(@buffer));
Rc := DosDeleteDir(buffer);
if Rc <> 0 then
begin
InOutRes := Rc;
Errno2Inoutres;
end;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
DoDirSeparators(s);
Rc := DosDeleteDir(s);
if Rc <> 0 then
begin
InOutRes := Rc;
Errno2Inoutres;
end;
end;
{$ASMMODE INTEL}
procedure ChDir (const S: string);[IOCheck];
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
var RC: cardinal;
Buffer: array [0..255] of char;
begin
If (s='') or (InOutRes <> 0) then exit;
if (Length (S) >= 2) and (S [2] = ':') then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
if (Len >= 2) and (S[1] = ':') then
begin
RC := DosSetDefaultDisk ((Ord (S [1]) and not ($20)) - $40);
RC := DosSetDefaultDisk ((Ord (S [0]) and not ($20)) - $40);
if RC <> 0 then
InOutRes := RC
else
if Length (S) > 2 then
if Len > 2 then
begin
Move (S [1], Buffer, Length (S));
Buffer [Length (S)] := #0;
DoDirSeparators (PChar (@Buffer));
RC := DosSetCurrentDir (@Buffer);
DoDirSeparators (s);
RC := DosSetCurrentDir (s);
if RC <> 0 then
begin
InOutRes := RC;
@ -84,10 +77,8 @@ begin
end;
end;
end else begin
Move (S [1], Buffer, Length (S));
Buffer [Length (S)] := #0;
DoDirSeparators (PChar (@Buffer));
RC := DosSetCurrentDir (@Buffer);
DoDirSeparators (s);
RC := DosSetCurrentDir (s);
if RC <> 0 then
begin
InOutRes:= RC;

43
rtl/unix/sysdir.inc
View File

@ -18,53 +18,44 @@
Directory Handling
*****************************************************************************}
Procedure MkDir(Const s: String);[IOCheck];
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
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH OR
S_IXUSR OR S_IXGRP OR S_IXOTH;
Var
Buffer: Array[0..255] of Char;
// 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)
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpmkdir(@buffer[0], MODE_MKDIR)<0 Then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
If Fpmkdir(s, MODE_MKDIR)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure RmDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
Begin
if (s = '.') then
if (len=1) and (s^ = '.') then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fprmdir(@buffer[0])<0 Then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
If Fprmdir(s)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure ChDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
Begin
If (s='') or (InOutRes <> 0) then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpchdir(@buffer[0])<0 Then
If Fpchdir(s)<0 Then
Errno2Inoutres
Else
InOutRes:=0;

37
rtl/win/sysdir.inc
View File

@ -17,18 +17,13 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
type
TDirFnType=function(name:pointer):longbool;stdcall;
procedure dirfn(afunc : TDirFnType;const s:string);
var
buffer : array[0..255] of char;
procedure dirfn(afunc : TDirFnType;s:pchar;len:integer);
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(pchar(@buffer));
if not aFunc(@buffer) then
DoDirSeparators(s);
if not aFunc(s) then
begin
errno:=GetLastError;
Errno2InoutRes;
@ -40,36 +35,38 @@ begin
CreateDirectoryTrunc:=CreateDirectory(name,nil);
end;
procedure mkdir(const s:string);[IOCHECK];
Procedure MkDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_MKDIR'];
begin
If (s='') or (InOutRes <> 0) then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@CreateDirectoryTrunc),s);
dirfn(TDirFnType(@CreateDirectoryTrunc),s,len);
end;
procedure rmdir(const s:string);[IOCHECK];
Procedure RmDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_RMDIR'];
begin
if (s ='.') then
if (len=1) and (s^ ='.') then
InOutRes := 16;
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
{$ifdef WINCE}
if (s ='..') then
if (len=2) and (s[0]='.') and (s[1]='.') then
InOutRes := 5;
{$endif WINCE}
If (s='') or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@RemoveDirectory),s);
dirfn(TDirFnType(@RemoveDirectory),s,len);
{$ifdef WINCE}
if (Inoutres=3) and (Pos(DirectorySeparator, s)<2) then
Inoutres:=2;
{$endif WINCE}
end;
procedure chdir(const s:string);[IOCHECK];
Procedure ChDir(s: pchar;len:sizeuint);[IOCheck, public, alias : 'FPC_SYS_CHDIR'];
begin
{$ifndef WINCE}
If (s='') or (InOutRes <> 0) then
If not assigned(s) or (len=0) or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@SetCurrentDirectory),s);
dirfn(TDirFnType(@SetCurrentDirectory),s,len);
if Inoutres=2 then
Inoutres:=3;
{$else WINCE}