http://github.com/dongola7/tcl_bonjour/

http://www.tibco.com/software/enterprise_backbone/rendezvous.jsp

/*
 Copyright (c) 2004, Blair Kitchen All rights reserved.

 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

 Redistributions of source code must retain the above copyright notice, this
 list of conditions and the following disclaimer. Redistributions in binary
 form must reproduce the above copyright notice, this list of conditions and
 the following disclaimer in the documentation and/or other materials
 provided with the distribution. Neither the name of Blair Kitchen nor
 the names of its contributors may be used to endorse or promote products
 derived from this software without specific prior written permission. 
 
 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 
 ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
 ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
 DAMAGE.
 */

/*
 *  A Tcl package to allow access to rendezvous functionality
 *
 *  Author: Blair Kitchen <blair_kitchen@yahoo.com>
 */
 
/*
 * TODO:
 *  - Keep track of the active_resolve structures so that
 *    they can be deallocated in the event of a call to
 *    rendezvous_cleanup.  (If the program exits in the
 *    middle of a resolution, for example.)
 *  - Fix handling of protocol errors returned by rendezvous
 *    in the Tcl_BackgroundError function calls.  More
 *    descriptive error messages are necessary.
 */

#include <string.h>

#include <tcl.h>
#include <dns_sd.h>

#define PACKAGE_NAME "rendezvous"
#define PACKAGE_VERSION "0.1"

////////////////////////////////////////////////////
// structure declarations
////////////////////////////////////////////////////

// information on a browse operation currently in
// progress
typedef struct {
   DNSServiceRef sdRef; // the service discovery reference
   char *regtype;       // the regtype being discovered
   Tcl_Obj *callback;   // the callback script
   Tcl_Interp *interp;  // interpreter in which to execute the
                        // callback
} active_browse;

// information on a resolve currently in progress
typedef struct {
   DNSServiceRef sdRef; // the service discovery reference
   Tcl_Obj *callback;   // the callback script
   Tcl_Interp *interp;  // interpreter in which to execute the
                        // callback
} active_resolve;

////////////////////////////////////////////////////
// prototype declarations
////////////////////////////////////////////////////

// misc. cleanup routines
int rendezvous_cleanup(
   ClientData clientData
);

// generic routines
void rendezvous_tcl_callback(
   ClientData clientData,
   int mask
);

// functions to support browsing of rendezvous services
int rendezvous_browse(
   ClientData clientData,
   Tcl_Interp *interp,
   int objc,
   Tcl_Obj *const objv[]
);
int rendezvous_browse_start(
   Tcl_Interp *interp,
   const char *const regtype,
   Tcl_Obj *const callbackScript,
   Tcl_HashTable *browseRegistrations
);
int rendezvous_browse_stop(
   Tcl_Interp *interp,
   const char *const regtype,
   Tcl_HashTable *browseRegistrations
);
void rendezvous_browse_callback(
   DNSServiceRef sdRef,
   DNSServiceFlags flags,
   uint32_t interfaceIndex,
   DNSServiceErrorType errorCode,
   const char *const serviceName,
   const char *const replyType,
   const char *const replyDomain,
   void *context
);

// functions to support resolving rendezvous service names
int rendezvous_resolve(
   ClientData clientData,
   Tcl_Interp *interp,
   int objc,
   Tcl_Obj *const objv[]
);
void rendezvous_resolve_tcl_callback(
   ClientData clientData,
   int mask
);
void rendezvous_resolve_callback(
   DNSServiceRef sdRef,
   DNSServiceFlags flags,
   uint32_t interfaceIndex,
   DNSServiceErrorType errorCode,
   const char *fullname,
   const char *hosttarget,
   uint16_t port,
   uint16_t txtLen,
   const char *txtRecord,
   void *context
);

////////////////////////////////////////////////////
// variable declaration
////////////////////////////////////////////////////

// stores active_browse structures hashed on the
// regtype being browsed
static Tcl_HashTable browseRegistrations;


////////////////////////////////////////////////////
// initialize the package
////////////////////////////////////////////////////
int Rendezvous_Init(
   Tcl_Interp *interp
) {
   // Initialize the stubs library
   if(Tcl_InitStubs(interp, "8.4", 0) == NULL) {
      return(TCL_ERROR);
   }

   // Tell Tcl what package we're providing
   Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION);

   // initialize the browseRegistrations hash table
   Tcl_InitHashTable(&browseRegistrations, TCL_STRING_KEYS);

   // Register our commands
   Tcl_CreateObjCommand(
      interp, "::rendezvous::browse", rendezvous_browse, 
      &browseRegistrations, NULL
   );
   Tcl_CreateObjCommand(
      interp, "::rendezvous::resolve", rendezvous_resolve,
      NULL, NULL
   );

   // create an exit handler for cleanup
   Tcl_CreateExitHandler(
      (Tcl_ExitProc *)rendezvous_cleanup,
      &browseRegistrations
   );

   return(TCL_OK);
}

////////////////////////////////////////////////////
// cleanup any leftover connections
////////////////////////////////////////////////////
int rendezvous_cleanup(
   ClientData clientData
) {
   Tcl_HashTable *browseRegistrations = NULL;
   Tcl_HashEntry *hashEntry = NULL;
   Tcl_HashSearch searchToken;
   active_browse *activeBrowse = NULL;

   browseRegistrations = (Tcl_HashTable *)clientData;

   // run through the remaning entries in the hash table
   for(hashEntry = Tcl_FirstHashEntry(browseRegistrations,
                                      &searchToken);
       hashEntry != NULL;
       hashEntry = Tcl_NextHashEntry(&searchToken)) {

      activeBrowse = (active_browse *)Tcl_GetHashValue(hashEntry);

      // remove the file handler
      Tcl_DeleteFileHandler(DNSServiceRefSockFD(activeBrowse->sdRef));

      // deallocate the browse service reference
      DNSServiceRefDeallocate(activeBrowse->sdRef);

      // clean up the memory used by activeBrowse
      ckfree(activeBrowse->regtype);
      ckfree((void *)activeBrowse);

      // let Tcl know the callback object is no longer
      // in use
      Tcl_DecrRefCount(activeBrowse->callback);

      // deallocate the hash entry
      Tcl_DeleteHashEntry(hashEntry);
   } // end loop over hash entries

   Tcl_DeleteHashTable(browseRegistrations);

   return(TCL_OK);
}

////////////////////////////////////////////////////
// called by the Tcl event loop when there is data
// on the socket used by the DNS service reference
////////////////////////////////////////////////////
void rendezvous_tcl_callback(
   ClientData clientData,
   int mask
) {
   DNSServiceRef sdRef = (DNSServiceRef)clientData;

   // process the incoming data
   DNSServiceProcessResult(sdRef);
}

////////////////////////////////////////////////////
// ::rendezvous::browse command
////////////////////////////////////////////////////
int rendezvous_browse(
   ClientData clientData,
   Tcl_Interp *interp,
   int objc,
   Tcl_Obj *const objv[]
) {
   char *subcommands[] = {
      "start", "stop", NULL
   };
   const char *regtype = NULL;
   int result = TCL_OK;
   int cmdIndex;
   Tcl_HashTable *browseRegistrations;

   browseRegistrations = (Tcl_HashTable *)clientData;

   if(objc < 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "<sub-command> <args>");
      return(TCL_ERROR);
   }

   if(Tcl_GetIndexFromObj(
         interp, objv[1], (const char **)subcommands, 
         "subcommand", 0, &cmdIndex
      ) != TCL_OK) {
      return(TCL_ERROR);
   }

   switch(cmdIndex) {
   case 0: // start
      if(objc != 4) {
         Tcl_WrongNumArgs(interp, 2, objv, "<regtype> <callback>");
         return(TCL_ERROR);
      }

      regtype = Tcl_GetString(objv[2]);
      result = 
         rendezvous_browse_start(
            interp, regtype, objv[3], browseRegistrations
         );
         
      return(result);
      break;
   case 1: // stop
      if(objc != 3) {
         Tcl_WrongNumArgs(interp, 2, objv, "<regtype>");
         return(TCL_ERROR);
      }

      regtype = Tcl_GetString(objv[2]);
      result = 
         rendezvous_browse_stop(interp, regtype, browseRegistrations);
      break;
   default:
      Tcl_SetResult(interp, "Unknown option", TCL_STATIC);
      result = TCL_ERROR;
   } // end switch(cmdIndex)

   return(result);
}

////////////////////////////////////////////////////
// start browsing for a service type
////////////////////////////////////////////////////
int rendezvous_browse_start(
   Tcl_Interp *interp,
   const char *const regtype,
   Tcl_Obj *const callbackScript,
   Tcl_HashTable *browseRegistrations
) {
   active_browse *activeBrowse = NULL;
   Tcl_HashEntry *hashEntry = NULL;
   int newFlag;

   // attempt to create an entry in the hash table
   // for this regtype
   hashEntry = 
      Tcl_CreateHashEntry(browseRegistrations, regtype, &newFlag);
   // if an entry already exists, return an error
   if(!newFlag) {
      Tcl_Obj *errorMsg = Tcl_NewStringObj(NULL, 0);
      Tcl_AppendStringsToObj(
         errorMsg, "regtype ", regtype, " is already being browsed", NULL);
      Tcl_SetObjResult(interp, errorMsg);
      return(TCL_ERROR);
   }

   // allocate the active_browse structure for this
   // regtype
   activeBrowse = (active_browse *)ckalloc(sizeof(active_browse));
   activeBrowse->regtype = (char *)ckalloc(strlen(regtype) + 1);
   strcpy(activeBrowse->regtype, regtype);
   activeBrowse->callback = callbackScript;
   Tcl_IncrRefCount(activeBrowse->callback);
   activeBrowse->interp = interp;

   // store the active_browse structure in the hash entry
   Tcl_SetHashValue(hashEntry, activeBrowse);

   // call DNSServiceBrowse
   DNSServiceBrowse(
      &activeBrowse->sdRef,
      0, 0, regtype, NULL,
      rendezvous_browse_callback,
      activeBrowse);

   // retrieve the socket being used for the browse operation
   // and register a file handler so that we know when
   // there is data to be read
   Tcl_CreateFileHandler(
      DNSServiceRefSockFD(activeBrowse->sdRef),
      TCL_READABLE,
      rendezvous_tcl_callback,
      activeBrowse->sdRef);

   return(TCL_OK);
}

////////////////////////////////////////////////////
// stop browsing for a service type
////////////////////////////////////////////////////
int rendezvous_browse_stop(
   Tcl_Interp *interp,
   const char *const regtype,
   Tcl_HashTable *browseRegistrations
) {
   active_browse *activeBrowse = NULL;
   Tcl_HashEntry *hashEntry = NULL;
   
   // retrieve the hash entry for this regtype
   // from the hash table
   hashEntry = Tcl_FindHashEntry(browseRegistrations, regtype);

   // if a valid hash entry was found, clean it up
   if(hashEntry) {
      activeBrowse = (active_browse *)Tcl_GetHashValue(hashEntry);

      // remove the file handler
      Tcl_DeleteFileHandler(DNSServiceRefSockFD(activeBrowse->sdRef));

      // deallocate the browse service reference
      DNSServiceRefDeallocate(activeBrowse->sdRef);

      // clean up the memory used by activeBrowse
      ckfree(activeBrowse->regtype);
      ckfree((void *)activeBrowse);

      // let Tcl know the callback object is no longer
      // in use
      Tcl_DecrRefCount(activeBrowse->callback);

      // deallocate the hash entry
      Tcl_DeleteHashEntry(hashEntry);
   }

   return(TCL_OK);
}

////////////////////////////////////////////////////
// called when a service browse result is received.
// executes the appropriate Tcl callback to let
// the application know what has happened
////////////////////////////////////////////////////
void rendezvous_browse_callback(
   DNSServiceRef sdRef,
   DNSServiceFlags flags,
   uint32_t interfaceIndex,
   DNSServiceErrorType errorCode,
   const char *const serviceName,
   const char *const replyType,
   const char *const replyDomain,
   void *context
) {
   active_browse *activeBrowse = NULL;
   Tcl_Obj *callback;
   int result;

   activeBrowse = (active_browse *)context;

   // begin creating the callback as a list
   callback = Tcl_NewListObj(0, NULL);
   Tcl_ListObjAppendList(NULL, callback, activeBrowse->callback);

   if(errorCode == kDNSServiceErr_NoError) {
      // determine whether a service is being
      // added or removed
      if(flags & kDNSServiceFlagsAdd) {
         Tcl_ListObjAppendElement(
            activeBrowse->interp,
            callback,
            Tcl_NewStringObj("add", 3));
      }
      else {
         Tcl_ListObjAppendElement(
            activeBrowse->interp,
            callback,
            Tcl_NewStringObj("remove", 6));
      }

      // append the service name and domain
      Tcl_ListObjAppendElement(
         activeBrowse->interp,
         callback,
         Tcl_NewStringObj(serviceName, -1));
      Tcl_ListObjAppendElement(
         activeBrowse->interp,
         callback,
         Tcl_NewStringObj(replyDomain, -1));

      // evaluate the callback
      result = Tcl_GlobalEvalObj(activeBrowse->interp, callback);
   } // end if no error
   else {
      // store an appropriate error message in the interpreter
      Tcl_SetResult(
         activeBrowse->interp,
         "Rendezvous returned an error",
         TCL_STATIC);
      result = TCL_ERROR;
   }

   if(result == TCL_ERROR) {
      Tcl_BackgroundError(activeBrowse->interp);
   }
}

////////////////////////////////////////////////////
// ::rendezvous::resolve command
////////////////////////////////////////////////////
int rendezvous_resolve(
   ClientData clientData,
   Tcl_Interp *interp,
   int objc,
   Tcl_Obj *const objv[]
) {
   const char *hostname = NULL,
              *regtype = NULL,
              *domain = NULL;
   Tcl_Obj *callbackScript = NULL;
   active_resolve *activeResolve = NULL;

   // check for the appropriate number of arguments
   if(objc != 5) {
      Tcl_WrongNumArgs(interp, 1, objv, "<name> <regtype> <domain> <script>");
      return(TCL_ERROR);
   }

   // retrieve the argument values
   hostname = Tcl_GetString(objv[1]);
   regtype = Tcl_GetString(objv[2]);
   domain = Tcl_GetString(objv[3]);
   callbackScript = Tcl_DuplicateObj(objv[4]);

   // increment the reference count on the callback script
   // since we will be holding onto it until the callback
   // is executed
   Tcl_IncrRefCount(callbackScript);

   // create the active_resolve structure
   activeResolve = (active_resolve *)ckalloc(sizeof(active_resolve));
   activeResolve->callback = callbackScript;
   activeResolve->interp = interp;

   // start the resolution
   DNSServiceResolve(
      &activeResolve->sdRef,
      0,
      0,
      hostname,
      regtype,
      domain,
      rendezvous_resolve_callback,
      (void *)activeResolve);

   // retrieve the socket being used for the browse operation
   // and register a file handler so that we know when
   // there is data to be read
   Tcl_CreateFileHandler(
      DNSServiceRefSockFD(activeResolve->sdRef),
      TCL_READABLE,
      rendezvous_tcl_callback,
      activeResolve->sdRef);

   return(TCL_OK);
}

////////////////////////////////////////////////////
// called when a service browse result is received.
// executes the appropriate Tcl callback to let
// the application know what has happened
////////////////////////////////////////////////////
void rendezvous_resolve_callback(
   DNSServiceRef sdRef,
   DNSServiceFlags flags,
   uint32_t interfaceIndex,
   DNSServiceErrorType errorCode,
   const char *fullname,
   const char *hosttarget,
   uint16_t port,
   uint16_t txtLen,
   const char *txtRecord,
   void *context
) {
   active_resolve *activeResolve = (active_resolve *)context;
   Tcl_Obj *txtRecordList = NULL;
   int result;

   if(errorCode == kDNSServiceErr_NoError) {
      // append the service name and domain
      Tcl_ListObjAppendElement(
         activeResolve->interp,
         activeResolve->callback,
         Tcl_NewStringObj(fullname, -1));
      Tcl_ListObjAppendElement(
         activeResolve->interp,
         activeResolve->callback,
         Tcl_NewStringObj(hosttarget, -1));
      Tcl_ListObjAppendElement(
         activeResolve->interp,
         activeResolve->callback,
         Tcl_NewIntObj(port));

      // the text records will be passed as a list
      // of Tcl_ByteArray objects
      txtRecordList = Tcl_NewListObj(0, NULL);
      uint16_t currentByte = 0;
      while(currentByte < txtLen) {
         uint16_t currentLen = (uint16_t)txtRecord[currentByte++];
         Tcl_ListObjAppendElement(
            activeResolve->interp,
            txtRecordList,
            Tcl_NewByteArrayObj(&txtRecord[currentByte], currentLen));
         currentByte += currentLen;
      }
      Tcl_ListObjAppendElement(
         activeResolve->interp,
         activeResolve->callback,
         txtRecordList);

      // evaluate the callback
      result = Tcl_GlobalEvalObj(activeResolve->interp, 
                                 activeResolve->callback);
   } // end if no error
   else {
      // store an appropriate error message in the
      // interpreter
      Tcl_SetResult(
         activeResolve->interp,
         "Rendezvous returned an error", 
         TCL_STATIC);
      result = TCL_ERROR;
   }

   if(result == TCL_ERROR) {
      Tcl_BackgroundError(activeResolve->interp);
   }

   // the callback is no longer being used, so decrement the
   // reference count
   Tcl_DecrRefCount(activeResolve->callback);

   // deallocate the browse service reference
   DNSServiceRefDeallocate(activeResolve->sdRef);

   // deallocate the active_resolve structure
   ckfree((void *)activeResolve);
}

lappend auto_path .

package require rendezvous 0.1

proc browse_callback {regtype action service domain} {
   puts "browse $action $regtype $service $domain"
   ::rendezvous::resolve $service $regtype $domain resolve_callback
} 

proc resolve_callback {fullname hosttarget port txtRecords} {
   puts "resolve $fullname $hosttarget $port"
   foreach txtRecord $txtRecords {
      puts "\t$txtRecord"
   }
}

after 100000 [list set runFlag false]

set serviceTypes {
   _http._tcp
   _ssh._tcp
   _mysql._tcp
   _daap._tcp
   _ipp._tcp
   _presence._tcp
}

foreach serviceType $serviceTypes {
   ::rendezvous::browse start $serviceType \
      [list browse_callback $serviceType]
}

vwait runFlag

foreach serviceType $serviceTypes {
   ::rendezvous::browse stop $serviceType
}

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References