mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-01 22:39:28 +02:00
+ Added SetDefaultMacOS[Filetype|Creator]
* Files written to by fpc rtl now always will get decent filetype/creator * Adapted to use FSpGetFullPath
This commit is contained in:
parent
4a9345c203
commit
0e5d980f63
@ -65,8 +65,15 @@ var
|
||||
{To be called at regular intervals, for lenghty tasks.
|
||||
Yield might give time for other tasks to run under the cooperative
|
||||
multitasked macos. For an MPW Tool, it also spinns the cursor.}
|
||||
|
||||
procedure Yield;
|
||||
|
||||
{To set mac file type and creator codes, to be used for files created
|
||||
by the FPC runtime library. They must be exactly 4 chars long.}
|
||||
|
||||
procedure SetDefaultMacOSFiletype(ftype: ShortString);
|
||||
procedure SetDefaultMacOSCreator(creator: ShortString);
|
||||
|
||||
{*********************************}
|
||||
{** Available features on macos **}
|
||||
{*********************************}
|
||||
@ -440,6 +447,10 @@ end;
|
||||
{*****************************************************************************
|
||||
MacOS specific functions
|
||||
*****************************************************************************}
|
||||
var
|
||||
defaultCreator: OSType = $4D505320; {'MPS ' MPW Shell}
|
||||
//defaultCreator: OSType = $74747874; {'ttxt' Simple Text}
|
||||
defaultFileType: OSType = $54455854; {'TEXT'}
|
||||
|
||||
procedure Yield;
|
||||
|
||||
@ -448,6 +459,21 @@ begin
|
||||
SpinCursor(1);
|
||||
end;
|
||||
|
||||
procedure SetDefaultMacOSFiletype(ftype: ShortString);
|
||||
|
||||
begin
|
||||
if Length(ftype) = 4 then
|
||||
defaultFileType:= PLongWord(@ftype[1])^;
|
||||
end;
|
||||
|
||||
procedure SetDefaultMacOSCreator(creator: ShortString);
|
||||
|
||||
begin
|
||||
if Length(creator) = 4 then
|
||||
defaultCreator:= PLongWord(@creator[1])^;
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
ParamStr/Randomize
|
||||
*****************************************************************************}
|
||||
@ -710,16 +736,20 @@ procedure do_open(var f;p:pchar;flags:longint);
|
||||
}
|
||||
|
||||
var
|
||||
creator, fileType: OSType;
|
||||
scriptTag: ScriptCode;
|
||||
refNum: Integer;
|
||||
res: OSErr;
|
||||
|
||||
err: OSErr;
|
||||
res: Integer;
|
||||
spec: FSSpec;
|
||||
|
||||
fh: Longint;
|
||||
|
||||
oflags : longint;
|
||||
s: AnsiString;
|
||||
fullPath: AnsiString;
|
||||
|
||||
finderInfo: FInfo;
|
||||
|
||||
begin
|
||||
// AllowSlash(p);
|
||||
|
||||
@ -783,10 +813,28 @@ begin
|
||||
end
|
||||
else
|
||||
begin
|
||||
InOutRes:= PathArgToFullPath(p, s);
|
||||
InOutRes:= PathArgToFSSpec(p, spec);
|
||||
if (InOutRes = 0) or (InOutRes = 2) then
|
||||
begin
|
||||
err:= FSpGetFullPath(spec, fullPath, false);
|
||||
InOutRes:= MacOSErr2RTEerr(err);
|
||||
end;
|
||||
|
||||
if InOutRes <> 0 then
|
||||
exit;
|
||||
p:= PChar(s);
|
||||
|
||||
p:= PChar(fullPath);
|
||||
|
||||
if FileRec(f).mode in [fmoutput, fminout, fmappend] then
|
||||
begin
|
||||
{Since opening of an existing file will not change filetype and creator,
|
||||
it is set here. Otherwise overwritten darwin files will not get filetype
|
||||
TEXT. This is not done when only opening file for reading.}
|
||||
FSpGetFInfo(spec, finderInfo);
|
||||
finderInfo.fdType:= defaultFileType;
|
||||
finderInfo.fdCreator:= defaultCreator;
|
||||
FSpSetFInfo(spec, finderInfo);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
@ -805,10 +853,6 @@ begin
|
||||
{$else}
|
||||
|
||||
InOutRes:=1;
|
||||
//creator:= $522A6368; {'MPS ' -- MPW}
|
||||
//creator:= $74747874; {'ttxt'}
|
||||
creator:= $522A6368; {'R*ch' -- BBEdit}
|
||||
fileType:= $54455854; {'TEXT'}
|
||||
|
||||
{ reset file handle }
|
||||
filerec(f).handle:=UnusedHandle;
|
||||
@ -816,7 +860,7 @@ begin
|
||||
res:= FSpLocationFromFullPath(StrLen(p), p, spec);
|
||||
if (res = noErr) or (res = fnfErr) then
|
||||
begin
|
||||
if FSpCreate(spec, creator, fileType, smSystemScript) = noErr then
|
||||
if FSpCreate(spec, defaultCreator, defaultFileType, smSystemScript) = noErr then
|
||||
;
|
||||
|
||||
if FSpOpenDF(spec, fsCurPerm, refNum) = noErr then
|
||||
@ -941,21 +985,19 @@ end;
|
||||
procedure getDir (DriveNr: byte; var Dir: ShortString);
|
||||
|
||||
var
|
||||
pathHandle: Mac_Handle;
|
||||
fullPath: AnsiString;
|
||||
pathHandleSize: Longint;
|
||||
|
||||
begin
|
||||
if FSpGetFullPath(workingDirectorySpec, pathHandle, false) <> noErr then
|
||||
if FSpGetFullPath(workingDirectorySpec, fullPath, false) <> noErr then
|
||||
Halt(3); {exit code 3 according to MPW}
|
||||
|
||||
pathHandleSize:= GetHandleSize(pathHandle);
|
||||
SetString(dir, pathHandle^, pathHandleSize);
|
||||
DisposeHandle(pathHandle);
|
||||
|
||||
if pathHandleSize <= 255 then {because dir is ShortString}
|
||||
if Length(fullPath) <= 255 then {because dir is ShortString}
|
||||
InOutRes := 0
|
||||
else
|
||||
InOutRes := 1; //TODO Exchange to something better
|
||||
|
||||
dir:= fullPath;
|
||||
end;
|
||||
|
||||
{*****************************************************************************
|
||||
@ -1305,7 +1347,12 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.21 2004-09-12 19:51:02 olle
|
||||
Revision 1.22 2004-09-30 19:58:42 olle
|
||||
+ Added SetDefaultMacOS[Filetype|Creator]
|
||||
* Files written to by fpc rtl now always will get decent filetype/creator
|
||||
* Adapted to use FSpGetFullPath
|
||||
|
||||
Revision 1.21 2004/09/12 19:51:02 olle
|
||||
+ InitGraf called for MPW tool, which make strange bug disappear.
|
||||
* bugfix initial wd for MPW tool
|
||||
+ Added SysInitExceptions
|
||||
|
Loading…
Reference in New Issue
Block a user