1{%MainUnit ../graphics.pp} 2{****************************************************************************** 3 TPen 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 14type 15 TExtPenAndPattern = record 16 ExtPen: TExtLogPen; 17 Pattern: TPenPattern; 18 end; 19 PExtPenAndPattern = ^TExtPenAndPattern; 20 21function CompareExtPenAndPatternWithResDesc(Key: PExtPenAndPattern; Desc: TPenHandleCacheDescriptor): integer; 22begin 23 Result := CompareMemRange(@Key^.ExtPen, @Desc.ExtPen, 24 SizeOf(Key^.ExtPen)); 25 if Result <> 0 then 26 Exit; 27 28 Result := CompareValue(Length(Key^.Pattern), Length(Desc.Pattern)); 29 if Result <> 0 then 30 Exit; 31 32 if Length(Key^.Pattern) > 0 then 33 begin 34 Result := CompareMemRange(@Key^.Pattern[0], @Desc.Pattern[0], 35 SizeOf(Key^.Pattern[0]) * Length(Key^.Pattern)); 36 end; 37end; 38 39{ TPenHandleCache } 40 41procedure TPenHandleCache.RemoveItem(Item: TResourceCacheItem); 42begin 43 DeleteObject(HGDIOBJ(Item.Handle)); 44 inherited RemoveItem(Item); 45end; 46 47constructor TPenHandleCache.Create; 48begin 49 inherited Create; 50 FResourceCacheDescriptorClass := TPenHandleCacheDescriptor; 51end; 52 53function TPenHandleCache.CompareDescriptors(Tree: TAvlTree; Desc1, 54 Desc2: Pointer): integer; 55var 56 Descriptor1: TPenHandleCacheDescriptor absolute Desc1; 57 Descriptor2: TPenHandleCacheDescriptor absolute Desc2; 58begin 59 Result := CompareMemRange(@Descriptor1.ExtPen, @Descriptor2.ExtPen, 60 SizeOf(Descriptor1.ExtPen)); 61 if Result <> 0 then 62 Exit; 63 64 Result := CompareValue(Length(Descriptor1.Pattern), Length(Descriptor2.Pattern)); 65 if Result <> 0 then 66 Exit; 67 68 if Length(Descriptor1.Pattern) > 0 then 69 begin 70 Result := CompareMemRange(@Descriptor1.Pattern[0], @Descriptor2.Pattern[0], 71 SizeOf(Descriptor1.Pattern[0]) * Length(Descriptor1.Pattern)); 72 end; 73end; 74 75function TPenHandleCache.FindPen(APen: TLCLHandle): TResourceCacheItem; 76var 77 ANode: TAvlTreeNode; 78begin 79 ANode := FItems.FindKey(@APen, 80 TListSortCompare(@ComparePHandleWithResourceCacheItem)); 81 if ANode <> nil then 82 Result := TResourceCacheItem(ANode.Data) 83 else 84 Result := nil; 85end; 86 87function TPenHandleCache.FindPenDesc(const AExtPen: TExtLogPen; 88 const APattern: TPenPattern): TPenHandleCacheDescriptor; 89var 90 ExtPenAndPattern: TExtPenAndPattern; 91 ANode: TAvlTreeNode; 92begin 93 ExtPenAndPattern.ExtPen := AExtPen; 94 ExtPenAndPattern.Pattern := APattern; 95 ANode := FDescriptors.Findkey(@ExtPenAndPattern, 96 TListSortCompare(@CompareExtPenAndPatternWithResDesc)); 97 if ANode <> nil then 98 Result := TPenHandleCacheDescriptor(ANode.Data) 99 else 100 Result := nil; 101end; 102 103function TPenHandleCache.Add(APen: TLCLHandle; const AExtPen: TExtLogPen; 104 const APattern: TPenPattern): TPenHandleCacheDescriptor; 105var 106 Item: TResourceCacheItem; 107begin 108 if FindPenDesc(AExtPen, APattern) <> nil then 109 RaiseGDBException('TPenHandleCache.Add pen desc added twice'); 110 111 // find cache item with APen 112 Item := FindPen(APen); 113 if Item = nil then 114 begin 115 // create new item 116 Item := TResourceCacheItem.Create(Self, APen); 117 FItems.Add(Item); 118 end; 119 120 // create descriptor 121 Result := TPenHandleCacheDescriptor.Create(Self, Item); 122 Result.ExtPen := AExtPen; 123 Result.Pattern := APattern; 124 FDescriptors.Add(Result); 125 if FindPenDesc(AExtPen, APattern) = nil then 126 begin 127 {$IFNDEF DisableChecks} 128 DebugLn('TPenHandleCache.Add Added: %p', [Pointer(Result)]); 129 {$ENDIF} 130 RaiseGDBException(''); 131 end; 132end; 133 134{ TPen } 135 136{------------------------------------------------------------------------------ 137 Method: TPen.SetColor 138 Params: Value: the new value 139 Returns: nothing 140 141 Sets the style of a pen 142 ------------------------------------------------------------------------------} 143procedure TPen.SetColor(Value : TColor); 144begin 145 if FColor <> Value then 146 SetColor(Value, TColorToFPColor(Value)); 147end; 148 149{------------------------------------------------------------------------------ 150 Method: TPen.SetStyle 151 Params: Value: the new value 152 Returns: nothing 153 154 Sets the style of a pen 155 ------------------------------------------------------------------------------} 156procedure TPen.SetStyle(Value : TPenStyle); 157begin 158 if Style <> Value then 159 begin 160 FreeReference; 161 inherited SetStyle(Value); 162 Changed; 163 end; 164end; 165 166{------------------------------------------------------------------------------ 167 Method: TPen.SetMode 168 Params: Value: the new value 169 Returns: nothing 170 171 Sets the Mode of a pen 172 ------------------------------------------------------------------------------} 173procedure TPen.SetMode(Value : TPenMode); 174begin 175 if Mode <> Value then 176 begin 177 FreeReference; 178 inherited SetMode(Value); 179 Changed; 180 end; 181end; 182 183{------------------------------------------------------------------------------ 184 Method: TPen.SetWidth 185 Params: Value: the new value 186 Returns: nothing 187 188 Sets the style of a pen 189 ------------------------------------------------------------------------------} 190procedure TPen.SetWidth(Value : Integer); 191begin 192 if (Width <> Value) then 193 begin 194 FreeReference; 195 inherited SetWidth(Value); 196 Changed; 197 end; 198end; 199 200{------------------------------------------------------------------------------ 201 Method: TPen.Create 202 Params: none 203 Returns: Nothing 204 205 Constructor for the class. 206 ------------------------------------------------------------------------------} 207constructor TPen.Create; 208begin 209 inherited Create; 210 DelayAllocate := True; 211 FCosmetic := True; 212 {$IFDEF HasFPEndCap} 213 inherited SetEndCap(pecRound); 214 {$ELSE} 215 FEndCap := pecRound; 216 {$ENDIF} 217 {$IFDEF HasFPJoinStyle} 218 inherited SetJoinStyle(pjsRound); 219 {$ELSE} 220 FJoinStyle := pjsRound; 221 {$ENDIF} 222 inherited SetWidth(1); 223 inherited SetStyle(psSolid); 224 inherited SetMode(pmCopy); 225 inherited SetFPColor(colBlack); 226 Color := clBlack; 227end; 228 229{------------------------------------------------------------------------------ 230 Method: TPen.Destroy 231 Params: None 232 Returns: Nothing 233 234 Destructor for the class. 235 ------------------------------------------------------------------------------} 236destructor TPen.Destroy; 237begin 238 FreeReference; 239 inherited Destroy; 240end; 241 242{------------------------------------------------------------------------------ 243 Method: TPen.Assign 244 Params: Source: Another pen 245 Returns: nothing 246 247 Copies the source pen to itself 248 ------------------------------------------------------------------------------} 249procedure TPen.Assign(Source : Tpersistent); 250var 251 APen: TPen absolute Source; 252begin 253 if Source is TPen then 254 begin 255 Width := APen.Width; 256 SetColor(APen.Color, TFPCanvasHelper(Source).FPColor); 257 Style := APen.Style; 258 Mode := APen.Mode; 259 Cosmetic := APen.Cosmetic; 260 JoinStyle := APen.JoinStyle; 261 EndCap := APen.EndCap; 262 SetPattern(APen.GetPattern); 263 end 264 else 265 inherited Assign(Source); 266end; 267 268function TPen.GetPattern: TPenPattern; 269begin 270 Result := FPattern; 271end; 272 273procedure TPen.SetPattern(APattern: TPenPattern); 274 275 function PatternsDiffer: Boolean; 276 var 277 l1, l2, m: integer; 278 begin 279 l1 := Length(FPattern); 280 l2 := Length(APattern); 281 m := min(l1, l2); 282 Result := (l1 <> l2) or 283 ((m > 0) and not CompareMem(@APattern[0], @FPattern[0], m * SizeOf(LongWord))); 284 end; 285 286begin 287 if PatternsDiffer then 288 begin 289 FreeReference; 290 FPattern := APattern; 291 Changed; 292 end; 293end; 294 295{------------------------------------------------------------------------------ 296 Method: TPen.SetHandle 297 Params: a pen handle 298 Returns: nothing 299 300 sets the pen to an external created pen 301 ------------------------------------------------------------------------------} 302procedure TPen.SetHandle(const Value: HPEN); 303begin 304 if HPEN(FReference.Handle) = Value then Exit; 305 306 FreeReference; 307 FReference._lclHandle := TLCLHandle(Value); 308 Changed; 309end; 310 311procedure TPen.SetJoinStyle(AValue: TPenJoinStyle); 312begin 313 if JoinStyle <> AValue then 314 begin 315 FreeReference; 316 {$IFDEF HasFPJoinStyle} 317 inherited SetJoinStyle(AValue); 318 {$ELSE} 319 FJoinStyle := AValue; 320 {$ENDIF} 321 Changed; 322 end; 323end; 324 325{------------------------------------------------------------------------------ 326 Function: TPen.GetHandle 327 Params: none 328 Returns: a handle to a pen gdiobject 329 330 Creates a pen if needed 331 ------------------------------------------------------------------------------} 332function TPen.GetHandle: HPEN; 333begin 334 Result := HPEN(Reference.Handle); 335end; 336 337function TPen.GetReference: TWSPenReference; 338begin 339 ReferenceNeeded; 340 Result := FReference; 341end; 342 343procedure TPen.ReferenceNeeded; 344const 345 PEN_STYLES: array[TPenStyle] of DWord = ( 346 { psSolid } PS_SOLID, 347 { psDash } PS_DASH, 348 { psDot } PS_DOT, 349 { psDashDot } PS_DASHDOT, 350 { psDashDotDot } PS_DASHDOTDOT, 351 { psinsideFrame } PS_INSIDEFRAME, 352 { psPattern } PS_USERSTYLE, 353 { psClear } PS_NULL 354 ); 355 356 PEN_GEOMETRIC: array[Boolean] of DWord = ( 357 { false } PS_COSMETIC, 358 { true } PS_GEOMETRIC 359 ); 360 361 PEN_ENDCAP: array[TPenEndCap] of DWord = ( 362 { pecRound } PS_ENDCAP_ROUND, 363 { pecSquare } PS_ENDCAP_SQUARE, 364 { pecFlat } PS_ENDCAP_FLAT 365 ); 366 367 PEN_JOIN: array[TPenJoinStyle] of DWord = ( 368 { pjsRound } PS_JOIN_ROUND, 369 { pjsBevel } PS_JOIN_BEVEL, 370 { pjsMiter } PS_JOIN_MITER 371 ); 372var 373 ALogPen: TLogPen; 374 AExtPen: TExtLogPen; 375 ALogBrush: TLogBrush; 376 CachedPen: TPenHandleCacheDescriptor; 377 IsGeometric: Boolean; 378begin 379 if FReference.Allocated then Exit; 380 381 IsGeometric := (Width > 1) or not Cosmetic; 382 383 FillChar(AExtPen, SizeOf(AExtPen), 0); 384 with AExtPen do 385 begin 386 elpPenStyle := PEN_STYLES[Style] or PEN_GEOMETRIC[IsGeometric]; 387 if IsGeometric then 388 elpPenStyle := elpPenStyle or PEN_ENDCAP[EndCap] or PEN_JOIN[JoinStyle]; 389 if IsGeometric then 390 elpWidth := Width 391 else 392 begin 393 // issue #32465, regression from fixing #22646. Pure cosmetic 394 // pen is created via TLogPen, not via TExtLogPen 395 if ((elpPenStyle and PS_STYLE_MASK) = elpPenStyle) and 396 (elpPenStyle <> PS_USERSTYLE) then 397 elpWidth := 0 398 else 399 //(https://msdn.microsoft.com/en-us/library/windows/desktop/dd162705(v=vs.85).aspx 400 //https://msdn.microsoft.com/en-us/library/windows/desktop/dd162711(v=vs.85).aspx 401 //Issue #0022646 402 elpWidth := 1; 403 end; 404 elpBrushStyle := BS_SOLID; 405 elpColor := TColorRef(FColor); 406 end; 407 408 PenResourceCache.Lock; 409 try 410 if Style = psPattern then 411 CachedPen := PenResourceCache.FindPenDesc(AExtPen, FPattern) 412 else 413 CachedPen := PenResourceCache.FindPenDesc(AExtPen, nil); 414 415 if CachedPen <> nil then 416 begin 417 CachedPen.Item.IncreaseRefCount; 418 FReference._lclHandle := CachedPen.Item.Handle; 419 end else 420 begin 421 // choose which function to use: CreatePenIndirect or ExtCreatePen 422 if ((AExtPen.elpPenStyle and PS_STYLE_MASK) = AExtPen.elpPenStyle) and 423 (AExtPen.elpPenStyle <> PS_USERSTYLE) then 424 begin 425 // simple pen 426 ALogPen.lopnStyle := AExtPen.elpPenStyle; 427 ALogPen.lopnWidth := Point(AExtPen.elpWidth, 0); 428 ALogPen.lopnColor := AExtPen.elpColor; 429 FReference._lclHandle := TLCLHandle(CreatePenIndirect(ALogPen)); 430 end 431 else 432 begin 433 // extended pen 434 ALogBrush.lbStyle := AExtPen.elpBrushStyle; 435 ALogBrush.lbColor := AExtPen.elpColor; 436 ALogBrush.lbHatch := AExtPen.elpHatch; 437 if (Style = psPattern) and (Length(FPattern) > 0) then 438 FReference._lclHandle := TLCLHandle(ExtCreatePen(AExtPen.elpPenStyle, 439 AExtPen.elpWidth, ALogBrush, Length(FPattern), @FPattern[0])) 440 else 441 FReference._lclHandle := TLCLHandle(ExtCreatePen(AExtPen.elpPenStyle, 442 AExtPen.elpWidth, ALogBrush, 0, nil)); 443 end; 444 445 if Style = psPattern then 446 PenResourceCache.Add(FReference.Handle, AExtPen, FPattern) 447 else 448 PenResourceCache.Add(FReference.Handle, AExtPen, nil); 449 end; 450 FPenHandleCached := True; 451 finally 452 PenResourceCache.Unlock; 453 end; 454end; 455 456procedure TPen.SetCosmetic(const AValue: Boolean); 457begin 458 if Cosmetic <> AValue then 459 begin 460 FreeReference; 461 FCosmetic := AValue; 462 Changed; 463 end; 464end; 465 466procedure TPen.SetEndCap(AValue: TPenEndCap); 467begin 468 if EndCap <> AValue then 469 begin 470 FreeReference; 471 {$IFDEF HasFPEndCap} 472 inherited SetEndCap(AValue); 473 {$ELSE} 474 FEndCap := AValue; 475 {$ENDIF} 476 Changed; 477 end; 478end; 479 480{------------------------------------------------------------------------------ 481 Method: TPen.FreeReference 482 Params: none 483 Returns: Nothing 484 485 Frees a pen handle if needed 486 ------------------------------------------------------------------------------} 487 488procedure TPen.FreeReference; 489begin 490 if not FReference.Allocated then Exit; 491 492 Changing; 493 if FPenHandleCached then 494 begin 495 PenResourceCache.Lock; 496 try 497 PenResourceCache.FindPen(FReference.Handle).DecreaseRefCount; 498 FPenHandleCached := False; 499 finally 500 PenResourceCache.Unlock; 501 end; 502 end else 503 DeleteObject(HGDIOBJ(FReference.Handle)); 504 FReference._lclHandle := 0; 505end; 506 507procedure TPen.DoAllocateResources; 508begin 509 inherited DoAllocateResources; 510 GetReference; 511end; 512 513procedure TPen.DoDeAllocateResources; 514begin 515 FreeReference; 516 inherited DoDeAllocateResources; 517end; 518 519procedure TPen.DoCopyProps(From: TFPCanvasHelper); 520var 521 APen: TPen absolute From; 522begin 523 if From is TPen then 524 begin 525 FreeReference; 526 inherited DoCopyProps(From); 527 FCosmetic := APen.Cosmetic; 528 EndCap := APen.EndCap; 529 JoinStyle := APen.JoinStyle; 530 //TODO: query new parameters 531 Changed; 532 end else 533 inherited DoCopyProps(From); 534end; 535 536procedure TPen.SetColor(const NewColor: TColor; const NewFPColor: TFPColor); 537begin 538 if (NewColor = Color) and (NewFPColor = FPColor) then Exit; 539 FreeReference; 540 FColor := NewColor; 541 inherited SetFPColor(NewFPColor); 542 Changed; 543end; 544 545procedure TPen.SetFPColor(const AValue: TFPColor); 546begin 547 if FPColor <> AValue then 548 SetColor(FPColorToTColor(AValue), AValue); 549end; 550 551