unit uROmDNS; {----------------------------------------------------------------------------} { RemObjects SDK Library - Core Library } { } { compiler: Delphi 5 and up, Kylix 2 and up } { platform: Win32, Linux } { } { (c)opyright RemObjects Software. all rights reserved. } { } { Using this code requires a valid license of the RemObjects SDK } { which can be obtained at http://www.remobjects.com. } {----------------------------------------------------------------------------} {$I RemObjects.inc} interface {$DEFINE USE_ONLY_mDNS_FOR_RESOLVE} {$DEFINE NO_DNSServiceGetAddrInfo} uses {$IFDEF MSWINDOWS}Windows,{$ENDIF} SysUtils,Classes, {$IFDEF FPC} {$IFNDEF MSWINDOWS}BaseUnix,{$ENDIF} Sockets, {$ENDIF} uROClasses, uROThread; const // from Winsock2 AF_UNSPEC = 0; AF_INET = 2; AF_INET6 = 23; kDNSServiceInterfaceIndexAny = 0; kDNSServiceInterfaceIndexLocalOnly = $ffffffff; // (-1) kDNSServiceInterfaceIndexUnicast = $fffffffe; // (-2) kDNSServiceProtocol_IPv4 = $01; kDNSServiceProtocol_IPv6 = $02; kDNSServiceProtocol_UDP = $10; kDNSServiceProtocol_TCP = $20; kDNSServiceClass_IN = 1; // Internet // DNSServiceType kDNSServiceType_A = 1; // Host address. { kDNSServiceType_NS = 2, /* Authoritative server. */ kDNSServiceType_MD = 3, /* Mail destination. */ kDNSServiceType_MF = 4, /* Mail forwarder. */ kDNSServiceType_CNAME = 5, /* Canonical name. */ kDNSServiceType_SOA = 6, /* Start of authority zone. */ kDNSServiceType_MB = 7, /* Mailbox domain name. */ kDNSServiceType_MG = 8, /* Mail group member. */ kDNSServiceType_MR = 9, /* Mail rename name. */ kDNSServiceType_NULL = 10, /* Null resource record. */ kDNSServiceType_WKS = 11, /* Well known service. */ kDNSServiceType_PTR = 12, /* Domain name pointer. */ kDNSServiceType_HINFO = 13, /* Host information. */ kDNSServiceType_MINFO = 14, /* Mailbox information. */ kDNSServiceType_MX = 15, /* Mail routing information. */ kDNSServiceType_TXT = 16, /* One or more text strings (NOT "zero or more..."). */ kDNSServiceType_RP = 17, /* Responsible person. */ kDNSServiceType_AFSDB = 18, /* AFS cell database. */ kDNSServiceType_X25 = 19, /* X_25 calling address. */ kDNSServiceType_ISDN = 20, /* ISDN calling address. */ kDNSServiceType_RT = 21, /* Router. */ kDNSServiceType_NSAP = 22, /* NSAP address. */ kDNSServiceType_NSAP_PTR = 23, /* Reverse NSAP lookup (deprecated). */ kDNSServiceType_SIG = 24, /* Security signature. */ kDNSServiceType_KEY = 25, /* Security key. */ kDNSServiceType_PX = 26, /* X.400 mail mapping. */ kDNSServiceType_GPOS = 27, /* Geographical position (withdrawn). */ kDNSServiceType_AAAA = 28, /* IPv6 Address. */ kDNSServiceType_LOC = 29, /* Location Information. */ kDNSServiceType_NXT = 30, /* Next domain (security). */ kDNSServiceType_EID = 31, /* Endpoint identifier. */ kDNSServiceType_NIMLOC = 32, /* Nimrod Locator. */ kDNSServiceType_SRV = 33, /* Server Selection. */ kDNSServiceType_ATMA = 34, /* ATM Address */ kDNSServiceType_NAPTR = 35, /* Naming Authority PoinTeR */ kDNSServiceType_KX = 36, /* Key Exchange */ kDNSServiceType_CERT = 37, /* Certification record */ kDNSServiceType_A6 = 38, /* IPv6 Address (deprecated) */ kDNSServiceType_DNAME = 39, /* Non-terminal DNAME (for IPv6) */ kDNSServiceType_SINK = 40, /* Kitchen sink (experimental) */ kDNSServiceType_OPT = 41, /* EDNS0 option (meta-RR) */ kDNSServiceType_APL = 42, /* Address Prefix List */ kDNSServiceType_DS = 43, /* Delegation Signer */ kDNSServiceType_SSHFP = 44, /* SSH Key Fingerprint */ kDNSServiceType_IPSECKEY = 45, /* IPSECKEY */ kDNSServiceType_RRSIG = 46, /* RRSIG */ kDNSServiceType_NSEC = 47, /* NSEC */ kDNSServiceType_DNSKEY = 48, /* DNSKEY */ kDNSServiceType_DHCID = 49, /* DHCID */ kDNSServiceType_TKEY = 249, /* Transaction key */ kDNSServiceType_TSIG = 250, /* Transaction signature. */ kDNSServiceType_IXFR = 251, /* Incremental zone transfer. */ kDNSServiceType_AXFR = 252, /* Transfer zone of authority. */ kDNSServiceType_MAILB = 253, /* Transfer mailbox records. */ kDNSServiceType_MAILA = 254, /* Transfer mail agent records. */ kDNSServiceType_ANY = 255 /* Wildcard match. */ } // DNSServiceFlags kDNSServiceFlagsMoreComing = $01; { * MoreComing indicates to a callback that at least one more result is * queued and will be delivered following immediately after this one. * When the MoreComing flag is set, applications should not immediately * update their UI, because this can result in a great deal of ugly flickering * on the screen, and can waste a great deal of CPU time repeatedly updating * the screen with content that is then immediately erased, over and over. * Applications should wait until until MoreComing is not set, and then * update their UI when no more changes are imminent. * When MoreComing is not set, that doesn't mean there will be no more * answers EVER, just that there are no more answers immediately * available right now at this instant. If more answers become available * in the future they will be delivered as usual.} kDNSServiceFlagsAdd = $02; kDNSServiceFlagsDefault = $04; { * Flags for domain enumeration and browse/query reply callbacks. * "Default" applies only to enumeration and is only valid in * conjunction with "Add". An enumeration callback with the "Add" * flag NOT set indicates a "Remove", i.e. the domain is no longer * valid.} kDNSServiceFlagsNoAutoRename = $08; { * Flag for specifying renaming behavior on name conflict when registering * non-shared records. By default, name conflicts are automatically handled * by renaming the service. NoAutoRename overrides this behavior - with this * flag set, name conflicts will result in a callback. The NoAutorename flag * is only valid if a name is explicitly specified when registering a service * (i.e. the default name is not used.) } kDNSServiceFlagsShared = $10; kDNSServiceFlagsUnique = $20; {* Flag for registering individual records on a connected * DNSServiceRef. Shared indicates that there may be multiple records * with this name on the network (e.g. PTR records). Unique indicates that the * record's name is to be unique on the network (e.g. SRV records)} kDNSServiceFlagsBrowseDomains = $40; kDNSServiceFlagsRegistrationDomains = $80; {* Flags for specifying domain enumeration type in DNSServiceEnumerateDomains. * BrowseDomains enumerates domains recommended for browsing, RegistrationDomains * enumerates domains recommended for registration.} kDNSServiceFlagsLongLivedQuery = $100; {* Flag for creating a long-lived unicast query for the DNSServiceQueryRecord call. } kDNSServiceFlagsAllowRemoteQuery = $200; {* Flag for creating a record for which we will answer remote queries * (queries from hosts more than one hop away; hosts not directly connected to the local link).} kDNSServiceFlagsForceMulticast = $400; {* Flag for signifying that a query or registration should be performed exclusively via multicast * DNS, even for a name in a domain (e.g. foo.apple.com.) that would normally imply unicast DNS.} kDNSServiceFlagsForce = $800; {* Flag for signifying a "stronger" variant of an operation. * Currently defined only for DNSServiceReconfirmRecord(), where it forces a record to * be removed from the cache immediately, instead of querying for a few seconds before * concluding that the record is no longer valid and then removing it. This flag should * be used with caution because if a service browsing PTR record is indeed still valid * on the network, forcing its removal will result in a user-interface flap -- the * discovered service instance will disappear, and then re-appear moments later.} kDNSServiceFlagsReturnIntermediates = $1000; {* Flag for returning intermediate results. * For example, if a query results in an authoritative NXDomain (name does not exist) * then that result is returned to the client. However the query is not implicitly * cancelled -- it remains active and if the answer subsequently changes * (e.g. because a VPN tunnel is subsequently established) then that positive * result will still be returned to the client. * Similarly, if a query results in a CNAME record, then in addition to following * the CNAME referral, the intermediate CNAME result is also returned to the client. * When this flag is not set, NXDomain errors are not returned, and CNAME records * are followed silently without informing the client of the intermediate steps. * (In earlier builds this flag was briefly calledkDNSServiceFlagsReturnCNAME)} kDNSServiceFlagsNonBrowsable = $2000; {* A service registered with the NonBrowsable flag set can be resolved using * DNSServiceResolve(), but will not be discoverable using DNSServiceBrowse(). * This is for cases where the name is actually a GUID; it is found by other means; * there is no end-user benefit to browsing to find a long list of opaque GUIDs. * Using the NonBrowsable flag creates SRV+TXT without the cost of also advertising * an associated PTR record.} kDNSServiceFlagsShareConnection = $4000; {* For efficiency, clients that perform many concurrent operations may want to use a * single Unix Domain Socket connection with the background daemon, instead of having a * separate connection for each independent operation. To use this mode, clients first * call DNSServiceCreateConnection(&MainRef) to initialize the main DNSServiceRef. * For each subsequent operation that is to share that same connection, the client copies * the MainRef, and then passes the address of that copy, setting the ShareConnection flag * to tell the library that this DNSServiceRef is not a typical uninitialized DNSServiceRef; * it's a copy of an existing DNSServiceRef whose connection information should be reused.} // DNSServiceErrorType kDNSServiceErr_NoError = 0; kDNSServiceErr_Timeout = -1; kDNSServiceErr_Unknown = -65537; // 0xFFFE FFFF kDNSServiceErr_NoSuchName = -65538; kDNSServiceErr_NoMemory = -65539; kDNSServiceErr_BadParam = -65540; kDNSServiceErr_BadReference = -65541; kDNSServiceErr_BadState = -65542; kDNSServiceErr_BadFlags = -65543; kDNSServiceErr_Unsupported = -65544; kDNSServiceErr_NotInitialized = -65545; kDNSServiceErr_AlreadyRegistered = -65547; kDNSServiceErr_NameConflict = -65548; kDNSServiceErr_Invalid = -65549; kDNSServiceErr_Firewall = -65550; kDNSServiceErr_Incompatible = -65551; // client library incompatible with daemon kDNSServiceErr_BadInterfaceIndex = -65552; kDNSServiceErr_Refused = -65553; kDNSServiceErr_NoSuchRecord = -65554; kDNSServiceErr_NoAuth = -65555; kDNSServiceErr_NoSuchKey = -65556; kDNSServiceErr_NATTraversal = -65557; kDNSServiceErr_DoubleNAT = -65558; kDNSServiceErr_BadTime = -65559; FD_SETSIZE = 64; type DNSServiceErrorType = integer; DNSServiceFlags = cardinal; DNSServiceProtocol = cardinal; {$IFNDEF FPC} TSocket = Cardinal; {$ENDIF} fdset = record fd_count: Word; fd_array: Array[0..FD_SETSIZE-1] of TSocket; end; TFDSet = fdset; PFDSet = ^fdset; timeval=record tv_sec: LongInt; // seconds tv_usec: LongInt; // and microseconds end; TTimeVal = timeval; PTimeVal = ^TTimeVal; SelectMode = (SelectRead,SelectWrite,SelectError); TROUnixSocket = class; TRODNSService = class; TROAsyncCallback = procedure(const DNSService: TRODNSService; const Sender: TROUnixSocket); TROSocketThread = class; TROUnixSocket = class private fSocket: TSocket; public constructor Create(ASocket: TSocket); procedure BeginPoll(timeout: PTimeVal; mode: SelectMode; callback: TROAsyncCallback; DNS: TRODNSService); end; TROAsyncPollCaller = function(ASocket:TROUnixSocket; timeout: PTimeVal; mode: SelectMode):boolean; TROSocketThread = class(TROThread) private ftimeout: PTimeVal; fmode: SelectMode; fcallback: TROAsyncCallback; fcaller: TROAsyncPollCaller; fsocket:TROUnixSocket; fdns:TRODNSService; procedure Callback; protected procedure Execute; override; public constructor Create(timeout: PTimeVal; mode: SelectMode; aCallback: TROAsyncCallback; caller: TROAsyncPollCaller; socket:TROUnixSocket; dns:TRODNSService); destructor Destroy; override; end; // import functions TDNSServiceBrowseReply = procedure(const sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const errorCode: DNSServiceErrorType; const serviceName: PAnsichar; const regtype: PAnsiChar; const replyDomain: PAnsiChar; const context: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceResolveReply = procedure(const sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const errorCode: DNSServiceErrorType; const fullname: PAnsiChar; const hosttarget: PAnsiChar; const port: Word; const txtLen: Word; const txtRecord: PAnsiChar; const context: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceDomainEnumReply = procedure(const sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const errorCode: DNSServiceErrorType; const replyDomain: PAnsiChar; const context: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceRegisterReply = procedure(const sdRef: Pointer; const flags: Cardinal; const errorCode: DNSServiceErrorType; const name: PAnsiChar; const regtype: PAnsiChar; const domain: PAnsiChar; const context: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceQueryRecordReply = procedure(const sdRef: pointer; const flags: Cardinal;const interfaceIndex: Cardinal; const errorCode: DNSServiceErrorType; const FullName: PAnsiChar; const rrtype, rrclass: Word; const rdLen: Word; const rdata: PAnsiChar; ttl: cardinal;const context: Pointer);{$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; {$IFNDEF NO_DNSServiceGetAddrInfo} TDNSServiceGetAddrInfoReply = procedure(const sdRef: pointer;const flags: Cardinal;const interfaceIndex: Cardinal; const errorCode: DNSServiceErrorType; const HostName: PAnsiChar; const address: Pointer; ttl: cardinal;const context: Pointer);{$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; {$ENDIF} ERODNSServiceException = class(Exception) private fDNSServiceErrorType: DNSServiceErrorType; public constructor Create(const Msg: string; const ADNSServiceErrorType: DNSServiceErrorType); property DNSServiceErrorType: DNSServiceErrorType read fDNSServiceErrorType; end; TRONetServiceErrorEvent = procedure (Sender: TRODNSService; ErrorCode: DNSServiceErrorType) of object; TRODNSService = class private socket: TROUnixSocket; inPoll: boolean; stoppingPoll: TROEvent; procedure PollInvokeable; protected sdRef: pointer; // Pointer to the internal DNSService object flags: DNSServiceFlags; interfaceIndex : cardinal; stopping: boolean; //True when we are attempting to stop the current asynchronous task. FOnError: TRONetServiceErrorEvent; FErrorCode: DNSServiceErrorType; function BlockWatchSocket(seconds: PTimeVal): boolean; overload; function BlockWatchSocket(seconds: integer): boolean; overload; procedure SetupWatchSocket; procedure WaitStop; property OnError: TRONetServiceErrorEvent read FOnError write FOnError; public constructor Create; destructor Destroy; override; procedure Stop; virtual; //Stops the currently running search or resolution. property ErrorCode: DNSServiceErrorType read FErrorCode; end; TRONetService = TRODNSService; TRONetServiceBrowseEvent = procedure (service: TRONetService; Add: boolean; AName, aServiceType, aDomain: Unicodestring) of object; TRONetServiceResolveEvent= procedure (caller: TRONetService; aFullDomainName, aHostTarget: Unicodestring; aPort: integer; txtRecord: Ansistring; addresses: Unicodestring; IPType: integer) of object; TRONetServiceQueryEvent= procedure (caller: TRONetService; aIP: UnicodeString; aIPType: integer) of object; TRORegisterNetService = class(TRONetService) private fDomain, fServiceType, fServiceName: Unicodestring; fPort: integer; fregisterReplyCb: TDNSServiceRegisterReply; fTXTRecordData: Ansistring; public constructor Create(const aDomain, aServiceType, aServiceName: Unicodestring; const aPort: integer); procedure Publish; procedure Stop; override; class procedure CreateDNSServiceRegisterException(anErrorCode: DNSServiceErrorType); property RegisterDomain: Unicodestring read fDomain; property RegisterType: Unicodestring read fServiceType; property RegisterName: Unicodestring read fServiceName; property RegisterPort: integer read fPort; property TXTRecordData: Ansistring read fTXTRecordData write fTXTRecordData; property OnError; end; TROBrowseNetService = class(TRONetService) private fResolveDomain, fResolveType: Unicodestring; fBrowseResult: TRONetServiceBrowseEvent; fBrowseReplyCb: TDNSServiceBrowseReply; public constructor Create(const aDomain, aServiceType: Unicodestring); procedure Start; procedure Stop; override; class procedure CreateDNSServiceBrowseException(anErrorCode: DNSServiceErrorType); property ResolveType: Unicodestring read fResolveType; property ResolveDomain: Unicodestring read fResolveDomain; property BrowseResult:TRONetServiceBrowseEvent read fBrowseResult write fBrowseResult; property OnError; end; TROResolveNetService = class(TRONetService) private fDomain, fType, fName: Unicodestring; fResolveResult: TRONetServiceResolveEvent; fResolveReplyCb: TDNSServiceResolveReply; fFullDomainName_block, fHostTarget_block: Unicodestring; fPort_block: integer; ftxtRecord_block: Ansistring; procedure intResolveResult(caller: TRONetService; aFullDomainName, aHostTarget: Unicodestring; aPort: integer; txtRecord: Ansistring; addresses: Unicodestring; aIPType: integer); public constructor Create(const aDomain, aType, aName: Unicodestring); procedure Resolve; procedure Stop; override; function BlockResolve(const seconds: PTimeVal; aReqIPType: integer;out fullDomainName, hostTarget: Unicodestring;out port: integer; out txtRecord: AnsiString;out IP4addresses, IP6addresses: string): DNSServiceErrorType;overload; function BlockResolve(const seconds: integer; aReqIPType: integer;out fullDomainName, hostTarget: Unicodestring;out port: integer; out txtRecord: AnsiString;out IP4addresses, IP6addresses: string): DNSServiceErrorType;overload; property ResolveDomain: Unicodestring read fDomain; property ResolveType: Unicodestring read fType; property ResolveName: Unicodestring read fName; property ResolveResult: TRONetServiceResolveEvent read fResolveResult write fResolveResult; property OnError; end; TRODNSServiceQueryRecordNetService = class(TRONetService) private FFullName: Unicodestring; FReqIPType: integer; fQueryResult: TRONetServiceQueryEvent; FIP4_block, FIP6_block: string; public constructor Create(const aFullName: Unicodestring); procedure QueryRecord; function BlockQueryRecord(const seconds: integer;aReqIPType: integer; out aIP4, aIP6: string): DNSServiceErrorType; property FullName: Unicodestring read FFullName; property OnError; property QueryResult:TRONetServiceQueryEvent read fQueryResult write fQueryResult; end; {$IFNDEF NO_DNSServiceGetAddrInfo} TRODNSServiceGetAddrInfo = class(TRONetService) private fHostName: Unicodestring; FIP_block: string; public constructor Create(const aHostName: Unicodestring); procedure GetAddrInfo; function BlockGetAddrInfo(const seconds: integer; var aIP: String): DNSServiceErrorType; property HostName: Unicodestring read fHostName; property OnError; // property OnResult:TRONetServiceQueryEvent read fQueryResult write fQueryResult; end; {$ENDIF} TROResolveNetServiceThread = class(TROThread) fcaller: TROResolveNetService; fFullDomainName, fHostTarget: Unicodestring; fPort: integer; ftxtRecord: Ansistring; faddresses: Unicodestring; fIPType: integer; procedure Callback; protected procedure Execute; override; public constructor Create(caller: TROResolveNetService; aFullDomainName, aHostTarget: Unicodestring; aPort: integer; txtRecord: Ansistring); end; EDllNotFoundException = class(Exception) end; // procedure FD_CLR(ASocket: TSocket; var FDSet: TFDSet); // function FD_ISSET(ASocket: TSocket; var FDSet: TFDSet): Boolean; // procedure FD_SET(ASocket: TSocket; var FDSet: TFDSet); // procedure FD_ZERO(var fdset: TFDSet); TDNSServiceRefSockFD = function(const sdRef: Pointer): DNSServiceErrorType; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceProcessResult = function (const sdRef: Pointer): DNSServiceErrorType; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceRefDeallocate = procedure (const sdRef: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceBrowse = function(out sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const regtype: PAnsiChar; const domain: PAnsiChar; const callBack: TDNSServiceBrowseReply; const context: Pointer): DNSServiceErrorType; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceResolve = function(out sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const name: PAnsiChar; const regtype: PAnsiChar; const domain: PAnsiChar; const callBack: TDNSServiceResolveReply; const context: Pointer): DNSServiceErrorType; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceEnumerateDomains = function (out sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const callBack: TDNSServiceDomainEnumReply; const context: Pointer):DNSServiceErrorType; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceRegister = function(out sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const name: PAnsiChar; const regtype: PAnsiChar; const domain: PAnsiChar; const host: PAnsiChar; const port: Word; const txtLen: Word; const txtRecord: PAnsiChar; const callBack: TDNSServiceRegisterReply;const context: Pointer): DNSServiceErrorType; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; TDNSServiceQueryRecord = function(out sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal;const FullName: PAnsiChar; const rrtype, rrclass: word; callBack: TDNSServiceQueryRecordReply; context: Pointer):DNSServiceErrorType;{$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; {$IFNDEF NO_DNSServiceGetAddrInfo} TDNSServiceGetAddrInfo = function(out sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal;const protocol:DNSServiceProtocol;const HostName: PAnsiChar; const callBack: TDNSServiceGetAddrInfoReply;context: Pointer):DNSServiceErrorType;{$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; {$ENDIF} TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; timeout: PTimeVal): Integer; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; {$IFNDEF FPC} Thtons = function(hostshort: Word): Word; stdcall; Tntohs = function(hostshort: Word): Word; stdcall; PInAddr = ^TInAddr; TInAddr = packed record case integer of 0: (S_bytes: packed array [0..3] of byte); 1: (S_addr: Cardinal); end; PSockAddrIn = ^TSockAddrIn; TSockAddrIn = packed record case Integer of 0: (sin_family: word; sin_port: word; sin_addr: TInAddr; sin_zero: array[0..7] of byte); 1: (sa_family: word; sa_data: array[0..13] of byte) end; PSockAddr = ^TSockAddr; TSockAddr = TSockAddrIn; PSockProto = ^TSockProto; TSockProto = packed record sp_family: Word; sp_protocol: Word; end; {$ENDIF} PAddrInfo = ^TAddrInfo; TAddrInfo = packed record ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. ai_family: integer; // PF_xxx. ai_socktype: integer; // SOCK_xxx. ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. ai_addrlen: cardinal; // Length of ai_addr. ai_canonname: PAnsiChar; // Canonical name for nodename. ai_addr: PSockAddr; // Binary address. ai_next: PAddrInfo; // Next structure in linked list. end; PAddrInfoW = ^TAddrInfoW; TAddrInfoW = packed record ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. ai_family: integer; // PF_xxx. ai_socktype: integer; // SOCK_xxx. ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. ai_addrlen: cardinal; // Length of ai_addr. ai_canonname: PWideChar; // Canonical name for nodename. ai_addr: PSockAddr; // Binary address. ai_next: PAddrInfoW; // Next structure in linked list. end; var DNSServiceRefSockFD: TDNSServiceRefSockFD = nil; DNSServiceProcessResult: TDNSServiceProcessResult = nil; DNSServiceRefDeallocate: TDNSServiceRefDeallocate = nil; DNSServiceBrowse: TDNSServiceBrowse = nil; DNSServiceResolve: TDNSServiceResolve = nil; DNSServiceEnumerateDomains: TDNSServiceEnumerateDomains = nil; DNSServiceRegister: TDNSServiceRegister = nil; DNSServiceQueryRecord: TDNSServiceQueryRecord = nil; {$IFNDEF NO_DNSServiceGetAddrInfo} DNSServiceGetAddrInfo:TDNSServiceGetAddrInfo = nil; {$ENDIF} {$IFNDEF MSWINDOWS} Select: TSelect; {$ENDIF} {$IFDEF MSWINDOWS} const WINSOCK2_DLL = 'ws2_32.dll'; AF_IRDA = 26; AF_BTM = 32; WSADESCRIPTION_LEN = 256; WSASYS_STATUS_LEN = 128; NI_MAXHOST = 1025; NI_MAXSERV = 32; NI_NUMERICHOST = $2; NI_NUMERICSERV = $8; type PWSAData = ^TWSAData; TWSAData = packed record wVersion: Word; wHighVersion: Word; szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar; szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar; iMaxSockets: Word; iMaxUDPDg: Word; lpVendorInfo: PAnsiChar; end; function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Longint; stdcall; external WINSOCK2_DLL; function WSACleanup: Longint; stdcall; external WINSOCK2_DLL; function getaddrinfo(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; var Addrinfo: PAddrInfo): integer; stdcall; external WINSOCK2_DLL; procedure freeaddrinfo(ai: PAddrInfo); stdcall;external WINSOCK2_DLL; function getnameinfo( addr: PSockAddr; namelen: Integer; host: PAnsiChar;hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; stdcall;external WINSOCK2_DLL; function select(nfds: Longint; readfds, writefds, exceptfds: PFDSet; timeout: PTimeVal): Longint; stdcall;external WINSOCK2_DLL name 'select'; function htons(hostshort: Word): Word; stdcall;external WINSOCK2_DLL name 'htons'; function ntohs(netshort: Word): Word; stdcall;external WINSOCK2_DLL name 'ntohs'; {$ENDIF} function CheckDNSFunctions(aRaiseException: Boolean = True): Boolean; function ROGetAddrInfo(const aHostTarget: Unicodestring; out aIPType: integer; const AReqIPType: integer = AF_UNSPEC; const Timeout: integer =60): string; function TXTRecordFromString(aString: UnicodeString): AnsiString; function StringFromTXTRecord(aString: AnsiString): UnicodeString; implementation {$IFDEF FPC}uses dynlibs, Math;{$ENDIF} function TXTRecordFromString(aString: UnicodeString): AnsiString; var s: TStringList; p: PAnsiChar; a: AnsiString; i: integer; k: byte; aTXTRecordSize: integer; begin s:= TStringList.Create; try s.Text := {$IFNDEF UNICODE}UTF8Encode{$ENDIF}(aString); aTXTRecordSize := Length(s.Text)+s.Count; if aTXTRecordSize = 0 then Result := '' else begin SetLength(Result, aTXTRecordSize{$IFDEF UNICODE}*3{$ENDIF}); p :=PAnsiChar(Result); for I := 0 to s.Count - 1 do begin a := {$IFDEF UNICODE}UTF8Encode{$ENDIF}(s[i]); if Length(a) > 255 then k:= 255 else k := Length(a); p^:=AnsiChar(k); inc(p); Move(Pointer(a)^, p^,k); inc(p,k); end; SetLength(Result, p - PAnsiChar(Result)); end; finally s.Free; end; end; function StringFromTXTRecord(aString: AnsiString): UnicodeString; var s: TStringList; p1,p2: PAnsiChar; a: AnsiString; begin Result:= ''; if Length(aString) = 0 then Exit; s:= TStringList.Create; try p1 := PAnsiChar(aString); p2:= p1+ Length(aString); while p1+1+ord(p1^) <= p2 do begin SetString(a,p1+1,Ord(p1^)); s.Add({$IFDEF UNICODE}UTF8ToString{$ENDIF}(a)); inc(p1,ord(p1^)+1); end; Result:={$IFNDEF UNICODE}UTF8ToString{$ENDIF}(s.Text); if (Length(Result)>2) and (Result[Length(Result)-1] = #13) and (Result[Length(Result)]=#10) then SetLength(Result, Length(Result)-2); finally s.Free; end; end; function ROGetAddrInfo(const aHostTarget: Unicodestring; out aIPType: integer; const AReqIPType: integer = AF_UNSPEC; const Timeout: integer =60): string; {$IFNDEF USE_ONLY_mDNS_FOR_RESOLVE} var S: TStringList; lHostTarget: Ansistring; Procedure _GetAddrInfo(aFamily: integer); var lhint : TAddrInfo; lnext,lnext1 : PAddrInfo; lhost, lserv: AnsiString; begin FillChar(lhint,SizeOf(lhint),0); lhint.ai_family := aFamily; if GetAddrInfo(PAnsiChar(lHostTarget),nil,@lhint,lnext) = 0 then try lnext1 := lnext; while lNext1 <> nil do begin setlength(lhost, NI_MAXHOST); setlength(lserv, NI_MAXSERV); if getnameinfo(lNext1^.ai_addr, lNext1^.ai_addrlen, PAnsiChar(lhost), NI_MAXHOST, PAnsiChar(lserv), NI_MAXSERV, NI_NUMERICHOST + NI_NUMERICSERV) = 0 then s.Add({$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(PAnsiChar(lhost))); lnext1:=lnext1^.ai_next; end; finally freeaddrinfo(lnext); end; end; {$ENDIF USE_ONLY_mDNS_FOR_RESOLVE} var lip4, lip6: string; begin {$IFDEF FPC} Result := ''; {$ENDIF} {$IFNDEF USE_ONLY_mDNS_FOR_RESOLVE} if Pos('.local.', aHostTarget) <> Length(aHostTarget) - 6 then begin lHostTarget := {$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(aHostTarget); s:= TStringList.Create; try _GetAddrInfo(AF_INET); // ip4 _GetAddrInfo(AF_INET6);// ip6 _GetAddrInfo(AF_IRDA); // IrDA _GetAddrInfo(AF_BTM); // Bluetooth Result := s.CommaText; finally s.Free; end; end else {$ENDIF USE_ONLY_mDNS_FOR_RESOLVE} begin // use mDNS function {$IFNDEF NO_DNSServiceGetAddrInfo} With TRODNSServiceGetAddrInfo.Create(aHostTarget) do try if BlockGetAddrInfo(Timeout,Result)<>kDNSServiceErr_NoError then Result := ''; finally Free; end; {$ELSE} With TRODNSServiceQueryRecordNetService.Create(aHostTarget) do try if BlockQueryRecord(Timeout,AReqIPType,lip4,lIP6)=kDNSServiceErr_NoError then begin Result := lip4; aIPType := AF_INET; if (Result = '') or ((lip6 <> '') and (AReqIPType = AF_INET6)) then begin Result := lip6; aIPType := AF_INET6; end; end else begin Result := ''; end; finally Free; end; {$ENDIF} end; end; procedure FD_CLR(ASocket: TSocket; var FDSet: TFDSet); var i: integer; begin i := 0; while i < FDSet.fd_count do begin if FDSet.fd_array[i] = ASocket then begin while i < FDSet.fd_count do begin FDSet.fd_array[i] := FDSet.fd_array[i+1]; Inc(i); end; Dec(FDSet.fd_count); Break; end; end; end; function FD_ISSET(ASocket: TSocket; var FDSet: TFDSet): Boolean; var i: integer; begin Result := False; for i := 0 to FDSet.fd_count - 1 do begin if FDSet.fd_array[i] = ASocket then begin Result := True; Exit; end; end; end; procedure FD_SET(ASocket: TSocket; var FDSet: TFDSet); var i: integer; begin for i := 0 to FDSet.fd_count - 1 do if FDSet.fd_array[i] = ASocket then Exit; if FDSet.fd_count < fd_setsize then begin FDSet.fd_array[FDSet.fd_count] := ASocket; Inc(FDSet.fd_count); end; end; procedure FD_ZERO(var fdset: TFDSet); begin fdset.fd_count := 0; end; { TROUnixSocket } function Pool(ASocket:TROUnixSocket; timeout: PTimeVal; mode: SelectMode): boolean; var readFDs: FDSet; begin with ASocket do begin if mode = SelectRead then begin FD_ZERO(readFDs); FD_SET(FSocket,readFDs); end; Select(1, @readFDs, nil, nil, timeout); Result := FD_ISSET(FSocket, readFDs); end; end; procedure TROUnixSocket.BeginPoll(timeout: PTimeVal; mode: SelectMode;callback: TROAsyncCallback; DNS: TRODNSService); var lAsyncPollCaller: TROAsyncPollCaller; begin lAsyncPollCaller := @Pool; TROSocketThread.Create(timeout, mode, callback, lAsyncPollCaller, Self, DNS); end; constructor TROUnixSocket.Create(ASocket: TSocket); begin inherited Create; fSocket := ASocket; end; { TROSocketThread } procedure TROSocketThread.Callback; begin if Assigned(fcallback) then fcallback(fdns, Fsocket); end; constructor TROSocketThread.Create(timeout: PTimeVal; mode: SelectMode; aCallback: TROAsyncCallback; caller: TROAsyncPollCaller; socket:TROUnixSocket; dns:TRODNSService); begin {$IFNDEF FPC} inherited Create(False,''); {$ELSE} inherited Create(True,''); {$ENDIF} fTimeOut := timeout; fmode := mode; fcallback := aCallback; fcaller:= caller; fSocket := socket; fDNS:= dns; FreeOnTerminate := True; {$IFDEF FPC} Resume; {$ENDIF} end; destructor TROSocketThread.Destroy; begin inherited; end; procedure TROSocketThread.Execute; begin inherited; if Assigned(fCaller) then begin fcaller(fsocket, ftimeout,fmode); // Synchronize(Callback); Callback; end; end; { ERODNSServiceException } constructor ERODNSServiceException.Create(const Msg: string; const ADNSServiceErrorType: DNSServiceErrorType); begin inherited Create(Msg); fDNSServiceErrorType := ADNSServiceErrorType; end; { TRODNSService } procedure AsyncPollCallback(const DNSService: TRODNSService; const Sender: TROUnixSocket); begin with DNSService do begin if (stopping) then begin inPoll := false; stoppingPoll.SetEvent; exit; // if we're stopping, don't begin a new poll end; PollInvokeable(); inPoll := true; socket.BeginPoll(nil, SelectRead, @AsyncPollCallback,DNSService); end; end; function TRODNSService.BlockWatchSocket(seconds: PTimeVal): boolean; var lsocket: TSocket; begin if inPoll then begin Result := False end else begin inPoll := True; try lsocket := DNSServiceRefSockFD(sdRef); socket := TROUnixSocket.Create(lsocket); if (Pool(socket, seconds, SelectRead)) then begin PollInvokeable(); Result := true; end else begin Result := false; end; finally inPoll := False; end; end; end; function TRODNSService.BlockWatchSocket(seconds: integer): boolean; var lTimeVal: TTimeVal; begin if Seconds = - 1 then begin Result:= BlockWatchSocket(nil) end else begin lTimeVal.tv_sec:=seconds; lTimeVal.tv_usec:=0; Result:= BlockWatchSocket(@lTimeVal); end; end; constructor TRODNSService.Create; begin inherited Create; stopping := False; inPoll:=False; stoppingPoll := TROEvent.Create(nil,false,false,''); {$IFNDEF DESIGNTIME} CheckDNSFunctions; {$ENDIF} flags:=0;; interfaceIndex := kDNSServiceInterfaceIndexAny; end; destructor TRODNSService.Destroy; begin Stop; FreeAndNil(stoppingPoll); FreeAndNil(socket); inherited; end; procedure TRODNSService.PollInvokeable; begin try DNSServiceProcessResult(sdRef); except end; end; procedure TRODNSService.SetupWatchSocket; var lsocket: TSocket; lcallback:TROAsyncCallback; begin if inPoll then Exit; // already running lsocket := DNSServiceRefSockFD(sdRef); socket := TROUnixSocket.Create(lsocket); stopping := false; inPoll := true; lcallback:=@AsyncPollCallback; socket.BeginPoll(nil, SelectRead, lcallback, Self); end; procedure TRODNSService.Stop; begin if sdRef <> nil then begin DNSServiceRefDeallocate(sdRef); sdRef := nil; end; WaitStop; end; procedure TRODNSService.WaitStop; begin if (inPoll) then begin stopping := true; stoppingPoll.WaitFor(Cardinal(-1)); end; end; { TRORegisterNetService } constructor TRORegisterNetService.Create(const aDomain, aServiceType, aServiceName: Unicodestring; const aPort: integer); begin inherited Create; fDomain := aDomain; fServiceType := aServiceType; fServiceName := aServiceName; fPort := aPort; end; procedure IntRegisterReply(const sdRef: Pointer; const flags: Cardinal; const errorCode: DNSServiceErrorType; const name: PAnsiChar; const regtype: PAnsiChar; const domain: PAnsiChar; const context: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; begin if Assigned(context) and Assigned(TRORegisterNetService(context).OnError) then TRORegisterNetService(context).OnError(TRORegisterNetService(context),errorCode); end; class procedure TRORegisterNetService.CreateDNSServiceRegisterException(anErrorCode: DNSServiceErrorType); begin raise ERODNSServiceException.CreateFmt('DNSServiceRegister, ErrorCode = %d', [anErrorCode]); end; procedure TRORegisterNetService.Publish; var lServiceName, lServiceType, lDomain: AnsiString; begin Stop; FErrorCode:= kDNSServiceErr_NoError; fregisterReplyCb := @IntRegisterReply; lServiceName :=UTF8Encode(fServiceName); lServiceType := UTF8Encode(fServiceType); lDomain :=UTF8Encode(fDomain); FErrorCode := DNSServiceRegister(sdRef, flags, interfaceIndex, PAnsiChar(lServiceName), PAnsiChar(lServiceType), PAnsichar(lDomain), nil, htons(fport), Length(fTXTRecordData), PAnsiChar(fTXTRecordData), fregisterReplyCb, Self); if (FErrorCode <> kDNSServiceErr_NoError) then begin if Assigned(OnError) then OnError(Self,FErrorCode) else CreateDNSServiceRegisterException(FErrorCode); end else begin SetupWatchSocket(); end; end; procedure TRORegisterNetService.Stop; begin inherited; fregisterReplyCb := nil; end; { TROBrowseNetService } constructor TROBrowseNetService.Create(const aDomain, aServiceType: Unicodestring); begin inherited Create; fResolveDomain := aDomain; fResolveType := aServiceType; end; procedure IntBrowseReply(const sdRef: Pointer; const aflags: Cardinal; const aInterfaceIndex: Cardinal; const aErrorCode: DNSServiceErrorType; const aserviceName: PAnsichar; const aregtype: PAnsiChar; const areplyDomain: PAnsiChar; const acontext: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; begin if Assigned(aContext) then with TROBrowseNetService(acontext) do begin if (AErrorCode <> kDNSServiceErr_NoError) then begin fErrorCode:= aErrorCode; if Assigned(OnError) then OnError(TROBrowseNetService(acontext), aErrorCode); end else begin if Assigned(fBrowseResult) then fBrowseResult(TROBrowseNetService(acontext), (aflags and kDNSServiceFlagsAdd) = kDNSServiceFlagsAdd, UTF8ToString(aServiceName), UTF8ToString(aregtype), UTF8ToString(areplyDomain)); end; end; end; class procedure TROBrowseNetService.CreateDNSServiceBrowseException(anErrorCode: DNSServiceErrorType); begin raise ERODNSServiceException.CreateFmt('DNSServiceBrowse, ErrorCode = %d', [anErrorCode]); end; procedure TROBrowseNetService.Start; var lResolveType: UTF8String; lResolveDomain: UTF8String; begin Stop(); fBrowseReplyCb := @IntBrowseReply; lResolveType := UTF8Encode(fResolveType); lResolveDomain := UTF8Encode(fResolveDomain); FErrorCode:= kDNSServiceErr_NoError; FErrorCode := DNSServiceBrowse(sdRef, flags, interfaceIndex, PAnsiChar(lResolveType), PAnsiChar(lResolveDomain), fBrowseReplyCb, Self); if (FErrorCode <> kDNSServiceErr_NoError) then begin if assigned(OnError) then OnError(Self,fErrorCode) else CreateDNSServiceBrowseException(FErrorCode); end; if FErrorCode = kDNSServiceErr_NoError then SetupWatchSocket(); end; procedure TROBrowseNetService.Stop; begin inherited Stop; fBrowseReplyCb := nil; end; { TROResolveNetService } procedure intResolveReply_block(const sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const aErrorCode: DNSServiceErrorType; const fullname: PAnsiChar; const hosttarget: PAnsiChar; const port: Word; const txtLen: Word; const txtRecord: PAnsiChar; const context: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; var ltxtRecord: Ansistring; begin if Assigned(context) then with TROResolveNetService(context) do begin if (aErrorCode <> kDNSServiceErr_NoError) then begin FErrorCode:= aErrorCode; if Assigned(OnError) then OnError(TROResolveNetService(context),errorCode); end else begin fFullDomainName_block:= UTF8ToString(fullname); fHostTarget_block:= UTF8ToString(hosttarget); fPort_block:=ntohs(port); SetString(ltxtRecord,txtRecord,txtLen); ftxtRecord_block:=ltxtRecord; end; end; end; function TROResolveNetService.BlockResolve(const seconds: PTimeVal; aReqIPType: integer; out fullDomainName, hostTarget: Unicodestring; out port: integer; out txtRecord: AnsiString; out IP4addresses, IP6addresses: string): DNSServiceErrorType; var lUTF8_name,lUTF8_Type,lUTF8_Domain: UTF8String; fResolveReplyCb_block: TDNSServiceResolveReply; liptype: integer; laddress:string; begin Stop(); fResolveReplyCb_block := @intResolveReply_block; fFullDomainName_block:= ''; fHostTarget_block:= ''; fPort_block:=0; ftxtRecord_block:=''; lUTF8_name := UTF8Encode(fName); lUTF8_Type := UTF8Encode(fType); lUTF8_Domain := UTF8Encode(fDomain); FErrorCode := DNSServiceResolve(sdRef, flags, interfaceIndex, PAnsiChar(lUTF8_name), PAnsiChar(lUTF8_Type), PAnsiChar(lUTF8_Domain), fResolveReplyCb_block, Self); try if (FErrorCode = kDNSServiceErr_NoError) then begin if (not BlockWatchSocket(seconds) ) then begin FErrorCode:=kDNSServiceErr_Timeout; end else begin fullDomainName := fFullDomainName_block; hostTarget := fHostTarget_block; port := fPort_block; txtRecord := ftxtRecord_block; laddress := ROGetAddrInfo(fHostTarget_block, liptype, aReqIPType); if liptype = AF_INET then IP4addresses := laddress else IP6addresses := laddress; end; end; finally inherited Stop(); if FErrorCode <> kDNSServiceErr_NoError then begin fullDomainName := ''; hostTarget := ''; port := 0; txtRecord := ''; IP4addresses := ''; IP6addresses := ''; end; Result := FErrorCode; end; end; function TROResolveNetService.BlockResolve(const seconds: integer; aReqIPType: integer; out fullDomainName, hostTarget: Unicodestring; out port: integer; out txtRecord: AnsiString; out IP4addresses, IP6addresses: string): DNSServiceErrorType; var lTimeVal: TTimeVal; begin if Seconds = - 1 then begin Result:= BlockResolve(nil,aReqIPType, fullDomainName,hostTarget,port,txtRecord, IP4addresses, IP6addresses); end else begin lTimeVal.tv_sec:=seconds; lTimeVal.tv_usec:=0; Result:= BlockResolve(@lTimeVal,aReqIPType, fullDomainName,hostTarget,port,txtRecord, IP4addresses, IP6addresses); end; end; constructor TROResolveNetService.Create(const aDomain, aType, aName: Unicodestring); begin inherited Create; fDomain := aDomain; fType := aType; fName := aName; end; procedure intResolveReply(const sdRef: Pointer; const flags: Cardinal; const interfaceIndex: Cardinal; const aErrorCode: DNSServiceErrorType; const fullname: PAnsiChar; const hosttarget: PAnsiChar; const port: Word; const txtLen: Word; const txtRecord: PAnsiChar; const context: Pointer); {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; var ltxtRecord: Ansistring; begin if Assigned(context) then with TROResolveNetService(context) do begin if (aErrorCode <> kDNSServiceErr_NoError) then begin FErrorCode:=aErrorCode; if Assigned(OnError) then OnError(TROResolveNetService(context),errorCode); end else begin SetString(ltxtRecord,txtRecord,txtLen); TROResolveNetServiceThread.Create(TROResolveNetService(context),UTF8ToString(fullname),UTF8ToString(hosttarget),ntohs(port),ltxtRecord); end; end; end; procedure TROResolveNetService.intResolveResult(caller: TRONetService; aFullDomainName, aHostTarget: Unicodestring; aPort: integer; txtRecord: AnsiString; addresses: Unicodestring; aIPType: integer); begin if assigned(fResolveResult) then fResolveResult(self, aFullDomainName, ahosttarget, aport, txtRecord, addresses, aipType); end; procedure TROResolveNetService.Resolve; var lUTF8_name,lUTF8_Type,lUTF8_Domain: UTF8String; begin Stop; fResolveReplyCb := @intResolveReply; lUTF8_name := UTF8Encode(fName); lUTF8_Type := UTF8Encode(fType); lUTF8_Domain := UTF8Encode(fDomain); FErrorCode:= kDNSServiceErr_NoError; FErrorCode := DNSServiceResolve(sdRef, flags, interfaceIndex, PAnsiChar(lUTF8_name), PAnsiChar(lUTF8_Type), PAnsiChar(lUTF8_Domain), fResolveReplyCb, Self); if (FErrorCode <> kDNSServiceErr_NoError) then begin if Assigned(OnError) then OnError(Self,ErrorCode) else raise ERODNSServiceException.CreateFmt('DNSServiceResolve, ErrorCode = %d', [FErrorCode]); end; SetupWatchSocket(); end; procedure TROResolveNetService.Stop; begin inherited; fResolveReplyCb := nil; end; var lib_handle :THandle = 0; lib1_handle :THandle = 0; lib2_handle :THandle = 0; const {$IFDEF MSWINDOWS}lib_name = 'dnssd.dll';{$ELSE} {$IFDEF DARWIN} lib_name = 'libc.dylib';{$ELSE} lib_name = 'libdns_sd.so'; lib_name2 = 'dnssdlibdns_sd.so'; lib_name3 = 'libc.so'; {$ENDIF}{$ENDIF} procedure LoadLibraries; {$IFDEF MSWINDOWS} var WSData: TWSAData; begin lib_handle := LoadLibrary(lib_name); if lib_handle <> 0 then begin DNSServiceRefSockFD := TDNSServiceRefSockFD(GetProcAddress(lib_handle,'DNSServiceRefSockFD')); DNSServiceProcessResult := TDNSServiceProcessResult(GetProcAddress(lib_handle,'DNSServiceProcessResult')); DNSServiceRefDeallocate := TDNSServiceRefDeallocate(GetProcAddress(lib_handle,'DNSServiceRefDeallocate')); DNSServiceBrowse := TDNSServiceBrowse(GetProcAddress(lib_handle,'DNSServiceBrowse')); DNSServiceResolve := TDNSServiceResolve(GetProcAddress(lib_handle,'DNSServiceResolve')); DNSServiceEnumerateDomains := TDNSServiceEnumerateDomains(GetProcAddress(lib_handle,'DNSServiceEnumerateDomains')); DNSServiceRegister := TDNSServiceRegister(GetProcAddress(lib_handle,'DNSServiceRegister')); DNSServiceQueryRecord := TDNSServiceQueryRecord(GetProcAddress(lib_handle,'DNSServiceQueryRecord')); {$IFNDEF NO_DNSServiceGetAddrInfo} DNSServiceGetAddrInfo := TDNSServiceGetAddrInfo(GetProcAddress(lib_handle,'DNSServiceGetAddrInfo')); {$ENDIF} end; WSAStartup($0202,WSData); end; {$ELSE} {$IFDEF DARWIN} begin lib_handle := LoadLibrary(lib_name); if lib_handle <> 0 then begin DNSServiceRefSockFD := TDNSServiceRefSockFD(GetProcAddress(lib_handle,'DNSServiceRefSockFD')); DNSServiceProcessResult := TDNSServiceProcessResult(GetProcAddress(lib_handle,'DNSServiceProcessResult')); DNSServiceRefDeallocate := TDNSServiceRefDeallocate(GetProcAddress(lib_handle,'DNSServiceRefDeallocate')); DNSServiceBrowse := TDNSServiceBrowse(GetProcAddress(lib_handle,'DNSServiceBrowse')); DNSServiceResolve := TDNSServiceResolve(GetProcAddress(lib_handle,'DNSServiceResolve')); DNSServiceEnumerateDomains := TDNSServiceEnumerateDomains(GetProcAddress(lib_handle,'DNSServiceEnumerateDomains')); DNSServiceRegister := TDNSServiceRegister(GetProcAddress(lib_handle,'DNSServiceRegister')); DNSServiceQueryRecord := TDNSServiceQueryRecord(GetProcAddress(lib_handle,'DNSServiceQueryRecord')); {$IFNDEF NO_DNSServiceGetAddrInfo} DNSServiceGetAddrInfo := TDNSServiceGetAddrInfo(GetProcAddress(lib_handle,'DNSServiceGetAddrInfo')); {$ENDIF} Select := TSelect(GetProcAddress(lib_handle,'Select')); end; end; {$ELSE} begin lib_handle := LoadLibrary(lib_name); if lib_handle <> 0 then begin DNSServiceRefSockFD := TDNSServiceRefSockFD(GetProcAddress(lib_handle,'DNSServiceRefSockFD')); DNSServiceProcessResult := TDNSServiceProcessResult(GetProcAddress(lib_handle,'DNSServiceProcessResult')); DNSServiceRefDeallocate := TDNSServiceRefDeallocate(GetProcAddress(lib_handle,'DNSServiceRefDeallocate')); DNSServiceResolve := TDNSServiceResolve(GetProcAddress(lib_handle,'DNSServiceResolve')); DNSServiceEnumerateDomains := TDNSServiceEnumerateDomains(GetProcAddress(lib_handle,'DNSServiceEnumerateDomains')); DNSServiceRegister := TDNSServiceRegister(GetProcAddress(lib_handle,'DNSServiceRegister')); DNSServiceQueryRecord := TDNSServiceQueryRecord(GetProcAddress(lib_handle,'DNSServiceQueryRecord')); {$IFNDEF NO_DNSServiceGetAddrInfo} DNSServiceGetAddrInfo := TDNSServiceGetAddrInfo(GetProcAddress(lib_handle,'DNSServiceGetAddrInfo')); {$ENDIF} end; lib1_handle := LoadLibrary(lib_name2); if lib1_handle <> 0 then begin DNSServiceBrowse := TDNSServiceBrowse(GetProcAddress(lib1_handle,'DNSServiceBrowse')); end; lib2_handle := LoadLibrary(lib_name3); if lib2_handle <> 0 then begin Select := TSelect(GetProcAddress(lib2_handle,'Select')); end; end; {$ENDIF} {$ENDIF} procedure UnloadLibraries; begin {$IFDEF MSWINDOWS} WSACleanup; {$ENDIF} if lib_handle <> 0 then FreeLibrary(lib_handle); if lib1_handle <> 0 then FreeLibrary(lib1_handle); if lib2_handle <> 0 then FreeLibrary(lib2_handle); DNSServiceRefSockFD := nil; DNSServiceProcessResult := nil; DNSServiceRefDeallocate := nil; DNSServiceBrowse := nil; DNSServiceResolve := nil; DNSServiceEnumerateDomains := nil; DNSServiceRegister := nil; DNSServiceQueryRecord := nil; {$IFNDEF NO_DNSServiceGetAddrInfo} DNSServiceGetAddrInfo:=nil; {$ENDIF} end; function CheckDNSFunctions(aRaiseException: Boolean = True): Boolean; begin Result := False; if lib_handle = 0 then begin if aRaiseException then raise EDllNotFoundException.CreateFmt('Cannot load %s library', [lib_name]); Exit; end; {$IFNDEF MSWINDOWS} {$IFNDEF DARWIN} if lib1_handle = 0 then begin if aRaiseException then raise EDllNotFoundException.CreateFmt('Cannot load %s library', [lib_name2]); Exit; end; if lib1_handle = 0 then begin if aRaiseException then raise EDllNotFoundException.CreateFmt('Cannot load %s library', [lib_name3]); Exit; end; {$ENDIF} {$ENDIF} Result := (@DNSServiceRefSockFD <> nil) and (@DNSServiceProcessResult <> nil) and (@DNSServiceRefDeallocate <> nil) and (@DNSServiceBrowse <> nil) and (@DNSServiceResolve <> nil) and (@DNSServiceEnumerateDomains <> nil) and (@DNSServiceRegister <> nil) and (@DNSServiceQueryRecord <> nil) {$IFNDEF NO_DNSServiceGetAddrInfo} and (@DNSServiceGetAddrInfo <> nil) {$ENDIF} ; if not Result and aRaiseException then raise EDllNotFoundException.Create('uROmDNSImports: Some functions aren''t loaded!'); end; { TROResolveNetServiceThread } procedure TROResolveNetServiceThread.Callback; begin fcaller.intResolveResult(fcaller,fFullDomainName,fHostTarget,fPort,ftxtRecord,fAddresses, fIPType); end; constructor TROResolveNetServiceThread.Create(caller: TROResolveNetService; aFullDomainName, aHostTarget: Unicodestring; aPort: integer; txtRecord: Ansistring); begin inherited Create(True); fcaller := caller; fFullDomainName := aFullDomainName; fHostTarget := aHostTarget; fPort := aPort; ftxtRecord := txtRecord; end; procedure TROResolveNetServiceThread.Execute; begin inherited; faddresses := ROGetAddrInfo(fHostTarget, fIPType); // Synchronize(Callback); callback; end; function DecodeIP4(const rdLen: Word; const rdata: PAnsiChar): string; begin Result := Format('%d.%d.%d.%d', [ord(rdata[0]),ord(rdata[1]),ord(rdata[2]),ord(rdata[3])]); end; function DecodeIP6(const rdLen: Word; const rdata: PAnsiChar): string; var lip: AnsiString; begin SetString(lip,rdata,rdLen); Result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(lIP); end; { TRODNSServiceQueryRecordNetService } procedure intQueryRecordReply_block(const DNSServiceRef: pointer; const flags: Cardinal;const interfaceIndex: Cardinal; const aErrorCode: DNSServiceErrorType; const FullName: PAnsiChar; const rrtype, rrclass: Word; const rdLen: Word; const rdata: PAnsiChar; ttl: cardinal;const context: Pointer);{$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; begin if Assigned(context) then with TRODNSServiceQueryRecordNetService(context) do begin if (aErrorCode <> kDNSServiceErr_NoError) then begin FErrorCode:= aErrorCode; if Assigned(OnError) then OnError(TROResolveNetService(context),errorCode); end else begin if rdLen = 4 then FIP4_block := DecodeIP4(rdLen,rdata) else FIP6_block := DecodeIP6(rdLen,rdata) end; end; end; function TRODNSServiceQueryRecordNetService.BlockQueryRecord(const seconds: integer;aReqIPType: integer; out aIP4, aIP6: string): DNSServiceErrorType; var lUTF8_Fullname: AnsiString; lQueryRecordCb_block: TDNSServiceQueryRecordReply; begin Stop(); FReqIPType := aReqIPType; lQueryRecordCb_block := @intQueryRecordReply_block; FIP4_block:= ''; FIP6_block:= ''; lUTF8_Fullname:= UTF8Encode(FFullName); FErrorCode := DNSServiceQueryRecord(sdRef, flags, interfaceIndex,PAnsiChar(lUTF8_Fullname),kDNSServiceType_A,kDNSServiceClass_IN,lQueryRecordCb_block,self); try if (FErrorCode = kDNSServiceErr_NoError) then begin if (not BlockWatchSocket(seconds)) then begin FErrorCode:=kDNSServiceErr_Timeout; end else begin aIP4 := FIP4_block; aIP6 := FIP6_block; end; end; finally inherited Stop(); if FErrorCode <> kDNSServiceErr_NoError then begin aIP4 := ''; aIP6 := ''; end; Result := FErrorCode; end; end; constructor TRODNSServiceQueryRecordNetService.Create( const aFullName: Unicodestring); begin inherited Create; FFullName := aFullName; flags := kDNSServiceFlagsForceMulticast; end; procedure intQueryRecordCb(const DNSServiceRef: pointer; const flags: Cardinal;const interfaceIndex: Cardinal; const aErrorCode: DNSServiceErrorType; const FullName: PAnsiChar; const rrtype, rrclass: Word; const rdLen: Word; const rdata: PAnsiChar; ttl: cardinal;const context: Pointer);{$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; var lIP: string; lIPType: integer; begin if Assigned(context) then with TRODNSServiceQueryRecordNetService(context) do begin if (aErrorCode <> kDNSServiceErr_NoError) then begin FErrorCode := aErrorCode; if Assigned(OnError) then OnError(TROResolveNetService(context),errorCode); end else begin if rdLen = 4 then begin lIP := DecodeIP4(rdLen, rdata); lIPType := AF_INET; end else begin lIP := DecodeIP6(rdLen, rdata); lIPType := AF_INET6; end; if Assigned(fQueryResult) then fQueryResult(TROResolveNetService(context),lIP, lIPType); end; end; end; procedure TRODNSServiceQueryRecordNetService.QueryRecord; var lUTF8_Fullname: AnsiString; fQueryRecordCb: TDNSServiceQueryRecordReply; begin fQueryRecordCb := @intQueryRecordCb; lUTF8_Fullname:= UTF8Encode(FFullName); FErrorCode := kDNSServiceErr_NoError; FErrorCode := DNSServiceQueryRecord(sdRef,flags, interfaceIndex,PAnsiChar(lUTF8_Fullname),kDNSServiceType_A,kDNSServiceClass_IN,fQueryRecordCb,self); end; {$IFDEF DELPHI10UP}{$REGION 'NO_DNSServiceGetAddrInfo'}{$ENDIF DELPHI10UP} {$IFNDEF NO_DNSServiceGetAddrInfo} { TRODNSServiceGetAddrInfo } procedure intGetAddrInfoReply_block(const sdRef: pointer;const flags: Cardinal;const interfaceIndex: Cardinal; const aErrorCode: DNSServiceErrorType; const HostName: PAnsiChar; const address: Pointer; ttl: cardinal;const context: Pointer);{$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; begin if Assigned(context) then begin with TRODNSServiceGetAddrInfo(context) do begin if aErrorCode <> kDNSServiceErr_NoError then begin FErrorCode := aErrorCode; if Assigned(OnError) then OnError(TRODNSServiceGetAddrInfo(context),aErrorCode) end else begin FIP_block:=FIP_block; end; end; end; end; function TRODNSServiceGetAddrInfo.BlockGetAddrInfo(const seconds: integer; var aIP: String): DNSServiceErrorType; var lUTF8_HostName: AnsiString; fCallback: TDNSServiceGetAddrInfoReply; begin Stop(); fCallback := intGetAddrInfoReply_block; FIP_block:= ''; lUTF8_HostName:= UTF8Encode(lUTF8_HostName); FErrorCode := DNSServiceGetAddrInfo(sdRef,flags, interfaceIndex,kDNSServiceProtocol_IPv4 or kDNSServiceProtocol_IPv6,PAnsiChar(lUTF8_HostName),fCallback,self); try if (FErrorCode = kDNSServiceErr_NoError) then begin if (not BlockWatchSocket(seconds) ) then begin FErrorCode:=kDNSServiceErr_Timeout; end else begin aIP := FIP_block; end; end; finally inherited Stop(); if FErrorCode <> kDNSServiceErr_NoError then aIP := ''; Result := FErrorCode; end; end; constructor TRODNSServiceGetAddrInfo.Create(const aHostName: Unicodestring); begin inherited Create; FHostName := AHostName; end; procedure intGetAddrInfoReply(const sdRef: pointer;const flags: Cardinal;const interfaceIndex: Cardinal; const aErrorCode: DNSServiceErrorType; const HostName: PAnsiChar; const address: Pointer; ttl: cardinal;const context: Pointer);{$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; begin if Assigned(context) then begin with TRODNSServiceGetAddrInfo(context) do begin if aErrorCode <> kDNSServiceErr_NoError then begin FErrorCode := aErrorCode; if Assigned(OnError) then OnError(TRODNSServiceGetAddrInfo(context),aErrorCode) end else begin // FIP_block:=FIP_block; // don't implemented yet end; end; end; end; procedure TRODNSServiceGetAddrInfo.GetAddrInfo; var lUTF8_HostName: AnsiString; fCallback: TDNSServiceGetAddrInfoReply; begin Fcallback := intGetAddrInfoReply; lUTF8_HostName:= UTF8Encode(lUTF8_HostName); FErrorCode := DNSServiceGetAddrInfo(sdRef,flags, interfaceIndex,kDNSServiceProtocol_IPv4 or kDNSServiceProtocol_IPv6,PAnsiChar(lUTF8_HostName),fCallback,self); end; {$ENDIF NO_DNSServiceGetAddrInfo} {$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP} initialization LoadLibraries; finalization UnloadLibraries; end.