umysqlvio.pas

MYSQL 连接控件 MYSQL 连接控件

  else
    result:=-1; //no socket has changed
end;
{$ENDIF}

{------------------------------------------------------------------------------}
{ TMysqlVio }
{------------------------------------------------------------------------------}

////////////////////////////////////////////////////////////////////////////////
// class constructor
constructor TMysqlVio.create;
begin
  inherited;
  FSd :=-1;
  FHPipe :=-1;
  ffcntl_mode :=0;
  ftype :=VIO_CLOSED;
  flast_error:='';
  flast_errno:=0;
  fNoTimeOut:=false;
  {$IFDEF HAVE_SSL}
  fssl:=nil;
  fnewcon:=nil;
  {$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////
// class destructor
destructor TMysqlVio.destroy;
begin
  if (ftype<>VIO_CLOSED)then //if vio open
    vio_close; //close it
  inherited destroy;
end;

////////////////////////////////////////////////////////////////////////////////
// attempt to use fast send
function TMysqlVio.fastsend: longint;
var
  nodelay:longint;
begin
  result:=0;
  if setsockopt(fsd, IPPROTO_IP, IP_TOS, nil, 0)<>0 then
    begin
      nodelay:=1;
      if (setsockopt(fsd, IPPROTO_TCP, TCP_NODELAY, pchar(@nodelay),sizeof(nodelay)))<>0 then
        result:= -1;
    end;
end;

////////////////////////////////////////////////////////////////////////////////
// get last error text value
function TMysqlVio.Getlast_error: string;
begin
  result:=Flast_error;
end;

////////////////////////////////////////////////////////////////////////////////
// sets/resets keepalive on socket
function TMysqlVio.keepalive(onoff: boolean): longint;
var
  opt:longint;
begin
  opt:=0;
  if (onoff) then
    opt:=1;
  result:=setsockopt(fsd, SOL_SOCKET, SO_KEEPALIVE, pchar(@opt),sizeof(opt));
end;

{$IFDEF HAVE_SSL}
////////////////////////////////////////////////////////////////////////////////
// attempt to create a ssl connector
function TMysqlVio.new_VioSSLConnectorFd(const key, cert, ca, capath,
  cipher: pchar): pointer;
var
  ptr:^st_VioSSLConnectorFd;
  dh:pointer;
begin
  result:=nil;
  new(ptr);
  ptr.ssl_context_:=nil;
  ptr.ssl_method_:=nil;
  //do we have the algorithms loaded?
  if not(ssl_algorithms_added) then
    begin
      ssl_algorithms_added := TRUE;
      OpenSSL_add_all_algorithms; //load them
    end;
  //do we have the error strings?
  if not(ssl_error_strings_loaded)then
    begin
      ssl_error_strings_loaded := TRUE;
      SSL_load_error_strings; //load them
    end;
  ptr.ssl_method_ := TLSv1_client_method; //get the methods
  ptr.ssl_context_ := SSL_CTX_new(ptr.ssl_method_); //get the context
  if (ptr.ssl_context_ = nil) then //empty contex?
    begin
      dispose(ptr);
      exit;
    end;
  if (cipher<>nil)then //did we passed any ciphers?
    SSL_CTX_set_cipher_list(ptr.ssl_context_, cipher);
  //let's check the context
  SSL_CTX_set_verify(ptr.ssl_context_, 1{SSL_VERIFY_PEER}, addr(vio_verify_callback));
  //set the cert stuff
  if (vio_set_cert_stuff(ptr.ssl_context_, cert, key) = -1) then
    begin
      dispose(ptr);
      exit;
    end;
  //verify the locations
  if (SSL_CTX_load_verify_locations( ptr.ssl_context_, ca,capath)=0) then
    if (SSL_CTX_set_default_verify_paths(ptr.ssl_context_)=0) then
      begin
        dispose(ptr);
        exit;
      end;
  //get a new dh
  dh:=get_dh512;
  //check it
  SSL_CTX_ctrl(ptr.ssl_context_,3{SSL_CTRL_SET_TMP_DH},0,dh);
  DH_free(dh);
  result:=ptr;
end;
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
// set no use of timeout
procedure TMysqlVio.SetNoTimeOut(const Value: boolean);
begin
  if not Value then // we use timeout
    if ftimeout=0 then //is it 0 seconds?
      ftimeout:=NET_READ_TIMEOUT;
  fNoTimeOut:=Value;
  if fNoTimeOut and (ftype = VIO_TYPE_TCPIP) then
    vio_blocking(true);
end;

////////////////////////////////////////////////////////////////////////////////
// set last error text value
procedure TMysqlVio.Setlast_error(const Value: string);
begin
  Flast_error := Value;
end;

{$IFDEF HAVE_SSL}
////////////////////////////////////////////////////////////////////////////////
// attempt to use ssl
procedure TMysqlVio.SwitchToSSL(const key:pchar;const cert:pchar;const ca:pchar;const capath:pchar;var cipher:pchar; timeout:cardinal);
var
  newcon:^st_VioSSLConnectorFd;
  l:longint;
  server_cert:pointer;
  s:string;
begin
  //are we connected? or are we using named pipe?
  if (ftype<>VIO_CLOSED) and (ftype<>VIO_TYPE_NAMEDPIPE) then
    begin
      //grab a connector
      if cipher='' then
        newcon:= new_VioSSLConnectorFd(key, cert, ca, capath, cipher)
      else
        newcon:= new_VioSSLConnectorFd(key, cert, ca, capath, nil);
      fnewcon:=newcon;
      //new ssl
      fssl := SSL_new(st_VioSSLConnectorFd(newcon^).ssl_context_);
      if (fssl=nil) then
        begin //errors?
          dispose(newcon);
          fnewcon:=nil;
          exit;
        end;
      ftype:=VIO_CLOSED;
      SSL_clear(fssl);
      vio_blocking(FALSE);
      SSL_SESSION_set_timeout(SSL_get_session(fssl), timeout);
      SSL_set_fd (fssl, fsd);
      SSL_set_connect_state(fssl);
      l:=SSL_do_handshake(fssl); //if any of the previous fails this will fail
      if l=1 then
        begin //success
          ftype:=VIO_TYPE_SSL;
          fastsend; //attempt to use fastsend
          keepalive(TRUE);
          cipher:=SSL_CIPHER_get_name(SSL_get_current_cipher(fssl));
          //now we can do some checking on server
          server_cert := SSL_get_peer_certificate (fssl);
          if (server_cert <> nil) then
            begin
              s := X509_NAME_oneline (X509_get_subject_name (server_cert), nil, 0);
              //showmessage('info subject: '+ s);

              s := X509_NAME_oneline (X509_get_issuer_name  (server_cert), nil, 0);
              //showmessage('info issuer: '+ s);

              // We could do all sorts of certificate verification stuff here before deallocating the certificate. */
              X509_free (server_cert);
            end
          else
            //showmessage('info Server does not have certificate.');
            ;
        end
      else
        begin //we had errors ... let's clean it
          SSL_shutdown(fssl);
          SSL_free(fssl);
          if fnewcon<>nil then
            dispose(fnewcon);
          fssl:= nil;
        end;
    end;
end;
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
// checks whenever vio is blocking
function TMysqlVio.vio_blocking(onoff: boolean): longint;
var
  r:longint;
  old_fcntl:longint;
  {$IFDEF _WIN_}
  arg:cardinal;
  {$ENDIF}
begin
  if (ftype <> VIO_CLOSED) then //is vio connected?
    begin
      r:=0;
      {$IFNDEF _WIN_} //if it is on linux
      if (fsd >= 0) then
        begin
          old_fcntl:=ffcntl_mode;
          if (onoff) then
            ffcntl_mode :=ffcntl_mode and ($7FFFFFFE)
          else
            ffcntl_mode := ffcntl_mode or 1;
          if (old_fcntl <> ffcntl_mode) then
            r := fcntl(fsd, F_SETFL, ffcntl_mode);
        end;
      {$ELSE} //if it is not on linux
      if (ftype <> VIO_TYPE_NAMEDPIPE) then //pipes don't need blocking
        begin
          old_fcntl:=ffcntl_mode;
          if (onoff) then
            begin //set blocking
              arg := 0;
              ffcntl_mode := ffcntl_mode and $7FFFFFFE
            end
          else
            begin //reset blocking
              arg := 1;
              ffcntl_mode := ffcntl_mode or 1;
            end;
          if (old_fcntl<>ffcntl_mode) then
            r:=ioctlsocket(fsd,FIONBIO, longint(arg));
        end;
      {$ENDIF}
      result:=r;
    end
  else //vio not connected
    result:=-1;
end;

////////////////////////////////////////////////////////////////////////////////
// closes the socket/pipe
function TMysqlVio.vio_close: longint;
begin
  result:=0;
  {$IFDEF HAVE_SSL}
  if assigned(fssl) then
    begin //did we used ssl?
      //free it
      result := SSL_shutdown(fssl);
      SSL_free(fssl);
      if fnewcon<>nil then
        dispose(fnewcon);
      fssl:= nil;
    end;
  {$ENDIF}
  {$IFDEF _WIN_}
  if (ftype=VIO_TYPE_NAMEDPIPE) then
    result:=longint(CloseHandle(fhPipe))
  else
  {$ENDIF}
  if (ftype <> VIO_CLOSED) then
    begin
      result:=0;
      if (shutdown(fsd,2)<>0) then
        result:=-1;
      if (closesocket(fsd)<>0) then
        result:=-1;
    end;
  ftype:=VIO_CLOSED;
  fsd:=-1;
  FHPipe:=-1;
  ffcntl_mode:=0;
end;

////////////////////////////////////////////////////////////////////////////////
// checks whenever the communication was intrerupted
function TMysqlVio.vio_intrerupted: boolean;
begin
  {$IFDEF _WIN_}
  result:=WSAGetLastError = WSAEINTR;
  {$ELSE}
  result:=errno = EINTR;
  {$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////
// main vio function it creates the pipe, connects the socket
// will return -x on error ??
// _type represent the kind of vio we open (ssl not supported on connect)
// host and unix_socket are obvious
// connect_timeout is used only on named pipes
// trysock is used when you try a pipe and if in error you want to try socket
function TMysqlVio.vio_open( _type:TEnumVioType; host:string='localhost'; unix_socket:string={$IFDEF _WIN_}MYSQL_NAMEDPIPE{$ELSE}MYSQL_UNIX_ADDR{$ENDIF}; port:longint=0; connect_timeout:cardinal=0; trysock:boolean=true): longint;
var
  sock:longint;
  {$IFDEF _WIN_}
  hPipe:longint;
  arg:cardinal;
  szPipeName:string[255];
  i:integer;
  dwMode:longword;
  {$ELSE}
  haserr:boolean;
  Unixaddr:TUnixSockAddr;
  {$ENDIF}
  sock_addr:TSockAddr;
  ip_addr:cardinal;
  hp:phostent;
  lhost:string; //store temp values
  lunix_socket:string; //store temp values
begin
  if ftype=VIO_CLOSED then
    begin
      ftimeout:=connect_timeout;
      if not fNoTimeOut then // we use timeout
        if ftimeout=0 then //is it 0 seconds?
          ftimeout:=NET_READ_TIMEOUT;
      if _type=VIO_TYPE_SSL then
        begin
          result:=-2; //ssl not supported yet
          exit;
        end;
      //only if using winsock
      {$IFDEF _WIN_}
      if (_type = VIO_TYPE_TCPIP)or(trysock) then //do we need winsock?
        if fWsaData.wVersion=0 then // has it been initialized before
          if (WSAStartup ($0101, fWsaData)<>0) then
            begin
              result:=-1; //we can't start winsock - one should never get here
              exit;
            end;
      hpipe:=INVALID_HANDLE_VALUE;
      {$ENDIF}
      lhost:=host;
      lunix_socket:=unix_socket;
      if (_type = VIO_TYPE_NAMEDPIPE) then
        begin
          //one may pass wrong host info
          if (host='') or (host<>LOCAL_HOST_NAMEDPIPE) then
            {$IFDEF _WIN_}
            host:=LOCAL_HOST_NAMEDPIPE;
            {$ELSE}
            host:='localhost';
            {$ENDIF}
          if (unix_socket='') or {$IFDEF _WIN_}(unix_socket<>MYSQL_NAMEDPIPE){$ELSE}(unix_socket<>MYSQL_UNIX_ADDR){$ENDIF} then
            {$IFDEF _WIN_}
            unix_socket:=MYSQL_NAMEDPIPE;
            {$ELSE}
            unix_socket:=MYSQL_UNIX_ADDR;
            {$ENDIF}
        end;
      {$IFDEF _WIN_}
      if (_type = VIO_TYPE_NAMEDPIPE) and
         (((host<>'') and (host=LOCAL_HOST_NAMEDPIPE))or
         ((unix_socket<>'') and(unix_socket=MYSQL_NAMEDPIPE))) then //we try a named pipe
        begin
          szPipeName:='\\'+host+'\pipe\'+unix_socket;
          for i:=0 to 100 do //try 100 times to connect - one may remove this
            begin
              //try open the pipe
              hPipe := CreateFile(pchar(longint(@szPipeName)+1), GENERIC_READ or GENERIC_WRITE, 0,nil,OPEN_EXISTING,0,0 );
              if ( hPipe<> INVALID_HANDLE_VALUE) then //success?
                break;
              if (GetLastError <> ERROR_PIPE_BUSY) then //we got another error than pipe busy?
                begin
                  //we can stop trying
                  flast_errno:=CR_NAMEDPIPEOPEN_ERROR;
                  flast_error:=format(client_errors[(flast_errno)-CR_MIN_ERROR],[host, unix_socket,GetLastError]);
                  if not trysock then //should we try socket?
                    begin
                      result:=-9;
                      exit;
                    end
                  else