umysqlvio.pas

RO模拟器!!适合玩仙境传说的玩家们呦~

  lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: LongWORD;
  hTemplateFile: longword): longword; stdcall; external 'kernel32.dll' name 'CreateFileA';
function GetLastError: LongWORD;  stdcall; external 'kernel32.dll' name 'GetLastError';
function WaitNamedPipe(lpNamedPipeName: PChar; nTimeOut: LongWORD): LongBOOL; stdcall; external 'kernel32.dll' name 'WaitNamedPipeA';
function SetNamedPipeHandleState(hNamedPipe: longword; var lpMode: LongWORD;
  lpMaxCollectionCount, lpCollectDataTimeout: Pointer): LongBOOL; stdcall; external 'kernel32.dll' name 'SetNamedPipeHandleState';
{$ENDIF}

{$IFNDEF _WIN_}
function fcntl(Handle: Integer; Command: Integer; Arg: Longint): Integer; external 'libc.so.6' name 'fcntl';overload;
function fcntl(Handle: Integer; Command: Integer): Integer; cdecl; external 'libc.so.6' name 'fcntl';overload;
function recv(fd: longint; var buf; n: longword; flags: Integer): Integer; cdecl;external 'libc.so.6' name 'recv';
function send(fd: longint; const buf; n: longword; flags: Integer): Integer; cdecl;external 'libc.so.6' name 'send';
function setsockopt(fd: longint; level, optname: Integer; optval: Pointer; optlen: cardinal): Integer; cdecl;external 'libc.so.6' name 'setsockopt';
function shutdown(fd: longint; how: Integer): Integer; cdecl;external 'libc.so.6' name 'shutdown';
function connect(fd: longint; const addr: tsockaddr; len: cardinal): Integer; cdecl;external 'libc.so.6' name 'connect';
function socket(domain, _type, protocol: Integer): longint; cdecl; external 'libc.so.6' name 'socket';
function inet_addr(cp: PChar): longword; cdecl;external 'libc.so.6' name 'inet_addr';
function gethostbyname(name: PChar): PHostEnt; cdecl;external 'libc.so.6' name 'gethostbyname';
function htons(hostshort: word): word; cdecl;external 'libc.so.6' name 'htons';
function poll(fds: PPollFD; nfds: LongWord; timeout: Integer): Integer; cdecl;external 'libc.so.6' name 'poll';
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////

{$IFNDEF _WIN_}
var errno:longint;
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
{$IFDEF _WIN_}
var fwsaData:WSADATA; // on windows winsock
{$ENDIF}

{$IFDEF _WIN_}
////////////////////////////////////////////////////////////////////////////////
procedure FD_SET(Socket: longint; var FDSet: TFDSet);
begin
     if FDSet.fd_count < FD_SETSIZE then
     begin
          FDSet.fd_array[FDSet.fd_count] := Socket;
          Inc(FDSet.fd_count);
     end;
end;

////////////////////////////////////////////////////////////////////////////////
// poll implementation using select
// not needed on linux
function poll(fds:TPollFD; timeout:longint):longint;
var err,count,n:longint;
    rfd,wfd,efd,ifd:tfdset;
    timebuf:timeval;
    tbuff:ptimeval;
    events,fd:longint;
    revents:longint;
begin
    tbuff :=nil;
    n:=0;
    ifd.fd_count:=0;
    rfd.fd_count:=0;
    wfd.fd_count:=0;
    efd.fd_count:=0;
    events := fds.events;
    fd := fds.fd;
    fds.revents := 0;
    if not((fd < 0) or (__WSAFDIsSet(fd, ifd))) then
    begin
         if (fd > n) then
            n := fd;
         if (events and POLL_CAN_READ)=POLL_CAN_READ then
            FD_SET(fd, rfd);
         if (events and POLL_CAN_WRITE)=POLL_CAN_WRITE then
            FD_SET(fd, wfd);
         if (events and POLL_HAS_EXCP)=POLL_HAS_EXCP then
            FD_SET(fd, efd);
    end;
    if(timeout >= 0) then
    begin
        timebuf.tv_sec := timeout div 1000;
        timebuf.tv_usec := (timeout div 1000) * 1000;
        tbuff := @timebuf;
    end;
    err := select(n+1,@rfd,@wfd,@efd,tbuff);
    if(err < 0) then
    begin
        result:=err;
        exit;
    end;
    count := 0;
    begin
        revents := (fds.events and POLL_EVENTS_MASK);
        fd := fds.fd;
        if(fd >= 0) then
        begin
             if (__WSAFDIsSet(fd, ifd))then
                revents := POLLNVAL
             else
             begin
                  if not(__WSAFDIsSet(fd, rfd)) then
                     revents :=revents and not POLL_CAN_READ;
                  if not(__WSAFDIsSet(fd, wfd)) then
                     revents :=revents and not POLL_CAN_WRITE;
                  if not(__WSAFDIsSet(fd, efd)) then
                     revents :=revents and not POLL_HAS_EXCP;
             end;
             fds.revents := revents;
             if (fds.revents <> 0) then
                inc(count);
        end;
    end;
    if count>0 then
       result:=count
    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;
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.');