ipMoreC.tcl at tip

File vendor/tcl-packages/dns/ipMoreC.tcl from the latest check-in


# Skip this for window and a specific version of Solaris
# 
# This could do with an explanation -- why are we avoiding these platforms
# and perhaps using critcl's platform::platform command might be better?
#
if {[string equal $::tcl_platform(platform) windows] ||
    ([string equal $::tcl_platform(os)      SunOS] &&
     [string equal $::tcl_platform(osVersion) 5.6])
} {
    # avoid warnings about nothing to compile
    critcl::ccode {
        /* nothing to do */
    }
    return
}

package require critcl;

namespace eval ::ip {

critcl::ccode {
#include <stdlib.h>
#include <stdio.h>
#include <tcl.h>
#include <inttypes.h>
#include <arpa/inet.h>
#include <string.h>
#include <sys/socket.h>
}

critcl::ccommand prefixToNativec {clientData interp objc objv} { 
    int elemLen, maskLen, ipLen, mask;
	int rval,convertListc,i;
	Tcl_Obj **convertListv;
	Tcl_Obj *listPtr,*returnPtr, *addrList;
	char *stringIP, *slashPos, *stringMask;
	char v4HEX[11];
	
	uint32_t inaddr;
	listPtr = NULL;

	/* printf ("\n in prefixToNativeC"); */
	/* printf ("\n objc = %d",objc); */

	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "<ipaddress>/<mask>");
		return TCL_ERROR;
	}


	if (Tcl_ListObjGetElements (interp, objv[1], 
								&convertListc, &convertListv) != TCL_OK) {
		return TCL_ERROR;
	}
	returnPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	for (i = 0; i < convertListc; i++) {
		/*  need to create a duplicate here because when we modify */
		/*  the stringIP it'll mess up the original in the calling */
		/*  context */
		addrList = Tcl_DuplicateObj(convertListv[i]);
		stringIP = Tcl_GetStringFromObj(addrList, &elemLen);
		listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		/* printf ("\n  ### %s ### string \n", stringIP); */
		/*  split the ip address and mask */
		slashPos = strchr(stringIP, (int) '/');
		if (slashPos == NULL) {
			/*  straight ip address without mask */
			mask = 0xffffffff;
			ipLen = strlen(stringIP);
		} else {
			/* ipaddress has the mask, handle the mask and seperate out the  */
			/*  ip address */
			/* printf ("\n ** %d ",(uintptr_t)slashPos); */
			stringMask = slashPos +1;
			maskLen =strlen(stringMask);
			/* put mask in hex form */
			if (maskLen < 3) {
				mask = atoi(stringMask);
				mask = (0xFFFFFFFF << (32 - mask)) & 0xFFFFFFFF;
			} else {
				/* mask is in dotted form */
				if ((rval = inet_pton(AF_INET,stringMask,&mask)) < 1 ) {
					Tcl_AddErrorInfo(interp, "\n    bad format encountered in mask conversion");
					return TCL_ERROR;	
				}
				mask = htonl(mask);
			}
			ipLen = (uintptr_t)slashPos  - (uintptr_t)stringIP;
			/* divide the string into ip and mask portion */
			*slashPos = '\0';
			/* printf("\n %d %d %d %d", (uintptr_t)stringMask, maskLen, (uintptr_t)stringIP, ipLen); */
		}
		if ( (rval = inet_pton(AF_INET,stringIP,&inaddr)) < 1) {
			Tcl_AddErrorInfo(interp, 
							 "\n    bad format encountered in ip conversion");
			return TCL_ERROR;
		};
		inaddr = htonl(inaddr);
		/* apply the mask the to the ip portion, just to make sure  */
		/*  what we return is cleaned up */
		inaddr = inaddr & mask;
		sprintf(v4HEX,"0x%08X",inaddr);
		/* printf ("\n\n ### %s",v4HEX); */
		Tcl_ListObjAppendElement(interp, listPtr,
								 Tcl_NewStringObj(v4HEX,-1));
		sprintf(v4HEX,"0x%08X",mask);
		Tcl_ListObjAppendElement(interp, listPtr,
								 Tcl_NewStringObj(v4HEX,-1));
		Tcl_ListObjAppendElement(interp, returnPtr, listPtr);
		Tcl_DecrRefCount(addrList);
	}
	
	if (convertListc==1) {
		Tcl_SetObjResult(interp,listPtr);
	} else {
		Tcl_SetObjResult(interp,returnPtr);
	}
	
	return TCL_OK;
}

critcl::ccommand isOverlapNativec {clientData interp objc objv} {
        int i; 
        unsigned int ipaddr,ipMask, mask1mask2;
        unsigned int ipaddr2,ipMask2;
        int compareListc,comparePrefixMaskc;
        int allSet,inlineSet,index;
        Tcl_Obj **compareListv,**comparePrefixMaskv, *listPtr;
        Tcl_Obj *result;
    static CONST char *options[] = {
                "-all",     "-inline", "-ipv4", NULL
    };
    enum options {
		OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4
    };

        allSet = 0;
        inlineSet = 0;
        listPtr = NULL;

        /* printf ("\n objc = %d",objc); */
        if (objc < 3) {
                Tcl_WrongNumArgs(interp, 1, objv, "?options? <hexIP> <hexMask> <hexList>");
                return TCL_ERROR;
        }
        for (i = 1; i < objc-3; i++) {
           if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
                   != TCL_OK) {
                   return TCL_ERROR;
           }
           switch (index) {
           case OVERLAP_ALL:
                   allSet = 1;
                   /* printf ("\n all selected"); */
                   break;
           case OVERLAP_INLINE:
                   inlineSet = 1;
                   /* printf ("\n inline selected"); */
                   break;
		   case OVERLAP_IPV4:
			   break;
           }
        }
        /* options are parsed */

        /* create return obj */
        result = Tcl_GetObjResult (interp);

        /* set ipaddr and ipmask */
        Tcl_GetIntFromObj(interp,objv[objc-3],(int*)&ipaddr);
        Tcl_GetIntFromObj(interp,objv[objc-2],(int*)&ipMask);

        /* split the 3rd argument into <ipaddr> <mask> pairs */
        if (Tcl_ListObjGetElements (interp, objv[objc-1], &compareListc, &compareListv) != TCL_OK) {
                return TCL_ERROR;
        }
/*       printf("comparing %x/%x \n",ipaddr,ipMask); */

        if (allSet || inlineSet) {
                listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
        }

        for (i = 0; i < compareListc; i++) {
					    /* split the ipaddr2 and ipmask2  */
                if (Tcl_ListObjGetElements (interp, 
					    compareListv[i], 
					    &comparePrefixMaskc, 
					    &comparePrefixMaskv) != TCL_OK) {
		    return TCL_ERROR;
                }
                if (comparePrefixMaskc != 2) {
		    Tcl_AddErrorInfo(interp,"need format {{<ipaddr> <mask>} {<ipad..}}");
                        return TCL_ERROR;
                }
                Tcl_GetIntFromObj(interp,comparePrefixMaskv[0],(int*)&ipaddr2);
                Tcl_GetIntFromObj(interp,comparePrefixMaskv[1],(int*)&ipMask2);
/*               printf(" with %x/%x \n",ipaddr2,ipMask2); */
                mask1mask2 = ipMask & ipMask2;
/*               printf("  mask1mask2 %x \n",mask1mask2); */
/*               printf("  ipaddr & mask1mask2  %x\n",ipaddr & mask1mask2); */
/*               printf("  ipaddr2 & mask1mask2 %x\n",ipaddr2 & mask1mask2); */
                if ((ipaddr & mask1mask2) == (ipaddr2 & mask1mask2)) {
		    if (allSet) {
			if (inlineSet) {
			    Tcl_ListObjAppendElement(interp, listPtr,
						     compareListv[i]);
			} else {
			    /* printf("\n appending %d",i+1); */
			    Tcl_ListObjAppendElement(interp, listPtr,
						     Tcl_NewIntObj(i+1));
			};
		    } else {
			if (inlineSet) {
			    Tcl_ListObjAppendElement(interp, listPtr,
						     compareListv[i]);
			    Tcl_SetObjResult(interp,listPtr);
			} else {
			    Tcl_SetIntObj (result, i+1);
			}
			return TCL_OK;
		    };
                };
					};

        if (allSet || inlineSet) {
                Tcl_SetObjResult(interp, listPtr);
                return TCL_OK;
        } else {
                Tcl_SetIntObj (result, 0);
                return TCL_OK;
        }
        return TCL_OK;



}


}

# @sak notprovided ipMorec
package provide ipMorec 1.0