Archivado/Componentes.Terceros.RemObjects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
e3a5cfc500
Componentes.Terceros.RemObj.../internal/6.0.43.801/1/RemObjects SDK for Delphi/Source/uROmDNS.pas
david 2a98435b14 Importación inicial 
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@68 b6239004-a887-0f4b-9937-50029ccdca16
2010-01-29 16:17:43 +00:00

1585 lines
60 KiB
ObjectPascal
Raw Blame History

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.
Reference in New Issue View Git Blame Copy Permalink