Merge branch 'master' of http://192.168.1.41:3000/maixinrong/measure

Units/ScAutoUpdateUnit.pas

@@ -0,0 +1,666 @@
+{
+  单元名： 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.