soapdbserverunit.pas

Delphi 7组件与分布式应用开发源码,介绍了基础的组件应用实例

unit SoapDBServerUnit;

interface

uses
  SysUtils, Classes, DBXpress, DB, SqlExpr, InvokeRegistry, XSBuiltIns,
  FMTBcd, DBCommon, Dialogs;

const
  SUpdateSQL = 'update %s set %s where %s';
  SInsertSQL = 'insert into %s VALUES( %s )';
  SDeleteSQL = 'delete from %s where %s';

type

  TUpdateType = (utUpdateNone, utUpdateInsert, utUpdateUpdate, utUpdateDelete);

  TIndexDesc = class(TRemotable)
  private
    FFields: string;
    FName: string;
    FDescending: Boolean;
    FPrimary: Boolean;
    FCaseInsensitive: Boolean;
    FUnique: Boolean;
  published
    property Fields: string read FFields write FFields;
    property Name: string read FName write FName;
    property Primary: Boolean read FPrimary write FPrimary;
    property Unique: Boolean read FUnique write FUnique;
    property Descending: Boolean read FDescending write FDescending ;
    property CaseInsensitive: Boolean read FCaseInsensitive write FCaseInsensitive;
  end;

  TIndexDescArray = array of TIndexDesc;

  TColDesc = class(TRemotable)
  private
    FRequired: Boolean;
    FReadOnly: Boolean;
    FDataSize: Integer;
    FFieldName: string;
    FDataType: TFieldType;
    FSize: Integer;
    FIsBlob: Boolean;
  published
    property DataType: TFieldType read FDataType write FDataType default ftUnknown;
    property FieldName: string read FFieldName write FFieldName;
    property IsBlob: Boolean read FIsBlob write FIsBlob default False;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property Required: Boolean read FRequired write FRequired default False;
    property DataSize: Integer read FDataSize write FDataSize default 0;
    property Size: Integer read FSize write FSize default 0;
  end;

  TColDescArray = array of TColDesc;

  TFieldValue = class(TRemotable)
  private
    FID: Integer;
    FValue: Variant;
    FOldValue: Variant;
    FChanged: Boolean;
  published
    property ID: Integer read FID write FID;
    property OldValue: Variant read FOldValue write FOldValue;
    property Value: Variant read FValue write FValue;
    property Changed: Boolean read FChanged write FChanged default False;
  end;

  TFieldValueArray = array of TFieldValue;

  TSoapRow = class(TRemotable)
  private
    FFieldValueArray: TFieldValueArray;
    FUpdateType: TUpdateType;
    FRowID: Integer;
  public
    function Clone: TSoapRow; virtual;
    procedure ClearValues;
  published
    property RowID: Integer read FRowID write FRowID;
    property FieldValueArray: TFieldValueArray read FFieldValueArray write FFieldValueArray;
    property UpdateType: TUpdateType read FUpdateType write FUpdateType;
  end;

  TRowArray = array of TSoapRow;

  TUpdateInfo = class(TRemotable)
  private
    FUseIndexMetadata: Boolean;
    FKeyFields: string;
    FMetadataRetrieved: Boolean;
    FErrorCount: Integer;
    FErrorMessage: string;
  published
    property ErrorCount: Integer read FErrorCount write FErrorCount default 0;
    property ErrorMessage: string read FErrorMessage write FErrorMessage;
    property KeyFields: string read FKeyFields write FKeyFields;
    property MetadataRetrieved: Boolean read FMetadataRetrieved write FMetadataRetrieved default False;
    property UseIndexMetadata: Boolean read FUseIndexMetadata write FUseIndexMetadata default True;
  end;

  TSoapDBError = class(TRemotable)
  private
    FErrorMsg: string;
    FFailedRecord: TSoapRow;
  published
    property ErrorMsg: string read FErrorMsg write FErrorMsg;
    property FailedRecord: TSoapRow read FFailedRecord write FFailedRecord;
  end;

  TDBErrorArray = array of TSoapDBError;

  TSoapDataPacket = class(TRemotable)
  private
    FColDescArray: TColDescArray;
    FIndexDescArray: TIndexDescArray;
    FRowArray: TRowArray;
    FTableName: string;
    function UpdateRow(Row: TSoapRow; var UpdateInfo: TUpdateInfo; var UpdateErrors: TDBErrorArray): Integer; virtual;
  public
    function IncRowSize: Integer;
    function CloneStructure: TSoapDataPacket; virtual;
    procedure ClearRow(ID: Integer; AdjustArray: Boolean); virtual;
    procedure ClearRows; virtual;
    procedure ClearRowByRowID(RowID: Integer); virtual;
    procedure ClearPacket; virtual;
  published
    property ColDescArray: TColDescArray read FColDescArray write FColDescArray;
    property IndexDescArray: TIndexDescArray read FIndexDescArray write FIndexDescArray;
    property RowArray: TRowArray read FRowArray write FRowArray;
    property TableName: string read FTableName write FTableName;
  end;

  IWebServicesDataSet = Interface(IInvokable)
  ['{9392AF9B-39B1-11D5-BF7B-00C04F79AB6E}']
    procedure RetrieveDataSet(SQL: string; var DataSet: TSoapDataPacket; var UpdateInfo: TUpdateInfo); stdcall;
    function UpdateDataSet(UpdatePacket: TSoapDataPacket; var UpdateInfo: TUpdateInfo; var UpdateErrors: TDBErrorArray): Integer; stdcall;
  end;

  TWebServicesDataSet = class(TInvokableClass, IWebServicesDataSet)
  public
    procedure RetrieveDataSet(SQL: string; var DataSet: TSoapDataPacket; var UpdateInfo: TUpdateInfo); stdcall;
    function UpdateDataSet(UpdatePacket: TSoapDataPacket; var UpdateInfo: TUpdateInfo; var UpdateErrors: TDBErrorArray): Integer; stdcall;
  end;

  TData = class(TDataModule)
    SQLConnection1: TSQLConnection;
    SQLDataSet1: TSQLDataSet;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

{ Utility functions }

  function LoadFields(DataSet: TDataSet): TFieldValueArray;
  function RowArrayFromDataSet(DataSet: TDataSet): TRowArray;
  function ColumnArrayFromDataSet(DataSet: TDataSet): TColDescArray;
  procedure DataSetFromRowArray(DataSet: TDataSet; RowArray: TRowArray);
  procedure DataSetFromColumnDescArray(ColDescArray: TColDescArray; DataSet: TDataSet; AddRowID: Boolean = False);
  procedure ClearRowArray(RowArray: TRowArray);

var
  Data: TData;

implementation

uses Variants;

{ Utility functions }

  procedure ClearRowArray(RowArray: TRowArray);
  var
    I, J: Integer;
  begin
    for I := 0 to Length(RowArray) -1 do
    begin
      for J := 0 to Length(RowArray[I].FieldValueArray) -1 do
        RowArray[I].FieldValueArray[J].Free;
      SetLength(RowArray[I].FFieldValueArray, 0);
    end;
    SetLength(RowArray, 0);
  end;

  procedure DataSetFromColumnDescArray(ColDescArray: TColDescArray; DataSet: TDataSet; AddRowID: Boolean = False);

    function FieldFromColDesc(ColDesc: TColDesc): TFieldDef;
    begin
      Result := DataSet.FieldDefs.AddFieldDef;
      Result.DataType := ColDesc.DataType;
      Result.Name := ColDesc.FieldName;
      Result.Required := ColDesc.FRequired;
      Result.Precision := ColDesc.FDataSize;
      Result.Size := ColDesc.FSize;
    end;
  var
    I: Integer;
  begin
    DataSet.FieldDefs.Clear;
    for I := 0 to Length(ColDescArray) -1 do
      FieldFromColDesc(ColDescArray[I]);
  end;


  function LoadFields(DataSet: TDataSet): TFieldValueArray;
  var
    I: Integer;
  begin
    SetLength(Result, DataSet.FieldCount);
    for I := 0 to DataSet.FieldCount -1 do
    begin
      Result[I] := TFieldValue.Create;
      Result[I].ID := I;
      if DataSet.Fields[I].DataType = ftTimeStamp then
        Result[I].Value := DataSet.Fields[I].AsDateTime
      else if DataSet.Fields[I].DataType = ftFMTBcd then
        Result[I].Value := DataSet.Fields[I].AsCurrency
      else
        Result[I].Value := DataSet.Fields[I].Value;
      VarClear(Result[I].FOldValue);
    end;
  end;

  function RowArrayFromDataSet(DataSet: TDataSet): TRowArray;
  var
    RowCount: Integer;
  begin
    RowCount := 1;
    while not DataSet.EOF do
    begin
      SetLength(Result, RowCount);
      Result[RowCount-1] := TSoapRow.Create;
      Result[RowCount-1].FieldValueArray := LoadFields(DataSet);
      Result[RowCount-1].RowID := RowCount;
      Inc(RowCount);
      DataSet.Next;
    end;
  end;

  function ColumnArrayFromDataSet(DataSet: TDataSet): TColDescArray;
  var
    I: Integer;
  begin
    SetLength(Result, DataSet.FieldCount);
    for I := 0 to DataSet.FieldCount -1 do
    begin
      Result[I] := TColDesc.Create;
      Result[I].FDataType := DataSet.Fields[I].DataType;
      Result[I].FReadOnly := DataSet.Fields[I].ReadOnly;
      Result[I].FFieldName := DataSet.Fields[I].FieldName;
      Result[I].FRequired := DataSet.Fields[I].Required;
      Result[I].FDataSize := DataSet.Fields[I].DataSize;
      Result[I].FSize := DataSet.Fields[I].Size;
      Result[I].IsBlob := DataSet.Fields[I].IsBlob;
    end;
  end;

  function IndexArrayFromDataSet(DataSet: TSQLDataSet): TIndexDescArray;
  var
    IndexDefs: TIndexDefs;
    I: Integer;
  begin
    IndexDefs := DataSet.IndexDefs;
    for I := 0 to IndexDefs.Count -1 do
    begin
      SetLength(Result, I+1);
      Result[I] := TIndexDesc.Create;
      Result[I].Fields := IndexDefs[I].Fields;
      Result[I].Primary := (ixPrimary in IndexDefs[I].Options);
      Result[I].Unique := (ixUnique in IndexDefs[I].Options);
      Result[I].Descending := (ixDescending in IndexDefs[I].Options);
      Result[I].CaseInsensitive := (ixCaseInsensitive in IndexDefs[I].Options);
    end;
  end;

  function GetKeyFields(const Option: TIndexOption; const IndexDefs: TIndexDefs): string;
  var
    I: Integer;
  begin
    for I := 0 to IndexDefs.Count -1 do
    begin
      if Option in IndexDefs[I].Options then
      begin
        Result := IndexDefs[I].Fields;
        break;
      end;
    end;  
  end;

  function LoadUpdateInfo(DataSet: TSQLDataSet; var UpdateInfo: TUpdateInfo): TIndexDescArray;
  begin
    if UpdateInfo.MetadataRetrieved then exit;
    if not UpdateInfo.UseIndexMetadata then exit;
    Result := IndexArrayFromDataSet(DataSet);
    UpdateInfo.MetadataRetrieved := True;
    UpdateInfo.KeyFields := GetKeyFields(ixPrimary, DataSet.IndexDefs);
    if UpdateInfo.KeyFields = '' then
      UpdateInfo.KeyFields := GetKeyFields(ixUnique, DataSet.IndexDefs);
  end;

  procedure DataSetFromRowArray(DataSet: TDataSet; RowArray: TRowArray);
  var
    I, J: Integer;
  begin
    for I := 0 to Length(RowArray) -1 do
    begin
      DataSet.Append;
      for J := 0 to DataSet.FieldCount -1 do
        DataSet.Fields[J].Value := RowArray[I].FFieldValueArray[J].Value;
      DataSet.Post;
    end;
    DataSet.First;
  end;

{ TSoapRow }

procedure TSoapRow.ClearValues;
var
  I: Integer;
begin
  for I := 0 to Length(FFieldValueArray) -1 do
  begin
    VarClear(FFieldValueArray[I].FValue);
    VarClear(FFieldValueArray[I].FOldValue);
  end;
end;

function TSoapRow.Clone: TSoapRow;
var
  I: Integer;
begin
  Result := TSoapRow.Create;
  Result.RowId := RowID;
  Result.UpdateType := UpdateType;
  SetLength(Result.FFieldValueArray, Length(FFieldValueArray));
  for I := 0 to Length(FFieldValueArray) -1 do
  begin
    Result.FFieldValueArray[I] := TFieldValue.Create;
    Result.FFieldValueArray[I].FID := FFieldValueArray[I].FID;
    Result.FFieldValueArray[I].Value := FFieldValueArray[I].Value;
    Result.FFieldValueArray[I].OldValue := FFieldValueArray[I].OldValue;
    Result.FFieldValueArray[I].Changed := FFieldValueArray[I].Changed;
  end;