zquery.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

    DatabaseError('Fatal internal error');

  if (Field.DataType = ftBCD) and (Buffer <> nil) then
  begin
    Result := SqlBuffer.GetFieldData(FieldDesc, @TempCurr, RecBuffer);
    if Result then
{-$IFDEF VER130ABOVE}
      CurrToBCD(TempCurr, TBCD(Buffer^), 32, Field.Size);
{-$ELSE}
     // CurrToBCD(TempCurr, Buffer, 32, Field.Size);
{-$ENDIF}
  end
  else
    Result := SqlBuffer.GetFieldData(FieldDesc, Buffer, RecBuffer);
end;

{ Retrive data from TField into record buffer }
procedure TZDataset.SetFieldData(Field: TField; Buffer: Pointer);
var
  RecBuffer: PRecordData;
  FieldDesc: PFieldDesc;
  TempCurr: System.Currency;
begin
  if not GetActiveRecBuf(RecBuffer) then Exit;

  if State in [dsEdit, dsInsert] then
    Field.Validate(Buffer);
  FieldDesc := SqlBuffer.SqlFields.FindByField(Field);
  if not Assigned(FieldDesc) then
    DatabaseError('Fatal internal error');

  if (Field.DataType = ftBCD) and (Buffer <> nil) then
  begin
{-$IFDEF VER130ABOVE}
    BCDToCurr(TBCD(Buffer^), TempCurr);
{-$ELSE}
   // BCDToCurr(Buffer, TempCurr);
{-$ENDIF}
    SqlBuffer.SetFieldData(FieldDesc, @TempCurr, RecBuffer);
  end
  else
    SqlBuffer.SetFieldData(FieldDesc, Buffer, RecBuffer);

  if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
    DataEvent(deFieldChange, LongInt(Field));
end;

function TZDataset.GetFieldClass(FieldType: TFieldType): TFieldClass;
begin
  if FieldType = ftBCD then
    Result := TZBCDField
  else
    Result := inherited GetFieldClass(FieldType);
end;

{ Check if cursor open (??) }
function TZDataset.IsCursorOpen: Boolean;
begin
  Result := Query.Active or Active or (SqlBuffer.Count > 0);
end;

{ Get current affected rows }
function TZDataset.RowsAffected: LongInt;
begin
  Result := FRowsAffected;
end;

{ Internal methods for buffers processing }

{ Get record buffer size }
function TZDataset.GetRecordSize: Word;
begin
  Result := SqlBuffer.RecBufSize;
end;

{ Allocate record buffer in memory }
function TZDataset.AllocRecordBuffer: PChar;
begin
  Result := AllocMem(SqlBuffer.RecBufSize);
  SqlBuffer.InitRecord(PRecordData(Result));
end;

{ Free allocated buffer }
procedure TZDataset.FreeRecordBuffer(var Buffer: PChar);
begin
  SqlBuffer.FreeRecord(PRecordData(Buffer), False);
  FreeMem(Buffer);
end;

{ Get current record buffer }
function TZDataset.GetActiveRecBuf(var Value: PRecordData): Boolean;
var
  N: Integer;
  CheckState: TDatasetState;
begin
  Value := nil;
  CheckState := State;
  if FNewValueState then
    CheckState := dsNewValue;
  case CheckState of
    dsBrowse:
      if not IsEmpty then
        Value := PRecordData(ActiveBuffer);
    dsEdit, dsInsert:
      Value := PRecordData(ActiveBuffer);
    dsCalcFields:
      Value := PRecordData(CalcBuffer);
    dsNewValue, dsCurValue:
      if (CurRec >= 0) and (CurRec < SqlBuffer.Count) then
        Value := SqlBuffer[CurRec];
    dsOldValue:
      begin
        if (CurRec >= 0) and (CurRec < SqlBuffer.Count) then
        begin
          N := CacheBuffer.IndexOfIndex(SqlBuffer[CurRec].Index);
          if N >= 0 then
            Value := CacheBuffer[N]
          else
            Value := SqlBuffer[CurRec];
        end
      end;
  end;
  Result := Value <> nil;
end;

{ Exec a non SELECT Sql query }
procedure TZDataset.ExecSql;
begin
  AutoFillObjects;

  if Assigned(TransactObj) then
  begin
    TransactObj.Connected := True;
    SqlParser.UpdateText;
    FRowsAffected := TransactObj.ExecSql(ConvertToSqlEnc(SqlParser.Text));
  end else
    DatabaseError(STransactNotDefined);
end;

{ After Load properties method }
procedure TZDataset.Loaded;
begin
  FAutoStart := True;
  inherited Loaded;
  FAutoStart := False;
end;

{ Update field parameters }
procedure TZDataset.UpdateFieldDef(FieldDesc: PFieldDesc;
  var FieldType: TFieldType; var FieldSize: Integer);
begin
  { Fix unknown blobs }
  if (FieldDesc = nil) and (FieldType = ftBlob) and (DatabaseType = dtPostgreSql) then
    FieldType := ftInteger;

  if FieldType <> ftBCD then
  begin
    { Fix string length }
    if FieldType <> ftString then FieldSize := 0
    else FieldSize := Min(MAX_STRING_SIZE, FieldSize);
    if (FieldType = ftString) and (FieldSize = 0) then
      FieldSize := DEFAULT_STRING_SIZE;
    if (FieldType = ftBytes) and (FieldSize = 0) then
      FieldSize := DEFAULT_STRING_SIZE;
  end;
  { Autoinc fields }
  if (doEnableAutoInc in Options) and (FieldDesc <> nil)
    and (FieldType = ftInteger) and (FieldDesc.AutoType in [atAutoInc, atIdentity]) then
    FieldType := ftAutoInc;
end;

{ Define all fields in a query }
procedure TZDataset.InternalInitFieldDefs;
var
  SaveActive: Boolean;
  I: Integer;
  FieldName: string;
  FieldRequired: Boolean;
  FieldSize: Integer;
  FieldType: TFieldType;
  FieldNo: Integer;
  FieldDesc: PFieldDesc;
  FieldReadOnly: Boolean;
begin
  { Set start values }
  FieldDefs.Clear;
  FieldNo := 1;
  { Open connections for separate func call }
  SaveActive := Query.Active;
  if not Query.Active then
  begin
    CreateConnections;
    { Define all tables fields }
    if RequestLive or not (doQuickOpen in Options)then
      SqlParser.DefineTableDefs;
    { Open a query }
    Query.Sql := ConvertToSqlEnc(SqlParser.Text);
    Query.Open;
  end;
  { Create TField for every query field }
  for I := 0 to Query.FieldCount - 1 do
  begin
    if (I = 0) and SqlParser.UsedRowId then
      Continue;

    FieldRequired := False;
    FieldDesc := SqlParser.SqlFields.FindByAlias(Query.FieldAlias(I));
    if Assigned(FieldDesc) then
    begin
      { Process table fields }
      FieldName := FieldDesc.Alias;
      FieldType := FieldDesc.FieldType;
      if FieldType = ftBCD then
        FieldSize := FieldDesc.Decimals
      else
        FieldSize := FieldDesc.Length;
      FieldRequired := not FieldDesc.IsNull and (FieldDesc.AutoType = atNone);
      FieldReadOnly := FieldDesc.ReadOnly;
    end
    else
    begin
      { Process calc and unknown fields }
      FieldName := Query.FieldAlias(I);
      if FieldType = ftBCD then
        FieldSize := Query.FieldDecimals(I)
      else
        FieldSize := Max(Query.FieldSize(I), Query.FieldMaxSize(I));
      FieldType := Query.FieldDataType(I);
      FieldReadOnly := Query.FieldReadOnly(I);
    end;
    { Correct field size }
    UpdateFieldDef(FieldDesc, FieldType, FieldSize);
    { Add new field def }
    with TFieldDef.Create(FieldDefs, FieldName, FieldType, FieldSize,
        FieldRequired, FieldNo) do
    begin
{$IFNDEF VER100}
      if FieldReadOnly then
        Attributes := Attributes + [faReadonly];
{$ENDIF}
    end;
    Inc(FieldNo);
  end;
  { Restore dataset state }
  if not SaveActive then
    Query.Close;
end;

{ Update index defs }
procedure TZDataset.UpdateIndexDefs;
begin
  FieldDefs.Update;
  SqlParser.UpdateIndexDefs(IndexDefs);
end;

{ Create demanded connections }
procedure TZDataset.CreateConnections;
begin
  { Check database and transact components }
  if not Assigned(DatabaseObj) then
    DatabaseError(SConnectNotDefined);
  if not Assigned(TransactObj) then
    DatabaseError(STransactNotDefined);
  { Check connect }
  TransactObj.Connect;
  if not TransactObj.Connected then
    DatabaseError(SConnectTransactError);
end;

{ Internal open query }
procedure TZDataset.InternalOpen;
var
  Error: string;
{$IFNDEF NO_GUI}
  OldCursor: TCursor;
{$ENDIF}
begin
  { Make auto-open }
  if FAutoStart and (not Assigned(DatabaseObj) or not Assigned(TransactObj)) then
  begin
    FAutoOpen := True;
    Exit;
  end;
  { Autofill objects }
  AutoFillObjects;
  { Change cursor }
{$IFNDEF NO_GUI}
  OldCursor := Screen.Cursor;
{$ENDIF}
  try
{$IFNDEF NO_GUI}
    if doHourGlass in FOptions then
      Screen.Cursor := crSqlWait;
{$ENDIF}
    { Set mail query params }
    FRowsAffected := 0;
    CurRec := -1;
    FMasterIndex := -1;
    FAutoOpen := False;
    FLinkCheck := False;
    { Create necessary connections }
    CreateConnections;
    { Set sql statement }
    SqlParser.ExtraOrderBy := FormTableSqlOrder;
    Query.Sql := ConvertToSqlEnc(SqlParser.Text);
    { Define all tables fields }
    if RequestLive or not (doQuickOpen in Options) then
      SqlParser.DefineTableDefs;
    { Update master-detail links }
    if Assigned(MasterSource) and (loLinkRequery in LinkOptions) then
      MasterRequery
    else if Assigned(DataSource) then
      ParamsRequery;
    { Set cursor fetch mode }
    Query.UseCursor := (doCursorFetch in Options);
    { Open the query }
    if Trim(Query.Sql) = '' then
      DatabaseError('Empty Query');
    if not Query.Active then
      Query.Open;
    if not Query.Active then
    begin
      Error := ConvertFromSqlEnc(Query.Error);
      if Assigned(TransactObj) then
        TransactObj.Recovery(True);
      if Error <> '' then
        DatabaseError(Error);
    end;
    { Initialize field and index defs }
    InternalInitFieldDefs;
    if DefaultFields then
      CreateFields;
    BindFields(True);
    { Update field and index defs }
    SqlParser.UpdateIndexDefs(IndexDefs);
    SqlBuffer.BindFields(SqlParser.SqlFields);
    SqlBuffer.BindIndices(IndexDefs, SqlParser.SqlIndices);
    CacheBuffer.SetCache(SqlBuffer);
    { Fetch records }
    QueryRecords(False);
    if Assigned(MasterSource) then
      MasterRequery;
    { Set index sorting }
    if FIndexName <> '' then
      SetIndex(FIndexName, FFieldsIndex);
  finally
{$IFNDEF NO_GUI}
    if doHourGlass in FOptions then
      Screen.Cursor := OldCursor;
{$ENDIF}
  end;
end;

{ Internal close qiery }
procedure TZDataset.InternalClose;
{$IFNDEF NO_GUI}
var
  OldCursor: TCursor;
{$ENDIF}
begin
{$IFNDEF NO_GUI}
  OldCursor := Screen.Cursor;
{$ENDIF}
  try
{$IFNDEF NO_GUI}
    if doHourGlass in FOptions then
      Screen.Cursor := crSqlWait;
{$ENDIF}
    { Clear all collections }
    Query.Close;
    SqlBuffer.ClearBuffer(True);
    CacheBuffer.ClearBuffer(True);
    SqlParser.Clear;
    { Destroy default fields }
    if DefaultFields then
      DestroyFields;
  finally
{$IFNDEF NO_GUI}
    if doHourGlass in FOptions then
      Screen.Cursor := OldCursor;
{$ENDIF}
  end;
end;

{ Internal go to first record }
procedure TZDataset.InternalFirst;
begin
  CurRec := -1;
end;

{ Internal go to last record }
procedure TZDataset.InternalLast;
begin
  QueryRecords(True);
  CurRec := SqlBuffer.Count;
end;

{ Internal exception processing }
procedure TZDataset.InternalHandleException;
begin
  Application.HandleException(Self);
end;

{ Get records quantity }
function TZDataset.GetRecordCount: Longint;
var
  I: LongInt;
begin
  if Filtered and not (doSqlFilter in Options) then
  begin
    QueryRecords(True);
    Result := 0;
    for I := 0 to SqlBuffer.Count-1 do
      if CheckRecordByFilter(I) then
        Inc(Result);
  end
  else
  begin
    if not Query.EOF then
      Result := Query.RecordCount
    else
      Result := SqlBuffer.Count;
  end;
end;

{ Get current record number }
function TZDataset.GetRecNo: Longint;
begin
  UpdateCursorPos;
  if (CurRec = -1) and (RecordCount > 0) then
    Result := 1
  else
    Result := CurRec + 1;
end;

{ Set currenct record number }
procedure TZDataset.SetRecNo(Value: Integer);
{$IFNDEF NO_GUI}
var
  OldCursor: TCursor;
{$ENDIF}
begin
{$IFNDEF NO_GUI}
  OldCursor := Screen.Cursor;
{$ENDIF}
  try
{$IFNDEF NO_GUI}