
//////////////////////////////////////////////////
//  Oracle Data Access Components
//  Copyright (c) 1998-2014 Devart. All right reserved.
//////////////////////////////////////////////////

{$IFNDEF CLR}
{$I Odac.inc}
unit OraServicesUni;
{$ENDIF}

interface

uses
  Classes, SysUtils, {$IFDEF VER6P}Variants,{$ENDIF} DB,
{$IFDEF MSWINDOWS}
  Registry, Windows,
{$ENDIF}
{$IFDEF CLR}
  System.Text, System.XML, System.Runtime.InteropServices,
{$ELSE}
  CLRClasses, CRXml,
{$ENDIF}
  CRTypes, MemData, {$IFNDEF FPC}MemDS{$ELSE}MemDataSet{$ENDIF},
  CRAccess, DBAccess, DADump, DASQLGenerator,
{$IFNDEF UNIDACPRO}
  OraCall, OraSQLGenerator;
{$ELSE}
  OraCallUni, OraSQLGeneratorUni;
{$ENDIF}

const
  prSequenceMode = 101; // integer
  prTNSPath      = 102; // string

type
  TCustomOraDataSetService = class;

  TCustomOraFieldTypeMap = class(TDAFieldTypeMap)
    class function GetDataType(FieldType: TFieldType): integer; override;
    class function GetFieldType(DataType: Word): TFieldType; override;
  end;

  TCustomOraDataSetUpdater = class(TDADataSetUpdater)
  private
    function GetDataSetService: TCustomOraDataSetService;
  protected
    procedure GetSequenceNextVal;
    function GetIdentityFieldValue(out Value: variant): boolean; override;

    function IsNeedInsertPreconnect: boolean; override;
    function IsNeedEditPreconnect: boolean; override;
    function IsPreconnected: boolean; override;

    function PrepareBatch(SQL: string): string; override;

    procedure CheckUpdateQuery(const StatementType: TStatementType); override;
    procedure SetUpdateQueryOptions(const StatementType: TStatementType); override;
    procedure UpdateExecute(const StatementTypes: TStatementTypes); override;

    procedure PrepareAppend; override;
    function PerformAppend: boolean; override;

    property UpdateQuery: TComponent read FUpdateQuery;
    property DataSetService: TCustomOraDataSetService read GetDataSetService;
  public
    function PerformSQL(const SQL: string; const StatementTypes: TStatementTypes): boolean; override;
    function GetDefaultExpressionValue(DefExpr: string; out Value: variant): boolean; override;
  end;

  TCustomOraDataSetService = class(TDADataSetService)
  private
    function GetUpdater: TCustomOraDataSetUpdater;
  protected
    FScrollableCursor: boolean;

    procedure CreateDataSetUpdater; override;
    procedure CreateSQLGenerator; override;

    function DetectHiddenFields: TFieldArray; override;
    function DetectCanModify: boolean; override;

    function ExtFieldsInfoIsInternal: boolean; override;
    procedure RequestFieldsInfo(Tables: TSQLObjectsInfo; Columns: TColumnsInfo); override;

    function GetRecCount: integer; override;

    function CompatibilityMode: boolean; virtual;
    function GetFieldClass(FieldType: TFieldType; DataType: Word): TFieldClass; override;
    function GetCurrentSchema: string; override;

  { XML }
    procedure WriteFieldXMLDataType(Field: TField; FieldDesc: TFieldDesc; const FieldAlias: string;
      XMLWriter: XMLTextWriter); override;
    function GetFieldXMLValue(Field: TField; FieldDesc: TFieldDesc): WideString; override;

    property Updater: TCustomOraDataSetUpdater read GetUpdater;
  public
    function SetProp(Prop: integer; const Value: variant): boolean; override;

    function OpenNext: boolean; override;
    function NeedParamValuesOnPrepare: boolean; override;
  end;

  TCustomDBOraSQLGenerator = class(TCustomOraSQLGenerator)
  public
    function GenerateSQL(const StatementType: _TStatementType;
      const ModifiedFieldsOnly: boolean;
      const Index: Integer = -1): string; override;
  end;

  TOraServerEnumerator = class (TCRServerEnumerator)
  private
    FDirect: boolean;
    FHomeName: string;
    FTNSPath: string;

  public
    function SetProp(Prop: integer; const Value: variant): boolean; override;
    function GetProp(Prop: integer; var Value: variant): boolean; override;

    function GetTNSFileName(Home: TOracleHome): string;
    procedure GetServerList(List: TStrings); override;
  end;

  TCustomOraDumpProcessor = class(TDADumpProcessor)
  protected
    function CreateQuery: TCustomDADataSet; override;
  end;

implementation

uses
  CRFunctions, CRParser, MemUtils, DAConsts, DASQLMonitor,
{$IFDEF CLR}
  System.IO,
{$ENDIF}
{$IFNDEF UNIDACPRO}
  OraClasses, OraParser;
{$ELSE}
  OraClassesUni, OraParserUni;
{$ENDIF}

{ TCustomOraFieldTypeMap }

const
{$IFDEF VER5}
  OraDataTypeMap: array [TFieldType] of word = (
    dtUnknown, dtString, dtSmallint, dtInteger, dtWord, dtBoolean, dtFloat,
    dtFloat, dtUnknown, dtDate, dtTime, dtDateTime, dtBytes, dtVarBytes, 0, dtBlob, dtMemo,
    0, 0, 0, 0, 0, dtCursor, dtFixedChar, dtWideString, dtInteger, dtObject, dtArray, dtReference,
    dtTable, dtOraBlob, dtOraClob, 0, 0, 0, 0);
{$ENDIF}
{$IFDEF VER6P}
  OraDataTypeMap: array [TFieldType] of word = (
  //ftUnknown, ftString, ftSmallint, ftInteger, ftWord
    dtUnknown, dtString, dtSmallint, dtInteger, dtWord,
  //ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime
    dtBoolean, dtFloat, dtCurrency, dtBCD, dtDate, dtTime, dtDateTime,
  //ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo
    dtBytes, dtVarBytes, 0,         dtBlob, dtMemo, 0,         0,
  //ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString
    0,            0,          0,             dtCursor, dtFixedChar, dtWideString,
  //ftLargeint, ftADT,    ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob
    dtLargeInt, dtObject, dtArray, dtReference, dtTable,   dtOraBlob, dtOraClob,
  //ftVariant, ftInterface, ftIDispatch,  ftGuid,
    0,         0,           0,            dtGuid,
  //             ftTimeStamp,    ftFMTBcd,
    {$IFNDEF FPC}dtSQLTimeStamp, dtFMTBcd{$ELSE}0, 0{$ENDIF}
  {$IFDEF FPC}
    //ftFixedWideChar, ftWideMemo,
    , dtFixedWideChar, dtWideMemo
  {$ENDIF}
  {$IFDEF VER10P}
    //ftFixedWideChar, ftWideMemo, ftOraTimeStamp, ftOraInterval,
    , dtFixedWideChar, dtWideMemo, dtTimeStamp,    0
  {$IFDEF VER12P}
    //ftLongWord, ftShortint, ftByte,    ftExtended, ftConnection, ftParams, ftStream
    , dtUInt32,   dtInt8,     dtUInt8,   dtFloat,    0,            0,        0
  {$ENDIF}
  {$IFDEF VER14P}
    //ftTimeStampOffset, ftObject, ftSingle
    , 0,                 0,        dtSingle
  {$ENDIF}
  {$ENDIF}
  );
{$ENDIF}

class function TCustomOraFieldTypeMap.GetDataType(FieldType: TFieldType): integer;
begin
{$IFNDEF FPC}
{$IFNDEF VER10P}
  if Integer(FieldType) = Integer(ftFixedWideChar) then
    Result := dtFixedWideChar
  else
{$ENDIF}
{$ENDIF}
    Result := OraDataTypeMap[FieldType];
end;

class function TCustomOraFieldTypeMap.GetFieldType(DataType: Word): TFieldType;
begin
  case DataType of
    dtOraBlob:
      Result := ftOraBlob;
    dtOraClob, dtWideOraClob:
      Result := ftOraClob;
    dtFixedChar:
      Result := ftFixedChar;
    dtFixedWideChar:
      Result := TFieldType(ftFixedWideChar);
  {$IFDEF VER6P}
  {$IFNDEF FPC}
    dtSQLTimeStamp:
      Result := ftTimeStamp;
  {$ENDIF}
  {$ENDIF}
    dtUndefined, dtTimeStamp, dtTimeStampTZ, dtTimeStampLTZ, dtBFile, dtLabel,
    dtIntervalYM, dtIntervalDS, dtNumber, dtXML:
      Result := ftUnknown;
  else
    Result := inherited GetFieldType(DataType);
  end;
end;

{ TCustomOraUpdater }

function TCustomOraDataSetUpdater.GetDataSetService: TCustomOraDataSetService;
begin
  Result := TCustomOraDataSetService(FDataSetService);
end;

function TCustomOraDataSetUpdater.GetIdentityFieldValue(out Value: variant): boolean;
var
  Command: TOCICommand;
  RowId: string;
begin
  Command := TOCICommand(TDBAccessUtils.GetICommand(TCustomDADataSet(FUpdateQuery)));
  Assert(Command <> nil);
  RowId := Command.GetRowId;
  Result := RowID <> '';
  if Result then
    Value := RowID;
end;

procedure TCustomOraDataSetUpdater.CheckUpdateQuery(const StatementType: TStatementType);
begin
  inherited;

  TDBAccessUtils.GetICommand(FUpdateQuery as TCustomDADataSet).SetProp(prStoreRowId, True);
end;

procedure TCustomOraDataSetUpdater.SetUpdateQueryOptions(const StatementType: TStatementType);
var
  DestCommand, SourceCommand: TCRCommand;

  procedure CopyPropC(Prop: integer);
  var
    v: variant;
  begin
    SourceCommand.GetProp(Prop, v);
    DestCommand.SetProp(Prop, v);
  end;

begin
  CheckIRecordSet; // can be inactive
  SourceCommand := GetICommand;
  DestCommand := TDBAccessUtils.GetICommand(FUpdateQuery as TCustomDADataSet);

  CopyPropC(prCacheLobs);
  CopyPropC(prFieldsAsString);
  CopyPropC(prRawAsString);
  CopyPropC(prTemporaryLobUpdate);
end;

procedure TCustomOraDataSetUpdater.UpdateExecute(const StatementTypes: TStatementTypes);

  procedure ResetOutputParams(Params: TDAParams);
  var
    i: integer;
    Commnad: TCRCommand;
    ParamDesc: TParamDesc;
  begin
    // to fix bug with InputOutput NVARCHAR params for Oracle 10
    Commnad := TDBAccessUtils.GetICommand(FUpdateQuery);
    if (Commnad <> nil) and (Commnad.Params.Count = Params.Count) then
      for i := 0 to Commnad.Params.Count - 1 do begin
        ParamDesc := Commnad.Params[i];
        if not TOraParamDesc(ParamDesc).GetCanBeOutput then
          if ParamDesc.GetName = Params[i].Name then
            Params[i].ParamType := ptInput;
      end;
  end;

var
  i: integer;
  Param: TDAParam;
  Params: TDAParams;
  Field: TField;
begin
  Params := TDBAccessUtils.GetParams(FUpdateQuery);

  if NeedReturnParams or (stRefresh in StatementTypes) then
    for i := 0 to Params.Count - 1 do begin
      Param := Params[i];
      if not (Param.DataType in [ftOraBlob, ftOraClob]) then
        Param.ParamType := ptInputOutput;
    end;

  ResetOutputParams(Params);

  // Update ROWID value for successful Refresh after Update on Post or on
  // ApplyUpdaes (UROWID)
  if (stRefresh in StatementTypes) and ((FDataSet.State = dsEdit) or FDataSet.InCacheProcessing)
    and (DataSetService.IdentityField <> nil)
  then begin
    Param := Params.FindParam('OLD_ROWID');
    Field := FDataSet.GetField(DataSetService.IdentityField);
    if (Param <> nil) and (Field <> nil) then
      Param.Value := Field.Value;
  end;
  inherited;
end;

function TCustomOraDataSetUpdater.PerformSQL(const SQL: string; const StatementTypes: TStatementTypes): boolean;
var
  RowId: string;
  Command: TOCICommand;
  Connection: TOCIConnection;
begin
  BeginConnection;
  try
    Result := inherited PerformSQL(SQL, StatementTypes);

    if Result and (stUpdate in StatementTypes) then begin
      RowId := TOCICommand(TDBAccessUtils.GetICommand(TCustomDADataSet(FUpdateQuery))).GetRowId;
      if (RowId <> '') and (RowId[1] = '*') then // UROWID was returned
        SetIdentityFieldValue; // for correct updates when UROWID was changed
    end;

    Connection := TOCIConnection(TDBAccessUtils.GetIConnection(UsedConnection));

    if Result and 
       (Connection.OCISvcCtx.Home.OCIVersion >= 8150) and (Connection.OCISvcCtx.Home.OCIVersion < 9000) and
       (stInsert in StatementTypes) and (DataSetService.IdentityField <> nil)
    then begin
      Command := TOCICommand(TDBAccessUtils.GetICommand(TCustomDADataSet(FUpdateQuery)));
      if (Command.GetRowId = '')
        and (Connection.GetOracleVersion > 8000) and (Connection.GetOracleVersion < 8100)
      then begin
        TCustomDADataSet(FUpdateQuery).SQL.Text := 'select 1 from dual where 1=0';
        TCustomDADataSet(FUpdateQuery).Execute;
        TCustomDADataSet(FUpdateQuery).Close;
      end;
    end;
  finally
    EndConnection;
  end;
end;

function TCustomOraDataSetUpdater.GetDefaultExpressionValue(DefExpr: string; out Value: variant): boolean;
begin
  DefExpr := AnsiUpperCase(Trim(DefExpr));
  if (DefExpr = 'EMPTY_BLOB()') or (DefExpr = 'EMPTY_CLOB()') then begin
    Value := '';
    Result := True;
  end
  else
    Result := inherited GetDefaultExpressionValue(DefExpr, Value);
end;

procedure TCustomOraDataSetUpdater.PrepareAppend;
begin
  if (DataSetService.KeyGeneratorField <> nil) and (TCustomDBOraSQLGenerator(DataSetService.SQLGenerator).SequenceMode = _smInsert) then
    GetSequenceNextVal;
end;

function TCustomOraDataSetUpdater.PerformAppend: boolean;
var
  OldReturnParams: boolean;
begin
  OldReturnParams := FDataSet.Options.ReturnParams;
  if DataSetService.KeyGeneratorField <> nil then
    if ((FDataSet.SQLInsert.Count > 0) or ((GetUpdateObject <> nil)
      and (GetUpdateObject.InsertSQL.Count > 0))) and
      (TCustomDBOraSQLGenerator(DataSetService.SQLGenerator).SequenceMode = _smPost)
    then
      GetSequenceNextVal
    else
      FDataSet.Options.ReturnParams := True;

  try
    Result := inherited PerformAppend;
  finally
    FDataSet.Options.ReturnParams := OldReturnParams;
  end;
end;

procedure TCustomOraDataSetUpdater.GetSequenceNextVal;
var
  OldReturnParams: boolean;
begin
  if DataSetService.KeyGeneratorField <> nil then begin
    OldReturnParams := FDataSet.Options.ReturnParams;
    FDataSet.Options.ReturnParams := True;
    try
      if OCISQLInfo.QuotesNeeded(DataSetService.KeyGeneratorField.Name) then
        PerformSQL('begin' + DALineSeparator + '  SELECT ' +
          DataSetService.SQLGenerator.KeySequence + '.NEXTVAL INTO :' +
          IntToStr(DataSetService.KeyGeneratorField.FieldNo) + ' FROM Dual;' + DALineSeparator + 'end;', [stCustom])
      else
        PerformSQL('begin' + DALineSeparator + '  SELECT ' +
          DataSetService.SQLGenerator.KeySequence + '.NEXTVAL INTO :' +
          OCISQLInfo.QuoteIfNeed(DataSetService.KeyGeneratorField.Name) +' FROM Dual;' + DALineSeparator + 'end;', [stCustom]);
    finally
      FDataSet.Options.ReturnParams := OldReturnParams;
    end;
  end;
end;

function TCustomOraDataSetUpdater.PrepareBatch(SQL: string): string;
begin
  Result := 'BEGIN' + #13#10 + SQL + #13#10 + 'END;'
end;

function TCustomOraDataSetUpdater.IsNeedEditPreconnect: boolean;
var
  vHasObjectFields: variant;
begin
  Result := not FDataSet.CachedUpdates and (GetLockMode = lmPessimistic);
  if not Result then begin
    GetIRecordSet.GetProp(prHasObjectFields, vHasObjectFields);
    Result := (vHasObjectFields = True);
  end;
end;

function TCustomOraDataSetUpdater.IsPreconnected: boolean;
var
  vHasObjectFields: variant;
begin
  Result := inherited IsPreconnected;
  if UsedConnection.Options.DisconnectedMode then begin         //in case of Object fields there is pre-connection during
    GetIRecordSet.GetProp(prHasObjectFields, vHasObjectFields); //InitRecord, so we should call EndConnection after post or cancel
    Result := Result or (vHasObjectFields = True);
  end;
end;

function TCustomOraDataSetUpdater.IsNeedInsertPreconnect: boolean;
begin
  Result := (TCustomDBOraSQLGenerator(DataSetService.SQLGenerator).SequenceMode = _smInsert);
end;

{ TCustomOraDataSetService }

procedure TCustomOraDataSetService.CreateDataSetUpdater;
begin
  SetDataSetUpdater(TCustomOraDataSetUpdater.Create(Self));
end;

procedure TCustomOraDataSetService.CreateSQLGenerator;
begin
  SetSQLGenerator(TCustomDBOraSQLGenerator.Create(TDASQLGeneratorService));
end;

function TCustomOraDataSetService.GetUpdater: TCustomOraDataSetUpdater;
begin
  Result := TCustomOraDataSetUpdater(FUpdater);
end;

function TCustomOraDataSetService.DetectHiddenFields: TFieldArray;
var
  i: integer;
  FieldDesc: TCRFieldDesc;
  RecordSet: TOCIRecordSet;
  Field: TField;
begin
  Result := nil;
  RecordSet := TOCIRecordSet(GetIRecordSet);
  for i := 0 to RecordSet.Fields.Count - 1 do begin
    FieldDesc := TCRFieldDesc(RecordSet.Fields[i]);
    if CompareText(FieldDesc.ActualName, 'ROWID') = 0 then begin
      Field := FDataSet.GetField(FieldDesc);
      if Field <> nil then begin
        SetLength(Result, Length(Result) + 1);
        Result[Length(Result) - 1] := Field;
      end;
    end;
  end;
end;

function TCustomOraDataSetService.DetectCanModify: boolean;
begin
  Result := (inherited DetectCanModify or
    not FDataSet.ReadOnly and
    (not CompatibilityMode or
    (FDataSet.SQLInsert.Count > 0) or
    (FDataSet.SQLUpdate.Count > 0) or
    (FDataSet.SQLDelete.Count > 0)) and
     FIsAnyFieldCanBeModified) and
    not (FScrollableCursor); // can't modify scrollable cursor
end;

function TCustomOraDataSetService.SetProp(Prop: integer; const Value: variant): boolean;
begin
  Result := True;
  case Prop of
    prSequenceMode:
      TCustomDBOraSQLGenerator(SQLGenerator).SequenceMode := _TSequenceMode(Value);
    prScrollableCursor:
      FScrollableCursor := Value;
  else
    Result := inherited SetProp(Prop, Value);
  end;
end;

function TCustomOraDataSetService.OpenNext: boolean;
var
  Cursor: TCRCursor;
begin
  if not FDataSet.Active then begin
    FDataSet.Open;
    Result := True;
  end
  else begin
    Cursor := TOCICommand(GetIRecordSet.GetCommand).GetNextCursor;
    if Cursor <> nil then begin
      FDataSet.Close;
      TDBAccessUtils.SetCursor(FDataSet, Cursor);
      FDataSet.Open;
      Result := True;
    end
    else
      Result := False;
  end;
end;

function TCustomOraDataSetService.NeedParamValuesOnPrepare: boolean;
begin
  Result := True;
end;

function TCustomOraDataSetService.ExtFieldsInfoIsInternal: boolean;
begin
  Result := False;
end;

procedure TCustomOraDataSetService.RequestFieldsInfo(Tables: TSQLObjectsInfo; Columns: TColumnsInfo);
var
  UserName: string;
  Query: TCustomDADataSet;

  function AddDBLink(DBLink: string): string;
  begin
    if DBLink <> '' then
      Result := '@' + DBLink;
  end;

  function GetDefExpr(Value: string; DataType: string): string;
  var
    P: integer;
    DeqValue: string;
  begin
    if DefaultExpressionOldBehavior then begin
      Result := TrimRight(Value);
      DeqValue := AnsiDequotedStr(Result, '''');
      if (Result <> DeqValue) and (AnsiQuotedStr(DeqValue, '''') = Result) then // '1' + '2' should not be dequoted
        Result := DeqValue;
      if (DataType = 'NUMBER') and ({$IFDEF VER16P}FormatSettings.{$ENDIF}DecimalSeparator{$IFDEF CLR}[1]{$ENDIF} <> '.') then begin
        P := Pos('.', Result);
        if P > 0 then
          Result[P] := Char({$IFDEF VER16P}FormatSettings.{$ENDIF}DecimalSeparator{$IFDEF CLR}[1]{$ENDIF});
      end;
    end
    else
      Result := Value;
  end;

  function GetOwner: string;
  begin
    Result := TOCIConnection(TDBAccessUtils.GetIConnection(UsedConnection)).GetCachedSchema;
  end;

  procedure GetFieldsInfoServer(var NeedDescribeSynonyms: boolean);
  var
    SQL, Filter: string;
    CurTableName, FieldTableName, CurOwner, FieldOwner, DBLink: string;
    j, p: integer;
    ColumnInfo, NewColumnInfo: TColumnInfo;
    Located, MoreDBLinks: boolean;
  begin
    NeedDescribeSynonyms := False;
    for j := 0 to High(Tables) do
      Tables[j].Flag := Tables[j].Flag and not 2; // 2 - info is queried
    repeat
      Filter := '';
      MoreDBLinks := False;
      for j := 0 to High(Tables) do
        if (Tables[j].Flag and 1 <> 0) and (Tables[j].Flag and 2 = 0) then begin
          if Filter = '' then
            DBLink := Tables[j].DBLink
          else begin
            if Tables[j].DBLink <> DBLink then begin
              MoreDBLinks := True;
              continue;
            end;
            Tables[j].Flag := Tables[j].Flag or 2;
            Filter := Filter + ' OR';
          end;
          Filter := Filter + ' (table_name = ''' + Tables[j].Name + '''' +
            ' and owner = ''' + Tables[j].Schema + ''')';
        end;

      if Filter = '' then
        exit;

      SQL := 'SELECT owner, table_name, column_name';
      if FDataSet.Options.DefaultValues then
        SQL := SQL + ', data_default, data_type';
      SQL := SQL + ' FROM sys.all_tab_columns' + AddDBLink(DBLink) +
        ' WHERE ' + Filter +
        ' ORDER BY owner, table_name, column_id';

      Query.SQL.Text := SQL;
      try
        Query.Open;
      except
        //Probably no DBLink
      end;

      p := 0;
      while p < Columns.Count do begin
        ColumnInfo := Columns[p];
        if (ColumnInfo.TableIndex = -1) and (ColumnInfo.Table <> '') and
          not GetIRecordSet.UpdTableIsArtificial or
          not FDataSet.Options.FieldsOrigin and (ColumnInfo.TableIndex <> -1)
          and (ColumnInfo.TableIndex <> GetIRecordSet.UpdatingTableInfoIdx)
        then
          ColumnInfo.Described := True;

        if ColumnInfo.Described then begin
          Inc(p);
          continue;
        end;

        if ColumnInfo.Name = '*' then begin
          if ColumnInfo.TableIndex <> -1 then begin
            FieldTableName := Tables[ColumnInfo.TableIndex].Name;
            FieldOwner := Tables[ColumnInfo.TableIndex].Schema;
          end;
          NewColumnInfo := nil;
          Query.First;
          while not Query.EOF do begin
            CurOwner := Query.Fields[0].AsString;
            CurTableName := Query.Fields[1].AsString;
            if (ColumnInfo.TableIndex = -1) or
              (CurOwner = FieldOwner) and (CurTableName = FieldTableName)
            then begin
              Inc(p);
              NewColumnInfo := TColumnInfo.Create;
              Columns.Insert(p, NewColumnInfo);
              NewColumnInfo.Used := False;
              NewColumnInfo.Described := True;
              NewColumnInfo.Table := ColumnInfo.Table;
              NewColumnInfo.TableIndex := ColumnInfo.TableIndex;
              NewColumnInfo.Name := Query.Fields[2].AsString;
              NewColumnInfo.Alias := NewColumnInfo.Name;

              if NewColumnInfo.TableIndex = -1 then begin
                for j := 0 to High(Tables) do
                  if (Tables[j].Schema = CurOwner) and (Tables[j].Name = CurTableName) then begin
                    NewColumnInfo.TableIndex := j;
                    break;
                  end;
              end;
              if NewColumnInfo.TableIndex <> -1 then
                Tables[NewColumnInfo.TableIndex].Flag := 0;

              if FDataSet.Options.DefaultValues and (NewColumnInfo.TableIndex = GetIRecordSet.UpdatingTableInfoIdx) then
                NewColumnInfo.Expr := GetDefExpr(Query.Fields[3].AsString, Query.Fields[4].AsString);
            end
            else
              if (NewColumnInfo <> nil) and (ColumnInfo.TableIndex <> -1) then
                break;
            Query.Next;
          end;
          if (NewColumnInfo <> nil) and (ColumnInfo.TableIndex <> -1) then
            ColumnInfo.Described := True;
        end
        else
          if (ColumnInfo.Name <> '') and (ColumnInfo.Name <> 'ROWID') then begin
            if ColumnInfo.TableIndex <> -1 then begin
              if FDataSet.Options.DefaultValues and (ColumnInfo.TableIndex = GetIRecordSet.UpdatingTableInfoIdx) then
                Located := Query.Locate('owner;table_name;column_name',
                  VarArrayOf([Tables[ColumnInfo.TableIndex].Schema, Tables[ColumnInfo.TableIndex].Name, ColumnInfo.Name]), [])
              else begin
                ColumnInfo.Described := True;
                Located := False;
              end;
            end
            else
              Located := Query.Locate('column_name', ColumnInfo.Name, []);

            if Located then begin
              ColumnInfo.Described := True;
              if FDataSet.Options.DefaultValues then
                ColumnInfo.Expr := GetDefExpr(Query.Fields[3].AsString, Query.Fields[4].AsString);

              if ColumnInfo.TableIndex = -1 then begin
                CurOwner := Query.Fields[0].AsString;
                CurTableName := Query.Fields[1].AsString;
                for j := 0 to High(Tables) do
                  if (Tables[j].Schema = CurOwner) and (Tables[j].Name = CurTableName) then begin
                    ColumnInfo.TableIndex := j;
                    break;
                  end;
              end;
              if ColumnInfo.TableIndex <> -1 then
                Tables[ColumnInfo.TableIndex].Flag := 0;
            end;
          end
          else
            ColumnInfo.Described := True;

        inc(p);
      end;

      for j := 0 to High(Tables) do
        if (Tables[j].Flag and 1 <> 0) and (Tables[j].DBLink = DBLink) then begin
          if Query.Locate('owner;table_name',
            VarArrayOf([Tables[j].Schema, Tables[j].Name]), [])
          then
            Tables[j].Flag := 0
          else
            NeedDescribeSynonyms := True;
        end;

    until not MoreDBLinks;

    if NeedDescribeSynonyms then begin
      NeedDescribeSynonyms := False;
      for j := 0 to Columns.Count - 1 do
        if not Columns[j].Described then begin
          NeedDescribeSynonyms := True;
          break;
        end;
    end;
  end;

  procedure GetDBLinkSchema;
  var
    SQL: string;
    i: integer;
  begin
    for i := 0 to High(Tables) do
      if (Tables[i].Flag and 1 <> 0) and
        (Tables[i].DBLink <> '') and (Tables[i].Schema = '')
      then
        SQL := SQL + ' AND db_link = ''' + Tables[i].DBLink + '''';

    if SQL = '' then
      Exit;

    SQL := 'SELECT username, db_link FROM sys.all_db_links' +
           ' WHERE owner IN (''' + GetOwner + ''', ''PUBLIC'') ' +
           SQL +
           ' ORDER BY decode(owner, ''PUBLIC'', 1, 0) ';

    Query.SQL.Text := SQL;
    Query.Open;

    for i := 0 to High(Tables) do
      if (Tables[i].Flag and 1 <> 0) and
        (Tables[i].DBLink <> '') and (Tables[i].Schema = '')
      then
        if Query.Locate('db_link', Tables[i].DBLink, []) then
          Tables[i].Schema := VarToStr(Query.Fields[0].Value);

    Query.Close;

    for i := 0 to High(Tables) do
      if (Tables[i].Flag and 1 <> 0) and
        (Tables[i].DBLink <> '') and
        ((Tables[i].Schema = '') or (Tables[i].Schema = 'CURRENT_USER'))
      then begin
        if UserName = '' then begin
          UserName := UsedConnection.Username;
          UserName := OCISQLInfo.NormalizeName(UserName, False, True);
          if UserName = '' then begin
            Query.SQL.Text := 'SELECT sys_context(''USERENV'', ''SESSION_USER'') FROM dual';
            Query.Open;
            UserName := VarToStr(Query.Fields[0].Value);
            Query.Close;
          end;
        end;
        Tables[i].Schema := UserName;
      end;
  end;

  procedure DescribeSynonyms;
  var
    j: integer;
    SQL, Filter, DBLink: string;
    MoreDBLinks: boolean;
  begin
    for j := 0 to High(Tables) do
      Tables[j].Flag := Tables[j].Flag and not 2;
    repeat
      Filter := '';
      MoreDBLinks := False;
      for j := 0 to High(Tables) do
        if (Tables[j].Flag and 1 <> 0) and (Tables[j].Flag and 2 = 0) then begin
          if Filter = '' then
            DBLink := Tables[j].DBLink
          else begin
            if Tables[j].DBLink <> DBLink then begin
              MoreDBLinks := True;
              continue;
            end;
            Tables[j].Flag := Tables[j].Flag or 2;
            Filter := Filter + ' OR';
          end;
          Filter := Filter + ' (synonym_name = ''' + Tables[j].Name + '''';
          if Tables[j].Flag and 8 = 0 then
            Filter := Filter + ' AND owner IN (''' + Tables[j].Schema + ''',''PUBLIC'') )'
          else
            Filter := Filter + ' AND owner = ''' + Tables[j].Schema + ''')';
        end;

      if Filter = '' then
        Exit;

      SQL := 'SELECT synonym_name, table_owner, table_name, db_link ' +
        'FROM sys.all_synonyms' + AddDBLink(DBLink) +
        ' WHERE ' + Filter +
        ' ORDER BY decode(owner, ''PUBLIC'', 1, 0)';

      Query.SQL.Text := SQL;
      Query.Open;

      for j := 0 to High(Tables) do
        if (Tables[j].Flag and 1 <> 0) and (Tables[j].DBLink = DBLink) then
          if Query.Locate('synonym_name', Tables[j].Name, []) then begin
            if (DBLink <> '') and (VarToStr(Query.Fields[3].Value) <> '') then
              Tables[j].Flag := 0
            else begin
              Tables[j].Synonym := Tables[j].Name;
              Tables[j].Name := VarToStr(Query.Fields[2].Value);
              Tables[j].DBLink := VarToStr(Query.Fields[3].Value);
              Tables[j].Schema := VarToStr(Query.Fields[1].Value);
              Tables[j].Flag := Tables[j].Flag or 8;
            end
          end
          else
            Tables[j].Flag := 0;

    until not MoreDBLinks;

    GetDBLinkSchema;
  end;

var
  i: integer;
  NeedDescribeSynonyms: boolean;
begin
  Query := UsedConnection.CreateDataSet;
  try
    for i := 0 to High(Tables) do begin
      if FDataSet.Options.FieldsOrigin or (i = GetIRecordSet.UpdatingTableInfoIdx) then
        Tables[i].Flag := 1
      else
        Tables[i].Flag := 0; // don't query fields for this table

      if Tables[i].Schema = '' then begin
        if Tables[i].DBLink <> '' then
          GetDBLinkSchema
        else
          Tables[i].Schema := GetOwner;
        end;
    end;

    TDBAccessUtils.SetLockDebug(Query, True);
    repeat
      GetFieldsInfoServer(NeedDescribeSynonyms);

      if NeedDescribeSynonyms then
        DescribeSynonyms;
    until not NeedDescribeSynonyms;
  finally
    Query.Free;
  end;
end;

function TCustomOraDataSetService.GetRecCount: integer;
var
  St: string;
  UpdateQuery: TCustomDADataSet;
  MonitorClass: TDASQLMonitorClass;
  MessageID: cardinal;
begin
  Result := 0;
  St := Trim(FDataSet.SQLRecCount.Text);
  if St = '' then
    St := FSQLGenerator.GenerateRecCountSQL;

  Updater.CheckUpdateQuery(stCustom);
  UpdateQuery := TCustomDADataSet(FUpdater.UpdateQuery);
  UpdateQuery.SQL.Text := St;
  UpdateQuery.Params.Assign(FDataSet.Params);

  UpdateQuery.Prepare;
  if TOCICommand(TDBAccessUtils.GetICommand(UpdateQuery)).GetSQLType = SQL_SELECT then begin
    MonitorClass := TDASQLMonitorClass(TDBAccessUtils.SQLMonitorClass(UsedConnection));
    if MonitorClass.HasMonitor or FDataSet.Debug then
      MonitorClass.SQLExecute(FDataSet, St, UpdateQuery.Params, 'Get RecordCount', MessageID, True);

    UpdateQuery.Open;
    if not UpdateQuery.EOF then
      Result := UpdateQuery.Fields[0].AsInteger;

    if MonitorClass.HasMonitor or FDataSet.Debug then
      MonitorClass.SQLExecute(FDataSet, St, UpdateQuery.Params, 'Get RecordCount', MessageID, False);
  end;
end;

function TCustomOraDataSetService.CompatibilityMode: boolean;
begin
  Result := False;
end;

function TCustomOraDataSetService.GetFieldClass(FieldType: TFieldType; DataType: Word): TFieldClass;
{$IFDEF VER10P}
var
  Value: variant;
{$ENDIF}
begin
{$IFDEF VER10P}
  if FieldType = ftOraClob then
    if DataType = dtWideOraClob then
      Result := TWideMemoField
    else if DataType = dtOraClob then
      Result := TMemoField
    else begin
      TDBAccessUtils.GetIConnection(UsedConnection).GetProp(prUseUnicode, Value);
      if Boolean(Value) then
        Result := TWideMemoField
      else
        Result := TMemoField;
    end
  else
{$ENDIF}
    Result := inherited GetFieldClass(FieldType, DataType);
end;

function TCustomOraDataSetService.GetCurrentSchema: string;
begin
  Result := TOCIConnection(TDBAccessUtils.GetIConnection(UsedConnection)).GetCachedSchema;
  // to preserve character case
  Result := '"' + Result + '"';
end;

procedure TCustomOraDataSetService.WriteFieldXMLDataType(Field: TField; FieldDesc: TFieldDesc; const FieldAlias: string;
  XMLWriter: XMLTextWriter);
var
  Length: integer;
begin
  case FieldDesc.Datatype of
    dtNumber: begin
      Length := FieldDesc.Length;
      if FieldDesc.Scale <> 0 then
        Inc(Length);
    end;
    dtTimeStamp, dtTimeStampTZ, dtTimeStampLTZ, dtIntervalYM, dtIntervalDS:
      Length := 50;
  else
    Length := 0;
  end;

  case FieldDesc.Datatype of
    dtNumber, dtTimeStamp, dtTimeStampTZ, dtTimeStampLTZ, dtIntervalYM, dtIntervalDS: begin
      XmlWriter.WriteAttributeString('dt:type', 'string');
      XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(Length));
      XmlWriter.WriteAttributeString('rs:dbtype', 'str');
    end;
    dtOraBlob, dtBFILE: begin
      XmlWriter.WriteAttributeString('dt:type', 'bin.hex');
      XmlWriter.WriteAttributeString('dt:maxLength', '2147483647');
      XmlWriter.WriteAttributeString('rs:long', 'true');
    end;
    dtOraClob, dtWideOraClob, dtCFILE, dtXML: begin
      XmlWriter.WriteAttributeString('dt:type', 'string');
      XmlWriter.WriteAttributeString('dt:maxLength', '2147483647');
      if FieldDesc.DataType <> dtWideOraClob then
        XmlWriter.WriteAttributeString('rs:dbtype', 'str');
      XmlWriter.WriteAttributeString('rs:long', 'true');
    end;
  else
    inherited;
    Exit;
  end;

  if Field.Required and not Field.ReadOnly then
    XmlWriter.WriteAttributeString('rs:maybenull', 'false');
end;

function TCustomOraDataSetService.GetFieldXMLValue(Field: TField; FieldDesc: TFieldDesc): WideString;
var
  Blob: TBlob;
  Piece: PPieceHeader;
{$IFDEF CLR}
  sb: StringBuilder;
  Buffer, Bytes: TBytes;
{$ELSE}
  sbOffset: integer;
  StrValue: string;
{$ENDIF}
begin
  case FieldDesc.DataType of
    dtOraBlob, dtBFILE: begin
      Blob := FDataSet.GetBlob(Field);
      Piece := Blob.FirstPiece;
    {$IFDEF CLR}
      sb := StringBuilder.Create;
      try
        while IntPtr(Piece) <> nil do begin
          SetLength(Buffer, Piece.Used);
          Marshal.Copy(PtrOffset(Piece, sizeof(TPieceHeader)), Buffer, 0, Piece.Used);
          SetLength(Bytes, Length(Buffer) * 2);
          BinToHex(Buffer, 0, Bytes, 0, Length(Buffer));
          sb.Append(Encoding.Default.GetString(Bytes));
          Piece := Piece.Next;
        end;
        Result := sb.ToString;
      finally
        sb.Free;
      end;
    {$ELSE}
      SetLength(StrValue, Blob.Size * 2);
      sbOffset := 0;
      while Piece <> nil do begin
        BinToHex(PtrOffset(Piece, sizeof(TPieceHeader)),
          PChar(PtrOffset(IntPtr(StrValue), sbOffset)), Piece.Used);
        sbOffset := sbOffset + Piece.Used * 2;
        Piece := Piece.Next;
      end;
      Result := StrValue;
    {$ENDIF}
    end;
    dtOraClob, dtWideOraClob, dtCFILE: begin
      Blob := FDataSet.GetBlob(Field);
      Result := Blob.AsWideString; // Unicode CLOBs support
    end;
  else
    Result := inherited GetFieldXMLValue(Field, FieldDesc);
  end;
end;

{ TCustomDBOraSQLGenerator }

function TCustomDBOraSQLGenerator.GenerateSQL(const StatementType: _TStatementType;
  const ModifiedFieldsOnly: boolean;
  const Index: Integer = -1): string;
var
  DataSet: TCustomDADataSet;
begin
  DataSet := TDASQLGeneratorService(FService).DataSet;
  if TCustomOraDataSetService(TDBAccessUtils.GetDataSetService(DataSet)).CompatibilityMode then
    Result := ''
  else
    Result := inherited GenerateSQL(StatementType, ModifiedFieldsOnly, Index);
end;

{ TOraServerEnumerator }

type
  TTNSParser = class (TParser)
  protected
    function IsInlineComment(Ch: Char; Pos: integer): boolean; override;
  end;

function TTNSParser.IsInlineComment(Ch: Char; Pos: integer): boolean;
begin
  Result := (TextLength >= Pos + 1) and (Text[Pos] = '#');
end;

function TOraServerEnumerator.GetTNSFileName(Home: TOracleHome): string;
const
  sTnsAdmin = 'TNS_ADMIN';
  sTnsNames = 'tnsnames.ora';
{$IFDEF MSWINDOWS}
  sNetwork = '\network\admin\';
  sNet80 = '\net80\admin\';
{$ELSE}
  sNetwork = '/network/admin/';
{$ENDIF}
var
{$IFDEF MSWINDOWS}
{$IFNDEF CLR}
  i: integer;
{$ENDIF}
{$ENDIF}
  FileName: string;
  TNSFound: boolean;

  function AddPath(Path, FileName: string): string;
  begin
    if (Path <> '') and (Path[Length(Path)] <> '\') then
      Result := Path + '\' + FileName
    else
      Result := Path + FileName;
  end;

begin
  TNSFound := False;

  if Home = nil then
    Exit;

  if FTNSPath <> '' then begin
    FileName := AddPath(FTNSPath, sTnsNames);
    if FileExists(FileName) then
      TNSFound := True;
  end
  else begin
    if Home.Path <> '' then begin
      FileName := Home.Path + sNetwork + sTnsNames;
      if FileExists(FileName) then
        TNSFound := True
      else begin
      {$IFDEF MSWINDOWS}
        FileName := Home.Path + sNet80 + sTnsNames;
        if FileExists(FileName) then
          TNSFound := True
      {$ENDIF}
      end;
    end;

  {$IFDEF MSWINDOWS}
    {$IFNDEF CLR}
    /// check if TNS_ADMIN environment variable is set
    if not TNSFound then begin
      i := GetEnvironmentVariable(sTnsAdmin, nil, 0);
      if i > 0 then begin
        SetLength(FileName, i - 1);
        GetEnvironmentVariable(sTnsAdmin, PChar(FileName), Length(FileName) + 1);
        FileName := AddPath(FileName, sTnsNames);
        if FileExists(FileName) then
          TNSFound := True;
      end;
    end;
    {$ENDIF}
  {$ENDIF}
  end;

  if not TNSFound then
    if Home.TNSPath <> '' then begin
      FileName := AddPath(FTNSPath, sTnsNames);
      if FileExists(FileName) then
        TNSFound := True;
    end;

  if TNSFound then
    Result := FileName;
end;

procedure TOraServerEnumerator.GetServerList(List: TStrings);
var
  i, j: integer;
  Home: TOracleHome;
  IFile, F: TStrings;
  Parser: TTNSParser;
  Code: integer;
  FileName, CurrentDir, St, OldSt, Alias: string;
  Bracket: integer;
begin
  inherited;

  if not FDirect then
    if FHomeName <> '' then
      Home := OracleHomes.FindHome(FHomeName)
    else
      Home := OracleHomes.Default
  else
    Home := nil;

  if Home = nil then
    exit;

  FileName := GetTNSFileName(Home);
  if FileName = '' then
    exit;

  F := TStringList.Create;
  Parser := TTNSParser.Create('');
  try
    Parser.OmitBlank := True;
    Parser.OmitComment := True;
    F.LoadFromFile(FileName);

    IFile := TStringList.Create;
    i := 0;
    CurrentDir := GetCurrentDir;
    SetCurrentDir(ExtractFileDir(FileName));
    try
      while i < F.Count do begin
        if Pos('IFILE', UpperCase(F[i])) > 0 then begin
          FileName := Trim(Copy(F[i], Pos('=',F[i]) + 1, MaxInt));
          if FileExists(FileName) then begin
            IFile.LoadFromFile(FileName);
            F.Delete(i);
            for j := IFile.Count - 1 downto 0 do
               F.Insert(i, IFile[j]);
            Continue;
          end;
        end;
        Inc(i);
      end;
    finally
      SetCurrentDir(CurrentDir);
      IFile.Free;
    end;

    Parser.SetText(F.Text);
    Code := 0;
    St := '';
    Alias := '';
    Bracket := 0;
    List.Clear;
    repeat
      if (Bracket = 0) and ((Code = lcIdent) or (Code = lcNumber) or (St = '-')) then
        if OldSt = '.' then begin
          if (UpperCase(St) <> 'WORLD') or (Home.OCIVersion > 8100) then
            Alias := Alias + '.' + St
        end
        else
          Alias := Alias + St;

      OldSt := St;

      Code := Parser.GetNext(St);
      if St = '(' then
        Inc(Bracket)
      else
        if St = ')' then
          Dec(Bracket)
        else
          if ((St = '=') or (St = ',')) and (Bracket = 0) then begin
            List.Add(Alias);
            Alias := '';
          end;
    until Code = lcEnd;
  finally
    Parser.Free;
    F.Free;
  end;
end;

function TOraServerEnumerator.GetProp(Prop: integer; var Value: variant): boolean;
begin
  Result := True;
  case Prop of
    prHomeName:
      Value := FHomeName;
  else
    Result := inherited GetProp(Prop, Value);
  end;
end;

function TOraServerEnumerator.SetProp(Prop: integer; const Value: variant): boolean;
begin
  Result := True;
  case Prop of
    prDirect:
      FDirect := Value;
    prHomeName:
      FHomeName := Value;
    prTNSPath:
      FTNSPath := Value;
  else
    Result := inherited SetProp(Prop, Value);
  end;
end;

{ TCustomOraDumpProcessor }

function TCustomOraDumpProcessor.CreateQuery: TCustomDADataSet;
begin
  Result := GetConnection.CreateDataSet;
  Result.ReadOnly := True;
  Result.UniDirectional := True;
  Result.Options.QueryRecCount := True;
  TDBAccessUtils.CheckConnection(Result);
  TDBAccessUtils.GetIRecordSet(Result).SetProp(prFetchAll, False);
end;

end.

