Core/XMLValidate.pas - master - YakuninAV/Convertors

Core/XMLValidate.pas
384 строки15 KB
YakuninAV
begin with gitflick
31 июл 2026, 15:21
31 июл 2026, 15:211dc0fc6
/// Модуль содержащий процедуры проверки XML-текстов на соответствие схемам
unit XMLValidate;

{$I mormot.defines.inc}

// Requirements ----------------------------------------------------------------
//
// MSXML 6.0 Service Pack 1
// http://www.microsoft.com/downloads/release.asp?releaseid=37176
//
// -----------------------------------------------------------------------------

interface

uses
{$IFDEF ISDELPHIXE2}
  System.SysUtils, System.StrUtils, XMLIntf, XMLDom, XMLDoc, msxmldom, XMLSchema, MSXML2_TLB_60,
{$ELSE}
  SysUtils, StrUtils, XMLIntf, xmlDom, xmlDoc, {msxml,} msxmldom, XMLSchema, MSXML2_TLB_60,
{$ENDIF}
  mormot.core.base, mormot.core.buffers, mormot.core.unicode
  ;

type
  /// Исключение возникающее при обработке XML-строк
  EValidateXMLError = class(Exception)
  private
    FErrorCode: Integer;
    FReason: string;
  public
    /// Конструктор
    constructor Create(AErrorCode: Integer; const AReason: string);
    /// Код ошибки, возникшей при работе с XML-строкой
    property ErrorCode: Integer read FErrorCode;
    /// Описание причины ошибки, возникшей при работе с XML-строкой
    property Reason: string read FReason;
  end;

/// Функция возвращает схему (XSD)из ресурса программы
// ResID - идентификатор ресурса  
function SchemaFromResource(const ResID: string): WideString;

/// Процедура осуществляет валидацию XML-документа
// Doc: IDOMDocument - XML-документ, подлежащий валидации
// SchemaLocation - полное имя файла со схемой
// SchemaNS - пространство имён
procedure ValidateXMLDoc(const Doc: IDOMDocument; const SchemaLocation, SchemaNS: WideString); overload;
/// Процедура осуществляет валидацию XML-документа
// Doc: XMLIntf.IXMLDocument - XML-документ, подлежащий валидации
// SchemaLocation - полное имя файла со схемой
// SchemaNS - пространство имён
procedure ValidateXMLDoc(const Doc: XMLIntf.IXMLDocument; const SchemaLocation, SchemaNS: WideString); overload;
/// Процедура осуществляет валидацию XML-документа
// Doc: IDOMDocument - XML-документ, подлежащий валидации
// Schema: IXMLSchemaDoc - XML-документ, содержащий схему
procedure ValidateXMLDoc(const Doc: IDOMDocument; const Schema: IXMLSchemaDoc); overload;
/// Процедура осуществляет валидацию XML-документа
// Doc: XMLIntf.IXMLDocument - XML-документ, подлежащий валидации
// Schema: IXMLSchemaDoc - XML-документ, содержащий схему
procedure ValidateXMLDoc(const Doc: XMLIntf.IXMLDocument; const Schema: IXMLSchemaDoc); overload;

/// Процедура осуществляет валидацию XML-строки, используя объекты XMLDoc
// sXML - XML-строка, подлежащая проверке
// SchemaLocation - XML-строка со схемой
function ValidateXMLDoc(const sXML: string; const SchemaLocation: String): string; overload;
{$IFDEF ISDELPHIXE2}
/// Процедура осуществляет валидацию XML-строки, используя MSXML6   // не использует SchemaLocation
// sXML - XML-строка, подлежащая проверке
// SchemaLocation - XML-строка со схемой
function ValidateMSXML6(const sXML: string; const SchemaLocation: String): string;
{$ENDIF}

function ValidateXMLString(const sXML, sSchema: WideString): string; overload;
function ValidateXMLString(const Doc: XMLIntf.IXMLDocument; const sSchema: WideString): string; overload;

/// Функция выполняет трансформацию XML-текста в соответствии с заданным XLST
function TransformXML(const XMLFile, StyleSheet: TFileName; out ResultStr: string): Boolean;

function ValidateXML(const XMLFile, SchemaFile: TFileName): string;

implementation

uses
  Windows, ComObj;

resourcestring
  RsValidateError = 'Validate XML Error (%.8x), Reason: %s';

function SchemaFromResource(const ResID: string): WideString;
var r: RawByteString;
begin
  ResourceToRawByteString(ResID, RT_RCDATA, r);
  Result := Utf8ToWideString(r);
end;

{ EValidateXMLError }

constructor EValidateXMLError.Create(AErrorCode: Integer; const AReason: string);
begin
  inherited CreateResFmt(@RsValidateError, [AErrorCode, AReason]);
  FErrorCode := AErrorCode;
  FReason := AReason;
end;

{ Utility routines }

function DOMToMSDom(const Doc: IDOMDocument): IXMLDOMDocument2;
begin
  Result := ((Doc as IXMLDOMNodeRef).GetXMLDOMNode as IXMLDOMDocument2);
end;
function LoadMSDom(const FileName: WideString): IXMLDOMDocument2;
begin
  Result := CoDOMDocument60.Create;
  Result.async := False;
  Result.resolveExternals := True; //False;
  Result.validateOnParse := True;
  Result.load(FileName);
end;

{$IFDEF ISDELPHIXE2}
 function ValidateMSXML6(const sXML: string; const SchemaLocation: String): string;
var XMLDoc: IXMLDOMDocument3; XMLParserError: IXMLDOMParseError;
begin
  XMLDoc:=CoDOMDocument60.Create;
  try
  XMLDoc.async:=False;
  XMLDoc.resolveExternals:=True;
  XMLDoc.validateOnParse:=False;
  if XMLDoc.LoadXML(sXML) then begin
    XMLParserError:=XMLDoc.validate;
    if XMLParserError.errorCode = 0 then Result:=''
    else Result := Format('Ошибка при валидации <Причина: %s; Текст: %s; Код: %d>',
                                          [XMLParserError.reason, XMLParserError.srcText, XMLParserError.errorCode]);
  end else Result:= 'Не удалось загрузить XML';
  except
    on E:Exception do begin
      Result := E.Message;
    end;
  end;
end;

procedure InternalValidateXMLDoc(const Doc: IDOMDocument; const SchemaDoc: IXMLDOMDocument2; const SchemaNS: WideString);
var
  MsxmlDoc: IXMLDOMDocument2;
  SchemaCache: IXMLDOMSchemaCollection;
  Error: IXMLDOMParseError;
begin
  MsxmlDoc := DOMToMSDom(Doc);
{$IFDEF ISDELPHIXE2}
  SchemaCache := CoXMLSchemaCache60.Create;
{$ELSE}
  SchemaCache := CoXMLSchemaCache.Create;
{$ENDIF}
  SchemaCache.add(SchemaNS, SchemaDoc);
  MsxmlDoc.schemas := SchemaCache;
  Error := MsxmlDoc.validate;
  if Error.errorCode <> S_OK then
    raise EValidateXMLError.Create(Error.errorCode, Error.reason);
end;

function ValidateXMLDoc(const sXML: string; const SchemaLocation: string): string; overload;
var
  vXMLParserError: IXMLDOMParseError;
  vXMLDoc: IXMLDOMDocument3;
  vXMLSchema: IXMLDOMSchemaCollection2;
  vXMLSchemaDoc: IXMLDOMDocument3;
begin
  if SchemaLocation<>'' then begin
    vXMLSchema := CoXMLSchemaCache60.Create();
    vXMLSchemaDoc := CoDOMDocument60.Create();
    vXMLSchemaDoc.Load(SchemaLocation);
    if vXMLSchemaDoc.parseError.errorCode <> 0 then begin
      Result := System.SysUtils.Format('Ошибка при загрузке схемы <%s: %s>',
                                       [vXMLSchemaDoc.parseError.reason, vXMLSchemaDoc.parseError.srcText]);
      Exit;
    end;
    vXMLSchema.add('', vXMLSchemaDoc);
  end;
  vXMLDoc := CoDOMDocument60.Create();
  vXMLDoc.async := False;
  vXMLDoc.resolveExternals := true;
  vXMLDoc.validateOnParse := false;
  vXMLDoc.LoadXML(sXML);
  if vXMLSchema<>nil then vXMLDoc.schemas := vXMLSchema;
  vXMLParserError := vXMLDoc.validate;
  if vXMLParserError.errorCode = 0 then Result:=''
  else Result := System.SysUtils.Format('Ошибка при валидации <Причина: %s; Текст: %s; Код: %d>',
                                        [vXMLParserError.reason, vXMLParserError.srcText, vXMLParserError.errorCode]);
end;

{$ELSE}

procedure InternalValidateXMLDoc(const Doc: IDOMDocument; const SchemaDoc: IXMLDOMDocument2; const SchemaNS: WideString);
var
  MsxmlDoc: IXMLDOMDocument2;
//  SchemaCache: IXMLDOMSchemaCollection;
  Error: IXMLDOMParseError;
begin
  MsxmlDoc := DOMToMSDom(Doc);
//  SchemaCache := CoXMLSchemaCache.Create;
//  SchemaCache.add(SchemaNS, SchemaDoc);
//  MsxmlDoc.schemas := SchemaCache;
  MsxmlDoc.schemas := SchemaNS;
  Error := MsxmlDoc.validate;
  if Error.errorCode <> S_OK then
    raise EValidateXMLError.Create(Error.errorCode, Error.reason);
end;

function ValidateXMLDoc(const sXML: string; const SchemaLocation: String): string; overload;
var
  vXMLParserError: IXMLDOMParseError;
  vXMLSchema: IXMLDOMSchemaCollection2;
  vXMLDoc: IXMLDOMDocument2;
  vXMLSchemaDoc: IXMLDOMDocument2;
begin
  if SchemaLocation<>'' then begin
    vXMLSchema := CoXMLSchemaCache60.Create();
    vXMLSchemaDoc := CoDOMDocument60.Create();
    vXMLSchemaDoc.LoadXML(SchemaLocation);
    if vXMLSchemaDoc.parseError.errorCode <> 0 then begin
      Result :=SysUtils.Format('Ошибка при загрузке схемы <%s: %s>',
                                       [vXMLSchemaDoc.parseError.reason, vXMLSchemaDoc.parseError.srcText]);
      Exit;
    end;
    vXMLSchema.add('', vXMLSchemaDoc);
  end;
  vXMLDoc := CoDOMDocument60.Create();
  vXMLDoc.async := False;
  vXMLDoc.resolveExternals := true;
  vXMLDoc.validateOnParse := false;
  vXMLDoc.LoadXML(sXML);
  if vXMLSchema<>nil then vXMLDoc.schemas := vXMLSchema;
  vXMLParserError := vXMLDoc.validate;
  if vXMLParserError.errorCode = 0 then Result:=''
    else Result := SysUtils.Format('Ошибка при валидации <Причина: %s; Текст: %s; Код: %d>',
                                          [vXMLParserError.reason, vXMLParserError.srcText, vXMLParserError.errorCode]);
end;

{$ENDIF}

{ Validate }

procedure ValidateXMLDoc(const Doc: IDOMDocument; const SchemaLocation, SchemaNS: WideString);
begin
  InternalValidateXMLDoc(Doc, LoadMSDom(SchemaLocation), SchemaNS);
end;

procedure ValidateXMLDoc(const Doc: XMLIntf.IXMLDocument; const SchemaLocation, SchemaNS: WideString);
begin
  InternalValidateXMLDoc(Doc.DOMDocument, LoadMSDom(SchemaLocation), SchemaNS);
end;

procedure ValidateXMLDoc(const Doc: IDOMDocument; const Schema: IXMLSchemaDoc);
begin
  InternalValidateXMLDoc(Doc, DOMToMSDom(Schema.DOMDocument), '');
end;

procedure ValidateXMLDoc(const Doc: XMLIntf.IXMLDocument; const Schema: IXMLSchemaDoc);
begin
  InternalValidateXMLDoc(Doc.DOMDocument, DOMToMSDom(Schema.DOMDocument), '');
end;

function ValidateXMLString(const sXML, sSchema: WideString): string; overload;
var
  vXMLParserError: IXMLDOMParseError;
  vXMLSchema: IXMLDOMSchemaCollection2;
  vXMLDoc: IXMLDOMDocument3;
  vXMLSchemaDoc: IXMLDOMDocument3;
begin
  vXMLSchema := CoXMLSchemaCache60.Create();
  vXMLSchemaDoc := CoDOMDocument60.Create();
  try
    vXMLSchemaDoc.LoadXML(sSchema);
    if vXMLSchemaDoc.parseError.errorCode <> 0 then begin
      Result := Format('Ошибка при загрузке схемы <%s: %s>',
                      [vXMLSchemaDoc.parseError.reason, vXMLSchemaDoc.parseError.srcText]);
      Exit;
    end;
    vXMLSchema.add('', vXMLSchemaDoc);
    vXMLDoc := CoDOMDocument60.Create();
    vXMLDoc.async := False;
    vXMLDoc.resolveExternals := false;
    vXMLDoc.validateOnParse := false;
    vXMLDoc.loadXML(sXML);
    if vXMLSchema<>nil then vXMLDoc.schemas := vXMLSchema;
    vXMLParserError := vXMLDoc.validate;
    if vXMLParserError.errorCode = 0 then Result:=''
    else Result := Format('Ошибка при валидации <Причина: %s; Текст: %s; Код: %d>',
                          [vXMLParserError.reason, vXMLParserError.srcText, vXMLParserError.errorCode]);
  except
    on E: EDOMParseError    do Result:=E.Message;
    on E: EValidateXMLError do Result:=E.Reason;
    on E: EXMLDocError      do Result:=E.Message;
    on E: Exception         do Result:=E.Message;
  end;
end;

function ValidateXMLString(const Doc: XMLIntf.IXMLDocument; const sSchema: WideString): string; overload;
var
  vXMLParserError: IXMLDOMParseError;
  vXMLSchema: IXMLDOMSchemaCollection2;
  vXMLDoc: IXMLDOMDocument3;
  vXMLSchemaDoc: IXMLDOMDocument3;
  w,x: wideString;
begin
  vXMLSchema := CoXMLSchemaCache60.Create();
  vXMLSchemaDoc := CoDOMDocument60.Create();
  try
    vXMLSchemaDoc.LoadXML(sSchema);
    if vXMLSchemaDoc.parseError.errorCode <> 0 then begin
      Result := Format('Ошибка при загрузке схемы <%s: %s>',
                      [vXMLSchemaDoc.parseError.reason, vXMLSchemaDoc.parseError.srcText]);
      Exit;
    end;
    vXMLSchema.add('', vXMLSchemaDoc);
    vXMLDoc := CoDOMDocument60.Create();
    vXMLDoc.async := False;
    vXMLDoc.resolveExternals := false;
    vXMLDoc.validateOnParse := false;
    Doc.SaveToXML(x); vXMLDoc.loadXML(x);
    if vXMLSchema<>nil then vXMLDoc.schemas := vXMLSchema;
    vXMLParserError := vXMLDoc.validate;
    if vXMLParserError.errorCode = 0 then Result:=''
    else Result := Format('Ошибка при валидации <Причина: %s; Текст: %s; Код: %d>',
                          [vXMLParserError.reason, vXMLParserError.srcText, vXMLParserError.errorCode]);
  except
    on E: EDOMParseError    do Result:=E.Message;
    on E: EValidateXMLError do Result:=E.Reason;
    on E: EXMLDocError      do Result:=E.Message;
    on E: Exception         do Result:=E.Message;
  end;
end;

function TransformXML(const XMLFile, StyleSheet: TFileName; out ResultStr: string): Boolean;
var XMLDoc, XMLStyle: TXMLDocument; {$IFDEF ISDELPHIXE2} S: XmlDomString; {$ELSE} S: WideString; {$ENDIF}
begin
  S:='';
  if (XMLFile='') or (not FileExists(XMLFile)) then Result := False
  else if (StyleSheet='') or (not FileExists(StyleSheet)) then Result := False
  else begin
    XMLDoc:= TXMLDocument.Create(nil);
    XMLStyle:= TXMLDocument.Create(nil);
    try
      try
        XMLDoc.LoadFromFile(XMLFile);
        XMLDoc.Active:= True;
        XMLStyle.LoadFromFile(StyleSheet);
        XMLStyle.Active:= True;
        XMLDoc.Node.TransformNode(xmlStyle.Node,S);
        ResultStr:=S;
        Result:=(ResultStr<>'');
      except
        on E: Exception do begin
          ResultStr:= 'Исключение: (' + IntToStr(E.HelpContext) + ') ' + E.Message;
          Result:=False;
        end;
      end;
    finally
      XMLDoc.Free; XMLStyle.Free;
    end;
  end;
end;

function ValidateXML(const XMLFile, SchemaFile: TFileName): string;
var XMLDoc: TXMLDocument;
begin
  if (XMLFile='') or (not FileExists(XMLFile)) then Result := 'файл: "' + XMLFile + '" не найден'
  else begin
    XMLDoc:= TXMLDocument.Create(nil);
    try
      XMLDoc.ParseOptions:= [poResolveExternals, poValidateOnParse];
      XMLDoc.LoadFromFile(XMLFile);
      XMLDoc.Active:= True;
     if XMLDoc.Active then Result:=''
                      else Result:='При анализе файла обнаружены ошибки';
    except
      on E:EDOMParseError do begin
        Result:=E.Message;
      end;
    end;
  end;
end;

end.