← Back to branch summary

~ubuntu-branches/ubuntu/feisty/fpc/feisty

« back to all changes in this revision

Viewing changes to rtl/objpas/typinfo.pp

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2007-01-27 20:08:50 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070127200850-9mrptaqqjsx9nwa7
Tags: 2.0.4-5
* Fixed Build-Depends.
* Add myself to Uploaders in debian/control.
* Make sure that the sources are really patched before building them.
* Build unit 'libc' on powerpc too.

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/objpas/typinfo.pp
1
1
{
2
 
    $Id: typinfo.pp,v 1.45 2005/04/16 09:24:29 michael Exp $
3
2
    This file is part of the Free Pascal run time library.
4
3
 
5
4
    Copyright (c) 1999-2000 by Florian Klaempfl
30
29
// temporary types:
31
30
 
32
31
    type
33
 
{$ifndef HASVARIANT}
34
 
       Variant      = Pointer;
35
 
{$endif}
36
32
 
37
33
{$MINENUMSIZE 1   this saves a lot of memory }
38
34
       // if you change one of the following enumeration types
48
44
       TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr);
49
45
       TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor,
50
46
                      mkClassProcedure, mkClassFunction);
51
 
       TParamFlags    = set of (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
52
 
       TIntfFlag      = (ifHasGuid,ifDispInterface,ifDispatch);
 
47
       TParamFlag     = (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
 
48
       TParamFlags    = set of TParamFlag;
 
49
       TIntfFlag      = (ifHasGuid,ifDispInterface,ifDispatch,ifHasStrGUID);
53
50
       TIntfFlags     = set of TIntfFlag;
54
51
       TIntfFlagsBase = set of TIntfFlag;
55
52
 
128
125
              (MinInt64Value, MaxInt64Value: Int64);
129
126
            tkQWord:
130
127
              (MinQWordValue, MaxQWordValue: QWord);
131
 
            tkInterface,
 
128
            tkInterface:
 
129
              (
 
130
               IntfParent: PTypeInfo;
 
131
               IntfFlags : TIntfFlagsBase;
 
132
               GUID: TGUID;
 
133
               IntfUnit: ShortString;
 
134
              );
132
135
            tkInterfaceRaw:
133
136
              (
134
 
               IntfParent: PPTypeInfo;
135
 
               IID: PGUID;
 
137
               RawIntfParent: PTypeInfo;
 
138
               RawIntfFlags : TIntfFlagsBase;
 
139
               IID: TGUID;
 
140
               RawIntfUnit: ShortString;
136
141
               IIDStr: ShortString;
137
 
               IntfUnit: ShortString;
138
142
              );
139
143
      end;
140
144
 
191
195
Function FindPropInfo(Instance: TObject; const PropName: string): PPropInfo;
192
196
Function FindPropInfo(AClass:TClass;const PropName: string): PPropInfo;
193
197
Procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
194
 
{$ifdef ver1_0}
195
 
Function  GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList;Sorted : boolean):longint;
196
 
Function GetPropList(TypeInfo: PTypeInfo; var PropList: PPropList): SizeInt;
197
 
{$else}
198
 
Function  GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList;Sorted : boolean = true):longint;
 
198
Function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList;Sorted : boolean = true):longint;
199
199
Function GetPropList(TypeInfo: PTypeInfo; out PropList: PPropList): SizeInt;
200
 
{$endif}
 
200
function GetPropList(AObject: TObject; out PropList: PPropList): Integer;
 
201
 
201
202
 
202
203
 
203
204
// Property information routines.
232
233
Procedure SetStrProp(Instance: TObject; const PropName: string; const Value: AnsiString);
233
234
Procedure SetStrProp(Instance: TObject; PropInfo : PPropInfo; const Value : Ansistring);
234
235
 
235
 
{$ifdef HASWIDESTRING}
236
236
Function GetWideStrProp(Instance: TObject; PropInfo: PPropInfo): WideString;
237
237
Function GetWideStrProp(Instance: TObject; const PropName: string): WideString;
238
238
Procedure SetWideStrProp(Instance: TObject; const PropName: string; const Value: WideString);
239
239
Procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: WideString);
240
 
{$endif HASWIDESTRING}
241
240
 
242
241
Function  GetFloatProp(Instance: TObject; PropInfo : PPropInfo) : Extended;
243
242
Function  GetFloatProp(Instance: TObject; const PropName: string): Extended;
275
274
// Auxiliary routines, which may be useful
276
275
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
277
276
Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
 
277
function GetEnumNameCount(enum1: PTypeInfo): SizeInt;
 
278
 
 
279
function SetToString(TypeInfo: PTypeInfo; Value: Integer; Brackets: Boolean) : String;
278
280
function SetToString(PropInfo: PPropInfo; Value: Integer; Brackets: Boolean) : String;
279
281
function SetToString(PropInfo: PPropInfo; Value: Integer) : String;
280
282
function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;
 
283
function StringToSet(TypeInfo: PTypeInfo; const Value: string): Integer;
281
284
 
282
285
const
283
286
    BooleanIdents: array[Boolean] of String = ('False', 'True');
287
290
  EPropertyError  = Class(Exception);
288
291
  TGetPropValue   = Function (Instance: TObject; const PropName: string; PreferStrings: Boolean) : Variant;
289
292
  TSetPropValue   = Procedure (Instance: TObject; const PropName: string; const Value: Variant);
290
 
  TGetVariantProp = Function (Instance: TObject; PropInfo : PPropInfo): Variant;  
 
293
  TGetVariantProp = Function (Instance: TObject; PropInfo : PPropInfo): Variant;
291
294
  TSetVariantProp = Procedure (Instance: TObject; PropInfo : PPropInfo; const Value: Variant);
292
 
  
 
295
 
293
296
Const
294
297
  OnGetPropValue   : TGetPropValue = Nil;
295
298
  OnSetPropValue   : TSetPropValue = Nil;
296
299
  OnGetVariantprop : TGetVariantProp = Nil;
297
300
  OnSetVariantprop : TSetVariantProp = Nil;
298
 
 
 
301
 
299
302
Implementation
300
303
 
301
304
uses rtlconsts;
302
 
  
 
305
 
303
306
type
304
307
  PMethod = ^TMethod;
305
308
 
308
311
  ---------------------------------------------------------------------}
309
312
 
310
313
function aligntoptr(p : pointer) : pointer;
311
 
  begin
 
314
   begin
312
315
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
313
 
    if (ptrint(p) mod sizeof(ptrint))<>0 then
314
 
      inc(ptrint(p),sizeof(ptrint)-ptrint(p) mod sizeof(ptrint));
 
316
     if (ptruint(p) and (sizeof(ptruint)-1))<>0 then
 
317
          ptruint(p) := (ptruint(p) + sizeof(ptruint) - 1) and not (sizeof(ptruint) - 1);
315
318
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
316
 
    result:=p;
317
 
  end;
 
319
     aligntoptr:=p;
 
320
   end;
318
321
 
319
322
 
320
323
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
359
362
end;
360
363
 
361
364
 
 
365
function GetEnumNameCount(enum1: PTypeInfo): SizeInt;
 
366
var
 
367
  PS: PShortString;
 
368
  PT: PTypeData;
 
369
  Count: SizeInt;
 
370
begin
 
371
  PT:=GetTypeData(enum1);
 
372
  Count:=0;
 
373
  Result:=0;
 
374
 
 
375
  PS:=@PT^.NameList;
 
376
  While (PByte(PS)^<>0) do
 
377
    begin
 
378
      PS:=PShortString(pointer(PS)+PByte(PS)^+1);
 
379
      Inc(Count);
 
380
    end;
 
381
 
 
382
  Result := Count;
 
383
end;
 
384
 
 
385
 
362
386
Function SetToString(PropInfo: PPropInfo; Value: Integer; Brackets: Boolean) : String;
363
387
 
 
388
begin
 
389
  Result:=SetToString(PropInfo^.PropType,Value,Brackets);
 
390
end;
 
391
 
 
392
Function SetToString(TypeInfo: PTypeInfo; Value: Integer; Brackets: Boolean) : String;
 
393
 
364
394
Var
365
395
  I : Integer;
366
396
  PTI : PTypeInfo;
367
397
 
368
398
begin
369
 
  PTI:=GetTypeData(PropInfo^.PropType)^.CompType;
 
399
  PTI:=GetTypeData(TypeInfo)^.CompType;
370
400
  Result:='';
371
401
  For I:=0 to SizeOf(Integer)*8-1 do
372
402
    begin
409
439
    end;
410
440
end;
411
441
 
412
 
 
413
442
Function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;
 
443
 
 
444
begin
 
445
  Result:=StringToSet(PropInfo^.PropType,Value);
 
446
end;
 
447
 
 
448
Function StringToSet(TypeInfo: PTypeInfo; const Value: string): Integer;
414
449
Var
415
450
  S,T : String;
416
451
  I : Integer;
418
453
 
419
454
begin
420
455
  Result:=0;
421
 
  PTI:=GetTypeData(PropInfo^.PropType)^.Comptype;
 
456
  PTI:=GetTypeData(TypeInfo)^.Comptype;
422
457
  S:=Value;
423
458
  I:=1;
424
459
  If Length(S)>0 then
567
602
  TP : PPropInfo;
568
603
  Count : Longint;
569
604
begin
 
605
  // Get this objects TOTAL published properties count
570
606
  TD:=GetTypeData(TypeInfo);
571
 
  // Get this objects TOTAL published properties count
572
 
  TP:=aligntoptr(PPropInfo(aligntoptr((@TD^.UnitName+Length(TD^.UnitName)+1))));
573
 
  Count:=PWord(TP)^;
574
 
  // Now point TP to first propinfo record.
575
 
  Inc(Pointer(TP),SizeOF(Word));
576
 
  tp:=aligntoptr(tp);
577
 
  While Count>0 do
578
 
    begin
579
 
      PropList^[0]:=TP;
580
 
      Inc(Pointer(PropList),SizeOf(Pointer));
581
 
      // Point to TP next propinfo record.
582
 
      // Located at Name[Length(Name)+1] !
583
 
      TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1));
584
 
      Dec(Count);
585
 
    end;
586
 
  // recursive call for parent info.
587
 
  If TD^.Parentinfo<>Nil then
588
 
    GetPropInfos (TD^.ParentInfo,PropList);
 
607
  // Clear list
 
608
  FillChar(PropList^,TD^.PropCount*sizeof(Pointer),0);
 
609
  repeat
 
610
    TD:=GetTypeData(TypeInfo);
 
611
    // published properties count for this object
 
612
    TP:=aligntoptr(PPropInfo(aligntoptr((@TD^.UnitName+Length(TD^.UnitName)+1))));
 
613
    Count:=PWord(TP)^;
 
614
    // Now point TP to first propinfo record.
 
615
    Inc(Pointer(TP),SizeOF(Word));
 
616
    tp:=aligntoptr(tp);
 
617
    While Count>0 do
 
618
      begin
 
619
        // Don't overwrite properties with the same name
 
620
        if PropList^[TP^.NameIndex]=nil then
 
621
          PropList^[TP^.NameIndex]:=TP;
 
622
        // Point to TP next propinfo record.
 
623
        // Located at Name[Length(Name)+1] !
 
624
        TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1));
 
625
        Dec(Count);
 
626
      end;
 
627
    TypeInfo:=TD^.Parentinfo;
 
628
  until TypeInfo=nil;
589
629
end;
590
630
 
591
631
Procedure InsertProp (PL : PProplist;PI : PPropInfo; Count : longint);
609
649
 
610
650
//Const InsertProps : array[false..boolean] of TInsertProp = (InsertPropNoSort,InsertProp);
611
651
 
612
 
{$ifdef ver1_0}
613
 
Function  GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList;Sorted : boolean):longint;
614
 
{$else}
615
652
Function  GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList;Sorted : boolean = true):longint;
616
 
{$endif}
617
653
 
618
654
{
619
655
  Store Pointers to property information OF A CERTAIN KIND in the list pointed
655
691
end;
656
692
 
657
693
 
658
 
{$ifdef ver1_0}
659
 
Function GetPropList(TypeInfo: PTypeInfo; var PropList: PPropList): SizeInt;
660
 
{$else}
661
694
Function GetPropList(TypeInfo: PTypeInfo; out PropList: PPropList): SizeInt;
662
 
{$endif}
663
 
  begin
664
 
    result:=GetTypeData(TypeInfo)^.Propcount;
665
 
    if result>0 then
666
 
      begin
667
 
        getmem(PropList,result*sizeof(pointer));
668
 
        GetPropInfos(TypeInfo,PropList);
669
 
      end;
670
 
  end;
671
 
 
 
695
begin
 
696
  result:=GetTypeData(TypeInfo)^.Propcount;
 
697
  if result>0 then
 
698
    begin
 
699
      getmem(PropList,result*sizeof(pointer));
 
700
      GetPropInfos(TypeInfo,PropList);
 
701
    end;
 
702
end;
 
703
 
 
704
 
 
705
function GetPropList(AObject: TObject; out PropList: PPropList): Integer;
 
706
begin
 
707
  Result := GetPropList(PTypeInfo(AObject.ClassInfo), PropList);
 
708
end;
672
709
 
673
710
{ ---------------------------------------------------------------------
674
711
  Property access functions
701
738
  Signed := false;
702
739
  DataSize := 4;
703
740
  case TypeInfo^.Kind of
 
741
{$ifdef cpu64}
 
742
    tkClass:
 
743
      DataSize:=8;
 
744
{$endif cpu64}
704
745
    tkChar, tkBool:
705
746
      DataSize:=1;
706
747
    tkWChar:
787
828
  DataSize: Integer;
788
829
  AMethod : TMethod;
789
830
begin
790
 
  if PropInfo^.PropType^.Kind in [tkInt64,tkQword] then
 
831
  if PropInfo^.PropType^.Kind in [tkInt64,tkQword
 
832
  { why do we have to handle classes here, see also below? (FK) }
 
833
{$ifdef cpu64}
 
834
    ,tkClass
 
835
{$endif cpu64}
 
836
    ] then
791
837
    DataSize := 8
792
838
  else
793
839
    DataSize := 4;
794
 
  if PropInfo^.PropType^.Kind <> tkClass then
 
840
  if not(PropInfo^.PropType^.Kind in [tkInt64,tkQword,tkClass]) then
795
841
    begin
796
842
      { cut off unnecessary stuff }
797
843
      case GetTypeData(PropInfo^.PropType)^.OrdType of
812
858
      case DataSize of
813
859
        1: PByte(Pointer(Instance)+Ptrint(PropInfo^.SetProc))^:=Byte(Value);
814
860
        2: PWord(Pointer(Instance)+Ptrint(PropInfo^.SetProc))^:=Word(Value);
815
 
        4:PLongint(Pointer(Instance)+Ptrint(PropInfo^.SetProc))^:=Longint(Value);
 
861
        4: PLongint(Pointer(Instance)+Ptrint(PropInfo^.SetProc))^:=Longint(Value);
816
862
        8: PInt64(Pointer(Instance)+Ptrint(PropInfo^.SetProc))^:=Value;
817
863
      end;
818
864
    ptstatic,
1019
1065
begin
1020
1066
  Result:='';
1021
1067
  case Propinfo^.PropType^.Kind of
1022
 
{$ifdef HASWIDESTRING}
1023
1068
    tkWString:
1024
1069
      Result:=GetWideStrProp(Instance,PropInfo);
1025
 
{$endif HASWIDESTRING}
1026
1070
    tkSString:
1027
1071
      begin
1028
1072
        case (PropInfo^.PropProcs) and 3 of
1077
1121
  AMethod : TMethod;
1078
1122
begin
1079
1123
  case Propinfo^.PropType^.Kind of
1080
 
{$ifdef HASWIDESTRING}
1081
1124
    tkWString:
1082
1125
      SetWideStrProp(Instance,PropInfo,Value);
1083
 
{$endif HASWIDESTRING}
1084
1126
    tkSString:
1085
1127
      begin
1086
1128
        case (PropInfo^.PropProcs shr 2) and 3 of
1137
1179
end;
1138
1180
 
1139
1181
 
1140
 
{$ifdef HASWIDESTRING}
1141
1182
Function GetWideStrProp(Instance: TObject; const PropName: string): WideString;
1142
1183
begin
1143
1184
  Result:=GetWideStrProp(Instance, FindPropInfo(Instance, PropName));
1218
1259
  end;
1219
1260
end;
1220
1261
 
1221
 
{$endif HASWIDESTRING}
1222
1262
 
1223
1263
 
1224
1264
{ ---------------------------------------------------------------------
1233
1273
  TGetDoubleProcIndex = function(Index: integer): Double of object;
1234
1274
  TGetSingleProc = function:Single of object;
1235
1275
  TGetSingleProcIndex = function(Index: integer):Single of object;
1236
 
{$ifdef HASCURRENCY}
1237
1276
  TGetCurrencyProc = function : Currency of object;
1238
1277
  TGetCurrencyProcIndex = function(Index: integer) : Currency of object;
1239
 
{$endif HASCURRENCY}
1240
1278
var
1241
1279
  AMethod : TMethod;
1242
1280
begin
1252
1290
         Result:=PExtended(Pointer(Instance)+Ptrint(PropInfo^.GetProc))^;
1253
1291
       ftcomp:
1254
1292
         Result:=PComp(Pointer(Instance)+Ptrint(PropInfo^.GetProc))^;
1255
 
{$ifdef HASCURRENCY}
1256
1293
       ftcurr:
1257
1294
         Result:=PCurrency(Pointer(Instance)+Ptrint(PropInfo^.GetProc))^;
1258
 
{$endif HASCURRENCY}
1259
1295
       end;
1260
1296
    ptStatic,
1261
1297
    ptVirtual:
1281
1317
              Result:=TGetExtendedProc(AMethod)()
1282
1318
            else
1283
1319
              Result:=TGetExtendedProcIndex(AMethod)(PropInfo^.Index);
1284
 
          {$ifdef HASCURRENCY}
1285
1320
          ftCurr:
1286
1321
            if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
1287
1322
              Result:=TGetCurrencyProc(AMethod)()
1288
1323
            else
1289
1324
              Result:=TGetCurrencyProcIndex(AMethod)(PropInfo^.Index);
1290
 
          {$endif HASCURRENCY}
1291
1325
        end;
1292
1326
      end;
1293
1327
  end;
1302
1336
  TSetDoubleProcIndex = procedure(Index: integer; const AValue: Double) of object;
1303
1337
  TSetSingleProc = procedure(const AValue: Single) of object;
1304
1338
  TSetSingleProcIndex = procedure(Index: integer; const AValue: Single) of object;
1305
 
{$ifdef HASCURRENCY}
1306
1339
  TSetCurrencyProc = procedure(const AValue: Currency) of object;
1307
1340
  TSetCurrencyProcIndex = procedure(Index: integer; const AValue: Currency) of object;
1308
 
{$endif HASCURRENCY}
1309
1341
Var
1310
1342
  AMethod : TMethod;
1311
1343
begin
1325
1357
        ftComp:
1326
1358
          PComp(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
1327
1359
{$endif FPC_COMP_IS_INT64}
1328
 
{$ifdef HASCURRENCY}
1329
1360
        ftCurr:
1330
1361
          PCurrency(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
1331
 
{$endif HASCURRENCY}
1332
1362
       end;
1333
1363
    ptStatic,
1334
1364
    ptVirtual:
1354
1384
              TSetExtendedProc(AMethod)(Value)
1355
1385
            else
1356
1386
              TSetExtendedProcIndex(AMethod)(PropInfo^.Index,Value);
1357
 
          {$ifdef HASCURRENCY}
1358
1387
          ftCurr:
1359
1388
            if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
1360
1389
              TSetCurrencyProc(AMethod)(Value)
1361
1390
            else
1362
1391
              TSetCurrencyProcIndex(AMethod)(PropInfo^.Index,Value);
1363
 
          {$endif HASCURRENCY}
1364
1392
        end;
1365
1393
      end;
1366
1394
  end;
1559
1587
end;
1560
1588
 
1561
1589
end.
1562
 
{
1563
 
  $Log: typinfo.pp,v $
1564
 
  Revision 1.45  2005/04/16 09:24:29  michael
1565
 
  + Moved constants to rtlconsts and added callbacks for variant support
1566
 
 
1567
 
  Revision 1.44  2005/04/14 17:43:07  michael
1568
 
  + Added getPropValue by Uberto Barbini
1569
 
 
1570
 
  Revision 1.43  2005/04/05 06:44:25  marco
1571
 
   * Currency property patch from Dean Zobec
1572
 
 
1573
 
  Revision 1.42  2005/04/03 11:50:58  marco
1574
 
   * patch for 3854 added. There are probably more places that need explicit
1575
 
  currency handling.
1576
 
 
1577
 
  Revision 1.41  2005/03/14 21:15:52  florian
1578
 
    * fixed compilation on i386
1579
 
 
1580
 
  Revision 1.40  2005/03/14 19:16:06  peter
1581
 
    * getordprop supports int64
1582
 
 
1583
 
  Revision 1.39  2005/02/26 20:59:38  florian
1584
 
    * fixed 1.0.10 issue
1585
 
 
1586
 
  Revision 1.38  2005/02/26 11:37:01  florian
1587
 
    + overload of GetPropList added
1588
 
 
1589
 
  Revision 1.37  2005/02/22 12:14:56  marco
1590
 
   * getproplist sorted param added.
1591
 
 
1592
 
  Revision 1.36  2005/02/14 17:13:31  peter
1593
 
    * truncate log
1594
 
 
1595
 
  Revision 1.35  2005/02/08 16:10:29  florian
1596
 
    * TTOrdType -> TOrdType
1597
 
 
1598
 
}