sqlexpr.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

      finally
        IniOut.Free;
      end;
    finally
      IniIn.Free;
    end;
  finally
    List.Free;
  end;
end;
{$ENDIF}

function GetRegistryFile(Setting, Default: string; DesignMode: Boolean): string;
var
{$IFDEF MSWINDOWS}
  Reg: TRegistry;
{$ENDIF}
{$IFDEF LINUX}
  GlobalFile: string;
{$ENDIF}
begin
  {$IFDEF MSWINDOWS}
  Result := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKeyReadOnly(SDBEXPRESSREG_SETTING) then
      Result := Reg.ReadString(Setting);
  finally
    Reg.Free;
  end;
  if Result = '' then
    Result := ExtractFileDir(ParamStr(0)) + '\' + Default;
  {$ENDIF}
  {$IFDEF LINUX}
  Result := getenv('HOME') + SDBEXPRESSREG_USERPATH + Default;    { do not localize }
  if not FileExists(Result) then
  begin
    GlobalFile := SDBEXPRESSREG_GLOBALPATH + Default + SConfExtension;
    if FileExists(GlobalFile) then
    begin
      if DesignMode then
      begin
        if not CopyConfFile(GlobalFile, Result) then
          DatabaseErrorFmt(SConfFileMoveError, [GlobalFile, Result])
      end else
        Result := GlobalFile;
    end else
      DatabaseErrorFmt(SMissingConfFile, [GlobalFile]);
  end;
  {$ENDIF}
end;

function GetDriverRegistryFile(DesignMode: Boolean = False): string;
begin
  Result := GetRegistryFile(SDRIVERREG_SETTING, sDriverConfigFile, DesignMode);
end;

function GetConnectionRegistryFile(DesignMode: Boolean = False): string;
begin
  Result := GetRegistryFile(SCONNECTIONREG_SETTING, sConnectionConfigFile, DesignMode);
end;

function GetBlobSize(DataSet: TCustomSQLDataSet; FieldNo: Integer): LongWord;
var
  IsNull: LongBool;
  Status: SQLResult;
begin
  Result := 0;
  if not DataSet.EOF then
  begin
    if DataSet.MaxBlobSize = 0 then exit;
    Status := DataSet.FSQLCursor.GetBlobSize(Word(FieldNo), Result, IsNull);
    if Status <> SQL_SUCCESS then
      DataSet.SQLError(Status, exceptCursor);
    if IsNull then
      Result := 0;
  end;
  DataSet.CurrentBlobSize := Result;
end;

function NextPiece(Start: string; InLiteral: Boolean; QuoteChar: Char; EndParam: Boolean = False): Integer;
var
  P: PChar;
  Ctr: Integer;
  SearchChars: set of char;
begin
  SearchChars := [' ', ')', ',', '=', ':', '>', '<', #13, #10];
  P := (PChar(Start))+1;
  Ctr := 1;
  Result := 0;
  while (Result = 0) and (P^ <> #0) do
  begin
    if (P^ = '''') or (P^ = QuoteChar) then
      InLiteral := not InLiteral
    else
    if not InLiteral and (P^ in SearchChars) then
    begin
      if EndParam then
      begin
        if not (P^ in ['=', ':', '<', '>']) then
        begin
          Result := Ctr;
          Inc(Result);
        end
      end else
      begin
        if (P^ = ':') then
        begin
          if P[-1] in [' ', ')', ',', '=', '('] then
            Result := Ctr;
        end
        else if (P[1] = ':') then
        begin
          Result := Ctr;
          Inc(Result);
        end;
      end;
    end;
    Inc(P);
    Inc(Ctr);
  end;
end;

// SqlObjects does not support named params: convert to ?
// if not yet converted
function FixParams(SQL: string; Count: Integer; QuoteChar: string): string;
var
  Param, Start: string;
  Pos, EndPos: Integer;
  InLiteral: Boolean;
  Q: Char;
begin
  Q := PChar(QuoteChar)[0];
  if Q in [#0, ' '] then Q := '''';
  InLiteral := False;
  Start := SQL;
  Pos := NextPiece(Start, InLiteral, Q);
  while Pos > 0 do
  begin
    Start := copy(Start, Pos + 1, Length(Start) - Pos);
    EndPos := NextPiece(Start, InLiteral, Q, True);
    if EndPos = 0 then
      Param := copy(Start, 1, Length(Start))
    else
      Param := copy(Start, 1, EndPos-1);
    SQL := stringReplace(SQL, Param, ' ? ', []);
    Pos := NextPiece(Start, InLiteral, Q);
  end;
  Result := SQL;
end;

function GetProfileString(Section, Setting, IniFileName: string): string;
var
  IniFile: TMemIniFile;
  List: TStrings;
begin
  List := TStringList.Create;
  try
    IniFile := TMemIniFile.Create(IniFileName);
    IniFile.ReadSectionValues(Section, List);
    try
      Result := List.Values[ Setting ];
    finally
      IniFile.Free;
    end;
  finally
    List.Free;
  end;
end;

procedure GetDriverNames(List: TStrings; DesignMode: Boolean = True);
var
  ConnectionAdmin: IConnectionAdmin;
begin
  ConnectionAdmin := GetConnectionAdmin;
  ConnectionAdmin.GetDriverNames(List);
end;

procedure GetConnectionNames(List: TStrings; Driver: string = ''; DesignMode: Boolean = True);
var
  I: Integer;
  ConnectionAdmin: IConnectionAdmin;
begin
  ConnectionAdmin := GetConnectionAdmin;
  ConnectionAdmin.GetConnectionNames(List, '');
  if Driver <> '' then
  begin
    List.BeginUpdate;
    try
      I := List.Count - 1;
      while I >= 0 do
      begin
        if AnsiCompareText(GetProfileString(List[I], DRIVERNAME_KEY,
              GetConnectionRegistryFile(DesignMode)), Driver) <> 0 then
           List.Delete(I);
        Dec(I);
      end;
    finally
      List.EndUpdate;
    end;
  end;
end;

procedure GetParamData(Param: TParam; Buffer: Pointer; const DrvLocale: TLocale);

  function GetNativeStr: PChar;
  begin
    Param.NativeStr := VarToStr(Param.Value);
    Result := PChar(Param.NativeStr);
  end;

begin
  if Buffer <> nil then
  begin
    with Param do
      if DataType in [ftString, ftFixedChar, ftMemo]  then
      begin
        NativeStr := VarToStr(Value);
        GetData(Buffer);
      end
      else
        GetData(Buffer);
  end;
end;


procedure CalcUnits( const Params: TParams; const ProcParams: TList;
          const Index: Integer; pArgDesc: pSPParamDesc; var ChildPos: array of Word );
var
  I: Integer;
  ArgDesc: SPParamDesc;
begin
  I := Index + 1;
  ArgDesc := pArgDesc^;
  pArgDesc.iUnits1 := 0;
  pArgDesc.iUnits2 := 0;
  while (I < Params.Count) do
  begin
    ArgDesc := (PSPParamDesc(ProcParams.Items[I]))^;
    if ArgDesc.iParamNum <> pArgDesc.iParamNum then
      break;
    Inc(pArgDesc.iUnits1);
    Inc(pArgDesc.iUnits2);
    ChildPos[I] := I - Index;
    if ArgDesc.iDataType = ftADT then
    begin
      CalcUnits(Params, ProcParams, I, @ArgDesc, ChildPos);
      Inc(pArgDesc.iUnits2, ArgDesc.iUnits2);
      Inc(I, ArgDesc.iUnits2);
    end else
      Inc(I);
  end;
end;

procedure SetProcedureParams(const Sender: TSQLConnection;
  const Command: ISQLCommand; const Params: TParams; ProcParams: TList);
var
  I, IInd, DataLen: Integer;
  iFldNum: LongWord;
  RecBuffer: PChar;
  iFldType, iSubType: Word;
  DrvLocale: TLocale;
  Status: SQLResult;
  ArgDesc: SPParamDesc;
  ChildPosArray: array of Word;
  SBcd: string;
  Bcd: TBcd;
begin
  DrvLocale := nil;
  SetLength(ChildPosArray, Params.Count);
  for I := 0 to Params.Count - 1 do
    begin
      RecBuffer := nil;
      try
        if Params[I].ParamType = ptUnknown then  // Midas assumes its Input
          Params[I].ParamType := ptInput;
        iFldNum := i + 1;
        iFldType := FldTypeMap[Params[I].DataType];
        iSubType := 0;
        if iFldType in [fldBlob, fldZString] then
          iSubType := Word(FldSubTypeMap[Params[I].DataType])
        else if iFldType = fldUNKNOWN then
          DatabaseErrorFmt(SNoParameterValue, [Params[I].Name]);
        ArgDesc := (PSPParamDesc(ProcParams.Items[I]))^;
        iFldType := FldTypeMap[ArgDesc.iDataType];
        if Params[I].ParamType <> ptOutput then
          DataLen := Params[I].GetDataSize
        else
          DataLen := ArgDesc.iLen;
        {Check if the IN param is NULL and set the NULL indicator}
        if ((Params[I].ParamType = ptInput) and Params[I].IsNull) then
          iInd := 1
        else
        if (DataLen > 0) then
        begin
          iInd := 0;
          RecBuffer := AllocMem(DataLen);
          if Params[I].ParamType <> ptOutput then
            GetParamData(Params[I], RecBuffer, DrvLocale)
          else
            FillChar(RecBuffer^, DataLen, 0);
          if Params[I].ParamType = ptInput then
            Params[I].Size := 0;
          if (Params[I].ParamType = ptOutput) and not(iFldType in [fldFLOAT]) then
            ArgDesc.iLen := 0
          else
            case iFldType of
              fldBlob, fldZString, fldBYTES, fldVARBYTES:
                begin
                  ArgDesc.iLen := DataLen;
                  ArgDesc.iLen := DataLen;
                  ArgDesc.iUnits2 := 0;
                  if (Params[I].ParamType = ptInputOutput) and (DataLen > Params[I].Size) then
                  begin
                    if iFldType = fldVARBYTES then
                      Params[I].Size := DataLen - 2
                    else if iFldType = fldZString then
                      Params[I].Size := DataLen - 1
                    else
                      Params[I].Size := DataLen;
                  end;
                end;
              fldFLOAT:
                begin
                  if Params[I].Precision = 4 then
                    ArgDesc.iLen := 4
                  else
                    ArgDesc.iLen := Sizeof(Double);
                end;
              fldFMTBCD, fldBCD:
                begin
                  iFldType := fldBCD;   { DBExpress does not distinguish }
                  if Params[I].Size = 0 then
                  begin
                    SBcd := BcdToStr(PBcd(RecBuffer)^);
                    Bcd := StrToBcd(SBcd);
                    Params[I].Size := Bcd.Precision;
                    ArgDesc.iUnits2 := Bcd.SignSpecialPlaces AND $3F;
                  end else
                  begin
                    ArgDesc.iUnits2 := Params[I].NumericScale;
                  end;
                end;
              fldADT, fldARRAY:
                begin
                  CalcUnits(Params, ProcParams, I, @ArgDesc, ChildPosArray);
                  ArgDesc.iLen := DataLen;
                end;
            end;
        end else  // leave RecBuffer nil
        begin
          if iFldType in [fldADT, fldARRAY] then
            DatabaseError(SObjectTypenameRequired);
          iInd := 1;
        end;
        Status := Command.setParameter(iFldNum - ChildPosArray[I], ChildPosArray[I], TSTMTParamType(ArgDesc.iArgType),
                iFldType, iSubType, Params[I].Size,
                Integer(ArgDesc.iUnits2), ArgDesc.iLen, RecBuffer, IInd);
        if (Status <> SQL_Success) then
          Sender.SQLError(Status, exceptConnection);
      finally
        if RecBuffer <> nil then FreeMem(RecBuffer);
      end;
    end;
end;

procedure FreeProcParams(var ProcParams: TList);
var
  ArgParam: pSPParamDesc;
  I: Integer;
begin
  if not Assigned(ProcParams) then Exit;
  for I := 0 to ProcParams.Count -1 do
  begin
    ArgParam := ProcParams[I];
    Dispose(ArgParam);
  end;
  FreeAndNil(ProcParams);
end;

procedure LoadParamListItems(Params: TParams; ProcParams: TList);
var
  I: Integer;