Core/DBDCommons.pas - master - YakuninAV/Convertors

Core/DBDCommons.pas
765 строк26 KB
YakuninAV
begin with gitflick
31 июл 2026, 15:21
31 июл 2026, 15:211dc0fc6
unit DBDCommons;

{$I mormot.defines.inc}

interface

uses
{$IFDEF ISDELPHIXE2}
   System.SysUtils, System.Classes, System.Variants, System.IOUtils, System.Masks, System.Types, System.Math,
{$ELSE}
   {$IFDEF FPC}
   SysUtils, Classes, Variants, FPMasks, Types, Math,
   {$ELSE}
   SysUtils, Classes, Variants, Masks, Types, Math,
   {$ENDIF}
{$ENDIF}
{$IFDEF MORMOT_V1_18}
  SynCommons, SynZip,
{$ELSE}
  mormot.core.base, mormot.core.os, mormot.core.unicode, mormot.core.zip, mormot.core.variants, mormot.core.data,
  mormot.core.buffers, mormot.core.text,
{$ENDIF}
// DBDStrUtils,
 DBDWindows;

const
  /// максимальная точность представления вещественного числа двойной точности
  DBD_DOUBLE_PRECISION=15;
  /// точность представления цен в сметах
  DBD_PRICE_PREC = 2;
  /// точность представления вещественных значений в сметах
  DBD_VALUE_PREC = 7;
  /// точность представления значений коэффициентов в сметах
  DBD_COEFFS_PREC = 7;
  DBD_COEFFS_PREC_FINAL = 7;
  /// максимальная точность представления значений объёмов в сметах
  DBD_QUANTITY_PREC = 14;

  DBD_MONTH_NAMES: array[1..12] of string = ('январь','февраль','март','апрель','май','июнь',
                                             'июль','август','сентябрь','октябрь','ноябрь','декабрь');
var
  ///
  DBDBackupFilesCount: Byte = 10;
  /// Установки форматов
  DBDFormatSettings: TFormatSettings;
  /// точность вывода финального коэффициента
  DBDFinalCoeffPrec: Integer = DBD_COEFFS_PREC_FINAL;

type
{$IFDEF ISDELPHIXE2}
  String1251 = type AnsiString(1251);
{$ELSE}
  String1251 = type AnsiString;
{$ENDIF}

  TExtendedDynArray = array of Extended;

  TStringArray = array[0..MaxLongint div 8-1] of String1251;
  PStringArray = ^TStringArray;

type

  /// Части строки
  // ! dbdSPLeft  - левая
  // ! dbdSPRight - правая
  // ! dbdSPBoth  - обе
  TDBDStringPart = (dbdSPLeft, dbdSPRight, dbdSPBoth);

  /// Правила склеивания строк
  //  dbdSGPNoSpace      - удалить пробелы
  //  dbdSGPRemoveHipen  - удалить символ переноса строки
  //  dbdSPGDefault      - по умолчанию
  TDBDStringGlueProp = (dbdSGPNoSpace, dbdSGPRemoveHipen, dbdSPGDefault);

  /// Событие возникающее при обработке файла
  // Sender   - Объект возбудивший событие
  // FileName - Имя обработанного файла
  // Error    - Признак ошибки при обработке файла
  // Data     - JSON-документ, полученный при обработке файла
  TDBDOnFileEvent = procedure (Sender: TObject; const FileName: string; const Error: Boolean; const Data: Variant) of object;

  /// Обработчик управляющих сообщений
  // Sender     - Объект возбудивший событие
  // msgCommand - управляющая команда
  // msgData    - данные передоваемые с командой
  // msgResult  - результат выполнения команды
  TDBDCommandEvent = procedure(Sender: TObject; const msgCommand: Integer; const msgData: Variant; out msgResult: Variant) of object;

  /// Опции сохранения файла
  //  fsoCreateNewIfExists - создать новый файл, если старый существует
  //  fsoBackupOldFile     - создать копию старого файла прежде чем переписать его
  //  fsoRemoveExists      - удалить существующий файл
  TDBDFileSaveOption = (fsoCreateNewIfExists, fsoBackupOldFile, fsoRemoveExists);
  TDBDFileSaveOptions = set of TDBDFileSaveOption;

  /// Запись для представления даты объявления цены имеет вид MM/YY[YY]
  TDBDPriceDate = record
  private
    FPriceDate: Integer;
    function GetPriceDate: Integer;
    function GetMonth: Word;
    function GetQuarter: Word;
    function GetYear: Word;
    procedure SetPriceDate(const Value: Integer);
    procedure SetMonth(const Value: Word);
    procedure SetQuarter(const Value: Word);
    procedure SetYear(const Value: Word);
    function GetDate: TDateTime;
    procedure SetDate(const Value: TDateTime);
  public
    /// Ценовая дата
    property PriceDate: Integer read GetPriceDate write SetPriceDate;
    /// Дата
    property Date: TDateTime read GetDate write SetDate;
    /// Год, к которому относится ценовая дата
    property Year: Word read GetYear write SetYear;
    /// Месяц, к которому относится ценовая дата
    property Month: Word read GetMonth write SetMonth;
    /// Квартал, к которому относится ценовая дата
    property Quarter: Word read GetQuarter write SetQuarter;
    /// Конструктор создаёт ценовую дату из календарной
    constructor Create(const aDate: TDateTime);
    /// Конструктор создаёт ценовую дату из года и месяца
    constructor CreateMonth(const aYear, aMonth: Word);
    /// Конструктор создаёт ценовую дату из года и номера квартала
    constructor CreateQuarter(const aYear, aQuorter: Word);
    /// Функция преобразует календарную дату в ценовую
    class function PriceDateFromDateTime(const dt: TDateTime): Integer; static;
    /// Функция преобразует сроку вида MM/YY[YY] в число
    class function PriceDateFromStr(const dt: string): Integer; static;
    /// Функция преобразует число в сроку вида MM/YY[YY]
    class function PriceDateToStr(const dt: Integer; const TwoDigsYear: Boolean=True): string; static;
    /// Функция выделяет из чила номер месяца
    class function MonthFromPriceDate(const dt: Integer): Integer; static; inline;
    /// Функция выделяет из чила год
    class function YearFromPriceDate(const dt: Integer): Integer; static; inline;
  end;

  TDBDZipper = class(TObject)
  private
    Reader: TZipRead;
    Writer: TZipWrite;
    FZipName: TFileName;
    FNames: TStringDynArray;
    procedure SetNames(const Value: TStringDynArray);
  public
    /// Имя файла архива
    property ZipName: TFileName read FZipName;
    /// массив имён файлов в архиве
    property Names: TStringDynArray read FNames write SetNames;
    /// Конструктор
    constructor Create(const zName: TFileName; const fName: TFileName);
    /// Деструктор, освобождает распределённые ресурсы
    destructor Destroy; override;
    /// функция извлекает файл на диск
    function ExtractFile(const fName: TFilename; const Dest: TFileName=''): Boolean;
    /// функция копирует файл из архива в поток
    function ReadFile(const fName: TFileName; Stream: TStream): Boolean;
    function AddFile(const fName: TFileName; const ForceAdd: Boolean=False): Boolean;
    /// Функция добавляет файл в архив, если файл с таким именем есть, то он заменяется
    function AddOrReplace(const fName: TFileName): Boolean;
    /// Функция удаляет файл с указанным именем из архива
    function Remove(const fName: TFileName): Boolean;
    /// Функция возвращает список имен файлов в архиве
    function GetNamesCSV: string;
  end;

type
  /// Опции формирования XML-текста
  // dbdxmlEachElemOnNewLine - каждый элемент на новой строке
  // dbdxmlEachTagOnNewLine  - каждый таг на новой строке
  // dbdxmlNodeAutoIndent    - формировать текст с отступами (используется для DOM)
  // dbdxmlDustSTring        - опищать строку от "грязи" (используется dbdUtf8Utils.dbdTextNormalization(Text, dbdTNODust);
  TDBDXMLWriterOption = (dbdxmlEachElemOnNewLine, dbdxmlEachTagOnNewLine, dbdxmlNodeAutoIndent, dbdxmlDustSTring);
  /// Набор опций формирования XML-текста
  TDBDXMLWriterOptions = set of TDBDXMLWriterOption;

const
  XML_HEADER_UTF8 = '<?xml version="1.0" encoding="UTF-8"?>';
  XML_HEADER_1251 = '<?xml version="1.0" encoding="windows-1251"?>';
  XML_NAMESPACE: RawUTF8 = 'http://www.w3.org/2001/XMLSchema-instance';
  XML_NAMESPACE_SCHEME_SLOCATION: RawUTF8 = ' xsi:noNamespaceSchemaLocation="';
  cLT: AnsiChar='<'; cGT: AnsiChar='>'; cSL: AnsiChar = '/'; cSP: AnsiChar = ' '; cDQ: AnsiChar='"'; cTab:AnsiChar=#9;

var
  XML_HEADER: RawUtf8;

function TextFromResourceS(const ResID: string): string;
function TextFromResourceU(const ResID: string): RawUtf8;
function TextFromResourceW(const ResID: string): WideString;

/// Функция копирует файл
function DBDFileCopy(const SrcName, DstName: TFileName; const Options: TDBDFileSaveOptions = []): Boolean;
{$IFNDEF MORMOT_V1_18}
///Функция составляет иерархический список содержимого папки
// в список включаются все папки, а также файлы, соответствующие заданной маске
// Составлееный список возвращается в виде JSON-документа:
// folder   - Имя исследуемого каталога (Dirname)
// mask   - маска отбираемых файлов (Mask)
// contents - содержимое папки. Включает в себя
//      dir[] - массив подкаталогов (рекурсия)
//           nam - имя подкаталога
//           dir - массив подкаталов (рекурсия), входящих в nam
//           fil - массив отобранных файлов в подкаталоге
//      fil[] - массив отобранных файлов в каталоге
// TODO: опции просмотра каталогов
//      -без рекурсии
//      -только папки
//      -раздельные маски для папок и файлов
//      -глубина рекурсии
//      -множественные маски
//              предположительно запись с набором полей
function DBDGetFolderTree(const DirName: string; out DirTree: Variant; const Mask: string='*'; const fullpath: Boolean=False): Boolean;
/// Функция сохраняет заданный ресурс в файл и, в случае успеха, возвращает true
// Если существует файл с именем FileName и время его модификации старше времени компиляции программы, то
// существующий файл удаляется, если нет, то функция оставляет существующий файл, возвращая True
function ResourceToFile(const ResName, ResType: string; const FileName: TFileName;
                        const DeleteIfExists: Boolean = False): Boolean;
{$ENDIF}

/// Функция формирует строковое представление вещественного числа с заданной точностью
//function DBDDoubleToString(const D: Double; const Prec: Integer): string;
function DBDRoundTo(const D: Double; const Prec: Integer): Double;
function DBDRoundToDbl(const D: Double; const Prec: Integer): Double;
/// округление до двух знаков
function DBDRoundToCur(const D: Double): Currency;
/// Фунция возвращает true, если с объектом можно работать (взамен Assigned для использования в новых компиляторах)
function ValidObject(const AObj: TObject): Boolean;

function RawUtf82DynArray(const R: RawUtf8): TRawUtf8DynArray;

{begin from ComUnit.pas}
function StringsBufToVar(const Buffer; Count: integer): Variant;
function VarToStringsBuf(SourceVar: Variant; var Buffer): integer;
{end from ComUnit.pas}

/// Функция возвращает True, если заданный путь полным (от корня диска)
function IsFullPath(const Path: TFileName): Boolean; inline;

{$ifdef DELPHI}
/// Циклический сдвиг влево Int64
//function _rol(const Target: int64; Shift: Longword): int64; Overload; Register;
/// Циклический сдвиг влево LongInt
function _rol(Target: LongInt; Shift: Byte): LongInt; Overload; Register;
/// Циклический сдвиг влево Word
function _rol(Target: Word; Shift: Byte): Word; Overload; Register;
/// Циклический сдвиг влево Byte
function _rol(Target, Shift: Byte): Byte; Overload; Register;
/// циклический сдвиг вправо Int64
//function _ror(const Target: int64; Shift: Longword): int64; Overload; Register;
/// циклический сдвиг вправо LongInt
function _ror(Target: LongInt; Shift: Byte): LongInt; Overload; Register;
/// циклический сдвиг вправо Word
function _ror(Target: Word; Shift: Byte): Word; Overload; Register;
/// циклический сдвиг вправо Byte
function _ror(Target, Shift: Byte): Byte; Overload; Register;
{$endif}

implementation

function IsFullPath(const Path: TFileName): Boolean;
begin
  if Length(Path)<3 then Result:=False
  else begin
    Result := (Path[2]=':')
           or ((Path[1]='\') and (Path[2]='\'))
           or ((Path[1]='/') and (Path[2]='/'))
           ;
  end;
end;

function RawUtf82DynArray(const R: RawUtf8): TRawUtf8DynArray;
begin
  CsvToRawUtf8DynArray(@R[1],Result,';',True)
end;

{$ifdef DELPHI}
{
function _rol(const Target: int64; Shift: Longword): int64; Overload; Register;
asm
  MOV   ECX, EAX
  MOV   EAX, [ESP+$08]
  MOV   EDX, [ESP+$0C]
  PUSH  EBX
  XOR   EBX, EBX
  AND   CL, $3F       // shift mod 64
  CMP   CL, $20       // if shift less 32 goto
  JL    @_rol@below32
  MOV   EBX, EDX      // swap EDX, EAX = shift to 32
  MOV   EDX, EAX
  MOV   EAX, EBX
  AND   CL, $1F       // shift mod 32
@_rol@below32:
  MOV   EBX, EDX      // i'm idiot
  SHLD  EDX, EAX, CL  // work
  SHLD  EAX, EBX, CL
  POP   EBX
  // RET
end;
}

function _rol(Target: LongInt; Shift: Byte): LongInt; Overload; Register;
asm
  mov cl, dl;
  rol eax, cl;
end;

function _rol(Target: Word; Shift: Byte): Word; Overload; Register;
asm
  mov cl, dl;
  rol ax, cl;
end;

function _rol(Target, Shift: Byte): Byte; Overload; Register;
asm
  mov cl, dl;
  rol al, cl;
end;
{
function _ror(const Target: int64; Shift: Longword): int64; Overload; Register;
asm
  MOV   ECX, EAX
  MOV   EAX, [ESP+$08]
  MOV   EDX, [ESP+$0C]
  PUSH  EBX
  XOR   EBX, EBX
  AND   CL, $3F       // shift mod 64
  CMP   CL, $20       // if shift less 32 goto
  JL    @_ror@below32
  MOV   EBX, EDX      // swap EDX, EAX = shift to 32
  MOV   EDX, EAX
  MOV   EAX, EBX
  AND   CL, $1F       // shift mod 32
@_ror@below32:
  MOV   EBX, EAX      // i'm idiot
  SHRD  EAX, EDX, CL  // work
  SHRD  EDX, EBX, CL
  POP   EBX
  // RET
end;
}
function _ror(Target: LongInt; Shift: Byte): LongInt; Overload; Register;
asm
  mov cl, dl;
  ror eax, cl;
end;

function _ror(Target: Word; Shift: Byte): Word; Overload; Register;
asm
  mov cl, dl;
  ror ax, cl;
end;

function _ror(Target, Shift: Byte): Byte; Overload; Register;
asm
  mov cl, dl;
  ror al, cl;
end;
{$endif}

function TextFromResourceS(const ResID: string): string;
var r: RawByteString;
begin
  ResourceToRawByteString(ResID, RT_RCDATA, r);
  Result:=Utf8ToString(r);
end;
function TextFromResourceU(const ResID: string): RawUtf8;
var r: RawByteString;
begin
  ResourceToRawByteString(ResID, RT_RCDATA, r);
  Result:=r;
end;
function TextFromResourceW(const ResID: string): WideString;
var r: RawByteString;
begin
  ResourceToRawByteString(ResID, RT_RCDATA, r);
  Result := Utf8ToWideString(r);
end;

function DBDFileCopy(const SrcName, DstName: TFileName; const Options: TDBDFileSaveOptions = []): Boolean;
var f: Boolean; fn: TFileName;
begin
  Assert((SrcName<>'') or (DstName<>''), 'Имя файла должно быть задано');
  Result := FileExists(SrcName); if not Result then Exit;
  if ExtractFileName(DstName)=DstName then fn := IncludeTrailingPathDelimiter(ExtractFilePath(SrcName)) + DstName
                                      else fn := DstName;

  f := FileExists(fn);
  if f and (fsoCreateNewIfExists in Options) then begin

  end else if f and (fsoBackupOldFile in Options) then begin

  end else if f and (fsoRemoveExists in Options) then begin
    Result := DeleteFile(fn); if not Result then Exit;
  end;

  try
    Result := CopyFile(SrcName, fn, False);
  except on E: Exception do
    Result := False;
  end;
end;

function DBDRoundTo(const D: Double; const Prec: Integer): Double;
begin
  if D=0.0 then Result:=0.0
  else Result:=RoundTo(D+POW10[Prec-4],Prec);
end;
function DBDRoundToDbl(const D: Double; const Prec: Integer): Double;
begin
  if D=0.0 then Result:=0.0
  else begin
     Result:=RoundTo(D+POW10[Prec-4],Prec);
  end;
end;
function DBDRoundToCur(const D: Double): Currency;
begin
  Result:=DBDRoundToDbl(D,-2);
//  Result:=Round(D*100.0)/100.;
end;

{$IFNDEF MORMOT_V1_18}
function DBDGetFolderTree(const DirName: string; out DirTree: Variant; const Mask: string='*'; const fullpath: Boolean=False): Boolean;
var sa: Integer;
  function BuildTree(const PrntName, DirName: string; out DirDoc: Variant): Boolean;
  var da, fa: Variant; pda,pfa: PDocVariantData; d,v: Variant; fn: string; sr: TSearchRec; PDoc: PDocVariantData; ds: string;
     arrFNames: TRawUTF8DynArray; DynArr: TDynArray; r: RawUTF8;
  begin
    ds:= IncludeTrailingBackslash(PrntName) + DirName;
    if DirName='' then DirDoc:=_Obj([])
    else if fullpath then DirDoc:=_Obj(['nam', StringToUTF8(ds)])
    else DirDoc:=_Obj(['nam', StringToUTF8(DirName)]);
    PDoc:=_Safe(DirDoc);
    fa:=_Arr([]); pfa:=_Safe(fa); da:=_Arr([]); pda:=_Safe(da); v:=_Obj([]);
    try
      SetLength(arrFNames,0);
      DynArr.Init(TypeInfo(TRawUTF8DynArray),arrFNames, nil);
      if FindFirst(IncludeTrailingBackslash(ds)+'*', sa, sr)=0 then
        repeat
          fn:=sr.Name;
          if (fn<>'.') and (fn<>'..') then begin
            if ((sr.Attr and faDirectory)=faDirectory) then begin
              if BuildTree(ds, fn, d) and (_Safe(d).Count>0) then begin
                pda.AddItem(d); TDocVariantData(d).Clear
              end
            end else if MatchesMask(fn, Mask) then begin
              r:=StringToUTF8(fn);
              DynArr.Add(r);
            end;
          end;
      until FindNext(sr)<>0;
      Result:=True;
    except
      Result:=False;
      _Safe(v).Clear; _Safe(d).Clear;
    end;
    FindClose(sr);
    if Length(arrFNames)>0 then pfa^.InitArrayFrom(arrFNames,[]);
    if pda^.Count>0 then PDoc^.AddValue('dir', da);
    if pfa^.Count>0 then PDoc^.AddValue('fil', fa);
    pda^.Clear; pfa^.Clear;
  end;
  var v: Variant;
begin
  DirTree:=_Obj(['folder', StringToUTF8(DirName), 'mask', StringToUTF8(Mask)]);
  {$IFDEF ISDELPHIXE2}
  sa := faNormal + faDirectory + faReadOnly + faArchive; // TODO: облагородить
  {$ELSE}
  sa := faAnyFile + faDirectory + faReadOnly + faArchive; // TODO: облагородить
  {$ENDIF}
  Result := (DirName<>'') and DirectoryExists(DirName) and (Mask<>'');
  Result := Result and BuildTree(DirName, '', v);
  TDocVariantData(DirTree).AddValue('contents', v);
end;
{$ENDIF}
{$IFNDEF MORMOT_V1_18}
function ResourceToFile(const ResName, ResType: string; const FileName: TFileName;
                        const DeleteIfExists: Boolean = False): Boolean;
var Resource: TResourceStream; ResFile: TFileStream;  r: RawByteString;
begin
  if (ResName='') or (ResType='') then Result := False
  else if FileExists(FileName) and (not DeleteIfExists) and
          (Executable.Version.BuildDateTime < FileAgeToDateTime(FileName)) then begin
          Result := True
          end
  else begin
    Result:=True;
    if FileExists(FileName) then Result := DeleteFile(FileName);
    if Result then begin
      Resource := TResourceStream.Create(HInstance, ResName, RT_RCDATA);
      try
        if Resource.Size>0 then begin
          ResFile := TFileStream.Create(FileName, fmCreate);
          try
            try
              ResFile.CopyFrom(Resource, Resource.Size);
            except
              Result:=False;
            end;
          finally
            ResFile.Free;
          end;
        end else Result:=False;
      finally
        Resource.Free;
      end;
    end;
  end;
end;
{$ENDIF}
function ValidObject(const AObj: TObject): Boolean;
begin
  Result := Assigned(AObj) {$IFDEF AUTOREFCOUNT} and (not AObj.Disposed){$ENDIF};
end;

{begin from ComUnit.pas}
function StringsBufToVar(const Buffer; Count: integer): Variant;
var
  i: integer;
begin
  if Count>0 then
    begin
      Result:=VarArrayCreate([0,Count-1], varOleStr);
      for i:=0 to Count-1 do
        Result[i] := PStringArray(@Buffer)[i];
    end
      else
    Result:=Null;
end;
function VarToStringsBuf(SourceVar: Variant; var Buffer): integer;
var i,L,H: integer;
  {$ifndef ISDELPHIXE2} s: AnsiString; {$ENDIF}
begin
  if not(VarIsNull(SourceVar)) then
    begin
      L:=VarArrayLowBound(SourceVar,1);
      H:=VarArrayHighBound(SourceVar,1);
      for i:=L to H do
        {$IFDEF ISDELPHIXE2}
        PStringArray(@Buffer)[i-L]:=String1251(SourceVar[i]);
        {$else}
        begin
          s:=SourceVar[i];
          PStringArray(@Buffer)[i-L]:=s;
        end;
        {$ENDIF}
      Result:=H-L+1;
    end
      else
    Result:=0;
end;
{end from ComUnit.pas}

{ TDBDZipper }

function TDBDZipper.AddFile(const fName: TFileName; const ForceAdd: Boolean=False): Boolean;
begin

end;

function TDBDZipper.AddOrReplace(const fName: TFileName): Boolean;
begin

end;

constructor TDBDZipper.Create(const zName, fName: TFileName);
begin

end;

destructor TDBDZipper.Destroy;
begin

  inherited;
end;

function TDBDZipper.ExtractFile(const fName, Dest: TFileName): Boolean;
begin

end;

function TDBDZipper.GetNamesCSV: string;
begin

end;

function TDBDZipper.ReadFile(const fName: TFileName; Stream: TStream): Boolean;
begin

end;

function TDBDZipper.Remove(const fName: TFileName): Boolean;
begin

end;

procedure TDBDZipper.SetNames(const Value: TStringDynArray);
begin
  FNames := Value;
end;

{ TDBDPriceDate }

constructor TDBDPriceDate.Create(const aDate: TDateTime);
begin
  SetDate(aDate);
end;

constructor TDBDPriceDate.CreateMonth(const aYear, aMonth: Word);
begin
  FPriceDate:=aYear*100+aMonth;
end;

constructor TDBDPriceDate.CreateQuarter(const aYear, aQuorter: Word);
begin
  FPriceDate:=aYear*100+(aQuorter*3-2);
end;

function TDBDPriceDate.GetPriceDate: Integer;
begin
  Result:=FPriceDate;
end;

function TDBDPriceDate.GetDate: TDateTime;
begin
  Result:=EncodeDate(GetYear,GetMonth,1);
end;

function TDBDPriceDate.GetMonth: Word;
begin
  Result:=(FPriceDate mod 100);
end;

function TDBDPriceDate.GetQuarter: Word;
begin
  Result:=((GetMonth - 1) div 3) + 1;
end;

function TDBDPriceDate.GetYear: Word;
begin
  Result:=(FPriceDate div 100);
end;

class function TDBDPriceDate.MonthFromPriceDate(const dt: Integer): Integer;
begin
  Result:=(dt mod 100);
end;

class function TDBDPriceDate.PriceDateFromDateTime(const dt: TDateTime): Integer;
var Y,M,D: Word;
begin
  DecodeDate(dt,Y,M,D);
  Result:=Y*100+M;
end;

function DBDReadDigit(const aStr: string; var vPos: Integer; out oNum: Byte): Boolean;
var c: Char; i: Integer;
begin
  oNum:=0; Result :=((aStr<>'') and (vPos>0) and (vPos<=Length(aStr))); if not Result then Exit;
  c := aStr[vPos];
{$ifdef ISDELPHIXE2}
  i := System.Pos(c,'0123456789')-1;
  Result := i>=0;
{$else}
  {$ifdef FPC_OR_UNICODE}
  i := System.Pos(c,'0123456789')-1;
  Result := i>=0;
  {$else}
  i := Ord(c)-$30;
  Result := (i>=0) and (i<=9);
  {$endif FPC_OR_UNICODE}
{$endif ISDELPHIXE2}
  if Result then begin oNum:=i; Inc(vPos); end;
end;
function DBDReadNumber(const aStr: string; var vPos: Integer; out oNum: Cardinal): Boolean;
var f: Boolean; b: Byte;
const maxCardinal = 429496729; // ~ (4294967295 div 10);
begin
{$IFDEF DEBUG}
  Assert((aStr<>'') and (vPos>0) and (vPos<=Length(aStr)));
{$ENDIF}
  Result:=(aStr<>'') and (vPos>0) and (vPos<=Length(aStr)); if not Result then Exit;
  Result := DBDReadDigit(aStr,vPos, b); oNum:=0; if not Result then Exit;
  f := True;
  try
    while f do begin
      oNum := oNum*10+b;
      f := (vPos<=Length(aStr)) and DBDReadDigit(aStr,vPos, b);
    end;
  except
    Result := false; // слишком много цифр подряд
  end;
end;

class function TDBDPriceDate.PriceDateFromStr(const dt: string): Integer;
var i: Integer; m,y: Cardinal;
begin
  if dt='' then Result:=0
  else begin
    i:=1;
    if DBDReadNumber(dt,i,m) and (dt[i]='/') and (m>0) and (m<13) then begin
      Inc(i);
      if DBDReadNumber(dt,i,y) then begin
        if y<50 then y:=y+2000
        else if y<100 then y:=y+1900;
        Result:=y*100+m;
      end;
    end;
  end;
end;

class function TDBDPriceDate.PriceDateToStr(const dt: Integer; const TwoDigsYear: Boolean): string;
var w: Word;
begin
  if TwoDigsYear then begin
    w:= YearFromPriceDate(dt);
    if w>2000 then w:=w-2000
    else if w>1900 then w:=w-1900;
    Result:=Format('%2.2d/%2.2d', [MonthFromPriceDate(dt), w])
  end else Result:=Format('%2.2d/%d', [MonthFromPriceDate(dt), YearFromPriceDate(dt)])
end;

procedure TDBDPriceDate.SetPriceDate(const Value: Integer);
begin
  FPriceDate:=Value;
end;

procedure TDBDPriceDate.SetDate(const Value: TDateTime);
begin
  FPriceDate:=PriceDateFromDateTime(Value);
end;

procedure TDBDPriceDate.SetMonth(const Value: Word);
begin
  FPriceDate:=GetYear*100+Value;
end;

procedure TDBDPriceDate.SetQuarter(const Value: Word);
begin
  FPriceDate:=GetYear*100+((Value div 3)+1);
end;

procedure TDBDPriceDate.SetYear(const Value: Word);
begin
  FPriceDate:=Value*100+GetMonth;
end;

class function TDBDPriceDate.YearFromPriceDate(const dt: Integer): Integer;
begin
  Result:=(dt div 100);
end;

initialization

{$IFDEF ISDELPHIXE2}
  DBDFormatSettings:=TFormatSettings.Create;
{$ELSE}
  GetLocaleFormatSettings(0,DBDFormatSettings);
{$ENDIF}
 DBDFormatSettings.DecimalSeparator:='.';

 XML_HEADER:=XML_HEADER_UTF8;


end.