tpipro, fix print preview empty pages under unix

git-svn-id: trunk@24419 -

components/turbopower_ipro/iphtml.pas

@@ -3829,8 +3829,13 @@ var
 begin
   ScreenDC := GetDC(0);
   try
-    Aspect := GetDeviceCaps(PrinterDC, LOGPIXELSX)
+    Aspect :=
-                / GetDeviceCaps(ScreenDC, LOGPIXELSX);
+      {$IFDEF IP_LAZARUS}
+      Printer.XDPI
+      {$ELSE}
+      GetDeviceCaps(PrinterDC, LOGPIXELSX)
+      {$ENDIF}
+      / GetDeviceCaps(ScreenDC, LOGPIXELSX);
   finally
     ReleaseDC(0, ScreenDC);
   end;
@@ -10267,7 +10272,11 @@ var
   procedure ApplyProps;
   var
     Changed : Boolean;
+    {$IFDEF IP_LAZARUS}
+    TextMetrics : TLCLTextMetric;
+    {$ELSE}
     TextMetrics : TTextMetric;
+    {$ENDIF}
   begin
     with CurElement.Props do begin
       if (CurProps = nil) or not AIsEqualTo(CurProps) then begin
@@ -10304,10 +10313,17 @@ var
         end;
         if Changed then begin
           if PropA.tmHeight = 0 then begin
+            {$IFDEF IP_LAZARUS}
+            aCanvas.GetTextMetrics(TextMetrics);
+            PropA.tmAscent := TextMetrics.Ascender;
+            PropA.tmDescent := TextMetrics.Descender;
+            PropA.tmHeight := TextMetrics.Height;
+            {$ELSE}
             GetTextMetrics(aCanvas.Handle, TextMetrics);
             PropA.tmAscent := TextMetrics.tmAscent;
             PropA.tmDescent := TextMetrics.tmDescent;
             PropA.tmHeight := TextMetrics.tmHeight;
+            {$ENDIF}
           end;
         end;
       end;
@@ -10836,7 +10852,11 @@ var
 
   procedure ApplyProps;
   var
-    TextMetrics : TTextMetric;
+    {$IFDEF IP_LAZARUS}
+    TextMetrics : TLCLTextMetric;
+    {$ELSE}
+    TExtMetrics : TTextMetric;
+    {$ENDIF}
   begin
     with CurElement.Props do begin
       if (CurProps = nil) or not AIsEqualTo(CurProps) then begin
@@ -10856,10 +10876,17 @@ var
           aCanvas.Font.Name := FontName;
           aCanvas.Font.Size := FontSize;
           aCanvas.Font.Style := FontStyle;
+          {$IFDEF IP_LAZARUS}
+          Owner.Target.GetTextMetrics(TextMetrics);
+          PropA.tmAscent := TextMetrics.Ascender;
+          PropA.tmDescent := TextMetrics.Descender;
+          PropA.tmHeight := TextMetrics.Height;
+          {$ELSE}
           GetTextMetrics(Owner.Target.Handle, TextMetrics);
           PropA.tmAscent := TextMetrics.tmAscent;
           PropA.tmDescent := TextMetrics.tmDescent;
           PropA.tmHeight := TextMetrics.tmHeight;
+          {$ENDIF}
         end;
         tmHeight := PropA.tmHeight;
         tmAscent := PropA.tmAscent;
@@ -10876,6 +10903,16 @@ var
   end;
 
   procedure InitMetrics;
+  {$IFDEF IP_LAZARUS}
+  var
+    TextMetrics : TLCLTextMetric;
+  begin
+    aCanvas.GetTextMetrics(TextMetrics);
+    tmAscent := TextMetrics.Ascender;
+    tmDescent := TextMetrics.Descender;
+    tmHeight := TextMetrics.Height;
+  end;
+  {$ELSE}
   var
     TextMetrics : TTextMetric;
   begin
@@ -10884,6 +10921,7 @@ var
     tmDescent := TextMetrics.tmDescent;
     tmHeight := TextMetrics.tmHeight;
   end;
+  {$ENDIF}
 
   {!!.10 rewritten
   procedure SetWordInfoLength(NewLength : Integer);
@@ -17266,8 +17304,8 @@ begin
   else
     Canvas.FillRect(CR);
   {$IFDEF IP_LAZARUS_DBG}
-  DebugBox(CR, clYellow);
+  DebugBox(Canvas, CR, clYellow);
-  Debugbox(Canvas.ClipRect,clLime, true);
+  Debugbox(Canvas, Canvas.ClipRect, clLime, true);
   {$ENDIF}
 end;
 
@@ -17288,12 +17326,27 @@ begin
     Printed := False;
     ScaleBitmaps := True;
     GetRelativeAspect(Printer.Canvas.Handle);
+    {$IF DEFINED(IP_LAZARUS) AND NOT DEFINED(WINDOWS)}
+    // this test looks weird, according to most references consulted, the number
+    // of colors in a display is NColors = 1 shl (bitsPerPixel * Planes). A mono
+    // printer should have 2 colors, somebody else needs to clarify.
+    BWPrinter := false;
+    {$ELSE}
     BWPrinter := GetDeviceCaps(Printer.Canvas.Handle, PLANES) = 1;
+    {$ENDIF}
+    {$IFDEF IP_LAZARUS}
+    LogPixX := Printer.XDPI;
+    {$ELSE}
     LogPixX := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSX);
+    {$ENDIF}
     LMarginPix := round(HtmlPanel.PrintSettings.MarginLeft * LogPixX);
     RMarginPix := round(HtmlPanel.PrintSettings.MarginRight * LogPixX);
     PrintWidth := Printer.PageWidth - LMarginPix - RMarginPix;
+    {$IFDEF IP_LAZARUS}
+    LogPixY := Printer.YDPI;
+    {$ELSE}
     LogPixY := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);
+    {$ENDIF}
     TMarginPix := round(HtmlPanel.PrintSettings.MarginTop * LogPixY);
     BMarginPix := round(HtmlPanel.PrintSettings.MarginBottom * LogPixY);
     PrintHeight := Printer.PageHeight - TMarginPix - BMarginPix;

lcl/graphics.pp

@@ -955,6 +955,12 @@ type
     amOff       // disabled
   );
 
+  TLCLTextMetric = record
+    Ascender: Integer;
+    Descender: Integer;
+    Height: Integer;
+  end;
+
   { TCanvas }
 
   TCanvas = class(TFPCustomCanvas)
@@ -1083,6 +1089,7 @@ type
     procedure Frame(X1,Y1,X2,Y2: Integer);     // border using pen
     procedure FrameRect(const ARect: TRect); virtual; // border using brush
     procedure FrameRect(X1,Y1,X2,Y2: Integer); // border using brush
+    function  GetTextMetrics(out TM: TLCLTextMetric): boolean; virtual;
     procedure GradientFill(ARect: TRect; AStart, AStop: TColor; ADirection: TGradientDirection);
     procedure RadialPie(x1, y1, x2, y2,
                         StartAngle16Deg, Angle16DegLength: Integer); virtual;

lcl/include/canvas.inc

@@ -1003,6 +1003,20 @@ begin
   FrameRect(Rect(X1, Y1, X2, Y2));
 end;
 
+function TCanvas.GetTextMetrics(out TM: TLCLTextMetric): boolean;
+var
+  TTM: TTextMetric;
+begin
+  RequiredState([csHandleValid]);
+  Fillchar(TM, SizeOf(TM), 0);
+  Result := LCLIntf.GetTextMetrics(FHandle, TTM);
+  if Result then begin
+    TM.Ascender := TTM.tmAscent;
+    TM.Descender := TTM.tmDescent;
+    TM.Height := TTM.tmHeight;
+  end;
+end;
+
 {------------------------------------------------------------------------------
   Method:   TCanvas.Rectangle
   Params:   X1,Y1,X2,Y2

lcl/postscriptcanvas.pas

@@ -107,6 +107,9 @@ Type
     procedure RestoreClip;
     procedure SaveClip;
     procedure CheckLastPos;
+    function  GetFontIndex: Integer;
+    function  FontUnitsToPixelsX(const Value:Integer): Integer;
+    function  FontUnitsToPixelsY(const Value:Integer): Integer;
   protected
     procedure CreateHandle; override;
     procedure CreateBrush; override;
@@ -164,6 +167,7 @@ Type
     procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); override;
     procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); override;
 
+    function  GetTextMetrics(out TM: TLCLTextMetric): boolean; override;
 
     //** Methods not definined on PostScript
     procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); override;
@@ -197,6 +201,7 @@ Type
   TFontsWidths = Array[32..255] of Integer;
   TFontPSMetrics = Record
     Name   : string;
+    ULPos, ULThickness, Ascender, Descender: Integer;
     Widths : TFontsWidths;
   end;
 
@@ -209,6 +214,7 @@ Const
 
   cFontPSMetrics : Array[0..12] of TFontPSMetrics =(
     (Name  : 'Courier';
+     ULPos : -100; ULThickness : 50; Ascender : 604; Descender : -186;
      Widths:  (600, 600, 600, 600, 600, 600, 600, 600,
                600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
                600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
@@ -234,6 +240,7 @@ Const
                600, 600, 600, 600, 600, 600)
      ),
     (Name  : 'Courier-Bold';
+     ULPos : -100; ULThickness : 50; Ascender : 624; Descender : -205;
      Widths:  (600, 600, 600, 600, 600, 600, 600, 600,
                600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
                600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
@@ -259,6 +266,7 @@ Const
                600, 600, 600, 600, 600, 600)
      ),
     (Name  : 'Courier-Oblique';
+     ULPos : -100; ULThickness : 50; Ascender : 604; Descender : -186;
      Widths:  (600, 600, 600, 600, 600, 600, 600, 600,
                600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
                600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
@@ -284,6 +292,7 @@ Const
                600, 600, 600, 600, 600, 600)
      ),
     (Name  : 'Courier-BoldOblique';
+     ULPos : -100; ULThickness : 50; Ascender : 624; Descender : -205;
      Widths:  (600, 600, 600, 600, 600, 600, 600, 600,
                600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
                600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
@@ -309,6 +318,7 @@ Const
                600, 600, 600, 600, 600, 600)
      ),
     (Name  : 'Helvetica';
+     ULPos : -151; ULThickness : 50; Ascender : 729; Descender : -218;
      Widths:  (278, 278, 355, 556, 556, 889, 667, 191,
                333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
                556, 556, 556, 556, 556, 556, 556, 556, 278, 278,
@@ -334,6 +344,7 @@ Const
                556, 556, 556, 500, 556, 500)
      ),
     (Name  : 'Helvetica-Bold';
+     ULPos : -155; ULThickness : 69; Ascender : 729; Descender : -218;
      Widths: (278, 333, 474, 556, 556, 889, 722, 238,
               333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
               556, 556, 556, 556, 556, 556, 556, 556, 333, 333,
@@ -359,6 +370,7 @@ Const
               611, 611, 611, 556, 611, 556)
     ),
     (Name  : 'Helvetica-Oblique';
+     ULPos : -151; ULThickness : 50; Ascender : 729; Descender : -213;
      Widths: (278, 278, 355, 556, 556, 889, 667, 191,
               333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
               556, 556, 556, 556, 556, 556, 556, 556, 278, 278,
@@ -384,6 +396,7 @@ Const
               556, 556, 556, 500, 556, 500)
     ),
    (Name  : 'Helvetica-BoldOblique';
+    ULPos : -111; ULThickness : 69; Ascender : 729; Descender : -218;
     Widths: (278, 333, 474, 556, 556, 889, 722, 238,
              333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
              556, 556, 556, 556, 556, 556, 556, 556, 333, 333,
@@ -409,6 +422,7 @@ Const
              611, 611, 611, 556, 611, 556)
     ),
    (Name  : 'Times-Roman';
+    ULPos : -100; ULThickness : 50; Ascender : 683; Descender : -217;
     Widths: (250, 333, 408, 500, 500, 833, 778, 180,
              333, 333, 500, 564, 250, 333, 250, 278, 500, 500,
              500, 500, 500, 500, 500, 500, 500, 500, 278, 278,
@@ -434,6 +448,7 @@ Const
              500, 500, 500, 500, 500, 500)
    ),
   (Name  : 'Times-Bold';
+   ULPos : -100; ULThickness : 50; Ascender : 676; Descender : -205;
    Widths: (250, 333, 555, 500, 500, 1000, 833, 278,
             333, 333, 500, 570, 250, 333, 250, 278, 500, 500,
             500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
@@ -459,6 +474,7 @@ Const
             556, 556, 556, 500, 556, 500)
    ),
   (Name  : 'Times-Italic';
+   ULPos : -100; ULThickness : 50; Ascender : 683; Descender : -205;
    Widths: (250, 333, 420, 500, 500, 833, 778, 214,
             333, 333, 500, 675, 250, 333, 250, 278, 500, 500,
             500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
@@ -484,6 +500,7 @@ Const
             500, 500, 500, 444, 500, 444)
    ),
   (Name  : 'Times-BoldItalic';
+   ULPos : -100; ULThickness : 50; Ascender : 699; Descender : -205;
    Widths: (250, 389, 555, 500, 500, 833, 778, 278,
             333, 333, 500, 570, 250, 333, 250, 278, 500, 500,
             500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
@@ -509,6 +526,7 @@ Const
             556, 556, 556, 444, 500, 444)
    ),
   (Name  : 'Symbol';
+   ULPos : -229; ULThickness : 46; Ascender : 673; Descender : -222;
    Widths: (250,333,713,500,549,833,778,439,
             333,333,500,549,250,549,250,278,500,500,
             500,500,500,500,500,500,500,500,278,278,
@@ -860,7 +878,7 @@ function TPostScriptPrinterCanvas.MappedFontName: string;
 Var Atr : string;
 begin
   Atr:='';
-  Result:='Helvetica';
+  Result := '';
   if Copy(LowerCase(Font.Name),1,5)='times' then
     Result:='Times';
   if (LowerCase(Font.Name)='monospaced') or (Copy(LowerCase(Font.Name),1,7)='courier') then
@@ -872,6 +890,9 @@ begin
   if LowerCase(Font.Name)='symbol' then
     Result:='Symbol';
 
+  if Result='' then
+    Result:='Helvetica';
+
   if (fsBold in Font.Style)  and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1) or (Pos('Times',Result)=1)) then
     Atr:=Atr+'Bold';
   if (fsItalic in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1)) then
@@ -1089,6 +1110,35 @@ begin
     MoveToLastPos;
 end;
 
+function TPostScriptPrinterCanvas.GetFontIndex: Integer;
+var
+  FontName: string;
+  i: Integer;
+begin
+  FontName:=MappedFontName;
+  Result:=0; //By default, use Courier metrics
+  for i:=0 to High(cFontPSMetrics) do
+  begin
+    if cFontPSMetrics[i].Name=FontName then
+    begin
+      Result:=i;
+      Break;
+    end;
+  end;
+end;
+
+function TPostScriptPrinterCanvas.FontUnitsToPixelsX(const Value: Integer
+  ): Integer;
+begin
+  result := Round(Value*Abs(GetFontSize/72)*0.001*XDPI);
+end;
+
+function TPostScriptPrinterCanvas.FontUnitsToPixelsY(const Value: Integer
+  ): Integer;
+begin
+  result := Round(Value*Abs(GetFontSize/72)*0.001*YDPI);
+end;
+
 procedure TPostScriptPrinterCanvas.CreateHandle;
 begin
   SetHandle(1); // set dummy handle
@@ -2024,9 +2074,9 @@ begin
 end;
 
 function TPostScriptPrinterCanvas.TextExtent(const Text: string): TSize;
-var IndexFont,i : Integer;
+var
-    FontName    : string;
+  IndexFont,i : Integer;
-    c: Char;
+  c: Char;
 begin
   Result.cX := 0;
   Result.cY := 0;
@@ -2034,24 +2084,14 @@ begin
   RequiredState([csHandleValid, csFontValid]);
   Result.cY:=round((Abs(GetFontSize)/72)*YDPI); // points to inches and then to pixels
   // Abs is not right - should also take internal leading into account
-  FontName:=MappedFontName;
+  IndexFont := GetFontIndex;
-  IndexFont:=0; //By default, use Courier metrics
-  for i:=0 to High(cFontPSMetrics) do
-  begin
-    if cFontPSMetrics[i].Name=FontName then
-    begin
-      IndexFont:=i;
-      Break;
-    end;
-  end;
-
   for i:=1 to Length(Text) do
   begin
     c:=Text[i];
     if (c in [#32..#255]) then
       Inc(Result.cX,cFontPSMetrics[IndexFont].Widths[Ord(c)]);
   end;
-  Result.cX:=Round(Result.cX*Abs(GetFontSize/72)*0.001*XDPI);
+  Result.cX:=FontUnitsToPixelsX(Result.cX);
 end;
 
 //Draw an Picture
@@ -2126,6 +2166,20 @@ begin
   Changed;
 end;
 
+function TPostScriptPrinterCanvas.GetTextMetrics(out TM: TLCLTextMetric): boolean;
+var
+  FontIndex: Integer;
+begin
+  FontIndex := GetFontIndex;
+  Result := FontIndex>=0;
+  if Result then
+  with CFontPSMetrics[FontIndex] do begin
+    TM.Ascender := FontUnitsToPixelsY( Ascender );
+    TM.Descender := FontUnitsToPixelsY( -Descender );
+    TM.Height := TM.Ascender + TM.Descender;
+  end;
+end;
+
 procedure TPostScriptPrinterCanvas.Arc(x, y, Right, Bottom, SX, SY, EX,
   EY: Integer);
 begin