provider.pas

这是不可多得的源代码

    end;
  end;
end;

function TDataPacketWriter.GetFieldIdx(const FieldName: string; const Info: TInfoArray): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i := 0 to High(Info) do
    if (Info[i].Field <> nil) and (Info[i].Field.FieldName = FieldName) then
    begin
      Result := Info[i].LocalFieldIndex;
      break;
    end;
end;

type
  TPropWriter = class(TWriter);

procedure TDataPacketWriter.AddExtraFieldProps(Field: TField);

  procedure WriteProp(Instance: TPersistent; const PropName: string;
    Writer: TPropWriter);
  var
    PropInfo: PPropInfo;
  begin
    PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, PropName);
    if (PropInfo <> nil) and IsStoredProp(Instance, PropInfo) then
      Writer.WriteProperty(Instance, PropInfo);
  end;

var
  Writer: TPropWriter;
  Stream: TMemoryStream;
  i: Integer;
  Attr: Cardinal;
begin
  Stream := TMemoryStream.Create;
  try
    Writer := TPropWriter.Create(Stream, 1024);
    try
      Writer.WriteListBegin;
      for i := 0 to High(ExtraFieldProps) do
        WriteProp(Field, ExtraFieldProps[i], Writer);
      Writer.WriteListEnd;
      Writer.FlushBuffer;
      if Stream.Size > 2 then
      begin
        Attr := (dsfldBYTES shl dsSizeBitsLen) or dsArrayFldType or SizeOf(Byte) or dsIncInDelta;
        PInteger(FBuffer)^ := Stream.Size;
        Move(Stream.Memory^, FBuffer[SizeOf(Integer)], Stream.Size);
        Check(FIDSWriter.AddAttribute(fldAttrArea, szFIELDPROPS, Attr,
          Stream.Size + SizeOf(Integer), FBuffer));
      end;
    finally
      Writer.Free;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TDataPacketWriter.AddColumn(const Info: TPutFieldInfo);

  procedure AddFieldDesc(const FldName: string; FldType, Attributes: Integer);
  var
    FldDesc: TDSDataPacketFldDesc;
  begin
    if Length(FldName) >= SizeOf(FldDesc.szFieldName) then
      raise EDSWriter.CreateFmt(SFieldNameTooLong,[SizeOf(FldDesc.szFieldName) - 1]);
    FillChar(FldDesc, SizeOf(FldDesc), 0);
    StrLCopy(FldDesc.szFieldName, PChar(FldName), SizeOf(FldDesc.szFieldName) - 1);
    FldDesc.iFieldType := FldType;
    FldDesc.iAttributes := Attributes;
    Check(FIDSWriter.AddColumnDesc(FldDesc));
  end;

  function ComputeInfoCount(Info: TInfoArray): Integer;
  var
    i: Integer;
  begin
    Result := Length(Info);
    for i := 0 to High(Info) do
      if Info[i].FieldInfos <> nil then
        Inc(Result, ComputeInfoCount(Info[i].FieldInfos));
  end;

  procedure AddMinMax(AField: TField);
  begin
    case AField.DataType of
      ftInteger, ftSmallInt:    
        if (TIntegerField(AField).MinValue <> 0) or 
           (TIntegerField(AField).MaxValue <> 0)  then
           begin
             AddAttribute(fldAttrArea, szMINVALUE, 
                           TIntegerField(AField).MinValue, False);
             AddAttribute(fldAttrArea, szMAXVALUE, 
                          TIntegerField(AField).MaxValue, False);
           end;
      ftCurrency, ftFloat:
        if (TFloatField(AField).MinValue <> 0 ) or 
           (TFloatField(AField).MaxValue <> 0 ) then
           begin
             AddAttribute(fldAttrArea, szMINVALUE, 
                           TFloatField(AField).MinValue, False);
             AddAttribute(fldAttrArea, szMAXVALUE, 
                          TFloatField(AField).MaxValue, False);
           end;
      ftBCD:
        if (TBCDField(AField).MinValue <> 0 ) or 
           (TIntegerField(AField).MaxValue <> 0 ) then
           begin
             AddAttribute(fldAttrArea, szMINVALUE, 
                           TBCDField(AField).MinValue, False);
             AddAttribute(fldAttrArea, szMAXVALUE, 
                          TBCDField(AField).MaxValue, False);
           end;
      ftFMTBcd:
        if (TFMTBcdField(AField).MaxValue <> '') or
           (TFMTBcdField(AField).MinValue <> '') then
           begin
             AddAttribute(fldAttrArea, szMINVALUE, 
                    VarFMTBcdCreate(TFMTBCDField(AField).MinValue, TFMTBCDField(AField).Precision, TFMTBCDField(AField).Size), False);
             AddAttribute(fldAttrArea, szMAXVALUE, 
                    VarFMTBcdCreate(TFMTBCDField(AField).MaxValue, TFMTBCDField(AField).Precision, TFMTBCDField(AField).Size), False);
           end;
    end;
  end;

var
  FldType, Prec, Attr, i, Width: Integer;
  TempStr: string;
begin
  if Info.IsDetail and (Info.Field = nil) then
  begin
    FldType := (dsfldEMBEDDEDTBL shl dsSizeBitsLen) or
      ComputeInfoCount(Info.FieldInfos) or dsPseudoFldType;
    AddFieldDesc(Info.DataSet.Name, FldType, 0);
    WriteMetaData(Info.DataSet, TInfoArray(Info.FieldInfos));
  end else
  begin
    Width := 0;
    Attr := 0;
    if Info.Field.ReadOnly or (Info.Field.FieldKind <> fkData) then Attr := Attr or fldAttrREADONLY;
    if Info.Field.Required and (Info.Field.DataType <> ftAutoInc) then Attr := Attr or fldAttrREQUIRED;
    if (pfHidden in Info.Field.ProviderFlags) then Attr := Attr or fldAttrHIDDEN or fldAttrREADONLY;
    FldType := PacketTypeMap[Info.Field.DataType];
    case Info.Field.DataType of
      ftTimeStamp:
        FldType := (FldType shl dsSizeBitsLen) or sizeof(TSQLTimeStamp);
      ftString, ftFixedChar, ftVarBytes, ftGUID, ftWideString:
      begin
        FldType := FldType shl dsSizeBitsLen or dsVaryingFldType;
        if Info.Size < 255 then
          FldType := FldType or SizeOf(Byte) else
          FldType := FldType or SizeOf(Word);
        Width := Info.Size;
      end;
      ftBCD:
      begin
        if TBCDField(Info.Field).Precision = 0 then
          Width := 32 else
          Width := TBCDField(Info.Field).Precision;
        Prec := Width shr 1;
        Inc(Prec, Prec and 1);  { Make an even number }
        FldType := (FldType shl dsSizeBitsLen) or (Prec + 2);
      end;
      ftFMTBcd:
      begin
        if TFMTBCDField(Info.Field).Precision = 0 then
          Width := 32 else
          Width := TFMTBCDField(Info.Field).Precision;
        Prec := Width shr 1;
        Inc(Prec, Prec and 1);  { Make an even number }
        FldType := (FldType shl dsSizeBitsLen) or (Prec + 2);
      end;
      ftArray:
        FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
          dsCompArrayFldType or TObjectField(Info.Field).Size;
      ftADT:
        FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
          TObjectField(Info.Field).FieldCount;
      ftDataSet, ftReference:
        FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
          dsEmbeddedFldType or ComputeInfoCount(TInfoArray(Info.FieldInfos));
    else
      if Info.Field.IsBlob then
      begin
        FldType := (FldType shl dsSizeBitsLen) or dsVaryingFldType or SizeOf(Integer);
        Width := Info.Field.Size;
      end else
        FldType := (FldType shl dsSizeBitsLen) or Info.Size;
    end;
    AddFieldDesc(Info.Field.FieldName, FldType, Attr);
    if (Info.Field.FieldKind <> fkData) then
      AddAttribute(fldAttrArea, szSERVERCALC, True, True);
    if Info.Field.ProviderFlags <> [pfInWhere, pfInUpdate] then
      AddAttribute(fldAttrArea, szPROVFLAGS, Byte(Info.Field.ProviderFlags), True);
    if Info.Field.Origin <> '' then
      AddAttribute(fldAttrArea, szORIGIN, Info.Field.Origin, True);
    if Width > 0 then
      AddAttribute(fldAttrArea, szWIDTH, Width, False);
    if Info.Field is TBCDField then 
    begin
      if TBCDField(Info.Field).Size <> 0 then
        AddAttribute(fldAttrArea, szDECIMALS, TBCDField(Info.Field).Size, False);
    end
    else if Info.Field is TFMTBCDField then 
    begin
      if TFMTBCDField(Info.Field).Size <> 0 then
        AddAttribute(fldAttrArea, szDECIMALS, TFMTBCDField(Info.Field).Size, False);
    end;
    AddMinMax(Info.Field);
    case Info.Field.DataType of
      ftCurrency: TempStr := szstMONEY;
      ftAutoInc: TempStr := szstAUTOINC;
      ftVarBytes, ftBlob: TempStr := szstBINARY;
      ftMemo: TempStr := szstMEMO;
      ftFmtMemo: TempStr := szstFMTMEMO;
      ftParadoxOle: TempStr := szstOLEOBJ;
      ftGraphic: TempStr := szstGRAPHIC;
      ftDBaseOle: TempStr := szstDBSOLEOBJ;
      ftTypedBinary: TempStr := szstTYPEDBINARY;
      ftADT:
        if (Info.Field.ParentField <> nil) and
           (Info.Field.ParentField.DataType in [ftDataSet, ftReference]) then
          TempStr := szstADTNESTEDTABLE;
      ftReference: TempStr := szstREFNESTEDTABLE;
      ftString:
        if TStringField(Info.Field).FixedChar then
          TempStr := szstFIXEDCHAR else
          TempStr := '';
      ftGUID: TempStr := szstGUID;
      ftOraClob: TempStr := szstHMEMO;
      ftOraBlob: TempStr := szstHBINARY;
    else
        TempStr := '';
    end;
    if TempStr <> '' then
      AddAttribute(fldAttrArea, szSUBTYPE, TempStr, False);
    if Info.Field is TObjectField then
      AddAttribute(fldAttrArea, szTYPENAME, TObjectField(Info.Field).ObjectType, False);
    if poIncFieldProps in Options then
      AddExtraFieldProps(Info.Field);
    case Info.Field.DataType of
      ftADT, ftArray: { Array will only have 1 child field }
        for i := 0 to High(TInfoArray(Info.FieldInfos)) do
          AddColumn(TInfoArray(Info.FieldInfos)[i]);
      ftDataSet, ftReference:
        with TDataSetField(Info.Field) do
          WriteMetaData(NestedDataSet, TInfoArray(Info.FieldInfos),
            Info.Field.DataType = ftReference);
    end;
  end;
end;

procedure TDataPacketWriter.AddConstraints(DataSet: TDataSet);
type
  TConstraintType = (ctField, ctRecord, ctDefault);

  procedure AddSQLExprAttr(ExprParser: TExprParser; const ExprText, ExprErrMsg,
    FieldName: string; FieldIndex: Integer; ConstraintType: TConstraintType;
    Required: Boolean);
  type
    PSQLExprInfo = ^TSQLExprInfo;
    TSQLExprInfo = packed record
      iErrStrLen: Integer;
      iFldNum: Integer;
      bReqExpr: BYTE;
    end;
  const
    TypeStr: array[TConstraintType] of PChar = (szBDEDOMX, szBDERECX, szBDEDEFX);
    Attr: Integer = dsVaryingFldType or SizeOf(Integer) or (dsfldBYTES shl dsSizeBitsLen);
  var
    ErrorStr: string;
    AttrType: PChar;
    Len, AttrSize: Integer;
    SQLExprInfo: PSQLExprInfo;
    Options: TParserOptions;
  begin
    if ExprText = '' then Exit;
    if (ConstraintType <> ctDefault) and (ExprErrMsg = '') then
    begin
      if (ConstraintType = ctField) and (FieldName <> '') then
        ErrorStr := Format('%s %s: %s %s',[SConstraintFailed, SField, FieldName, ExprText]) else
        ErrorStr := Format('%s %s',[SConstraintFailed, ExprText]);
    end else
      ErrorStr := ExprErrMsg;
    Len := Length(ErrorStr);
    if (Len > 0) then Inc(Len);
    SQLExprInfo := @FBuffer[SizeOf(Integer)];
    SQLExprInfo.iErrStrLen := Len;
    SQLExprInfo.iFldNum := FieldIndex;
    SQLExprInfo.bReqExpr := Ord(Required);
    Options := [poExtSyntax];
    if ConstraintType = ctDefault then Include(Options, poDefaultExpr);
    if ConstraintType = ctRecord then Include(Options, poUseOrigNames);
    if FieldName <> '' then Include(Options, poFieldNameGiven);
    with ExprParser do
    begin
      SetExprParams(ExprText, [], Options, FieldName);
      Move(FilterData[0], FBuffer[SizeOf(TSQLExprInfo) + Len + SizeOf(Integer)], DataSize);
      AttrSize := DataSize + SizeOf(TSQLExprInfo) + Len;
    end;
    PInteger(FBuffer)^ := AttrSize;
    if Len > 0 then
      StrLCopy(@FBuffer[SizeOf(TSQLExprInfo) + SizeOf(Integer)], PChar(ErrorStr), Length(FBuffer) - SizeOf(TSQLExprInfo) - SizeOf(Integer) - 1);
    AttrType := TypeStr[ConstraintType];
    Check(FIDSWriter.AddAttribute(pcktAttrArea, AttrType, Attr, AttrSize + SizeOf(Integer), PByte(FBuffer)));
  end;

var
  i: Integer;
  ExprParser: TExprParser;
  Constraints: TCheckConstraints;
  Obj: TObject;
  ErrMsg: string;
begin
  ExprParser := TExprParser.Create(DataSet, '', [], [], '', nil, FieldTypeMap);
  try
    Obj := GetObjectProperty(DataSet, 'Constraints'); { Do not localize }
    if (Obj <> nil) and (Obj is TCheckConstraints) then
    begin
      Constraints := Obj as TCheckConstraints;
      try
        for i := 0 to Constraints.Count - 1 do
          with Constraints[i] do
          begin
            AddSQLExprAttr(ExprParser, ImportedConstraint, ErrorMessage, '', 0,
              ctRecord, False);
            AddSQLExprAttr(ExprParser, CustomConstraint, ErrorMessage, '', 0,
              ctRecord, False);
          end;
      except
        if DataSet.Name <> '' then
          ErrMsg := Format('%s: %s',[DataSet.Name, SRecConstFail]) 
        else
          ErrMsg := SRecConstFail;
        if ExceptObject is Exception then
          raise EDSWriter.CreateFmt(ErrMsg, [Exception(ExceptObject).Message])