1{                 ---------------------------------------
2                  carbonclipboard.pp  -  Carbon clipboard
3                  ---------------------------------------
4
5 *****************************************************************************
6  This file is part of the Lazarus Component Library (LCL)
7
8  See the file COPYING.modifiedLGPL.txt, included in this distribution,
9  for details about the license.
10 *****************************************************************************
11}
12unit CarbonClipboard;
13
14{$mode objfpc}{$H+}
15
16interface
17
18// defines
19{$I carbondefines.inc}
20
21uses
22 // rtl+ftl
23  Classes, SysUtils,
24 // carbon bindings
25  MacOSAll,
26 // LCL
27  LCLProc, LCLType, Graphics, GraphType;
28
29type
30
31  { TCarbonClipboard }
32
33  TCarbonClipboard = class
34  private
35    FOwnerShips: Integer;
36    FPasteboards: Array [TClipboardType] of PasteboardRef;
37    FFormats: TList; // list of CFStringRef UTIs
38    FOnClipboardRequest: Array [TClipboardType] of TClipboardRequestEvent;
39
40    function FindFormat(const UTI: CFStringRef): TClipboardFormat;
41  public
42    constructor Create;
43    destructor Destroy; override;
44  public
45    procedure CheckOwnerShip;
46    function Clear(ClipboardType: TClipboardType): Boolean;
47    function FormatToMimeType(FormatID: TClipboardFormat): String;
48    function GetData(ClipboardType: TClipboardType; FormatID: TClipboardFormat;
49      Stream: TStream): Boolean;
50    function GetFormats(ClipboardType: TClipboardType; var Count: Integer;
51      var List: PClipboardFormat): Boolean;
52    function GetOwnerShip(ClipboardType: TClipboardType;
53      OnRequestProc: TClipboardRequestEvent; FormatCount: Integer;
54      Formats: PClipboardFormat): Boolean;
55    function RegisterFormat(const AMimeType: String): TClipboardFormat;
56  public
57    property OwnerShips: Integer read FOwnerShips;
58  end;
59
60var
61  ClipboardTypeToPasteboard: Array [TClipboardType] of CFStringRef =
62  (
63{ctPrimarySelection  } kPasteboardUniqueName, // local application pasteboard
64{ctSecondarySelection} nil,                   // Find pasteboard
65{ctClipboard         } nil                    // standard global pasteboard
66  );
67  Clipboard: TCarbonClipboard;
68
69
70implementation
71
72uses CarbonProc, CarbonDbgConsts;
73
74function WriteSteamData( info: UnivPtr; buffer: {const} UnivPtr; count: size_t ): size_t; mwpascal;
75begin
76  try
77    if Assigned(info) then
78      Result:=TStream(info).write(Buffer^, count)
79    else
80      Result:=0;
81  except
82    Result:=0;
83  end;
84end;
85
86procedure FinishStreamData( {%H-}info: UnivPtr ); mwpascal;
87begin
88  //do nothing;
89end;
90
91function AllocStreamConsumer(str: TStream): CGDataConsumerRef;
92var
93  callbacks: CGDataConsumerCallbacks;
94begin
95  callbacks.putBytes:=@WriteSteamData;
96  callbacks.releaseConsumer:=@FinishStreamData;
97  Result:=CGDataConsumerCreate(str, callbacks);
98end;
99
100function CarbonImageToStream(img: CGImageRef; dst: TStream; CarbonImageType: CFStringRef): Boolean;
101var
102  idst  : CGImageDestinationRef;
103  cg    : CGDataConsumerRef;
104begin
105  Result := Assigned(img) and Assigned(dst);
106  if not Result then Exit;
107  cg := AllocStreamConsumer(dst);
108  idst := CGImageDestinationCreateWithDataConsumer(cg, CarbonImageType, 1, nil);
109  Result := Assigned(idst);
110  if Result then
111  begin
112    CGImageDestinationAddImage(idst, img, nil);
113    CGImageDestinationFinalize(idst);
114    CFRelease(idst);
115  end;
116  CFRelease(cg);
117end;
118
119function GetImageFromPasteboard(Pasteboard: PasteboardRef; ID: PasteboardItemID; UTI: CFStringRef): CGImageRef;
120var
121  data  : CFDataRef;
122  prov  : CGImageSourceRef;
123begin
124  PasteboardCopyItemFlavorData(PasteBoard, ID, UTI, Data{%H-});
125  prov := CGImageSourceCreateWithData(Data, nil);
126  Result:=CGImageSourceCreateImageAtIndex(prov, 0, nil);
127  CFRelease(prov);
128  CFRelease(data);
129end;
130
131
132{ TCarbonClipboard }
133
134{------------------------------------------------------------------------------
135  Method:  TCarbonClipboard.FindFormat
136  Params:  UTI
137  Returns: The corresponding registered format identifier
138 ------------------------------------------------------------------------------}
139function TCarbonClipboard.FindFormat(const UTI: CFStringRef): TClipboardFormat;
140var
141  I: Integer;
142begin
143  for I := 1 to FFormats.Count - 1 do
144  begin
145    if UTTypeEqual(UTI, CFStringRef(FFormats[I])) then
146    begin
147      Result := I;
148      Exit;
149    end;
150  end;
151
152  Result := 0;
153end;
154
155{------------------------------------------------------------------------------
156  Method:  TCarbonClipboard.Create
157 ------------------------------------------------------------------------------}
158constructor TCarbonClipboard.Create;
159var
160  T: TClipboardType;
161begin
162  for T := Low(TClipboardType) to High(TClipboardType) do
163  begin
164    OSError(
165      PasteboardCreate(ClipboardTypeToPasteboard[T], FPasteboards[T]),
166      Self, SCreate, 'PasteboardCreate', ClipboardTypeName[T]);
167
168    FOnClipboardRequest[T] := nil;
169  end;
170  FOwnerShips := 0;
171
172  FFormats := TList.Create;
173
174  FFormats.Add(nil); // add default supported text formats
175  FFormats.Add(kUTTypePlainText);
176  FFormats.Add(kUTTypeUTF8PlainText);
177  FFormats.Add(kUTTypeUTF16PlainText);
178
179  RegisterFormat(PredefinedClipboardMimeTypes[pcfText]);
180
181end;
182
183{------------------------------------------------------------------------------
184  Method:  TCarbonClipboard.Destroy
185 ------------------------------------------------------------------------------}
186destructor TCarbonClipboard.Destroy;
187var
188  T: TClipboardType;
189  I: Integer;
190  S: CFStringRef;
191begin
192  for I := 4 to FFormats.Count - 1 do // 0..3 are predefined
193  begin
194    S := FFormats[I];
195    FreeCFString(S);
196  end;
197
198  FFormats.Free;
199
200  for T := Low(TClipboardType) to High(TClipboardType) do
201    CFRelease(FPasteboards[T]);
202
203  inherited Destroy;
204end;
205
206{------------------------------------------------------------------------------
207  Method:  TCarbonClipboard.CheckOwnerShip
208
209  Checks the ownership
210 ------------------------------------------------------------------------------}
211procedure TCarbonClipboard.CheckOwnerShip;
212var
213  T: TClipboardType;
214begin
215  for T := Low(TClipboardType) to High(TClipboardType) do
216  begin
217    if FOnClipboardRequest[T] = nil then Continue;
218    if (PasteboardSynchronize(FPasteboards[T]) and
219      kPasteboardClientIsOwner) = 0 then
220    begin  // inform LCL about ownership lost
221      Dec(FOwnerShips);
222      FOnClipboardRequest[T](0, nil);
223    end;
224  end;
225end;
226
227{------------------------------------------------------------------------------
228  Method:  TCarbonClipboard.Clear
229  Params:  ClipboardType - Clipboard type
230  Returns: If the function succeeds
231
232  Clears the specified clipboard and gets ownership
233 ------------------------------------------------------------------------------}
234function TCarbonClipboard.Clear(ClipboardType: TClipboardType): Boolean;
235var
236  Pasteboard: PasteboardRef;
237begin
238  Result := False;
239  Pasteboard := FPasteboards[ClipboardType];
240
241  if OSError(PasteboardClear(Pasteboard), Self, 'Clear', 'PasteboardClear') then Exit;
242  PasteboardSynchronize(Pasteboard);
243  Result := True;
244end;
245
246{------------------------------------------------------------------------------
247  Method:  TCarbonClipboard.FormatToMimeType
248  Params:  FormatID - A registered format identifier (0 is invalid)
249  Returns: The corresponding mime type as string
250 ------------------------------------------------------------------------------}
251function TCarbonClipboard.FormatToMimeType(FormatID: TClipboardFormat): String;
252var
253  S: CFStringRef;
254begin
255  if (FormatID > 0) and (FormatID < TClipboardFormat(FFormats.Count)) then
256  begin
257    S := UTTypeCopyPreferredTagWithClass(CFStringRef(FFormats[FormatID]), kUTTagClassMIMEType);
258    try
259      Result := CFStringToStr(S);
260      if (Result='') and (CFStringToStr(CFStringRef(FFormats[FormatID]))='com.microsoft.bmp') then
261        Result:='image/bmp';
262    finally
263      FreeCFString(S);
264    end;
265  end
266  else
267    Result := '';
268end;
269
270{------------------------------------------------------------------------------
271  Method:  TCarbonClipboard.GetData
272  Params:  ClipboardType - Clipboard type
273           FormatID      - A registered format identifier (0 is invalid)
274           Stream        - If format is available, it will be appended to this
275                           stream
276  Returns: If the function succeeds
277 ------------------------------------------------------------------------------}
278function TCarbonClipboard.GetData(ClipboardType: TClipboardType;
279  FormatID: TClipboardFormat; Stream: TStream): Boolean;
280var
281  Pasteboard: PasteboardRef;
282  I: Integer;
283  UTI, CFString: CFStringRef;
284  Encoding: CFStringEncoding;
285  Flavors: CFArrayRef;
286  FlavorData: CFDataRef;
287  Count: ItemCount;
288  ID: PasteboardItemID;
289  S: String;
290
291  Image:CGImageRef;
292  ImageUTI: CFStringRef;
293  ImageConfort: Boolean;
294const
295  SName = 'GetData';
296
297  function HasFormat(Format: CFStringRef): Boolean;
298  var
299    FlavorCount: CFIndex;
300    J: Integer;
301  begin
302    Result := False;
303    FlavorCount := CFArrayGetCount(Flavors);
304    for J := 0 to FlavorCount - 1 do
305      if UTTypeEqual(Format, CFArrayGetValueAtIndex(Flavors, J)) then
306      begin
307        //DebugLn('Has UTI ' + CFStringToStr(Format));
308        Result := True;
309        Break;
310      end;
311  end;
312
313  function HasConfortingFormat(ConfortTo: CFStringRef; var UTIFormat: CFStringRef): Boolean;
314  var
315    J : Integer;
316    FlavorCount: CFIndex;
317  begin
318    Result := False;
319    UTIFormat := nil;
320    FlavorCount := CFArrayGetCount(Flavors);
321    for J := 0 to FlavorCount - 1 do
322      if UTTypeConformsTo(CFArrayGetValueAtIndex(Flavors, J), ConfortTo) then
323      begin
324        //DebugLn('Has UTI ' + CFStringToStr(Format));
325        UTIFormat := CFArrayGetValueAtIndex(Flavors, J);
326        Result := True;
327        Break;
328      end;
329  end;
330
331begin
332  Result := False;
333  ImageConfort:=False;
334
335  if not ((FormatID > 0) and (FormatID < TClipboardFormat(FFormats.Count))) then
336  begin
337    DebugLn('TCarbonClipboard.GetData Error: Invalid Format ' + DbgS(FormatID) + ' specified!');
338    Exit;
339  end;
340
341  Pasteboard := FPasteboards[ClipboardType];
342
343  PasteboardSynchronize(Pasteboard);
344  if OSError(PasteboardGetItemCount(Pasteboard, Count{%H-}), Self, SName,
345    'PasteboardGetItemCount') then Exit;
346  if Count < 1 then Exit;
347
348  for I := 1 to Count do
349  begin
350    if OSError(PasteboardGetItemIdentifier(Pasteboard, I, ID{%H-}), Self, SName,
351      'PasteboardGetItemIdentifier') then Continue;
352    if OSError(PasteboardCopyItemFlavors(Pasteboard, ID, Flavors{%H-}), Self, SName,
353      'PasteboardCopyItemFlavors') then Continue;
354
355    UTI := FFormats[FormatID];
356    if FormatID = 1 then
357    begin
358      if HasFormat(FFormats[2]) then UTI := FFormats[2]   // check UTF-8 text
359      else
360        if HasFormat(FFormats[3]) then UTI := FFormats[3] // check UTF-16 text
361        else
362          if not HasFormat(UTI) then Exit;               // check plain text
363    end
364    else
365      if not HasFormat(UTI) then
366      begin
367        // System built-in images can be converted to a necessary format.
368        // ImageUTI - is the necessary format.
369        ImageUTI:=UTI;
370        // UTI - is not conforming format available in pasteboard
371        ImageConfort:=UTTypeConformsTo(ImageUTI, kUTTypeImage) and HasConfortingFormat(kUTTypeImage, UTI);
372        if not ImageConfort then Exit;
373      end;
374
375    //DebugLn('TCarbonClipboard.GetData Paste FlavorType: ' + CFStringToStr(UTI));
376
377    if OSError(PasteboardCopyItemFlavorData(Pasteboard, ID, UTI, FlavorData{%H-}),
378      Self, SGetData, 'PasteboardCopyItemFlavorData') then Continue;
379    try
380      if CFDataGetLength(FlavorData) = 0 then
381      begin
382        Result := True;
383        Exit;
384      end;
385      //DebugLn('TCarbonClipboard.GetData Paste FlavordataLength: ' + DbgS(CFDataGetLength(FlavorData)));
386
387      if FormatID = 1 then
388      begin
389        if UTI =  FFormats[2] then // UTF-8 text
390            Encoding := kCFStringEncodingUTF8;
391        if UTI =  FFormats[3] then // UTF-16 text
392            Encoding := kCFStringEncodingUTF16;
393        if UTI =  FFormats[1] then // plain text
394            Encoding := CFStringGetSystemEncoding;
395
396        CreateCFString(FlavorData, Encoding, CFString);
397        try
398          S := CFStringtoStr(CFString);
399          Stream.Write(S[1], Length(S));
400        finally
401          FreeCFString(CFString);
402        end
403      end
404      else
405      begin
406        if ImageConfort then
407        begin
408          Image:=GetImageFromPasteboard(Pasteboard, ID, UTI);
409          CarbonImageToStream(Image, Stream, ImageUTI);
410          CGImageRelease(Image);
411        end
412        else
413          Stream.Write(CFDataGetBytePtr(FlavorData)^, CFDataGetLength(FlavorData));
414      end;
415    finally
416      CFRelease(FlavorData);
417    end;
418
419    Result := True;
420    Exit;
421  end;
422end;
423
424{------------------------------------------------------------------------------
425  Method:  TCarbonClipboard.GetFormats
426  Params:  ClipboardType - The type of clipboard operation
427           Count         - The number of clipboard formats
428           List          - Pointer to an array of supported formats
429                           (you must free it yourself)
430  Returns: If the function succeeds
431 ------------------------------------------------------------------------------}
432function TCarbonClipboard.GetFormats(ClipboardType: TClipboardType;
433  var Count: Integer; var List: PClipboardFormat): Boolean;
434var
435  Pasteboard: PasteboardRef;
436  I, J: Integer;
437  Flavors: CFArrayRef;
438  UTI: CFStringRef;
439  FlavorCount: CFIndex;
440  FormatID: TClipboardFormat;
441  C: ItemCount;
442  ID: PasteboardItemID;
443  Formats: TList;
444  isImageFormat: Boolean;
445const
446  SName = 'GetFormats';
447begin
448  Result := False;
449
450  Pasteboard := FPasteboards[ClipboardType];
451
452  PasteboardSynchronize(Pasteboard);
453  if OSError(PasteboardGetItemCount(Pasteboard, C{%H-}), Self, SName,
454    'PasteboardGetItemCount') then Exit;
455  if C < 1 then Exit;
456
457  isImageFormat:=False;
458  Formats := TList.Create;
459  try
460    for I := 1 to C do
461    begin
462      if OSError(PasteboardGetItemIdentifier(Pasteboard, I, ID{%H-}), Self, SName,
463        'PasteboardGetItemIdentifier') then Continue;
464      if OSError(PasteboardCopyItemFlavors(Pasteboard, ID, Flavors{%H-}), Self, SName,
465        'PasteboardCopyItemFlavors') then Continue;
466
467      FlavorCount := CFArrayGetCount(Flavors);
468      for J := 0 to FlavorCount - 1 do
469      begin
470        UTI := CFArrayGetValueAtIndex(Flavors, J);
471        isImageFormat:=isImageFormat or UTTypeConformsTo(UTI, kUTTypePICT);
472        //DebugLn('TCarbonClipboard.GetFormats ' + CFStringToStr(UTI));
473
474        FormatID := FindFormat(UTI);
475        if FormatID = 0 then
476          FormatID := FFormats.Add(UTI)
477        else
478          // reserved text format!
479          if FormatID < 4 then FormatID:=1;
480
481        if Formats.IndexOf({%H-}Pointer(FormatID)) = -1 then
482        begin
483          //DebugLn('TCarbonClipboard.GetFormats ' + FormatToMimeType(FormatID) +
484          //  ' ' + CFStringToStr(UTI));
485          Formats.Add({%H-}Pointer(FormatID));
486        end;
487      end;
488    end;
489
490    if isImageFormat then
491    begin
492      // there's an image format in the clipboard, it can be converted
493      // to Bitmap. Since most of the delphi software is using CF_Bitmap as
494      // a common format, it's necessary to "emulate" bitmap presence!
495      FormatID:=FindFormat(kUTTypeBMP);
496      if (FormatID>0) and (Formats.IndexOf({%H-}Pointer(FormatID))=-1) then
497        Formats.Add({%H-}Pointer(FormatID));
498    end;
499
500
501    Count := Formats.Count;
502    GetMem(List, Count * SizeOf(TClipboardFormat));
503    for I := 0 to Count - 1 do List[i] := {%H-}TClipboardFormat(Formats[I]);
504  finally
505    Formats.Free;
506  end;
507
508  Result := True;
509end;
510
511{------------------------------------------------------------------------------
512  Method:  TCarbonClipboard.GetOwnerShip
513  Params:  ClipboardType - Type of clipboard
514           OnRequestProc - TClipboardRequestEvent is defined in LCLType.pp
515                           If OnRequestProc is nil the onwership will end.
516           FormatCount   - Number of formats
517           Formats       - Array of TClipboardFormat. The supported formats the
518                           owner provides.
519
520  Returns: If the function succeeds
521
522  Sets the supported formats and requests ownership for the clipboard.
523  The OnRequestProc is used to get the data from the LCL and to put it on the
524  clipboard.
525  If someone else requests the ownership, the OnRequestProc will be executed
526  with the invalid FormatID 0 to notify the old owner of the lost of ownership.
527 ------------------------------------------------------------------------------}
528function TCarbonClipboard.GetOwnerShip(ClipboardType: TClipboardType;
529  OnRequestProc: TClipboardRequestEvent; FormatCount: Integer;
530  Formats: PClipboardFormat): Boolean;
531
532  procedure AddData(Format: CFStringRef; CFData: CFDataRef);
533  begin
534    if CFData = nil then Exit;
535    //DebugLn('Add Data ' + CFStringToStr(Format));
536
537    OSError(PasteboardPutItemFlavor(FPasteboards[ClipboardType],
538          PasteboardItemID(1), Format, CFData, 0),
539        Self, 'GetOwnerShip', 'PasteboardPutItemFlavor');
540  end;
541
542  procedure PutOnClipboard;
543  var
544    DataStream: TStringStream;
545    I: Integer;
546    CFString: CFStringRef;
547  begin
548    DataStream := TStringStream.Create('');
549
550    for I := 0 to FormatCount - 1 do
551    begin
552      if not ((Formats[I] > 0) and (Formats[I] < TClipboardFormat(FFormats.Count))) then
553      begin
554        DebugLn('TCarbonClipboard.GetOwnerShip Error: Invalid Format ' + DbgS(Formats[I]) + ' specified!');
555        Continue;
556      end;
557
558      DataStream.Size := 0;
559      DataStream.Position := 0;
560      FOnClipBoardRequest[ClipboardType](Formats[I], DataStream);
561
562      if Formats[I] = 1 then // add more unicode and mac text formats
563      begin
564        CreateCFString(DataStream.DataString, CFString);
565        try
566          // UTF-8 text
567          AddData(FFormats[2], CFStringToData(CFString, kCFStringEncodingUTF8));
568          // UTF-16 text
569          AddData(FFormats[3], CFStringToData(CFString, kCFStringEncodingUTF16));
570          // plain text
571          AddData(FFormats[1], CFStringToData(CFString, CFStringGetSystemEncoding));
572        finally
573          FreeCFString(CFString);
574        end;
575      end
576      else
577        if DataStream.Size>0 then
578          AddData(FFormats[Formats[I]], CFDataCreate(nil, @DataStream.DataString[1],
579            DataStream.Size));
580    end;
581
582    DataStream.Free;
583  end;
584
585begin
586  Result := False;
587  //DebugLn('TCarbonClipboard.GetOwnerShip');
588
589  if (FormatCount = 0) or (OnRequestProc = nil) then
590  begin
591    // The LCL indicates it doesn't have the clipboard data anymore
592    // and the interface can't use the OnRequestProc anymore.
593    FOnClipboardRequest[ClipboardType] := nil;
594    Dec(FOwnerShips);
595  end
596  else
597  begin
598    // clear OnClipBoardRequest to prevent destroying the LCL clipboard,
599    // when emptying the clipboard
600    FOnClipboardRequest[ClipboardType] := nil;
601    if not Clear(ClipboardType) then Exit;
602
603    Inc(FOwnerShips);
604    FOnClipboardRequest[ClipboardType] := OnRequestProc;
605    PutOnClipboard;
606  end;
607
608  Result := True;
609end;
610
611function GetLCLPredefinedUTI(const LCLMimeType: String): CFStringRef;
612begin
613  if (LCLMimeType='image/bmp') or (LCLMimeType='image/delphi.bitmap') then
614    Result:=kUTTypeBMP
615  else if (LCLMimeType='image/png') then
616    Result:=kUTTypePNG
617  else if (LCLMimeType='image/jpeg') then
618    Result:=kUTTypeJPEG
619  else
620    Result:=nil;
621end;
622
623{------------------------------------------------------------------------------
624  Method:  TCarbonClipboard.RegisterFormat
625  Params:  AMimeType - A string (usually a MIME type) identifying a new format
626                       type to register
627  Returns: The registered Format identifier (TClipboardFormat)
628 ------------------------------------------------------------------------------}
629function TCarbonClipboard.RegisterFormat(const AMimeType: String): TClipboardFormat;
630var
631  UTI, M: CFStringRef;
632begin
633  CreateCFString(AMimeType, M);
634  try
635    UTI := GetLCLPredefinedUTI(AMimeType);
636    if not Assigned(UTI) then
637      UTI := UTTypeCreatePreferredIdentifierForTag(kUTTagClassMIMEType, M, nil);
638  finally
639    FreeCFString(M);
640  end;
641
642  Result := FindFormat(UTI);
643  if Result = 0 then
644  begin
645    //DebugLn('TCarbonClipboard.RegisterFormat ' + AMimeType + ' ' + CFStringToStr(UTI));
646    Result := FFormats.Add(UTI);
647  end
648  else
649    FreeCFString(UTI);
650end;
651
652initialization
653
654  CreateCFString('com.apple.pasteboard.find', ClipboardTypeToPasteboard[ctSecondarySelection]);
655  CreateCFString('com.apple.pasteboard.clipboard', ClipboardTypeToPasteboard[ctClipboard]);
656  Clipboard := TCarbonClipboard.Create;
657
658finalization
659
660  FreeAndNil(Clipboard);
661  FreeCFString(ClipboardTypeToPasteboard[ctSecondarySelection]);
662  FreeCFString(ClipboardTypeToPasteboard[ctClipboard]);
663
664
665end.
666