adataset.pas

delphi通过OCI访问ORACLE

procedure TAField.SetAsWord(RecordNum: integer; Value: Word);
begin
 TestType(ftoWord);
 IsNull[RecordNum] := False;
 if(Values <> nil)
  then THArrayWord(Values)[RecordToInternal(RecordNum)] := Value
  else raise Exception.CreateFmt(SErrRecordNotFound, [RecordNum]);
end;

procedure TAField.SetAsInt64(RecordNum: integer; Value: int64);
begin
 TestType(ftoInt64);
 IsNull[RecordNum] := False;
 if(Values <> nil)
  then THArrayInt64(Values)[RecordToInternal(RecordNum)] := Value
  else raise Exception.CreateFmt(SErrRecordNotFound, [RecordNum]);
end;

procedure TAField.SetIsNull(RecordNum: integer; Value: boolean);
begin
 if ValuesNull = nil then exit;
 ValuesNull[RecordToInternal(RecordNum)]:=not Value;
end;

procedure TAField.SetValue(RecordNum: integer; Value: variant);
begin
 if Value = Null then begin
  IsNull[RecordNum] := True;
  exit;
 end;
 case FieldType of
  ftoString:   AsString[RecordNum]   := Value;
  ftoSmallint: AsSmallInt[RecordNum] := Value;
  ftoInteger:  AsInteger[RecordNum]  := Value;
  ftoWord:     AsWord[RecordNum]     := Value;
  ftoBoolean:  AsBoolean[RecordNum]  := Value;
  ftoDouble:   AsDouble[RecordNum]   := Value;
  ftoCurrency: AsCurrency[RecordNum] := Value;
  ftoDate:     AsDate[RecordNum]     := DateTimeToGoodDate(Value);
  ftoTime:     AsTime[RecordNum]     := DateTimeToGoodTime(Value);
  ftoDateTime: AsDateTime[RecordNum] := DateTimeToGoodDateTime(Value);
  ftoBlob,ftoClob :
       raise Exception.Create('Use WriteBlob method to operate with BLOB and CLOB fields !');
  else
    raise Exception.Create(SUnknownFieldType);
 end;
end;

procedure TAField.TestType(t: TAFieldType);
begin
 if t <> FFieldType
   then raise Exception.Create(Format(SFieldTypeMismatch,[FName,AFieldTypeNames[FFieldType],AFieldTypeNames[t]]));
end;

procedure TAField.ClearBlob(RecordNum: integer);
begin
 TestType(ftoBlob);
 FreeMem(THArrayPointer(Values)[RecordNum]);
 THArrayPointer(Values)[RecordNum]:=nil;
 ValuesNull[RecordNum]:=False; // flag that Blob is NULL
 ValuesSize[RecordNum]:=0      // set length to 0
end;

function TAField.ReadBlob(RecordNum, Offset: integer; Buffer: pointer; Size: integer): cardinal;
var pc:PChar;
    RealSize,pi,c:integer;
begin
 TestType(ftoBlob);
 Result:=0;
 if IsNull[RecordNum] then exit; // BLOB is empty
 pi:=cardinal(THArrayPointer(Values)[RecordNum]); // pointer to memory where BLOB field data stores
 if pi=0 then exit; // BLOB is empty
 RealSize:=ValuesSize[RecordNum];
 if Offset>=RealSize then exit;  // the requested offset larger than length of BLOB field

 pc:=PChar(pi+offset);

 c:=min(RealSize-offset,Size);
 memcpy(pc,Buffer,c);
 Result:=c;
end;

function TAField.WriteBlob(RecordNum, Offset: integer; Buffer: pointer; Size: integer): cardinal;
// if Offset>0 then Offset+Size bytes of memory will be allocated and
var pc:PChar;
    pi:integer;
begin
 TestType(ftoBlob);
 Result := Size;

// if(Offset=0)or(Size=0) then ClearBlob(RecordNum);

 if Size > 0 then begin // do we have any data?
  pc := THArrayPointer(Values)[RecordNum];
  ReallocMem(pc, Offset + Size);
  THArrayPointer(Values)[RecordNum] := pc;
  pi := integer(pc);
  pc := PChar(pi + offset);
  memcpy(Buffer, pc, Size);
  IsNull[RecordNum] := False; // flag that BLOB field is not empty
 end;
 ValuesSize[RecordNum] := Offset + Size;
end;

function TAField.ReadBlobToStream(RecordNum: integer;Stream: TStream): cardinal;
var buf:array[0..16383] of byte;
    sz:cardinal;
    Offset:integer;
begin
 Result:=0; Offset:=0;
 repeat
  sz:=ReadBlob(RecordNum,Offset,@buf,sizeof(buf));
  Result:=Result+sz;
  inc(Offset,sz);
  Stream.Write(buf,sz);
 until sz<>sizeof(buf);
end;

function TAField.WriteBlobFromStream(RecordNum: integer;Stream: TStream): cardinal;
var buf:array[0..16383] of byte;
    sz:integer;
    Offset:integer;
begin
 ClearBlob(RecordNum);
 Result:=0; Offset:=0;
 Stream.Seek(0,soFromBeginning);
 if Stream.Size>0 then begin
  repeat
   sz:=Stream.Read(buf,sizeof(buf));
   Result:=Result+WriteBlob(RecordNum,Offset,@buf,sz);
   inc(Offset,sz);
  until Offset=Stream.Size;
 end;
end;

function TAField.GetLobLength(RecordNum: integer): integer;
begin
// if (RecordNum<0)or(RecordNum>=ValuesSize.Count) then raise Exception.Create('The Record number '+IntToStr(RecordNum)+' is more than RecordCount='+IntToStr(ValuesSize.Count)+'!');
 Result:=ValuesSize[RecordToInternal(RecordNum)];
end;


{ TADataSet }

procedure TADataSet.AllocateFields;
var i:integer;
begin
 for i:=0 to FFields.Count-1 do TAField(FFields[i]).Allocate;
end;

procedure TADataSet.AppendRecord;
begin
 InsertRecord(RecordCount);
end;

procedure TADataSet.ClearFields;
var i:integer;
begin
 for i:=0 to FFields.Count-1 do TAField(FFields[i]).Free;
 FFields.Clear;
end;
                    
procedure TADataSet.ClearParams;
var i:integer;
begin
 for i:=0 to FParams.Count-1 do TAParam(FParams[i]).Free;
 FParams.Clear;
end;

procedure TADataSet.Close;
begin
 EmptyFields;
 FActive:=False;
 FCount:=0;
end;

constructor TADataSet.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FFields := THArrayPointer.Create;
 FParams := THArrayPointer.Create;
// FSortIndex:=nil;
 FBeginRecord := 0;
 FCurrentRec  := -1;
 FCount := 0;
 FActive := False;
end;

destructor TADataSet.Destroy;
begin
{$ifdef ADEBUG}LogMessage('TADataSet.Destroy BEGIN');{$endif}

 if FActive then Close;
 ClearFields;
 FFields.Free;
 ClearParams;
 FParams.Free;
 inherited Destroy;

 {$ifdef ADEBUG}LogMessage('TADataSet.Destroy END');{$endif}
end;

procedure TADataSet.AddField(FieldName: string; FieldType: TAFieldType;FieldSize: word; Required: boolean);
var F:TAField;
    i:integer;
begin
 if FieldName = '' then ADatabaseError(SFieldNameMissing, self);
 for i:=0 to FFields.Count-1 do
  if AnsiCompareText(TAField(FFields[i]).Name,FieldName)=0 then ADatabaseError(Format(SDuplicateFieldName,[FieldName,self.name]));

 F:=CreateAField(FieldName,FieldType,FieldSize,Required);
 FFields.AddValue(F);
end;

function TADataSet.CreateAField(FieldName:string;FieldType:TAFieldType;FieldSize:word;Required:boolean): TAField;
begin
 Result:=TAField.Create(self,FieldName,FieldType,FieldSize,Required);
end;


{procedure TADataSet.AddParam(ParamName:string;FieldType:TAFieldType;ParamType:TAParamType);
var i:integer;
begin
 if ParamName = '' then ADatabaseError('Paramter name missing!', self);
 for i:=0 to FParams.Count-1 do
  if AnsiCompareText(TAParam(FParams[i]).Name,ParamName)=0 then ADatabaseError(Format(SDuplicateName,[ParamName,self.name]));

 FParams.AddValue(TAParam.Create(ParamName,FieldType,ParamType));
end;}

procedure TADataSet.DeleteRecord(RecordNum: integer);
var i:integer;
begin
 CheckActive;

 if(RecordNum < 0) or (RecordNum >= FCount)
   then raise Exception.Create('Record with number ' + IntToStr(RecordNum) + ' not found!');

 for i := 0 to FFields.Count - 1 do begin
   TAField(FFields[i]).DeleteRecord(RecordNum);
 end;

 FCount := FCount - 1;
 if Assigned(FBeforeDelete) then FBeforeDelete(Self, RecordNum);
end;

procedure TADataSet.InsertRecord(RecordNum: integer);
var i:integer;
begin
 CheckActive;

 if(RecordNum < 0) or (RecordNum > FCount)
   then raise Exception.Create('Record number ' + IntToStr(RecordNum) + ' too large! Cannot insert.');

 for i := 0 to FFields.Count - 1 do begin
  TAField(FFields[i]).InsertRecord(RecordNum);
 end;

 FCount := FCount + 1;
 if Assigned(FAfterInsert) then FAfterInsert(Self, RecordNum);
end;

procedure TADataSet.EmptyFields;
var i:integer;
begin
 for i:=0 to FFields.Count-1 do TAField(FFields[i]).Clear;
end;

procedure TADataSet.ForgetValues;
var i:integer;
begin
 for i:=0 to FFields.Count-1 do begin
  TAField(FFields.Value[i]).Values.Clear;
  if Assigned(TAField(FFields.Value[i]).ValuesNull)
   then TAField(FFields.Value[i]).ValuesNull.Clear;
  if Assigned(TAField(FFields.Value[i]).ValuesSize)
   then TAField(FFields.Value[i]).ValuesSize.Clear;
 end;
end;

function TADataSet.GetFieldByName(FieldName: string): TAField;
var n:integer;
begin
 n := GetFieldID(FieldName);
 if n = -1
   then raise Exception.Create('Field '''+FieldName+''' not found!');
 Result := FFields[n];
end;

function TADataSet.GetFieldByIndex(Index: integer): TAField;
begin
 if(Index<0)or(Index>=FFields.Count)then raise Exception.Create(SFieldIndexError);
 Result:=FFields[Index];
end;

function TADataSet.GetFieldCount: integer;
begin
 Result:=FFields.Count;
end;

function TADataSet.GetFieldID(FieldName: string): integer;
begin
  for Result:=0 to FFields.Count-1 do
  if AnsiCompareText(TAField(FFields[Result]).Name,FieldName)=0 then exit;
  Result:=-1;
end;

function TADataSet.FieldExists(FieldName: string): boolean;
begin
 Result:=GetFieldID(FieldName)>=0;
end;

function TADataSet.GetParamByIndex(Index: integer): TAParam;
begin
 if(Index<0)or(Index>=FParams.Count)then raise Exception.Create('Param with index '+IntToStr(Index)+' does not exists!');
 Result:=FParams[Index];
end;

function TADataSet.ParamExists(ParamName: string): boolean;
begin
 Result:=GetParamID(ParamName)>=0;
end;

function TADataSet.GetParamByName(ParamName: string): TAParam;
var i:integer;
begin
 i:=GetParamID(ParamName);
 if i=-1 then raise Exception.Create('Param '''+ParamName+''' not found !') //Result:=nil
         else Result:=FParams[i];
end;

function TADataSet.GetParamID(ParamName: string): integer;
begin
 for Result:=0 to FParams.Count-1 do
  if AnsiCompareText(TAParam(FParams[Result]).Name,ParamName)=0 then exit;
 Result:=-1;
end;

procedure TADataSet.Loaded;
begin
 inherited Loaded;
 Active:=FStreamedActive;
end;

procedure TADataSet.Open;
begin
 if FActive then exit;
 AllocateFields;
 FActive:=True;
 FCount:=0;
end;

procedure TADataSet.Open(Fields: THArrayPointer);
var i:integer;
begin
// if FActive then exit;
 if Fields.Count>0 then begin
  for i:=0 to Fields.Count-1 do TAField(Fields[i]).FParent:=self;
  FFields.Clear;
  FFields.AddMany(Fields.Memory,Fields.Count);
  FActive:=True;
  FCount:=TAField(FFields[0]).Values.Count;
 end else Open;
end;

procedure TADataSet.OpenAll;
begin
 Open;
 ReadAll;
end;

function TADataSet.ReadRecord(RecordNum: integer):boolean;
begin
 Result := FCount > RecordNum;
end;

procedure TADataSet.ReOpen;
begin
 Close;
 Open;
end;

procedure TADataSet.SetActive(Value: boolean);
begin
 if (csReading in ComponentState) then  begin
   if Value then FStreamedActive := True;
   exit;
 end;
// if (csDestroying in ComponentState) then exit;
 if Value=FActive then exit;
 if Value then Open else Close;
end;

procedure TADataSet.SaveToDBF(FileName:string);
{ ============================================================