1{%MainUnit ../graphics.pp} 2{****************************************************************************** 3 TFONT 4 ****************************************************************************** 5 6 ***************************************************************************** 7 This file is part of the Lazarus Component Library (LCL) 8 9 See the file COPYING.modifiedLGPL.txt, included in this distribution, 10 for details about the license. 11 ***************************************************************************** 12} 13 14 15{ TFontHandleCache } 16 17type 18 TLogFontAndName = record 19 LogFont: TLogFont; 20 LongFontName: string; 21 end; 22 PLogFontAndName = ^TLogFontAndName; 23 24function CompareLogFontAndNameWithResDesc(Key: PLogFontAndName; Desc: TFontHandleCacheDescriptor): integer; 25begin 26 Result := CompareStr(Key^.LongFontName, Desc.LongFontName); 27 //debugln('CompareLogFontAndNameWithResDesc A ',Key^.LongFontName,' ',Desc.LongFontName,' ',DbgS(Desc),' Result=',Result); 28 if Result = 0 then 29 Result := CompareMemRange(@Key^.LogFont, @Desc.LogFont, SizeOf(Desc.LogFont)); 30 //debugln('CompareLogFontAndNameWithResDesc END Result=',Result); 31end; 32 33procedure TFontHandleCache.RemoveItem(Item: TResourceCacheItem); 34begin 35 DeleteObject(HGDIOBJ(Item.Handle)); 36 inherited RemoveItem(Item); 37end; 38 39constructor TFontHandleCache.Create; 40begin 41 inherited Create; 42 FResourceCacheDescriptorClass := TFontHandleCacheDescriptor; 43end; 44 45function TFontHandleCache.CompareDescriptors(Tree: TAvlTree; Desc1, 46 Desc2: Pointer): integer; 47var 48 Descriptor1: TFontHandleCacheDescriptor absolute Desc1; 49 Descriptor2: TFontHandleCacheDescriptor absolute Desc2; 50begin 51 Result := CompareStr(Descriptor1.LongFontName, Descriptor2.LongFontName); 52 if Result <> 0 then 53 Exit; 54 Result := CompareMemRange(@Descriptor1.LogFont, @Descriptor2.LogFont, 55 SizeOf(Descriptor1.LogFont)); 56end; 57 58function TFontHandleCache.FindFont(TheFont: TLCLHandle): TResourceCacheItem; 59var 60 ANode: TAvlTreeNode; 61begin 62 ANode := FItems.FindKey(@TheFont, 63 TListSortCompare(@ComparePHandleWithResourceCacheItem)); 64 if ANode <> nil then 65 Result := TResourceCacheItem(ANode.Data) 66 else 67 Result := nil; 68end; 69 70function TFontHandleCache.FindFontDesc(const LogFont: TLogFont; 71 const LongFontName: string): TFontHandleCacheDescriptor; 72var 73 LogFontAndName: TLogFontAndName; 74 ANode: TAvlTreeNode; 75begin 76 LogFontAndName.LogFont := LogFont; 77 LogFontAndName.LongFontName := LongFontName; 78 ANode := FDescriptors.Findkey(@LogFontAndName, 79 TListSortCompare(@CompareLogFontAndNameWithResDesc)); 80 if ANode <> nil then 81 Result := TFontHandleCacheDescriptor(ANode.Data) 82 else 83 Result := nil; 84end; 85 86function TFontHandleCache.Add(TheFont: TLCLHandle; const LogFont: TLogFont; 87 const LongFontName: string): TFontHandleCacheDescriptor; 88var 89 Item: TResourceCacheItem; 90begin 91 if FindFontDesc(LogFont, LongFontName) <> nil then 92 RaiseGDBException('TFontHandleCache.Add font desc added twice'); 93 94 // find cache item with TheFont 95 Item := FindFont(TheFont); 96 if Item = nil then 97 begin 98 // create new item 99 Item := TResourceCacheItem.Create(Self, TheFont); 100 FItems.Add(Item); 101 end; 102 103 // create descriptor 104 Result := TFontHandleCacheDescriptor.Create(Self, Item); 105 Result.LongFontName := LongFontName; 106 Result.LogFont := LogFont; 107 FDescriptors.Add(Result); 108 if FindFontDesc(LogFont, LongFontName) = nil then 109 begin 110 DebugLn('TFontHandleCache.Add Added: %p LongFontName=%s', [Pointer(Result), Result.LongFontName]); 111 RaiseGDBException(''); 112 end; 113end; 114 115{ TFont } 116 117procedure GetCharsetValues(Proc: TGetStrProc); 118var 119 I: Integer; 120begin 121 for I := Low(FontCharsets) to High(FontCharsets) do 122 Proc(FontCharsets[I].Name); 123end; 124 125function CharsetToIdent(Charset: Longint; out Ident: string): Boolean; 126begin 127 Result := IntToIdent(Charset, Ident, FontCharsets); 128end; 129 130function IdentToCharset(const Ident: string; out Charset: Longint): Boolean; 131begin 132 Result := IdentToInt(Ident, CharSet, FontCharsets); 133end; 134 135function GetFontData(Font: HFont): TFontData; 136var 137 ALogFont: TLogFont; 138begin 139 Result := DefFontData; 140 if Font <> 0 then 141 begin 142 if GetObject(Font, SizeOf(ALogFont), @ALogFont) <> 0 then 143 with Result, ALogFont do 144 begin 145 Height := lfHeight; 146 if lfWeight >= FW_BOLD then 147 Include(Style, fsBold); 148 if lfItalic > 0 then 149 Include(Style, fsItalic); 150 if lfUnderline > 0 then 151 Include(Style, fsUnderline); 152 if lfStrikeOut > 0 then 153 Include(Style, fsStrikeOut); 154 Charset := TFontCharset(lfCharSet); 155 Name := lfFaceName; 156 case lfPitchAndFamily and $F of 157 VARIABLE_PITCH: Pitch := fpVariable; 158 FIXED_PITCH: Pitch := fpFixed; 159 else 160 Pitch := fpDefault; 161 end; 162 Orientation := lfOrientation; 163 Handle := Font; 164 end; 165 end; 166end; 167 168function GetDefFontCharSet: TFontCharSet; 169begin 170 Result := DEFAULT_CHARSET; 171end; 172 173{------------------------------------------------------------------------------ 174 function: FindXLFDItem 175 Params: const XLFDName: string; Index: integer; 176 var ItemStart, ItemEnd: integer 177 Returns: boolean 178 179 Searches the XLFD item on position Index. Index starts from 0. 180 Returns true on sucess. 181 ItemStart will be on the first character and ItemEnd after the last character. 182 ------------------------------------------------------------------------------} 183function FindXLFDItem(const XLFDName: string; Index: integer; 184 var ItemStart, ItemEnd: integer): boolean; 185begin 186 if Index<0 then 187 begin 188 Result := False; 189 exit; 190 end; 191 ItemStart := 1; 192 ItemEnd := ItemStart; 193 while true do 194 begin 195 if (ItemEnd>length(XLFDName)) then 196 begin 197 dec(Index); 198 break; 199 end; 200 if XLFDName[ItemEnd] = '-' then 201 begin 202 dec(Index); 203 if Index < 0 then break; 204 ItemStart := ItemEnd + 1; 205 end; 206 inc(ItemEnd); 207 end; 208 Result := (Index = -1); 209end; 210 211{------------------------------------------------------------------------------ 212 function: ExtractXLFDItem 213 Params: const XLFDName: string; Index: integer 214 Returns: string 215 216 Parses a font name in XLFD format and extracts one item. 217 (see http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html) 218 219 An XLFD name is 220 FontNameRegistry-Foundry-FamilyName-WeightName-Slant-SetwidthName 221 -AddStyleName-PixelSize-PointSize-ResolutionX-ResolutionY-Spacing 222 -AverageWidth-CharSetRegistry-CharSetCoding 223 224 ------------------------------------------------------------------------------} 225function ExtractXLFDItem(const XLFDName: string; Index: integer): string; 226var StartPos, EndPos: integer; 227begin 228 if FindXLFDItem(XLFDName, Index, StartPos, EndPos) then 229 Result := copy(XLFDName, StartPos, EndPos - StartPos) 230 else 231 Result := ''; 232end; 233 234{------------------------------------------------------------------------------ 235 function: ExtractFamilyFromXLFDName 236 Params: const XLFDName: string 237 Returns: string 238 239 Parses a font name in XLFD format and extracts the FamilyName. 240 (see http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html) 241 242 An XLFD name is 243 FontNameRegistry-Foundry-FamilyName-WeightName-Slant-SetwidthName 244 -AddStyleName-PixelSize-PointSize-ResolutionX-ResolutionY-Spacing 245 -AverageWidth-CharSetRegistry-CharSetCoding 246 247 ------------------------------------------------------------------------------} 248function ExtractFamilyFromXLFDName(const XLFDName: string): string; 249var StartPos, EndPos: integer; 250begin 251 if FindXLFDItem(XLFDName, 2, StartPos, EndPos) then 252 Result:=copy(XLFDName, StartPos, EndPos - StartPos) 253 else 254 Result := ''; 255end; 256 257{------------------------------------------------------------------------------ 258 Method: XLFDNameToLogFont 259 Params: const XLFDName: string 260 Returns: TLogFont 261 262 Parses a font name in XLFD format and creates a TLogFont record from it. 263 (see http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html) 264 265 An XLFD name is 266 FontNameRegistry-Foundry-FamilyName-WeightName-Slant-SetwidthName 267 -AddStyleName-PixelSize-PointSize-ResolutionX-ResolutionY-Spacing 268 -AverageWidth-CharSetRegistry-CharSetCoding 269 270 ------------------------------------------------------------------------------} 271function XLFDNameToLogFont(const XLFDName: string): TLogFont; 272type 273 TWeightMapEntry = record 274 Name: string; 275 Weight: integer; 276 end; 277const 278 WeightMap: array[1..15] of TWeightMapEntry = ( 279 (Name: 'DONTCARE'; Weight: FW_DONTCARE), 280 (Name: 'THIN'; Weight: FW_THIN), 281 (Name: 'EXTRALIGHT'; Weight: FW_EXTRALIGHT), 282 (Name: 'LIGHT'; Weight: FW_LIGHT), 283 (Name: 'NORMAL'; Weight: FW_NORMAL), 284 (Name: 'MEDIUM'; Weight: FW_MEDIUM), 285 (Name: 'SEMIBOLD'; Weight: FW_SEMIBOLD), 286 (Name: 'BOLD'; Weight: FW_BOLD), 287 (Name: 'EXTRABOLD'; Weight: FW_EXTRABOLD), 288 (Name: 'HEAVY'; Weight: FW_HEAVY), 289 (Name: 'ULTRALIGHT'; Weight: FW_ULTRALIGHT), 290 (Name: 'REGULAR'; Weight: FW_REGULAR), 291 (Name: 'DEMIBOLD'; Weight: FW_DEMIBOLD), 292 (Name: 'ULTRABOLD'; Weight: FW_ULTRABOLD), 293 (Name: 'BLACK'; Weight: FW_BLACK) 294 ); 295var 296 ItemStart, ItemEnd: integer; 297 Item: string; 298 299 procedure GetNextItem; 300 begin 301 ItemStart:=ItemEnd+1; 302 ItemEnd:=ItemStart; 303 while (ItemEnd<=length(XLFDName)) and (XLFDName[ItemEnd]<>'-') do 304 inc(ItemEnd); 305 Item:=copy(XLFDName,ItemStart,ItemEnd-ItemStart); 306 end; 307 308 function WeightNameToWeightID(const WeightName: string): integer; 309 var i: integer; 310 begin 311 for i:=Low(WeightMap) to High(WeightMap) do begin 312 if AnsiCompareText(WeightMap[i].Name,WeightName)=0 then begin 313 Result:=WeightMap[i].Weight; 314 exit; 315 end; 316 end; 317 Result:=FW_DONTCARE; 318 end; 319 320var l, FaceNameMax, PixelSize, PointSize, Resolution, AverageWidth: integer; 321begin 322 FillChar(Result,SizeOf(TLogFont),0); 323 ItemEnd:=0; 324 GetNextItem; // 1. read FontNameRegistry 325 // ToDo 326 327 GetNextItem; // 2. read Foundry 328 // ToDo 329 330 GetNextItem; // 3. read FamilyName 331 l:=length(Item); 332 FaceNameMax:=High(Result.lfFaceName)-Low(Result.lfFaceName); // max without #0 333 if l>FaceNameMax then l:=FaceNameMax; 334 if l>0 then Move(Item[1],Result.lfFaceName[Low(Result.lfFaceName)],l); 335 Result.lfFaceName[Low(Result.lfFaceName)+l]:=#0; 336 337 GetNextItem; // 4. read WeightName 338 Result.lfWeight:=WeightNameToWeightID(Item); 339 340 GetNextItem; // 5. read Slant 341 if (AnsiCompareText(Item,'I')=0) or (AnsiCompareText(Item,'RI')=0) 342 or (AnsiCompareText(Item,'O')=0) then 343 // I = italic, RI = reverse italic, O = oblique 344 Result.lfItalic:=1 345 else 346 Result.lfItalic:=0; 347 348 GetNextItem; // 6. read SetwidthName 349 // ToDO: NORMAL, CONDENSED, NARROW, WIDE, EXPANDED 350 351 GetNextItem; // 7. read AddStyleName 352 // calculate Style name extensions (=rotation) 353 // API XLFD 354 // --------------------- -------------- 355 // Orientation 1/10 deg 1/64 deg 356 Result.lfOrientation:=(StrToIntDef(Item,0)*10) div 64; 357 358 GetNextItem; // 8. read PixelSize 359 PixelSize:=StrToIntDef(Item,0); 360 GetNextItem; // 9. read PointSize 361 PointSize:=StrToIntDef(Item,0) div 10; 362 GetNextItem; // 10. read ResolutionX 363 Resolution:=StrToIntDef(Item,0); 364 if Resolution<=0 then Resolution:=72; 365 366 if PixelSize=0 then begin 367 if PointSize<=0 then 368 Result.lfHeight:=(12*Resolution) div 72 369 else 370 Result.lfHeight:=(PointSize*Resolution) div 72; 371 end else begin 372 Result.lfHeight:=PixelSize; 373 end; 374 375 GetNextItem; // 11. read ResolutionY 376 Resolution:=StrToIntDef(Item,0); 377 if Resolution<=0 then Resolution:=72; 378 379 GetNextItem; // 12. read Spacing 380 {M Monospaced (fixed pitch) 381 P Proportional spaced (variable pitch) 382 C Character cell. The glyphs of the font can be thought of as 383 "boxes" of the same width and height that are stacked side by 384 side or top to bottom.} 385 if AnsiCompareText(Item,'M')=0 then 386 Result.lfPitchAndFamily:=FIXED_PITCH 387 else if AnsiCompareText(Item,'P')=0 then 388 Result.lfPitchAndFamily:=VARIABLE_PITCH 389 else if AnsiCompareText(Item,'C')=0 then 390 Result.lfPitchAndFamily:=FIXED_PITCH; 391 392 GetNextItem; // 13. read AverageWidth 393 AverageWidth := StrToIntDef(Item,0); 394 Result.lfWidth := AverageWidth div 10; 395 396 GetNextItem; // 14. read CharSetRegistry 397 // ToDo 398 399 GetNextItem; // 15. read CharSetCoding 400 // ToDo 401 402end; 403 404{------------------------------------------------------------------------------ 405 function: ClearXLFDItem 406 Params: const LongFontName: string; Index: integer 407 Returns: string 408 409 Replaces an item of a font name in XLFD format with a '*'. 410 ------------------------------------------------------------------------------} 411function ClearXLFDItem(const LongFontName: string; Index: integer): string; 412var ItemStart, ItemEnd: integer; 413begin 414 if FindXLFDItem(LongFontName,Index,ItemStart,ItemEnd) 415 and ((ItemEnd-ItemStart<>1) or (LongFontName[ItemStart]<>'*')) then 416 Result:=LeftStr(LongFontName,ItemStart-1)+'*' 417 +RightStr(LongFontName,length(LongFontName)-ItemEnd+1) 418 else 419 Result:=LongFontName; 420end; 421 422{------------------------------------------------------------------------------ 423 function: ClearXLFDHeight 424 Params: const LongFontName: string 425 Returns: string 426 427 Replaces the PixelSize, PointSize, ResolutionX, ResolutionY and AverageWidth 428 of a font name in XLFD format with '*'. 429 430 An XLFD name is 431 FontNameRegistry-Foundry-FamilyName-WeightName-Slant-SetwidthName 432 -AddStyleName-PixelSize-PointSize-ResolutionX-ResolutionY-Spacing 433 -AverageWidth-CharSetRegistry-CharSetCoding 434 ------------------------------------------------------------------------------} 435function ClearXLFDHeight(const LongFontName: string): string; 436begin 437 Result:=ClearXLFDItem(LongFontName,7); // PixelSize 438 Result:=ClearXLFDItem(Result,8); // PointSize 439 Result:=ClearXLFDItem(Result,9); // ResolutionX 440 Result:=ClearXLFDItem(Result,10); // ResolutionY 441 Result:=ClearXLFDItem(Result,12); // AverageWidth 442end; 443 444{------------------------------------------------------------------------------ 445 function: ClearXLFDPitch 446 Params: const LongFontName: string 447 Returns: string 448 449 Replaces the spacing a font name in XLFD format with a '*'. 450 ------------------------------------------------------------------------------} 451function ClearXLFDPitch(const LongFontName: string): string; 452begin 453 Result:=ClearXLFDItem(LongFontName,11); 454end; 455 456{------------------------------------------------------------------------------ 457 function: ClearXLFDStyle 458 Params: const LongFontName: string 459 Returns: string 460 461 Replaces the WeightName, Slant and SetwidthName of a font name in XLFD format 462 with '*'. 463 ------------------------------------------------------------------------------} 464function ClearXLFDStyle(const LongFontName: string): string; 465begin 466 Result:=ClearXLFDItem(ClearXLFDItem(ClearXLFDItem(LongFontName,3),4),5); 467end; 468 469function XLFDHeightIsSet(const LongFontName: string): boolean; 470begin 471 Result:=(ExtractXLFDItem(LongFontName,7)<>'') 472 or (ExtractXLFDItem(LongFontName,8)<>'') 473 or (ExtractXLFDItem(LongFontName,9)<>'') 474 or (ExtractXLFDItem(LongFontName,10)<>''); 475end; 476 477{------------------------------------------------------------------------------ 478 function: IsFontNameXLogicalFontDesc 479 Params: const LongFontName: string 480 Returns: boolean 481 482 Checks if font name is in X Logical Font Description format. 483 (see http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html) 484 485 An XLFD name is 486 FontNameRegistry-Foundry-FamilyName-WeightName-Slant-SetwidthName 487 -AddStyleName-PixelSize-PointSize-ResolutionX-ResolutionY-Spacing 488 -AverageWidth-CharSetRegistry-CharSetCoding 489 ------------------------------------------------------------------------------} 490function IsFontNameXLogicalFontDesc(const LongFontName: string): boolean; 491// Quick test: check if LongFontName contains 14 times the char '-' 492var MinusCnt, p: integer; 493begin 494 MinusCnt:=0; 495 for p:=1 to length(LongFontName) do 496 if LongFontName[p]='-' then inc(MinusCnt); 497 Result:=(MinusCnt=14); 498end; 499 500// split a given fontName into Pango Font description components 501// font name is supposed to follow this layout: 502// [FAMILY-LIST][STYLE-LIST][SIZE] 503// where: 504// [FAMILY-LIST] is a comma separated list of families optionally 505// ended by a comma 506// [STYLE-LIST] is white space separated list of words where each word 507// describe one of style, variant, slant, weight or stretch 508// [SIZE] is a decimal number (size in points) (... and points in PANGO_UNITS) 509// any of these options may be absent. 510procedure FontNameToPangoFontDescStr(const LongFontName: string; 511 out aFamily,aStyle: string; out aSize: Integer; out aSizeInPixels: Boolean); 512 513var 514 ParsePos: Integer; 515 516 procedure addStyle(const s: string); 517 begin 518 if (s<>'') and (s<>'*') and (s<>'r') then begin 519 // 'r' is regular 520 if aStyle<>'' then 521 aStyle := aStyle + ' ' + s 522 else 523 aStyle := s; 524 end; 525 end; 526 527 function GetSize: string; 528 var 529 c: char; 530 ValidBlank, CheckPixelsNeeded: boolean; 531 InitPos: Integer; 532 533 function IsBlank: boolean; 534 begin 535 result := c in [#0..' ']; 536 end; 537 538 function IsDigit: boolean; 539 begin 540 result := c in ['0'..'9']; 541 end; 542 543 begin 544 Result := ''; 545 ValidBlank := True; 546 CheckPixelsNeeded := True; 547 ParsePos := Length(LongFontname); 548 InitPos := ParsePos; 549 while ParsePos>0 do begin 550 c := longFontName[ParsePos]; 551 if IsBlank then 552 if ValidBlank then begin 553 dec(ParsePos); 554 dec(InitPos); 555 continue 556 end else 557 break; 558 ValidBlank := False; 559 if CheckPixelsNeeded then 560 begin 561 CheckPixelsNeeded := False; 562 aSizeInPixels := (ParsePos > 2) and (longFontName[ParsePos - 1] = 'p') 563 and (longFontName[ParsePos] = 'x'); 564 if aSizeInPixels then 565 begin 566 dec(ParsePos, 2); 567 Continue; 568 end; 569 end; 570 if IsDigit then begin 571 Result := C + Result; 572 dec(ParsePos); 573 end else begin 574 if not IsBlank and (C <> ',')then 575 begin 576 Result := ''; 577 ParsePos := InitPos; 578 end; 579 if C = ',' then 580 dec(ParsePos); 581 break; 582 end; 583 end; 584 end; 585 586begin 587 aStyle := ''; 588 aFamily := ''; 589 aSize := 0; 590 aSizeInPixels := False; 591 if IsFontNameXLogicalFontDesc(LongFontName) then begin 592 aFamily := ExtractXLFDItem(LongFontName, XLFD_FAMILY); 593 if aFamily='*' then 594 aFamily:=''; 595 aSize := StrToIntDef(ExtractXLFDItem(LongFontName, XLFD_POINTSIZE),0) div 10; 596 addStyle( ExtractXLFDItem(LongFontName, XLFD_STYLENAME )); 597 addStyle( ExtractXLFDItem(LongFontname, XLFD_WEIGHTNAME)); 598 addStyle( ExtractXLFDItem(LongFontname, XLFD_SLANT)); 599 addStyle( ExtractXLFDItem(LongFontname, XLFD_WidthName)); 600 end else begin 601 // this could go through, but we want to know at least the pointSize from 602 // the fontname 603 aSize := StrToIntDef(GetSize,0); 604 aFamily := Copy(LongFontName, 1, ParsePos); 605 // todo: parse aFamily to separate Family and Style 606 end; 607end; 608 609{ TFont } 610 611{------------------------------------------------------------------------------ 612 Method: TFont.Create 613 Params: none 614 Returns: Nothing 615 616 Constructor for the class. 617 ------------------------------------------------------------------------------} 618constructor TFont.Create; 619begin 620 inherited Create; 621 FColor := {$ifdef UseCLDefault}clDefault{$else}clWindowText{$endif}; 622 FPixelsPerInch := ScreenInfo.PixelsPerInchY; 623 FPitch := DefFontData.Pitch; 624 FCharSet := DefFontData.CharSet; 625 FQuality := DefFontData.Quality; 626 FHeight := DefFontData.Height; 627 FStyle := DefFontData.Style; 628 inherited SetSize(-MulDiv(FHeight, 72, FPixelsPerInch)); 629 DelayAllocate := True; 630 inherited SetName(DefFontData.Name); 631 inherited SetFPColor(colBlack); 632end; 633 634{------------------------------------------------------------------------------ 635 Method: TFont.Assign 636 Params: Source: Another font 637 Returns: nothing 638 639 Copies the Source font to itself 640 ------------------------------------------------------------------------------} 641procedure TFont.Assign(Source: TPersistent); 642begin 643 if Source is TFont then 644 begin 645 //TODO:lock; 646 try 647 //TODO: TFont(Source).Lock; 648 try 649 BeginUpdate; 650 try 651 CharSet := TFont(Source).CharSet; 652 SetColor(TFont(Source).Color, TFPCanvasHelper(Source).FPColor); 653 if TFont(Source).PixelsPerInch <> FPixelsPerInch then 654 // use size to convert source height pixels to current resolution 655 Size := TFont(Source).Size 656 else 657 // use height which users could have changed directly 658 Height := TFont(Source).Height; 659 Name := TFont(Source).Name; 660 Orientation := TFont(Source).Orientation; 661 Pitch := TFont(Source).Pitch; 662 Style := TFont(Source).Style; 663 Quality := TFont(Source).Quality; 664 finally 665 EndUpdate; 666 end; 667 finally 668 //TODO: TFont(Source).UnLock; 669 end; 670 finally 671 //TODO: UnLock; 672 end; 673 Exit; 674 end; 675 676 inherited Assign(Source); 677end; 678 679{------------------------------------------------------------------------------ 680 Method: TFont.Assign 681 Params: ALogFont: TLogFont 682 Returns: nothing 683 684 Copies the logfont settings to itself 685 ------------------------------------------------------------------------------} 686procedure TFont.Assign(const ALogFont: TLogFont); 687var 688 AStyle: TFontStyles; 689begin 690 BeginUpdate; 691 try 692 Height := ALogFont.lfHeight; 693 Charset := TFontCharset(ALogFont.lfCharSet); 694 AStyle := []; 695 if ALogFont.lfWeight >= FW_SEMIBOLD then Include(AStyle, fsBold); 696 if ALogFont.lfItalic <> 0 then Include(AStyle, fsItalic); 697 if ALogFont.lfUnderline <> 0 then Include(AStyle, fsUnderline); 698 if ALogFont.lfStrikeOut <> 0 then Include(AStyle, fsStrikeOut); 699 if (FIXED_PITCH and ALogFont.lfPitchAndFamily) <> 0 then 700 Pitch := fpFixed 701 else if (VARIABLE_PITCH and ALogFont.lfPitchAndFamily) <> 0 then 702 Pitch := fpVariable 703 else 704 Pitch := fpDefault; 705 Style := AStyle; 706 Quality := TFontQuality(ALogFont.lfQuality); 707 Name := ALogFont.lfFaceName; 708 finally 709 EndUpdate; 710 end; 711end; 712 713function TFont.IsEqual(AFont: TFont): boolean; 714begin 715 if (AFont = Self) then Exit(true); 716 if (AFont=nil) 717 or (CharSet<>AFont.CharSet) 718 or (Color<>AFont.Color) 719 or (Size<>AFont.Size) 720 or (Height<>AFont.Height) 721 or (Name<>AFont.Name) 722 or (Pitch<>AFont.Pitch) 723 or (Quality<>AFont.Quality) 724 or (Style<>AFont.Style) then 725 Result := False 726 else 727 Result := True; 728end; 729 730procedure TFont.BeginUpdate; 731begin 732 inc(FUpdateCount); 733end; 734 735procedure TFont.EndUpdate; 736begin 737 if FUpdateCount=0 then exit; 738 dec(FUpdateCount); 739 if (FUpdateCount=0) and FChanged then Changed; 740end; 741 742{------------------------------------------------------------------------------ 743 Method: TFont.HandleAllocated 744 Params: none 745 Returns: boolean 746 747 Resturns True on handle allocated. 748 ------------------------------------------------------------------------------} 749function TFont.HandleAllocated: boolean; 750begin 751 Result := FReference.Allocated; 752end; 753 754{------------------------------------------------------------------------------ 755 function TFont.IsDefault: boolean; 756 ------------------------------------------------------------------------------} 757function TFont.IsDefault: boolean; 758begin 759 Result:=(CharSet=DEFAULT_CHARSET) 760 and (Color={$ifdef UseCLDefault}clDefault{$else}clWindowText{$endif}) 761 and (Height=0) 762 and (not IsNameStored) 763 and (Orientation=0) 764 and (Pitch=fpDefault) 765 and (Size=0) 766 and (Quality=fqDefault) 767 and (Style=[]); 768end; 769 770{------------------------------------------------------------------------------ 771 procedure TFont.SetDefault; 772 773 Set Font properties to default. 774 ------------------------------------------------------------------------------} 775procedure TFont.SetDefault; 776begin 777 BeginUpdate; 778 try 779 Name := DefFontData.Name; 780 Charset := DefFontData.CharSet; 781 Height := DefFontData.Height; 782 Pitch := DefFontData.Pitch; 783 Quality := DefFontData.Quality; 784 Style := DefFontData.Style; 785 Color := {$ifdef UseCLDefault}clDefault{$else}clWindowText{$endif}; 786 finally 787 EndUpdate; 788 end; 789end; 790 791{------------------------------------------------------------------------------ 792 Method: TFont.SetSize 793 Params: AValue: the new value 794 Returns: nothing 795 796 ------------------------------------------------------------------------------} 797procedure TFont.SetSize(AValue: Integer); 798begin 799 if Size <> AValue then 800 begin 801 BeginUpdate; 802 try 803 FreeReference; 804 inherited SetSize(AValue); 805 FHeight := -MulDiv(AValue, FPixelsPerInch, 72); 806 if IsFontNameXLogicalFontDesc(Name) then 807 Name := ClearXLFDHeight(Name); 808 Changed; 809 finally 810 EndUpdate; 811 end; 812 end; 813end; 814 815{------------------------------------------------------------------------------ 816 Function: TFont.GetSize 817 Params: none 818 Returns: The font size 819 820 Calculates the size based on height 821 ------------------------------------------------------------------------------} 822function TFont.GetSize: Integer; 823begin 824 Result := inherited Size; 825end; 826 827{------------------------------------------------------------------------------ 828 Method: TFont.SetPitch 829 Params: Value: the new value 830 Returns: nothing 831 832 Sets the pitch of a font 833 ------------------------------------------------------------------------------} 834procedure TFont.SetPitch(Value : TFontPitch); 835Begin 836 if FPitch <> Value then 837 begin 838 BeginUpdate; 839 FreeReference; 840 FPitch := Value; 841 if IsFontNameXLogicalFontDesc(Name) then 842 Name := ClearXLFDPitch(Name); 843 Changed; 844 EndUpdate; 845 end; 846end; 847 848procedure TFont.SetPixelsPerInch(const APixelsPerInch: Integer); 849var 850 OldPPI: Integer; 851begin 852 if FPixelsPerInch = APixelsPerInch then Exit; 853 OldPPI := FPixelsPerInch; 854 FPixelsPerInch := APixelsPerInch; 855 856 // the Height value is not correct anymore -> force recalculate it 857 if Height<>0 then 858 Height := MulDiv(Height, APixelsPerInch, OldPPI); 859 Changed; 860end; 861 862{------------------------------------------------------------------------------ 863 Method: TFont.SetHeight 864 Params: Value: the new value 865 Returns: nothing 866 867 Sets the height of a font 868 ------------------------------------------------------------------------------} 869procedure TFont.SetHeight(AValue: Integer); 870begin 871 // Don't update Size only. The LogFont contains a lfHeight value and on Windows, 872 // Qt and Carbon it is the main parameter which determins the font height. 873 if Height <> AValue then 874 begin 875 BeginUpdate; 876 try 877 FreeReference; 878 FHeight := AValue; 879 // update size to equivalent value 880 inherited SetSize(-MulDiv(AValue, 72, FPixelsPerInch)); 881 if IsFontNameXLogicalFontDesc(Name) then 882 Name := ClearXLFDHeight(Name); 883 Changed; 884 finally 885 EndUpdate; 886 end; 887 end; 888end; 889 890{------------------------------------------------------------------------------ 891 Method: TFont.SetStyle 892 Params: Value: the new value 893 Returns: nothing 894 895 Sets the style of a font 896 ------------------------------------------------------------------------------} 897procedure TFont.SetStyle(value : TFontStyles); 898begin 899 if FStyle <> Value then 900 begin 901 BeginUpdate; 902 FreeReference; 903 FStyle := Value; 904 inherited SetFlags(5, fsBold in FStyle); 905 inherited SetFlags(6, fsItalic in FStyle); 906 inherited SetFlags(7, fsUnderline in FStyle); 907 inherited SetFlags(8, fsStrikeOut in FStyle); 908 if IsFontNameXLogicalFontDesc(Name) then 909 Name := ClearXLFDStyle(Name); 910 Changed; 911 EndUpdate; 912 end; 913end; 914 915{------------------------------------------------------------------------------ 916 Method: TFont.SetColor 917 Params: Value: the new value 918 Returns: nothing 919 920 Sets the pencolor of a font 921 ------------------------------------------------------------------------------} 922procedure TFont.SetColor(Value : TColor); 923begin 924 if FColor <> Value then 925 SetColor(Value, TColorToFPColor(Value)); 926end; 927 928function TFont.GetColor: TColor; 929begin 930 Result := Color; 931 if (Result = clDefault) and (Canvas is TCanvas) then 932 Result := TCanvas(Canvas).GetDefaultColor(dctFont); 933end; 934 935{------------------------------------------------------------------------------ 936 Function: TFont.GetName 937 Params: none 938 Returns: The font name 939 940 Returns the name of the font 941 ------------------------------------------------------------------------------} 942function TFont.GetName: string; 943begin 944 Result := inherited Name; 945end; 946 947{------------------------------------------------------------------------------ 948 Returns the orientation of the font 949 950 The orientation is defined as the angle, in tenths of degrees, 951 between the X axis of the Canvas and the baseline of the font. 952 953 The property and it's setter/getter pair are compatible with Delphi 954 ------------------------------------------------------------------------------} 955function TFont.GetOrientation: Integer; 956begin 957 Result := FOrientation; 958end; 959 960{------------------------------------------------------------------------------ 961 Method: TFont.SetName 962 Params: Value: the new value 963 Returns: nothing 964 965 Sets the name of a font 966 ------------------------------------------------------------------------------} 967procedure TFont.SetName(AValue: string); 968begin 969 if Name <> AValue then 970 begin 971 FreeReference; 972 inherited SetName(AValue); 973 Changed; 974 end; 975end; 976 977{------------------------------------------------------------------------------ 978 Changes the orientation of the font 979 980 The orientation is defined as the angle, in tenths of degrees, 981 between the X axis of the Canvas and the baseline of the font. 982 983 The property and it's setter/getter pair are compatible with Delphi 984 ------------------------------------------------------------------------------} 985procedure TFont.SetOrientation(AValue: Integer); 986begin 987 if FOrientation <> AValue then 988 begin 989 FreeReference; 990 FOrientation := AValue; 991 Changed; 992 end; 993end; 994 995procedure TFont.DoAllocateResources; 996begin 997 inherited DoAllocateResources; 998 GetReference; 999end; 1000 1001procedure TFont.DoDeAllocateResources; 1002begin 1003 FreeReference; 1004 inherited DoDeAllocateResources; 1005end; 1006 1007procedure TFont.DoCopyProps(From: TFPCanvasHelper); 1008var 1009 SrcFont: TFont; 1010begin 1011 BeginUpdate; 1012 try 1013 inherited DoCopyProps(From); 1014 if From is TFont then 1015 begin 1016 SrcFont := TFont(From); 1017 Pitch := SrcFont.Pitch; 1018 CharSet := SrcFont.CharSet; 1019 Quality := SrcFont.Quality; 1020 Style := SrcFont.Style; 1021 end; 1022 finally 1023 EndUpdate; 1024 end; 1025end; 1026 1027procedure TFont.SetFlags(Index: integer; AValue: boolean); 1028 1029 procedure SetStyleFlag(Flag: TFontStyle; NewValue: boolean); 1030 begin 1031 BeginUpdate; 1032 FreeReference; 1033 if NewValue then 1034 Include(FStyle, Flag) 1035 else 1036 Exclude(FStyle, Flag); 1037 if IsFontNameXLogicalFontDesc(Name) then 1038 Name := ClearXLFDStyle(Name); 1039 Changed; 1040 EndUpdate; 1041 end; 1042 1043begin 1044 if GetFlags(Index) = AValue then Exit; 1045 inherited SetFlags(Index, AValue); 1046 case Index of 1047 5: SetStyleFlag(fsBold, AValue); 1048 6: SetStyleFlag(fsItalic, AValue); 1049 7: SetStyleFlag(fsUnderline, AValue); 1050 8: SetStyleFlag(fsStrikeOut, AValue); 1051 end; 1052end; 1053 1054{------------------------------------------------------------------------------ 1055 procedure TFont.SetFPColor(const AValue: TFPColor); 1056 1057 Set FPColor and Color 1058 ------------------------------------------------------------------------------} 1059procedure TFont.SetFPColor(const AValue: TFPColor); 1060begin 1061 if FPColor <> AValue then 1062 SetColor(FPColorToTColor(AValue), AValue); 1063end; 1064 1065procedure TFont.SetColor(const NewColor: TColor; const NewFPColor: TFPColor); 1066begin 1067 if (NewColor = Color) and (NewFPColor = FPColor) then Exit; 1068 FColor := NewColor; 1069 inherited SetFPColor(NewFPColor); 1070 Changed; 1071end; 1072 1073{------------------------------------------------------------------------------ 1074 Method: TFont.Destroy 1075 Params: None 1076 Returns: Nothing 1077 1078 Destructor for the class. 1079 ------------------------------------------------------------------------------} 1080destructor TFont.Destroy; 1081begin 1082 FreeReference; 1083 inherited Destroy; 1084end; 1085 1086{------------------------------------------------------------------------------ 1087 Method: TFont.SetHandle 1088 Params: a font handle 1089 Returns: nothing 1090 1091 sets the font to an external created font 1092 ------------------------------------------------------------------------------} 1093procedure TFont.SetHandle(const Value: HFONT); 1094begin 1095 SetData(GetFontData(Value)); 1096end; 1097 1098procedure TFont.ReferenceNeeded; 1099const 1100 LF_BOOL: array[Boolean] of Byte = (0, 255); 1101 LF_WEIGHT: array[Boolean] of Integer = (FW_NORMAL, FW_BOLD); 1102 LF_QUALITY: array[TFontQuality] of Integer = (DEFAULT_QUALITY, 1103 DRAFT_QUALITY, PROOF_QUALITY, NONANTIALIASED_QUALITY, ANTIALIASED_QUALITY, 1104 CLEARTYPE_QUALITY, CLEARTYPE_NATURAL_QUALITY); 1105var 1106 ALogFont: TLogFont; 1107 CachedFont: TFontHandleCacheDescriptor; 1108 1109 procedure SetLogFontName(const NewName: string); 1110 var 1111 l: integer; 1112 aName: string; 1113 begin 1114 if IsFontNameXLogicalFontDesc(NewName) then 1115 aName := ExtractFamilyFromXLFDName(NewName) 1116 else 1117 aName := NewName; 1118 l := High(ALogFont.lfFaceName) - Low(ALogFont.lfFaceName); 1119 if l > length(aName) then 1120 l := length(aName); 1121 if l > 0 then 1122 Move(aName[1], ALogFont.lfFaceName[Low(ALogFont.lfFaceName)], l); 1123 ALogFont.lfFaceName[Low(ALogFont.lfFaceName) + l] := #0; 1124 end; 1125 1126begin 1127 if FReference.Allocated then Exit; 1128 1129 FillChar(ALogFont, SizeOf(ALogFont), 0); 1130 with ALogFont do 1131 begin 1132 lfHeight := Height; 1133 lfWidth := 0; 1134 lfEscapement := FOrientation; 1135 lfOrientation := FOrientation; 1136 lfWeight := LF_WEIGHT[fsBold in Style]; 1137 lfItalic := LF_BOOL[fsItalic in Style]; 1138 lfUnderline := LF_BOOL[fsUnderline in Style]; 1139 lfStrikeOut := LF_BOOL[fsStrikeOut in Style]; 1140 lfCharSet := Byte(FCharset); 1141 SetLogFontName(Name); 1142 1143 lfQuality := LF_QUALITY[FQuality]; 1144 lfOutPrecision := OUT_DEFAULT_PRECIS; 1145 lfClipPrecision := CLIP_DEFAULT_PRECIS; 1146 case Pitch of 1147 fpVariable: lfPitchAndFamily := VARIABLE_PITCH; 1148 fpFixed: lfPitchAndFamily := FIXED_PITCH; 1149 else 1150 lfPitchAndFamily := DEFAULT_PITCH; 1151 end; 1152 end; 1153 FontResourceCache.Lock; 1154 try 1155 // ask the font cache for the nearest font 1156 CachedFont := FontResourceCache.FindFontDesc(ALogFont, Name); 1157 //DebugLn(['TFont.GetHandle in cache: ',CachedFont<>nil]); 1158 if CachedFont <> nil then 1159 begin 1160 CachedFont.Item.IncreaseRefCount; 1161 FReference._lclHandle := CachedFont.Item.Handle; 1162 end else 1163 begin 1164 // ask the interface for the nearest font 1165 FReference._lclHandle := TLCLHandle(CreateFontIndirectEx(ALogFont, Name)); 1166 FontResourceCache.Add(FReference.Handle, ALogFont, Name); 1167 end; 1168 FFontHandleCached := True; 1169 finally 1170 FontResourceCache.Unlock; 1171 end; 1172 FCanUTF8Valid := False; 1173 FIsMonoSpaceValid := False; 1174end; 1175 1176procedure TFont.SetQuality(const AValue: TFontQuality); 1177begin 1178 if FQuality <> AValue then 1179 begin 1180 BeginUpdate; 1181 FreeReference; 1182 FQuality := AValue; 1183 if IsFontNameXLogicalFontDesc(Name) then 1184 Name := ClearXLFDStyle(Name); 1185 Changed; 1186 EndUpdate; 1187 end; 1188end; 1189 1190{------------------------------------------------------------------------------ 1191 Function: TFont.GetHandle 1192 Params: none 1193 Returns: a handle to a font gdiobject 1194 1195 Creates a font if needed 1196 ------------------------------------------------------------------------------} 1197function TFont.GetHandle: HFONT; 1198begin 1199 Result := HFONT(Reference.Handle); 1200end; 1201 1202{------------------------------------------------------------------------------ 1203 Method: TFont.FreeReference 1204 Params: none 1205 Returns: Nothing 1206 1207 Frees a font handle if needed 1208 ------------------------------------------------------------------------------} 1209 1210procedure TFont.FreeReference; 1211begin 1212 if not FReference.Allocated then Exit; 1213 1214 // Changing triggers deselecting the current handle 1215 Changing; 1216 if FFontHandleCached then 1217 begin 1218 if Assigned(FontResourceCache) then 1219 begin 1220 FontResourceCache.Lock; 1221 try 1222 FontResourceCache.FindFont(FReference.Handle).DecreaseRefCount; 1223 FFontHandleCached := False; 1224 finally 1225 FontResourceCache.Unlock; 1226 end; 1227 end; 1228 end else 1229 DeleteObject(HGDIOBJ(FReference.Handle)); 1230 FReference._lclHandle := 0; 1231end; 1232 1233function TFont.GetCanUTF8: boolean; 1234begin 1235 if not FCanUTF8Valid then 1236 begin 1237 FCanUTF8 := {%H-}FontCanUTF8(HFONT(Reference.Handle)); 1238 FCanUTF8Valid := True; 1239 end; 1240 Result := FCanUTF8; 1241end; 1242 1243function TFont.GetCharSet: TFontCharSet; 1244begin 1245 Result := FCharSet; 1246end; 1247 1248procedure TFont.SetCharSet(const AValue: TFontCharSet); 1249begin 1250 if FCharSet <> AValue then 1251 begin 1252 FreeReference; 1253 FCharSet := AValue; 1254 Changed; 1255 end; 1256end; 1257 1258function TFont.GetData: TFontData; 1259begin 1260 Result := DefFontData; 1261 if HandleAllocated then 1262 Result.Handle := Reference.Handle 1263 else 1264 Result.Handle := 0; 1265 Result.Height := Height; 1266 Result.Pitch := Pitch; 1267 Result.Style := Style; 1268 Result.CharSet := CharSet; 1269 Result.Quality := Quality; 1270 Result.Name := LeftStr(Name, SizeOf(Result.Name) - 1); 1271 Result.Orientation := Orientation; 1272end; 1273 1274function TFont.GetIsMonoSpace: boolean; 1275begin 1276 if not FIsMonoSpaceValid then 1277 begin 1278 FIsMonoSpace := FontIsMonoSpace(HFONT(Reference.Handle)); 1279 FIsMonoSpaceValid := True; 1280 end; 1281 Result := FIsMonoSpace; 1282end; 1283 1284function TFont.GetReference: TWSFontReference; 1285begin 1286 ReferenceNeeded; 1287 Result := FReference; 1288end; 1289 1290function TFont.IsHeightStored: boolean; 1291begin 1292 Result := DefFontData.Height <> Height; 1293end; 1294 1295function TFont.IsNameStored: boolean; 1296begin 1297 Result := DefFontData.Name <> Name; 1298end; 1299 1300procedure TFont.SetData(const FontData: TFontData); 1301var 1302 OldStyle: TFontStylesbase; 1303begin 1304 if (HFONT(FReference.Handle) <> FontData.Handle) or not FReference.Allocated then 1305 begin 1306 OldStyle := FStyle; 1307 FreeReference; 1308 FReference._lclHandle := TLCLHandle(FontData.Handle); 1309 inherited SetSize(-MulDiv(FontData.Height, 72, FPixelsPerInch)); 1310 FHeight := FontData.Height; 1311 FPitch := FontData.Pitch; 1312 FStyle := FontData.Style; 1313 FCharSet := FontData.CharSet; 1314 FQuality := FontData.Quality; 1315 inherited SetName(FontData.Name); 1316 Bold; // it calls GetFlags 1317 if (fsBold in OldStyle)<>(fsBold in FStyle) then 1318 inherited SetFlags(5, fsBold in FStyle); 1319 if (fsItalic in OldStyle)<>(fsItalic in FStyle) then 1320 inherited SetFlags(6, fsItalic in FStyle); 1321 if (fsUnderline in OldStyle)<>(fsUnderline in FStyle) then 1322 inherited SetFlags(7, fsUnderline in FStyle); 1323 if (fsStrikeOut in OldStyle)<>(fsStrikeOut in FStyle) then 1324 inherited SetFlags(8, fsStrikeOut in FStyle); 1325 FOrientation := FontData.Orientation; 1326 Changed; 1327 end; 1328end; 1329 1330function TFont.GetHeight: Integer; 1331begin 1332 Result := FHeight; 1333end; 1334 1335function TFont.GetPitch: TFontPitch; 1336begin 1337 Result := FPitch; 1338end; 1339 1340function TFont.GetStyle: TFontStyles; 1341begin 1342 Result := FStyle; 1343end; 1344 1345procedure TFont.Changed; 1346begin 1347 if FUpdateCount > 0 then 1348 begin 1349 FChanged := True; 1350 exit; 1351 end; 1352 FChanged := False; 1353 inherited Changed; 1354 // ToDo: we need interfaces: 1355 // if FNotify <> nil then FNotify.Changed; 1356end; 1357 1358// included by graphics.pp 1359