unit XmlUtils;

interface

uses
	MSXML, Variants, SysUtils;

const
	XmlVersionPI = '<?xml version="1.0"?>';

function XmlEncodeText(const s: String): String;
function XmlDecodeText(const s: String): String;
function XmlEncodeXSLPatternString(const s: String): String;

function XmlGetText(const aNode: IXMLDOMNode): String;
procedure XmlSetText(const aNode: IXMLDOMNode; const aText: String;
	anAsCDATA: Boolean = False);

function XmlNeedSubNode(const aNode: IXMLDOMNode; const aName: String): IXMLDOMNode;
function XmlNeedSubNodeText(const aNode: IXMLDOMNode; const aName: String): String;

function XmlHasAttr(const aNode: IXMLDOMNode; const aName: String): Boolean;
function XmlGetAttr(const aNode: IXMLDomNode; const aName: String;
	const aDefValue: String = ''): String;
procedure XmlSetAttr(const aNode: IXMLDOMNode; const aName, aValue: String);
function XmlNeedAttr(const aNode: IXMLDomNode; const aName: String): String;
function XmlNeedID(const aNode: IXMLDOMNode): String;

function XmlAddElement(const aParentNode: IXMLDOMNode;
	const aName: String; const aText: String = '';
	anAsCDATA: Boolean = False): IXMLDOMElement;
procedure XmlAddPI(const aDoc: IXMLDOMDocument; const aPI: String);
procedure XmlAddRussianPI(const aDoc: IXMLDOMDocument);
function XmlCreateDoc(const aRootName: String = ''): IXMLDOMDocument;
function XmlLoadHttp(const anURL: String; const aRequest: OleVariant): IXMLDOMDocument;
function XmlCallWebService(const anURL, aNamespace, anAction: String;
	const aRequest: OleVariant): IXMLDOMDocument;
function XmlLoadFile(const aFileName: String): IXMLDOMDocument;

function XmlGetPreferredAttr(const aNode: IXMLDOMNode; const aNames: array of String;
	const aDefValue: String = ''): String;
function XmlFindAttr(const aNode: IXMLDOMNode; const aName: String;
	out aValue: OleVariant): Boolean;

function XmlOleVariantToXmlDomDocument(const aData: OleVariant): IXMLDOMDocument;

function GenAttrXML(const aName, aValue: String): String;
function GenTextXML(const aText: String): String;
function GenCDATAXML(const aValue: String): String;

type
	TXmlWriterElem = record
		Name: String;
		Attrs: String;
		Content: String;
	end;

	TXmlWriter = class
	private
		FElem: TXmlWriterElem;
		FElemStack: array of TXmlWriterElem;
    function GetElemXml: String;
	public
		constructor Create(const aRootName: String);
		procedure OpenElem(const aName: String); overload;
		procedure OpenElem(const aName: String; const anAttrs: array of String); overload;
		procedure SetName(const aValue: String);
		procedure AddAttr(const aName, aValue: String);
		procedure AddAttrs(const anAttrs: array of String);
		procedure AddText(const aText: String);
		procedure AddCDATA(const aContent: String);
		procedure CloseElem;

		function GetXML: String;
	end;


implementation

uses
	StrUtils, ComUtils;

function XmlEncodeText(const s: String): String;
begin
	Result := StringReplace(s, '&', '&amp;', [rfReplaceAll]);
	Result := StringReplace(Result, '<', '&lt;', [rfReplaceAll]);
	Result := StringReplace(Result, '>', '&gt;', [rfReplaceAll]);
	Result := StringReplace(Result, '"', '&quot;', [rfReplaceAll]);
	Result := StringReplace(Result, '''', '&apos;', [rfReplaceAll]);
end;

function XmlDecodeText(const s: String): String;
begin
	Result := StringReplace(s, '&apos;', '''', [rfReplaceAll]);
	Result := StringReplace(Result, '&quot;', '"', [rfReplaceAll]);
	Result := StringReplace(Result, '&gt;', '>', [rfReplaceAll]);
	Result := StringReplace(Result, '&lt;', '<', [rfReplaceAll]);
	Result := StringReplace(Result, '&amp;', '&', [rfReplaceAll]);
end;

function XmlEncodeXSLPatternString(const s: String): String;
begin
	Result := StringReplace(s, '\', '\\', [rfReplaceAll]);
	Result := StringReplace(Result, '"', '\"', [rfReplaceAll]);
	Result := StringReplace(Result, '''', '\''', [rfReplaceAll]);
end;

function XmlGetText(const aNode: IXMLDOMNode): String;
var
	aNodes: IXMLDOMNodeList;
	i: Integer;
begin
	Result := '';
	aNodes := aNode.selectNodes('text()');
	for i := 0 to aNodes.length - 1 do
		Result := Result + aNodes[i].nodeValue;
	Result := StringReplace(Result, #13#10, #13, [rfReplaceAll]);
	Result := StringReplace(Result, #10, #13, [rfReplaceAll]);
	Result := StringReplace(Result, #13, #13#10, [rfReplaceAll]);
end;

procedure XmlAddCDATASection(const aNode: IXMLDOMNode; const aText: String);
var
	i: Integer;
begin
	i := Pos(']]>', aText);
	if i = 0 then
		aNode.appendChild(aNode.ownerDocument.createCDATASection(aText))
	else begin
		aNode.appendChild(aNode.ownerDocument.createCDATASection(LeftStr(aText, i)));
		XmlAddCDATASection(aNode, RightStr(aText, Length(aText) - i));
	end;
end;

procedure XmlSetText(const aNode: IXMLDOMNode; const aText: String;
	anAsCDATA: Boolean = False);
var
	aNodes: IXMLDOMNodeList;
	i: Integer;
begin
	aNodes := aNode.selectNodes('text()');
	for i := 0 to aNodes.length - 1 do
		aNode.removeChild(aNodes[i]);
	if aText <> '' then begin
		if anAsCDATA then
			XmlAddCDATASection(aNode, aText)
		else
			aNode.appendChild(aNode.ownerDocument.createTextNode(aText));
	end;
end;

function XmlNeedSubNode(const aNode: IXMLDOMNode; const aName: String): IXMLDOMNode;
begin
	Result := aNode.selectSingleNode(aName);
	if not Assigned(Result) then
		raise Exception.CreateFmt('В элементе "%s" не найден подэлемент "%s"',
			[aNode.nodeName, aName]);
end;

function XmlNeedSubNodeText(const aNode: IXMLDOMNode; const aName: String): String;
begin
	Result := XmlGetText(XmlNeedSubNode(aNode, aName));
end;

function XmlHasAttr(const aNode: IXMLDOMNode; const aName: String): Boolean;
begin
	Result := Assigned(aNode.attributes.getNamedItem(aName));
end;

function XmlGetAttr(const aNode: IXMLDomNode; const aName: String;
	const aDefValue: String = ''): String;
var
	anAttr: IXMLDOMNode;
begin
	anAttr := aNode.attributes.getNamedItem(aName);
	if Assigned(anAttr) then
		Result := VarToStr(anAttr.nodeValue)
	else
		Result := aDefValue;
end;

procedure XmlSetAttr(const aNode: IXMLDOMNode; const aName, aValue: String);
var
	anAttr: IXMLDOMAttribute;
begin
	anAttr := aNode.attributes.getNamedItem(aName) as IXMLDOMAttribute;
	if not Assigned(anAttr) then begin
		anAttr := aNode.ownerDocument.createAttribute(aName);
		aNode.attributes.setNamedItem(anAttr);
	end;
	anAttr.value := aValue;
end;

function XmlNeedAttr(const aNode: IXMLDomNode; const aName: String): String;
var
	anAttr: IXMLDOMNode;
begin
	anAttr := aNode.attributes.getNamedItem(aName);
	if not Assigned(anAttr) then
		raise Exception.CreateFmt('Не найден атрибут "%s" у элемента "%s"',
			[aName, aNode.nodeName]);
	Result := VarToStr(anAttr.nodeValue);
end;

function XmlNeedID(const aNode: IXMLDOMNode): String;
begin
	Result := XmlNeedAttr(aNode, 'id');
end;

function XmlAddElement(const aParentNode: IXMLDOMNode;
	const aName: String; const aText: String = '';
	anAsCDATA: Boolean = False): IXMLDOMElement;
var
	aDoc: IXMLDOMDocument;
begin
	aDoc := aParentNode.ownerDocument;
	Result := aDoc.createElement(aName);
	aParentNode.appendChild(Result);
	if aText <> '' then begin
		if anAsCDATA then
			XmlAddCDATASection(Result, aText)
		else
			Result.appendChild(aDoc.createTextNode(aText));
	end;
end;

procedure XmlAddPI(const aDoc: IXMLDOMDocument; const aPI: String);
var
	aFirstNode, aPINode: IXMLDOMNode;
begin
	aFirstNode := aDoc.firstChild;
	if Assigned(aFirstNode) and (aFirstNode.nodeType = NODE_PROCESSING_INSTRUCTION) and
			(aFirstNode.nodeName = 'xml') then
		aDoc.removeChild(aFirstNode);
	aPINode := aDoc.createProcessingInstruction('xml', aPI);
	aDoc.insertBefore(aPINode, aDoc.firstChild);
end;

procedure XmlAddRussianPI(const aDoc: IXMLDOMDocument);
begin
	XmlAddPI(aDoc, 'version="1.0" encoding="windows-1251"');
end;

function XmlCreateDoc(const aRootName: String = ''): IXMLDOMDocument;
var
	anElem: IXMLDOMElement;
begin
	Result := CoDOMDocument.Create;
	Result.async := False;
	XmlAddRussianPI(Result);
	if aRootName <> '' then begin
		anElem := Result.createElement(aRootName);
		Result.documentElement := anElem;
	end;
end;

function XmlLoadHttp(const anURL: String; const aRequest: OleVariant): IXMLDOMDocument;
var
	aXmlHttp: IXMLHttpRequest;
begin
	aXmlHttp := CoXMLHTTPRequest.Create;
	aXmlHttp.open('GET', anURL, False, Null, Null);
	aXmlHttp.send(aRequest);
	if aXmlHttp.Status = 200 then
		Result := aXmlHttp.responseXML as IXMLDOMDocument
	else
		raise Exception.CreateFmt('XmlLoadHttp(%s). Ошибка обращения к серверу: %s',
			[anURL, aXmlHttp.statusText]);
end;

function XmlCallWebService(const anURL, aNamespace, anAction: String;
	const aRequest: OleVariant): IXMLDOMDocument;
var
	aXmlHttp: IXMLHttpRequest;
	aRequestDoc, aResponseDoc: IXMLDOMDocument;
	aRequestXml: WideString;
	aQualifiedAction: String;
	aResultNode: IXMLDOMNode;
begin
	if VarIsArray(aRequest) or VarIsObject(aRequest) then begin
		aRequestDoc := CoDOMDocument.Create;
		aRequestDoc.async := False;
		aRequestDoc.Load(aRequest);
		if aRequestDoc.parseError.errorCode <> 0 then
			raise Exception.Create('Ошибка загрузки XML: ' + aRequestDoc.parseError.reason);
		aRequestXml := aRequestDoc.documentElement.xml;
	end
	else
		aRequestXml := aRequest;

	aRequestXml :=
		'<soap:Envelope ' +
			'xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" ' +
			'xmlns:xsd="http://www.w3.org/2001/XMLSchema" ' +
			'xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">' +
			'<soap:Body>' +
				'<' + anAction + ' xmlns="' + aNamespace + '">' +
					aRequestXml +
				'</' + anAction + '>' +
			'</soap:Body>' +
		'</soap:Envelope>';

	aQualifiedAction := aNamespace;
	if not AnsiEndsStr('/', aQualifiedAction) then
		aQualifiedAction := aQualifiedAction + '/';
	aQualifiedAction := aQualifiedAction + anAction;

	aXmlHttp := CoXMLHTTPRequest.Create;
	aXmlHttp.open('POST', anURL, False, Null, Null);
	aXmlHttp.setRequestHeader('SOAPAction', aQualifiedAction);
	aXmlHttp.setRequestHeader('Content-Type', 'text/xml; charset=utf-8');
	aXmlHttp.send(aRequestXml);

	if Assigned(aXmlHttp.responseXML) then begin
		aResponseDoc := aXmlHttp.responseXML as IXMLDOMDocument;
		if Assigned(aResponseDoc.documentElement) then begin
			aResultNode := aResponseDoc.selectSingleNode('soap:Envelope/soap:Body/soap:Fault');
			if Assigned(aResultNode) then
				raise Exception.Create(anURL + '/' + anAction + #13#10 +
					XmlNeedSubNodeText(aResultNode, 'faultstring'));
			aResultNode := aResponseDoc.selectSingleNode('soap:Envelope/soap:Body/' + anAction + 'Response');

			Result := CoDOMDocument.Create;
			Result.async := False;
			if Assigned(aResultNode) then
				Result.appendChild(aResultNode.cloneNode(True));
			exit;
		end;
	end;
	raise Exception.Create(anURL + '/' + anAction + #13#10 +
		aXmlHttp.statusText + #13#10#13#10'----------'#13#10 +
		aXmlHttp.responseText);
end;

function XmlLoadFile(const aFileName: String): IXMLDOMDocument;
begin
	Result := CoDOMDocument.Create;
	Result.async := False;
	Result.load(aFileName);
	if Result.parseError.errorCode <> 0 then
		raise Exception.CreateFmt('Ошибка открытия файла "' + aFileName + '": %s'^M^J^M^J'%s',
			[Result.parseError.reason, Result.parseError.srcText]);
end;

function XmlGetPreferredAttr(const aNode: IXMLDOMNode; const aNames: array of String;
	const aDefValue: String): String;
var
	i: Integer;
	anAttr: IXMLDOMNode;
begin
	for i := Low(aNames) to High(aNames) do begin
		anAttr := aNode.attributes.getNamedItem(aNames[i]);
		if Assigned(anAttr) then begin
			Result := VarToStr(anAttr.nodeValue);
			exit;
		end;
	end;
	Result := aDefValue;
end;

function XmlFindAttr(const aNode: IXMLDOMNode; const aName: String;
	out aValue: OleVariant): Boolean;
var
	anAttr: IXMLDOMNode;
begin
	anAttr := aNode.attributes.getNamedItem(aName);
	Result := Assigned(anAttr);
	if Result then
		aValue := anAttr.nodeValue;
end;

function XmlOleVariantToXmlDomDocument(const aData: OleVariant): IXMLDOMDocument;
begin
	case VarType(aData) of
		varUnknown:
			Result := IUnknown(TVarData(aData).VUnknown) as IXMLDOMDocument;
		varDispatch:
			Result := IDispatch(TVarData(aData).VDispatch) as IXMLDOMDocument;
		varOleStr,
		varString,
		varVariant:
			begin
				Result := CoDOMDocument.Create;
				Result.appendChild(Result.createProcessingInstruction('xml', 'version="1.0" encoding="windows-1251"'));
				Result.async := False;
				Result.loadXML(aData);
				if Result.parseError.errorCode <> 0 then
					raise Exception.CreateFmt('Ошибка разбора XML: %s'^M^J^M^J'%s',
						[Result.parseError.reason, Result.parseError.srcText]);
			end
		else
			raise Exception.Create('Некорректный тип данных');
	end;
end;

function GenAttrXML(const aName, aValue: String): String;
var
	i, j: Integer;
begin
	j := 0;
	for i := 1 to Length(aValue) do
		case aValue[i] of
			'<', '>': Inc(j, 4);
			'&': Inc(j, 5);
			'"': Inc(j, 6);
			else
				Inc(j);
		end;
	if j = Length(aValue) then
		Result := ' ' + aName + '="' + aValue + '"'
	else begin
		SetLength(Result, 1 + Length(aName) + 2 + j + 1);
		Result[1] := ' ';
		Move(PChar(aName)^, Result[2], Length(aName));
		j := 1 + Length(aName) + 3;
		Result[j - 2] := '=';
		Result[j - 1] := '"';
		for i := 1 to Length(aValue) do
			case aValue[i] of
				'<': begin Move(PChar('&lt;')^, Result[j], 4); Inc(j, 4) end;
				'>': begin Move(PChar('&gt;')^, Result[j], 4); Inc(j, 4) end;
				'&': begin Move(PChar('&amp;')^, Result[j], 5); Inc(j, 5) end;
				'"': begin Move(PChar('&quot;')^, Result[j], 6); Inc(j, 6) end;
				else begin Result[j] := aValue[i]; Inc(j) end;
			end;
		Result[j] := '"';
	end;
end;

function GenTextXML(const aText: String): String;
var
	i, j: Integer;
begin
	j := 0;
	for i := 1 to Length(aText) do
		case aText[i] of
			'<', '>': Inc(j, 4);
			'&': Inc(j, 5);
			'"': Inc(j, 6);
			else
				Inc(j);
		end;
	if j = Length(aText) then
		Result := aText
	else begin
		SetLength(Result, j);
		j := 1;
		for i := 1 to Length(aText) do
			case aText[i] of
				'<': begin Move(PChar('&lt;')^, Result[j], 4); Inc(j, 4) end;
				'>': begin Move(PChar('&gt;')^, Result[j], 4); Inc(j, 4) end;
				'&': begin Move(PChar('&amp;')^, Result[j], 5); Inc(j, 5) end;
				'"': begin Move(PChar('&quot;')^, Result[j], 6); Inc(j, 6) end;
				else begin Result[j] := aText[i]; Inc(j) end;
			end;
	end;
end;

function GenCDATAXML(const aValue: String): String;
var
	i: Integer;
begin
	i := Pos(']]>', aValue);
	if i = 0 then
		Result := '<![CDATA[' + aValue + ']]>'
	else
		Result := '<![CDATA[' + Copy(aValue, 1, i) + ']]>' + GenCDATAXML(Copy(aValue, i + 1, Length(aValue) - i - 1));
end;

{ TXmlWriter }

constructor TXmlWriter.Create(const aRootName: String);
begin
	inherited Create;
	FElem.Name := aRootName;
end;

procedure TXmlWriter.OpenElem(const aName: String;
	const anAttrs: array of String);
begin
	OpenElem(aName);
	AddAttrs(anAttrs);
end;

function TXmlWriter.GetElemXml: String;
var
	anIndent: String;
begin
	if FElem.Name = '' then
		Result := ''
	else begin
		SetLength(anIndent, Length(FElemStack)*2);
		if Length(FElemStack) > 0 then
			FillChar(anIndent[1], Length(anIndent), ' ');
		if FElem.Content = '' then
			Result := anIndent + '<' + FElem.Name + FElem.Attrs + '/>'^M^J
		else
			Result :=
				anIndent + '<' + FElem.Name + FElem.Attrs + '>'^M^J +
				FElem.Content +
				anIndent + '</' + FElem.Name + '>'^M^J;
	end;
end;

procedure TXmlWriter.OpenElem(const aName: String);
begin
	if FElem.Name <> '' then begin
		SetLength(FElemStack, Length(FElemStack) + 1);
		FElemStack[Length(FElemStack) - 1] := FElem;
	end;
	FElem.Name := aName;
	FElem.Attrs := '';
	FElem.Content := '';
end;

procedure TXmlWriter.AddAttr(const aName, aValue: String);
begin
	FElem.Attrs := FElem.Attrs + GenAttrXML(aName, aValue) 
end;

procedure TXmlWriter.AddAttrs(const anAttrs: array of String);
var
	i: Integer;
begin
	for i := 0 to Length(anAttrs) div 2 - 1 do
		AddAttr(anAttrs[i*2], anAttrs[i*2 + 1])
end;

procedure TXmlWriter.AddCDATA(const aContent: String);
begin
	FElem.Content := FElem.Content + GenCDATAXML(aContent);
end;

procedure TXmlWriter.AddText(const aText: String);
begin
	FElem.Content := FElem.Content + GenTextXML(aText);
end;

procedure TXmlWriter.CloseElem;
var
	aContent: String;
begin
	if Length(FElemStack) > 0 then begin
		aContent := GetElemXml;
		FElem := FElemStack[Length(FElemStack) -1];
		SetLength(FElemStack, Length(FElemStack) - 1);
		FElem.Content := FElem.Content + aContent;
	end;
end;

procedure TXmlWriter.SetName(const aValue: String);
begin
	FElem.Name := aValue
end;

function TXmlWriter.GetXML: String;
begin
	while Length(FElemStack) > 0 do
		CloseElem;
	Result := GetElemXml;
end;

end.

