[JVCL-Checkins] CVS: dev/JVCL3/run JvUIBDataSet.pas,NONE,1.1 JvUIBMetaData.pas,NONE,1.1 JvUIBSQLParser.pas,NONE,1.1

[henri g. <pro...@us...>]

Update of /cvsroot/jvcl/dev/JVCL3/run
In directory sc8-pr-cvs1:/tmp/cvs-serv29405

Added Files:
	JvUIBDataSet.pas JvUIBMetaData.pas JvUIBSQLParser.pas 
Log Message:
UIB v1.1 rc3

--- NEW FILE: JvUIBDataSet.pas ---
{******************************************************************************}
{                                                                              }
{                        UNIFIED INTERBASE (UIB)                               }
{                                                                              }
{ Project JEDI Code Library (JCL)                                              }
{                                                                              }
{ The contents of this file are subject to the Mozilla Public License Version  }
{ 1.0 (the "License"); you may not use this file except in compliance with the }
{ License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ }
{                                                                              }
{ Software distributed under the License is distributed on an "AS IS" basis,   }
{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for }
{ the specific language governing rights and limitations under the License.    }
{                                                                              }
{ The Original Code is JvUIB.pas.                                              }
{                                                                              }
{ The Initial Developer of the Original Code is documented in the accompanying }
{ help file JCL.chm. Portions created by these individuals are Copyright (C)   }
{ 2000 of these individuals.                                                   }
{                                                                              }
{ UIB Dataset Descendants                                                      }
{                                                                              }
{ Unit owner:    Henri Gourvest                                                }
{ Last modified: September 21, 2003                                            }
{                                                                              }
{******************************************************************************}

unit JvUIBDataSet;

{$I JVCL.INC}
{$I JvUIB.inc}

interface

uses
  SysUtils, Classes, Db, JVUIB, JVUIBLib, JvUIBase, JvUIBConst;

type

  TUIBBookMark = record
    Bookmark: Longint;
    BookmarkFlag: TBookmarkFlag;
  end;
  PUIBBookMark = ^TUIBBookMark;

  TJvUIBCustomDataSet = class(TDataSet)
  private
    FStatement: TJvUIBStatement;
    FOnClose: TEndTransMode;
    FIsLast, FIsFirst: boolean;
    FCurrentRecord: Integer;
    FComplete: boolean;
    FIsOpen: Boolean;
    FRecordSize : Integer;
    FRecordBufferSize: Integer;
    procedure OnStatementClose(Sender: TObject);
    function GetOnError: TEndTransMode;
    function GetSQL: TStrings;
    function GetTransaction: TJvUIBTransaction;
    function GetUniDirectional: boolean;
    procedure SetOnClose(const Value: TEndTransMode);
    procedure SetOnError(const Value: TEndTransMode);
    procedure SetSQL(const Value: TStrings);
    procedure SetTransaction(const Value: TJvUIBTransaction);
    procedure SetUniDirectional(const Value: boolean);
    function GetFetchBlobs: boolean;
    procedure SetFetchBlobs(const Value: boolean);
    function GetParams: TSQLParams;
  protected

    procedure InternalOpen; override;
    procedure InternalClose; override;
    function IsCursorOpen: Boolean; override;

    function AllocRecordBuffer: PChar; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    function GetRecordSize: Word; override;

    function GetRecord(Buffer: PChar; GetMode: TGetMode;
      DoCheck: Boolean): TGetResult; override;
    procedure InternalFirst; override;
    procedure InternalLast; override;
    function GetRecNo: Longint; override;
    function GetRecordCount: Longint; override;
    procedure SetRecNo(Value: Integer); override;

    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;

    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    function GetCanModify: Boolean; override;

    procedure SetActive(Value: Boolean); override;

    property Transaction: TJvUIBTransaction read GetTransaction write SetTransaction;
    property UniDirectionnal: boolean read  GetUniDirectional write SetUniDirectional default False;
    property OnClose: TEndTransMode read FOnClose write SetOnClose default etmCommit;
    property OnError: TEndTransMode read GetOnError write SetOnError default etmRollback;
    property SQL: TStrings read GetSQL write SetSQL;
    property FetchBlobs: boolean read GetFetchBlobs write SetFetchBlobs default False;
    property Params: TSQLParams read GetParams;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; overload; override;
    function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; override;
    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
    procedure Execute;
    procedure ExecSQL;
  end;

  TJvUIBDataSet = class(TJvUIBCustomDataSet)
  public
    property Params;
  published
    property Transaction;
    property UniDirectionnal;
    property OnClose;
    property OnError;
    property SQL;
    property FetchBlobs;

    property Active;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeScroll;
    property AfterScroll;
  end;

implementation
uses FMTBCD;

procedure TJvUIBCustomDataSet.InternalOpen;
begin
  FRecordSize := SizeOf(Integer);
  InternalInitFieldDefs;
  if DefaultFields then
    CreateFields;
  BindFields (True);
  FStatement.Execute;
  FCurrentRecord := -1;
  FComplete := False;
  FRecordBufferSize := FRecordSize + sizeof (TUIBBookMark);
  BookmarkSize := sizeOf (Integer);
  FIsOpen := True;
end;

procedure TJvUIBCustomDataSet.InternalClose;
begin
  BindFields (False);
  if DefaultFields then
    DestroyFields;
  FStatement.Close(FOnClose);
  FIsOpen := False;
  FCurrentRecord := -1;
  FComplete := False;
end;

function TJvUIBCustomDataSet.IsCursorOpen: Boolean;
begin
  Result := FIsOpen;
end;

procedure TJvUIBCustomDataSet.InternalGotoBookmark (Bookmark: Pointer);
var
  ReqBookmark: Integer;
begin
  ReqBookmark := PInteger (Bookmark)^;
    FCurrentRecord := ReqBookmark
end;

procedure TJvUIBCustomDataSet.InternalSetToRecord (Buffer: PChar);
var
  ReqBookmark: Integer;
begin
  ReqBookmark := PUIBBookMark(Buffer + FRecordSize).Bookmark;
  InternalGotoBookmark (@ReqBookmark);
end;

function TJvUIBCustomDataSet.GetBookmarkFlag (
  Buffer: PChar): TBookmarkFlag;
begin
  Result := PUIBBookMark(Buffer + FRecordSize).BookmarkFlag;
end;

procedure TJvUIBCustomDataSet.SetBookmarkFlag (Buffer: PChar;
  Value: TBookmarkFlag);
begin
  PUIBBookMark(Buffer + FRecordSize).BookmarkFlag := Value;
end;

procedure TJvUIBCustomDataSet.InternalFirst;
begin
  FStatement.First;
  FIsFirst := True;
  FCurrentRecord := 0;
end;

procedure TJvUIBCustomDataSet.InternalLast;
begin
  FStatement.Last;
  FIsLast := True;
  FComplete := True;
  FCurrentRecord := FStatement.Fields.RecordCount - 1;
end;

procedure TJvUIBCustomDataSet.GetBookmarkData (
  Buffer: PChar; Data: Pointer);
begin
  PInteger(Data)^ :=
    PUIBBookMark(Buffer + FRecordSize).Bookmark;
end;

procedure TJvUIBCustomDataSet.SetBookmarkData (
  Buffer: PChar; Data: Pointer);
begin
  PUIBBookMark(Buffer + FRecordSize).Bookmark :=
    PInteger(Data)^;
end;

function TJvUIBCustomDataSet.GetRecordCount: Longint;
begin
  CheckActive;
  Result := FStatement.Fields.RecordCount;
end;

function TJvUIBCustomDataSet.GetRecNo: Longint;
begin
  UpdateCursorPos;
  Result := FCurrentRecord + 1;
end;

procedure TJvUIBCustomDataSet.SetRecNo(Value: Integer);
begin
  CheckBrowseMode;
  if (Value >= 1) and (Value <= FStatement.Fields.RecordCount) then
  begin
    FCurrentRecord := Value - 1;
    Resync([]);
  end;
end;

function TJvUIBCustomDataSet.GetRecord(Buffer: PChar;
  GetMode: TGetMode; DoCheck: Boolean): TGetResult;
begin
  Result := grOK;
  if (FCurrentRecord <> -1) and FStatement.CachedFetch then
    FStatement.Fields.CurrentRecord := FCurrentRecord;
  case GetMode of
    gmNext:
      begin
        if FIsFirst then
        begin
          FIsFirst := False;
        end else
          begin
            if (FCurrentRecord < FStatement.Fields.RecordCount - 1) then
            begin
              FStatement.Fields.CurrentRecord := FCurrentRecord + 1;
              inc(FCurrentRecord);
            end else
              if not FComplete then
              begin
                FStatement.Next;
                if FStatement.Eof then
                begin
                  Result := grEOF;
                  FComplete := True;
                end else
                  inc(FCurrentRecord);
              end else
               Result := grEOF;
          end;
      end;
    gmPrior:
      begin
        if FIsLast then
          FIsLast := False else
        if FStatement.Fields.CurrentRecord <= 0 then
          Result := grBOF else
          begin
            FStatement.Prior;
            dec(FCurrentRecord);
          end;
      end;
    gmCurrent:
      begin
        // nothing to do ...
      end;
  end;

  PInteger (Buffer)^ := FCurrentRecord;
  with PUIBBookMark(Buffer + FRecordSize)^ do
  begin
    case Result of
      grOK: BookmarkFlag := bfCurrent;
      grBOF: BookmarkFlag := bfBOF;
      grEOF: BookmarkFlag := bfEOF;
    end;
    Bookmark := PInteger (Buffer)^;
  end;
end;

procedure TJvUIBCustomDataSet.InternalInitRecord(Buffer: PChar);
begin
  FillChar(Buffer^, FRecordBufferSize, 0);
end;

procedure TJvUIBCustomDataSet.FreeRecordBuffer (var Buffer: PChar);
begin
  FreeMem (Buffer);
end;

function TJvUIBCustomDataSet.GetRecordSize: Word;
begin
  Result := FRecordSize;
end;

function TJvUIBCustomDataSet.AllocRecordBuffer: PChar;
begin
  GetMem(Result, FRecordBufferSize);
end;

procedure TJvUIBCustomDataSet.InternalHandleException;
begin
end;

function TJvUIBCustomDataSet.GetOnError: TEndTransMode;
begin
  Result := FStatement.OnError;
end;

function TJvUIBCustomDataSet.GetSQL: TStrings;
begin
  Result := FStatement.SQL;
end;

function TJvUIBCustomDataSet.GetTransaction: TJvUIBTransaction;
begin
  Result := FStatement.Transaction;
end;

function TJvUIBCustomDataSet.GetUniDirectional: boolean;
begin
  Result := not FStatement.CachedFetch;
end;

procedure TJvUIBCustomDataSet.SetOnClose(const Value: TEndTransMode);
begin
  FOnClose := Value;
end;

procedure TJvUIBCustomDataSet.SetOnError(const Value: TEndTransMode);
begin
  FStatement.OnError := Value;
end;

procedure TJvUIBCustomDataSet.SetSQL(const Value: TStrings);
begin
  CheckInactive;
  FStatement.SQL.Assign(Value);
  DataEvent(dePropertyChange, 0);
end;

procedure TJvUIBCustomDataSet.SetTransaction(
  const Value: TJvUIBTransaction);
begin
  FStatement.Transaction := Value;
end;

procedure TJvUIBCustomDataSet.SetUniDirectional(const Value: boolean);
begin
  inherited SetUniDirectional(Value);
  FStatement.CachedFetch := not Value;
end;

constructor TJvUIBCustomDataSet.Create(AOwner: TComponent);
begin
  FStatement := TJvUIBStatement.Create(nil);
  FStatement.OnClose := OnStatementClose;
  FOnClose := etmCommit;
  inherited Create(AOwner);
  FIsLast := False;
  FIsFirst := False;

end;

destructor TJvUIBCustomDataSet.Destroy;
begin
  inherited Destroy;
  FStatement.Free;
end;

procedure TJvUIBCustomDataSet.InternalInitFieldDefs;
var i: Integer;
begin
  FStatement.Prepare;
  FieldDefs.BeginUpdate;
  FieldDefs.Clear;
  try
    for i := 0 to FStatement.Fields.FieldCount - 1 do
    with FieldDefs.AddFieldDef, FStatement.Fields do
    begin
      Name := AliasName[i];
      FieldNo := i+1;
      Required := not IsNullable[i];
      case FieldType[i] of
        uftNumeric:
          begin
            case SQLType[i] of
              SQL_SHORT:
                begin
                  DataType := ftBCD;
                  Size := -Data.sqlvar[i].SqlScale;
                  if Size = 4 then
                    Precision := 5 else
                    Precision := 4;
                end;
              SQL_LONG:
                begin
                  Size := -Data.sqlvar[i].SqlScale;
                  if Size = 9 then
                    Precision := 10 else
                    Precision := 9;
                  if size > 4 then
                    DataType := ftFMTBcd else
                    DataType := ftBCD;
                end;
              SQL_INT64,
              SQL_QUAD:
                begin
                  DataType := ftBCD;
                  Size := -Data.sqlvar[i].SqlScale;
                  if Size = 18 then
                    Precision := 19 else
                    Precision := 18;
                  if size > 4 then
                    DataType := ftFMTBcd else
                    DataType := ftBCD;
                end;
              SQL_DOUBLE:
                DataType := ftFloat; // possible
            else
              //raise
            end;
          end;
        uftChar,
        uftCstring,
        uftVarchar:
          begin
            DataType := ftString;
            Size := SQLLen[i];
          end;
        uftSmallint: DataType := ftSmallint;
        uftInteger : DataType := ftInteger;
        uftFloat,
        uftDoublePrecision: DataType := ftFloat;
        uftTimestamp: DataType := ftDateTime;
        uftBlob :
          begin
            if Data.sqlvar[i].SqlSubType = 1 then
              DataType := ftMemo else
              DataType := ftBlob;
            Size := SizeOf(TIscQuad);
          end;
        uftDate : DataType := ftDate;
        uftTime : DataType := ftTime;
        uftInt64: DataType := ftLargeint;
      {$IFDEF IB7_UP}
        uftBoolean: DataType := ftBoolean;
      {$ENDIF}
      else
        DataType := ftUnknown;
      end;
    end;
  finally
    FieldDefs.EndUpdate;
  end;
end;

function TJvUIBCustomDataSet.GetFieldData(FieldNo: Integer;
  Buffer: Pointer): Boolean;
var
  FieldType: TUIBFieldType;
begin
  Result := False;

  if (FCurrentRecord < 0) then
    Exit;

  FStatement.Fields.GetRecord(PInteger(ActiveBuffer)^);

  if FStatement.Fields.IsNull[FieldNo] then
    Exit;

  FieldType := FStatement.Fields.FieldType[FieldNo];
  with FStatement.Fields.Data.sqlvar[FieldNo] do
  case FieldType of
        uftNumeric:
          begin
            case FStatement.Fields.SQLType[FieldNo] of
              SQL_SHORT:
                begin
                  TBCD(Buffer^) := strToBcd(IntToStr(PSmallint(sqldata)^));
                  BcdDivide(TBCD(Buffer^), inttostr(scaledivisor[sqlscale]), TBCD(Buffer^));
                end;
              SQL_LONG:
                begin
                  TBCD(Buffer^) := strToBcd(IntToStr(PInteger(sqldata)^));
                  BcdDivide(TBCD(Buffer^), inttostr(scaledivisor[sqlscale]), TBCD(Buffer^));
                end;
              SQL_INT64,
              SQL_QUAD:
                begin
                  TBCD(Buffer^) := strToBcd(IntToStr(PInt64(sqldata)^));
                  BcdDivide(TBCD(Buffer^), inttostr(scaledivisor[sqlscale]), TBCD(Buffer^));
                end;
              SQL_DOUBLE: PDouble(Buffer)^ := PDouble(sqldata)^;
            else
              raise Exception.Create('???');
            end;
          end;
        uftChar,
        uftCstring:
          begin
            move(sqldata^, Buffer^, SqlLen);
            PChar(Buffer)[SqlLen] := #0;
          end;
        uftVarchar:
          begin
            move(PVary(sqldata).vary_string, Buffer^, PVary(sqldata).vary_length);
            PChar(Buffer)[PVary(sqldata).vary_length] := #0;
          end;
        uftSmallint: PSmallint(Buffer)^ := PSmallint(sqldata)^;
        uftInteger : PInteger(Buffer)^ := PInteger(sqldata)^;
        uftFloat: PDouble(Buffer)^ := PSingle(sqldata)^;
        uftDoublePrecision: PDouble(Buffer)^ := PDouble(sqldata)^;
        uftTimestamp:
          begin
            DecodeTimeStamp(PIscTimeStamp(sqldata),  TTimeStamp(Buffer^));
            Double(Buffer^) := TimeStampToMSecs(TTimeStamp(Buffer^));
          end;
        uftBlob :
          begin
            if Buffer <> nil then
            begin
              FStatement.ReadBlob(FieldNo, TStream(Buffer));
              TStream(Buffer).Seek(0, soFromBeginning);
            end;
          end;
        uftDate: PInteger(Buffer)^ := DecodeSQLDate(PInteger(sqldata)^) + 693594;
        uftTime: PInteger(Buffer)^ := PCardinal(sqldata)^ div 10;
        uftInt64: PInt64(Buffer)^ := PInt64(sqldata)^;
      {$IFDEF IB7_UP}
        uftBoolean: WordBool(Buffer^) := PSmallInt(sqldata)^ = ISC_TRUE;
      {$ENDIF}
      else
        raise EUIBError.Create(EUIB_UNEXPECTEDERROR);
      end;
  Result := True;
end;

function TJvUIBCustomDataSet.GetFieldData(Field: TField;
  Buffer: Pointer): Boolean;
begin
  CheckActive;
  Result := GetFieldData(Field.Index, Buffer);
end;

function TJvUIBCustomDataSet.GetCanModify: Boolean;
begin
  Result := False;
end;

procedure TJvUIBCustomDataSet.OnStatementClose(Sender: TObject);
begin
  Close;
end;

function TJvUIBCustomDataSet.CreateBlobStream(Field: TField;
  Mode: TBlobStreamMode): TStream;
begin
  if (Mode = bmRead) then
  begin
    Result := TMemoryStream.Create;
    GetFieldData(Field, Result);
  end else
    Result := nil;
end;

function TJvUIBCustomDataSet.GetFetchBlobs: boolean;
begin
  Result := FStatement.FetchBlobs;
end;

procedure TJvUIBCustomDataSet.SetFetchBlobs(const Value: boolean);
begin
  FStatement.FetchBlobs := Value;
end;

function TJvUIBCustomDataSet.GetParams: TSQLParams;
begin
  Result := FStatement.Params;
end;

procedure TJvUIBCustomDataSet.Execute;
begin
  FStatement.Execute;
end;

procedure TJvUIBCustomDataSet.ExecSQL;
begin
  FStatement.ExecSQL;
end;

procedure TJvUIBCustomDataSet.SetActive(Value: Boolean);
begin
  inherited;
  if not Value then
    FStatement.Close(FOnClose);
end;

end.

--- NEW FILE: JvUIBMetaData.pas ---
{******************************************************************************}
{                                                                              }
{                        UNIFIED INTERBASE (UIB)                               }
{                                                                              }
{ Project JEDI Code Library (JCL)                                              }
{                                                                              }
{ The contents of this file are subject to the Mozilla Public License Version  }
{ 1.0 (the "License"); you may not use this file except in compliance with the }
{ License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ }
{                                                                              }
{ Software distributed under the License is distributed on an "AS IS" basis,   }
{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for }
{ the specific language governing rights and limitations under the License.    }
{                                                                              }
{ The Original Code is JvUIBMetaData.pas.                                      }
{                                                                              }
{ The Initial Developer of the Original Code is documented in the accompanying }
{ help file JCL.chm. Portions created by these individuals are Copyright (C)   }
{ 2000 of these individuals.                                                   }
[...2345 lines suppressed...]
    inherited;
  case FMechanism of
   -1 : Stream.WriteString(' FREE_IT');
    0 : Stream.WriteString(' BY VALUE');
    1 : ; // BY REFERENCE = default
    2 : Stream.WriteString(' BY DESCRIPTOR');
  end;
end;

procedure TMetaUDFField.SaveToStream(Stream: TStream);
begin
  inherited;
  Stream.Write(FPosition, SizeOf(FPosition));
  Stream.Write(FMechanism, SizeOf(FMechanism));
end;

end.




--- NEW FILE: JvUIBSQLParser.pas ---

(* Yacc parser template (TP Yacc V3.0), V1.2 6-17-91 AG *)

(* global definitions: *)


{******************************************************************************}
{                                                                              }
{                        UNIFIED INTERBASE (UIB)                               }
{                                                                              }
{ Project JEDI Code Library (JCL)                                              }
{                                                                              }
{ The contents of this file are subject to the Mozilla Public License Version  }
{ 1.0 (the "License"); you may not use this file except in compliance with the }
{ License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ }
{                                                                              }
{ Software distributed under the License is distributed on an "AS IS" basis,   }
{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for }
{ the specific language governing rights and limitations under the License.    }
[...41716 lines suppressed...]
  case yyflag of
    yyfaccept : goto accept;
    yyfabort  : goto abort;
    yyferror  : goto errlab;
  end;

  goto parse;

accept:

  yyparse := 0; exit;

abort:

  yyparse := 1; exit;

end(*yyparse*);


end.