{
  单元名： ScAutoUpdateUnit
  作者：   张引
  时间：   2003/12/29
  作用：   升级ACCESS数据库文件

  限制：   1.只能添加字段，修改字段类型，大小（字符串类型），不能删除字段
           2.只支持如下字段：
             ftString, ftSmallint, ftInteger, ftBoolean, ftSingle, ftDouble,
             ftCurrency, ftDateTime, ftMemo, ftOLEObject

  注意：   必须设置TScUpdater.CurrentFileVer，以实现根据版本号判断自动升级。
}
unit ScAutoUpdateUnit;

interface

uses
  SysUtils, DB, ADODB, Classes, ScTablesUnit{, ScFileArchiver, ScFileArchiverConsts};

const
  MaxFieldCount = 512;
  PrimaryKey = 'PrimaryKey';

type
  PFieldDefs = ^TFieldDefs;

  TFieldDefs = array [0..MaxFieldCount - 1] of TScFieldDef;

  PTableDef = ^TTableDef;

  // 表定义结构
  TTableDef = record
    // 表名
    TableName: string;
    // 字段数
    FieldCount: Integer;
    // 字段结构数组
    FieldDefs: PFieldDefs;
    // 是否需要重新创建
    Recreate: Boolean;
    // 重新创建主键
    RecreatePrimaryKey: Boolean;
  end;

  TSQLType = (stAlter, stCreate, stReCreate);

  TUpdateEventType = (uetAddFields, uetKeys, uetAfterUpdate);

  TUpdateEvent = procedure (ATableName: string; AEventType: TUpdateEventType;
    ASQLType: TSQLType; AConnection: TADOConnection);
  TUpdatedEvent = procedure (AFileVersion, ACurVersion: string;
    AConnection: TADOConnection; ASucceed: Boolean);

  EScUpdater = class(Exception);

  TScUpdater = class(TObject)
  private
    FTableDefList: TList;
    FFileName: string;
    FConnection: TADOConnection;
    FFileVer: string;
    FQuery: TADOQuery;
    FForceUpdate: Boolean;
    FForceCheck: Boolean;
    FCurFileVersion: string;
    FOnUpdateData: TUpdateEvent;
    FOnUpdated: TUpdatedEvent;
    function GetCurFileVersion: string;
    // 返回True：表存在，返回False: 表不存在
    function CheckTable(ATableName: string): Boolean;
    procedure GenerateSQL(ATableDef: PTableDef; ASQLType: TSQLType; ASQLList: TStrings);
    procedure InternalExcuteSQL(ASQL: string; AHideException: Boolean = False; AOpen: Boolean = False);
    function ExcuteUpdateSQL(ASQLList: TStrings): Boolean;
    procedure SetForceUpdate(const Value: Boolean);
    procedure SetForceCheck(const Value: Boolean);
    // 字符串是否是事件
    // 事件字符串格式："事件名 表名 操作类型"
    function CheckEvent(AText: string): Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    // 打开(AFileVers：打开文件的版本，程序中最新的文件版本号)
    procedure Open(AFileName: string; AConnection: TADOConnection;
        AFileVer, ACurrentFileVer: string);
    // 关闭
    procedure Close;
    // 执行升级操作
    function ExcuteUpdate: Boolean;
    // 执行其他SQL语句(如建立、删除索引)
    procedure ExcuteSQL(ASQL: string);
    // 添加表定义
    function AddTableDef(ATableName: string; AFieldDefs: PFieldDefs; AFieldCount: Integer;
        AReCreate, ARecreatePK: Boolean): Integer;
    // 文件是否需要升级（根据版本号判断）
    function FileNeedUpdate: Boolean;
    // 强制进行表和字段的升级检查
    property ForceCheck: Boolean read FForceCheck write SetForceCheck;
    // 强制升级所有表和字段
    property ForceUpdate: Boolean read FForceUpdate write SetForceUpdate;
    // 最新文件版本
    property CurrentFileVer: string read GetCurFileVersion;
    // 事件
    // 重建关键字之前
    property OnUpdateData: TUpdateEvent read FOnUpdateData
      write FOnUpdateData;
    // 完成升级后
    property OnUpdated: TUpdatedEvent read FOnUpdated
      write FOnUpdated;
  end;

const
  SQLTypeStrs: array [TSQLType] of string = ('Modify', 'Create', 'ReCreate');
  SOnUpdateData = 'OnUpdateData';

implementation

uses
  ScUtils;

function StrToSQLType(ASQLType: string): TSQLType;
var
  I: TSQLType;
begin
  Result := stAlter;
  for I := Low(SQLTypeStrs) to High(SQLTypeStrs) do
  begin
    if SameText(ASQLType, SQLTypeStrs[I]) then
    begin
      Result := I;
      Break;
    end;
  end;
end;

{ TScUpdater }

function TScUpdater.AddTableDef(ATableName: string; AFieldDefs: PFieldDefs;
  AFieldCount: Integer; AReCreate, ARecreatePK: Boolean): Integer;
var
  pRec: PTableDef;
begin
  New(pRec);
  pRec^.TableName := ATableName;
  pRec^.FieldCount := AFieldCount;
  pRec^.FieldDefs := AFieldDefs;
  pRec^.Recreate := AReCreate;
  pRec^.RecreatePrimaryKey := ARecreatePK;
  Result := FTableDefList.Add(pRec);
end;

function TScUpdater.CheckEvent(AText: string): Boolean;
var
  strText, strEvent, strTableName, strEventType, strSQLType: string;
  SQLType: TSQLType;
  iPos: Integer;
begin
  Result := False;
  strText := AText;
  // 检查事件名称
  iPos := Pos(' ', strText);
  if iPos > 0 then
  begin
    strEvent := Copy(strText, 1, iPos - 1);
    Delete(strText, 1, iPos);
    if SameText(strEvent, SOnUpdateData) then
    begin
      // 事件类型
      iPos := Pos(' ', strText);
      strEventType := Copy(strText, 1, iPos - 1);
      Delete(strText, 1, iPos);
      // 表名
      iPos := Pos(' ', strText);
      strTableName := Copy(strText, 1, iPos - 1);
      Delete(strText, 1, iPos);
      // 操作类型
      strSQLType := strText;
      SQLType := StrToSQLType(strSQLType);

      Result := True;
      if Assigned(FOnUpdateData) then
        FOnUpdateData(strTableName, TUpdateEventType(StrToInt(strEventType)), SQLType, FConnection);
    end;
  end;
end;

function TScUpdater.CheckTable(ATableName: string): Boolean;
var
  I: Integer;
  Names: TStringList;
begin
  Names := TStringList.Create;
  try
    FConnection.GetTableNames(Names);
    if Names.IndexOf(ATableName) < 0 then
      Result := False
    else
      Result := True;
  finally
    Names.Free;
  end;
end;

procedure TScUpdater.Close;
begin
  FQuery.Close;
end;

constructor TScUpdater.Create;
begin
  FForceUpdate := False;
  FForceCheck := False;
  FTableDefList := TList.Create;
  FQuery := TADOQuery.Create(nil);
end;

destructor TScUpdater.Destroy;
begin
  Close;
  FQuery.Free;
  ClearPointerList(FTableDefList);
  FTableDefList.Free;
  inherited;
end;

procedure TScUpdater.ExcuteSQL(ASQL: string);
begin
  InternalExcuteSQL(ASQL);
end;

function TScUpdater.ExcuteUpdate: Boolean;
var
  I: Integer;
  pRec: PTableDef;
  SQLs: TStringList;
  SQLType: TSQLType;
  bHasError: Boolean;
  sError: string;
begin
  Result := False;
  bHasError := False;
  sError := '';
  if FileNeedUpdate then
  begin
    SQLs := TStringList.Create;
    try
      for I := 0 to FTableDefList.Count - 1 do
      begin
        pRec := PTableDef(FTableDefList[I]);
        if CheckTable(pRec^.TableName) then
        begin
          if pRec^.Recreate then
            SQLType := stReCreate
          else
            SQLType := stAlter;
        end
        else
          SQLType := stCreate;
        GenerateSQL(pRec, SQLType, SQLs);
        if SQLs.Count > 0 then
          if not ExcuteUpdateSQL(SQLs) then
          begin
            bHasError := True;
            sError := sError + #13#10 + Format('Update operation [%s] on table [%s] can not be executed!', [SQLTypeStrs[SQLType], pRec^.TableName]);
          end;
      end;
    finally
      SQLs.Free;
    end;

    if bHasError then
      MessageWarning(0, '升级文件时发生错误，无法完成升级。'#13#10'错误信息：' + sError)
    else
      Result := True;

    if Assigned(FOnUpdated) then
      FOnUpdated(FFileVer, CurrentFileVer, FConnection, Result);
  end;
end;

function TScUpdater.ExcuteUpdateSQL(ASQLList: TStrings): Boolean;
var
  I: Integer;
  HideExcption: Boolean;
begin
  Result := False;
  try
    for I := 0 to ASQLList.Count - 1 do
    begin
      if not CheckEvent(ASQLList[I]) then
      begin
        HideExcption := ASQLList.Objects[I] <> nil;
        if HideExcption then
          HideExcption := Boolean(Integer(ASQLList.Objects[I]));
        InternalExcuteSQL(ASQLList[I], HideExcption);
      end;
    end;
    Result := True;
  except

  end;
end;

function TScUpdater.FileNeedUpdate: Boolean;
begin
  if GetCurFileVersion = '' then
    raise EScUpdater.Create('必须设置TScUpdater.CurrentFileVer！');
  Result := (ScCompareFileVer(FFileVer, GetCurFileVersion) < 0) or FForceCheck;
end;

function SameFieldType(AFieldType: TFieldType; AScFieldType: TScMDBFieldType): Boolean;
begin
  Result := False;
  case AScFieldType of
    ftString:
      Result := (AFieldType = DB.ftWideString) or (AFieldType = DB.ftString);
    ftByte:
      Result := AFieldType = DB.ftWord;
    ftSmallint:
      Result := AFieldType = DB.ftSmallint;
    ftInteger:
      Result := AFieldType = DB.ftInteger;
    ftBoolean:
      Result := AFieldType = DB.ftBoolean;
    ftSingle:
      Result := AFieldType = DB.ftFloat;
    ftDouble:
      Result := AFieldType = DB.ftFloat;
    ftCurrency:
      Result := (AFieldType = DB.ftCurrency) or (AFieldType = DB.ftBCD);
    ftDateTime:
      Result := AFieldType = DB.ftDateTime;
    ftMemo:
      Result := AFieldType = DB.ftMemo;
    ftOLEObject:
      Result := AFieldType = DB.ftBlob;
  end;
end;

procedure TScUpdater.GenerateSQL(ATableDef: PTableDef; ASQLType: TSQLType; ASQLList: TStrings);
var
  bHasKey: Boolean;

  function GenerateCreateSQL: string;
  var
    I: Integer;
    Def: TScFieldDef;
    strField, strFields, strKeyFields: string;
  begin
    Result := '';
    if ATableDef^.FieldCount > 0 then
    begin
      // CREATE TABLE table1
      Result := Format('CREATE TABLE %s ', [ATableDef^.TableName]);
      strFields := '';
      strKeyFields := '';
      for I := 0 to ATableDef^.FieldCount - 1 do
      begin
        Def := ATableDef^.FieldDefs[I];
        // field1 type
        strField := Def.FieldName + ' ' + ScMDBFieldTypeName[Def.FieldType];

        case Def.FieldType of
          ftString:
          // field1 type (size)
            strField := strField + Format(' (%d)', [Def.Size]);
          ftFMTBCD:
          // field1 type (size, Precision)
            strField := strField + Format(' (%d,%d)', [Def.Size, Def.Precision]);
        end;
        if Def.NotNull then
          // field1 type (size) NOT NULL
          strField := strField + ' ' + 'NOT NULL';
        if Def.PrimaryKey then
          strKeyFields := strKeyFields + Def.FieldName + ', ';

        strFields := strFields + strField + ', ';
      end;
      if strKeyFields <> '' then
      begin
        Delete(strKeyFields, Length(strKeyFields) - 1, 2);
        // CONSTRAINT PrimaryKey PRIMARY KEY (field1, field2...)
        strKeyFields := Format('CONSTRAINT %s PRIMARY KEY (%s)', [PrimaryKey, strKeyFields]);
      end
      else
        Delete(strFields, Length(strFields) - 1, 2);
      // (field1 type (size) NOT NULL, field2 type (size) NOT NULL..., CONSTRAINT PrimaryKey PRIMARY KEY (field1, field2...))
      strFields := Format('(%s)', [strFields + strKeyFields]);
      // CREATE TABLE table1 (field1 type (size) NOT NULL, field2 type (size) NOT NULL..., CONSTRAINT PrimaryKey PRIMARY KEY (field1, field2...))
      Result := Result + strFields;
    end;
  end;

type
  TAlterType = (atAddField, atAlterField, atDropField, atAddIndex, atDropIndex);

  function GenerateSingleFieldAlterSQL(ATableName: string; AFieldDef: TScFieldDef;
    AOp: TAlterType; var ANeedDefault: Boolean): string;
  begin
    Result := '';
    ANeedDefault := False;
    case AOp of
      atAddField:
      begin
        Result := Format('ALTER TABLE %s ADD COLUMN %s %s',
            [ATableName, AFieldDef.FieldName, ScMDBFieldTypeName[AFieldDef.FieldType]]);
        case AFieldDef.FieldType of
          ftString:
            Result := Result + Format(' (%d)', [AFieldDef.Size]);
          ftFMTBCD:
            Result := Result + Format(' (%d,%d)', [AFieldDef.Size, AFieldDef.Precision]);
        end;
        if AFieldDef.NotNull then
        begin
          Result := Result + ' NOT NULL';
          case AFieldDef.FieldType of
            ftByte, ftSmallint, ftInteger, ftBoolean, ftSingle, ftDouble,
                 ftCurrency, ftDateTime, ftFMTBCD:
            ANeedDefault := True;
          end;
        end;
      end;
      atDropField:
      begin
        Result := Format('ALTER TABLE %s DROP COLUMN %s', [ATableName, AFieldDef.FieldName]);
      end;
      atAlterField:
      begin
        Result := Format('ALTER TABLE %s ALTER COLUMN %s %s',
            [ATableName, AFieldDef.FieldName, ScMDBFieldTypeName[AFieldDef.FieldType]]);
        case AFieldDef.FieldType of
          ftString:
            Result := Result + Format(' (%d)', [AFieldDef.Size]);
          ftFMTBCD:
            Result := Result + Format(' (%d,%d)', [AFieldDef.Size, AFieldDef.Precision]);
        end;
        if AFieldDef.NotNull then
        begin
          Result := Result + ' NOT NULL';
          case AFieldDef.FieldType of
            ftByte, ftSmallint, ftInteger, ftBoolean, ftSingle, ftDouble,
                 ftCurrency, ftDateTime, ftFMTBCD:
            ANeedDefault := True;
          end;
        end;
      end;
    end;
  end;

  function GenerateDefaultValueSQL(ATableName: string; AFieldDef: TScFieldDef): string;
  begin
    Result := '';
    case AFieldDef.FieldType of
      ftByte, ftSmallint, ftInteger:
        Result := Format('UPDATE  %s SET %s = %d WHERE IsNull(%s)',
            [ATableName, AFieldDef.FieldName, 0, AFieldDef.FieldName]);
      ftSingle, ftDouble, ftCurrency, ftFMTBCD:
        Result := Format('UPDATE  %s SET %s = %f WHERE IsNull(%s)',
            [ATableName, AFieldDef.FieldName, 0.0, AFieldDef.FieldName]);
      ftBoolean:
        Result := Format('UPDATE  %s SET %s = %s WHERE IsNull(%s)',
            [ATableName, AFieldDef.FieldName, 'FALSE', AFieldDef.FieldName]);
      ftDateTime:
        Result := Format('UPDATE  %s SET %s = ''%s'' WHERE IsNull(%s)',
            [ATableName, AFieldDef.FieldName, '2000-1-1 12:00:00', AFieldDef.FieldName]);
    end;
  end;

  function GenerateSingleKeyAlterSQL(ATableName, AIndexName, AFieldNames: string; AOp: TAlterType): string;
  begin
    Result := '';
    case AOp of
      atAddIndex:
      begin
        Result := Format('ALTER TABLE %s ADD CONSTRAINT %s Primary Key (%s)', [ATableName, AIndexName, AFieldNames]);
      end;
      atDropIndex:
      begin
        Result := Format('ALTER TABLE %s DROP CONSTRAINT %s', [ATableName, AIndexName]);
      end;
    end;
  end;

  procedure GenerateAlterSQL;
  var
    I, J: Integer;
    Field: TField;
    pDef: PScFieldDef;
    AddList, ModifyList: TList;
    KeyFields: string;
    bNeedDefaultValue: Boolean;
  begin
    InternalExcuteSQL(Format('SELECT * FROM %s WHERE 0=1', [ATableDef^.TableName]), False, True);

    AddList := TList.Create;
    ModifyList := TList.Create;
    try
      KeyFields := '';
      for I := 0 to ATableDef^.FieldCount - 1 do
      begin
        pDef := @ATableDef^.FieldDefs^[I];
        if (KeyFields <> '') and pDef^.PrimaryKey then
          KeyFields := KeyFields + ', ';
        if pDef^.PrimaryKey then
          KeyFields := KeyFields + pDef^.FieldName;
        AddList.Add(pDef);
      end;

{      if KeyFields <> '' then
        Delete(KeyFields, Length(KeyFields) - 1, 2);}

      for I := 0 to FQuery.Fields.Count - 1 do
      begin
        Field := FQuery.Fields[I];
        for J := 0 to AddList.Count - 1 do
        begin
          pDef := PScFieldDef(AddList[J]);
          if SameText(Field.FieldName, pDef^.FieldName) then
          begin
            if FForceUpdate or pDef^.ForceUpdate then
              ModifyList.Add(pDef)
            else
            begin
              if not SameFieldType(Field.DataType, pDef^.FieldType) then
                ModifyList.Add(pDef)
              else if (Field.DataType in [ftWideString]) and (Field.Size <> pDef^.Size) then
                ModifyList.Add(pDef)
              // ADO读不到数据库中字段的Required，所以这句代码无用
              (*
              else if Field.Required <> pDef^.NotNull then
                ModifyList.Add(pDef)*);
            end;
            AddList.Remove(pDef);
            Break;
          end;
        end;
      end;

      for I := 0 to ModifyList.Count - 1 do
      begin
        pDef := PScFieldDef(ModifyList[I]);
        ASQLList.Add(GenerateSingleFieldAlterSQL(ATableDef^.TableName, pDef^, atAlterField, bNeedDefaultValue));
        if bNeedDefaultValue then
          ASQLList.Add(GenerateDefaultValueSQL(ATableDef^.TableName, pDef^));
      end;

      for I := 0 to AddList.Count - 1 do
      begin
        pDef := PScFieldDef(AddList[I]);
        ASQLList.Add(GenerateSingleFieldAlterSQL(ATableDef^.TableName, pDef^, atAddField, bNeedDefaultValue));
        if bNeedDefaultValue then
          ASQLList.Add(GenerateDefaultValueSQL(ATableDef^.TableName, pDef^));
      end;
      if AddList.Count > 0 then
        // 添加事件
        ASQLList.Add(Format('%s %d %s %s', [SOnUpdateData, Ord(uetAddFields), ATableDef.TableName, SQLTypeStrs[ASQLType]]));


      if ATableDef.RecreatePrimaryKey then
      begin
        if bHasKey then
          ASQLList.AddObject(GenerateSingleKeyAlterSQL(ATableDef^.TableName, PrimaryKey, KeyFields, atDropIndex), TObject(Integer(True)));
        // 添加事件
        ASQLList.Add(Format('%s %d %s %s', [SOnUpdateData, Ord(uetKeys), ATableDef.TableName, SQLTypeStrs[ASQLType]]));
        ASQLList.Add(GenerateSingleKeyAlterSQL(ATableDef^.TableName, PrimaryKey, KeyFields, atAddIndex));
      end;
    finally
      AddList.Free;
      ModifyList.Free;
    end;
  end;

  procedure CheckHasKey;
  var
    Table: TADOTable;
    I: Integer;
  begin
    bHasKey := False;
    Table := TADOTable.Create(nil);
    try
      Table.Connection := FConnection;
      Table.TableName := ATableDef^.TableName;
      Table.Open;
      for I := 0 to Table.FieldCount - 1 do
        if pfInKey in Table.Fields[I].ProviderFlags then
        begin
          bHasKey := True;
          Break;
        end;
    finally
      Table.Free;
    end;
  end;

begin
  ASQLList.Clear;
  bHasKey := True;
  case ASQLType of
    stAlter:
    begin
      // zhangyin 2014-01-26虽然此方法可以避免调试时弹出异常，但是会占用比较长的时间
      //    （4500行清单的项目会将升级数据库时间加长一倍以上 1s->2.4s）
      //    所以还是屏蔽掉。
      //CheckHasKey;
      GenerateAlterSQL;
    end;
    stCreate:
      ASQLList.Add(GenerateCreateSQL);
    stReCreate:
    begin
      ASQLList.Add(Format('DROP TABLE %s', [ATableDef^.TableName]));
      ASQLList.Add(GenerateCreateSQL);
    end;
  end;
  if ASQLList.Count > 0 then
   ASQLList.Add(Format('%s %d %s %s', [SOnUpdateData, Ord(uetAfterUpdate), ATableDef^.TableName, SQLTypeStrs[ASQLType]]));
end;

function TScUpdater.GetCurFileVersion: string;
begin
  Result := FCurFileVersion;
end;

procedure TScUpdater.InternalExcuteSQL(ASQL: string; AHideException, AOpen: Boolean);
begin
  FQuery.Close;
  FQuery.SQL.Clear;
  FQuery.SQL.Add(ASQL);
  try
    if AOpen then
      FQuery.Open
    else
      FQuery.ExecSQL;
  except
    if not AHideException then
      raise;
  end;
end;

procedure TScUpdater.Open(AFileName: string; AConnection: TADOConnection;
  AFileVer, ACurrentFileVer: string);
begin
  FFileName := AFileName;
  FConnection := AConnection;
  FFileVer := AFileVer;
  if AFileVer = '' then
    FFileVer := '0.0.0.0';
  FCurFileVersion := ACurrentFileVer;
  // 为空时，设一个很大的当前版本号，强制升级
  if FCurFileVersion = '' then
    FCurFileVersion := '100000.0.0.0';
  FQuery.Connection := AConnection;
  ClearPointerList(FTableDefList);
end;

procedure TScUpdater.SetForceCheck(const Value: Boolean);
begin
  FForceCheck := Value;
end;

procedure TScUpdater.SetForceUpdate(const Value: Boolean);
begin
  FForceUpdate := Value;
end;

end.