soapdbserverunit.pas

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

end;

{ TSoapDataPacket }

function TSoapDataPacket.IncRowSize: Integer;
var
  I: Integer;
begin
  Result := Length(FRowArray) + 1;
  SetLength(FRowArray, Result);
  FRowArray[Result-1] := TSoapRow.Create;
  FRowArray[Result-1].RowID := Result;
  SetLength(FRowArray[Result-1].FFieldValueArray, Length(FColDescArray));
  for I := 0 to Length(FColDescArray) -1 do
    FRowArray[Result-1].FFieldValueArray[I] := TFieldValue.Create;
end;

procedure TSoapDataPacket.ClearRow(ID: Integer; AdjustArray: Boolean);
var
  I: Integer;
begin
  for I := 0 to Length(FRowArray[ID].FFieldValueArray) -1 do
    FRowArray[ID].FFieldValueArray[I].Free;
  SetLength(FRowArray[ID].FFieldValueArray, 0);
  FRowArray[ID].Free;
  if AdjustArray then
  begin
    for I := ID to Length(FRowArray) -2 do
      FRowArray[I] := FRowArray[I+1];
    SetLength(FRowArray, Length(FRowArray) -1);
  end;
end;

procedure TSoapDataPacket.ClearRows;
var
  I: Integer;
begin
  for I := 0 to Length(FRowArray) -1 do
    ClearRow(I, False);
  SetLength(FRowArray, 0);
end;

procedure TSoapDataPacket.ClearRowByRowID(RowID: Integer);
var
  I: Integer;
begin
  for I := 0 to Length(FRowArray) -1 do
  begin
    if FRowArray[I].RowID = RowId then
    begin
      ClearRow(I, True);
      break;
    end;
  end;
end;

procedure TSoapDataPacket.ClearPacket;
var
  I: Integer;
begin
  ClearRows;
  for I := 0 to Length(FColDescArray) -1 do
    FColDescArray[I].Free;
  SetLength(FColDescArray, 0);
  for I := 0 to Length(FIndexDescArray) -1 do
    FIndexDescArray[I].Free;
  SetLength(FIndexDescArray, 0);
  TableName := '';
end;

procedure MoveColDesc(var Source, Target: TColDesc);
begin
  Target.FDataSize := Source.FDataSize;
  Target.FFieldName := Source.FFieldName;
  Target.FDataType := Source.FDataType;
  Target.FSize := Source.FSize;
  Target.FReadOnly := Source.FReadOnly;
  Target.FRequired := Source.FRequired;
  Target.FIsBlob := Source.FIsBlob;
end;

procedure MoveIndexDesc(var Source, Target: TIndexDesc);
begin
  Target.FName := Source.FName;
  Target.FCaseInsensitive := Source.FCaseInsensitive;
  Target.FDescending := Source.FDescending;
  Target.FFields := Source.FFields;
  Target.FPrimary := Source.FPrimary;
  Target.FUnique := Source.FUnique;
end;

function TSoapDataPacket.CloneStructure: TSoapDataPacket;
var
  I: Integer;
begin
  Result := TSoapDataPacket.Create;
  SetLength(Result.FColDescArray, Length(FColDescArray));
  for I := 0 to Length(FColDescArray) -1 do
  begin
    Result.FColDescArray[I] := TColDesc.Create;
    MoveColDesc(FColDescArray[I], Result.FColDescArray[I]);
  end;
  SetLength(Result.FIndexDescArray, Length(FColDescArray));
  for I := 0 to Length(FIndexDescArray) -1 do
  begin
    Result.FIndexDescArray[I] := TIndexDesc.Create;
    MoveIndexDesc(FIndexDescArray[I], Result.FIndexDescArray[I]);
  end;
  Result.TableName := TableName;
end;

type

  TGetValueType = (gvNone, gvNew, gvOld);

function TSoapDataPacket.UpdateRow(Row: TSoapRow; var UpdateInfo: TUpdateInfo; var UpdateErrors: TDBErrorArray): Integer;
var
  SQL: string;
  Params: TParams;
  ErrorCount: Integer;

    function GetDataForColumnName(Name: string; out Value: Variant;
             GetValueType: TGetValueType): TFieldType;
    var
      I, ID: Integer;
    begin
      Result := ftUnknown;
      ID := 0;
      for I := 0 to Length(ColDescArray) -1 do
      begin
        if Name = ColDescArray[I].FieldName then
        begin
          Result := ColDescArray[I].DataType;
          ID := I;
          break;
        end;
      end;
      if Result <> ftUnknown then
      case GetValueType of
        gvNew:
          Value := Row.FFieldValueArray[ID].Value;
        gvOld:
          if Row.FFieldValueArray[ID].Changed then
            Value := Row.FFieldValueArray[ID].OldValue
          else
            Value := Row.FFieldValueArray[ID].Value;
      end;
    end;

    function GetValueString(Where: Boolean): string;
    var
      I: Integer;
      SEquals, SConnector: string;
      V: Variant;
      ValueType: TGetValueType;
      DataType: TFieldType;
    begin
      if Row.UpdateType = utUpdateInsert then
        ValueType := gvNew
      else
        ValueType := gvOld;
      if Where then
        SConnector := 'and '
      else
        SConnector := ', ';
      for I := 0 to Length(ColDescArray) -1 do
      begin
        if (ColDescArray[I].IsBlob) and Where then continue;
        DataType := GetDataForColumnName(ColDescArray[I].
               FieldName, V, ValueType);
        if VarIsClear(V) then
        begin
          if I > 0 then
            Result := Result + sConnector + ColDescArray[I].FieldName + ' is NULL '
          else  
            Result := ColDescArray[I].FieldName + ' is NULL ';
          continue;
        end;
        if Where then
          SEquals := ColDescArray[I].FieldName + '= '
        else
          SEquals := '';
        if I > 0 then
          Result := Result + SConnector + SEquals + ':P' + IntToStr(I+1) + SEquals
        else
          Result := SEquals + ':P' + IntToStr(I+1) + SEquals;
        Params.CreateParam(DataType, 'P' + IntToStr(I+1), ptInput);
        Params[Params.Count -1].Value := V;
      end;
    end;

    function GetWhereString: string;
    var
      I: Integer;
      List: TStrings;
      V: Variant;
    begin
      if UpdateInfo.KeyFields = '' then
        Result := GetValueString(True)
      else
      begin
        List := TStringList.Create;
        try
          List.CommaText := UpdateInfo.KeyFields;
          for I := 0 to List.Count -1 do
          begin
            if I > 0 then
              Result := ' and ' + List[I] + ' = :P' + IntToStr(I+1)
            else
              Result := List[I] + ' = :P' + IntToStr(I+1);
            Params.CreateParam(GetDataForColumnName(List[I], V, gvOld),
                                'P' + IntToStr(I+1), ptInput);
            Params[Params.Count -1].Value := V;
          end;
        finally
          List.Free;
        end;
      end;
    end;

    function GetSetString: string;
    var
      I, J: Integer;
      FieldValue: TFieldValue;
      V: Variant;
      DataType: TFieldType;
    begin
      J := 0;
      for I := 0 to Length(Row.FFieldValueArray) -1 do
      begin
        FieldValue := Row.FFieldValueArray[I];
        if FieldValue.Changed then
        begin
          if J > 0 then
            Result := Result + ', ';
          DataType := GetDataForColumnName(ColDescArray[FieldValue.ID].FieldName,
                 V, gvNew);
          if VarIsClear(V) then
            Result := Result + ColDescArray[FieldValue.ID].FieldName
                 + ' is NULL' + IntToStr(J+1)
          else
          begin
            Params.CreateParam(DataType, 'PN' + IntToStr(J+1), ptInput);
            Params[Params.Count -1].Value := V;
            Result := Result + ColDescArray[FieldValue.ID].FieldName
                 + ' = :PN' + IntToStr(J+1);
            Inc(J);
          end;
        end;
      end;
    end;

  begin
    Params := TParams.Create;
    try
      try
        case Row.UpdateType of
          utUpdateInsert:
            SQL := format(SInsertSQL, [TableName, GetValueString(False)]);
          utUpdateUpdate:
            SQL := format(sUpdateSQL, [TableName, GetSetString, GetWhereString]);
          utUpdateDelete:
            SQL := format(sDeleteSQL, [TableName, GetWhereString]);
        end;
        Data.SqlDataSet1.CommandText := SQL;
        Data.SqlDataSet1.Params := Params;
        Data.SqlDataSet1.ExecSQL;
      except
        On E: Exception do
        begin
          ErrorCount:= Length(UpdateErrors) + 1;
          SetLength(UpdateErrors, ErrorCount);
          UpdateErrors[ErrorCount-1] := TSoapDBError.Create;
          UpdateErrors[ErrorCount-1].ErrorMsg := E.Message;
          UpdateErrors[ErrorCount-1].FailedRecord := Row.Clone;
        end;
      end;
    finally
      Params.Free;
      Result := 1;
    end;
  end;

{ TWebServicesDataSet }

  function TWebServicesDataSet.UpdateDataSet(UpdatePacket: TSoapDataPacket; var UpdateInfo: TUpdateInfo; var UpdateErrors: TDBErrorArray): Integer; stdcall;
  var
    I: Integer;
  begin
    Result := 0;
    for I := 0 to Length(UpdatePacket.RowArray) -1 do
      if UpdatePacket.RowArray[I].UpdateType <> utUpdateNone then
        Result := Result + UpdatePacket.UpdateRow(UpdatePacket.RowArray[I], UpdateInfo, UpdateErrors);
  end;

  procedure TWebServicesDataSet.RetrieveDataSet(SQL: string; var DataSet: TSoapDataPacket; var UpdateInfo: TUpdateInfo); stdcall;
  begin
     DataSet := Nil;
    try
      Data.SqlDataSet1.CommandText := SQL;
      ShowMessage(Data.SqlDataSet1.CommandText);
      Data.SqlDataSet1.Open;
      DataSet := TSoapDataPacket.Create;
      try
        DataSet.TableName := GetTableNameFromSQL(SQL);
        DataSet.FColDescArray := ColumnArrayFromDataSet(Data.SqlDataSet1);
        DataSet.FIndexDescArray := LoadUpdateInfo(Data.SQLDataSet1, UpdateInfo);
        DataSet.FRowArray := RowArrayFromDataSet(Data.SqlDataSet1);
      except
        On E: Exception do
        begin
          UpdateInfo.ErrorMessage := E.Message;
          DataSet.Free;
          UpdateInfo.ErrorCount := 1;
          DataSet := nil;
        end;  
      end;
    finally
      Data.SqlDataSet1.Close;
    end;
  end;

{$R *.dfm}
{ TColDesc }


Initialization
  InvRegistry.RegisterInterface(TypeInfo(IWebServicesDataSet));
  InvRegistry.RegisterInvokableClass(TWebServicesDataSet);
  RemClassRegistry.RegisterXSClass(TColDesc);
  RemClassRegistry.RegisterXSClass(TIndexDesc);
  RemClassRegistry.RegisterXSClass(TFieldValue);
  RemClassRegistry.RegisterXSClass(TUpdateInfo);
  RemClassRegistry.RegisterXSClass(TSoapRow);
  RemClassRegistry.RegisterXSClass(TSoapDBError);
  RemClassRegistry.RegisterXSClass(TSoapDataPacket);
  RemClassRegistry.RegisterXSInfo(TypeInfo(TFieldType));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TIndexDescArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TColDescArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TDBErrorArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TFieldValueArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TUpdateType));

end.