+ added support for Exec via AppleEvents - Toolserver

rtl/macos/dos.pp

@@ -58,9 +58,6 @@ Implementation
  volumes. At lest accessing the possible disk drives with
  driver number 1 and 2 should be easy.}
 
-{TODO Perhaps implement Exec with Apple Events, calling ToolServer.}
-
-
 {TODO Perhaps use LongDateTime for time functions. But the function
  calls must then be weak linked.}
 
@@ -173,14 +170,158 @@ End;
                                --- Exec ---
 ******************************************************************************}
 
+{ Create a DoScript AppleEvent that targets the given application with text as the direct object. }
+function CreateDoScriptEvent (applCreator: OSType; scriptText: PChar; var theEvent: AppleEvent): OSErr;
+
+  var
+   err: OSErr;
+   targetAddress: AEDesc;
+   s: signedByte;
+
+begin
+  err := AECreateDesc(FourCharCodeToLongword(typeApplSignature), @applCreator, sizeof(applCreator), targetAddress);
+  if err = noErr then
+    begin
+      err := AECreateAppleEvent(FourCharCodeToLongword('misc'), FourCharCodeToLongword('dosc'),
+          targetAddress, kAutoGenerateReturnID, kAnyTransactionID, theEvent);
+
+      if err = noErr then
+          { Add script text as the direct object parameter. }
+          err := AEPutParamPtr(theEvent, FourCharCodeToLongword('----'),
+                    FourCharCodeToLongword('TEXT'), scriptText, Length(scriptText));
+
+      if err <> noErr then
+        AEDisposeDesc(theEvent);
+      AEDisposeDesc(targetAddress);
+    end;
+
+  CreateDoScriptEvent := err;
+end;
+
+Procedure Fpc_WriteBuffer(var f:Text;const b;len:longint);[external name 'FPC_WRITEBUFFER'];
+{declared in text.inc}
+
+procedure WriteAEDescTypeCharToFile(desc: AEDesc; var f: Text);
+  
+begin
+  if desc.descriptorType = FourCharCodeToLongword(typeChar) then
+    begin
+      HLock(desc.dataHandle);
+      Fpc_WriteBuffer(f, PChar(desc.dataHandle^)^, GetHandleSize(desc.dataHandle));
+      Flush(f);
+      HUnLock(desc.dataHandle);
+    end;
+end;
+  
+function ExecuteToolserverScript(scriptText: PChar; var statusCode: Longint): OSErr;
+
+  var
+    err: OSErr;
+    err2: OSErr;  {Non serious error}
+    theEvent: AppleEvent;
+    reply: AppleEvent;
+    result: AEDesc;
+    applFileSpec: FSSpec;
+    p: SignedByte;
+   
+  const
+    applCreator = 'MPSX'; {Toolserver}
+    
+begin
+  statusCode:= 3; //3 according to MPW.
+  err:= CreateDoScriptEvent (FourCharCodeToLongword(applCreator), scriptText, theEvent);
+  if err = noErr then
+    begin
+      err := AESend(theEvent, reply, kAEWaitReply, kAENormalPriority, kAEDefaultTimeOut, nil, nil);
+
+      if err = connectionInvalid then  { Toolserver not available }
+        begin
+          err := FindApplication(FourCharCodeToLongword(applCreator), applFileSpec);
+          if err = noErr then
+            err := LaunchFSSpec(false, applFileSpec);
+          if err = noErr then
+            err := AESend(theEvent, reply, kAEWaitReply, kAENormalPriority, kAEDefaultTimeOut, nil, nil);
+        end;
+
+      if err = noErr then
+        begin    
+          err:= AEGetParamDesc(reply, FourCharCodeToLongword('stat'),
+                    FourCharCodeToLongword(typeLongInteger), result);
+          
+          if err = noErr then
+            if result.descriptorType = FourCharCodeToLongword(typeLongInteger) then
+              statusCode:= LongintPtr(result.dataHandle^)^;
+          
+          {If there is no output below, we get a non zero error code}
+          
+          err2:= AEGetParamDesc(reply, FourCharCodeToLongword('----'),
+                    FourCharCodeToLongword(typeChar), result);        
+          if err2 = noErr then
+             WriteAEDescTypeCharToFile(result, stdout);
+          
+          err2:= AEGetParamDesc(reply, FourCharCodeToLongword('diag'),
+                    FourCharCodeToLongword(typeChar), result);
+          if err2 = noErr then
+            WriteAEDescTypeCharToFile(result, stderr);
+          
+          AEDisposeDesc(reply);
+        
+          {$IFDEF TARGET_API_MAC_CARBON }
+          {$ERROR FIXME AEDesc data is not allowed to be directly accessed}
+          {$ENDIF}
+        end;
+        
+      AEDisposeDesc(theEvent);
+    end;
+
+  ExecuteToolserverScript:= err;
+end;
+
+{$ifdef HASTHREADVAR}
+threadvar
+{$else HASTHREADVAR}
+var
+{$endif HASTHREADVAR}
+  laststatuscode : longint;
+
 Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
+var
+  s: AnsiString;
+  err: OSErr;
+  wdpath: AnsiString;
+  
 Begin
-  DosError:=8; //TODO A better error sometime
+  {Make ToolServers working directory in sync with our working directory}
+  PathArgToFullPath(':', wdpath);
+  wdpath:= 'Directory ' + wdpath;
+  err:= ExecuteToolserverScript(PChar(wdpath), laststatuscode);
+    {TODO Only change path when actually needed. But this requires some 
+     change counter to be incremented each time wd is changed. }
+
+  s:= path + ' ' + comline;
+  
+  err:= ExecuteToolserverScript(PChar(s), laststatuscode);
+  if err = afpItemNotFound then
+    DosError := 900
+  else
+    DosError := MacOSErr2RTEerr(err);
+  //TODO Better dos error codes
 End;
 
 Function DosExitCode: Word;
+var
+  clippedstatus: Word;
 Begin
-  DosExitCode := 3; //Indicate failure TODO a better error sometime.
+  if laststatuscode <> 0 then
+    begin
+      {MPW status might be 24 bits}
+      clippedstatus := laststatuscode and $ffff;
+      if clippedstatus = 0 then
+        clippedstatus:= 1;
+      DosExitCode:= clippedstatus;
+    end
+  else
+    DosExitCode := 0;  
 End;
 
 {******************************************************************************
@@ -198,8 +339,8 @@ var
   myErr: OSErr;
 
 begin
-	myHPB.ioNamePtr := NIL;
-	myHPB.ioVolIndex := 0;
+  myHPB.ioNamePtr := NIL;
+  myHPB.ioVolIndex := 0;
   case drive of
     0: myHPB.ioVRefNum := GetWorkingDirectoryVRefNum;
     1: myHPB.ioVRefNum := 1;
@@ -231,8 +372,8 @@ var
   myErr: OSErr;
 
 Begin
-	myHPB.ioNamePtr := NIL;
-	myHPB.ioVolIndex := 0;
+  myHPB.ioNamePtr := NIL;
+  myHPB.ioVolIndex := 0;
   case drive of
     0: myHPB.ioVRefNum := GetWorkingDirectoryVRefNum;
     1: myHPB.ioVRefNum := 1;
@@ -917,4 +1058,4 @@ end;
                             --- Initialization ---
 ******************************************************************************}
 
-End.
+End.

rtl/macos/macutils.inc

@@ -3,7 +3,8 @@
     This file is part of the Free Pascal run time library.
     Copyright (c) 2004 by Olle Raab
 
-    Some utilities specific for Mac OS
+    Some utilities specific for Mac OS.
+    Modified portions from Peter N. Lewis (PNL Libraries). Thanks !
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -457,3 +458,123 @@ function GetWorkingDirectoryVRefNum: Integer;
 begin
   GetWorkingDirectoryVRefNum:= workingDirectorySpec.vRefNum;
 end;
+
+  function GetVolInfo (var name: Str63; var vrn: integer; index: integer; var CrDate: longint): OSErr;
+    var
+      pb: ParamBlockRec;
+      oe: OSErr;
+  begin
+    if (name <> '') and (name[length(name)] <> ':') then begin
+      name := concat(name, ':');
+    end;
+    pb.ioNamePtr := @name;
+    pb.ioVRefNum := vrn;
+    pb.ioVolIndex := index;
+    oe := PBGetVInfoSync(@pb);
+    if oe = noErr then begin
+      vrn := pb.ioVRefNum;
+      CrDate := pb.ioVCrDate;
+    end;
+    GetVolInfo := oe;
+  end;
+
+  {Checks that fs really is an application with the specified creator}
+  function ConfirmApplicationExists (creator: OSType; var fs: FSSpec): OSErr;
+  
+    var
+      err: OSErr;
+      info: FInfo;
+  begin
+    err := HGetFInfo(fs.vRefNum, fs.parID, fs.name, info);
+    if err = noErr then begin
+      if (info.fdType <> FourCharCodeToLongword('APPL')) or (info.fdCreator <> creator) then begin
+        err := fnfErr;
+      end;
+    end;
+    ConfirmApplicationExists := err;
+  end;
+
+  {Find an application with the given creator, in any of the mounted volumes.} 
+  function FindApplication (creator: OSType; var fs: FSSpec): OSErr;
+    var
+      i: integer;
+      pbdt: DTPBRec;
+      crdate: longint;
+      oe: OSErr;
+      found: Boolean;
+  begin
+    found := false;
+    if (macosSystemVersion >= $0700) then begin
+      i := 1;
+      repeat
+        fs.vRefNum := 0;
+        
+        {Get info for volume i}
+        oe := GetVolInfo(fs.name, fs.vRefNum, i, crdate);
+        i := i + 1;
+        if oe = noErr then begin
+          with pbdt do begin
+            fs.name := '';
+            ioNamePtr := @fs.name;
+            ioVRefNum := fs.vRefNum;
+            
+            {Get the desktop database for this volume}
+            oe := PBDTGetPath(@pbdt);
+            if oe = noErr then begin
+              ioFileCreator := creator;
+
+              {Look first for the "default" (newest) application file}
+              ioIndex := 0;
+              oe := PBDTGetAPPLSync(@pbdt);
+              if oe = noErr then begin
+                fs.parID := pbdt.ioAPPLParID;
+                found := ConfirmApplicationExists(creator,fs)=noErr;
+              end;
+              
+              {If not ok, look for older ones.}
+              if not found then begin
+                ioIndex := 1;              
+                repeat
+                  oe := PBDTGetAPPLSync(@pbdt);
+                  if oe = noErr then begin
+                    fs.parID := pbdt.ioAPPLParID;
+                    found := ConfirmApplicationExists(creator,fs)=noErr;
+                  end;
+                  ioIndex := ioIndex + 1;
+                until found or (oe <> noErr);
+              end;
+              
+            end;
+          end;
+          oe := noErr;
+        end;
+      until found or (oe <> noErr);
+    end;
+    if found then begin
+      oe := noErr;
+    end else begin
+      oe := fnfErr;
+      fs.vRefNum := 0;
+      fs.parID := 2;
+      fs.name := '';
+    end;
+    FindApplication := oe;
+  end;
+
+function LaunchFSSpec (tofront: Boolean; const applicationFileSpec: FSSpec): OSErr;
+var
+  launchThis: LaunchParamBlockRec;
+begin
+  launchThis.launchAppSpec := @applicationFileSpec;
+  launchThis.launchAppParameters := nil;
+  launchThis.launchBlockID := extendedBlock;
+  launchThis.launchEPBLength := extendedBlockLen;
+  launchThis.launchFileFlags := 0;
+  launchThis.launchControlFlags := launchContinue or launchNoFileFlags;
+  if not tofront then begin
+    launchThis.launchControlFlags := launchThis.launchControlFlags or launchDontSwitch;
+  end;
+  
+  LaunchFSSpec:= LaunchApplication(@launchThis);
+end;
+

rtl/macos/macutils.pp

@@ -4,6 +4,7 @@
     Copyright (c) 2004 by Olle Raab
 
     Some utilities specific for Mac OS
+    Modified portions from Peter N. Lewis (PNL Libraries). Thanks !
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -60,6 +61,13 @@ function GetVolumeName(vRefNum: Integer; var volName: String): OSErr;
 
 function GetWorkingDirectoryVRefNum: Integer;
 
+{Find an application with the given creator, in any of the mounted volumes.} 
+function FindApplication (creator: OSType; var fs: FSSpec): OSErr;
+
+{Launch the application given by applicationFileSpec. If toFront is true
+ it will be brought to the foreground when launched.}
+function LaunchFSSpec (tofront: Boolean; const applicationFileSpec: FSSpec): OSErr;
+
 implementation
 
 var