zsqlscript.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{              Sql-script forming routines               }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2001 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZSqlScript;

interface

uses Classes, ZSqlTypes;

{***************** Sql Forming Routines **************}

{ Show all tables }
function ShowTables(System: Boolean; DatabaseType: TDatabaseType): string;

{ Show table columns }
function ShowColumns(TableName: string; DatabaseType: TDatabaseType): string;

{ Show table indices }
function ShowIndex(TableName: string; DatabaseType: TDatabaseType): string;

{**************** Sql Parsing Routines ***************}

{ Skip spaces }
function SkipSpaces(var Buffer: string): Boolean;

{ Skip all white spaces }
function SkipWhite(var Buffer: string): Boolean;

{ Skip rest line }
function SkipLine(var Buffer: string): Boolean;

{ Skip rest chars till comment delimiter }
function SkipRest(var Buffer: string; Delim: string): Boolean;

{ Skip comments }
function SkipComment(var Buffer: string; DatabaseType: TDatabaseType): Boolean;

{ Skip term char }
function SkipTerm(var Buffer: string; Term: string;
  DatabaseType: TDatabaseType): Boolean;

{ Extract Sql Token }
function SqlToken(var Buffer: string; Term: string;
  DatabaseType: TDatabaseType): string;

{ Extract Sql Token which skips NL CR symbols }
function SqlTokenEx(var Buffer: string; Term: string;
  DatabaseType: TDatabaseType): string;

{ Check if sql start with command }
function SqlStartWith(Buffer, Value, Term: string;
  DatabaseType: TDatabaseType): Boolean;

{ Check if command at begin }
function CmdStartWith(Buffer, Value: string): Boolean;

{************* Sql form routines ***************}

{ Extract sql query }
function ExtractSqlQuery(var Buffer: string; Term: string;
  DatabaseType: TDatabaseType): string;

{ Check a reserved sql word }
function CheckKeyword(DatabaseType: TDatabaseType; Value: string): Boolean;

{ Extract from sql query select and from parts }
function SplitSelect(Sql: string; DatabaseType: TDatabaseType;
  var Select, From: string): Boolean;

{ Define position of sql parts }
function DefineSqlPos(Sql: string; DatabaseType: TDatabaseType;
  var SelectStartPos, WhereStartPos, WherePos, OrderPos: Integer): Boolean;

{ Compose sql statement }
function ComposeSelect(Sql, WhereAdd, OrderAdd: string;
  WhereStartPos, WherePos, OrderPos: Integer): string;

{ Define table names in SELECT query }
procedure ExtractTables(From: string; Tables, Aliases: TStrings);

implementation

uses ZToken, ZExtra, ZSqlExtra, SysUtils;

{***************** Additional Routines **************************}

function DeleteSqlQuotes(Value: string): string;
begin
  DeleteQuotes(Value);
  if (Value <> '') and (Value[1] = '[') then
    Delete(Value, 1, 1);
  if (Value <> '') and (Value[Length(Value)] = ']') then
    Delete(Value, Length(Value), 1);
  Result := Value;
end;

{******************** Sql Forming Routines ******************}

{ Show all tables }
function ShowTables(System: Boolean; DatabaseType: TDatabaseType): string;
begin
  Result := '';
  case DatabaseType of
    dtMySql:
      if System then
        Result := 'SHOW TABLES FROM mysql'
      else
        Result := 'SHOW TABLES';
    dtPostgreSql:
      if System then
        Result := 'SELECT relname AS TableName FROM pg_class WHERE'
          +' relkind = ''r'' AND relname ~''^pg_'''
      else
        Result := 'SELECT relname AS TableName FROM pg_class WHERE'
          +' relkind = ''r'' AND relname !~''^pg_''';
    dtInterbase:
      if System then
        Result := 'SELECT RDB$RELATION_NAME AS TableName'
          +' FROM RDB$RELATIONS WHERE RDB$RELATION_NAME LIKE ''RDB$%'''
          +' ORDER BY RDB$RELATION_NAME'
      else
        Result := 'SELECT RDB$RELATION_NAME AS TableName'
          +' FROM RDB$RELATIONS WHERE RDB$RELATION_NAME NOT LIKE ''RDB$%'''
          +' ORDER BY RDB$RELATION_NAME';
    dtMsSql:
      if System then
        Result := 'SELECT o.name FROM sysobjects o, sysindexes i'
          + ' WHERE o.sysstat & 0xf <> 3 AND i.id = o.id AND i.indid < 2'
          + ' AND o.name NOT LIKE ''#%'' ORDER BY o.name'
      else
        Result := 'SELECT o.name FROM sysobjects o, sysindexes i'
          + ' WHERE o.sysstat & 0xf = 3 AND i.id = o.id AND i.indid < 2'
          + ' AND o.name NOT LIKE ''#%'' ORDER BY o.name';
  end;
end;

{ Show table columns }
function ShowColumns(TableName: string; DatabaseType: TDatabaseType): string;
begin
  Result := '';
  case DatabaseType of
    dtMySql: Result := 'SHOW COLUMNS FROM '+TableName;
    dtPostgreSql: Result := 'SELECT attname AS field,'
      +' typname AS type, atttypmod-4 as length, NOT attnotnull AS "null",'
      +' adsrc AS def FROM pg_attribute, pg_class, pg_type, pg_attrdef WHERE'
      +' pg_class.oid=attrelid AND pg_type.oid=atttypid AND attnum>0'
      +' AND pg_class.oid=adrelid AND adnum=attnum AND atthasdef=''t'''
      +' AND relname='''+LowerCase(TableName)+''''
      +' UNION SELECT attname AS field,'
      +' typname AS type, atttypmod-4 as length, NOT attnotnull AS "null",'
      +' '''' AS def FROM pg_attribute, pg_class, pg_type WHERE'
      +' pg_class.oid=attrelid AND pg_type.oid=atttypid AND attnum>0'
      +' AND atthasdef=''f'' AND relname='''+TableName+'''';
    dtInterbase: Result := 'SELECT A.RDB$FIELD_NAME AS Fld,'
      +' C.RDB$TYPE_NAME AS Typ, B.RDB$FIELD_LENGTH AS Len,'
      +' A.RDB$NULL_FLAG AS N_Nul, A.RDB$DEFAULT_SOURCE AS Def,'
      +' -B.RDB$FIELD_SCALE AS Scale'
      +' FROM RDB$RELATION_FIELDS A LEFT JOIN RDB$FIELDS B'
      +' ON A.RDB$FIELD_SOURCE=B.RDB$FIELD_NAME LEFT JOIN RDB$TYPES C'
      +' ON B.RDB$FIELD_TYPE=C.RDB$TYPE WHERE'
      +' A.RDB$RELATION_NAME='''+TableName+''''
      +' AND C.RDB$FIELD_NAME=''RDB$FIELD_TYPE'''
      +' ORDER BY RDB$FIELD_POSITION';
    dtMsSql: Result := 'EXEC sp_mshelpcolumns '''+TableName+'''';
  end;
end;

{ Show table indices }
function ShowIndex(TableName: string; DatabaseType: TDatabaseType): string;
begin
  Result := '';
  case DatabaseType of
    dtMySql: Result := 'SHOW INDEX FROM '+TableName;
    dtPostgreSql: Result := 'SELECT t1.relname AS name, t2.relname AS table,'
      +' indisunique AS "unique", indkey AS fields'
      +' FROM pg_index AS i, pg_class AS t1, pg_class AS t2 WHERE'
      +' i.indexrelid=t1.oid AND i.indrelid=t2.oid'
      +' AND t2.relname='''+TableName+'''';
    dtInterbase: Result := 'SELECT A.RDB$INDEX_NAME AS Name, RDB$RELATION_NAME'
      +' AS Tbl, RDB$UNIQUE_FLAG AS Uni, RDB$INDEX_TYPE AS Srt, RDB$FIELD_NAME AS Fld'
      +' FROM RDB$INDICES A LEFT JOIN RDB$INDEX_SEGMENTS B'
      +' ON A.RDB$INDEX_NAME=B.RDB$INDEX_NAME WHERE'
      +' RDB$RELATION_NAME LIKE '''+TableName+' %''';
    dtMsSql: Result := 'EXEC sp_helpindex '''+TableName+'''';
  end;
end;

{******************** Sql Parsing Routines *******************}

{ Skip spaces }
function SkipSpaces(var Buffer: string): Boolean;
var
  Ptr: PChar;
begin
  Ptr := PChar(Buffer);
  Result := False;
  while Ptr^ <> #0 do
  begin
    if not (Ptr^ in [' ',#9]) then
      Break;
    Inc(Ptr);
    Result := True;
  end;
  Buffer := StrPas(Ptr);
end;

{ Skip white }
function SkipWhite(var Buffer: string): Boolean;
var
  Ptr: PChar;
begin
  Ptr := PChar(Buffer);
  Result := False;
  while Ptr^ <> #0 do
  begin
    if not (Ptr^ in [' ',#9,#10,#13]) then
      Break;
    Inc(Ptr);
    Result := True;
  end;
  Buffer := StrPas(Ptr);
end;

{ Skip rest line }
function SkipLine(var Buffer: string): Boolean;
var
  N: Integer;
begin
  N := Pos(#10, Buffer);
  if N > 0 then
    Buffer := Copy(Buffer, N+1, Length(Buffer)-N)
  else begin
    N := Pos(#13, Buffer);
    if N > 0 then
      Buffer := Copy(Buffer, N+1, Length(Buffer)-N)
    else
      Buffer := '';
  end;
  Result := True;
end;

{ Skip rest chars till comment delimiter }
function SkipRest(var Buffer: string; Delim: string): Boolean;
var
  N: Integer;
begin
  N := Pos(Delim, Buffer) + Length(Delim) - 1;
  if N > 0 then
    Buffer := Copy(Buffer, N+1, Length(Buffer)-N)
  else
    Buffer := '';
  Result := True;
end;

{ Skip comments }
function SkipComment(var Buffer: string; DatabaseType: TDatabaseType): Boolean;
var
  Skip: Boolean;
begin
  Result := False;
  repeat
    Result := SkipSpaces(Buffer) or Result;
    Skip := False;
    if DatabaseType = dtMySql then
    begin
      if StrCmpBegin(Buffer, '#') then
        Skip := SkipLine(Buffer);
    end;
    if DatabaseType = dtInterbase then
    begin
      if StrCmpBegin(Buffer, '//') then
        Skip := SkipLine(Buffer);
      if StrCmpBegin(Buffer, '/*') then
        Skip := SkipRest(Buffer, '*/');
    end;
    if DatabaseType = dtPostgreSql then
    begin
      if StrCmpBegin(Buffer, '--') then
        Skip := SkipLine(Buffer);
      if StrCmpBegin(Buffer, '/*') then
        Skip := SkipRest(Buffer, '*/');
    end;
    Result := Result or Skip;
  until not Skip;
end;

{ Skip term char }
function SkipTerm(var Buffer: string; Term: string;
  DatabaseType: TDatabaseType): Boolean;
begin
  SkipComment(Buffer, DatabaseType);
  SkipSpaces(Buffer);
  Result := StrCmpBegin(Buffer, Term);
  if Result then
    Buffer := Copy(Buffer, Length(Term)+1, Length(Buffer) - Length(Term));
  Result := Result or (Buffer = '');
end;

{ Extract Sql Token }
function SqlToken(var Buffer: string; Term: string;
  DatabaseType: TDatabaseType): string;
var
  Temp: string;
  N, M: Integer;
begin
  Result := '';
  SkipComment(Buffer, DatabaseType);
  if not StrCmpBegin(Buffer, Term) and (Buffer <> '') then
  begin
    N := 0;
    M := 0;
    repeat
      if (Buffer <> '') and (Buffer[1] in [' ', #9]) then
        Result := Result + ' ';
      ExtractLowToken(Buffer, Temp);
      Result := Result + Temp;
      if Temp = '(' then Inc(N);
      if Temp = ')' then Dec(N);
      if Temp = '[' then Inc(M);
      if Temp = ']' then Dec(M);
    until ((N <= 0) and (M <= 0)) or (Buffer = '');
  end;
end;

{ Extract Sql Token which skips NL CR symbols }
function SqlTokenEx(var Buffer: string; Term: string;
  DatabaseType: TDatabaseType): string;