paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 07:26:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* moved directory handling code

Browse Source 
git-svn-id: trunk@26361 -
This commit is contained in:
florian 2014-01-02 18:24:11 +00:00
parent 32b9926536
commit ac120d075a
3 changed files with 216 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -7598,6 +7598,7 @@ rtl/atari/Makefile.fpc svneol=native#text/plain
rtl/atari/prt0.as svneol=native#text/plain rtl/atari/prt0.as svneol=native#text/plain
rtl/atari/readme -text rtl/atari/readme -text
rtl/atari/rtldefs.inc svneol=native#text/plain rtl/atari/rtldefs.inc svneol=native#text/plain
rtl/atari/sysdir.inc svneol=native#text/plain
rtl/atari/sysfile.inc svneol=native#text/plain rtl/atari/sysfile.inc svneol=native#text/plain
rtl/atari/sysheap.inc svneol=native#text/plain rtl/atari/sysheap.inc svneol=native#text/plain
rtl/atari/sysos.inc svneol=native#text/plain rtl/atari/sysos.inc svneol=native#text/plain

215
rtl/atari/sysdir.inc Normal file
View File

@ -0,0 +1,215 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski
member of the Free Pascal development team.
FPC Pascal system unit for Amiga.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure DosDir(func:byte;const s:string);
var
buffer : array[0..255] of char;
c : word;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(pchar(@buffer));
c:=word(func);
asm
move.l d2,d6 { save d2 }
movem.l d3/a2/a3,-(sp)
pea buffer
move.w c,-(sp)
trap #1
add.l #6,sp
move.l d6,d2 { restore d2 }
movem.l (sp)+,d3/a2/a3
tst.w d0
beq @dosdirend
move.w d0,errno
@dosdirend:
end;
if errno <> 0 then
Error2InOut;
end;
procedure mkdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($39,s);
end;
procedure rmdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($3a,s);
end;
procedure chdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($3b,s);
end;
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
[public, alias: 'FPC_GETDIRIO'];
var
temp : array[0..255] of char;
i : longint;
j: byte;
drv: word;
begin
GetDirIO := 0;
drv:=word(drivenr);
asm
move.l d2,d6 { save d2 }
movem.l d3/a2/a3,-(sp)
{ Get dir from drivenr : 0=default, 1=A etc... }
move.w drv,-(sp)
{ put (previously saved) offset in si }
{ move.l temp,-(sp)}
pea temp
{ call attos function 47H : Get dir }
move.w #$47,-(sp)
{ make the call }
trap #1
add.l #8,sp
move.l d6,d2 { restore d2 }
movem.l (sp)+,d3/a2/a3
end;
{ conversion to pascal string }
i:=0;
while (temp[i]<>#0) do
begin
if temp[i] in AllowDirectorySeparators then
temp[i]:=DirectorySeparator;
dir[i+3]:=temp[i];
inc(i);
end;
dir[2]:=':';
dir[3]:='\';
dir[0]:=char(i+2);
{ upcase the string (FPC Pascal function) }
dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=chr(65+drivenr-1)
else
begin
asm
move.l d2,d6 { save d2 }
movem.l d3/a2/a3,-(sp)
move.w #$19,-(sp)
trap #1
add.l #2,sp
move.w d0,drv
move.l d6,d2 { restore d2 }
movem.l (sp)+,d3/a2/a3
end;
dir[1]:=chr(byte(drv)+ord('A'));
end;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
end;
procedure do_mkdir(const s : rawbytestring);
var
tmpStr : rawbytestring;
tmpLock: LongInt;
begin
checkCTRLC;
tmpStr:=PathConv(s);
tmpLock:=dosCreateDir(pchar(tmpStr));
if tmpLock=0 then begin
dosError2InOut(IoErr);
exit;
end;
UnLock(tmpLock);
end;
procedure do_rmdir(const s : rawbytestring);
var
tmpStr : rawbytestring;
begin
checkCTRLC;
if (s='.') then
begin
InOutRes:=16;
exit;
end;
tmpStr:=PathConv(s);
if not dosDeleteFile(pchar(tmpStr)) then
dosError2InOut(IoErr);
end;
procedure do_ChDir(const s: rawbytestring);
var
tmpStr : rawbytestring;
tmpLock: LongInt;
FIB : PFileInfoBlock;
begin
checkCTRLC;
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(pchar(tmpStr),SHARED_LOCK);
if tmpLock=0 then begin
dosError2InOut(IoErr);
exit;
end;
FIB:=nil;
new(FIB);
if (Examine(tmpLock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin
tmpLock:=CurrentDir(tmpLock);
if AOS_OrigDir=0 then begin
AOS_OrigDir:=tmpLock;
tmpLock:=0;
end;
end;
if tmpLock<>0 then Unlock(tmpLock);
if assigned(FIB) then dispose(FIB);
end;
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
var tmpbuf: array[0..255] of char;
begin
checkCTRLC;
Dir:='';
if not GetCurrentDirName(tmpbuf,256) then
dosError2InOut(IoErr)
else
begin
Dir:=tmpbuf;
SetCodePage(Dir,DefaultFileSystemCodePage,false);
end;
end;

123
rtl/atari/system.pp
View File

@ -320,129 +320,6 @@ end ['D0'];
{$i text.inc} {$i text.inc}
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure DosDir(func:byte;const s:string);
var
buffer : array[0..255] of char;
c : word;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(pchar(@buffer));
c:=word(func);
asm
move.l d2,d6 { save d2 }
movem.l d3/a2/a3,-(sp)
pea buffer
move.w c,-(sp)
trap #1
add.l #6,sp
move.l d6,d2 { restore d2 }
movem.l (sp)+,d3/a2/a3
tst.w d0
beq @dosdirend
move.w d0,errno
@dosdirend:
end;
if errno <> 0 then
Error2InOut;
end;
procedure mkdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($39,s);
end;
procedure rmdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($3a,s);
end;
procedure chdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($3b,s);
end;
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
[public, alias: 'FPC_GETDIRIO'];
var
temp : array[0..255] of char;
i : longint;
j: byte;
drv: word;
begin
GetDirIO := 0;
drv:=word(drivenr);
asm
move.l d2,d6 { save d2 }
movem.l d3/a2/a3,-(sp)
{ Get dir from drivenr : 0=default, 1=A etc... }
move.w drv,-(sp)
{ put (previously saved) offset in si }
{ move.l temp,-(sp)}
pea temp
{ call attos function 47H : Get dir }
move.w #$47,-(sp)
{ make the call }
trap #1
add.l #8,sp
move.l d6,d2 { restore d2 }
movem.l (sp)+,d3/a2/a3
end;
{ conversion to pascal string }
i:=0;
while (temp[i]<>#0) do
begin
if temp[i] in AllowDirectorySeparators then
temp[i]:=DirectorySeparator;
dir[i+3]:=temp[i];
inc(i);
end;
dir[2]:=':';
dir[3]:='\';
dir[0]:=char(i+2);
{ upcase the string (FPC Pascal function) }
dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=chr(65+drivenr-1)
else
begin
asm
move.l d2,d6 { save d2 }
movem.l d3/a2/a3,-(sp)
move.w #$19,-(sp)
trap #1
add.l #2,sp
move.w d0,drv
move.l d6,d2 { restore d2 }
movem.l (sp)+,d3/a2/a3
end;
dir[1]:=chr(byte(drv)+ord('A'));
end;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes := GetDirIO (DriveNr, Dir);
end;
{***************************************************************************** {*****************************************************************************
System Dependent Exit code System Dependent Exit code
*****************************************************************************} *****************************************************************************}