← Back to branch summary

~ubuntu-branches/ubuntu/vivid/lazarus/vivid-proposed

« back to all changes in this revision

Viewing changes to examples/xmlresource/xmlresourcefile.pas

  • Committer: Package Import Robot
  • Author(s): Abou Al Montacir
  • Date: 2014-07-14 20:16:50 UTC
  • mfrom: (1.1.15)
  • Revision ID: package-import@ubuntu.com-20140714201650-ossm36rrsdomp379
Tags: 1.2.4+dfsg-1
* New upstream release with few fixes and official support of FPC 2.6.4.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.2_fixes_branch#Fixes_for_1.2.4_.28Merged.29

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/xmlresource/xmlresourcefile.pas
689
689
end;
690
690
 
691
691
end.
692
 
 
693
 
unit xmlresourcefile;
694
 
 
695
 
{$mode objfpc}{$H+}
696
 
 
697
 
interface
698
 
 
699
 
uses
700
 
  Classes, SysUtils,
701
 
  LCLMemManager, forms,
702
 
  dom, XMLRead,XMLWrite,
703
 
  ProjectIntf,
704
 
  UnitResources;
705
 
 
706
 
type
707
 
 
708
 
  { TXMLUnitResourcefileFormat }
709
 
 
710
 
  TXMLUnitResourcefileFormat = class(TUnitResourcefileFormat)
711
 
  private
712
 
    class procedure QuickReadXML(s: TStream; out AComponentName, AClassName, ALCLVersion: string);
713
 
  public
714
 
    class function FindResourceDirective(Source: TObject): boolean; override;
715
 
    class function ResourceDirectiveFilename: string; override;
716
 
    class function GetUnitResourceFilename(AUnitFilenae: string): string; override;
717
 
    class procedure TextStreamToBinStream(ATxtStream, ABinStream: TExtMemoryStream); override;
718
 
    class procedure BinStreamToTextStream(ABinStream, ATextStream: TExtMemoryStream); override;
719
 
    class function GetClassNameFromStream(s: TStream; out IsInherited: Boolean): shortstring; override;
720
 
    class function CreateReader(s: TStream; var DestroyDriver: boolean): TReader; override;
721
 
    class function CreateWriter(s: TStream; var DestroyDriver: boolean): TWriter; override;
722
 
    class function QuickCheckResourceBuffer(PascalBuffer, LFMBuffer: TObject;
723
 
      out LFMType, LFMComponentName, LFMClassName: string; out
724
 
      LCLVersion: string; out MissingClasses: TStrings): TModalResult; override;
725
 
  end;
726
 
 
727
 
  { TXMLReader }
728
 
 
729
 
  TXMLReader = class(TReader)
730
 
  protected
731
 
    function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader; override;
732
 
  end;
733
 
 
734
 
  { TXMLObjectReader }
735
 
 
736
 
  TXMLObjectReader = class(TAbstractObjectReader)
737
 
  private
738
 
    FXMLDoc: TXMLDocument;
739
 
    FStream: TStream;
740
 
    FObjNode: TDOMNode;
741
 
    FCurNode: TDOMNode;
742
 
    FCurValue: string;
743
 
    FReadingChilds: Boolean;
744
 
  public
745
 
    constructor create(AStream: TStream); virtual;
746
 
    destructor Destroy; override;
747
 
    function NextValue: TValueType; override;
748
 
    function ReadValue: TValueType; override;
749
 
    procedure BeginRootComponent; override;
750
 
    procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
751
 
      var CompClassName, CompName: String); override;
752
 
    function BeginProperty: String; override;
753
 
 
754
 
    //Please don't use read, better use ReadBinary whenever possible
755
 
    procedure Read(var Buf; Count: LongInt); override;
756
 
    { All ReadXXX methods are called _after_ the value type has been read! }
757
 
    procedure ReadBinary(const DestData: TMemoryStream); override;
758
 
    function ReadCurrency: Currency; override;
759
 
    function ReadIdent(ValueType: TValueType): String; override;
760
 
    function ReadInt8: ShortInt; override;
761
 
    function ReadInt16: SmallInt; override;
762
 
    function ReadInt32: LongInt; override;
763
 
    function ReadInt64: Int64; override;
764
 
    function ReadSet(EnumType: Pointer): Integer; override;
765
 
    function ReadStr: String; override;
766
 
    function ReadString(StringType: TValueType): String; override;
767
 
    function ReadWideString: WideString;override;
768
 
    function ReadUnicodeString: UnicodeString;override;
769
 
    procedure SkipComponent(SkipComponentInfos: Boolean); override;
770
 
    procedure SkipValue; override;
771
 
  end;
772
 
 
773
 
  { TXMLWriter }
774
 
 
775
 
  TXMLWriter = class(TWriter)
776
 
  protected
777
 
    function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectWriter; override;
778
 
  end;
779
 
 
780
 
  { TXMLObjectWriter }
781
 
 
782
 
  TXMLObjectWriter = class(TAbstractObjectWriter)
783
 
  private
784
 
    FXMLCreated: boolean;
785
 
    FXMLDoc: TXMLDocument;
786
 
    FListLevel: integer;
787
 
    FObjNode: TDOMNode;
788
 
    FCurNode: TDOMElement;
789
 
    FStream: TStream;
790
 
    FIsStreamingProps: boolean;
791
 
  private
792
 
    procedure CreateXML;
793
 
  public
794
 
    constructor Create(Stream: TStream; BufSize: Integer);
795
 
    destructor Destroy; override;
796
 
 
797
 
    procedure BeginCollection; override;
798
 
    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
799
 
      ChildPos: Integer); override;
800
 
    procedure BeginList; override;
801
 
    procedure EndList; override;
802
 
    procedure BeginProperty(const PropName: String); override;
803
 
    procedure EndProperty; override;
804
 
 
805
 
    //Please don't use write, better use WriteBinary whenever possible
806
 
    procedure Write(const Buffer; Count: Longint); override;
807
 
    procedure WriteBinary(const Buffer; Count: LongInt); override;
808
 
    procedure WriteBoolean(Value: Boolean); override;
809
 
 
810
 
    procedure WriteCurrency(const Value: Currency); override;
811
 
    procedure WriteIdent(const Ident: string); override;
812
 
    procedure WriteInteger(Value: Int64); override;
813
 
    procedure WriteUInt64(Value: QWord); override;
814
 
    procedure WriteMethodName(const Name: String); override;
815
 
    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
816
 
    procedure WriteString(const Value: String); override;
817
 
    procedure WriteWideString(const Value: WideString); override;
818
 
    procedure WriteUnicodeString(const Value: UnicodeString); override;
819
 
    procedure WriteVariant(const VarValue: Variant);override;
820
 
 
821
 
    procedure WriteFloat(const Value: Extended);  override;
822
 
    procedure WriteSingle(const Value: Single); override;
823
 
    procedure WriteDate(const Value: TDateTime); override;
824
 
 
825
 
 
826
 
  end;
827
 
 
828
 
  { TFileDescPascalUnitWithXMLResource }
829
 
 
830
 
  TFileDescPascalUnitWithXMLResource = class(TFileDescPascalUnitWithResource)
831
 
  public
832
 
    constructor Create; override;
833
 
    function GetLocalizedName: string; override;
834
 
    function GetLocalizedDescription: string; override;
835
 
    function GetImplementationSource(const Filename, SourceName, ResourceName: string): string; override;
836
 
  end;
837
 
 
838
 
 
839
 
procedure register;
840
 
 
841
 
implementation
842
 
 
843
 
uses
844
 
  FileUtil,
845
 
  RtlConsts,
846
 
  CodeCache;
847
 
 
848
 
procedure register;
849
 
begin
850
 
  RegisterUnitResourcefileFormat(TXMLUnitResourcefileFormat);
851
 
  RegisterProjectFileDescriptor(TFileDescPascalUnitWithXMLResource.Create,
852
 
                                FileDescGroupName);
853
 
end;
854
 
 
855
 
{ TFileDescPascalUnitWithXMLResource }
856
 
 
857
 
constructor TFileDescPascalUnitWithXMLResource.Create;
858
 
begin
859
 
  inherited Create;
860
 
  ResourceClass:=TForm;
861
 
end;
862
 
 
863
 
function TFileDescPascalUnitWithXMLResource.GetLocalizedName: string;
864
 
begin
865
 
  Result:='Form with XML resource file';
866
 
end;
867
 
 
868
 
function TFileDescPascalUnitWithXMLResource.GetLocalizedDescription: string;
869
 
begin
870
 
  Result:='Create a new unit with a LCL form with XML resource file.';
871
 
end;
872
 
 
873
 
function TFileDescPascalUnitWithXMLResource.GetImplementationSource(
874
 
  const Filename, SourceName, ResourceName: string): string;
875
 
var
876
 
  ResourceFilename: String;
877
 
  LE: String;
878
 
begin
879
 
  LE:=LineEnding;
880
 
  case GetResourceType of
881
 
    rtLRS:
882
 
      begin
883
 
        ResourceFilename:=TrimFilename(ExtractFilenameOnly(Filename)+DefaultResFileExt);
884
 
        Result:='initialization'+LE+'  {$I '+ResourceFilename+'}'+LE+LE;
885
 
      end;
886
 
    rtRes: Result := '{$R *.xml}'+LE+LE;
887
 
  end;
888
 
end;
889
 
 
890
 
{ TXMLObjectWriter }
891
 
 
892
 
procedure TXMLObjectWriter.CreateXML;
893
 
begin
894
 
  FXMLDoc := TXMLDocument.Create;
895
 
  FXMLCreated:=true;
896
 
end;
897
 
 
898
 
constructor TXMLObjectWriter.Create(Stream: TStream; BufSize: Integer);
899
 
begin
900
 
  inherited Create;
901
 
  FStream:=Stream;
902
 
end;
903
 
 
904
 
destructor TXMLObjectWriter.Destroy;
905
 
begin
906
 
  FXMLDoc.Free;
907
 
  inherited Destroy;
908
 
end;
909
 
 
910
 
procedure TXMLObjectWriter.BeginCollection;
911
 
begin
912
 
 
913
 
end;
914
 
 
915
 
procedure TXMLObjectWriter.BeginComponent(Component: TComponent;
916
 
  Flags: TFilerFlags; ChildPos: Integer);
917
 
var
918
 
  ANewNode : TDOMElement;
919
 
begin
920
 
  if not FXmlCreated then
921
 
    begin
922
 
    CreateXML;
923
 
    end;
924
 
  inc(FListLevel,2);
925
 
  ANewNode := FXMLDoc.CreateElement('object');
926
 
 
927
 
  ANewNode.AttribStrings['type'] := Component.ClassName;
928
 
  ANewNode.AttribStrings['name'] := Component.Name;
929
 
  if not assigned(FObjNode) then
930
 
    FXMLDoc.AppendChild(ANewNode)
931
 
  else
932
 
    FObjNode.AppendChild(ANewNode);
933
 
  FObjNode := ANewNode;
934
 
  FIsStreamingProps:=True;
935
 
end;
936
 
 
937
 
procedure TXMLObjectWriter.BeginList;
938
 
begin
939
 
  inc(FListLevel);
940
 
end;
941
 
 
942
 
procedure TXMLObjectWriter.EndList;
943
 
begin
944
 
  dec(FListLevel);
945
 
  if FIsStreamingProps then
946
 
    begin
947
 
    FIsStreamingProps:=false;
948
 
    end
949
 
  else
950
 
    FObjNode := FObjNode.ParentNode;
951
 
 
952
 
  if FListLevel=0 then
953
 
    WriteXMLFile(FXMLDoc,FStream);
954
 
end;
955
 
 
956
 
procedure TXMLObjectWriter.BeginProperty(const PropName: String);
957
 
begin
958
 
  FCurNode := FXMLDoc.CreateElement('property');
959
 
  FObjNode.AppendChild(FCurNode);
960
 
  FCurNode.AttribStrings['name'] := PropName;
961
 
end;
962
 
 
963
 
procedure TXMLObjectWriter.EndProperty;
964
 
begin
965
 
  // Do nothing
966
 
end;
967
 
 
968
 
procedure TXMLObjectWriter.Write(const Buffer; Count: Longint);
969
 
begin
970
 
 
971
 
end;
972
 
 
973
 
procedure TXMLObjectWriter.WriteBinary(const Buffer; Count: LongInt);
974
 
begin
975
 
 
976
 
end;
977
 
 
978
 
procedure TXMLObjectWriter.WriteBoolean(Value: Boolean);
979
 
begin
980
 
  if value then
981
 
    begin
982
 
    FCurNode.AttribStrings['type'] := 'vatrue';
983
 
    FCurNode.TextContent:='True';
984
 
    end
985
 
  else
986
 
    begin
987
 
    FCurNode.AttribStrings['type'] := 'vafalse';
988
 
    FCurNode.TextContent:='False';
989
 
    end
990
 
end;
991
 
 
992
 
procedure TXMLObjectWriter.WriteCurrency(const Value: Currency);
993
 
begin
994
 
 
995
 
end;
996
 
 
997
 
procedure TXMLObjectWriter.WriteIdent(const Ident: string);
998
 
begin
999
 
  FCurNode.AttribStrings['type'] := 'ident';
1000
 
  FCurNode.TextContent:=Ident;
1001
 
end;
1002
 
 
1003
 
procedure TXMLObjectWriter.WriteInteger(Value: Int64);
1004
 
begin
1005
 
  FCurNode.AttribStrings['type'] := 'int64';
1006
 
  FCurNode.TextContent:=inttostr(value);
1007
 
end;
1008
 
 
1009
 
procedure TXMLObjectWriter.WriteUInt64(Value: QWord);
1010
 
begin
1011
 
  FCurNode.AttribStrings['type'] := 'int64';
1012
 
  FCurNode.TextContent:=inttostr(value);
1013
 
end;
1014
 
 
1015
 
procedure TXMLObjectWriter.WriteMethodName(const Name: String);
1016
 
begin
1017
 
  FCurNode.AttribStrings['type'] := 'ident';
1018
 
  FCurNode.TextContent:=Name;
1019
 
end;
1020
 
 
1021
 
procedure TXMLObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
1022
 
begin
1023
 
 
1024
 
end;
1025
 
 
1026
 
procedure TXMLObjectWriter.WriteString(const Value: String);
1027
 
begin
1028
 
  FCurNode.AttribStrings['type'] := 'string';
1029
 
  FCurNode.TextContent:=value;
1030
 
end;
1031
 
 
1032
 
procedure TXMLObjectWriter.WriteWideString(const Value: WideString);
1033
 
begin
1034
 
 
1035
 
end;
1036
 
 
1037
 
procedure TXMLObjectWriter.WriteUnicodeString(const Value: UnicodeString);
1038
 
begin
1039
 
 
1040
 
end;
1041
 
 
1042
 
procedure TXMLObjectWriter.WriteVariant(const VarValue: Variant);
1043
 
begin
1044
 
 
1045
 
end;
1046
 
 
1047
 
procedure TXMLObjectWriter.WriteFloat(const Value: Extended);
1048
 
begin
1049
 
  //
1050
 
end;
1051
 
 
1052
 
procedure TXMLObjectWriter.WriteSingle(const Value: Single);
1053
 
begin
1054
 
  //
1055
 
end;
1056
 
 
1057
 
procedure TXMLObjectWriter.WriteDate(const Value: TDateTime);
1058
 
begin
1059
 
  //
1060
 
end;
1061
 
 
1062
 
{ TXMLWriter }
1063
 
 
1064
 
function TXMLWriter.CreateDriver(Stream: TStream; BufSize: Integer
1065
 
  ): TAbstractObjectWriter;
1066
 
begin
1067
 
  Result:=TXMLObjectWriter.Create(Stream,BufSize);
1068
 
end;
1069
 
 
1070
 
{ TXMLObjectReader }
1071
 
 
1072
 
constructor TXMLObjectReader.create(AStream: TStream);
1073
 
begin
1074
 
  inherited create;
1075
 
 
1076
 
  If (AStream=Nil) then
1077
 
    Raise EReadError.Create(SEmptyStreamIllegalReader);
1078
 
 
1079
 
  FStream := AStream;
1080
 
end;
1081
 
 
1082
 
destructor TXMLObjectReader.Destroy;
1083
 
begin
1084
 
  FXMLDoc.Free;
1085
 
  inherited Destroy;
1086
 
end;
1087
 
 
1088
 
function TXMLObjectReader.NextValue: TValueType;
1089
 
var
1090
 
  StoreNode,
1091
 
  StoreObjNode: TDOMNode;
1092
 
  StoreReadingChilds: boolean;
1093
 
begin
1094
 
  StoreNode := FCurNode;
1095
 
  StoreObjNode := FObjNode;
1096
 
  StoreReadingChilds := FReadingChilds;
1097
 
  result := ReadValue;
1098
 
  FCurNode:=StoreNode;
1099
 
  FObjNode:=StoreObjNode;
1100
 
  FReadingChilds:=StoreReadingChilds;
1101
 
end;
1102
 
 
1103
 
function TXMLObjectReader.ReadValue: TValueType;
1104
 
begin
1105
 
  result := vaNull;
1106
 
  if not assigned(FCurNode) then
1107
 
    begin
1108
 
    if not FReadingChilds then
1109
 
      begin
1110
 
      FCurNode := FObjNode.FirstChild;
1111
 
      while assigned(FCurNode) and (FCurNode.NodeName<>'object') do
1112
 
        FCurNode := FCurNode.NextSibling;
1113
 
      FReadingChilds:=true;
1114
 
      end
1115
 
    else
1116
 
      begin
1117
 
      if assigned(FObjNode.NextSibling) then
1118
 
        FCurNode := FObjNode.NextSibling
1119
 
      else if assigned(FObjNode.ParentNode) then
1120
 
        FObjNode := FObjNode.ParentNode;
1121
 
 
1122
 
      while assigned(FCurNode) and (FCurNode.NodeName<>'object') do
1123
 
        FCurNode := FCurNode.NextSibling;
1124
 
      end;
1125
 
    Exit;
1126
 
    end;
1127
 
 
1128
 
  if not FReadingChilds and (FCurNode.NodeName='property') then
1129
 
    begin
1130
 
    FCurValue := FCurNode.TextContent;
1131
 
    if FCurNode.Attributes.GetNamedItem('type').NodeValue='int16' then
1132
 
      result := vaInt16
1133
 
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='int64' then
1134
 
      result := vaInt32
1135
 
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='string' then
1136
 
      result := vaString
1137
 
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='vatrue' then
1138
 
      result := vaTrue
1139
 
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='vafalse' then
1140
 
      result := vaFalse
1141
 
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='ident' then
1142
 
      result := vaIdent
1143
 
    else
1144
 
      raise EReadError.CreateFmt('Unknown property type %s',[FCurNode.Attributes.GetNamedItem('type').NodeValue]);
1145
 
    end;
1146
 
 
1147
 
  if FReadingChilds and (FCurNode.NodeName='object') then
1148
 
    result := vaIdent;
1149
 
 
1150
 
  FCurNode := FCurNode.NextSibling;
1151
 
  while assigned(FCurNode) do
1152
 
    begin
1153
 
    if FReadingChilds and (FCurNode.NodeName='object') then
1154
 
      break;
1155
 
    if not FReadingChilds and (FCurNode.NodeName='property') then
1156
 
      break;
1157
 
    FCurNode := FCurNode.NextSibling;
1158
 
    end;
1159
 
end;
1160
 
 
1161
 
procedure TXMLObjectReader.BeginRootComponent;
1162
 
begin
1163
 
  FXMLDoc.Free;
1164
 
 
1165
 
  ReadXMLFile(FXMLDoc, FStream);
1166
 
  FCurNode := FXMLDoc.FindNode('object');
1167
 
  if not assigned(FCurNode) then
1168
 
    raise EReadError.Create('Invalid XML-stream format: No object node found');
1169
 
end;
1170
 
 
1171
 
procedure TXMLObjectReader.BeginComponent(var Flags: TFilerFlags;
1172
 
  var AChildPos: Integer; var CompClassName, CompName: String);
1173
 
begin
1174
 
  flags := [];
1175
 
  FReadingChilds:=false;
1176
 
 
1177
 
  assert(FObjNode.NodeName='object');
1178
 
  FObjNode:=FCurNode;
1179
 
  CompName:=FObjNode.Attributes.GetNamedItem('name').NodeValue;
1180
 
  CompClassName:=FObjNode.Attributes.GetNamedItem('type').NodeValue;
1181
 
  FCurNode := FObjNode.FirstChild;
1182
 
  while assigned(FCurNode) and (FCurNode.NodeName<>'property') do
1183
 
    FCurNode := FCurNode.NextSibling;
1184
 
end;
1185
 
 
1186
 
function TXMLObjectReader.BeginProperty: String;
1187
 
begin
1188
 
  if FCurNode.NodeName<>'property' then
1189
 
    raise exception.create('property-element expected but found '+FCurNode.NodeName);
1190
 
  result := FCurNode.Attributes.GetNamedItem('name').NodeValue;
1191
 
end;
1192
 
 
1193
 
procedure TXMLObjectReader.Read(var Buf; Count: LongInt);
1194
 
begin
1195
 
 
1196
 
end;
1197
 
 
1198
 
procedure TXMLObjectReader.ReadBinary(const DestData: TMemoryStream);
1199
 
begin
1200
 
 
1201
 
end;
1202
 
 
1203
 
function TXMLObjectReader.ReadCurrency: Currency;
1204
 
begin
1205
 
 
1206
 
end;
1207
 
 
1208
 
function TXMLObjectReader.ReadIdent(ValueType: TValueType): String;
1209
 
begin
1210
 
  result := FCurValue;
1211
 
end;
1212
 
 
1213
 
function TXMLObjectReader.ReadInt8: ShortInt;
1214
 
begin
1215
 
  result := strtoint(FCurValue);
1216
 
end;
1217
 
 
1218
 
function TXMLObjectReader.ReadInt16: SmallInt;
1219
 
begin
1220
 
  result := strtoint(FCurValue);
1221
 
end;
1222
 
 
1223
 
function TXMLObjectReader.ReadInt32: LongInt;
1224
 
begin
1225
 
  result := strtoint(FCurValue);
1226
 
end;
1227
 
 
1228
 
function TXMLObjectReader.ReadInt64: Int64;
1229
 
begin
1230
 
  result := StrToInt64(FCurValue);
1231
 
end;
1232
 
 
1233
 
function TXMLObjectReader.ReadSet(EnumType: Pointer): Integer;
1234
 
begin
1235
 
 
1236
 
end;
1237
 
 
1238
 
function TXMLObjectReader.ReadStr: String;
1239
 
begin
1240
 
  result := FCurValue;
1241
 
end;
1242
 
 
1243
 
function TXMLObjectReader.ReadString(StringType: TValueType): String;
1244
 
begin
1245
 
  result := FCurValue;
1246
 
end;
1247
 
 
1248
 
function TXMLObjectReader.ReadWideString: WideString;
1249
 
begin
1250
 
  result := FCurValue;
1251
 
end;
1252
 
 
1253
 
function TXMLObjectReader.ReadUnicodeString: UnicodeString;
1254
 
begin
1255
 
  result := FCurValue;
1256
 
end;
1257
 
 
1258
 
procedure TXMLObjectReader.SkipComponent(SkipComponentInfos: Boolean);
1259
 
begin
1260
 
 
1261
 
end;
1262
 
 
1263
 
procedure TXMLObjectReader.SkipValue;
1264
 
begin
1265
 
 
1266
 
end;
1267
 
 
1268
 
{ TXMLReader }
1269
 
 
1270
 
function TXMLReader.CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader;
1271
 
begin
1272
 
  Result := TXMLObjectReader.Create(Stream);
1273
 
end;
1274
 
 
1275
 
{ TXMLUnitResourcefileFormat }
1276
 
 
1277
 
class procedure TXMLUnitResourcefileFormat.QuickReadXML(s: TStream; out
1278
 
  AComponentName, AClassName, ALCLVersion: string);
1279
 
var
1280
 
  AXMLDocument: TXMLDocument;
1281
 
  ms: TStringStream;
1282
 
  ObjNode: TDOMNode;
1283
 
begin
1284
 
  ReadXMLFile(AXMLDocument, s);
1285
 
  try
1286
 
    ObjNode := AXMLDocument.FindNode('lazarusinfo');
1287
 
    if assigned(ObjNode) then
1288
 
      begin
1289
 
      ObjNode := ObjNode.FindNode('lclversion');
1290
 
      if assigned(ObjNode) then
1291
 
        ALCLVersion:=ObjNode.TextContent;
1292
 
      end;
1293
 
 
1294
 
    ObjNode := AXMLDocument.FindNode('object');
1295
 
    if not assigned(ObjNode) then
1296
 
      raise EReadError.Create('Invalid XML-stream format: No object node found');
1297
 
    AComponentName:=ObjNode.Attributes.GetNamedItem('name').NodeValue;
1298
 
    AClassName:=ObjNode.Attributes.GetNamedItem('type').NodeValue;
1299
 
 
1300
 
  finally
1301
 
    AXMLDocument.Free;
1302
 
  end;
1303
 
end;
1304
 
 
1305
 
class function TXMLUnitResourcefileFormat.FindResourceDirective(Source: TObject): boolean;
1306
 
var
1307
 
  cb: TCodeBuffer;
1308
 
  nx,ny,nt: integer;
1309
 
begin
1310
 
//  result := CodeToolBoss.FindResourceDirective(Source as TCodeBuffer,1,1,cb,nx,ny,nt, ResourceDirectiveFilename,false);
1311
 
end;
1312
 
 
1313
 
class function TXMLUnitResourcefileFormat.ResourceDirectiveFilename: string;
1314
 
begin
1315
 
  result := '*.xml';
1316
 
end;
1317
 
 
1318
 
class function TXMLUnitResourcefileFormat.GetUnitResourceFilename(
1319
 
  AUnitFilenae: string): string;
1320
 
begin
1321
 
  result := ChangeFileExt(AUnitFilenae,'.xml');
1322
 
end;
1323
 
 
1324
 
class procedure TXMLUnitResourcefileFormat.TextStreamToBinStream(ATxtStream,
1325
 
  ABinStream: TExtMemoryStream);
1326
 
begin
1327
 
  ABinStream.LoadFromStream(ATxtStream);
1328
 
end;
1329
 
 
1330
 
class procedure TXMLUnitResourcefileFormat.BinStreamToTextStream(ABinStream,
1331
 
  ATextStream: TExtMemoryStream);
1332
 
begin
1333
 
  ATextStream.LoadFromStream(ABinStream);
1334
 
end;
1335
 
 
1336
 
class function TXMLUnitResourcefileFormat.GetClassNameFromStream(s: TStream;
1337
 
  out IsInherited: Boolean): shortstring;
1338
 
var
1339
 
  AComponentName,
1340
 
  AClassType,
1341
 
  ALCLVersion: string;
1342
 
begin
1343
 
  IsInherited:=false;
1344
 
  QuickReadXML(s, AComponentName, AClassType, ALCLVersion);
1345
 
  s.Seek(0,soFromBeginning);
1346
 
  result := AClassType;
1347
 
end;
1348
 
 
1349
 
class function TXMLUnitResourcefileFormat.CreateReader(s: TStream;
1350
 
  var DestroyDriver: boolean): TReader;
1351
 
begin
1352
 
  result := TXMLReader.Create(s,4096);
1353
 
end;
1354
 
 
1355
 
class function TXMLUnitResourcefileFormat.CreateWriter(s: TStream;
1356
 
  var DestroyDriver: boolean): TWriter;
1357
 
var
1358
 
  ADriver: TXMLObjectWriter;
1359
 
begin
1360
 
  ADriver:=TXMLObjectWriter.Create(s,4096);
1361
 
  result := TWriter.Create(ADriver);
1362
 
  DestroyDriver:=false;
1363
 
end;
1364
 
 
1365
 
class function TXMLUnitResourcefileFormat.QuickCheckResourceBuffer(
1366
 
  PascalBuffer, LFMBuffer: TObject; out LFMType, LFMComponentName,
1367
 
  LFMClassName: string; out LCLVersion: string; out MissingClasses: TStrings
1368
 
  ): TModalResult;
1369
 
var
1370
 
  ms: TStringStream;
1371
 
begin
1372
 
  ms := TStringStream.Create((LFMBuffer as TCodeBuffer).Source);
1373
 
  try
1374
 
    QuickReadXML(ms, LFMComponentName, LFMClassName, LCLVersion);
1375
 
  finally
1376
 
    ms.Free;
1377
 
  end;
1378
 
 
1379
 
  LFMType:='unknown';
1380
 
  MissingClasses := nil;
1381
 
end;
1382
 
 
1383
 
end.
1384