* Added basic TCustomAttribute tests

git-svn-id: branches/joost/classattributes@22965 -

.gitattributes

@@ -10479,6 +10479,12 @@ tests/test/tclass6.pp svneol=native#text/plain
 tests/test/tclass7.pp svneol=native#text/plain
 tests/test/tclass8.pp svneol=native#text/plain
 tests/test/tclass9.pp svneol=native#text/pascal
+tests/test/tclassattribute1.pp svneol=native#text/plain
+tests/test/tclassattribute2.pp svneol=native#text/plain
+tests/test/tclassattribute3.pp svneol=native#text/plain
+tests/test/tclassattribute4.pp svneol=native#text/plain
+tests/test/tclassattribute5.pp svneol=native#text/plain
+tests/test/tclassattribute6.pp svneol=native#text/plain
 tests/test/tclassinfo1.pp svneol=native#text/pascal
 tests/test/tclrprop.pp svneol=native#text/plain
 tests/test/tcmov1.pp svneol=native#text/plain

tests/test/tclassattribute1.pp

@@ -0,0 +1,42 @@
+program tclassattribute1;
+
+{$mode objfpc}{$H+}
+
+uses
+  typinfo;
+
+type
+
+  { tmyt }
+
+  tmyt = class(TCustomAttribute)
+    constructor create;
+  end;
+
+type
+  [Tmyt]
+  TMyObject = class(TObject)
+  end;
+
+var
+  td: PTypeData;
+  AClassAttribute: TCustomAttribute;
+
+{ tmyt }
+
+constructor tmyt.create;
+begin
+  //
+end;
+
+begin
+  td := GetTypeData(TMyObject.ClassInfo);
+  if td^.AttributeCount<>1 then
+    halt(1);
+
+  AClassAttribute := GetClassAttribute(td,0) as TCustomAttribute;
+  if AClassAttribute = nil then
+    halt(2);
+  writeln('ok');
+end.
+

tests/test/tclassattribute2.pp

@@ -0,0 +1,15 @@
+{ %fail }
+program tclassattribute2;
+
+{$mode objfpc}{$H+}
+
+type
+  // Delphi XE does compile attributes that are not defined, but ignores them.
+  // That's clearly a Delphi-bug, so fpc should fail on the following:
+  [TMyAttributeDoesNotExist]
+  TMyObject = class(TObject)
+  end;
+
+begin
+end.
+

tests/test/tclassattribute3.pp

@@ -0,0 +1,21 @@
+{ %fail }
+program tclassattribute3;
+
+{$mode objfpc}{$H+}
+
+type
+
+  { tmyt }
+
+  tmyt = class
+    constructor create;
+  end;
+
+  // tmyt is not a TCustomAttribute, so this should fail.
+  [tmyt]
+  TMyObject = class(TObject)
+  end;
+
+begin
+end.
+

tests/test/tclassattribute4.pp

@@ -0,0 +1,54 @@
+program tclassattribute4;
+
+{$mode objfpc}{$H+}
+
+uses
+  typinfo;
+
+type
+
+  { tmyt }
+
+  tmyt = class(TCustomAttribute)
+  private
+    FID: integer;
+  public
+    constructor create(Id: integer);
+  end;
+
+type
+  [Tmyt(924)]
+  [Tmyt(1425)]
+  TMyObject = class(TObject)
+  end;
+
+var
+  td: PTypeData;
+  AClassAttribute: tmyt;
+
+{ tmyt }
+
+constructor tmyt.create(Id: integer);
+begin
+  Fid := Id;
+end;
+
+begin
+  td := GetTypeData(TMyObject.ClassInfo);
+  if td^.AttributeCount<>2 then
+    halt(1);
+
+  AClassAttribute := GetClassAttribute(td,1) as tmyt;
+  if AClassAttribute = nil then
+    halt(2);
+  if AClassAttribute.FID<>1425 then
+    halt(3);
+
+  AClassAttribute := GetClassAttribute(td,0) as tmyt;
+  if AClassAttribute = nil then
+    halt(2);
+  if AClassAttribute.FID<>924 then
+    halt(3);
+  writeln('ok');
+end.
+

tests/test/tclassattribute5.pp

@@ -0,0 +1,29 @@
+{ %fail }
+program tclassattribute5;
+
+{$mode objfpc}{$H+}
+
+uses
+  typinfo;
+
+type
+
+  { tmyt }
+
+  tmyt = class(TCustomAttribute)
+  private
+    FID: integer;
+  public
+    constructor create(Id: integer);
+  end;
+
+type
+  // Delphi XE does compile attributes with invalid parameters.
+  // That's clearly a Delphi-bug, so fpc should fail on the following:
+  [Tmyt(924,32)]
+  TMyObject = class(TObject)
+  end;
+
+begin
+end.
+

tests/test/tclassattribute6.pp

@@ -0,0 +1,50 @@
+program tclassattribute6;
+
+{$mode objfpc}{$H+}
+
+uses
+  typinfo;
+
+type
+
+  { tmyt }
+
+  TMyt = class(TCustomAttribute)
+    constructor create;
+  end;
+
+type
+
+  { TMyObject }
+
+  TMyObject = class(TObject)
+  private
+    FInt: integer;
+  published
+    [TMyt]
+    property PublicInt: integer read FInt;
+  end;
+
+constructor TMyt.create;
+begin
+
+end;
+
+
+var
+  pi: PPropInfo;
+  AClassAttribute: TCustomAttribute;
+
+begin
+  pi := GetPropInfo(TMyObject.ClassInfo,'PublicInt');
+  if pi^.AttributeCount<>1 then
+    halt(1);
+
+  AClassAttribute := GetPropAttribute(pi,0) as TCustomAttribute;
+  if AClassAttribute = nil then
+    halt(2);
+
+  writeln('ok');
+
+end.
+