DOS/V Power Report 1997 May/VPR9705A.ISO/VPR_DATA/PROGRAM/CBTRIAL/SETUP/DATA.Z/BTSCLASS.PAS

Pascal/Delphi Source File | 1997-02-14 | 19KB | 741 lines

//---------------------------------------------------------------------------
// Borland C++Builder
// Copyright (c) 1987, 1997 Borland International Inc.  All Rights Reserved.
//---------------------------------------------------------------------------
// BtsClass.pas
//
// VCL Class Browser
//---------------------------------------------------------------------------

unit BtsClass;

interface

uses Windows, SysUtils, Classes, MIFiles, DB, DBTables, BtsConst, BDE;

const
  fldnoNetName    = 3;  { USER table, Network Name field }

type

{ Exceptions }

  EBts = class(Exception);
  ENoRecords = class(EBts);
  ESystemDown = class(EBts);
  EInvalidField = class(EBts)
  public
    Field: TField;
    constructor Create(AField: TField; const Msg: string);
  end;
  EMissingAttach = class(EInvalidField);

{ Notifications }

  EDisplayOutline = class(Exception)
  public
    ItemCode: Double;
    constructor Create(ACode: Double);
  end;

{ TLookupList }

  PStrItem = ^TStrItem;
  TStrItem = record
    FObject: TObject;
    FCode: Integer;
    FDesc: PChar;
    FValue: string;
    FString: string;
  end;

  TLookupList = class(TStrings)
  private
    List: TList;
    FCoded: Boolean;
    FUseDesc: Boolean;
    FTableName: string;
  protected
    CodeSep: string;
    DescSep: string;
    function NewStrItem(const S: string): PStrItem;
    procedure DisposeStrItem(P: PStrItem);
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    function GetValue(Index: Integer): string;
    function GetDesc(Index: Integer): string;
    function GetCode(Index: Integer): Integer;
    function GetItem(Index: Integer): string;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure Clear; override;
    function IndexOfValue(const S: string): Integer;
    function IndexOfDesc(const S: string): Integer;
    function IndexOfCode(ACode: Integer): Integer;
    function IndexOfItem(const S: string): Integer;
    function CodeToValue(ACode: Integer): string;
    function ValueToCode(const AValue: string): Integer;
    property Value[Index: Integer]: string read GetValue;
    property Desc[Index: Integer]: string read GetDesc;
    property Code[Index: Integer]: Integer read GetCode;
    property Item[Index: Integer]: string read GetItem;
    property UseDesc: Boolean read FUseDesc write FUseDesc;
    property TableName: string read FTableName write FTableName;
    property Coded: Boolean read FCoded;
  end;

{ TBtsUser }

  TBtsUser = class
  private
    FNetName: string;
    FUserName: string;
    FGroup: string;
    FRights: TUserRights;
    FRegistered: Boolean;
  public
    constructor Create(UserTab: TTable; GroupLook: TLookupList;
      const DefRights: string);
    procedure CheckRights(Value: TUserRights);
    property Group: string read FGroup;
    property NetName: string read FNetName;
    property Rights: TUserRights read FRights;
    property UserName: string read FUserName;
    property Registered: Boolean read FRegistered write FRegistered;
  end;

{ TFieldMap }

  TFieldMap = class(TStringList)
  private
    function GetStatusValue(ResValue: Integer): Integer;
  public
    constructor Create(StatIni: TMemIniFile; const CfgSect: string);
    property StatusValue[ResValue: Integer]: Integer read GetStatusValue;
  end;

{ TCloneDataset }

  TCloneDataset = class(TDBDataset)
  private
    FSourceHandle: HDBICur;
    procedure SetSourceHandle(ASourceHandle: HDBICur);
  protected
    function CreateHandle: HDBICur; override;
  public
    property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;
  end;

{ TCloneTable }

  TCloneTable = class(TTable)
  private
    FSourceHandle: HDBICur;
    procedure SetSourceHandle(ASourceHandle: HDBICur);
  protected
    function CreateHandle: HDBICur; override;
  public
    constructor CreateFromTable(AOwner: TComponent; Reset: Boolean);
    procedure InitFromTable(SourceTable: TTable; Reset: Boolean);
  end;

{ TQueryField }

  TQueryField = class
  protected
    FQDType: TQueryDataType;
    FFldNo: Integer;
    FQRow: Integer;
    FQText: string;
    FFldName: string;
    FLookupTableName: string;
  public
    LookupData: array[1..2] of TQueryField;
    constructor Create(AQDType: TQueryDataType; AFldNo: Integer; AQText: string);
    destructor Destroy; override;
    procedure InitLookupData(LookupList: TLookupList;
     const Example, CodeFldName, DescFldName: string; ARow, ACol: Integer);
    property FldNo: Integer read FFldNo;
    property FldName: string read FFldName write FFldName;
    property QText: string read FQText write FQText;
    property QRow: Integer read FQRow write FQRow;
    property QDType: TQueryDataType read FQDType;
    property LookupTableName: string read FLookupTableName write FLookupTableName;
  end;

{ TQueryData }

  TQueryData = class(TList)
  private
    function Get(Index: Integer): TQueryField;
  public
    procedure Empty;
    destructor Destroy; override;
    property Items[Index: Integer]: TQueryField read Get; default;
  end;

{ TQBEQuery }

  TCheckType = (ctNone, ctCheck, ctCheckPlus, ctCheckDesc, ctCheckGroup);

  TQBEQuery = class(TQuery)
  private
    hQry: hDBIQry;
  protected
    function CreateHandle: HDBICur; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure AddExpr(const TabName, FldName: string; Row: Integer;
      CheckType: TCheckType; Expr: string);
  end;

{ TOtlData }

  TOtlData = class(TObject)
  public
    ProgName: PChar;
    Tester: PChar;
    HasChildren: Boolean;
    constructor Create(PName, TName: PChar; ChildFlag: Boolean);
    destructor Destroy; override;
  end;

implementation

uses DBConsts;

{ EInvalidField }

constructor EInvalidField.Create(AField: TField; const Msg: string);
begin
  Field := AField;
  inherited Create(Msg);
end;

{ TDisplayOutline }

constructor EDisplayOutline.Create(ACode: Double);
begin
  ItemCode := ACode;
end;

{ TLookupList }

constructor TLookupList.Create;
const
  SCodeSep = '|';
  SDescSep = ' - ';
begin
  inherited Create;
  List := TList.Create;
  CodeSep := SCodeSep;
  DescSep := SDescSep;
end;

destructor TLookupList.Destroy;
begin
  if List <> nil then
  begin
    Clear;
    List.Destroy;
  end;
  inherited Destroy;
end;

function TLookupList.NewStrItem(const S: string): PStrItem;
var
  CodeSepPos: Integer;
  ValLen: Integer;
begin
  CodeSepPos := Pos(CodeSep, S);
  FCoded := CodeSepPos > 0;
  ValLen := Pos(DescSep, S) - 1;
  if (ValLen > 0) and (CodeSepPos > 0) then
    Dec(ValLen, CodeSepPos - 1 + Length(CodeSep));
  Result := New(PStrItem);
  if FCoded then
  begin
    Result^.FString := Copy(S, CodeSepPos + Length(CodeSep), Length(S));
    Result^.FCode := StrToInt(Copy(S, 1, CodeSepPos - 1));
  end else
  begin
    Result^.FString := S;
    Result^.FCode := -1;
  end;
  with Result^ do
  begin
    FObject := nil;
    if ValLen > 0 then
    begin
      { Make a copy of the value part, so we can access it easily }
      FValue := Copy(FString, 1 , ValLen);
      { And a pointer to only the description }
      FDesc := @FString[ValLen + Length(DescSep) + 1];
    end else
    begin
      FValue := FString;
      FDesc := nil;
    end;
  end;
end;

procedure TLookupList.DisposeStrItem(P: PStrItem);
begin
  P.FObject.Free;
  Dispose(P);
end;

function TLookupList.Get(Index: Integer): string;
begin
  Result := PStrItem(List[Index]).FString;
end;

function TLookupList.GetObject(Index: Integer): TObject;
begin
  Result := PStrItem(List[Index]).FObject;
end;

function TLookupList.GetCount: Integer;
begin
  Result := List.Count;
end;

procedure TLookupList.Put(Index: Integer; const S: string);
var
  P: PStrItem;
begin
  P := List[Index];
  List[Index] := NewStrItem(S);
  DisposeStrItem(P);
end;

procedure TLookupList.PutObject(Index: Integer; AObject: TObject);
begin
  PStrItem(List[Index]).FObject := AObject;
end;

procedure TLookupList.Insert(Index: Integer; const S: string);
begin
  List.Expand.Insert(Index, NewStrItem(S));
end;

procedure TLookupList.Delete(Index: Integer);
begin
  DisposeStrItem(List[Index]);
  List.Delete(Index);
end;

procedure TLookupList.Clear;
var
  I: Integer;
begin
  for I := 0 to List.Count - 1 do DisposeStrItem(List[I]);
  List.Clear;
end;

function TLookupList.GetValue(Index: Integer): string;
begin
  if Index >= 0 then
    with PStrItem(List[Index])^ do
      Result := FValue
  else
      Result := '';
end;

function TLookupList.GetDesc(Index: Integer): string;
begin
  with PStrItem(List[Index])^ do
    if Assigned(FDesc) then
      Result := FDesc else
      Result := '';
end;

function TLookupList.GetCode(Index: Integer): Integer;
begin
  with PStrItem(List[Index])^ do
    Result := FCode;
end;

function TLookupList.GetItem(Index: Integer): string;
begin
  if UseDesc then
    Result := GetDesc(Index) else
    Result := GetValue(Index);
end;

function TLookupList.IndexOfValue(const S: string): Integer;
begin
  for Result := 0 to GetCount - 1 do
    if CompareText(GetValue(Result), S) = 0 then Exit;
  Result := -1;
end;

function TLookupList.IndexOfDesc(const S: string): Integer;
begin
  for Result := 0 to GetCount - 1 do
    if CompareText(GetDesc(Result), S) = 0 then Exit;
  Result := -1;
end;

function TLookupList.IndexOfCode(ACode: Integer): Integer;
begin
  for Result := 0 to GetCount - 1 do
    if ACode = GetCode(Result) then Exit;
  Result := -1;
end;

function TLookupList.IndexOfItem(const S: string): Integer;
begin
  if UseDesc then
    Result := IndexOfDesc(S) else
    Result := IndexOfValue(S);
end;

function TLookupList.CodeToValue(ACode: Integer): string;
var
  Index: Integer;
begin
  Index := IndexOfCode(ACode);
  if Index >= 0 then
    Result := Item[Index] else
    Result := EmptyStr;
end;

function TLookupList.ValueToCode(const AValue: string): Integer;
begin
  Result := IndexOfItem(AValue);
  if Result > -1 then Result := Code[Result];
end;


{ TBtsUser }

constructor TBtsUser.Create(UserTab: TTable; GroupLook: TLookupList;
  const DefRights: string);
var
  RightsStr: string;
  NameBuf: array[0..255] of Char;

  procedure Str2Rights;
  var
    X: Byte;
    I: Integer;
  begin
    FRights := [];
    for I := 1 to Length(RightsStr) do
    begin
      X := Pos(RightsStr[I], sRightsChars);
      if X > 0 then
        Include(FRights, TUserRightsElement(X-1));
    end;
    if urDirectEntry in FRights then Include(FRights, urEntry);
  end;

begin
  if (DbiGetNetUserName(NameBuf) = 0) and (NameBuf[0] <> #0) then
    SetString(FNetName, NameBuf, StrLen(NameBuf)) else
    raise EBts.Create(SUnknownUser);

  with UserTab do
  try
    Open;
    try
      IndexName := 'NetName';
    except
      Close;
      Exclusive := True;
      Open;
      AddIndex('NetName', Fields[fldnoNetName].FieldName, [ixCaseInsensitive]);
      IndexName := 'NetName';
    end;
    if FindKey([NetName]) then
    begin
      FUserName := FieldByName('User Name').AsString;
      FGroup := GroupLook.CodeToValue(FieldByName('Group').AsInteger);
      RightsStr := FieldByName('Rights').AsString;
    end else
    begin
      FUserName := NetName;
      RightsStr := DefRights;
      FGroup := 'User';
    end;
    Str2Rights;
  finally
    Close
  end;
end;

procedure TBtsUser.CheckRights(Value: TUserRights);
var
  S: string;
  X: TUserRightsElement;
begin
  if not (Value <= Rights)  then
  begin
    S := SRights1;
    for X := Low(X) to High(X) do
      if (X in Value) and not (X in Rights) then
        S := Format('%s%s, ', [S, SRights[X]]);
    SetLength(S, Length(S) - 1); { remove last ", " }
    S := S + SRights2;
    raise EBts.Create(S);
  end;
end;

{ TFieldMap }

constructor TFieldMap.Create(StatIni: TMemIniFile; const CfgSect: string);
var
  I, Count, BarPos: Integer;
  S: string;
begin
  Count := StatIni.ReadInteger(CfgSect, ckCount, 0);
  for I := 1 to Count do
  begin
    S := StatIni.ReadString(CfgSect, IntToStr(I), '');
    BarPos := Pos('|', S);
    if BarPos > 0 then
      AddObject(Copy(S, 1, BarPos-1), TObject(StrToInt(Copy(S, BarPos+1, 5))));
  end;
end;

function TFieldMap.GetStatusValue(ResValue: Integer): Integer;
begin
  Result := IndexOf(IntToStr(ResValue));
  if Result <> -1 then
    Result := Integer(Objects[Result]);
end;

{ TCloneDataset }

procedure TCloneDataset.SetSourceHandle(ASourceHandle: HDBICur);
begin
  if ASourceHandle <> FSourceHandle then
  begin
    Close;
    FSourceHandle := ASourceHandle;
    if FSourceHandle <> nil then Open;
  end;
end;

function TCloneDataset.CreateHandle: HDBICur;
begin
   Check(DbiCloneCursor(FSourceHandle, False, False, Result));
end;

{ TCloneTable }

constructor TCloneTable.CreateFromTable(AOwner: TComponent; Reset: Boolean);
begin
  inherited Create(AOwner);
  InitFromTable(TTable(AOwner), Reset);
end;

procedure TCloneTable.InitFromTable(SourceTable: TTable; Reset: Boolean);
begin
  with SourceTable do
  begin
    Self.TableName := TableName;
    Self.DatabaseName := DatabaseName;
    if IndexName <> '' then
      Self.IndexName := IndexName
    else if IndexFieldNames <> '' then
      Self.IndexFieldNames := IndexFieldNames;
    SetSourceHandle(Handle);
    Self.Filter := Filter;
    Self.OnFilterRecord := OnFilterRecord;
    Self.Filtered := Filtered;
  end;
  if Reset then
  begin
    Filtered := False;
    DbiResetRange(Handle);
    IndexName := '';
    First;
  end;
end;

procedure TCloneTable.SetSourceHandle(ASourceHandle: HDBICur);
begin
  if ASourceHandle <> FSourceHandle then
  begin
    Close;
    FSourceHandle := ASourceHandle;
    if FSourceHandle <> nil then Open;
  end;
end;

function TCloneTable.CreateHandle: HDBICur;
begin
   Check(DbiCloneCursor(FSourceHandle, False, False, Result));
end;

{ TQueryField }

constructor TQueryField.Create(AQDType: TQueryDataType; AFldNo: Integer;
  AQText: string);
begin
  FQDType := AQDType;
  FFldNo := AFldNo;
  FQText := AQText;
  FQRow := 1;
end;

destructor TQueryField.Destroy;
begin
  LookupData[1].Free;
  LookupData[2].Free;
end;

procedure TQueryField.InitLookupData(LookupList: TLookupList;
  const Example, CodeFldName, DescFldName: string; ARow, ACol: Integer);
var
  Code: Integer;
begin
  Code := LookupList.ValueToCode(QText);
  if Code <> -1 then
    QText := IntToStr(Code)
  else if (CompareText(QText, 'BADLINK') = 0) then
  begin
    LookupData[1] := TQueryField.Create(qdLookup, 1, Example + ',count=0');
    LookupData[1].FldName := CodeFldName;
    LookupData[1].LookupTableName := LookupList.TableName;
    LookupData[1].QRow := ARow;
    QText := Example + #33',not blank'; {#33 = Exclamation point}
  end
  else if not (CompareText(QText, SBLANK) = 0) or
              (CompareText(QText, SNOTBLANK) = 0) then
  begin
    LookupData[1] := TQueryField.Create(qdLookup, 1, Example);
    LookupData[1].FldName := CodeFldName;
    LookupData[1].LookupTableName := LookupList.TableName;
    LookupData[1].QRow := ARow;
    LookupData[2] := TQueryField.Create(qdLookup, ACol, QText);
    LookupData[2].LookupTableName := LookupList.TableName;
    LookupData[2].FldName := DescFldName;
    LookupData[2].QRow := ARow;
    QText := Example;
  end;
end;

{ TQueryData }

procedure TQueryData.Empty;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do TQueryField(Items[I]).Free;
  Count := 0;
end;

destructor TQueryData.Destroy;
begin
  Empty;
  inherited Destroy;
end;

function TQueryData.Get(Index: Integer): TQueryField;
begin
  Result := inherited Items[Index];
end;

{ TQBEQuery }

type
  TDbiQryFree = function(var hQry: hDBIQry): DbiResult; stdcall;

  TDbiQLowStart = function (hDb: hDbiDb; pszQryName: PChar;
    eQryType: DbiQryType; var hQry: hDbiQry): DbiResult;  stdcall;

  TDbiQLowBuild = function(hQry: hDbiQry; pszTableName: PChar;
    pszTableType: PChar; pszFieldName: PChar; iRowNum: Word;
    eCheck: TCheckType; pszExpr: PChar): DbiResult; stdcall;

  TDbiQLowPrepare = function(hQry: hDbiQry;
    TableBits: PWord): DbiResult; stdcall;

  TDbiQryOpen = function(hQry: hDBIQry; bUniDirec: Bool;
    var hCur: hDBICur): DbiResult; stdcall;

var
  DbiQLowStart: TDbiQLowStart;
  DbiQLowBuild: TDbiQLowBuild;
  DbiQLowPrepare: TDbiQLowPrepare;
  DbiQryFree: TDbiQryFree;
  DbiQryOpen: TDbiQryOpen;

procedure InitializeQBEProcedures;
var
  HModule: THandle;
begin
  if not Assigned(DbiQLowStart) then
  begin
    HModule := LoadLibrary('IDAPI32.DLL');
    if HModule <= 32 then SysUtils.Abort;
    DbiQLowStart := GetProcAddress(HModule, 'DbiQLowStart');
    DbiQLowBuild := GetProcAddress(HModule, 'DbiQLowBuild');
    DbiQLowPrepare := GetProcAddress(HModule, 'DbiQLowPrepare');
    DbiQryOpen := GetProcAddress(HModule, 'DbiQryOpen');
    DbiQryFree := GetProcAddress(HModule, 'DbiQryFree');
    FreeLibrary(HModule);
  end;
end;

constructor TQBEQuery.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  InitializeQBEProcedures;
end;

procedure TQBEQuery.AddExpr(const TabName, FldName: string; Row: Integer;
  CheckType: TCheckType; Expr: string);
begin
  CheckInactive;
  SetDBFlag(dbfOpened, True);
  if hQry = nil then
    Check(DbiQLowStart(DBHandle, nil, dbiqryDIRTY, hQry));
  UniqueString(Expr);
  try
    Check(DbiQLowBuild(hQry, PChar(TabName), nil, PChar(FldName),
      Row, CheckType, PChar(Expr)));
  except
    DbiQryFree(hQry);
    raise;
  end;
end;

function TQBEQuery.CreateHandle: HDBICur;
begin
  try
    Check(DbiQLowPrepare(hQry, nil));
    Check(DbiQryOpen(hQry, True, Result));
  finally
    DbiQryFree(hQry);
  end;
end;

{ TOtlData }

constructor TOtlData.Create(PName, TName: PChar; ChildFlag: Boolean);
begin
  inherited Create;
  ProgName := StrNew(PName);
  Tester := StrNew(TName);
  HasChildren := ChildFlag;
end;

destructor TOtlData.Destroy;
begin
  StrDispose(ProgName);
  StrDispose(Tester);
  inherited Destroy;
end;

end.