{*********************************************************}
{                                                         }
{                 Zeos Database Objects                   }
{         Interbase Database Connectivity Classes         }
{                                                         }
{        Originally written by Sergey Merkuriev           }
{                                                         }
{*********************************************************}

{@********************************************************}
{    Copyright (c) 1999-2006 Zeos Development Group       }
{                                                         }
{ License Agreement:                                      }
{                                                         }
{ This library is distributed in the hope that it will be }
{ useful, but WITHOUT ANY WARRANTY; without even the      }
{ implied warranty of MERCHANTABILITY or FITNESS FOR      }
{ A PARTICULAR PURPOSE.  See the GNU Lesser General       }
{ Public License for more details.                        }
{                                                         }
{ The source code of the ZEOS Libraries and packages are  }
{ distributed under the Library GNU General Public        }
{ License (see the file COPYING / COPYING.ZEOS)           }
{ with the following  modification:                       }
{ As a special exception, the copyright holders of this   }
{ library give you permission to link this library with   }
{ independent modules to produce an executable,           }
{ regardless of the license terms of these independent    }
{ modules, and to copy and distribute the resulting       }
{ executable under terms of your choice, provided that    }
{ you also meet, for each linked independent module,      }
{ the terms and conditions of the license of that module. }
{ An independent module is a module which is not derived  }
{ from or based on this library. If you modify this       }
{ library, you may extend this exception to your version  }
{ of the library, but you are not obligated to do so.     }
{ If you do not wish to do so, delete this exception      }
{ statement from your version.                            }
{                                                         }
{                                                         }
{ The project web site is located on:                     }
{   http://zeos.firmos.at  (FORUM)                        }
{   http://zeosbugs.firmos.at (BUGTRACKER)                }
{   svn://zeos.firmos.at/zeos/trunk (SVN Repository)      }
{                                                         }
{   http://www.sourceforge.net/projects/zeoslib.          }
{   http://www.zeoslib.sourceforge.net                    }
{                                                         }
{                                                         }
{                                                         }
{                                 Zeos Development Group. }
{********************************************************@}

//code from ZDbcInterbase6Metadata;

unit fieldinfo;

interface

uses
  SysUtils, DBClient, ZConnection, ZDbcInterbase6;

function Filldatasetwithfieldsinfo(
     IBConnection: TZConnection; viewsystem: boolean;
     clDataset: TClientDataset; TableNamePattern: string; ColumnNamePattern: string): integer;

implementation

{$IFDEF VER210}
  {$DEFINE DELPHI12_UP}
{$ENDIF}

type
  TZWildcardsSet= set of Char;

  TZColumnNullableType = (ntNoNulls, ntNullable, ntNullableUnknown);

  TZSQLType = (stUnknown, stBoolean, stByte, stShort, stInteger, stLong, stFloat,
    stDouble, stBigDecimal, stString, stUnicodeString, stBytes, stDate, stTime,
    stTimestamp, stAsciiStream, stUnicodeStream, stBinaryStream);

const
  { SQL types definitions from RDB$FIELDS}
  RDB_VARCHAR = 37;
  RDB_VARCHAR2 = 38;
  RDB_CSTRING = 40;
  RDB_CSTRING2 = 41;
  RDB_CHAR = 14;
  RDB_CHAR2 = 15;
  RDB_D_FLOAT = 11;
  RDB_DOUBLE = 27;
  RDB_FLOAT = 10;
  RDB_INT64 = 16;
  RDB_QUAD = 9;
  RDB_BLOB_ID = 45;
  RDB_INTEGER = 8;
  RDB_SMALLINT = 7;
  RDB_DATE = 12;
  RDB_TIME = 13;
  RDB_TIMESTAMP = 35;
  RDB_BOOLEAN = 17;
  RDB_BLOB = 261;
  { SQL subtypes definitions from RDB$FIELDS}
  CS_NONE = 0;
  CS_BINARY = 1;
  CS_ASCII = 2;
  CS_UNICODE_FSS = 3;
  CS_METADATA = CS_UNICODE_FSS;

  RDB_BLOB_NONE = 0;
  RDB_BLOB_TEXT = 1;
  RDB_BLOB_BLR = 2;
  RDB_BLOB_ACL = 3;
  RDB_BLOB_RESERVED = 4;
  RDB_BLOB_ENCODED = 5;
  RDB_BLOB_DESCRIPTION = 6;

  //Dark Ninja
  RDB_BLOB_RANGES = 4;
  RDB_BLOB_SUMMARY = 5;
  RDB_BLOB_FORMAT = 6;
  RDB_BLOB_TRA = 7;
  RDB_BLOB_EXTFILE = 8;
  RDB_BLOB_DEBUG_INFO = 9;
  RDB_BLOB_MAX_PREDEFINED_SUBTYPE = 10;

  RDB_NUMBERS_NONE = 0;
  RDB_NUMBERS_NUMERIC = 1;
  RDB_NUMBERS_DECIMAL = 2;

var
  WildcardsArray: array of char; //Added by Cipto

//------------------------------------------------------------------------------

function GetSearchStringEscape: string;
begin
  //Result := '%';
  Result := '\';
end;

//------------------------------------------------------------------------------

function GetWildcardsSet:TZWildcardsSet;
var
  i: Integer;
begin

  try
    SetLength(WildcardsArray,2);
    WildcardsArray[0]:='_';
    WildcardsArray[1]:='%';
  except
    WildcardsArray:=nil;
  end;

  Result:=[];
  for i:=0 to High(WildcardsArray) do
    Result:=Result+[WildcardsArray[i]];
end;

//------------------------------------------------------------------------------

function HasNoWildcards(const Pattern: string): Boolean;
var
  I: Integer;
  PreviousChar: string[1];
  PreviousCharWasEscape: Boolean;
  EscapeChar: string;
  WildcardsSet: TZWildcardsSet;
begin
  Result := False;
  PreviousChar := '';
  PreviousCharWasEscape := False;
  EscapeChar := GetSearchStringEscape;
  WildcardsSet := GetWildcardsSet;
  for I := 1 to Length(Pattern) do
  begin
    if (not PreviousCharWasEscape) and (Pattern[I] in WildcardsSet) then
     Exit;

    PreviousCharWasEscape := (Pattern[I] = EscapeChar) and (PreviousChar <> EscapeChar);
    if (PreviousCharWasEscape) and (Pattern[I] = EscapeChar) then
      PreviousChar := ''
    else
      PreviousChar := Pattern[I];
  end;
  Result := True;
end;

//------------------------------------------------------------------------------

function StripEscape(const Pattern: string): string;
var
  I: Integer;
  PreviousChar: string[1];
  EscapeChar: string;
begin
  PreviousChar := '';
  Result := '';
  EscapeChar := GetSearchStringEscape;
  for I := 1 to Length(Pattern) do
  begin
    if (Pattern[i] <> EscapeChar) then
    begin
      Result := Result + Pattern[I];
      PreviousChar := Pattern[I];
    end
    else
    begin
      if (PreviousChar = EscapeChar) then
      begin
        Result := Result + Pattern[I];
        PreviousChar := '';
      end
      else
        PreviousChar := Pattern[i];
    end;
  end;
end;

//------------------------------------------------------------------------------

function ConstructNameCondition(Pattern, Column: string): string;
const
  Spaces = '';
var
  StrippedPattern: string;
begin
  if (Length(Pattern) > 2 * 31) then
    raise Exception.Create('SPattern2Long');

  if (Pattern = '%') or (Pattern = '') then
     Exit;

  if HasNoWildcards(Pattern) then
  begin
    StrippedPattern := StripEscape(Pattern);
    Result := Format('%s = ''%s''', [Column, StrippedPattern]);
  end
  else
  begin
    Result := Format('%s || ''%s'' like ''%s%s%%''',
      [Column, Spaces, Pattern, Spaces]);
  end;
end;

//------------------------------------------------------------------------------

{$IFDEF DELPHI12_UP}
{**
  Compares two PWideChars without stopping at #0 (Unicode Version)
  @param P1 first PWideChar
  @param P2 seconds PWideChar
  @return <code>True</code> if the memory at P1 and P2 are equal
}
function MemLCompUnicode(P1, P2: PWideChar; Len: Integer): Boolean;
begin
  while (Len > 0) and (P1^ = P2^) do
  begin
    Inc(P1);
    Inc(P2);
    Dec(Len);
  end;
  Result := Len = 0;
end;
{$ENDIF}

//------------------------------------------------------------------------------

function MemLCompAnsi(P1, P2: PAnsiChar; Len: Integer): Boolean;
begin
  while (Len > 0) and (P1^ = P2^) do
  begin
    Inc(P1);
    Inc(P2);
    Dec(Len);
  end;
  Result := Len = 0;
end;

//------------------------------------------------------------------------------

function StartsWith(const Str, SubStr: string): Boolean;
var
  LenSubStr: Integer;
begin
  LenSubStr := Length(SubStr);
  if SubStr = '' then
    Result := True
   else if LenSubStr <= Length(Str) then
    //Result := Copy(Str, 1, Length(SubStr)) = SubStr;
   {$IFDEF DELPHI12_UP}
   Result := MemLCompUnicode(PChar(Str), PChar(SubStr), LenSubStr)
   {$ELSE}
   Result := MemLCompAnsi(PChar(Str), PChar(SubStr), LenSubStr)
   {$ENDIF}
  else
    Result := False;
end;

//------------------------------------------------------------------------------

function ConvertInterbase6ToSqlType(SqlType, SqlSubType: Integer): TZSQLType;
begin
  Result := stUnknown;

  case SqlType of
    RDB_BOOLEAN: Result := stBoolean;
    RDB_VARCHAR2, RDB_VARCHAR, RDB_CSTRING, RDB_CSTRING2: Result := stString;
    RDB_CHAR, RDB_CHAR2:
      begin
        case SqlSubType of
          CS_NONE: Result := stString;
          CS_BINARY: Result := stBytes;
          CS_ASCII: Result := stString;
          CS_UNICODE_FSS: Result := stUnicodeString;
        else
          // Bug 1177394: Bug using View
          Result := stString;
        end;
      end;
    RDB_D_FLOAT: Result := stDouble;
    RDB_DOUBLE: Result := stDouble;
    RDB_FLOAT: Result := stDouble;
    RDB_BLOB_ID, RDB_QUAD: Result := stLong;
    RDB_INT64:
      begin
        case SqlSubType of
          RDB_NUMBERS_NONE: Result := stLong;
          RDB_NUMBERS_NUMERIC: Result := stDouble;
          RDB_NUMBERS_DECIMAL: Result := stBigDecimal;
        end;
      end;
    RDB_INTEGER:
      begin
        case SqlSubType of
          RDB_NUMBERS_NONE: Result := stInteger;
          RDB_NUMBERS_NUMERIC: Result := stDouble;
          RDB_NUMBERS_DECIMAL: Result := stBigDecimal;
        end;
      end;
    RDB_SMALLINT:
      begin
        case SqlSubType of
          RDB_NUMBERS_NONE: Result := stShort;
          RDB_NUMBERS_NUMERIC: Result := stDouble;
          RDB_NUMBERS_DECIMAL: Result := stDouble;
        end;
      end;
    RDB_DATE: Result := stDate;
    RDB_TIME: Result := stTime;
    RDB_TIMESTAMP: Result := stTimestamp;
    RDB_BLOB:
      begin
       case SqlSubType of
          RDB_BLOB_NONE: Result := stBinaryStream;
          RDB_BLOB_TEXT: Result := stAsciiStream;
          RDB_BLOB_BLR: Result := stBinaryStream;
          RDB_BLOB_ACL: Result := stAsciiStream;
          RDB_BLOB_RESERVED: Result := stUnknown;
          RDB_BLOB_ENCODED: Result := stAsciiStream;
          RDB_BLOB_DESCRIPTION: Result := stAsciiStream;
          //Dark Ninja
          RDB_BLOB_TRA: Result := stBinaryStream;
          RDB_BLOB_EXTFILE: Result := stBinaryStream;
          RDB_BLOB_DEBUG_INFO: Result := stBinaryStream;
        end;
      end;
    else
      Result := stUnknown;
  end;
end;

//------------------------------------------------------------------------------

function Filldatasetwithfieldsinfo(
     IBConnection: TZConnection; viewsystem: boolean;
     clDataset: TClientDataset; TableNamePattern: string; ColumnNamePattern: string): integer;
var
  SQL, Where, DefaultValue, ColumnName: string;
  TypeName, SubTypeName, FieldScale: integer;
  LTableNamePattern, LColumnNamePattern: string;
  ColumnIndexes : Array[1..16] of integer;
begin
  LTableNamePattern := ConstructNameCondition(TableNamePattern, 'a.RDB$RELATION_NAME');
  LColumnNamePattern := ConstructNameCondition(ColumnNamePattern, 'a.RDB$FIELD_NAME');

  Result := 0;

  SQL := ' SELECT'
    + ' e.RDB$LOWER_BOUND,'
    + ' e.RDB$UPPER_BOUND,'
    + ' a.RDB$RELATION_NAME, a.RDB$FIELD_NAME, a.RDB$FIELD_POSITION,'
    + ' a.RDB$NULL_FLAG, a.RDB$DEFAULT_VALUE, b. RDB$FIELD_LENGTH,'
    + ' b.RDB$FIELD_SCALE, c.RDB$TYPE_NAME, b.RDB$FIELD_TYPE,'
    + ' b.RDB$FIELD_SUB_TYPE, b.RDB$DESCRIPTION, b.RDB$CHARACTER_LENGTH,'
    + ' b.RDB$FIELD_PRECISION, a.RDB$DEFAULT_SOURCE, b.RDB$DEFAULT_SOURCE'
    + ' as RDB$DEFAULT_SOURCE_DOMAIN,b.RDB$COMPUTED_SOURCE as RDB$COMPUTED_SOURCE'
    + ' FROM RDB$RELATION_FIELDS a'
    + ' JOIN RDB$FIELDS b ON (b.RDB$FIELD_NAME = a.RDB$FIELD_SOURCE)'
    + ' LEFT JOIN RDB$FIELD_DIMENSIONS e ON (e.RDB$FIELD_NAME = a.RDB$FIELD_SOURCE)'
    + ' LEFT JOIN RDB$TYPES c ON (b.RDB$FIELD_TYPE = c.RDB$TYPE'
    + ' and c.RDB$FIELD_NAME = ''RDB$FIELD_TYPE'')';

  Where := LTableNamePattern;
  if LColumnNamePattern <> '' then
  begin
    if Where = '' then
      Where := LColumnNamePattern
    else
      Where := Where + ' AND ' + LColumnNamePattern;
  end;
  if Not viewsystem then
  begin
    if Where = '' then
      Where := ' ( (RDB$SYSTEM_FLAG=0) or (RDB$SYSTEM_FLAG IS NULL) ) '
    else
      Where := Where + ' AND ( (RDB$SYSTEM_FLAG=0) or (RDB$SYSTEM_FLAG IS NULL) ) ';
  end;
  if Where <> '' then
    Where := ' WHERE ' + Where;

  SQL := SQL + Where + ' ORDER BY a.RDB$RELATION_NAME, a.RDB$FIELD_POSITION';

  with IBConnection.DbcConnection.CreateStatement.ExecuteQuery(SQL) do
  begin
    ColumnIndexes[1] := FindColumn('RDB$FIELD_TYPE');
    ColumnIndexes[2] := FindColumn('RDB$FIELD_SUB_TYPE');
    ColumnIndexes[3] := FindColumn('RDB$FIELD_SCALE');
    ColumnIndexes[4] := FindColumn('RDB$FIELD_NAME');
    ColumnIndexes[5] := FindColumn('RDB$DEFAULT_SOURCE');
    ColumnIndexes[6] := FindColumn('RDB$DEFAULT_SOURCE_DOMAIN');
    ColumnIndexes[7] := FindColumn('RDB$RELATION_NAME');
    ColumnIndexes[8] := FindColumn('RDB$TYPE_NAME');
    ColumnIndexes[9] := FindColumn('RDB$FIELD_PRECISION');
    ColumnIndexes[10] := FindColumn('RDB$FIELD_LENGTH');
    ColumnIndexes[11] := FindColumn('RDB$NULL_FLAG');
    ColumnIndexes[12] := FindColumn('RDB$DESCRIPTION');
    ColumnIndexes[13] := FindColumn('RDB$FIELD_POSITION');
    ColumnIndexes[14] := FindColumn('RDB$COMPUTED_SOURCE');
    ColumnIndexes[15] := FindColumn('RDB$LOWER_BOUND');  //Dark Ninja
    ColumnIndexes[16] := FindColumn('RDB$UPPER_BOUND');
    While NEXT do
    begin
      clDataset.Append;
      try
        TypeName := GetInt(ColumnIndexes[1]);
        SubTypeName := GetInt(ColumnIndexes[2]);
        FieldScale := GetInt(ColumnIndexes[3]);
        ColumnName := GetString(ColumnIndexes[4]);

        if (GetString(ColumnIndexes[14]) <> '') then  //AVZ -- not isNull(14) was not working correcly here could be ' ' - subselect
        begin //Computed by Source  & Sub Selects  //AVZ
          if ((TypeName = 16) and (FieldScale < 0)) then SubTypeName := 1; // Fix for 0 subtype which removes decimals
        end;

        DefaultValue := GetString(ColumnIndexes[5]);
        if DefaultValue = '' then
          DefaultValue := GetString(ColumnIndexes[6]);
        if StartsWith(Trim(UpperCase(DefaultValue)), 'DEFAULT') then
        begin
          DefaultValue := Trim(StringReplace(DefaultValue, 'DEFAULT ', '', [rfIgnoreCase]));
        end;

        IF (UpperCase(DefaultValue)= '''NOW''') or (UpperCase(DefaultValue)= '"NOW"')then
          case TypeName of
          12: DefaultValue := 'CURRENT_DATE';
          13: DefaultValue := 'CURRENT_TIME';
          35: DefaultValue := 'CURRENT_TIMESTAMP';
          else begin end;
          end;

        ClDataSet.FieldByName('TABLE_CAT').Value := '';
        ClDataSet.FieldByName('TABLE_SCHEM').Value := '';
        ClDataSet.FieldByName('TABLE_NAME').Value := GetString(ColumnIndexes[7]);
        ClDataSet.FieldByName('COLUMN_NAME').Value := ColumnName;
        ClDataSet.FieldByName('DATA_TYPE').Value := Ord(ConvertInterbase6ToSqlType(TypeName, SubTypeName));

        // TYPE_NAME
        case TypeName of
          7  : ClDataSet.FieldByName('TYPE_NAME').Value := 'SMALLINT';
          8  : ClDataSet.FieldByName('TYPE_NAME').Value := 'INTEGER';
          16 :
            begin
              if (SubTypeName = 0) then
                ClDataSet.FieldByName('TYPE_NAME').Value := GetString(ColumnIndexes[8]);
              if (SubTypeName = 1) then
                ClDataSet.FieldByName('TYPE_NAME').Value := 'NUMERIC';
              if (SubTypeName = 2) then
                ClDataSet.FieldByName('TYPE_NAME').Value := 'DECIMAL';
            end;
          37 : ClDataSet.FieldByName('TYPE_NAME').Value := 'VARCHAR'; // Instead of VARYING
          else
            ClDataSet.FieldByName('TYPE_NAME').Value := GetString(ColumnIndexes[8]);
        end;

        // COLUMN_SIZE.
        case TypeName of
          7, 8 : ClDataSet.FieldByName('COLUMN_SIZE').Value := 0;
          16   : ClDataSet.FieldByName('COLUMN_SIZE').Value := GetInt(ColumnIndexes[9]);
        else
          ClDataSet.FieldByName('COLUMN_SIZE').Value := GetInt(ColumnIndexes[10]);
        end;

        ClDataSet.FieldByName('BUFFER_LENGTH').Value := '';

        if FieldScale < 0 then
          ClDataSet.FieldByName('DECIMAL_DIGITS').Value := -1 * FieldScale
        else
          ClDataSet.FieldByName('DECIMAL_DIGITS').Value := 0;

        ClDataSet.FieldByName('NUM_PREC_RADIX').Value := 10;

        if GetInt(ColumnIndexes[11]) <> 0 then
          ClDataSet.FieldByName('NULLABLE').Value := Ord(ntNoNulls)
        else
          ClDataSet.FieldByName('NULLABLE').Value := Ord(ntNullable);

        ClDataSet.FieldByName('REMARKS').Value := Copy(GetString(ColumnIndexes[12]),1,255);

        ClDataSet.FieldByName('COLUMN_DEF').Value := DefaultValue;

        ClDataSet.FieldByName('SQL_DATA_TYPE').Value := '';
        ClDataSet.FieldByName('SQL_DATETIME_SUB').Value := '';

        ClDataSet.FieldByName('CHAR_OCTET_LENGTH').Value := GetInt(7);
        ClDataSet.FieldByName('ORDINAL_POSITION').Value := GetInt(ColumnIndexes[13]) + 1;

        if IsNull(ColumnIndexes[11]) then
          ClDataSet.FieldByName('IS_NULLABLE').Value := 'YES'
        else
          ClDataSet.FieldByName('IS_NULLABLE').Value := 'NO';

        ClDataSet.FieldByName('AUTO_INCREMENT').Value := '';

        if CompareStr(ColumnName, UpperCase(ColumnName)) = 0 then
          ClDataSet.FieldByName('CASE_SENSITIVE').Value := False
        else
          ClDataSet.FieldByName('CASE_SENSITIVE').Value := True;

        ClDataSet.FieldByName('SEARCHABLE').Value := True;

        if isNull(ColumnIndexes[14]) then
          begin
            ClDataSet.FieldByName('WRITABLE').Value := True;
            ClDataSet.FieldByName('DEFINITELYWRITABLE').Value := True;
            ClDataSet.FieldByName('READONLY').Value := False;
          end
        else
          begin
            ClDataSet.FieldByName('WRITABLE').Value := False;
            ClDataSet.FieldByName('DEFINITELYWRITABLE').Value := False;
            ClDataSet.FieldByName('READONLY').Value := True;
          end;

        ClDataSet.FieldByName('DATA_SUBTYPE').Value := SubTypeName;

        ClDataSet.FieldByName('TYPE_ORIGINNAME').Value := GetString(ColumnIndexes[8]);

        ClDataSet.FieldByName('LOWER_BOUND').Value := GetInt(ColumnIndexes[15]);
        ClDataSet.FieldByName('UPPER_BOUND').Value := GetInt(ColumnIndexes[16]);

        clDataset.post;
      except
        clDataset.cancel;
        raise;
      end;
    end;
  end;
end;


end.

