Эмуляция LINQ for SQL на Delphi

Постановка задачи.
Имеется большой Клиент-Сервер проект. Клиент программно строит динамические SQL запросы для выполнения на SQL сервере. Запросов много, логика построения размазана по всему клиентскому коду. Проект развивается во времени, необходимо модифицировать структуру базы данных. Как заставить компилятор показать все места, где в коде используются уже не существующие поля? Как заставить компилятор проверить, что целочисленному полю не присваивается строковый параметр? При этом паскалевский код должен быть приближен к SQL синтаксису.

Пример.
Допустим имеем базу данных в которой присутствуют две таблицы:

CREATE TABLE PERSON (
    ID          INTEGER NOT NULL,
    SURNAME VARCHAR(100) NOT NULL,
    EMPLOYMENT  INTEGER,
    MOTHER      INTEGER,
    FATHER      INTEGER
);

CREATE TABLE EMPLOYMENT (
    ID           INTEGER NOT NULL,
    DESCRIPTION  VARCHAR(100) NOT NULL
);

Очень хочем сгенерировать SQL запрос на паскале (не стоит в нём искать логику):

select  P.ID,P.SURNAME 
from Person P,Person F,Employment E 
where P.FATHER=F.ID 
  and P.EMPLOYMENT=E.ID 
  and (F.SURNAME<>P.SURNAME or E.Description='U.S. President') 
  and P.MOTHER<>20

Решение.
Тестировалось на Delphi 2007. Предлагаю использовать такой синтаксис для построения SQL запроса:

function GetTestSql: String;
var
  aBulder: TSuperBaseSqlBulder;
  P: TPersonTable;
  F: TPersonTable;
  E: TEmploymentTable;
begin
  aBulder := TSuperBaseSqlBulder.Create;
  try
    P := aBulder.AddPersonTable('P');
    F := aBulder.AddPersonTable('F');
    E := aBulder.AddEmploymentTable('E');
    Result :=
      (
        (P.Father = F.ID)
        and (P.Employment = E.ID)
        and ( (F.Surname <> P.Surname) or (E.Description = 'U.S. President') )
        and (P.Mother <> 20)
      ).Select([P.ID, P.Surname]);
  finally
    aBulder.Free;
  end;
end;

Как видно синтаксис после «Result :=» очень похож на LINQ. Компилятор проверит наличие колонок, отловит ошибки несовместимости типов. Т.е. не пропустит что-нибудь из:

E.UnknownFiled = 1      // несуществующая колонка
E.Description = E.ID    // несоответствие типов колонок
P.Mother = 'Miss World' // несоответствие типа аргумента

Ради чего всё и затевалось. Теперь давайте уговаривать компилятор переварить GetTestSql. Для начала нам надо объяснить компилятору структуру нашей базы. В будущем вы напишете програмку, которая просматривая структуру БД, сгенерирует в нашем случае такое:

uses
  UKSqlBulder;

type
  TPersonTable = class(TSqlTable)
    property ID: TCondField_Integer          index 0 read GetCondFields_Integer;
    property Surname: TCondField_String      index 1 read GetCondFields_String;
    property Employment: TCondField_Integer  index 2 read GetCondFields_Integer;
    property Mother: TCondField_Integer      index 3 read GetCondFields_Integer;
    property Father: TCondField_Integer      index 4 read GetCondFields_Integer;
  end;

  TEmploymentTable = class(TSqlTable)
    property ID: TCondField_Integer          index 0 read GetCondFields_Integer;
    property Description: TCondField_String  index 1 read GetCondFields_String;
  end;

  TSuperBaseSqlBulder = class(TSqlBulder)
    function AddPersonTable(const aAlias: String = ''): TPersonTable;
    function AddEmploymentTable(const aAlias: String = ''): TEmploymentTable;
  end;

implementation

{ TSuperBaseSqlBulder }

function TSuperBaseSqlBulder.AddPersonTable(const aAlias: String = ''): TPersonTable;
begin
  Result := TPersonTable.Create;
  Result.Name := 'Person';
  Result.Alias := aAlias;
  Result.Add(TSqlField_Integer.Create('ID'));
  Result.Add(TSqlField_String.Create('SURNAME'));
  Result.Add(TSqlField_Integer.Create('EMPLOYMENT'));
  Result.Add(TSqlField_Integer.Create('MOTHER'));
  Result.Add(TSqlField_Integer.Create('FATHER'));
  Add(Result);
end;

function TSuperBaseSqlBulder.AddEmploymentTable(const aAlias: String = ''): TEmploymentTable;
begin
  Result := TEmploymentTable.Create;
  Result.Name := 'Employment';
  Result.Alias := aAlias;
  Result.Add(TSqlField_Integer.Create('ID'));
  Result.Add(TSqlField_String.Create('Description'));
  Add(Result);
end;

И наконец, исходный код UKSqlBulder:

unit UKSqlBulder;

interface

uses
  Contnrs;

type
  TSqlBulder = class;
  TSqlTable = class;
  TSqlField = class;
  TSqlField_Integer = class;
  TSqlField_String = class;

  TRCondition = record
  private
    AsSql: String;
  public
    class operator LogicalAnd(const A, B: TRCondition): TRCondition;
    class operator LogicalOr(const A, B: TRCondition): TRCondition;
    function Select(const aFields: array of TSqlField): String;
  end;
  TCondField_Integer = record
    Field: TSqlField_Integer;
    class operator Equal(const A, B: TCondField_Integer): TRCondition;
    class operator NotEqual(const A, B: TCondField_Integer): TRCondition;
    class operator Equal(const A: TCondField_Integer; const aArg: Integer): TRCondition;
    class operator NotEqual(const A: TCondField_Integer; const aArg: Integer): TRCondition;

    class operator Implicit(A: TCondField_Integer): TSqlField;
  end;

  TCondField_String = record
    Field: TSqlField_String;
    class operator Equal(const A, B: TCondField_String): TRCondition;
    class operator NotEqual(const A, B: TCondField_String): TRCondition;
    class operator Equal(const A: TCondField_String; const aArg: String): TRCondition;
    class operator NotEqual(const A: TCondField_String; const aArg: String): TRCondition;

    class operator Implicit(A: TCondField_String): TSqlField;
  end;

  TSqlBulder = class(TObjectList)
  private
    function GetTables(aIndex: Integer): TSqlTable;
  protected
    procedure Add(aTable: TSqlTable);
  public
    property Tables[aIndex: Integer]: TSqlTable read GetTables; default;
  end;

  TSqlField = class
    Table: TSqlTable;
    Name: String;
    function FullName: String;
    constructor Create(const aName: String);
  end;

  TSqlField_Integer = class(TSqlField)
  end;
  TSqlField_String = class(TSqlField)
    // MaxLength: Integer; not used
  end;

  TSqlTable = class(TObjectList)
  private
    Bulder: TSqlBulder;
    function GetFields(aIndex: Integer): TSqlField;
  protected
    Alias: String;
    Name: String;
    function GetCondFields_Integer(aIndex: Integer): TCondField_Integer;
    function GetCondFields_String(aIndex: Integer): TCondField_String;
    procedure Add(aField: TSqlField);
  public
    property Fields[aIndex: Integer]: TSqlField read GetFields; default;
  end;

implementation

uses
  SysUtils;

{ TSqlTable }

procedure TSqlTable.Add(aField: TSqlField);
begin
  inherited Add(aField);
  aField.Table := self;
end;

function TSqlTable.GetFields(aIndex: Integer): TSqlField;
begin
  Result := TSqlField(inherited Items[aIndex]);
end;

function TSqlTable.GetCondFields_Integer(aIndex: Integer): TCondField_Integer;
begin
  Result.Field := Fields[aIndex] as TSqlField_Integer;
end;

function TSqlTable.GetCondFields_String(aIndex: Integer): TCondField_String;
begin
  Result.Field := Fields[aIndex] as TSqlField_String;
end;

{ TSqlField }

constructor TSqlField.Create(const aName: String);
begin
  inherited Create;
  Name := aName;
end;

function TSqlField.FullName: String;
begin
  Result := Table.Alias + '.' + Name;
end;

{ TCondField_Integer }

class operator TCondField_Integer.Implicit(A: TCondField_Integer): TSqlField;
begin
  Result := A.Field;
end;

class operator TCondField_Integer.Equal(const A, B: TCondField_Integer): TRCondition;
begin
  Result.AsSql := A.Field.FullName + '=' + B.Field.FullName;
end;

class operator TCondField_Integer.NotEqual(const A, B: TCondField_Integer): TRCondition;
begin
  Result.AsSql := A.Field.FullName + '<>' + B.Field.FullName;
end;

class operator TCondField_Integer.Equal(const A: TCondField_Integer; const aArg: Integer): TRCondition;
begin
  Result.AsSql := A.Field.FullName + '=' + IntToStr(aArg);
end;

class operator TCondField_Integer.NotEqual(const A: TCondField_Integer; const aArg: Integer): TRCondition;
begin
  Result.AsSql := A.Field.FullName + '<>' + IntToStr(aArg);
end;

{ TCondField_String }

class operator TCondField_String.Implicit(A: TCondField_String): TSqlField;
begin
  Result := A.Field;
end;

class operator TCondField_String.Equal(const A, B: TCondField_String): TRCondition;
begin
  Result.AsSql := A.Field.FullName + '=' + B.Field.FullName;
end;

class operator TCondField_String.NotEqual(const A, B: TCondField_String): TRCondition;
begin
  Result.AsSql := A.Field.FullName + '<>' + B.Field.FullName;
end;

class operator TCondField_String.Equal(const A: TCondField_String; const aArg: String): TRCondition;
begin
  Result.AsSql := A.Field.FullName + '=''' + aArg + '''';
end;

class operator TCondField_String.NotEqual(const A: TCondField_String; const aArg: String): TRCondition;
begin
  Result.AsSql := A.Field.FullName + '<>''' + aArg + '''';
end;

{ TRCondition }

function TRCondition.Select(const aFields: array of TSqlField): String;
var
  i: Integer;
  aSelect, aFrom: String;
  aBulder: TSqlBulder;
  aTable: TSqlTable;
begin
  if Length(aFields) <= 0 then
    raise Exception.Create('Invalid argument');

  aBulder := aFields[0].Table.Bulder;
  aFrom := '';
  for i := 0 to aBulder.Count - 1 do
  begin
    aTable := aBulder[i];
    aFrom := aFrom + aTable.Name + ' ' + aTable.Alias + ',';
  end;
  aFrom[Length(aFrom)] := ' ';

  aSelect := '';
  for i := 0 to Length(aFields) - 1 do
  begin
    aSelect := aSelect + aFields[i].FullName + ',';
  end;
  aSelect[Length(aSelect)] := ' ';

  Result := Format('select %sfrom %swhere %s', [aSelect, aFrom, AsSql]);
end;

class operator TRCondition.LogicalAnd(const A, B: TRCondition): TRCondition;
begin
  Result.AsSql := A.AsSql + ' and ' + B.AsSql;
end;

class operator TRCondition.LogicalOr(const A, B: TRCondition): TRCondition;
begin
  Result.AsSql := '(' + A.AsSql + ' or ' + B.AsSql + ')';
end;

{ TSqlBulder }

procedure TSqlBulder.Add(aTable: TSqlTable);
var
  aPrefix: String;
begin
  if aTable.Alias = '' then
  begin
    if Count > 0 then
      aPrefix := 'T' + IntToStr(Count + 1) + '_'
    else
      aPrefix := 'T_';
    aTable.Alias := aPrefix + aTable.Name;
  end;
  aTable.Bulder := self;
  inherited Add(aTable);
end;

function TSqlBulder.GetTables(aIndex: Integer): TSqlTable;
begin
  Result := TSqlTable(inherited Items[aIndex]);
end;

end.