Printers,carbon: implements getting default printer resolution from PPD data

git-svn-id: trunk@48542 -

.gitattributes

@@ -3006,6 +3006,7 @@ components/printers/carbon/carbonprinters_h.inc svneol=native#text/pascal
 components/printers/carbon/carbonprinting.pas svneol=native#text/pascal
 components/printers/carbon/carbonprndialogs.inc svneol=native#text/pascal
 components/printers/carbon/issues.xml svneol=native#text/xml
+components/printers/carbon/ppdresolution.pas svneol=native#text/pascal
 components/printers/cocoa/cocoaprinters.inc svneol=native#text/plain
 components/printers/cocoa/cocoaprinters_h.inc svneol=native#text/plain
 components/printers/cocoa/cocoaprndialogs.inc svneol=native#text/plain

components/printers/carbon/carbonprinters.inc

@@ -360,9 +360,15 @@ begin
     _PMPrinterGetOutputResolutionLoaded := true;
     _PMPrinterGetOutputResolution := TPMPrinterGetOutputResolution(dlsym(RTLD_DEFAULT,'PMPrinterGetOutputResolution'));
   end;
-  if Assigned(_PMPrinterGetOutputResolution) then
+  if Assigned(_PMPrinterGetOutputResolution) then begin
     // the function might return kPMKeyNotFound, see function description in MacOSAll
-    res := _PMPrinterGetOutputResolution(prn,  PrintSettings, Result{%H-})
+    res := _PMPrinterGetOutputResolution(prn,  PrintSettings, Result{%H-});
+    if (res=kPMKeyNotFound) and (FDefaultResolution.Valid) then begin
+      res := noErr;
+      Result.hRes := fDefaultResolution.HorzRes;
+      Result.vRes := fDefaultResolution.VertRes;
+    end;
+  end
   else
     res := noErr+1;
 
@@ -567,6 +573,7 @@ function TCarbonPrinter.DoSetPrinter(aName: string): Integer;
 var
   S: TStringList;
   P: PMPrinter;
+  ResCount: UInt32;
 begin
   S := TStringList.Create;
   BeginEnumPrinters(S);
@@ -581,6 +588,13 @@ begin
       if OSError(PMSessionSetCurrentPMPrinter(PrintSession, P),
         Self, 'DoSetPrinter', 'PMSessionSetCurrentPMPrinter') then
           raise EPrinter.CreateFmt('The system is unable to select printer "%s"!', [AName]);
+      //
+      with FDefaultResolution do
+      begin
+        Valid := (PMPrinterGetPrinterResolutionCount(P, ResCount)=noErr) and (ResCount>1);
+        if Valid then
+          Valid := GetDefaultPPDResolution(P, HorzRes, VertRes);
+      end;
     end;
   finally
     EndEnumPrinters;

components/printers/carbon/carbonprinters_h.inc

@@ -1,7 +1,7 @@
 {%MainUnit ../osprinters.pas}
 uses
   MacOSAll,
-  Classes, SysUtils, Printers, LCLType, CarbonCanvas, CarbonPrinting;
+  Classes, SysUtils, Printers, LCLType, CarbonCanvas, CarbonPrinting, ppdresolution;
 
 type
   { TCarbonPrinterContext }
@@ -14,6 +14,11 @@ type
     procedure Reset; override;
   end;
 
+  TPrinterResolution = record
+    Valid: boolean;
+    HorzRes, VertRes: Integer;
+  end;
+
   { TCarbonPrinter }
 
   TCarbonPrinter = class(TPrinter)
@@ -27,6 +32,7 @@ type
     FPrinterArray: CFArrayRef;
     FPaperArray: CFArrayRef;
     FDefaultPrinter: String;
+    FDefaultResolution: TPrinterResolution;
     
     procedure CreatePrintSession;
     procedure CreatePrintSettings;

components/printers/carbon/ppdresolution.pas

@@ -0,0 +1,185 @@
+unit ppdresolution;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, MacOSAll, CarbonProc;
+
+  function GetDefaultPPDResolution(aPrinter: PMPrinter; out HorzRes, VertRes: Integer): boolean;
+
+implementation
+
+
+function StrPasP(A,B: pchar): ansistring;
+begin
+  SetLength(Result, B-A);
+  system.Move(A^, Result[1], B-A);
+end;
+
+procedure SkipBlanks(var A: pchar);
+begin
+  while A^ in [' ', #9] do
+    Inc(A);    // skip white space
+end;
+
+function GetNumber(var B: pchar; var Number: Integer): boolean;
+var
+  A: pchar;
+  Code: Integer;
+begin
+  Number := 0;
+  result := false;
+  A := B;
+  while B^ in ['0'..'9'] do Inc(B);
+  if A=B then
+    exit;
+
+  Val(StrPasP(A, B), Number, Code);
+  result := Code=0;
+end;
+
+function ParseDefaultResolution(A:Pchar; out ResTag: ansistring; out HorzRes, VertRes: Integer): boolean;
+var
+  B: PChar;
+begin
+
+  result := false;
+  HorzRes := 300;
+  VertRes := 300;
+  if A=nil then
+    exit;
+
+  inc(A, 19);                         // skip *DefaultResolution:
+  SkipBlanks(A);
+  B := A;
+  while not (B^ in [' ', #9, #10, #13]) do inc(B);
+  if A=B then
+    exit;
+
+  ResTag := StrPasP(A, B);
+  A := @ResTag[1];
+
+  // get first number
+  B := A;
+  result := GetNumber(B, HorzRes);
+  if not result then
+    exit;
+
+  if B^='d' then begin // start of dpi, we are done
+    VertRes := HorzRes;
+    result := true;
+    exit;
+  end;
+  if B^<>'x' then  // unexpected res format, expected NNNxMMMdpi
+    exit;
+
+  // get second number
+  inc(B);
+  A := B;
+  result := GetNumber(B, VertRes);
+end;
+
+function GetDefaultResolutionFromPtr(Buf: PChar;
+  var HorzRes, VertRes:Integer): boolean;
+var
+  A, B: PChar;
+  ResTag: ansistring;
+begin
+
+  result := false;
+  A := strpos(Buf, '*DefaultResolution:');
+  if A=nil then
+    exit;
+
+  result := ParseDefaultResolution(A, ResTag, HorzRes, VertRes);
+  if not result then
+    exit;
+
+  // now check for *OpenUI: *Resolution, maybe ResTag is just a tag
+  A := strpos(Buf, '*OpenUI *Resolution');
+  if A=nil then begin
+    // not found, assume ResTag is a valid value
+    exit;
+  end;
+
+  // restrict ourselves to this block
+  B := strpos(A, '*CloseUI: *Resolution');
+  if B=nil then
+    exit;  // something is wrong but we have a standalone default resolution
+           // we take it
+  B^ := #0;
+
+  result := false;
+  repeat
+    // find default resolution entry
+    B := strpos(A, #10'*Resolution');
+    if B<>nil then begin
+      inc(B, 12);
+      SkipBlanks(B);
+      // is this the one we are looking for?
+      if strlcomp(B, @ResTag[1], Length(ResTag))=0 then begin
+        // it is, look for /HWResolution
+        A := strpos(B, '/HWResolution');
+        if A<>nil then begin
+          // found
+          inc(A, 13);
+          SkipBlanks(A);
+          // we are not a postscript interpreter, only look for
+          // resolution values like NNN or [NNN MMM]
+          if A^='[' then begin
+            Inc(A);
+            SkipBlanks(A);
+            Result := GetNumber(A, HorzRes);
+            if Result then begin
+              SkipBlanks(A);
+              Result := GetNumber(A, VertRes);
+            end;
+          end else begin
+            result := GetNumber(A, HorzRes);
+            VertRes := HorzRes;
+          end;
+        end else
+          // /HWResolution not found, assume ResTag was in valid format
+          result := true;
+
+        break;
+      end;
+      A := B;
+    end;
+  until B=nil;
+end;
+
+function GetDefaultPPDResolution(aPrinter: PMPrinter; out HorzRes, VertRes: Integer
+  ): boolean;
+var
+  PPD: ansistring;
+  Name: CFStringRef;
+  aURL: CFURLRef = nil;
+  Range: CFRange;
+  Data: CFDataRef = nil;
+begin
+  VertRes := 0;
+  HorzRes := 0;
+
+  CreateCFString('PMPPDDescriptionType', Name);
+  Result := PMPrinterCopyDescriptionURL(aPrinter, Name, aURL)=noErr;
+  FreeCFString(Name);
+  if Result then begin
+    PMCopyPPDData(aURL, Data);
+    FreeCFString(aURL);
+    if Data<>nil then begin
+      Range.length := CFDataGetLength(Data);
+      Range.location := 0;
+      SetLength(PPD, Range.length);
+      CFDataGetBytes(Data, Range, @PPD[1]);
+      CFRelease(Data);
+      result := GetDefaultResolutionFromPtr(@PPD[1], HorzRes, VertRes);
+    end;
+  end;
+
+end;
+
+end.
+

components/printers/printer4lazarus.lpk

@@ -30,7 +30,7 @@
     <License Value="LGPL
 "/>
     <Version Minor="5"/>
-    <Files Count="36">
+    <Files Count="37">
       <Item1>
         <Filename Value="printersdlgs.pp"/>
         <HasRegisterProc Value="True"/>
@@ -186,6 +186,10 @@
         <AddToUsesPkgSection Value="False"/>
         <UnitName Value="cupslcl"/>
       </Item36>
+      <Item37>
+        <Filename Value="carbon\ppdresolution.pas"/>
+        <UnitName Value="ppdresolution"/>
+      </Item37>
     </Files>
     <RequiredPkgs Count="1">
       <Item1>

components/printers/printer4lazarus.pas

@@ -2,20 +2,20 @@
   This source is only used to compile and install the package.
  }
 
-unit Printer4Lazarus; 
+unit Printer4Lazarus;
 
 interface
 
 uses
-  PrintersDlgs, OSPrinters, LazarusPackageIntf;
+  PrintersDlgs, OSPrinters, ppdresolution, LazarusPackageIntf;
 
 implementation
 
-procedure Register; 
+procedure Register;
 begin
-  RegisterUnit('PrintersDlgs', @PrintersDlgs.Register); 
-end; 
+  RegisterUnit('PrintersDlgs', @PrintersDlgs.Register);
+end;
 
 initialization
-  RegisterPackage('Printer4Lazarus', @Register); 
+  RegisterPackage('Printer4Lazarus', @Register);
 end.