diff options
Diffstat (limited to 'tcllib/modules/dns')
| -rw-r--r-- | tcllib/modules/dns/ChangeLog | 385 | ||||
| -rw-r--r-- | tcllib/modules/dns/dns-url.txt | 728 | ||||
| -rw-r--r-- | tcllib/modules/dns/dns.tcl | 1416 | ||||
| -rw-r--r-- | tcllib/modules/dns/dns.test | 73 | ||||
| -rw-r--r-- | tcllib/modules/dns/ip.tcl | 553 | ||||
| -rw-r--r-- | tcllib/modules/dns/ip.test | 271 | ||||
| -rw-r--r-- | tcllib/modules/dns/ipMore.tcl | 1295 | ||||
| -rw-r--r-- | tcllib/modules/dns/ipMore.test | 803 | ||||
| -rw-r--r-- | tcllib/modules/dns/ipMoreC.tcl | 242 | ||||
| -rw-r--r-- | tcllib/modules/dns/msgs/en.msg | 8 | ||||
| -rw-r--r-- | tcllib/modules/dns/pkgIndex.tcl | 9 | ||||
| -rw-r--r-- | tcllib/modules/dns/resolv.tcl | 249 | ||||
| -rw-r--r-- | tcllib/modules/dns/spf.tcl | 528 | ||||
| -rw-r--r-- | tcllib/modules/dns/spf.test | 244 | ||||
| -rw-r--r-- | tcllib/modules/dns/tcllib_dns.man | 242 | ||||
| -rw-r--r-- | tcllib/modules/dns/tcllib_ip.man | 451 |
16 files changed, 7497 insertions, 0 deletions
diff --git a/tcllib/modules/dns/ChangeLog b/tcllib/modules/dns/ChangeLog new file mode 100644 index 0000000..01f57c0 --- /dev/null +++ b/tcllib/modules/dns/ChangeLog @@ -0,0 +1,385 @@ +2013-07-26 Andreas Kupries <andreask@activestate.com> + + * ip.tcl: [AS Bug 99728]: Fixed version mismatch code vs package + index. Bug introduced by last change, below. + +2013-03-25 Andreas Kupries <andreask@activestate.com> + + * ip.tcl: [Bug 3608943] Check ip::version for empty input and + * ip.test: react properly. Extended testsuite. Bumped version + * pkgIndex.tcl: to 1.2.1. + * tcllib_ip.man: + +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2010-08-16 Andreas Kupries <andreask@activestate.com> + + * ip.tcl: Added new commands 'collapse' and 'subtract' for + * ip.test: more 'arithmetic' on network ranges. Extended + * pkgIndex.tcl: documentation and testsuite. Version bumped + * tcllib_ip.man: to 1.2. Base code by Roy Keene, with thanks. + +2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-04-13 Andreas Kupries <andreask@activestate.com> + + * ip.tcl (::ip::IPv4?, ::ip::version): Corrected check for colons + * tcllib_ip.man: (wrong order of arguments), and moved this check, + * pkgIndex.tcl: a speed optimization from the look of it, into the + main IPv4 test to be used everywhere. Bumped the package version + to 1.1.3. Fixes [Bug 2123397]. + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-11-22 Michael Schlenker <mic42@users.sourceforge.net> + + * dns.tcl: Fixed typo in flags for errorcode decoding + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-03-14 Andreas Kupries <andreask@activestate.com> + + * spf.tcl (::spf::_exists): Fixed bad use of 'return', reported in + * pkgIndex.tcl: [SF Tcllib Bug 1826418], by Erik Leunissen. Bumped + to version 1.1.1. + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-08-26 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Applied patch #1610330 from Sergei Golovan to provide + asynchronous connection for dns over tcp. + +2007-08-25 Pat Thoyts <patthoyts@users.sourceforge.net> + + * tcllib_dns.man: Documented the -loglevel configure option. + +2007-08-22 Andreas Kupries <andreask@activestate.com> + + * spf.test: Added proper requisites to the testsuite. + +2007-08-20 Andreas Kupries <andreask@activestate.com> + + * tcllib_ip.man: Bumped version to 1.1.2 due to the bugfix made + * ip.tcl: by the last change. + * pkgIndex.tcl: + +2007-07-05 Pat Thoyts <patthoyts@users.sourceforge.net> + + * ip.tcl: bug #1739359 - reject domain names that look like + * ip.test: ipv4 addresses + +2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tcllib_ip.man: Fixed all warnings due to use of now deprecated + * tcllib_dns.man: commands. Added a section about how to give feedback. + +2006-11-04 Pat Thoyts <patthoyts@users.sourceforge.net> + + * ipMoreC.tcl: Silence critcl warning. + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-09-19 Andreas Kupries <andreask@activestate.com> + + * tcllib_ip.man: Bumped version to 1.1.1 + * ip.tcl: + * pkgIndex.tcl: + +2006-05-05 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Extended the nameservers command to work on Win9x + systems and we now make use of this to initially configure a + default nameserver. Some minor additional cleanup. + +2006-04-21 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Fixed bug #1158037. We were using the query id to + locate the DNS state token but this restricts us to 65535 queries + as the value is packed into a short. + +2006-04-20 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Applied patch from #1453327 by Segei Golovan to improve + support for TXT records. + +2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * spf.test: Fixed use of duplicate test names. + +2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dns.test: More boilerplate simplified via use of test support. + * ip.test: + * ipMore.test: + * spf.test: + +2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dns.test: Hooked into the new common test support code. + * ip.test: + * ipMore.test: + * spf.test + +2005-10-21 Andreas Kupries <andreask@activestate.com> + + * ipMore.tcl: Style cleanup. We need only one $Id expansion at + the top of the file, not for every command in it. + +2005-10-18 Andreas Kupries <andreask@activestate.com> + + * ipMore.tcl (::ip::maskToInt): Fixed [SF Tcllib Bug 1323146], + using the patch supplied by Mikhail Teterin + <kot@users.sf.net>. One path through the code did not mask the + data down to 32bit. + +2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-10-04 Andreas Kupries <andreask@activestate.com> + + * ipMoreC.tcl: disabling the new critcl parts of ip for the + platforms it is known to not work for. A better solution will be + worked on after the release. + +2005-09-30 Andreas Kupries <andreask@activestate.com> + + * ipMore.test: Integrated Aamer Akhter's extended + * ipMore.tcl: conversion and manipulation commands + * ipMoreC.tcl: for ip-addresses and -masks. See the + * msmgs/en.msg: [SF Tcllib Patch 1260196]. Extended the + * ip.man: documentation, testsuite, critcl setup. + +2005-05-21 Pat Thoyts <pat@zsplat.freeserve.co.uk> + + * dns.tcl: Added support for ceptcl as well as tcludp for udp + support. + +2005-05-06 Pat Thoyts <patthoyts@users.sourceforge.net> + + * ip.tcl: Added some support for acceping RFC3056 6to4 addresses + * ip.test: of the form 2002:<ipv4 address>::/48 + +2005-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dns.tcl (TcpEvent): Fixed [SF Tcllib Bug 1173444]. The cause was + a series of typos, the procedure argument 'token' was referenced + to in the code via 'tok'. + +2004-11-21 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Fixed bug in ReadUShort. + + * dns.tcl: Incremented the version to 1.2.1 and updated the + * ip.tcl: manual. + + * dns.tcl: Added support for RFC2782 (DNS SRV) which provides + for service discovery via DNS. + Added dns::nameservers command to return the list + of nameservers configured -- this is not + necessarily all that reliable but should be useful. + Implemented for Windows and Unix. + + * ip.tcl: Added an error message to deal with invalid address + formats during normalization. + +2004-11-06 Pat Thoyts <patthoyts@users.sourceforge.net> + + * ip.tcl: Bug #1060460 - support for IPv4 in IPv6-style + addresses in ip::normalize. + +2004-10-19 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Applied fix for bug #1018934 "incorrectly + detecting query as a reverse lookup" + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-07-31 Pat Thoyts <patthoyts@users.sourceforge.net> + + * spf.test: Added lots of macro tests and fixed some bugs + * spf.tcl: that this revealed. + +2004-07-30 Pat Thoyts <patthoyts@users.sourceforge.net> + + * spf.tcl: Updated to draft-ietf-marid-protocol-00 document. + * spf.test: Fully implements section 7 macro expansion. + +2004-07-23 Pat Thoyts <patthoyts@users.sourceforge.net> + + * spf.tcl: Use ip package and implemented IPv6 type. + + * dns.tcl: Added support for IPv6 lookups (type AAAA). + + * ip.tcl: NEW: IP address package + * ip.test: tests (ipv4 and ipv6) + * tcllib_ip.man: Manual page + +2004-06-01 Pat Thoyts <patthoyts@users.sourceforge.net> + + * spf.tcl: NEW: Implementation of SPF using our dns package. + * spf.test: NEW: tests for SPF package. + * pkgIndex.tcl: Updated to include SPF. + + * dns-url.txt: Updated the dns-url document to -09 version. This + implementation is still valid so no changes to the uri code. + +2004-05-26 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Fix issue setting the log level properly. + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2004-01-22 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Added automatic recognition of reverse lookups (where + query is 1.2.3.4). These are converted to in-addr.arpa lookups. + Added a dns::result to return the whole decoded answer record. + Added SPF record type (an alias for TXT). + Incremented package version to 1.0.5 + +2003-07-09 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Added decoding for SOA response records. + +2003-05-09 Andreas Kupries <andreask@activestate.com> + + * resolv.tcl (::resolv::init): Added missing [expr] bracing. + +2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-04-14 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Added error message to the timeout. + * resolv.tcl: incorporated some of Emmanuel's updated code. + +2003-04-12 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.man: *Renamed* to tcllib_dns.man to avoid a name clash with + the dns manpage from the scotty package. + +2003-04-11 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Try to read the whole reply when using tcp. Added a + catch to avoid bgerrors within the handler. + * dns.tcl: + * dns.man: + * pkgIndex.tcl: hiked version to 1.0.4 + +2003-04-11 Andreas Kupries <andreask@pliers.activestate.com> + + * dns.tcl: + * dns.man: + * pkgIndex.tcl: Fixed bug #614591. Set version of the package to + to 1.0.3 throughout. Added package 'resolv' to index. + +2003-03-04 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: converted from the log package to logger. Enable UDP as + the default if available. + +2003-02-27 Pat Thoyts <patthoyts@users.sourceforge.net> + + * resolv.tcl: Imported Emmanuel Frecon's code from the Tclers + Wiki. Provides a name cache and simplifies usage of the dns + package. + +2003-02-25 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Tested the UDP transmission using a fixed TclUDP. + * dns.tcl: Implemented inverse queries. (Pretty useless though). + * dns.tcl: Added errorcode procedure. + +2003-01-30 Pat Thoyts <patthoyts@users.sourceforge.net> + + * dns.tcl: Implemented UDP transmission. Currently not tested + because tcludp doesn't handle binary data. + +2003-01-24 Pat Thoyts <patthoyts@users.sourceforge.net> + + * pkgIndex.tcl: + * dns.man: Added Tcl 8.2 as minimum Tcl version to resolve bug + * dns.tcl: #674330. Upped version to 1.0.2 + * dns.test: Added some tests for the dns uri handling and fixed a + bug in decoding the class and type section. + +2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dns.man: More semantic markup, less visual one. + +2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dns.tcl: Updated 'info exist' to 'info exists'. + +2002-06-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dns.man: + * dns.tcl: + * pkgIndex.tcl: Version up to 1.0.1 + + * dns.tcl: moved var initialization code to the end, as it uses + the 'dns::configure' command, and thus should be called after + its definition. This is the reason for bug #564670, thus now + fixed. + +2002-06-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dns.man: Added note to manpage regarding DNS via TCP and + possible pitfalls. diff --git a/tcllib/modules/dns/dns-url.txt b/tcllib/modules/dns/dns-url.txt new file mode 100644 index 0000000..bed51f5 --- /dev/null +++ b/tcllib/modules/dns/dns-url.txt @@ -0,0 +1,728 @@ + + +Network Working Group S. Josefsson +Internet-Draft October 26, 2003 +Expires: April 25, 2004 + + + Domain Name System Uniform Resource Identifiers + draft-josefsson-dns-url-09 + +Status of this Memo + + This document is an Internet-Draft and is in full conformance with + all provisions of Section 10 of RFC2026. + + Internet-Drafts are working documents of the Internet Engineering + Task Force (IETF), its areas, and its working groups. Note that other + groups may also distribute working documents as Internet-Drafts. + + Internet-Drafts are draft documents valid for a maximum of six months + and may be updated, replaced, or obsoleted by other documents at any + time. It is inappropriate to use Internet-Drafts as reference + material or to cite them other than as "work in progress." + + The list of current Internet-Drafts can be accessed at http:// + www.ietf.org/ietf/1id-abstracts.txt. + + The list of Internet-Draft Shadow Directories can be accessed at + http://www.ietf.org/shadow.html. + + This Internet-Draft will expire on April 25, 2004. + +Copyright Notice + + Copyright (C) The Internet Society (2003). All Rights Reserved. + +Abstract + + This document define Uniform Resource Identifiers for Domain Name + System resources. + + + + + + + + + + + + + + +Josefsson Expires April 25, 2004 [Page 1] + +Internet-Draft DNS URI October 2003 + + +Table of Contents + + 1. Introduction and Background . . . . . . . . . . . . . . . . . 3 + 2. DNS URI Registration . . . . . . . . . . . . . . . . . . . . . 4 + 3. Examples . . . . . . . . . . . . . . . . . . . . . . . . . . . 7 + 4. Security Considerations . . . . . . . . . . . . . . . . . . . 8 + 5. IANA Considerations . . . . . . . . . . . . . . . . . . . . . 8 + Normative References . . . . . . . . . . . . . . . . . . . . . 9 + Informative References . . . . . . . . . . . . . . . . . . . . 9 + Author's Address . . . . . . . . . . . . . . . . . . . . . . . 10 + A. Revision Changes . . . . . . . . . . . . . . . . . . . . . . . 10 + A.1 Changes since -06 . . . . . . . . . . . . . . . . . . . . . . 10 + A.2 Changes since -07 . . . . . . . . . . . . . . . . . . . . . . 10 + A.3 Changes since -08 . . . . . . . . . . . . . . . . . . . . . . 10 + Intellectual Property and Copyright Statements . . . . . . . . 12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Josefsson Expires April 25, 2004 [Page 2] + +Internet-Draft DNS URI October 2003 + + +1. Introduction and Background + + The Domain Name System (DNS) [1][2] is a widely deployed system used + to, among other things, translate host names into IP addresses. + Recent work has added support for storing certificates and + certificate revocation lists in the DNS [10]. + + The primary motivation behind defining a Uniform Resource Identifier + (URI) for DNS resources, instead of using another non-URI syntax that + embed the domain, type value and class value, is that applications + that stores or retrieve certificates today uses URIs for this + purpose. Thus, defining a URI scheme for DNS resources allows these + existing protocols to be used with certificates in the DNS without + having to add DNS specific modifications to said protocols. In order + to not introduce interoperability or security considerations, + protocols that uses these URIs naturally must have been written to + allow for future, as of writing yet undefined, URIs to be used. + + A few examples of protocols that may utilize DNS URIs: + + o The OpenPGP Message Format [8], where an end-user may indicate the + location of a copy of any updates to her key, using the "preferred + key server" field. + + o The X.509 Online Certificate Status Protocol [11], where the OCSP + responder can indicate where a CRL is found, using the + id-pkix-ocsp-crl extension. + + The DNS URI scheme defined here can, of course, be used to reference + any DNS data, and is not limited to only certificates. The purpose + of this specification is to define a generic DNS URI, not a specific + DNS solution for certificates stored in the DNS. Browsers may + implement support for DNS URIs by forming DNS queries and render DNS + responses using HTML [14], similar to what is done for the FTP [5]. + + The core part of this document is the URI Registration Template + according to [13]. + + The key words "MUST", "MUST NOT", "REQUIRED", "SHALL", "SHALL NOT", + "SHOULD", "SHOULD NOT", "RECOMMENDED", "MAY", and "OPTIONAL" in this + document are to be interpreted as described in RFC 2119 [6]. + + + + + + + + + + +Josefsson Expires April 25, 2004 [Page 3] + +Internet-Draft DNS URI October 2003 + + +2. DNS URI Registration + + URL scheme name: "dns". + + URL scheme syntax: A DNS URI designates a DNS resource record set + that can be referenced by domain name, type, class and optionally the + authority. The DNS URI follows the generic syntax from RFC 2396 [4], + and is described using ABNF [3]. Strings are not case sensitive and + free insertion of linear-white-space is not permitted. + + dnsurl = "dns:" [ "//" dnsauthority "/" ] dnsname ["?" dnsquery] + + dnsauthority = hostport + ; See RFC 2396 for "hostport" definition. + + dnsname = *pchar + ; See RFC 2396 for "pchar" definition. + ; NB! Can be empty. + + dnsquery = dnsqueryelement [";" dnsquery] + ; First matching element MUST be used. + ; E.g., dns:host.example.org?TYPE=A;TYPE=TXT + ; means type A. + + dnsqueryelement = ( "CLASS=" dnsclassval ) / ( "TYPE=" dnstypeval ) / + ( 1*alphanum "=" 1*alphanum ) + + dnsclassval = 1*digit / "IN" / "CH" / ... + ; Any IANA registered DNS class expressed as + ; mnemonic or as decimal integer. + + dnstypeval = 1*digit / "A" / "NS" / "MD" / ... + ; Any IANA registered DNS type expressed as + ; mnemonic or as decimal integer. + + The digit representation of types and classes MAY be used when a + mnemonic for the corresponding value is not well known (e.g., for + newly introduced types or classes), but SHOULD NOT be used for the + types or classes defined in the DNS specification [2]. All + implementations MUST recognize the mnemonics defined in [2]. + + Unless specified in the URI, the authority ("dnsauthority") is + assumed to be locally known, "dnsclassval" to be the Internet class + ("IN"), and "dnstypeval" to be the Address type ("A"). + + To resolve a DNS URI using the DNS protocol [2] a query is formed by + using the dnsname, dnsclassval and dnstypeval from the URI string (or + the previously mentioned default values if some value missing from + + + +Josefsson Expires April 25, 2004 [Page 4] + +Internet-Draft DNS URI October 2003 + + + the string). If authority ("dnsauthority") is given in the URI + string, this indicate the server that should receive the DNS query, + otherwise the default DNS server should receive it. (Note that DNS + URIs could be resolved by other protocols than the DNS protocol. DNS + URIs does not require the use of the DNS protocol, although it is + expected to be the typical usage. This paragraph only illustrate how + DNS URIs are resolved using the DNS protocol.) + + A client MAY want to check that it understands the dnsclassval and + dnstypeval before sending a query, so that it is able to correctly + parse the answer. A typical example of a client that would not need + to check dnsclassval and dnstypeval would be a proxy that just treat + the answer as opaque data. + + Character encoding considerations: The characters are encoded as per + the "URI Generic Syntax" RFC [4]. The DNS protocol do not consider + character sets, it simply transports opaque data. In particular, the + "dnsname" field of the DNS URI is to be considered an + internationalized domain name (IDN) unaware domain name slot, in the + terminology of [16]. (The reason for this is that making these fields + be IDN aware by, e.g., specifying that they are UTF-8 [7] strings, + would require further encoding mechanisms to be able to express all + valid DNS domain names. This is because the DNS allows all octet + sequences to be used as domain labels, so UTF-8 strings do not cover + all possibilities. Instead of defining further encoding mechanisms, + we point applications with internationalization needs at the ASCII + encoding described in [16] which should be satisfactory.) The + considerations for "hostport" are discussed in [4] + + To encode a "." that is part of a DNS label the "escaped" encoding + MUST be used, and a label delimiter MUST be encoded as ".". That is, + the only way to encode a label delimiter is ".", and the only way to + encode a "." as part of label is "%2e". This approach was chosen to + minimize the modifications users will have to do when manually + translating a domain name string into the URI form. + + This URI specification allows all possible domain names to be encoded + (of course following the encoding rules of [4]), however certain + applications may restrict the set of valid characters and care should + be taken so that invalid characters in these contexts does not cause + harm. In particular, host names in the DNS have certain + restrictions. It is up to these application to limit this subset, + this URI scheme places no restrictions. + + Intended usage: Whenever DNS resources are useful to reference by + protocol independent identifiers, often when the data is more + important than the access method. Since software in general has + coped without this so far, it is not anticipated to be implemented + + + +Josefsson Expires April 25, 2004 [Page 5] + +Internet-Draft DNS URI October 2003 + + + widely, nor migrated to by existing systems, but specific solutions + (especially security related) may find this appropriate. + + Applications and/or protocols which use this scheme: Security related + software. It may be of interest to auxilliary DNS related software + too. + + Interoperability considerations: The data referenced by this URI + scheme might be transferred by protocols that are not URI aware (such + as the DNS protocol). This is not anticipated to have any serious + interoperability impact though. + + Interoperability problems may occur if one entity understands a new + DNS type or class mnemonic but another entity do not understand it. + This is an interoperability problem for DNS software in general, + although it is not a major practical problem as the DNS types and + classes are fairly static. To guarantee interoperability + implementations could use integers for all mnemonics not defined in + [2]. + + Interaction with Binary Labels [12], or other extended label types, + has not been analyzed. However, they appear to be infrequently used + in practice. + + Security considerations: See below. + + Contact: simon@josefsson.org + + Author/Change Controller: simon@josefsson.org + + + + + + + + + + + + + + + + + + + + + + +Josefsson Expires April 25, 2004 [Page 6] + +Internet-Draft DNS URI October 2003 + + +3. Examples + + A DNS URI is of the following general form. This is intended to + illustrate, not define, the scheme. + + dns:[//authority/]domain[?type=TYPE;class=CLASS] + + The following illustrate a URI for a resource with the name + "www.example.org", the Internet (IN) class and the Address (A) type: + + dns:www.example.org?class=IN;type=A + + Since the default class is IN, and the default type is A, the same + resource can be identified by a shorter URI: + + dns:www.example.org + + The following illustrate a URI for a resource with the name + "simon.example.org", for the CERT type, in the Internet (IN) class: + + dns:simon.example.org?type=CERT + + The following illustrate a URI for a resource with the name + "ftp.example.org", in the Internet (IN) class and the address (A) + type, but from the DNS authority 192.168.1.1 instead of the default + authority (i.e., when DNS is used, the query is sent to that server): + + dns://192.168.1.1/ftp.example.org?type=A + + The following illustrate a strange, albeit valid, DNS resource. Note + the encoding of "." and 0x00, and the use of a named dnsauthority: + + dns://internal-dns.example.org/*.%3f%20%00%2e%25+?type=TXT + + + + + + + + + + + + + + + + + + +Josefsson Expires April 25, 2004 [Page 7] + +Internet-Draft DNS URI October 2003 + + +4. Security Considerations + + If a DNS URI references domains in the Internet DNS environment, both + the URI itself and the information referenced by the URI is public + information. If a DNS URI is used within an "internal" DNS + environment, both the DNS URI and the data is referenced should be + handled using the same considerations that apply to DNS data in the + environment. + + If information referenced by DNS URIs are used to make security + decisions (examples of such data include, but is not limited to, + certificates stored in the DNS), implementations may need to employ + security techniques such as Secure DNS [9], or even CMS [15] or + OpenPGP [8], to protect the data during transport. How to implement + this will depend on the usage scenario, and it is not up to this URI + scheme to define how the data referenced by DNS URIs should be + protected. + + If applications accept unknown dnsqueryelement values (e.g., accepts + the URI "dns:www.example.org?secret=value" without knowing what the + "secret=value" dnsqueryelement means), a covert channel used to + "leak" information may be enabled. The implications of covert + channels should be understood by applications that accepts unknown + dnsqueryelement values. + + This draft does not modify the security considerations related to the + DNS or URIs in general. + +5. IANA Considerations + + The IANA is asked to register the DNS URI scheme, using the template + in section 2, in accordance with RFC 2717 [13]. + + + + + + + + + + + + + + + + + + + +Josefsson Expires April 25, 2004 [Page 8] + +Internet-Draft DNS URI October 2003 + + +Acknowledgments + + Thanks to Stuart Cheshire, Donald Eastlake, Pasi Eronen, Ted Hardie, + Peter Koch, Andrew Main, Larry Masinter, Michael Mealling, Steve + Mattson, and Paul Vixie for comments and suggestions. The author + acknowledges the RSA Laboratories for supporting the work that led to + this document. + +Normative References + + [1] Mockapetris, P., "Domain names - concepts and facilities", STD + 13, RFC 1034, November 1987. + + [2] Mockapetris, P., "Domain names - implementation and + specification", STD 13, RFC 1035, November 1987. + + [3] Crocker, D. and P. Overell, "Augmented BNF for Syntax + Specifications: ABNF", RFC 2234, November 1997. + + [4] Berners-Lee, T., Fielding, R. and L. Masinter, "Uniform Resource + Identifiers (URI): Generic Syntax", RFC 2396, August 1998. + +Informative References + + [5] Postel, J. and J. Reynolds, "File Transfer Protocol", STD 9, + RFC 959, October 1985. + + [6] Bradner, S., "Key words for use in RFCs to Indicate Requirement + Levels", BCP 14, RFC 2119, March 1997. + + [7] Yergeau, F., "UTF-8, a transformation format of ISO 10646", RFC + 2279, January 1998. + + [8] Callas, J., Donnerhacke, L., Finney, H. and R. Thayer, "OpenPGP + Message Format", RFC 2440, November 1998. + + [9] Eastlake, D., "Domain Name System Security Extensions", RFC + 2535, March 1999. + + [10] Eastlake, D. and O. Gudmundsson, "Storing Certificates in the + Domain Name System (DNS)", RFC 2538, March 1999. + + [11] Myers, M., Ankney, R., Malpani, A., Galperin, S. and C. Adams, + "X.509 Internet Public Key Infrastructure Online Certificate + Status Protocol - OCSP", RFC 2560, June 1999. + + [12] Crawford, M., "Binary Labels in the Domain Name System", RFC + 2673, August 1999. + + + +Josefsson Expires April 25, 2004 [Page 9] + +Internet-Draft DNS URI October 2003 + + + [13] Petke, R. and I. King, "Registration Procedures for URL Scheme + Names", BCP 35, RFC 2717, November 1999. + + [14] Connolly, D. and L. Masinter, "The 'text/html' Media Type", RFC + 2854, June 2000. + + [15] Housley, R., "Cryptographic Message Syntax (CMS)", RFC 3369, + August 2002. + + [16] Faltstrom, P., Hoffman, P. and A. Costello, "Internationalizing + Domain Names in Applications (IDNA)", RFC 3490, March 2003. + + +Author's Address + + Simon Josefsson + + EMail: simon@josefsson.org + +Appendix A. Revision Changes + + Note to RFC editor: This appendix is to be removed on publication. + +A.1 Changes since -06 + + The MIME registration templates for text/dns and application/dns was + removed, and will be defined in separate documents. + + Improved discussion related to which mnemonics that must be + supported. The interoperability problem that provoked the + clarification is also mentioned. + + Security consideration improvements. + +A.2 Changes since -07 + + Author/Change Controller changed to author of this document, not + IESG. Terminology section collapsed into introduction. The second + paragraph of the introduction rewritten and gives explicit examples. + Intended usage and applications fields fixed. Moved this revision + tracking information to an appendix. Mention IDN in charset section. + All previous thanks to suggestions by Larry Masinter. + +A.3 Changes since -08 + + Modifications derived from Last-Call comments: Made more clear that + DNS URIs does not imply use of the DNS protocol, but the issue is not + stressed because of the apparent inflamatory state of affairs. Added + + + +Josefsson Expires April 25, 2004 [Page 10] + +Internet-Draft DNS URI October 2003 + + + informative references to HTML and FTP. Clarified that dnsname can + be empty. Clarified that first dnsqueryelement "win" in case of + ambiguity. Clarified security consideration with respect to unknown + dnsqueryelements. Use "authority" instead of "server". Say "IANA + registered" instead of "standard". Interoperability note about binary + DNS labels. Typos. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Josefsson Expires April 25, 2004 [Page 11] + +Internet-Draft DNS URI October 2003 + + +Intellectual Property Statement + + The IETF takes no position regarding the validity or scope of any + intellectual property or other rights that might be claimed to + pertain to the implementation or use of the technology described in + this document or the extent to which any license under such rights + might or might not be available; neither does it represent that it + has made any effort to identify any such rights. Information on the + IETF's procedures with respect to rights in standards-track and + standards-related documentation can be found in BCP-11. Copies of + claims of rights made available for publication and any assurances of + licenses to be made available, or the result of an attempt made to + obtain a general license or permission for the use of such + proprietary rights by implementors or users of this specification can + be obtained from the IETF Secretariat. + + The IETF invites any interested party to bring to its attention any + copyrights, patents or patent applications, or other proprietary + rights which may cover technology that may be required to practice + this standard. Please address the information to the IETF Executive + Director. + + +Full Copyright Statement + + Copyright (C) The Internet Society (2003). All Rights Reserved. + + This document and translations of it may be copied and furnished to + others, and derivative works that comment on or otherwise explain it + or assist in its implementation may be prepared, copied, published + and distributed, in whole or in part, without restriction of any + kind, provided that the above copyright notice and this paragraph are + included on all such copies and derivative works. However, this + document itself may not be modified in any way, such as by removing + the copyright notice or references to the Internet Society or other + Internet organizations, except as needed for the purpose of + developing Internet standards in which case the procedures for + copyrights defined in the Internet Standards process must be + followed, or as required to translate it into languages other than + English. + + The limited permissions granted above are perpetual and will not be + revoked by the Internet Society or its successors or assignees. + + This document and the information contained herein is provided on an + "AS IS" basis and THE INTERNET SOCIETY AND THE INTERNET ENGINEERING + TASK FORCE DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING + BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION + + + +Josefsson Expires April 25, 2004 [Page 12] + +Internet-Draft DNS URI October 2003 + + + HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF + MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. + + +Acknowledgment + + Funding for the RFC Editor function is currently provided by the + Internet Society. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Josefsson Expires April 25, 2004 [Page 13] + diff --git a/tcllib/modules/dns/dns.tcl b/tcllib/modules/dns/dns.tcl new file mode 100644 index 0000000..305bd64 --- /dev/null +++ b/tcllib/modules/dns/dns.tcl @@ -0,0 +1,1416 @@ +# dns.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035 +# for information about the DNS protocol. This should insulate Tcl scripts +# from problems with using the system library resolver for slow name servers. +# +# This implementation uses TCP only for DNS queries. The protocol reccommends +# that UDP be used in these cases but Tcl does not include UDP sockets by +# default. The package should be simple to extend to use a TclUDP extension +# in the future. +# +# Support for SPF (http://spf.pobox.com/rfcs.html) will need updating +# if or when the proposed draft becomes accepted. +# +# Support added for RFC1886 - DNS Extensions to support IP version 6 +# Support added for RFC2782 - DNS RR for specifying the location of services +# Support added for RFC1995 - Incremental Zone Transfer in DNS +# +# TODO: +# - When using tcp we should make better use of the open connection and +# send multiple queries along the same connection. +# +# - We must switch to using TCP for truncated UDP packets. +# +# - Read RFC 2136 - dynamic updating of DNS +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +package require Tcl 8.2; # tcl minimum version +package require logger; # tcllib 1.3 +package require uri; # tcllib 1.1 +package require uri::urn; # tcllib 1.2 +package require ip; # tcllib 1.7 + +namespace eval ::dns { + namespace export configure resolve name address cname \ + status reset wait cleanup errorcode + + variable options + if {![info exists options]} { + array set options { + port 53 + timeout 30000 + protocol tcp + search {} + nameserver {localhost} + loglevel warn + } + variable log [logger::init dns] + ${log}::setlevel $options(loglevel) + } + + # We can use either ceptcl or tcludp for UDP support. + if {![catch {package require udp 1.0.4} msg]} { ;# tcludp 1.0.4+ + # If TclUDP 1.0.4 or better is available, use it. + set options(protocol) udp + } else { + if {![catch {package require ceptcl} msg]} { + set options(protocol) udp + } + } + + variable types + array set types { + A 1 NS 2 MD 3 MF 4 CNAME 5 SOA 6 MB 7 MG 8 MR 9 + NULL 10 WKS 11 PTR 12 HINFO 13 MINFO 14 MX 15 TXT 16 + SPF 16 AAAA 28 SRV 33 IXFR 251 AXFR 252 MAILB 253 MAILA 254 + ANY 255 * 255 + } + + variable classes + array set classes { IN 1 CS 2 CH 3 HS 4 * 255} + + variable uid + if {![info exists uid]} { + set uid 0 + } +} + +# ------------------------------------------------------------------------- + +# Description: +# Configure the DNS package. In particular the local nameserver will need +# to be set. With no options, returns a list of all current settings. +# +proc ::dns::configure {args} { + variable options + variable log + + if {[llength $args] < 1} { + set r {} + foreach opt [lsort [array names options]] { + lappend r -$opt $options($opt) + } + return $r + } + + set cget 0 + if {[llength $args] == 1} { + set cget 1 + } + + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -n* - + -ser* { + if {$cget} { + return $options(nameserver) + } else { + set options(nameserver) [Pop args 1] + } + } + -po* { + if {$cget} { + return $options(port) + } else { + set options(port) [Pop args 1] + } + } + -ti* { + if {$cget} { + return $options(timeout) + } else { + set options(timeout) [Pop args 1] + } + } + -pr* { + if {$cget} { + return $options(protocol) + } else { + set proto [string tolower [Pop args 1]] + if {[string compare udp $proto] == 0 \ + && [string compare tcp $proto] == 0} { + return -code error "invalid protocol \"$proto\":\ + protocol must be either \"udp\" or \"tcp\"" + } + set options(protocol) $proto + } + } + -sea* { + if {$cget} { + return $options(search) + } else { + set options(search) [Pop args 1] + } + } + -log* { + if {$cget} { + return $options(loglevel) + } else { + set options(loglevel) [Pop args 1] + ${log}::setlevel $options(loglevel) + } + } + -- { Pop args ; break } + default { + set opts [join [lsort [array names options]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be one of -$opts" + } + } + Pop args + } + + return +} + +# ------------------------------------------------------------------------- + +# Description: +# Create a DNS query and send to the specified name server. Returns a token +# to be used to obtain any further information about this query. +# +proc ::dns::resolve {query args} { + variable uid + variable options + variable log + + # get a guaranteed unique and non-present token id. + set id [incr uid] + while {[info exists [set token [namespace current]::$id]]} { + set id [incr uid] + } + # FRINK: nocheck + variable $token + upvar 0 $token state + + # Setup token/state defaults. + set state(id) $id + set state(query) $query + set state(qdata) "" + set state(opcode) 0; # 0 = query, 1 = inverse query. + set state(-type) A; # DNS record type (A address) + set state(-class) IN; # IN (internet address space) + set state(-recurse) 1; # Recursion Desired + set state(-command) {}; # asynchronous handler + set state(-timeout) $options(timeout); # connection timeout default. + set state(-nameserver) $options(nameserver);# default nameserver + set state(-port) $options(port); # default namerservers port + set state(-search) $options(search); # domain search list + set state(-protocol) $options(protocol); # which protocol udp/tcp + + # Handle DNS URL's + if {[string match "dns:*" $query]} { + array set URI [uri::split $query] + foreach {opt value} [uri::split $query] { + if {$value != {} && [info exists state(-$opt)]} { + set state(-$opt) $value + } + } + set state(query) $URI(query) + ${log}::debug "parsed query: $query" + } + + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -n* - ns - + -ser* { set state(-nameserver) [Pop args 1] } + -po* { set state(-port) [Pop args 1] } + -ti* { set state(-timeout) [Pop args 1] } + -co* { set state(-command) [Pop args 1] } + -cl* { set state(-class) [Pop args 1] } + -ty* { set state(-type) [Pop args 1] } + -pr* { set state(-protocol) [Pop args 1] } + -sea* { set state(-search) [Pop args 1] } + -re* { set state(-recurse) [Pop args 1] } + -inv* { set state(opcode) 1 } + -status {set state(opcode) 2} + -data { set state(qdata) [Pop args 1] } + default { + set opts [join [lsort [array names state -*]] ", "] + return -code error "bad option [lindex $args 0]: \ + must be $opts" + } + } + Pop args + } + + if {$state(-nameserver) == {}} { + return -code error "no nameserver specified" + } + + if {$state(-protocol) == "udp"} { + if {[llength [package provide ceptcl]] == 0 \ + && [llength [package provide udp]] == 0} { + return -code error "udp support is not available,\ + get ceptcl or tcludp" + } + } + + # Check for reverse lookups + if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} { + set addr [lreverse [split $state(query) .]] + lappend addr in-addr arpa + set state(query) [join $addr .] + set state(-type) PTR + } + + BuildMessage $token + + if {$state(-protocol) == "tcp"} { + TcpTransmit $token + } else { + UdpTransmit $token + } + if {$state(-command) == {}} { + wait $token + } + return $token +} + +# ------------------------------------------------------------------------- + +# Description: +# Return a list of domain names returned as results for the last query. +# +proc ::dns::name {token} { + set r {} + Flags $token flags + array set reply [Decode $token] + + switch -exact -- $flags(opcode) { + 0 { + # QUERY + foreach answer $reply(AN) { + array set AN $answer + if {![info exists AN(type)]} {set AN(type) {}} + switch -exact -- $AN(type) { + MX - NS - PTR { + if {[info exists AN(rdata)]} {lappend r $AN(rdata)} + } + default { + if {[info exists AN(name)]} { + lappend r $AN(name) + } + } + } + } + } + + 1 { + # IQUERY + foreach answer $reply(QD) { + array set QD $answer + lappend r $QD(name) + } + } + default { + return -code error "not supported for this query type" + } + } + return $r +} + +# Description: +# Return a list of the IP addresses returned for this query. +# +proc ::dns::address {token} { + set r {} + array set reply [Decode $token] + foreach answer $reply(AN) { + array set AN $answer + + if {[info exists AN(type)]} { + switch -exact -- $AN(type) { + "A" { + lappend r $AN(rdata) + } + "AAAA" { + lappend r $AN(rdata) + } + } + } + } + return $r +} + +# Description: +# Return a list of all CNAME results returned for this query. +# +proc ::dns::cname {token} { + set r {} + array set reply [Decode $token] + foreach answer $reply(AN) { + array set AN $answer + + if {[info exists AN(type)]} { + if {$AN(type) == "CNAME"} { + lappend r $AN(rdata) + } + } + } + return $r +} + +# Description: +# Return the decoded answer records. This can be used for more complex +# queries where the answer isn't supported byb cname/address/name. +proc ::dns::result {token args} { + array set reply [eval [linsert $args 0 Decode $token]] + return $reply(AN) +} + +# ------------------------------------------------------------------------- + +# Description: +# Get the status of the request. +# +proc ::dns::status {token} { + upvar #0 $token state + return $state(status) +} + +# Description: +# Get the error message. Empty if no error. +# +proc ::dns::error {token} { + upvar #0 $token state + if {[info exists state(error)]} { + return $state(error) + } + return "" +} + +# Description +# Get the error code. This is 0 for a successful transaction. +# +proc ::dns::errorcode {token} { + upvar #0 $token state + set flags [Flags $token] + set ndx [lsearch -exact $flags errorcode] + incr ndx + return [lindex $flags $ndx] +} + +# Description: +# Reset a connection with optional reason. +# +proc ::dns::reset {token {why reset} {errormsg {}}} { + upvar #0 $token state + set state(status) $why + if {[string length $errormsg] > 0 && ![info exists state(error)]} { + set state(error) $errormsg + } + catch {fileevent $state(sock) readable {}} + Finish $token +} + +# Description: +# Wait for a request to complete and return the status. +# +proc ::dns::wait {token} { + upvar #0 $token state + + if {$state(status) == "connect"} { + vwait [subst $token](status) + } + + return $state(status) +} + +# Description: +# Remove any state associated with this token. +# +proc ::dns::cleanup {token} { + upvar #0 $token state + if {[info exists state]} { + catch {close $state(sock)} + catch {after cancel $state(after)} + unset state + } +} + +# ------------------------------------------------------------------------- + +# Description: +# Dump the raw data of the request and reply packets. +# +proc ::dns::dump {args} { + if {[llength $args] == 1} { + set type -reply + set token [lindex $args 0] + } elseif { [llength $args] == 2 } { + set type [lindex $args 0] + set token [lindex $args 1] + } else { + return -code error "wrong # args:\ + should be \"dump ?option? methodName\"" + } + + # FRINK: nocheck + variable $token + upvar 0 $token state + + set result {} + switch -glob -- $type { + -qu* - + -req* { + set result [DumpMessage $state(request)] + } + -rep* { + set result [DumpMessage $state(reply)] + } + default { + error "unrecognised option: must be one of \ + \"-query\", \"-request\" or \"-reply\"" + } + } + + return $result +} + +# Description: +# Perform a hex dump of binary data. +# +proc ::dns::DumpMessage {data} { + set result {} + binary scan $data c* r + foreach c $r { + append result [format "%02x " [expr {$c & 0xff}]] + } + return $result +} + +# ------------------------------------------------------------------------- + +# Description: +# Contruct a DNS query packet. +# +proc ::dns::BuildMessage {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + variable types + variable classes + variable options + + if {! [info exists types($state(-type))] } { + return -code error "invalid DNS query type" + } + + if {! [info exists classes($state(-class))] } { + return -code error "invalid DNS query class" + } + + set qdcount 0 + set qsection {} + set nscount 0 + set nsdata {} + + # In theory we can send multiple queries. In practice, named doesn't + # appear to like that much. If it did work we'd do this: + # foreach domain [linsert $options(search) 0 {}] ... + + + # Pack the query: QNAME QTYPE QCLASS + set qsection [PackName $state(query)] + append qsection [binary format SS \ + $types($state(-type))\ + $classes($state(-class))] + incr qdcount + + if {[string length $state(qdata)] > 0} { + set nsdata [eval [linsert $state(qdata) 0 PackRecord]] + incr nscount + } + + switch -exact -- $state(opcode) { + 0 { + # QUERY + set state(request) [binary format SSSSSS $state(id) \ + [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \ + $qdcount 0 $nscount 0] + append state(request) $qsection $nsdata + } + 1 { + # IQUERY + set state(request) [binary format SSSSSS $state(id) \ + [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \ + 0 $qdcount 0 0 0] + append state(request) \ + [binary format cSSI 0 \ + $types($state(-type)) $classes($state(-class)) 0] + switch -exact -- $state(-type) { + A { + append state(request) \ + [binary format Sc4 4 [split $state(query) .]] + } + PTR { + append state(request) \ + [binary format Sc4 4 [split $state(query) .]] + } + default { + return -code error "inverse query not supported for this type" + } + } + } + default { + return -code error "operation not supported" + } + } + + return +} + +# Pack a human readable dns name into a DNS resource record format. +proc ::dns::PackName {name} { + set data "" + foreach part [split [string trim $name .] .] { + set len [string length $part] + append data [binary format ca$len $len $part] + } + append data \x00 + return $data +} + +# Pack a character string - byte length prefixed +proc ::dns::PackString {text} { + set len [string length $text] + set data [binary format ca$len $len $text] + return $data +} + +# Pack up a single DNS resource record. See RFC1035: 3.2 for the format +# of each type. +# eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com} +# +proc ::dns::PackRecord {args} { + variable types + variable classes + array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""} + array set rr $args + set data [PackName $rr(name)] + + switch -exact -- $rr(type) { + CNAME - MB - MD - MF - MG - MR - NS - PTR { + set rr(rdata) [PackName $rr(rdata)] + } + HINFO { + array set r {CPU {} OS {}} + array set r $rr(rdata) + set rr(rdata) [PackString $r(CPU)] + append rr(rdata) [PackString $r(OS)] + } + MINFO { + array set r {RMAILBX {} EMAILBX {}} + array set r $rr(rdata) + set rr(rdata) [PackString $r(RMAILBX)] + append rr(rdata) [PackString $r(EMAILBX)] + } + MX { + foreach {pref exch} $rr(rdata) break + set rr(rdata) [binary format S $pref] + append rr(rdata) [PackName $exch] + } + TXT { + set str $rr(rdata) + set len [string length [set str $rr(rdata)]] + set rr(rdata) "" + for {set n 0} {$n < $len} {incr n} { + set s [string range $str $n [incr n 253]] + append rr(rdata) [PackString $s] + } + } + NULL {} + SOA { + array set r {MNAME {} RNAME {} + SERIAL 0 REFRESH 0 RETRY 0 EXPIRE 0 MINIMUM 0} + array set r $rr(rdata) + set rr(rdata) [PackName $r(MNAME)] + append rr(rdata) [PackName $r(RNAME)] + append rr(rdata) [binary format IIIII $r(SERIAL) \ + $r(REFRESH) $r(RETRY) $r(EXPIRE) $r(MINIMUM)] + } + } + + # append the root label and the type flag and query class. + append data [binary format SSIS $types($rr(type)) \ + $classes($rr(class)) $rr(ttl) [string length $rr(rdata)]] + append data $rr(rdata) + return $data +} + +# ------------------------------------------------------------------------- + +# Description: +# Transmit a DNS request over a tcp connection. +# +proc ::dns::TcpTransmit {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + # setup the timeout + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) \ + [list [namespace origin reset] \ + $token timeout\ + "operation timed out"]] + } + + # Sometimes DNS servers drop TCP requests. So it's better to + # use asynchronous connect + set s [socket -async $state(-nameserver) $state(-port)] + fileevent $s writable [list [namespace origin TcpConnected] $token $s] + set state(sock) $s + set state(status) connect + + return $token +} + +proc ::dns::TcpConnected {token s} { + variable $token + upvar 0 $token state + + fileevent $s writable {} + if {[catch {fconfigure $s -peername}]} { + # TCP connection failed + Finish $token "can't connect to server" + return + } + + fconfigure $s -blocking 0 -translation binary -buffering none + + # For TCP the message must be prefixed with a 16bit length field. + set req [binary format S [string length $state(request)]] + append req $state(request) + + puts -nonewline $s $req + + fileevent $s readable [list [namespace current]::TcpEvent $token] +} + +# ------------------------------------------------------------------------- +# Description: +# Transmit a DNS request using UDP datagrams +# +# Note: +# This requires a UDP implementation that can transmit binary data. +# As yet I have been unable to test this myself and the tcludp package +# cannot do this. +# +proc ::dns::UdpTransmit {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + # setup the timeout + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) \ + [list [namespace origin reset] \ + $token timeout\ + "operation timed out"]] + } + + if {[llength [package provide ceptcl]] > 0} { + # using ceptcl + set state(sock) [cep -type datagram $state(-nameserver) $state(-port)] + fconfigure $state(sock) -blocking 0 + } else { + # using tcludp + set state(sock) [udp_open] + udp_conf $state(sock) $state(-nameserver) $state(-port) + } + fconfigure $state(sock) -translation binary -buffering none + set state(status) connect + puts -nonewline $state(sock) $state(request) + + fileevent $state(sock) readable [list [namespace current]::UdpEvent $token] + + return $token +} + +# ------------------------------------------------------------------------- + +# Description: +# Tidy up after a tcp transaction. +# +proc ::dns::Finish {token {errormsg ""}} { + # FRINK: nocheck + variable $token + upvar 0 $token state + global errorInfo errorCode + + if {[string length $errormsg] != 0} { + set state(error) $errormsg + set state(status) error + } + catch {close $state(sock)} + catch {after cancel $state(after)} + if {[info exists state(-command)] && $state(-command) != {}} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + if {[info exists state(-command)]} { + unset state(-command) + } + } +} + +# ------------------------------------------------------------------------- + +# Description: +# Handle end-of-file on a tcp connection. +# +proc ::dns::Eof {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + set state(status) eof + Finish $token +} + +# ------------------------------------------------------------------------- + +# Description: +# Process a DNS reply packet (protocol independent) +# +proc ::dns::Receive {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + binary scan $state(reply) SS id flags + set status [expr {$flags & 0x000F}] + + switch -- $status { + 0 { + set state(status) ok + Finish $token + } + 1 { Finish $token "Format error - unable to interpret the query." } + 2 { Finish $token "Server failure - internal server error." } + 3 { Finish $token "Name Error - domain does not exist" } + 4 { Finish $token "Not implemented - the query type is not available." } + 5 { Finish $token "Refused - your request has been refused by the server." } + default { + Finish $token "unrecognised error code: $err" + } + } +} + +# ------------------------------------------------------------------------- + +# Description: +# file event handler for tcp socket. Wait for the reply data. +# +proc ::dns::TcpEvent {token} { + variable log + # FRINK: nocheck + variable $token + upvar 0 $token state + set s $state(sock) + + if {[eof $s]} { + Eof $token + return + } + + set status [catch {read $state(sock)} result] + if {$status != 0} { + ${log}::debug "Event error: $result" + Finish $token "error reading data: $result" + } elseif { [string length $result] >= 0 } { + if {[catch { + # Handle incomplete reads - check the size and keep reading. + if {![info exists state(size)]} { + binary scan $result S state(size) + set result [string range $result 2 end] + } + append state(reply) $result + + # check the length and flags and chop off the tcp length prefix. + if {[string length $state(reply)] >= $state(size)} { + binary scan $result S id + set id [expr {$id & 0xFFFF}] + if {$id != [expr {$state(id) & 0xFFFF}]} { + ${log}::error "received packed with incorrect id" + } + # bug #1158037 - doing this causes problems > 65535 requests! + #Receive [namespace current]::$id + Receive $token + } else { + ${log}::debug "Incomplete tcp read:\ + [string length $state(reply)] should be $state(size)" + } + } err]} { + Finish $token "Event error: $err" + } + } elseif { [eof $state(sock)] } { + Eof $token + } elseif { [fblocked $state(sock)] } { + ${log}::debug "Event blocked" + } else { + ${log}::critical "Event error: this can't happen!" + Finish $token "Event error: this can't happen!" + } +} + +# ------------------------------------------------------------------------- + +# Description: +# file event handler for udp sockets. +proc ::dns::UdpEvent {token} { + # FRINK: nocheck + variable $token + upvar 0 $token state + set s $state(sock) + + set payload [read $state(sock)] + append state(reply) $payload + + binary scan $payload S id + set id [expr {$id & 0xFFFF}] + if {$id != [expr {$state(id) & 0xFFFF}]} { + ${log}::error "received packed with incorrect id" + } + # bug #1158037 - doing this causes problems > 65535 requests! + #Receive [namespace current]::$id + Receive $token +} + +# ------------------------------------------------------------------------- + +proc ::dns::Flags {token {varname {}}} { + # FRINK: nocheck + variable $token + upvar 0 $token state + + if {$varname != {}} { + upvar $varname flags + } + + array set flags {query 0 opcode 0 authoritative 0 errorcode 0 + truncated 0 recursion_desired 0 recursion_allowed 0} + + binary scan $state(reply) SSSSSS mid hdr nQD nAN nNS nAR + + set flags(response) [expr {($hdr & 0x8000) >> 15}] + set flags(opcode) [expr {($hdr & 0x7800) >> 11}] + set flags(authoritative) [expr {($hdr & 0x0400) >> 10}] + set flags(truncated) [expr {($hdr & 0x0200) >> 9}] + set flags(recursion_desired) [expr {($hdr & 0x0100) >> 8}] + set flags(recursion_allowed) [expr {($hdr & 0x0080) >> 7}] + set flags(errorcode) [expr {($hdr & 0x000F)}] + + return [array get flags] +} + +# ------------------------------------------------------------------------- + +# Description: +# Decode a DNS packet (either query or response). +# +proc ::dns::Decode {token args} { + variable log + # FRINK: nocheck + variable $token + upvar 0 $token state + + array set opts {-rdata 0 -query 0} + while {[string match -* [set option [lindex $args 0]]]} { + switch -exact -- $option { + -rdata { set opts(-rdata) 1 } + -query { set opts(-query) 1 } + default { + return -code error "bad option \"$option\":\ + must be -rdata" + } + } + Pop args + } + + if {$opts(-query)} { + binary scan $state(request) SSSSSSc* mid hdr nQD nAN nNS nAR data + } else { + binary scan $state(reply) SSSSSSc* mid hdr nQD nAN nNS nAR data + } + + set fResponse [expr {($hdr & 0x8000) >> 15}] + set fOpcode [expr {($hdr & 0x7800) >> 11}] + set fAuthoritative [expr {($hdr & 0x0400) >> 10}] + set fTrunc [expr {($hdr & 0x0200) >> 9}] + set fRecurse [expr {($hdr & 0x0100) >> 8}] + set fCanRecurse [expr {($hdr & 0x0080) >> 7}] + set fRCode [expr {($hdr & 0x000F)}] + set flags "" + + if {$fResponse} {set flags "QR"} else {set flags "Q"} + set opcodes [list QUERY IQUERY STATUS] + lappend flags [lindex $opcodes $fOpcode] + if {$fAuthoritative} {lappend flags "AA"} + if {$fTrunc} {lappend flags "TC"} + if {$fRecurse} {lappend flags "RD"} + if {$fCanRecurse} {lappend flags "RA"} + + set info "ID: $mid\ + Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\ + NQ: $nQD\ + NA: $nAN\ + NS: $nNS\ + AR: $nAR" + ${log}::debug $info + + set ndx 12 + set r {} + set QD [ReadQuestion $nQD $state(reply) ndx] + lappend r QD $QD + set AN [ReadAnswer $nAN $state(reply) ndx $opts(-rdata)] + lappend r AN $AN + set NS [ReadAnswer $nNS $state(reply) ndx $opts(-rdata)] + lappend r NS $NS + set AR [ReadAnswer $nAR $state(reply) ndx $opts(-rdata)] + lappend r AR $AR + return $r +} + +# ------------------------------------------------------------------------- + +proc ::dns::Expand {data} { + set r {} + binary scan $data c* d + foreach c $d { + lappend r [expr {$c & 0xFF}] + } + return $r +} + + +# ------------------------------------------------------------------------- +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::dns::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Reverse a list. Code from http://wiki.tcl.tk/tcl/43 +# +proc ::dns::lreverse {lst} { + set res {} + set i [llength $lst] + while {$i} {lappend res [lindex $lst [incr i -1]]} + return $res +} + +# ------------------------------------------------------------------------- + +proc ::dns::KeyOf {arrayname value {default {}}} { + upvar $arrayname array + set lst [array get array] + set ndx [lsearch -exact $lst $value] + if {$ndx != -1} { + incr ndx -1 + set r [lindex $lst $ndx] + } else { + set r $default + } + return $r +} + + +# ------------------------------------------------------------------------- +# Read the question section from a DNS message. This always starts at index +# 12 of a message but may be of variable length. +# +proc ::dns::ReadQuestion {nitems data indexvar} { + variable types + variable classes + upvar $indexvar index + set result {} + + for {set cn 0} {$cn < $nitems} {incr cn} { + set r {} + lappend r name [ReadName data $index offset] + incr index $offset + + # Read off QTYPE and QCLASS for this query. + set ndx $index + incr index 3 + binary scan [string range $data $ndx $index] SS qtype qclass + set qtype [expr {$qtype & 0xFFFF}] + set qclass [expr {$qclass & 0xFFFF}] + incr index + lappend r type [KeyOf types $qtype $qtype] \ + class [KeyOf classes $qclass $qclass] + lappend result $r + } + return $result +} + +# ------------------------------------------------------------------------- + +# Read an answer section from a DNS message. +# +proc ::dns::ReadAnswer {nitems data indexvar {raw 0}} { + variable types + variable classes + upvar $indexvar index + set result {} + + for {set cn 0} {$cn < $nitems} {incr cn} { + set r {} + lappend r name [ReadName data $index offset] + incr index $offset + + # Read off TYPE, CLASS, TTL and RDLENGTH + binary scan [string range $data $index end] SSIS type class ttl rdlength + + set type [expr {$type & 0xFFFF}] + set type [KeyOf types $type $type] + + set class [expr {$class & 0xFFFF}] + set class [KeyOf classes $class $class] + + set ttl [expr {$ttl & 0xFFFFFFFF}] + set rdlength [expr {$rdlength & 0xFFFF}] + incr index 10 + set rdata [string range $data $index [expr {$index + $rdlength - 1}]] + + if {! $raw} { + switch -- $type { + A { + set rdata [join [Expand $rdata] .] + } + AAAA { + set rdata [ip::contract [ip::ToString $rdata]] + } + NS - CNAME - PTR { + set rdata [ReadName data $index off] + } + MX { + binary scan $rdata S preference + set exchange [ReadName data [expr {$index + 2}] off] + set rdata [list $preference $exchange] + } + SRV { + set x $index + set rdata [list priority [ReadUShort data $x off]] + incr x $off + lappend rdata weight [ReadUShort data $x off] + incr x $off + lappend rdata port [ReadUShort data $x off] + incr x $off + lappend rdata target [ReadName data $x off] + incr x $off + } + TXT { + set rdata [ReadString data $index $rdlength] + } + SOA { + set x $index + set rdata [list MNAME [ReadName data $x off]] + incr x $off + lappend rdata RNAME [ReadName data $x off] + incr x $off + lappend rdata SERIAL [ReadULong data $x off] + incr x $off + lappend rdata REFRESH [ReadLong data $x off] + incr x $off + lappend rdata RETRY [ReadLong data $x off] + incr x $off + lappend rdata EXPIRE [ReadLong data $x off] + incr x $off + lappend rdata MINIMUM [ReadULong data $x off] + incr x $off + } + } + } + + incr index $rdlength + lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata + lappend result $r + } + return $result +} + + +# Read a 32bit integer from a DNS packet. These are compatible with +# the ReadName proc. Additionally - ReadULong takes measures to ensure +# the unsignedness of the value obtained. +# +proc ::dns::ReadLong {datavar index usedvar} { + upvar $datavar data + upvar $usedvar used + set r {} + set used 0 + if {[binary scan $data @${index}I r]} { + set used 4 + } + return $r +} + +proc ::dns::ReadULong {datavar index usedvar} { + upvar $datavar data + upvar $usedvar used + set r {} + set used 0 + if {[binary scan $data @${index}cccc b1 b2 b3 b4]} { + set used 4 + # This gets us an unsigned value. + set r [expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8) + + (($b2 & 0xFF) << 16) + ($b1 << 24)}] + } + return $r +} + +proc ::dns::ReadUShort {datavar index usedvar} { + upvar $datavar data + upvar $usedvar used + set r {} + set used 0 + if {[binary scan [string range $data $index end] cc b1 b2]} { + set used 2 + # This gets us an unsigned value. + set r [expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}] + } + return $r +} + +# Read off the NAME or QNAME element. This reads off each label in turn, +# dereferencing pointer labels until we have finished. The length of data +# used is passed back using the usedvar variable. +# +proc ::dns::ReadName {datavar index usedvar} { + upvar $datavar data + upvar $usedvar used + set startindex $index + + set r {} + set len 1 + set max [string length $data] + + while {$len != 0 && $index < $max} { + # Read the label length (and preread the pointer offset) + binary scan [string range $data $index end] cc len lenb + set len [expr {$len & 0xFF}] + incr index + + if {$len != 0} { + if {[expr {$len & 0xc0}]} { + binary scan [binary format cc [expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset + incr index + lappend r [ReadName data $offset junk] + set len 0 + } else { + lappend r [string range $data $index [expr {$index + $len - 1}]] + incr index $len + } + } + } + set used [expr {$index - $startindex}] + return [join $r .] +} + +proc ::dns::ReadString {datavar index length} { + upvar $datavar data + set startindex $index + + set r {} + set max [expr {$index + $length}] + + while {$index < $max} { + binary scan [string range $data $index end] c len + set len [expr {$len & 0xFF}] + incr index + + if {$len != 0} { + append r [string range $data $index [expr {$index + $len - 1}]] + incr index $len + } + } + return $r +} + +# ------------------------------------------------------------------------- + +# Support for finding the local nameservers +# +# For unix we can just parse the /etc/resolv.conf if it exists. +# Of course, some unices use /etc/resolver and other things (NIS for instance) +# On Windows, we can examine the Internet Explorer settings from the registry. +# +switch -exact $::tcl_platform(platform) { + windows { + proc ::dns::nameservers {} { + package require registry + set base {HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services} + set param "$base\\Tcpip\\Parameters" + set interfaces "$param\\Interfaces" + set nameservers {} + if {[string equal $::tcl_platform(os) "Windows NT"]} { + AppendRegistryValue $param NameServer nameservers + AppendRegistryValue $param DhcpNameServer nameservers + foreach i [registry keys $interfaces] { + AppendRegistryValue "$interfaces\\$i" NameServer nameservers + AppendRegistryValue "$interfaces\\$i" DhcpNameServer nameservers + } + } else { + set param "$base\\VxD\\MSTCP" + AppendRegistryValue $param NameServer nameservers + } + return $nameservers + } + proc ::dns::AppendRegistryValue {key val listName} { + upvar $listName lst + if {![catch {registry get $key $val} v]} { + foreach ns [split $v ", "] { + if {[lsearch -exact $lst $ns] == -1} { + lappend lst $ns + } + } + } + } + } + unix { + proc ::dns::nameservers {} { + set nameservers {} + if {[file readable /etc/resolv.conf]} { + set f [open /etc/resolv.conf r] + while {![eof $f]} { + gets $f line + if {[regexp {^\s*nameserver\s+(.*)$} $line -> ns]} { + lappend nameservers $ns + } + } + close $f + } + if {[llength $nameservers] < 1} { + lappend nameservers 127.0.0.1 + } + return $nameservers + } + } + default { + proc ::dns::nameservers {} { + return -code error "command not supported for this platform." + } + } +} + +# ------------------------------------------------------------------------- +# Possible support for the DNS URL scheme. +# Ref: http://www.ietf.org/internet-drafts/draft-josefsson-dns-url-04.txt +# eg: dns:target?class=IN;type=A +# dns://nameserver/target?type=A +# +# URI quoting to be accounted for. +# + +catch { + uri::register {dns} { + variable escape [set [namespace parent [namespace current]]::basic::escape] + variable host [set [namespace parent [namespace current]]::basic::host] + variable hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort] + + variable class [string map {* \\\\*} \ + "class=([join [array names ::dns::classes] {|}])"] + variable type [string map {* \\\\*} \ + "type=([join [array names ::dns::types] {|}])"] + variable classOrType "(?:${class}|${type})" + variable classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?" + + variable query "${host}(${classOrTypeSpec})?" + variable schemepart "(//${hostOrPort}/)?(${query})" + variable url "dns:$schemepart" + } +} + +namespace eval ::uri {} ;# needed for pkg_mkIndex. + +proc ::uri::SplitDns {uri} { + upvar \#0 [namespace current]::dns::schemepart schemepart + upvar \#0 [namespace current]::dns::class classOrType + upvar \#0 [namespace current]::dns::class classRE + upvar \#0 [namespace current]::dns::type typeRE + upvar \#0 [namespace current]::dns::classOrTypeSpec classOrTypeSpec + + array set parts {nameserver {} query {} class {} type {} port {}} + + # validate the uri + if {[regexp -- $dns::schemepart $uri r] == 1} { + + # deal with the optional class and type specifiers + if {[regexp -indices -- "${classOrTypeSpec}$" $uri range]} { + set spec [string range $uri [lindex $range 0] [lindex $range 1]] + set uri [string range $uri 0 [expr {[lindex $range 0] - 2}]] + + if {[regexp -- "$classRE" $spec -> class]} { + set parts(class) $class + } + if {[regexp -- "$typeRE" $spec -> type]} { + set parts(type) $type + } + } + + # Handle the nameserver specification + if {[string match "//*" $uri]} { + set uri [string range $uri 2 end] + array set tmp [GetHostPort uri] + set parts(nameserver) $tmp(host) + set parts(port) $tmp(port) + } + + # what's left is the query domain name. + set parts(query) [string trimleft $uri /] + } + + return [array get parts] +} + +proc ::uri::JoinDns {args} { + array set parts {nameserver {} port {} query {} class {} type {}} + array set parts $args + set query [::uri::urn::quote $parts(query)] + if {$parts(type) != {}} { + append query "?type=$parts(type)" + } + if {$parts(class) != {}} { + if {$parts(type) == {}} { + append query "?class=$parts(class)" + } else { + append query ";class=$parts(class)" + } + } + if {$parts(nameserver) != {}} { + set ns "$parts(nameserver)" + if {$parts(port) != {}} { + append ns ":$parts(port)" + } + set query "//${ns}/${query}" + } + return "dns:$query" +} + +# ------------------------------------------------------------------------- + +catch {dns::configure -nameserver [lindex [dns::nameservers] 0]} + +package provide dns 1.3.5 + +# ------------------------------------------------------------------------- +# Local Variables: +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/dns/dns.test b/tcllib/modules/dns/dns.test new file mode 100644 index 0000000..1e80944 --- /dev/null +++ b/tcllib/modules/dns/dns.test @@ -0,0 +1,73 @@ +# dns.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Tests for the Tcllib dns package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: dns.test,v 1.6 2006/10/09 21:41:40 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal dns.tcl dns +} + +# ------------------------------------------------------------------------- +# Tests +# ------------------------------------------------------------------------- + +# Test the dns uri scheme split and join methods. + +set urls { + 1 dns:www.example.org + {class {} nameserver {} port {} query www.example.org scheme dns type {}} + 2 dns://nameserver/www.example.org + {class {} nameserver nameserver port {} query www.example.org scheme dns type {}} + 3 dns://nameserver:53/www.example.org + {class {} nameserver nameserver port 53 query www.example.org scheme dns type {}} + 4 dns:www.example.org?class=IN + {class IN nameserver {} port {} query www.example.org scheme dns type {}} + 5 dns:www.example.org?type=MX + {class {} nameserver {} port {} query www.example.org scheme dns type MX} + 6 dns:www.example.org?class=IN;type=A + {class IN nameserver {} port {} query www.example.org scheme dns type A} + 7 dns:www.example.org?type=A;class=IN + {class IN nameserver {} port {} query www.example.org scheme dns type A} +} + +foreach {ndx url check} $urls { + test dns-1.$ndx [list uri::split $url] { + if {![catch {uri::split $url} result]} { + if {![catch {array set URL $result} result]} { + set result [dictsort [array get URL]] + } + } + set result + } $check +} + +foreach {ndx url check} $urls { + if {$ndx == 6} continue; # this test is bogus for join. + test dns-2.$ndx [list uri::join $url] { + catch {eval [list uri::join] $check} result + set result + } $url +} + + +# ------------------------------------------------------------------------- +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/dns/ip.tcl b/tcllib/modules/dns/ip.tcl new file mode 100644 index 0000000..f55ab3e --- /dev/null +++ b/tcllib/modules/dns/ip.tcl @@ -0,0 +1,553 @@ +# ip.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Internet address manipulation. +# +# RFC 3513: IPv6 addressing. +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +# @mdgen EXCLUDE: ipMoreC.tcl + +package require Tcl 8.2; # tcl minimum version + +namespace eval ip { + namespace export is version normalize equal type contract mask collapse subtract + #catch {namespace ensemble create} + + variable IPv4Ranges + if {![info exists IPv4Ranges]} { + array set IPv4Ranges { + 0/8 private + 10/8 private + 127/8 private + 172.16/12 private + 192.168/16 private + 223/8 reserved + 224/3 reserved + } + } + + variable IPv6Ranges + if {![info exists IPv6Ranges]} { + # RFC 3513: 2.4 + # RFC 3056: 2 + array set IPv6Ranges { + 2002::/16 "6to4 unicast" + fe80::/10 "link local" + fec0::/10 "site local" + ff00::/8 "multicast" + ::/128 "unspecified" + ::1/128 "localhost" + } + } +} + +proc ::ip::is {class ip} { + foreach {ip mask} [split $ip /] break + switch -exact -- $class { + ipv4 - IPv4 - 4 { + return [IPv4? $ip] + } + ipv6 - IPv6 - 6 { + return [IPv6? $ip] + } + default { + return -code error "bad class \"$class\": must be ipv4 or ipv6" + } + } +} + +proc ::ip::version {ip} { + set version -1 + if {[string equal $ip {}]} { return $version} + foreach {addr mask} [split $ip /] break + if {[IPv4? $addr]} { + set version 4 + } elseif {[IPv6? $addr]} { + set version 6 + } + return $version +} + +proc ::ip::equal {lhs rhs} { + foreach {LHS LM} [SplitIp $lhs] break + foreach {RHS RM} [SplitIp $rhs] break + if {[set version [version $LHS]] != [version $RHS]} { + return -code error "type mismatch:\ + cannot compare different address types" + } + if {$version == 4} {set fmt I} else {set fmt I4} + set LHS [Mask$version [Normalize $LHS $version] $LM] + set RHS [Mask$version [Normalize $RHS $version] $RM] + binary scan $LHS $fmt LLL + binary scan $RHS $fmt RRR + foreach L $LLL R $RRR { + if {$L != $R} {return 0} + } + return 1 +} + +proc ::ip::collapse {prefixlist} { + #puts **[llength $prefixlist]||$prefixlist + + # Force mask parts into length notation for the following merge + # loop to work. + foreach ip $prefixlist { + foreach {addr mask} [SplitIp $ip] break + set nip $addr/[maskToLength [maskToInt $mask]] + #puts "prefix $ip = $nip" + lappend tmp $nip + } + set prefixlist $tmp + + #puts @@[llength $prefixlist]||$prefixlist + + set ret {} + set can_normalize_more 1 + while {$can_normalize_more} { + set prefixlist [lsort -dict $prefixlist] + + #puts ||[llength $prefixlist]||$prefixlist + + set can_normalize_more 0 + + for {set idx 0} {$idx < [llength $prefixlist]} {incr idx} { + set nextidx [expr {$idx + 1}] + + set item [lindex $prefixlist $idx] + set nextitem [lindex $prefixlist $nextidx] + + if {$nextitem eq ""} { + lappend ret $item + continue + } + + set itemmask [mask $item] + set nextitemmask [mask $nextitem] + + set item [prefix $item] + + if {$itemmask ne $nextitemmask} { + lappend ret $item/$itemmask + continue + } + + set adjacentitem [intToString [nextNet $item $itemmask]]/$itemmask + + if {$nextitem ne $adjacentitem} { + lappend ret $item/$itemmask + continue + } + + set upmask [expr {$itemmask - 1}] + set upitem "$item/$upmask" + + # Maybe just checking the llength of the result is enough ? + if {[reduceToAggregates [list $item $nextitem $upitem]] != [list $upitem]} { + lappend ret $item/$itemmask + continue + } + + set can_normalize_more 1 + + incr idx + lappend ret $upitem + } + + set prefixlist $ret + set ret {} + } + + return $prefixlist +} + + +proc ::ip::normalize {ip {Ip4inIp6 0}} { + foreach {ip mask} [SplitIp $ip] break + set version [version $ip] + set s [ToString [Normalize $ip $version] $Ip4inIp6] + if {($version == 6 && $mask != 128) || ($version == 4 && $mask != 32)} { + append s /$mask + } + return $s +} + +proc ::ip::contract {ip} { + foreach {ip mask} [SplitIp $ip] break + set version [version $ip] + set s [ToString [Normalize $ip $version]] + if {$version == 6} { + set r "" + foreach o [split $s :] { + append r [format %x: 0x$o] + } + set r [string trimright $r :] + regsub {(?:^|:)0(?::0)+(?::|$)} $r {::} r + } else { + set r [string trimright $s .0] + } + return $r +} + +proc ::ip::subtract {hosts} { + set positives {} + set negatives {} + + foreach host $hosts { + foreach {addr mask} [SplitIp $host] break + set host $addr/[maskToLength [maskToInt $mask]] + + if {[string match "-*" $host]} { + set host [string trimleft $host "-"] + lappend negatives $host + } else { + lappend positives $host + } + } + + # Reduce to aggregates if needed + if {[llength $positives] > 1} { + set positives [reduceToAggregates $positives] + } + + if {![llength $positives]} { + return {} + } + + if {[llength $negatives] > 1} { + set negatives [reduceToAggregates $negatives] + } + + if {![llength $negatives]} { + return $positives + } + + # Remove positives that are cancelled out entirely + set new_positives {} + foreach positive $positives { + set found 0 + foreach negative $negatives { + # Do we need the exact check, i.e. ==, or 'eq', or would + # checking the length of result == 1 be good enough? + if {[reduceToAggregates [list $positive $negative]] == [list $negative]} { + set found 1 + break + } + } + + if {!$found} { + lappend new_positives $positive + } + } + set positives $new_positives + + set retval {} + foreach positive $positives { + set negatives_found {} + foreach negative $negatives { + if {[isOverlap $positive $negative]} { + lappend negatives_found $negative + } + } + + if {![llength $negatives_found]} { + lappend retval $positive + continue + } + + # Convert the larger subnet + ## Determine smallest subnet involved + set maxmask 0 + foreach subnet [linsert $negatives 0 $positive] { + set mask [mask $subnet] + if {$mask > $maxmask} { + set maxmask $mask + } + } + + set positive_list [ExpandSubnet $positive $maxmask] + set negative_list {} + foreach negative $negatives_found { + foreach negative_subnet [ExpandSubnet $negative $maxmask] { + lappend negative_list $negative_subnet + } + } + + foreach positive_sub $positive_list { + if {[lsearch -exact $negative_list $positive_sub] < 0} { + lappend retval $positive_sub + } + } + } + + return $retval +} + +proc ::ip::ExpandSubnet {subnet newmask} { + #set oldmask [maskToLength [maskToInt [mask $subnet]]] + set oldmask [mask $subnet] + set subnet [prefix $subnet] + + set numsubnets [expr {round(pow(2, ($newmask - $oldmask)))}] + + set ret {} + for {set idx 0} {$idx < $numsubnets} {incr idx} { + lappend ret "${subnet}/${newmask}" + set subnet [intToString [nextNet $subnet $newmask]] + } + + return $ret +} + +# Returns an IP address prefix. +# For instance: +# prefix 192.168.1.4/16 => 192.168.0.0 +# prefix fec0::4/16 => fec0:0:0:0:0:0:0:0 +# prefix fec0::4/ffff:: => fec0:0:0:0:0:0:0:0 +# +proc ::ip::prefix {ip} { + foreach {addr mask} [SplitIp $ip] break + set version [version $addr] + set addr [Normalize $addr $version] + return [ToString [Mask$version $addr $mask]] +} + +# Return the address type. For IPv4 this is one of private, reserved +# or normal +# For IPv6 it is one of site local, link local, multicast, unicast, +# unspecified or loopback. +proc ::ip::type {ip} { + set version [version $ip] + upvar [namespace current]::IPv${version}Ranges types + set ip [prefix $ip] + foreach prefix [array names types] { + set mask [mask $prefix] + if {[equal $ip/$mask $prefix]} { + return $types($prefix) + } + } + if {$version == 4} { + return "normal" + } else { + return "unicast" + } +} + +proc ::ip::mask {ip} { + foreach {addr mask} [split $ip /] break + return $mask +} + +# ------------------------------------------------------------------------- + +# Returns true is the argument can be converted into an IPv4 address. +# +proc ::ip::IPv4? {ip} { + if {[string first : $ip] >= 0} { + return 0 + } + if {[catch {Normalize4 $ip}]} { + return 0 + } + return 1 +} + +proc ::ip::IPv6? {ip} { + set octets [split $ip :] + if {[llength $octets] < 3 || [llength $octets] > 8} { + return 0 + } + set ndx 0 + foreach octet $octets { + incr ndx + if {[string length $octet] < 1} continue + if {[regexp {^[a-fA-F\d]{1,4}$} $octet]} continue + if {$ndx >= [llength $octets] && [IPv4? $octet]} continue + if {$ndx == 2 && [lindex $octets 0] == 2002 && [IPv4? $octet]} continue + #"Invalid IPv6 address \"$ip\"" + return 0 + } + if {[regexp {^:[^:]} $ip]} { + #"Invalid ipv6 address \"$ip\" (starts with :)" + return 0 + } + if {[regexp {[^:]:$} $ip]} { + # "Invalid IPv6 address \"$ip\" (ends with :)" + return 0 + } + if {[regsub -all :: $ip "|" junk] > 1} { + # "Invalid IPv6 address \"$ip\" (more than one :: pattern)" + return 0 + } + return 1 +} + +proc ::ip::Mask4 {ip {bits {}}} { + if {[string length $bits] < 1} { set bits 32 } + binary scan $ip I ipx + if {[string is integer $bits]} { + set mask [expr {(0xFFFFFFFF << (32 - $bits)) & 0xFFFFFFFF}] + } else { + binary scan [Normalize4 $bits] I mask + } + return [binary format I [expr {$ipx & $mask}]] +} + +proc ::ip::Mask6 {ip {bits {}}} { + if {[string length $bits] < 1} { set bits 128 } + if {[string is integer $bits]} { + set mask [binary format B128 [string repeat 1 $bits]] + } else { + binary scan [Normalize6 $bits] I4 mask + } + binary scan $ip I4 Addr + binary scan $mask I4 Mask + foreach A $Addr M $Mask { + lappend r [expr {$A & $M}] + } + return [binary format I4 $r] +} + + + +# A network address specification is an IPv4 address with an optional bitmask +# Split an address specification into a IPv4 address and a network bitmask. +# This doesn't validate the address portion. +# If a spec with no mask is provided then the mask will be 32 +# (all bits significant). +# Masks may be either integer number of significant bits or dotted-quad +# notation. +# +proc ::ip::SplitIp {spec} { + set slash [string last / $spec] + if {$slash != -1} { + incr slash -1 + set ip [string range $spec 0 $slash] + incr slash 2 + set bits [string range $spec $slash end] + } else { + set ip $spec + if {[string length $ip] > 0 && [version $ip] == 6} { + set bits 128 + } else { + set bits 32 + } + } + return [list $ip $bits] +} + +# Given an IP string from the user, convert to a normalized internal rep. +# For IPv4 this is currently a hex string (0xHHHHHHHH). +# For IPv6 this is a binary string or 16 chars. +proc ::ip::Normalize {ip {version 0}} { + if {$version < 0} { + set version [version $ip] + if {$version < 0} { + return -code error "invalid address \"$ip\":\ + value must be a valid IPv4 or IPv6 address" + } + } + return [Normalize$version $ip] +} + +proc ::ip::Normalize4 {ip} { + set octets [split $ip .] + if {[llength $octets] > 4} { + return -code error "invalid ip address \"$ip\"" + } elseif {[llength $octets] < 4} { + set octets [lrange [concat $octets 0 0 0] 0 3] + } + foreach oct $octets { + if {$oct < 0 || $oct > 255} { + return -code error "invalid ip address" + } + } + return [binary format c4 $octets] +} + +proc ::ip::Normalize6 {ip} { + set octets [split $ip :] + set ip4embed [string first . $ip] + set len [llength $octets] + if {$len < 0 || $len > 8} { + return -code error "invalid address: this is not an IPv6 address" + } + set result "" + for {set n 0} {$n < $len} {incr n} { + set octet [lindex $octets $n] + if {$octet == {}} { + if {$n == 0 || $n == ($len - 1)} { + set octet \0\0 + } else { + set missing [expr {9 - $len}] + if {$ip4embed != -1} {incr missing -1} + set octet [string repeat \0\0 $missing] + } + } elseif {[string first . $octet] != -1} { + set octet [Normalize4 $octet] + } else { + set m [expr {4 - [string length $octet]}] + if {$m != 0} { + set octet [string repeat 0 $m]$octet + } + set octet [binary format H4 $octet] + } + append result $octet + } + if {[string length $result] != 16} { + return -code error "invalid address: \"$ip\" is not an IPv6 address" + } + return $result +} + + +# This will convert a full ipv4/ipv6 in binary format into a normal +# expanded string rep. +proc ::ip::ToString {bin {Ip4inIp6 0}} { + set len [string length $bin] + set r "" + if {$len == 4} { + binary scan $bin c4 octets + foreach octet $octets { + lappend r [expr {$octet & 0xff}] + } + return [join $r .] + } elseif {$len == 16} { + if {$Ip4inIp6 == 0} { + binary scan $bin H32 hex + for {set n 0} {$n < 32} {incr n} { + append r [string range $hex $n [incr n 3]]: + } + return [string trimright $r :] + } else { + binary scan $bin H24c4 hex octets + for {set n 0} {$n < 24} {incr n} { + append r [string range $hex $n [incr n 3]]: + } + foreach octet $octets { + append r [expr {$octet & 0xff}]. + } + return [string trimright $r .] + } + } else { + return -code error "invalid binary address:\ + argument is neither an IPv4 nor an IPv6 address" + } +} + +# ------------------------------------------------------------------------- +# Load extended command set. + +source [file join [file dirname [info script]] ipMore.tcl] + +# ------------------------------------------------------------------------- + +package provide ip 1.3 + +# ------------------------------------------------------------------------- +# Local Variables: +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/dns/ip.test b/tcllib/modules/dns/ip.test new file mode 100644 index 0000000..1affbc4 --- /dev/null +++ b/tcllib/modules/dns/ip.test @@ -0,0 +1,271 @@ +# ip.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Tests for the Tcllib ip package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: ip.test,v 1.9 2010/08/16 17:35:18 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal ip.tcl ip +} + +# ------------------------------------------------------------------------- +# Tests +# ------------------------------------------------------------------------- + +# version +set Data { + 127.0.0.1 4 + 0.0.0.0 4 + 192.168.0.4 4 + 255.255.255.255 4 + 127/8 4 + 192/16 4 + :: 6 + ::1 6 + fec0::1 6 + ::192.168.0.4 6 + fec0:0:0:0:0:0:0:1 6 + fffe:0:0::2 6 + 2002:192.168.0.4:: 6 + 2001:192.168.0.4:: -1 + 2002:127.0.0.1::1 6 + hello -1 + -1 -1 + 1.2.3.4.example.com -1 + bogus.1.2.3.4.example.com -1 + {} -1 +} +set n 0 +foreach {addr result} $Data { + test ip-1.[incr n] [list ip version $addr] { + list [catch {ip::version $addr} msg] $addr $msg + } [list 0 $addr $result] +} + +# is +set n 0 +foreach {addr result} $Data { + if {$result != 4} {set result 0} + test ip-2.[incr n] [list ip::is ipv4 $addr] { + list [catch {expr {[ip::is ipv4 $addr] ? 4 : 0}} msg] $addr $msg + } [list 0 $addr $result] +} + +set n 0 +foreach {addr result} $Data { + if {$result != 6} {set result 0} + test ip-3.[incr n] [list ip::is ipv6 $addr] { + list [catch {expr {[ip::is ipv6 $addr] ? 6 : 0}} msg] $addr $msg + } [list 0 $addr $result] +} + +# normalize +set Data { + 192.168.0.4/32 192.168.0.4 + 192.168.0.4/24 192.168.0.4/24 + 192.168 192.168.0.0 + 192.168/24 192.168.0.0/24 + 192.168/255.255.0.0 192.168.0.0/255.255.0.0 + :: 0000:0000:0000:0000:0000:0000:0000:0000 + ::1 0000:0000:0000:0000:0000:0000:0000:0001 + fec0::1 fec0:0000:0000:0000:0000:0000:0000:0001 + fec0:0:0::1 fec0:0000:0000:0000:0000:0000:0000:0001 + fec0:0::8:0:1 fec0:0000:0000:0000:0000:0008:0000:0001 + ::192.168.0.4 0000:0000:0000:0000:0000:0000:c0a8:0004 + ::ffff:192.168.0.4 0000:0000:0000:0000:0000:ffff:c0a8:0004 + fec0::1/16 fec0:0000:0000:0000:0000:0000:0000:0001/16 + fec0::1/128 fec0:0000:0000:0000:0000:0000:0000:0001 + 2002:127.0.0.1::1 2002:7f00:0001:0000:0000:0000:0000:0001 +} +set n 0 +foreach {addr result} $Data { + test ip-4.[incr n] [list ip::normalize $addr] { + list [catch {ip::normalize $addr} msg] $msg + } [list 0 $result] +} + +set Data { + 192.168.1.4 8 192.0.0.0 + 192.168.1.4 1 128.0.0.0 + 192.168.1.4 16 192.168.0.0 + 192.169.1.4 15 192.168.0.0 + 192.168.1.4 24 192.168.1.0 + 192.168.1.4 32 192.168.1.4 + fec0:fafa::1 64 fec0:fafa:0000:0000:0000:0000:0000:0000 + fec0:fafa::1 8 fe00:0000:0000:0000:0000:0000:0000:0000 + fec0:fafa::1 10 fec0:0000:0000:0000:0000:0000:0000:0000 + fec0:fafa::1 128 fec0:fafa:0000:0000:0000:0000:0000:0001 +} + +# prefix +set n 0 +foreach {addr mask prefix} $Data { + test ip-5.[incr n] [list ip::prefix $addr/$mask] { + list [catch {ip::prefix $addr/$mask} msg] $msg + } [list 0 $prefix] +} + +# mask + +set n 0 +foreach {addr mask prefix} $Data { + test ip-6.[incr n] [list ip::mask $addr/$mask] { + list [catch {ip::mask $addr/$mask} msg] $msg + } [list 0 $mask] +} + +# equal +set Data { + 192.168.0.4 ::1 1 "type mismatch: cannot compare different address types" + 192.168.1.4/16 192.168.0.0/16 0 1 + 192.169.1.4/16 192.168.0.0/16 0 0 + 192.169.1.4/15 192.168.0.0/15 0 1 + 192.168.1.4/24 192.168.1.0/24 0 1 + 127/8 192/8 0 0 + 192.168.1.4/255.255.0.0 192.168.1.4/16 0 1 + 192.169.1.4/255.255.0.0 192.168.1.4/16 0 0 + 192.169.1.4/255.254.0.0 192.168.1.4/16 0 1 + + fec0::1/10 fec0::2/10 0 1 + ::1/64 ::2/64 0 1 + ::1/128 ::2/128 0 0 + ::1/127 ::2/127 0 0 + ::1/126 ::2/126 0 1 + fec0:ffff::1/16 fec0:aaaa::2/16 0 1 + fec0:ffff::1/17 fec0:aaaa::2/17 0 1 + fec0:ffff::1/18 fec0:aaaa::2/18 0 0 +} +set n 0 +foreach {lhs rhs err result} $Data { + test ip-7.[incr n] [list ip::equal $lhs $rhs] { + list [catch {ip::equal $lhs $rhs} msg] $msg + } [list $err $result] +} + +# contract +set Data { + 127.0.0.1 127.0.0.1 + 127.0.0.0 127 + 0000:0000:0000:0000:0000:0000:0000:0000 :: + 0000:0000:0000:0000:0000:0000:0000:0001 ::1 + fec0:0000:0000:0000:0000:0000:0000:0000 fec0:: + fec0:0000:0000:0000:0000:0000:0000:0001 fec0::1 + fec0:0000:0001:0000:0000:0000:0000:0001 fec0:0:1::1 + fec0:0001:0002:0003:0004:0005:0006:0001 fec0:1:2:3:4:5:6:1 + fec0:0001:2002:0003:0004:0005:0006:0001 fec0:1:2002:3:4:5:6:1 +} +set n 0 +foreach {addr result} $Data { + test ip-8.[incr n] [list ip::contract $addr] { + list [catch {ip::contract $addr} msg] $msg + } [list 0 $result] +} + +# ------------------------------------------------------------------------- + +test ip-9.0 {collapse} { + ip::collapse {1.2.2.0/24 1.2.3.0/24} +} 1.2.2.0/23 + +test ip-9.1 {collapse revers} { + ip::collapse {1.2.3.0/24 1.2.2.0/24} +} 1.2.2.0/23 + +test ip-9.2 {collapse} { + set l {} + for {set n 0} {$n < 256} {incr n} { + lappend l 1.2.$n.0/24 + } + ip::collapse $l +} {1.2.0.0/16} + +test ip-9.3 {collapse revers} { + set l {} + for {set n 255} {$n >= 0} {incr n -1} { + lappend l 1.2.$n.0/24 + } + ip::collapse $l +} {1.2.0.0/16} + +test ip-9.4 {collapse} { + ip::collapse {1.2.2.0/255.255.255.0 1.2.3.0/255.255.255.0} +} 1.2.2.0/23 + +test ip-9.5 {collapse revers} { + ip::collapse {1.2.3.0/255.255.255.0 1.2.2.0/255.255.255.0} +} 1.2.2.0/23 + +# ------------------------------------------------------------------------- + +test ip-10.0 {subtract} { + ip::collapse [ip::subtract {1.2.0.0/16 1.3.0.0/16 -1.2.4.0/24}] +} {1.2.0.0/22 1.2.5.0/24 1.2.6.0/23 1.2.8.0/21 1.2.16.0/20 1.2.32.0/19 1.2.64.0/18 1.2.128.0/17 1.3.0.0/16} + +# ------------------------------------------------------------------------- + +foreach {i m e} { + 0 255.255.255.255 32 5 0xffffffff 32 + 1 255.255.255.0 24 6 0xffffff00 24 + 2 255.255.0.0 16 7 0xffff0000 16 + 3 255.0.0.0 8 8 0xff000000 8 + 4 0.0.0.0 0 9 0x00000000 0 +} { + test ip-11.$i "maskToLength, $m" { + ip::maskToLength $m + } $e +} + +# ------------------------------------------------------------------------- + +foreach {i ip e} { + 0 0.0.0.0 0 + 1 0.0.0.1 1 + 2 0.0.1.0 256 + 3 0.1.0.0 65536 + 4 1.0.0.0 16777216 + 5 0.0.0.255 255 + 6 0.0.255.0 65280 + 7 0.255.0.0 16711680 + 8 255.0.0.0 4278190080 + 9 255.255.255.255 4294967295 +} { + test ip-12.$i "toInteger $ip" { + ip::toInteger $ip + } $e +} + +# ------------------------------------------------------------------------- + +foreach {i pma e} { + 0 {1.1.1.1 24} 1.1.2.1/0 + 1 {1.1.1.1 24 0} 1.1.1.1/0 + 2 {1.1.1.1 24 1} 1.1.2.1/0 + 3 {1.1.1.1 24 2} 1.1.3.1/0 +} { + test ip-13.$i "nextNet $pma" { + ip::nativeToPrefix [eval ip::nextNet $pma] + } $e +} + + +# ------------------------------------------------------------------------- + +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/dns/ipMore.tcl b/tcllib/modules/dns/ipMore.tcl new file mode 100644 index 0000000..942f64c --- /dev/null +++ b/tcllib/modules/dns/ipMore.tcl @@ -0,0 +1,1295 @@ +#temporary home until this gets cleaned up for export to tcllib ip module +# $Id: ipMore.tcl,v 1.4 2006/01/22 00:27:22 andreas_kupries Exp $ + + +##Library Header +# +# Copyright (c) 2005 Cisco Systems, Inc. +# +# Name: +# ipMore +# +# Purpose: +# Additional commands for the tcllib ip package. +# +# Author: +# Aamer Akhter / aakhter@cisco.com +# +# Support Alias: +# aakhter@cisco.com +# +# Usage: +# package require ip +# (The command are loaded from the regular package). +# +# Description: +# A detailed description of the functionality provided by the library. +# +# Requirements: +# +# Variables: +# namespace ::ip +# +# Notes: +# 1. +# +# Keywords: +# +# +# Category: +# +# +# End of Header + +package require msgcat + +# Try to load various C based accelerator packages for two of the +# commands. + +if {[catch {package require ipMorec}]} { + catch {package require tcllibc} +} + +if {[llength [info commands ::ip::prefixToNativec]]} { + # An accelerator is present, providing the C variants + interp alias {} ::ip::prefixToNative {} ::ip::prefixToNativec + interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativec +} else { + # Link API to the Tcl variants, no accelerators are available. + interp alias {} ::ip::prefixToNative {} ::ip::prefixToNativeTcl + interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativeTcl +} + +namespace eval ::ip { + ::msgcat::mcload [file join [file dirname [info script]] msgs] +} + +if {![llength [info commands lassign]]} { + # Either an older tcl version, or tclx not loaded; have to use our + # internal lassign from http://wiki.tcl.tk/1530 by Schelte Bron + + proc ::ip::lassign {values args} { + uplevel 1 [list foreach $args $values break] + lrange $values [llength $args] end + } +} +if {![llength [info commands lvarpop]]} { + # Define an emulation of Tclx's lvarpop if the command + # is not present already. + + proc ::ip::lvarpop {upVar {index 0}} { + upvar $upVar list; + set top [lindex $list $index]; + set list [concat [lrange $list 0 [expr $index - 1]] \ + [lrange $list [expr $index +1] end]]; + return $top; + } +} + +# Some additional aliases for backward compatability. Not +# documented. The old names are from previous versions while at Cisco. +# +# Old command name --> Documented command name +interp alias {} ::ip::ToInteger {} ::ip::toInteger +interp alias {} ::ip::ToHex {} ::ip::toHex +interp alias {} ::ip::MaskToInt {} ::ip::maskToInt +interp alias {} ::ip::MaskToLength {} ::ip::maskToLength +interp alias {} ::ip::LengthToMask {} ::ip::lengthToMask +interp alias {} ::ip::IpToLayer2Multicast {} ::ip::ipToLayer2Multicast +interp alias {} ::ip::IpHostFromPrefix {} ::ip::ipHostFromPrefix + + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::prefixToNative +# +# Purpose: +# convert from dotted from to native (hex) form +# +# Synopsis: +# prefixToNative <prefix> +# +# Arguments: +# <prefix> +# string in the <ipaddr>/<mask> format +# +# Return Values: +# <prefix> in native format {<hexip> <hexmask>} +# +# Description: +# +# Examples: +# % ip::prefixToNative 1.1.1.0/24 +# 0x01010100 0xffffff00 +# +# Sample Input: +# +# Sample Output: +# Notes: +# fixed bug in C extension that modified +# calling context variable +# See Also: +# +# End of Header + +proc ip::prefixToNativeTcl {prefix} { + set plist {} + foreach p $prefix { + set newPrefix [ip::toHex [ip::prefix $p]] + if {[string equal [set mask [ip::mask $p]] ""]} { + set newMask 0xffffffff + } else { + set newMask [format "0x%08x" [ip::maskToInt $mask]] + } + lappend plist [list $newPrefix $newMask] + } + if {[llength $plist]==1} {return [lindex $plist 0]} + return $plist +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::nativeToPrefix +# +# Purpose: +# convert from native (hex) form to dotted form +# +# Synopsis: +# nativeToPrefix <nativeList>|<native> [-ipv4] +# +# Arguments: +# <nativeList> +# list of native form ip addresses native form is: +# <native> +# tcllist in format {<hexip> <hexmask>} +# -ipv4 +# the provided native format addresses are in ipv4 format (default) +# +# Return Values: +# if nativeToPrefix is called with <native> a single (non-listified) address +# is returned +# if nativeToPrefix is called with a <nativeList> address list, then +# a list of addresses is returned +# +# return form is: <ipaddr>/<mask> +# +# Description: +# +# Examples: +# % ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4 +# 1.1.1.0/24 +# +# Sample Input: +# +# Sample Output: + +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::nativeToPrefix {nativeList args} { + set pList 1 + set ipv4 1 + while {[llength $args]} { + switch -- [lindex $args 0] { + -ipv4 {set args [lrange $args 1 end]} + default { + return -code error [msgcat::mc "option %s not supported" [lindex $args 0]] + } + } + } + + # if a single native element is passed eg {0x01010100 0xffffff00} + # instead of {{0x01010100 0xffffff00} {0x01010100 0xffffff00}...} + # then return a (non-list) single entry + if {[llength [lindex $nativeList 0]]==1} {set pList 0; set nativeList [list $nativeList]} + foreach native $nativeList { + lassign $native ip mask + if {[string equal $mask ""]} {set mask 32} + set pString "" + append pString [ip::ToString [binary format I [expr {$ip}]]] + append pString "/" + append pString [ip::maskToLength $mask] + lappend rList $pString + } + # a multi (listified) entry was given + # return the listified entry + if {$pList} { return $rList } + return $pString +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::intToString +# +# Purpose: +# convert from an integer/hex to dotted form +# +# Synopsis: +# intToString <integer/hex> [-ipv4] +# +# Arguments: +# <integer> +# ip address in integer form +# -ipv4 +# the provided integer addresses is ipv4 (default) +# +# Return Values: +# ip address in dotted form +# +# Description: +# +# Examples: +# ip::intToString 4294967295 +# 255.255.255.255 +# +# Sample Input: +# +# Sample Output: + +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::intToString {int args} { + set ipv4 1 + while {[llength $args]} { + switch -- [lindex $args 0] { + -ipv4 {set args [lrange $args 1 end]} + default { + return -code error [msgcat::mc "option %s not supported" [lindex $args 0]] + } + } + } + return [ip::ToString [binary format I [expr {$int}]]] +} + + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::toInteger +# +# Purpose: +# convert dotted form ip to integer +# +# Synopsis: +# toInteger <ipaddr> +# +# Arguments: +# <ipaddr> +# decimal dotted form ip address +# +# Return Values: +# integer form of <ipaddr> +# +# Description: +# +# Examples: +# % ::ip::toInteger 1.1.1.0 +# 16843008 +# +# Sample Input: +# +# Sample Output: + +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::toInteger {ip} { + binary scan [ip::Normalize4 $ip] I out + return [format %lu [expr {$out & 0xffffffff}]] +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::toHex +# +# Purpose: +# convert dotted form ip to hex +# +# Synopsis: +# toHex <ipaddr> +# +# Arguments: +# <ipaddr> +# decimal dotted from ip address +# +# Return Values: +# hex form of <ipaddr> +# +# Description: +# +# Examples: +# % ::ip::toHex 1.1.1.0 +# 0x01010100 +# +# Sample Input: +# +# Sample Output: + +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::toHex {ip} { + binary scan [ip::Normalize4 $ip] H8 out + return "0x$out" +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::maskToInt +# +# Purpose: +# convert mask to integer +# +# Synopsis: +# maskToInt <mask> +# +# Arguments: +# <mask> +# mask in either dotted form or mask length form (255.255.255.0 or 24) +# +# Return Values: +# integer form of mask +# +# Description: +# +# Examples: +# ::ip::maskToInt 24 +# 4294967040 +# +# +# Sample Input: +# +# Sample Output: + +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::maskToInt {mask} { + if {[string is integer -strict $mask]} { + set maskInt [expr {(0xFFFFFFFF << (32 - $mask))}] + } else { + binary scan [Normalize4 $mask] I maskInt + } + set maskInt [expr {$maskInt & 0xFFFFFFFF}] + return [format %u $maskInt] +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::broadcastAddress +# +# Purpose: +# return broadcast address given prefix +# +# Synopsis: +# broadcastAddress <prefix> [-ipv4] +# +# Arguments: +# <prefix> +# route in the form of <ipaddr>/<mask> or native form {<hexip> <hexmask>} +# -ipv4 +# the provided native format addresses are in ipv4 format (default) +# note: broadcast addresses are not valid in ipv6 +# +# +# Return Values: +# ipaddress of broadcast +# +# Description: +# +# Examples: +# ::ip::broadcastAddress 1.1.1.0/24 +# 1.1.1.255 +# +# ::ip::broadcastAddress {0x01010100 0xffffff00} +# 0x010101ff +# +# Sample Input: +# +# Sample Output: + +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::broadcastAddress {prefix args} { + set ipv4 1 + while {[llength $args]} { + switch -- [lindex $args 0] { + -ipv4 {set args [lrange $args 1 end]} + default { + return -code error [msgcat::mc "option %s not supported" [lindex $args 0]] + } + } + } + if {[llength $prefix] == 2} { + lassign $prefix net mask + } else { + set net [maskToInt [ip::prefix $prefix]] + set mask [maskToInt [ip::mask $prefix]] + } + set ba [expr {$net | ((~$mask)&0xffffffff)}] + + if {[llength $prefix]==2} { + return [format "0x%08x" $ba] + } + return [ToString [binary format I $ba]] +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::maskToLength +# +# Purpose: +# converts dotted or integer form of mask to length +# +# Synopsis: +# maskToLength <dottedMask>|<integerMask>|<hexMask> [-ipv4] +# +# Arguments: +# <dottedMask> +# <integerMask> +# <hexMask> +# mask to convert to prefix length format (eg /24) +# -ipv4 +# the provided integer/hex format masks are ipv4 (default) +# +# Return Values: +# prefix length +# +# Description: +# +# Examples: +# ::ip::maskToLength 0xffffff00 -ipv4 +# 24 +# +# % ::ip::maskToLength 255.255.255.0 +# 24 +# +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::maskToLength {mask args} { + set ipv4 1 + while {[llength $args]} { + switch -- [lindex $args 0] { + -ipv4 {set args [lrange $args 1 end]} + default { + return -code error [msgcat::mc "option %s not supported" [lindex $args 0]] + } + } + } + #pick the fastest method for either format + if {[string is integer -strict $mask]} { + binary scan [binary format I [expr {$mask}]] B32 maskB + if {[regexp -all {^1+} $maskB ones]} { + return [string length $ones] + } else { + return 0 + } + } else { + regexp {\/(.+)} $mask dumb mask + set prefix 0 + foreach ipByte [split $mask {.}] { + switch $ipByte { + 255 {incr prefix 8; continue} + 254 {incr prefix 7} + 252 {incr prefix 6} + 248 {incr prefix 5} + 240 {incr prefix 4} + 224 {incr prefix 3} + 192 {incr prefix 2} + 128 {incr prefix 1} + 0 {} + default { + return -code error [msgcat::mc "not an ip mask: %s" $mask] + } + } + break + } + return $prefix + } +} + + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::lengthToMask +# +# Purpose: +# converts mask length to dotted mask form +# +# Synopsis: +# lengthToMask <maskLength> [-ipv4] +# +# Arguments: +# <maskLength> +# mask length +# -ipv4 +# the provided mask length is ipv4 (default) +# +# Return Values: +# mask in dotted form +# +# Description: +# +# Examples: +# ::ip::lengthToMask 24 +# 255.255.255.0 +# +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::lengthToMask {masklen args} { + while {[llength $args]} { + switch -- [lindex $args 0] { + -ipv4 {set args [lrange $args 1 end]} + default { + return -code error [msgcat::mc "option %s not supported" [lindex $args 0]] + } + } + } + # the fastest method is just to look + # thru an array + return $::ip::maskLenToDotted($masklen) +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::nextNet +# +# Purpose: +# returns next an ipaddress in same position in next network +# +# Synopsis: +# nextNet <ipaddr> <mask> [<count>] [-ipv4] +# +# Arguments: +# <ipaddress> +# in hex/integer/dotted format +# <mask> +# mask in hex/integer/dotted/maskLen format +# <count> +# number of nets to skip over (default is 1) +# -ipv4 +# the provided hex/integer addresses are in ipv4 format (default) +# +# Return Values: +# ipaddress in same position in next network in hex +# +# Description: +# +# Examples: +# +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::nextNet {prefix mask args} { + set count 1 + while {[llength $args]} { + switch -- [lindex $args 0] { + -ipv4 {set args [lrange $args 1 end]} + default { + set count [lindex $args 0] + set args [lrange $args 1 end] + } + } + } + if {![string is integer -strict $prefix]} { + set prefix [toInteger $prefix] + } + if {![string is integer -strict $mask] || ($mask < 33 && $mask > 0)} { + set mask [maskToInt $mask] + } + set prefix [expr {$prefix + ((($mask ^ 0xFFffFFff) + 1) * $count) }] + return [format "0x%08x" $prefix] +} + + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::isOverlap +# +# Purpose: +# checks to see if prefixes overlap +# +# Synopsis: +# isOverlap <prefix> <prefix1> <prefix2>... +# +# Arguments: +# <prefix> +# in form <ipaddr>/<mask> prefix to compare <prefixN> against +# <prefixN> +# in form <ipaddr>/<mask> prefixes to compare against +# +# Return Values: +# 1 if there is an overlap +# +# Description: +# +# Examples: +# % ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 +# 0 +# +# ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32 +# 1 +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::isOverlap {ip args} { + lassign [SplitIp $ip] ip1 mask1 + set ip1int [toInteger $ip1] + set mask1int [maskToInt $mask1] + + set overLap 0 + foreach prefix $args { + lassign [SplitIp $prefix] ip2 mask2 + set ip2int [toInteger $ip2] + set mask2int [maskToInt $mask2] + set mask1mask2 [expr {$mask1int & $mask2int}] + if {[expr {$ip1int & $mask1mask2}] == [expr {$ip2int & $mask1mask2}]} { + set overLap 1 + break + } + } + return $overLap +} + + +#optimized overlap, that accepts native format + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::isOverlapNative +# +# Purpose: +# checks to see if prefixes overlap (optimized native form) +# +# Synopsis: +# isOverlap <hexipaddr> <hexmask> {{<hexipaddr1> <hexmask1>} {<hexipaddr2> <hexmask2>...} +# +# Arguments: +# -all +# return all overlaps rather than the first one +# -inline +# rather than returning index values, return the actual overlap prefixes +# <hexipaddr> +# ipaddress in hex/integer form +# <hexMask> +# mask in hex/integer form +# -ipv4 +# the provided native format addresses are in ipv4 format (default) +# +# Return Values: +# non-zero if there is an overlap, value is element # in list with overlap +# +# Description: +# isOverlapNative is available both as a C extension and in a native tcl form +# if the extension is loaded (tried automatically), isOverlapNative will be +# linked to isOverlapNativeC. If an extension is not loaded, then isOverlapNative +# will be linked to the native tcl proc: ipOverlapNativeTcl. +# +# Examples: +# % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff}} +# 0 +# +# %::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}} +# 2 +# +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::isOverlapNativeTcl {args} { + set all 0 + set inline 0 + set notOverlap 0 + set ipv4 1 + foreach sw [lrange $args 0 end-3] { + switch -exact -- $sw { + -all { + set all 1 + set allList [list] + } + -inline {set inline 1} + -ipv4 {} + } + } + set args [lassign [lrange $args end-2 end] ip1int mask1int prefixList] + if {$inline} { + set overLap [list] + } else { + set overLap 0 + } + set count 0 + foreach prefix $prefixList { + incr count + lassign $prefix ip2int mask2int + set mask1mask2 [expr {$mask1int & $mask2int}] + if {[expr {$ip1int & $mask1mask2}] == [expr {$ip2int & $mask1mask2}]} { + if {$inline} { + set overLap [list $prefix] + } else { + set overLap $count + } + if {$all} { + if {$inline} { + lappend allList $prefix + } else { + lappend allList $count + } + } else { + break + } + } + } + if {$all} {return $allList} + return $overLap +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::ipToLayer2Multicast +# +# Purpose: +# converts ipv4 address to a layer 2 multicast address +# +# Synopsis: +# ipToLayer2Multicast <ipaddr> +# +# Arguments: +# <ipaddr> +# ipaddress in dotted form +# +# Return Values: +# mac address in xx.xx.xx.xx.xx.xx form +# +# Description: +# +# Examples: +# % ::ip::ipToLayer2Multicast 224.0.0.2 +# 01.00.5e.00.00.02 +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::ipToLayer2Multicast { ipaddr } { + regexp "\[0-9\]+\.(\[0-9\]+)\.(\[0-9\]+)\.(\[0-9\]+)" $ipaddr junk ip2 ip3 ip4 + #remove MSB of 2nd octet of IP address for mcast L2 addr + set mac2 [expr {$ip2 & 127}] + return [format "01.00.5e.%02x.%02x.%02x" $mac2 $ip3 $ip4] +} + + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::ipHostFromPrefix +# +# Purpose: +# gives back a host address from a prefix +# +# Synopsis: +# ::ip::ipHostFromPrefix <prefix> [-exclude <list of prefixes>] +# +# Arguments: +# <prefix> +# prefix is <ipaddr>/<masklen> +# -exclude <list of prefixes> +# list if ipprefixes that host should not be in +# Return Values: +# ip address +# +# Description: +# +# Examples: +# %::ip::ipHostFromPrefix 1.1.1.5/24 +# 1.1.1.1 +# +# %::ip::ipHostFromPrefix 1.1.1.1/32 +# 1.1.1.1 +# +# +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::ipHostFromPrefix { prefix args } { + set mask [mask $prefix] + set ipaddr [prefix $prefix] + if {[llength $args]} { + array set opts $args + } else { + if {$mask==32} { + return $ipaddr + } else { + return [intToString [expr {[toHex $ipaddr] + 1} ]] + } + } + set format {-ipv4} + # if we got here, then options were set + if {[info exists opts(-exclude)]} { + #basic algo is: + # 1. throw away prefixes that are less specific that $prefix + # 2. of remaining pfx, throw away prefixes that do not overlap + # 3. run reducetoAggregates on specific nets + # 4. + + # 1. convert to hex format + set currHex [prefixToNative $prefix ] + set exclHex [prefixToNative $opts(-exclude) ] + # sort the prefixes by their mask, include the $prefix as a marker + # so we know from where to throw away prefixes + set sortedPfx [lsort -integer -index 1 [concat [list $currHex] $exclHex]] + # throw away prefixes that are less specific than $prefix + set specPfx [lrange $sortedPfx [expr {[lsearch -exact $sortedPfx $currHex] +1} ] end] + + #2. throw away non-overlapping prefixes + set specPfx [isOverlapNative -all -inline \ + [lindex $currHex 0 ] \ + [lindex $currHex 1 ] \ + $specPfx ] + #3. run reduce aggregates + set specPfx [reduceToAggregates $specPfx] + + #4 now have to pick an address that overlaps with $currHex but not with + # $specPfx + # 4.1 find the largest prefix w/ most specific mask and go to the next net + + + # current ats tcl does not allow this in one command, so + # for now just going to grab the last prefix (list is already sorted) + set sPfx [lindex $specPfx end] + set startPfx $sPfx + # add currHex to specPfx + set oChkPfx [concat $specPfx [list $currHex]] + + + set notcomplete 1 + set overflow 0 + while {$notcomplete} { + #::ipMore::log::debug "doing nextnet on $sPfx" + set nextNet [nextNet [lindex $sPfx 0] [lindex $sPfx 1]] + #::ipMore::log::debug "trying $nextNet" + if {$overflow && ($nextNet > $startPfx)} { + #we've gone thru the entire net and didn't find anything. + return -code error [msgcat::mc "ip host could not be found in %s" $prefix] + break + } + set oPfx [isOverlapNative -all -inline \ + $nextNet -1 \ + $oChkPfx + ] + switch -exact [llength $oPfx] { + 0 { + # no overlap at all. meaning we have gone beyond the bounds of + # $currHex. need to overlap and try again + #::ipMore::log::debug {ipHostFromPrefix: overlap done} + set overflow 1 + } + 1 { + #we've found what we're looking for. pick this address and exit + return [intToString $nextNet] + } + default { + # 2 or more overlaps, need to increment again + set sPfx [lindex $oPfx 0] + } + } + } + } +} + + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::reduceToAggregates +# +# Purpose: +# finds nets that overlap and filters out the more specifc nets +# +# Synopsis: +# ::ip::reduceToAggregates <prefixList> +# +# Arguments: +# <prefixList> +# prefixList a list in the from of +# is <ipaddr>/<masklen> or native format +# +# Return Values: +# non-overlapping ip prefixes +# +# Description: +# +# Examples: +# +# % ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 } +# 1.0.0.0/8 2.1.1.0/24 +# +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::reduceToAggregates { prefixList } { + #find out format of $prefixeList + set dotConv 0 + if {[llength [lindex $prefixList 0]]==1} { + #format is dotted form convert all prefixes to native form + set prefixList [ip::prefixToNative $prefixList] + set dotConv 1 + } + + set nonOverLapping $prefixList + while {1==1} { + set overlapFound 0 + set remaining $nonOverLapping + set nonOverLapping {} + while {[llength $remaining]} { + set current [lvarpop remaining] + set overLap [ip::isOverlapNative [lindex $current 0] [lindex $current 1] $remaining] + if {$overLap} { + #there was a overlap find out which prefix has a the smaller mask, and keep that one + if {[lindex $current 1] > [lindex [lindex $remaining [expr {$overLap -1}]] 1]} { + #current has more restrictive mask, throw that prefix away + # keep other prefix + lappend nonOverLapping [lindex $remaining [expr {$overLap -1}]] + } else { + lappend nonOverLapping $current + } + lvarpop remaining [expr {$overLap -1}] + set overlapFound 1 + } else { + #no overlap, keep all prefixes, don't touch the stuff in + # remaining, it is needed for other overlap checking + lappend nonOverLapping $current + } + } + if {$overlapFound==0} {break} + } + if {$dotConv} {return [nativeToPrefix $nonOverLapping]} + return $nonOverLapping +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::longestPrefixMatch +# +# Purpose: +# given host IP finds longest prefix match from set of prefixes +# +# Synopsis: +# ::ip::longestPrefixMatch <ipaddr> <prefixList> [-ipv4] +# +# Arguments: +# <prefixList> +# is list of <ipaddr> in native or dotted form +# <ipaddr> +# ip address in <ipprefix> format, dotted form, or integer form +# -ipv4 +# the provided integer format addresses are in ipv4 format (default) +# +# Return Values: +# <ipprefix> that is the most specific match to <ipaddr> +# +# Description: +# +# Examples: +# % ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.0/28 } +# 1.1.1.0/28 +# +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header + +proc ::ip::longestPrefixMatch { ipaddr prefixList args} { + set ipv4 1 + while {[llength $args]} { + switch -- [lindex $args 0] { + -ipv4 {set args [lrange $args 1 end]} + default { + return -code error [msgcat::mc "option %s not supported" [lindex $args 0]] + } + } + } + #find out format of prefixes + set dotConv 0 + if {[llength [lindex $prefixList 0]]==1} { + #format is dotted form convert all prefixes to native form + set prefixList [ip::prefixToNative $prefixList] + set dotConv 1 + } + #sort so that most specific prefix is in the front + if {[llength [lindex [lindex $prefixList 0] 1]]} { + set prefixList [lsort -decreasing -integer -index 1 $prefixList] + } else { + set prefixList [list $prefixList] + } + if {![string is integer -strict $ipaddr]} { + set ipaddr [prefixToNative $ipaddr] + } + set best [ip::isOverlapNative -inline \ + [lindex $ipaddr 0] [lindex $ipaddr 1] $prefixList] + if {$dotConv && [llength $best]} { + return [nativeToPrefix $best] + } + return $best +} + +##Procedure Header +# Copyright (c) 2004 Cisco Systems, Inc. +# +# Name: +# ::ip::cmpDotIP +# +# Purpose: +# helper function for dotted ip address for use in lsort +# +# Synopsis: +# ::ip::cmpDotIP <ipaddr1> <ipaddr2> +# +# Arguments: +# <ipaddr1> <ipaddr2> +# prefix is in dotted ip address format +# +# Return Values: +# -1 if ipaddr1 is less that ipaddr2 +# 1 if ipaddr1 is more that ipaddr2 +# 0 if ipaddr1 and ipaddr2 are equal +# +# Description: +# +# Examples: +# % lsort -command ip::cmpDotIP {1.0.0.0 2.2.0.0 128.0.0.0 3.3.3.3} +# 1.0.0.0 2.2.0.0 3.3.3.3 128.0.0.0 +# +# Sample Input: +# +# Sample Output: +# Notes: +# +# See Also: +# +# End of Header +# ip address in <ipprefix> format, dotted form, or integer form + +if {![package vsatisfies [package provide Tcl] 8.4]} { + # 8.3+ + proc ip::cmpDotIP {ipaddr1 ipaddr2} { + # convert dotted to list of integers + set ipaddr1 [split $ipaddr1 .] + set ipaddr2 [split $ipaddr2 .] + foreach a $ipaddr1 b $ipaddr2 { + #ipMore::log::debug "$ipInt1 $ipInt2" + if { $a < $b} { + return -1 + } elseif {$a >$b} { + return 1 + } + } + return 0 + } +} else { + # 8.4+ + proc ip::cmpDotIP {ipaddr1 ipaddr2} { + # convert dotted to decimal + set ipInt1 [::ip::toHex $ipaddr1] + set ipInt2 [::ip::toHex $ipaddr2] + #ipMore::log::debug "$ipInt1 $ipInt2" + if { $ipInt1 < $ipInt2} { + return -1 + } elseif {$ipInt1 >$ipInt2 } { + return 1 + } else { + return 0 + } + } +} + +# Populate the array "maskLenToDotted" for fast lookups of mask to +# dotted form. + +namespace eval ::ip { + variable maskLenToDotted + variable x + + for {set x 0} {$x <33} {incr x} { + set maskLenToDotted($x) [intToString [maskToInt $x]] + } + unset x +} + +##Procedure Header +# Copyright (c) 2015 Martin Heinrich <martin.heinrich@frequentis.com> +# +# Name: +# ::ip::distance +# +# Purpose: +# Calculate integer distance between two IPv4 addresses (dotted form or int) +# +# Synopsis: +# distance <ipaddr1> <ipaddr2> +# +# Arguments: +# <ipaddr1> +# <ipaddr2> +# ip address +# +# Return Values: +# integer distance (addr2 - addr1) +# +# Description: +# +# Examples: +# % ::ip::distance 1.1.1.0 1.1.1.5 +# 5 +# +# Sample Input: +# +# Sample Output: + +proc ::ip::distance {ip1 ip2} { + # use package ip for normalization + # XXX does not support ipv6 + expr {[toInteger $ip2]-[toInteger $ip1]} +} + +##Procedure Header +# Copyright (c) 2015 Martin Heinrich <martin.heinrich@frequentis.com> +# +# Name: +# ::ip::nextIp +# +# Purpose: +# Increment the given IPv4 address by an offset. +# Complement to 'distance'. +# +# Synopsis: +# nextIp <ipaddr> ?<offset>? +# +# Arguments: +# <ipaddr> +# ip address +# +# <offset> +# The integer to increment the address by. +# Default is 1. +# +# Return Values: +# The increment ip address. +# +# Description: +# +# Examples: +# % ::ip::nextIp 1.1.1.0 5 +# 1.1.1.5 +# +# Sample Input: +# +# Sample Output: + +proc ::ip::nextIp {ip {offset 1}} { + set int [toInteger $ip] + incr int $offset + set prot {} + # TODO if ipv4 then set prot -ipv4, but + # XXX intToString has -ipv4, but never returns ipv6 + intToString $int ;# 8.5-ism, avoid: {*}$prot +} diff --git a/tcllib/modules/dns/ipMore.test b/tcllib/modules/dns/ipMore.test new file mode 100644 index 0000000..246be8d --- /dev/null +++ b/tcllib/modules/dns/ipMore.test @@ -0,0 +1,803 @@ +# ip.test -*- tcl -*- +# +# Tests for the Tcllib ip package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: ipMore.test,v 1.4 2006/10/09 21:41:40 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 2.2 + +testing { + useLocal ip.tcl ip +} + +# ------------------------------------------------------------------------- + +::tcltest::testConstraint Cextension \ + [llength [info commands ::ip::prefixToNativec]] + +# ------------------------------------------------------------------------- + +logger::setlevel critical + +namespace eval ::ip::test { + + ::tcltest::test load-1 {} -setup { + } -constraints { + } -cleanup { + } -body { + } -result {} + + ::tcltest::test ip::prefixToNativeTcl-1 {} -setup { + } -constraints { + } -cleanup { + } -body { + ip::prefixToNativeTcl 1.1.1.0/24 + } -result {0x01010100 0xffffff00} + + ::tcltest::test ip::prefixToNativeTcl-2 {} -setup { + } -constraints { + } -cleanup { + } -body { + ip::prefixToNativeTcl {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.1/32} + } -result {{0x01010100 0xffffff00} {0x01000000 0xff000000} {0x02010100 0xffffff00} {0x01010101 0xffffffff}} + + ::tcltest::test ip::prefixToNativeTcl-3 {} -setup { + } -constraints { + } -cleanup { + } -body { + ip::prefixToNativeTcl "" + } -result {} + + ::tcltest::test ip::prefixToNativec-1 {} -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + ip::prefixToNativec 1.1.1.0/24 + } -result {0x01010100 0xFFFFFF00} + + ::tcltest::test ip::prefixToNativec-2 {} -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + ip::prefixToNativec 1.1.1.0/255.255.255.0 + } -result {0x01010100 0xFFFFFF00} + + ::tcltest::test ip::prefixToNativec-3 {} -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + ip::prefixToNativec 1.1.1.0 + } -result {0x01010100 0xFFFFFFFF} + + ::tcltest::test ip::prefixToNativec-4 {} -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + ip::prefixToNativec {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.1/32} + } -result {{0x01010100 0xFFFFFF00} {0x01000000 0xFF000000} {0x02010100 0xFFFFFF00} {0x01010101 0xFFFFFFFF}} + + ::tcltest::test ip::prefixToNativec-5 {} -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + ip::prefixToNativec {1.1.1.0/24 1.0AAF0/8 2.1.1.0/24 1.1.1.1/32} + } -result {} -returnCodes error + + ::tcltest::test ip::prefixToNativec-6 {} -setup { + } -constraints { + Cextension + } -cleanup { + unset y + } -body { + set y {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.1/32} + ip::prefixToNativec $y + lindex $y 0 + } -result {1.1.1.0/24} + + ::tcltest::test ip::nativeToPrefix-1 { + single address test + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4 + } -result {1.1.1.0/24} + + ::tcltest::test ip::nativeToPrefix-2 { + multi list test + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nativeToPrefix {{0x01010100 0xffffff00} {0x01000000 0xff000000} {0x02010100 0xffffff00} {0x01010101 0xffffffff}} -ipv4 + } -result {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.1/32} + + ::tcltest::test ip::nativeToPrefix-3 { + 0 test + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nativeToPrefix {0x0 0x0} -ipv4 + } -result {0.0.0.0/0} + + ::tcltest::test ip::nativeToPrefix-4 { + 0 test, check default is ipv4 + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nativeToPrefix {0x0 0x0} + } -result {0.0.0.0/0} + + ::tcltest::test ip::toInteger-1 {} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::toInteger 1.1.1.0 + } -result {16843008} + + ::tcltest::test ::ip::toHex-1 {} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::toHex 1.1.1.0 + } -result {0x01010100} + + + + + + ::tcltest::test ::ip:broadcastAddress-1 { + dotted form + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::broadcastAddress 1.1.1.0/24 + } -result {1.1.1.255} + + ::tcltest::test ::ip:broadcastAddress-2 { + native form + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::broadcastAddress {0x01010100 0xffffff00} + } -result {0x010101ff} + + + ::tcltest::test ::ip:maskToLength-1 { + hexform + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::maskToLength 0xffffff00 -ipv4 + } -result {24} + + ::tcltest::test ::ip:maskToLength-2 { + dotted form + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::maskToLength 255.255.255.0 + } -result {24} + + + ::tcltest::test ::ip:maskToLength-3 { + zero form + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::maskToLength 0.0.0.0 + } -result {0} + + ::tcltest::test ::ip:maskToLength-4 { + zero form + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::maskToLength 0x0 -ipv4 + } -result {0} + + ::tcltest::test ::ip:maskToLength-5 { + zero form, defualt is ipv4 + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::maskToLength 0x0 + } -result {0} + + + ::tcltest::test ::ip::lengthToMask-1 { + dotted form + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::lengthToMask 24 -ipv4 + } -result {255.255.255.0} + + ::tcltest::test ::ip::lengthToMask-2 { + dotted form, default is ipv4 + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::lengthToMask 24 + } -result {255.255.255.0} + + ::tcltest::test ::ip:maskToInt-1 { + integer form + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::maskToInt 32 + } -result {4294967295} + + + ::tcltest::test ::ip:maskToInt-2 { + dotted form + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::maskToInt 255.255.255.255 + } -result {4294967295} + + ::tcltest::test ::ip:intToString-1 { + convert 255.255.255.255 + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::intToString 4294967295 -ipv4 + } -result {255.255.255.255} + + ::tcltest::test ::ip:intToString-2 { + convert hex to string + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::intToString 0x01010101 -ipv4 + } -result {1.1.1.1} + + ::tcltest::test ::ip:intToString-3 { + convert hex to string, default is ipv4 + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::intToString 0x01010101 + } -result {1.1.1.1} + + ::tcltest::test ::ip:nextNet-1 { + 255.255.255.0/32 -> 255.255.255.1 + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::nextNet 0xffffff00 0xffffffff -ipv4 + } -result {0xffffff01} + + ::tcltest::test ::ip:nextNet-2 { + 1.0.0.0/24 -> 1.0.1.0/24 + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nextNet 0x01000000 0xffffff00 -ipv4 + } -result {0x01000100} + + + ::tcltest::test ::ip:nextNet-3 { + 1.1.28.0/24 -> 1.1.29.0 + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nextNet 0x01011c00 0xffffff00 -ipv4 + } -result {0x01011d00} + + ::tcltest::test ::ip:nextNet-4 { + 1.1.28.0/24 -> 1.1.29.0 by 1 + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nextNet 0x01011c00 0xffffff00 1 -ipv4 + } -result {0x01011d00} + + + ::tcltest::test ::ip:nextNet-5 { + 1.1.1.1/32 -> 1.1.29.0 by 2 + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nextNet 0x01010101 [ip::maskToInt 32] 2 -ipv4 + } -result {0x01010103} + + ::tcltest::test ::ip:nextNet-6 { + 1.1.1.1/32 -> 1.1.29.0 by 2 + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nextNet 1.1.1.1 32 2 + } -result {0x01010103} + + ::tcltest::test ::ip:nextNet-7 { + 1.1.1.1/32 -> 1.1.29.0 by 2 + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nextNet 1.1.1.1 255.255.255.255 2 + } -result {0x01010103} + + ::tcltest::test ::ip:nextNet-8 { + 1.1.1.1/32 -> 1.1.29.0 by 2, default is ipv4 + } -setup { + } -constraints { + } -cleanup { + } -body { + ip::nextNet 0x01010101 [ip::maskToInt 32] 2 + } -result {0x01010103} + + ::tcltest::test ::ip:isOverlap-1 { + no overlap test + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 + } -result {0} + + + ::tcltest::test ::ip:isOverlap-2 { + yes overlap test + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32 + } -result {1} + + + ::tcltest::test ::ip:isOverlapNative-1 { + no overlap test + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::isOverlapNative -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff}} + } -result {0} + + + ::tcltest::test ::ip:isOverlapNative-2 { + yes overlap test + } -setup { + } -constraints { + } -cleanup { + } -body { + set a [::ip::isOverlapNative -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}} ] + expr $a > 0 + } -result {1} + + ::tcltest::test ::ip:isOverlapNativeTcl-1 { + no overlap test + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::isOverlapNativeTcl -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff}} + } -result {0} + + + ::tcltest::test ::ip:isOverlapNativeTcl-2 { + yes overlap test + } -setup { + } -constraints { + } -cleanup { + } -body { + set a [::ip::isOverlapNativeTcl -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}] + expr $a > 0 + } -result {1} + + ::tcltest::test ::ip:isOverlapNativeTcl-3 { + yes overlap test + } -setup { + } -constraints { + } -cleanup { + } -body { + set a [::ip::isOverlapNativeTcl -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}] + } -result {2} + + ::tcltest::test ::ip:isOverlapNativeTcl-4 { + -all overlap test + } -setup { + } -constraints { + } -cleanup { + } -body { + set a [::ip::isOverlapNativeTcl -ipv4 -all 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + {0x01010101 0xffffffff} + {0x01010102 0xffffffff} + }] + } -result {2 3} + + ::tcltest::test ::ip:isOverlapNativeTcl-5 { + -all overlap test with -inline + } -setup { + } -constraints { + } -cleanup { + } -body { + set a [::ip::isOverlapNativeTcl -ipv4 -all -inline 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + {0x01010101 0xffffffff} + {0x01010102 0xffffffff} + }] + } -result {{0x01010101 0xffffffff} {0x01010102 0xffffffff}} + + ::tcltest::test ::ip:isOverlapNativeTcl-6 { + test with -inline + } -setup { + } -constraints { + } -cleanup { + } -body { + set a [::ip::isOverlapNativeTcl -ipv4 -inline 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + {0x01010101 0xffffffff} + {0x01010102 0xffffffff} + }] + } -result {{0x01010101 0xffffffff}} + + ::tcltest::test ::ip:isOverlapNativeTcl-7 { + test with -all -inline one element return + } -setup { + } -constraints { + } -cleanup { + } -body { + set a [::ip::isOverlapNativeTcl -ipv4 -all -inline 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + {0x01010101 0xffffffff} + }] + } -result {{0x01010101 0xffffffff}} + + ::tcltest::test ::ip:isOverlapNativeTcl-8 { + test with -inline + } -setup { + } -constraints { + } -cleanup { + } -body { + set a [::ip::isOverlapNativeTcl -ipv4 -inline 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + }] + } -result {} + + ::tcltest::test ::ip:isOverlapNativec-1 { + no overlap test + } -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + ::ip::isOverlapNativec -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff}} + } -result {0} + + + ::tcltest::test ::ip:isOverlapNativec-2 { + yes overlap test + } -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + set a [::ip::isOverlapNativec -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}] + expr $a > 0 + } -result {1} + + ::tcltest::test ::ip:isOverlapNativec-3 { + yes overlap test + } -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + set a [::ip::isOverlapNativec -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}] + } -result {2} + + ::tcltest::test ::ip:isOverlapNativec-4 { + -all overlap test + } -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + set a [::ip::isOverlapNativec -ipv4 -all 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + {0x01010101 0xffffffff} + {0x01010102 0xffffffff} + }] + } -result {2 3} + + ::tcltest::test ::ip:isOverlapNativec-5 { + -all overlap test with -inline + } -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + set a [::ip::isOverlapNativec -ipv4 -all -inline 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + {0x01010101 0xffffffff} + {0x01010102 0xffffffff} + }] + } -result {{0x01010101 0xffffffff} {0x01010102 0xffffffff}} + + ::tcltest::test ::ip:isOverlapNativec-6 { + test with -inline + } -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + set a [::ip::isOverlapNativec -ipv4 -inline 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + {0x01010101 0xffffffff} + {0x01010102 0xffffffff} + }] + } -result {{0x01010101 0xffffffff}} + + ::tcltest::test ::ip:isOverlapNativec-7 { + test with -all -inline one element return + } -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + set a [::ip::isOverlapNativec -ipv4 -all -inline 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + {0x01010101 0xffffffff} + }] + } -result {{0x01010101 0xffffffff}} + + ::tcltest::test ::ip:isOverlapNativec-8 { + test with -inline with not overlaps, returns nothing + } -setup { + } -constraints { + Cextension + } -cleanup { + } -body { + set a [::ip::isOverlapNativec -ipv4 -inline 0x01010100 0xffffff00 { + {0x02010001 0xffffffff} + }] + } -result {} + + + + ::tcltest::test ::ip:ipToLayer2Multicast-1 { + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::ipToLayer2Multicast 224.0.0.2 + } -result {01.00.5e.00.00.02} + + ::tcltest::test ::ip:ipHostFromPrefix-1 { + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::ipHostFromPrefix 1.1.1.1/32 + } -result {1.1.1.1} + + ::tcltest::test ::ip:ipHostFromPrefix-2 { + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::ipHostFromPrefix 1.1.1.0/24 + } -result {1.1.1.1} + + ::tcltest::test ::ip:ipHostFromPrefix-3 { + } -setup { + } -constraints { + } -cleanup { + unset x + unset exlList + unset testPrefix + } -body { + set testPrefix 1.1.1.0/24 + set exlList { + 1.1.1.18/32 + 1.1.1.13/32 + 1.1.1.17/32 + 2.1.1.0/24 + 1.1.0.0/16 + 1.1.1.12/30 + 1.1.1.4/30 + } + set x [::ip::ipHostFromPrefix $testPrefix -exclude $exlList ] + ip::longestPrefixMatch $x [concat $exlList [list $testPrefix]] -ipv4 + } -result {1.1.1.0/24} + + ::tcltest::test ::ip:reduceToAggregates { + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 } + } -result {1.0.0.0/8 2.1.1.0/24} + + ::tcltest::test ::ip:longestPrefixMatch-1 { + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::longestPrefixMatch 1.1.1.1/32 {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 } -ipv4 + } -result {1.1.1.1/32} + + ::tcltest::test ::ip:longestPrefixMatch-2 { + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.0/28 } -ipv4 + } -result {1.1.1.0/28} + + ::tcltest::test ::ip:longestPrefixMatch-3 { + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::longestPrefixMatch 1.1.1.1 {2.1.1.0/24 2.0.0.0/8} -ipv4 + } -result {} + + ::tcltest::test ::ip:longestPrefixMatch-4 { + } -setup { + } -constraints { + } -cleanup { + unset x + unset y + } -body { + set x 128.0.0.2 + set y {1.0.0.0/8 2.2.0.0/16 128.0.0.0/16 3.3.3.3/32} + ::ip::longestPrefixMatch $x $y -ipv4 + # there was a problem when using varibles, it looked like + # tcl was modifying the original variables in an + # upvar fashion + ::ip::longestPrefixMatch $x $y -ipv4 + } -result {128.0.0.0/16} + + ::tcltest::test ::ip:longestPrefixMatch-5 { + check where the match list is only a single prefix (non-match case) + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::longestPrefixMatch 128.0.0.2 {1.0.0.0/8} -ipv4 + } -result {} + + ::tcltest::test ::ip:longestPrefixMatch-6 { + check where the match list is only a single prefix (match case) + } -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::longestPrefixMatch 128.0.0.2 {128.0.0.0/8} -ipv4 + } -result {128.0.0.0/8} + + ::tcltest::test ::ip:cmpDotIP-1 { + test sorting of cmpDotIP + } -setup { + set iplist {1.0.0.0 2.2.0.0 128.0.0.0 3.3.3.3} + } -constraints { + } -cleanup { + unset iplist + } -body { + set a [lsort -command ip::cmpDotIP $iplist] + } -result {1.0.0.0 2.2.0.0 3.3.3.3 128.0.0.0} + + + ::tcltest::test ip::distance-1 {basic distance} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::distance 1.1.1.0 1.1.1.5 + } -result 5 + + ::tcltest::test ip::distance-2 {distance, not enough args} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::distance + } -returnCodes error -result {wrong # args: should be "::ip::distance ip1 ip2"} + + ::tcltest::test ip::distance-3 {distance, too many args} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::distance 1.1.1.1 1.1.1.5 1.1.1.19 + } -returnCodes error -result {wrong # args: should be "::ip::distance ip1 ip2"} + + + ::tcltest::test ip::nextIp-1 {basic nextIp} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::nextIp 1.1.1.0 5 + } -result 1.1.1.5 + + ::tcltest::test ip::nextIp-2 {nextIp, not enough args} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::nextIp + } -returnCodes error -result {wrong # args: should be "::ip::nextIp ip ?offset?"} + + ::tcltest::test ip::nextIp-3 {nextIp, too many args} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::nextIp 1.1.1.1 1.1.1.5 1.1.1.19 + } -returnCodes error -result {wrong # args: should be "::ip::nextIp ip ?offset?"} + + foreach {n delta ip1 ip2} { + 0 4294967295 0.0.0.0 255.255.255.255 + 1 -4294967295 255.255.255.255 0.0.0.0 + 2 7709 10.11.12.13 10.11.42.42 + 3 -7709 10.11.42.42 10.11.12.13 + 4 1994195353 54.229.115.42 173.194.116.195 + 5 -1994195353 173.194.116.195 54.229.115.42 + } { + ::tcltest::test ip::distance-4.$n {basic distance} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::distance $ip1 $ip2 + } -result $delta + + ::tcltest::test ip::nextIp-4.$n {basic nextIp} -setup { + } -constraints { + } -cleanup { + } -body { + ::ip::nextIp $ip1 $delta + } -result $ip2 + } + +} + +namespace delete ::ip::test + +testsuiteCleanup + +# +# ;;; Local Variables: +# ;;; mode: tcl +# ;;; indent-tabs-mode:nil +# ;;; End: diff --git a/tcllib/modules/dns/ipMoreC.tcl b/tcllib/modules/dns/ipMoreC.tcl new file mode 100644 index 0000000..a90b4b9 --- /dev/null +++ b/tcllib/modules/dns/ipMoreC.tcl @@ -0,0 +1,242 @@ +# 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 diff --git a/tcllib/modules/dns/msgs/en.msg b/tcllib/modules/dns/msgs/en.msg new file mode 100644 index 0000000..813cb9e --- /dev/null +++ b/tcllib/modules/dns/msgs/en.msg @@ -0,0 +1,8 @@ +# -*- tcl -*- +package require msgcat +namespace import ::msgcat::* + +mcset en "option %s not supported" "option %s not supported" +mcset en "option %s not supported" "option %s not supported" +mcset en "not an ip mask: %s" "not an ip mask: %s" +mcset en "ip host could not be found in %s" "ip host could not be found in %s" diff --git a/tcllib/modules/dns/pkgIndex.tcl b/tcllib/modules/dns/pkgIndex.tcl new file mode 100644 index 0000000..5f03e9c --- /dev/null +++ b/tcllib/modules/dns/pkgIndex.tcl @@ -0,0 +1,9 @@ +# pkgIndex.tcl - +# +# $Id: pkgIndex.tcl,v 1.21 2010/08/16 17:35:18 andreas_kupries Exp $ + +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded dns 1.3.5 [list source [file join $dir dns.tcl]] +package ifneeded resolv 1.0.3 [list source [file join $dir resolv.tcl]] +package ifneeded ip 1.3 [list source [file join $dir ip.tcl]] +package ifneeded spf 1.1.1 [list source [file join $dir spf.tcl]] diff --git a/tcllib/modules/dns/resolv.tcl b/tcllib/modules/dns/resolv.tcl new file mode 100644 index 0000000..503be13 --- /dev/null +++ b/tcllib/modules/dns/resolv.tcl @@ -0,0 +1,249 @@ +# resolv.tcl - Copyright (c) 2002 Emmanuel Frecon <emmanuel@sics.se> +# +# Original Author -- Emmanuel Frecon - emmanuel@sics.se +# Modified by Pat Thoyts <patthoyts@users.sourceforge.net> +# +# A super module on top of the dns module for host name resolution. +# There are two services provided on top of the regular Tcl library: +# Firstly, this module attempts to automatically discover the default +# DNS server that is setup on the machine that it is run on. This +# server will be used in all further host resolutions. Secondly, this +# module offers a rudimentary cache. The cache is rudimentary since it +# has no expiration on host name resolutions, but this is probably +# enough for short lived applications. +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +package require dns 1.0; # tcllib 1.3 + +namespace eval ::resolv { + namespace export resolve init ignore hostname + + variable R + if {![info exists R]} { + array set R { + initdone 0 + dns "" + dnsdefault "" + ourhost "" + search {} + } + } +} + +# ------------------------------------------------------------------------- +# Command Name -- ignore +# Original Author -- Emmanuel Frecon - emmanuel@sics.se +# +# Remove a host name resolution from the cache, if present, so that the +# next resolution will query the DNS server again. +# +# Arguments: +# hostname - Name of host to remove from the cache. +# +proc ::resolv::ignore { hostname } { + variable Cache + catch {unset Cache($hostname)} + return +} + +# ------------------------------------------------------------------------- +# Command Name -- init +# Original Author -- Emmanuel Frecon - emmanuel@sics.se +# +# Initialise this module with a known host name. This host (not mandatory) +# will become the default if the library was not able to find a DNS server. +# This command can be called several times, its effect is double: actively +# looking for the default DNS server setup on the running machine; and +# emptying the host name resolution cache. +# +# Arguments: +# defaultdns - Default DNS server +# +proc ::resolv::init { {defaultdns ""} {search {}}} { + variable R + variable Cache + + # Clean the resolver cache + catch {unset Cache} + + # Record the default DNS server and search list. + set R(dnsdefault) $defaultdns + set R(search) $search + + # Now do some intelligent lookup. We do this on the current + # hostname to get a chance to get back some (full) information on + # ourselves. A previous version was using 127.0.0.1, not sure + # what is best. + set res [catch [list exec nslookup [info hostname]] lkup] + if { $res == 0 } { + set l [split $lkup] + set nl "" + foreach e $l { + if { [string length $e] > 0 } { + lappend nl $e + } + } + + # Now, a lot of mixture to arrange so that hostname points at the + # DNS server that we should use for any further request. This + # code is complex, but was actually tested behind a firewall + # during the SITI Winter Conference 2003. There, strangly, + # nslookup returned an error but a DNS server was actually setup + # correctly... + set hostname "" + set len [llength $nl] + for { set i 0 } { $i < $len } { incr i } { + set e [lindex $nl $i] + if { [string match -nocase "*server*" $e] } { + set hostname [lindex $nl [expr {$i + 1}]] + if { [string match -nocase "UnKnown" $hostname] } { + set hostname "" + } + break + } + } + + if { $hostname != "" } { + set R(dns) $hostname + } else { + for { set i 0 } { $i < $len } { incr i } { + set e [lindex $nl $i] + if { [string match -nocase "*address*" $e] } { + set hostname [lindex $nl [expr {$i + 1}]] + break + } + } + if { $hostname != "" } { + set R(dns) $hostname + } + } + } + + if {$R(dns) == ""} { + set R(dns) $R(dnsdefault) + } + + + # Start again to find our full name + set ourhost "" + if {$res == 0} { + set dot [string first "." [info hostname]] + if { $dot < 0 } { + for { set i 0 } { $i < $len } { incr i } { + set e [lindex $nl $i] + if { [string match -nocase "*name*" $e] } { + set ourhost [lindex $nl [expr {$i + 1}]] + break + } + } + if { $ourhost == "" } { + if { ! [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } { + set dot [string first "." $hostname] + set ourhost [format "%s%s" [info hostname] \ + [string range $hostname $dot end]] + } + } + } else { + set ourhost [info hostname] + } + } + + if {$ourhost == ""} { + set R(ourhost) [info hostname] + } else { + set R(ourhost) $ourhost + } + + + set R(initdone) 1 + + return $R(dns) +} + +# ------------------------------------------------------------------------- +# Command Name -- resolve +# Original Author -- Emmanuel Frecon - emmanuel@sics.se +# +# Resolve a host name to an IP address. This is a wrapping procedure around +# the basic services of the dns library. +# +# Arguments: +# hostname - Name of host +# +proc ::resolv::resolve { hostname } { + variable R + variable Cache + + # Initialise if not already done. Auto initialisation cannot take + # any known DNS server (known to the caller) + if { ! $R(initdone) } { init } + + # Check whether this is not simply a raw IP address. What about + # IPv6 ?? + # - We don't have sockets in Tcl for IPv6 protocols - [PT] + # + if { [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } { + return $hostname + } + + # Look for hostname in the cache, if found return. + if { [array names ::resolv::Cache $hostname] != "" } { + return $::resolv::Cache($hostname) + } + + # Scream if we don't have any DNS server setup, since we cannot do + # anything in that case. + if { $R(dns) == "" } { + return -code error "No dns server provided" + } + + set R(retries) 0 + set ip [Resolve $hostname] + + # And store the result of resolution in our cache for further use. + set Cache($hostname) $ip + + return $ip +} + +# Description: +# Attempt to resolve hostname via DNS. If the name cannot be resolved then +# iterate through the search list appending each domain in turn until we +# get one that succeeds. +# +proc ::resolv::Resolve {hostname} { + variable R + set t [::dns::resolve $hostname -server $R(dns)] + ::dns::wait $t; # wait with event processing + set status [dns::status $t] + if {$status == "ok"} { + set ip [lindex [::dns::address $t] 0] + ::dns::cleanup $t + } elseif {$status == "error" + && [::dns::errorcode $t] == 3 + && $R(retries) < [llength $R(search)]} { + ::dns::cleanup $t + set suffix [lindex $R(search) $R(retries)] + incr R(retries) + set new [lindex [split $hostname .] 0].[string trim $suffix .] + set ip [Resolve $new] + } else { + set err [dns::error $t] + ::dns::cleanup $t + return -code error "dns error: $err" + } + return $ip +} + +# ------------------------------------------------------------------------- + +package provide resolv 1.0.3 + +# ------------------------------------------------------------------------- +# Local Variables: +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/dns/spf.tcl b/tcllib/modules/dns/spf.tcl new file mode 100644 index 0000000..a752c54 --- /dev/null +++ b/tcllib/modules/dns/spf.tcl @@ -0,0 +1,528 @@ +# spf.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Sender Policy Framework +# +# http://www.ietf.org/internet-drafts/draft-ietf-marid-protocol-00.txt +# http://spf.pobox.com/ +# +# Some domains using SPF: +# pobox.org - mx, a, ptr +# oxford.ac.uk - include +# gnu.org - ip4 +# aol.com - ip4, ptr +# sourceforge.net - mx, a +# altavista.com - exists, multiple TXT replies. +# oreilly.com - mx, ptr, include +# motleyfool.com - include (looping includes) +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +package require Tcl 8.2; # tcl minimum version +package require dns; # tcllib 1.3 +package require logger; # tcllib 1.3 +package require ip; # tcllib 1.7 +package require struct::list; # tcllib 1.7 +package require uri::urn; # tcllib 1.3 + +namespace eval spf { + namespace export spf + + variable uid + if {![info exists uid]} {set uid 0} + + variable log + if {![info exists log]} { + set log [logger::init spf] + ${log}::setlevel warn + proc ${log}::stdoutcmd {level text} { + variable service + puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\ + $service $level\] $text" + } + } +} + +# ------------------------------------------------------------------------- +# ip : ip address of the connecting host +# domain : the domain to match +# sender : full sender email address +# +proc ::spf::spf {ip domain sender} { + variable log + + # 3.3: Initial processing + # If the sender address has no local part, set it to postmaster + set addr [split $sender @] + if {[set len [llength $addr]] == 0} { + return -code error -errorcode permanent "invalid sender address" + } elseif {$len == 1} { + set sender "postmaster@$sender" + } + + # 3.4: Record lookup + set spf [SPF $domain] + if {[string equal $spf none]} { + return $spf + } + + return [Spf $ip $domain $sender $spf] +} + +proc ::spf::Spf {ip domain sender spf} { + variable log + + # 3.4.1: Matching Version + if {![regexp {^v=spf(\d)\s+} $spf -> version]} { + return none + } + + ${log}::debug "$spf" + + if {$version != 1} { + return -code error -errorcode permanent \ + "version mismatch: we only understand SPF 1\ + this domain has provided version \"$version\"" + } + + set result ? + set seen_domains $domain + set explanation {denied} + + set directives [lrange [split $spf { }] 1 end] + foreach directive $directives { + set prefix [string range $directive 0 0] + if {[string equal $prefix "+"] || [string equal $prefix "-"] + || [string equal $prefix "?"] || [string equal $prefix "~"]} { + set directive [string range $directive 1 end] + } else { + set prefix "+" + } + + set cmd [string tolower [lindex [split $directive {:/=}] 0]] + set param [string range $directive [string length $cmd] end] + + if {[info commands ::spf::_$cmd] == {}} { + # 6.1 Unrecognised directives terminate processing + # but unknown modifiers are ignored. + if {[string match "=*" $param]} { + continue + } else { + set result unknown + break + } + } else { + set r [catch {::spf::_$cmd $ip $domain $sender $param} res] + if {$r} { + if {$r == 2} {return $res};# deal with return -code return + if {[string equal $res "none"] + || [string equal $res "error"] + || [string equal $res "unknown"]} { + return $res + } + return -code error "error in \"$cmd\": $res" + } + if {$res} { set result $prefix } + } + + ${log}::debug "$prefix $cmd\($param) -> $result" + if {[string equal $result "+"]} break + } + + return $result +} + +proc ::spf::loglevel {level} { + variable log + ${log}::setlevel $level +} + +# get a guaranteed unique and non-present token id. +proc ::spf::create_token {} { + variable uid + set id [incr uid] + while {[info exists [set token [namespace current]::$id]]} { + set id [incr uid] + } + return $token +} + +# ------------------------------------------------------------------------- +# +# SPF MECHANISM HANDLERS +# +# ------------------------------------------------------------------------- + +# 4.1: The "all" mechanism is a test that always matches. It is used as the +# rightmost mechanism in an SPF record to provide an explicit default +# +proc ::spf::_all {ip domain sender param} { + return 1 +} + +# 4.2: The "include" mechanism triggers a recursive SPF query. +# The domain-spec is expanded as per section 8. +proc ::spf::_include {ip domain sender param} { + variable log + upvar seen_domains Seen + + if {![string equal [string range $param 0 0] ":"]} { + return -code error "dubious parameters for \"include\"" + } + set r ? + set new_domain [Expand [string range $param 1 end] $ip $domain $sender] + if {[lsearch $Seen $new_domain] == -1} { + lappend Seen $new_domain + set spf [SPF $new_domain] + if {[string equal $spf none]} { + return $spf + } + set r [Spf $ip $new_domain $sender $spf] + } + return [string equal $r "+"] +} + +# 4.4: This mechanism matches if <ip> is one of the target's +# IP addresses. +# e.g: a:smtp.example.com a:mail.%{d} a +# +proc ::spf::_a {ip domain sender param} { + variable log + foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {} + if {[string length $testdomain] < 1} { + set testdomain $domain + } else { + set testdomain [Expand $testdomain $ip $domain $sender] + } + ${log}::debug " fetching A for $testdomain" + set dips [A $testdomain]; # get the IPs for the testdomain + foreach dip $dips { + ${log}::debug " compare: ${ip}/${bits} with ${dip}/${bits}" + if {[ip::equal $ip/$bits $dip/$bits]} { + return 1 + } + } + return 0 +} + +# 4.5: This mechanism matches if the <sending-host> is one of the MX hosts +# for a domain name. +# +proc ::spf::_mx {ip domain sender param} { + variable log + foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {} + if {[string length $testdomain] < 1} { + set testdomain $domain + } else { + set testdomain [Expand $testdomain $ip $domain $sender] + } + ${log}::debug " fetching MX for $testdomain" + set mxs [MX $testdomain] + + foreach mx $mxs { + set mx [lindex $mx 1] + set mxips [A $mx] + foreach mxip $mxips { + ${log}::debug " compare: ${ip}/${bits} with ${mxip}/${bits}" + if {[ip::equal $ip/$bits $mxip/$bits]} { + return 1 + } + } + } + return 0 +} + +# 4.6: This mechanism tests if the <sending-host>'s name is within a +# particular domain. +# +proc ::spf::_ptr {ip domain sender param} { + variable log + set validnames {} + if {[catch { set names [PTR $ip] } msg]} { + ${log}::debug " \"$ip\" $msg" + return 0 + } + foreach name $names { + set addrs [A $name] + foreach addr $addrs { + if {[ip::equal $ip $addr]} { + lappend validnames $name + continue + } + } + } + + ${log}::debug " validnames: $validnames" + set testdomain [Expand [string trimleft $param :] $ip $domain $sender] + if {$testdomain == {}} { + set testdomain $domain + } + foreach name $validnames { + if {[string match "*$testdomain" $name]} { + return 1 + } + } + + return 0 +} + +# 4.7: These mechanisms test if the <sending-host> falls into a given IP +# network. +# +proc ::spf::_ip4 {ip domain sender param} { + variable log + foreach {network bits} [ip::SplitIp [string range $param 1 end]] {} + ${log}::debug " compare ${ip}/${bits} to ${network}/${bits}" + if {[ip::equal $ip/$bits $network/$bits]} { + return 1 + } + return 0 +} + +# 4.6: These mechanisms test if the <sending-host> falls into a given IP +# network. +# +proc ::spf::_ip6 {ip domain sender param} { + variable log + foreach {network bits} [ip::SplitIp [string range $param 1 end]] {} + ${log}::debug " compare ${ip}/${bits} to ${network}/${bits}" + if {[ip::equal $ip/$bits $network/$bits]} { + return 1 + } + return 0 +} + +# 4.7: This mechanism is used to construct an arbitrary host name that is +# used for a DNS A record query. It allows for complicated schemes +# involving arbitrary parts of the mail envelope to determine what is +# legal. +# +proc ::spf::_exists {ip domain sender param} { + variable log + set testdomain [Expand [string range $param 1 end] $ip $domain $sender] + ${log}::debug " checking existence of '$testdomain'" + if {[catch {A $testdomain}]} { + return 0 + } + return 1 +} + +# 5.1: Redirected query +# +proc ::spf::_redirect {ip domain sender param} { + variable log + set new_domain [Expand [string range $param 1 end] $ip $domain $sender] + ${log}::debug ">> redirect to '$new_domain'" + set spf [SPF $new_domain] + if {![string equal $spf none]} { + set spf [Spf $ip $new_domain $sender $spf] + } + ${log}::debug "<< redirect returning '$spf'" + return -code return $spf +} + +# 5.2: Explanation +# +proc ::spf::_exp {ip domain sender param} { + variable log + set new_domain [string range $param 1 end] + set exp [TXT $new_domain] + set exp [Expand $exp $ip $domain $sender] + ${log}::debug "exp expanded to \"$exp\"" + # FIX ME: need to store this somehow. +} + +# 5.3: Sender accreditation +# +proc ::spf::_accredit {ip domain sender param} { + variable log + set accredit [Expand [string range $param 1 end] $ip $domain $sender] + ${log}::debug " accreditation '$accredit'" + # We are not using this at the moment. + return 0 +} + + +# 7: Macro expansion +# +proc ::spf::Expand {txt ip domain sender} { + variable log + set re {%\{[[:alpha:]](?:\d+)?r?[\+\-\.,/_=]*\}} + set txt [string map {\[ \\\[ \] \\\]} $txt] + regsub -all $re $txt {[ExpandMacro & $ip $domain $sender]} cmd + set cmd [string map {%% % %_ \ %- %20} $cmd] + return [subst -novariables $cmd] +} + +proc ::spf::ExpandMacro {macro ip domain sender} { + variable log + set re {%\{([[:alpha:]])(\d+)?(r)?([\+\-\.,/_=]*)\}} + set C {} ; set T {} ; set R {}; set D {} + set r [regexp $re $macro -> C T R D] + if {$R == {}} {set R 0} else {set R 1} + set res $macro + if {$r} { + set enc [string is upper $C] + switch -exact -- [string tolower $C] { + s { set res $sender } + l { + set addr [split $sender @] + if {[llength $addr] < 2} { + set res postmaster + } else { + set res [lindex $addr 0] + } + } + o { + set addr [split $sender @] + if {[llength $addr] < 2} { + set res $sender + } else { + set res [lindex $addr 1] + } + } + h - d { set res $domain } + i { + set res [ip::normalize $ip] + if {[ip::is ipv6 $res]} { + # Convert 0000:0001 to 0.1 + set t {} + binary scan [ip::Normalize $ip 6] c* octets + foreach octet $octets { + set hi [expr {($octet & 0xF0) >> 4}] + set lo [expr {$octet & 0x0F}] + lappend t [format %x $hi] [format %x $lo] + } + set res [join $t .] + } + } + v { + if {[ip::is ipv6 $ip]} { + set res ip6 + } else { + set res "in-addr" + } + } + c { + set res [ip::normalize $ip] + if {[ip::is ipv6 $res]} { + set res [ip::contract $res] + } + } + r { + set s [socket -server {} -myaddr [info host] 0] + set res [lindex [fconfigure $s -sockname] 1] + close $s + } + t { set res [clock seconds] } + } + if {$T != {} || $R || $D != {}} { + if {$D == {}} {set D .} + set res [split $res $D] + if {$R} { + set res [struct::list::Lreverse $res] + } + if {$T != {}} { + incr T -1 + set res [join [lrange $res end-$T end] $D] + } + set res [join $res .] + } + if {$enc} { + # URI encode the result. + set res [uri::urn::quote $res] + } + } + return $res +} + +# ------------------------------------------------------------------------- +# +# DNS helper procedures. +# +# ------------------------------------------------------------------------- + +proc ::spf::Resolve {domain type resultproc} { + if {[info commands $resultproc] == {}} { + return -code error "invalid arg: \"$resultproc\" must be a command" + } + set tok [dns::resolve $domain -type $type] + dns::wait $tok + set errorcode NONE + if {[string equal [dns::status $tok] "ok"]} { + set result [$resultproc $tok] + set code ok + } else { + set result [dns::error $tok] + set errorcode [dns::errorcode $tok] + set code error + } + dns::cleanup $tok + return -code $code -errorcode $errorcode $result +} + +# 3.4: Record lookup +proc ::spf::SPF {domain} { + set txt "" + if {[catch {Resolve $domain SPF ::dns::result} spf]} { + set code $::errorCode + ${log}::debug "error fetching SPF record: $r" + switch -exact -- $code { + 3 { return -code return [list - "Domain Does Not Exist"] } + 2 { return -code error -errorcode temporary $spf } + } + set txt none + } else { + foreach res $spf { + set ndx [lsearch $res rdata] + incr ndx + if {$ndx != 0} { + append txt [string range [lindex $res $ndx] 1 end] + } + } + } + return $txt +} + +proc ::spf::TXT {domain} { + set r [Resolve $domain TXT ::dns::result] + set txt "" + foreach res $r { + set ndx [lsearch $res rdata] + incr ndx + if {$ndx != 0} { + append txt [string range [lindex $res $ndx] 1 end] + } + } + return $txt +} + +proc ::spf::A {name} { + return [Resolve $name A ::dns::address] +} + + +proc ::spf::AAAA {name} { + return [Resolve $name AAAA ::dns::address] +} + +proc ::spf::PTR {addr} { + return [Resolve $addr A ::dns::name] +} + +proc ::spf::MX {domain} { + set r [Resolve $domain MX ::dns::name] + return [lsort -index 0 $r] +} + + +# ------------------------------------------------------------------------- + +package provide spf 1.1.1 + +# ------------------------------------------------------------------------- +# Local Variables: +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/dns/spf.test b/tcllib/modules/dns/spf.test new file mode 100644 index 0000000..3ba3bb9 --- /dev/null +++ b/tcllib/modules/dns/spf.test @@ -0,0 +1,244 @@ +# spf.test - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Tests for the Tcllib SPF package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: spf.test,v 1.8 2007/08/22 20:37:50 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +support { + useLocal dns.tcl dns; # tcllib 1.3 + useLocal ip.tcl ip; # tcllib 1.7 + use log/logger.tcl logger; # tcllib 1.3 + use struct/list.tcl struct::list; # tcllib 1.7 + use uri/uri.tcl uri; # - clear scheme registry + use uri/urn-scheme.tcl uri::urn; # tcllib 1.3 +} +testing { + useLocal spf.tcl spf +} + +# ------------------------------------------------------------------------- +# Helpers +# ------------------------------------------------------------------------- + +# These tests do not make any network calls. Instead we emulate the +# DNS query results wiht the following functions. + +foreach cmd [list SPF TXT A PTR MX] { + catch {rename ::spf::$cmd ::spf::tmp_$cmd} +} +proc ::spf::A {name} { return 192.0.2.3 } +proc ::spf::AAAA {name} { return 5f05:2000:80ad:5800::1 } +proc ::spf::PTR {addr} { return mx.example.org } +proc ::spf::MX {domain} { return {{10 mx1.example.org} {20 mx2.example.org}} } +proc ::spf::TXT {domain} { return "Only mail from local hosts permitted." } +proc ::spf::SPF {domain} { return "v=spf1 ?all" } +set email strong-bad@email.example.com + +# ------------------------------------------------------------------------- +# Tests +# ------------------------------------------------------------------------- + +test spf-1.1 {a directive: fallthrough} { + list [catch { + spf::Spf 192.168.0.1 email.example.com $::email "v=spf1 a -all" + } r] $r +} {0 -} + +test spf-1.2 {a directive: fallthrough} { + list [catch { + spf::Spf 192.168.0.1 email.example.com $::email "v=spf1 a ?all" + } r] $r +} {0 ?} + +test spf-1.3 {a directive: matching subnet} { + list [catch { + spf::Spf 192.0.2.1 email.example.com $::email "v=spf1 a/24 ?all" + } r] $r +} {0 +} + +test spf-1.4 {a directive: rejected matching subnet} { + list [catch { + spf::Spf 192.0.2.1 email.example.com $::email "v=spf1 -a/24 ?all" + } r] $r +} {0 ?} + +test spf-1.5 {a directive: match host} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email "v=spf1 a ?all" + } r] $r +} {0 +} + +test spf-2.1 {mx directive: fail mx} { + list [catch { + spf::Spf 192.168.0.1 email.example.com $::email "v=spf1 mx ?all" + } r] $r +} {0 ?} + +test spf-2.2 {mx directive: match mx subnet} { + list [catch { + spf::Spf 192.0.2.1 email.example.com $::email "v=spf1 mx/24 ?all" + } r] $r +} {0 +} + +test spf-2.3 {mx directive: fail match explict mx} { + list [catch { + spf::Spf 192.168.0.1 email.example.com $::email \ + "v=spf1 mx:mail.local.net ?all" + } r] $r +} {0 ?} + +test spf-2.4 {mx directive: match explict mx} { + list [catch { + spf::Spf 192.0.2.1 email.example.com $::email \ + "v=spf1 mx:mail.local.net/24 ?all" + } r] $r +} {0 +} + +test spf-2.5 {mx directive: match explict mx} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email \ + "v=spf1 mx:mx2.example.org ?all" + } r] $r +} {0 +} + +test spf-3.1 {ptr directive} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email "v=spf1 ptr ?all" + } r] $r +} {0 ?} + +test spf-3.2 {ptr directive} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email "v=spf1 ptr ?all" + } r] $r +} {0 ?} + +test spf-3.3 {ptr directive} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email \ + "v=spf1 ptr:example.org ?all" + } r] $r +} {0 +} + +test spf-3.4 {ptr directive} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email \ + "v=spf1 ptr:example.com ?all" + } r] $r +} {0 ?} + +test spf-4.1 {ip4 directive} { + list [catch { + spf::Spf 192.168.2.3 email.example.com $::email \ + "v=spf1 ip4:192.0.2.3/32 ?all" + } r] $r +} {0 ?} + +test spf-4.2 {ip4 directive} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email \ + "v=spf1 ip4:192.0.2.0/24 ?all" + } r] $r +} {0 +} + +test spf-4.3 {ip4 directive} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email \ + "v=spf1 ip4:192.0.0.0/16 ?all" + } r] $r +} {0 +} + +test spf-4.4 {ip4 directive} { + list [catch { + spf::Spf 192.255.2.3 email.example.com $::email \ + "v=spf1 ip4:192.0.0.0/16 ?all" + } r] $r +} {0 ?} + +test spf-4.5 {ip4 directive} { + list [catch { + spf::Spf 192.0.2.3 email.example.com $::email \ + "v=spf1 ip4:192.0/16 ?all" + } r] $r +} {0 +} + +# ------------------------------------------------------------------------- +# Macros language tests +# These are all taken from the specification document. + +set Data { + %{s} strong-bad@email.example.com + %{o} email.example.com + %{d} email.example.com + %{d4} email.example.com + %{d3} email.example.com + %{d2} example.com + %{d1} com + %{dr} com.example.email + %{d2r} example.email + %{l} strong-bad + %{l-} strong.bad + %{lr} strong-bad + %{lr-} bad.strong + %{l1r-} strong + %{ir}.%{v}._spf.%{d2} 3.2.0.192.in-addr._spf.example.com + %{lr-}.lp._spf.%{d2} bad.strong.lp._spf.example.com + + %{lr-}.lp.%{ir}.%{v}._spf.%{d2} + bad.strong.lp.3.2.0.192.in-addr._spf.example.com + + %{ir}.%{v}.%{l1r-}.lp._spf.%{d2} + 3.2.0.192.in-addr.strong.lp._spf.example.com + + %{d2}.trusted-domains.example.net + example.com.trusted-domains.example.net +} +set n 0 +foreach {macro check} $Data { + test spf-5.[incr n] [list spf macro language $macro] { + list [catch { + ::spf::Expand $macro 192.0.2.3 email.example.com $::email + } msg] $msg + } [list 0 $check] +} + +set Data { + %{ir}.%{v}._spf.%{d2} + 1.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.8.5.d.a.0.8.0.0.0.2.5.0.f.5.ip6._spf.example.com +} +set n 0 +foreach {macro check} $Data { + test spf-6.0 [list spf macro language ipv6] { + list [catch { + ::spf::Expand $macro 5f05:2000:80ad:5800::1 \ + email.example.com $::email + } msg] $msg + } [list 0 $check] +} + +# ------------------------------------------------------------------------- + +foreach cmd [list SPF TXT A PTR MX] { + catch {rename ::spf::$cmd {}} + catch {rename ::spf::tmp_$cmd ::spf::$cmd} +} + +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/dns/tcllib_dns.man b/tcllib/modules/dns/tcllib_dns.man new file mode 100644 index 0000000..c0cae7f --- /dev/null +++ b/tcllib/modules/dns/tcllib_dns.man @@ -0,0 +1,242 @@ +[vset DNS_VERSION 1.3.5] +[manpage_begin dns n [vset DNS_VERSION]] +[see_also resolver(5)] +[keywords DNS] +[keywords {domain name service}] +[keywords resolver] +[keywords {rfc 1034}] +[keywords {rfc 1035}] +[keywords {rfc 1886}] +[copyright {2002, Pat Thoyts}] +[moddesc {Domain Name Service}] +[titledesc {Tcl Domain Name Service Client}] +[category Networking] +[require Tcl 8.2] +[require dns [opt [vset DNS_VERSION]]] +[description] +[para] + +The dns package provides a Tcl only Domain Name Service client. You +should refer to (1) and (2) for information about the DNS protocol or +read resolver(3) to find out how the C library resolves domain names. + +The intention of this package is to insulate Tcl scripts +from problems with using the system library resolver for slow name servers. +It may or may not be of practical use. Internet name resolution is a +complex business and DNS is only one part of the resolver. You may +find you are supposed to be using hosts files, NIS or WINS to name a +few other systems. This package is not a substitute for the C library +resolver - it does however implement name resolution over DNS. + +The package also extends the package [package uri] to support DNS URIs +(4) of the form [uri dns:what.host.com] or +[uri dns://my.nameserver/what.host.com]. The [cmd dns::resolve] +command can handle DNS URIs or simple domain names as a query. + +[para] + +[emph Note:] The package defaults to using DNS over TCP +connections. If you wish to use UDP you will need to have the +[package tcludp] package installed and have a version that +correctly handles binary data (> 1.0.4). +This is available at [uri http://tcludp.sourceforge.net/]. +If the [package udp] package is present then UDP will be used by default. + +[section COMMANDS] + +[list_begin definitions] + +[call [cmd ::dns::resolve] [arg query] [opt [arg "options"]]] + +Resolve a domain name using the [term DNS] protocol. [arg query] is +the domain name to be lookup up. This should be either a fully +qualified domain name or a DNS URI. + +[list_begin definitions] +[def "[cmd -nameserver] [arg hostname] or [cmd -server] [arg hostname]"] + Specify an alternative name server for this request. +[def "[cmd -protocol] [arg tcp|udp]"] + Specify the network protocol to use for this request. Can be one of + [arg tcp] or [arg udp]. +[def "[cmd -port] [arg portnum]"] + Specify an alternative port. +[def "[cmd -search] [arg domainlist]"] +[def "[cmd -timeout] [arg milliseconds]"] + Override the default timeout. +[def "[cmd -type] [arg TYPE]"] + Specify the type of DNS record you are interested in. Valid values + are A, NS, MD, MF, CNAME, SOA, MB, MG, MR, NULL, WKS, PTR, HINFO, + MINFO, MX, TXT, SPF, SRV, AAAA, AXFR, MAILB, MAILA and *. + See RFC1035 for details about the return values. + See [uri http://spf.pobox.com/] about SPF. + See (3) about AAAA records and RFC2782 for details of SRV records. + +[def "[cmd -class] [arg CLASS]"] + Specify the class of domain name. This is usually IN but may be one + of IN for internet domain names, CS, CH, HS or * for any class. +[def "[cmd -recurse] [arg boolean]"] + Set to [arg false] if you do not want the name server to recursively + act upon your request. Normally set to [arg true]. +[def "[cmd -command] [arg procname]"] + Set a procedure to be called upon request completion. The procedure + will be passed the token as its only argument. +[list_end] + +[para] +[call [cmd ::dns::configure] [opt [arg "options"]]] + +The [cmd ::dns::configure] command is used to setup the dns +package. The server to query, the protocol and domain search path are +all set via this command. If no arguments are provided then a list of +all the current settings is returned. If only one argument then it +must the the name of an option and the value for that option is +returned. + +[list_begin definitions] +[def "[cmd -nameserver] [arg hostname]"] + Set the default name server to be used by all queries. The default is + [term localhost]. +[def "[cmd -protocol] [arg tcp|udp]"] + Set the default network protocol to be used. Default is [arg tcp]. +[def "[cmd -port] [arg portnum]"] + Set the default port to use on the name server. The default is 53. +[def "[cmd -search] [arg domainlist]"] + Set the domain search list. This is currently not used. +[def "[cmd -timeout] [arg milliseconds]"] + Set the default timeout value for DNS lookups. Default is 30 seconds. +[def "[cmd -loglevel] [arg level]"] + Set the log level used for emitting diagnostic messages from this + package. The default is [term warn]. See the [package log] package + for details of the available levels. +[list_end] + +[para] +[call [cmd ::dns::name] [arg token]] + Returns a list of all domain names returned as an answer to your query. + +[para] +[call [cmd ::dns::address] [arg token]] + Returns a list of the address records that match your query. + +[para] +[call [cmd ::dns::cname] [arg token]] + Returns a list of canonical names (usually just one) matching your query. + +[para] +[call [cmd ::dns::result] [arg token]] + Returns a list of all the decoded answer records provided for your + query. This permits you to extract the result for more unusual query types. + +[para] +[call [cmd ::dns::status] [arg token]] + Returns the status flag. For a successfully completed query this will be + [emph ok]. May be [emph error] or [emph timeout] or [emph eof]. + See also [cmd ::dns::error] + +[para] +[call [cmd ::dns::error] [arg token]] + Returns the error message provided for requests whose status is [emph error]. + If there is no error message then an empty string is returned. + +[para] +[call [cmd ::dns::reset] [arg token]] + Reset or cancel a DNS query. + +[para] +[call [cmd ::dns::wait] [arg token]] + Wait for a DNS query to complete and return the status upon completion. + +[para] +[call [cmd ::dns::cleanup] [arg token]] + Remove all state variables associated with the request. + +[para] +[call [cmd ::dns::nameservers]] + +Attempts to return a list of the nameservers currently configured +for the users system. On a unix machine this parses the +/etc/resolv.conf file for nameservers (if it exists) and on Windows +systems we examine certain parts of the registry. If no nameserver can +be found then the loopback address (127.0.0.1) is used as a default. + +[list_end] + +[comment { ----------------------------------------------------------- }] + +[section EXAMPLES] + +[para] +[example { +% set tok [dns::resolve www.tcl.tk] +::dns::1 +% dns::status $tok +ok +% dns::address $tok +199.175.6.239 +% dns::name $tok +www.tcl.tk +% dns::cleanup $tok +}] + +[para] +Using DNS URIs as queries: +[example { +% set tok [dns::resolve "dns:tcl.tk;type=MX"] +% set tok [dns::resolve "dns://l.root-servers.net/www.tcl.tk"] +}] + +[para] +Reverse address lookup: +[example { +% set tok [dns::resolve 127.0.0.1] +::dns::1 +% dns::name $tok +localhost +% dns::cleanup $tok +}] + +[comment { ----------------------------------------------------------- }] + +[section {REFERENCES}] + +[list_begin enumerated] + +[enum] + Mockapetris, P., "Domain Names - Concepts and Facilities", + RFC 1034, November 1987. + ([uri http://www.ietf.org/rfc/rfc1034.txt]) + +[enum] + Mockapetris, P., "Domain Names - Implementation and Specification", + RFC 1035, November 1087. + ([uri http://www.ietf.org/rfc/rfc1035.txt]) + +[enum] + Thompson, S. and Huitema, C., "DNS Extensions to support IP version 6", + RFC 1886, December 1995. + ([uri http://www.ietf.org/rfc/rfc1886.txt]) + +[enum] + Josefsson, S., "Domain Name System Uniform Resource Identifiers", + Internet-Draft, October 2003, + ([uri http://www.ietf.org/internet-drafts/draft-josefsson-dns-url-09.txt]) + +[enum] + Gulbrandsen, A., Vixie, P. and Esibov, L., + "A DNS RR for specifying the location of services (DNS SRV)", + RFC 2782, February 2000, + ([uri http://www.ietf.org/rfc/rfc2782.txt]) + +[enum] + Ohta, M. "Incremental Zone Transfer in DNS", + RFC 1995, August 1996, + ([uri http://www.ietf.org/rfc/rfc1995.txt]) + +[list_end] + +[section AUTHORS] +Pat Thoyts + +[vset CATEGORY dns] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/dns/tcllib_ip.man b/tcllib/modules/dns/tcllib_ip.man new file mode 100644 index 0000000..66d0e24 --- /dev/null +++ b/tcllib/modules/dns/tcllib_ip.man @@ -0,0 +1,451 @@ +[vset IP_VERSION 1.3] +[manpage_begin tcllib_ip n [vset IP_VERSION]] +[see_also inet(3)] +[see_also ip(7)] +[see_also ipv6(7)] +[keywords {internet address}] +[keywords ip] +[keywords ipv4] +[keywords ipv6] +[keywords {rfc 3513}] +[copyright {2004, Pat Thoyts}] +[copyright {2005 Aamer Akhter <aakhter@cisco.com>}] +[moddesc {Domain Name Service}] +[titledesc {IPv4 and IPv6 address manipulation}] +[category Networking] +[require Tcl 8.2] +[require ip [opt [vset IP_VERSION]]] +[description] +[para] + +This package provides a set of commands to help in parsing, displaying +and comparing internet addresses. The package can handle both IPv4 (1) +and IPv6 (2) address types. + +[section COMMANDS] + +[list_begin definitions] + +[call [cmd ::ip::version] [arg address]] + +Returns the protocol version of the address (4 or 6) or 0 if the +address is neither IPv4 or IPv6. + +[call [cmd ::ip::is] [arg class] [arg address]] + +Returns true if the address is a member of the given protocol +class. The class parameter may be either [arg ipv4] or [arg ipv6] +This is effectively a boolean equivalent of the [cmd version] +command. The [arg class] argument may be shortened to [arg 4] or +[arg 6]. + +[call [cmd ::ip::equal] [arg address] [arg address]] + +Compare two address specifications for equivalence. The arguments are +normalized and the address prefix determined (if a mask is +supplied). The normalized addresses are then compared bit-by-bit and +the procedure returns true if they match. + +[call [cmd ::ip::normalize] [arg address]] + +Convert an IPv4 or IPv6 address into a fully expanded version. There +are various shorthand ways to write internet addresses, missing out +redundant parts or digts.. This procedure is the opposite of +[cmd contract]. + +[call [cmd ::ip::contract] [arg address]] + +Convert a [cmd normalize]d internet address into a more compact form +suitable for displaying to users. + +[call [cmd ::ip::distance] [arg ipaddr1] [arg ipaddr2]] + +This command computes the (integer) distance from IPv4 address +[arg ipaddr1] to IPv4 address [arg ipaddr2], i.e. "ipaddr2 - ipaddr1" + +[para] +[example { + % ::ip::distance 1.1.1.1 1.1.1.5 + 4 +}] + +[call [cmd ::ip::nextIp] [arg ipaddr] [opt [arg offset]]] + +This command adds the integer [arg offset] to the IPv4 address [arg ipaddr] +and returns the new IPv4 address. + +[para] +[example { + % ::ip::distance 1.1.1.1 4 + 1.1.1.5 +}] + +[call [cmd ::ip::prefix] [arg address]] + +Returns the address prefix generated by masking the address part with +the mask if provided. If there is no mask then it is equivalent to +calling [cmd normalize] + +[call [cmd ::ip::type] [arg address]] + +[call [cmd ::ip::mask] [arg address]] + +If the address supplied includes a mask then this is returned +otherwise returns an empty string. + +[call [cmd ::ip::prefixToNative] [arg prefix]] + +This command converts the string [arg prefix] from dotted form +(<ipaddr>/<mask> format) to native (hex) form. Returns a list +containing two elements, ipaddress and mask, in this order, in +hexadecimal notation. + +[para] +[example { + % ip::prefixToNative 1.1.1.0/24 + 0x01010100 0xffffff00 +}] + +[call [cmd ::ip::nativeToPrefix] [arg nativeList]|[arg native] \ + [opt [option -ipv4]]] + +This command converts from native (hex) form to dotted form. +It is the complement of [cmd ::ip::prefixToNative]. + +[para] +[list_begin arguments] +[arg_def list nativeList in] + +List of several ip addresses in native form. The native form is a list +as returned by [cmd ::ip::prefixToNative]. + +[arg_def list native in] + +A list as returned by [cmd ::ip::prefixToNative]. + +[list_end] +[para] + +The command returns a list of addresses in dotted form if it was +called with a list of addresses. Otherwise a single address in dotted +form is returned. + +[para] +[example { + % ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4 + 1.1.1.0/24 +}] + +[call [cmd ::ip::intToString] [arg number] [opt [option -ipv4]]] + +This command converts from an ip address specified as integer number +to dotted form. + +[para] +[example { + ip::intToString 4294967295 + 255.255.255.255 +}] + +[call [cmd ::ip::toInteger] [arg ipaddr]] + +This command converts a dotted form ip into an integer number. + +[para] +[example { + % ::ip::toInteger 1.1.1.0 + 16843008 +}] + +[call [cmd ::ip::toHex] [arg ipaddr]] + +This command converts dotted form ip into a hexadecimal number. + +[para] +[example { + % ::ip::toHex 1.1.1.0 + 0x01010100 +}] + +[call [cmd ::ip::maskToInt] [arg ipmask]] + +This command convert an ipmask in either dotted (255.255.255.0) form +or mask length form (24) into an integer number. + +[para] +[example { + ::ip::maskToInt 24 + 4294967040 +}] + +[call [cmd ::ip::broadcastAddress] [arg prefix] [opt [option -ipv4]]] + +This commands returns a broadcast address in dotted form for the given +route [arg prefix], either in the form "addr/mask", or in native +form. The result is in dotted form. + +[para] +[example { + ::ip::broadcastAddress 1.1.1.0/24 + 1.1.1.255 + + ::ip::broadcastAddress {0x01010100 0xffffff00} + 0x010101ff +}] + +[call [cmd ::ip::maskToLength] \ + [arg dottedMask]|[arg integerMask]|[arg hexMask] \ + [opt [option -ipv4]]] + +This command converts the dotted or integer form of an ipmask to +the mask length form. + +[para] +[example { + ::ip::maskToLength 0xffffff00 -ipv4 + 24 + + % ::ip::maskToLength 255.255.255.0 + 24 +}] + +[call [cmd ::ip::lengthToMask] [arg maskLength] \ + [opt [option -ipv4]]] + +This command converts an ipmask in mask length form to its dotted +form. + +[para] +[example { + ::ip::lengthToMask 24 + 255.255.255.0 +}] + +[call [cmd ::ip::nextNet] [arg ipaddr] [arg ipmask] \ + [opt [arg count]] \ + [opt [option -ipv4]]] + +This command returns an ipaddress in the same position in the +[arg count] next network. The default value for [arg count] is +[const 1]. + +[para] + +The address can be specified as either integer number or in dotted +form. The mask can be specified as either integer number, dotted form, +or mask length form. + +[para] + +The result is in hex form. + +[call [cmd ::ip::isOverlap] [arg prefix] [arg prefix]...] + +This command checks if the given ip prefixes overlap. All arguments +are in dotted "addr/mask" form. All arguments after the first prefix +are compared against the first prefix. The result is a boolean +value. It is true if an overlap was found for any of the prefixes. + +[para] +[example { + % ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 + 0 + + ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32 + 1 +}] + +[call [cmd ::ip::isOverlapNative] \ + [opt [option -all]] \ + [opt [option -inline]] \ + [opt [option -ipv4]] \ + [arg hexipaddr] [arg hexipmask] [arg hexiplist]] + +This command is similar to [cmd ::ip::isOverlap], however the +arguments are in the native form, and the form of the result is under +greater control of the caller. + +If the option [option -all] is specified it checks all addresses for +overlap, not only until the first one is found. + +If the option [option -inline] is specified the command returns the +overlapping prefix instead of index values. + +[para] + +The result of the command is, depending on the specified options, + +[list_begin definitions] +[def {no options}] + +The index of the first overlap found, or 0 if there is none. + +[def -all] + +A list containing the indices of all overlaps found, or an empty list + +if there are none. + +[def -inline] + +The first overlapping prefix, or an empoty string if there is none. + +[def {-all -inline}] + +A list containing the prefixes of all overlaps found, or an empty list +if there are none. + +[list_end] + +[para] +[example { + % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff}} + 0 + + % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}} + 2 +}] + +[call [cmd ::ip::ipToLayer2Multicast] [arg ipaddr]] + +This command an converts ipv4 address in dotted form into a layer 2 +multicast address, also in dotted form. + +[para] +[example { + % ::ip::ipToLayer2Multicast 224.0.0.2 + 01.00.5e.00.00.02 +}] + +[call [cmd ::ip::ipHostFromPrefix] [arg prefix] \ + [opt "[option -exclude] [arg prefixExcludeList]"]] + +This command returns a host address from a prefix in the form +"ipaddr/masklen", also making sure that the result is not an address +found in the [arg prefixExcludeList]. + +The result is an ip address in dotted form. + +[para] +[example { + %::ip::ipHostFromPrefix 1.1.1.5/24 + 1.1.1.1 + + %::ip::ipHostFromPrefix 1.1.1.1/32 + 1.1.1.1 +}] + +[call [cmd ::ip::reduceToAggregates] [arg prefixlist]] + +This command finds nets that overlap and filters out the more specific +nets. The prefixes are in either addr/mask form or in native format. + +The result is a list containing the non-overlapping ip prefixes from +the input. + +[para] +[example { + % ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 } + 1.0.0.0/8 2.1.1.0/24 +}] + +[call [cmd ::ip::longestPrefixMatch] [arg ipaddr] [arg prefixlist] \ + [opt [option -ipv4]]] + +This command finds longest prefix match from set of prefixes, given a +specific host address. The prefixes in the list are in either native +or dotted form, whereas the host address is in either ipprefix format, +dotted form, or integer form. + +The result is the prefix which is the most specific match to the host +address. + +[para] +[example { + % ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.0/28 } + 1.1.1.0/28 +}] + +[call [cmd ::ip::collapse] [arg prefixlist]] + +This commands takes a list of prefixes and returns a list prefixes +with the largest possible subnet masks covering the input, in this +manner collapsing adjacent prefixes into larger ranges. + +[para] This is different from [cmd ::ip::reduceToAggregates] in that +the latter only removes specific nets from a list when they are +covered by other elements of the input whereas this command actively +merges nets into larger ranges when they are adjacent to each other. + +[para] +[example { +% ::ip::collapse {1.2.2.0/24 1.2.3.0/24} +1.2.2.0/23 +}] + +[call [cmd ::ip::subtract] [arg prefixlist]] + +This command takes a list of prefixes, some of which are prefixed by a +dash. These latter [term negative] prefixes are used to punch holes +into the ranges described by the other, [term positive], +prefixes. I.e. the negative prefixes are subtracted frrom the positive +ones, resulting in a larger list of describes describing the covered +ranges only as positives. + +[list_end] + +[comment { ----------------------------------------------------------- }] + +[section EXAMPLES] +[para] + +[example { +% ip::version ::1 +6 +% ip::version 127.0.0.1 +4 +}] + +[example { +% ip::normalize 127/8 +127.0.0.0/8 +% ip::contract 192.168.0.0 +192.168 +% +% ip::normalize fec0::1 +fec0:0000:0000:0000:0000:0000:0000:0001 +% ip::contract fec0:0000:0000:0000:0000:0000:0000:0001 +fec0::1 +}] + +[example { +% ip::equal 192.168.0.4/16 192.168.0.0/16 +1 +% ip::equal fec0::1/10 fec0::fe01/10 +1 +}] + +[comment { ----------------------------------------------------------- }] + +[section {REFERENCES}] + +[list_begin enumerated] + +[enum] + Postel, J. "Internet Protocol." RFC 791, September 1981, + ([uri http://www.ietf.org/rfc/rfc791.txt]) + +[enum] + Hinden, R. and Deering, S., + "Internet Protocol Version 6 (IPv6) Addressing Architecture", + RFC 3513, April 2003 + ([uri http://www.ietf.org/rfc/rfc3513.txt]) + +[list_end] + +[section AUTHORS] +Pat Thoyts + +[vset CATEGORY dns] +[include ../doctools2base/include/feedback.inc] +[manpage_end] |