1{ 2 This file is part of the Free Pascal run time library. 3 Copyright (c) 2019 by the Free Pascal development team 4 5 SQLDB REST bridge : XML input/output 6 7 See the file COPYING.FPC, included in this distribution, 8 for details about the copyright. 9 10 This program is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 14 **********************************************************************} 15unit sqldbrestxml; 16 17{$mode objfpc}{$H+} 18 19interface 20 21uses 22 Classes, SysUtils, DateUtils, db,fpjson, dom, XMLRead, XMLWrite,sqldbrestschema,sqldbrestio, sqldbrestbridge; 23 24Type 25 26 { TXMLInputStreamer } 27 28 TXMLInputStreamer = Class(TRestInputStreamer) 29 private 30 FXML: TXMLDocument; 31 FPacket : TDOMElement; 32 FData : TDOMElement; 33 FRow : TDOMElement; 34 Protected 35 function GetNodeText(N: TDOmNode): UnicodeString; 36 Public 37 Destructor Destroy; override; 38 Class Function GetContentType: String; override; 39 Function SelectObject(aIndex : Integer) : Boolean; override; 40 function GetContentField(aName: UTF8string): TJSONData; override; 41 procedure InitStreaming; override; 42 Property XML : TXMLDocument Read FXML; 43 Property Packet : TDOMElement Read FPacket; 44 Property Data : TDOMElement Read FData; 45 Property Row : TDOMElement Read FRow; 46 end; 47 48 { TXMLOutputStreamer } 49 50 TXMLOutputStreamer = Class(TRestOutputStreamer) 51 Private 52 FXML: TXMLDocument; 53 FData : TDOMElement; 54 FRow: TDOMElement; 55 FRoot: TDomElement; 56 Public 57 procedure EndData; override; 58 procedure EndRow; override; 59 procedure FinalizeOutput; override; 60 procedure StartData; override; 61 procedure StartRow; override; 62 // Return Nil for null field. 63 function FieldToXML(aPair: TRestFieldPair): TDOMElement; virtual; 64 procedure WriteField(aPair: TRestFieldPair); override; 65 procedure WriteMetadata(aFieldList: TRestFieldPairArray); override; 66 Procedure CreateErrorContent(aCode : Integer; Const aMessage: String); override; 67 Property XML : TXMLDocument Read FXML; 68 Property Data : TDOMelement Read FData; 69 Property Row : TDOMelement Read FRow; 70 Public 71 Destructor Destroy; override; 72 Class Function GetContentType: String; override; 73 procedure InitStreaming; override; 74 end; 75 76implementation 77 78uses sqldbrestconst; 79 80{ TXMLInputStreamer } 81 82destructor TXMLInputStreamer.Destroy; 83begin 84 FreeAndNil(FXML); 85 inherited Destroy; 86end; 87 88class function TXMLInputStreamer.GetContentType: String; 89begin 90 Result:='text/xml'; 91end; 92 93function TXMLInputStreamer.SelectObject(aIndex: Integer): Boolean; 94 95Var 96 N : TDomNode; 97 NN : UnicodeString; 98begin 99 Result:=False; 100 NN:=UTF8Decode(GetString(rpRowName)); 101 N:=FData.FindNode(NN); 102 While (aIndex>0) and (N<>Nil) and (N.NodeName<>NN) and (N.NodeType<>ELEMENT_NODE) do 103 begin 104 N:=N.NextSibling; 105 Dec(aIndex); 106 end; 107 Result:=(aIndex=0) and (N<>Nil); 108 If Result then 109 FRow:=N as TDomElement 110 else 111 FRow:=Nil; 112end; 113 114Function TXMLInputStreamer.GetNodeText(N : TDOmNode) : UnicodeString; 115 116Var 117 V : TDomNode; 118 119begin 120 Result:=''; 121 V:=N.FirstChild; 122 While (V<>Nil) and (V.NodeType<>TEXT_NODE) do 123 V:=V.NextSibling; 124 If Assigned(V) then 125 Result:=V.NodeValue; 126end; 127 128function TXMLInputStreamer.GetContentField(aName: UTF8string): TJSONData; 129 130Var 131 NN : UnicodeString; 132 N : TDomNode; 133begin 134 NN:=UTF8Decode(aName); 135 N:=FRow.FindNode(NN); 136 if Assigned(N) and (N.NodeType=ELEMENT_NODE) then 137 Result:=TJSONString.Create(UTF8Encode(GetNodeText(N))); 138end; 139 140procedure TXMLInputStreamer.InitStreaming; 141 142Var 143 Msg : String; 144 N : TDomNode; 145 NN : UnicodeString; 146 147begin 148 FreeAndNil(FXML); 149 if Stream.Size<=0 then 150 exit; 151 try 152 ReadXMLFile(FXML,Stream); 153 except 154 On E : Exception do 155 begin 156 Msg:=E.Message; 157 FXML:=Nil; 158 end; 159 end; 160 if (FXML=Nil) then 161 Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[Msg]); 162 FPacket:=FXML.DocumentElement; 163 NN:=UTF8Decode(GetString(rpXMLDocumentRoot)); 164 if (NN<>'') then 165 begin 166 if FPacket.NodeName<>NN then 167 Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInput,[SErrMissingDocumentRoot]); 168 NN:=UTF8Decode(GetString(rpDataRoot)); 169 N:=FPacket.FindNode(NN); 170 end 171 else 172 begin 173 // if Documentroot is empty, data packet is the root element 174 NN:=UTF8Decode(GetString(rpDataRoot)); 175 if (Packet.NodeName=NN) then 176 N:=FPacket 177 else 178 N:=Nil 179 end; 180 if Not (Assigned(N) and (N is TDOMelement)) then 181 Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsInvalidContent),SErrInvalidXMLInputMissingElement,[NN]); 182 FData:=(N as TDOMelement); 183end; 184 185{ TXMLOutputStreamer } 186 187 188procedure TXMLOutputStreamer.EndData; 189begin 190 FData:=Nil; 191end; 192 193procedure TXMLOutputStreamer.EndRow; 194begin 195 FRow:=Nil; 196end; 197 198procedure TXMLOutputStreamer.FinalizeOutput; 199 200begin 201{$IFNDEF VER3_0} 202 if Not (ooHumanReadable in OutputOptions) then 203 begin 204 With TDOMWriter.Create(Stream,FXML) do 205 try 206 LineBreak:=''; 207 IndentSize:=0; 208 WriteNode(FXML); 209 finally 210 Free; 211 end; 212 end 213 else 214{$ENDIF} 215 xmlwrite.WriteXML(FXML,Stream); 216 FreeAndNil(FXML); 217end; 218 219procedure TXMLOutputStreamer.StartData; 220begin 221 FData:=FXML.CreateElement(UTF8Decode(GetString(rpDataRoot))); 222 FRoot.AppendChild(FData); 223end; 224 225procedure TXMLOutputStreamer.StartRow; 226begin 227 if (FRow<>Nil) then 228 Raise ESQLDBRest.Create(Statuses.GetStatusCode(rsError),SErrDoubleRowStart); 229 FRow:=FXML.CreateElement(UTF8Decode(GetString(rpRowName))); 230 FData.AppendChild(FRow); 231end; 232 233Function TXMLOutputStreamer.FieldToXML(aPair: TRestFieldPair) : TDomElement; 234 235Var 236 F : TField; 237 S : UTF8String; 238 239begin 240 Result:=Nil; 241 F:=aPair.DBField;; 242 If (aPair.RestField.FieldType=rftUnknown) then 243 raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrUnsupportedRestFieldType, [aPair.RestField.PublicName]); 244 If (F.IsNull) then 245 Exit; 246 S:=FieldToString(aPair.RestField.FieldType,F); 247 Result:=FXML.CreateElement(UTF8Decode(aPair.RestField.PublicName)); 248 Result.AppendChild(FXML.CreateTextNode(UTF8Decode(S))); 249end; 250 251procedure TXMLOutputStreamer.WriteField(aPair: TRestFieldPair); 252 253Var 254 D : TDOMElement; 255 N : UTF8String; 256 257begin 258 N:=aPair.RestField.PublicName; 259 if FRow=Nil then 260 Raise ESQLDBRest.CreateFmt(Statuses.GetStatusCode(rsError),SErrFieldWithoutRow,[N]); 261 D:=FieldToXML(aPair); 262 if (D=Nil) and (not HasOption(ooSparse)) then 263 D:=FXML.CreateElement(UTF8Decode(aPair.RestField.PublicName)); 264 if D<>Nil then 265 FRow.AppendChild(D); 266end; 267 268procedure TXMLOutputStreamer.WriteMetadata(aFieldList: TRestFieldPairArray); 269 270Var 271 M : TDOMElement; 272 F : TDomElement; 273 P : TREstFieldPair; 274begin 275 F:=FXML.CreateElement(UTF8Decode(GetString(rpMetaDataFields))); 276 M:=FXML.CreateElement(UTF8Decode(GetString(rpMetaDataRoot))); 277 M.AppendChild(F); 278 FRoot.AppendChild(M); 279 M:=F; 280 For P in aFieldList do 281 begin 282 F:=FXML.CreateElement(UTF8Decode(GetString(rpMetaDataField))); 283 M.AppendChild(F); 284 F[UTF8Decode(GetString(rpFieldNameProp))]:=UTF8Decode(P.RestField.PublicName); 285 F[UTF8Decode(GetString(rpFieldTypeProp))]:=UTF8Decode(typenames[P.RestField.FieldType]); 286 Case P.RestField.FieldType of 287 rftDate : F[UTF8Decode(GetString(rpFieldDateFormatProp))]:=UTF8Decode(GetString(rpDateFormat)); 288 rftTime : F[UTF8Decode(GetString(rpFieldDateFormatProp))]:=UTF8Decode(GetString(rpTimeFormat)); 289 rftDateTime : F[UTF8Decode(GetString(rpFieldDateFormatProp))]:=UTF8Decode(GetString(rpDateTimeFormat)); 290 rftString : F[UTF8Decode(GetString(rpFieldMaxLenProp))]:=UTF8Decode(IntToStr(P.DBField.Size)); 291 end; 292 end; 293end; 294 295class function TXMLOutputStreamer.GetContentType: String; 296begin 297 Result:='text/xml'; 298end; 299 300procedure TXMLOutputStreamer.CreateErrorContent(aCode: Integer; const aMessage: String); 301 302Var 303 ErrorObj : TDomElement; 304 305begin 306 ErrorObj:=FXML.CreateElement(UTF8Decode(GetString(rpErrorRoot))); 307 ErrorObj['code']:=UTF8Decode(IntToStr(aCode)); 308 ErrorObj['message']:=UTF8Decode(aMessage); 309 FRoot.AppendChild(ErrorObj); 310end; 311 312destructor TXMLOutputStreamer.Destroy; 313begin 314 FreeAndNil(FXML); 315 inherited Destroy; 316end; 317 318procedure TXMLOutputStreamer.InitStreaming; 319begin 320 FXML:=TXMLDocument.Create; 321 FRoot:=FXML.CreateElement('datapacket'); 322 FXML.AppendChild(FRoot); 323end; 324 325Initialization 326 TXMLInputStreamer.RegisterStreamer('xml'); 327 TXMLOutputStreamer.RegisterStreamer('xml'); 328end. 329 330