ibcarrayuni.pas

来自「CrLab UniDAC 1.0 include sources」· PAS 代码 · 共 2,088 行 · 第 1/5 页

    Result := 0;
end;

procedure TCustomIBCArray.SetItemAsInteger(Indices: array of integer; Value: integer);
begin
  if FInternalItemType = dtInteger then
    SetItemValue(Indices, Value);
end;

function TCustomIBCArray.GetItemAsSmallInt(Indices: array of integer): SmallInt;
begin
  if FInternalItemType = dtSmallInt then
    Result := GetItemValue(Indices)
  else
    Result := 0;
end;

procedure TCustomIBCArray.SetItemAsSmallInt(Indices: array of integer; Value: SmallInt);
begin
  if FInternalItemType = dtSmallInt then
    SetItemValue(Indices, Value);
end;

function TCustomIBCArray.GetItemAsFloat(Indices: array of integer): double;
begin
  if FInternalItemType = dtFloat then
    Result := GetItemValue(Indices)
  else
    Result := 0;
end;

procedure TCustomIBCArray.SetItemAsFloat(Indices: array of integer; Value: double);
begin
  if FInternalItemType = dtFloat then
    SetItemValue(Indices, Value);
end;

function TCustomIBCArray.GetItemAsDateTime(Indices: array of integer): TDateTime;
begin
  if FInternalItemType in [dtDate, dtTime, dtDateTime] then
    Result := GetItemValue(Indices)
  else
    Result := 0;
end;

procedure TCustomIBCArray.SetItemAsDateTime(Indices: array of integer; Value: TDateTime);
begin
  if FInternalItemType in [dtDate, dtTime, dtDateTime] then
    SetItemValue(Indices, Value);
end;

{ TIBCType }

constructor TIBCArrayType.Create(DbHandle: TISC_DB_HANDLE; TrHandle: TISC_TR_HANDLE;
  TableName, ColumnName: string; NeedDescribe: boolean = True);
begin
  inherited Create;
  
  if GDSVersion >= 7 then
    FADType := adGDS7
  else
    FADType := adGDS;
  FStatusVector := Marshal.AllocHGlobal(20 * SizeOf(ISC_Status));
  FDbHandle := Marshal.AllocHGlobal(SizeOf(TISC_DB_HANDLE));
  Marshal.WriteIntPtr(FDbHandle, DbHandle);
  FTrHandle := Marshal.AllocHGlobal(SizeOf(TISC_TR_HANDLE));
  Marshal.WriteIntPtr(FTrHandle, TrHandle);
  FArrayDesc := Marshal.AllocHGlobal(ARRAYDESC_LENGTH(FADType));
  FDescAccessor := TDescAccessor.Create(FADType, FArrayDesc);
  FDescAccessor.Clear;
  FTableName := TableName;
  FColumnName := ColumnName;
  if NeedDescribe then
    Describe(FDbHandle, FTrHandle, TableName, ColumnName)
end;

destructor TIBCArrayType.Destroy;
begin
  FDescAccessor.Free;
  Marshal.FreeHGlobal(FArrayDesc);
  Marshal.FreeHGlobal(FTrHandle);
  Marshal.FreeHGlobal(FDbHandle);
  Marshal.FreeHGlobal(FStatusVector);
  
  inherited Destroy;
end;

function TIBCArrayType.GetDbHandle: TISC_DB_HANDLE;
begin
  Result := Marshal.ReadIntPtr(FDbHandle);
end;

procedure TIBCArrayType.SetDbHandle(Value: TISC_DB_HANDLE);
begin
  if GetDbHandle <> Value then
    Marshal.WriteIntPtr(FDbHandle, Value);
end;

function TIBCArrayType.GetTrHandle: TISC_TR_HANDLE;
begin
  Result := Marshal.ReadIntPtr(FTrHandle);
end;

procedure TIBCArrayType.SetTrHandle(Value: TISC_TR_HANDLE);
begin
  if GetTrHandle <> Value then
    Marshal.WriteIntPtr(FTrHandle, Value);
end;

procedure TIBCArrayType.Check(Status: ISC_STATUS);
var
  SqlErrMsg, Msg: string;
  ErrorNumber, ErrorCode: integer;
begin
  if Status > 0 then begin
    ErrorCode := isc_sqlcode(FStatusVector);
    GetIBError(ErrorCode, ErrorNumber, FStatusVector, Msg, SqlErrMsg);
    raise EIBCError.Create(ErrorCode, ErrorNumber, Msg, SqlErrMsg);
  end;
end;

procedure TIBCArrayType.Describe(DbHandle: TISC_DB_HANDLE; TrHandle: TISC_TR_HANDLE; TableName, ColumnName: string);
var
  pTableName, pColumnName: IntPtr;

  procedure CreateAttr(ArrayType: TIBCArrayType; Dimension: integer);
  var
    Attribute: TAttribute;
  begin
    Attribute := TAttribute.Create;
    ArrayType.FAttributes.Add(Attribute);
    Attribute.Owner := Self;
    Attribute.AttributeNo := ArrayType.FAttributes.Count;
    Attribute.Scale := Word(ABS(ArrayType.FDescAccessor.Scale));
    Attribute.Length := FDescAccessor.Length;
    if Dimension = ArrayType.FDescAccessor.Dimensions then begin
      case ArrayType.FDescAccessor.DataType of
        blr_double, blr_float, blr_d_float, blr_int64:
          Attribute.DataType := dtFloat;
        blr_long:
          Attribute.DataType := dtInteger;
        blr_short:
          Attribute.DataType := dtSmallInt;
        blr_boolean_dtype:
          Attribute.DataType := dtBoolean;
        blr_sql_date:
          Attribute.DataType := dtDate;
        blr_sql_time:
          Attribute.DataType := dtTime;
        blr_timestamp:
          Attribute.DataType := dtDateTime;
        blr_cstring, blr_cstring2,
        blr_text, blr_text2,
        blr_Varying, blr_varying2:
          Attribute.DataType := dtString;
        else
          Attribute.DataType := dtUnknown;
      end;
    end
    else begin
      Attribute.DataType := dtArray;
      Attribute.ObjectType := TIBCArrayType.Create(DBHandle, TrHandle, FTableName, FColumnName, False);
      TIBCArrayType(Attribute.ObjectType).FName := TableName + '.' + ColumnName;
      CopyBuffer(ArrayType.FArrayDesc, TIBCArrayType(Attribute.ObjectType).FArrayDesc, ARRAYDESC_LENGTH(FADType));
      TIBCArrayType(Attribute.ObjectType).LowBound := FDescAccessor.LowBound[Dimension];
      TIBCArrayType(Attribute.ObjectType).FSize := FDescAccessor.HighBound[Dimension] -
        FDescAccessor.LowBound[Dimension] + 1;
      TIBCArrayType(Attribute.ObjectType).FDataType := dtArray;
      CreateAttr(TIBCArrayType(Attribute.ObjectType), Dimension + 1);
    end;
    Attribute.Size := SizeOf(IntPtr);
  end;

begin
  ClearAttributes;
  pTableName := Marshal.StringToHGlobalAnsi(TableName);
  pColumnName := Marshal.StringToHGlobalAnsi(ColumnName);
  try
    Check(isc_array_lookup_bounds(FStatusVector, FDbHandle, FTrHandle,
      pTableName, pColumnName, FArrayDesc));
  finally
    Marshal.FreeCoTaskMem(pTableName);
    Marshal.FreeCoTaskMem(pColumnName);
  end;

  FName := TableName + '.' + ColumnName;
  if FDescAccessor.Dimensions > 0 then begin
    FSize := FDescAccessor.HighBound[0] - FDescAccessor.LowBound[0] + 1;
    FLowBound := FDescAccessor.LowBound[0];
    FDataType := dtArray;
    CreateAttr(Self, 1);
  end
  else
    FSize := 0;
end;

function TCustomIBCArray.GetArrayIndices(Name: string): TIBCIntegerDynArray;
var
  IdxStart: integer;
  i: integer;
begin
  IdxStart := 0;
  for i := 1 to Length(Name) do begin
    if Name[i] = '[' then
      IdxStart := i;
    if (Name[i] = ']') and (IdxStart > 0) then begin
      SetLength(Result, Length(Result) + 1);
      Result[High(Result)] := StrToInt(Copy(Name, IdxStart + 1, i - IdxStart - 1));
      IdxStart := 0;
    end;
  end;
end;

procedure TCustomIBCArray.GetAttributeValue(Name: string; Dest: IntPtr;
  var IsBlank: boolean);
var
  Offset: integer;
  Ptr: IntPtr;
begin
  IsBlank := IsNull;

  if (Dest = nil) or IsBlank and
    not (FInternalItemType in [dtObject, dtReference, dtArray])
  then
    Exit;

  if (not FCached) or (FArrayBuffer = nil) then
    ReadArray;

  Offset := GetItemOffset(GetArrayIndices(Name));
  Ptr := IntPtr(Integer(FArrayBuffer) + Offset);
  CopyBuffer(Ptr, Dest, FDescAccessor.Length);
  if FDescAccessor.DataType in [blr_text, blr_text2, blr_cstring, blr_cstring2,
    blr_varying, blr_varying2] then
    Marshal.WriteByte(Dest, FDescAccessor.Length, $00);
end;

procedure TCustomIBCArray.SetAttributeValue(Name: string; Source: IntPtr);
var
  Offset: integer;
  Ptr: IntPtr;
begin
  Offset := GetItemOffset(GetArrayIndices(Name));
  if FArrayBuffer = nil then
    AllocBuffer;
  Ptr := IntPtr(Integer(FArrayBuffer) + Offset);
  CopyBuffer(Source, Ptr, FDescAccessor.Length);
  FModified := True;
end;

function TCustomIBCArray.GetAsString: string;
var
  Values: variant;
  Value: variant;
  Dimesions: integer;
  Indices: array of integer;
  ItemCount: integer;
  i: integer;

  procedure UpdateIndices(CurrentItem: integer);
  var
    i, j: integer;
    BeginCount: integer;
  begin
    BeginCount := 0;
    for i := VarArrayDimCount(Values) - 1 downto 0 do
      if Indices[i] = VarArrayHighBound(Values, i + 1) then begin
        Indices[i] := VarArrayLowBound(Values, i + 1);
        Result := Result + ')';
        Inc(BeginCount);
        if (i > 0) and (Indices[i - 1] < VarArrayHighBound(Values, i)) then begin
          Result := Result + ', ';
          if CurrentItem < ItemCount - 1 then begin
            for j := 0 to BeginCount - 1 do
              Result := Result + '(';
            BeginCount := 0;
          end;
        end;
      end
      else begin
        Indices[i] := Indices[i] + 1;
        if i = VarArrayDimCount(Values) - 1 then
          Result := Result + '; ';
        Break;
      end;
  end;

begin
  Values := Items;
  Dimesions := VarArrayDimCount(Values);
  ItemCount := 1;
  SetLength(Indices, Dimesions);
  for i := 0 to Dimesions - 1 do begin
    ItemCount := ItemCount * (VarArrayHighBound(Values, i + 1) - VarArrayLowBound(Values, i + 1) + 1);
    Indices[i] := VarArrayLowBound(Values, i + 1);
    Result := Result + '(';
  end;
  for i := 0 to ItemCount - 1 do begin
    Value := VarArrayGet(Values, Indices);
    if VarIsType(Value, varSmallint) or VarIsType(Value, varInteger) then
      Result := Result + IntToStr(Value)
    else
    if VarIsType(Value, varSingle) or VarIsType(Value, varDouble) then
      Result := Result + FloatToStr(Value)
    else
    if VarIsType(Value, varDate) then
      Result := Result + DateTimeToStr(Value)
    else
    if VarIsType(Value, varBoolean) then
      Result := Result + BoolToStr(Boolean(WordBool(Value)), True)
    else
      Result := Result + '''' + Value + '''';
    UpdateIndices(i);
  end;
end;

procedure TCustomIBCArray.SetAsString(Value: string);
var
  Parser: TIBCParser;
  Lexem: string;
  Code, PrevCode: integer;
  Indices: array of integer;
  TmpValue: variant;
  i: integer;
  
  procedure IncIndices;
  var
    i: integer;
  begin
    for i := FDescAccessor.Dimensions - 1 downto 0 do
      if Indices[i] = FDescAccessor.HighBound[i] then
        Indices[i] := FDescAccessor.LowBound[i]
      else begin
        Inc(Indices[i]);
        Break;
      end;
  end;
  
begin
  PrevCode := 0;
  SetLength(Indices, FDescAccessor.Dimensions);
  for i := 0 to High(Indices) do
    Indices[i] := FDescAccessor.LowBound[i];
  Parser := TIBCParser.Create(Value);
  try
    Parser.OmitBlank := True;
    Parser.OmitComment := True;
    Parser.ToBegin;
    Code := Parser.GetNext(Lexem);
    repeat
      if (PrevCode = lcNumber) or (PrevCode = lcString) then begin
        if Code = lcSymbol then begin
          if (Lexem <> ';') and (Lexem <> ')') then
            raise Exception.Create('');
        end
        else
          raise Exception.Create('');
      end
      else
      if (Code = lcNumber) then begin
        case FInternalItemType of
          dtFloat:
            TmpValue := StrToFloat(Lexem);
          dtInteger, dtSmallInt:
            TmpValue := StrToInt(Lexem);
          dtBoolean:
            TmpValue := StrToBool(Lexem);
         dtDate, dtTime, dtDateTime:
           TmpValue := StrToDateTime(Lexem);
         else
           TmpValue := Unassigned;
           raise Exception.Create('Invalid value');
        end;
        SetItemValue(Indices, TmpValue);
        IncIndices;
      end
      else
      if Code = lcString then begin
        case FInternalItemType of
          dtBoolean:
            TmpValue := StrToBool(Lexem);
          dtString:
            TmpValue := Lexem;
          else
            TmpValue := Unassigned;
            raise Exception.Create('Invalid value');
        end;
        SetItemValue(Indices, TmpValue);
        IncIndices;
      end;
      Code := Parser.GetNext(Lexem);
    until Code = lcEnd;
  finally
    Parser.Free;
  end;
end;

procedure TIBCArrayType.SetLowBound(const Value: integer);
begin
  FLowBound := Value;
end;

{ TIBCArrayUtils }

class procedure TIBCArrayUtils.SetArrayDesc(Obj: TCustomIBCArray; Desc: IntPtr);
begin
  Obj.SetArrayDesc(Desc);
end;

class function TIBCArrayUtils.GetArrayIDPtr(Obj: TCustomIBCArray): PISC_QUAD;
begin
  Result := obj.GetArrayIDPtr;
end;

end.