← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/interfaces/cocoa/cocoaobject.inc

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lcl/interfaces/cocoa/cocoaobject.inc
1
1
{%MainUnit cocoaint.pas}
2
2
 
3
 
{ $Id: carbonobject.inc 15152 2008-05-15 10:15:06Z sekelsenmat $ }
4
3
{******************************************************************************
5
 
  All utility method implementations of the TCocoaWidgetSet class are here.
 
4
  All utility method implementations of the TCarbonWidgetSet class are here.
6
5
 
7
6
 
8
7
 ******************************************************************************
23
22
 *****************************************************************************
24
23
}
25
24
 
26
 
 
 
25
{ TCocoaWidgetSet }
 
26
 
 
27
{------------------------------------------------------------------------------
 
28
  Method:  TCocoaWidgetSet.AppInit
 
29
  Params:  ScreenInfo
 
30
 
 
31
  Initialize Carbon Widget Set
 
32
 ------------------------------------------------------------------------------}
 
33
procedure TCocoaWidgetSet.AppInit(var ScreenInfo: TScreenInfo);
 
34
begin
 
35
  {$IFDEF VerboseObject}
 
36
    DebugLn('TCocoaWidgetSet.AppInit');
 
37
  {$ENDIF}
 
38
 
 
39
  delegate:=TCocoaAppDelegate.alloc;
 
40
 
 
41
  { Creates the application NSApp object }
 
42
  FNsApp := NSApplication.sharedApplication;
 
43
  FNSApp.setDelegate(delegate);
 
44
end;
 
45
 
 
46
{------------------------------------------------------------------------------
 
47
  Method:  TCocoaWidgetSet.AppRun
 
48
  Params:  ALoop
 
49
 ------------------------------------------------------------------------------}
 
50
procedure TCocoaWidgetSet.AppRun(const ALoop: TApplicationMainLoop);
 
51
begin
 
52
  {$IFDEF VerboseObject}
 
53
    DebugLn('TCocoaWidgetSet.AppRun');
 
54
  {$ENDIF}
 
55
 
 
56
  { Enters main message loop }
 
57
  NSApp.run;
 
58
end;
 
59
 
 
60
{------------------------------------------------------------------------------
 
61
  Method:  TCocoaWidgetSet.AppProcessMessages
 
62
 
 
63
  Handle all pending messages
 
64
 ------------------------------------------------------------------------------}
 
65
procedure TCocoaWidgetSet.AppProcessMessages;
 
66
var
 
67
  event: NSEvent;
 
68
begin
 
69
  {$IFDEF VerboseObject}
 
70
    DebugLn('TCocoaWidgetSet.AppProcessMessages');
 
71
  {$ENDIF}
 
72
 
 
73
  event := NSApp.nextEventMatchingMask_untilDate_inMode_dequeue(NSAnyEventMask, nil, NSDefaultRunLoopMode, true);
 
74
  NSApp.sendEvent(event);
 
75
 
 
76
  {$IFDEF VerboseObject}
 
77
    DebugLn('TCocoaWidgetSet.AppProcessMessages END');
 
78
  {$ENDIF}
 
79
end;
 
80
 
 
81
{------------------------------------------------------------------------------
 
82
  Method:  TCocoaWidgetSet.AppWaitMessage
 
83
 
 
84
  Passes execution control to Cocoa
 
85
 ------------------------------------------------------------------------------}
 
86
procedure TCocoaWidgetSet.AppWaitMessage;
 
87
var
 
88
  event : NSEvent;
 
89
begin
 
90
  {$IFDEF VerboseObject}
 
91
    DebugLn('TCocoaWidgetSet.AppWaitMessage');
 
92
  {$ENDIF}
 
93
  event := NSApp.nextEventMatchingMask_untilDate_inMode_dequeue(NSAnyEventMask, NSDate.distantFuture, NSDefaultRunLoopMode, true);
 
94
  NSApp.sendEvent(event);
 
95
end;
 
96
 
 
97
{------------------------------------------------------------------------------
 
98
  Method:  TCocoaWidgetSet.Create
 
99
 
 
100
  Constructor for the class
 
101
 ------------------------------------------------------------------------------}
 
102
constructor TCocoaWidgetSet.Create;
 
103
begin
 
104
  CocoaWidgetSet := Self;
 
105
  inherited Create;
 
106
  FTerminating := False;
 
107
 
 
108
  {  Creates the AutoreleasePool }
 
109
  pool := NSAutoreleasePool.alloc.init;
 
110
 
 
111
  NSMessageWnd := NSStringUTF8('HWND');
 
112
  NSMessageMsg := NSStringUTF8('MSG');
 
113
  NSMessageWParam := NSStringUTF8('WPARAM');
 
114
  NSMessageLParam := NSStringUTF8('LPARAM');
 
115
  NSMessageResult := NSStringUTF8('RESULT');
 
116
 
 
117
  InitStockItems;
 
118
end;
 
119
 
 
120
{------------------------------------------------------------------------------
 
121
  Method:  TCocoaWidgetSet.Destroy
 
122
 
 
123
  Destructor for the class
 
124
 ------------------------------------------------------------------------------}
 
125
destructor TCocoaWidgetSet.Destroy;
 
126
begin
 
127
  inherited Destroy;
 
128
 
 
129
  FreeSysColorBrushes;
 
130
  FreeStockItems;
 
131
 
 
132
  CocoaWidgetSet := nil;
 
133
 
 
134
  {  Releases the AutoreleasePool }
 
135
  pool.release;
 
136
end;
 
137
 
 
138
{------------------------------------------------------------------------------
 
139
  Method:  TCocoaWidgetSet.AppTerminate
 
140
 
 
141
  Tells Carbon to halt the application
 
142
 ------------------------------------------------------------------------------}
 
143
procedure TCocoaWidgetSet.AppTerminate;
 
144
begin
 
145
  if FTerminating then Exit;
 
146
  NSApp.terminate(nil);
 
147
end;
 
148
 
 
149
{------------------------------------------------------------------------------
 
150
  Method:  TCocoaWidgetSet.AppMinimize
 
151
 
 
152
  Minimizes the whole application to the taskbar
 
153
 ------------------------------------------------------------------------------}
 
154
procedure TCocoaWidgetSet.AppMinimize;
 
155
begin
 
156
  NSApp.hide(NSApp);
 
157
end;
 
158
 
 
159
{------------------------------------------------------------------------------
 
160
  Method:  TCocoaWidgetSet.AppRestore
 
161
 
 
162
  Restores the whole minimized application from the taskbar
 
163
 ------------------------------------------------------------------------------}
 
164
procedure TCocoaWidgetSet.AppRestore;
 
165
begin
 
166
  NSApp.unhide(NSApp);
 
167
end;
 
168
 
 
169
{------------------------------------------------------------------------------
 
170
  Method:  TCocoaWidgetSet.AppBringToFront
 
171
 
 
172
  Brings the entire application on top of all other non-topmost programs
 
173
 ------------------------------------------------------------------------------}
 
174
procedure TCocoaWidgetSet.AppBringToFront;
 
175
begin
 
176
  NSApp.activateIgnoringOtherApps(True);
 
177
end;
 
178
 
 
179
procedure TCocoaWidgetSet.AppSetIcon(const Small, Big: HICON);
 
180
begin
 
181
  if Big <> 0 then
 
182
    NSApp.setApplicationIconImage(TCocoaBitmap(Big).image)
 
183
  else
 
184
    NSApp.setApplicationIconImage(nil);
 
185
end;
 
186
 
 
187
{------------------------------------------------------------------------------
 
188
  Method:  TCocoaWidgetSet.AppSetTitle
 
189
  Params:  ATitle - New application title
 
190
 
 
191
  Changes the application title
 
192
 ------------------------------------------------------------------------------}
 
193
procedure TCocoaWidgetSet.AppSetTitle(const ATitle: string);
 
194
var
 
195
  ns: NSString;
 
196
begin
 
197
  if not Assigned(NSApp.dockTile) then Exit;
 
198
  //todo: setBadgeLabel is for 10.5 only, should be removed
 
199
  if NSApp.dockTile.respondsToSelector_(objcselector('setBadgeLabel:')) then
 
200
  begin
 
201
    ns := NSStringUtf8(ATitle);
 
202
    NSApp.dockTile.setBadgeLabel(NSStringUtf8(ATitle));
 
203
    ns.release;
 
204
  end;
 
205
end;
 
206
 
 
207
function TCocoaWidgetSet.GetLCLCapability(ACapability: TLCLCapability): PtrUInt;
 
208
begin
 
209
  case ACapability of
 
210
    lcCanDrawOutsideOnPaint,
 
211
    lcNeedMininimizeAppWithMainForm,
 
212
    lcApplicationTitle,
 
213
    lcFormIcon,
 
214
    lcModalWindow,
 
215
    lcReceivesLMClearCutCopyPasteReliably:
 
216
      Result := LCL_CAPABILITY_NO;
 
217
    lcAntialiasingEnabledByDefault:
 
218
      Result := LCL_CAPABILITY_YES;
 
219
  else
 
220
    Result := inherited;
 
221
  end;
 
222
end;
 
223
 
 
224
function TCocoaWidgetSet.CreateTimer(Interval: integer; TimerFunc: TWSTimerProc): THandle;
 
225
var
 
226
  timer : NSTimer;
 
227
  user  : TCocoaTimerObject;
 
228
begin
 
229
  {$IFDEF VerboseObject}
 
230
    DebugLn('TCocoaWidgetSet.CreateTimer');
 
231
  {$ENDIF}
 
232
  user:=TCocoaTimerObject.initWithFunc(TimerFunc);
 
233
 
 
234
  timer:=NSTimer.timerWithTimeInterval_target_selector_userInfo_repeats(
 
235
    Interval/1000, user, objcselector(user.timerEvent), user, True);
 
236
 
 
237
  NSRunLoop.currentRunLoop.addTimer_forMode(timer, NSDefaultRunLoopMode);
 
238
 
 
239
  {user is retained (twice, because it's target), by the timer and }
 
240
  {released (twice) on timer invalidation}
 
241
  user.release;
 
242
 
 
243
  Result:=THandle(timer);
 
244
end;
 
245
 
 
246
function TCocoaWidgetSet.DestroyTimer(TimerHandle: THandle): boolean;
 
247
var
 
248
  obj : NSObject;
 
249
begin
 
250
  {$IFDEF VerboseObject}
 
251
    DebugLn('TCocoaWidgetSet.DestroyTimer');
 
252
  {$ENDIF}
 
253
  obj:=NSObject(TimerHandle);
 
254
  try
 
255
    Result:= Assigned(obj) and obj.isKindOfClass_(NSTimer);
 
256
  except
 
257
    Result:=false;
 
258
  end;
 
259
  if not Result then Exit;
 
260
  NSTimer(obj).invalidate;
 
261
end;
 
262
 
 
263
function TCocoaWidgetSet.PrepareUserEventInfo(Handle: HWND; Msg: Cardinal;
 
264
  wParam: WParam; lParam: LParam): NSMutableDictionary;
 
265
var
 
266
  LocalPool: NSAutoReleasePool;
 
267
  Keys, Objs: NSMutableArray;
 
268
begin
 
269
  // create a dinctionary
 
270
  LocalPool := NSAutoReleasePool.alloc.init;
 
271
  Keys := NSMutableArray.arrayWithObjects(
 
272
    NSMessageWnd,
 
273
    NSMessageMsg,
 
274
    NSMessageWParam,
 
275
    NSMessageLParam,
 
276
    NSMessageResult,
 
277
    nil);
 
278
  Objs := NSMutableArray.arrayWithObjects(
 
279
    NSNumber.numberWithUnsignedInteger(Handle),
 
280
    NSNumber.numberWithUnsignedLong(Msg),
 
281
    NSNumber.numberWithInteger(wParam),
 
282
    NSNumber.numberWithInteger(lParam),
 
283
    NSNumber.numberWithInteger(0),
 
284
    nil);
 
285
  Result := NSMutableDictionary.dictionaryWithObjects_forKeys(Objs, Keys);
 
286
  Result.retain;
 
287
  // release everything
 
288
  LocalPool.release;
 
289
end;
 
290
 
 
291
function TCocoaWidgetSet.PrepareUserEvent(Handle: HWND; Info: NSDictionary): NSEvent;
 
292
var
 
293
  Obj: NSObject;
 
294
  Win: NSWindow;
 
295
begin
 
296
  Obj := NSObject(Handle);
 
297
  if Obj.isKindOfClass(NSWindow) then
 
298
    Win := NSWindow(Obj)
 
299
  else
 
300
  if Obj.isKindOfClass(NSView) then
 
301
    Win := NSView(Handle).window
 
302
  else
 
303
    Exit(nil);
 
304
  Result := NSEvent.otherEventWithType_location_modifierFlags_timestamp_windowNumber_context_subtype_data1_data2(
 
305
    NSApplicationDefined,
 
306
    NSZeroPoint,
 
307
    0,
 
308
    GetCurrentEventTime,
 
309
    Win.windowNumber,
 
310
    nil,
 
311
    LCLEventSubTypeMessage,
 
312
    NSInteger(Info),
 
313
    0);
 
314
end;
 
315
 
 
316
procedure TCocoaWidgetSet.InitStockItems;
 
317
var
 
318
  LogBrush: TLogBrush;
 
319
  logPen: TLogPen;
 
320
begin
 
321
  FillChar(LogBrush, SizeOf(TLogBrush),0);
 
322
  LogBrush.lbStyle := BS_NULL;
 
323
  FStockNullBrush := HBrush(TCocoaBrush.Create(LogBrush, True));
 
324
 
 
325
  LogBrush.lbStyle := BS_SOLID;
 
326
  LogBrush.lbColor := $000000;
 
327
  FStockBlackBrush := HBrush(TCocoaBrush.Create(LogBrush, True));
 
328
 
 
329
  LogBrush.lbColor := $C0C0C0;
 
330
  FStockLtGrayBrush := HBrush(TCocoaBrush.Create(LogBrush, True));
 
331
 
 
332
  LogBrush.lbColor := $808080;
 
333
  FStockGrayBrush := HBrush(TCocoaBrush.Create(LogBrush, True));
 
334
 
 
335
  LogBrush.lbColor := $404040;
 
336
  FStockDkGrayBrush := HBrush(TCocoaBrush.Create(LogBrush, True));
 
337
 
 
338
  LogBrush.lbColor := $FFFFFF;
 
339
  FStockWhiteBrush := HBrush(TCocoaBrush.Create(LogBrush, True));
 
340
 
 
341
  LogPen.lopnStyle := PS_NULL;
 
342
  LogPen.lopnWidth := Types.Point(0, 0); // create cosmetic pens
 
343
  LogPen.lopnColor := $FFFFFF;
 
344
  FStockNullPen := HPen(TCocoaPen.Create(LogPen, True));
 
345
 
 
346
  LogPen.lopnStyle := PS_SOLID;
 
347
  FStockWhitePen := HPen(TCocoaPen.Create(LogPen, True));
 
348
 
 
349
  LogPen.lopnColor := $000000;
 
350
  FStockBlackPen := HPen(TCocoaPen.Create(LogPen, True));
 
351
 
 
352
  FStockSystemFont := HFont(TCocoaFont.CreateDefault(True));
 
353
  FStockFixedFont := HFont(TCocoaFont.Create(NSFont.userFixedPitchFontOfSize(0), True));
 
354
end;
 
355
 
 
356
procedure TCocoaWidgetSet.FreeStockItems;
 
357
 
 
358
  procedure DeleteAndNilObject(var h: HGDIOBJ);
 
359
  begin
 
360
    if h <> 0 then
 
361
      TCocoaGDIObject(h).Global := False;
 
362
    DeleteObject(h);
 
363
    h := 0;
 
364
  end;
 
365
 
 
366
begin
 
367
  DeleteAndNilObject(FStockNullBrush);
 
368
  DeleteAndNilObject(FStockBlackBrush);
 
369
  DeleteAndNilObject(FStockLtGrayBrush);
 
370
  DeleteAndNilObject(FStockGrayBrush);
 
371
  DeleteAndNilObject(FStockDkGrayBrush);
 
372
  DeleteAndNilObject(FStockWhiteBrush);
 
373
 
 
374
  DeleteAndNilObject(FStockNullPen);
 
375
  DeleteAndNilObject(FStockBlackPen);
 
376
  DeleteAndNilObject(FStockWhitePen);
 
377
 
 
378
  DeleteAndNilObject(FStockSystemFont);
 
379
  DeleteAndNilObject(FStockFixedFont);
 
380
end;
 
381
 
 
382
procedure TCocoaWidgetSet.FreeSysColorBrushes;
 
383
 
 
384
  procedure DeleteAndNilObject(var h: HBrush);
 
385
  begin
 
386
    if h <> 0 then
 
387
    begin
 
388
      TCocoaBrush(h).Free;
 
389
      h := 0;
 
390
    end;
 
391
  end;
 
392
 
 
393
var
 
394
  i: integer;
 
395
begin
 
396
  for i := Low(FSysColorBrushes) to High(FSysColorBrushes) do
 
397
    DeleteAndNilObject(FSysColorBrushes[i]);
 
398
end;
 
399
 
 
400
{------------------------------------------------------------------------------
 
401
  Method:  TCocoaWidgetSet.GetAppHandle
 
402
  Returns: Returns NSApp object, created via NSApplication.sharedApplication
 
403
 ------------------------------------------------------------------------------}
 
404
function TCocoaWidgetSet.GetAppHandle: THandle;
 
405
begin
 
406
  Result:=THandle(NSApp);
 
407
end;
 
408
 
 
409
function TCocoaWidgetSet.DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor;
 
410
begin
 
411
  Result:=0;
 
412
end;
 
413
 
 
414
procedure TCocoaWidgetSet.DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor);
 
415
begin
 
416
 
 
417
end;
 
418
 
 
419
procedure TCocoaWidgetSet.DCRedraw(CanvasHandle: HDC);
 
420
begin
 
421
  if CanvasHandle <> 0 then
 
422
    TCocoaContext(CanvasHandle).ctx.flushGraphics;
 
423
end;
 
424
 
 
425
procedure TCocoaWidgetSet.DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean);
 
426
begin
 
427
  if CanvasHandle <> 0 then
 
428
    TCocoaContext(CanvasHandle).SetAntialiasing(AEnabled);
 
429
end;
 
430
 
 
431
procedure TCocoaWidgetSet.SetDesigning(AComponent: TComponent);
 
432
begin
 
433
 
 
434
end;
 
435
 
 
436
{------------------------------------------------------------------------------
 
437
  Method:  TCocoaWidgetSet.LCLPlatform
 
438
  Returns: lpCocoa - enum value for Cocoa widgetset
 
439
 ------------------------------------------------------------------------------}
 
440
function TCocoaWidgetSet.LCLPlatform: TLCLPlatform;
 
441
begin
 
442
  Result:= lpCocoa;
 
443
end;
 
444
 
 
445
procedure InternalInit;
 
446
begin
 
447
end;
 
448
 
 
449
procedure InternalFinal;
 
450
begin
 
451
  if Assigned(ScreenContext) then ScreenContext.Free;
 
452
end;
 
453
 
 
454
 
 
455
{ TCocoaAppDelegate }
 
456
 
 
457
function TCocoaAppDelegate.applicationShouldTerminate(sender: NSApplication): NSApplicationTerminateReply;
 
458
begin
 
459
  Result := NSTerminateNow;
 
460
end;
 
461
 
 
462
{ TCocoaTimerObject }
 
463
 
 
464
procedure TCocoaTimerObject.timerEvent;
 
465
begin
 
466
  if Assigned(@func) then func;
 
467
end;
 
468
 
 
469
class function TCocoaTimerObject.initWithFunc(afunc: TWSTimerProc): TCocoaTimerObject;
 
470
begin
 
471
  Result:=alloc;
 
472
  Result.func:=afunc;
 
473
end;
 
474
 
 
475
{------------------------------------------------------------------------------
 
476
  Method:  TCarbonWidgetSet.RawImage_DescriptionFromCarbonBitmap
 
477
 
 
478
  Creates a rawimage description for a carbonbitmap
 
479
 ------------------------------------------------------------------------------}
 
480
function TCocoaWidgetSet.RawImage_DescriptionFromCocoaBitmap(out ADesc: TRawImageDescription; ABitmap: TCocoaBitmap): Boolean;
 
481
var
 
482
  Prec, Shift, BPR: Byte;
 
483
begin
 
484
  ADesc.Init;
 
485
 
 
486
  case ABitmap.BitmapType of
 
487
    cbtMono, cbtGray: ADesc.Format := ricfGray;
 
488
  else
 
489
    ADesc.Format := ricfRGBA;
 
490
  end;
 
491
 
 
492
  with ABitmap.image.size do
 
493
  begin
 
494
    ADesc.Width := Round(width);
 
495
    ADesc.Height := Round(Height);
 
496
  end;
 
497
 
 
498
  //ADesc.PaletteColorCount := 0;
 
499
 
 
500
  ADesc.BitOrder := riboReversedBits;
 
501
  ADesc.ByteOrder := riboMSBFirst;
 
502
 
 
503
  BPR := ABitmap.BytesPerRow;
 
504
  if BPR and $F = 0 then ADesc.LineEnd := rileDQWordBoundary     // 128bit aligned
 
505
  else if BPR and $7 = 0 then ADesc.LineEnd := rileQWordBoundary //  64bit aligned
 
506
  else if BPR and $3 = 0 then ADesc.LineEnd := rileWordBoundary  //  32bit aligned
 
507
  else if BPR and $1 = 0 then ADesc.LineEnd := rileByteBoundary  //   8bit aligned
 
508
  else ADesc.LineEnd := rileTight;
 
509
 
 
510
  ADesc.LineOrder := riloTopToBottom;
 
511
  ADesc.BitsPerPixel := ABitmap.BitsPerPixel;
 
512
 
 
513
  ADesc.MaskBitOrder := riboReversedBits;
 
514
  ADesc.MaskBitsPerPixel := 1;
 
515
  ADesc.MaskLineEnd := rileByteBoundary;
 
516
  // ADesc.MaskShift := 0;
 
517
 
 
518
  ADesc.Depth := ABitmap.Depth;
 
519
  Prec := ABitmap.BitsPerSample;
 
520
 
 
521
  ADesc.RedPrec := Prec;
 
522
  ADesc.GreenPrec := Prec;
 
523
  ADesc.BluePrec := Prec;
 
524
 
 
525
  // gray or mono
 
526
  if ADesc.Format = ricfGray then Exit;
 
527
 
 
528
  // alpha
 
529
  if ABitmap.BitmapType in [cbtARGB, cbtRGBA, cbtBGRA] then
 
530
    ADesc.AlphaPrec := Prec;
 
531
 
 
532
  case ABitmap.BitmapType of
 
533
    cbtRGB: begin
 
534
      Shift := 32 - Prec;
 
535
      ADesc.RedShift := Shift;
 
536
      Dec(Shift, Prec);
 
537
      ADesc.GreenShift := Shift;
 
538
      Dec(Shift, Prec);
 
539
      ADesc.BlueShift := Shift;
 
540
    end;
 
541
    cbtBGR: begin
 
542
      Shift := 32 - Prec;
 
543
      ADesc.BlueShift := Shift;
 
544
      Dec(Shift, Prec);
 
545
      ADesc.GreenShift := Shift;
 
546
      Dec(Shift, Prec);
 
547
      ADesc.RedShift := Shift;
 
548
    end;
 
549
    cbtARGB: begin
 
550
      Shift := 32 - Prec;
 
551
      ADesc.AlphaShift := Shift;
 
552
      Dec(Shift, Prec);
 
553
      ADesc.RedShift := Shift;
 
554
      Dec(Shift, Prec);
 
555
      ADesc.GreenShift := Shift;
 
556
      Dec(Shift, Prec);
 
557
      ADesc.BlueShift := Shift;
 
558
    end;
 
559
    cbtRGBA: begin
 
560
      Shift := 32 - Prec;
 
561
      ADesc.RedShift := Shift;
 
562
      Dec(Shift, Prec);
 
563
      ADesc.GreenShift := Shift;
 
564
      Dec(Shift, Prec);
 
565
      ADesc.BlueShift := Shift;
 
566
      Dec(Shift, Prec);
 
567
      ADesc.AlphaShift := Shift;
 
568
    end;
 
569
    cbtBGRA: begin
 
570
      Shift := 32 - Prec;
 
571
      ADesc.BlueShift := Shift;
 
572
      Dec(Shift, Prec);
 
573
      ADesc.GreenShift := Shift;
 
574
      Dec(Shift, Prec);
 
575
      ADesc.RedShift := Shift;
 
576
      Dec(Shift, Prec);
 
577
      ADesc.AlphaShift := Shift;
 
578
    end;
 
579
  end;
 
580
 
 
581
  Result := True;
 
582
end;
 
583
 
 
584
{------------------------------------------------------------------------------
 
585
  Method:  TCarbonWidgetSet.RawImage_FromCarbonBitmap
 
586
 
 
587
  Creates a rawimage description for a carbonbitmap
 
588
 ------------------------------------------------------------------------------}
 
589
function TCocoaWidgetSet.RawImage_FromCocoaBitmap(out ARawImage: TRawImage; ABitmap, AMask: TCocoaBitmap; ARect: PRect = nil): Boolean;
 
590
begin
 
591
  FillChar(ARawImage, SizeOf(ARawImage), 0);
 
592
  RawImage_DescriptionFromCocoaBitmap(ARawImage.Description, ABitmap);
 
593
 
 
594
  ARawImage.DataSize := ABitmap.DataSize;
 
595
  ReAllocMem(ARawImage.Data, ARawImage.DataSize);
 
596
  if ARawImage.DataSize > 0 then
 
597
    System.Move(ABitmap.Data^, ARawImage.Data^, ARawImage.DataSize);
 
598
 
 
599
  Result := True;
 
600
  
 
601
  if AMask = nil then
 
602
  begin
 
603
    ARawImage.Description.MaskBitsPerPixel := 0;
 
604
    Exit;
 
605
  end;
 
606
 
 
607
  if AMask.Depth > 1
 
608
  then begin
 
609
    DebugLn('[WARNING] RawImage_FromCarbonBitmap: AMask.Depth > 1');
 
610
    Exit;
 
611
  end;
 
612
 
 
613
  ARawImage.MaskSize := AMask.DataSize;
 
614
  ReAllocMem(ARawImage.Mask, ARawImage.MaskSize);
 
615
  if ARawImage.MaskSize > 0 then
 
616
    System.Move(AMask.Data^, ARawImage.Mask^, ARawImage.MaskSize);
 
617
end;
 
618
 
 
619
function TCocoaWidgetSet.RawImage_DescriptionToBitmapType(
 
620
  ADesc: TRawImageDescription;
 
621
  out bmpType: TCocoaBitmapType): Boolean;
 
622
begin
 
623
  Result := False;
 
624
 
 
625
  if ADesc.Format = ricfGray
 
626
  then
 
627
  begin
 
628
    if ADesc.Depth = 1 then bmpType := cbtMono
 
629
    else bmpType := cbtGray;
 
630
  end
 
631
  else if ADesc.Depth = 1
 
632
  then bmpType := cbtMono
 
633
  else if ADesc.AlphaPrec <> 0
 
634
  then begin
 
635
    if ADesc.ByteOrder = riboMSBFirst
 
636
    then begin
 
637
      if  (ADesc.AlphaShift = 24)
 
638
      and (ADesc.RedShift   = 16)
 
639
      and (ADesc.GreenShift = 8 )
 
640
      and (ADesc.BlueShift  = 0 )
 
641
      then bmpType := cbtARGB
 
642
      else
 
643
      if  (ADesc.AlphaShift = 0)
 
644
      and (ADesc.RedShift   = 24)
 
645
      and (ADesc.GreenShift = 16 )
 
646
      and (ADesc.BlueShift  = 8 )
 
647
      then bmpType := cbtRGBA
 
648
      else
 
649
      if  (ADesc.AlphaShift = 0 )
 
650
      and (ADesc.RedShift   = 8 )
 
651
      and (ADesc.GreenShift = 16)
 
652
      and (ADesc.BlueShift  = 24)
 
653
      then bmpType := cbtBGRA
 
654
      else Exit;
 
655
    end
 
656
    else begin
 
657
      if  (ADesc.AlphaShift = 24)
 
658
      and (ADesc.RedShift   = 16)
 
659
      and (ADesc.GreenShift = 8 )
 
660
      and (ADesc.BlueShift  = 0 )
 
661
      then bmpType := cbtBGRA
 
662
      else
 
663
      if  (ADesc.AlphaShift = 0 )
 
664
      and (ADesc.RedShift   = 8 )
 
665
      and (ADesc.GreenShift = 16)
 
666
      and (ADesc.BlueShift  = 24)
 
667
      then bmpType := cbtARGB
 
668
      else
 
669
      if  (ADesc.AlphaShift = 24 )
 
670
      and (ADesc.RedShift   = 0 )
 
671
      and (ADesc.GreenShift = 8)
 
672
      and (ADesc.BlueShift  = 16)
 
673
      then bmpType := cbtRGBA
 
674
      else Exit;
 
675
    end;
 
676
  end
 
677
  else begin
 
678
    bmpType := cbtRGB;
 
679
  end;
 
680
 
 
681
  Result := True;
 
682
end;
27
683