← Back to branch summary

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

« back to all changes in this revision

Viewing changes to components/codetools/ide/codyutils.pas

  • 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:
components/codetools/ide/codyutils.pas
 
1
{
 
2
 ***************************************************************************
 
3
 *                                                                         *
 
4
 *   This source is free software; you can redistribute it and/or modify   *
 
5
 *   it under the terms of the GNU General Public License as published by  *
 
6
 *   the Free Software Foundation; either version 2 of the License, or     *
 
7
 *   (at your option) any later version.                                   *
 
8
 *                                                                         *
 
9
 *   This code is distributed in the hope that it will be useful, but      *
 
10
 *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
 
11
 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
 
12
 *   General Public License for more details.                              *
 
13
 *                                                                         *
 
14
 *   A copy of the GNU General Public License is available on the World    *
 
15
 *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
 
16
 *   obtain it by writing to the Free Software Foundation,                 *
 
17
 *   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
 
18
 *                                                                         *
 
19
 ***************************************************************************
 
20
 
 
21
  Author: Mattias Gaertner
 
22
 
 
23
  Abstract:
 
24
    Common functions.
 
25
}
 
26
unit CodyUtils;
 
27
 
 
28
{$mode objfpc}{$H+}
 
29
 
 
30
interface
 
31
 
 
32
uses
 
33
  Classes, SysUtils, Dialogs, Controls, LCLIntf, Clipbrd, LCLType, LResources,
 
34
  // IDEIntf
 
35
  IDEDialogs, LazIDEIntf, SrcEditorIntf, IDEHelpIntf,
 
36
  FileProcs, CodeToolManager, CodeCache, SourceLog, BasicCodeTools,
 
37
  EventCodeTool, LinkScanner, PascalParserTool, CodeTree, SourceChanger,
 
38
  CodeBeautifier,
 
39
  CodyStrConsts;
 
40
 
 
41
type
 
42
 
 
43
  { TCodyClipboardData }
 
44
 
 
45
  TCodyClipboardData = class
 
46
  public
 
47
    AsText: string;
 
48
    procedure WriteString(MemStream: TMemoryStream; const s: string);
 
49
    function ReadString(MemStream: TMemoryStream): string;
 
50
    procedure WriteToStream(MemStream: TMemoryStream); virtual; abstract;
 
51
    procedure ReadFromStream(MemStream: TMemoryStream); virtual; abstract;
 
52
    procedure Execute({%H-}SrcEdit: TSourceEditorInterface; {%H-}LogXY: TPoint); virtual;
 
53
  end;
 
54
  TCodyClipboardFormat = class of TCodyClipboardData;
 
55
 
 
56
  { TCodyClipboardSrcData }
 
57
 
 
58
  TCodyClipboardSrcData = class(TCodyClipboardData)
 
59
  public
 
60
    SourceFilename: string;
 
61
    SourceX: integer;
 
62
    SourceY: integer;
 
63
    procedure SetSourcePos(const SrcPos: TCodeXYPosition);
 
64
    procedure WriteToStream(MemStream: TMemoryStream); override;
 
65
    procedure ReadFromStream(MemStream: TMemoryStream); override;
 
66
  end;
 
67
 
 
68
  { TCody }
 
69
 
 
70
  TCody = class
 
71
  private
 
72
    FClipboardFormats: TFPList;
 
73
    function GetClipboardFormats(Index: integer): TCodyClipboardFormat;
 
74
  public
 
75
    constructor Create;
 
76
    destructor Destroy; override;
 
77
 
 
78
    procedure DecodeLoaded(Sender: TSourceLog; const Filename: string;
 
79
                           var Source, DiskEncoding, MemEncoding: string);
 
80
 
 
81
    // clipboard
 
82
    class function ClipboardFormatId: TClipboardFormat;
 
83
    function CanReadFromClipboard(AClipboard: TClipboard): Boolean;
 
84
    function ReadFromClipboard(AClipboard: TClipboard;
 
85
        SrcEdit: TSourceEditorInterface; LogXY: TPoint; AText: string): boolean;
 
86
    function WriteToClipboard(Data: TCodyClipboardData;
 
87
                              AClipboard: TClipboard = nil): Boolean;
 
88
    procedure RegisterClipboardFormat(ccFormat: TCodyClipboardFormat);
 
89
    function FindClipboardFormat(aName: string): TCodyClipboardFormat;
 
90
    function ClipboardFormatCount: integer;
 
91
    property ClipboardFormats[Index: integer]: TCodyClipboardFormat
 
92
                                                       read GetClipboardFormats;
 
93
    procedure SrcEditCopyPaste(SrcEdit: TSourceEditorInterface;
 
94
      var AText: String; var {%H-}AMode: TSemSelectionMode; ALogStartPos: TPoint;
 
95
      var AnAction: TSemCopyPasteAction);
 
96
  end;
 
97
 
 
98
var
 
99
  Cody: TCody;
 
100
 
 
101
type
 
102
  TCUParseError = (
 
103
    cupeNoSrcEditor,
 
104
    cupeMainCodeNotFound, // the file of the unit start was not found
 
105
    cupeParseError,
 
106
    cupeCursorNotInCode, // e.g. in front of the keyword 'unit'
 
107
    cupeSuccess
 
108
    );
 
109
 
 
110
procedure ExplodeAWithBlockCmd(Sender: TObject);
 
111
procedure InsertFileAtCursor(Sender: TObject);
 
112
procedure InsertCallInherited(Sender: TObject);
 
113
 
 
114
function ParseTilCursor(out Tool: TCodeTool; out CleanPos: integer;
 
115
   out Node: TCodeTreeNode; out ErrorHandled: boolean;
 
116
   JumpToError: boolean; CodePos: PCodeXYPosition = nil): TCUParseError;
 
117
function ParseUnit(out Tool: TCodeTool; out CleanPos: integer;
 
118
   out Node: TCodeTreeNode; out ErrorHandled: boolean;
 
119
   JumpToError: boolean; CodePos: PCodeXYPosition = nil;
 
120
   TilCursor: boolean = false): TCUParseError;
 
121
procedure OpenCodyHelp(Path: string);
 
122
 
 
123
implementation
 
124
 
 
125
procedure ExplodeAWithBlockCmd(Sender: TObject);
 
126
 
 
127
  procedure ErrorNotInWithVar;
 
128
  begin
 
129
    IDEMessageDialog(crsCWError,
 
130
      crsCWPleasePlaceTheCursorOfTheSourceEditorOnAWithVariab,
 
131
      mtError,[mbCancel]);
 
132
  end;
 
133
 
 
134
var
 
135
  SrcEdit: TSourceEditorInterface;
 
136
begin
 
137
  // commit changes form source editor to codetools
 
138
  if not LazarusIDE.BeginCodeTools then exit;
 
139
  // check context at cursor
 
140
  SrcEdit:=SourceEditorManagerIntf.ActiveEditor;
 
141
  if SrcEdit=nil then begin
 
142
    ErrorNotInWithVar;
 
143
    exit;
 
144
  end;
 
145
  if not CodeToolBoss.RemoveWithBlock(SrcEdit.CodeToolsBuffer as TCodeBuffer,
 
146
    SrcEdit.CursorTextXY.X,SrcEdit.CursorTextXY.Y)
 
147
  then begin
 
148
    // syntax error or not in a class
 
149
    if CodeToolBoss.ErrorMessage<>'' then
 
150
      LazarusIDE.DoJumpToCodeToolBossError
 
151
    else
 
152
      ErrorNotInWithVar;
 
153
    exit;
 
154
  end;
 
155
end;
 
156
 
 
157
procedure InsertFileAtCursor(Sender: TObject);
 
158
var
 
159
  OpenDialog: TOpenDialog;
 
160
  Filter: String;
 
161
  Filename: String;
 
162
  Code: TCodeBuffer;
 
163
  SrcEdit: TSourceEditorInterface;
 
164
begin
 
165
  SrcEdit:=SourceEditorManagerIntf.ActiveEditor;
 
166
  if SrcEdit=nil then exit;
 
167
 
 
168
  OpenDialog:=TOpenDialog.Create(nil);
 
169
  Code:=nil;
 
170
  try
 
171
    InitIDEFileDialog(OpenDialog);
 
172
    OpenDialog.Title:=crsCUSelectFileToInsertAtCursor;
 
173
    OpenDialog.Options:=OpenDialog.Options+[ofFileMustExist];
 
174
    Filter:=crsCUPascalPasPpPasPp;
 
175
    Filter:=Format(crsCUAllFiles, [Filter, FileMask, FileMask]);
 
176
    OpenDialog.Filter:=Filter;
 
177
    if not OpenDialog.Execute then exit;
 
178
    Filename:=OpenDialog.FileName;
 
179
    if not FileIsText(Filename) then begin
 
180
      if IDEMessageDialog(crsCUWarning, crsCUTheFileSeemsToBeABinaryProceed,
 
181
        mtConfirmation,[mbOk,mbCancel])<>mrOK then exit;
 
182
    end;
 
183
    Code:=TCodeBuffer.Create;
 
184
    Code.Filename:=Filename;
 
185
    Code.OnDecodeLoaded:=@Cody.DecodeLoaded;
 
186
    if not Code.LoadFromFile(Filename) then begin
 
187
      IDEMessageDialog(crsCWError, Format(crsCUUnableToLoadFile, [Filename, #13
 
188
        , Code.LastError]),
 
189
        mtError,[mbCancel]);
 
190
      exit;
 
191
    end;
 
192
 
 
193
    SrcEdit.Selection:=Code.Source;
 
194
  finally
 
195
    OpenDialog.Free;
 
196
    Code.Free;
 
197
  end;
 
198
end;
 
199
 
 
200
procedure InsertCallInherited(Sender: TObject);
 
201
 
 
202
  procedure ErrorNotInMethod;
 
203
  begin
 
204
    IDEMessageDialog(crsCWError,
 
205
      crsCUPleasePlaceTheCursorOfTheSourceEditorInAnImplement,
 
206
      mtError,[mbCancel]);
 
207
  end;
 
208
 
 
209
var
 
210
  Handled: boolean;
 
211
  Tool: TEventsCodeTool;
 
212
  CleanPos: integer;
 
213
  CursorNode: TCodeTreeNode;
 
214
  ProcNode: TCodeTreeNode;
 
215
  DeclNode: TCodeTreeNode;
 
216
  NewCode: String;
 
217
  SrcEdit: TSourceEditorInterface;
 
218
  Indent: LongInt;
 
219
  IndentContextSensitive: Boolean;
 
220
  NewIndent: TFABIndentationPolicy;
 
221
  NewLine: Boolean;
 
222
  Gap: TGapTyp;
 
223
  FromPos: Integer;
 
224
  ToPos: Integer;
 
225
  NewXY: TPoint;
 
226
begin
 
227
  if (ParseTilCursor(Tool,CleanPos,CursorNode,Handled,true)<>cupeSuccess)
 
228
  and not Handled then begin
 
229
    ErrorNotInMethod;
 
230
    exit;
 
231
  end;
 
232
  SrcEdit:=SourceEditorManagerIntf.ActiveEditor;
 
233
  try
 
234
    try
 
235
      ProcNode:=CursorNode.GetNodeOfType(ctnProcedure);
 
236
      if not Tool.NodeIsMethodBody(ProcNode) then begin
 
237
        debugln(['InsertCallInherited not in a method body']);
 
238
        exit;
 
239
      end;
 
240
      // search the declaration (the header of the body may be incomplete)
 
241
      DeclNode:=Tool.FindCorrespondingProcNode(ProcNode);
 
242
      if DeclNode=nil then
 
243
        DeclNode:=ProcNode;
 
244
      Handled:=true;
 
245
      NewCode:='inherited '+Tool.ExtractProcHead(DeclNode,
 
246
        [phpWithoutClassName,phpWithParameterNames,phpWithoutParamTypes,
 
247
         phpWithoutSemicolon]);
 
248
      NewCode:=StringReplace(NewCode,';',',',[rfReplaceAll])+';';
 
249
      //debugln(['InsertCallInherited NewCode="',NewCode,'"']);
 
250
      NewLine:=true;
 
251
      Gap:=gtNone;
 
252
      if Tool.NodeIsFunction(DeclNode) then begin
 
253
        if FindFirstNonSpaceCharInLine(Tool.Src,CleanPos)<CleanPos then begin
 
254
          // insert function behind some code
 
255
          // e.g. InheritedValue:=|
 
256
          Indent:=0;
 
257
          NewLine:=false;
 
258
        end else begin
 
259
          // store the old result value
 
260
          NewCode:='Result:='+NewCode;
 
261
        end;
 
262
      end else
 
263
        NewLine:=true; // procedures always on a separate line
 
264
      FromPos:=CleanPos;
 
265
      ToPos:=CleanPos;
 
266
 
 
267
      if NewLine then begin
 
268
        // auto indent
 
269
        Gap:=gtNewLine;
 
270
        Indent:=SrcEdit.CursorScreenXY.X-1;
 
271
        IndentContextSensitive:=true;
 
272
        if CodeToolBoss.Indenter.GetIndent(Tool.Src,CleanPos,
 
273
          Tool.Scanner.NestedComments,
 
274
          true,NewIndent,IndentContextSensitive,NewCode)
 
275
        and NewIndent.IndentValid then begin
 
276
          Indent:=NewIndent.Indent;
 
277
        end;
 
278
        while (FromPos>1) and (Tool.Src[FromPos-1] in [' ',#9]) do
 
279
          dec(FromPos);
 
280
        NewCode:=GetIndentStr(Indent)+NewCode;
 
281
        //debugln(['InsertCallInherited Indent=',Indent,' Line="',GetLineInSrc(Tool.Src,CleanPos),'"']);
 
282
      end;
 
283
 
 
284
      NewCode:=CodeToolBoss.SourceChangeCache.BeautifyCodeOptions.BeautifyStatement(
 
285
        NewCode,Indent,[bcfDoNotIndentFirstLine],GetPosInLine(Tool.Src,FromPos));
 
286
      CodeToolBoss.SourceChangeCache.MainScanner:=Tool.Scanner;
 
287
      // move editor cursor in front of insert position
 
288
      NewXY:=Point(GetPosInLine(Tool.Src,FromPos)+1,SrcEdit.CursorTextXY.Y);
 
289
      //debugln(['InsertCallInherited NewXY=',dbgs(NewXY),' FromPos=',Tool.CleanPosToStr(FromPos),' ToPos=',Tool.CleanPosToStr(ToPos)]);
 
290
      if not CodeToolBoss.SourceChangeCache.Replace(Gap,Gap,FromPos,ToPos,NewCode)
 
291
      then begin
 
292
        debugln(['InsertCallInherited CodeToolBoss.SourceChangeCache.Replace failed']);
 
293
        exit;
 
294
      end;
 
295
      SrcEdit.BeginUndoBlock{$IFDEF SynUndoDebugBeginEnd}('InsertCallInherited'){$ENDIF};
 
296
      try
 
297
        SrcEdit.CursorTextXY:=NewXY;
 
298
        if not CodeToolBoss.SourceChangeCache.Apply then begin
 
299
          debugln(['InsertCallInherited CodeToolBoss.SourceChangeCache.Apply failed']);
 
300
          exit;
 
301
        end;
 
302
      finally
 
303
        SrcEdit.EndUndoBlock{$IFDEF SynUndoDebugBeginEnd}('InsertCallInherited'){$ENDIF};
 
304
      end;
 
305
    except
 
306
      on e: Exception do CodeToolBoss.HandleException(e);
 
307
    end;
 
308
  finally
 
309
    // syntax error or not in a method
 
310
    if not Handled then begin
 
311
      if CodeToolBoss.ErrorMessage<>'' then
 
312
        LazarusIDE.DoJumpToCodeToolBossError
 
313
      else
 
314
        ErrorNotInMethod;
 
315
    end;
 
316
  end;
 
317
end;
 
318
 
 
319
function ParseTilCursor(out Tool: TCodeTool; out CleanPos: integer;
 
320
  out Node: TCodeTreeNode; out ErrorHandled: boolean;
 
321
  JumpToError: boolean; CodePos: PCodeXYPosition): TCUParseError;
 
322
begin
 
323
  Result:=ParseUnit(Tool,CleanPos,Node,ErrorHandled,JumpToError,CodePos,true);
 
324
end;
 
325
 
 
326
function ParseUnit(out Tool: TCodeTool; out CleanPos: integer;
 
327
  out Node: TCodeTreeNode; out ErrorHandled: boolean; JumpToError: boolean;
 
328
  CodePos: PCodeXYPosition; TilCursor: boolean): TCUParseError;
 
329
var
 
330
  SrcEdit: TSourceEditorInterface;
 
331
  CursorPos: TCodeXYPosition;
 
332
begin
 
333
  Tool:=nil;
 
334
  CleanPos:=0;
 
335
  Node:=nil;
 
336
  ErrorHandled:=false;
 
337
  if CodePos<>nil then CodePos^:=CleanCodeXYPosition;
 
338
  SrcEdit:=SourceEditorManagerIntf.ActiveEditor;
 
339
  if SrcEdit=nil then begin
 
340
    debugln(['CodyUtils.ParseTilCursor: no source editor']);
 
341
    exit(cupeNoSrcEditor);
 
342
  end;
 
343
  if not LazarusIDE.BeginCodeTools then exit;
 
344
 
 
345
  CursorPos.Code:=SrcEdit.CodeToolsBuffer as TCodeBuffer;
 
346
  CursorPos.X:=SrcEdit.CursorTextXY.X;
 
347
  CursorPos.Y:=SrcEdit.CursorTextXY.Y;
 
348
  if CodePos<>nil then
 
349
    CodePos^:=CursorPos;
 
350
  try
 
351
    if not CodeToolBoss.InitCurCodeTool(CursorPos.Code) then
 
352
      exit(cupeMainCodeNotFound);
 
353
    try
 
354
      Tool:=CodeToolBoss.CurCodeTool;
 
355
      Result:=cupeParseError;
 
356
      //Range:=trTillRange;
 
357
      if TilCursor then
 
358
        Tool.BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanPos,
 
359
                                    [btSetIgnoreErrorPos])
 
360
      else
 
361
        Tool.BuildTreeAndGetCleanPos(trTillRange,lsrEnd,CursorPos,CleanPos,[]);
 
362
      Node:=Tool.FindDeepestNodeAtPos(CleanPos,false);
 
363
      if Node=nil then
 
364
        exit(cupeCursorNotInCode);
 
365
      Result:=cupeSuccess;
 
366
    except
 
367
      on e: Exception do CodeToolBoss.HandleException(e);
 
368
    end;
 
369
  finally
 
370
    if (CodeToolBoss.ErrorMessage<>'') and JumpToError then begin
 
371
      ErrorHandled:=true;
 
372
      LazarusIDE.DoJumpToCodeToolBossError;
 
373
    end;
 
374
  end;
 
375
end;
 
376
 
 
377
procedure OpenCodyHelp(Path: string);
 
378
var
 
379
  BasePath: String;
 
380
begin
 
381
  BasePath:='http://wiki.lazarus.freepascal.org/Cody';
 
382
  OpenURL(BasePath+Path);
 
383
end;
 
384
 
 
385
{ TCodyClipboardSrcData }
 
386
 
 
387
procedure TCodyClipboardSrcData.SetSourcePos(const SrcPos: TCodeXYPosition);
 
388
begin
 
389
  SourceFilename:=SrcPos.Code.Filename;
 
390
  SourceX:=SrcPos.X;
 
391
  SourceY:=SrcPos.Y;
 
392
end;
 
393
 
 
394
procedure TCodyClipboardSrcData.WriteToStream(MemStream: TMemoryStream);
 
395
begin
 
396
  WriteString(MemStream,SourceFilename);
 
397
  WriteLRSInteger(MemStream,SourceY);
 
398
  WriteLRSInteger(MemStream,SourceX);
 
399
end;
 
400
 
 
401
procedure TCodyClipboardSrcData.ReadFromStream(MemStream: TMemoryStream);
 
402
begin
 
403
  SourceFilename:=ReadString(MemStream);
 
404
  SourceY:=ReadLRSInteger(MemStream);
 
405
  SourceX:=ReadLRSInteger(MemStream);
 
406
end;
 
407
 
 
408
{ TCodyClipboardData }
 
409
 
 
410
procedure TCodyClipboardData.WriteString(MemStream: TMemoryStream;
 
411
  const s: string);
 
412
var
 
413
  b: byte;
 
414
  l: Integer;
 
415
begin
 
416
  if length(s)<255 then begin
 
417
    b:=length(s);
 
418
    MemStream.Write(b,1);
 
419
    if b>0 then
 
420
      MemStream.Write(s[1],b);
 
421
  end else begin
 
422
    b:=255;
 
423
    MemStream.Write(b,1);
 
424
    l:=length(s);
 
425
    WriteLRSInteger(MemStream,l);
 
426
    MemStream.Write(s[1],l);
 
427
  end;
 
428
end;
 
429
 
 
430
function TCodyClipboardData.ReadString(MemStream: TMemoryStream): string;
 
431
var
 
432
  b: byte;
 
433
  l: integer;
 
434
begin
 
435
  Result:='';
 
436
  b:=0;
 
437
  if MemStream.Read(b,1)<>1 then exit;
 
438
  if b<255 then begin
 
439
    SetLength(Result,b);
 
440
    if Result<>'' then
 
441
      MemStream.Read(Result[1],b);
 
442
  end else begin
 
443
    l:=ReadLRSInteger(MemStream);
 
444
    if l<=0 then exit;
 
445
    SetLength(Result,l);
 
446
    MemStream.Read(Result[1],l);
 
447
  end;
 
448
  //debugln(['TCodyClipboardData.ReadString Result="',Result,'"']);
 
449
end;
 
450
 
 
451
procedure TCodyClipboardData.Execute(SrcEdit: TSourceEditorInterface;
 
452
  LogXY: TPoint);
 
453
begin
 
454
  raise Exception.Create('not implemented yet: '+ClassName+'.Execute');
 
455
end;
 
456
 
 
457
{ TCody }
 
458
 
 
459
function TCody.GetClipboardFormats(Index: integer): TCodyClipboardFormat;
 
460
begin
 
461
  Result:=TCodyClipboardFormat(FClipboardFormats[Index]);
 
462
end;
 
463
 
 
464
constructor TCody.Create;
 
465
begin
 
466
  FClipboardFormats:=TFPList.Create;
 
467
end;
 
468
 
 
469
destructor TCody.Destroy;
 
470
begin
 
471
  FreeAndNil(FClipboardFormats);
 
472
  inherited Destroy;
 
473
end;
 
474
 
 
475
procedure TCody.DecodeLoaded(Sender: TSourceLog; const Filename: string;
 
476
  var Source, DiskEncoding, MemEncoding: string);
 
477
begin
 
478
  //debugln(['TCody.DecodeLoaded ',Filename]);
 
479
  if (Sender is TCodeBuffer)
 
480
  and Assigned(CodeToolBoss.SourceCache.OnDecodeLoaded) then
 
481
    CodeToolBoss.SourceCache.OnDecodeLoaded(TCodeBuffer(Sender),Filename,
 
482
      Source,DiskEncoding,MemEncoding);
 
483
end;
 
484
 
 
485
class function TCody.ClipboardFormatId: TClipboardFormat;
 
486
const
 
487
  CodyClipboardMimeType = 'Application/X-Laz-Cody';
 
488
var
 
489
  ID: TClipboardFormat = 0;
 
490
begin
 
491
  if ID = 0 then
 
492
    ID := ClipboardRegisterFormat(CodyClipboardMimeType);
 
493
  Result := ID;
 
494
end;
 
495
 
 
496
function TCody.CanReadFromClipboard(AClipboard: TClipboard): Boolean;
 
497
begin
 
498
  Result := AClipboard.HasFormat(ClipboardFormatId);
 
499
end;
 
500
 
 
501
function TCody.ReadFromClipboard(AClipboard: TClipboard;
 
502
  SrcEdit: TSourceEditorInterface; LogXY: TPoint; AText: string): boolean;
 
503
 
 
504
  procedure InvalidStream;
 
505
  begin
 
506
    raise Exception.Create('The Cody clipboard data is invalid');
 
507
  end;
 
508
 
 
509
var
 
510
  MemStream: TMemoryStream;
 
511
  ID: ShortString;
 
512
  aFormat: TCodyClipboardFormat;
 
513
  Data: TCodyClipboardData;
 
514
begin
 
515
  Result:=false;
 
516
  if not AClipboard.HasFormat(ClipboardFormatId) then exit;
 
517
  Result:=true;
 
518
  MemStream:=TMemoryStream.Create;
 
519
  Data:=nil;
 
520
  try
 
521
    Result:=AClipboard.GetFormat(ClipboardFormatId,MemStream);
 
522
    ID:='';
 
523
    MemStream.Position:=0;
 
524
    if MemStream.Read(ID[0],1)<>1 then
 
525
      InvalidStream;
 
526
    if MemStream.Read(ID[1],ord(ID[0]))<>ord(ID[0]) then
 
527
      InvalidStream;
 
528
    aFormat:=FindClipboardFormat(ID);
 
529
    if aFormat=nil then
 
530
      InvalidStream;
 
531
    Data:=aFormat.Create;
 
532
    Data.AsText:=AText;
 
533
    Data.ReadFromStream(MemStream);
 
534
    Data.Execute(SrcEdit,LogXY);
 
535
  finally
 
536
    Data.Free;
 
537
    MemStream.Free;
 
538
  end;
 
539
end;
 
540
 
 
541
function TCody.WriteToClipboard(Data: TCodyClipboardData; AClipboard: TClipboard
 
542
  ): Boolean;
 
543
var
 
544
  MemStream: TMemoryStream;
 
545
  ID: ShortString;
 
546
begin
 
547
  if AClipboard=nil then AClipboard:=Clipboard;
 
548
  AClipboard.AsText:=Data.AsText;
 
549
  if not AClipboard.HasFormat(CF_TEXT) then
 
550
    raise Exception.Create('Write to clipboard failed');
 
551
  MemStream:=TMemoryStream.Create;
 
552
  try
 
553
    ID:=Data.ClassName;
 
554
    MemStream.Write(ID[0],length(ID)+1);
 
555
    Data.WriteToStream(MemStream);
 
556
    MemStream.Position:=0;
 
557
    Result:=AClipboard.AddFormat(ClipboardFormatId,MemStream);
 
558
  finally
 
559
    MemStream.Free;
 
560
  end;
 
561
end;
 
562
 
 
563
procedure TCody.RegisterClipboardFormat(ccFormat: TCodyClipboardFormat);
 
564
begin
 
565
  if FindClipboardFormat(ccFormat.ClassName)<>nil then
 
566
    raise Exception.Create('cody clipboard format "'+ccFormat.ClassName+'" is already registered');
 
567
  FClipboardFormats.Add(ccFormat);
 
568
end;
 
569
 
 
570
function TCody.FindClipboardFormat(aName: string): TCodyClipboardFormat;
 
571
var
 
572
  i: Integer;
 
573
begin
 
574
  for i:=0 to ClipboardFormatCount-1 do begin
 
575
    Result:=ClipboardFormats[i];
 
576
    if SysUtils.CompareText(Result.ClassName,aName)=0 then exit;
 
577
  end;
 
578
  Result:=nil;
 
579
end;
 
580
 
 
581
function TCody.ClipboardFormatCount: integer;
 
582
begin
 
583
  Result:=FClipboardFormats.Count;
 
584
end;
 
585
 
 
586
procedure TCody.SrcEditCopyPaste(SrcEdit: TSourceEditorInterface;
 
587
  var AText: String; var AMode: TSemSelectionMode; ALogStartPos: TPoint;
 
588
  var AnAction: TSemCopyPasteAction);
 
589
var
 
590
  AClipBoard: TClipboard;
 
591
begin
 
592
  // ToDo: use the right clipboard
 
593
  AClipBoard:=Clipboard;
 
594
  try
 
595
    if not ReadFromClipboard(AClipBoard,SrcEdit,ALogStartPos,AText) then exit;
 
596
  except
 
597
    on E: Exception do begin
 
598
      IDEMessageDialog('Error','Unable to paste Cody data.'#13+E.Message,
 
599
        mtError,[mbCancel]);
 
600
    end;
 
601
  end;
 
602
  AnAction:=semcaAbort;
 
603
end;
 
604
 
 
605
initialization
 
606
  Cody:=TCody.Create;
 
607
finalization
 
608
  FreeAndNil(Cody);
 
609
 
 
610
end.
 
611