← Back to branch summary

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

« back to all changes in this revision

Viewing changes to components/codetools/codetoolsfpcmsgs.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/codetoolsfpcmsgs.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
    Parsing fpc message files.
 
25
    FPC prints message IDs with -vq
 
26
}
 
27
(*
 
28
    For example:
 
29
general_t_compilername=01000_T_Compiler: $1
 
30
% When the \var{-vt} switch is used, this line tells you what compiler
 
31
% is used.
 
32
 
 
33
<part>_<type>_<txtidentifier>=<id>_<idtype>_<message with plcaeholders>
 
34
 
 
35
*)
 
36
unit CodeToolsFPCMsgs;
 
37
 
 
38
{$mode objfpc}{$H+}
 
39
 
 
40
{off $DEFINE VerboseFPCMsgFile}
 
41
 
 
42
interface
 
43
 
 
44
uses
 
45
  Classes, SysUtils, FileProcs, AVL_Tree;
 
46
 
 
47
type
 
48
  TfmiSpecialItem = (
 
49
    fmisiNone,
 
50
    fmisiFatal,
 
51
    fmisiError,
 
52
    fmisiWarning,
 
53
    fmisiNote,
 
54
    fmisiHint
 
55
    );
 
56
  TfmiSpecialItems = set of TfmiSpecialItem;
 
57
 
 
58
  { TFPCMsgItem }
 
59
 
 
60
  TFPCMsgItem = class
 
61
  public
 
62
    Part: string; // e.g. 'general', 'unit', 'link'
 
63
    Typ: string; // e.g. 'f','e','w','n','h','i','l','u','t','c','d','x','o'
 
64
    TxtIdentifier: string; // identifier
 
65
    ID: integer; // positive number
 
66
    ShownTyp: string; // e.g. shown Typ, can be different from Typ
 
67
    Pattern: string; // Text with placeholders $1 .. $9
 
68
    PatternEndSpace: string;
 
69
    Comment: string; // multi line
 
70
 
 
71
    Index: integer; // index in list
 
72
    function GetName(WithID: boolean = true): string;
 
73
    function PatternFits(aMsg: string): integer; // >=0 fits
 
74
    function GetTrimmedComment(NoLineBreaks, NoLatex: boolean): string;
 
75
  end;
 
76
 
 
77
  { TFPCMsgFile }
 
78
 
 
79
  TFPCMsgFile = class
 
80
  private
 
81
    fSpecialItems: array[TfmiSpecialItem] of TFPCMsgItem;
 
82
    FItems: TFPList; // list of TFPCMsgItem
 
83
    fSortedForID: TAVLTree; // tree of TFPCMsgItem sorted for ID
 
84
    fItemById: array of TFPCMsgItem;
 
85
    fNodeMgr: TAVLTreeNodeMemManager;
 
86
    function GetItems(Index: integer): TFPCMsgItem;
 
87
    procedure CreateArray;
 
88
    function GetSpecialItems(Index: TfmiSpecialItem): TFPCMsgItem;
 
89
  public
 
90
    constructor Create;
 
91
    destructor Destroy; override;
 
92
    procedure LoadFromFile(const Filename: string);
 
93
    procedure LoadFromList(List: TStrings); virtual;
 
94
    procedure LoadFromText(s: string); virtual;
 
95
    procedure Clear; virtual;
 
96
    function Count: integer;
 
97
    property Items[Index: integer]: TFPCMsgItem read GetItems; default;
 
98
    function FindWithID(ID: integer): TFPCMsgItem;
 
99
    function FindWithMessage(Msg: string): TFPCMsgItem;
 
100
    function GetMsgText(Item: TFPCMsgItem): string; // prepends msg type (e.g. Error:)
 
101
    function PatternFits(Item: TFPCMsgItem; aMsg: string): integer; // >=0 fits
 
102
    property SpecialItems[Index: TfmiSpecialItem]: TFPCMsgItem read GetSpecialItems;
 
103
    function MsgTypToSpecialItem(const Typ: string): TFPCMsgItem;
 
104
  end;
 
105
 
 
106
function CompareFPCMsgId(item1, item2: Pointer): integer;
 
107
function CompareIDWithFPCMsgId(PtrID, Item: Pointer): integer;
 
108
 
 
109
type
 
110
  TFPCMsgRange = record
 
111
    StartPos: integer;
 
112
    EndPos: integer;
 
113
  end;
 
114
  PFPCMsgRange = ^TFPCMsgRange;
 
115
 
 
116
  { TFPCMsgRanges }
 
117
 
 
118
  TFPCMsgRanges = class
 
119
  private
 
120
    FCount: integer;
 
121
    FCapacity: integer;
 
122
  public
 
123
    Ranges: PFPCMsgRange;
 
124
    property Count: integer read FCount;
 
125
    property Capacity: integer read FCapacity;
 
126
    procedure Add(StartPos, EndPos: integer);
 
127
    procedure Clear(FreeMemory: boolean = false);
 
128
    destructor Destroy; override;
 
129
  end;
 
130
 
 
131
procedure ExtractFPCMsgParameters(const Mask, Txt: string; var Ranges: TFPCMsgRanges);
 
132
 
 
133
function dbgs(i: TfmiSpecialItem): string; overload;
 
134
 
 
135
implementation
 
136
 
 
137
function CompareFPCMsgId(item1, item2: Pointer): integer;
 
138
var
 
139
  Msg1: TFPCMsgItem absolute item1;
 
140
  Msg2: TFPCMsgItem absolute item2;
 
141
begin
 
142
  if Msg1.ID<Msg2.ID then
 
143
    exit(-1)
 
144
  else if Msg1.ID>Msg2.ID then
 
145
    exit(1)
 
146
  else
 
147
    exit(0);
 
148
end;
 
149
 
 
150
function CompareIDWithFPCMsgId(PtrID, Item: Pointer): integer;
 
151
var
 
152
  Msg: TFPCMsgItem absolute Item;
 
153
  ID: LongInt;
 
154
begin
 
155
  ID:=PInteger(PtrID)^;
 
156
  if ID<Msg.ID then
 
157
    exit(-1)
 
158
  else if ID>Msg.ID then
 
159
    exit(1)
 
160
  else
 
161
    exit(0);
 
162
end;
 
163
 
 
164
procedure ExtractFPCMsgParameters(const Mask, Txt: string;
 
165
  var Ranges: TFPCMsgRanges);
 
166
{ Examples:
 
167
   Mask: bla$1blo
 
168
   Txt: blatestblo
 
169
   Result:=['test']
 
170
}
 
171
 
 
172
  function FindEndOfNextMatch(MaskStartPos, MaskEndPos, TxtStartPos: PChar): PChar;
 
173
  var
 
174
    TxtPos: PChar;
 
175
    MaskPos: PChar;
 
176
  begin
 
177
    while TxtStartPos^<>#0 do begin
 
178
      TxtPos:=TxtStartPos;
 
179
      MaskPos:=MaskStartPos;
 
180
      while (MaskPos<MaskEndPos) and (MaskPos^=TxtPos^) do begin
 
181
        inc(MaskPos);
 
182
        inc(TxtPos);
 
183
      end;
 
184
      if MaskPos=MaskEndPos then begin
 
185
        Result:=TxtPos;
 
186
        exit;
 
187
      end;
 
188
      inc(TxtStartPos);
 
189
    end;
 
190
    Result:=nil;
 
191
  end;
 
192
 
 
193
var
 
194
  BaseMaskPos: PChar;
 
195
  BaseTxtPos: PChar;
 
196
  MaskPos: PChar;
 
197
  TxtPos: PChar;
 
198
  MaskStartPos: PChar;
 
199
  TxtEndPos: PChar;
 
200
begin
 
201
  if Ranges=nil then
 
202
    Ranges:=TFPCMsgRanges.Create;
 
203
  Ranges.Clear();
 
204
  if Mask='' then exit;
 
205
  BaseMaskPos:=PChar(Mask);
 
206
  if Txt='' then
 
207
    BaseTxtPos:=#0
 
208
  else
 
209
    BaseTxtPos:=PChar(Txt);
 
210
 
 
211
  MaskPos:=BaseMaskPos;
 
212
  TxtPos:=BaseTxtPos;
 
213
  while (MaskPos^=TxtPos^) do begin
 
214
    if MaskPos^=#0 then exit;
 
215
    if (MaskPos^='$') and (MaskPos[1]<>'$') then break;
 
216
    inc(MaskPos);
 
217
    inc(TxtPos);
 
218
  end;
 
219
  while MaskPos^='$' do begin
 
220
    // skip variable in mask
 
221
    inc(MaskPos);
 
222
    while MaskPos^ in ['0'..'9','A'..'Z','a'..'z','_'] do inc(MaskPos);
 
223
    // get next pattern in mask
 
224
    MaskStartPos:=MaskPos;
 
225
    while (MaskPos^<>#0) and (MaskPos^<>'$') do inc(MaskPos);
 
226
    if MaskPos^=#0 then begin
 
227
      // variable at end of mask
 
228
      Ranges.Add(TxtPos-BaseTxtPos,length(Txt)+1);
 
229
      exit;
 
230
    end;
 
231
    // search pattern in txt
 
232
    TxtEndPos:=FindEndOfNextMatch(MaskStartPos,MaskPos,TxtPos);
 
233
    if TxtEndPos=nil then exit;
 
234
    Ranges.Add(TxtPos-BaseTxtPos,TxtEndPos-BaseTxtPos);
 
235
    TxtPos:=TxtEndPos;
 
236
  end;
 
237
end;
 
238
 
 
239
function dbgs(i: TfmiSpecialItem): string;
 
240
begin
 
241
  case i of
 
242
  fmisiFatal: Result:='fatal';
 
243
  fmisiError: Result:='error';
 
244
  fmisiWarning: Result:='warning';
 
245
  fmisiNote: Result:='note';
 
246
  fmisiHint: Result:='hint';
 
247
  else Result:='?';
 
248
  end;
 
249
end;
 
250
 
 
251
{ TFPCMsgItem }
 
252
 
 
253
function TFPCMsgItem.GetName(WithID: boolean): string;
 
254
begin
 
255
  Result:=Part+'_';
 
256
  if Typ<>'' then Result:=Result+Typ+'_';
 
257
  Result:=Result+TxtIdentifier;
 
258
  if WithID then
 
259
    Result:=Result+'='+IntToStr(ID);
 
260
end;
 
261
 
 
262
function TFPCMsgItem.PatternFits(aMsg: string): integer;
 
263
var
 
264
  PatStartPos: PChar;
 
265
  PatEndPos: PChar;
 
266
  MsgFitPos: PChar;
 
267
  MatchLen: Integer;
 
268
  MsgPos: PChar;
 
269
  PatPos: PChar;
 
270
  MsgStartPos: PChar;
 
271
  PatLen: Integer;
 
272
begin
 
273
  Result:=-1;
 
274
  // Pattern is for example "$1 lines compiled, $2 sec$3"
 
275
  if (aMsg='') or (Pattern='') then exit;
 
276
 
 
277
  // aMsg can start with a filename => hard to tell where the message starts
 
278
  // the Pattern is always at the end of aMsg => quick check the end
 
279
  PatLen:=length(Pattern);
 
280
  if (PatLen>=2)
 
281
  and ((Pattern[PatLen-1]<>'$') or (not (Pattern[PatLen] in ['0'..'9'])))
 
282
  then begin
 
283
    // the pattern does not have a placeholder at the end
 
284
    // => the tail must be the pattern => check tail
 
285
    PatStartPos:=PChar(Pattern);
 
286
    PatEndPos:=@Pattern[PatLen];
 
287
    MsgPos:=@aMsg[length(aMsg)];
 
288
    MsgStartPos:=PChar(aMsg);
 
289
    while (PatEndPos^=MsgPos^) do begin
 
290
      if PatEndPos=PatStartPos then begin
 
291
        // pattern has no placeholders and whole pattern fits
 
292
        Result:=PatLen;
 
293
        exit;
 
294
      end;
 
295
      dec(PatEndPos);
 
296
      if (PatEndPos^ in ['0'..'9']) and (PatEndPos[-1]='$') then begin
 
297
        // pattern behind last placeholder fits
 
298
        // => a full check is needed
 
299
        break;
 
300
      end;
 
301
      if MsgPos=MsgStartPos then begin
 
302
        // pattern does not fit
 
303
        exit(-1);
 
304
      end;
 
305
      dec(MsgPos);
 
306
    end;
 
307
  end;
 
308
 
 
309
  PatEndPos:=PChar(Pattern);
 
310
  MsgFitPos:=PChar(aMsg);
 
311
  MatchLen:=0;
 
312
  repeat
 
313
    PatStartPos:=PatEndPos;
 
314
    // get next pattern between placeholders
 
315
    repeat
 
316
      if PatEndPos^=#0 then break;
 
317
      if (PatEndPos^='$') and (PatEndPos[1] in ['0'..'9']) then break;
 
318
      inc(PatEndPos);
 
319
    until false;
 
320
    if PatEndPos<>PatStartPos then begin
 
321
      // search pattern in Pattern
 
322
      repeat
 
323
        MsgPos:=MsgFitPos;
 
324
        PatPos:=PatStartPos;
 
325
        while (MsgPos^=PatPos^) and (PatPos<PatEndPos) do begin
 
326
          inc(MsgPos);
 
327
          inc(PatPos);
 
328
        end;
 
329
        if PatPos=PatEndPos then
 
330
          break;
 
331
        // does not fit => check next
 
332
        inc(MsgFitPos);
 
333
      until MsgFitPos^=#0;
 
334
      if PatPos<PatEndPos then
 
335
        exit(-1); // pattern not found => does not fit
 
336
      inc(MatchLen,PatEndPos-PatStartPos);
 
337
      // pattern fits, search the rest of the patterns behind this position
 
338
      MsgFitPos:=MsgPos;
 
339
    end;
 
340
    if PatEndPos^=#0 then begin
 
341
      // whole pattern fits
 
342
      Result:=MatchLen;
 
343
      exit;
 
344
    end;
 
345
    // skip placeholder $d
 
346
    inc(PatEndPos,2);
 
347
  until false;
 
348
end;
 
349
 
 
350
function TFPCMsgItem.GetTrimmedComment(NoLineBreaks, NoLatex: boolean): string;
 
351
var
 
352
  i: Integer;
 
353
  StartPos: Integer;
 
354
begin
 
355
  Result:=Comment;
 
356
  if NoLatex then begin
 
357
    // remove tags
 
358
    i:=1;
 
359
    while i<length(Result) do begin
 
360
      if Result[i]='\' then begin
 
361
        StartPos:=i;
 
362
        inc(i);
 
363
        if Result[i] in ['a'..'z','A'..'Z'] then begin
 
364
          // \tag
 
365
          while (i<=length(Result))
 
366
          and (Result[i] in ['a'..'z','A'..'Z','0'..'9','_']) do
 
367
            inc(i);
 
368
          System.Delete(Result,StartPos,i-StartPos);
 
369
          i:=StartPos;
 
370
        end else begin
 
371
          // special character
 
372
          System.Delete(Result,StartPos,1);
 
373
        end;
 
374
      end else if Result[i] in ['{','}'] then begin
 
375
        System.Delete(Result,i,1);
 
376
      end else begin
 
377
        inc(i);
 
378
      end;
 
379
    end;
 
380
  end;
 
381
  for i:=length(Result) downto 1 do begin
 
382
    if NoLineBreaks and (Result[i] in [#10,#13]) then
 
383
      Result[i]:=' '
 
384
    else if Result[i]=#9 then
 
385
      Result[i]:=' ';
 
386
    if Result[i]=' ' then begin
 
387
      if (i=1) or (i=length(Result)) or (Result[i+1] in [' ',#10,#13]) then
 
388
        system.Delete(Result,i,1);
 
389
    end;
 
390
  end;
 
391
end;
 
392
 
 
393
{ TFPCMsgFile }
 
394
 
 
395
function TFPCMsgFile.GetItems(Index: integer): TFPCMsgItem;
 
396
begin
 
397
  Result:=TFPCMsgItem(FItems[Index]);
 
398
end;
 
399
 
 
400
procedure TFPCMsgFile.CreateArray;
 
401
var
 
402
  MaxID: Integer;
 
403
  i: Integer;
 
404
  Item: TFPCMsgItem;
 
405
  MinID: Integer;
 
406
begin
 
407
  //debugln(['TFPCMsgFile.CreateArray START']);
 
408
  SetLength(fItemById,0);
 
409
  if fSortedForID.Count=0 then
 
410
    exit;
 
411
  Item:=TFPCMsgItem(fSortedForID.FindLowest.Data);
 
412
  MinID:=Item.ID;
 
413
  if MinID<0 then begin
 
414
    debugln(['TFPCMsgFile.CreateArray WARNING: MinID ',MinID,' too low: ',Item.Pattern]);
 
415
    exit;
 
416
  end;
 
417
  Item:=TFPCMsgItem(fSortedForID.FindHighest.Data);
 
418
  MaxID:=Item.ID;
 
419
  if MaxID>100000 then begin
 
420
    debugln(['TFPCMsgFile.CreateArray WARNING: MaxID ',MaxID,' too high: ',Item.Pattern]);
 
421
    exit;
 
422
  end;
 
423
  //debugln(['TFPCMsgFile.CreateArray Max=',MaxID]);
 
424
  SetLength(fItemById,MaxID+1);
 
425
  for i:=0 to length(fItemById)-1 do fItemById[i]:=nil;
 
426
  for i:=0 to FItems.Count-1 do begin
 
427
    Item:=TFPCMsgItem(FItems[i]);
 
428
    //debugln(['TFPCMsgFile.CreateArray ',Item.ID,' ',copy(Item.Pattern,1,20),'..',copy(Item.Pattern,length(Item.Pattern)-19,20)]);
 
429
    fItemById[Item.ID]:=Item;
 
430
  end;
 
431
end;
 
432
 
 
433
function TFPCMsgFile.GetSpecialItems(Index: TfmiSpecialItem): TFPCMsgItem;
 
434
begin
 
435
  Result:=fSpecialItems[Index];
 
436
end;
 
437
 
 
438
constructor TFPCMsgFile.Create;
 
439
begin
 
440
  inherited Create;
 
441
  FItems:=TFPList.Create;
 
442
  fSortedForID:=TAVLTree.Create(@CompareFPCMsgId);
 
443
  fNodeMgr:=TAVLTreeNodeMemManager.Create;
 
444
  fSortedForID.SetNodeManager(fNodeMgr);
 
445
end;
 
446
 
 
447
destructor TFPCMsgFile.Destroy;
 
448
begin
 
449
  Clear;
 
450
  FreeAndNil(FItems);
 
451
  FreeAndNil(fSortedForID);
 
452
  FreeAndNil(fNodeMgr);
 
453
  inherited Destroy;
 
454
end;
 
455
 
 
456
procedure TFPCMsgFile.LoadFromFile(const Filename: string);
 
457
var
 
458
  sl: TStringList;
 
459
begin
 
460
  {$IFDEF VerboseFPCMsgFile}
 
461
  debugln(['TFPCMsgFile.LoadFromFile START ',Filename]);
 
462
  {$ENDIF}
 
463
  sl:=TStringList.Create;
 
464
  try
 
465
    sl.LoadFromFile(UTF8ToSys(Filename));
 
466
    LoadFromList(sl);
 
467
  finally
 
468
    sl.Free;
 
469
  end;
 
470
end;
 
471
 
 
472
procedure TFPCMsgFile.LoadFromList(List: TStrings);
 
473
 
 
474
  function ReadTilChar(var p: PChar; EndChar: char; out s: string): boolean;
 
475
  var
 
476
    c: Char;
 
477
    StartPos: PChar;
 
478
  begin
 
479
    StartPos:=p;
 
480
    repeat
 
481
      c:=p^;
 
482
      if c=#0 then exit(false);
 
483
      if c=EndChar then begin
 
484
        break;
 
485
      end;
 
486
      inc(p);
 
487
    until false;
 
488
    if p=StartPos then exit(false);
 
489
    SetLength(s,p-StartPos);
 
490
    System.Move(StartPos^,s[1],length(s));
 
491
    inc(p);
 
492
    Result:=true;
 
493
  end;
 
494
 
 
495
  function ReadItem(var Line: integer; const s: string): TFPCMsgItem;
 
496
  // <part>_<typ>_<txtidentifier>=<id>_<idtype>_<message with placeholders>
 
497
  // option and wpo are different:
 
498
  //   <part>_<txtidentifier>=<id>_<idtype>_<message with placeholders>
 
499
  // and
 
500
  //   <part>_<txtidentifier>=<id>_[<multi line message with placeholders>
 
501
  //      ...]
 
502
  //
 
503
  var
 
504
    p: PChar;
 
505
    Part: string;
 
506
    Typ: string;
 
507
    TxtID: string;
 
508
    ShownTyp: string;
 
509
    IDStr: string;
 
510
    ID: LongInt;
 
511
    Msg: string;
 
512
    h: string;
 
513
    i: Integer;
 
514
    MsgEndSpace: String;
 
515
  begin
 
516
    Result:=nil;
 
517
    p:=PChar(s);
 
518
    if not ReadTilChar(p,'_',Part) then begin
 
519
      {$IFDEF VerboseFPCMsgFile}
 
520
      debugln(['TFPCMsgFile.LoadFromList invalid <part>, line ',Line,': "',s,'"']);
 
521
      {$ENDIF}
 
522
      exit;
 
523
    end;
 
524
    if (Part='option') or (Part='wpo') then
 
525
      Typ:=''
 
526
    else if not ReadTilChar(p,'_',Typ) then begin
 
527
      {$IFDEF VerboseFPCMsgFile}
 
528
      debugln(['TFPCMsgFile.LoadFromList invalid <type>, line ',Line,': "',s,'"']);
 
529
      {$ENDIF}
 
530
      exit;
 
531
    end else if (length(Typ)<>1)
 
532
      or (not (Typ[1] in ['f','e','w','n','h','i','l','u','t','c','d','x','o']))
 
533
    then begin
 
534
      {$IFDEF VerboseFPCMsgFile}
 
535
      debugln(['TFPCMsgFile.LoadFromList invalid <type>, line ',Line,': "',s,'"']);
 
536
      {$ENDIF}
 
537
      exit;
 
538
    end;
 
539
    if not ReadTilChar(p,'=',TxtID) then begin
 
540
      {$IFDEF VerboseFPCMsgFile}
 
541
      debugln(['TFPCMsgFile.LoadFromList invalid <textidentifier>, line ',Line,': "',s,'"']);
 
542
      {$ENDIF}
 
543
      exit;
 
544
    end;
 
545
    if not ReadTilChar(p,'_',IDStr) then begin
 
546
      {$IFDEF VerboseFPCMsgFile}
 
547
      debugln(['TFPCMsgFile.LoadFromList invalid id, line ',Line,': "',s,'"']);
 
548
      {$ENDIF}
 
549
      exit;
 
550
    end;
 
551
    ID:=StrToIntDef(IDStr,-1);
 
552
    if ID<0 then begin
 
553
      {$IFDEF VerboseFPCMsgFile}
 
554
      debugln(['TFPCMsgFile.LoadFromList invalid id, line ',Line,': "',s,'"']);
 
555
      {$ENDIF}
 
556
      exit;
 
557
    end;
 
558
    ShownTyp:='';
 
559
    if p<>'[' then begin
 
560
      if not ReadTilChar(p,'_',ShownTyp) then begin
 
561
        {$IFDEF VerboseFPCMsgFile}
 
562
        debugln(['TFPCMsgFile.LoadFromList invalid urgency, line ',Line,': "',s,'"']);
 
563
        {$ENDIF}
 
564
        exit;
 
565
      end;
 
566
      Msg:=p;
 
567
    end else begin
 
568
      // multi line message
 
569
      Msg:='';
 
570
      repeat
 
571
        inc(Line);
 
572
        if Line>=List.Count then exit;
 
573
        h:=List[Line];
 
574
        //debugln(['ReadItem ID=',ID,' h=',h]);
 
575
        if (h<>'') and (h[1]=']') then break;
 
576
        Msg:=Msg+h+LineEnding;
 
577
      until false;
 
578
    end;
 
579
 
 
580
    i:=length(Msg);
 
581
    while (i>=1) and (Msg[i] in [' ',#9,#10,#13]) do dec(i);
 
582
    if i<length(Msg) then begin
 
583
      MsgEndSpace:=copy(Msg,i+1,length(Msg));
 
584
      System.Delete(Msg,i+1,length(Msg));
 
585
    end else
 
586
      MsgEndSpace:='';
 
587
 
 
588
    Result:=TFPCMsgItem.Create;
 
589
    Result.Part:=Part;
 
590
    Result.Typ:=Typ;
 
591
    Result.TxtIdentifier:=TxtID;
 
592
    Result.ID:=ID;
 
593
    Result.ShownTyp:=ShownTyp;
 
594
    Result.Pattern:=Msg;
 
595
    Result.PatternEndSpace:=MsgEndSpace;
 
596
    //debugln(['ReadItem Part=',Part,' Typ=',Typ,' TxtID=',TxtID,' ID=',ID,' IdTyp=',ShownTyp,' Msg="',copy(Result.Pattern,1,20),'"']);
 
597
  end;
 
598
 
 
599
var
 
600
  Line: Integer;
 
601
  s: string;
 
602
  Item: TFPCMsgItem;
 
603
begin
 
604
  //debugln(['TFPCMsgFile.LoadFromList START']);
 
605
  Clear;
 
606
  Line:=0;
 
607
  Item:=nil;
 
608
  while Line<List.Count do begin
 
609
    s:=List[Line];
 
610
    if s='' then begin
 
611
      // empty line
 
612
      Item:=nil;
 
613
    end else if s[1]='#' then begin
 
614
      // comment
 
615
    end else if s[1]='%' then begin
 
616
      // item comment
 
617
      if Item<>nil then begin
 
618
        if Item.Comment<>'' then
 
619
          Item.Comment:=Item.Comment+LineEnding;
 
620
        Item.Comment:=Item.Comment+copy(s,2,length(s));
 
621
      end;
 
622
    end else begin
 
623
      Item:=ReadItem(Line,s);
 
624
      if Item<>nil then begin
 
625
        //debugln(['TFPCMsgFile.LoadFromList ',Item.ID,' ',Item.Pattern]);
 
626
        Item.Index:=FItems.Count;
 
627
        FItems.Add(Item);
 
628
        fSortedForID.Add(Item);
 
629
        case Item.ID of
 
630
        1012: fSpecialItems[fmisiFatal]:=Item;
 
631
        1013: fSpecialItems[fmisiError]:=Item;
 
632
        1014: fSpecialItems[fmisiWarning]:=Item;
 
633
        1015: fSpecialItems[fmisiNote]:=Item;
 
634
        1016: fSpecialItems[fmisiHint]:=Item;
 
635
        end;
 
636
      end;
 
637
    end;
 
638
    inc(Line);
 
639
  end;
 
640
  CreateArray;
 
641
end;
 
642
 
 
643
procedure TFPCMsgFile.LoadFromText(s: string);
 
644
var
 
645
  sl: TStringList;
 
646
begin
 
647
  //debugln(['TFPCMsgFile.LoadFromText START']);
 
648
  sl:=TStringList.Create;
 
649
  try
 
650
    sl.Text:=s;
 
651
    LoadFromList(sl);
 
652
  finally
 
653
    sl.Free;
 
654
  end;
 
655
end;
 
656
 
 
657
procedure TFPCMsgFile.Clear;
 
658
var
 
659
  i: Integer;
 
660
  s: TfmiSpecialItem;
 
661
begin
 
662
  for s:=Low(fSpecialItems) to high(fSpecialItems) do
 
663
    fSpecialItems[s]:=nil;
 
664
  SetLength(fItemById,0);
 
665
  fSortedForID.Clear;
 
666
  for i:=0 to FItems.Count-1 do
 
667
    TObject(FItems[i]).Free;
 
668
  FItems.Clear;
 
669
end;
 
670
 
 
671
function TFPCMsgFile.Count: integer;
 
672
begin
 
673
  Result:=FItems.Count;
 
674
end;
 
675
 
 
676
function TFPCMsgFile.FindWithID(ID: integer): TFPCMsgItem;
 
677
var
 
678
  Node: TAVLTreeNode;
 
679
begin
 
680
  //debugln(['TFPCMsgFile.FindWithID ',ID,' Max=',length(fItemById)]);
 
681
  if (ID>=0) and (ID<length(fItemById)) then begin
 
682
    Result:=fItemById[ID];
 
683
    exit;
 
684
  end;
 
685
  Node:=fSortedForID.FindKey(@ID,@CompareIDWithFPCMsgId);
 
686
  if Node<>nil then
 
687
    Result:=TFPCMsgItem(Node.Data)
 
688
  else
 
689
    Result:=nil;
 
690
end;
 
691
 
 
692
function TFPCMsgFile.FindWithMessage(Msg: string): TFPCMsgItem;
 
693
var
 
694
  MsgID: Integer;
 
695
  Item: TFPCMsgItem;
 
696
  i: Integer;
 
697
  p: PChar;
 
698
  BestMatchLen: Integer;
 
699
  MatchLen: Integer;
 
700
begin
 
701
  Result:=nil;
 
702
  if Msg='' then exit;
 
703
  Msg:=Trim(Msg);
 
704
  if Msg='' then exit;
 
705
  p:=PChar(Msg);
 
706
 
 
707
  // skip time [0.000]
 
708
  if (p^='[') and (p[1] in ['0'..'9']) then begin
 
709
    inc(p,2);
 
710
    while p^ in ['0'..'9','.'] do inc(p);
 
711
    if p^<>']' then exit; // not a fpc message
 
712
    inc(p);
 
713
    while p^ in [' '] do inc(p);
 
714
  end;
 
715
 
 
716
  // read message ID (000)
 
717
  MsgID:=0;
 
718
  if (p^='(') and (p[1] in ['0'..'9']) then begin
 
719
    inc(p);
 
720
    while p^ in ['0'..'9','.'] do begin
 
721
      if MsgID>1000000 then exit; // not a fpc message
 
722
      MsgID:=MsgID*10+ord(p^)-ord('0');
 
723
      inc(p);
 
724
    end;
 
725
    if p^<>')' then exit; // not a fpc message
 
726
    inc(p);
 
727
    while p^ in [' '] do inc(p);
 
728
    Result:=FindWithID(MsgID);
 
729
    exit;
 
730
  end;
 
731
 
 
732
  // search a message pattern that fits the Msg
 
733
  BestMatchLen:=-1;
 
734
  for i:=0 to Count-1 do begin
 
735
    Item:=Items[i];
 
736
    if Item.Pattern='' then continue;
 
737
    MatchLen:=PatternFits(Item,Msg);
 
738
    if MatchLen>BestMatchLen then begin
 
739
      BestMatchLen:=MatchLen;
 
740
      Result:=Item;
 
741
    end;
 
742
  end;
 
743
end;
 
744
 
 
745
function TFPCMsgFile.GetMsgText(Item: TFPCMsgItem): string;
 
746
var
 
747
  si: TFPCMsgItem;
 
748
begin
 
749
  if Item=nil then exit('');
 
750
  Result:=Item.Pattern;
 
751
  si:=MsgTypToSpecialItem(Item.Typ);
 
752
  if si<>nil then
 
753
    Result:=si.Pattern+' '+Result;
 
754
end;
 
755
 
 
756
function TFPCMsgFile.PatternFits(Item: TFPCMsgItem; aMsg: string): integer;
 
757
var
 
758
  si: TFPCMsgItem;
 
759
begin
 
760
  Result:=Item.PatternFits(aMsg);
 
761
  if Result<0 then exit;
 
762
  // some messages have two types
 
763
  // => check typ
 
764
  si:=MsgTypToSpecialItem(Item.Typ);
 
765
  if si<>nil then begin
 
766
    if System.Pos(si.Pattern,aMsg)>0 then
 
767
      inc(Result,length(si.Pattern));
 
768
  end;
 
769
end;
 
770
 
 
771
function TFPCMsgFile.MsgTypToSpecialItem(const Typ: string): TFPCMsgItem;
 
772
begin
 
773
  Result:=nil;
 
774
  if length(Typ)<>1 then exit;
 
775
  case Typ[1] of
 
776
  'f': Result:=fSpecialItems[fmisiFatal];
 
777
  'e': Result:=fSpecialItems[fmisiError];
 
778
  'w': Result:=fSpecialItems[fmisiWarning];
 
779
  'n': Result:=fSpecialItems[fmisiNote];
 
780
  'h': Result:=fSpecialItems[fmisiHint];
 
781
  end;
 
782
end;
 
783
 
 
784
{ TFPCMsgRanges }
 
785
 
 
786
procedure TFPCMsgRanges.Add(StartPos, EndPos: integer);
 
787
begin
 
788
  if Count=Capacity then begin
 
789
    if Capacity<8 then
 
790
      fCapacity:=8
 
791
    else
 
792
      fCapacity:=Capacity*2;
 
793
    ReAllocMem(Ranges,Capacity*SizeOf(TFPCMsgRange));
 
794
  end;
 
795
  Ranges[FCount].StartPos:=StartPos;
 
796
  Ranges[FCount].EndPos:=EndPos;
 
797
  inc(FCount);
 
798
end;
 
799
 
 
800
procedure TFPCMsgRanges.Clear(FreeMemory: boolean);
 
801
begin
 
802
  FCount:=0;
 
803
  if not FreeMemory then begin
 
804
    ReAllocMem(Ranges,0);
 
805
    FCapacity:=0;
 
806
  end;
 
807
end;
 
808
 
 
809
destructor TFPCMsgRanges.Destroy;
 
810
begin
 
811
  Clear(true);
 
812
  inherited Destroy;
 
813
end;
 
814
 
 
815
end.
 
816