PageRenderTime 76ms CodeModel.GetById 20ms app.highlight 51ms RepoModel.GetById 1ms app.codeStats 0ms

/debugger/gdbtypeinfo.pp

http://github.com/graemeg/lazarus
Pascal | 627 lines | 490 code | 78 blank | 59 comment | 84 complexity | 7196e365af0c47d45d208750db5996c4 MD5 | raw file
  1{ $Id$ }
  2{                        ----------------------------------------------
  3                            GDBTypeInfo.pp  -  Debugger helper class 
  4                         ----------------------------------------------
  5
  6 @created(Wed Mar 29th WET 2003)
  7 @lastmod($Date$)
  8 @author(Marc Weustink <marc@@dommelstein.net>)
  9
 10 This unit contains a helper class for decoding PType output.
 11
 12
 13 ***************************************************************************
 14 *                                                                         *
 15 *   This source is free software; you can redistribute it and/or modify   *
 16 *   it under the terms of the GNU General Public License as published by  *
 17 *   the Free Software Foundation; either version 2 of the License, or     *
 18 *   (at your option) any later version.                                   *
 19 *                                                                         *
 20 *   This code is distributed in the hope that it will be useful, but      *
 21 *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
 22 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
 23 *   General Public License for more details.                              *
 24 *                                                                         *
 25 *   A copy of the GNU General Public License is available on the World    *
 26 *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
 27 *   obtain it by writing to the Free Software Foundation,                 *
 28 *   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
 29 *                                                                         *
 30 ***************************************************************************
 31}
 32unit GDBTypeInfo;
 33{$mode objfpc}{$H+}
 34interface
 35
 36uses
 37  Classes, SysUtils;
 38
 39(*
 40  ptype = {
 41     family = "class" | "record" | "enum" | "set" | "procedure" | "function" | "simple" | "pointer"
 42    [ ancestor = "...", ]
 43    [ private = "[" ( "{" name = "...", type = ptype "}" )* "}," ]
 44    [ protected = "[" ( "{" name = "...", type = ptype "}" )* "}," ]
 45    [ public = "[" ( "{" name = "...", type = ptype "}" )* "},"]
 46    [ published = "[" ( "{" name = "...", type = ptype "}" )* "}," ]
 47    [ members = "[" ( "..." )* "]," | "[" ( "{" name = "...", type = "..." "}" )* "]," ]
 48    [ args = "[" ( "..." )* "]," ]
 49    [ result = "..." ]
 50    [ name = "..." ]
 51    [ type = "..." ]
 52*)
 53type
 54  TGDBSymbolKind = (skClass, skRecord, skEnum, skSet, skProcedure, skFunction, skSimple, skPointer);
 55  TGDBFieldLocation = (flPrivate, flProtected, flPublic, flPublished);
 56  TGDBFieldFlag = (ffVirtual);
 57  TGDBFieldFlags = set of TGDBFieldFlag;
 58
 59  TGDBType = class;
 60  TGDBField = class(TObject)
 61  private
 62    FName: String;
 63    FFlags: TGDBFieldFlags;
 64    FLocation: TGDBFieldLocation;
 65    FGDBType: TGDBType;
 66  protected
 67  public
 68    constructor Create;
 69    destructor Destroy; override;
 70    property Name: String read FName;
 71    property GDBType: TGDBType read FGDBType;
 72    property Location: TGDBFieldLocation read FLocation;
 73    property Flags: TGDBFieldFlags read FFlags;
 74  end;
 75
 76  TGDBFields = class(TObject)
 77  private
 78    FList: TList;
 79    function GetField(const AIndex: Integer): TGDBField;
 80    function GetCount: Integer;
 81  protected
 82  public
 83    constructor Create;
 84    destructor Destroy; override;
 85    property Count: Integer read GetCount;
 86    property Items[const AIndex: Integer]: TGDBField read GetField; default;
 87  end;
 88
 89  TGDBTypes = class(TObject)
 90  private
 91    FList: TList;
 92    function GetType(const AIndex: Integer): TGDBType;
 93    function GetCount: Integer;
 94  protected
 95  public
 96    constructor Create;
 97    constructor CreateFromCSV(AValues: String);
 98    destructor Destroy; override;
 99    property Count: Integer read GetCount;
100    property Items[const AIndex: Integer]: TGDBType read GetType; default;
101  end;
102
103  { TGDBType }
104
105  TGDBType = class(TObject)
106  private
107    FAncestor: String;
108    FResult: TGDBType;
109    FArguments: TGDBTypes;
110    FFields: TGDBFields;
111    FKind: TGDBSymbolKind;
112    FMembers: TStrings;
113    FTypeName: String;
114  protected
115  public
116    constructor Create;
117    constructor CreateFromValues(const AValues: String);
118    destructor Destroy; override;
119    property Ancestor: String read FAncestor;
120    property Arguments: TGDBTypes read FArguments;
121    property Fields: TGDBFields read FFields;
122    property Kind: TGDBSymbolKind read FKind;
123    property TypeName: String read FTypeName;
124    property Members: TStrings read FMembers;
125    property Result: TGDBType read FResult;
126  end;
127
128
129function CreatePTypeValueList(AResultValues: String): TStringList;
130
131implementation
132
133function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String): String;
134var
135  n, i, idx, SkipLen: Integer;
136begin
137  idx := 0;
138  SkipLen := 0;
139  if High(ASkipTo) <> -1
140  then begin
141    for n := Low(ASkipTo) to High(ASkipTo) do
142    begin
143      if ASkipTo[n] <> ''
144      then begin
145        i := Pos(ASkipTo[n], ASource);
146        if (i > 0) and ((idx = 0) or (i < idx))
147        then begin
148          idx := i;
149          SkipLen := Length(ASkipTo[n]);
150        end;
151      end;
152    end;
153    if idx = 0
154    then begin
155      Result := '';
156      Exit;
157    end;
158    Delete(ASource, 1, idx + SkipLen - 1);
159  end;
160
161  idx := 0;
162  for n := Low(AnEnd) to High(AnEnd) do
163  begin
164    if AnEnd[n] <> ''
165    then begin
166      i := Pos(AnEnd[n], ASource);
167      if (i > 0) and ((idx = 0) or (i < idx))
168      then idx := i;
169    end;
170  end;
171
172  if idx = 0
173  then begin
174    Result := ASource;
175    ASource := '';
176  end
177  else begin
178    Result := Copy(ASource, 1, idx - 1);
179    Delete(ASource, 1, idx - 1);
180  end;
181end;
182
183function CreatePTypeValueList(AResultValues: String): TStringList;
184var
185  S, Line: String;
186  Lines: TStringList;
187
188  procedure DoRecord;
189  var
190    n: Integer;
191    S, Members: String;
192  begin
193    Result.Add('family=record');
194    Members := '';
195
196    //concatinate all lines and skip last end
197    S := '';
198    for n := 0 to Lines.Count - 2 do
199      S := S + Lines[n];
200
201    while S <> '' do
202    begin
203      if Members <> '' then Members := Members + ',';
204      Members := Members + '{name=' + GetPart(['    '], [' '], S);
205      Members := Members + ',type=' + GetPart([' : '], [';'], S) + '}';
206    end;
207    Result.Add('members=[' + Members + ']');
208  end;
209
210  procedure DoEnum;
211  var
212    n: Integer;
213    S: String;
214  begin
215    Result.Add('family=enum');
216
217    S := GetPart(['('], [], Line);
218    //concatinate all lines
219    for n := 0 to Lines.Count - 1 do
220      S := S + Lines[n];
221
222    S := GetPart([], [')'], S);
223    Result.Add('members=[' + StringReplace(S, ' ', '', [rfReplaceAll]) + ']');
224  end;
225
226  procedure DoProcedure;
227  var
228    n: Integer;
229    S: String;
230  begin
231    Result.Add('family=procedure');
232
233    S := GetPart(['('], [''], Line);
234    //concatinate all lines
235    for n := 0 to Lines.Count - 1 do
236      S := S + Lines[n];
237
238    S := GetPart([''], [')'], S);
239    Result.Add('args=[' + StringReplace(S, ', ', ',', [rfReplaceAll]) + ']');
240  end;
241
242  procedure DoFunction;
243  var
244    n: Integer;
245    S, Args: String;
246  begin
247    Result.Add('family=function');
248
249    S := GetPart(['('], [], Line);
250    //concatinate all lines
251    for n := 0 to Lines.Count - 1 do
252      S := S + Lines[n];
253
254    Args := GetPart([], [')'], S);
255    S := GetPart([' : '], [], S);
256    Result.Add('args=[' + StringReplace(Args, ', ', ',', [rfReplaceAll]) + ']');
257    Result.Add('result=' + S);
258  end;
259
260  procedure DoClass;
261  begin
262    Result.Add('family=class');
263    Result.Add('ancestor=' + GetPart([': public '], [' '], Line));
264  end;
265
266begin
267  Result := TStringList.Create;
268  if AResultValues = '' then Exit;
269
270  Lines := TStringList.Create;
271  try
272    Lines.Text := AResultValues;
273    if Lines.Count = 0 then Exit;
274    Line := Lines[0];
275    Lines.Delete(0);
276
277    S := GetPart(['type = '], [' '], Line);
278    if S = '' then Exit;
279    if Pos(' = class ', Line) > 0
280    then DoClass
281    else if S[1] = '^'
282    then begin
283      Result.Add('family=pointer');
284      Result.Add('type=' + GetPart(['^'], [' ='], S));
285    end
286    else if S = 'set'
287    then begin
288      Result.Add('family=set');
289      Result.Add('type=' + Copy(Line, 5, Length(Line)));
290    end
291    else if S = 'procedure'
292    then DoProcedure
293    else if S = 'function'
294    then DoFunction
295    else if Pos(' = (', Line) > 0
296    then DoEnum
297    else if Pos(' = record', Line) > 0
298    then DoRecord
299    else begin
300      Result.Add('family=simple');
301      Result.Add('type=' + S);
302    end;
303
304  finally
305    Lines.Free;
306  end;
307end;
308
309{ TGDBField }
310
311constructor TGDBField.Create;
312begin
313  FFlags := [];
314  FGDBType := nil;
315  FLocation := flPublic;
316end;
317
318destructor TGDBField.Destroy;
319begin
320  if FGDBType<>nil then FreeAndNil(FGDBType);
321  inherited Destroy;
322end;
323
324{ TGDBFields }
325
326constructor TGDBFields.Create;
327begin
328  FList := TList.Create;
329  inherited;
330end;
331
332destructor TGDBFields.Destroy;
333var
334  n: Integer;
335begin
336  for n := 0 to Count - 1 do
337    Items[n].Free;
338
339  FreeAndNil(FList);
340  inherited;
341end;
342
343function TGDBFields.GetCount: Integer;
344begin
345  Result := FList.Count;
346end;
347
348function TGDBFields.GetField(const AIndex: Integer): TGDBField;
349begin
350  Result := TGDBField(FList[AIndex]);
351end;
352
353{ TGDBPType }
354
355constructor TGDBType.Create;
356begin
357  FResult := nil;
358  FArguments := nil;
359  FFields := nil;
360  FMembers := nil;
361
362  inherited Create;
363end;
364
365constructor TGDBType.CreateFromValues(const AValues: String);
366var
367  S, Line: String;
368  Lines: TStringList;
369
370  procedure DoRecord;
371  var
372    n: Integer;
373    S: String;
374    Field: TGDBField;
375  begin
376    FKind := skRecord;
377    FFields := TGDBFields.Create;
378
379    //concatenate all lines and skip last end
380    S := '';
381    for n := 0 to Lines.Count - 2 do
382      S := S + Lines[n];
383
384    while S <> '' do
385    begin
386      Field := TGDBField.Create;
387      Field.FName := GetPart(['    '], [' '], S);
388      Field.FLocation := flPublic;
389      Field.FGDBType := TGDBType.Create;
390      Field.FGDBType.FKind := skSimple; // for now
391      Field.FGDBType.FTypeName := GetPart([' : '], [';'], S);
392      FFields.FList.Add(Field);
393      Delete(S, 1, 1);
394    end;
395  end;
396
397  procedure DoEnum;
398  var
399    n: Integer;
400    S: String;
401  begin
402    FKind := skEnum;
403
404    S := GetPart(['('], [], Line);
405    //concatenate all lines
406    for n := 0 to Lines.Count - 1 do
407      S := S + Lines[n];
408
409    S := GetPart([], [')'], S);
410    FMembers := TStringList.Create;
411    FMembers.Text := StringReplace(S, ' ', #13#10, [rfReplaceAll]);
412  end;
413
414  procedure DoSet;
415  var
416    n: Integer;
417    S: String;
418  begin
419    FKind := skSet;
420
421    S := Copy(Line, 5, Length(Line));
422    for n := 0 to Lines.Count - 1 do
423      S := S + Lines[n];
424
425    if Pos('=', S) = 0
426    then FTypeName := S
427    else begin
428      S := GetPart(['('], [')'], S);
429      FMembers := TStringList.Create;
430      FMembers.Text := StringReplace(StringReplace(S, ',', #13#10, [rfReplaceAll]), ' ', '', [rfReplaceAll]);
431    end;
432  end;
433
434  procedure DoProcedure;
435  var
436    n: Integer;
437    S: String;
438  begin
439    FKind := skProcedure;
440
441    S := GetPart(['('], [], Line);
442    //concatenate all lines
443    for n := 0 to Lines.Count - 1 do
444      S := S + Lines[n];
445
446    S := GetPart([], [')'], S);
447    FArguments := TGDBTypes.CreateFromCSV(S);
448  end;
449
450  procedure DoFunction;
451  var
452    n: Integer;
453    S: String;
454  begin
455    FKind := skFunction;
456
457    S := GetPart(['('], [], Line);
458    //concatenate all lines
459    for n := 0 to Lines.Count - 1 do
460      S := S + Lines[n];
461
462    FArguments := TGDBTypes.CreateFromCSV(GetPart([], [')'], S));
463    FResult := TGDBType.Create;
464    FResult.FKind := skSimple; // for now
465    FResult.FTypeName := GetPart([' : '], [], S);
466  end;
467
468  procedure DoClass;
469  var
470    n: Integer;
471    Field: TGDBField;
472    S: String;
473    Location: TGDBFieldLocation;
474  begin
475    FKind := skClass;
476    FAncestor := GetPart([': public '], [' '], Line);
477    FFields := TGDBFields.Create;
478
479    Location := flPublished;
480    for n := 0 to Lines.Count - 2 do
481    begin
482      S := Lines[n];
483      if S = '' then Continue;
484      if S = '  private' then Location := flPrivate
485      else if S = '  protected' then Location := flProtected
486      else if S = '  public' then Location := flPublic
487      else if S = '  published' then Location := flPublished
488      else begin
489        Field := TGDBField.Create;
490        Field.FLocation := Location;
491        Field.FGDBType := TGDBType.Create;
492        FFields.FList.Add(Field);
493
494        if Pos(' procedure ', S) > 0
495        then begin
496          Field.FName := GetPart(['procedure '], [' ', ';'], S);
497          Field.FGDBType.FKind := skProcedure;
498          Field.FGDBType.FArguments := TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S));
499          if GetPart(['; '], [';'], S) = 'virtual'
500          then Field.FFlags := [ffVirtual];
501        end
502        else if Pos(' function ', S) > 0
503        then begin
504          Field.FName := GetPart(['function  '], [' ', ';'], S);
505          Field.FGDBType.FKind := skFunction;
506          Field.FGDBType.FArguments := TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S));
507          Field.FGDBType.FResult := TGDBType.Create;
508          Field.FGDBType.FResult.FKind := skSimple; // for now
509          Field.FGDBType.FResult.FTypeName := GetPart([' : '], [';'], S);
510          if GetPart(['; '], [';'], S) = 'virtual'
511          then Field.FFlags := [ffVirtual];
512        end
513        else begin
514          Field.FName := GetPart(['    '], [' '], S);
515          Field.FGDBType.FKind := skSimple; // for now
516          Field.FGDBType.FTypeName := GetPart([' : '], [';'], S);
517        end;
518      end;
519    end;
520  end;
521  
522var
523  HasClass: Boolean;
524begin
525  Create;
526
527  if AValues = '' then Exit;
528
529  Lines := TStringList.Create;
530  try
531    Lines.Text := AValues;
532    if Lines.Count = 0 then Exit;
533
534    Line := Lines[0];
535    Lines.Delete(0);
536
537    S := GetPart(['type = '], [' '], Line);
538    if S = '' then Exit;
539    HasClass := Pos(' = class ', Line) > 0;
540    if HasClass
541    and (S[2] <> '^') // pointer to class is handled next
542    then begin
543      FTypeName := GetPart(['^'], [' '], S);
544      DoClass;
545    end
546    else if S[1] = '^'
547    then begin
548      FKind := skPointer;
549      if HasClass
550      then FTypeName := GetPart(['^^'], [' ='], S)
551      else FTypeName := GetPart(['^'], [' ='], S);
552    end
553    else if S = 'set'
554    then DoSet
555    else if S = 'procedure'
556    then DoProcedure
557    else if S = 'function'
558    then DoFunction
559    else if Pos(' = (', Line) > 0
560    then DoEnum
561    else if Pos(' = record', Line) > 0
562    then DoRecord
563    else begin
564      FKind := skSimple;
565      FTypeName := S;
566    end;
567
568  finally
569    Lines.Free;
570  end;
571end;
572
573destructor TGDBType.Destroy;
574begin
575  if FResult<>nil then FreeAndNil(FResult);
576  if FArguments<>nil then FreeAndNil(FArguments);
577  if FFields<>nil then FreeAndNil(FFields);
578  if FMembers<>nil then FreeAndNil(FMembers);
579
580  inherited;
581end;
582
583{ TGDBPTypes }
584
585constructor TGDBTypes.Create;
586begin
587  FList := TList.Create;
588  inherited;
589end;
590
591constructor TGDBTypes.CreateFromCSV(AValues: String);
592var
593  GDBType: TGDBType;
594begin
595  Create;
596  while AValues <> '' do
597  begin
598    GDBType := TGDBType.Create;
599    GDBType.FKind := skSimple;
600    GDBType.FTypeName := GetPart([], [', '], AValues);
601    FList.Add(GDBType);
602    {if Length(AValues) >= 2 then} Delete(AValues, 1, 2);
603  end;
604end;
605
606destructor TGDBTypes.Destroy;
607var
608  n: Integer;
609begin
610  for n := 0 to Count - 1 do
611    Items[n].Free;
612    
613  FreeAndNil(FList);
614  inherited;
615end;
616
617function TGDBTypes.GetCount: Integer;
618begin
619  Result := Flist.Count;
620end;
621
622function TGDBTypes.GetType(const AIndex: Integer): TGDBType;
623begin
624  Result := TGDBType(FList[AIndex]);
625end;
626
627end.