From f6e53acb52b1cf16ecec6595ae3b7cb4ff509b71 Mon Sep 17 00:00:00 2001 From: Packit Service Date: Dec 10 2020 02:18:26 +0000 Subject: perl-Net-DNS-1.15 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..01bd2ba --- /dev/null +++ b/Changes @@ -0,0 +1,2525 @@ +$Id: Changes 1639 2018-02-09 11:08:24Z willem $ -*-text-*- + + +**** 1.15 Feb 9, 2018 + + GOST R 34.11-94 hash algorithm: end of life 1st Jan 2018 + per sunset clause in successor standard GOST R 34.11-2012. + Digest::GOST removed from the recommended module metadata, + but will still be used if available. + + +**** 1.14 Dec 15, 2017 + +Fix rt.cpan.org #123702 + + 'use base' should not be used in packages with several + subpackages defined + +Fix rt.cpan.org #123676 + + Net::DNS::Nameserver malformed message on big axfr + + +**** 1.13 Oct 18, 2017 + +Feature IDN query support + + Queries for domain names containing non-ASCII characters are + now possible on Unicode platforms using CPAN Net::LibIDN2 + + +**** 1.12 Aug 18, 2017 + +Fix rt.cpan.org #122586 + + Persistent UDP reports false timeouts + +Fix rt.cpan.org #122352 + + bgsend(): TCP retry can stall for IO::Socket::IP before 0.38 + +Feature + CDS / CDNSKEY: Implement RFC8078 erratum 5049. + + +**** 1.11 Jun 26, 2017 + +Fix rt.cpan.org #122138 + + Send a UDP query with udppacketsize=512 + +Feature + Extract default resolver configuration from OS/390 MVS datasets. + Thanks to Sandra Carroll and Yaroslav Kuzmin for their assistance. + + +**** 1.10 May 5, 2017 + +Fix rt.cpan.org #120748 + + Net::DNS::Resolver::MSWin32 critical issue + Thanks to Dmytro Zagashev for his valuable assistance during + the investigation which exposed five distinct issues. + +Feature rt.cpan.org #18819 + + Perl 5.22.0 puts EBCDIC character encoding back on the agenda. + Thanks to Yaroslav Kuzmin for successful test build on os390. + + +**** 1.09 March 24, 2017 + +Fix rt.cpan.org #120542 + + Fails tests when no "." in @INC + +Fix rt.cpan.org #120470 + + Fragmented TCP length not correctly reassembled + +Feature rt.cpan.org #75357 + + Add mechanism to encode/decode EDNS option octet strings + + +**** 1.08 February 20, 2017 + +Fix rt.cpan.org #120208 + + Unable to install 1.07 in local::lib environment + +Feature rt.cpan.org #119679 + + Net::DNS::Nameserver: UpdateHandler for responding to UPDATE packets + +Feature rt.cpan.org #75357 + + Net::DNS::Nameserver: optionmask (similar to headermask) added + to allow user to set EDNS options in reply packet + +Discontinue support for pre-5.6 perl + + Remove pre-5.6 workarounds and outdated language features + + +**** 1.07 December 29, 2016 + +Fix rt.cpan.org #118598/#108908 + + Serious Makefile.PL issues + "make install" now suppressed if pre-1.01 version detected + +Fix rt.cpan.org #115558 + + Net::DNS::Nameserver does not allow EDNS replies + +Fix rt.cpan.org #114917 + + Net::DNS::ZoneFile fails to parse mixed case mnemonics + +Fix rt.cpan.org #114876 + + Use of uninitialized value in lc at MSWin32.pm line 77 + +Fix rt.cpan.org #114819 + + Net::DNS fails to compile with taint checks enabled + +Feature + Add support for dynamic RR subtype package creation + per draft-levine-dnsextlang + + +**** 1.06 May 27, 2016 + +Fix rt.cpan.org #114918 + + Net::DNS::ZoneFile fails when unnamed RR follows $ORIGIN + +Fix rt.cpan.org #114351 + + Case sensitive compression breaks resolver->nameservers() + +Fix rt.cpan.org #113579 + + Net::DNS::Resolver dies on scoped IPv6 nameserver address + +Fix rt.cpan.org #113020 + + Resolve::Recurse Hangs + +Fix rt.cpan.org #112860 + + improperly terminated AXFR at t/08-IPv4.t line 446. + + +**** 1.05 March 7, 2016 + +Fix rt.cpan.org #111559 + + 1.04: TSIG not working anymore (TSIG.pm) + +Fix rt.cpan.org #108908 + + Installing recent version gets shadowed by old version. + Warnings added to Makefile.PL and t/00-version.t. + +Fix rt.cpan.org #66900 + + Net::DNS::Async unable to retry truncated UDP using TCP because + of limitations in Net::DNS. + + +**** 1.04 December 8, 2015 + +Fix rt.cpan.org #109183 + + Semantics of "retry" and "retrans" options has changed with 1.03 + +Fix rt.cpan.org #109152 + + Deprecated method make_query_packet breaks calling code + +Fix rt.cpan.org #109135 + + Resolver behaves differently with long and short IPv6 address format + +Fix rt.cpan.org #108745 + + Net::DNS::Resolver bgsend + + +**** 1.03 November 6, 2015 + +Fix rt.cpan.org #107897 + + t/10-recurse.t freezes, never completes + +Fix rt.cpan.org #101978 + + Update Net::DNS to use IO::Socket::IP + +Fix rt.cpan.org #84375 + + Timeout doesn't work with bgsend/bgread + +Fix rt.cpan.org #47050 + + persistent sockets for Resolver::bg(send|read|isready) + +Fix rt.cpan.org #15515 + + bgsend on TCP + + +**** 1.02 September 16, 2015 + +Fix rt.cpan.org #107052 + + suppress messages: Can't locate Net/DNS/Resolver/linux.pm + +Fix rt.cpan.org #106916 + + Dependency on MIME::Base32 makes Net::DNS not installable on MSWin32 + +Fix rt.cpan.org #106565 + + Net::DNS::Resolver::Recurse and IPv6 Reverse DNS + +Fix rt.cpan.org #105808 + + Version test for Pod::Test is broken + + +**** 1.01 Jul 6, 2015 + +Feature + The RRs previously only available with Net::DNS::SEC are now + integrated with Net::DNS. Net::DNS::SEC needs to be installed + to enable the signature generation and verification functions. + +Fix rt.cpan.org #105491 + + Can't call method "zclass" on an undefined value at ... Net/DNS/Packet.pm line 474 + +Fix rt.cpan.org #105421 + + Dead link in Net::DNS::FAQ + +Fix rt.cpan.org #104657 + + Wrong split on Cygwin + +Fix rt.cpan.org #102810 + + Dynamic update: rr_add overrides ttl of zero + +Fix rt.cpan.org #102809 + + CAA broken + + +**** 0.83 Feb 26, 2015 + +Fix rt.cpan.org #101798 + + AUTOLOAD error confusing w/o reference to object class + +Fix rt.cpan.org #101709 + + Provide separate control of IPv6 tests + +Fix rt.cpan.org #101675 + + MX record with 0 preference fails to parse + +Fix rt.cpan.org #101405 + + Install tests fail for v0.81 on Perl 5.21.7 + + +**** 0.82 Jan 20, 2015 + +Fix rt.cpan.org #100385 + + Support for IPv6 link-local addresses with scope_id + + +**** 0.81 Oct 29, 2014 + +Fix rt.cpan.org #99571 + + AXFR BADSIG failures + +Fix rt.cpan.org #99531 + + Resolver doc error - when is a 'bug' a 'bug'? [TSIG verification] + +Fix rt.cpan.org #99528 + + TSIG::create fails with some filenames + +Fix rt.cpan.org #99527 + + Random errors... [declaration with statement modifier] + +Fix rt.cpan.org #99429 + + Infinite recursion in Net::DNS::Resolver::Recurse::send when + following certain delegations with empty non-terminals. + +Fix rt.cpan.org #99320 + + Net::DNS::ZoneFile bug in "$ORIGIN ." + + +**** 0.80 Sep 22, 2014 + +Removal of Win32::IPHelper support with cygwin + + Resolvers on Cygwin can get their DNS configuration from the + registry directly via the /proc filesystem. Getting rid of + the other method reduces dependencies and makes installations + less error prone. + +Rework rt.cpan.org #96119 + + "Too late to run INIT block" warning for require Net::DNS + + +**** 0.79 Aug 22, 2014 + +Feature rt.cpan.org #98149 + + Add support for Android platform. + +Fix rt.cpan.org #97736 + + Net::DNS::Resolver->new mistakenly copies supplied arguments + into default configuration on first instantiation. + +Fix rt.cpan.org #97502 + + Net::DNS::Resolver->retrans does not accept a value of 1 (uses 2 instead) + +Fix rt.cpan.org #83642 + + Configure CD flag in Net::DNS::Resolver->new + +Fix rt.cpan.org #81760 + + Reverted workaround for TXT issue preventing propagation of + rule updates for SpamAssassin versions earlier than 3.4.0 + +Fix rt.cpan.org #16630 + + Net::DNS::Resolver::Recurse issues lots of IMHO unnecessary DNS requests. + + +**** 0.78 Jul 10, 2014 + +Fix rt.cpan.org #97036 + + Nameserver identification on Cygwin + +Fix rt.cpan.org #96814 + + Trailing comments not stripped in /etc/resolv.conf + +Fix rt.cpan.org #96812 + + Net::DNS::Resolver->new() hangs if nameserver :: exists + +Fix rt.cpan.org #96755 + + RFC 3597 (hex) parsing mistake + +Fix rt.cpan.org #96708 + + String treated as boolean in TXT + +Fix rt.cpan.org #96608 + + "Insecure dependency in connect" with Net::DNS::Resolver over TCP + +Fix rt.cpan.org #96535 + + Net::DNS::Resolver warns "Use of uninitialized value in length" + +Fix rt.cpan.org #96531 + + Calling $resolver->nameservers multiple times returns an + increasingly-long list (on some perl installations) + +Fix rt.cpan.org #96439 + + Uninitialised decoding object when printing packet + + +**** 0.77 Jun 13, 2014 + +Fix rt.cpan.org #96151 + + Unlocalised $_ modified when reading config file + +Fix rt.cpan.org #96135 + + Deep recursion problem on Cygwin + +Fix rt.cpan.org #96119 + + "Too late to run INIT block" warning for require Net::DNS + +Fix rt.cpan.org #96035 + + Insert missing plan 'no-plan' in 10-recurse.t + +Fix inefficient Net::DNS::SEC compatibility code + + +**** 0.76 May 23, 2014 + +Fix rt.cpan.org #95738 + + Test failure with IPv6 address in resolver.conf but without + prerequisite IO::Socket::INET6 package installed. + +Fix rt.cpan.org #95596 + + Incorrect parsing of nameserver lines in resolv.conf + +Feature rt.cpan.org #79568 + + Implement prefer_v6 resolver configuration attribute. + +Fix rt.cpan.org #67602 + + Set resolver configuration defaults at first instantiation + instead of module load time. + + +**** 0.75 May 8, 2014 + +Fix rt.cpan.org #94069 + + Compile-time constant in Domain.pm/Text.pm cannot be used to + store pointer to encoding object when using perlcc compiler. + Thanks are due to Reini Urban for testing the revised code. + +Fix rt.cpan.org #93764 + + Resolver gives unhelpful errorstring when attempting to use + IPv6-only nameserver without INET6 and Socket6 installed. + +Fix rt.cpan.org #92626 + + Clarify documentation surrounding SRV RR sorting + +Feature + + Implement TSIG verified zone transfer. + +Fix rt.cpan.org #92433 & #91241 + + TSIG: implement sign/verify for multi-packet message. + +Fix rt.cpan.org #79569 + + Iterate nameservers in AXFR + + +**** 0.74 Jan 16, 2014 + +Fix rt.cpan.org #91306 + + Nameserver crashes on malformed UDP query. + +Fix rt.cpan.org #91241 + + TSIG: Fix incorrectly generated %algbyval table. + +Feature + + Add CAA, EUI48 and EUI64 RR implementation. + + +**** 0.73 Nov 29, 2013 + +Fix rt.cpan.org #88778 + + $update->unique_push() does not work as advertised. + +Fix rt.cpan.org #88744 + + Nameserver crashes on malformed TCP query. + +Fix rt.cpan.org #84601/#81942 + + Fix memory leak on packet cleanup. Indirect self-reference via + header prevented garbage collector from deallocating packet. + +Feature rt.cpan.org #84468 + + TSIG: add support for HMAC-SHA1 .. HMAC-SHA512 + +Fix rt.cpan.org #84110 + + Incorrect parsing of PTR records in zonefile. + +Fix rt.cpan.org #83755 + + Erroneous attempt to invoke Net::LibIDN package in Domain.pm. + +Fix rt.cpan.org #83078 + + Can't locate Net/DNS/Resolver/linux.pm in @INC + Conjecture: eval{ ... }; if ($@) { ... }; broken by threads. + +Fix rt.cpan.org #83075 + + ZoneFile.pm wrongly rejects $TTL 0 directive. + +Fix rt.cpan.org #82621 + + Error string empty after failed TCP query. + +Fix rt.cpan.org #82296 + + IPv6 with embedded IPv4 address not mapped to ip6.arpa. + +Fix rt.cpan.org #82294 + + Perl taint inadvertently removed in Domain and Text objects. + +Feature rt.cpan.org #53610 + + add TSIG validation support + + +**** 0.72 Dec 28, 2012 + +Fix rt.cpan.org #82148 + + nxrrset fails to ignore RDATA. + +Fix rt.cpan.org #82134 + + TSIG key and algorithm names not downcased in digest. + Class not forced to ANY. + +Fix rt.cpan.org #82063 + + yxrrset, nxrrset and rr_del functions should force zero TTL. + +Fix rt.cpan.org #82047 + + Clarify documentation to indicate that header counts may + differ from the number of RRs present if a packet is corrupt. + +Fix rt.cpan.org #81941 + + Clarify documentation to make users aware that bgread will not + switch to TCP when a truncated packet is received. + + +**** 0.71 Dec 15, 2012 + +Temporary workaround rt.cpan.org #81760 + + The rdatastr method for TXT RRs will return unconditionally + quoted rdata fields to work around an issue with updating + SpamAssassin rules. This workaround will be reverted after + release of a version of SpamAssassin which resolves the issue. + +Fix TSIG initialization + + Uninitialised algorithm attribute caused signature generation + to fail silently when creating a TSIG signed packet. + +Fix rt.cpan.org #81869 + + The rr_del auxilliary function broken by a conflicting change + in the RR.pm string parser. Note the ambiguous use of ANY, + which may stand for CLASS255 or TYPE255 depending upon the + argument string presented. + +Fix rt.cpan.org #81756 + + Test failures on Perl 5.8.5 .. 5.8.8. + lc(), uc() and case insensitive regex matching broken for UTF8. + Thanks are due to Paul Howarth for patient work with perl -d. + +Fix rt.cpan.org #81787 + + NXDOMAIN no longer reported by $resolver->errorstring. + +Fix rt.cpan.org #81814 + + Allow zero in format, tag and algorithm fields of CERT RR. + +Fix rt.cpan.org #81786 + + Substitute last owner for leading spaces in multiline zonefile RR. + +Fix rt.cpan.org #77444 + + Make use of new extended header modus operandi for OPT records + also in the resolver. Preventing a warning. + + +**** 0.70 Dec 6, 2012 + +Feature + Add support for NID L32 L64 LP, RFC6742. + + +**** 0.69 Dec 5, 2012 + +Feature rt.cpan.org #62030 + + Parsing of BIND zone files implemented in Net::DNS::ZoneFile. + This replaces and is backward compatible with the CPAN module + of the same name. + +Enhancement to simplify RR subtype template and recode packages. + +Enhancement rt.cpan.org #75185 + + Packet decoder returns index to end of decoded data. + + Added packet->reply() method. + +Fix rt.cpan.org #79569 + + AXFR not setting packet->answer_from. + +Enhancement rt.cpan.org #18819 + + Added support for Unicode and non-ASCII character encoding. + +Feature integrate OPT as a header extension + + Treat extended rcodes and the DO flag like they are part of + the packet header. + +Fix rt.cpan.org #77444 + + Support escaped characters according to RFC1035 in TXT rdata. + +Fix rt.cpan.org #77304 + + Fix resolver searchlist from registry setup on Win32. + +Enhancement rt.cpan.org #67570 + + Make wire2presentation two till eighteen times faster. + A contribution from Matthew Horsfall + +Fix rt.cpan.org #73366 + + Remove existing TSIG when resigning with a new TSIG and give warning. + +Fix rt.cpan.org #75330 + + Also try nameserver without glue (as a last resort) when recursing. + +Fix rt.cpan.org #74493 + + Read correct resolver configuration in OS/2. + + +**** 0.68 Jan 30, 2012 + +Fix rt.cpan.org #72314 + + Let a Net::DNS::Nameserver bind on Net::DNS::Nameserver::DEFAULT_ADDR + as a last resort. + +Fix to suppress false warnings about subroutine profiles on ancient + versions of perl. + +Fix to avoid constants with value undef which prevents unwanted code from being + optimized away on ancient versions of perl. + +Fix code error in PTR.pm, canonical RDATA not downcased. + +Enhancement to clarify the function of parse and data methods, by renaming them + to decode and encode respectively. + +Feature IDN query support. + + Question.pm modified to use the recently introduced DomainName.pm + module to represent DNS names. Queries for domain names containing + non-ASCII characters are now possible on Unicode platforms with CPAN + Net::LibIDN installed. + +Introduction of Mailbox.pm module that will be used in the future to represent + RDATA components containing DNS coded RFC822 mailbox addresses. + +Introduction of Text.pm module that will be used in the future to represent + RDATA components containing text. + + +**** 0.67 Nov 4, 2011 + +Enhancement rt.cpan.org #60726 + + On Cygwin Net::DNS now builds without Win32::IPHelper, unless a + previous version is updated that did use it. + The choice may also be set by the --iphelper or --noiphelper option + to Makefile.PL. + +Fix to suppress IO::Socket::INET(6)::peerhost usage with TCP. On some systems + it doesn't work after receiving data. + +Enhancement rt.cpan.org #43142 + + Allow ReplyHandlers to indicate that no answer should be returned + by the Net::DNS::Nameserver. + +Fix rt.cpan.org #71796 + + Prevent TCP accepts from blocking on unfinished 3-way handshakes. + +Fix rt.cpan.org #65607 + + Make 64bits windows work by depending on Win32::IPHelper version 0.07 + Thanks to Lian Wan Situ. + +Fix rt.cpan.org #66470 + + Named nameserver should be reachable by IPv6 too. + +Fix to make tests work in jailed environments where a reply might come + from a different address than that of the loopback interface. + +Feature to use a class method ReplyHandler for classes inheriting from + Net::DNS::Nameserver. + + A contribution from Rob Brown. + +Fix rt.cpan.org #71062 + + Replace the usage of the obsolete Win32::Registry module by + Win32::TieRegistry module. + +Fix rt.cpan.org #68731 + + Fix linking of the C compiled parts of the library on Mac OS X + +New improved version of the check_soa script in the contrib section. + + A contribution from Dick Franks. + +Fix rt.cpan.org #70830 + + Make t/08-online.t handle NXDOMAIN hijacking that return more than one + answer. + +Fix rt.cpan.org #24525 + + Removed dependency on Net::IP + +Fix online tests to use the library as documented and not use knowledge of the + internal workings of the classes that should be hidden. + + A contribution from Dick Franks + +Fix rt.cpan.org #55682 + Make online tests non-fatal by default. + All interactive prompts are removed from Makefile.PL. + Online tests may still be made a requisite by using the --online-tests + option. + +Major rework of Net::DNS::Domain.pm and the addition of Net::DNS::DomainName.pm + + Which paves the way towards handling of character encodings and IDN. + A contribution from Dick Franks. + +Fix rt.cpan.org #69174 + + Typo that prevented TCP traffic from being replied from the same + socket as it was received on. + +Fix rt.cpan.org #68338 + + Suppress warnings of the deprecated use of qw as parentheses in + perl 5.14. + +Enhancement rt.cpan.org #67418 + + A contribution from Wolfsage to perform presentation to wire format + conversion more efficiently. + +Fix rt.cpan.org #67133 + + Gracefully handle corrupted incoming packets in Net::DNS::Nameserver. + +Feature to manage serial numbers in SOA records in a modular and extensible way. + + Three modules are provided. Strictly sequential, Date Encoded and + Time Encoded. A contribution from Dick Franks. + +Fix rt.cpan.org #53325 + + Make Net::DNS::Resolver load even if /etc/resolv.conf is unreadable. + +Fix rt.cpan.org #63486 + + Make t/08-online.t fail gracefully in stead of crash on failures. + +Fix rt.cpan.org #55586 + + Various typo fixes. + +Fix rt.cpan.org #55682 + + Really do not use networking functions when online tests are disabled. + +Fix rt.cpan.org #64562 + + Replace TSIG key with the signature of the whole packet when signing + a packet, even when the TSIG key is not the first in the additional + section. + +Fix rt.cpan.org #56181 and #47265 + + Assembly of segmented TCP traffic. + +Feature rt.cpan.org #57289 + + Provide a configurable IdleTimeout for Net::DNS::Namserver. + +Fix rt.cpan.org #53595 + + Fix documentation to reflect code behaviour where on successful packet + creation, the error should be ignored. + +Fix rt.cpan.org #58914 + + Fix spelling of "algorithm" + +Fix rt.cpan.org #61725 + + Include default domain in the search list on Win32. + Thanks Mark Rallen. + +Fix rt.cpan.org #63321 + + A Net::DNS::Nameserver without a NotifyHandler now responds NOTIMP + to NOTIFY requests. + +Fix rt.cpan.org #53595 + + Documentation now reflects Net::DNS::Packet construction behaviour. + + +**** 0.66 Dec 30, 2009 + +Feature Truncation for Nameserver + fixes rt.cpan.org #33547 and #42744 + + TAKE CARE: + this feature may cause unexpected behavior for your nameservers + and can be turned off by setting Truncate to 0 during the creation + of the nameserver. + my $ns = Net::DNS::Nameserver->new( + Truncate => 0, + + ); + + + Net::DNS::Packet::truncate is a new method that is called from + within Net::DNS::Nameserver that truncates a packet according to + the rules of RFC2181 section 9. + + Acknowledgement Aaron Crane for an elegant test and for + inspiration for a direction. + + +Feature: Added Net::DNS::Domain + Net::DNS::Domain is an attempt to introduce a consistent model + for representation of RFC 1035 s. + + The class and its test script t/02-domain.t are included to be + exposed to various architectures. + + The class and its methods may be subject to change, both in terms of + naming and functionality. + + A contribution by Dick Franks + +Fix improved fuzzy matching of CLASS and TYPE in the Question + constructor method. + + A contribution by Dick Franks. + +Fix rt.cpan.org #43770 + + Update->rr_del() was reported broken for AAAA after 0.65. + The same bug also occurred in HINFO RR. + + +Fix rt.cpan.org #43765 + + Code inconsistent with documentation for loop_once. + + Note: Keeping timeout undefined in loop_once will now block until + something arrived on the socket. + +Fix rt.cpan.org #47050 + + Fixed logic error in bgsend socket acquisition code. + +Fix rt.cpan.org #47265 (partial) + + Frequently Net:DNS under Windows XP has a UDP problem which is + caused by a buggy implementation of SOCKS under Windows. + + One liner added to not continue UDP processing when that happens. + +Feature KX RR + + Added support for the KX RR, RFC2230 + The implementation is trivial since the KX inherits almost all of + its functionality by inheritance from the MX RR. + + +Fix NSAP RR string representation + + RFC1706 specifies the masterfile format to have a leading "0x" and + optional dot. This was not how the RR was represented with the + rdatastr method (and hence string and print). + +Fix rt.cpan.org #52307 AAAA v4compat parsing bug + Acknowledgement: BLBLACK + +Fix AAAA dynamic update + + Dynamic update of AAAA caused FORMERR on the prerequisite caused + by AAAA creating rdata even when an address was never specified. + This fix may cause difference in behavior for people who expect + a NULL address ("::") when creating a AAAA without an address + specified. + + +Feature HIP RR + + Added support for the HIP RR, RFC5205 + perldoc Net::DNS::RR::HIP for more information. + + +Feature DHCID RR + Added rudimentary support for the DHCID RR. + + +Fix rt.cpan.org #50883 + This is basically #11931 but for cygwin. + + Codepath in Cygwin and Win32 are now the same. This adds a + dependency in cygwin. + Acknowledgements "mikaraento" + +Fix rt.cpan.org #45407 and #43190 + Fixed escaping of semicolon. + + Note a change in behavior: + For TXT and SPF the rdatastr method (and therefore the + print, and string method) returns the escaped format while the + chr_str_list method will return unescaped format. + + +Fix rt.cpan.org #43393 + Typo in 01-resolver.t + +Fix rt.cpan.org #43273 + Added check for uninitialized opcode in headermask in + Nameserver.pm + +Fix rt.cpan.org #46635 + Minor documentation error in OPT.pm + +Fix rt.cpan.org #51009 + Fixed handling of empty string in Net::DNS::stripdot. + Elegant one-liner supplied by JMEHNLE. + +Fix rt.cpan.org #49035 + + Comment parsing fixed: Semicolon in character string blocks (such + as in TXT and NAPTR) were only recognized when escaped. + Also fixed the NAPTR regular expression to not interpret + "bla' 'foo" as two strings bla and foo, but as one: bla' 'foo + +Fix cd flag settings + + Resolver bug and fix reported by Jon Haidu. + + +**** 0.65 January 26, 2009 + +Fix rt.cpan.org #41076 + + When the AAAA object was constructed with new_from_hash with an + address containing the "::" shorthand notation normalization was + not done properly. + +Fix rt.cpan.org #42375 + + Typo in Win32.pm Registry root. + + + +**** 0.64 December 30, 2008 + +Feature rt.cpan.org #36656 + + Added support for the APL record (RFC 3123) + The module consists of a list of Address Prefix Item objects + as defined in the Net::DNS::RR::APL::ApItem class. + NOTE: Class and its interface may be subject to change. + + +Fix rt.cpan.org #11931 Wrong nameserver list handling in + Net::DNS::Resolver::Win32 + + + The init method has been rewritten to be based on WIN32::IPhelper for + the selection of the domain and the IP addresses. This is believed to + be more portable than trying to fetch the data from the registry. + We still trying to get the searchlist from the registry. + + WARNING: If you use Perl under WIN32 (eg ActivePerl or Strawberry Perl) + then your module dependency graph has changed drastically + +Fix IPv6 modules + When IO::Socket::INET6 was available but Socket6 was not the code would + recurse to infinity. + +Fix rt.cpan.org #21757 and Feature: Connectivity during test + Addition of --no-IPv6-tests and --IPv6-tests option in Makefile.PL. + Note: This causes two questions to be asked when building the + Makefile instead of one. + + Besides the test suites are constructed so that all the connectivity testing + happen in 001-connectivity.t and nonavailability of connectivity over a certain + transport is signaled over files t/online.disabled and t/IPv6.disabled respectively. + Both files are removed by t/99-cleanup + +Fix rt.cpan.org #34511 + Priming query logic contained unneeded recursion. + Now also falls back to hardcoded hints if there are no nameservers whatsoever. + +Fix rt.cpan.org #38390 and 37089 + Added CD and AD bit control to the resolver. + + The CD flag defaults to being unset and the AD flags is set by default + whenever DNSSEC is available. + Both flags default to unset in absence of DNSSEC. + + +Fix rt.cpan.org #37282 + Improved error reporting during client disconnect from the nameserver + +NOTE rt.cpan.org # 40249 + + Release 0.62 introduced a feature to parse data inside a packet only + when needed. This can cause the following to happen: + + Exception: corrupt or incomplete data at + /usr/lib/perl5/Net/DNS/RR.pm line 510. + caught at -e line 1 + + This may happen when you have undefined your packet data before all the + sections have been fully parsed. Such as in: + + $packet = Net::DNS::Packet->new(\$data); + undef($data); + + The workaround is to force parsing by calling the methods that + parse the data. e.g. + + $packet = Net::DNS::Packet->new(\$data); + $packet->answer; $packet->additional; $packet->authority; + undef ($data) + + +Fix rt.cpan.org # 41076 and # 41071 + + Net::DNS::RR->new_from_hash function would not normalize the content + of the data so that a method getting a string representation would + get inconsistent results depending on whether a RR was created from + a string of from a hash. + +Fix rt.cpan.org # 41296 + + Compression buggy for large packets. Fix by Kim Minh. + + +Fix rt.cpan.org # 35752 + + Perl 5.10.0 gave a number of issues on several platforms, preferring + XSLoader over Dynaloader seemed to fix those. + + +Bug rt.cpan.org #34510 + Buggy setting of "Recursion too deep, aborted" corrected. + +Feature (rt.cpan.org #39284) + + The ReplyHandler now also receives a variable with an anonymous hash with the connection details. Variables + supplied to the Reply handler are: $qname, $qclass, $qtype, $peerhost, $query, $conn + The hash referenced by $conn contains the following buckets: sockhost, sockport, peerhost, and peerport. + + + +Feature t/08-online.t and t/10-recurse.t + + In particular environments a query for a.t. will resolve and or + middleboxes will replace DNS packet content for queries to the root. + A bunch of test is skipped when this (broken) environment is + detected. + + + +Feature/Bug rt.cpan.org #22019 + + The initial fix for rt 22019 was to strip a trailing dot from all + attributes that were provided as argument for the + Net::DNS::RR::new_from_hash function. We have introduced + Net::DNS::stripdot, a function that will strip the dots of domain + names, taking into account possible escapes (e.g. labels like + foo\\\..). As a side effect the new_from_string method will now + convert possible spaces that are not trapped by some of the + new_from_string functions and convert them to \032 escapes. + + For information: The internal storage of domain names is using + presentation format without trailing dots. + + + +Bug + @EXPORT and @EXPORT_OK moved to a BEGIN block so that Net::DNS::SEC + can make use of exported functions + + +Feature/Bug + + The Notify handler introduced in 0.63 did not set the OPCODE on the + reply appropriately. This has been solved generically by allowing the + "Headermask" that is returned as 4th element by the reply or notify + handler in the nameserver also allows for the opcode to be set. + e.g. as in return ("NXDOMAIN",[],[],[],{ opcode => "NS_NOTIFY_OP" } + ); + + +*** 0.63, 8 Feb 2008 + +This version contains a Security Fix. + +Feature NotifyHandler in Nameserver + + The NotifyHandler is a new attribute to the nameserver used in the + same way as the ReplyHandler except that it is executed when the + opcode is NS_NOTIFY (RFC1996). It takes the same arguments as the + reply handler (i.e. $qname, $qclass, $qtype, $peerhost, and $query). + Corrections made in the documentation. + +Fix rt.cpan.org #32937: 5.11 introduces new warning on uc(undef) + + The patch supplied fixes for methods where undefined arguments were + likely. For methods where undefined arguments don't make the warning + will be printed. + + +Fix rt.cpan.org #32147: Default LocalAddr broken in Net::DNS::Nameserver 0.62 + + Listen on the default address if LocalAddr not defined. + + +Fix rt.cpan.org #30316 Security issue with Net::DNS Resolver. + + Net/DNS/RR/A.pm in Net::DNS 0.60 build 654 allows remote attackers + to cause a denial of service (program "croak") via a crafted DNS + response (http://nvd.nist.gov/nvd.cfm?cvename=CVE-2007-6341). Packet + parsing routines are now enclosed in eval blocks to trap exception + and avoid premature termination of user program. + +Bug: mbox-dname and txt-dname were not allowed to be empty in the RP RR. + Fix by Peter Koch + + +*** 0.62, 28 December 2007 + +Features: Move of some functionality out of the Packet to the Question + and RR classes; parsing of elements in the packet is now performed + by calling the appropriate subclasses. + + New methods were introduced: + * Net::DNS::Packet->parse() + * Net::DNS::RR->parse() + * Net::DNS::Question->parse() + + The Packet class now defers parsing of authority/additional until + their content is really needed. This should cause a bit of + performance improvement. + + Dick Franks is acknowledged for this Good Work (TM). + + Added 20081216 see NOTE above under rt.cpan.org # 40249 + +Feature: the Net::DNS::Packet's answersize() method will from now on + ignore its arguments and just return the size of the packet. + +Feature: The Net::DNS::RR->new() method used to call + Net::DNS::RR->new_from_data() whenever called with the appropriate + combination of arguments. That (undocumented) behavior has been deprecated. + Use Net::DNS::RR->new_from_data() directly if you depended on that. + +Feature: Net::DNS::Packets unique_push now ignores the TTL in + comparison of uniqueness, this is closer to the intent of + RFC2181, but not yet fully compliant. + +Fix rt.cpan.org #29816 + Acquiring the IP address for the Resolver under Cygwin is made + more resilient. + +Fix rt.cpan.org #31425 + Empty question section in Base.pm search method detected + +Fix rt.cpan.org #31042 + Makefile corrected to add a library target. + +Fix rt.cpan.org #29818 + 10-recurse.t used to fail in very specific environment (where a query for + qname="." and qtype="NS" would return with an empty additional section). + Fixed by adding the hints explicitly; this also forces the tests to take + place under the root served by a-m.root-servers.net + + +Fix rt.cpan.org #29877 + Made 00-version.t recognize a "GIT" environment. + + + + +Fix rt.cpan.org #29878 + + SPF.pm did not evaluate as true. Thanks Bjorn Hansen. + + +Fix rt.cpan.org #21398 + answersize() and answerfrom() set for persistent sockets + +Fix rt.cpan.org #29883 + Fix various tests only available through SVN, so they are + more robust (Acknowledgements Bjoern Hansen) + + +Fix rt.cpan.org #24343 + Resolver's nameserver() method would do silly things with undefined + arguments. + +Fix rt.cpan.org #29531 + Nameserver.pm, Packet.pm and Question.pm modified to avoid erroneous PTR + lookup in response to mischievous query packet containing an IP address. + + +Fix rt.cpan.org #27970 better netdns.o + + Marek Rouchal provided two minor improvements for linking the C + code snippets + + +Fix rt.cpan 28345 + + A fix in Test::Simple revealed an off by 1 error in the testplan + for 05-rr-rrsort.t. The fix is to remove a test, creating a dependency + on Test::Simple 0.71 seemed overkill. + + + +*** 0.61, 1 August 2007 + +Fix rt.cpan.org #28106, 28198, and 28590 + Modification of $_ in various places. + +Fix + t/11-inet6 assumed lowercase domain names. + +*** 0.60 20 June 2007 + +Fix spelling mistakes in change log using interactive spell checker (aspell). + +Fix + Two redundant calls of $self->rdatastr() in Net::DNS::RR::string(). + +Fix rt.cpan.org #27285 bis + Unreleased 0.59_1 dn_expand_PP() has security flaw allowing access to + arbitrary data using crafted packet with out of range compression pointer. + Patch by Dick Franks based on 0.59 code. + +Fix rt.cpan.org #27391 + dn_compress() produces corrupt packet for name containing empty label. + +Fix rt.cpan.org #26957 + dn_compress() croaks for name having label which exceeds 63 characters. + Patch by Dick Franks truncates offending label. + +Feature check_soa test of NCACHE TTL + Dick Franks supplied an improved version of check_soa script which + performs a direct test of NCACHE TTL by looking up non-existent name and + reporting value if it exceeds 86400. Test is skipped unless minimumTTL is + above same threshold. Recent BIND implementations impose a ceiling on + NCACHE TTLs internally, so a large minimumTTL value is unlikely to have + damaging consequences at many sites. + +Fix rt.cpan.org #27285 + Break out of malformed packets with compression loops. + Steffen Ullrich is acknowledged for patch and test code. + +Feature check_zone "alternate domain" and "exception file" flags + Paul Archer supplied a patch for check_zone adding two new features. + +Feature Support for IPSECKEY RR + Rudimentary IPSECKEY RR support added. + +Fix rt.cpan.org #25342 + HINFO would only accept its data fields within quotes. That has now + been fixed to adhere to by inheriting parsing functions + from TXT. + +Fix rt.cpan.org #24631 / Feature IP address prefix notation + Dick Franks supplied a cleaned up version of Question.pm. + + Revised code deals with incomplete IPv6 address bug and accepts RFC4291 + address prefix notation. IPv4/prefix also supported for completeness. + + This involved a minor change to the API for reverse IP lookup. Changing + qtype to PTR is now performed for A and AAAA only. This allows queries + for NS and SOA records at interior nodes to be specified using the address + prefix. Type ANY queries now also produce the expected result. + + Cleaned up TYPE/CLASS reversal code, exploiting fact that the intersection + of the sets of class and type names contains only one member (ANY). + + Minor cleanup of remaining code. + + +Fix rt.cpan.org #22019 + + Expunge trailing dots from RR->new_from_hash() FQDN arguments. + Patch by Dick Franks. + +Fix Recursion and EDNS OPT record + + The Recursive resolver process would add an OPT-RR with each recursion + which causes FORMERRs with a number of authoritative servers. + +Feature SSHFP warn instead of die + + We do not die if a not implemented fingerprint type value is read + from the wire, instead we 'warn' and return undef. + +Feature NSEC3PARAM hook + + A hook to load NSEC3PARAM when available has been added. + WARNING: Both NSEC3 and NSEC3PARAM are configured with their + experimental type codes. + +Feature rt r24525 + + Net::DNS::Resolver depended on Net::IP (2268 Kb) which depends on + heavy module Math::BigInt (1780 Kb). Valery Studennikov suggested to + ship Net::DNS::Resolver::Base with its own copies of ip_is_ipv[4|6] and + supplied a patch with those functions stripped from Net::IP. + + Note that the package still depends on Net::IP because + Net::DNS::Nameserver and a few tests depend on it. + +Fix rt 22334 + Fixed "perl Makefile.PL --xs" behavior, patch by Tamas Palfalvi + +Fix rt 21752 and 24042 + Applied the patch supplied by Alexandr Ciornii to be able + to compile on ActiveState perl . + Slight modifications based on comments by nimnul + + +Fix rt 23961 + Randomized the ID on the queries. Thanks to "hjp" for reporting and + suggesting a fix. + + The randomization of the src port is supposed to be handled by the + setting the source port to "0" (default). Overriding the default + or using persistent sockets may be problematic. + + Also see: + http://www.potaroo.net/ietf/idref/draft-hubert-dns-anti-spoofing/ + +Fix + Minor compile time warnings for netdns.c on Fedora Core. + + + + +*** 0.59 September 18, 2006 + + + +Fix rt.cpan.org 20836, 20857, 20994, and 21402 + + These tickets all revolved around proper reverse mapping of IPv6 + addresses. + + Acknowledgments to Dick Franks who has provided elegant solutions and + cleaned a bit of code. + + Note that directly calling Question->new() without arguments will + cause the qclass,qtype to be IN, A instead of ANY, ANY. + + Net::DNS::Resolver's search() method would always gracefully + interpret a qname in the form of an IPv4 address. It would go out + and do a PTR query in the reverse address tree. This behavior has + also been applied to IPv6 addresses in their many shapes and + forms. + + This change did two things, 1) root zone not implicitly added to + search list when looking up short name, 2) default domain appended + to short name if DEFNAMES and not DNSRCH. + + +Fix rt.cpan.org 18113 + + Minor error due to unapplied part of patch fixed. + +Feature: Experimental NSEC3 hooks. + + Added hook for future support of (experimental) NSEC3 support + (NSEC3 having an experimental type code). + + + + +*** 0.58 July 4, 2006 + +Feature: hooks for DLV support in Net::DNS::SEC + + added hooks for DLV support which is/will be available in + Net::DNS::SEC as of subversion version 592 (Tests are done against + the subversion number, not against the perl release version) + Net::DNS::SEC version 0.15 will have DLV support. + +Partly Fixed rt.cpan.org 18940 + + djhale noticed a number of error conditions under which the + udp_connection in Nameserver dies. We now print a warning instead + of dying. + + +Fix rt.cpan.org 18958 + + Fixed typebyname croak for SIGZERO. Acknowledgments to djhale. + + +Optimize rt.cpan.org 11931 + + Hanno Stock optimized the method to get the list of available + interfaces in Win32. I have only done very rudimentary tests on + my Windows XP system. + +Fix dependency on "CC" rt.cpan.org 19352 + + The Makefile.PL depended on availability of "cc" and would bail + out on systems where gcc is exclusively available. Thanks to Rob + Windsor for noticing and patching. + +Fix compressed dnames in NAPTR/SRV + + Clayton O'Neill noted that the domain names in the NAPTR and + SRV RRs rdata were subject to name compression which does not + conform to specs. Also see RFC 2782 and 2915. + + +Fix rt.cpan.org 18897 + + Zero-length rdata in TXT fixed (Acknowledgments to Roy Arends) + +Fix rt.cpan.org 18785 + + SPF would not work unless the TXT RR was already loaded. + SPF fully inherits TXT and loading of TXT.pm is therefore a + prerequisite. + + +Fix rt.cpan.org 18713 + + Net::DNS::Resolver now deals gracefully with persistent sockets + that got disconnected. It will first try to connect again to the + socket and if that fails it will try to connect to the next + available nameserver. tcp_timeout() is the parameter that + determines how long to wait during a reconnect. + +Fix rt.cpan.org 18268 + + Added reference to RFC in croak message for label length > 63 in + dn_comp(). + +Fix rt.cpan.org 18113 + + The inet6 tests contained another bug when online-tests were disabled. + Klaus Heinz discovered and provided a patch. + +*** 0.57 February 24, 2006 + +Fix rt.cpan.org 17783 + + The inet6 tests do not skip enough tests when ipv6 is not available. + I did not catch this in my setup since IPv6 is available on all my + machines. + + Since this breaks automatic CPAN installs a new release is + reasonable. + + +*** 0.56 February 20, 2006 + +Fix rt.cpan.org 17694 + + Net::DNS::typesbyval() now confesses on undefined + args. Acknowledgments to Dean Serenevy. + +Feature Implemented SPF (typecode 99). + + The class completely inherits from Net::DNS::RR::TXT (the easiest + RR to implement ever). + +Feature added rrsort() function. + Feature was requested by Eric Hall in rt.cpan.org 13392 + + This was a little tricky as I think that the sort functions are in + fact RR specific class attributes that should be accessed through + class methods. This is difficult to implement. I do think I found a + fairly clean manner. It does require a global variable in Net::DNS + to store the functions and some trickery when the sorting functions + are defined. + + See Net::DNS and Net::DNS::RR documentation for details. + + Defaults sorting functions are currently implemented in + SRV: default sort: low priority to high priority and for + same preference highest weight first. + weight: sort all RRs based on weight, highest first + priority: see default sort + + MX: default sort: lowest preference first. + preference: see default sort + + NAPTR: default sort: lowest to highest order, for same order lowest + preference first + order: see default sort + preference: order on preference, lowest first + + PX: See MX + RT: See MX + + +Fix rt.cpan.org 14653 and 14049 + TCP fallback after V6 socket failure + + Reworked Net::DNS::Base::Nameserver::send_tcp() to fallback to IPv4 when + possible. (change applied to SVN Revision 538). + + +Feature Cleanup duplicated code + + axfr_send() and send_tcp() contained some duplicated code. I merged + this in one "helper" method _create_tcp_socket() + + + +Fix AXFR persistent sockets colliding with query sockets. + + I think that using the same persistent sockets for AXFR and + 'ordinary' queries could lead to race conditions. Better safe than + sorry. For axfrs we create a different set of persistent sockets. + + Note that this prevents performing a SOA query first and then using + the same socket for the zone transfer itself(in Net::DNS these are + different code paths). This behavior of SOA and transfer on the + same socket-- seems to be suggested by 1035 section 4.2.2: + + "In particular, the server should allow the SOA and AXFR request + sequence (which begins a refresh operation) to be made on a + single connection." + + Obviously, on the client side this behavior is not mandatory. + + +Fix rt.cpan.org 17596 + + The fixes and features above also fixed the timeout problem reported by + Paul Hoffman + + +Profiling + + It turned out that each time we were calling + Net::DNS::Resolver::Base::nameserver(); We were creating a + resolver object. Now a resolver object is only called when a + domain name is given as argument. + + +**** 0.55 December 14, 2005 + +Fix Inconsistency in test + + There was an inconsistency in the t/05-rr.t that got triggered by + the release of Net::DNS::SEC version 0.13 (when installed). That + has been fixed. + +Feature Net::DNS::Nameserver loop_once() + + Uncommented the documentation of the loop_once() function and introduced + get_open_tcp() that reports if there are any open TCP sockets (useful + when using loop_once(). + + loop_once() itself was introduced in version 0.53_02 + + +Fix rt.cpan.org 16392 + + TCP Sockets stayed open even if not requested. This may cause the kernel + to run out of TCP slots. + + This bug is the reason for releasing version 0.55 shortly after 0.54. + + Spotted and patched by Robert Felber. + + +*** 0.54 December 7, 2005 + + +Fix rt.cpan.org 15947 + + Failure to bind a nameserver when specifying an IPv6 address. + +Fix rt.cpan.org 11931 + + Using Net-DNS 0.53 on Win XP, it is unable to retrieve the + nameservers when the IP address of the interface is assigned by + DHCP. This is due to the DHCP assigned IP address being stored in + DhcpIPAddress rather than IPAddress (which is then 0.0.0.0). Adding + a check of DhcpIPAddress existence and not being 0.0.0.0 fixes the + problem. Applied the patch submitted by "orjan". + +Fix rt.cpan.org 15119 + + main_loop() consumed 100% of CPU, because of a bug that + caused loop_once() to loop ad infinitum. + +Fix rt.cpan.org 15299 + + Defining multiple constants with 'use constant { BLA => 1, FOO =>2 }; + is a backwards incompatible feature. Thanks to Ian White for spotting and + fixing this. + +*** 0.53_02 Oct 18, 2005 + + + +Fix rt.cpan.org 14046 + + RRSIGs verify and create failed for a number of RR types. The + error message showed something like: + Can't call method "dn_comp" on an undefined value + This was caused by an omission in the _canonicalRdata() method + in Net::DNS::RR that was inherited by all failing RR types. + + Code was added to t/05-rr.t that will test signature creation + if Net::DNS::SEC is available and can be loaded. + + +Feature async nameserver behaviour. + + In rt.cpan.org 14622 Robert Stone suggested: + + The fact that it needs to take over the main running thread + limits its audience. Since many daemon programs are already + driven by a top level select loop, it seems useful to provide an + API for the user to integrate Net::DNS::Nameserver processing to + their own select loop. + + He also supplied example code for which he is hereby acknowledged. + The patch was not used because simultaneously Robert Martin-Leg�ne + supplied a patch to Nameservers.pm that allowed the same async + functionality through the use of loop_once method. Robert M-L's + code also carefully manages the TCP sockets, so that they can + deal with AXFRs. + + Robert S. has been so kind to review Robert M-L's code and is hereby + kindly acknowledged. + + NB. Since the code may be subject to change the documentation of the + loop_once method has been commented out. + + +Fix bgsend srcaddr for IPv6 Achim Adam previously noticed that the + source address wildard "::" works provides better portability than + "0". We forgot to fix the bgsend() part earlier. + + + +Fix rt.cpan.org 14624 + + Fixed documentation of Nameserver.pm Replyhandler and fixed a bug + that prevented the peerhost to be set. + +Fix rt.cpan.org 14700 + + mistyped _name2wire helper function name. Noticed and patched by Simon + Josefsson. + +Fix rt.cpan.org 13944 + + Terminating dot not printed when printing SRV record. The SRV dname should + be printed as FQDN, that is, including the dot at the end. + Acknowledgments Jakob Schlyter. + + While adding the "dot" I noticed that in the fileformat parsing code + there might be theoretical corner cases where rdata elements are not + properly read. The code needs an audit for this. + +Fix srcport for socket creation in bgsend method + + Lionel Cons noted and patched a small bug in bgsocket creation code for + lib/Net/DNS/Resolver/Base.pm + + +*** 0.53_01 July 31, 2005 + +Fix rt.cpan.org 13809 + + "Phar" noted that the peerhost is never passed to the make_reply function + in nameserver.pm and provided the trivial patch. + +Fix rt.cpan.org 13922 + + Fixed a problem with persistent TCP sockets which was introduced + because of using the address family as an index to the array of + persistent sockets. + + Used AF_UNSPEC for the array index for the TCP socket; just to choose + a number. The key to the persistent sockets is the remote nameserver:port + combination. + + Acknowledgments to Mike Mitchell for reporting the bug and testing + the solution. + +Feat t/01-resolve will not try to do tests from private IP space; hopefully + that cuts down on the number of false positives. + + +*** 0.53 July 22, 2005 + +Fix rt.cpan.org 13669 + + Danny Thomas provided a somewhat more elegant line of code for the + typesbyval regexp. + +Fix rt.cpan.org 13534 + + Net::DNS::Resolver::Recurse would bail out when it happened to run + into lame servers. + +Doc rt.cpan.org 13387 + + Documented the BUG caught by Robert Martin-Leg�ne + Net::DNS::Nameserver running with multiple IP interfaces might + violate section 4 of RFC2181. + + +Fix IPv6 on AIX + + Binding to the local interface did not work when local address was + specified as "0" instead of "::". The problem was identified, + reported and fixed by Achim Adam. + + + +Fix rt.cpan.org 13232 + One uncaught AF_INET6. + +*** 0.52 July 1, 2005 + +Feature + Net::DNS::RR::OPT + + added the the size(), do(),set_do() and clear_do() methods. + + + +*** 0.51_02 June 22, 2005 + + +Fix rt.cpan.org 13297 + + Persistent_udp option broken starting in version 0.50. + This was fixed, based on a patch by Sidney Markowitz. + Guido van Rooij independently submitted a similar patch. + +Fix rt.cpan.org 13289 + + Was caused by a typo. + +Fix rt.cpan.org 13243 and 13191 + + The escaped characters test failed on some system because the + the systems dn_expand instead of the supplied dn_expand + was used after the makemaker magic linked DNS.xs. + + This was fixed by renaming the dn_expand that comes with the + library to netdns_dn_expand. + + +Fix rt.cpan.org 13239: + + When queries are refused the resolver would not take the next + nameserver on the nameserver list for its next try but skip one. + + I was also made aware that the "use byte" pragma is incompatible + with pre 5.06 perl. + + BEGIN { + eval { require bytes; } + } + + + It should be noted that for perl versions < 5.006 I had to disable + the escaped character test. Don't expect domain names with labels + that contain anything else than host names to work for versions + earlier than perl 5.6.0. + + Thanks to Vladimir Kotal for the assistance in testing the code on + his system and the members of the NL-PM list for suggestions and + education. + + +*** 0.51_01 June 14, 2005 + +Fix rt.cpan.org 13232: + + Replaced IF_INET6 by IF_INET6() so that use strict subs does not + complain in the absence of a definition of IF_INET6 in earlier + versions perl that did not have IF_INET6 defined in Socket.pm + The problem is similar to the problem described in: + http://lists.ee.ethz.ch/mrtg-developers/msg00198.html + + + +*** 0.51 June 10, 2005 + +Fix rt.cpan.org 13184: + + Removed a 'stale' debug line (oops). A "stale" debug line may + cause clutter in log files which may cause false positives on log + analysis tools. Harmful enough to warrant a quick patch. + + +*** 0.50 June 8, 2005 + +No changes with respect to 0.49_03. + + +*** 0.49_03 June 1, 2005 (Version 0.50 release candidate 3) + +Fix: + Concatenation of scalars caused modification of data because of + Perl's habit to treat scalars as utf characters instead of bytes. + Inserted use bytes pragma throughout the code base. DNS is done + in octets. + +Feature: + Added "ignqrid" as an attribute to the Resolver. + + use as: + ok (my $res=Net::DNS::Resolver->new(nameservers => ['127.0.0.1'], + port => 5354, + recurse => 0, + igntc => 1, + ignqrid => 1, + ), + + When the attribute is set to a non-zero value replies with the + qr bit clear and replies with non-matching query ids are + happily accepted. This opens the possibility to accept spoofed + answers. YOU CAN BURN YOURSELF WITH THIS FEATURE. + + It is set to 0 per default and remains, except for this changes file + an undocumented feature. + + +*** 0.49_02 May 28, 2005 (Version 0.50 release candidate 2) + +Fix: Smoking Gun tests for non-cygwin Win32. + Makefile.PL failed to produce a proper Makefile under win32. + (e.g. www,nntp.perl.org/group/perl.cpan.testers/210570) + I worked around that by moving the library into the base + directory of the distribution as the "subdir" section + seemed to be all funny. + +Fix: rt.cpan.org#11931 (the off-topic part) + + Sidney Markowitz spotted an awkward condition that rarely happens but is + significant enough to be dealt with. + + In the send_udp method there are two loops: one over the nameservers + and one that waits for the sockets to come forward with data. + + That second loop will sometimes timeout and then be entered with a + repeated query to the same nameserver. It occasionally happens that the + old packet arrives on the socket. That packet is discarded but the + loop does not return to the loop to wait for the remainder of the + timeout period for an answer on the second query, that may still arrive. + This has now been fixed. + + Thanks to Sidney for the assessment of the problem and the fix. + + + +*** 0.49_01 (Version 0.50 release candidate 1) + +Fix: Makefile.PL: Minor tweak to recognize Mac OS X 10.4 not so relevant + since netdnslib is distributed with the code. + +Feature: Calling the Net::DNS::Resolver::dnssec method with a non-zero + argument will set the udppacketsize to 2048. The method will + also carp a warning if you pass a non-zero argument when + Net::DNS::SEC is not installed. + + +Feature: IPv6 transport support + + IPv6 transport has been added to the resolver and to the + nameserver code. + + To use IPv6 please make sure that you have IO::Socket::INET6 version + 2.01 or later installed. + + If IPv6 transport is available Net::DNS::Resolver::Recurse will make + use of it (picking randomly between IPv4 and IPv6 transport) use + the force_v4() method to only force IPv4. + + + +Feature: Binary characters in labels + + RFC 1035 3.1: + + Domain names in messages are expressed in terms of a sequence of + labels. Each label is represented as a one octet length field + followed by that number of octets. Since every domain name ends + with the null label of the root, a domain name is terminated by a + length byte of zero. The high order two bits of every length octet + must be zero, and the remaining six bits of the length field limit + the label to 63 octets or less. + + Unfortunately dname attributes are stored strings throughout + Net::DNS. (With hindsight dnames should have had their own class + in which one could have preserved the wire format.). + + To be able to represent all octets that are allowed in domain + names I took the approach to use the "presentation format" for + the attributes. This presentation format is defined in RFC 1035 + 5.1. + + I added code to parse presentation format domain names that has + escaped data such as \ddd and \X (where X is not a number) to + wireformat and vice verse. In the conversion from wire format to + presentation format the characters that have special meaning in a + zone file are escaped (so that they can be cut-n-pasted without + pain). + + These are " (0x22), $ (0x24), (0x28), ) (0x29), . (0x2e) , ; + (0x3b), @ (ox40) and \ (0x5c). The number between brackets + representing the ascii code in hex. + + Note that wherever a name occurs as a string in Net::DNS it is + now in presentation format. + + For those that dealt with 'hostnames' (subset of all possible + domain names) this will be a completely transparent change. + + Details: + + I added netdnslib which contains Net::DNS's own dn_expand. Its + implemented in C and the source is a hodgepodge of Berkeley based + code and snippets from ISC's bind9 distribution. The behavior, in + terms of which chars are escaped, is similar to bind9. + + There are some functions added to DNS.pm that do conversion from + presentation and wire format and back. They should only be used + internally (although they live in EXPORT_OK.) + + + For esoteric test cases see t/11-escapedchars.t. + +Fix: rt.cpan.org #11931 + Applied the patch suggested by "Sidney". It is a practical workaround + that may not be portable to all versions of the OS from Redmond. See + the ticket for details. + + + +*** 0.49 March 29, 2005 + + No changes wrt 0.48_03. + + +*** 0.48_03 March 22, 2005 (Version 0.49 release candidate 3) + +Fix: Only remove leading zeros in the regular expressions for typesbyval + and classbyval methods. (patch by Ronald v.d. Pol) + +Fix: Properly return an empty array in the authority, additional and answer + methods (patch by Ronald v.d. Pol) + + +Fix: rt.cpan.org #11930 + Incorrect searchlist duplication removal in Net::DNS::Resolver::Win32 + Patch courtesy Risto Kankkunen. + +Problem: rt.cpan.org #11931 + + Win32.pm used the DNSRegisteredAdapters registry key to determine which + local forwarders to send queries to. This is arguably the wrong key as it + is used to identify the server which to send dynamic updates to. + + A real fix for determining the set of nameservers to query has not been + implemented. For details see + https://rt.cpan.org/Ticket/Display.html?id=11931 + + +*** 0.48_02 March 14, 2005 (Version 0.49 release candidate 2) + +Fix: Bug report by Bernhard Schmidt (concerning a bug on the IPv6 branch). + + The bug caused dname compression to fail and to create + compression pointers causing loops. + +*** 0.48_01 March 7, 2005 (Version 0.49 release candidate 1) + +Fix: rt.cpan.org #8882 + No redundant lookups on SERVFAIL response + and #6149 + Does not search multiple DNS servers + + Net::DNS::Resolver will now use the other nameservers in the + list if the RCODE of the answer is not NOERROR (0) or NXDOMAIN + (3). When send() exhausted the last nameserver from the it will + return the answer that was received from the last nameserver + that responded with an RCODE. + + The errorstring will be set to "RCODE: " + + +Fix: rt.cpan.org #8803 + TXT records don't work with semicolons + + Since we are expecting "zonefile" presentation at input + a comment will need to be escaped ( \; ). + + It could be argued that this is a to strict interpretation of + 1035 section 5.1. + + While working on this I discovered there are more problems with + TXT RRs. Eg; 0100 is a perfectly legal character string that + should be represented as "\000" in a zonefile. Net::DNS does + pass character strings with "non-ASCII" chars from the wire + to the char_str_lst array but the print functions do not + properly escape them when printing. + + Properly dealing with zonefile presentation format and binary + data is still to be done. + + +Fix: rt.cpan.org Ticket #8483 + eval tests for DNS::RR::SIG fail when using a die handler + (Thanks Sebastiaan Hoogeveen) + + Patch applied. + +Fix: rt.cpan.org: Ticket #8608 + Net::DNS::Packet->data makes incorrect assumptions + + Implemented the "pop" method for the question. + Since having a qcount that is not 1 is somewhat rare (it appears + in TCP AXFR streams) the ability to pop the answer from a question + has not been documented in the "pod" + + Also fixed the incorrect assumption. + + (Thanks Bruce Campbell.) + + +Fix: Ticket #11106 + Incorrect instructions in README + + Corrected in the README and in Makefile.PL + + +Olaf Kolkman took over maintenance responsibility from Chris +Reinhardt. This involved importing the code into another subversion +repository. I made sure the numbers jumped, but I did not have access +to the "original" subversion repository so I lost some of the history. + + +*** 0.48 Aug 12, 2004 + + +Net::DNS is now stored in a subversion repository, replacing cvs. +As such the submodule version numbers have taken another big jump. +Luckily those numbers don't matter as long as they work. + +Fixed a bug with Unknown RR types that broke zone signing [Olaf]. + +Added callback support to Net::DNS::Resolver::Recurse. The +demo/trace_dns.pl script demonstrates this. + +Added a note regarding answers with an empty answer section to the +Net::DNS::Resolver::search() and Net::DNS::Resolver::query() +documentation. + +The copyright notice for Net::DNS::RR::SSHFP was incorrect. That file +is Copyright (c) 2004 RIPE NCC, Olaf Kolkman. + +*** 0.47_01 May 6, 2004 + +** NOTICE ** + +RR subclasses no longer pull in parts of Net::DNS; Net::DNS is assumed +to be up and running when the subclass is compiled. If you were using a +RR subclass directly, this may break your code. It was never documented +that you could use them directly however, so hopefully you never did... + +Fixed bug where SRV records with a priority of 0 did not function +correctly. CPAN #6214 + +Calls to various constants where using the &NAME syntax, which is not +inlined. Changed to NAME(). + +Added SSHFP support. [Olaf] + +CERT fixes. [Olaf] + +*** 0.47 April 1, 2004 + +safe_push() is back in Net::DNS::Packet, due to the excellent debate +skills of Luis E Munoz. However, the name safe_push() is deprecated, +use the new name unique_push() instead. + +Fixed a bug in Net::DNS::Nameserver which caused the class to build +packets incorrectly in some cases. [Ask Bjorn Hansen] + +Error message cleanups in Net::DNS::typesbyname() +and Net::DNS::typesbyval() [Ask Bjorn Hansen] + +Net::DNS::RR::new_from_hash() now works with unknown RR types [Olaf]. + +*** 0.46 February 21, 2004 + +IPv6 reverse lookups can now be done with Net::DNS::Resolver::search(), +as well as with query(). + +Hostnames can now be used in the 'nameservers' argument to +Net::DNS::Resolver->new() + +*** 0.45_01 February 9, 2004 + +Net::DNS now uses UDP on windows. + +Removed Net::DNS::Select from the package. IO::Select appears to work +on windows just fine. + +Fixed a bug that caused MXes with a preference of 0 to function +incorrectly, reported by Dick Franks. + +Net::DNS had a few problems running under taint mode, especially under +cygwin. These issues have been fixed. More issues with taint mode may +lie undiscovered. + +Applied Matthew Darwin's patch added support for IPv6 reverse lookups to +Net::DNS::Resolver::query. + +*** 0.45 January 8, 2004 + +No changes from 0.44_02. + +** 0.44_02 January 3, 2004 + +The XS detection code was broken. We actually use the XS bits now. + +Major cleanups/optimizations of the various RR subclasses. This release +of Net::DNS is over twice as fast at parsing dns packets as 0.44. + +** NOTICE ** + +$rr->rdatastr no longer returns '; no data' if the RR record has no +data. This happens in $rr->string now. + +Net::DNS::Packet::safe_push() no longer exists. The method is now only +available from Net::DNS::Update objects. + + +** 0.44_01 January 3, 2004 + +Net::DNS::RR objects were not playing nice with Storable, this caused +the axfr demo script to fail. Thanks to Joe Dial for the report. + +** NOTICE ** +This may cause RR objects that are already serialize to not deserialize +correctly. + +Reply handlers in Net::DNS::Nameserver are now passed the query object. + +Fixed a nasty bug in Nameserver.pm related to the qr bit. As Olaf +explained: + + Replies are sent if the query has its "qr" bit set. The "qr" bit is an + indication that the packet is sent as a response to a query. Since + there are more implementations that suffer from this bug one can cause + all kinds of nasty ping-pong loops by spoofing the initial packet or + have an infinite query loop by spoofing a query from the localhost:53 + address. + +Various Win32/Cygwin cleanups from Sidney Markowitz. + + +*** 0.44 December 12, 2003 + + The Wrath of CPAN Release. + +CPAN.pm doesn't understand the nature of revision numbers. 1.10 is +newer than 1.9; but CPAN.pm treats them as floats. This is bad. +All the internal version numbers in Net::DNS have been bumped to +2.100 in order to fix this. + +No actual code changes in this release. + + +*** 0.43 December 11, 2003 + +Added warning of deprecation of Net::DNS::Packet::safe_push. This will +move into Net::DNS::Update, as Net::DNS::Update is now a proper subclass +of Net::DNS::Packet. + +** 0.42_02 December 11, 2003 + +Fixed a long standing bug with zone transfers in the "many-answers" format. +CPAN #1903. + +Added the '--online-tests' flag to Makefile.PL. This activates the online +tests without asking the user interactively. "--no-online-tests" turns +the tests off. + +Cleaned up Makefile.PL a little. The "--pm" flag is now deprecated, use +"--no-xs" instead. + +Added support for unknown RR types (rfc3597). Note for developers: the +typesbyname, typesbyval, classesbyname and classesbyval hashes should +not be used directly, use the same named wrapper functions +instead. [Olaf Kolkman] + +Added two hashes for administrative use; they store which types are +qtypes and metatypes (rfc2929). [Olaf Kolkman] + +** 0.42_01 November 30, 2003 + +Major work to get Net::DNS functioning properly on Cygwin by Sidney +Markowitz. + +Fixed a bug in Net::DNS::Nameserver's error handling. CPAN #4195 + +*** 0.42 October 26, 2003 + +Fixed compilation problems on panther (Mac OS 10.3). + +Fixed a bug in Net::DNS::Resolver::Recurse which allowed an endless +loop to arise in certain situations. (cpan #3969, patch +by Rob Brown) + +Applied Mike Mitchell's patch implementing a persistent UDP socket. +See the Net::DNS::Resolver documentation for details. + +*** 0.41 October 3, 2003 + +Added some documentation about modifying the behavior of Net::DNS::Resolver. + +** 0.40_01 September 26, 2003 + +Fixed some uninitialized value warnings when running under windows. + +Fixed a bug in the test suite that caused 00-version.t to fail with +certain versions of ExtUtils::MakeMaker. Thanks to David James, Jos +Boumans and others for reporting it. + +Reply handlers in Net::DNS::Nameserver are now passed the peerhost. +(Assen Totin ) + +Reply handlers in Net::DNS::Nameserver can now tweak the header bits +that the nameserver returns. [Olaf] + +The AD header bit is now documented, and twiddlable. [Olaf] + +The change log has been trimmed, entries for versions older than 0.21 +have been removed. + +** NOTICE ** +Net::DNS::Resolver::axfr_old() has been removed from the package. +An exception will be thrown if you attempt to use this method. Use +axfr() or axfr_start() instead. + +*** 0.40 September 1, 2003 + +Various POD tweaks. + +** 0.39_02 August 28, 2003 + +Net-DNS-SEC updates, seems that IETF has been busy redefining DNSSEC. +[Olaf] + +Added version to all the modules in the distribution. + +** 0.39_01 August 12 2003 + +Added a META.yaml. The crystal ball says an upgrade to Module::Install may +be coming soon. + +Changed how the versions of the various submodules were set. The CPAN +indexer cannot execute "$VERSION = $Net::DNS::VERSION". The single line +with the $VERSION assignment is pulled out of the file and eval'ed; at +that time, Net::DNS is not loaded. The submodules now pull their version +numbers out of CVS. + +*** 0.39 August 7 2003 + +Fixed a bug on Win32 where some machines separated lists with commas, +not whitespace. Thanks to Jim White for pointing it out. + +** 0.38_02 July 29 2003 + +Reworked the POD for Net::DNS::Resolver. + +When parsing resolver configuration files, IPv6 addresses are now skipped, +as Net::DNS does not yet have IPv6 support. + +** 0.38_01 Jun 22 2003 + +Broke Net::DNS::Resolver into separate classes. UNIX and Win32 +classes are currently implemented. Many of the globals in +Net::DNS::Resolver no longer exist. They were never documented +so you never used them.... right? + +Options to Net::DNS::Resolver->new() are now supported, including +using your own configuration file. See the Net::DNS::Resolver man +page for details. + +Tweaked Net::DNS::RR::TXT to fail more gracefully when the quotes +in the data section are not balanced. + +Add more tests (of course). + +Moved next_id() from Resolver.pm to Header.pm (which is where it is +used). + +Net::DNS::Select now uses $^O directly, this means that the second +argument to Net::DNS::Select::new() (the OS) is now ignored. + +*** 0.38 Jun 5 2003 + +Various buglets fixed in the new Makefile.PL. + +Use Dynaloader instead of XSLoader. Turns out that XSLoader is only +in more recent perls. + +Added deprecation warning to Net::DNS::Resolver::axfr_old(). + +HP-UX fixes [cpan #2710], I don't have the name of the reporter/patcher. + +*** 0.37 May 28 2003 + +Renamed the test C file to compile.c, test.c was confusing the 'make test' +target. + +*** 0.36 May 28 2003 + +Removed Rob Brown's RPM stuff. Something odd happened in the 0.35 tarball +and at the moment I don't have the time to investigate. + +*** 0.35 May 26 2003 + +POD fixes, added tests for POD. + +*** 0.34_03 May 22 2003 + +Reworked Makefile.PL to try and detect if you have a working C compiler. + +Added '--pm' and '--xs' command line options to Makefile.PL + +Fixed linking problem on linux. + +Tie::DNSHash removed from the package, see Tie::DNS from CPAN for a more +complete implementation of a DNS hash. + +*** 0.34_02 May 21 2003 + +Net::DNS::Packet::dn_expand is now implemented using the function of the +same name from libresolv. This method of decompressing names is around +twice as fast as the perl implementation. + +Applied Jan Dubois's patch to fix nameserver lookup on Windows 2000/95/98/ME. + +*** 0.34 6 Mar 2003 + +Applied David Carmean's patch for handling more than one string in a +TXT RR's RDATA section. + +Applied Net::DNS::Resolver::Recurse bug fixes from Rob Brown. + +Added check of the answer's rcode in Net::DNS::Resolver::axfr_next(). + +Applied Kenneth Olving Windows changes. + +Applied patch from Dan Sully (daniel@electricrain.com) allowing multiple +questions to be part of a DNS packet. + +*** 0.33 8 Jan 2003 + +Fixed 00-load.t to skip the Net::DNS::SEC modules. The test suite +should now pass if you have Net::DNS::SEC installed. + +Fixed the regular expression in RR.pm to comply with the RFCs, turns +out we were _too_ paranoid. [Olaf] + + +*** 0.32 5 Jan 2003 + +Various cleanups for perl 5.004. Thanks to nathan@anderson-net.com +([cpan #1847]) + +Applied Olaf's SIG patch (thanks as always). + +Win32 now looks at the environment variables when building the +configuration defaults. Thanks to net-dns-bug@oak-wood.co.uk +(That's the only name I have... [cpan #1819]) + +Added Rob Brown's Net::DNS::Resolver::Recurse module. + + +*** 0.31 17 Nov 2002 + +Applied Olaf's patch for an initialization bug in OPT.pm + +Applied Rob Brown's patch for udp timeouts. + +Added stuff from Rob Brown for making RPM creation easier. + +Fixed a typo in FAQ.pod that was making apropos and whatis +grumpy. Thanks to Florian Hinzmann for pointing it out and a patch. + + +*** 0.30 7 Nov 2002 + +Applied Andrew Tridgell's (tridge@samba.org) patch for TKEY support. + +Added Net::DNS::Packet->safe_push() to allow for automatically +checking for duplicate RRs being pushed into a packet. Inspired by Luis +Munoz. + +Added more tests. + + +*** 0.29 2 Oct 2002 + +Fixed $_ from creeping out of scope in Resolver.pm. Thanks to +Ilya Martynov for finding the problem and the patch to fix it. + +Fixed divide by zero bug there is no usable network interface(s). +Thanks to twilliams@tfcci.com, misiek@pld.ORG.PL (and one other +person that I can't seem to find the address of) for reports. + + +*** 0.28 20 Aug 2002 + +Fixed a bug in the new AUTOLOAD routines that made it impossible to set +attributes to '0'. + +Fixed a bug in the RR patch that broke many updates. + + +*** 0.27 15 Aug 2002 + +Added (untested) support for perl 5.004. + +We now allow whitespace at the beginning of a RR. + +Fixed an issue that gave Net::DNS::SEC problems, %Net::DNS::RR::RR is now +in a scope that the Net::DNS::SEC hook can see it from. + +Fixed SRV records. + +Fixed debug message in Net::DNS::Resolver::bgread(). + + +*** 0.26 5 Aug 2002 + +Fixed various bugs in the test suite. + +Fixed warning in Net::DNS::RR::AUTOLOAD with perl 5.005. + +--- +Olaf Kolkman +Chris Reinhardt +Michael Fuhr + + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..1c5e8ea --- /dev/null +++ b/MANIFEST @@ -0,0 +1,204 @@ +Changes +contrib/check_soa +contrib/check_zone +contrib/dnswalk.README +contrib/find_zonecut +contrib/loc2earth.fcgi +contrib/loclist.pl +contrib/README +demo/axfr +demo/check_soa +demo/check_zone +demo/example_recurse.pl +demo/mresolv +demo/mx +demo/perldig +demo/README +demo/trace_dns.pl +lib/Net/DNS.pm +lib/Net/DNS/Domain.pm +lib/Net/DNS/DomainName.pm +lib/Net/DNS/FAQ.pod +lib/Net/DNS/Header.pm +lib/Net/DNS/Mailbox.pm +lib/Net/DNS/Nameserver.pm +lib/Net/DNS/Packet.pm +lib/Net/DNS/Parameters.pm +lib/Net/DNS/Question.pm +lib/Net/DNS/Resolver.pm +lib/Net/DNS/Resolver/android.pm +lib/Net/DNS/Resolver/Base.pm +lib/Net/DNS/Resolver/cygwin.pm +lib/Net/DNS/Resolver/MSWin32.pm +lib/Net/DNS/Resolver/os2.pm +lib/Net/DNS/Resolver/os390.pm +lib/Net/DNS/Resolver/Recurse.pm +lib/Net/DNS/Resolver/UNIX.pm +lib/Net/DNS/RR.pm +lib/Net/DNS/RR/A.pm +lib/Net/DNS/RR/AAAA.pm +lib/Net/DNS/RR/AFSDB.pm +lib/Net/DNS/RR/APL.pm +lib/Net/DNS/RR/CAA.pm +lib/Net/DNS/RR/CDNSKEY.pm +lib/Net/DNS/RR/CDS.pm +lib/Net/DNS/RR/CERT.pm +lib/Net/DNS/RR/CNAME.pm +lib/Net/DNS/RR/CSYNC.pm +lib/Net/DNS/RR/DHCID.pm +lib/Net/DNS/RR/DLV.pm +lib/Net/DNS/RR/DNAME.pm +lib/Net/DNS/RR/DNSKEY.pm +lib/Net/DNS/RR/DS.pm +lib/Net/DNS/RR/EUI48.pm +lib/Net/DNS/RR/EUI64.pm +lib/Net/DNS/RR/GPOS.pm +lib/Net/DNS/RR/HINFO.pm +lib/Net/DNS/RR/HIP.pm +lib/Net/DNS/RR/IPSECKEY.pm +lib/Net/DNS/RR/ISDN.pm +lib/Net/DNS/RR/KEY.pm +lib/Net/DNS/RR/KX.pm +lib/Net/DNS/RR/L32.pm +lib/Net/DNS/RR/L64.pm +lib/Net/DNS/RR/LOC.pm +lib/Net/DNS/RR/LP.pm +lib/Net/DNS/RR/MB.pm +lib/Net/DNS/RR/MG.pm +lib/Net/DNS/RR/MINFO.pm +lib/Net/DNS/RR/MR.pm +lib/Net/DNS/RR/MX.pm +lib/Net/DNS/RR/NAPTR.pm +lib/Net/DNS/RR/NID.pm +lib/Net/DNS/RR/NS.pm +lib/Net/DNS/RR/NSEC.pm +lib/Net/DNS/RR/NSEC3.pm +lib/Net/DNS/RR/NSEC3PARAM.pm +lib/Net/DNS/RR/NULL.pm +lib/Net/DNS/RR/OPENPGPKEY.pm +lib/Net/DNS/RR/OPT.pm +lib/Net/DNS/RR/PTR.pm +lib/Net/DNS/RR/PX.pm +lib/Net/DNS/RR/RP.pm +lib/Net/DNS/RR/RRSIG.pm +lib/Net/DNS/RR/RT.pm +lib/Net/DNS/RR/SIG.pm +lib/Net/DNS/RR/SMIMEA.pm +lib/Net/DNS/RR/SOA.pm +lib/Net/DNS/RR/SPF.pm +lib/Net/DNS/RR/SRV.pm +lib/Net/DNS/RR/SSHFP.pm +lib/Net/DNS/RR/TKEY.pm +lib/Net/DNS/RR/TLSA.pm +lib/Net/DNS/RR/TSIG.pm +lib/Net/DNS/RR/TXT.pm +lib/Net/DNS/RR/URI.pm +lib/Net/DNS/RR/X25.pm +lib/Net/DNS/Text.pm +lib/Net/DNS/Update.pm +lib/Net/DNS/ZoneFile.pm +Makefile.PL +MANIFEST This list of files +README +t/00-install.t +t/00-load.t +t/00-pod.t +t/01-resolver-env.t +t/01-resolver-file.t +t/01-resolver-flags.t +t/01-resolver-opt.t +t/01-resolver.t +t/02-domain.t +t/02-domainname.t +t/02-IDN.t +t/02-mailbox.t +t/02-text.t +t/03-header.t +t/03-question.t +t/03-rr.t +t/04-packet.t +t/04-packet-truncate.t +t/05-A.t +t/05-AAAA.t +t/05-AFSDB.t +t/05-APL.t +t/05-CAA.t +t/05-CDNSKEY.t +t/05-CDS.t +t/05-CERT.t +t/05-CNAME.t +t/05-CSYNC.t +t/05-DHCID.t +t/05-DLV.t +t/05-DNAME.t +t/05-DNSKEY.t +t/05-DS.t +t/05-EUI48.t +t/05-EUI64.t +t/05-HINFO.t +t/05-HIP.t +t/05-IPSECKEY.t +t/05-ISDN.t +t/05-L32.t +t/05-L64.t +t/05-LP.t +t/05-LOC.t +t/05-KEY.t +t/05-KX.t +t/05-MINFO.t +t/05-MX.t +t/05-NAPTR.t +t/05-NID.t +t/05-NULL.t +t/05-NS.t +t/05-NSEC.t +t/05-NSEC3.t +t/05-NSEC3PARAM.t +t/05-OPENPGPKEY.t +t/05-OPT.t +t/05-PTR.t +t/05-PX.t +t/05-RP.t +t/05-RRSIG.t +t/05-RT.t +t/05-SIG.t +t/05-SMIMEA.t +t/05-SOA.t +t/05-SPF.t +t/05-SRV.t +t/05-SSHFP.t +t/05-TKEY.t +t/05-TLSA.t +t/05-TSIG.t +t/05-TXT.t +t/05-URI.t +t/05-X25.t +t/06-packet-unique-push.t +t/06-update.t +t/07-rrsort.t +t/07-zonefile.t +t/08-IPv4.t +t/08-IPv6.t +t/08-recurse.t +t/21-TSIG-create.t +t/22-TSIG-verify.t +t/31-NSEC-typelist.t +t/32-NSEC3-typelist.t +t/33-NSEC3-hash.t +t/34-NSEC3-flags.t +t/35-NSEC3-match.t +t/36-NSEC3-covered.t +t/37-NSEC3-base32.t +t/41-DNSKEY-keytag.t +t/42-DNSKEY-flags.t +t/43-DNSKEY-keylength.t +t/51-DS-SHA1.t +t/52-DS-SHA256.t +t/54-DS-SHA384.t +t/61-SIG0-RSAMD5.t +t/65-RRSIG-RSASHA1.t +t/99-cleanup.t +t/NonFatal.pm +t/custom.txt +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/META.json b/META.json new file mode 100644 index 0000000..0b0e322 --- /dev/null +++ b/META.json @@ -0,0 +1,60 @@ +{ + "abstract" : "Perl Interface to the Domain Name System", + "author" : [ + "Dick Franks", + "Olaf Kolkman", + "Michael Fuhr" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", + "license" : [ + "mit" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Net-DNS", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "recommends" : { + "Digest::BubbleBabble" : "0.01", + "IO::Socket::IP" : "0.38", + "Net::LibIDN" : "0.12", + "Net::LibIDN2" : "1", + "Scalar::Util" : "1.25" + }, + "requires" : { + "Digest::HMAC" : "1.03", + "Digest::MD5" : "2.13", + "Digest::SHA" : "5.23", + "File::Spec" : "0.86", + "IO::File" : "1.08", + "IO::Socket" : "1.16", + "MIME::Base64" : "2.11", + "Test::More" : "0.52", + "Time::Local" : "1.19", + "perl" : "5.006" + } + } + }, + "release_status" : "stable", + "version" : "1.15", + "x_serialization_backend" : "JSON::PP version 2.27400_02" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..1d33f73 --- /dev/null +++ b/META.yml @@ -0,0 +1,40 @@ +--- +abstract: 'Perl Interface to the Domain Name System' +author: + - 'Dick Franks' + - 'Olaf Kolkman' + - 'Michael Fuhr' +build_requires: + ExtUtils::MakeMaker: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' +license: mit +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Net-DNS +no_index: + directory: + - t + - inc +recommends: + Digest::BubbleBabble: '0.01' + IO::Socket::IP: '0.38' + Net::LibIDN: '0.12' + Net::LibIDN2: '1' + Scalar::Util: '1.25' +requires: + Digest::HMAC: '1.03' + Digest::MD5: '2.13' + Digest::SHA: '5.23' + File::Spec: '0.86' + IO::File: '1.08' + IO::Socket: '1.16' + MIME::Base64: '2.11' + Test::More: '0.52' + Time::Local: '1.19' + perl: '5.006' +version: '1.15' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..ced520a --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,301 @@ +# +# $Id: Makefile.PL 1623 2018-01-26 14:23:54Z willem $ -*-perl-*- +# + + +BEGIN { + die < eval $ExtUtils::MakeMaker::VERSION; + + +# See perldoc ExtUtils::MakeMaker for details of how to influence +# the contents of the Makefile that is written. + +my @author = ( 'Dick Franks', 'Olaf Kolkman', 'Michael Fuhr' ); + +my %metadata = ( + NAME => 'Net::DNS', + VERSION_FROM => 'lib/Net/DNS.pm', + ABSTRACT_FROM => 'lib/Net/DNS.pm', + AUTHOR => MM < 6.58 ? "$author[0] et al" : [@author], + LICENSE => 'mit', + MIN_PERL_VERSION => 5.006, + ); + + +my %platform = ( ## platform-specific dependencies + MSWin32 => { + 'Win32::IPHelper' => 0.07, + 'Win32::API' => 0.55, + 'Win32::TieRegistry' => 0.24, + } ); + +my $platform = $platform{$^O} || {}; + + +my %prerequisite = ( + 'Digest::HMAC' => 1.03, + 'Digest::MD5' => 2.13, + 'Digest::SHA' => 5.23, + 'File::Spec' => 0.86, + 'IO::File' => 1.08, + 'IO::Socket' => 1.16, + 'MIME::Base64' => 2.11, + 'Time::Local' => 1.19, + 'Test::More' => 0.52, + %$platform + ); + + +my %optional = ( + 'Net::DNS::SEC' => 1.01, ## For information only + 'Digest::BubbleBabble' => 0.01, + 'IO::Socket::INET6' => 2.51, + 'IO::Socket::IP' => 0.38, + 'Net::LibIDN' => 0.12, + 'Net::LibIDN2' => 1.00, + 'Scalar::Util' => 1.25, + ); + + +my @debris = qw( + .resolv.conf + t/IPv6.enabled + t/online.enabled t/online.nonfatal + zone[0-9].txt zone[0-9][0-9].txt + ); + + +delete $optional{'Net::DNS::SEC'}; ## Note: MUST NOT be installed automatically + + +use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.32; 1;'; + +use constant USE_SOCKET_INET6 => defined eval 'require IO::Socket::INET6'; + +delete $optional{'IO::Socket::INET6'} if USE_SOCKET_IP; # exclude redundant dependency +delete $optional{'Net::LibIDN'} if eval 'require Net::LibIDN2'; + + +print < {%prerequisite}, + META_MERGE => {recommends => {%optional}}, + clean => {FILES => "@debris"}, + ); + + +# clean up the online testing flag file. +unlink("t/online.enabled"); +unlink("t/online.disabled"); + +# clean up the IPv6 testing flag file. +unlink("t/IPv6.enabled"); +unlink("t/IPv6.disabled"); + + +# +# Get the command line args +# + +my $help = 0; +my $IPv6_tests; +my $online_tests = 2; ## 2 = non-fatal, 1 = on, 0 = off ## + +my @options = ( + 'online-tests!' => \$online_tests, + 'non-fatal-online-tests' => sub { $online_tests = 2; }, + 'IPv6-tests!' => \$IPv6_tests, + 'help!' => \$help + ); + + +unless ( GetOptions(@options) ) { + print "Error: Unrecognized option.\n"; + print "Try perl Makefile.PL --help for more information\n"; + exit 1; +} + + +if ($help) { + print <new( + PeerAddr => "www.google.com:80", + Timeout => 10 + ); + + unless ($socket) { + $online_tests = 0; + print <$enable" ) || die "Can't touch $enable $!"; + close(ENABLED) || die "Can't touch $enable $!"; + + if ( $online_tests == 2 ) { + my $nonfatal = 't/online.nonfatal'; + open( NONFATAL, ">$nonfatal" ) || die "Can't touch $nonfatal $!"; + close(NONFATAL) || die "Can't touch $nonfatal $!"; + print "\nActivating Non Fatal Online Tests...\n"; + } else { + print "\nActivating Online Tests...\n"; + } + + $IPv6_tests = 1 unless defined $IPv6_tests; + if ( USE_SOCKET_IP || USE_SOCKET_INET6 ) { + if ($IPv6_tests) { + my $enable = 't/IPv6.enabled'; + print "\nActivating IPv6 Tests...\n"; + open( ENABLED, ">$enable" ) || die "Can't touch $enable $!"; + close(ENABLED) || die "Can't touch $enable $!"; + } + } + + print <{INSTALLDIRS}}, ')'; + for ($install_site) { + s/\$\(([A-Z_]+)\)/$self->{$1}/eg while /\$\(/; # expand Makefile macros + s|([/])[/]+|$1|g; # remove gratuitous //s + } + + eval 'require Net::DNS'; + my @version = grep $_, ( 'version', $Net::DNS::VERSION ); + + my $nameregex = '\W+Net\WDNS.pm$'; + my @installed = grep $_ && m/$nameregex/io, values %INC; + my %noinstall; + + foreach (@installed) { + my $path = $1 if m/^(.+)$nameregex/i; + my %seen; + foreach (@INC) { + $seen{$_}++; # find $path in @INC + last if $_ eq $path; + } + foreach ( grep !$seen{$_}, @INC ) { + $noinstall{$_}++; # mark hidden libraries + } + } + + return $self->SUPER::install(@_) unless $noinstall{$install_site}; + + warn <<"AMEN"; +## +## The install location for this version of Net::DNS differs +## from the existing @version in your perl library. +## @installed +## +## The installation will be rendered ineffective because the +## library search finds the existing version before reaching +## $install_site +## +## Makefile has been generated to support build and test only. +## +AMEN + + return <<'END'; +install : + $(NOECHO) $(ECHO) "## Makefile supports test build only" + $(NOECHO) $(ECHO) "## (see message from Makefile.PL)" + $(NOECHO) $(FALSE) +END +} + + +sub postamble { + return <<'END'; +test_cover : pure_all + cover -delete + HARNESS_PERL_SWITCHES=-MDevel::Cover $(MAKE) test + cover -summary +END +} + + +__END__ + diff --git a/README b/README new file mode 100644 index 0000000..5782301 --- /dev/null +++ b/README @@ -0,0 +1,336 @@ + +Net::DNS - Perl DNS Resolver Module +=================================== + + + TABLE OF CONTENTS + ----------------- + +1. Description +2. Availability +3. Prerequisites +4. Installation +5. Running Tests +6. Demonstration Scripts +7. Dynamic Updates +8. Signed Queries & Updates +9. DNSSEC +10. Bugs +11. Copyright +12. License +13. Staying Tuned +14. Acknowledgments + + +1. DESCRIPTION + ----------- + +Net::DNS is a DNS resolver implemented in Perl. It allows the programmer +to perform nearly any type of DNS query from a Perl script. For details +and examples, please read the Net::DNS manual page. + +To read about the latest features, see the Changes file. To find out about +known bugs and to see what is planned for future versions, see the CPAN RT +ticket list. + +The author invites feedback on Net::DNS. If there is something you would +like to have added, please let me know. If you find a bug, please send me +the information described in the BUGS section below. + +See http://www.net-dns.org/blog/ for announcements about Net::DNS. + + +2. AVAILABILITY + ------------ + +You can get the latest version of Net::DNS from the Comprehensive Perl +Archive Network (CPAN) or from the module's homepage: + + http://search.cpan.org/dist/Net-DNS/ + +or through + + http://www.net-dns.org/ + +Additionally a subversion repository is made available through + + http://www.net-dns.org/svn/net-dns/ + +The version on the "trunk" (http://www.net-dns.org/svn/net-dns/trunk) is +the version that is targeted for next release. + +Please note that the SVN version at any given moment may be broken. + + +3. PREREQUISITES + ------------- + +The availability of prerequisites for Net::DNS is tested at installation +time. These are the core packages that need to be available: + + Digest::HMAC + Digest::MD5 + Digest::SHA + File::Spec + IO::Socket + MIME::Base64 + Time::Local + Test::More + +The availability of these optional packages is tested at runtime: + + Digest::BubbleBabble + Digest::GOST + IO::Socket::INET6 + IO::Socket::IP + Net::DNS::SEC + Net::LibIDN + +You can obtain the latest version of Perl from: + + http://www.cpan.org + +Some of the demonstration and contributed scripts may require additional +modules -- see demo/README and contrib/README for details. + +Note that the Test::More module is actually part of the Test-Simple +distribution. See the FAQ (lib/Net/DNS/FAQ.pod) for more information. + + +4. INSTALLATION + ------------ + +Please install any modules mentioned in the PREREQUISITES section above. +If you do not, some features of Net::DNS will not work. When you run "perl +Makefile.PL", Perl should complain if any of the required modules is +missing. + +To build this module, run the following commands: + + tar xvzf Net-DNS-?.??.tar.gz + cd Net-DNS-?.?? + perl Makefile.PL + make + make test + make install + +If you do not wish to run the online tests, the '--no-online-tests' option +can be used. Similarly, '--online-tests' will enable the online tests. +Online tests will be run by default, but the result will not adversely +affect the outcome of test suite. + +Also, if you do not wish to run the IPv6 tests, the '--no-IPv6-tests' +option can be used. Similarly, '--IPv6-tests' will enable the IPv6 tests. + + +5. RUNNING TESTS + ------------- + +If any of the tests fail, please contact the author with the output from +the following command: + + make test TEST_VERBOSE=1 + + +6. DEMONSTRATION SCRIPTS + --------------------- + +There are a few demonstration scripts in the demo/ directory -- see +demo/README for more information. Contributed scripts are in the contrib/ +directory -- see contrib/README. + +The author would be happy to include any contributed scripts in future +versions of this module. All I ask is that they be documented (preferably +using POD) and that the contributor's name and contact information be +mentioned somewhere. + + +7. DYNAMIC UPDATES + --------------- + +Net::DNS supports DNS dynamic updates as documented in RFC 2136; for more +information and examples, please see the Net::DNS::Update manual page. + +Here is a summary of the update semantics for those interested (see RFC +2136 for details): + + PREREQUISITE SECTION + # RRs NAME TTL CLASS TYPE RDLENGTH RDATA + ----- ---- --- ----- ---- -------- ----- + yxrrset 1 name 0 ANY type 0 empty + yxrrset 1+ name 0 class type rdlength rdata + nxrrset 1 name 0 NONE type 0 empty + yxdomain 1 name 0 ANY ANY 0 empty + nxdomain 1 name 0 NONE ANY 0 empty + + + UPDATE SECTION + # RRs NAME TTL CLASS TYPE RDLENGTH RDATA + ----- ---- --- ----- ---- -------- ----- + add RRs 1+ name ttl class type rdlength rdata + del RRset 1 name 0 ANY type 0 empty + del all RRsets 1 name 0 ANY ANY 0 empty + del RRs 1+ name 0 NONE type rdlength rdata + + +8. SIGNED QUERIES & UPDATES + ------------------------ + +Net::DNS supports the TSIG resource record to perform signed queries and +updates (RFC 2845). See the Net::DNS::Packet and Net::DNS::Update manual +pages for examples. + +If you're using the BIND nameserver, the BIND FAQ shows how to generate +keys and configure the nameserver to use them: + + http://www.nominum.com/resources/faqs/bind-faq.html + +TSIG support is new and isn't yet complete. Please use with caution on +production systems. Feedback on TSIG functionality would be most welcome. + + +9. DNSSEC + ------ + +The extensions to enable the DNSSEC signature generation and verification +functions are distributed separately as Net::DNS::SEC. The package is +available from CPAN. + + +10. BUGS + ---- + +Net::DNS, although begun in 1997, is still under development and may still +contain a few bugs. Please see CPAN RT and Changes file for more +information. + +We recommend that you exercise caution when using Net::DNS to maintain a +production nameserver via dynamic updates. Always test your code +*thoroughly*. The Net::DNS authors accept no blame if you corrupt your +zone. That warning in place, We are aware of one large company that has +used Net::DNS to make thousands of dynamic updates per day for at least +three years without any problems. + +Please use the following form to submit bug reports: + + https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-DNS + +If you find any bugs, please report each in a separate "rt.cpan.org" +report along with the following information: + + * subject field containing a concise descriptive summary + * version of Perl (output of 'perl -V' is best) + * version of Net::DNS + * operating system type and version + * version of nameserver (if known) + * exact text of error message or description of problem + * the shortest possible program that exhibits the problem + * the specific queries you are making, if the fault can be + demonstrated using Internet nameservers + +If we do not have access to a system similar to yours, you may be asked +to insert some debugging lines and report back on the results. The more +focussed the help and information you provide, the better. + +Net::DNS is currently maintained at NLnet Labs (www.nlnetlabs.nl) by: + Willem Toorop. + +Between 2005 and 2012 Net::DNS was maintained by: + Olaf Kolkman and his team. + +Between 2002 and 2004 Net::DNS was maintained by Chris Reinhardt. + +Net::DNS was created in 1997 by Michael Fuhr. + + +11. COPYRIGHT + --------- + +Authorship of individual components and significant contributions is shown +in the copyright notice attached to the relevant documentation. Copyright +in all components is retained by their respective authors. + + +12. LICENSE + ------- + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +13. STAYING TUNED + ------------- + +http://www.net-dns.org is a web site dedicated to the development of +Net::DNS. Announcements about Net::DNS and Net::DNS::SEC will be done +through the Net::DNS weblog at http://www.net-dns.org/blog/. An RSS feed +for the weblog is available. + +If you want to have access to the latest and greatest code a subversion +repository is made available through + + http://www.net-dns.org/svn/net-dns/ + +The version on the "trunk" (http://www.net-dns.org/svn/net-dns/trunk) is +the version that is targeted for next release. + +Please note that code from the SVN repositories trunk and development +branches may be broken at any time. + + +14. ACKNOWLEDGMENTS + --------------- + +Thanks to Mike for letting me take care of his baby. + +Thanks to Chris for maintaining Net::DNS for a couple of years. + +Thanks to Olaf for maintaining Net::DNS for over eight years. + +Thanks to Rob Brown and Dick Franks for all their patches and input. + +Thanks to all who have used Net::DNS and reported bugs, made suggestions, +contributed code, and encouraged me to add certain features. Many of these +people are mentioned by name in the Changes file; lack of mention should +be considered an oversight and not a conscious act of omission. + +Thanks to Larry Wall and all who have made Perl possible. + +Thanks to Paul Albitz and Cricket Liu for allowing me [OK: that is Mike] +to write the Net::DNS section in the programming chapter of DNS and BIND, +3rd Edition. This chapter in earlier editions was very helpful while I +was developing Net::DNS, and I was proud to contribute to it. + +Thanks to Paul Vixie and all who have worked on the BIND nameserver, which +I've used exclusively while developing Net::DNS. + +Thanks to Andreas Gustafsson for DNAME support, and for all the work he +has done on BIND 9. + +Olaf acknowledges the RIPE NCC for allowing Net::DNS maintenance to take +place as part of 'the job'. + +Thanks to the team that maintains wireshark. Without its marvelous +interface, debugging of bugs in wireformat would be so much more +difficult. + +Thanks to the thousands who participate in the open-source community. I +have always developed Net::DNS using open-source systems and I am proud +to make Net::DNS freely available to the world. + + +---- $Id: README 1550 2017-03-08 13:14:14Z willem $ + diff --git a/contrib/README b/contrib/README new file mode 100644 index 0000000..52362f4 --- /dev/null +++ b/contrib/README @@ -0,0 +1,19 @@ +This directory contains contributed scripts and modules that use Net::DNS. +The Net::DNS author assumes no responsibility for them -- if you have +problems or questions, please contact the contributor. + + +File Contributor +------ ----------- +check_soa Dick Franks + +check_zone Dennis Glatting + +find_zonecut Dick Franks + +loc2earth.fcgi Christopher Davis + +loclist.pl Christopher Davis + +--- +$Id: README 1251 2014-08-18 10:18:23Z willem $ diff --git a/contrib/check_soa b/contrib/check_soa new file mode 100755 index 0000000..84a540f --- /dev/null +++ b/contrib/check_soa @@ -0,0 +1,561 @@ +#!/usr/bin/perl +$VERSION = (qw$LastChangedRevision: 1603 $)[1]; + +=head1 NAME + +check_soa - Check nameservers for a domain + + +=head1 SYNOPSIS + + check_soa [-d] [-n] [-s] [-t] [-v] domain [nameserver] + + +=head1 DESCRIPTION + +B builds a list of nameservers for the zone +which contains the specified domain name. +The program queries each nameserver for the relevant SOA record +and reports the zone serial number. + +Error reports are generated for nameservers which reply with incorrect, +non-authoritative or outdated information. + +=over 8 + +=item I + +Fully qualified domain name to be tested. +Domains within ip6.arpa or in-addr.arpa namespaces may be specified +using the appropriate IP address or prefix notation. + +=item I + +Optional name or list of IP addresses of specific nameserver to be tested. +Addresses are used in the sequence they appear in the argument list. + +=back + +SOA query packets are sent to the nameservers as rapidly as the underlying hardware will allow. +The program waits for a response only when it is needed for analysis. +Execution time is determined by the slowest nameserver. + +This perldoc(1) documentation page is displayed if the I argument is omitted. + +The program is based on the B idea described by Albitz and Liu. + + +=head1 OPTIONS + +=over 8 + +=item B<-d> + +Turn on resolver diagnostics. + +=item B<-n> + +Report negative cache TTL. + +=item B<-s> + +Request DNSSEC resource records. + +=item B<-t> + +Ignore UDP datagram truncation. + +=item B<-v> + +Verbose output including address records for each nameserver. + +=back + + +=head1 EXAMPLES + +=over 8 + +=item check_soa example.com + +Query all nameservers for the specified domain. + +=item check_soa 192.0.2.1 + +Query nameservers for the corresponding in-addr.arpa subdomain. + +=item check_soa 2001:DB8::8:800:200C:417A + +Query nameservers for the corresponding ip6.arpa subdomain. + +=item check_soa 2001:DB8:0:CD30::/60 + +As above, for IPv6 address prefix of specified length. + +=item check_soa 192.0.2.1 z.arin.net + +Query specific nameserver as above. + +=back + + +=head1 BUGS + +The program can become confused by zones which originate, +or appear to originate, from more than one primary server. + +The timeout code uses the perl 4-argument select() function. +This is not guaranteed to work in non-Unix environments. + + +=head1 COPYRIGHT + +(c) 2003-2011 Dick Franks Erwfranks[...]acm.orgE + +All rights reserved. + +This program is free software; you may use or redistribute +it under the same terms as Perl itself. + + +=head1 SEE ALSO + +Paul Albitz, Cricket Liu. +DNS and BIND, 5th Edition. +O'Reilly, 2006. + +Andrews, M., +Locally Served DNS Zones, +RFC6303, IETF, 2011. + +Andrews, M., +Negative Caching of DNS Queries, +RFC2308, IETF Network Working Group, 1998. + +Elz, R., Bush, R., +Clarifications to the DNS Specification, +RFC2181, IETF Network Working Group, 1997. + +Mockapetris, P., +Domain Names - Implementation and Specification, +RFC 1035, USC/ISI, 1987. + +Larry Wall, Tom Christiansen, Jon Orwant. +Programming Perl, 3rd Edition. +O'Reilly, 2000. + +=cut + + +use strict; + +use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see UTR#16 3.6] + require Encode; + Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); +}; + + +my $self = $0; # script + +my $options = 'dnstv'; # options +my %option; +eval { require Getopt::Std; Getopt::Std::getopts( $options, \%option ) }; +warn "Can't locate Getopt::Std\n" if $@; + +my @arg = qw( domain [nameserver] ); # arguments + +my @flag = map "[-$_]", split( //, $options ); # documentation +die eval { system("perldoc -F $self"); "" }, < ( $option{d} || 0 ), # -d enable diagnostics + igntc => ( $option{t} || 0 ) # -t ignore truncation + ); + +my $negtest = $option{n}; # -n report NCACHE TTL +my $dnssec = $option{s}; # -s request DNSSEC RRs +my $verbose = $option{v}; # -v verbose + +my $neg_min = 300; # NCACHE TTL reporting threshold +my $neg_max = 86400; # NCACHE TTL reporting threshold + +my $udp_timeout = 5; # timeout for concurrent queries +my $udp_wait = 0.100; # minimum polling interval + +local $SIG{__WARN__} = sub { }; # suppress all warnings + +my $resolver = new Net::DNS::Resolver(@conf); # create resolver object +$resolver->nameservers(@nameserver) or die $resolver->string; + + +my ($question) = new Net::DNS::Packet($domain)->question; # invert IP address/prefix +my $name = lc $question->qname; +my $NetDNSrev = &Net::DNS::version; +die "\tFeature not supported by Net::DNS $NetDNSrev\n" if $name =~ m#[:/\s]|\.\d+$#; + +my $packet = $resolver->send( "*.$name", 'NULL' ) or die $resolver->errorstring; +my ($zone) = map lc( $_->name ), $packet->authority; + +my @ns = ( $zone or $name eq '.' ) ? NS($zone) : (); # find NS serving name +die "\nno such zone: $name\n\n", $resolver->string unless @ns; # game over + + +my @nsname = grep $_ ne $zone, map $_->nsdname, @ns; # extract server names from NS records +my @server = @nameserver ? (@nameserver) : ( sort @nsname ); + +$resolver->dnssec(1) if $dnssec; + +my @soa = grep $_->type eq 'SOA', displayRR( $zone, 'SOA' ); +foreach my $soa (@soa) { # simple sanity check + my $owner = lc $soa->name; # zone name + my $mname = lc $soa->mname; # primary server + my $rname = lc $soa->rname; # responsible person + + my $resolved; # check MNAME resolvable + foreach my $rrtype (qw( A AAAA CNAME )) { + my $probe = $resolver->send( $mname, $rrtype ); + next unless $probe; + last if ( $resolved = scalar $probe->answer ); + } + + for ($mname) { + last unless $_ eq $owner; # RFC6303 local zone + displayRR( $zone, 'NS' ) unless @nameserver; # ensure NS always listed + last unless /(in-addr|ip6)\.arpa/i; + report('unexpected address record in locally served zone [RFC6303]') if $resolved; + } + + last unless @nsname; # suppress remaining tests + + report( 'unresolved MNAME', $mname ) unless $resolved; + + unless ( $rname =~ /(@|[^\\]\.)([^@]+)$/ ) { # parse RNAME + report( 'incomplete RNAME', $rname ) unless $rname eq '<>'; + } elsif ( $2 ne $mname ) { + my $resolved; # check RNAME resolvable + foreach my $rrtype (qw( MX A AAAA CNAME )) { + my $probe = $resolver->send( $2, $rrtype ); + last if ( $resolved = scalar $probe->answer ); + } + report( 'unresolved RNAME', $rname ) unless $resolved; + } + + if ( $soa->expire < $soa->refresh ) { # check refresh/retry timing + report('slave expires zone data before scheduled refresh'); + } else { + my $window = $soa->expire - $soa->refresh - 1; # zone transfer window + my $retry = $soa->retry || 1; # retry interval + my $n = 1 + int( $window / $retry ); # number of transfer attempts + my $s = $n > 1 ? 's' : ''; + report("slave expires zone data after $n transfer failure$s") unless $n > 3; + } + + my ($min) = sort { $a <=> $b } ( $soa->minimum, $soa->ttl ); # force NCACHE test for extreme TTLs + $negtest++ if $min < $neg_min or $soa->minimum > $neg_max; +} + +my @ncache = $negtest ? NCACHE($zone) : (); # report observed NCACHE TTL + +foreach my $rrtype (qw( A AAAA PTR )) { # nobody believes in ANY any more + displayRR( $name, $rrtype ); +} + +displayRR( $zone, 'NS' ) if @nameserver; # show NS if testing specific nameserver + +print "----\n"; + +my ( $bad, $seq, $iphash ) = checkNS( $zone, @server ); # report status +$iphash->{$seq} ||= ''; +print "\n"; +my $s = $bad != 1 ? 's' : ''; +print "Unsatisfactory response from $bad nameserver$s\n\n" if $bad and @server > 1; + +my %mname = reverse %$iphash; # invert address hash +my $mcount = keys %mname; # number of distinct MNAMEs +if ( $mcount > 1 ) { + report('SOAs do not identify unique primary server'); # RFC1034, 4.3.5 + foreach my $mname ( sort keys %mname ) { + foreach ( $mname, $resolver->nameservers($mname) ) { delete $iphash->{$_} } + } + my %serial = map { ( $iphash->{$_} => $_ ) } sort { $a <=> $b } keys %$iphash; + foreach ( sort keys %mname ) { report( sprintf '%10s %s', $serial{$_}, $_ ) } +} + +exit; + + +sub checkNS0 { ## initial status vector for checkNS + my $serial = undef; + my $hash = {}; + my $res = new Net::DNS::Resolver(@conf); + + foreach my $soa ( grep $_->type eq 'SOA', @ncache, @soa ) { + my $mname = lc $soa->mname; # populate hash with name/IP of primary + next if $mname eq lc $soa->name; # RFC6303 local zone + foreach ( $mname, $res->nameservers($mname) ) { $hash->{$_} = $mname } + my $s = $soa->serial; + $hash->{$s} = $mname; + $serial = $s if ordered( $serial, $s ); + } + + return ( 0, $serial, $hash ); +} + + +sub checkNS { ## query nameservers (concurrently) and report status + my $zone = shift; + my $index = scalar @_; # index last element + my $element = pop(@_) || return checkNS0; # pop element, terminate if undef + my ( $ns, $if ) = split / /, lc $element; # name + optional interface IP + + my $res = new Net::DNS::Resolver(@conf); # use clean resolver for each test + my @xip = $res->nameservers( $if || $ns ); # point at nameserver + my $ip = pop @xip; # last (or only) interface + $res->nameservers($ip) if @xip; + + $res->recurse(0); # send non-recursive query to nameserver + my ( $socket, $sent ); + ( $socket, $sent ) = ( $res->bgsend( $zone, 'SOA' ), time ) if $ip; + + my ( $fail, $latest, $hash ) = checkNS( $zone, @_ ); # recurse to query others concurrently + # pick up response as recursion unwinds + my $packet; + if ($socket) { + until ( $res->bgisready($socket) ) { # timed wait on socket + last if time > ( $sent + $udp_timeout ); + delay($udp_wait); # snatch a few milliseconds sleep + } + $packet = $res->bgread($socket) if $res->bgisready($socket); # get response + } elsif ($ip) { + $packet = $res->send( $zone, 'SOA' ); # use sequential query model + } + + my @pass = ( $fail, $latest, $hash ); # use prebuilt return values + my @fail = ( $fail + 1, $latest, $hash ); + + my %nsaddr = $ip ? ( $ip => 1 ) : (); # special handling for multihomed server + foreach my $xip (@xip) { # iterate over remaining interfaces + next if $nsaddr{$xip}++; # silently ignore duplicate address record + my ( $f, $x, $h ) = checkNS( $zone, (undef) x scalar(@_), "$ns $xip" ); + %$hash = ( %$hash, %$h ); # merge address hashes + @pass = @fail if $f; # propagate failure to caller + } + + my $rcode; + my @soa; + unless ($packet) { # ... is no more! It has ceased to be! + $rcode = 'no response'; + } elsif ( $packet->header->rcode ne 'NOERROR' ) { + $rcode = $packet->header->rcode; # NXDOMAIN or fault at nameserver + } else { + @soa = grep $_->type eq 'SOA', $packet->answer; + foreach my $soa (@soa) { + my $mname = lc $soa->mname; # hash MNAME by IP + my @ip = $hash->{$mname} ? () : $res->nameservers($mname); + foreach ( $mname, @ip ) { $hash->{$_} = $mname } + } + } + + my $primary = $hash->{$ip || $ns} ? '*' : ''; # flag zone primary + unless ($ip) { # identify nameserver + print "\n[$index]$primary\t$ns\n"; # name only + $rcode = 'unresolved server name'; + } elsif ( $ns eq $ip ) { + print "\n[$index]$primary\t$ip\n"; # ip only + } else { + print "\n[$index]$primary\t$ns [$ip]\n"; # name and ip + } + + if ($verbose) { # show PTR record + my @ptr = grep $_->type eq 'PTR', $ip ? displayRR($ip) : (); + my @fwd = sort map { lc $_->ptrdname } @ptr; + foreach my $name ( @fwd ? @fwd : ($ns) ) { # show address records + displayRR( $name, 'A' ); + displayRR( $name, 'AAAA' ); + } + } + + if ($rcode) { + return @pass if $ns eq lc $zone; # RFC6303 local zone + report($rcode); # abject failure + return @fail; + } + + my @result = @fail; # analyse response + my @auth = @soa ? () : $packet->authority; + my @ncache = grep $_->type eq 'SOA', @auth; + my @refer = grep $_->type eq 'NS', @auth; + if (@soa) { + if ( @soa > 1 ) { + report('multiple SOA records'); # RFC2181, 6.1 + } elsif ( $packet->header->aa ) { + @result = @pass; # RFC1034, 6.2.1(1) + } else { + my $ttl = $soa[0]->ttl; # RFC1034, 6.2.1(2) + report( 'non-authoritative answer', ttl($ttl) ); + } + } elsif (@ncache) { + my ($ttl) = map { $_->ttl } @soa = @ncache; # RFC2308, 2.2(1)(2) + report( 'negative cache', ttl($ttl) ); + return @fail unless grep $_->name =~ /^$zone$/i, @ncache; + report('requested SOA in authority section; violates RFC2308'); + } elsif (@refer) { + my @n = grep $_->nsdname =~ /$ns/i, @refer; # RFC2308, 2.2(4) + report('authoritative data expired') if @n; # self referral + report('not configured for zone') unless @n; + return @fail; + } else { + report('NOERROR (no data)'); # RFC2308, 2.2(3) + return @fail; + } + + report('truncated response from nameserver') if $packet->header->tc; + + my ($serial) = map { $_->serial } @soa; # check serial number + + if ( $primary && ordered( $serial, $latest ) ) { # primary should have latest data + my $response = $res->send( $zone, 'SOA' ); # repeat test before pointing finger + my ($retest) = grep $_->type eq 'SOA', $response ? $response->answer : (); + $serial = $retest->serial if ordered( $serial, $retest->serial ); + } + + print "\t\t\tzone serial\t", $serial, "\n"; + $hash->{$serial} = $hash->{$ip} if $primary; + + if ( ordered( $serial, $latest ) ) { + report('serial number not current'); + return @fail unless $primary; + report('discredited as unique primary nameserver'); + return @fail; + } + + return @result if $serial == $latest; + + my $x = $if ? 0 : ( $index - 1 ) - $fail; # all previous out of date + my $s = $x > 1 ? 's' : ''; # pedants really are revolting! + report("at least $x previously unreported stale serial number$s") if $x; + return ( $result[0] + $x, $serial, $hash ); # restate partial result +} + + +sub delay { ## short duration sleep + my $duration = shift; # seconds + sleep( 1 + $duration ) unless eval { defined select( undef, undef, undef, $duration ) }; +} + + +sub displayRR { ## print specified RRs or error code + my $packet = $resolver->send(@_) or return (); # get specified RRs + my $header = $packet->header; + my $rcode = $header->rcode; # response code + my ($question) = $packet->question; + my $qtype = $question->qtype; + my $qname = $question->qname; + my $name = $qname =~ /^xn--/ ? eval { $question->name } : ''; + my @annotation = $name ? ("; $name\n") : (); + my @answer = $packet->answer; + my @authority = $packet->authority; + my @ncache = grep $_->type eq 'SOA', @authority; # per RFC2308 + my @workaround = $qtype eq 'SOA' ? @ncache : (); # SOA misplaced/withheld? + my @remark = @workaround ? qw(unexpected) : (); + + foreach my $rr ( @answer, @workaround ) { # print RRs unless shown elsewhere + + next if $qtype eq 'ANY' && $rr->type =~ /^(SOA|NS)$/; + + print @annotation if $rr->name eq $qname; # annotate IDN + + for ( $rr->string ) { + my $l = $verbose ? length($_) : 108; # abbreviate long RR + substr( $_, $l ) = ' ...' if length($_) > $l && $rr->type ne 'SOA'; + print "$_\n"; + } + } + + report( @remark, "$rcode:", $question->string, @annotation ) if $rcode ne 'NOERROR'; + return @answer; +} + + +sub NCACHE { ## report observed NCACHE TTL for domain + my $domain = shift || ''; + my $seq = time; + my $nxdomain = "_nx_$seq.$domain"; # intentionally perverse query + my $reply = $resolver->send( $nxdomain, 'PTR' ) or return (); + for ( $reply->answer ) { + report( 'wildcard invalidates NCACHE test:', $_->string ); + return (); + } + my @ncache = grep $_->type eq 'SOA', $reply->authority; + for (@ncache) { + my $serial = $_->serial; + my ($seen) = ( @soa, @ncache ); + my @source = $serial > $seen->serial ? ("\t(SOA: $serial)") : (); + report( 'negative cache data', ttl( $_->ttl ), @source ); + } + return @ncache; +} + + +sub NS { ## find NS records for domain + my $name = shift; + + my $packet = $resolver->send( $name, 'NS' ) or die $resolver->string; + + # Bear in mind the possibility of malformed zones! + my @answer = grep $_->type eq 'NS', $packet->answer, $packet->authority; +} + + +sub ordered { ## irreflexive 32-bit partial ordering + use integer; + my ( $a, $b ) = @_; + + return defined $b unless defined $a; # ( undef, any ) + return 0 unless defined $b; # ( any, undef ) + + # unwise to assume 32-bit arithmetic, or that integer overflow goes unpunished + if ( $a < 0 ) { # translate $a<0 region + $a = ( $a ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $a < 2**31 + $b = ( $b ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $b < 2**32 + } + + return $a < $b ? ( $a > ( $b - 0x80000000 ) ) : ( $b < ( $a - 0x80000000 ) ); +} + + +sub report { ## concatenate strings into fault report + print '### ', join( "\t", @_ ), "\n"; +} + + +sub ttl { ## human-friendly TTL + my $t = shift; + my ( $s, $m, $h, $y, $d ) = ( gmtime($t) )[0 .. 2, 5, 7]; + + unless ( $y == 70 ) { + return sprintf 'TTL %u (%uy%ud)', $t, $y - 70, $d; + } elsif ($h) { + return sprintf 'TTL %u (%ud%0.2uh)', $t, $d, $h if $d; + return sprintf 'TTL %u (%uh%0.2um)', $t, $h, $m if $m; + return sprintf 'TTL %u (%uh)', $t, $h; + } else { + return sprintf 'TTL %u (%ud)', $t, $d if $d; + return sprintf 'TTL %u (%um%0.2us)', $t, $m, $s if $s; + return sprintf 'TTL %u (%um)', $t, $m; + } +} + + +__END__ + diff --git a/contrib/check_zone b/contrib/check_zone new file mode 100755 index 0000000..439290b --- /dev/null +++ b/contrib/check_zone @@ -0,0 +1,799 @@ +#!/usr/local/bin/perl -w +# $Id: check_zone 638 2007-05-15 18:59:26Z olaf $ + +=head1 NAME + +check_zone - Check a DNS zone for errors + +=head1 SYNOPSIS + +C [ C<-r> ][ C<-v> ] I [ I ] + +=head1 DESCRIPTION + +Checks a DNS zone for errors. Current checks are: + +=over 4 + +=item * + +Checks the domain's SOA from each of the domain's name servers. The SOA serial numbers should match. This program's output cannot be trusted if they do not. + +=item * + +Tries to perform an AXFR from each of the domain's name servers. This test helps to detect whether the name server is blocking AXFR. + +=item * + +Checks that all A records have corresponding PTR records. For each A record its PTR's name is match checked. + +=item * + +Checks that all PTR records match an A record (sometimes they match a CNAME). Check the PTR's name against the A record. + +=item * + +Checks that hosts listed in NS, MX, and CNAME records have +A records. Checks for NS and CNAME records not pointing to another CNAME (i.e., they must directly resolve to an A record). That test may be somewhat controversial because, in many cases, a MX to a CNAME or a CNAME to another CNAME will resolve; however, in DNS circles it isn't a recommended practise. + +=item * + +Check each record processed for being with the class requested. This is an internal integrity check. + +=back + +=head1 OPTIONS + +=over 4 + +=back + +=item C<-r> + +Perform a recursive check on subdomains. + +=item C<-v> + +Verbose. + +=item C<-a alternate_domain> + +Treat as equal to . This is useful when supporting a change of domain names (eg from myolddomain.example.net to mynewdomain.example.net) where the PTR records can point to only one of the two supported domains (which are otherwise identical). + +=item C<-e exception_file> + +Ignore exceptions in file . File format can be space-separated domain pairs, one pair per line, or it can be straight output from this program itself (for simple cut-and-paste functionality). +This allows for skipping entries that are odd or unusual, but not causing problems. Note: this only works with A - PTR checks. + +=head1 AUTHORS + +Originally developed by Michael Fuhr (mfuhr@dimensional.com) and +hacked--with furor--by Dennis Glatting +(dennis.glatting@software-munitions.com). + +"-a" and "-e" options added by Paul Archer + + +=head1 COPYRIGHT + +=head1 SEE ALSO + +L, L, L, L, L, L + +=head1 BUGS + +A query for an A RR against a name that is a CNAME may not follow the CNAME to an A RR. + +There isn't a mechanism to insure records are returned from an authoritative source. + +There appears to be a bug in the resolver AXFR routine where, if one server cannot be contacted, the routine doesn't try another in its list. + +=cut + + +require 'assert.pl'; + +use strict; +use vars qw($opt_r); +use vars qw($opt_v); +use vars qw($opt_a); +use vars qw($opt_e); + +use Getopt::Std; +use File::Basename; +use IO::Socket; +use Net::DNS; + +getopts("rva:e:"); + +die "Usage: ", basename($0), " [ -r -v ] [ -a alternate_domain] [ -e eqivalent_domains_file ] domain [ class ]\n" + unless (@ARGV >= 1) && (@ARGV <= 2); + + +our $exit_status = 0; +$SIG{__WARN__} = sub {$exit_status=1 ; print STDERR @_ }; + + + +$opt_r = 1; + +our $main_domain=$ARGV[0]; +our %exceptions = parse_exceptions_file(); +foreach my $key (sort keys %exceptions) { + print "$key:\t"; + foreach my $val (@{$exceptions{$key}}) { + print "$val "; + } + print "\n"; +} + +check_domain(@ARGV); +exit $exit_status; + + +sub parse_exceptions_file { + my %exceptions; + my $file = $opt_e || ""; + return %exceptions unless ( -r $file); + open FH, $file or warn "Couldn't read $file: $!"; + my $line; + while ( defined ($line = ) ) { + chomp $line; + #print " raw line: $line\n"; + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + $line =~ s/^\s*//; + $line =~ s/\s*$//; + $line =~ s/'//g; + my ($left, $right) = (split /[\s:]+/, $line)[0, -1]; + push @{$exceptions{$left}}, $right; + #print "processed line: $line\n"; + + } + return %exceptions; +} + + + +sub check_domain { + + my ( $domain, $class ) = @_; + my $ns; + my @zone; + + $class ||= "IN"; + + print "-" x 70, "\n"; + print "$domain (class $class)\n"; + print "\n"; + + my $res = new Net::DNS::Resolver; + $res->defnames( 0 ); + $res->retry( 2 ); + + + my( $nspack, $ns_rr, @nsl ); + + # Get a list of name servers for the domain. + # Error-out if the query isn't satisfied. + # + + $nspack = $res->query( $domain, 'NS', $class ); + unless( defined( $nspack )) { + + warn "Couldn't find nameservers for $domain: ", + $res->errorstring, "\n"; + return; + } + + printf( "List of name servers returned from '%s'\n", $res->answerfrom ); + foreach $ns_rr ( $nspack->answer ) { + + $ns_rr->print if( $opt_v ); + + assert( $class eq $ns_rr->class ); + assert( 'NS' eq $ns_rr->type ); + + if( $ns_rr->name eq $domain ) { + + print "\t", $ns_rr->rdatastr, "\n"; + push @nsl, $ns_rr->rdatastr; + } else { + + warn( "asked for '$domain', got '%s'\n", $ns_rr->rdatastr ); + } + } + print "\n"; + + warn( "\tZone has no NS records\n" ) if( scalar( @nsl ) == 0 ); + + + # Transfer the zone from each of the name servers. + # The zone is transferred for several reasons. + # First, so the check routines won't (an efficiency + # issue) and second, to see if we can. + # + + $res->nameservers( @nsl ); + + foreach $ns ( @nsl ) { + + $res->nameservers( $ns ); + + my @local_zone = $res->axfr( $domain, $class ); + unless( @local_zone ) { + + warn "Zone transfer from '", $ns, "' failed: ", + $res->errorstring, "\n"; + } + @zone = @local_zone if( ! @zone ); + } + + # Query each name server for the zone + # and check the zone's SOA serial number. + # + + print "checking SOA records\n"; + check_soa( $domain, $class, \@nsl ); + print "\n"; + + + # Check specific record types. + # + + print "checking NS records\n"; + check_ns( $domain, $class, \@nsl, \@zone ); + print "\n"; + + print "checking A records\n"; + check_a( $domain, $class, \@nsl, \@zone ); + print "\n"; + + print "checking PTR records\n"; + check_ptr( $domain, $class, \@nsl, \@zone ); + print "\n"; + + print "checking MX records\n"; + check_mx( $domain, $class, \@nsl, \@zone ); + print "\n"; + + print "checking CNAME records\n"; + check_cname( $domain, $class, \@nsl, \@zone ); + print "\n"; + + + # Recurse? + # + + if( $opt_r ) { + + my %subdomains; + + print "checking subdomains\n\n"; + + # Get a list of NS records from the zone that + # are not for the zone (i.e., they're subdomains). + # + + foreach ( grep { $_->type eq 'NS' and $_->name ne $domain } @zone ) { + + $subdomains{$_->name} = 1; + } + + # For each subdomain, check it. + # + + foreach ( sort keys %subdomains ) { + + check_domain($_, $class); + } + } +} + +sub check_soa { + + my( $domain, $class, $nsl ) = @_; + my( $soa_sn, $soa_diff ) = ( 0, 0 ); + my( $ns, $soa_rr ); + my $rr_count = 0; + + my $res = new Net::DNS::Resolver; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->recurse( 0 ); + + # Contact each name server and get the + # SOA for the somain. + # + + foreach $ns ( @$nsl ) { + + my $soa = 0; + my $nspack; + + # Query the name server and test + # for a result. + # + + $res->nameservers( $ns ); + + $nspack = $res->query( $domain, "SOA", $class ); + unless( defined( $nspack )) { + + warn "Couldn't get SOA from '$ns'\n"; + next; + } + + # Look at each SOA for the domain from the + # name server. Specifically, look to see if + # its serial number is different across + # the name servers. + # + + foreach $soa_rr ( $nspack->answer ) { + + $soa_rr->print if( $opt_v ); + + assert( $class eq $soa_rr->class ); + assert( 'SOA' eq $soa_rr->type ); + + print "\t$ns:\t", $soa_rr->serial, "\n"; + + # If soa_sn is zero then an SOA serial number + # hasn't been recorded. In that case record + # the serial number. If the serial number + # doesn't match a previously recorded one then + # indicate they are different. + # + # If the serial numbers are different then you + # cannot really trust the remainder of the test. + # + + if( $soa_sn ) { + + $soa_diff = 1 if ( $soa_sn != $soa_rr->serial ); + } else { + + $soa_sn = $soa_rr->serial; + } + } + + ++$rr_count; + } + + print "\t*** SOAs are different!\n" if( $soa_diff ); + print "$rr_count SOA RRs checked.\n"; +} + +sub check_ptr { + + my( $domain, $class, $nsl, $zone ) = @_; + + my $res = new Net::DNS::Resolver; + my $ptr_rr; + my $rr_count = 0; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + foreach $ptr_rr ( grep { $_->type eq 'PTR' } @$zone ) { + + my @types; + + $ptr_rr->print if( $opt_v ); + + assert( $class eq $ptr_rr->class ); + assert( 'PTR' eq $ptr_rr->type ); + + print "\tchecking PTR rr '$ptr_rr' to PTR\n" if( $opt_v ); + + @types = types4name( $ptr_rr->ptrdname, $domain, $class, $nsl ); + if( grep { $_ eq 'A' } @types ) { + + xcheck_ptr2a( $ptr_rr, $domain, $class, $nsl ); + } else { + + warn "\t'", $ptr_rr->ptrdname, + "' doesn't resolve to an A RR (RRs are '", + join( ', ', @types ), "')\n"; + + } + + + ++$rr_count; + } + + print "$rr_count PTR RRs checked.\n"; +} + +sub check_ns { + + my( $domain, $class, $nsl, $zone ) = @_; + my $res = new Net::DNS::Resolver; + my $ns_rr; + my $rr_count = 0; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + # Go through the zone data and process + # all NS RRs for the zone (delegation + # NS RRs are ignored). Specifically, + # check to see if the indicate name server + # is a CNAME RR and the name resolves to an A + # RR. Check to insure the address resolved + # against the name has an associated PTR RR. + # + + foreach $ns_rr ( grep { $_->type eq 'NS' } @$zone ) { + + my @types; + + $ns_rr->print if( $opt_v ); + + assert( $class eq $ns_rr->class ); + assert( 'NS' eq $ns_rr->type ); + + next if( $ns_rr->name ne $domain ); + + printf( "rr nsdname: %s\n", $ns_rr->nsdname ) if $opt_v; + + @types = types4name( $ns_rr->nsdname, $domain, $class, $nsl ); + if( grep { $_ eq 'A' } @types ) { + + xcheck_name( $ns_rr->nsdname, $domain, $class, $nsl ); + } else { + + warn "\t'", $ns_rr->nsdname, + "' doesn't resolve to an A RR (RRs are '", + join( ', ', @types ), "')\n"; + } + ++$rr_count; + } + + print "$rr_count NS RRs checked.\n"; +} + +sub check_a { + + my( $domain, $class, $nsl, $zone ) = @_; + + my $res = new Net::DNS::Resolver; + my $a_rr; + my $rr_count = 0; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + # Go through the zone data and process + # all A RRs. Specifically, check to insure + # each A RR matches a PTR RR and the PTR RR + # matches the A RR. + # + + foreach $a_rr ( grep { $_->type eq 'A' } @$zone ) { + + $a_rr->print if( $opt_v ); + + assert( $class eq $a_rr->class ); + assert( 'A' eq $a_rr->type ); + + print "\tchecking A RR '", $a_rr->address, "' to PTR\n" if( $opt_v ); + + xcheck_a2ptr( $a_rr, $domain, $class, $nsl ); + + ++$rr_count; + } + + print "$rr_count A RRs checked.\n"; +} + + +sub check_mx { + + my( $domain, $class, $nsl, $zone ) = @_; + + my $res = new Net::DNS::Resolver; + my $mx_rr; + my $rr_count = 0; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + # Go through the zone data and process + # all MX RRs. Specifically, check to insure + # each MX RR resolves to an A RR and the + # A RR has a matching PTR RR. + # + + foreach $mx_rr ( grep { $_->type eq 'MX' } @$zone ) { + + $mx_rr->print if( $opt_v ); + + assert( $class eq $mx_rr->class ); + assert( 'MX' eq $mx_rr->type ); + + print "\tchecking MX RR '", $mx_rr->exchange, "' to A\n" if( $opt_v ); + + xcheck_name( $mx_rr->exchange, $domain, $class, $nsl ); + + ++$rr_count; + } + + print "$rr_count MX RRs checked.\n"; +} + +sub check_cname { + + my( $domain, $class, $nsl, $zone ) = @_; + + my $res = new Net::DNS::Resolver; + my $cname_rr; + my $rr_count = 0; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + # Go through the zone data and process + # all CNAME RRs. Specifically, check to insure + # each CNAME RR resolves to an A RR and the + # A RR has a matching PTR RR. + # + + foreach $cname_rr ( grep { $_->type eq 'CNAME' } @$zone ) { + + my @types; + + $cname_rr->print if( $opt_v ); + + assert( $class eq $cname_rr->class ); + assert( 'CNAME' eq $cname_rr->type ); + + print "\tchecking CNAME RR '", $cname_rr->cname, "' to A\n" + if( $opt_v ); + + @types = types4name( $cname_rr->cname, $domain, $class, $nsl ); + if( grep { $_ eq 'A' } @types ) { + + xcheck_name( $cname_rr->cname, $domain, $class, $nsl ); + } else { + + warn "\t'", $cname_rr->cname, + "' doesn't resolve to an A RR (RRs are '", + join( ', ', @types ), "')\n"; + } + + ++$rr_count; + } + + print "$rr_count CNAME RRs checked.\n"; +} + +sub check_w_equivs_and_exceptions { + my ($left, $comp, $right) = @_; + + if (defined $exceptions{$left}) { + foreach my $rval (@{$exceptions{$left}}) { + $left = $right if ($rval eq $right); + } + } + + if ($opt_a){ + $left =~ s/\.?$opt_a$//; + $left =~ s/\.?$main_domain$//; + $right =~ s/\.?$opt_a$//; + $right =~ s/\.?$main_domain$//; + } + return (eval ("\"$left\" $comp \"$right\"") ); +} + +sub xcheck_a2ptr { + + my( $a_rr, $domain, $class, $nsl ) = @_; + + my $res = new Net::DNS::Resolver; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + assert( $class eq $a_rr->class ); + assert( 'A' eq $a_rr->type ); + + # Request a PTR RR against the A RR. + # A missing PTR RR is an error. + # + + my $ans = $res->query( $a_rr->address, 'PTR', $class ); + if( defined( $ans )) { + + my $ptr_rr; + foreach $ptr_rr ( $ans->answer ) { + + $ptr_rr->print if( $opt_v ); + + assert( $class eq $ptr_rr->class ); + assert( 'PTR' eq $ptr_rr->type ); + + warn( "\t'", $a_rr->name, "' has address '", + $a_rr->address, "' but PTR is '", + $ptr_rr->ptrdname, "'\n" ) + if( check_w_equivs_and_exceptions($a_rr->name, "ne", $ptr_rr->ptrdname) ); + + warn( "\t'", $a_rr->name, "' has address '", + $a_rr->address, "' but PTR is '", + ip_ptr2a_str( $ptr_rr->name ), "'\n" ) + if( $a_rr->address ne ip_ptr2a_str( $ptr_rr->name )); + } + } else { + + warn( "\tNO PTR RR for '", $a_rr->name, + "' at address '", $a_rr->address,"'\n" ); + } +} + + +sub xcheck_ptr2a { + + my( $ptr_rr, $domain, $class, $nsl ) = @_; + + my $res = new Net::DNS::Resolver; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + assert( $class eq $ptr_rr->class ); + assert( 'PTR' eq $ptr_rr->type ); + + # Request an A RR against the PTR RR. + # A missing A RR is an error. + # + + my $ans = $res->query( $ptr_rr->ptrdname, 'A', $class ); + if( defined( $ans )) { + + my $a_rr; + foreach $a_rr ( $ans->answer ) { + + $a_rr->print if( $opt_v ); + + assert( $class eq $a_rr->class ); + assert( 'A' eq $a_rr->type ); + + warn( "\tPTR RR '", $ptr_rr->name, "' has name '", + $ptr_rr->ptrdname, "' but A query returned '", + $a_rr->name, "'\n" ) + if( check_w_equivs_and_exceptions($ptr_rr->ptrdname, "ne", $a_rr->name) ); + + warn( "\tPTR RR '", $ptr_rr->name, "' has address '", + ip_ptr2a_str( $ptr_rr->name ), + "' but A query returned '", $a_rr->address, "'\n" ) + if( ip_ptr2a_str( $ptr_rr->name ) ne $a_rr->address ); + } + } else { + + warn( "\tNO A RR for '", $ptr_rr->ptrdname, + "' at address '", ip_ptr2a_str( $ptr_rr->address ), "'\n" ); + } +} + + +sub xcheck_name { + + my( $name, $domain, $class, $nsl ) = @_; + + my $res = new Net::DNS::Resolver; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + # Get the A RR for the name. + # + + my $ans = $res->query( $name, 'A', $class ); + if( defined( $ans )) { + + # There is one or more A RRs. + # For each A RR do a reverse look-up + # and verify the PTR matches the A. + # + + my $a_rr; + foreach $a_rr ( $ans->answer ) { + + $a_rr->print if( $opt_v ); + + assert( $class eq $a_rr->class ); + assert( 'A' eq $a_rr->type ); + + warn( "\tQuery for '$name' returned A RR name '", + $a_rr->name, "'\n" ) + if( check_w_equivs_and_exceptions($name, "ne", $a_rr->name) ); + + xcheck_a2ptr( $a_rr, $domain, $class, $nsl ); + } + } else { + + warn( "\t", $name, " has no A RR\n" ); + } + +} + + +sub types4name { + + my( $name, $domain, $class, $nsl ) = @_; + + my $res = new Net::DNS::Resolver; + my @rr_types; + + $res->defnames( 0 ); + $res->retry( 2 ); + $res->nameservers( @$nsl ); + + # Get the RRs for the name. + # + + my $ans = $res->query( $name, 'ANY', $class ); + if( defined( $ans )) { + + my $any_rr; + foreach $any_rr ( $ans->answer ) { + + $any_rr->print if( $opt_v ); + + assert( $class eq $any_rr->class ); + + push @rr_types, ( $any_rr->type ); + } + } else { + + warn( "\t'", $name, "' doesn't resolve.\n" ); + } + + # If there were no RRs for the name then + # return the RR types of ??? + # + + push @rr_types, ( '???' ) if( ! @rr_types ); + + return @rr_types; +} + + +sub ip_ptr2a_str { + + my( $d, $c, $b, $a ) = ip_parts( $_[0]); + + return "$a.$b.$c.$d"; +} + + + +sub ip_parts { + + my $ip = $_[0]; + assert( $ip ne '' ); + + if( $ip =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/oi ) { + + return ( $1, $2, $3, $4 ); + } else { + + warn "Unable to parse '$ip'\n"; + } + + assert( 0 ); +} + + + + diff --git a/contrib/dnswalk.README b/contrib/dnswalk.README new file mode 100644 index 0000000..9c1394c --- /dev/null +++ b/contrib/dnswalk.README @@ -0,0 +1,6 @@ +$Id: dnswalk.README 739 2008-12-17 13:48:03Z olaf $ + +Dave Barr's dnswalk now uses Net::DNS. You can get a copy from: + + http://sourceforge.net/projects/dnswalk/ + diff --git a/contrib/find_zonecut b/contrib/find_zonecut new file mode 100755 index 0000000..59f88b1 --- /dev/null +++ b/contrib/find_zonecut @@ -0,0 +1,55 @@ +#!/usr/bin/perl +$VERSION = (qw$LastChangedRevision: 1251 $)[1] || 0.01; + +=head1 NAME + +find_zonecut - Find zonecut for a domain name + + +=head1 SYNOPSIS + + find_zonecut name + + +=head1 DESCRIPTION + +B returns the name of the closest delegation point +to the specified domain name. + +=cut + +use strict; +use Net::DNS; + +my $resolver = new Net::DNS::Resolver(); + +print find_zonecut(shift), "\n"; + + +sub find_zonecut { ## Copyright (c)2014 Dick Franks + my $name = shift; + my $reply = $resolver->send( "*.$name", 'NULL' ) || die $resolver->errorstring; + my ($cut) = map $_->name, $reply->authority; + return $cut || die "failed to find zone cut for $name"; +} + +__END__ + + +=head1 COPYRIGHT + +(c)2014 Dick Franks Erwfranks[...]acm.orgE + +All rights reserved. + +This program is free software; you may use or redistribute +it under the same terms as Perl itself. + +FOR DEMONSTRATION PURPOSES ONLY, NO WARRANTY, NO SUPPORT + +=head1 SEE ALSO + +L, L + +=cut + diff --git a/contrib/loc2earth.fcgi b/contrib/loc2earth.fcgi new file mode 100755 index 0000000..90251d0 --- /dev/null +++ b/contrib/loc2earth.fcgi @@ -0,0 +1,196 @@ +#!/usr/local/bin/perl -T + +# loc2earth.cgi - generates a redirect to Earth Viewer based on LOC record +# [ see or RFC 1876 ] + +# by Christopher Davis + +# $Id: loc2earth.fcgi 264 2005-04-06 09:16:15Z olaf $ + +die "I want 5.004 and I want it now" if $] < 5.004; + +# if you don't have FastCGI support, comment out this line and the two lines +# later in the script with "NO FCGI" comments +use CGI::Fast qw(:standard); + +# and uncomment the following instead. +#use CGI qw(:standard); + +use Net::DNS '0.08'; # LOC support in 0.08 and later + +$res = new Net::DNS::Resolver; + +@samplehosts= ('www.kei.com', + 'www.ndg.com.au', + 'gw.alink.net', + 'quasar.inexo.com.br', + 'hubert.fukt.hk-r.se', + 'sargent.cms.dmu.ac.uk', + 'thales.mathematik.uni-ulm.de'); + +while (new CGI::Fast) { # NO FCGI -- comment out this line + print header(-Title => "RFC 1876 Resources: Earth Viewer Demo"); + + # reinitialize these since FastCGI would keep them around otherwise + @addrs = @netnames = (); + $foundloc = 0; + + print ' + RFC 1876 Resources: Earth Viewer Demo + + + + + +

RFC 1876 Resources

+

loc2earth: The Earth Viewer Demo

+
'; + + print p("This is a quick & dirty demonstration of the use of the", + a({-href => 'http://www.dimensional.com/~mfuhr/perldns/'}, + 'Net::DNS module'),"and the", + a({-href => + 'http://www-genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'}, + 'CGI.pm library'), "to write LOC-aware Web applications."); + + print startform("GET"); + + print p(strong("Hostname"),textfield(-name => host, -size => 50)); + + print p(submit, reset), endform; + + if (param('host')) { + ($host = param('host')) =~ s/\s//g; # strip out spaces + + # check for numeric IPs and do reverse lookup to get name + if ($host =~ m/^\d+\.\d+\.\d+\.\d+$/) { + $query = $res->query($host); + + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "PTR") { + $host = $ans->ptrdname; + } + } + } + } + + $query = $res->query($host,"LOC"); + + if (defined ($query)) { # then we got an answer of some sort + foreach $ans ($query->answer) { + if ($ans->type eq "LOC") { + &print_loc($ans->rdatastr); + $foundloc++; + } elsif ($ans->type eq "CNAME") { + # XXX should follow CNAME chains here + } + } + } + if (!$foundloc) { # try the RFC 1101 search bit + $query = $res->query($host,"A"); + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "A") { + push(@addrs,$ans->address); + } + } + } + if (@addrs) { + checkaddrs: + foreach $ipstr (@addrs) { + $ipnum = unpack("N",pack("CCCC",split(/\./,$ipstr,4))); + ($ip1) = split(/\./,$ipstr); + if ($ip1 >= 224) { # class D/E, treat as host addr + $mask = 0xFFFFFFFF; + } elsif ($ip1 >= 192) { # "class C" + $mask = 0xFFFFFF00; + } elsif ($ip1 >= 128) { # "class B" + $mask = 0xFFFF0000; + } else { # class A + $mask = 0xFF000000; + } + $oldmask = 0; + while ($oldmask != $mask) { + $oldmask = $mask; + $querystr = + join(".", reverse (unpack("CCCC",pack("N",$ipnum & $mask)))) + . ".in-addr.arpa"; + $query = $res->query($querystr,"PTR"); + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "PTR") { + # we want the list in LIFO order + unshift(@netnames,$ans->ptrdname); + } + } + $query = $res->query($querystr,"A"); + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "A") { + $mask = unpack("L",pack("CCCC", + split(/\./,$ans->address,4))); + } + } + } + } + } + if (@netnames) { + foreach $network (@netnames) { + $query = $res->query($network,"LOC"); + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "LOC") { + &print_loc($ans->rdatastr); + $foundloc++; + last checkaddrs; + } elsif ($ans->type eq "CNAME") { + # XXX should follow CNAME chains here + } + } + } + } + } + } + } + } + if (!$foundloc) { + print hr,p("Sorry, there appear to be no LOC records for the", + "host $host in the DNS."); + } + } + print hr,p("Some hosts with LOC records you may want to try:"), + "
    \n
  • ",join("\n
  • ",@samplehosts),"
"; + + print '
+ RFC 1876 Now +
Christopher Davis +<ckd@kei.com>
+'; + +} # NO FCGI -- comment out this line + +sub print_loc { + local($rdata) = @_; + + ($latdeg,$latmin,$latsec,$lathem, + $londeg,$lonmin,$lonsec,$lonhem) = split (/ /,$rdata); + print hr,p("The host $host appears to be at", + "${latdeg}°${latmin}'${latsec}\" ${lathem}", + "latitude and ${londeg}°${lonmin}'${lonsec}\"", + "${lonhem} longitude according to the DNS."); + $evurl = ("http://www.fourmilab.ch/cgi-bin/uncgi/Earth?" . + "lat=${latdeg}d${latmin}m${latsec}s&ns=" . + (($lathem eq "S")?"lSouth":"lNorth") . + "&lon=${londeg}d${lonmin}m${lonsec}s&ew=" . + (($lonhem eq "W")?"West":"East") . + "&alt="); + print "

Generate an Earth Viewer image from "; + foreach $alt (49, 204, 958, 35875) { + print ('', + $alt,'km '); + } + print " above this point

"; +} diff --git a/contrib/loclist.pl b/contrib/loclist.pl new file mode 100755 index 0000000..e593487 --- /dev/null +++ b/contrib/loclist.pl @@ -0,0 +1,128 @@ +#!/usr/bin/perl + +# loclist.pl -- check a list of hostnames for LOC records + +# -v -- verbose output (include NO results). used to be the default +# -n -- try looking for network LOC records as well (slower) +# -r -- try doing reverse-resolution on IP-appearing hosts +# -d -- debugging output + +# egrep 'loc2earth.*host' /serv/www/logs/wn.log | +# perl -pe 's/^.*host=//; s/([a-zA-Z0-9.-]+).*/$1/' | +# sort -u | ~/loclist.pl > loc.sites + +use Net::DNS '0.08'; +use Getopt::Std; + +getopts('vnrd'); + +$res = new Net::DNS::Resolver; + +line: + foreach $_ (<>) { + chomp; + $foundloc = $namefound = 0; + + next line if m/^$/; + next line if m/[^\w.-\/+_]/; # /, +, _ not actually valid in hostnames + + print STDERR "$_ DEBUG looking up...\n" if $opt_d; + + if (m/^\d+\.\d+\.\d+\.\d+$/) { + if ($opt_r) { + $query = $res->query($_); + + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "PTR") { + $_ = $ans->ptrdname; + $namefound++; + } + } + } + } + next line unless $namefound; + } + + $query = $res->query($_,"LOC"); + + if (defined ($query)) { # then we got an answer of some sort + foreach $ans ($query->answer) { + if ($ans->type eq "LOC") { + print "$_ YES ",$ans->rdatastr,"\n"; + $foundloc++; + } + } + } + if ($opt_n && !$foundloc) { # try the RFC 1101 search bit + @addrs = @netnames = (); + $query = $res->query($_,"A"); + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "A") { + push(@addrs,$ans->address); + } + } + } + if (@addrs) { + checkaddrs: + foreach $ipstr (@addrs) { + $ipnum = unpack("N",pack("CCCC",split(/\./,$ipstr,4))); + ($ip1) = split(/\./,$ipstr); + if ($ip1 >= 224) { # class D/E, treat as host addr + $mask = 0xFFFFFFFF; + } elsif ($ip1 >= 192) { # "class C" + $mask = 0xFFFFFF00; + } elsif ($ip1 >= 128) { # "class B" + $mask = 0xFFFF0000; + } else { # class A + $mask = 0xFF000000; + } + $oldmask = 0; + while ($oldmask != $mask) { + $oldmask = $mask; + $querystr = + join(".", reverse (unpack("CCCC",pack("N",$ipnum & $mask)))) + . ".in-addr.arpa"; + $query = $res->query($querystr,"PTR"); + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "PTR") { + # we want the list in LIFO order + unshift(@netnames,$ans->ptrdname); + } + } + $query = $res->query($querystr,"A"); + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "A") { + $mask = unpack("L",pack("CCCC", + split(/\./,$ans->address,4))); + } + } + } + } + } + if (@netnames) { + foreach $network (@netnames) { + $query = $res->query($network,"LOC"); + if (defined ($query)) { + foreach $ans ($query->answer) { + if ($ans->type eq "LOC") { + print "$_ YES ",$ans->rdatastr,"\n"; + $foundloc++; + last checkaddrs; + } elsif ($ans->type eq "CNAME") { + # XXX should follow CNAME chains here + } + } + } + } + } + } + } + } + if ($opt_v && !$foundloc) { + print "$_ NO\n"; + } + } diff --git a/demo/README b/demo/README new file mode 100644 index 0000000..ece196a --- /dev/null +++ b/demo/README @@ -0,0 +1,30 @@ +This directory contains demonstration scripts for the Net::DNS +module. To read the manual page for a particular program, +run the command "perldoc program-name". + + +axfr Performs a zone transfer and stores the zone in a + file. If a zone file already exists, axfr reads + the file instead of performing a zone transfer. + Requires the Storable module (available on CPAN). + +check_soa Perl version of the check_soa program presented + in _DNS and BIND_ by Paul Albitz & Cricket Liu. + + Also see the check_soa version in the Contrib + directory which is an fires off the queries in + parallel. + + +check_zone Checks a zone for errors like missing PTR records. + Can recurse into subdomains. See also a hacked + version in contrib/check_zone. + +mresolv Performs multiple DNS queries in parallel. + +mx Prints a domain's MX records sorted by preference. + +perldig Performs DNS queries and print the results. + +--- +$Id: README 607 2006-09-17 18:20:28Z olaf $ diff --git a/demo/axfr b/demo/axfr new file mode 100755 index 0000000..ee0e9fe --- /dev/null +++ b/demo/axfr @@ -0,0 +1,183 @@ +#!/usr/local/bin/perl -w +# $Id: axfr 264 2005-04-06 09:16:15Z olaf $ + +use strict; +use vars qw($opt_f $opt_q $opt_s $opt_D); +use File::Basename; +use Getopt::Std; +use Net::DNS; +use Storable; + +#------------------------------------------------------------------------------ +# Read any command-line options and check syntax. +#------------------------------------------------------------------------------ + +getopts("fqsD:"); + +die "Usage: ", basename($0), " [ -fqs ] [ -D directory ] [ \@nameserver ] zone\n" + unless (@ARGV >= 1) && (@ARGV <= 2); + +#------------------------------------------------------------------------------ +# Get the nameserver (if specified) and set up the zone transfer directory +# hierarchy. +#------------------------------------------------------------------------------ + +my $nameserver = ($ARGV[0] =~ /^@/) ? shift @ARGV : ""; +$nameserver =~ s/^@//; + +my $zone = shift @ARGV; +my $basedir = defined $opt_D ? $opt_D : $ENV{"HOME"} . "/.dns-zones"; +my $zonedir = join("/", reverse(split(/\./, $zone))); +my $zonefile = $basedir . "/" . $zonedir . "/axfr"; + +# Don't worry about the 0777 permissions here - the current umask setting +# will be applied. +unless (-d $basedir) { + mkdir($basedir, 0777) or die "can't mkdir $basedir: $!\n"; +} + +my $dir = $basedir; +my $subdir; +foreach $subdir (split(m#/#, $zonedir)) { + $dir .= "/" . $subdir; + unless (-d $dir) { + mkdir($dir, 0777) or die "can't mkdir $dir: $!\n"; + } +} + +#------------------------------------------------------------------------------ +# Get the zone. +#------------------------------------------------------------------------------ + +my $res = Net::DNS::Resolver->new; +$res->nameservers($nameserver) if $nameserver; + +my (@zone, $zoneref); + +if (-e $zonefile && !defined $opt_f) { + $zoneref = retrieve($zonefile) || die "couldn't retrieve zone from $zonefile: $!\n"; + + #---------------------------------------------------------------------- + # Check the SOA serial number if desired. + #---------------------------------------------------------------------- + + if (defined $opt_s) { + my($serial_file, $serial_zone); + + my $rr; + foreach $rr (@$zoneref) { + if ($rr->type eq "SOA") { + $serial_file = $rr->serial; + last; + } + } + die "no SOA in $zonefile\n" unless defined $serial_file; + + my $soa = $res->query($zone, "SOA"); + die "couldn't get SOA for $zone: ", $res->errorstring, "\n" + unless defined $soa; + + foreach $rr ($soa->answer) { + if ($rr->type eq "SOA") { + $serial_zone = $rr->serial; + last; + } + } + + if ($serial_zone != $serial_file) { + $opt_f = 1; + } + } +} else { + $opt_f = 1; +} + +if (defined $opt_f) { + @zone = $res->axfr($zone); + die "couldn't transfer zone: ", $res->errorstring, "\n" unless @zone; + store \@zone, $zonefile or die "couldn't store zone to $zonefile: $!\n"; + $zoneref = \@zone; +} + +#------------------------------------------------------------------------------ +# Print the records in the zone. +#------------------------------------------------------------------------------ + +unless ($opt_q) { + $_->print for @$zoneref +} + +__END__ + +=head1 NAME + +axfr - Perform a DNS zone transfer + +=head1 SYNOPSIS + +B S<[ B<-fqs> ]> S<[ B<-D> I ]> S<[ B<@>I ]> +I + +=head1 DESCRIPTION + +B performs a DNS zone transfer, prints each record to the standard +output, and stores the zone to a file. If the zone has already been +stored in a file, B will read the file instead of performing a +zone transfer. + +Zones will be stored in a directory hierarchy. For example, the +zone transfer for foo.bar.com will be stored in the file +$HOME/.dns-zones/com/bar/foo/axfr. The directory can be changed +with the B<-D> option. + +This programs requires that the Storable module be installed. + +=head1 OPTIONS + +=over 4 + +=item B<-f> + +Force a zone transfer, even if the zone has already been stored +in a file. + +=item B<-q> + +Be quiet -- don't print the records from the zone. + +=item B<-s> + +Perform a zone transfer if the SOA serial number on the nameserver +is different than the serial number in the zone file. + +=item B<-D> I + +Store zone files under I instead of the default directory +(see L<"FILES">). + +=item B<@>I + +Query I instead of the default nameserver. + +=back + +=head1 FILES + +=over 4 + +=item B<$HOME/.dns-zones> + +Default directory for storing zone files. + +=back + +=head1 AUTHOR + +Michael Fuhr + +=head1 SEE ALSO + +L, L, L, L, L, L, +L, L + +=cut diff --git a/demo/check_soa b/demo/check_soa new file mode 100755 index 0000000..7f451a8 --- /dev/null +++ b/demo/check_soa @@ -0,0 +1,143 @@ +#!/usr/local/bin/perl -w +# $Id: check_soa 264 2005-04-06 09:16:15Z olaf $ + +=head1 NAME + +check_soa - Check a domain's nameservers + +=head1 SYNOPSIS + +B I + +=head1 DESCRIPTION + +B queries each of a domain's nameservers for the Start +of Authority (SOA) record and prints the serial number. Errors +are printed for nameservers that couldn't be reached or didn't +answer authoritatively. + +=head1 AUTHOR + +The original Bourne Shell and C versions were printed in +I by Paul Albitz & Cricket Liu. + +This Perl version was written by Michael Fuhr . + +=head1 SEE ALSO + +L, L, L, L, L, L, L + +=cut + +use File::Basename; +use Net::DNS; +use strict; + +#------------------------------------------------------------------------------ +# Get the domain from the command line. +#------------------------------------------------------------------------------ + +die "Usage: ", basename($0), " domain\n" unless @ARGV == 1; + +my ($domain) = @ARGV; + +#------------------------------------------------------------------------------ +# Find all the nameservers for the domain. +#------------------------------------------------------------------------------ + +my $res = Net::DNS::Resolver->new(); + +$res->defnames(0); +$res->retry(2); + +my $ns_req = $res->query($domain, "NS"); +die "No nameservers found for $domain: ", $res->errorstring, "\n" + unless defined($ns_req) and ($ns_req->header->ancount > 0); + + +# Send out non-recursive queries +$res->recurse(0); +# Do not buffer standard out +$| = 1; + + +#------------------------------------------------------------------------------ +# Check the SOA record on each nameserver. +#------------------------------------------------------------------------------ + +foreach my $nsrr (grep {$_->type eq "NS" } $ns_req->answer) { + + #---------------------------------------------------------------------- + # Set the resolver to query this nameserver. + #---------------------------------------------------------------------- + my $ns = $nsrr->nsdname; + + # In order to lookup the IP(s) of the nameserver, we need a Resolver + # object that is set to our local, recursive nameserver. So we create + # a new object just to do that. + + my $local_res = Net::DNS::Resolver->new(); + + my $a_req = $local_res->query($ns, 'A'); + + + unless ($a_req) { + warn "Can not find address for $ns: ", $res->errorstring, "\n"; + next; + } + + foreach my $ip (map { $_->address } grep { $_->type eq 'A' } $a_req->answer) { + #---------------------------------------------------------------------- + # Ask this IP. + #---------------------------------------------------------------------- + $res->nameservers($ip); + + print "$ns ($ip): "; + + #---------------------------------------------------------------------- + # Get the SOA record. + #---------------------------------------------------------------------- + + my $soa_req = $res->send($domain, 'SOA', 'IN'); + + unless (defined($soa_req)) { + warn $res->errorstring, "\n"; + next; + } + + #---------------------------------------------------------------------- + # Is this nameserver authoritative for the domain? + #---------------------------------------------------------------------- + + unless ($soa_req->header->aa) { + warn "isn't authoritative for $domain\n"; + next; + } + + #---------------------------------------------------------------------- + # We should have received exactly one answer. + #---------------------------------------------------------------------- + + unless ($soa_req->header->ancount == 1) { + warn "expected 1 answer, got ", $soa_req->header->ancount, "\n"; + next; + } + + #---------------------------------------------------------------------- + # Did we receive an SOA record? + #---------------------------------------------------------------------- + + unless (($soa_req->answer)[0]->type eq "SOA") { + warn "expected SOA, got ", ($soa_req->answer)[0]->type, "\n"; + next; + } + + #---------------------------------------------------------------------- + # Print the serial number. + #---------------------------------------------------------------------- + + print "has serial number ", ($soa_req->answer)[0]->serial, "\n"; + } +} + +0; diff --git a/demo/check_zone b/demo/check_zone new file mode 100755 index 0000000..7254f1c --- /dev/null +++ b/demo/check_zone @@ -0,0 +1,174 @@ +#!/usr/local/bin/perl -w +# $Id: check_zone 264 2005-04-06 09:16:15Z olaf $ + +=head1 NAME + +check_zone - Check a DNS zone for errors + +=head1 SYNOPSIS + +C [ C<-r> ] I [ I ] + +=head1 DESCRIPTION + +Checks a DNS zone for errors. Current checks are: + +=over 4 + +=item * + +Checks that all A records have corresponding PTR records. + +=item * + +Checks that hosts listed in NS, MX, and CNAME records have +A records. + +=back + +=head1 OPTIONS + +=over 4 + +=item C<-r> + +Perform a recursive check on subdomains. + +=back + +=head1 AUTHOR + +Michael Fuhr + +=head1 SEE ALSO + +L, L, L, L, L, L, L + +=cut + +use strict; +use vars qw($opt_r); + +use Getopt::Std; +use File::Basename; +use IO::Socket; +use Net::DNS; + +getopts("r"); + +die "Usage: ", basename($0), " [ -r ] domain [ class ]\n" + unless (@ARGV >= 1) && (@ARGV <= 2); + +check_domain(@ARGV); +exit; + +sub check_domain { + my ($domain, $class) = @_; + $class ||= "IN"; + + print "-" x 70, "\n"; + print "$domain (class $class)\n"; + print "\n"; + + my $res = Net::DNS::Resolver->new; + $res->defnames(0); + $res->retry(2); + + my $nspack = $res->query($domain, "NS", $class); + + unless (defined($nspack)) { + warn "Couldn't find nameservers for $domain: ", + $res->errorstring, "\n"; + return; + } + + print "nameservers (will request zone from first available):\n"; + my $ns; + foreach $ns (grep { $_->type eq "NS" } $nspack->answer) { + print "\t", $ns->nsdname, "\n"; + } + print "\n"; + + $res->nameservers(map { $_->nsdname } + grep { $_->type eq "NS" } + $nspack->answer); + + my @zone = $res->axfr($domain, $class); + unless (@zone) { + warn "Zone transfer failed: ", $res->errorstring, "\n"; + return; + } + + print "checking PTR records\n"; + check_ptr($domain, $class, @zone); + print "\n"; + + print "checking NS records\n"; + check_ns($domain, $class, @zone); + print "\n"; + + print "checking MX records\n"; + check_mx($domain, $class, @zone); + print "\n"; + + print "checking CNAME records\n"; + check_cname($domain, $class, @zone); + print "\n"; + + if ($opt_r) { + print "checking subdomains\n\n"; + my %subdomains; + foreach (grep { $_->type eq "NS" and $_->name ne $domain } @zone) { + $subdomains{$_->name} = 1; + } + foreach (sort keys %subdomains) { + check_domain($_, $class); + } + } +} + +sub check_ptr { + my ($domain, $class, @zone) = @_; + my $res = Net::DNS::Resolver->new; + my $rr; + foreach $rr (grep { $_->type eq "A" } @zone) { + my $host = $rr->name; + my $addr = $rr->address; + my $ans = $res->send($addr, "A", $class); + print "\t$host ($addr) has no PTR record\n" + if ($ans->header->ancount < 1); + } +} + +sub check_ns { + my ($domain, $class, @zone) = @_; + my $res = Net::DNS::Resolver->new; + my $rr; + foreach $rr (grep { $_->type eq "NS" } @zone) { + my $ans = $res->send($rr->nsdname, "A", $class); + print "\t", $rr->nsdname, " has no A record\n" + if ($ans->header->ancount < 1); + } +} + +sub check_mx { + my ($domain, $class, @zone) = @_; + my $res = Net::DNS::Resolver->new; + my $rr; + foreach $rr (grep { $_->type eq "MX" } @zone) { + my $ans = $res->send($rr->exchange, "A", $class); + print "\t", $rr->exchange, " has no A record\n" + if ($ans->header->ancount < 1); + } +} + +sub check_cname { + my ($domain, $class, @zone) = @_; + my $res = Net::DNS::Resolver->new; + my $rr; + foreach $rr (grep { $_->type eq "CNAME" } @zone) { + my $ans = $res->send($rr->cname, "A", $class); + print "\t", $rr->cname, " has no A record\n" + if ($ans->header->ancount < 1); + } +} diff --git a/demo/example_recurse.pl b/demo/example_recurse.pl new file mode 100755 index 0000000..bbcccff --- /dev/null +++ b/demo/example_recurse.pl @@ -0,0 +1,11 @@ +#!/usr/local/bin/perl -w + +# Example usage for Net::DNS::Resolver::Recurse +# Performs recursion for a query. + +use Net::DNS::Resolver::Recurse; +my $res = Net::DNS::Resolver::Recurse->new; +$res->debug(1); +$res->hints("198.41.0.4"); # A.ROOT-SERVER.NET. +my $packet = $res->query_dorecursion("www.rob.com.au.", "A"); +$packet && $packet->print; diff --git a/demo/mresolv b/demo/mresolv new file mode 100755 index 0000000..4c816bb --- /dev/null +++ b/demo/mresolv @@ -0,0 +1,144 @@ +#!/usr/local/bin/perl -w +# $Id: mresolv 264 2005-04-06 09:16:15Z olaf $ + +=head1 NAME + +mresolv - Perform multiple DNS lookups in parallel + +=head1 SYNOPSIS + +B S<[ B<-d> ]> S<[ B<-n> I ]> S<[ B<-t> I ]> +S<[ I... ]> + +=head1 DESCRIPTION + +B performs multiple DNS lookups in parallel. Names to query +are read from the list of files given on the command line, or from the +standard input. + +=head1 OPTIONS + +=over 4 + +=item B<-d> + +Turn on debugging output. + +=item B<-n> I + +Set the number of queries to have outstanding at any time. + +=item B<-t> I + +Set the timeout in seconds. If no replies are received for this +amount of time, all outstanding queries will be flushed and new +names will be read from the input stream. + +=back + +=head1 COPYRIGHT + +Copyright (c) 1997-2000 Michael Fuhr. All rights reserved. This +program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L, L, L, L, L, L, +L + +=cut + +use Net::DNS; +use IO::Select; +use Getopt::Std; +use strict; +use vars qw($opt_d $opt_n $opt_t); + +$| = 1; + +$opt_n = 32; # number of requests to have outstanding at any time +$opt_t = 15; # timeout (seconds) + +getopts("dn:t:"); + +my $res = Net::DNS::Resolver->new; +my $sel = IO::Select->new; +my $eof = 0; + +while (1) { + my $name; + my $sock; + + #---------------------------------------------------------------------- + # Read names until we've filled our quota of outstanding requests. + #---------------------------------------------------------------------- + + while (!$eof && $sel->count < $opt_n) { + print "DEBUG: reading..." if defined $opt_d; + $name = <>; + unless ($name) { + print "EOF.\n" if defined $opt_d; + $eof = 1; + last; + } + chomp $name; + $sock = $res->bgsend($name); + $sel->add($sock); + print "name = $name, outstanding = ", $sel->count, "\n" + if defined $opt_d; + } + + #---------------------------------------------------------------------- + # Wait for any replies. Remove any replies from the outstanding pool. + #---------------------------------------------------------------------- + + my @ready; + my $timed_out = 1; + + print "DEBUG: waiting for replies\n" if defined $opt_d; + + for (@ready = $sel->can_read($opt_t); + @ready; + @ready = $sel->can_read(0)) { + + $timed_out = 0; + + print "DEBUG: replies received: ", scalar @ready, "\n" + if defined $opt_d; + + foreach $sock (@ready) { + print "DEBUG: handling a reply\n" if defined $opt_d; + $sel->remove($sock); + my $ans = $res->bgread($sock); + next unless $ans; + my $rr; + foreach $rr ($ans->answer) { + $rr->print; + } + } + } + + #---------------------------------------------------------------------- + # If we timed out waiting for replies, remove all entries from the + # outstanding pool. + #---------------------------------------------------------------------- + + if ($timed_out) { + print "DEBUG: timeout: clearing the outstanding pool.\n" + if defined $opt_d; + my $sock; + foreach $sock ($sel->handles) { + $sel->remove($sock); + } + } + + print "DEBUG: outstanding = ", $sel->count, ", eof = $eof\n" + if defined $opt_d; + + #---------------------------------------------------------------------- + # We're done if there are no outstanding queries and we've read EOF. + #---------------------------------------------------------------------- + + last if ($sel->count == 0) && $eof; +} diff --git a/demo/mx b/demo/mx new file mode 100755 index 0000000..38def65 --- /dev/null +++ b/demo/mx @@ -0,0 +1,43 @@ +#!/usr/local/bin/perl -w +# $Id: mx 264 2005-04-06 09:16:15Z olaf $ + +=head1 NAME + +mx - Print a domain's MX records + +=head1 SYNOPSIS + +C I + +=head1 DESCRIPTION + +C prints a domain's MX records, sorted by preference. + +=head1 AUTHOR + +Michael Fuhr + +=head1 SEE ALSO + +L, L, L, L, L, L, +L + +=cut + +use strict; +use File::Basename; +use Net::DNS; + +die "Usage: ", basename($0), " domain\n" unless (@ARGV == 1); + +my $dname = $ARGV[0]; +my $res = Net::DNS::Resolver->new; +my @mx = mx($res, $dname); + +if (@mx) { + foreach my $rr (@mx) { + print $rr->preference, "\t", $rr->exchange, "\n"; + } +} else { + print "Can't find MX hosts for $dname: ", $res->errorstring, "\n"; +} diff --git a/demo/perldig b/demo/perldig new file mode 100755 index 0000000..28a2b6d --- /dev/null +++ b/demo/perldig @@ -0,0 +1,70 @@ +#!/usr/local/bin/perl -w +# $Id: perldig 264 2005-04-06 09:16:15Z olaf $ + +=head1 NAME + +perldig - Perl script to perform DNS queries + +=head1 SYNOPSIS + +C [ C<@>I ] I [ I [ I ] ] + +=head1 DESCRIPTION + +Performs a DNS query on the given name. The record type +and class can also be specified; if left blank they default +to A and IN. + +=head1 AUTHOR + +Michael Fuhr + +=head1 SEE ALSO + +L, L, L, L, L, L, +L + +=cut + +use strict; + +use File::Basename; +use Net::DNS; + +my $res = Net::DNS::Resolver->new; + +if (@ARGV && ($ARGV[0] =~ /^@/)) { + my $nameserver = shift; + $nameserver =~ s/^@//; + $res->nameservers($nameserver); +} + +die "Usage: ", basename($0), " [ \@nameserver ] name [ type [ class ] ]\n" + unless (@ARGV >= 1) && (@ARGV <= 3); + +my ($name, $type, $class) = @ARGV; +$type ||= "A"; +$class ||= "IN"; + +if (uc($type) eq "AXFR") { + + my @rrs = $res->axfr($name, $class); + + if (@rrs) { + foreach my $rr (@rrs) { + $rr->print; + } + } else { + die "zone transfer failed: ", $res->errorstring, "\n"; + } + +} else { + + my $answer = $res->send($name, $type, $class); + + if ($answer) { + $answer->print; + } else { + die "query failed: ", $res->errorstring, "\n"; + } +} diff --git a/demo/trace_dns.pl b/demo/trace_dns.pl new file mode 100755 index 0000000..6e13753 --- /dev/null +++ b/demo/trace_dns.pl @@ -0,0 +1,21 @@ +#!/usr/local/bin/perl + +use strict; +use warnings; + +use Net::DNS; +use Net::DNS::Resolver::Recurse; + +my $res = Net::DNS::Resolver::Recurse->new; + + +$res->recursion_callback(sub { + my $packet = shift; + + $_->print for $packet->additional; + + printf(";; Received %d bytes from %s\n\n", $packet->answersize, $packet->answerfrom); +}); + + +$res->query_dorecursion(@ARGV); diff --git a/lib/Net/DNS.pm b/lib/Net/DNS.pm new file mode 100644 index 0000000..c50833b --- /dev/null +++ b/lib/Net/DNS.pm @@ -0,0 +1,650 @@ +package Net::DNS; + +# +# $Id: DNS.pm 1639 2018-02-09 11:08:24Z willem $ +# +require 5.006; +our $VERSION; +$VERSION = '1.15'; +$VERSION = eval $VERSION; +our $SVNVERSION = (qw$LastChangedRevision: 1639 $)[1]; + + +=head1 NAME + +Net::DNS - Perl Interface to the Domain Name System + +=head1 SYNOPSIS + + use Net::DNS; + +=head1 DESCRIPTION + +Net::DNS is a collection of Perl modules that act as a Domain Name System +(DNS) resolver. It allows the programmer to perform DNS queries that are +beyond the capabilities of "gethostbyname" and "gethostbyaddr". + +The programmer should be somewhat familiar with the format of a DNS packet +and its various sections. See RFC 1035 or DNS and BIND (Albitz & Liu) for +details. + +=cut + + +use strict; +use warnings; +use integer; + +use base qw(Exporter); +our @EXPORT = qw(SEQUENTIAL UNIXTIME YYYYMMDDxx + yxrrset nxrrset yxdomain nxdomain rr_add rr_del + mx rr rrsort); + + +local $SIG{__DIE__}; +require Net::DNS::Resolver; +require Net::DNS::Packet; +require Net::DNS::RR; +require Net::DNS::Update; + + +sub version { $VERSION; } + + +# +# rr() +# +# Usage: +# @rr = rr('example.com'); +# @rr = rr('example.com', 'A', 'IN'); +# @rr = rr($res, 'example.com' ... ); +# +sub rr { + my ($arg1) = @_; + my $res = ref($arg1) ? shift : new Net::DNS::Resolver(); + + my $ans = $res->query(@_); + my @list = $ans ? $ans->answer : (); +} + + +# +# mx() +# +# Usage: +# @mx = mx('example.com'); +# @mx = mx($res, 'example.com'); +# +sub mx { + my ($arg1) = @_; + my @res = ( ref($arg1) ? shift : () ); + my ( $name, @class ) = @_; + + # This construct is best read backwards. + # + # First we take the answer section of the packet. + # Then we take just the MX records from that list + # Then we sort the list by preference + # We do this into an array to force list context. + # Then we return the list. + + my @list = sort { $a->preference <=> $b->preference } + grep $_->type eq 'MX', &rr( @res, $name, 'MX', @class ); + return @list; +} + + +# +# rrsort() +# +# Usage: +# @prioritysorted = rrsort( "SRV", "priority", @rr_array ); +# +sub rrsort { + my $rrtype = uc shift; + my ( $attribute, @rr ) = @_; ## NB: attribute is optional + ( @rr, $attribute ) = @_ if ref($attribute) =~ /^Net::DNS::RR/; + + my @extracted = grep $_->type eq $rrtype, @rr; + return @extracted unless scalar @extracted; + my $func = "Net::DNS::RR::$rrtype"->get_rrsort_func($attribute); + my @sorted = sort $func @extracted; +} + + +# +# Auxiliary functions to support policy-driven zone serial numbering. +# +# $successor = $soa->serial(SEQUENTIAL); +# $successor = $soa->serial(UNIXTIME); +# $successor = $soa->serial(YYYYMMDDxx); +# + +sub SEQUENTIAL {undef} + +sub UNIXTIME { return CORE::time; } + +sub YYYYMMDDxx { + my ( $dd, $mm, $yy ) = (localtime)[3 .. 5]; + return 1900010000 + sprintf '%d%0.2d%0.2d00', $yy, $mm, $dd; +} + + +# +# Auxiliary functions to support dynamic update. +# + +sub yxrrset { + my $rr = new Net::DNS::RR(@_); + $rr->ttl(0); + $rr->class('ANY') unless $rr->rdata; + return $rr; +} + +sub nxrrset { + my $rr = new Net::DNS::RR(@_); + new Net::DNS::RR( + name => $rr->name, + type => $rr->type, + class => 'NONE' + ); +} + +sub yxdomain { + my ( $domain, @etc ) = map split, @_; + my $rr = new Net::DNS::RR( scalar(@etc) ? @_ : ( name => $domain ) ); + new Net::DNS::RR( + name => $rr->name, + type => 'ANY', + class => 'ANY' + ); +} + +sub nxdomain { + my ( $domain, @etc ) = map split, @_; + my $rr = new Net::DNS::RR( scalar(@etc) ? @_ : ( name => $domain ) ); + new Net::DNS::RR( + name => $rr->name, + type => 'ANY', + class => 'NONE' + ); +} + +sub rr_add { + my $rr = new Net::DNS::RR(@_); + $rr->{ttl} = 86400 unless defined $rr->{ttl}; + return $rr; +} + +sub rr_del { + my ( $domain, @etc ) = map split, @_; + my $rr = new Net::DNS::RR( scalar(@etc) ? @_ : ( name => $domain, type => 'ANY' ) ); + $rr->class( $rr->rdata ? 'NONE' : 'ANY' ); + $rr->ttl(0); + return $rr; +} + + +1; +__END__ + + + +=head2 Resolver Objects + +A resolver object is an instance of the L class. +A program can have multiple resolver objects, each maintaining its +own state information such as the nameservers to be queried, whether +recursion is desired, etc. + + +=head2 Packet Objects + +L queries return L objects. +Packet objects have five sections: + +=over 3 + +=item * + +The header section, a L object. + +=item * + +The question section, a list of L objects. + +=item * + +The answer section, a list of L objects. + +=item * + +The authority section, a list of L objects. + +=item * + +The additional section, a list of L objects. + +=back + +=head2 Update Objects + +L is a subclass of L +used to create dynamic update requests. + +=head2 Header Objects + +L objects represent the header +section of a DNS packet. + +=head2 Question Objects + +L objects represent the content of the question +section of a DNS packet. + +=head2 RR Objects + +L is the base class for DNS resource record (RR) objects +in the answer, authority, and additional sections of a DNS packet. + +Do not assume that RR objects will be of the type requested. +The type of an RR object must be checked before calling any methods. + + +=head1 METHODS + +See the manual pages listed above for other class-specific methods. + +=head2 version + + print Net::DNS->version, "\n"; + +Returns the version of Net::DNS. + + +=head2 rr + + # Use a default resolver -- can not get an error string this way. + use Net::DNS; + my @rr = rr("example.com"); + my @rr = rr("example.com", "A"); + my @rr = rr("example.com", "A", "IN"); + + # Use your own resolver object. + my $res = Net::DNS::Resolver->new; + my @rr = rr($res, "example.com" ... ); + + my ($ptr) = rr("192.0.2.1"); + +The C method provides simple RR lookup for scenarios where +the full flexibility of Net::DNS is not required. + +Returns a list of L objects for the specified name +or an empty list if the query failed or no record was found. + +See L for more complete examples. + + +=head2 mx + + # Use a default resolver -- can not get an error string this way. + use Net::DNS; + my @mx = mx("example.com"); + + # Use your own resolver object. + my $res = Net::DNS::Resolver->new; + my @mx = mx($res, "example.com"); + +Returns a list of L objects representing the MX +records for the specified name. +The list will be sorted by preference. +Returns an empty list if the query failed or no MX record was found. + +This method does not look up A records; it only performs MX queries. + + +=head1 Dynamic DNS Update Support + +The Net::DNS module provides auxiliary functions which support +dynamic DNS update requests. + + +=head2 yxrrset + +Use this method to add an "RRset exists" prerequisite to a dynamic +update packet. There are two forms, value-independent and +value-dependent: + + # RRset exists (value-independent) + $update->push(pre => yxrrset("host.example.com A")); + +Meaning: At least one RR with the specified name and type must +exist. + + # RRset exists (value-dependent) + $update->push(pre => yxrrset("host.example.com A 10.1.2.3")); + +Meaning: At least one RR with the specified name and type must +exist and must have matching data. + +Returns a L object or C if the object could not +be created. + +=head2 nxrrset + +Use this method to add an "RRset does not exist" prerequisite to +a dynamic update packet. + + $update->push(pre => nxrrset("host.example.com A")); + +Meaning: No RRs with the specified name and type can exist. + +Returns a L object or C if the object could not +be created. + +=head2 yxdomain + +Use this method to add a "name is in use" prerequisite to a dynamic +update packet. + + $update->push(pre => yxdomain("host.example.com")); + +Meaning: At least one RR with the specified name must exist. + +Returns a L object or C if the object could not +be created. + +=head2 nxdomain + +Use this method to add a "name is not in use" prerequisite to a +dynamic update packet. + + $update->push(pre => nxdomain("host.example.com")); + +Meaning: No RR with the specified name can exist. + +Returns a L object or C if the object could not +be created. + +=head2 rr_add + +Use this method to add RRs to a zone. + + $update->push(update => rr_add("host.example.com A 10.1.2.3")); + +Meaning: Add this RR to the zone. + +RR objects created by this method should be added to the "update" +section of a dynamic update packet. The TTL defaults to 86400 +seconds (24 hours) if not specified. + +Returns a L object or C if the object could not +be created. + +=head2 rr_del + +Use this method to delete RRs from a zone. There are three forms: +delete all RRsets, delete an RRset, and delete a specific RR. + + # Delete all RRsets. + $update->push(update => rr_del("host.example.com")); + +Meaning: Delete all RRs having the specified name. + + # Delete an RRset. + $update->push(update => rr_del("host.example.com A")); + +Meaning: Delete all RRs having the specified name and type. + + # Delete a specific RR. + $update->push(update => rr_del("host.example.com A 10.1.2.3")); + +Meaning: Delete all RRs having the specified name, type, and data. + +RR objects created by this method should be added to the "update" +section of a dynamic update packet. + +Returns a L object or C if the object could not +be created. + + +=head1 Zone Serial Number Management + +The Net::DNS module provides auxiliary functions which support +policy-driven zone serial numbering regimes. + +=head2 SEQUENTIAL + + $successor = $soa->serial( SEQUENTIAL ); + +The existing serial number is incremented modulo 2**32. + +=head2 UNIXTIME + + $successor = $soa->serial( UNIXTIME ); + +The Unix time scale will be used as the basis for zone serial +numbering. The serial number will be incremented if the time +elapsed since the previous update is less than one second. + +=head2 YYYYMMDDxx + + $successor = $soa->serial( YYYYMMDDxx ); + +The 32 bit value returned by the auxiliary C function +will be used as the base for the date-coded zone serial number. +Serial number increments must be limited to 100 per day for the +date information to remain useful. + + + +=head1 Sorting of RR arrays + +C provides functionality to help you sort RR arrays. In most cases +this will give you the answer that you want, but you can specify your +own sorting method by using the C<< Net::DNS::RR::FOO->set_rrsort_func() >> +class method. See L for details. + +=head2 rrsort + + use Net::DNS; + + my @sorted = rrsort( $rrtype, $attribute, @rr_array ); + +C selects all RRs from the input array that are of the type defined +by the first argument. Those RRs are sorted based on the attribute that is +specified as second argument. + +There are a number of RRs for which the sorting function is defined in the +code. + +For instance: + + my @prioritysorted = rrsort( "SRV", "priority", @rr_array ); + +returns the SRV records sorted from lowest to highest priority and for +equal priorities from highest to lowest weight. + +If the function does not exist then a numerical sort on the attribute +value is performed. + + my @portsorted = rrsort( "SRV", "port", @rr_array ); + +If the attribute is not defined then either the C function or +"canonical sorting" (as defined by DNSSEC) will be used. + +C returns a sorted array containing only elements of the specified +RR type. Any other RR types are silently discarded. + +C returns an empty list when arguments are incorrect. + + +=head1 EXAMPLES + +The following brief examples illustrate some of the features of Net::DNS. +The documentation for individual modules and the demo scripts included +with the distribution provide more extensive examples. + +See L for an example of performing dynamic updates. + + +=head2 Look up host addresses. + + use Net::DNS; + my $res = Net::DNS::Resolver->new; + my $reply = $res->search("www.example.com", "A"); + + if ($reply) { + foreach my $rr ($reply->answer) { + print $rr->address, "\n" if $rr->can("address"); + } + } else { + warn "query failed: ", $res->errorstring, "\n"; + } + + +=head2 Find the nameservers for a domain. + + use Net::DNS; + my $res = Net::DNS::Resolver->new; + my $reply = $res->query("example.com", "NS"); + + if ($reply) { + foreach $rr (grep { $_->type eq "NS" } $reply->answer) { + print $rr->nsdname, "\n"; + } + } else { + warn "query failed: ", $res->errorstring, "\n"; + } + + +=head2 Find the MX records for a domain. + + use Net::DNS; + my $name = "example.com"; + my $res = Net::DNS::Resolver->new; + my @mx = mx($res, $name); + + if (@mx) { + foreach $rr (@mx) { + print $rr->preference, "\t", $rr->exchange, "\n"; + } + } else { + warn "Can not find MX records for $name: ", $res->errorstring, "\n"; + } + + +=head2 Print domain SOA record in zone file format. + + use Net::DNS; + my $res = Net::DNS::Resolver->new; + my $reply = $res->query("example.com", "SOA"); + + if ($reply) { + foreach my $rr ($reply->answer) { + $rr->print; + } + } else { + warn "query failed: ", $res->errorstring, "\n"; + } + + +=head2 Perform a zone transfer and print all the records. + + use Net::DNS; + my $res = Net::DNS::Resolver->new; + $res->tcp_timeout(20); + $res->nameservers("ns.example.com"); + + my @zone = $res->axfr("example.com"); + + foreach $rr (@zone) { + $rr->print; + } + + warn $res->errorstring if $res->errorstring; + + +=head2 Perform a background query and print the reply. + + use Net::DNS; + my $res = Net::DNS::Resolver->new; + $res->udp_timeout(10); + $res->tcp_timeout(20); + my $socket = $res->bgsend("host.example.com"); + + while ( $res->bgbusy($socket) ) { + # do some work here while waiting for the answer + # ...and some more here + } + + my $packet = $res->bgread($socket); + if ($packet) { + $packet->print; + } else { + warn "query failed: ", $res->errorstring, "\n"; + } + + +=head1 BUGS + +Net::DNS is slow. + +For other items to be fixed, or if you discover a bug in this +distribution please use the CPAN bug reporting system. + + +=head1 COPYRIGHT + +Copyright (c)1997-2000 Michael Fuhr. + +Portions Copyright (c)2002,2003 Chris Reinhardt. + +Portions Copyright (c)2005 Olaf Kolkman (RIPE NCC) + +Portions Copyright (c)2006 Olaf Kolkman (NLnet Labs) + +Portions Copyright (c)2014 Dick Franks + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 AUTHOR INFORMATION + +Net::DNS is maintained at NLnet Labs (www.nlnetlabs.nl) by Willem Toorop. + +Between 2005 and 2012 Net::DNS was maintained by Olaf Kolkman. + +Between 2002 and 2004 Net::DNS was maintained by Chris Reinhardt. + +Net::DNS was created in 1997 by Michael Fuhr. + + +=head1 SEE ALSO + +L, L, L, L, +L, L, +RFC1035, L, +I by Paul Albitz & Cricket Liu + +=cut + diff --git a/lib/Net/DNS/Domain.pm b/lib/Net/DNS/Domain.pm new file mode 100644 index 0000000..7e4b985 --- /dev/null +++ b/lib/Net/DNS/Domain.pm @@ -0,0 +1,404 @@ +package Net::DNS::Domain; + +# +# $Id: Domain.pm 1611 2018-01-02 09:41:24Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1611 $)[1]; + + +=head1 NAME + +Net::DNS::Domain - DNS domains + +=head1 SYNOPSIS + + use Net::DNS::Domain; + + $domain = new Net::DNS::Domain('example.com'); + $name = $domain->name; + +=head1 DESCRIPTION + +The Net::DNS::Domain module implements a class of abstract DNS +domain objects with associated class and instance methods. + +Each domain object instance represents a single DNS domain which +has a fixed identity throughout its lifetime. + +Internally, the primary representation is a (possibly empty) list +of ASCII domain name labels, and optional link to an arbitrary +origin domain object topologically closer to the DNS root. + +The computational expense of Unicode character-set conversion is +partially mitigated by use of caches. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + + +use constant ASCII => ref eval { + require Encode; + Encode::find_encoding('ascii'); +}; + +use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see UTR#16 3.6] + Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); +}; + +use constant LIBIDN => defined eval 'require Net::LibIDN'; +use constant LIBIDN2 => ref eval 'require Net::LibIDN2; Net::LibIDN2->can("idn2_to_ascii_8")'; + +use constant IDN2FLAG => eval 'Net::LibIDN2::IDN2_NFC_INPUT + Net::LibIDN2::IDN2_NONTRANSITIONAL'; + +# perlcc: address of encoding objects must be determined at runtime +my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law: +my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't. + + +=head1 METHODS + +=head2 new + + $object = new Net::DNS::Domain('example.com'); + +Creates a domain object which represents the DNS domain specified +by the character string argument. The argument consists of a +sequence of labels delimited by dots. + +A character preceded by \ represents itself, without any special +interpretation. + +Arbitrary 8-bit codes can be represented by \ followed by exactly +three decimal digits. +Character code points are ASCII, irrespective of the character +coding scheme employed by the underlying platform. + +Argument string literals should be delimited by single quotes to +avoid escape sequences being interpreted as octal character codes +by the Perl compiler. + +The character string presentation format follows the conventions +for zone files described in RFC1035. + +Users should be aware that non-ASCII domain names will be transcoded +to NFC before encoding, which is an irreversible process. + +=cut + +my ( %escape, %unescape ); ## precalculated ASCII escape tables + +our $ORIGIN; +my ( $cache1, $cache2, $limit ) = ( {}, {}, 100 ); + +sub new { + my ( $class, $s ) = @_; + croak 'domain identifier undefined' unless defined $s; + + my $k = join '', $s, $class, $ORIGIN || ''; # cache key + my $cache = $$cache1{$k} ||= $$cache2{$k}; # two layer cache + return $cache if defined $cache; + + ( $cache1, $cache2, $limit ) = ( {}, $cache1, 500 ) unless $limit--; # recycle cache + + my $self = bless {}, $class; + + $s =~ s/\\\\/\\092/g; # disguise escaped escape + $s =~ s/\\\./\\046/g; # disguise escaped dot + + my $label = $self->{label} = ( $s eq '@' ) ? [] : [split /\056/, _encode_utf8($s)]; + + foreach (@$label) { + croak 'empty domain label' unless length; + + if ( LIBIDN2 && UTF8 && /[^\000-\177]/ ) { + my $rc = 0; + s/\134/\357\277\275/; # disallow escapes + $_ = Net::LibIDN2::idn2_to_ascii_8( $_, IDN2FLAG, $rc ); + croak Net::LibIDN2::idn2_strerror($rc) unless $_; + } + + if ( !LIBIDN2 && LIBIDN && UTF8 && /[^\000-\177]/ ) { + s/\134/\357\277\275/; # disallow escapes + $_ = Net::LibIDN::idn_to_ascii( $_, 'utf-8' ); + croak 'name contains disallowed character' unless $_; + } + + s/\134([\060-\071]{3})/$unescape{$1}/eg; # numeric escape + s/\134(.)/$1/g; # character escape + croak 'long domain label' if length > 63; + } + + $$cache1{$k} = $self; # cache object reference + + return $self if $s =~ /\.$/; # fully qualified name + $self->{origin} = $ORIGIN || return $self; # dynamically scoped $ORIGIN + return $self; +} + + +=head2 name + + $name = $domain->name; + +Returns the domain name as a character string corresponding to the +"common interpretation" to which RFC1034, 3.1, paragraph 9 alludes. + +Character escape sequences are used to represent a dot inside a +domain name label and the escape character itself. + +Any non-printable code point is represented using the appropriate +numerical escape sequence. + +=cut + +sub name { + my ($self) = @_; + + return $self->{name} if defined $self->{name}; + return unless defined wantarray; + + my @label = map { s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; $_ } $self->_wire; + + return $self->{name} = '.' unless scalar @label; + $self->{name} = _decode_ascii( join chr(46), @label ); +} + + +=head2 fqdn + + @fqdn = $domain->fqdn; + +Returns a character string containing the fully qualified domain +name, including the trailing dot. + +=cut + +sub fqdn { + my $name = &name; + return $name =~ /[.]$/ ? $name : $name . '.'; # append trailing dot +} + + +=head2 xname + + $xname = $domain->xname; + +Interprets an extended name containing Unicode domain name labels +encoded as Punycode A-labels. + +If decoding is not possible, the ACE encoded name is returned. + +=cut + +sub xname { + my $name = &name; + + if ( LIBIDN2 && UTF8 && $name =~ /xn--/i ) { + my $self = shift; + return $self->{xname} if defined $self->{xname}; + my $u8 = Net::LibIDN2::idn2_to_unicode_88($name); + return $self->{xname} = $u8 ? $utf8->decode($u8) : $name; + } + + if ( !LIBIDN2 && LIBIDN && UTF8 && $name =~ /xn--/i ) { + my $self = shift; + return $self->{xname} if defined $self->{xname}; + return $self->{xname} = $utf8->decode( Net::LibIDN::idn_to_unicode $name, 'utf-8' ); + } + return $name; +} + + +=head2 label + + @label = $domain->label; + +Identifies the domain by means of a list of domain labels. + +=cut + +sub label { + map { + s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; + _decode_ascii($_) + } shift->_wire; +} + + +sub _wire { + my $self = shift; + + my $label = $self->{label}; + my $origin = $self->{origin} || return (@$label); + return ( @$label, $origin->_wire ); +} + + +=head2 string + + $string = $object->string; + +Returns a character string containing the fully qualified domain +name as it appears in a zone file. + +Characters which are recognised by RFC1035 zone file syntax are +represented by the appropriate escape sequence. + +=cut + +sub string { + ( my $name = &name ) =~ s/(["'\$();@])/\\$1/; # escape special char + return $name =~ /[.]$/ ? $name : $name . '.'; # append trailing dot +} + + +=head2 origin + + $create = origin Net::DNS::Domain( $ORIGIN ); + $result = &$create( sub{ new Net::DNS::RR( 'mx MX 10 a' ); } ); + $expect = new Net::DNS::RR( "mx.$ORIGIN. MX 10 a.$ORIGIN." ); + +Class method which returns a reference to a subroutine wrapper +which executes a given constructor in a dynamically scoped context +where relative names become descendents of the specified $ORIGIN. + +=cut + +my $placebo = sub { my $constructor = shift; &$constructor; }; + +sub origin { + my ( $class, $name ) = @_; + my $domain = defined $name ? new Net::DNS::Domain($name) : return $placebo; + + return sub { # closure w.r.t. $domain + my $constructor = shift; + local $ORIGIN = $domain; # dynamically scoped $ORIGIN + &$constructor; + } +} + + +######################################## + +sub _decode_ascii { ## ASCII to perl internal encoding + local $_ = shift; + + # partial transliteration for non-ASCII character encodings + tr + [\040-\176\000-\377] + [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII; + + my $z = length($_) - length($_); # pre-5.18 taint workaround + ASCII ? substr( $ascii->decode($_), $z ) : $_; +} + + +sub _encode_utf8 { ## perl internal encoding to UTF8 + local $_ = shift; + + # partial transliteration for non-ASCII character encodings + tr + [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~\000-\377] + [\040-\176\077] unless ASCII; + + my $z = length($_) - length($_); # pre-5.18 taint workaround + ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; +} + + +%escape = eval { ## precalculated ASCII escape table + my %table; + + foreach ( 33 .. 126 ) { # ASCII printable + $table{pack( 'C', $_ )} = pack 'C', $_; + } + + # minimal character escapes + foreach ( 46, 92 ) { # \. \\ + $table{pack( 'C', $_ )} = pack 'C*', 92, $_; + } + + foreach my $n ( 0 .. 32, 127 .. 255 ) { # \ddd + my $codepoint = sprintf( '%03u', $n ); + + # partial transliteration for non-ASCII character encodings + $codepoint =~ tr [0-9] [\060-\071]; + + $table{pack( 'C', $n )} = pack 'C a3', 92, $codepoint; + } + + return %table; +}; + + +%unescape = eval { ## precalculated numeric escape table + my %table; + + foreach my $n ( 0 .. 255 ) { + my $key = sprintf( '%03u', $n ); + + # partial transliteration for non-ASCII character encodings + $key =~ tr [0-9] [\060-\071]; + + $table{$key} = pack 'C', $n; + $table{$key} = pack 'C2', 92, $n if $n == 92; # escaped escape + } + + return %table; +}; + + +1; +__END__ + + +######################################## + +=head1 BUGS + +Coding strategy is intended to avoid creating unnecessary argument +lists and stack frames. This improves efficiency at the expense of +code readability. + +Platform specific character coding features are conditionally +compiled into the code. + + +=head1 COPYRIGHT + +Copyright (c)2009-2011,2017 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1034, RFC1035, RFC5891, +Unicode Technical Report #16 + +=cut + diff --git a/lib/Net/DNS/DomainName.pm b/lib/Net/DNS/DomainName.pm new file mode 100644 index 0000000..55c8c3e --- /dev/null +++ b/lib/Net/DNS/DomainName.pm @@ -0,0 +1,294 @@ +package Net::DNS::DomainName; + +# +# $Id: DomainName.pm 1605 2017-11-27 11:37:40Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1605 $)[1]; + + +=head1 NAME + +Net::DNS::DomainName - DNS name representation + +=head1 SYNOPSIS + + use Net::DNS::DomainName; + + $object = new Net::DNS::DomainName('example.com'); + $name = $object->name; + $data = $object->encode; + + ( $object, $next ) = decode Net::DNS::DomainName( \$data, $offset ); + +=head1 DESCRIPTION + +The Net::DNS::DomainName module implements the concrete representation +of DNS domain names used within DNS packets. + +Net::DNS::DomainName defines methods for encoding and decoding wire +format octet strings as defined in RFC1035. All other behaviour, +including the new() constructor, is inherited from Net::DNS::Domain. + +The Net::DNS::DomainName1035 and Net::DNS::DomainName2535 packages +implement disjoint domain name subtypes which provide the name +compression and canonicalisation specified by RFC1035 and RFC2535. +These are necessary to meet the backward compatibility requirements +introduced by RFC3597. + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Domain); + +use integer; +use Carp; + + +=head1 METHODS + +=head2 new + + $object = new Net::DNS::DomainName('example.com'); + +Creates a domain name object which identifies the domain specified +by the character string argument. + + +=head2 canonical + + $data = $object->canonical; + +Returns the canonical wire-format representation of the domain name +as defined in RFC2535(8.1). + +=cut + +sub canonical { + join '', map( { tr /\101-\132/\141-\172/; + pack 'C a*', length($_), $_; + } shift->_wire ), + pack 'x'; +} + + +=head2 decode + + $object = decode Net::DNS::DomainName( \$buffer, $offset, $hash ); + + ( $object, $next ) = decode Net::DNS::DomainName( \$buffer, $offset, $hash ); + +Creates a domain name object which represents the DNS domain name +identified by the wire-format data at the indicated offset within +the data buffer. + +The argument list consists of a reference to a scalar containing the +wire-format data and specified offset. The optional reference to a +hash table provides improved efficiency of decoding compressed names +by exploiting already cached compression pointers. + +The returned offset value indicates the start of the next item in the +data buffer. + +=cut + +sub decode { + my $label = []; + my $self = bless {label => $label}, shift; + my $buffer = shift; # reference to data buffer + my $offset = shift || 0; # offset within buffer + my $cache = shift || {}; # hashed objectref by offset + + my $buflen = length $$buffer; + my $index = $offset; + + while ( $index < $buflen ) { + my $header = unpack( "\@$index C", $$buffer ) + || return wantarray ? ( $self, ++$index ) : $self; + + if ( $header < 0x40 ) { # non-terminal label + push @$label, substr( $$buffer, ++$index, $header ); + $index += $header; + + } elsif ( $header < 0xC0 ) { # deprecated extended label types + croak 'unimplemented label type'; + + } else { # compression pointer + my $link = 0x3FFF & unpack( "\@$index n", $$buffer ); + croak 'corrupt compression pointer' unless $link < $offset; + + # uncoverable condition false + $self->{origin} = $cache->{$link} ||= decode Net::DNS::DomainName( $buffer, $link, $cache ); + return wantarray ? ( $self, $index + 2 ) : $self; + } + } + croak 'corrupt wire-format data'; +} + + +=head2 encode + + $data = $object->encode; + +Returns the wire-format representation of the domain name suitable +for inclusion in a DNS packet buffer. + +=cut + +sub encode { + join '', map pack( 'C a*', length($_), $_ ), shift->_wire, ''; +} + + +######################################## + +sub _wire { ## Generate list of wire-format labels + my $self = shift; + + my $label = $self->{label}; + my $origin = $self->{origin} || return (@$label); + return ( @$label, $origin->_wire ); +} + + +######################################## + +package Net::DNS::DomainName1035; +our @ISA = qw(Net::DNS::DomainName); + +=head1 Net::DNS::DomainName1035 + +Net::DNS::DomainName1035 implements a subclass of domain name +objects which are to be encoded using the compressed wire format +defined in RFC1035. + + use Net::DNS::DomainName; + + $object = new Net::DNS::DomainName1035('compressible.example.com'); + $data = $object->encode( $offset, $hash ); + + ( $object, $next ) = decode Net::DNS::DomainName1035( \$data, $offset ); + +Note that RFC3597 implies that the RR types defined in RFC1035 +section 3.3 are the only types eligible for compression. + + +=head2 encode + + $data = $object->encode( $offset, $hash ); + +Returns the wire-format representation of the domain name suitable +for inclusion in a DNS packet buffer. + +The optional arguments are the offset within the packet data where +the domain name is to be stored and a reference to a hash table used +to index compressed names within the packet. + +If the hash reference is undefined, encode() returns the lowercase +uncompressed canonical representation defined in RFC2535(8.1). + +=cut + +sub encode { + my $self = shift; + my $offset = shift || 0; # offset in data buffer + my $hash = shift || return $self->canonical; # hashed offset by name + + my @labels = $self->_wire; + my $data = ''; + while (@labels) { + my $name = join( '.', @labels ); + + return $data . pack( 'n', 0xC000 | $hash->{$name} ) if defined $hash->{$name}; + + my $label = shift @labels; + my $length = length $label; + $data .= pack( 'C a*', $length, $label ); + + next unless $offset < 0x4000; + $hash->{$name} = $offset; + $offset += 1 + $length; + } + $data .= pack 'x'; +} + + +######################################## + +package Net::DNS::DomainName2535; +our @ISA = qw(Net::DNS::DomainName); + +=head1 Net::DNS::DomainName2535 + +Net::DNS::DomainName2535 implements a subclass of domain name +objects which are to be encoded using uncompressed wire format. + +Note that RFC3597, and latterly RFC4034, specifies that the lower +case canonical encoding defined in RFC2535 is to be used for RR +types defined prior to RFC3597. + + use Net::DNS::DomainName; + + $object = new Net::DNS::DomainName2535('incompressible.example.com'); + $data = $object->encode( $offset, $hash ); + + ( $object, $next ) = decode Net::DNS::DomainName2535( \$data, $offset ); + + +=head2 encode + + $data = $object->encode( $offset, $hash ); + +Returns the uncompressed wire-format representation of the domain +name suitable for inclusion in a DNS packet buffer. + +If the hash reference is undefined, encode() returns the lowercase +canonical form defined in RFC2535(8.1). + +=cut + +sub encode { + return shift->canonical unless defined $_[2]; + join '', map pack( 'C a*', length($_), $_ ), shift->_wire, ''; +} + +1; +__END__ + + +######################################## + +=head1 COPYRIGHT + +Copyright (c)2009-2011 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035, RFC2535, +RFC3597, RFC4034 + +=cut + diff --git a/lib/Net/DNS/FAQ.pod b/lib/Net/DNS/FAQ.pod new file mode 100644 index 0000000..33a481d --- /dev/null +++ b/lib/Net/DNS/FAQ.pod @@ -0,0 +1,49 @@ +=head1 NAME + +Net::DNS::FAQ - Frequently Asked Net::DNS Questions + +=head1 SYNOPSIS + + perldoc Net::DNS::FAQ + +=head1 DESCRIPTION + +This document serves to answer the most frequently asked questions on both the +Net::DNS Mailing List and those sent to the author. + +The latest version of this FAQ can be found at + L + + +=head1 GENERAL + +=head2 What is Net::DNS? + +Net::DNS is a perl implementation of a DNS resolver. + + +=head1 INSTALLATION + +=head2 Where can I find Test::More? + +Test::More is part of the Test-Simple package, by Michael G Schwern. +You should be able to find the distribution at + L + + +=head1 USAGE + +=head2 Why does $resolver->query() return undef when the answer section is empty? + +The short answer is, do not use query(). +$resolver->send() will always return the answer packet, +as long as an answer was received. + +The longer answer is that query() is modeled after the res_query() function +from the libresolv C library, which has similar behavior. + + +=head1 VERSION + + $Id: FAQ.pod 1365 2015-06-26 08:46:01Z willem $ + diff --git a/lib/Net/DNS/Header.pm b/lib/Net/DNS/Header.pm new file mode 100644 index 0000000..b31714d --- /dev/null +++ b/lib/Net/DNS/Header.pm @@ -0,0 +1,501 @@ +package Net::DNS::Header; + +# +# $Id: Header.pm 1527 2017-01-18 21:42:48Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1527 $)[1]; + + +=head1 NAME + +Net::DNS::Header - DNS packet header + +=head1 SYNOPSIS + + use Net::DNS; + + $packet = new Net::DNS::Packet; + $header = $packet->header; + + +=head1 DESCRIPTION + +C represents the header portion of a DNS packet. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use Net::DNS::Parameters; + + +=head1 METHODS + + +=head2 $packet->header + + $packet = new Net::DNS::Packet; + $header = $packet->header; + +Net::DNS::Header objects emanate from the Net::DNS::Packet header() +method, and contain an opaque reference to the parent Packet object. + +Header objects may be assigned to suitably scoped lexical variables. +They should never be stored in global variables or persistent data +structures. + + +=head2 string + + print $packet->header->string; + +Returns a string representation of the packet header. + +=cut + +sub string { + my $self = shift; + + my $id = $self->id; + my $qr = $self->qr; + my $opcode = $self->opcode; + my $rcode = $self->rcode; + my $qd = $self->qdcount; + my $an = $self->ancount; + my $ns = $self->nscount; + my $ar = $self->arcount; + + my $opt = $$self->edns; + my $edns = $opt->_specified ? $opt->string : ''; + + return <aa; + my $tc = $self->tc; + my $rd = $self->rd; + my $ra = $self->ra; + my $zz = $self->z; + my $ad = $self->ad; + my $cd = $self->cd; + my $do = $self->do; + + return <header->print; + +Prints the string representation of the packet header. + +=cut + +sub print { print &string; } + + +=head2 id + + print "query id = ", $packet->header->id, "\n"; + $packet->header->id(1234); + +Gets or sets the query identification number. + +A random value is assigned if the argument value is undefined. + +=cut + +sub id { + my $self = shift; + $$self->{id} = shift if scalar @_; + return $$self->{id} if defined $$self->{id}; + $$self->{id} = int rand(0xffff); +} + + +=head2 opcode + + print "query opcode = ", $packet->header->opcode, "\n"; + $packet->header->opcode("UPDATE"); + +Gets or sets the query opcode (the purpose of the query). + +=cut + +sub opcode { + my $self = shift; + for ( $$self->{status} ) { + return opcodebyval( ( $_ >> 11 ) & 0x0f ) unless scalar @_; + my $opcode = opcodebyname(shift); + $_ = ( $_ & 0x87ff ) | ( $opcode << 11 ); + return $opcode; + } +} + + +=head2 rcode + + print "query response code = ", $packet->header->rcode, "\n"; + $packet->header->rcode("SERVFAIL"); + +Gets or sets the query response code (the status of the query). + +=cut + +sub rcode { + my $self = shift; + for ( $$self->{status} ) { + my $arg = shift; + my $opt = $$self->edns; + unless ( defined $arg ) { + my $rcode = $opt->rcode; + return rcodebyval( $_ & 0x0f ) unless $opt->_specified; + $rcode = ( $rcode & 0xff0 ) | ( $_ & 0x00f ); + $opt->rcode($rcode); # write back full 12-bit rcode + return $rcode == 16 ? 'BADVERS' : rcodebyval($rcode); + } + my $rcode = rcodebyname($arg); + $opt->rcode($rcode); # full 12-bit rcode + $_ &= 0xfff0; # low 4-bit rcode + $_ |= ( $rcode & 0x000f ); + return $rcode; + } +} + + +=head2 qr + + print "query response flag = ", $packet->header->qr, "\n"; + $packet->header->qr(0); + +Gets or sets the query response flag. + +=cut + +sub qr { + shift->_dnsflag( 0x8000, @_ ); +} + + +=head2 aa + + print "answer is ", $packet->header->aa ? "" : "non-", "authoritative\n"; + $packet->header->aa(0); + +Gets or sets the authoritative answer flag. + +=cut + +sub aa { + shift->_dnsflag( 0x0400, @_ ); +} + + +=head2 tc + + print "packet is ", $packet->header->tc ? "" : "not ", "truncated\n"; + $packet->header->tc(0); + +Gets or sets the truncated packet flag. + +=cut + +sub tc { + shift->_dnsflag( 0x0200, @_ ); +} + + +=head2 rd + + print "recursion was ", $packet->header->rd ? "" : "not ", "desired\n"; + $packet->header->rd(0); + +Gets or sets the recursion desired flag. + +=cut + +sub rd { + shift->_dnsflag( 0x0100, @_ ); +} + + +=head2 ra + + print "recursion is ", $packet->header->ra ? "" : "not ", "available\n"; + $packet->header->ra(0); + +Gets or sets the recursion available flag. + +=cut + +sub ra { + shift->_dnsflag( 0x0080, @_ ); +} + + +=head2 z + +Unassigned bit, should always be zero. + +=cut + +sub z { + shift->_dnsflag( 0x0040, @_ ); +} + + +=head2 ad + + print "The result has ", $packet->header->ad ? "" : "not", "been verified\n"; + +Relevant in DNSSEC context. + +(The AD bit is only set on answers where signatures have been +cryptographically verified or the server is authoritative for the data +and is allowed to set the bit by policy.) + +=cut + +sub ad { + shift->_dnsflag( 0x0020, @_ ); +} + + +=head2 cd + + print "checking was ", $packet->header->cd ? "not" : "", "desired\n"; + $packet->header->cd(0); + +Gets or sets the checking disabled flag. + +=cut + +sub cd { + shift->_dnsflag( 0x0010, @_ ); +} + + +=head2 qdcount, zocount + + print "# of question records: ", $packet->header->qdcount, "\n"; + +Returns the number of records in the question section of the packet. +In dynamic update packets, this field is known as C and refers +to the number of RRs in the zone section. + +=cut + +our $warned; + +sub qdcount { + my $self = shift; + return $$self->{count}[0] || scalar @{$$self->{question}} unless scalar @_; + carp 'header->qdcount attribute is read-only' unless $warned++; +} + + +=head2 ancount, prcount + + print "# of answer records: ", $packet->header->ancount, "\n"; + +Returns the number of records in the answer section of the packet +which may, in the case of corrupt packets, differ from the actual +number of records. +In dynamic update packets, this field is known as C and refers +to the number of RRs in the prerequisite section. + +=cut + +sub ancount { + my $self = shift; + return $$self->{count}[1] || scalar @{$$self->{answer}} unless scalar @_; + carp 'header->ancount attribute is read-only' unless $warned++; +} + + +=head2 nscount, upcount + + print "# of authority records: ", $packet->header->nscount, "\n"; + +Returns the number of records in the authority section of the packet +which may, in the case of corrupt packets, differ from the actual +number of records. +In dynamic update packets, this field is known as C and refers +to the number of RRs in the update section. + +=cut + +sub nscount { + my $self = shift; + return $$self->{count}[2] || scalar @{$$self->{authority}} unless scalar @_; + carp 'header->nscount attribute is read-only' unless $warned++; +} + + +=head2 arcount, adcount + + print "# of additional records: ", $packet->header->arcount, "\n"; + +Returns the number of records in the additional section of the packet +which may, in the case of corrupt packets, differ from the actual +number of records. +In dynamic update packets, this field is known as C. + +=cut + +sub arcount { + my $self = shift; + return $$self->{count}[3] || scalar @{$$self->{additional}} unless scalar @_; + carp 'header->arcount attribute is read-only' unless $warned++; +} + +sub zocount { &qdcount; } +sub prcount { &ancount; } +sub upcount { &nscount; } +sub adcount { &arcount; } + + +=head1 EDNS Protocol Extensions + + +=head2 do + + print "DNSSEC_OK flag was ", $packet->header->do ? "not" : "", "set\n"; + $packet->header->do(1); + +Gets or sets the EDNS DNSSEC OK flag. + +=cut + +sub do { + shift->_ednsflag( 0x8000, @_ ); +} + + +=head2 Extended rcode + +EDNS extended rcodes are handled transparently by $packet->header->rcode(). + + +=head2 UDP packet size + + $udp_max = $packet->header->size; + $udp_max = $packet->edns->size; + +EDNS offers a mechanism to advertise the maximum UDP packet size +which can be assembled by the local network stack. + +UDP size advertisement can be viewed as either a header extension or +an EDNS feature. Endless debate is avoided by supporting both views. + +=cut + +sub size { + my $self = shift; + return $$self->edns->size(@_); +} + + +=head2 edns + + $header = $packet->header; + $version = $header->edns->version; + @options = $header->edns->options; + $option = $header->edns->option(n); + $udp_max = $packet->edns->size; + +Auxiliary function which provides access to the EDNS protocol +extension OPT RR. + +=cut + +sub edns { + my $self = shift; + return $$self->edns; +} + + +######################################## + +sub _dnsflag { + my $self = shift; + my $flag = shift; + for ( $$self->{status} ) { + my $set = $_ | $flag; + my $not = $set - $flag; + $_ = (shift) ? $set : $not if scalar @_; + return ( $_ & $flag ) ? 1 : 0; + } +} + + +sub _ednsflag { + my $self = shift; + my $flag = shift; + my $edns = $$self->edns->flags || 0; + return $flag & $edns ? 1 : 0 unless scalar @_; + my $set = $flag | $edns; + my $not = $set - $flag; + my $new = (shift) ? $set : $not; + $$self->edns->flags($new) unless $new == $edns; + return ( $new & $flag ) ? 1 : 0; +} + + +1; +__END__ + + +######################################## + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2002,2003 Chris Reinhardt. + +Portions Copyright (c)2012 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L +RFC 1035 Section 4.1.1 + +=cut + diff --git a/lib/Net/DNS/Mailbox.pm b/lib/Net/DNS/Mailbox.pm new file mode 100644 index 0000000..785bbe7 --- /dev/null +++ b/lib/Net/DNS/Mailbox.pm @@ -0,0 +1,158 @@ +package Net::DNS::Mailbox; + +# +# $Id: Mailbox.pm 1605 2017-11-27 11:37:40Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1605 $)[1]; + + +=head1 NAME + +Net::DNS::Mailbox - DNS mailbox representation + +=head1 SYNOPSIS + + use Net::DNS::Mailbox; + + $mailbox = new Net::DNS::Mailbox('user@example.com'); + $address = $mailbox->address; + +=head1 DESCRIPTION + +The Net::DNS::Mailbox module implements a subclass of DNS domain name +objects representing the DNS coded form of RFC822 mailbox address. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use base qw(Net::DNS::DomainName); + + +=head1 METHODS + +=head2 new + + $mailbox = new Net::DNS::Mailbox('John Doe '); + $mailbox = new Net::DNS::Mailbox('john.doe@example.com'); + $mailbox = new Net::DNS::Mailbox('john\.doe.example.com'); + +Creates a mailbox object representing the RFC822 mail address specified by +the character string argument. An encoded domain name is also accepted for +backward compatibility with Net::DNS 0.68 and earlier. + +The argument string consists of printable characters from the 7-bit +ASCII repertoire. + +=cut + +sub new { + my $class = shift; + local $_ = shift; + croak 'undefined mail address' unless defined $_; + + s/^.*.*$//g; # strip excess on right + + s/\\\@/\\064/g; # disguise escaped @ + s/("[^"]*)\@([^"]*")/$1\\064$2/g; # disguise quoted @ + + my ( $mbox, @host ) = split /\@/; # split on @ if present + for ( $mbox ||= '' ) { + s/^.*"(.*)".*$/$1/; # strip quotes + s/\\\./\\046/g; # disguise escaped dot + s/\./\\046/g if @host; # escape dots in local part + } + + bless __PACKAGE__->SUPER::new( join '.', $mbox, @host ), $class; +} + + +=head2 address + + $address = $mailbox->address; + +Returns a character string containing the RFC822 mailbox address +corresponding to the encoded domain name representation described +in RFC1035 section 8. + +=cut + +sub address { + return unless defined wantarray; + my @label = shift->label; + local $_ = shift(@label) || return '<>'; + s/\\\\//g; # delete escaped \ + s/\\\d\d\d//g; # delete non-printable + s/\\\./\./g; # unescape dots + s/[\\"]//g; # delete \ " + s/^(.*)$/"$1"/ if /["(),:;<>@\[\\\]]/; # quote local part + return $_ unless scalar(@label); + join '@', $_, join '.', @label; +} + + +######################################## + +=head1 DOMAIN NAME COMPRESSION AND CANONICALISATION + +The Net::DNS::Mailbox1035 and Net::DNS::Mailbox2535 subclass +packages implement RFC1035 domain name compression and RFC2535 +canonicalisation. + +=cut + +package Net::DNS::Mailbox1035; +our @ISA = qw(Net::DNS::Mailbox); + +sub encode { &Net::DNS::DomainName1035::encode; } + + +package Net::DNS::Mailbox2535; +our @ISA = qw(Net::DNS::Mailbox); + +sub encode { &Net::DNS::DomainName2535::encode; } + + +1; +__END__ + + +######################################## + +=head1 COPYRIGHT + +Copyright (c)2009,2012 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035, RFC5322 (RFC822) + +=cut + diff --git a/lib/Net/DNS/Nameserver.pm b/lib/Net/DNS/Nameserver.pm new file mode 100644 index 0000000..af04c04 --- /dev/null +++ b/lib/Net/DNS/Nameserver.pm @@ -0,0 +1,869 @@ +package Net::DNS::Nameserver; + +# +# $Id: Nameserver.pm 1608 2017-12-07 10:10:38Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1608 $)[1]; + + +=head1 NAME + +Net::DNS::Nameserver - DNS server class + +=head1 SYNOPSIS + + use Net::DNS::Nameserver; + + my $nameserver = new Net::DNS::Nameserver( + LocalAddr => ['::1' , '127.0.0.1'], + ZoneFile => "filename" + ); + + my $nameserver = new Net::DNS::Nameserver( + LocalAddr => '10.1.2.3', + LocalPort => 5353, + ReplyHandler => \&reply_handler + ); + + +=head1 DESCRIPTION + +Net::DNS::Nameserver offers a simple mechanism for instantiation of +customised DNS server objects intended to provide test responses to +queries emanating from a client resolver. + +It is not, nor will it ever be, a general-purpose DNS nameserver +implementation. + +See L for an example. + +=cut + +use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.32; 1;'; + +use constant USE_SOCKET_INET => defined eval 'require IO::Socket::INET'; + +use constant USE_SOCKET_INET6 => defined eval 'require IO::Socket::INET6'; + +use constant IPv6 => USE_SOCKET_IP || USE_SOCKET_INET6; + + +use strict; +use warnings; +use integer; +use Carp; +use Net::DNS; +use Net::DNS::ZoneFile; + +use IO::Socket; +use IO::Select; + +use constant FORCE_IPv4 => 0; + +use constant DEFAULT_ADDR => qw(::1 127.0.0.1); +use constant DEFAULT_PORT => 53; + +use constant STATE_ACCEPTED => 1; +use constant STATE_GOT_LENGTH => 2; +use constant STATE_SENDING => 3; + +use constant PACKETSZ => 512; + + +#------------------------------------------------------------------------------ +# Constructor. +#------------------------------------------------------------------------------ + +sub new { + my ( $class, %self ) = @_; + my $self = bless \%self, $class; + if ( !exists $self{ReplyHandler} ) { + if ( my $handler = UNIVERSAL::can( $class, "ReplyHandler" ) ) { + $self{ReplyHandler} = sub { $handler->( $self, @_ ); }; + } + } + croak 'No reply handler!' unless ref( $self{ReplyHandler} ) eq "CODE"; + + $self->ReadZoneFile( $self{ZoneFile} ) if exists $self{ZoneFile}; + + # local server addresses must also be accepted by a resolver + my $LocalAddr = $self{LocalAddr} || [DEFAULT_ADDR]; + my $resolver = new Net::DNS::Resolver( nameservers => $LocalAddr ); + $resolver->force_v4(1) if FORCE_IPv4; + my @localaddresses = $resolver->nameservers; + + my $port = $self{LocalPort} || DEFAULT_PORT; + $self{Truncate} = 1 unless defined( $self{Truncate} ); + $self{IdleTimeout} = 120 unless defined( $self{IdleTimeout} ); + + my @sock_tcp; # All the TCP sockets we will listen to. + my @sock_udp; # All the UDP sockets we will listen to. + + # while we are here, print incomplete lines as they come along. + local $| = 1 if $self{Verbose}; + + foreach my $addr (@localaddresses) { + + #-------------------------------------------------------------------------- + # Create the TCP socket. + #-------------------------------------------------------------------------- + + print "\nCreating TCP socket $addr#$port - " if $self{Verbose}; + + my $sock_tcp = inet_new( + LocalAddr => $addr, + LocalPort => $port, + Listen => 64, + Proto => "tcp", + Reuse => 1, + Blocking => 0, + ); + if ($sock_tcp) { + push @sock_tcp, $sock_tcp; + print "done.\n" if $self{Verbose}; + } else { + carp "Couldn't create TCP socket: $!"; + } + + #-------------------------------------------------------------------------- + # Create the UDP Socket. + #-------------------------------------------------------------------------- + + print "Creating UDP socket $addr#$port - " if $self{Verbose}; + + my $sock_udp = inet_new( + LocalAddr => $addr, + LocalPort => $port, + Proto => "udp", + ); + + if ($sock_udp) { + push @sock_udp, $sock_udp; + print "done.\n" if $self{Verbose}; + } else { + carp "Couldn't create UDP socket: $!"; + } + + } + + #-------------------------------------------------------------------------- + # Create the Select object. + #-------------------------------------------------------------------------- + + my $select = $self{select} = new IO::Select; + + $select->add(@sock_tcp); + $select->add(@sock_udp); + + return undef unless $select->count; + + #-------------------------------------------------------------------------- + # Return the object. + #-------------------------------------------------------------------------- + + return $self; +} + + +#------------------------------------------------------------------------------ +# ReadZoneFile - Read zone file used by default reply handler +#------------------------------------------------------------------------------ + +sub ReadZoneFile { + my ( $self, $file ) = @_; + my $zonefile = new Net::DNS::ZoneFile($file); + + my $RRhash = $self->{RRhash} = {}; + my $RRlist = []; + while ( my $rr = $zonefile->read ) { + my ($leaf) = $rr->{owner}->label; + push @{$RRhash->{lc $leaf}}, $rr; + + # Warning: Nasty trick abusing SOA to reference zone RR list + if ( $rr->type eq 'SOA' ) { $RRlist = $rr->{RRlist} = [] } + else { push @$RRlist, $rr } + } +} + + +#------------------------------------------------------------------------------ +# ReplyHandler - Default reply handler serving RRs from zone file +#------------------------------------------------------------------------------ + +sub ReplyHandler { + my ( $self, $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; + my $opcode = $query->header->opcode; + my $rcode = 'NOERROR'; + my @ans; + + my $lcase = lc $qname; # assume $qclass always 'IN' + my ( $leaf, @tail ) = split /\./, $lcase; + my $RRhash = $self->{RRhash}; + my $RRlist = $RRhash->{$leaf} || []; # hash, then linear search + my @match = grep lc( $_->owner ) eq $lcase, @$RRlist; + + if ( $qtype eq 'AXFR' ) { + my ($soa) = grep $_->type eq 'SOA', @match; + if ($soa) { push @ans, $soa, @{$soa->{RRlist}}, $soa } + else { $rcode = 'NOTAUTH' } + + } else { + unless ( scalar(@match) ) { + my $wildcard = join '.', '*', @tail; + my $wildlist = $RRhash->{'*'} || []; + foreach ( grep lc( $_->owner ) eq $wildcard, @$wildlist ) { + my $clone = bless {%$_}, ref($_); + $clone->owner($qname); + push @match, $clone; + } + $rcode = 'NXDOMAIN' unless @match; + } + @ans = grep $_->type eq $qtype, @match; + } + + return ( $rcode, \@ans, [], [], {aa => 1}, {} ); +} + + +#------------------------------------------------------------------------------ +# inet_new - Calls the constructor in the correct module for making sockets. +#------------------------------------------------------------------------------ + +sub inet_new { + return new IO::Socket::INET(@_) unless IPv6; + + return new IO::Socket::IP(@_) if USE_SOCKET_IP; + + my %param = @_; + + return new IO::Socket::INET6(@_) if $param{LocalAddr} =~ /:/; + return new IO::Socket::INET(@_); +} + +#------------------------------------------------------------------------------ +# make_reply - Make a reply packet. +#------------------------------------------------------------------------------ + +sub make_reply { + my ( $self, $query, $peerhost, $conn ) = @_; + + unless ($query) { + print "ERROR: invalid packet\n" if $self->{Verbose}; + my $empty = new Net::DNS::Packet(); # create empty reply packet + my $reply = $empty->reply(); + $reply->header->rcode("FORMERR"); + return $reply; + } + + if ( $query->header->qr() ) { + print "ERROR: invalid packet (qr set), dropping\n" if $self->{Verbose}; + return; + } + + my $reply = $query->reply(); + my $header = $reply->header; + my $headermask; + my $optionmask; + + my $opcode = $query->header->opcode; + my $qdcount = $query->header->qdcount; + + unless ($qdcount) { + $header->rcode("NOERROR"); + + } elsif ( $qdcount > 1 ) { + print "ERROR: qdcount $qdcount unsupported\n" if $self->{Verbose}; + $header->rcode("FORMERR"); + + } else { + my ($qr) = $query->question; + my $qname = $qr->qname; + my $qtype = $qr->qtype; + my $qclass = $qr->qclass; + + my $id = $query->header->id; + print "query $id : $qname $qclass $qtype\n" if $self->{Verbose}; + + my ( $rcode, $ans, $auth, $add ); + my @arglist = ( $qname, $qclass, $qtype, $peerhost, $query, $conn ); + + if ( $opcode eq "QUERY" ) { + ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = + &{$self->{ReplyHandler}}(@arglist); + + } elsif ( $opcode eq "NOTIFY" ) { #RFC1996 + if ( ref $self->{NotifyHandler} eq "CODE" ) { + ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = + &{$self->{NotifyHandler}}(@arglist); + } else { + $rcode = "NOTIMP"; + } + + } elsif ( $opcode eq "UPDATE" ) { #RFC2136 + if ( ref $self->{UpdateHandler} eq "CODE" ) { + ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = + &{$self->{UpdateHandler}}(@arglist); + } else { + $rcode = "NOTIMP"; + } + + } else { + print "ERROR: opcode $opcode unsupported\n" if $self->{Verbose}; + $rcode = "FORMERR"; + } + + if ( !defined($rcode) ) { + print "remaining silent\n" if $self->{Verbose}; + return undef; + } + + $header->rcode($rcode); + + $reply->{answer} = [@$ans] if $ans; + $reply->{authority} = [@$auth] if $auth; + $reply->{additional} = [@$add] if $add; + } + + while ( my ( $key, $value ) = each %{$headermask || {}} ) { + $header->$key($value); + } + + while ( my ( $option, $value ) = each %{$optionmask || {}} ) { + $reply->edns->option( $option, $value ); + } + + $header->print if $self->{Verbose} && ( $headermask || $optionmask ); + + return $reply; +} + + +#------------------------------------------------------------------------------ +# readfromtcp - read from a TCP client +#------------------------------------------------------------------------------ + +sub readfromtcp { + my ( $self, $sock ) = @_; + return -1 unless defined $self->{_tcp}{$sock}; + my $peer = $self->{_tcp}{$sock}{peer}; + my $buf; + my $charsread = $sock->sysread( $buf, 16384 ); + $self->{_tcp}{$sock}{inbuffer} .= $buf; + $self->{_tcp}{$sock}{timeout} = time() + $self->{IdleTimeout}; # Reset idle timer + print "Received $charsread octets from $peer\n" if $self->{Verbose}; + + if ( $charsread == 0 ) { # 0 octets means socket has closed + print "Connection to $peer closed or lost.\n" if $self->{Verbose}; + $self->{select}->remove($sock); + $sock->close(); + delete $self->{_tcp}{$sock}; + return $charsread; + } + return $charsread; +} + +#------------------------------------------------------------------------------ +# tcp_connection - Handle a TCP connection. +#------------------------------------------------------------------------------ + +sub tcp_connection { + my ( $self, $sock ) = @_; + + if ( not $self->{_tcp}{$sock} ) { + + # We go here if we are called with a listener socket. + my $client = $sock->accept; + if ( not defined $client ) { + print "TCP connection closed by peer before we could accept it.\n" if $self->{Verbose}; + return 0; + } + my $peerport = $client->peerport; + my $peerhost = $client->peerhost; + + print "TCP connection from $peerhost:$peerport\n" if $self->{Verbose}; + $client->blocking(0); + $self->{_tcp}{$client}{peer} = "tcp:" . $peerhost . ":" . $peerport; + $self->{_tcp}{$client}{state} = STATE_ACCEPTED; + $self->{_tcp}{$client}{socket} = $client; + $self->{_tcp}{$client}{timeout} = time() + $self->{IdleTimeout}; + $self->{select}->add($client); + + # After we accepted we will look at the socket again + # to see if there is any data there. ---Olaf + $self->loop_once(0); + } else { + + # We go here if we are called with a client socket + my $peer = $self->{_tcp}{$sock}{peer}; + + if ( $self->{_tcp}{$sock}{state} == STATE_ACCEPTED ) { + if ( not $self->{_tcp}{$sock}{inbuffer} =~ s/^(..)//s ) { + return; # Still not 2 octets ready + } + my $msglen = unpack( "n", $1 ); + print "$peer said his query contains $msglen octets\n" if $self->{Verbose}; + $self->{_tcp}{$sock}{state} = STATE_GOT_LENGTH; + $self->{_tcp}{$sock}{querylength} = $msglen; + } + + # Not elsif, because we might already have all the data + if ( $self->{_tcp}{$sock}{state} == STATE_GOT_LENGTH ) { + + # return if not all data has been received yet. + return if $self->{_tcp}{$sock}{querylength} > length $self->{_tcp}{$sock}{inbuffer}; + + my $qbuf = substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ); + substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ) = ""; + my $query = new Net::DNS::Packet( \$qbuf ); + if ( my $err = $@ ) { + print "Error decoding query packet: $err\n" if $self->{Verbose}; + undef $query; # force FORMERR reply + } + my $conn = { + sockhost => $sock->sockhost, + sockport => $sock->sockport, + peerhost => $sock->peerhost, + peerport => $sock->peerport + }; + my $reply = $self->make_reply( $query, $sock->peerhost, $conn ); + if ( not defined $reply ) { + print "I couldn't create a reply for $peer. Closing socket.\n" + if $self->{Verbose}; + $self->{select}->remove($sock); + $sock->close(); + delete $self->{_tcp}{$sock}; + return; + } + my $reply_data = $reply->data(65535); # limit to one TCP envelope + warn "multi-packet TCP response not implemented" if $reply->header->tc; + my $len = length $reply_data; + $self->{_tcp}{$sock}{outbuffer} = pack( 'n a*', $len, $reply_data ); + print "Queued TCP response (2 + $len octets) to $peer\n" + if $self->{Verbose}; + + # We are done. + $self->{_tcp}{$sock}{state} = STATE_SENDING; + } + } +} + +#------------------------------------------------------------------------------ +# udp_connection - Handle a UDP connection. +#------------------------------------------------------------------------------ + +sub udp_connection { + my ( $self, $sock ) = @_; + + my $buf = ""; + + $sock->recv( $buf, PACKETSZ ); + my ( $peerhost, $peerport, $sockhost ) = ( $sock->peerhost, $sock->peerport, $sock->sockhost ); + unless ( defined $peerhost && defined $peerport ) { + print "the Peer host and sock host appear to be undefined: bailing out of handling the UDP connection" + if $self->{Verbose}; + return; + } + + + print "UDP connection from $peerhost:$peerport to $sockhost\n" if $self->{Verbose}; + + my $query = new Net::DNS::Packet( \$buf ); + if ( my $err = $@ ) { + print "Error decoding query packet: $err\n" if $self->{Verbose}; + undef $query; # force FORMERR reply + } + my $conn = { + sockhost => $sock->sockhost, + sockport => $sock->sockport, + peerhost => $sock->peerhost, + peerport => $sock->peerport + }; + my $reply = $self->make_reply( $query, $peerhost, $conn ) || return; + + my $max_len = ( $query && $self->{Truncate} ) ? $query->edns->size : undef; + if ( $self->{Verbose} ) { + local $| = 1; + print "Maximum UDP size advertised by $peerhost#$peerport: $max_len\n" if $max_len; + print "Writing response - "; + print $sock->send( $reply->data($max_len) ) ? "done" : "failed: $!", "\n"; + + } else { + $sock->send( $reply->data($max_len) ); + } +} + + +sub get_open_tcp { + my $self = shift; + return keys %{$self->{_tcp}}; +} + + +#------------------------------------------------------------------------------ +# loop_once - Just check "once" on sockets already set up +#------------------------------------------------------------------------------ + +# This function might not actually return immediately. If an AXFR request is +# coming in which will generate a huge reply, we will not relinquish control +# until our outbuffers are empty. + +# +# NB this method may be subject to change and is therefore left 'undocumented' +# + +sub loop_once { + my ( $self, $timeout ) = @_; + + print ";loop_once called with timeout: " . ( defined($timeout) ? $timeout : "undefined" ) . "\n" + if $self->{Verbose} && $self->{Verbose} > 4; + foreach my $sock ( keys %{$self->{_tcp}} ) { + + # There is TCP traffic to handle + $timeout = 0.1 if $self->{_tcp}{$sock}{outbuffer}; + } + my @ready = $self->{select}->can_read($timeout); + + foreach my $sock (@ready) { + my $protonum = $sock->protocol; + + # This is a weird and nasty hack. Although not incorrect, + # I just don't know why ->protocol won't tell me the protocol + # on a connected socket. --robert + $protonum = getprotobyname('tcp') if not defined $protonum and $self->{_tcp}{$sock}; + + my $proto = getprotobynumber($protonum); + if ( !$proto ) { + print "ERROR: connection with unknown protocol\n" + if $self->{Verbose}; + } elsif ( lc($proto) eq "tcp" ) { + + $self->readfromtcp($sock) + && $self->tcp_connection($sock); + } elsif ( lc($proto) eq "udp" ) { + $self->udp_connection($sock); + } else { + print "ERROR: connection with unsupported protocol $proto\n" + if $self->{Verbose}; + } + } + my $now = time(); + + # Lets check if any of our TCP clients has pending actions. + # (outbuffer, timeout) + foreach my $s ( keys %{$self->{_tcp}} ) { + my $sock = $self->{_tcp}{$s}{socket}; + if ( $self->{_tcp}{$s}{outbuffer} ) { + + # If we have buffered output, then send as much as the OS will accept + # and wait with the rest + my $len = length $self->{_tcp}{$s}{outbuffer}; + my $charssent = $sock->syswrite( $self->{_tcp}{$s}{outbuffer} ) || 0; + print "Sent $charssent of $len octets to ", $self->{_tcp}{$s}{peer}, ".\n" + if $self->{Verbose}; + substr( $self->{_tcp}{$s}{outbuffer}, 0, $charssent ) = ""; + if ( length $self->{_tcp}{$s}{outbuffer} == 0 ) { + delete $self->{_tcp}{$s}{outbuffer}; + $self->{_tcp}{$s}{state} = STATE_ACCEPTED; + if ( length $self->{_tcp}{$s}{inbuffer} >= 2 ) { + + # See if the client has send us enough data to process the + # next query. + # We do this here, because we only want to process (and buffer!!) + # a single query at a time, per client. If we allowed a STATE_SENDING + # client to have new requests processed. We could be easilier + # victims of DoS (client sending lots of queries and never reading + # from it's socket). + # Note that this does not disable serialisation on part of the + # client. The split second it should take for us to lookup the + # next query, is likely faster than the time it takes to + # send the response... well, unless it's a lot of tiny queries, + # in which case we will be generating an entire TCP packet per + # reply. --robert + $self->tcp_connection( $self->{_tcp}{$s}{socket} ); + } + } + $self->{_tcp}{$s}{timeout} = time() + $self->{IdleTimeout}; + } else { + + # Get rid of idle clients. + my $timeout = $self->{_tcp}{$s}{timeout}; + if ( $timeout - $now < 0 ) { + print $self->{_tcp}{$s}{peer}, " has been idle for too long and will be disconnected.\n" + if $self->{Verbose}; + $self->{select}->remove($sock); + $sock->close(); + delete $self->{_tcp}{$s}; + } + } + } +} + +#------------------------------------------------------------------------------ +# main_loop - Main nameserver loop. +#------------------------------------------------------------------------------ + +sub main_loop { + my $self = shift; + + while (1) { + print "Waiting for connections...\n" if $self->{Verbose}; + + # You really need an argument otherwise you'll be burning CPU. + $self->loop_once(10); + } +} + + +1; +__END__ + + +=head1 METHODS + +=head2 new + + $nameserver = new Net::DNS::Nameserver( + LocalAddr => ['::1' , '127.0.0.1'], + ZoneFile => "filename" + ); + + $nameserver = new Net::DNS::Nameserver( + LocalAddr => '10.1.2.3', + LocalPort => 5353, + ReplyHandler => \&reply_handler, + Verbose => 1, + Truncate => 0 + ); + +Returns a Net::DNS::Nameserver object, or undef if the object +could not be created. + +Each instance is configured using the following optional arguments: + + LocalAddr IP address on which to listen Defaults to loopback address + LocalPort Port on which to listen Defaults to 53 + ZoneFile Name of file containing RRs + accessed using the default + reply-handling subroutine + ReplyHandler Reference to customised + reply-handling subroutine + NotifyHandler Reference to reply-handling + subroutine for queries with + opcode NOTIFY (RFC1996) + UpdateHandler Reference to reply-handling + subroutine for queries with + opcode UPDATE (RFC2136) + Verbose Report internal activity Defaults to 0 (off) + Truncate Truncates UDP packets that + are too big for the reply Defaults to 1 (on) + IdleTimeout TCP clients are disconnected + if they are idle longer than + this duration Defaults to 120 (secs) + +The LocalAddr attribute may alternatively be specified as a list of IP +addresses to listen to. +If the IO::Socket::IP library package is available on the system +this may also include IPv6 addresses. + + +The ReplyHandler subroutine is passed the query name, query class, +query type and optionally an argument containing the peerhost, the +incoming query, and the name of the incoming socket (sockethost). It +must either return the response code and references to the answer, +authority, and additional sections of the response, or undef to leave +the query unanswered. Common response codes are: + + NOERROR No error + FORMERR Format error + SERVFAIL Server failure + NXDOMAIN Non-existent domain (name doesn't exist) + NOTIMP Not implemented + REFUSED Query refused + +For advanced usage it may also contain a headermask containing an +hashref with the settings for the C, C, and C +header bits. The argument is of the form +C<< { ad => 1, aa => 0, ra => 1 } >>. + +EDNS options may be specified in a similar manner using optionmask +C<< { $optioncode => $value, $optionname => $value } >>. + + +See RFC 1035 and the IANA dns-parameters file for more information: + + ftp://ftp.rfc-editor.org/in-notes/rfc1035.txt + http://www.isi.edu/in-notes/iana/assignments/dns-parameters + +The nameserver will listen for both UDP and TCP connections. On +Unix-like systems, the program will probably have to run as root +to listen on the default port, 53. A non-privileged user should +be able to listen on ports 1024 and higher. + +UDP reply truncation functionality was introduced in VERSION 830. +The size limit is determined by the EDNS0 size advertised in the query, +otherwise 512 is used. +If you want to do packet truncation yourself you should set C +to 0 and truncate the reply packet in the code of the ReplyHandler. + +See L for an example. + +=head2 main_loop + + $ns->main_loop; + +Start accepting queries. Calling main_loop never returns. + + +=head2 loop_once + + $ns->loop_once( [TIMEOUT_IN_SECONDS] ); + +Start accepting queries, but returns. If called without a parameter, the +call will not return until a request has been received (and replied to). +Otherwise, the parameter specifies the maximum time to wait for a request. +A zero timeout forces an immediate return if there is nothing to do. + +Handling a request and replying obviously depends on the speed of +ReplyHandler. Assuming a fast ReplyHandler, loop_once should spend just a +fraction of a second, if called with a timeout value of 0.0 seconds. One +exception is when an AXFR has requested a huge amount of data that the OS +is not ready to receive in full. In that case, it will remain in a loop +(while servicing new requests) until the reply has been sent. + +In case loop_once accepted a TCP connection it will immediately check if +there is data to be read from the socket. If not it will return and you +will have to call loop_once() again to check if there is any data waiting +on the socket to be processed. In most cases you will have to count on +calling "loop_once" twice. + +A code fragment like: + + $ns->loop_once(10); + while( $ns->get_open_tcp() ){ + $ns->loop_once(0); + } + +Would wait for 10 seconds for the initial connection and would then +process all TCP sockets until none is left. + + +=head2 get_open_tcp + +In scalar context returns the number of TCP connections for which state +is maintained. In array context it returns IO::Socket objects, these could +be useful for troubleshooting but be careful using them. + + +=head1 EXAMPLE + +The following example will listen on port 5353 and respond to all queries +for A records with the IP address 10.1.2.3. All other queries will be +answered with NXDOMAIN. Authority and additional sections are left empty. +The $peerhost variable catches the IP address of the peer host, so that +additional filtering on its basis may be applied. + + #!/usr/bin/perl + + use strict; + use warnings; + use Net::DNS::Nameserver; + + sub reply_handler { + my ( $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; + my ( $rcode, @ans, @auth, @add ); + + print "Received query from $peerhost to " . $conn->{sockhost} . "\n"; + $query->print; + + if ( $qtype eq "A" && $qname eq "foo.example.com" ) { + my ( $ttl, $rdata ) = ( 3600, "10.1.2.3" ); + my $rr = new Net::DNS::RR("$qname $ttl $qclass $qtype $rdata"); + push @ans, $rr; + $rcode = "NOERROR"; + } elsif ( $qname eq "foo.example.com" ) { + $rcode = "NOERROR"; + + } else { + $rcode = "NXDOMAIN"; + } + + # mark the answer as authoritative (by setting the 'aa' flag) + my $headermask = {aa => 1}; + + # specify EDNS options { option => value } + my $optionmask = {}; + + return ( $rcode, \@ans, \@auth, \@add, $headermask, $optionmask ); + } + + + my $ns = new Net::DNS::Nameserver( + LocalPort => 5353, + ReplyHandler => \&reply_handler, + Verbose => 1 + ) || die "couldn't create nameserver object\n"; + + + $ns->main_loop; + + +=head1 BUGS + +Limitations in perl 5.8.6 makes it impossible to guarantee that +replies to UDP queries from Net::DNS::Nameserver are sent from the +IP-address they were received on. This is a problem for machines with +multiple IP-addresses and causes violation of RFC2181 section 4. +Thus a UDP socket created listening to INADDR_ANY (all available +IP-addresses) will reply not necessarily with the source address being +the one to which the request was sent, but rather with the address that +the operating system chooses. This is also often called "the closest +address". This should really only be a problem on a server which has +more than one IP-address (besides localhost - any experience with IPv6 +complications here, would be nice). If this is a problem for you, a +work-around would be to not listen to INADDR_ANY but to specify each +address that you want this module to listen on. A separate set of +sockets will then be created for each IP-address. + + +=head1 COPYRIGHT + +Copyright (c)2000 Michael Fuhr. + +Portions Copyright (c)2002-2004 Chris Reinhardt. + +Portions Copyright (c)2005 Robert Martin-Legene. + +Portions Copyright (c)2005-2009 O.M, Kolkman, RIPE NCC. + +Portions Copyright (c)2017 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, +L, L, L, +L, RFC 1035 + +=cut + diff --git a/lib/Net/DNS/Packet.pm b/lib/Net/DNS/Packet.pm new file mode 100644 index 0000000..c9a0114 --- /dev/null +++ b/lib/Net/DNS/Packet.pm @@ -0,0 +1,869 @@ +package Net::DNS::Packet; + +# +# $Id: Packet.pm 1584 2017-07-28 16:15:17Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1584 $)[1]; + + +=head1 NAME + +Net::DNS::Packet - DNS protocol packet + +=head1 SYNOPSIS + + use Net::DNS::Packet; + + $query = new Net::DNS::Packet( 'example.com', 'MX', 'IN' ); + + $reply = $resolver->send( $query ); + + +=head1 DESCRIPTION + +A Net::DNS::Packet object represents a DNS protocol packet. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use constant UDPSZ => 512; + +BEGIN { + require Net::DNS::Header; + require Net::DNS::Question; + require Net::DNS::RR; +} + + +=head1 METHODS + +=head2 new + + $packet = new Net::DNS::Packet( 'example.com' ); + $packet = new Net::DNS::Packet( 'example.com', 'MX', 'IN' ); + + $packet = new Net::DNS::Packet(); + +If passed a domain, type, and class, new() creates a Net::DNS::Packet +object which is suitable for making a DNS query for the specified +information. The type and class may be omitted; they default to A +and IN. + +If called with an empty argument list, new() creates an empty packet. + +=cut + +sub new { + return &decode if ref $_[1]; + my $class = shift; + + my $self = bless { + status => 0, + question => [], + answer => [], + authority => [], + additional => [], + }, $class; + + $self->{question} = [Net::DNS::Question->new(@_)] if scalar @_; + + return $self; +} + + +#=head2 decode + +=pod + + $packet = new Net::DNS::Packet( \$data ); + $packet = new Net::DNS::Packet( \$data, 1 ); # debug + +If passed a reference to a scalar containing DNS packet data, a new +packet object is created by decoding the data. +The optional second boolean argument enables debugging output. + +Returns undef if unable to create a packet object. + +Decoding errors, including data corruption and truncation, are +collected in the $@ ($EVAL_ERROR) variable. + + + ( $packet, $length ) = new Net::DNS::Packet( \$data ); + +If called in array context, returns a packet object and the number +of octets successfully decoded. + +Note that the number of RRs in each section of the packet may differ +from the corresponding header value if the data has been truncated +or corrupted during transmission. + +=cut + +use constant HEADER_LENGTH => length pack 'n6', (0) x 6; + +sub decode { + my $class = shift; # uncoverable pod + my $data = shift; + my $debug = shift || 0; + + my $offset = 0; + my $self; + eval { + local $SIG{__DIE__}; + die 'corrupt wire-format data' if length($$data) < HEADER_LENGTH; + + # header section + my ( $id, $status, @count ) = unpack 'n6', $$data; + my ( $qd, $an, $ns, $ar ) = @count; + $offset = HEADER_LENGTH; + + $self = bless { + id => $id, + status => $status, + count => [@count], + question => [], + answer => [], + authority => [], + additional => [], + answersize => length $$data + }, $class; + + # question/zone section + my $hash = {}; + my $record; + while ( $qd-- ) { + ( $record, $offset ) = decode Net::DNS::Question( $data, $offset, $hash ); + CORE::push( @{$self->{question}}, $record ); + } + + # RR sections + while ( $an-- ) { + ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash ); + CORE::push( @{$self->{answer}}, $record ); + } + + while ( $ns-- ) { + ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash ); + CORE::push( @{$self->{authority}}, $record ); + } + + while ( $ar-- ) { + ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash ); + CORE::push( @{$self->{additional}}, $record ); + } + + return $self; + }; + + if ($debug) { + local $@ = $@; + print $@ if $@; + $self->print if $self; + } + + return wantarray ? ( $self, $offset ) : $self; +} + + +=head2 data + + $data = $packet->data; + $data = $packet->data( $size ); + +Returns the packet data in binary format, suitable for sending as a +query or update request to a nameserver. + +Truncation may be specified using a non-zero optional size argument. + +=cut + +sub data { + &encode; +} + +sub encode { + my ( $self, $size ) = @_; # uncoverable pod + + my $edns = $self->edns; # EDNS support + my @addl = grep !$_->isa('Net::DNS::RR::OPT'), @{$self->{additional}}; + $self->{additional} = [$edns, @addl] if $edns->_specified; + + return $self->truncate($size) if $size; + + my @part = qw(question answer authority additional); + my @size = map scalar( @{$self->{$_}} ), @part; + my $data = pack 'n6', $self->header->id, $self->{status}, @size; + $self->{count} = []; + + my $hash = {}; # packet body + foreach my $component ( map @{$self->{$_}}, @part ) { + $data .= $component->encode( length $data, $hash, $self ); + } + + return $data; +} + + +=head2 header + + $header = $packet->header; + +Constructor method which returns a Net::DNS::Header object which +represents the header section of the packet. + +=cut + +sub header { + my $self = shift; + bless \$self, q(Net::DNS::Header); +} + + +=head2 edns + + $edns = $packet->edns; + $version = $edns->version; + $UDPsize = $edns->size; + +Auxiliary function which provides access to the EDNS protocol +extension OPT RR. + +=cut + +sub edns { + my $self = shift; + my $link = \$self->{xedns}; + ($$link) = grep $_->isa(qw(Net::DNS::RR::OPT)), @{$self->{additional}} unless $$link; + $$link = new Net::DNS::RR( type => 'OPT' ) unless $$link; + return $$link; +} + + +=head2 reply + + $reply = $query->reply( $UDPmax ); + +Constructor method which returns a new reply packet. + +The optional UDPsize argument is the maximum UDP packet size which +can be reassembled by the local network stack, and is advertised in +response to an EDNS query. + +=cut + +sub reply { + my $query = shift; + my $UDPmax = shift; + my $qheadr = $query->header; + croak 'erroneous qr flag in query packet' if $qheadr->qr; + + my $reply = new Net::DNS::Packet(); + my $header = $reply->header; + $header->qr(1); # reply with same id, opcode and question + $header->id( $qheadr->id ); + $header->opcode( $qheadr->opcode ); + my @question = $query->question; + $reply->{question} = [@question]; + + $header->rcode('FORMERR'); # no RCODE considered sinful! + + $header->rd( $qheadr->rd ); # copy these flags into reply + $header->cd( $qheadr->cd ); + + return $reply unless grep $_->isa('Net::DNS::RR::OPT'), @{$query->{additional}}; + + my $edns = $reply->edns(); + CORE::push( @{$reply->{additional}}, $edns ); + $edns->size($UDPmax); + return $reply; +} + + +=head2 question, zone + + @question = $packet->question; + +Returns a list of Net::DNS::Question objects representing the +question section of the packet. + +In dynamic update packets, this section is known as zone() and +specifies the DNS zone to be updated. + +=cut + +sub question { + my @qr = @{shift->{question}}; +} + +sub zone {&question} + + +=head2 answer, pre, prerequisite + + @answer = $packet->answer; + +Returns a list of Net::DNS::RR objects representing the answer +section of the packet. + +In dynamic update packets, this section is known as pre() or +prerequisite() and specifies the RRs or RRsets which must or must +not preexist. + +=cut + +sub answer { + my @rr = @{shift->{answer}}; +} + +sub pre {&answer} +sub prerequisite {&answer} + + +=head2 authority, update + + @authority = $packet->authority; + +Returns a list of Net::DNS::RR objects representing the authority +section of the packet. + +In dynamic update packets, this section is known as update() and +specifies the RRs or RRsets to be added or deleted. + +=cut + +sub authority { + my @rr = @{shift->{authority}}; +} + +sub update {&authority} + + +=head2 additional + + @additional = $packet->additional; + +Returns a list of Net::DNS::RR objects representing the additional +section of the packet. + +=cut + +sub additional { + my @rr = @{shift->{additional}}; +} + + +=head2 print + + $packet->print; + +Prints the packet data on the standard output in an ASCII format +similar to that used in DNS zone files. + +=cut + +sub print { print &string; } + + +=head2 string + + print $packet->string; + +Returns a string representation of the packet. + +=cut + +sub string { + my $self = shift; + + my $header = $self->header; + my $update = $header->opcode eq 'UPDATE'; + + my $server = $self->{answerfrom}; + my $length = $self->{answersize}; + my $string = $server ? ";; Answer received from $server ($length bytes)\n" : ""; + + $string .= ";; HEADER SECTION\n" . $header->string; + + my $question = $update ? 'ZONE' : 'QUESTION'; + my @question = map $_->string, $self->question; + my $qdcount = scalar @question; + my $qds = $qdcount != 1 ? 's' : ''; + $string .= join "\n;; ", "\n;; $question SECTION ($qdcount record$qds)", @question; + + my $answer = $update ? 'PREREQUISITE' : 'ANSWER'; + my @answer = map $_->string, $self->answer; + my $ancount = scalar @answer; + my $ans = $ancount != 1 ? 's' : ''; + $string .= join "\n", "\n\n;; $answer SECTION ($ancount record$ans)", @answer; + + my $authority = $update ? 'UPDATE' : 'AUTHORITY'; + my @authority = map $_->string, $self->authority; + my $nscount = scalar @authority; + my $nss = $nscount != 1 ? 's' : ''; + $string .= join "\n", "\n\n;; $authority SECTION ($nscount record$nss)", @authority; + + my @additional = map $_->string, $self->additional; + my $arcount = scalar @additional; + my $ars = $arcount != 1 ? 's' : ''; + $string .= join "\n", "\n\n;; ADDITIONAL SECTION ($arcount record$ars)", @additional; + + return "$string\n\n"; +} + + +=head2 answerfrom + + print "packet received from ", $packet->answerfrom, "\n"; + +Returns the IP address from which this packet was received. +User-created packets will return undef for this method. + +=cut + +sub answerfrom { + my $self = shift; + + $self->{answerfrom} = shift if scalar @_; + $self->{answerfrom}; +} + + +=head2 answersize + + print "packet size: ", $packet->answersize, " bytes\n"; + +Returns the size of the packet in bytes as it was received from a +nameserver. User-created packets will return undef for this method +(use length($packet->data) instead). + +=cut + +sub answersize { + shift->{answersize}; +} + + +=head2 push + + $ancount = $packet->push( prereq => $rr ); + $nscount = $packet->push( update => $rr ); + $arcount = $packet->push( additional => $rr ); + + $nscount = $packet->push( update => $rr1, $rr2, $rr3 ); + $nscount = $packet->push( update => @rr ); + +Adds RRs to the specified section of the packet. + +Returns the number of resource records in the specified section. + +Section names may be abbreviated to the first three characters. + +=cut + +sub push { + my $self = shift; + my $list = $self->_section(shift); + CORE::push( @$list, grep ref($_), @_ ); +} + + +=head2 unique_push + + $ancount = $packet->unique_push( prereq => $rr ); + $nscount = $packet->unique_push( update => $rr ); + $arcount = $packet->unique_push( additional => $rr ); + + $nscount = $packet->unique_push( update => $rr1, $rr2, $rr3 ); + $nscount = $packet->unique_push( update => @rr ); + +Adds RRs to the specified section of the packet provided that the +RRs are not already present in the same section. + +Returns the number of resource records in the specified section. + +Section names may be abbreviated to the first three characters. + +=cut + +sub unique_push { + my $self = shift; + my $list = $self->_section(shift); + my @rr = grep ref($_), @_; + + my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } @rr, @$list; + + scalar( @$list = values %unique ); +} + + +=head2 pop + + my $rr = $packet->pop( 'pre' ); + my $rr = $packet->pop( 'update' ); + my $rr = $packet->pop( 'additional' ); + +Removes a single RR from the specified section of the packet. + +=cut + +sub pop { + my $self = shift; + my $list = $self->_section(shift); + CORE::pop(@$list); +} + + +my %_section = ( ## section name abbreviation table + 'ans' => 'answer', + 'pre' => 'answer', + 'aut' => 'authority', + 'upd' => 'authority', + 'add' => 'additional' + ); + +sub _section { ## returns array reference for section + my $self = shift; + my $name = shift; + my $list = $_section{unpack 'a3', $name} || $name; + $self->{$list} ||= []; +} + + +=head2 sign_tsig + + $query = Net::DNS::Packet->new( 'www.example.com', 'A' ); + + $query->sign_tsig( + 'Khmac-sha512.example.+165+01018.private', + fudge => 60 + ); + + $reply = $res->send( $query ); + + $reply->verify( $query ) || die $reply->verifyerr; + +Attaches a TSIG resource record object, which will be used to sign +the packet (see RFC 2845). + +The TSIG record can be customised by optional additional arguments to +sign_tsig() or by calling the appropriate Net::DNS::RR::TSIG methods. + +If you wish to create a TSIG record using a non-standard algorithm, +you will have to create it yourself. In all cases, the TSIG name +must uniquely identify the key shared between the parties, and the +algorithm name must identify the signing function to be used with the +specified key. + + $tsig = Net::DNS::RR->new( + name => 'tsig.example', + type => 'TSIG', + algorithm => 'custom-algorithm', + key => '', + sig_function => sub { + my ($key, $data) = @_; + ... + } + ); + + $query->sign_tsig( $tsig ); + + +The historical simplified syntax is still available, but additional +options can not be specified. + + $packet->sign_tsig( $key_name, $key ); + + +The response to an inbound request is signed by presenting the request +in place of the key parameter. + + $response = $request->reply; + $response->sign_tsig( $request, @options ); + + +Multi-packet transactions are signed by chaining the sign_tsig() +calls together as follows: + + $opaque = $packet1->sign_tsig( 'Kexample.+165+13281.private' ); + $opaque = $packet2->sign_tsig( $opaque ); + $packet3->sign_tsig( $opaque ); + +The opaque intermediate object references returned during multi-packet +signing are not intended to be accessed by the end-user application. +Any such access is expressly forbidden. + +Note that a TSIG record is added to every packet; this implementation +does not support the suppressed signature scheme described in RFC2845. + +=cut + +sub sign_tsig { + my $self = shift; + + eval { + local $SIG{__DIE__}; + require Net::DNS::RR::TSIG; + my $tsig = Net::DNS::RR::TSIG->create(@_); + $self->push( 'additional' => $tsig ); + return $tsig; + } || do { + croak "$@\nTSIG: unable to sign packet"; + }; +} + + +=head2 verify and verifyerr + + $packet->verify() || die $packet->verifyerr; + $reply->verify( $query ) || die $reply->verifyerr; + +Verify TSIG signature of packet or reply to the corresponding query. + + + $opaque = $packet1->verify( $query ) || die $packet1->verifyerr; + $opaque = $packet2->verify( $opaque ); + $verifed = $packet3->verify( $opaque ) || die $packet3->verifyerr; + +The opaque intermediate object references returned during multi-packet +verify() will be undefined (Boolean false) if verification fails. +Access to the object itself, if it exists, is expressly forbidden. +Testing at every stage may be omitted, which results in a BADSIG error +on the final packet in the absence of more specific information. + +=cut + +sub verify { + my $self = shift; + + my $sig = $self->sigrr; + return $sig ? $sig->verify( $self, @_ ) : shift; +} + +sub verifyerr { + my $self = shift; + + my $sig = $self->sigrr; + return $sig ? $sig->vrfyerrstr : 'not signed'; +} + + +=head2 sign_sig0 + +SIG0 support is provided through the Net::DNS::RR::SIG class. +The requisite cryptographic components are not integrated into +Net::DNS but reside in the Net::DNS::SEC distribution available +from CPAN. + + $update = new Net::DNS::Update('example.com'); + $update->push( update => rr_add('foo.example.com A 10.1.2.3')); + $update->sign_sig0('Kexample.com+003+25317.private'); + +Execution will be terminated if Net::DNS::SEC is not available. + + +=head2 verify SIG0 + + $packet->verify( $keyrr ) || die $packet->verifyerr; + $packet->verify( [$keyrr, ...] ) || die $packet->verifyerr; + +Verify SIG0 packet signature against one or more specified KEY RRs. + +=cut + +sub sign_sig0 { + my $self = shift; + my $karg = shift; + + eval { + local $SIG{__DIE__}; + require Net::DNS::RR::SIG; + + my $sig0; + if ( ref($karg) eq 'Net::DNS::RR::SIG' ) { + $sig0 = $karg; + + } else { + $sig0 = Net::DNS::RR::SIG->create( '', $karg ); + } + + $self->push( 'additional' => $sig0 ); + return $sig0; + } || do { + croak "$@\nSIG0: unable to sign packet"; + }; +} + + +=head2 sigrr + + $sigrr = $packet->sigrr() || die 'unsigned packet'; + +The sigrr method returns the signature RR from a signed packet +or undefined if the signature is absent. + +=cut + +sub sigrr { + my $self = shift; + + my ($sig) = reverse $self->additional; + return undef unless $sig; + return $sig if $sig->type eq 'TSIG'; + return $sig if $sig->type eq 'SIG'; + return undef; +} + + +######################################## + +=head2 truncate + +The truncate method takes a maximum length as argument and then tries +to truncate the packet and set the TC bit according to the rules of +RFC2181 Section 9. + +The smallest length limit that is honoured is 512 octets. + +=cut + +# From RFC2181: +# +# 9. The TC (truncated) header bit +# +# The TC bit should be set in responses only when an RRSet is required +# as a part of the response, but could not be included in its entirety. +# The TC bit should not be set merely because some extra information +# could have been included, for which there was insufficient room. This +# includes the results of additional section processing. In such cases +# the entire RRSet that will not fit in the response should be omitted, +# and the reply sent as is, with the TC bit clear. If the recipient of +# the reply needs the omitted data, it can construct a query for that +# data and send that separately. +# +# Where TC is set, the partial RRSet that would not completely fit may +# be left in the response. When a DNS client receives a reply with TC +# set, it should ignore that response, and query again, using a +# mechanism, such as a TCP connection, that will permit larger replies. + +# Code developed from a contribution by Aaron Crane via rt.cpan.org 33547 + +sub truncate { + my $self = shift; + my $size = shift || UDPSZ; + + my $sigrr = $self->sigrr; + $size = UDPSZ unless $size > UDPSZ; + $size -= $sigrr->_size if $sigrr; + + my $data = pack 'x' x HEADER_LENGTH; # header placeholder + $self->{count} = []; + + my $tc; + my $hash = {}; + foreach my $section ( map $self->{$_}, qw(question answer authority) ) { + my @list; + foreach my $item (@$section) { + my $component = $item->encode( length $data, $hash ); + last if length($data) + length($component) > $size; + last if $tc; + $data .= $component; + CORE::push @list, $item; + } + $tc++ if scalar(@list) < scalar(@$section); + @$section = @list; + } + $self->header->tc(1) if $tc; # only set if truncated here + + my %rrset; + my @order; + foreach my $item ( grep ref($_) ne ref($sigrr), $self->additional ) { + my $name = $item->{owner}->canonical; + my $class = $item->{class} || 0; + my $key = pack 'nna*', $class, $item->{type}, $name; + CORE::push @order, $key unless $rrset{$key}; + CORE::push @{$rrset{$key}}, $item; + } + + my @list; + foreach my $key (@order) { + my $component = ''; + my @item = @{$rrset{$key}}; + foreach my $item (@item) { + $component .= $item->encode( length $data, $hash ); + } + last if length($data) + length($component) > $size; + $data .= $component; + CORE::push @list, @item; + } + + if ($sigrr) { + $data .= $sigrr->encode( length $data, $hash, $self ); + CORE::push @list, $sigrr; + } + $self->{'additional'} = \@list; + + my @part = qw(question answer authority additional); + my @size = map scalar( @{$self->{$_}} ), @part; + pack 'n6 a*', $self->header->id, $self->{status}, @size, substr( $data, HEADER_LENGTH ); +} + + +######################################## + +sub dump { ## print internal data structure + require Data::Dumper; # uncoverable pod + local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 3; + local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; + print Data::Dumper::Dumper(@_); +} + + +1; +__END__ + + +=head1 COPYRIGHT + +Copyright (c)1997-2000 Michael Fuhr. + +Portions Copyright (c)2002-2004 Chris Reinhardt. + +Portions Copyright (c)2002-2009 Olaf Kolkman + +Portions Copyright (c)2007-2015 Dick Franks + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, +L, L, L, +RFC1035 Section 4.1, RFC2136 Section 2, RFC2845 + +=cut + diff --git a/lib/Net/DNS/Parameters.pm b/lib/Net/DNS/Parameters.pm new file mode 100644 index 0000000..052d445 --- /dev/null +++ b/lib/Net/DNS/Parameters.pm @@ -0,0 +1,429 @@ +package Net::DNS::Parameters; + +# +# $Id: Parameters.pm 1623 2018-01-26 14:23:54Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1623 $)[1]; + + +################################################ +## +## Domain Name System (DNS) Parameters +## (last updated 2018-01-08) +## +################################################ + + +use strict; +use warnings; +use integer; +use Carp; + +use base qw(Exporter); +our @EXPORT = qw( + classbyname classbyval %classbyname + typebyname typebyval %typebyname + opcodebyname opcodebyval + rcodebyname rcodebyval + ednsoptionbyname ednsoptionbyval + ); + + +# Registry: DNS CLASSes +my @classbyname = ( + IN => 1, # RFC1035 + CH => 3, # Chaosnet + HS => 4, # Hesiod + NONE => 254, # RFC2136 + ANY => 255, # RFC1035 + ); +our %classbyval = reverse( CLASS0 => 0, @classbyname ); +push @classbyname, map /^\d/ ? $_ : lc($_), @classbyname; +our %classbyname = ( '*' => 255, @classbyname ); + + +# Registry: Resource Record (RR) TYPEs +my @typebyname = ( + A => 1, # RFC1035 + NS => 2, # RFC1035 + MD => 3, # RFC1035 + MF => 4, # RFC1035 + CNAME => 5, # RFC1035 + SOA => 6, # RFC1035 + MB => 7, # RFC1035 + MG => 8, # RFC1035 + MR => 9, # RFC1035 + NULL => 10, # RFC1035 + WKS => 11, # RFC1035 + PTR => 12, # RFC1035 + HINFO => 13, # RFC1035 + MINFO => 14, # RFC1035 + MX => 15, # RFC1035 + TXT => 16, # RFC1035 + RP => 17, # RFC1183 + AFSDB => 18, # RFC1183 RFC5864 + X25 => 19, # RFC1183 + ISDN => 20, # RFC1183 + RT => 21, # RFC1183 + NSAP => 22, # RFC1706 + 'NSAP-PTR' => 23, # RFC1348 RFC1637 RFC1706 + SIG => 24, # RFC4034 RFC3755 RFC2535 RFC2536 RFC2537 RFC2931 RFC3110 RFC3008 + KEY => 25, # RFC4034 RFC3755 RFC2535 RFC2536 RFC2537 RFC2539 RFC3008 RFC3110 + PX => 26, # RFC2163 + GPOS => 27, # RFC1712 + AAAA => 28, # RFC3596 + LOC => 29, # RFC1876 + NXT => 30, # RFC3755 RFC2535 + EID => 31, # http://ana-3.lcs.mit.edu/~jnc/nimrod/dns.txt + NIMLOC => 32, # http://ana-3.lcs.mit.edu/~jnc/nimrod/dns.txt + SRV => 33, # RFC2782 + ATMA => 34, # http://www.broadband-forum.org/ftp/pub/approved-specs/af-dans-0152.000.pdf + NAPTR => 35, # RFC2915 RFC2168 RFC3403 + KX => 36, # RFC2230 + CERT => 37, # RFC4398 + A6 => 38, # RFC3226 RFC2874 RFC6563 + DNAME => 39, # RFC6672 + SINK => 40, # http://tools.ietf.org/html/draft-eastlake-kitchen-sink + OPT => 41, # RFC6891 RFC3225 + APL => 42, # RFC3123 + DS => 43, # RFC4034 RFC3658 + SSHFP => 44, # RFC4255 + IPSECKEY => 45, # RFC4025 + RRSIG => 46, # RFC4034 RFC3755 + NSEC => 47, # RFC4034 RFC3755 + DNSKEY => 48, # RFC4034 RFC3755 + DHCID => 49, # RFC4701 + NSEC3 => 50, # RFC5155 + NSEC3PARAM => 51, # RFC5155 + TLSA => 52, # RFC6698 + SMIMEA => 53, # RFC8162 + HIP => 55, # RFC8005 + NINFO => 56, # + RKEY => 57, # + TALINK => 58, # + CDS => 59, # RFC7344 + CDNSKEY => 60, # RFC7344 + OPENPGPKEY => 61, # RFC7929 + CSYNC => 62, # RFC7477 + SPF => 99, # RFC7208 + UINFO => 100, # IANA-Reserved + UID => 101, # IANA-Reserved + GID => 102, # IANA-Reserved + UNSPEC => 103, # IANA-Reserved + NID => 104, # RFC6742 + L32 => 105, # RFC6742 + L64 => 106, # RFC6742 + LP => 107, # RFC6742 + EUI48 => 108, # RFC7043 + EUI64 => 109, # RFC7043 + TKEY => 249, # RFC2930 + TSIG => 250, # RFC2845 + IXFR => 251, # RFC1995 + AXFR => 252, # RFC1035 RFC5936 + MAILB => 253, # RFC1035 + MAILA => 254, # RFC1035 + ANY => 255, # RFC1035 RFC6895 + URI => 256, # RFC7553 + CAA => 257, # RFC6844 + AVC => 258, # + DOA => 259, # draft-durand-doa-over-dns + TA => 32768, # http://cameo.library.cmu.edu/ http://www.watson.org/~weiler/INI1999-19.pdf + DLV => 32769, # RFC4431 + ); +our %typebyval = reverse( TYPE0 => 0, @typebyname ); +push @typebyname, map /^\d/ ? $_ : lc($_), @typebyname; +our %typebyname = ( '*' => 255, @typebyname ); + + +# Registry: DNS OpCodes +my @opcodebyname = ( + QUERY => 0, # RFC1035 + IQUERY => 1, # RFC3425 + STATUS => 2, # RFC1035 + NOTIFY => 4, # RFC1996 + UPDATE => 5, # RFC2136 + ); +our %opcodebyval = reverse @opcodebyname; +push @opcodebyname, map /^\d/ ? $_ : lc($_), @opcodebyname; +our %opcodebyname = ( NS_NOTIFY_OP => 4, @opcodebyname ); + + +# Registry: DNS RCODEs +my @rcodebyname = ( + NOERROR => 0, # RFC1035 + FORMERR => 1, # RFC1035 + SERVFAIL => 2, # RFC1035 + NXDOMAIN => 3, # RFC1035 + NOTIMP => 4, # RFC1035 + REFUSED => 5, # RFC1035 + YXDOMAIN => 6, # RFC2136 RFC6672 + YXRRSET => 7, # RFC2136 + NXRRSET => 8, # RFC2136 + NOTAUTH => 9, # RFC2136 + NOTAUTH => 9, # RFC2845 + NOTZONE => 10, # RFC2136 + BADVERS => 16, # RFC6891 + BADSIG => 16, # RFC2845 + BADKEY => 17, # RFC2845 + BADTIME => 18, # RFC2845 + BADMODE => 19, # RFC2930 + BADNAME => 20, # RFC2930 + BADALG => 21, # RFC2930 + BADTRUNC => 22, # RFC4635 + BADCOOKIE => 23, # RFC7873 + ); +our %rcodebyval = reverse( BADSIG => 16, @rcodebyname ); +push @rcodebyname, map /^\d/ ? $_ : lc($_), @rcodebyname; +our %rcodebyname = @rcodebyname; + + +# Registry: DNS EDNS0 Option Codes (OPT) +my @ednsoptionbyname = ( + LLQ => 1, # http://files.dns-sd.org/draft-sekar-dns-llq.txt + UL => 2, # http://files.dns-sd.org/draft-sekar-dns-ul.txt + NSID => 3, # RFC5001 + DAU => 5, # RFC6975 + DHU => 6, # RFC6975 + N3U => 7, # RFC6975 + 'CLIENT-SUBNET' => 8, # RFC7871 + EXPIRE => 9, # RFC7314 + COOKIE => 10, # RFC7873 + 'TCP-KEEPALIVE' => 11, # RFC7828 + PADDING => 12, # RFC7830 + CHAIN => 13, # RFC7901 + 'KEY-TAG' => 14, # RFC8145 + DEVICEID => 26946, # https://docs.umbrella.com/developer/networkdevices-api/identifying-dns-traffic2 + ); +our %ednsoptionbyval = reverse @ednsoptionbyname; +push @ednsoptionbyname, map /^\d/ ? $_ : lc($_), @ednsoptionbyname; +our %ednsoptionbyname = @ednsoptionbyname; + + +# Registry: DNS Header Flags +my @dnsflagbyname = ( + AA => 0x0400, # RFC1035 + TC => 0x0200, # RFC1035 + RD => 0x0100, # RFC1035 + RA => 0x0080, # RFC1035 + AD => 0x0020, # RFC4035 RFC6840 + CD => 0x0010, # RFC4035 RFC6840 + ); +push @dnsflagbyname, map /^\d/ ? $_ : lc($_), @dnsflagbyname; +our %dnsflagbyname = @dnsflagbyname; + + +# Registry: EDNS Header Flags (16 bits) +my @ednsflagbyname = ( + DO => 0x8000, # RFC4035 RFC3225 RFC6840 + ); +push @ednsflagbyname, map /^\d/ ? $_ : lc($_), @ednsflagbyname; +our %ednsflagbyname = @ednsflagbyname; + + +######## + +# The following functions are wrappers around similarly named hashes. + +sub classbyname { + my $name = shift; + + $classbyname{$name} || $classbyname{uc $name} || do { + croak "unknown class $name" unless $name =~ m/^(CLASS)?(\d+)/i; + my $val = 0 + $2; + croak "classbyname( $name ) out of range" if $val > 0xffff; + return $val; + } +} + +sub classbyval { + my $val = shift; + + $classbyval{$val} || do { + $val += 0; + croak "classbyval( $val ) out of range" if $val > 0xffff; + return "CLASS$val"; + } +} + + +sub typebyname { + my $name = shift; + + $typebyname{$name} || do { + if ( $name =~ m/^(TYPE)?(\d+)/i ) { + my $val = 0 + $2; + croak "typebyname( $name ) out of range" if $val > 0xffff; + return $val; + } + _typespec("$name.RRNAME") unless $typebyname{uc $name}; + return $typebyname{uc $name} || croak "unknown type $name"; + } +} + +sub typebyval { + my $val = shift; + + $typebyval{$val} || do { + $val += 0; + croak "typebyval( $val ) out of range" if $val > 0xffff; + $typebyval{$val} = "TYPE$val"; + _typespec("$val.RRTYPE"); + return $typebyval{$val}; + } +} + + +sub opcodebyname { + my $arg = shift; + return $opcodebyname{$arg} if defined $opcodebyname{$arg}; + return 0 + $arg if $arg =~ /^\d/; + croak "unknown opcode $arg"; +} + +sub opcodebyval { + my $val = shift; + $opcodebyval{$val} || return $val; +} + + +sub rcodebyname { + my $arg = shift; + return $rcodebyname{$arg} if defined $rcodebyname{$arg}; + return 0 + $arg if $arg =~ /^\d/; + croak "unknown rcode $arg"; +} + +sub rcodebyval { + my $val = shift; + $rcodebyval{$val} || return $val; +} + + +sub ednsoptionbyname { + my $arg = shift; + return $ednsoptionbyname{$arg} if defined $ednsoptionbyname{$arg}; + return 0 + $arg if $arg =~ /^\d/; + croak "unknown option $arg"; +} + +sub ednsoptionbyval { + my $val = shift; + $ednsoptionbyval{$val} || return $val; +} + + +sub register { ## register( 'TOY', 1234 ) (NOT part of published API) + my ( $mnemonic, $rrtype ) = map uc($_), @_; # uncoverable pod + $rrtype = rand(255) + 65280 unless $rrtype; + for ( typebyval $rrtype = int($rrtype) ) { + croak "'$mnemonic' is a CLASS identifier" if $classbyname{$mnemonic}; + return $rrtype if /^$mnemonic$/; # duplicate registration + croak "'$mnemonic' conflicts with TYPE$rrtype ($_)" unless /^TYPE\d+$/; + my $known = $typebyname{$mnemonic}; + croak "'$mnemonic' conflicts with TYPE$known" if $known; + } + $typebyval{$rrtype} = $mnemonic; + return $typebyname{$mnemonic} = $rrtype; +} + + +use constant EXTLANG => defined eval 'require Net::DNS::Extlang'; + +our $DNSEXTLANG = EXTLANG ? eval 'Net::DNS::Extlang->new()->domain' : undef; + +sub _typespec { ## draft-levine-dnsextlang + eval <<'END' if EXTLANG && $DNSEXTLANG; + my ($node) = @_; + + require Net::DNS::Resolver; + my $resolver = new Net::DNS::Resolver() || return; + my $response = $resolver->send( "$node.$DNSEXTLANG", 'TXT' ) || return; + + foreach my $txt ( grep $_->type eq 'TXT', $response->answer ) { + my @stanza = $txt->txtdata; + my ( $tag, $identifier, @attribute ) = @stanza; + next unless defined($tag) && $tag =~ /^RRTYPE=\d+$/; + register( $1, $2 ) if $identifier =~ /^(\w+):(\d+)\W*/; + return unless defined wantarray; + + my $extobj = new Net::DNS::Extlang(); + my $recipe = $extobj->xlstorerecord( $identifier, @attribute ); + my @source = split /\n/, $extobj->compilerr($recipe); + return sub { defined( $_ = shift @source ) }; + } + return; +END +} + + +1; +__END__ + + +=head1 NAME + + Net::DNS::Parameters - DNS parameter assignments + + +=head1 SYNOPSIS + + use Net::DNS::Parameters; + + +=head1 DESCRIPTION + +Net::DNS::Parameters is a Perl package representing the DNS parameter +allocation (key,value) tables as recorded in the definitive registry +maintained and published by IANA. + + +=head1 FUNCTIONS + +=head2 classbyname, typebyname, opcodebyname, rcodebyname, ednsoptionbyname + +Access functions which return the numerical code corresponding to +the given mnemonic. + +=head2 classbyval, typebyval, opcodebyval, rcodebyval, ednsoptionbyval + +Access functions which return the canonical mnemonic corresponding to +the given numerical code. + + +=head1 COPYRIGHT + +Copyright (c)2012,2016 Dick Franks. + +Portions Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2003 Olaf Kolkman. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, +L + +=cut + diff --git a/lib/Net/DNS/Question.pm b/lib/Net/DNS/Question.pm new file mode 100644 index 0000000..f04f8bb --- /dev/null +++ b/lib/Net/DNS/Question.pm @@ -0,0 +1,340 @@ +package Net::DNS::Question; + +# +# $Id: Question.pm 1530 2017-01-27 10:40:37Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1530 $)[1]; + + +=head1 NAME + +Net::DNS::Question - DNS question record + +=head1 SYNOPSIS + + use Net::DNS::Question; + + $question = new Net::DNS::Question('example.com', 'A', 'IN'); + +=head1 DESCRIPTION + +A Net::DNS::Question object represents a record in the question +section of a DNS packet. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use Net::DNS::Parameters; +use Net::DNS::Domain; +use Net::DNS::DomainName; + + +=head1 METHODS + +=head2 new + + $question = new Net::DNS::Question('example.com', 'A', 'IN'); + $question = new Net::DNS::Question('example.com'); + + $question = new Net::DNS::Question('192.0.32.10', 'PTR', 'IN'); + $question = new Net::DNS::Question('192.0.32.10'); + +Creates a question object from the domain, type, and class passed as +arguments. One or both type and class arguments may be omitted and +will assume the default values shown above. + +RFC4291 and RFC4632 IP address/prefix notation is supported for +queries in both in-addr.arpa and ip6.arpa namespaces. + +=cut + +sub new { + my $self = bless {}, shift; + my $qname = shift; + my $qtype = shift || ''; + my $qclass = shift || ''; + + # tolerate (possibly unknown) type and class in zone file order + unless ( exists $classbyname{$qclass} ) { + ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $classbyname{$qtype}; + ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qtype =~ /CLASS/; + } + unless ( exists $typebyname{$qtype} ) { + ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $typebyname{$qclass}; + ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qclass =~ /TYPE/; + } + + # if argument is an IP address, do appropriate reverse lookup + if ( defined $qname and $qname =~ m/:|\d$/ ) { + if ( my $reverse = _dns_addr($qname) ) { + $qname = $reverse; + $qtype ||= 'PTR'; + } + } + + $self->{qname} = new Net::DNS::DomainName1035($qname); + $self->{qtype} = typebyname( $qtype || 'A' ); + $self->{qclass} = classbyname( $qclass || 'IN' ); + + return $self; +} + + +=head2 decode + + $question = decode Net::DNS::Question(\$data, $offset); + + ($question, $offset) = decode Net::DNS::Question(\$data, $offset); + +Decodes the question record at the specified location within a DNS +wire-format packet. The first argument is a reference to the buffer +containing the packet data. The second argument is the offset of +the start of the question record. + +Returns a Net::DNS::Question object and the offset of the next +location in the packet. + +An exception is raised if the object cannot be created +(e.g., corrupt or insufficient data). + +=cut + +use constant QFIXEDSZ => length pack 'n2', (0) x 2; + +sub decode { + my $self = bless {}, shift; + my ( $data, $offset ) = @_; + + ( $self->{qname}, $offset ) = decode Net::DNS::DomainName1035(@_); + + my $next = $offset + QFIXEDSZ; + die 'corrupt wire-format data' if length $$data < $next; + @{$self}{qw(qtype qclass)} = unpack "\@$offset n2", $$data; + + wantarray ? ( $self, $next ) : $self; +} + + +=head2 encode + + $data = $question->encode( $offset, $hash ); + +Returns the Net::DNS::Question in binary format suitable for +inclusion in a DNS packet buffer. + +The optional arguments are the offset within the packet data where +the Net::DNS::Question is to be stored and a reference to a hash +table used to index compressed names within the packet. + +=cut + +sub encode { + my $self = shift; + + pack 'a* n2', $self->{qname}->encode(@_), @{$self}{qw(qtype qclass)}; +} + + +=head2 print + + $object->print; + +Prints the record to the standard output. Calls the string() method +to get the string representation. + +=cut + +sub print { + print shift->string, "\n"; +} + + +=head2 string + + print "string = ", $question->string, "\n"; + +Returns a string representation of the question record. + +=cut + +sub string { + my $self = shift; + + join "\t", $self->{qname}->string, $self->qclass, $self->qtype; +} + + +=head2 name + + $name = $question->name; + +Internationalised domain name corresponding to the qname attribute. + +Decoding non-ASCII domain names is computationally expensive and +undesirable for names which are likely to be used to construct +further queries. + +When required to communicate with humans, the 'proper' domain name +should be extracted from a query or reply packet. + + $query = new Net::DNS::Packet( $example, 'ANY' ); + $reply = $resolver->send($query) or die; + ($question) = $reply->question; + $name = $question->name; + +=cut + +sub name { + my $self = shift; + + croak 'immutable object: argument invalid' if scalar @_; + $self->{qname}->xname; +} + + +=head2 qname, zname + + $qname = $question->qname; + $zname = $question->zname; + +Canonical ASCII domain name as required for the query subject +transmitted to a nameserver. In dynamic update packets, this +attribute is known as zname() and refers to the zone name. + +=cut + +sub qname { + my $self = shift; + + croak 'immutable object: argument invalid' if scalar @_; + $self->{qname}->name; +} + +sub zname { &qname; } + + +=head2 qtype, ztype, type + + $qtype = $question->type; + $qtype = $question->qtype; + $ztype = $question->ztype; + +Returns the question type attribute. In dynamic update packets, +this attribute is known as ztype() and refers to the zone type. + +=cut + +sub type { + my $self = shift; + + croak 'immutable object: argument invalid' if scalar @_; + typebyval( $self->{qtype} ); +} + +sub qtype { &type; } +sub ztype { &type; } + + +=head2 qclass, zclass, class + + $qclass = $question->class; + $qclass = $question->qclass; + $zclass = $question->zclass; + +Returns the question class attribute. In dynamic update packets, +this attribute is known as zclass() and refers to the zone class. + +=cut + +sub class { + my $self = shift; + + croak 'immutable object: argument invalid' if scalar @_; + classbyval( $self->{qclass} ); +} + +sub qclass { &class; } +sub zclass { &class; } + + +######################################## + +sub _dns_addr { ## Map IP address into reverse lookup namespace + local $_ = shift; + + # IP address must contain address characters only + s/[%].+$//; # discard RFC4007 scopeid + return undef unless m#^[a-fA-F0-9:./]+$#; + + my ( $address, $pfxlen ) = split m#/#; + + # map IPv4 address to in-addr.arpa space + if (m#^\d*[.\d]*\d(/\d+)?$#) { + my @parse = split /\./, $address; + $pfxlen = scalar(@parse) << 3 unless $pfxlen; + my $last = $pfxlen > 24 ? 3 : ( $pfxlen - 1 ) >> 3; + return join '.', reverse( ( @parse, (0) x 3 )[0 .. $last] ), 'in-addr.arpa.'; + } + + # map IPv6 address to ip6.arpa space + return unless m#^[:\w]+:([.\w]*)(/\d+)?$#; + my $rhs = $1 || '0'; + return _dns_addr($rhs) if m#^[:0]*:0*:[fF]{4}:[^:]+$#; # IPv4 + $rhs = sprintf '%x%0.2x:%x%0.2x', map $_ || 0, split( /\./, $rhs, 4 ) if /\./; + $address =~ s/:[^:]*$/:0$rhs/; + my @parse = split /:/, ( reverse "0$address" ), 9; + my @xpand = map { /./ ? $_ : ('0') x ( 9 - @parse ) } @parse; # expand :: + $pfxlen = ( scalar(@xpand) << 4 ) unless $pfxlen; # implicit length if unspecified + my $len = $pfxlen > 124 ? 32 : ( $pfxlen + 3 ) >> 2; + my $hex = pack 'A4' x 8, map { $_ . '000' } ('0') x ( 8 - @xpand ), @xpand; + return join '.', split( //, substr( $hex, -$len ) ), 'ip6.arpa.'; +} + + +1; +__END__ + +######################################## + +=head1 COPYRIGHT + +Copyright (c)1997-2000 Michael Fuhr. + +Portions Copyright (c)2002,2003 Chris Reinhardt. + +Portions Copyright (c)2003,2006-2011 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, +RFC 1035 Section 4.1.2 + +=cut + diff --git a/lib/Net/DNS/RR.pm b/lib/Net/DNS/RR.pm new file mode 100644 index 0000000..d3bec82 --- /dev/null +++ b/lib/Net/DNS/RR.pm @@ -0,0 +1,824 @@ +package Net::DNS::RR; + +# +# $Id: RR.pm 1611 2018-01-02 09:41:24Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1611 $)[1]; + + +=head1 NAME + +Net::DNS::RR - DNS resource record base class + +=head1 SYNOPSIS + + use Net::DNS; + + $rr = new Net::DNS::RR('example.com IN A 192.0.2.99'); + + $rr = new Net::DNS::RR( + owner => 'example.com', + type => 'A', + address => '192.0.2.99' + ); + + +=head1 DESCRIPTION + +Net::DNS::RR is the base class for DNS Resource Record (RR) objects. +See also the manual pages for each specific RR type. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use constant LIB => grep $_ ne '.', grep !ref($_), @INC; + +use Net::DNS::Parameters; +use Net::DNS::Domain; +use Net::DNS::DomainName; + + +=head1 METHODS + +B Do not assume the RR objects you receive from a query +are of a particular type. You must always check the object type +before calling any of its methods. If you call an unknown method, +you will get an error message and execution will be terminated. + +=cut + +sub new { + return eval { + local $SIG{__DIE__}; + scalar @_ > 2 ? &_new_hash : &_new_string; + } || do { + my $class = shift || __PACKAGE__; + my @param = map defined($_) ? split /\s+/ : 'undef', @_; + my $stmnt = substr "new $class( @param )", 0, 80; + croak "${@}in $stmnt\n"; + }; +} + + +=head2 new (from string) + + $a = new Net::DNS::RR('host.example.com. 86400 A 192.0.2.1'); + $mx = new Net::DNS::RR('example.com. 7200 MX 10 mailhost.example.com.'); + $cname = new Net::DNS::RR('www.example.com 300 IN CNAME host.example.com'); + $txt = new Net::DNS::RR('txt.example.com 3600 HS TXT "text data"'); + +Returns an object of the appropriate RR type, or a L object +if the type is not implemented. The attribute values are extracted from the +string passed by the user. The syntax of the argument string follows the +RFC1035 specification for zone files, and is compatible with the result +returned by the string method. + +The owner and RR type are required; all other information is optional. +Omitting the optional fields is useful for creating the empty RDATA +sections required for certain dynamic update operations. +See the L manual page for additional examples. + +All names are interpreted as fully qualified domain names. +The trailing dot (.) is optional. + +=cut + +my $PARSE_REGEX = q/("[^"]*")|;[^\n]*|[ \t\n\r\f()]/; + +sub _new_string { + my $base; + local $_; + ( $base, $_ ) = @_; + croak 'argument absent or undefined' unless defined $_; + croak 'non-scalar argument' if ref $_; + + # parse into quoted strings, contiguous non-whitespace and (discarded) comments + s/\\\\/\\092/g; # disguise escaped escape + s/\\"/\\034/g; # disguise escaped quote + s/\\\(/\\040/g; # disguise escaped bracket + s/\\\)/\\041/g; # disguise escaped bracket + s/\\;/\\059/g; # disguise escaped semicolon + my ( $owner, @token ) = grep defined && length, split /$PARSE_REGEX/o; + + croak 'unable to parse RR string' unless scalar @token; + my $t1 = uc $token[0]; + my $t2 = uc $token[1] if $#token; + + my ( $ttl, $class ); + if ( not defined $t2 ) { # + @token = ('ANY') if $classbyname{$t1}; # + } elsif ( $classbyname{$t1} || $t1 =~ /^CLASS\d/ ) { + $class = shift @token; # [] + $ttl = shift @token if $t2 =~ /^\d/; + } elsif ( $t1 =~ /^\d/ ) { + $ttl = shift @token; # [] + $class = shift @token if $classbyname{$t2} || $t2 =~ /^CLASS\d/; + } + + my $type = shift(@token); + my $populated = scalar @token; + + my $self = $base->_subclass( $type, $populated ); # create RR object + $self->owner($owner); + $self->class($class) if defined $class; # specify CLASS + $self->ttl($ttl) if defined $ttl; # specify TTL + + return $self unless $populated; # empty RR + + if ( $#token && $token[0] =~ /^[\\]?#$/ ) { + shift @token; # RFC3597 hexadecimal format + my $rdlen = shift(@token) || 0; + my $rdata = pack 'H*', join( '', @token ); + croak 'length and hexadecimal data inconsistent' unless $rdlen == length $rdata; + $self->rdata($rdata); # unpack RDATA + return $self; + } + + $self->_parse_rdata(@token); # parse arguments + return $self; +} + + +=head2 new (from hash) + + $rr = new Net::DNS::RR(%hash); + + $rr = new Net::DNS::RR( + owner => 'host.example.com', + ttl => 86400, + class => 'IN', + type => 'A', + address => '192.0.2.1' + ); + + $rr = new Net::DNS::RR( + owner => 'txt.example.com', + type => 'TXT', + txtdata => [ 'one', 'two' ] + ); + +Returns an object of the appropriate RR type, or a L object +if the type is not implemented. Consult the relevant manual pages for the +usage of type specific attributes. + +The owner and RR type are required; all other information is optional. +Omitting optional attributes is useful for creating the empty RDATA +sections required for certain dynamic update operations. + +=cut + +my @core = qw(owner name type class ttl rdlength); + +sub _new_hash { + my $base = shift; + + my %attribute = ( owner => '.', type => 'NULL' ); + while ( my $key = shift ) { + $attribute{lc $key} = shift; + } + + my ( $owner, $name, $type, $class, $ttl ) = delete @attribute{@core}; + + my $self = $base->_subclass( $type, scalar(%attribute) ); + $self->owner( $name ? $name : $owner ); + $self->class($class) if defined $class; # optional CLASS + $self->ttl($ttl) if defined $ttl; # optional TTL + + eval { + while ( my ( $attribute, $value ) = each %attribute ) { + $self->$attribute( ref($value) eq 'ARRAY' ? @$value : $value ); + } + }; + die ref($self) eq __PACKAGE__ ? "type $type not implemented" : () if $@; + + return $self; +} + + +=head2 decode + + ( $rr, $next ) = decode Net::DNS::RR( \$data, $offset, @opaque ); + +Decodes a DNS resource record at the specified location within a +DNS packet. + +The argument list consists of a reference to the buffer containing +the packet data and offset indicating where resource record begins. +Remaining arguments, if any, are passed as opaque data to +subordinate decoders. + +Returns a C object and the offset of the next record +in the packet. + +An exception is raised if the data buffer contains insufficient or +corrupt data. + +Any remaining arguments are passed as opaque data to subordinate +decoders and do not form part of the published interface. + +=cut + +use constant RRFIXEDSZ => length pack 'n2 N n', (0) x 4; + +sub decode { + my $base = shift; + my ( $data, $offset, @opaque ) = @_; + + my ( $owner, $fixed ) = decode Net::DNS::DomainName1035(@_); + + my $index = $fixed + RRFIXEDSZ; + die 'corrupt wire-format data' if length $$data < $index; + my $self = $base->_subclass( unpack "\@$fixed n", $$data ); + $self->{owner} = $owner; + @{$self}{qw(class ttl rdlength)} = unpack "\@$fixed x2 n N n", $$data; + + my $next = $index + $self->{rdlength}; + die 'corrupt wire-format data' if length $$data < $next; + + $self->{offset} = $offset || 0; + $self->_decode_rdata( $data, $index, @opaque ) if $next > $index or $self->type eq 'OPT'; + delete $self->{offset}; + + return wantarray ? ( $self, $next ) : $self; +} + + +=head2 encode + + $data = $rr->encode( $offset, @opaque ); + +Returns the C in binary format suitable for inclusion +in a DNS packet buffer. + +The offset indicates the intended location within the packet data +where the C is to be stored. + +Any remaining arguments are opaque data which are passed intact to +subordinate encoders. + +=cut + +sub encode { + my $self = shift; + my ( $offset, @opaque ) = scalar(@_) ? @_ : ( 0x4000, {} ); + + my $owner = $self->{owner}->encode( $offset, @opaque ); + my $type = $self->{type}; + my $class = $self->{class} || 1; + my $index = $offset + length($owner) + RRFIXEDSZ; + my $rdata = $self->_empty ? '' : $self->_encode_rdata( $index, @opaque ); + return pack 'a* n2 N n a*', $owner, $type, $class, $self->ttl, length $rdata, $rdata; +} + + +=head2 canonical + + $data = $rr->canonical; + +Returns the C in canonical binary format suitable for +DNSSEC signature validation. + +The absence of the associative array argument signals to subordinate +encoders that the canonical uncompressed lower case form of embedded +domain names is to be used. + +=cut + +sub canonical { + my $self = shift; + + my $owner = $self->{owner}->canonical; + my $type = $self->{type}; + my $class = $self->{class} || 1; + my $index = RRFIXEDSZ + length $owner; + my $rdata = $self->_empty ? '' : $self->_encode_rdata($index); + pack 'a* n2 N n a*', $owner, $type, $class, $self->ttl, length $rdata, $rdata; +} + + +=head2 print + + $rr->print; + +Prints the record to the standard output. Calls the string method +to get the formatted RR representation. + +=cut + +sub print { + print shift->string, "\n"; +} + + +=head2 string + + print $rr->string, "\n"; + +Returns a string representation of the RR using the zone file format +described in RFC1035. All domain names are fully qualified with +trailing dot. This differs from RR attribute methods, which omit +the trailing dot. + +=cut + +sub string { + my $self = shift; + + my $name = $self->{owner}->string; + my @ttl = grep defined, $self->{ttl}; + my @core = ( $name, @ttl, $self->class, $self->type ); + + my $empty = $self->_empty; + my @rdata = $empty ? () : eval { $self->_format_rdata }; + carp $@ if $@; + + my $tab = length($name) < 72 ? "\t" : ' '; + $self->_annotation('no data') if $empty; + + my @line = _wrap( join( $tab, @core, '(' ), @rdata, ')' ); + + my $last = pop(@line); # last or only line + $last = join $tab, @core, "@rdata" unless scalar(@line); + + return join "\n\t", @line, _wrap( $last, map "; $_", $self->_annotation ); +} + + +=head2 plain + + $plain = $rr->plain; + +Returns a simplified single line representation of the RR using the +zone file format defined in RFC1035. This facilitates interaction +with programs like nsupdate which have rudimentary RR parsers. + +=cut + +sub plain { + join ' ', shift->token; +} + + +=head2 token + + @token = $rr->token; + +Returns a token list representation of the RR zone file string. + +=cut + +sub token { + my $self = shift; + + my @ttl = grep defined, $self->{ttl}; + my @core = ( $self->{owner}->string, @ttl, $self->class, $self->type ); + + my @rdata = $self->_empty ? () : eval { $self->_format_rdata }; + + # parse into quoted strings, contiguous non-whitespace and (discarded) comments + my @parse = map { s/\\\\/\\092/g; s/\\"/\\034/g; split /$PARSE_REGEX/o; } @rdata; + my @token = ( @core, grep defined && length, @parse ); +} + + +=head2 generic + + $generic = $rr->generic; + +Returns the generic RR representation defined in RFC3597. This facilitates +creation of zone files containing RRs unrecognised by outdated nameservers +and provisioning software. + +=cut + +sub generic { + my $self = shift; + + my @ttl = grep defined, $self->{ttl}; + my @class = map "CLASS$_", grep defined, $self->{class}; + my @core = ( $self->{owner}->string, @ttl, @class, "TYPE$self->{type}" ); + my $data = $self->rdata; + my @data = ( '\\#', length($data), split /(\S{32})/, unpack 'H*', $data ); + my @line = _wrap( "@core (", @data, ')' ); + return join "\n\t", @line if scalar(@line) > 1; + join ' ', @core, @data; +} + + +=head2 owner name + + $name = $rr->owner; + +Returns the owner name of the record. + +=cut + +sub owner { + my $self = shift; + $self->{owner} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{owner}->name if defined wantarray; +} + +sub name { &owner; } ## historical + + +=head2 type + + $type = $rr->type; + +Returns the record type. + +=cut + +sub type { + my $self = shift; + croak 'not possible to change RR->type' if scalar @_; + typebyval( $self->{type} ); +} + + +=head2 class + + $class = $rr->class; + +Resource record class. + +=cut + +sub class { + my $self = shift; + return $self->{class} = classbyname(shift) if scalar @_; + defined $self->{class} ? classbyval( $self->{class} ) : 'IN'; +} + + +=head2 ttl + + $ttl = $rr->ttl; + $ttl = $rr->ttl(3600); + +Resource record time to live in seconds. + +=cut + +# The following time units are recognised, but are not part of the +# published API. These are required for parsing BIND zone files but +# should not be used in other contexts. +my %unit = ( W => 604800, D => 86400, H => 3600, M => 60, S => 1 ); + +sub ttl { + my ( $self, $time ) = @_; + + return $self->{ttl} || 0 unless defined $time; # avoid defining rr->{ttl} + + my $ttl = 0; + my %time = reverse split /(\D)\D*/, $time . 'S'; + while ( my ( $u, $t ) = each %time ) { + my $scale = $unit{uc $u} || die qq(bad time: $t$u); + $ttl += $t * $scale; + } + $self->{ttl} = $ttl; +} + + +################################################################################ +## +## Default implementation for unknown RR type +## +################################################################################ + +sub _decode_rdata { ## decode rdata from wire-format octet string + my ( $self, $data, $offset ) = @_; + $self->{rdata} = substr $$data, $offset, $self->{rdlength}; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $rdata = shift->{rdata}; +} + + +sub _format_rdata { ## format rdata portion of RR string + my $data = shift->rdata; + my $size = length($data); # RFC3597 unknown RR format + my @data = ( '\\#', $size, split /(\S{32})/, unpack 'H*', $data ); +} + + +sub _parse_rdata { ## parse RR attributes in argument list + my $self = shift; + die join ' ', 'type', $self->type, 'not implemented' if ref($self) eq __PACKAGE__; + die join ' ', 'no zone file representation defined for', $self->type; +} + + +sub _defaults { } ## set attribute default values + + +sub dump { ## print internal data structure + require Data::Dumper; # uncoverable pod + local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 6; + local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; + print Data::Dumper::Dumper(@_); +} + +sub rdatastr { ## historical RR subtype method + &rdstring; # uncoverable pod +} + + +=head2 rdata + + $rr = new Net::DNS::RR( type => NULL, rdata => 'arbitrary' ); + +Resource record data section when viewed as opaque octets. + +=cut + +sub rdata { + my $self = shift; + + return $self->_empty ? '' : eval { $self->_encode_rdata( 0x4000, {} ) } unless @_; + + my $data = shift || ''; + my $hash = {}; + $self->_decode_rdata( \$data, 0, $hash ) if ( $self->{rdlength} = length $data ); + croak 'unexpected compression pointer in rdata' if keys %$hash; +} + + +=head2 rdstring + + $rdstring = $rr->rdstring; + +Returns a string representation of the RR-specific data. + +=cut + +sub rdstring { + my $self = shift; + + my @rdata = $self->_empty ? () : eval { $self->_format_rdata }; + carp $@ if $@; + + join "\n\t", _wrap(@rdata); +} + + +=head2 rdlength + + $rdlength = $rr->rdlength; + +Returns the uncompressed length of the encoded RR-specific data. + +=cut + +sub rdlength { + length shift->rdata; +} + + +################################################################################### + +=head1 Sorting of RR arrays + +Sorting of RR arrays is done by Net::DNS::rrsort(), see documentation +for L. This package provides class methods to set the +comparator function used for a particular RR based on its attributes. + + +=head2 set_rrsort_func + + my $function = sub { ## numerically ascending order + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; + }; + + Net::DNS::RR::MX->set_rrsort_func( 'preference', $function ); + + Net::DNS::RR::MX->set_rrsort_func( 'default_sort', $function ); + +set_rrsort_func() must be called as a class method. The first argument is +the attribute name on which the sorting is to take place. If you specify +"default_sort" then that is the sort algorithm that will be used when +get_rrsort_func() is called without an RR attribute as argument. + +The second argument is a reference to a comparator function that uses the +global variables $a and $b in the Net::DNS package. During sorting, the +variables $a and $b will contain references to objects of the class whose +set_rrsort_func() was called. The above sorting function will only be +applied to Net::DNS::RR::MX objects. + +The above example is the sorting function implemented in MX. + +=cut + +our %rrsortfunct; + +sub set_rrsort_func { + my $class = shift; + my $attribute = shift; + my $function = shift; + + my ($type) = $class =~ m/::([^:]+)$/; + $rrsortfunct{$type}{$attribute} = $function; +} + + +=head2 get_rrsort_func + + $function = Net::DNS::RR::MX->get_rrsort_func('preference'); + $function = Net::DNS::RR::MX->get_rrsort_func(); + +get_rrsort_func() returns a reference to the comparator function. + +=cut + +my $default = sub { $Net::DNS::a->canonical() cmp $Net::DNS::b->canonical(); }; + +sub get_rrsort_func { + my $class = shift; + my $attribute = shift || 'default_sort'; + + my ($type) = $class =~ m/::([^:]+)$/; + + $rrsortfunct{$type}{$attribute} || $default; +} + + +################################################################################ +# +# Net::DNS::RR->_subclass($rrname) +# Net::DNS::RR->_subclass($rrname, $default) +# +# Create a new object blessed into appropriate RR subclass, after +# loading the subclass module (if necessary). A subclass with no +# corresponding module will be regarded as unknown and blessed +# into the RR base class. +# +# The optional second argument indicates that default values are +# to be copied into the newly created object. + +our %_MINIMAL = ( 255 => bless ['type' => 255], __PACKAGE__ ); +our %_LOADED = %_MINIMAL; + +sub _subclass { + my ( $class, $rrname, $default ) = @_; + + unless ( $_LOADED{$rrname} ) { + my $rrtype = typebyname($rrname); + + unless ( $_LOADED{$rrtype} ) { # load once only + local @INC = LIB; + + my $identifier = typebyval($rrtype); + $identifier =~ s/\W/_/g; # kosher Perl identifier + + my $subclass = join '::', __PACKAGE__, $identifier; + + unless ( eval "require $subclass" ) { + push @INC, sub { + Net::DNS::Parameters::_typespec("$rrtype.RRTYPE"); + }; + + $subclass = join '::', __PACKAGE__, "TYPE$rrtype"; + eval "require $subclass"; + } + + $subclass = __PACKAGE__ if $@; + + # cache pre-built minimal and populated default object images + my @base = ( 'type' => $rrtype ); + $_MINIMAL{$rrtype} = bless [@base], $subclass; + + my $object = bless {@base}, $subclass; + $object->_defaults; + $_LOADED{$rrtype} = bless [%$object], $subclass; + } + + $_MINIMAL{$rrname} = $_MINIMAL{$rrtype}; + $_LOADED{$rrname} = $_LOADED{$rrtype}; + } + + my $prebuilt = $default ? $_LOADED{$rrname} : $_MINIMAL{$rrname}; + bless {@$prebuilt}, ref($prebuilt); # create object +} + + +sub _annotation { + my $self = shift; + $self->{annotation} = ["@_"] if scalar @_; + return @{$self->{annotation} || []} if wantarray; +} + + +my %ignore = map( ( $_ => 1 ), @core, 'annotation', '#' ); + +sub _empty { + not( $_[0]->{'#'} ||= scalar grep !$ignore{$_}, keys %{$_[0]} ); +} + + +sub _wrap { + my @text = @_; + my $cols = 80; + my $coln = 0; + + my ( @line, @fill ); + foreach (@text) { + if ( ( $coln += 1 + length ) > $cols ) { # start new line + push @line, join ' ', @fill if scalar @fill; + $coln = length; + @fill = (); + } + $coln = $cols if chomp; # force line break + push( @fill, $_ ); + } + push @line, join ' ', @fill; + return @line; +} + + +################################################################################ + +our $AUTOLOAD; + +sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) + +sub AUTOLOAD { ## Default method + my $self = shift; + my $oref = ref($self); + + no strict q/refs/; + my ($method) = reverse split /::/, $AUTOLOAD; + *{$AUTOLOAD} = sub {undef}; ## suppress repetition and deep recursion + croak "$self has no class method '$method'" unless $oref; + + my $string = $self->string; + my @object = grep defined($_), $oref, $oref->VERSION; + my $module = join '::', __PACKAGE__, $self->type; + eval("require $module") if $oref eq __PACKAGE__; + + @_ = ( <<"END", $@, "@object" ); +*** FATAL PROGRAM ERROR!! Unknown instance method '$method' +*** which the program has attempted to call for the object: +*** +$string +*** +*** THIS IS A BUG IN THE CALLING SOFTWARE, which incorrectly assumes +*** that the object would be of a particular type. The type of an +*** object should be checked before calling any of its methods. +*** +END + goto &{'Carp::confess'}; +} + + +1; +__END__ + + +=head1 COPYRIGHT + +Copyright (c)1997-2001 Michael Fuhr. + +Portions Copyright (c)2002,2003 Chris Reinhardt. + +Portions Copyright (c)2005-2007 Olaf Kolkman. + +Portions Copyright (c)2007,2012 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, +L, L, +RFC1035 Section 4.1.3, RFC1123, RFC3597 + +=cut + diff --git a/lib/Net/DNS/RR/A.pm b/lib/Net/DNS/RR/A.pm new file mode 100644 index 0000000..4a02e8b --- /dev/null +++ b/lib/Net/DNS/RR/A.pm @@ -0,0 +1,136 @@ +package Net::DNS::RR::A; + +# +# $Id: A.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::A - DNS A resource record + +=cut + + +use integer; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + $self->{address} = unpack "\@$offset a4", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a4', $self->{address}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->address; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +my $pad = pack 'x4'; + +sub address { + my $self = shift; + my $addr = shift; + + return join '.', unpack 'C4', $self->{address} . $pad unless defined $addr; + + # Note: pack masks overlarge values, mostly without warning + my @part = split /\./, $addr; + my $last = pop(@part); + $self->{address} = pack 'C4', @part, (0) x ( 3 - @part ), $last; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN A address'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'A', + address => '192.0.2.1' + ); + +=head1 DESCRIPTION + +Class for DNS Address (A) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 address + + $IPv4_address = $rr->address; + $rr->address( $IPv4_address ); + +Version 4 IP address represented using dotted-quad notation. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.4.1 + +=cut diff --git a/lib/Net/DNS/RR/AAAA.pm b/lib/Net/DNS/RR/AAAA.pm new file mode 100644 index 0000000..1e97a18 --- /dev/null +++ b/lib/Net/DNS/RR/AAAA.pm @@ -0,0 +1,176 @@ +package Net::DNS::RR::AAAA; + +# +# $Id: AAAA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::AAAA - DNS AAAA resource record + +=cut + + +use integer; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + $self->{address} = unpack "\@$offset a16", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a16', $self->{address}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->address_short; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +sub address_long { + my $addr = pack 'a*@16', grep defined, shift->{address}; + sprintf '%x:%x:%x:%x:%x:%x:%x:%x', unpack 'n8', $addr; +} + + +sub address_short { + my $addr = pack 'a*@16', grep defined, shift->{address}; + for ( sprintf ':%x:%x:%x:%x:%x:%x:%x:%x:', unpack 'n8', $addr ) { + s/(:0[:0]+:)(?!.+:0\1)/::/; # squash longest zero sequence + s/^:// unless /^::/; # prune LH : + s/:$// unless /::$/; # prune RH : + return $_; + } +} + + +sub address { + my $self = shift; + + return address_long($self) unless scalar @_; + + my $addr = shift; + my @parse = split /:/, "0$addr"; + + if ( (@parse)[$#parse] =~ /\./ ) { # embedded IPv4 + my @ip4 = split /\./, pop(@parse); + my $rhs = pop(@ip4); + my @ip6 = map { /./ ? hex($_) : (0) x ( 7 - @parse ) } @parse; + return $self->{address} = pack 'n6 C4', @ip6, @ip4, (0) x ( 3 - @ip4 ), $rhs; + } + + # Note: pack() masks overlarge values, mostly without warning. + my @expand = map { /./ ? hex($_) : (0) x ( 9 - @parse ) } @parse; + $self->{address} = pack 'n8', @expand; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN AAAA address'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'AAAA', + address => '2001:DB8::8:800:200C:417A' + ); + +=head1 DESCRIPTION + +Class for DNS IPv6 Address (AAAA) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 address + + $IPv6_address = $rr->address; + +Returns the text representation of the IPv6 address. + + +=head2 address_long + + $IPv6_address = $rr->address_long; + +Returns the text representation specified in RFC3513, 2.2(1). + + +=head2 address_short + + $IPv6_address = $rr->address_short; + +Returns the textual form of address recommended by RFC5952. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2003 Chris Reinhardt. + +Portions Copyright (c)2012 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC3596, RFC3513, RFC5952 + +=cut diff --git a/lib/Net/DNS/RR/AFSDB.pm b/lib/Net/DNS/RR/AFSDB.pm new file mode 100644 index 0000000..321afcf --- /dev/null +++ b/lib/Net/DNS/RR/AFSDB.pm @@ -0,0 +1,149 @@ +package Net::DNS::RR::AFSDB; + +# +# $Id: AFSDB.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::AFSDB - DNS AFSDB resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{subtype} = unpack "\@$offset n", $$data; + $self->{hostname} = decode Net::DNS::DomainName2535( $data, $offset + 2, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $hostname = $self->{hostname}; + pack 'n a*', $self->subtype, $hostname->encode( $offset + 2, @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $hostname = $self->{hostname}; + join ' ', $self->subtype, $hostname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->subtype(shift); + $self->hostname(shift); +} + + +sub subtype { + my $self = shift; + + $self->{subtype} = 0 + shift if scalar @_; + $self->{subtype} || 0; +} + + +sub hostname { + my $self = shift; + + $self->{hostname} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{hostname}->name if $self->{hostname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name AFSDB subtype hostname'); + +=head1 DESCRIPTION + +Class for DNS AFS Data Base (AFSDB) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 subtype + + $subtype = $rr->subtype; + $rr->subtype( $subtype ); + +A 16 bit integer which indicates the service offered by the +listed host. + +=head2 hostname + + $hostname = $rr->hostname; + $rr->hostname( $hostname ); + +The hostname field is a domain name of a host that has a server +for the cell named by the owner name of the RR. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2002,2003 Chris Reinhardt. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1183, RFC5864 + +=cut diff --git a/lib/Net/DNS/RR/APL.pm b/lib/Net/DNS/RR/APL.pm new file mode 100644 index 0000000..c2180dd --- /dev/null +++ b/lib/Net/DNS/RR/APL.pm @@ -0,0 +1,281 @@ +package Net::DNS::RR::APL; + +# +# $Id: APL.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::APL - DNS APL resource record + +=cut + + +use integer; + +use Carp; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + + my $aplist = $self->{aplist} = []; + while ( $offset < $limit ) { + my $xlen = unpack "\@$offset x3 C", $$data; + my $size = ( $xlen & 0x7F ); + my $item = bless {}, 'Net::DNS::RR::APL::Item'; + $item->{negate} = $xlen - $size; + @{$item}{qw(family prefix address)} = unpack "\@$offset n C x a$size", $$data; + $offset += $size + 4; + push @$aplist, $item; + } + croak('corrupt APL data') unless $offset == $limit; # more or less FUBAR +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my @rdata; + my $aplist = $self->{aplist}; + foreach (@$aplist) { + my $address = $_->{address}; + $address =~ s/[\000]+$//; # strip trailing null octets + my $xlength = ( $_->{negate} ? 0x80 : 0 ) | length($address); + push @rdata, pack 'n C2 a*', @{$_}{qw(family prefix)}, $xlength, $address; + } + join '', @rdata; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $aplist = $self->{aplist}; + my @rdata = map $_->string, @$aplist; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->aplist(@_); +} + + +sub aplist { + my $self = shift; + + while ( scalar @_ ) { # parse apitem strings + last unless $_[0] =~ m#[!:./]#; + shift =~ m#^(!?)(\d+):(.+)/(\d+)$#; + my $n = $1 ? 1 : 0; + my $f = $2 || 0; + my $a = $3; + my $p = $4 || 0; + $self->aplist( negate => $n, family => $f, address => $a, prefix => $p ); + } + + my $aplist = $self->{aplist} ||= []; + if ( my %argval = @_ ) { # parse attribute=value list + my $item = bless {}, 'Net::DNS::RR::APL::Item'; + while ( my ( $attribute, $value ) = each %argval ) { + $item->$attribute($value) unless $attribute eq 'address'; + } + $item->address( $argval{address} ); # address must be last + push @$aplist, $item; + } + + my @ap = @$aplist; + return wantarray ? @ap : join ' ', map $_->string, @ap if defined wantarray; +} + + +######################################## + + +package Net::DNS::RR::APL::Item; + +use Net::DNS::RR::A; +use Net::DNS::RR::AAAA; + +my %family = qw(1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA); + + +sub negate { + my $bit = 0x80; + for ( shift->{negate} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub family { + my $self = shift; + + $self->{family} = 0 + shift if scalar @_; + $self->{family} || 0; +} + + +sub prefix { + my $self = shift; + + $self->{prefix} = 0 + shift if scalar @_; + $self->{prefix} || 0; +} + + +sub address { + my $self = shift; + + my $family = $family{$self->family} || die 'unknown address family'; + return bless( {%$self}, $family )->address unless scalar @_; + + my $bitmask = $self->prefix; + my $address = bless( {}, $family )->address(shift); + $self->{address} = pack "B$bitmask", unpack 'B*', $address; +} + + +sub string { + my $self = shift; + + my $not = $self->{negate} ? '!' : ''; + my ( $family, $address, $prefix ) = ( $self->family, $self->address, $self->prefix ); + return "$not$family:$address/$prefix"; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN APL aplist'); + +=head1 DESCRIPTION + +DNS Address Prefix List (APL) record + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 aplist + + @aplist = $rr->aplist; + + @aplist = $rr->aplist( '1:192.168.32.0/21', '!1:192.168.38.0/28' ); + + @aplist = $rr->aplist( '1:224.0.0.0/4', '2:FF00:0:0:0:0:0:0:0/8' ); + + @aplist = $rr->aplist( negate => 1, + family => 1, + address => '192.168.38.0', + prefix => 28, + ); + +Ordered, possibly empty, list of address prefix items. +Additional items, if present, are appended to the existing list +with neither prefix aggregation nor reordering. + + +=head2 Net::DNS::RR::APL::Item + +Each element of the prefix list is a Net::DNS::RR::APL::Item +object which is inextricably bound to the APL record which +created it. + +=head2 negate + + $rr->negate(1); + + if ( $rr->negate ) { + ... + } + +Boolean attribute indicating the prefix to be an address range exclusion. + +=head2 family + + $family = $rr->family; + $rr->family( $family ); + +Address family discriminant. + +=head2 prefix + + $prefix = $rr->prefix; + $rr->prefix( $prefix ); + +Number of bits comprising the address prefix. + + +=head2 address + + $address = $object->address; + +Address portion of the prefix list item. + +=head2 string + + $string = $object->string; + +Returns the prefix list item in the form required in zone files. + + +=head1 COPYRIGHT + +Copyright (c)2008 Olaf Kolkman, NLnet Labs. + +Portions Copyright (c)2011,2017 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC3123 + +=cut diff --git a/lib/Net/DNS/RR/CAA.pm b/lib/Net/DNS/RR/CAA.pm new file mode 100644 index 0000000..4cc8d5b --- /dev/null +++ b/lib/Net/DNS/RR/CAA.pm @@ -0,0 +1,199 @@ +package Net::DNS::RR::CAA; + +# +# $Id: CAA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::CAA - DNS CAA resource record + +=cut + + +use integer; + +use Net::DNS::Text; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + $self->{flags} = unpack "\@$offset C", $$data; + ( $self->{tag}, $offset ) = decode Net::DNS::Text( $data, $offset + 1 ); + $self->{value} = decode Net::DNS::Text( $data, $offset, $limit - $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $tag = $self->{tag}; + pack 'C a* a*', $self->flags, $tag->encode, $self->{value}->raw; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $tag = $self->{tag}; + my @rdata = ( $self->flags, $tag->string, $self->{value}->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->flags(shift); + $self->tag(shift); + $self->value(shift); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->flags(0); +} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub critical { + my $bit = 0x0080; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub tag { + my $self = shift; + + $self->{tag} = new Net::DNS::Text(shift) if scalar @_; + $self->{tag}->value if $self->{tag}; +} + + +sub value { + my $self = shift; + + $self->{value} = new Net::DNS::Text(shift) if scalar @_; + $self->{value}->value if $self->{value}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN CAA flags tag value'); + +=head1 DESCRIPTION + +Class for Certification Authority Authorization (CAA) DNS resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 flags + + $flags = $rr->flags; + $rr->flags( $flags ); + +Unsigned 8-bit number representing Boolean flags. + +=over 4 + +=item critical + + $rr->critical(1); + + if ( $rr->critical ) { + ... + } + +Issuer critical flag. + +=back + +=head2 tag + + $tag = $rr->tag; + $rr->tag( $tag ); + +The property identifier, a sequence of ASCII characters. + +Tag values may contain ASCII characters a-z, A-Z, and 0-9. +Tag values should not contain any other characters. +Matching of tag values is not case sensitive. + +=head2 value + + $value = $rr->value; + $rr->value( $value ); + +A sequence of octets representing the property value. +Property values are encoded as binary values and may employ +sub-formats. + + +=head1 COPYRIGHT + +Copyright (c)2013,2015 Dick Franks + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC6844 + +=cut diff --git a/lib/Net/DNS/RR/CDNSKEY.pm b/lib/Net/DNS/RR/CDNSKEY.pm new file mode 100644 index 0000000..b2059d3 --- /dev/null +++ b/lib/Net/DNS/RR/CDNSKEY.pm @@ -0,0 +1,99 @@ +package Net::DNS::RR::CDNSKEY; + +# +# $Id: CDNSKEY.pm 1586 2017-08-15 09:01:57Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1586 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::DNSKEY); + +=head1 NAME + +Net::DNS::RR::CDNSKEY - DNS CDNSKEY resource record + +=cut + + +use integer; + + +sub algorithm { + my ( $self, $arg ) = @_; + return $self->SUPER::algorithm($arg) if $arg; + return $self->SUPER::algorithm() unless defined $arg; + @{$self}{qw(flags protocol algorithm)} = ( 0, 3, 0 ); +} + + +sub key { + my $self = shift; + return $self->SUPER::key(@_) unless defined( $_[0] ) && length( $_[0] ) < 2; + return $self->SUPER::keybin( $_[0] ? '' : chr(0) ); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name CDNSKEY flags protocol algorithm publickey'); + +=head1 DESCRIPTION + +DNS Child DNSKEY resource record + +This is a clone of the DNSKEY record and inherits all properties of +the Net::DNS::RR::DNSKEY class. + +Please see the L perl documentation for details. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + + +=head1 COPYRIGHT + +Copyright (c)2014,2017 Dick Franks + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, RFC7344, RFC8078(erratum 5049) + +=cut diff --git a/lib/Net/DNS/RR/CDS.pm b/lib/Net/DNS/RR/CDS.pm new file mode 100644 index 0000000..b40f841 --- /dev/null +++ b/lib/Net/DNS/RR/CDS.pm @@ -0,0 +1,105 @@ +package Net::DNS::RR::CDS; + +# +# $Id: CDS.pm 1586 2017-08-15 09:01:57Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1586 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::DS); + +=head1 NAME + +Net::DNS::RR::CDS - DNS CDS resource record + +=cut + + +use integer; + + +sub algorithm { + my ( $self, $arg ) = @_; + return $self->SUPER::algorithm($arg) if $arg; + return $self->SUPER::algorithm() unless defined $arg; + @{$self}{qw(keytag algorithm digtype)} = ( 0, 0, 0 ); +} + + +sub digtype { + my ( $self, $arg ) = @_; + $self->SUPER::digtype( $arg ? $arg : () ); +} + + +sub digest { + my $self = shift; + return $self->SUPER::digest(@_) unless defined( $_[0] ) && length( $_[0] ) < 2; + return $self->SUPER::digestbin( $_[0] ? '' : chr(0) ); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name CDS keytag algorithm digtype digest'); + +=head1 DESCRIPTION + +DNS Child DS resource record + +This is a clone of the DS record and inherits all properties of +the Net::DNS::RR::DS class. + +Please see the L perl documentation for details. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + + +=head1 COPYRIGHT + +Copyright (c)2014,2017 Dick Franks + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, RFC7344, RFC8078(erratum 5049) + +=cut diff --git a/lib/Net/DNS/RR/CERT.pm b/lib/Net/DNS/RR/CERT.pm new file mode 100644 index 0000000..09e35a6 --- /dev/null +++ b/lib/Net/DNS/RR/CERT.pm @@ -0,0 +1,269 @@ +package Net::DNS::RR::CERT; + +# +# $Id: CERT.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::CERT - DNS CERT resource record + +=cut + + +use integer; + +use Carp; +use MIME::Base64; + + +my %certtype = ( + PKIX => 1, # X.509 as per PKIX + SPKI => 2, # SPKI certificate + PGP => 3, # OpenPGP packet + IPKIX => 4, # The URL of an X.509 data object + ISPKI => 5, # The URL of an SPKI certificate + IPGP => 6, # The fingerprint and URL of an OpenPGP packet + ACPKIX => 7, # Attribute Certificate + IACPKIX => 8, # The URL of an Attribute Certificate + URI => 253, # URI private + OID => 254, # OID private + ); + + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + my @algbyname = ( + 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] + 'RSAMD5' => 1, # [RFC3110][RFC4034] + 'DH' => 2, # [RFC2539] + 'DSA' => 3, # [RFC3755][RFC2536] + ## Reserved => 4, # [RFC6725] + 'RSASHA1' => 5, # [RFC3110][RFC4034] + 'DSA-NSEC3-SHA1' => 6, # [RFC5155] + 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] + 'RSASHA256' => 8, # [RFC5702] + ## Reserved => 9, # [RFC6725] + 'RSASHA512' => 10, # [RFC5702] + ## Reserved => 11, # [RFC6725] + 'ECC-GOST' => 12, # [RFC5933] + 'ECDSAP256SHA256' => 13, # [RFC6605] + 'ECDSAP384SHA384' => 14, # [RFC6605] + 'ED25519' => 15, # [RFC8080] + 'ED448' => 16, # [RFC8080] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @algbyname; + my %algbyname = @algrehash; # work around broken cperl + + sub _algbyname { + my $arg = shift; + my $key = uc $arg; # synthetic key + $key =~ s/[\W_]//g; # strip non-alphanumerics + my $val = $algbyname{$key}; + return $val if defined $val; + return $key =~ /^\d/ ? $arg : croak "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + @{$self}{qw(certtype keytag algorithm)} = unpack "\@$offset n2 C", $$data; + $self->{certbin} = substr $$data, $offset + 5, $self->{rdlength} - 5; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack "n2 C a*", $self->certtype, $self->keytag, $self->algorithm, $self->{certbin}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @base64 = split /\s+/, encode_base64( $self->{certbin} ); + my @rdata = ( $self->certtype, $self->keytag, $self->algorithm, @base64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->certtype(shift); + $self->keytag(shift); + $self->algorithm(shift); + $self->cert(@_); +} + + +sub certtype { + my $self = shift; + + return $self->{certtype} unless scalar @_; + + my $certtype = shift || 0; + return $self->{certtype} = $certtype unless $certtype =~ /\D/; + + my $typenum = $certtype{$certtype}; + $typenum || croak "unknown certtype $certtype"; + $self->{certtype} = $typenum; +} + + +sub keytag { + my $self = shift; + + $self->{keytag} = 0 + shift if scalar @_; + $self->{keytag} || 0; +} + + +sub algorithm { + my ( $self, $arg ) = @_; + + return $self->{algorithm} unless defined $arg; + return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; + $self->{algorithm} = _algbyname($arg); +} + + +sub certificate { &certbin; } + + +sub certbin { + my $self = shift; + + $self->{certbin} = shift if scalar @_; + $self->{certbin} || ""; +} + + +sub cert { + my $self = shift; + return MIME::Base64::encode( $self->certbin(), "" ) unless scalar @_; + $self->certbin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub format { &certtype; } # uncoverable pod + +sub tag { &keytag; } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN CERT certtype keytag algorithm cert'); + +=head1 DESCRIPTION + +Class for DNS Certificate (CERT) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 certtype + + $certtype = $rr->certtype; + +Returns the certtype code for the certificate (in numeric form). + +=head2 keytag + + $keytag = $rr->keytag; + $rr->keytag( $keytag ); + +Returns the key tag for the public key in the certificate + +=head2 algorithm + + $algorithm = $rr->algorithm; + +Returns the algorithm used by the certificate (in numeric form). + +=head2 certificate + +=head2 certbin + + $certbin = $rr->certbin; + $rr->certbin( $certbin ); + +Binary representation of the certificate. + +=head2 cert + + $cert = $rr->cert; + $rr->cert( $cert ); + +Base64 representation of the certificate. + + +=head1 COPYRIGHT + +Copyright (c)2002 VeriSign, Mike Schiraldi + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC4398 + +=cut diff --git a/lib/Net/DNS/RR/CNAME.pm b/lib/Net/DNS/RR/CNAME.pm new file mode 100644 index 0000000..84fb43a --- /dev/null +++ b/lib/Net/DNS/RR/CNAME.pm @@ -0,0 +1,135 @@ +package Net::DNS::RR::CNAME; + +# +# $Id: CNAME.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::CNAME - DNS CNAME resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + + $self->{cname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $cname = $self->{cname}; + $cname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $cname = $self->{cname}; + $cname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->cname(shift); +} + + +sub cname { + my $self = shift; + + $self->{cname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{cname}->name if $self->{cname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name CNAME cname'); + + $rr = new Net::DNS::RR( + name => 'alias.example.com', + type => 'CNAME', + cname => 'example.com', + ); + +=head1 DESCRIPTION + +Class for DNS Canonical Name (CNAME) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 cname + + $cname = $rr->cname; + $rr->cname( $cname ); + +A domain name which specifies the canonical or primary name for +the owner. The owner name is an alias. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2002-2003 Chris Reinhardt. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.1 + +=cut diff --git a/lib/Net/DNS/RR/CSYNC.pm b/lib/Net/DNS/RR/CSYNC.pm new file mode 100644 index 0000000..12cda42 --- /dev/null +++ b/lib/Net/DNS/RR/CSYNC.pm @@ -0,0 +1,219 @@ +package Net::DNS::RR::CSYNC; + +# +# $Id: CSYNC.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::CSYNC - DNS CSYNC resource record + +=cut + + +use integer; + +use Net::DNS::Parameters; +use Net::DNS::RR::NSEC; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + @{$self}{qw(soaserial flags)} = unpack "\@$offset Nn", $$data; + $offset += 6; + $self->{typebm} = substr $$data, $offset, $limit - $offset; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'N n a*', $self->soaserial, $self->flags, $self->{typebm}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @rdata = ( $self->soaserial, $self->flags, $self->typelist ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->soaserial(shift); + $self->flags(shift); + $self->typelist(@_); +} + + +sub soaserial { + my $self = shift; + + $self->{soaserial} = 0 + shift if scalar @_; + $self->{soaserial} || 0; +} + + +sub SOAserial {&soaserial} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub immediate { + my $bit = 0x0001; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub soaminimum { + my $bit = 0x0002; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub typelist { + &Net::DNS::RR::NSEC::typelist; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name CSYNC SOAserial flags typelist'); + +=head1 DESCRIPTION + +Class for DNSSEC CSYNC resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 SOAserial + +=head2 soaserial + + $soaserial = $rr->soaserial; + $rr->soaserial( $soaserial ); + +The SOA Serial field contains a copy of the 32-bit SOA serial number from +the child zone. + +=head2 flags + + $flags = $rr->flags; + $rr->flags( $flags ); + +The flags field contains 16 bits of boolean flags that define operations +which affect the processing of the CSYNC record. + +=over 4 + +=item immediate + + $rr->immediate(1); + + if ( $rr->immediate ) { + ... + } + +If not set, a parental agent must not process the CSYNC record until +the zone administrator approves the operation through an out-of-band +mechanism. + +=back + +=over 4 + +=item soaminimum + + $rr->soaminimum(1); + + if ( $rr->soaminimum ) { + ... + } + +If set, a parental agent querying child authoritative servers must not +act on data from zones advertising an SOA serial number less than the +SOAserial value. + +=back + +=head2 typelist + + @typelist = $rr->typelist; + $typelist = $rr->typelist; + +The type list indicates the record types to be processed by the parental +agent. When called in scalar context, the list is interpolated into a +string. + + +=head1 COPYRIGHT + +Copyright (c)2015 Dick Franks + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC7477 + +=cut diff --git a/lib/Net/DNS/RR/DHCID.pm b/lib/Net/DNS/RR/DHCID.pm new file mode 100644 index 0000000..304905f --- /dev/null +++ b/lib/Net/DNS/RR/DHCID.pm @@ -0,0 +1,188 @@ +package Net::DNS::RR::DHCID; + +# +# $Id: DHCID.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::DHCID - DNS DHCID resource record + +=cut + + +use integer; + +use MIME::Base64; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $size = $self->{rdlength} - 3; + @{$self}{qw(identifiertype digesttype digest)} = unpack "\@$offset nC a$size", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'nC a*', map $self->$_, qw(identifiertype digesttype digest); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @base64 = split /\s+/, encode_base64( $self->_encode_rdata ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + my $data = MIME::Base64::decode( join "", @_ ); + my $size = length($data) - 3; + @{$self}{qw(identifiertype digesttype digest)} = unpack "n C a$size", $data; +} + + +# +------------------+------------------------------------------------+ +# | Identifier Type | Identifier | +# | Code | | +# +------------------+------------------------------------------------+ +# | 0x0000 | The 1-octet 'htype' followed by 'hlen' octets | +# | | of 'chaddr' from a DHCPv4 client's DHCPREQUEST | +# | | [7]. | +# | 0x0001 | The data octets (i.e., the Type and | +# | | Client-Identifier fields) from a DHCPv4 | +# | | client's Client Identifier option [10]. | +# | 0x0002 | The client's DUID (i.e., the data octets of a | +# | | DHCPv6 client's Client Identifier option [11] | +# | | or the DUID field from a DHCPv4 client's | +# | | Client Identifier option [6]). | +# | 0x0003 - 0xfffe | Undefined; available to be assigned by IANA. | +# | 0xffff | Undefined; RESERVED. | +# +------------------+------------------------------------------------+ + + +sub identifiertype { + my $self = shift; + + $self->{identifiertype} = 0 + shift if scalar @_; + $self->{identifiertype} || 0; +} + + +sub digesttype { + my $self = shift; + + $self->{digesttype} = 0 + shift if scalar @_; + $self->{digesttype} || 0; +} + + +sub digest { + my $self = shift; + + $self->{digest} = shift if scalar @_; + $self->{digest} || ""; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('client.example.com. DHCID ( AAAB + xLmlskllE0MVjd57zHcWmEH3pCQ6VytcKD//7es/deY='); + + $rr = new Net::DNS::RR( + name => 'client.example.com', + type => 'DHCID', + digest => 'ObfuscatedIdentityData', + digesttype => 1, + identifiertype => 2, + ); + +=head1 DESCRIPTION + +DNS RR for Encoding DHCP Information (DHCID) + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 identifiertype + + $identifiertype = $rr->identifiertype; + $rr->identifiertype( $identifiertype ); + +The 16-bit identifier type describes the form of host identifier +used to construct the DHCP identity information. + +=head2 digesttype + + $digesttype = $rr->digesttype; + $rr->digesttype( $digesttype ); + +The 8-bit digest type number describes the message-digest +algorithm used to obfuscate the DHCP identity information. + +=head2 digest + + $digest = $rr->digest; + $rr->digest( $digest ); + +Binary representation of the digest of DHCP identity information. + + +=head1 COPYRIGHT + +Copyright (c)2009 Olaf Kolkman, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC4701 + +=cut diff --git a/lib/Net/DNS/RR/DLV.pm b/lib/Net/DNS/RR/DLV.pm new file mode 100644 index 0000000..bba13f7 --- /dev/null +++ b/lib/Net/DNS/RR/DLV.pm @@ -0,0 +1,81 @@ +package Net::DNS::RR::DLV; + +# +# $Id: DLV.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::DS); + +=head1 NAME + +Net::DNS::RR::DLV - DNS DLV resource record + +=cut + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name DLV keytag algorithm digtype digest'); + +=head1 DESCRIPTION + +DNS DLV resource record + +This is a clone of the DS record and inherits all properties of +the Net::DNS::RR::DS class. + +Please see the L documentation for details. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + + +=head1 COPYRIGHT + +Copyright (c)2005 Olaf Kolkman, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, RFC4431 + +=cut diff --git a/lib/Net/DNS/RR/DNAME.pm b/lib/Net/DNS/RR/DNAME.pm new file mode 100644 index 0000000..5bd42fa --- /dev/null +++ b/lib/Net/DNS/RR/DNAME.pm @@ -0,0 +1,130 @@ +package Net::DNS::RR::DNAME; + +# +# $Id: DNAME.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::DNAME - DNS DNAME resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + + $self->{target} = decode Net::DNS::DomainName2535(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $target = $self->{target}; + $target->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $target = $self->{target}; + $target->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->target(shift); +} + + +sub target { + my $self = shift; + + $self->{target} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{target}->name if $self->{target}; +} + + +sub dname { ⌖ } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name DNAME target'); + +=head1 DESCRIPTION + +Class for DNS Non-Terminal Name Redirection (DNAME) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 target + + $target = $rr->target; + $rr->target( $target ); + +Redirection target domain name which is to be substituted +for its owner as a suffix of a domain name. + + +=head1 COPYRIGHT + +Copyright (c)2002 Andreas Gustafsson. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC6672 + +=cut diff --git a/lib/Net/DNS/RR/DNSKEY.pm b/lib/Net/DNS/RR/DNSKEY.pm new file mode 100644 index 0000000..be212e7 --- /dev/null +++ b/lib/Net/DNS/RR/DNSKEY.pm @@ -0,0 +1,426 @@ +package Net::DNS::RR::DNSKEY; + +# +# $Id: DNSKEY.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::DNSKEY - DNS DNSKEY resource record + +=cut + + +use integer; + +use Carp; + +use constant BASE64 => defined eval 'require MIME::Base64'; + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + my @algbyname = ( + 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] + 'RSAMD5' => 1, # [RFC3110][RFC4034] + 'DH' => 2, # [RFC2539] + 'DSA' => 3, # [RFC3755][RFC2536] + ## Reserved => 4, # [RFC6725] + 'RSASHA1' => 5, # [RFC3110][RFC4034] + 'DSA-NSEC3-SHA1' => 6, # [RFC5155] + 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] + 'RSASHA256' => 8, # [RFC5702] + ## Reserved => 9, # [RFC6725] + 'RSASHA512' => 10, # [RFC5702] + ## Reserved => 11, # [RFC6725] + 'ECC-GOST' => 12, # [RFC5933] + 'ECDSAP256SHA256' => 13, # [RFC6605] + 'ECDSAP384SHA384' => 14, # [RFC6605] + 'ED25519' => 15, # [RFC8080] + 'ED448' => 16, # [RFC8080] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @algbyname; + my %algbyname = @algrehash; # work around broken cperl + + sub _algbyname { + my $arg = shift; + my $key = uc $arg; # synthetic key + $key =~ s/[\W_]//g; # strip non-alphanumerics + my $val = $algbyname{$key}; + return $val if defined $val; + return $key =~ /^\d/ ? $arg : croak "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $rdata = substr $$data, $offset, $self->{rdlength}; + $self->{keybin} = unpack '@4 a*', $rdata; + @{$self}{qw(flags protocol algorithm)} = unpack 'n C*', $rdata; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n C2 a*', @{$self}{qw(flags protocol algorithm keybin)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $algorithm = $self->{algorithm}; + $self->_annotation( 'Key ID =', $self->keytag ) if $algorithm; + return $self->SUPER::_format_rdata() unless BASE64; + my @base64 = split /\s+/, MIME::Base64::encode( $self->{keybin} ) || '-'; + my @rdata = ( @{$self}{qw(flags protocol)}, $algorithm, @base64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + my $flags = shift; ## avoid destruction by CDNSKEY algorithm(0) + $self->protocol(shift); + $self->algorithm(shift); + $self->flags($flags); + $self->key(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->algorithm(1); + $self->flags(256); + $self->protocol(3); +} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub zone { + my $bit = 0x0100; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub revoke { + my $bit = 0x0080; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub sep { + my $bit = 0x0001; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub protocol { + my $self = shift; + + $self->{protocol} = 0 + shift if scalar @_; + $self->{protocol} || 0; +} + + +sub algorithm { + my ( $self, $arg ) = @_; + + unless ( ref($self) ) { ## class method or simple function + my $argn = pop; + return $argn =~ /\D/ ? _algbyname($argn) : _algbyval($argn); + } + + return $self->{algorithm} unless defined $arg; + return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; + $self->{algorithm} = _algbyname($arg) || die _algbyname('') # disallow algorithm(0) +} + + +sub key { + my $self = shift; + return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; + $self->keybin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub keybin { + my $self = shift; + + $self->{keybin} = shift if scalar @_; + $self->{keybin} || ""; +} + + +sub publickey { shift->key(@_); } + + +sub privatekeyname { + my $self = shift; + my $name = $self->signame; + sprintf 'K%s+%03d+%05d.private', $name, $self->algorithm, $self->keytag; +} + + +sub signame { + my $self = shift; + my $name = lc $self->{owner}->fqdn; +} + + +sub keylength { + my $self = shift; + + my $keybin = $self->keybin || return undef; + + local $_ = _algbyval( $self->{algorithm} ); + + if (/^RSA/) { + + # Modulus length, see RFC 3110 + if ( my $exp_length = unpack 'C', $keybin ) { + + return ( length($keybin) - $exp_length - 1 ) << 3; + + } else { + $exp_length = unpack 'x n', $keybin; + return ( length($keybin) - $exp_length - 3 ) << 3; + } + + } elsif (/^DSA/) { + + # Modulus length, see RFC 2536 + my $T = unpack 'C', $keybin; + return ( $T << 6 ) + 512; + } + + length($keybin) << 2; ## ECDSA / ECC-GOST +} + + +sub keytag { + my $self = shift; + + my $keybin = $self->keybin || return 0; + + # RFC4034 Appendix B.1: most significant 16 bits of least significant 24 bits + return unpack 'n', substr $keybin, -3 if $self->{algorithm} == 1; + + # RFC4034 Appendix B + my $od = length($keybin) & 1; + my $rd = pack "n C2 a* x$od", @{$self}{qw(flags protocol algorithm)}, $keybin; + my $ac = 0; + $ac += $_ for unpack 'n*', $rd; + $ac += ( $ac >> 16 ); + return $ac & 0xFFFF; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name DNSKEY flags protocol algorithm publickey'); + +=head1 DESCRIPTION + +Class for DNSSEC Key (DNSKEY) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 flags + + $flags = $rr->flags; + $rr->flags( $flags ); + +Unsigned 16-bit number representing Boolean flags. + +=over 4 + +=item zone + + $rr->zone(1); + + if ( $rr->zone ) { + ... + } + +Boolean Zone flag. + +=back + +=over 4 + +=item revoke + + $rr->revoke(1); + + if ( $rr->revoke ) { + ... + } + +Boolean Revoke flag. + +=back + +=over 4 + +=item sep + + $rr->sep(1); + + if ( $rr->sep ) { + ... + } + +Boolean Secure Entry Point flag. + +=back + +=head2 protocol + + $protocol = $rr->protocol; + $rr->protocol( $protocol ); + +The 8-bit protocol number. This field MUST have value 3. + +=head2 algorithm + + $algorithm = $rr->algorithm; + $rr->algorithm( $algorithm ); + +The 8-bit algorithm number describes the public key algorithm. + +algorithm() may also be invoked as a class method or simple function +to perform mnemonic and numeric code translation. + +=head2 publickey + +=head2 key + + $key = $rr->key; + $rr->key( $key ); + +Base64 representation of the public key material. + +=head2 keybin + + $keybin = $rr->keybin; + $rr->keybin( $keybin ); + +Opaque octet string representing the public key material. + +=head2 privatekeyname + + $privatekeyname = $rr->privatekeyname; + +Returns the name of the privatekey as it would be generated by +the BIND dnssec-keygen program. The format of that name being: + + K++.private + +=head2 signame + +Returns the canonical signer name of the privatekey. + +=head2 keylength + +Returns the length (in bits) of the modulus calculated from the key text. + +=head2 keytag + + print "keytag = ", $rr->keytag, "\n"; + +Returns the 16-bit numerical key tag of the key. (RFC2535 4.1.6) + + +=head1 COPYRIGHT + +Copyright (c)2003-2005 RIPE NCC. Author Olaf M. Kolkman + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC4034, RFC3755 + +L + +=cut diff --git a/lib/Net/DNS/RR/DS.pm b/lib/Net/DNS/RR/DS.pm new file mode 100644 index 0000000..d8306c1 --- /dev/null +++ b/lib/Net/DNS/RR/DS.pm @@ -0,0 +1,406 @@ +package Net::DNS::RR::DS; + +# +# $Id: DS.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::DS - DNS DS resource record + +=cut + + +use integer; + +use Carp; + +use constant BABBLE => defined eval 'require Digest::BubbleBabble'; + +eval 'require Digest::SHA'; ## optional for simple Net::DNS RR +eval 'require Digest::GOST'; +eval 'require Digest::GOST::CryptoPro'; + +my %digest = ( + '1' => ['Digest::SHA', 1], + '2' => ['Digest::SHA', 256], + '3' => ['Digest::GOST::CryptoPro'], + '4' => ['Digest::SHA', 384], + ); + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + my @algbyname = ( + 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] + 'RSAMD5' => 1, # [RFC3110][RFC4034] + 'DH' => 2, # [RFC2539] + 'DSA' => 3, # [RFC3755][RFC2536] + ## Reserved => 4, # [RFC6725] + 'RSASHA1' => 5, # [RFC3110][RFC4034] + 'DSA-NSEC3-SHA1' => 6, # [RFC5155] + 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] + 'RSASHA256' => 8, # [RFC5702] + ## Reserved => 9, # [RFC6725] + 'RSASHA512' => 10, # [RFC5702] + ## Reserved => 11, # [RFC6725] + 'ECC-GOST' => 12, # [RFC5933] + 'ECDSAP256SHA256' => 13, # [RFC6605] + 'ECDSAP384SHA384' => 14, # [RFC6605] + 'ED25519' => 15, # [RFC8080] + 'ED448' => 16, # [RFC8080] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @algbyname; + my %algbyname = @algrehash; # work around broken cperl + + sub _algbyname { + my $arg = shift; + my $key = uc $arg; # synthetic key + $key =~ s/[\W_]//g; # strip non-alphanumerics + my $val = $algbyname{$key}; + return $val if defined $val; + return $key =~ /^\d/ ? $arg : croak "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + +# +# source: http://www.iana.org/assignments/ds-rr-types +# +{ + my @digestbyname = ( + 'SHA-1' => 1, # RFC3658 + 'SHA-256' => 2, # RFC4509 + 'GOST-R-34.11-94' => 3, # RFC5933 + 'SHA-384' => 4, # RFC6605 + ); + + my @digestalias = ( + 'SHA' => 1, + 'GOST' => 3, + ); + + my %digestbyval = reverse @digestbyname; + + my @digestrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @digestbyname; + my %digestbyname = ( @digestalias, @digestrehash ); # work around broken cperl + + sub _digestbyname { + my $arg = shift; + my $key = uc $arg; # synthetic key + $key =~ s/[\W_]//g; # strip non-alphanumerics + my $val = $digestbyname{$key}; + return $val if defined $val; + return $key =~ /^\d/ ? $arg : croak "unknown digest type $arg"; + } + + sub _digestbyval { + my $value = shift; + $digestbyval{$value} || return $value; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $rdata = substr $$data, $offset, $self->{rdlength}; + $self->{digestbin} = unpack '@4 a*', $rdata; + @{$self}{qw(keytag algorithm digtype)} = unpack 'n C*', $rdata; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n C2 a*', @{$self}{qw(keytag algorithm digtype digestbin)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->_annotation( $self->babble ) if BABBLE && $self->{algorithm}; + my @digest = split /(\S{64})/, $self->digest || '-'; + my @rdata = ( @{$self}{qw(keytag algorithm digtype)}, @digest ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + my $keytag = shift; ## avoid destruction by CDS algorithm(0) + $self->algorithm(shift); + $self->keytag($keytag); + $self->digtype(shift); + $self->digest(@_); +} + + +sub keytag { + my $self = shift; + + $self->{keytag} = 0 + shift if scalar @_; + $self->{keytag} || 0; +} + + +sub algorithm { + my ( $self, $arg ) = @_; + + unless ( ref($self) ) { ## class method or simple function + my $argn = pop; + return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); + } + + return $self->{algorithm} unless defined $arg; + return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; + $self->{algorithm} = _algbyname($arg) || die _algbyname('') # disallow algorithm(0) +} + + +sub digtype { + my ( $self, $arg ) = @_; + + unless ( ref($self) ) { ## class method or simple function + my $argn = pop; + return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn); + } + + return $self->{digtype} unless defined $arg; + return _digestbyval( $self->{digtype} ) if uc($arg) eq 'MNEMONIC'; + $self->{digtype} = _digestbyname($arg) || die _digestbyname('') # disallow digtype(0) +} + + +sub digest { + my $self = shift; + return unpack "H*", $self->digestbin() unless scalar @_; + $self->digestbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub digestbin { + my $self = shift; + + $self->{digestbin} = shift if scalar @_; + $self->{digestbin} || ""; +} + + +sub babble { + return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->digestbin ) : ''; +} + + +sub create { + my $class = shift; + my $keyrr = shift; + my %args = $keyrr->ttl ? ( ttl => $keyrr->ttl, @_ ) : (@_); + + my ($type) = reverse split '::', $class; + + my $kname = $keyrr->name; + my $flags = $keyrr->flags; + croak "Unable to create $type record for non-DNSSEC key" unless $keyrr->protocol == 3; + croak "Unable to create $type record for non-authentication key" if $flags & 0x8000; + croak "Unable to create $type record for non-ZONE key" unless ( $flags & 0x300 ) == 0x100; + + my $self = new Net::DNS::RR( + name => $kname, # per definition, same as keyrr + type => $type, + class => $keyrr->class, + keytag => $keyrr->keytag, + algorithm => $keyrr->algorithm, + digtype => 1, # SHA1 by default + %args + ); + + my $owner = $self->{owner}->encode(); + my $data = pack 'a* a*', $owner, $keyrr->_encode_rdata; + + my $arglist = $digest{$self->digtype}; + croak join ' ', 'digtype', $self->digtype('MNEMONIC'), 'not supported' unless $arglist; + my ( $object, @argument ) = @$arglist; + my $hash = $object->new(@argument); + $hash->add($data); + $self->digestbin( $hash->digest ); + + return $self; +} + + +sub verify { + my ( $self, $key ) = @_; + my $verify = create Net::DNS::RR::DS( $key, ( digtype => $self->digtype ) ); + return $verify->digestbin eq $self->digestbin; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name DS keytag algorithm digtype digest'); + + use Net::DNS::SEC; + $ds = create Net::DNS::RR::DS( + $dnskeyrr, + digtype => 'SHA256', + ttl => 3600 + ); + +=head1 DESCRIPTION + +Class for DNS Delegation Signer (DS) resource record. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 keytag + + $keytag = $rr->keytag; + $rr->keytag( $keytag ); + +The 16-bit numerical key tag of the key. (RFC2535 4.1.6) + +=head2 algorithm + + $algorithm = $rr->algorithm; + $rr->algorithm( $algorithm ); + +Decimal representation of the 8-bit algorithm field. + +algorithm() may also be invoked as a class method or simple function +to perform mnemonic and numeric code translation. + +=head2 digtype + + $digtype = $rr->digtype; + $rr->digtype( $digtype ); + +Decimal representation of the 8-bit digest type field. + +digtype() may also be invoked as a class method or simple function +to perform mnemonic and numeric code translation. + +=head2 digest + + $digest = $rr->digest; + $rr->digest( $digest ); + +Hexadecimal representation of the digest over the label and key. + +=head2 digestbin + + $digestbin = $rr->digestbin; + $rr->digestbin( $digestbin ); + +Binary representation of the digest over the label and key. + +=head2 babble + + print $rr->babble; + +The babble() method returns the 'BubbleBabble' representation of the +digest if the Digest::BubbleBabble package is available, otherwise +an empty string is returned. + +BubbleBabble represents a message digest as a string of plausible +words, to make the digest easier to verify. The "words" are not +necessarily real words, but they look more like words than a string +of hex characters. + +The 'BubbleBabble' string is appended as a comment when the string +method is called. + +=head2 create + + use Net::DNS::SEC; + + $dsrr = create Net::DNS::RR::DS($keyrr, digtype => 'SHA-256' ); + $keyrr->print; + $dsrr->print; + +This constructor takes a key object as argument and will return the +corresponding DS RR object. + +The digest type defaults to SHA-1. + +=head2 verify + + $verify = $dsrr->verify($keyrr); + +The boolean verify method will return true if the hash over the key +RR provided as the argument conforms to the data in the DS itself +i.e. the DS points to the DNSKEY from the argument. + + +=head1 COPYRIGHT + +Copyright (c)2001-2005 RIPE NCC. Author Olaf M. Kolkman + +Portions Copyright (c)2013 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC4034, RFC3658 + +L, +L + +=cut diff --git a/lib/Net/DNS/RR/EUI48.pm b/lib/Net/DNS/RR/EUI48.pm new file mode 100644 index 0000000..f830984 --- /dev/null +++ b/lib/Net/DNS/RR/EUI48.pm @@ -0,0 +1,133 @@ +package Net::DNS::RR::EUI48; + +# +# $Id: EUI48.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::EUI48 - DNS EUI48 resource record + +=cut + + +use integer; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + $self->{address} = unpack "\@$offset a6", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a6', $self->{address}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->address; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +sub address { + my ( $self, $address ) = @_; + $self->{address} = pack 'C6', map hex($_), split /[:-]/, $address if $address; + join '-', unpack 'H2H2H2H2H2H2', $self->{address} if defined wantarray; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN EUI48 address'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'EUI48', + address => '00-00-5e-00-53-2a' + ); + +=head1 DESCRIPTION + +DNS resource records for 48-bit Extended Unique Identifier (EUI48). + +The EUI48 resource record is used to represent IEEE Extended Unique +Identifiers used in various layer-2 networks, ethernet for example. + +EUI48 addresses SHOULD NOT be published in the public DNS. +RFC7043 describes potentially severe privacy implications resulting +from indiscriminate publication of link-layer addresses in the DNS. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 address +The address field is a 6-octet layer-2 address in network byte order. + +The presentation format is hexadecimal separated by "-". + + +=head1 COPYRIGHT + +Copyright (c)2013 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC7043 + +=cut diff --git a/lib/Net/DNS/RR/EUI64.pm b/lib/Net/DNS/RR/EUI64.pm new file mode 100644 index 0000000..22586a7 --- /dev/null +++ b/lib/Net/DNS/RR/EUI64.pm @@ -0,0 +1,133 @@ +package Net::DNS::RR::EUI64; + +# +# $Id: EUI64.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::EUI64 - DNS EUI64 resource record + +=cut + + +use integer; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + $self->{address} = unpack "\@$offset a8", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a8', $self->{address}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->address; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +sub address { + my ( $self, $address ) = @_; + $self->{address} = pack 'C8', map hex($_), split /[:-]/, $address if $address; + join '-', unpack 'H2H2H2H2H2H2H2H2', $self->{address} if defined wantarray; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN EUI64 address'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'EUI64', + address => '00-00-5e-ef-10-00-00-2a' + ); + +=head1 DESCRIPTION + +DNS resource records for 64-bit Extended Unique Identifier (EUI64). + +The EUI64 resource record is used to represent IEEE Extended Unique +Identifiers used in various layer-2 networks, ethernet for example. + +EUI64 addresses SHOULD NOT be published in the public DNS. +RFC7043 describes potentially severe privacy implications resulting +from indiscriminate publication of link-layer addresses in the DNS. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 address +The address field is a 8-octet layer-2 address in network byte order. + +The presentation format is hexadecimal separated by "-". + + +=head1 COPYRIGHT + +Copyright (c)2013 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC7043 + +=cut diff --git a/lib/Net/DNS/RR/GPOS.pm b/lib/Net/DNS/RR/GPOS.pm new file mode 100644 index 0000000..ac64180 --- /dev/null +++ b/lib/Net/DNS/RR/GPOS.pm @@ -0,0 +1,181 @@ +package Net::DNS::RR::GPOS; + +# +# $Id: GPOS.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::GPOS - DNS GPOS resource record + +=cut + + +use integer; + +use Carp; +use Net::DNS::Text; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + ( $self->{latitude}, $offset ) = decode Net::DNS::Text( $data, $offset ) if $offset < $limit; + ( $self->{longitude}, $offset ) = decode Net::DNS::Text( $data, $offset ) if $offset < $limit; + ( $self->{altitude}, $offset ) = decode Net::DNS::Text( $data, $offset ) if $offset < $limit; + croak('corrupt GPOS data') unless $offset == $limit; # more or less FUBAR +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + return '' unless defined $self->{altitude}; + join '', map $self->{$_}->encode, qw(latitude longitude altitude); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + return '' unless defined $self->{altitude}; + join ' ', map $self->{$_}->string, qw(latitude longitude altitude); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->latitude(shift); + $self->longitude(shift); + $self->altitude(shift); + die 'too many arguments for GPOS' if scalar @_; +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->_parse_rdata(qw(0.0 0.0 0.0)); +} + + +sub latitude { + my $self = shift; + $self->{latitude} = _fp2text(shift) if scalar @_; + _text2fp( $self->{latitude} ) if defined wantarray; +} + + +sub longitude { + my $self = shift; + $self->{longitude} = _fp2text(shift) if scalar @_; + _text2fp( $self->{longitude} ) if defined wantarray; +} + + +sub altitude { + my $self = shift; + $self->{altitude} = _fp2text(shift) if scalar @_; + _text2fp( $self->{altitude} ) if defined wantarray; +} + + +######################################## + +sub _fp2text { + return new Net::DNS::Text( sprintf( '%1.10g', shift ) ); +} + +sub _text2fp { + no integer; + return 0.0 + shift->value; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name GPOS latitude longitude altitude'); + +=head1 DESCRIPTION + +Class for DNS Geographical Position (GPOS) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 latitude + + $latitude = $rr->latitude; + $rr->latitude( $latitude ); + +Floating-point representation of latitude, in degrees. + +=head2 longitude + + $longitude = $rr->longitude; + $rr->longitude( $longitude ); + +Floating-point representation of longitude, in degrees. + +=head2 altitude + + $altitude = $rr->altitude; + $rr->altitude( $altitude ); + +Floating-point representation of altitude, in metres. + + +=head1 COPYRIGHT + +Copyright (c)1997,1998 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1712 + +=cut diff --git a/lib/Net/DNS/RR/HINFO.pm b/lib/Net/DNS/RR/HINFO.pm new file mode 100644 index 0000000..c67583d --- /dev/null +++ b/lib/Net/DNS/RR/HINFO.pm @@ -0,0 +1,142 @@ +package Net::DNS::RR::HINFO; + +# +# $Id: HINFO.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::HINFO - DNS HINFO resource record + +=cut + + +use integer; + +use Net::DNS::Text; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + ( $self->{cpu}, $offset ) = decode Net::DNS::Text( $data, $offset ); + ( $self->{os}, $offset ) = decode Net::DNS::Text( $data, $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + join '', $self->{cpu}->encode, $self->{os}->encode; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->{cpu}->string, $self->{os}->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->cpu(shift); + $self->os(@_); +} + + +sub cpu { + my $self = shift; + + $self->{cpu} = new Net::DNS::Text(shift) if scalar @_; + $self->{cpu}->value if $self->{cpu}; +} + + +sub os { + my $self = shift; + + $self->{os} = new Net::DNS::Text(shift) if scalar @_; + $self->{os}->value if $self->{os}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name HINFO cpu os'); + +=head1 DESCRIPTION + +Class for DNS Hardware Information (HINFO) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 cpu + + $cpu = $rr->cpu; + $rr->cpu( $cpu ); + +Returns the CPU type for this RR. + +=head2 os + + $os = $rr->os; + $rr->os( $os ); + +Returns the operating system type for this RR. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.2 + +=cut diff --git a/lib/Net/DNS/RR/HIP.pm b/lib/Net/DNS/RR/HIP.pm new file mode 100644 index 0000000..48cedde --- /dev/null +++ b/lib/Net/DNS/RR/HIP.pm @@ -0,0 +1,228 @@ +package Net::DNS::RR::HIP; + +# +# $Id: HIP.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::HIP - DNS HIP resource record + +=cut + + +use integer; + +use Carp; +use Net::DNS::DomainName; +use MIME::Base64; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my ( $hitlen, $pklen ) = unpack "\@$offset Cxn", $$data; + @{$self}{qw(pkalgorithm hitbin keybin)} = unpack "\@$offset xCxx a$hitlen a$pklen", $$data; + + my $limit = $offset + $self->{rdlength}; + $offset += 4 + $hitlen + $pklen; + $self->{servers} = []; + while ( $offset < $limit ) { + my $item; + ( $item, $offset ) = decode Net::DNS::DomainName( $data, $offset ); + push @{$self->{servers}}, $item; + } + croak('corrupt HIP data') unless $offset == $limit; # more or less FUBAR +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $hit = $self->hitbin; + my $key = $self->keybin; + my $nos = pack 'C2n a* a*', length($hit), $self->pkalgorithm, length($key), $hit, $key; + join '', $nos, map $_->encode, @{$self->{servers}}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $base64 = encode_base64( $self->keybin, '' ); + my @server = map $_->string, @{$self->{servers}}; + my @rdata = ( $self->pkalgorithm, $self->hit, $base64, @server ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach (qw(pkalgorithm hit key)) { $self->$_(shift) } + $self->servers(@_); +} + + +sub pkalgorithm { + my $self = shift; + + $self->{pkalgorithm} = 0 + shift if scalar @_; + $self->{pkalgorithm} || 0; +} + + +sub hit { + my $self = shift; + return unpack "H*", $self->hitbin() unless scalar @_; + $self->hitbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub hitbin { + my $self = shift; + + $self->{hitbin} = shift if scalar @_; + $self->{hitbin} || ""; +} + + +sub key { + my $self = shift; + return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; + $self->keybin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub keybin { + my $self = shift; + + $self->{keybin} = shift if scalar @_; + $self->{keybin} || ""; +} + + +sub pubkey { &key; } + +sub servers { + my $self = shift; + + my $servers = $self->{servers} ||= []; + @$servers = map Net::DNS::DomainName->new($_), @_ if scalar @_; + return map $_->name, @$servers if defined wantarray; +} + +sub rendezvousservers { ## historical + my @servers = &servers; # uncoverable pod + \@servers; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN HIP algorithm hit key servers'); + +=head1 DESCRIPTION + +Class for DNS Host Identity Protocol (HIP) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 pkalgorithm + + $pkalgorithm = $rr->pkalgorithm; + $rr->pkalgorithm( $pkalgorithm ); + +The PK algorithm field indicates the public key cryptographic +algorithm and the implied public key field format. +The values are those defined for the IPSECKEY algorithm type [RFC4025]. + +=head2 hit + + $hit = $rr->hit; + $rr->hit( $hit ); + +The hexadecimal representation of the host identity tag. + +=head2 hitbin + + $hitbin = $rr->hitbin; + $rr->hitbin( $hitbin ); + +The binary representation of the host identity tag. + +=head2 pubkey + +=head2 key + + $key = $rr->key; + $rr->key( $key ); + +The hexadecimal representation of the public key. + +=head2 keybin + + $keybin = $rr->keybin; + $rr->keybin( $keybin ); + +The binary representation of the public key. + +=head2 servers + + @servers = $rr->servers; + +Optional list of domain names of rendezvous servers. + + +=head1 COPYRIGHT + +Copyright (c)2009 Olaf Kolkman, NLnet Labs + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC8005 + +=cut diff --git a/lib/Net/DNS/RR/IPSECKEY.pm b/lib/Net/DNS/RR/IPSECKEY.pm new file mode 100644 index 0000000..e55de0e --- /dev/null +++ b/lib/Net/DNS/RR/IPSECKEY.pm @@ -0,0 +1,301 @@ +package Net::DNS::RR::IPSECKEY; + +# +# $Id: IPSECKEY.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::IPSECKEY - DNS IPSECKEY resource record + +=cut + + +use integer; + +use Carp; +use MIME::Base64; + +use Net::DNS::DomainName; +use Net::DNS::RR::A; +use Net::DNS::RR::AAAA; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + + @{$self}{qw(precedence gatetype algorithm)} = unpack "\@$offset C3", $$data; + $offset += 3; + + my $gatetype = $self->{gatetype}; + if ( not $gatetype ) { + $self->{gateway} = undef; # no gateway + + } elsif ( $gatetype == 1 ) { + $self->{gateway} = unpack "\@$offset a4", $$data; + $offset += 4; + + } elsif ( $gatetype == 2 ) { + $self->{gateway} = unpack "\@$offset a16", $$data; + $offset += 16; + + } elsif ( $gatetype == 3 ) { + my $name; + ( $name, $offset ) = decode Net::DNS::DomainName( $data, $offset ); + $self->{gateway} = $name; + + } else { + die "unknown gateway type ($gatetype)"; + } + + $self->keybin( substr $$data, $offset, $limit - $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $gatetype = $self->gatetype; + my $gateway = $self->{gateway}; + my $precedence = $self->precedence; + my $algorithm = $self->algorithm; + my $keybin = $self->keybin; + + if ( not $gatetype ) { + return pack 'C3 a*', $precedence, $gatetype, $algorithm, $keybin; + + } elsif ( $gatetype == 1 ) { + return pack 'C3 a4 a*', $precedence, $gatetype, $algorithm, $gateway, $keybin; + + } elsif ( $gatetype == 2 ) { + return pack 'C3 a16 a*', $precedence, $gatetype, $algorithm, $gateway, $keybin; + + } elsif ( $gatetype == 3 ) { + my $namebin = $gateway->encode; + return pack 'C3 a* a*', $precedence, $gatetype, $algorithm, $namebin, $keybin; + } + die "unknown gateway type ($gatetype)"; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @params = map $self->$_, qw(precedence gatetype algorithm); + my @base64 = split /\s+/, encode_base64( $self->keybin ); + my @rdata = ( @params, $self->gateway, @base64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach (qw(precedence gatetype algorithm gateway)) { $self->$_(shift) } + $self->key(@_); +} + + +sub precedence { + my $self = shift; + + $self->{precedence} = 0 + shift if scalar @_; + $self->{precedence} || 0; +} + + +sub gatetype { + return shift->{gatetype} || 0; +} + + +sub algorithm { + my $self = shift; + + $self->{algorithm} = 0 + shift if scalar @_; + $self->{algorithm} || 0; +} + + +sub gateway { + my $self = shift; + + for (@_) { + /^\.*$/ && do { + $self->{gatetype} = 0; + $self->{gateway} = undef; # no gateway + last; + }; + /:.*:/ && do { + $self->{gatetype} = 2; + $self->{gateway} = Net::DNS::RR::AAAA::address( {}, $_ ); + last; + }; + /\.\d+$/ && do { + $self->{gatetype} = 1; + $self->{gateway} = Net::DNS::RR::A::address( {}, $_ ); + last; + }; + /\..+/ && do { + $self->{gatetype} = 3; + $self->{gateway} = new Net::DNS::DomainName($_); + last; + }; + croak "unrecognised gateway type"; + } + + if ( defined wantarray ) { + my $gatetype = $self->{gatetype}; + return wantarray ? '.' : undef unless $gatetype; + my $gateway = $self->{gateway}; + for ($gatetype) { + /^1$/ && return Net::DNS::RR::A::address( {address => $gateway} ); + /^2$/ && return Net::DNS::RR::AAAA::address( {address => $gateway} ); + /^3$/ && return wantarray ? $gateway->string : $gateway->name; + die "unknown gateway type ($gatetype)"; + } + } +} + + +sub key { + my $self = shift; + return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; + $self->keybin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub keybin { + my $self = shift; + + $self->{keybin} = shift if scalar @_; + $self->{keybin} || ""; +} + + +sub pubkey { &key; } + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IPSECKEY precedence gatetype algorithm gateway key'); + +=head1 DESCRIPTION + +DNS IPSEC Key Storage (IPSECKEY) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 precedence + + $precedence = $rr->precedence; + $rr->precedence( $precedence ); + +This is an 8-bit precedence for this record. Gateways listed in +IPSECKEY records with lower precedence are to be attempted first. + +=head2 gatetype + + $gatetype = $rr->gatetype; + +The gateway type field indicates the format of the information that is +stored in the gateway field. + +=head2 algorithm + + $algorithm = $rr->algorithm; + $rr->algorithm( $algorithm ); + +The algorithm type field identifies the public keys cryptographic +algorithm and determines the format of the public key field. + +=head2 gateway + + $gateway = $rr->gateway; + $rr->gateway( $gateway ); + +The gateway field indicates a gateway to which an IPsec tunnel may be +created in order to reach the entity named by this resource record. + +=head2 pubkey + +=head2 key + + $key = $rr->key; + $rr->key( $key ); + +Base64 representation of the optional public key block for the resource record. + +=head2 keybin + + $keybin = $rr->keybin; + $rr->keybin( $keybin ); + +Binary representation of the public key block for the resource record. + + +=head1 COPYRIGHT + +Copyright (c)2007 Olaf Kolkman, NLnet Labs. + +Portions Copyright (c)2012,2015 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC4025 + +=cut diff --git a/lib/Net/DNS/RR/ISDN.pm b/lib/Net/DNS/RR/ISDN.pm new file mode 100644 index 0000000..23d7e01 --- /dev/null +++ b/lib/Net/DNS/RR/ISDN.pm @@ -0,0 +1,158 @@ +package Net::DNS::RR::ISDN; + +# +# $Id: ISDN.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::ISDN - DNS ISDN resource record + +=cut + + +use integer; + +use Net::DNS::Text; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + ( $self->{address}, $offset ) = decode Net::DNS::Text( $data, $offset ); + ( $self->{sa}, $offset ) = decode Net::DNS::Text( $data, $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $address = $self->{address}; + join '', $address->encode, $self->{sa}->encode; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $address = $self->{address}; + join ' ', $address->string, $self->{sa}->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); + $self->sa(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->sa(''); +} + + +sub address { + my $self = shift; + + $self->{address} = new Net::DNS::Text(shift) if scalar @_; + $self->{address}->value if $self->{address}; +} + + +sub sa { + my $self = shift; + + $self->{sa} = new Net::DNS::Text(shift) if scalar @_; + $self->{sa}->value if $self->{sa}; +} + + +sub ISDNaddress { &address; } + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name ISDN ISDNaddress sa'); + +=head1 DESCRIPTION + +Class for DNS ISDN resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 ISDNaddress + +=head2 address + + $address = $rr->address; + $rr->address( $address ); + +The ISDN-address is a string of characters, normally decimal +digits, beginning with the E.163 country code and ending with +the DDI if any. + +=head2 sa + + $sa = $rr->sa; + $rr->sa( $sa ); + +The optional subaddress (SA) is a string of hexadecimal digits. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1183 Section 3.2 + +=cut diff --git a/lib/Net/DNS/RR/KEY.pm b/lib/Net/DNS/RR/KEY.pm new file mode 100644 index 0000000..d7fee0b --- /dev/null +++ b/lib/Net/DNS/RR/KEY.pm @@ -0,0 +1,90 @@ +package Net::DNS::RR::KEY; + +# +# $Id: KEY.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::DNSKEY); + +=head1 NAME + +Net::DNS::RR::KEY - DNS KEY resource record + +=cut + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->algorithm(1); + $self->flags(0); + $self->protocol(3); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name KEY flags protocol algorithm publickey'); + +=head1 DESCRIPTION + +DNS KEY resource record + +This is a clone of the DNSKEY record and inherits all properties of +the Net::DNS::RR::DNSKEY class. + +Please see the L documentation for details. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + + +=head1 COPYRIGHT + +Copyright (c)2005 Olaf Kolkman, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, RFC3755, RFC2535 + +=cut diff --git a/lib/Net/DNS/RR/KX.pm b/lib/Net/DNS/RR/KX.pm new file mode 100644 index 0000000..3ee3c22 --- /dev/null +++ b/lib/Net/DNS/RR/KX.pm @@ -0,0 +1,157 @@ +package Net::DNS::RR::KX; + +# +# $Id: KX.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::KX - DNS KX resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + $self->{exchange} = decode Net::DNS::DomainName2535( $data, $offset + 2, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $exchange = $self->{exchange}; + pack 'n a*', $self->preference, $exchange->encode( $offset + 2, @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $exchange = $self->{exchange}; + join ' ', $self->preference, $exchange->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->exchange(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub exchange { + my $self = shift; + + $self->{exchange} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{exchange}->name if $self->{exchange}; +} + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name KX preference exchange'); + +=head1 DESCRIPTION + +DNS Key Exchange Delegation (KX) record + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + +A 16 bit integer which specifies the preference +given to this RR among others at the same owner. +Lower values are preferred. + +=head2 exchange + + $exchange = $rr->exchange; + $rr->exchange( $exchange ); + +A domain name which specifies a host willing +to act as a key exchange for the owner name. + + +=head1 COPYRIGHT + +Copyright (c)2009 Olaf Kolkman, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC2230 + +=cut diff --git a/lib/Net/DNS/RR/L32.pm b/lib/Net/DNS/RR/L32.pm new file mode 100644 index 0000000..0b881f5 --- /dev/null +++ b/lib/Net/DNS/RR/L32.pm @@ -0,0 +1,164 @@ +package Net::DNS::RR::L32; + +# +# $Id: L32.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::L32 - DNS L32 resource record + +=cut + + +use integer; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + @{$self}{qw(preference locator32)} = unpack "\@$offset n a4", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n a4', $self->{preference}, $self->{locator32}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->preference, $self->locator32; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->locator32(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub locator32 { + my $self = shift; + my $prfx = shift; + + $self->{locator32} = pack 'C* @4', split /\./, $prfx if defined $prfx; + + join '.', unpack 'C4', $self->{locator32} if $self->{locator32}; +} + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN L32 preference locator32'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'L32', + preference => 10, + locator32 => '10.1.02.0' + ); + +=head1 DESCRIPTION + +Class for DNS 32-bit Locator (L32) resource records. + +The L32 resource record is used to hold 32-bit Locator values for +ILNPv4-capable nodes. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + +A 16 bit unsigned integer in network byte order that indicates the +relative preference for this L32 record among other L32 records +associated with this owner name. Lower values are preferred over +higher values. + +=head2 locator32 + + $locator32 = $rr->locator32; + +The Locator32 field is an unsigned 32-bit integer in network byte +order that has the same syntax and semantics as a 32-bit IPv4 +routing prefix. + + +=head1 COPYRIGHT + +Copyright (c)2012 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC6742 + +=cut diff --git a/lib/Net/DNS/RR/L64.pm b/lib/Net/DNS/RR/L64.pm new file mode 100644 index 0000000..f480665 --- /dev/null +++ b/lib/Net/DNS/RR/L64.pm @@ -0,0 +1,164 @@ +package Net::DNS::RR::L64; + +# +# $Id: L64.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::L64 - DNS L64 resource record + +=cut + + +use integer; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + @{$self}{qw(preference locator64)} = unpack "\@$offset n a8", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n a8', $self->{preference}, $self->{locator64}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->preference, $self->locator64; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->locator64(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub locator64 { + my $self = shift; + my $prfx = shift; + + $self->{locator64} = pack 'n4', map hex($_), split /:/, $prfx if defined $prfx; + + sprintf '%x:%x:%x:%x', unpack 'n4', $self->{locator64} if $self->{locator64}; +} + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN L64 preference locator64'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'L64', + preference => 10, + locator64 => '2001:0DB8:1140:1000' + ); + +=head1 DESCRIPTION + +Class for DNS 64-bit Locator (L64) resource records. + +The L64 resource record is used to hold 64-bit Locator values for +ILNPv6-capable nodes. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + +A 16 bit unsigned integer in network byte order that indicates the +relative preference for this L64 record among other L64 records +associated with this owner name. Lower values are preferred over +higher values. + +=head2 locator64 + + $locator64 = $rr->locator64; + +The Locator64 field is an unsigned 64-bit integer in network byte +order that has the same syntax and semantics as a 64-bit IPv6 +routing prefix. + + +=head1 COPYRIGHT + +Copyright (c)2012 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC6742 + +=cut diff --git a/lib/Net/DNS/RR/LOC.pm b/lib/Net/DNS/RR/LOC.pm new file mode 100644 index 0000000..1b82ec0 --- /dev/null +++ b/lib/Net/DNS/RR/LOC.pm @@ -0,0 +1,347 @@ +package Net::DNS::RR::LOC; + +# +# $Id: LOC.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::LOC - DNS LOC resource record + +=cut + + +use integer; + +use Carp; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $version = $self->{version} = unpack "\@$offset C", $$data; + @{$self}{qw(size hp vp latitude longitude altitude)} = unpack "\@$offset xC3N3", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'C4N3', @{$self}{qw(version size hp vp latitude longitude altitude)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my ( $altitude, @precision ) = map $self->$_() . 'm', qw(altitude size hp vp); + my $precision = join ' ', @precision; + for ($precision) { + s/\s+10m$//; + s/\s+10000m$//; + s/\s*1m$//; + } + my @rdata = ( $self->latitude, '', $self->longitude, '', $altitude, $precision ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + my @lat; + while ( scalar @_ ) { + my $this = shift; + push( @lat, $this ); + last if $this =~ /[NSns]/; + } + $self->latitude(@lat); + + my @long; + while ( scalar @_ ) { + my $this = shift; + push( @long, $this ); + last if $this =~ /[EWew]/; + } + $self->longitude(@long); + + foreach my $attr (qw(altitude size hp vp)) { + $self->$attr(@_); + shift; + } +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->{version} = 0; + $self->size(1); + $self->hp(10000); + $self->vp(10); +} + + +sub latitude { + my $self = shift; + $self->{latitude} = _encode_lat(@_) if scalar @_; + return _decode_lat( $self->{latitude} ) if defined wantarray; +} + + +sub longitude { + my $self = shift; + $self->{longitude} = _encode_lat(@_) if scalar @_; + return undef unless defined wantarray; + return _decode_lat( $self->{longitude} ) unless wantarray; + my @long = map { s/N/E/; s/S/W/; $_ } _decode_lat( $self->{longitude} ); +} + + +sub altitude { + my $self = shift; + $self->{altitude} = _encode_alt(shift) if scalar @_; + _decode_alt( $self->{altitude} ) if defined wantarray; +} + + +sub size { + my $self = shift; + $self->{size} = _encode_prec(shift) if scalar @_; + _decode_prec( $self->{size} ) if defined wantarray; +} + + +sub hp { + my $self = shift; + $self->{hp} = _encode_prec(shift) if scalar @_; + _decode_prec( $self->{hp} ) if defined wantarray; +} + +sub horiz_pre { &hp; } # uncoverable pod + + +sub vp { + my $self = shift; + $self->{vp} = _encode_prec(shift) if scalar @_; + _decode_prec( $self->{vp} ) if defined wantarray; +} + +sub vert_pre { &vp; } # uncoverable pod + + +sub latlon { + my $self = shift; + my ( $lat, @lon ) = @_; + my @pair = scalar $self->latitude(@_), scalar $self->longitude(@lon); +} + + +sub version { + shift->{version}; +} + + +######################################## + +no integer; + +use constant ALTITUDE0 => 10000000; +use constant LATITUDE0 => 0x80000000; + +sub _decode_lat { + my $msec = shift || LATITUDE0; + return int( 0.5 + ( $msec - LATITUDE0 ) / 0.36 ) / 10000000 unless wantarray; + use integer; + my $abs = abs( $msec - LATITUDE0 ); + my $deg = int( $abs / 3600000 ); + my $min = int( $abs / 60000 ) % 60; + no integer; + my $sec = ( $abs % 60000 ) / 1000; + return ( $deg, $min, $sec, ( $msec < LATITUDE0 ? 'S' : 'N' ) ); +} + + +sub _encode_lat { + my @ang = scalar @_ > 1 ? (@_) : ( split /[\s\260'"]+/, shift ); + my $ang = ( 0 + shift @ang ) * 3600000; + my $neg = ( @ang ? pop @ang : '' ) =~ /[SWsw]/; + $ang += ( @ang ? shift @ang : 0 ) * 60000; + $ang += ( @ang ? shift @ang : 0 ) * 1000; + return int( 0.5 + ( $neg ? LATITUDE0 - $ang : LATITUDE0 + $ang ) ); +} + + +sub _decode_alt { + my $cm = ( shift || ALTITUDE0 ) - ALTITUDE0; + return 0.01 * $cm; +} + + +sub _encode_alt { + ( my $argument = shift ) =~ s/[Mm]$//; + $argument += 0; + return int( 0.5 + ALTITUDE0 + 100 * $argument ); +} + + +my @power10 = ( 0.01, 0.1, 1, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 0, 0, 0, 0, 0 ); + +sub _decode_prec { + my $argument = shift || 0; + my $mantissa = $argument >> 4; + return $mantissa * $power10[$argument & 0x0F]; +} + +sub _encode_prec { + ( my $argument = shift ) =~ s/[Mm]$//; + foreach my $exponent ( 0 .. 9 ) { + next unless $argument < $power10[1 + $exponent]; + my $mantissa = int( 0.5 + $argument / $power10[$exponent] ); + return ( $mantissa & 0xF ) << 4 | $exponent; + } +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name LOC latitude longitude altitude size hp vp'); + +=head1 DESCRIPTION + +DNS geographical location (LOC) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 latitude + + $latitude = $rr->latitude; + ($deg, $min, $sec, $ns ) = $rr->latitude; + + $rr->latitude( 42.357990 ); + $rr->latitude( 42, 21, 28.764, 'N' ); + $rr->latitude( '42 21 28.764 N' ); + +When invoked in scalar context, latitude is returned in degrees, +a negative ordinate being south of the equator. + +When invoked in list context, latitude is returned as a list of +separate degree, minute, and second values followed by N or S +as appropriate. + +Optional replacement values may be represented as single value, list +or formatted string. Trailing zero values are optional. + +=head2 longitude + + $longitude = $rr->longitude; + ($deg, $min, $sec, $ew ) = $rr->longitude; + + $rr->longitude( -71.014338 ); + $rr->longitude( 71, 0, 51.617, 'W' ); + $rr->longitude( '71 0 51.617 W' ); + +When invoked in scalar context, longitude is returned in degrees, +a negative ordinate being west of the prime meridian. + +When invoked in list context, longitude is returned as a list of +separate degree, minute, and second values followed by E or W +as appropriate. + +=head2 altitude + + $altitude = $rr->altitude; + +Represents altitude, in metres, relative to the WGS 84 reference +spheroid used by GPS. + +=head2 size + + $size = $rr->size; + +Represents the diameter, in metres, of a sphere enclosing the +described entity. + +=head2 hp + + $hp = $rr->hp; + +Represents the horizontal precision of the data expressed as the +diameter, in metres, of the circle of error. + +=head2 vp + + $vp = $rr->vp; + +Represents the vertical precision of the data expressed as the +total spread, in metres, of the distribution of possible values. + +=head2 latlon + + ($lat, $lon) = $rr->latlon; + $rr->latlon($lat, $lon); + +Representation of the latitude and longitude coordinate pair as +signed floating-point degrees. + +=head2 version + + $version = $rr->version; + +Version of LOC protocol. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2011 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1876 + +=cut diff --git a/lib/Net/DNS/RR/LP.pm b/lib/Net/DNS/RR/LP.pm new file mode 100644 index 0000000..2ccefd1 --- /dev/null +++ b/lib/Net/DNS/RR/LP.pm @@ -0,0 +1,173 @@ +package Net::DNS::RR::LP; + +# +# $Id: LP.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::LP - DNS LP resource record + +=cut + + +use integer; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + $self->{target} = decode Net::DNS::DomainName( $data, $offset + 2 ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $target = $self->{target}; + pack 'n a*', $self->preference, $target->encode(); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $target = $self->{target}; + join ' ', $self->preference, $target->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->target(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub target { + my $self = shift; + + $self->{target} = new Net::DNS::DomainName(shift) if scalar @_; + $self->{target}->name if $self->{target}; +} + + +sub FQDN { shift->{target}->fqdn; } +sub fqdn { shift->{target}->fqdn; } + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN LP preference FQDN'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'LP', + preference => 10, + target => 'target.example.com.' + ); + +=head1 DESCRIPTION + +Class for DNS Locator Pointer (LP) resource records. + +The LP DNS resource record (RR) is used to hold the name of a +subnetwork for ILNP. The name is an FQDN which can then be used to +look up L32 or L64 records. LP is, effectively, a Locator Pointer to +L32 and/or L64 records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + +A 16 bit unsigned integer in network byte order that indicates the +relative preference for this LP record among other LP records +associated with this owner name. Lower values are preferred over +higher values. + +=head2 FQDN, fqdn + +=head2 target + + $target = $rr->target; + $rr->target( $target ); + +The FQDN field contains the DNS target name that is used to +reference L32 and/or L64 records. + + +=head1 COPYRIGHT + +Copyright (c)2012 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC6742 + +=cut diff --git a/lib/Net/DNS/RR/MB.pm b/lib/Net/DNS/RR/MB.pm new file mode 100644 index 0000000..d496f46 --- /dev/null +++ b/lib/Net/DNS/RR/MB.pm @@ -0,0 +1,127 @@ +package Net::DNS::RR::MB; + +# +# $Id: MB.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::MB - DNS MB resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + + $self->{madname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $madname = $self->{madname} || return ''; + $madname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $madname = $self->{madname} || return ''; + $madname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->madname(shift); +} + + +sub madname { + my $self = shift; + + $self->{madname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{madname}->name if $self->{madname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name MB madname'); + +=head1 DESCRIPTION + +Class for DNS Mailbox (MB) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 madname + + $madname = $rr->madname; + $rr->madname( $madname ); + +A domain name which specifies a host which has the +specified mailbox. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.3 + +=cut diff --git a/lib/Net/DNS/RR/MG.pm b/lib/Net/DNS/RR/MG.pm new file mode 100644 index 0000000..321be8a --- /dev/null +++ b/lib/Net/DNS/RR/MG.pm @@ -0,0 +1,127 @@ +package Net::DNS::RR::MG; + +# +# $Id: MG.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::MG - DNS MG resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + + $self->{mgmname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $mgmname = $self->{mgmname} || return ''; + $mgmname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $mgmname = $self->{mgmname} || return ''; + $mgmname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->mgmname(shift); +} + + +sub mgmname { + my $self = shift; + + $self->{mgmname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{mgmname}->name if $self->{mgmname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name MG mgmname'); + +=head1 DESCRIPTION + +Class for DNS Mail Group (MG) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 mgmname + + $mgmname = $rr->mgmname; + $rr->mgmname( $mgmname ); + +A domain name which specifies a mailbox which is a member +of the mail group specified by the owner name. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.6 + +=cut diff --git a/lib/Net/DNS/RR/MINFO.pm b/lib/Net/DNS/RR/MINFO.pm new file mode 100644 index 0000000..c4095fe --- /dev/null +++ b/lib/Net/DNS/RR/MINFO.pm @@ -0,0 +1,155 @@ +package Net::DNS::RR::MINFO; + +# +# $Id: MINFO.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::MINFO - DNS MINFO resource record + +=cut + + +use integer; + +use Net::DNS::Mailbox; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + ( $self->{rmailbx}, $offset ) = decode Net::DNS::Mailbox1035(@_); + ( $self->{emailbx}, $offset ) = decode Net::DNS::Mailbox1035( $data, $offset, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $rdata = $self->{rmailbx}->encode(@_); + $rdata .= $self->{emailbx}->encode( $offset + length $rdata, @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @rdata = ( $self->{rmailbx}->string, $self->{emailbx}->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->rmailbx(shift); + $self->emailbx(shift); +} + + +sub rmailbx { + my $self = shift; + + $self->{rmailbx} = new Net::DNS::Mailbox1035(shift) if scalar @_; + $self->{rmailbx}->address if $self->{rmailbx}; +} + + +sub emailbx { + my $self = shift; + + $self->{emailbx} = new Net::DNS::Mailbox1035(shift) if scalar @_; + $self->{emailbx}->address if $self->{emailbx}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name MINFO rmailbx emailbx'); + +=head1 DESCRIPTION + +Class for DNS Mailbox Information (MINFO) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 rmailbx + + $rmailbx = $rr->rmailbx; + $rr->rmailbx( $rmailbx ); + +A domain name which specifies a mailbox which is +responsible for the mailing list or mailbox. If this +domain name names the root, the owner of the MINFO RR is +responsible for itself. Note that many existing mailing +lists use a mailbox X-request to identify the maintainer +of mailing list X, e.g., Msgroup-request for Msgroup. +This field provides a more general mechanism. + +=head2 emailbx + + $emailbx = $rr->emailbx; + $rr->emailbx( $emailbx ); + +A domain name which specifies a mailbox which is to +receive error messages related to the mailing list or +mailbox specified by the owner of the MINFO RR (similar +to the ERRORS-TO: field which has been proposed). +If this domain name names the root, errors should be +returned to the sender of the message. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.7 + +=cut diff --git a/lib/Net/DNS/RR/MR.pm b/lib/Net/DNS/RR/MR.pm new file mode 100644 index 0000000..4537801 --- /dev/null +++ b/lib/Net/DNS/RR/MR.pm @@ -0,0 +1,127 @@ +package Net::DNS::RR::MR; + +# +# $Id: MR.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::MR - DNS MR resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + + $self->{newname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $newname = $self->{newname} || return ''; + $newname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $newname = $self->{newname} || return ''; + $newname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->newname(shift); +} + + +sub newname { + my $self = shift; + + $self->{newname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{newname}->name if $self->{newname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name MR newname'); + +=head1 DESCRIPTION + +Class for DNS Mail Rename (MR) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 newname + + $newname = $rr->newname; + $rr->newname( $newname ); + +A domain name which specifies a mailbox which is the +proper rename of the specified mailbox. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.8 + +=cut diff --git a/lib/Net/DNS/RR/MX.pm b/lib/Net/DNS/RR/MX.pm new file mode 100644 index 0000000..39f839f --- /dev/null +++ b/lib/Net/DNS/RR/MX.pm @@ -0,0 +1,166 @@ +package Net::DNS::RR::MX; + +# +# $Id: MX.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::MX - DNS MX resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + $self->{exchange} = decode Net::DNS::DomainName1035( $data, $offset + 2, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $exchange = $self->{exchange}; + pack 'n a*', $self->preference, $exchange->encode( $offset + 2, @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $exchange = $self->{exchange}; + join ' ', $self->preference, $exchange->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->exchange(shift); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->preference(10); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub exchange { + my $self = shift; + + $self->{exchange} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{exchange}->name if $self->{exchange}; +} + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name MX preference exchange'); + +=head1 DESCRIPTION + +DNS Mail Exchanger (MX) resource record + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + +A 16 bit integer which specifies the preference +given to this RR among others at the same owner. +Lower values are preferred. + +=head2 exchange + + $exchange = $rr->exchange; + $rr->exchange( $exchange ); + +A domain name which specifies a host willing +to act as a mail exchange for the owner name. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.9 + +=cut diff --git a/lib/Net/DNS/RR/NAPTR.pm b/lib/Net/DNS/RR/NAPTR.pm new file mode 100644 index 0000000..1f5fae1 --- /dev/null +++ b/lib/Net/DNS/RR/NAPTR.pm @@ -0,0 +1,236 @@ +package Net::DNS::RR::NAPTR; + +# +# $Id: NAPTR.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::NAPTR - DNS NAPTR resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; +use Net::DNS::Text; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + @{$self}{qw(order preference)} = unpack "\@$offset n2", $$data; + ( $self->{flags}, $offset ) = decode Net::DNS::Text( $data, $offset + 4 ); + ( $self->{service}, $offset ) = decode Net::DNS::Text( $data, $offset ); + ( $self->{regexp}, $offset ) = decode Net::DNS::Text( $data, $offset ); + $self->{replacement} = decode Net::DNS::DomainName2535( $data, $offset, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $rdata = pack 'n2', @{$self}{qw(order preference)}; + $rdata .= $self->{flags}->encode; + $rdata .= $self->{service}->encode; + $rdata .= $self->{regexp}->encode; + $rdata .= $self->{replacement}->encode( $offset + length($rdata), @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @order = @{$self}{qw(order preference)}; + my @rdata = ( @order, map $_->string, @{$self}{qw(flags service regexp replacement)} ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach (qw(order preference flags service regexp replacement)) { $self->$_(shift) } +} + + +sub order { + my $self = shift; + + $self->{order} = 0 + shift if scalar @_; + $self->{order} || 0; +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub flags { + my $self = shift; + + $self->{flags} = new Net::DNS::Text(shift) if scalar @_; + $self->{flags}->value if $self->{flags}; +} + + +sub service { + my $self = shift; + + $self->{service} = new Net::DNS::Text(shift) if scalar @_; + $self->{service}->value if $self->{service}; +} + + +sub regexp { + my $self = shift; + + $self->{regexp} = new Net::DNS::Text(shift) if scalar @_; + $self->{regexp}->value if $self->{regexp}; +} + + +sub replacement { + my $self = shift; + + $self->{replacement} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{replacement}->name if $self->{replacement}; +} + + +my $function = sub { + my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); + $a->{order} <=> $b->{order} + || $a->{preference} <=> $b->{preference}; +}; + +__PACKAGE__->set_rrsort_func( 'order', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name NAPTR order preference flags service regexp replacement'); + +=head1 DESCRIPTION + +DNS Naming Authority Pointer (NAPTR) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 order + + $order = $rr->order; + $rr->order( $order ); + +A 16-bit unsigned integer specifying the order in which the NAPTR +records must be processed to ensure the correct ordering of rules. +Low numbers are processed before high numbers. + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + +A 16-bit unsigned integer that specifies the order in which NAPTR +records with equal "order" values should be processed, low numbers +being processed before high numbers. + +=head2 flags + + $flags = $rr->flags; + $rr->flags( $flags ); + +A string containing flags to control aspects of the rewriting and +interpretation of the fields in the record. Flags are single +characters from the set [A-Z0-9]. + +=head2 service + + $service = $rr->service; + $rr->service( $service ); + +Specifies the service(s) available down this rewrite path. It may +also specify the protocol used to communicate with the service. + +=head2 regexp + + $regexp = $rr->regexp; + $rr->regexp; + +A string containing a substitution expression that is applied to +the original string held by the client in order to construct the +next domain name to lookup. + +=head2 replacement + + $replacement = $rr->replacement; + $rr->replacement( $replacement ); + +The next NAME to query for NAPTR, SRV, or address records +depending on the value of the flags field. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. + +Based on code contributed by Ryan Moats. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC2915, RFC2168, RFC3403 + +=cut diff --git a/lib/Net/DNS/RR/NID.pm b/lib/Net/DNS/RR/NID.pm new file mode 100644 index 0000000..7c438f2 --- /dev/null +++ b/lib/Net/DNS/RR/NID.pm @@ -0,0 +1,165 @@ +package Net::DNS::RR::NID; + +# +# $Id: NID.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::NID - DNS NID resource record + +=cut + + +use integer; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + @{$self}{qw(preference nodeid)} = unpack "\@$offset n a8", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n a8', $self->{preference}, $self->{nodeid}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->preference, $self->nodeid; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->nodeid(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub nodeid { + my $self = shift; + my $idnt = shift; + + $self->{nodeid} = pack 'n4', map hex($_), split /:/, $idnt if defined $idnt; + + sprintf '%0.4x:%0.4x:%0.4x:%0.4x', unpack 'n4', $self->{nodeid} if $self->{nodeid}; +} + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN NID preference nodeid'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'NID', + preference => 10, + nodeid => '8:800:200C:417A' + ); + +=head1 DESCRIPTION + +Class for DNS Node Identifier (NID) resource records. + +The Node Identifier (NID) DNS resource record is used to hold values +for Node Identifiers that will be used for ILNP-capable nodes. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + +A 16 bit unsigned integer in network byte order that indicates the +relative preference for this NID record among other NID records +associated with this owner name. Lower values are preferred over +higher values. + +=head2 nodeid + + $nodeid = $rr->nodeid; + +The NodeID field is an unsigned 64-bit value in network byte order. +The text representation uses the same syntax (i.e., groups of 4 +hexadecimal digits separated by a colons) that is already used for +IPv6 interface identifiers. + + +=head1 COPYRIGHT + +Copyright (c)2012 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC6742 + +=cut diff --git a/lib/Net/DNS/RR/NS.pm b/lib/Net/DNS/RR/NS.pm new file mode 100644 index 0000000..b97740e --- /dev/null +++ b/lib/Net/DNS/RR/NS.pm @@ -0,0 +1,133 @@ +package Net::DNS::RR::NS; + +# +# $Id: NS.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::NS - DNS NS resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + + $self->{nsdname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $nsdname = $self->{nsdname}; + $nsdname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $nsdname = $self->{nsdname}; + $nsdname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->nsdname(shift); +} + + +sub nsdname { + my $self = shift; + + $self->{nsdname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{nsdname}->name if $self->{nsdname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name NS nsdname'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'NS', + nsdname => 'ns.example.com', + ); + +=head1 DESCRIPTION + +Class for DNS Name Server (NS) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 nsdname + + $nsdname = $rr->nsdname; + $rr->nsdname( $nsdname ); + +A domain name which specifies a host which should be +authoritative for the specified class and domain. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.11 + +=cut diff --git a/lib/Net/DNS/RR/NSEC.pm b/lib/Net/DNS/RR/NSEC.pm new file mode 100644 index 0000000..aba86ef --- /dev/null +++ b/lib/Net/DNS/RR/NSEC.pm @@ -0,0 +1,213 @@ +package Net::DNS::RR::NSEC; + +# +# $Id: NSEC.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::NSEC - DNS NSEC resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; +use Net::DNS::Parameters; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + ( $self->{nxtdname}, $offset ) = decode Net::DNS::DomainName(@_); + $self->{typebm} = substr $$data, $offset, $limit - $offset; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $nxtdname = $self->{nxtdname}; + join '', $nxtdname->encode(), $self->{typebm}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $nxtdname = $self->{nxtdname}; + my @rdata = ( $nxtdname->string(), $self->typelist ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->nxtdname(shift); + $self->typelist(@_); +} + + +sub nxtdname { + my $self = shift; + + $self->{nxtdname} = new Net::DNS::DomainName(shift) if scalar @_; + $self->{nxtdname}->name if $self->{nxtdname}; +} + + +sub typelist { + my $self = shift; + + $self->{typebm} = &_type2bm if scalar @_; + + my @type = defined wantarray ? &_bm2type( $self->{typebm} ) : (); + return wantarray ? (@type) : "@type"; +} + + +######################################## + +sub _type2bm { + my @typearray; + foreach my $typename ( map split(), @_ ) { + my $number = typebyname($typename); + my $window = $number >> 8; + my $bitnum = $number & 255; + my $octet = $bitnum >> 3; + my $bit = $bitnum & 7; + $typearray[$window][$octet] |= 0x80 >> $bit; + } + + my $bitmap = ''; + my $window = 0; + foreach (@typearray) { + if ( my $pane = $typearray[$window] ) { + my @content = map $_ || 0, @$pane; + $bitmap .= pack 'CC C*', $window, scalar(@content), @content; + } + $window++; + } + + return $bitmap; +} + + +sub _bm2type { + my @typelist; + my $bitmap = shift || return @typelist; + + my $index = 0; + my $limit = length $bitmap; + + while ( $index < $limit ) { + my ( $block, $size ) = unpack "\@$index C2", $bitmap; + my $typenum = $block << 8; + foreach my $octet ( unpack "\@$index xxC$size", $bitmap ) { + my $i = $typenum += 8; + my @name; + while ($octet) { + --$i; + unshift @name, typebyval($i) if $octet & 1; + $octet = $octet >> 1; + } + push @typelist, @name; + } + $index += $size + 2; + } + + return @typelist; +} + + +sub typebm { ## historical + my $self = shift; # uncoverable pod + $self->{typebm} = shift if scalar @_; + return $self->{typebm}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name NSEC nxtdname typelist'); + +=head1 DESCRIPTION + +Class for DNSSEC NSEC resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 nxtdname + + $nxtdname = $rr->nxtdname; + $rr->nxtdname( $nxtdname ); + +The Next Domain field contains the next owner name (in the +canonical ordering of the zone) that has authoritative data +or contains a delegation point NS RRset. + +=head2 typelist + + @typelist = $rr->typelist; + $typelist = $rr->typelist; + +The Type List identifies the RRset types that exist at the NSEC RR +owner name. When called in scalar context, the list is interpolated +into a string. + + +=head1 COPYRIGHT + +Copyright (c)2001-2005 RIPE NCC. Author Olaf M. Kolkman + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC4034, RFC3755 + +=cut diff --git a/lib/Net/DNS/RR/NSEC3.pm b/lib/Net/DNS/RR/NSEC3.pm new file mode 100644 index 0000000..3ab111c --- /dev/null +++ b/lib/Net/DNS/RR/NSEC3.pm @@ -0,0 +1,434 @@ +package Net::DNS::RR::NSEC3; + +# +# $Id: NSEC3.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::NSEC); + +=head1 NAME + +Net::DNS::RR::NSEC3 - DNS NSEC3 resource record + +=cut + + +use integer; + +use base qw(Exporter); +our @EXPORT_OK = qw(name2hash); + +use Carp; + +require Net::DNS::DomainName; + +eval 'require Digest::SHA'; ## optional for simple Net::DNS RR + +my %digest = ( + '1' => ['Digest::SHA', 1], # RFC3658 + ); + +{ + my @digestbyname = ( + 'SHA-1' => 1, # RFC3658 + ); + + my @digestalias = ( 'SHA' => 1 ); + + my %digestbyval = reverse @digestbyname; + + my @digestrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @digestbyname; + my %digestbyname = ( @digestalias, @digestrehash ); # work around broken cperl + + sub _digestbyname { + my $name = shift; + my $key = uc $name; # synthetic key + $key =~ s /[\W_]//g; # strip non-alphanumerics + $digestbyname{$key} || croak "unknown digest type $name"; + } + + sub _digestbyval { + my $value = shift; + $digestbyval{$value} || return $value; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + my $ssize = unpack "\@$offset x4 C", $$data; + @{$self}{qw(algorithm flags iterations saltbin)} = unpack "\@$offset CCnx a$ssize", $$data; + $offset += 5 + $ssize; + my $hsize = unpack "\@$offset C", $$data; + $self->{hnxtname} = unpack "\@$offset x a$hsize", $$data; + $offset += 1 + $hsize; + $self->{typebm} = substr $$data, $offset, ( $limit - $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $salt = $self->saltbin; + my $hash = $self->{hnxtname}; + pack 'CCn C a* C a* a*', $self->algorithm, $self->flags, $self->iterations, + length($salt), $salt, + length($hash), $hash, + $self->{typebm}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @rdata = ( + $self->algorithm, $self->flags, $self->iterations, + $self->salt || '-', $self->hnxtname, $self->typelist + ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->algorithm(shift); + $self->flags(shift); + $self->iterations(shift); + my $salt = shift; + $self->salt($salt) unless $salt eq '-'; + $self->hnxtname(shift); + $self->typelist(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->_parse_rdata( 1, 0, 0, '' ); +} + + +sub algorithm { + my ( $self, $arg ) = @_; + + unless ( ref($self) ) { ## class method or simple function + my $argn = pop; + return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn); + } + + return $self->{algorithm} unless defined $arg; + return _digestbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; + return $self->{algorithm} = _digestbyname($arg); +} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub optout { + my $bit = 0x01; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub iterations { + my $self = shift; + + $self->{iterations} = 0 + shift if scalar @_; + $self->{iterations} || 0; +} + + +sub salt { + my $self = shift; + return unpack "H*", $self->saltbin() unless scalar @_; + $self->saltbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub saltbin { + my $self = shift; + + $self->{saltbin} = shift if scalar @_; + $self->{saltbin} || ""; +} + + +sub hnxtname { + my $self = shift; + $self->{hnxtname} = _decode_base32hex(shift) if scalar @_; + _encode_base32hex( $self->{hnxtname} ) if defined wantarray; +} + + +sub covered { + my $self = shift; + my $name = shift; + + # first test if the domain name is in the NSEC3 zone. + my ( $owner, @zonelabels ) = $self->{owner}->_wire; + my @labels = new Net::DNS::DomainName( lc $name )->_wire; + foreach ( reverse @zonelabels ) { + tr /\101-\132/\141-\172/; + return 0 unless $_ eq ( pop(@labels) || '' ); + } + + my $ownerhash = _decode_base32hex($owner); + my $nexthash = "$self->{hnxtname}"; + + my $namehash = _hash( $self->algorithm, $name, $self->iterations, $self->saltbin ); + + my $c1 = $namehash cmp $ownerhash; + my $c2 = $nexthash cmp $namehash; + return ( $c1 + $c2 ) == 2; +} + + +sub match { + my $self = shift; + my $name = shift; + + my ($owner) = $self->{owner}->_wire; + my $ownerhash = _decode_base32hex($owner); + + $ownerhash eq _hash( $self->algorithm, $name, $self->iterations, $self->saltbin ); +} + + +######################################## + +sub _decode_base32hex { + local $_ = shift || ''; + tr [0-9A-Va-v\060-\071\101-\126\141-\166] [\000-\037\012-\037\000-\037\012-\037]; + $_ = unpack 'B*', $_; + s/000(.....)/$1/g; + my $l = length; + $_ = substr $_, 0, $l & ~7 if $l & 7; + pack 'B*', $_; +} + + +sub _encode_base32hex { + local $_ = unpack 'B*', shift; + s/(.....)/000$1/g; + my $l = length; + my $x = substr $_, $l & ~7; + my $n = length $x; + substr( $_, $l & ~7 ) = join '', '000', $x, '0' x ( 5 - $n ) if $n; + $_ = pack( 'B*', $_ ); + tr [\000-\037] [0-9a-v]; + return $_; +} + + +sub _hash { + my $hashalg = shift; + my $name = shift; + my $iterations = shift; + my $salt = shift || ''; + + my $arglist = $digest{$hashalg}; + my ( $object, @argument ) = @$arglist; + my $hash = $object->new(@argument); + + my $wirename = new Net::DNS::DomainName($name)->canonical; + $iterations++; + + while ( $iterations-- ) { + $hash->add($wirename); + $hash->add($salt); + $wirename = $hash->digest; + } + + return $wirename; +} + + +sub name2hash { _encode_base32hex(&_hash); } # uncoverable pod + + +sub hashalgo { &algorithm; } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name NSEC3 algorithm flags iterations salt hnxtname'); + +=head1 DESCRIPTION + +Class for DNSSEC NSEC3 resource records. + +The NSEC3 Resource Record (RR) provides authenticated denial of +existence for DNS Resource Record Sets. + +The NSEC3 RR lists RR types present at the original owner name of the +NSEC3 RR. It includes the next hashed owner name in the hash order +of the zone. The complete set of NSEC3 RRs in a zone indicates which +RRSets exist for the original owner name of the RR and form a chain +of hashed owner names in the zone. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 algorithm + + $algorithm = $rr->algorithm; + $rr->algorithm( $algorithm ); + +The Hash Algorithm field is represented as an unsigned decimal +integer. The value has a maximum of 255. + +algorithm() may also be invoked as a class method or simple function +to perform mnemonic and numeric code translation. + +=head2 flags + + $flags = $rr->flags; + $rr->flags( $flags ); + +The Flags field is represented as an unsigned decimal integer. +The value has a maximum value of 255. + +=over 4 + +=item optout + + $rr->optout(1); + + if ( $rr->optout ) { + ... + } + +Boolean Opt Out flag. + +=back + +=head2 iterations + + $iterations = $rr->iterations; + $rr->iterations( $iterations ); + +The Iterations field is represented as an unsigned decimal +integer. The value is between 0 and 65535, inclusive. + +=head2 salt + + $salt = $rr->salt; + $rr->salt( $salt ); + +The Salt field is represented as a contiguous sequence of hexadecimal +digits. A "-" (unquoted) is used in string format to indicate that the +salt field is absent. + +=head2 saltbin + + $saltbin = $rr->saltbin; + $rr->saltbin( $saltbin ); + +The Salt field as a sequence of octets. + +=head2 hnxtname + + $hnxtname = $rr->hnxtname; + $rr->hnxtname( $hnxtname ); + +The Next Hashed Owner Name field points to the next node that has +authoritative data or contains a delegation point NS RRset. + +=head2 typelist + + @typelist = $rr->typelist; + $typelist = $rr->typelist; + $rr->typelist( @typelist ); + +The Type List identifies the RRset types that exist at the domain name +matched by the NSEC3 RR. When called in scalar context, the list is +interpolated into a string. + +=head2 covered, match + + print "covered" if $rr->covered{'example.foo'} + +covered() returns a nonzero value when the the domain name provided as argument +is covered as defined in the NSEC3 specification: + + To cover: An NSEC3 RR is said to "cover" a name if the hash of the + name or "next closer" name falls between the owner name and the + next hashed owner name of the NSEC3. In other words, if it proves + the nonexistence of the name, either directly or by proving the + nonexistence of an ancestor of the name. + + +Similarly matched() returns a nonzero value when the domainname in the argument +matches as defined in the NSEC3 specification: + + To match: An NSEC3 RR is said to "match" a name if the owner name + of the NSEC3 RR is the same as the hashed owner name of that + name. + + +=head1 COPYRIGHT + +Copyright (c)2017 Dick Franks + +Portions Copyright (c)2007,2008 NLnet Labs. Author Olaf M. Kolkman + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC5155, RFC4648 + +L + +=cut diff --git a/lib/Net/DNS/RR/NSEC3PARAM.pm b/lib/Net/DNS/RR/NSEC3PARAM.pm new file mode 100644 index 0000000..bc62548 --- /dev/null +++ b/lib/Net/DNS/RR/NSEC3PARAM.pm @@ -0,0 +1,209 @@ +package Net::DNS::RR::NSEC3PARAM; + +# +# $Id: NSEC3PARAM.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::NSEC3PARAM - DNS NSEC3PARAM resource record + +=cut + + +use integer; + +use Carp; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $size = unpack "\@$offset x4 C", $$data; + @{$self}{qw(algorithm flags iterations saltbin)} = unpack "\@$offset CCnx a$size", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $salt = $self->saltbin; + pack 'CCnCa*', @{$self}{qw(algorithm flags iterations)}, length($salt), $salt; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->algorithm, $self->flags, $self->iterations, $self->salt || '-'; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->algorithm(shift); + $self->flags(shift); + $self->iterations(shift); + my $salt = shift; + $self->salt($salt) unless $salt eq '-'; +} + + +sub algorithm { + my $self = shift; + + $self->{algorithm} = 0 + shift if scalar @_; + $self->{algorithm} || 0; +} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub iterations { + my $self = shift; + + $self->{iterations} = 0 + shift if scalar @_; + $self->{iterations} || 0; +} + + +sub salt { + my $self = shift; + return unpack "H*", $self->saltbin() unless scalar @_; + $self->saltbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub saltbin { + my $self = shift; + + $self->{saltbin} = shift if scalar @_; + $self->{saltbin} || ""; +} + + +######################################## + +sub hashalgo { &algorithm; } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name NSEC3PARAM algorithm flags iterations salt'); + +=head1 DESCRIPTION + +Class for DNSSEC NSEC3PARAM resource records. + +The NSEC3PARAM RR contains the NSEC3 parameters (hash algorithm, +flags, iterations and salt) needed to calculate hashed ownernames. + +The presence of an NSEC3PARAM RR at a zone apex indicates that the +specified parameters may be used by authoritative servers to choose +an appropriate set of NSEC3 records for negative responses. + +The NSEC3PARAM RR is not used by validators or resolvers. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 algorithm + + $algorithm = $rr->algorithm; + $rr->algorithm( $algorithm ); + +The Hash Algorithm field is represented as an unsigned decimal +integer. The value has a maximum of 255. + +=head2 flags + + $flags = $rr->flags; + $rr->flags( $flags ); + +The Flags field is represented as an unsigned decimal integer. +The value has a maximum of 255. + +=head2 iterations + + $iterations = $rr->iterations; + $rr->iterations( $iterations ); + +The Iterations field is represented as an unsigned decimal +integer. The value is between 0 and 65535, inclusive. + +=head2 salt + + $salt = $rr->salt; + $rr->salt( $salt ); + +The Salt field is represented as a contiguous sequence of hexadecimal +digits. A "-" (unquoted) is used in string format to indicate that the +salt field is absent. + +=head2 saltbin + + $saltbin = $rr->saltbin; + $rr->saltbin( $saltbin ); + +The Salt field as a sequence of octets. + + +=head1 COPYRIGHT + +Copyright (c)2007,2008 NLnet Labs. Author Olaf M. Kolkman + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC5155 + +=cut diff --git a/lib/Net/DNS/RR/NULL.pm b/lib/Net/DNS/RR/NULL.pm new file mode 100644 index 0000000..3532ef0 --- /dev/null +++ b/lib/Net/DNS/RR/NULL.pm @@ -0,0 +1,89 @@ +package Net::DNS::RR::NULL; + +# +# $Id: NULL.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::NULL - DNS NULL resource record + +=cut + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name NULL \# length hexdata ...'); + +=head1 DESCRIPTION + +Class for DNS null (NULL) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 rdlength + + $rdlength = $rr->rdlength; + +Returns the length of the record data section. + +=head2 rdata + + $rdata = $rr->rdata; + $rr->rdata( $rdata ); + +Returns the record data section as binary data. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.10 + +=cut diff --git a/lib/Net/DNS/RR/OPENPGPKEY.pm b/lib/Net/DNS/RR/OPENPGPKEY.pm new file mode 100644 index 0000000..e4741bf --- /dev/null +++ b/lib/Net/DNS/RR/OPENPGPKEY.pm @@ -0,0 +1,141 @@ +package Net::DNS::RR::OPENPGPKEY; + +# +# $Id: OPENPGPKEY.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::OPENPGPKEY - DNS OPENPGPKEY resource record + +=cut + + +use integer; + +use MIME::Base64; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $length = $self->{rdlength}; + $self->keybin( substr $$data, $offset, $length ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a*', $self->keybin; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @base64 = split /\s+/, encode_base64( $self->keybin ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->key(@_); +} + + +sub key { + my $self = shift; + return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; + $self->keybin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub keybin { + my $self = shift; + + $self->{keybin} = shift if scalar @_; + $self->{keybin} || ""; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name OPENPGPKEY key'); + +=head1 DESCRIPTION + +Class for OpenPGP Key (OPENPGPKEY) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 key + + $key = $rr->key; + $rr->key( $key ); + +Base64 encoded representation of the OpenPGP public key material. + +=head2 keybin + + $keybin = $rr->keybin; + $rr->keybin( $keybin ); + +OpenPGP public key material consisting of +a single OpenPGP transferable public key in RFC4880 format. + + +=head1 COPYRIGHT + +Copyright (c)2014 Dick Franks + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC7929 + +=cut diff --git a/lib/Net/DNS/RR/OPT.pm b/lib/Net/DNS/RR/OPT.pm new file mode 100644 index 0000000..42245c7 --- /dev/null +++ b/lib/Net/DNS/RR/OPT.pm @@ -0,0 +1,515 @@ +package Net::DNS::RR::OPT; + +# +# $Id: OPT.pm 1605 2017-11-27 11:37:40Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1605 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::OPT - DNS OPT resource record + +=cut + + +use integer; + +use Carp; +use Net::DNS::Parameters; + +use constant CLASS_TTL_RDLENGTH => length pack 'n N n', (0) x 3; + +use constant OPT => typebyname qw(OPT); + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $index = $offset - CLASS_TTL_RDLENGTH; # OPT redefines class and TTL fields + @{$self}{qw(size rcode version flags)} = unpack "\@$index n C2 n", $$data; + @{$self}{rcode} = @{$self}{rcode} << 4; + delete @{$self}{qw(class ttl)}; + + my $limit = $offset + $self->{rdlength} - 4; + + while ( $offset <= $limit ) { + my ( $code, $length ) = unpack "\@$offset nn", $$data; + my $value = unpack "\@$offset x4 a$length", $$data; + $self->{option}{$code} = $value; + $offset += $length + 4; + } +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $option = $self->{option} || {}; + join '', map pack( 'nna*', $_, length $option->{$_}, $option->{$_} ), keys %$option; +} + + +sub encode { ## overide RR method + my $self = shift; + + my $data = $self->_encode_rdata; + my $size = $self->size; + my @xttl = ( $self->rcode >> 4, $self->version, $self->flags ); + pack 'C n n C2n n a*', 0, OPT, $size, @xttl, length($data), $data; +} + + +sub string { ## overide RR method + my $self = shift; + + my $edns = $self->version; + my $flags = sprintf '%04x', $self->flags; + my $rcode = $self->rcode; + my $size = $self->size; + my @option = sort { $a <=> $b } $self->options; + my @lines = map $self->_format_option($_), @option; + my @format = join "\n;;\t\t", @lines; + + $rcode = 0 if $rcode < 16; # weird: 1 .. 15 not EDNS codes!! + + my $rc = exists( $self->{rdlength} ) && $rcode ? "$rcode + [4-bits]" : rcodebyval($rcode); + + $rc = 'BADVERS' if $rcode == 16; # code 16 unambiguous here + + return <<"QQ"; +;; EDNS version $edns +;; flags: $flags +;; rcode: $rc +;; size: $size +;; option: @format +QQ +} + + +my ( $class, $ttl ); + +sub class { ## overide RR method + carp qq[Usage: OPT has no "class" attribute, please use "size()"] unless $class++; + &size; +} + +sub ttl { ## overide RR method + my $self = shift; + carp qq[Usage: OPT has no "ttl" attribute, please use "flags()" or "rcode()"] unless $ttl++; + my @rcode = map unpack( 'C', pack 'N', $_ ), @_; + my @flags = map unpack( 'x2n', pack 'N', $_ ), @_; + pack 'C2n', $self->rcode(@rcode), $self->version, $self->flags(@flags); +} + + +sub version { + my $version = shift->{version}; + return defined($version) ? $version : 0; +} + + +sub size { + my $self = shift; + for ( $self->{size} ) { + my $UDP_size = 0; + ( $UDP_size, $_ ) = ( shift || 0 ) if scalar @_; + return $UDP_size < 512 ? 512 : ( $_ = $UDP_size ) unless $_; + return $_ > 512 ? $_ : 512; + } +} + + +sub rcode { + my $self = shift; + return $self->{rcode} || 0 unless scalar @_; + delete $self->{rdlength}; # (ab)used to signal incomplete value + my $val = shift || 0; + $self->{rcode} = $val < 16 ? 0 : $val; # discard non-EDNS rcodes 1 .. 15 +} + + +sub flags { + my $self = shift; + return $self->{flags} || 0 unless scalar @_; + $self->{flags} = shift; +} + + +sub options { + my ($self) = @_; + my $options = $self->{option} || {}; + return keys %$options; +} + +sub option { + my $self = shift; + my $number = ednsoptionbyname(shift); + return $self->_get_option($number) unless scalar @_; + $self->_set_option( $number, @_ ); +} + + +sub _format_option { + my ( $self, $number ) = @_; + my $option = ednsoptionbyval($number); + my $options = $self->{option} || {}; + my $payload = $options->{$number}; + return () unless defined $payload; + my $package = join '::', __PACKAGE__, $option; + $package =~ s/-/_/g; + my $defined = length($payload) && $package->can('_image'); + my @payload = $defined ? eval { $package->_image($payload) } : unpack 'H*', $payload; + Net::DNS::RR::_wrap( "$option\t=> (", @payload, ')' ); +} + + +sub _get_option { + my ( $self, $number ) = @_; + + my $options = $self->{option} || {}; + my $payload = $options->{$number}; + return $payload unless wantarray; + return () unless $payload; + my $package = join '::', __PACKAGE__, ednsoptionbyval($number); + $package =~ s/-/_/g; + return ( 'OPTION-DATA' => $payload ) unless $package->can('_decompose'); + my @payload = eval { $package->_decompose($payload) }; +} + + +sub _set_option { + my ( $self, $number, $value, @etc ) = @_; + + my $options = $self->{option} ||= {}; + delete $options->{$number}; + if ( ref($value) || scalar(@etc) ) { + my $option = ednsoptionbyval($number); + my @arg = ( $value, @etc ); + @arg = @$value if ref($value) eq 'ARRAY'; + @arg = %$value if ref($value) eq 'HASH'; + if ( $arg[0] eq 'OPTION-DATA' ) { + $value = $arg[1]; + } else { + my $package = join '::', __PACKAGE__, $option; + $package =~ s/-/_/g; + croak "unable to compose option $option" unless $package->can('_compose'); + $value = $package->_compose(@arg); + } + } + $options->{$number} = $value if defined $value; +} + + +sub _specified { + my $self = shift; + my @spec = grep $self->{$_}, qw(size flags rcode option); + scalar @spec; +} + + +######################################## + +package Net::DNS::RR::OPT::DAU; # RFC6975 + +sub _compose { + my ( $class, @argument ) = @_; + pack 'C*', @argument; +} + +sub _decompose { + my @payload = unpack 'C*', $_[1]; +} + +sub _image { &_decompose; } + + +package Net::DNS::RR::OPT::DHU; # RFC6975 +our @ISA = qw(Net::DNS::RR::OPT::DAU); + +package Net::DNS::RR::OPT::N3U; # RFC6975 +our @ISA = qw(Net::DNS::RR::OPT::DAU); + + +package Net::DNS::RR::OPT::CLIENT_SUBNET; # RFC7871 +use Net::DNS::RR::A; +use Net::DNS::RR::AAAA; + +my %family = qw(1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA); +my @field = qw(FAMILY SOURCE-PREFIX-LENGTH SCOPE-PREFIX-LENGTH ADDRESS); + +sub _compose { + my ( $class, %argument ) = @_; + my $address = bless( {}, $family{$argument{FAMILY}} )->address( $argument{ADDRESS} ); + my $preamble = pack 'nC2', map $_ ||= 0, @argument{@field}; + my $bitmask = $argument{'SOURCE-PREFIX-LENGTH'}; + pack "a* B$bitmask", $preamble, unpack 'B*', $address; +} + +sub _decompose { + my %hash; + @hash{@field} = unpack 'nC2a*', $_[1]; + $hash{ADDRESS} = bless( {address => $hash{ADDRESS}}, $family{$hash{FAMILY}} )->address; + my @payload = map { ( $_ => $hash{$_} ) } @field; +} + +sub _image { &_decompose; } + + +package Net::DNS::RR::OPT::EXPIRE; # RFC7314 + +sub _compose { + my ( $class, %argument ) = @_; + pack 'N', values %argument; +} + +sub _decompose { + my @payload = ( 'EXPIRE-TIMER' => unpack 'N', $_[1] ); +} + +sub _image { &_decompose; } + + +package Net::DNS::RR::OPT::COOKIE; # RFC7873 + +my @key = qw(CLIENT-COOKIE SERVER-COOKIE); + +sub _compose { + my ( $class, %argument ) = @_; + pack 'a8 a*', map $_ || '', @argument{@key}; +} + +sub _decompose { + my %hash; + my $template = ( length( $_[1] ) < 16 ) ? 'a8' : 'a8 a*'; + @hash{@key} = unpack $template, $_[1]; + my @payload = map { ( $_ => $hash{$_} ) } @key; +} + + +package Net::DNS::RR::OPT::TCP_KEEPALIVE; # RFC7828 + +sub _compose { + my ( $class, %argument ) = @_; + pack 'n', values %argument; +} + +sub _decompose { + my @payload = ( TIMEOUT => unpack 'n', $_[1] ); +} + +sub _image { &_decompose; } + + +package Net::DNS::RR::OPT::PADDING; # RFC7830 + +sub _compose { + my ( $class, %argument ) = @_; + my ($size) = values %argument; + pack "x$size"; +} + +sub _decompose { + my @payload = ( 'OPTION-LENGTH' => length( $_[1] ) ); +} + +sub _image { &_decompose; } + + +package Net::DNS::RR::OPT::CHAIN; # RFC7901 +use Net::DNS::DomainName; + +sub _compose { + my ( $class, %argument ) = @_; + my ($trust_point) = values %argument; + Net::DNS::DomainName->new( $trust_point || return '' )->encode; +} + +sub _decompose { + my ( $class, $payload ) = @_; + my $fqdn = Net::DNS::DomainName->decode( \$payload )->string; + my @payload = ( 'CLOSEST-TRUST-POINT' => $fqdn ); +} + +sub _image { &_decompose; } + + +package Net::DNS::RR::OPT::KEY_TAG; # RFC8145 + +sub _compose { + my ( $class, @argument ) = @_; + pack 'n*', @argument; +} + +sub _decompose { + my @payload = unpack 'n*', $_[1]; +} + +sub _image { &_decompose; } + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $packet = new Net::DNS::Packet( ... ); + + $packet->header->do(1); # extended flag + + $packet->edns->size(1280); # UDP payload size + + $packet->edns->option( COOKIE => $cookie ); + + $packet->edns->print; + + ;; EDNS version 0 + ;; flags: 8000 + ;; rcode: NOERROR + ;; size: 1280 + ;; option: COOKIE => ( 7261776279746573 ) + +=head1 DESCRIPTION + +EDNS OPT pseudo resource record. + +The OPT record supports EDNS protocol extensions and is not intended to be +created, accessed or modified directly by user applications. + +All EDNS features are performed indirectly by operations on the objects +returned by the $packet->header and $packet->edns creator methods. +The underlying mechanisms are entirely hidden from the user. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 version + + $version = $rr->version; + +The version of EDNS used by this OPT record. + +=head2 size + + $size = $packet->edns->size; + $more = $packet->edns->size(1280); + +size() advertises the maximum size (octets) of UDP packet that can be +reassembled in the network stack of the originating host. + +=head2 rcode + + $extended_rcode = $packet->header->rcode; + $incomplete_rcode = $packet->edns->rcode; + +The 12 bit extended RCODE. The most significant 8 bits reside in the OPT +record. The least significant 4 bits can only be obtained from the packet +header. + +=head2 flags + + $edns_flags = $packet->edns->flags; + + $do = $packet->header->do; + $packet->header->do(1); + +16 bit field containing EDNS extended header flags. + +=head2 options, option + + @option = $packet->edns->options; + + $octets = $packet->edns->option($option_code); + + $packet->edns->option( COOKIE => $cookie ); + $packet->edns->option( 10 => $cookie ); + +When called in a list context, options() returns a list of option codes +found in the OPT record. + +When called in a scalar context with a single argument, +option() returns the uninterpreted octet string +corresponding to the specified option. +The method returns undef if the specified option is absent. + +Options can be added or replaced by providing the (name => string) pair. +The option is deleted if the value is undefined. + + +When option() is called in a list context with a single argument, +the returned array provides a structured interpretation +appropriate to the specified option. + +For the example above: + + %hash = $packet->edns->option(10); + + { + 'CLIENT-COOKIE' => 'rawbytes', + 'SERVER-COOKIE' => undef + }; + + +For some options, an array is more appropriate: + + @algorithms = $packet->edns->option(6); + + +Similar forms of array syntax may be used to construct the option value: + + $packet->edns->option( DHU => [1, 2, 4] ); + $packet->edns->option( 6 => (1, 2, 4) ); + + $packet->edns->option( COOKIE => {'CLIENT-COOKIE' => $cookie} ); + $packet->edns->option( 10 => ('CLIENT-COOKIE' => $cookie) ); + + +=head1 COPYRIGHT + +Copyright (c)2001,2002 RIPE NCC. Author Olaf M. Kolkman. + +Portions Copyright (c)2012,2017 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC6891, RFC3225 + +=cut diff --git a/lib/Net/DNS/RR/PTR.pm b/lib/Net/DNS/RR/PTR.pm new file mode 100644 index 0000000..3bd4a5d --- /dev/null +++ b/lib/Net/DNS/RR/PTR.pm @@ -0,0 +1,127 @@ +package Net::DNS::RR::PTR; + +# +# $Id: PTR.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::PTR - DNS PTR resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + + $self->{ptrdname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $ptrdname = $self->{ptrdname}; + $ptrdname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $ptrdname = $self->{ptrdname}; + $ptrdname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->ptrdname(shift); +} + + +sub ptrdname { + my $self = shift; + + $self->{ptrdname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{ptrdname}->name if $self->{ptrdname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name PTR ptrdname'); + +=head1 DESCRIPTION + +Class for DNS Pointer (PTR) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 ptrdname + + $ptrdname = $rr->ptrdname; + $rr->ptrdname( $ptrdname ); + +A domain name which points to some location in the +domain name space. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.12 + +=cut diff --git a/lib/Net/DNS/RR/PX.pm b/lib/Net/DNS/RR/PX.pm new file mode 100644 index 0000000..3ecfef8 --- /dev/null +++ b/lib/Net/DNS/RR/PX.pm @@ -0,0 +1,177 @@ +package Net::DNS::RR::PX; + +# +# $Id: PX.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::PX - DNS PX resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + ( $self->{map822}, $offset ) = decode Net::DNS::DomainName2535( $data, $offset + 2, @opaque ); + ( $self->{mapx400}, $offset ) = decode Net::DNS::DomainName2535( $data, $offset + 0, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $mapx400 = $self->{mapx400}; + my $rdata = pack( 'n', $self->{preference} ); + $rdata .= $self->{map822}->encode( $offset + 2, @opaque ); + $rdata .= $mapx400->encode( $offset + length($rdata), @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @rdata = ( $self->preference, $self->{map822}->string, $self->{mapx400}->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->map822(shift); + $self->mapx400(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub map822 { + my $self = shift; + + $self->{map822} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{map822}->name if $self->{map822}; +} + + +sub mapx400 { + my $self = shift; + + $self->{mapx400} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{mapx400}->name if $self->{mapx400}; +} + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name PX preference map822 mapx400'); + +=head1 DESCRIPTION + +Class for DNS X.400 Mail Mapping Information (PX) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + +A 16 bit integer which specifies the preference +given to this RR among others at the same owner. +Lower values are preferred. + +=head2 map822 + + $map822 = $rr->map822; + $rr->map822( $map822 ); + +A domain name element containing , the +RFC822 part of the MIXER Conformant Global Address Mapping. + +=head2 mapx400 + + $mapx400 = $rr->mapx400; + $rr->mapx400( $mapx400 ); + +A element containing the value of + derived from the X.400 part of +the MIXER Conformant Global Address Mapping. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC2163 + +=cut diff --git a/lib/Net/DNS/RR/RP.pm b/lib/Net/DNS/RR/RP.pm new file mode 100644 index 0000000..8fd949b --- /dev/null +++ b/lib/Net/DNS/RR/RP.pm @@ -0,0 +1,154 @@ +package Net::DNS::RR::RP; + +# +# $Id: RP.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::RP - DNS RP resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; +use Net::DNS::Mailbox; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + ( $self->{mbox}, $offset ) = decode Net::DNS::Mailbox2535( $data, $offset, @opaque ); + $self->{txtdname} = decode Net::DNS::DomainName2535( $data, $offset, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $txtdname = $self->{txtdname}; + my $rdata = $self->{mbox}->encode( $offset, @opaque ); + $rdata .= $txtdname->encode( $offset + length($rdata), @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @rdata = ( $self->{mbox}->string, $self->{txtdname}->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->mbox(shift); + $self->txtdname(shift); +} + + +sub mbox { + my $self = shift; + + $self->{mbox} = new Net::DNS::Mailbox2535(shift) if scalar @_; + $self->{mbox}->address if $self->{mbox}; +} + + +sub txtdname { + my $self = shift; + + $self->{txtdname} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{txtdname}->name if $self->{txtdname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name RP mbox txtdname'); + +=head1 DESCRIPTION + +Class for DNS Responsible Person (RP) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 mbox + + $mbox = $rr->mbox; + $rr->mbox( $mbox ); + +A domain name which specifies the mailbox for the person responsible for +this domain. The format in master files uses the DNS encoding convention +for mailboxes, identical to that used for the RNAME mailbox field in the +SOA RR. The root domain name (just ".") may be specified to indicate that +no mailbox is available. + +=head2 txtdname + + $txtdname = $rr->txtdname; + $rr->txtdname( $txtdname ); + +A domain name identifying TXT RRs. A subsequent query can be performed to +retrieve the associated TXT records. This provides a level of indirection +so that the entity can be referred to from multiple places in the DNS. The +root domain name (just ".") may be specified to indicate that there is no +associated TXT RR. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1183 Section 2.2 + +=cut diff --git a/lib/Net/DNS/RR/RRSIG.pm b/lib/Net/DNS/RR/RRSIG.pm new file mode 100644 index 0000000..453e960 --- /dev/null +++ b/lib/Net/DNS/RR/RRSIG.pm @@ -0,0 +1,875 @@ +package Net::DNS::RR::RRSIG; + +# +# $Id: RRSIG.pm 1623 2018-01-26 14:23:54Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1623 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::RRSIG - DNS RRSIG resource record + +=cut + + +use integer; + +use Carp; +use MIME::Base64; +use Time::Local; + +use Net::DNS::Parameters; + +use constant DEBUG => 0; + +use constant UTIL => defined eval 'use Scalar::Util 1.25; 1;'; + +use constant PRIVATE => defined eval 'require Net::DNS::SEC::Private'; + +use constant DSA => defined eval 'require Net::DNS::SEC::DSA'; +use constant RSA => defined eval 'require Net::DNS::SEC::RSA'; + +use constant ECDSA => defined eval 'require Net::DNS::SEC::ECDSA'; +use constant EdDSA => defined eval 'require Net::DNS::SEC::EdDSA'; +use constant GOST => defined eval 'require Digest::GOST; require Net::DNS::SEC::ECCGOST'; + +use constant DNSSEC => PRIVATE && ( RSA || DSA || ECDSA || EdDSA ); + +my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; + ( $self->{signame}, $offset ) = decode Net::DNS::DomainName( $data, $offset + 18 ); + $self->{sigbin} = substr $$data, $offset, $limit - $offset; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $signame = $self->{signame}; + pack 'n C2 N3 n a* a*', @{$self}{@field}, $signame->canonical, $self->sigbin; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $signame = $self->{signame}; + my @sig64 = split /\s+/, encode_base64( $self->sigbin ); + my @rdata = ( map( $self->$_, @field ), $signame->string, @sig64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach ( @field, qw(signame) ) { $self->$_(shift) } + $self->signature(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->sigval(30); +} + + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + my @algbyname = ( + 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] + 'RSAMD5' => 1, # [RFC3110][RFC4034] + 'DH' => 2, # [RFC2539] + 'DSA' => 3, # [RFC3755][RFC2536] + ## Reserved => 4, # [RFC6725] + 'RSASHA1' => 5, # [RFC3110][RFC4034] + 'DSA-NSEC3-SHA1' => 6, # [RFC5155] + 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] + 'RSASHA256' => 8, # [RFC5702] + ## Reserved => 9, # [RFC6725] + 'RSASHA512' => 10, # [RFC5702] + ## Reserved => 11, # [RFC6725] + 'ECC-GOST' => 12, # [RFC5933] + 'ECDSAP256SHA256' => 13, # [RFC6605] + 'ECDSAP384SHA384' => 14, # [RFC6605] + 'ED25519' => 15, # [RFC8080] + 'ED448' => 16, # [RFC8080] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @algbyname; + my %algbyname = @algrehash; # work around broken cperl + + sub _algbyname { + my $arg = shift; + my $key = uc $arg; # synthetic key + $key =~ s/[\W_]//g; # strip non-alphanumerics + my $val = $algbyname{$key}; + return $val if defined $val; + return $key =~ /^\d/ ? $arg : croak "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + + +my $RSA = RSA ? 'Net::DNS::SEC::RSA' : 0; +my $DSA = DSA ? 'Net::DNS::SEC::DSA' : 0; +my $ECDSA = ECDSA ? 'Net::DNS::SEC::ECDSA' : 0; +my $EdDSA = EdDSA ? 'Net::DNS::SEC::EdDSA' : 0; +my $GOST = GOST ? 'Net::DNS::SEC::ECCGOST' : 0; + +my %SEC = ( + 3 => $DSA, + 5 => $RSA, + 6 => $DSA, + 7 => $RSA, + 8 => $RSA, + 10 => $RSA, + 12 => $GOST, + 13 => $ECDSA, + 14 => $ECDSA, + 15 => $EdDSA, + 16 => $EdDSA, + ); + + +sub typecovered { + my $self = shift; + $self->{typecovered} = typebyname(shift) if scalar @_; + my $typecode = $self->{typecovered}; + typebyval($typecode) if defined wantarray && defined $typecode; +} + + +sub algorithm { + my ( $self, $arg ) = @_; + + unless ( ref($self) ) { ## class method or simple function + my $argn = pop; + return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); + } + + return $self->{algorithm} unless defined $arg; + return _algbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; + return $self->{algorithm} = _algbyname($arg); +} + + +sub labels { + my $self = shift; + + $self->{labels} = 0 + shift if scalar @_; + $self->{labels} || 0; +} + + +sub orgttl { + my $self = shift; + + $self->{orgttl} = 0 + shift if scalar @_; + $self->{orgttl} || 0; +} + + +sub sigexpiration { + my $self = shift; + $self->{sigexpiration} = _string2time(shift) if scalar @_; + my $time = $self->{sigexpiration}; + return unless defined wantarray && defined $time; + return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); +} + +sub siginception { + my $self = shift; + $self->{siginception} = _string2time(shift) if scalar @_; + my $time = $self->{siginception}; + return unless defined wantarray && defined $time; + return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); +} + +sub sigex { &sigexpiration; } ## historical + +sub sigin { &siginception; } ## historical + +sub sigval { + my $self = shift; + no integer; + ( $self->{sigval} ) = map int( 86400 * $_ ), @_; +} + + +sub keytag { + my $self = shift; + + $self->{keytag} = 0 + shift if scalar @_; + $self->{keytag} || 0; +} + + +sub signame { + my $self = shift; + + $self->{signame} = new Net::DNS::DomainName(shift) if scalar @_; + $self->{signame}->name if $self->{signame}; +} + + +sub sig { + my $self = shift; + return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @_; + $self->sigbin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub sigbin { + my $self = shift; + + $self->{sigbin} = shift if scalar @_; + $self->{sigbin} || ""; +} + + +sub signature { &sig; } + + +sub create { + unless (DNSSEC) { + croak 'Net::DNS::SEC support not available'; + } else { + my ( $class, $rrsetref, $priv_key, %etc ) = @_; + + $rrsetref = [$rrsetref] unless ref($rrsetref) eq 'ARRAY'; + my $RR = $rrsetref->[0]; + croak '$rrsetref is not reference to RR array' unless ref($RR) =~ /^Net::DNS::RR/; + + # All the TTLs need to be the same in the data RRset. + my $ttl = $RR->ttl; + my @ttl = grep $_->ttl != $ttl, @$rrsetref; + croak 'RRs in RRset do not have same TTL' if scalar @ttl; + + my $private = ref($priv_key) ? $priv_key : Net::DNS::SEC::Private->new($priv_key); + croak 'unable to parse private key' unless ref($private) eq 'Net::DNS::SEC::Private'; + + my @label = grep $_ ne chr(42), $RR->{owner}->_wire; # count labels + + my $self = new Net::DNS::RR( + name => $RR->name, + type => 'RRSIG', + class => 'IN', + ttl => $ttl, + typecovered => $RR->type, + labels => scalar @label, + orgttl => $ttl, + siginception => time(), + algorithm => $private->algorithm, + keytag => $private->keytag, + signame => $private->signame, + ); + + while ( my ( $attribute, $value ) = each %etc ) { + $self->$attribute($value); + } + + $self->{sigexpiration} = $self->{siginception} + $self->{sigval} + unless $self->{sigexpiration}; + + $self->_CreateSig( $self->_CreateSigData($rrsetref), $private ); + return $self; + } +} + + +sub verify { + + # Reminder... + + # $rrsetref must be a reference to an array of RR objects. + + # $keyref is either a key object or a reference to an array + # of key objects. + + if (DNSSEC) { + my ( $self, $rrsetref, $keyref ) = @_; + + croak '$keyref argument is scalar or undefined' unless ref($keyref); + + print '$keyref argument is ', ref($keyref), "\n" if DEBUG; + if ( ref($keyref) eq "ARRAY" ) { + + # We will recurse for each key that matches algorithm and key-id + # and return when there is a successful verification. + # If not, we will continue so that we can survive key-id collision. + # The downside of this is that the error string only matches the + # last error. + + print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG; + my @error; + my $i; + foreach my $keyrr (@$keyref) { + my $result = $self->verify( $rrsetref, $keyrr ); + return $result if $result; + my $error = $self->{vrfyerrstr}; + $i++; + push @error, "key $i: $error"; + print "key $i: $error\n" if DEBUG; + next; + } + + $self->{vrfyerrstr} = join "\n", @error; + return 0; + + } elsif ( $keyref->isa('Net::DNS::RR::DNSKEY') ) { + + print "Validating using key with keytag: ", $keyref->keytag, "\n" if DEBUG; + + } else { + croak join ' ', ref($keyref), 'can not be used as DNSSEC key'; + } + + + $rrsetref = [$rrsetref] unless ref($rrsetref) eq 'ARRAY'; + my $RR = $rrsetref->[0]; + croak '$rrsetref not a reference to array of RRs' unless ref($RR) =~ /^Net::DNS::RR/; + + if (DEBUG) { + print "\n ---------------------- RRSIG DEBUG --------------------"; + print "\n SIG:\t", $self->string; + print "\n KEY:\t", $keyref->string; + print "\n -------------------------------------------------------\n"; + } + + $self->{vrfyerrstr} = ''; + unless ( $self->algorithm == $keyref->algorithm ) { + $self->{vrfyerrstr} = 'algorithm does not match'; + return 0; + } + + unless ( $self->keytag == $keyref->keytag ) { + $self->{vrfyerrstr} = 'keytag does not match'; + return 0; + } + + $self->_VerifySig( $self->_CreateSigData($rrsetref), $keyref ) || return 0; + + # time to do some time checking. + my $t = time; + + if ( _ordered( $self->{sigexpiration}, $t ) ) { + $self->{vrfyerrstr} = join ' ', 'Signature expired at', $self->sigexpiration; + return 0; + } elsif ( _ordered( $t, $self->{siginception} ) ) { + $self->{vrfyerrstr} = join ' ', 'Signature valid from', $self->siginception; + return 0; + } + + return 1; + } +} #END verify + + +sub vrfyerrstr { + my $self = shift; + $self->{vrfyerrstr}; +} + + +######################################## + +sub _ordered($$) { ## irreflexive 32-bit partial ordering + use integer; + my ( $a, $b ) = @_; + + return defined $b unless defined $a; # ( undef, any ) + return 0 unless defined $b; # ( any, undef ) + + # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished + if ( $a < 0 ) { # translate $a<0 region + $a = ( $a ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $a < 2**31 + $b = ( $b ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $b < 2**32 + } + + return $a < $b ? ( $a > ( $b - 0x80000000 ) ) : ( $b < ( $a - 0x80000000 ) ); +} + + +my $y1998 = timegm( 0, 0, 0, 1, 0, 1998 ); +my $y2026 = timegm( 0, 0, 0, 1, 0, 2026 ); +my $y2082 = $y2026 << 1; +my $y2054 = $y2082 - $y1998; +my $m2026 = int( 0x80000000 - $y2026 ); +my $m2054 = int( 0x80000000 - $y2054 ); +my $t2082 = int( $y2082 & 0x7FFFFFFF ); +my $t2100 = 1960058752; + +sub _string2time { ## parse time specification string + my $arg = shift; + croak 'undefined time' unless defined $arg; + return int($arg) if length($arg) < 12; + my ( $y, $m, @dhms ) = unpack 'a4 a2 a2 a2 a2 a2', $arg . '00'; + if ( $arg lt '20380119031408' ) { # calendar folding + return timegm( reverse(@dhms), $m - 1, $y ) if $y < 2026; + return timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2026; + } elsif ( $y > 2082 ) { + my $z = timegm( reverse(@dhms), $m - 1, $y - 84 ); # expunge 29 Feb 2100 + return $z < 1456790400 ? $z + $y2054 : $z + $y2054 - 86400; + } + return ( timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2054 ) - $y1998; +} + + +sub _time2string { ## format time specification string + my $arg = shift; + croak 'undefined time' unless defined $arg; + my $ls31 = int( $arg & 0x7FFFFFFF ); + if ( $arg & 0x80000000 ) { + + if ( $ls31 > $t2082 ) { + $ls31 += 86400 unless $ls31 < $t2100; # expunge 29 Feb 2100 + my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2054 ) )[0 .. 5] ); + return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1984, $mm + 1, @dhms; + } + + my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2026 ) )[0 .. 5] ); + return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; + + + } elsif ( $ls31 > $y2026 ) { + my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 - $y2026 ) )[0 .. 5] ); + return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; + } + + my ( $yy, $mm, @dhms ) = reverse( ( gmtime $ls31 )[0 .. 5] ); + return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1900, $mm + 1, @dhms; +} + + +sub _CreateSigData { + + # This method creates the data string that will be signed. + # See RFC4034(6) and RFC6840(5.1) on how this string is constructed + + # This method is called by the method that creates a signature + # and by the method that verifies the signature. It is assumed + # that the creation method has checked that all the TTLs are + # the same for the rrsetref and that sig->orgttl has been set + # to the TTL of the data. This method will set the datarr->ttl + # to the sig->orgttl for all the RR in the rrsetref. + + if (DNSSEC) { + my ( $self, $rrsetref ) = @_; + + print "_CreateSigData\n" if DEBUG; + + croak 'SIG0 using RRSIG not permitted' unless ref($rrsetref); + + my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); + my $sigdata = pack 'n C2 N3 n a*', @{$self}{@field}, $self->{signame}->canonical; + print "\npreamble\t", unpack( 'H*', $sigdata ), "\n" if DEBUG; + + my $owner = $self->{owner}; # create wildcard domain name + my $limit = $self->{labels}; + my @label = $owner->_wire; + shift @label while scalar @label > $limit; + my $wild = bless {label => \@label}, ref($owner); # DIY to avoid wrecking name cache + my $suffix = $wild->canonical; + unshift @label, chr(42); # asterisk + + my @RR = map bless( {%$_}, ref($_) ), @$rrsetref; # shallow RR clone + my $RR = $RR[0]; + my $class = $RR->class; + my $type = $RR->type; + + my $ttl = $self->orgttl; + my %table; + foreach my $RR (@RR) { + my $ident = $RR->{owner}->canonical; + my $match = substr $ident, -length($suffix); + croak 'RRs in RRset have different NAMEs' if $match ne $suffix; + croak 'RRs in RRset have different TYPEs' if $type ne $RR->type; + croak 'RRs in RRset have different CLASS' if $class ne $RR->class; + $RR->ttl($ttl); # reset TTL + + my $offset = 10 + length($suffix); # RDATA offset + if ( $ident ne $match ) { + $RR->{owner} = $wild; + $offset += 2; + print "\nsubstituting wildcard name: ", $RR->name if DEBUG; + } + + # For sorting we create a hash table of canonical data keyed on RDATA + my $canonical = $RR->canonical; + $table{substr $canonical, $offset} = $canonical; + } + + $sigdata = join '', $sigdata, map $table{$_}, sort keys %table; + + if (DEBUG) { + my $i = 0; + foreach my $rdata ( sort keys %table ) { + print "\n>>> ", $i++, "\tRDATA:\t", unpack 'H*', $rdata; + print "\nRR: ", unpack( 'H*', $table{$rdata} ), "\n"; + } + print "\n sigdata:\t", unpack( 'H*', $sigdata ), "\n"; + } + + return $sigdata; + } +} + + +######################################## + +sub _CreateSig { + if (DNSSEC) { + my $self = shift; + + my $algorithm = $self->algorithm; + my $class = $SEC{$algorithm}; + + eval { + die "algorithm $algorithm not supported" unless $class; + $self->sigbin( $class->sign(@_) ); + } || croak "${@}signature generation failed"; + } +} + + +sub _VerifySig { + if (DNSSEC) { + my $self = shift; + + my $algorithm = $self->algorithm; + my $class = $SEC{$algorithm}; + + my $retval = eval { + die "algorithm $algorithm not supported" unless $class; + $class->verify( @_, $self->sigbin ); + }; + + unless ($retval) { + $self->{vrfyerrstr} = "${@}signature verification failed"; + print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; + return 0; + } + + # uncoverable branch true # bug in Net::DNS::SEC or dependencies + croak "unknown error in $class->verify" unless $retval == 1; + print "\nalgorithm $algorithm verification successful\n" if DEBUG; + return 1; + } +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name RRSIG typecovered algorithm labels + orgttl sigexpiration siginception + keytag signame signature'); + + use Net::DNS::SEC; + $sigrr = create Net::DNS::RR::RRSIG( \@rrset, $keypath, + sigex => 20171231010101 + sigin => 20171201010101 + ); + + $sigrr->verify( \@rrset, $keyrr ) || die $sigrr->vrfyerrstr; + +=head1 DESCRIPTION + +Class for DNS digital signature (RRSIG) resource records. + +In addition to the regular methods inherited from Net::DNS::RR the +class contains a method to sign RRsets using private keys (create) +and a method for verifying signatures over RRsets (verify). + +The RRSIG RR is an implementation of RFC4034. +See L for an implementation of SIG0 (RFC2931). + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 typecovered + + $typecovered = $rr->typecovered; + +The typecovered field identifies the type of the RRset that is +covered by this RRSIG record. + +=head2 algorithm + + $algorithm = $rr->algorithm; + +The algorithm number field identifies the cryptographic algorithm +used to create the signature. + +algorithm() may also be invoked as a class method or simple function +to perform mnemonic and numeric code translation. + +=head2 labels + + $labels = $rr->labels; + $rr->labels( $labels ); + +The labels field specifies the number of labels in the original RRSIG +RR owner name. + +=head2 orgttl + + $orgttl = $rr->orgttl; + $rr->orgttl( $orgttl ); + +The original TTL field specifies the TTL of the covered RRset as it +appears in the authoritative zone. + +=head2 sigexpiration and siginception times + +=head2 sigex sigin sigval + + $expiration = $rr->sigexpiration; + $expiration = $rr->sigexpiration( $value ); + + $inception = $rr->siginception; + $inception = $rr->siginception( $value ); + +The signature expiration and inception fields specify a validity +time interval for the signature. + +The value may be specified by a string with format 'yyyymmddhhmmss' +or a Perl time() value. + +Return values are dual-valued, providing either a string value or +numerical Perl time() value. + +=head2 keytag + + $keytag = $rr->keytag; + $rr->keytag( $keytag ); + +The keytag field contains the key tag value of the DNSKEY RR that +validates this signature. + +=head2 signame + + $signame = $rr->signame; + $rr->signame( $signame ); + +The signer name field value identifies the owner name of the DNSKEY +RR that a validator is supposed to use to validate this signature. + +=head2 signature + +=head2 sig + + $sig = $rr->sig; + $rr->sig( $sig ); + +The Signature field contains the cryptographic signature that covers +the RRSIG RDATA (excluding the Signature field) and the RRset +specified by the RRSIG owner name, RRSIG class, and RRSIG type +covered fields. + +=head2 sigbin + + $sigbin = $rr->sigbin; + $rr->sigbin( $sigbin ); + +Binary representation of the cryptographic signature. + +=head2 create + +Create a signature over a RR set. + + use Net::DNS::SEC; + + $keypath = '/home/olaf/keys/Kbla.foo.+001+60114.private'; + + $sigrr = create Net::DNS::RR::RRSIG( \@rrsetref, $keypath ); + + $sigrr = create Net::DNS::RR::RRSIG( \@rrsetref, $keypath, + sigex => 20171231010101 + sigin => 20171201010101 + ); + $sigrr->print; + + + # Alternatively use Net::DNS::SEC::Private + + $private = Net::DNS::SEC::Private->new($keypath); + + $sigrr= create Net::DNS::RR::RRSIG( \@rrsetref, $private ); + + +create() is an alternative constructor for a RRSIG RR object. + +This method returns an RRSIG with the signature over the subject rrset +(an array of RRs) made with the private key stored in the key file. + +The first argument is a reference to an array that contains the RRset +that needs to be signed. + +The second argument is a string which specifies the path to a file +containing the private key as generated by dnssec-keygen. + +The optional remaining arguments consist of ( name => value ) pairs +as follows: + + sigex => 20171231010101, # signature expiration + sigin => 20171201010101, # signature inception + sigval => 30, # validity window (days) + ttl => 3600 # TTL + +The sigin and sigex values may be specified as Perl time values or as +a string with the format 'yyyymmddhhmmss'. The default for sigin is +the time of signing. + +The sigval argument specifies the signature validity window in days +( sigex = sigin + sigval ). + +By default the signature is valid for 30 days. + +By default the TTL matches the RRset that is presented for signing. + +=head2 verify + + $verify = $sigrr->verify( $rrsetref, $keyrr ); + $verify = $sigrr->verify( $rrsetref, [$keyrr, $keyrr2, $keyrr3] ); + +$rrsetref contains a reference to an array of RR objects and the +method verifies the RRset against the signature contained in the +$sigrr object itself using the public key in $keyrr. + +The second argument can either be a Net::DNS::RR::KEYRR object or a +reference to an array of such objects. Verification will return +successful as soon as one of the keys in the array leads to positive +validation. + +Returns 0 on error and sets $sig->vrfyerrstr + +=head2 vrfyerrstr + + $verify = $sigrr->verify( $rrsetref, $keyrr ); + print $sigrr->vrfyerrstr unless $verify; + + $sigrr->verify( $rrsetref, $keyrr ) || die $sigrr->vrfyerrstr; + +=head1 KEY GENERATION + +Private key files and corresponding public DNSKEY records +are most conveniently generated using dnssec-keygen, +a program that comes with the ISC BIND distribution. + + dnssec-keygen -a 10 -b 2048 -f ksk rsa.example. + dnssec-keygen -a 10 -b 1024 rsa.example. + + dnssec-keygen -a 14 -f ksk ecdsa.example. + dnssec-keygen -a 14 ecdsa.example. + +Do not change the name of the file generated by dnssec-keygen. +The create method uses the filename to determine the keyowner, +algorithm and the keyid (keytag). + + +=head1 REMARKS + +The code is not optimised for speed. +It is probably not suitable to be used for signing large zones. + +If this code is still around in 2100 (not a leap year) you will +need to check for proper handling of times ... + +=head1 ACKNOWLEDGMENTS + +Andy Vaskys (Network Associates Laboratories) supplied the code for +handling RSA with SHA1 (Algorithm 5). + +T.J. Mather, the Crypt::OpenSSL::DSA maintainer, for his quick +responses to bug report and feature requests. + +Dick Franks added support for elliptic curve signatures. + +Mike McCauley created the Crypt::OpenSSL::ECDSA perl extension module +specifically for this development. + + +=head1 COPYRIGHT + +Copyright (c)2001-2005 RIPE NCC, Olaf M. Kolkman + +Copyright (c)2007-2008 NLnet Labs, Olaf M. Kolkman + +Portions Copyright (c)2014 Dick Franks + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, +RFC4034, RFC6840, RFC3755, +L, +L, +L, +L + +L + +L + +=cut diff --git a/lib/Net/DNS/RR/RT.pm b/lib/Net/DNS/RR/RT.pm new file mode 100644 index 0000000..d3e6e74 --- /dev/null +++ b/lib/Net/DNS/RR/RT.pm @@ -0,0 +1,156 @@ +package Net::DNS::RR::RT; + +# +# $Id: RT.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::RT - DNS RT resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + $self->{intermediate} = decode Net::DNS::DomainName2535( $data, $offset + 2, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + pack 'n a*', $self->preference, $self->{intermediate}->encode( $offset + 2, @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->preference, $self->{intermediate}->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->intermediate(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub intermediate { + my $self = shift; + + $self->{intermediate} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{intermediate}->name if $self->{intermediate}; +} + + +my $function = sub { ## sort RRs in numerically ascending order. + $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; +}; + +__PACKAGE__->set_rrsort_func( 'preference', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name RT preference intermediate'); + +=head1 DESCRIPTION + +Class for DNS Route Through (RT) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 preference + + $preference = $rr->preference; + $rr->preference( $preference ); + + A 16 bit integer representing the preference of the route. +Smaller numbers indicate more preferred routes. + +=head2 intermediate + + $intermediate = $rr->intermediate; + $rr->intermediate( $intermediate ); + +The domain name of a host which will serve as an intermediate +in reaching the host specified by the owner name. +The DNS RRs associated with the intermediate host are expected +to include at least one A, X25, or ISDN record. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1183 Section 3.3 + +=cut diff --git a/lib/Net/DNS/RR/SIG.pm b/lib/Net/DNS/RR/SIG.pm new file mode 100644 index 0000000..64dbaf0 --- /dev/null +++ b/lib/Net/DNS/RR/SIG.pm @@ -0,0 +1,809 @@ + +# pre-5.14.0 perl inadvertently destroys signal handlers +# http://rt.perl.org/rt3/Public/Bug/Display.html?id=76138 +# +BEGIN { ## capture %SIG before compilation + use constant RT_76138 => $] < 5.014; + @::SIG_BACKUP = %SIG if RT_76138; +} + +sub UNITCHECK { ## restore %SIG after compilation + %SIG = @::SIG_BACKUP if RT_76138; +} + + +package Net::DNS::RR::SIG; + +# +# $Id: SIG.pm 1611 2018-01-02 09:41:24Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1611 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::SIG - DNS SIG resource record + +=cut + + +use integer; + +use Carp; +use Time::Local; + +eval 'require MIME::Base64'; + +use Net::DNS::Parameters; + +use constant DEBUG => 0; + +use constant UTIL => defined eval 'use Scalar::Util 1.25; 1;'; + +use constant PRIVATE => defined eval 'require Net::DNS::SEC::Private'; + +use constant DSA => defined eval 'require Net::DNS::SEC::DSA'; +use constant RSA => defined eval 'require Net::DNS::SEC::RSA'; + +use constant DNSSEC => PRIVATE && ( RSA || DSA ); + +my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + my $limit = $offset + $self->{rdlength}; + @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; + ( $self->{signame}, $offset ) = decode Net::DNS::DomainName2535( $data, $offset + 18 ); + $self->{sigbin} = substr $$data, $offset, $limit - $offset; + + croak('misplaced or corrupt SIG') unless $limit == length $$data; + my $raw = substr $$data, 0, $self->{offset}; + $self->{rawref} = \$raw; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my ( $hash, $packet ) = @opaque; + + my $signame = $self->{signame}; + + if ( DNSSEC && !$self->{sigbin} ) { + my $private = delete $self->{private}; # one shot is all you get + my $sigdata = $self->_CreateSigData($packet); + $self->_CreateSig( $sigdata, $private || die 'missing key reference' ); + } + + pack 'n C2 N3 n a* a*', @{$self}{@field}, $signame->encode, $self->sigbin; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $signame = $self->{signame} || return ''; + my @sig64 = split /\s+/, MIME::Base64::encode( $self->sigbin ); + my @rdata = ( map( $self->$_, @field ), $signame->string, @sig64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach ( @field, qw(signame) ) { $self->$_(shift) } + $self->signature(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->class('ANY'); + $self->typecovered('TYPE0'); + $self->algorithm(1); + $self->labels(0); + $self->orgttl(0); + $self->sigval(10); +} + + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + my @algbyname = ( + 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] + 'RSAMD5' => 1, # [RFC3110][RFC4034] + 'DH' => 2, # [RFC2539] + 'DSA' => 3, # [RFC3755][RFC2536] + ## Reserved => 4, # [RFC6725] + 'RSASHA1' => 5, # [RFC3110][RFC4034] + 'DSA-NSEC3-SHA1' => 6, # [RFC5155] + 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] + 'RSASHA256' => 8, # [RFC5702] + ## Reserved => 9, # [RFC6725] + 'RSASHA512' => 10, # [RFC5702] + ## Reserved => 11, # [RFC6725] + 'ECC-GOST' => 12, # [RFC5933] + 'ECDSAP256SHA256' => 13, # [RFC6605] + 'ECDSAP384SHA384' => 14, # [RFC6605] + 'ED25519' => 15, # [RFC8080] + 'ED448' => 16, # [RFC8080] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @algbyname; + my %algbyname = @algrehash; # work around broken cperl + + sub _algbyname { + my $arg = shift; + my $key = uc $arg; # synthetic key + $key =~ s/[\W_]//g; # strip non-alphanumerics + my $val = $algbyname{$key}; + return $val if defined $val; + return $key =~ /^\d/ ? $arg : croak "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + + +my $DSA = DSA ? 'Net::DNS::SEC::DSA' : 0; +my $RSA = RSA ? 'Net::DNS::SEC::RSA' : 0; + +my %SEC = ( + 1 => $RSA, + 3 => $DSA, + 5 => $RSA, + 6 => $DSA, + 7 => $RSA, + ); + +my %siglen = ( + 1 => 128, + 3 => 41, + 5 => 256, + 6 => 41, + 7 => 256, + ); + + +sub _size { ## estimate encoded size + my $self = shift; + my $clone = bless {%$self}, ref($self); # shallow clone + $clone->sigbin( 'x' x $siglen{$self->algorithm} ); + length $clone->encode(); +} + + +sub typecovered { + my $self = shift; # uncoverable pod + $self->{typecovered} = typebyname(shift) if scalar @_; + my $typecode = $self->{typecovered}; + typebyval($typecode) if defined wantarray && defined $typecode; +} + + +sub algorithm { + my ( $self, $arg ) = @_; + + unless ( ref($self) ) { ## class method or simple function + my $argn = pop; + return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); + } + + return $self->{algorithm} unless defined $arg; + return _algbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; + return $self->{algorithm} = _algbyname($arg); +} + + +sub labels { + shift->{labels} = 0; # uncoverable pod +} + + +sub orgttl { + shift->{orgttl} = 0; # uncoverable pod +} + + +sub sigexpiration { + my $self = shift; + $self->{sigexpiration} = _string2time(shift) if scalar @_; + my $time = $self->{sigexpiration}; + return unless defined wantarray && defined $time; + return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); +} + +sub siginception { + my $self = shift; + $self->{siginception} = _string2time(shift) if scalar @_; + my $time = $self->{siginception}; + return unless defined wantarray && defined $time; + return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); +} + +sub sigex { &sigexpiration; } ## historical + +sub sigin { &siginception; } ## historical + +sub sigval { + my $self = shift; + no integer; + ( $self->{sigval} ) = map int( 60.0 * $_ ), @_; +} + + +sub keytag { + my $self = shift; + + $self->{keytag} = 0 + shift if scalar @_; + $self->{keytag} || 0; +} + + +sub signame { + my $self = shift; + + $self->{signame} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{signame}->name if $self->{signame}; +} + + +sub sig { + my $self = shift; + return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @_; + $self->sigbin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub sigbin { + my $self = shift; + + $self->{sigbin} = shift if scalar @_; + $self->{sigbin} || ""; +} + + +sub signature { &sig; } + + +sub create { + unless (DNSSEC) { + croak 'Net::DNS::SEC support not available'; + } else { + my ( $class, $data, $priv_key, %etc ) = @_; + + my $private = ref($priv_key) ? $priv_key : Net::DNS::SEC::Private->new($priv_key); + croak 'Unable to parse private key' unless ref($private) eq 'Net::DNS::SEC::Private'; + + my $self = new Net::DNS::RR( + type => 'SIG', + typecovered => 'TYPE0', + siginception => time(), + algorithm => $private->algorithm, + keytag => $private->keytag, + signame => $private->signame, + ); + + while ( my ( $attribute, $value ) = each %etc ) { + $self->$attribute($value); + } + + $self->{sigexpiration} = $self->{siginception} + $self->{sigval} + unless $self->{sigexpiration}; + + $self->_CreateSig( $self->_CreateSigData($data), $private ) if $data; + + $self->{private} = $private unless $data; # mark packet for SIG0 generation + return $self; + } +} + + +sub verify { + + # Reminder... + + # $dataref may be either a data string or a reference to a + # Net::DNS::Packet object. + # + # $keyref is either a key object or a reference to an array + # of keys. + + if (DNSSEC) { + my ( $self, $dataref, $keyref ) = @_; + + if ( my $isa = ref($dataref) ) { + print '$dataref argument is ', $isa, "\n" if DEBUG; + croak '$dataref can not be ', $isa unless $isa =~ /^Net::DNS::/; + croak '$dataref can not be ', $isa unless $dataref->isa('Net::DNS::Packet'); + } + + print '$keyref argument is of class ', ref($keyref), "\n" if DEBUG; + if ( ref($keyref) eq "ARRAY" ) { + + # We will recurse for each key that matches algorithm and key-id + # and return when there is a successful verification. + # If not, we'll continue so that we even survive key-id collision. + # The downside of this is that the error string only matches the + # last error. + + print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG; + my @error; + my $i; + foreach my $keyrr (@$keyref) { + my $result = $self->verify( $dataref, $keyrr ); + return $result if $result; + my $error = $self->{vrfyerrstr}; + $i++; + push @error, "key $i: $error"; + print "key $i: $error\n" if DEBUG; + next; + } + + $self->{vrfyerrstr} = join "\n", @error; + return 0; + + } elsif ( $keyref->isa('Net::DNS::RR::DNSKEY') ) { + + print "Validating using key with keytag: ", $keyref->keytag, "\n" if DEBUG; + + } else { + croak join ' ', ref($keyref), 'can not be used as SIG0 key'; + } + + + if (DEBUG) { + print "\n ---------------------- SIG DEBUG ----------------------"; + print "\n SIG:\t", $self->string; + print "\n KEY:\t", $keyref->string; + print "\n -------------------------------------------------------\n"; + } + + croak "Trying to verify SIG0 using non-SIG0 signature" if $self->{typecovered}; + + $self->{vrfyerrstr} = ''; + unless ( $self->algorithm == $keyref->algorithm ) { + $self->{vrfyerrstr} = 'algorithm does not match'; + return 0; + } + + unless ( $self->keytag == $keyref->keytag ) { + $self->{vrfyerrstr} = 'keytag does not match'; + return 0; + } + + # The data that is to be verified + my $sigdata = $self->_CreateSigData($dataref); + + my $verified = $self->_VerifySig( $sigdata, $keyref ) || return 0; + + # time to do some time checking. + my $t = time; + + if ( _ordered( $self->{sigexpiration}, $t ) ) { + $self->{vrfyerrstr} = join ' ', 'Signature expired at', $self->sigexpiration; + return 0; + } elsif ( _ordered( $t, $self->{siginception} ) ) { + $self->{vrfyerrstr} = join ' ', 'Signature valid from', $self->siginception; + return 0; + } + + return 1; + } +} #END verify + + +sub vrfyerrstr { + shift->{vrfyerrstr}; +} + + +######################################## + +sub _ordered($$) { ## irreflexive 32-bit partial ordering + use integer; + my ( $a, $b ) = @_; + + return defined $b unless defined $a; # ( undef, any ) + return 0 unless defined $b; # ( any, undef ) + + # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished + if ( $a < 0 ) { # translate $a<0 region + $a = ( $a ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $a < 2**31 + $b = ( $b ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $b < 2**32 + } + + return $a < $b ? ( $a > ( $b - 0x80000000 ) ) : ( $b < ( $a - 0x80000000 ) ); +} + + +my $y1998 = timegm( 0, 0, 0, 1, 0, 1998 ); +my $y2026 = timegm( 0, 0, 0, 1, 0, 2026 ); +my $y2082 = $y2026 << 1; +my $y2054 = $y2082 - $y1998; +my $m2026 = int( 0x80000000 - $y2026 ); +my $m2054 = int( 0x80000000 - $y2054 ); +my $t2082 = int( $y2082 & 0x7FFFFFFF ); +my $t2100 = 1960058752; + +sub _string2time { ## parse time specification string + my $arg = shift; + croak 'undefined time' unless defined $arg; + return int($arg) if length($arg) < 12; + my ( $y, $m, @dhms ) = unpack 'a4 a2 a2 a2 a2 a2', $arg . '00'; + if ( $arg lt '20380119031408' ) { # calendar folding + return timegm( reverse(@dhms), $m - 1, $y ) if $y < 2026; + return timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2026; + } elsif ( $y > 2082 ) { + my $z = timegm( reverse(@dhms), $m - 1, $y - 84 ); + $z -= 86400 unless $z < 1456704000 + 86400; # expunge 29 Feb 2100 + return $z + $y2054; + } + return ( timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2054 ) - $y1998; +} + + +sub _time2string { ## format time specification string + my $arg = shift; + croak 'undefined time' unless defined $arg; + my $ls31 = int( $arg & 0x7FFFFFFF ); + if ( $arg & 0x80000000 ) { + + if ( $ls31 > $t2082 ) { + $ls31 += 86400 unless $ls31 < $t2100; # expunge 29 Feb 2100 + my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2054 ) )[0 .. 5] ); + return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1984, $mm + 1, @dhms; + } + + my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2026 ) )[0 .. 5] ); + return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; + + + } elsif ( $ls31 > $y2026 ) { + my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 - $y2026 ) )[0 .. 5] ); + return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; + } + + my ( $yy, $mm, @dhms ) = reverse( ( gmtime $ls31 )[0 .. 5] ); + return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1900, $mm + 1, @dhms; +} + + +sub _CreateSigData { + if (DNSSEC) { + my ( $self, $message ) = @_; + + if ( ref($message) ) { + die 'missing packet reference' unless $message->isa('Net::DNS::Packet'); + my @unsigned = grep ref($_) ne ref($self), @{$message->{additional}}; + local $message->{additional} = \@unsigned; # remake header image + my @part = qw(question answer authority additional); + my @size = map scalar( @{$message->{$_}} ), @part; + my $rref = delete $self->{rawref}; + my $data = $rref ? $$rref : $message->data; + my ( $id, $status ) = unpack 'n2', $data; + my $hbin = pack 'n6 a*', $id, $status, @size; + $message = $hbin . substr $data, length $hbin; + } + + my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); + my $sigdata = pack 'n C2 N3 n a*', @{$self}{@field}, $self->{signame}->encode; + print "\npreamble\t", unpack( 'H*', $sigdata ), "\nrawdata\t", unpack( 'H100', $message ), " ...\n" + if DEBUG; + join '', $sigdata, $message; + } +} + + +######################################## + +sub _CreateSig { + if (DNSSEC) { + my $self = shift; + + my $algorithm = $self->algorithm; + my $class = $SEC{$algorithm}; + + eval { + die "algorithm $algorithm not supported" unless $class; + $self->sigbin( $class->sign(@_) ); + } || croak "${@}signature generation failed"; + } +} + + +sub _VerifySig { + if (DNSSEC) { + my $self = shift; + + my $algorithm = $self->algorithm; + my $class = $SEC{$algorithm}; + + my $retval = eval { + die "algorithm $algorithm not supported" unless $class; + $class->verify( @_, $self->sigbin ); + }; + + unless ($retval) { + $self->{vrfyerrstr} = "${@}signature verification failed"; + print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; + return 0; + } + + # uncoverable branch true # bug in Net::DNS::SEC or dependencies + croak "unknown error in $class->verify" unless $retval == 1; + print "\nalgorithm $algorithm verification successful\n" if DEBUG; + return 1; + } +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name SIG typecovered algorithm labels + orgttl sigexpiration siginception + keytag signame signature'); + + use Net::DNS::SEC; + $sigrr = create Net::DNS::RR::SIG( $string, $keypath, + sigval => 10 # minutes + ); + + $sigrr->verify( $string, $keyrr ) || die $sigrr->vrfyerrstr; + $sigrr->verify( $packet, $keyrr ) || die $sigrr->vrfyerrstr; + +=head1 DESCRIPTION + +Class for DNS digital signature (SIG) resource records. + +In addition to the regular methods inherited from Net::DNS::RR the +class contains a method to sign packets and scalar data strings +using private keys (create) and a method for verifying signatures. + +The SIG RR is an implementation of RFC2931. +See L for an implementation of RFC4034. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 algorithm + + $algorithm = $rr->algorithm; + +The algorithm number field identifies the cryptographic algorithm +used to create the signature. + +algorithm() may also be invoked as a class method or simple function +to perform mnemonic and numeric code translation. + +=head2 sigexpiration and siginception times + +=head2 sigex sigin sigval + + $expiration = $rr->sigexpiration; + $expiration = $rr->sigexpiration( $value ); + + $inception = $rr->siginception; + $inception = $rr->siginception( $value ); + +The signature expiration and inception fields specify a validity +time interval for the signature. + +The value may be specified by a string with format 'yyyymmddhhmmss' +or a Perl time() value. + +Return values are dual-valued, providing either a string value or +numerical Perl time() value. + +=head2 keytag + + $keytag = $rr->keytag; + $rr->keytag( $keytag ); + +The keytag field contains the key tag value of the KEY RR that +validates this signature. + +=head2 signame + + $signame = $rr->signame; + $rr->signame( $signame ); + +The signer name field value identifies the owner name of the KEY +RR that a validator is supposed to use to validate this signature. + +=head2 signature + +=head2 sig + + $sig = $rr->sig; + $rr->sig( $sig ); + +The Signature field contains the cryptographic signature that covers +the SIG RDATA (excluding the Signature field) and the subject data. + +=head2 sigbin + + $sigbin = $rr->sigbin; + $rr->sigbin( $sigbin ); + +Binary representation of the cryptographic signature. + +=head2 create + +Create a signature over scalar data. + + use Net::DNS::SEC; + + $keypath = '/home/olaf/keys/Kbla.foo.+001+60114.private'; + + $sigrr = create Net::DNS::RR::SIG( $data, $keypath ); + + $sigrr = create Net::DNS::RR::SIG( $data, $keypath, + sigval => 10 + ); + $sigrr->print; + + + # Alternatively use Net::DNS::SEC::Private + + $private = Net::DNS::SEC::Private->new($keypath); + + $sigrr= create Net::DNS::RR::SIG( $data, $private ); + + +create() is an alternative constructor for a SIG RR object. + +This method returns a SIG with the signature over the data made with +the private key stored in the key file. + +The first argument is a scalar that contains the data to be signed. + +The second argument is a string which specifies the path to a file +containing the private key as generated with dnssec-keygen, a program +that comes with the ISC BIND distribution. + +The optional remaining arguments consist of ( name => value ) pairs +as follows: + + sigin => 20171201010101, # signature inception + sigex => 20171201011101, # signature expiration + sigval => 10, # validity window (minutes) + +The sigin and sigex values may be specified as Perl time values or as +a string with the format 'yyyymmddhhmmss'. The default for sigin is +the time of signing. + +The sigval argument specifies the signature validity window in minutes +( sigex = sigin + sigval ). + +By default the signature is valid for 10 minutes. + +=over 4 + +=item * + +Do not change the name of the file generated by dnssec-keygen, the +create method uses the filename as generated by dnssec-keygen to +determine the keyowner, algorithm and the keyid (keytag). + +=back + +=head2 verify + + $verify = $sigrr->verify( $data, $keyrr ); + $verify = $sigrr->verify( $data, [$keyrr, $keyrr2, $keyrr3] ); + +The verify() method performs SIG0 verification of the specified data +against the signature contained in the $sigrr object itself using +the public key in $keyrr. + +If a reference to a Net::DNS::Packet is supplied, the method performs +a SIG0 verification on the packet data. + +The second argument can either be a Net::DNS::RR::KEYRR object or a +reference to an array of such objects. Verification will return +successful as soon as one of the keys in the array leads to positive +validation. + +Returns false on error and sets $sig->vrfyerrstr + +=head2 vrfyerrstr + + $sig0 = $packet->sigrr || die 'not signed'; + print $sig0->vrfyerrstr unless $sig0->verify( $packet, $keyrr ); + + $sigrr->verify( $packet, $keyrr ) || die $sigrr->vrfyerrstr; + +=head1 REMARKS + +The code is not optimised for speed. + +If this code is still around in 2100 (not a leap year) you will +need to check for proper handling of times ... + +=head1 ACKNOWLEDGMENTS + +Andy Vaskys (Network Associates Laboratories) supplied the code for +handling RSA with SHA1 (Algorithm 5). + +T.J. Mather, the Crypt::OpenSSL::DSA maintainer, for his quick +responses to bug report and feature requests. + + +=head1 COPYRIGHT + +Copyright (c)2001-2005 RIPE NCC, Olaf M. Kolkman + +Copyright (c)2007-2008 NLnet Labs, Olaf M. Kolkman + +Portions Copyright (c)2014 Dick Franks + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, +RFC4034, RFC3755, RFC2535, RFC2931, RFC3110, RFC3008, +L, +L + +L + +L + +=cut diff --git a/lib/Net/DNS/RR/SMIMEA.pm b/lib/Net/DNS/RR/SMIMEA.pm new file mode 100644 index 0000000..226d5cb --- /dev/null +++ b/lib/Net/DNS/RR/SMIMEA.pm @@ -0,0 +1,229 @@ +package Net::DNS::RR::SMIMEA; + +# +# $Id: SMIMEA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::SMIMEA - DNS SMIMEA resource record + +=cut + + +use integer; + +use Carp; + +use constant BABBLE => defined eval 'require Digest::BubbleBabble'; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $next = $offset + $self->{rdlength}; + + @{$self}{qw(usage selector matchingtype)} = unpack "\@$offset C3", $$data; + $offset += 3; + $self->{certbin} = substr $$data, $offset, $next - $offset; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + return pack 'C3 a*', @{$self}{qw(usage selector matchingtype certbin)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->_annotation( $self->babble ) if BABBLE; + my @cert = split /(\S{64})/, $self->cert; + my @rdata = ( $self->usage, $self->selector, $self->matchingtype, @cert ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->usage(shift); + $self->selector(shift); + $self->matchingtype(shift); + $self->cert(@_); +} + + +sub usage { + my $self = shift; + + $self->{usage} = 0 + shift if scalar @_; + $self->{usage} || 0; +} + + +sub selector { + my $self = shift; + + $self->{selector} = 0 + shift if scalar @_; + $self->{selector} || 0; +} + + +sub matchingtype { + my $self = shift; + + $self->{matchingtype} = 0 + shift if scalar @_; + $self->{matchingtype} || 0; +} + + +sub cert { + my $self = shift; + return unpack "H*", $self->certbin() unless scalar @_; + $self->certbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub certbin { + my $self = shift; + + $self->{certbin} = shift if scalar @_; + $self->{certbin} || ""; +} + + +sub certificate { &cert; } + + +sub babble { + return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->certbin ) : ''; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name SMIMEA usage selector matchingtype certificate'); + +=head1 DESCRIPTION + +The SMIMEA DNS resource record (RR) is used to associate an end +entity certificate or public key with the associated email address, +thus forming a "SMIMEA certificate association". +The semantics of how the SMIMEA RR is interpreted are described in +RFC6698. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 usage + + $usage = $rr->usage; + $rr->usage( $usage ); + +8-bit integer value which specifies the provided association that +will be used to match the certificate. + +=head2 selector + + $selector = $rr->selector; + $rr->selector( $selector ); + +8-bit integer value which specifies which part of the certificate +presented by the server will be matched against the association data. + +=head2 matchingtype + + $matchingtype = $rr->matchingtype; + $rr->matchingtype( $matchingtype ); + +8-bit integer value which specifies how the certificate association +is presented. + +=head2 certificate + +=head2 cert + + $cert = $rr->cert; + $rr->cert( $cert ); + +Hexadecimal representation of the certificate data. + +=head2 certbin + + $certbin = $rr->certbin; + $rr->certbin( $certbin ); + +Binary representation of the certificate data. + +=head2 babble + + print $rr->babble; + +The babble() method returns the 'BubbleBabble' representation of the +digest if the Digest::BubbleBabble package is available, otherwise +an empty string is returned. + +BubbleBabble represents a message digest as a string of plausible +words, to make the digest easier to verify. The "words" are not +necessarily real words, but they look more like words than a string +of hex characters. + +The 'BubbleBabble' string is appended as a comment when the string +method is called. + + +=head1 COPYRIGHT + +Copyright (c)2016 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC8162, +RFC6698 + +=cut diff --git a/lib/Net/DNS/RR/SOA.pm b/lib/Net/DNS/RR/SOA.pm new file mode 100644 index 0000000..3a15c19 --- /dev/null +++ b/lib/Net/DNS/RR/SOA.pm @@ -0,0 +1,317 @@ +package Net::DNS::RR::SOA; + +# +# $Id: SOA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::SOA - DNS SOA resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; +use Net::DNS::Mailbox; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + ( $self->{mname}, $offset ) = decode Net::DNS::DomainName1035(@_); + ( $self->{rname}, $offset ) = decode Net::DNS::Mailbox1035( $data, $offset, @opaque ); + @{$self}{qw(serial refresh retry expire minimum)} = unpack "\@$offset N5", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $rname = $self->{rname}; + my $rdata = $self->{mname}->encode(@_); + $rdata .= $rname->encode( $offset + length($rdata), @opaque ); + $rdata .= pack 'N5', $self->serial, @{$self}{qw(refresh retry expire minimum)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $mname = $self->{mname}->string; + my $rname = $self->{rname}->string; + my $serial = $self->serial; + my $spacer = length "$serial" > 7 ? "" : "\t"; + my @rdata = $mname, $rname, join "\n\t\t\t\t", + "\t\t\t$serial$spacer\t;serial", + "$self->{refresh}\t\t;refresh", + "$self->{retry}\t\t;retry", + "$self->{expire}\t\t;expire", + "$self->{minimum}\t\t;minimum\n"; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->mname(shift); + $self->rname(shift); + $self->serial(shift); + for (qw(refresh retry expire minimum)) { + $self->$_( Net::DNS::RR::ttl( {}, shift ) ) if scalar @_; + } +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->_parse_rdata(qw(. . 0 4h 1h 3w 1h)); + delete $self->{serial}; +} + + +sub mname { + my $self = shift; + + $self->{mname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{mname}->name if $self->{mname}; +} + + +sub rname { + my $self = shift; + + $self->{rname} = new Net::DNS::Mailbox1035(shift) if scalar @_; + $self->{rname}->address if $self->{rname}; +} + + +sub serial { + my $self = shift; + + return $self->{serial} || 0 unless scalar @_; # current/default value + + my $value = shift; # replace if in sequence + return $self->{serial} = 0 + ( $value || 0 ) if _ordered( $self->{serial}, $value ); + + # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished + my $serial = ( 0 + $self->{serial} ) & 0xFFFFFFFF; + return $self->{serial} = $serial ^ 0xFFFFFFFF if ( $serial & 0x7FFFFFFF ) == 0x7FFFFFFF; # wrap + return $self->{serial} = $serial + 1; # increment +} + + +sub refresh { + my $self = shift; + + $self->{refresh} = 0 + shift if scalar @_; + $self->{refresh} || 0; +} + + +sub retry { + my $self = shift; + + $self->{retry} = 0 + shift if scalar @_; + $self->{retry} || 0; +} + + +sub expire { + my $self = shift; + + $self->{expire} = 0 + shift if scalar @_; + $self->{expire} || 0; +} + + +sub minimum { + my $self = shift; + + $self->{minimum} = 0 + shift if scalar @_; + $self->{minimum} || 0; +} + + +######################################## + +sub _ordered($$) { ## irreflexive 32-bit partial ordering + use integer; + my ( $a, $b ) = @_; + + return 1 unless defined $a; # ( undef, any ) + return 0 unless defined $b; # ( any, undef ) + + # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished + if ( $a < 0 ) { # translate $a<0 region + $a = ( $a ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $a < 2**31 + $b = ( $b ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $b < 2**32 + } + + return $a < $b ? ( $a > ( $b - 0x80000000 ) ) : ( $b < ( $a - 0x80000000 ) ); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name SOA mname rname 0 14400 3600 1814400 3600'); + +=head1 DESCRIPTION + +Class for DNS Start of Authority (SOA) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 mname + + $mname = $rr->mname; + $rr->mname( $mname ); + +The domain name of the name server that was the +original or primary source of data for this zone. + +=head2 rname + + $rname = $rr->rname; + $rr->rname( $rname ); + +The mailbox which identifies the person responsible +for maintaining this zone. + +=head2 serial + + $serial = $rr->serial; + $serial = $rr->serial(value); + +Unsigned 32 bit version number of the original copy of the zone. +Zone transfers preserve this value. + +RFC1982 defines a strict (irreflexive) partial ordering for zone +serial numbers. The serial number will be incremented unless the +replacement value argument satisfies the ordering constraint. + +=head2 refresh + + $refresh = $rr->refresh; + $rr->refresh( $refresh ); + +A 32 bit time interval before the zone should be refreshed. + +=head2 retry + + $retry = $rr->retry; + $rr->retry( $retry ); + +A 32 bit time interval that should elapse before a +failed refresh should be retried. + +=head2 expire + + $expire = $rr->expire; + $rr->expire( $expire ); + +A 32 bit time value that specifies the upper limit on +the time interval that can elapse before the zone is no +longer authoritative. + +=head2 minimum + + $minimum = $rr->minimum; + $rr->minimum( $minimum ); + +The unsigned 32 bit minimum TTL field that should be +exported with any RR from this zone. + +=head1 Zone Serial Number Management + +The internal logic of the serial() method offers support for several +widely used zone serial numbering policies. + +=head2 Strictly Sequential + + $successor = $soa->serial( SEQUENTIAL ); + +The existing serial number is incremented modulo 2**32 because the +value returned by the auxiliary SEQUENTIAL() function can never +satisfy the serial number ordering constraint. + +=head2 Date Encoded + + $successor = $soa->serial( YYYYMMDDxx ); + +The 32 bit value returned by the auxiliary YYYYMMDDxx() function will +be used if it satisfies the ordering constraint, otherwise the serial +number will be incremented as above. + +Serial number increments must be limited to 100 per day for the date +information to remain useful. + +=head2 Time Encoded + + $successor = $soa->serial( UNIXTIME ); + +The 32 bit value returned by the auxiliary UNIXTIME() function will +used if it satisfies the ordering constraint, otherwise the existing +serial number will be incremented as above. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2003 Chris Reinhardt. + +Portions Copyright (c)2010,2012 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.13, RFC1982 + +=cut diff --git a/lib/Net/DNS/RR/SPF.pm b/lib/Net/DNS/RR/SPF.pm new file mode 100644 index 0000000..d7849a3 --- /dev/null +++ b/lib/Net/DNS/RR/SPF.pm @@ -0,0 +1,115 @@ +package Net::DNS::RR::SPF; + +# +# $Id: SPF.pm 1593 2017-09-04 14:23:26Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1593 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::TXT); + +=head1 NAME + +Net::DNS::RR::SPF - DNS SPF resource record + +=cut + + +use integer; + + +sub spfdata { + my @spf = shift->char_str_list(@_); + wantarray ? @spf : join '', @spf; +} + +sub txtdata { &spfdata; } + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name SPF spfdata ...'); + + $rr = new Net::DNS::RR( name => 'name', + type => 'SPF', + spfdata => 'single text string' + ); + + $rr = new Net::DNS::RR( name => 'name', + type => 'SPF', + spfdata => [ 'multiple', 'strings', ... ] + ); + +=head1 DESCRIPTION + +Class for DNS Sender Policy Framework (SPF) resource records. + +SPF records inherit most of the properties of the Net::DNS::RR::TXT +class. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 spfdata + +=head2 txtdata + + $string = $rr->spfdata; + @list = $rr->spfdata; + + $rr->spfdata( @list ); + +When invoked in scalar context, spfdata() returns the policy text as +a single string, with text elements concatenated without intervening +spaces. + +In a list context, spfdata() returns a list of the text elements. + + +=head1 COPYRIGHT + +Copyright (c)2005 Olaf Kolkman, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, RFC7208 + +=cut diff --git a/lib/Net/DNS/RR/SRV.pm b/lib/Net/DNS/RR/SRV.pm new file mode 100644 index 0000000..d564681 --- /dev/null +++ b/lib/Net/DNS/RR/SRV.pm @@ -0,0 +1,199 @@ +package Net::DNS::RR::SRV; + +# +# $Id: SRV.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::SRV - DNS SRV resource record + +=cut + + +use integer; + +use Net::DNS::DomainName; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + @{$self}{qw(priority weight port)} = unpack( "\@$offset n3", $$data ); + + $self->{target} = decode Net::DNS::DomainName2535( $data, $offset + 6, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $target = $self->{target}; + my @nums = ( $self->priority, $self->weight, $self->port ); + pack 'n3 a*', @nums, $target->encode( $offset + 6, @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $target = $self->{target}; + my @rdata = ( $self->priority, $self->weight, $self->port, $target->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach my $attr (qw(priority weight port target)) { + $self->$attr(shift); + } +} + + +sub priority { + my $self = shift; + + $self->{priority} = 0 + shift if scalar @_; + $self->{priority} || 0; +} + + +sub weight { + my $self = shift; + + $self->{weight} = 0 + shift if scalar @_; + $self->{weight} || 0; +} + + +sub port { + my $self = shift; + + $self->{port} = 0 + shift if scalar @_; + $self->{port} || 0; +} + + +sub target { + my $self = shift; + + $self->{target} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{target}->name if $self->{target}; +} + + +# order RRs by numerically increasing priority, decreasing weight +my $function = sub { + my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); + $a->{priority} <=> $b->{priority} + || $b->{weight} <=> $a->{weight}; +}; + +__PACKAGE__->set_rrsort_func( 'priority', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name SRV priority weight port target'); + +=head1 DESCRIPTION + +Class for DNS Service (SRV) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 priority + + $priority = $rr->priority; + $rr->priority( $priority ); + +Returns the priority for this target host. + +=head2 weight + + $weight = $rr->weight; + $rr->weight( $weight ); + +Returns the weight for this target host. + +=head2 port + + $port = $rr->port; + $rr->port( $port ); + +Returns the port number for the service on this target host. + +=head2 target + + $target = $rr->target; + $rr->target( $target ); + +Returns the domain name of the target host. + +=head1 Sorting of SRV Records + +By default, rrsort() returns the SRV records sorted from lowest to highest +priority and for equal priorities from highest to lowest weight. + +Note: This is NOT the order in which connections should be attempted. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC2782 + +=cut diff --git a/lib/Net/DNS/RR/SSHFP.pm b/lib/Net/DNS/RR/SSHFP.pm new file mode 100644 index 0000000..c53ef09 --- /dev/null +++ b/lib/Net/DNS/RR/SSHFP.pm @@ -0,0 +1,208 @@ +package Net::DNS::RR::SSHFP; + +# +# $Id: SSHFP.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::SSHFP - DNS SSHFP resource record + +=cut + + +use integer; + +use Carp; + +use constant BABBLE => defined eval 'require Digest::BubbleBabble'; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $size = $self->{rdlength} - 2; + @{$self}{qw(algorithm fptype fpbin)} = unpack "\@$offset C2 a$size", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'C2 a*', @{$self}{qw(algorithm fptype fpbin)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->_annotation( $self->babble ) if BABBLE; + my @fprint = split /(\S{64})/, $self->fp; + my @rdata = ( $self->algorithm, $self->fptype, @fprint ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->algorithm(shift); + $self->fptype(shift); + $self->fp(@_); +} + + +sub algorithm { + my $self = shift; + + $self->{algorithm} = 0 + shift if scalar @_; + $self->{algorithm} || 0; +} + + +sub fptype { + my $self = shift; + + $self->{fptype} = 0 + shift if scalar @_; + $self->{fptype} || 0; +} + + +sub fp { + my $self = shift; + return unpack "H*", $self->fpbin() unless scalar @_; + $self->fpbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub fpbin { + my $self = shift; + + $self->{fpbin} = shift if scalar @_; + $self->{fpbin} || ""; +} + + +sub babble { + return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->fpbin ) : ''; +} + + +sub fingerprint { &fp; } ## historical + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name SSHFP algorithm fptype fp'); + +=head1 DESCRIPTION + +DNS SSH Fingerprint (SSHFP) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 algorithm + + $algorithm = $rr->algorithm; + $rr->algorithm( $algorithm ); + +The 8-bit algorithm number describes the algorithm used to +construct the public key. + +=head2 fptype + + $fptype = $rr->fptype; + $rr->fptype( $fptype ); + +The 8-bit fingerprint type number describes the message-digest +algorithm used to calculate the fingerprint of the public key. + +=head2 fingerprint + +=head2 fp + + $fp = $rr->fp; + $rr->fp( $fp ); + +Hexadecimal representation of the fingerprint digest. + +=head2 fpbin + + $fpbin = $rr->fpbin; + $rr->fpbin( $fpbin ); + +Returns opaque octet string representing the fingerprint digest. + +=head2 babble + + print $rr->babble; + +The babble() method returns the 'BabbleBubble' representation of +the fingerprint if the Digest::BubbleBabble package is available, +otherwise an empty string is returned. + +Bubble babble represents a message digest as a string of "real" +words, to make the fingerprint easier to remember. The "words" +are not necessarily real words, but they look more like words +than a string of hex characters. + +Bubble babble fingerprinting is used by the SSH2 suite (and +consequently by Net::SSH::Perl, the Perl SSH implementation) +to display easy-to-remember key fingerprints. + +The 'BubbleBabble' string is appended as a comment when the +string method is called. + + +=head1 COPYRIGHT + +Copyright (c)2007 Olaf Kolkman, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC4255 + +=cut diff --git a/lib/Net/DNS/RR/TKEY.pm b/lib/Net/DNS/RR/TKEY.pm new file mode 100644 index 0000000..bc3f9a2 --- /dev/null +++ b/lib/Net/DNS/RR/TKEY.pm @@ -0,0 +1,255 @@ +package Net::DNS::RR::TKEY; + +# +# $Id: TKEY.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::TKEY - DNS TKEY resource record + +=cut + + +use integer; + +use Carp; + +use Net::DNS::Parameters; +use Net::DNS::DomainName; + +use constant ANY => classbyname qw(ANY); +use constant TKEY => typebyname qw(TKEY); + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + + ( $self->{algorithm}, $offset ) = decode Net::DNS::DomainName(@_); + + @{$self}{qw(inception expiration mode error)} = unpack "\@$offset N2n2", $$data; + $offset += 12; + + my $key_size = unpack "\@$offset n", $$data; + $self->{key} = substr $$data, $offset + 2, $key_size; + $offset += $key_size + 2; + + my $other_size = unpack "\@$offset n", $$data; + $self->{other} = substr $$data, $offset + 2, $other_size; + $offset += $other_size + 2; + + croak('corrupt TKEY data') unless $offset == $limit; # more or less FUBAR +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + return '' unless defined $self->{algorithm}; + my $rdata = $self->{algorithm}->encode; + + $rdata .= pack 'N2n2', $self->inception, $self->expiration, $self->mode, $self->error; + + my $key = $self->key; # RFC2930(2.7) + $rdata .= pack 'na*', length $key, $key; + + my $other = $self->other; # RFC2930(2.8) + $rdata .= pack 'na*', length $other, $other; + return $rdata; +} + + +sub class { ## overide RR method + return 'ANY'; +} + +sub encode { ## overide RR method + my $self = shift; + + my $owner = $self->{owner}->encode(); + my $rdata = eval { $self->_encode_rdata() } || ''; + return pack 'a* n2 N n a*', $owner, TKEY, ANY, 0, length $rdata, $rdata; +} + + +sub algorithm { + my $self = shift; + + $self->{algorithm} = new Net::DNS::DomainName(shift) if scalar @_; + $self->{algorithm}->name if $self->{algorithm}; +} + + +sub inception { + my $self = shift; + + $self->{inception} = 0 + shift if scalar @_; + $self->{inception} || 0; +} + + +sub expiration { + my $self = shift; + + $self->{expiration} = 0 + shift if scalar @_; + $self->{expiration} || 0; +} + + +sub mode { + my $self = shift; + + $self->{mode} = 0 + shift if scalar @_; + $self->{mode} || 0; +} + + +sub error { + my $self = shift; + + $self->{error} = 0 + shift if scalar @_; + $self->{error} || 0; +} + + +sub key { + my $self = shift; + + $self->{key} = shift if scalar @_; + $self->{key} || ""; +} + + +sub other { + my $self = shift; + + $self->{other} = shift if scalar @_; + $self->{other} || ""; +} + + +sub other_data { &other; } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + +=head1 DESCRIPTION + +Class for DNS TSIG Key (TKEY) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 algorithm + + $algorithm = $rr->algorithm; + $rr->algorithm( $algorithm ); + +The algorithm name is in the form of a domain name with the same +meaning as in [RFC 2845]. The algorithm determines how the secret +keying material agreed to using the TKEY RR is actually used to derive +the algorithm specific key. + +=head2 inception + + $inception = $rr->inception; + $rr->inception( $inception ); + +Time expressed as the number of non-leap seconds modulo 2**32 since the +beginning of January 1970 GMT. + +=head2 expiration + + $expiration = $rr->expiration; + $rr->expiration( $expiration ); + +Time expressed as the number of non-leap seconds modulo 2**32 since the +beginning of January 1970 GMT. + +=head2 mode + + $mode = $rr->mode; + $rr->mode( $mode ); + +The mode field specifies the general scheme for key agreement or the +purpose of the TKEY DNS message, as defined in [RFC2930(2.5)]. + +=head2 error + + $error = $rr->error; + $rr->error( $error ); + +The error code field is an extended RCODE. + +=head2 key + + $key = $rr->key; + $rr->key( $key ); + +Sequence of octets representing the key exchange data. +The meaning of this data depends on the mode. + +=head2 other + + $other = $rr->other; + $rr->other( $other ); + +Content not defined in the [RFC2930] specification but may be used +in future extensions. + + +=head1 COPYRIGHT + +Copyright (c)2000 Andrew Tridgell. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC2930 + +=cut diff --git a/lib/Net/DNS/RR/TLSA.pm b/lib/Net/DNS/RR/TLSA.pm new file mode 100644 index 0000000..fb1e74b --- /dev/null +++ b/lib/Net/DNS/RR/TLSA.pm @@ -0,0 +1,227 @@ +package Net::DNS::RR::TLSA; + +# +# $Id: TLSA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::TLSA - DNS TLSA resource record + +=cut + + +use integer; + +use Carp; +use constant BABBLE => defined eval 'require Digest::BubbleBabble'; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $next = $offset + $self->{rdlength}; + + @{$self}{qw(usage selector matchingtype)} = unpack "\@$offset C3", $$data; + $offset += 3; + $self->{certbin} = substr $$data, $offset, $next - $offset; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'C3 a*', @{$self}{qw(usage selector matchingtype certbin)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->_annotation( $self->babble ) if BABBLE; + my @cert = split /(\S{64})/, $self->cert; + my @rdata = ( $self->usage, $self->selector, $self->matchingtype, @cert ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->usage(shift); + $self->selector(shift); + $self->matchingtype(shift); + $self->cert(@_); +} + + +sub usage { + my $self = shift; + + $self->{usage} = 0 + shift if scalar @_; + $self->{usage} || 0; +} + + +sub selector { + my $self = shift; + + $self->{selector} = 0 + shift if scalar @_; + $self->{selector} || 0; +} + + +sub matchingtype { + my $self = shift; + + $self->{matchingtype} = 0 + shift if scalar @_; + $self->{matchingtype} || 0; +} + + +sub cert { + my $self = shift; + return unpack "H*", $self->certbin() unless scalar @_; + $self->certbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub certbin { + my $self = shift; + + $self->{certbin} = shift if scalar @_; + $self->{certbin} || ""; +} + + +sub certificate { &cert; } + + +sub babble { + return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->certbin ) : ''; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name TLSA usage selector matchingtype certificate'); + +=head1 DESCRIPTION + +The Transport Layer Security Authentication (TLSA) DNS resource record +is used to associate a TLS server certificate or public key with the +domain name where the record is found, forming a "TLSA certificate +association". The semantics of how the TLSA RR is interpreted are +described in RFC6698. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 usage + + $usage = $rr->usage; + $rr->usage( $usage ); + +8-bit integer value which specifies the provided association that +will be used to match the certificate presented in the TLS handshake. + +=head2 selector + + $selector = $rr->selector; + $rr->selector( $selector ); + +8-bit integer value which specifies which part of the TLS certificate +presented by the server will be matched against the association data. + +=head2 matchingtype + + $matchingtype = $rr->matchingtype; + $rr->matchingtype( $matchingtype ); + +8-bit integer value which specifies how the certificate association +is presented. + +=head2 certificate + +=head2 cert + + $cert = $rr->cert; + $rr->cert( $cert ); + +Hexadecimal representation of the certificate data. + +=head2 certbin + + $certbin = $rr->certbin; + $rr->certbin( $certbin ); + +Binary representation of the certificate data. + +=head2 babble + + print $rr->babble; + +The babble() method returns the 'BubbleBabble' representation of the +digest if the Digest::BubbleBabble package is available, otherwise +an empty string is returned. + +BubbleBabble represents a message digest as a string of plausible +words, to make the digest easier to verify. The "words" are not +necessarily real words, but they look more like words than a string +of hex characters. + +The 'BubbleBabble' string is appended as a comment when the string +method is called. + + +=head1 COPYRIGHT + +Copyright (c)2012 Willem Toorop, NLnet Labs. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC6698 + +=cut diff --git a/lib/Net/DNS/RR/TSIG.pm b/lib/Net/DNS/RR/TSIG.pm new file mode 100644 index 0000000..5c22057 --- /dev/null +++ b/lib/Net/DNS/RR/TSIG.pm @@ -0,0 +1,836 @@ +package Net::DNS::RR::TSIG; + +# +# $Id: TSIG.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::TSIG - DNS TSIG resource record + +=cut + + +use integer; + +use Carp; + +eval 'require Digest::HMAC'; +eval 'require Digest::MD5'; +eval 'require Digest::SHA'; +eval 'require MIME::Base64'; + +use Net::DNS::DomainName; +use Net::DNS::Parameters; + +use constant ANY => classbyname qw(ANY); +use constant TSIG => typebyname qw(TSIG); + +{ + # source: http://www.iana.org/assignments/tsig-algorithm-names + my @algbyname = ( + 'HMAC-MD5.SIG-ALG.REG.INT' => 157, + 'HMAC-SHA1' => 161, + 'HMAC-SHA224' => 162, + 'HMAC-SHA256' => 163, + 'HMAC-SHA384' => 164, + 'HMAC-SHA512' => 165, + ); + + my @algalias = ( + 'HMAC-MD5' => 157, + 'HMAC-SHA' => 161, + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @algbyname, @algalias; + my %algbyname = @algrehash; # work around broken cperl + + sub _algbyname { + my $key = uc shift; # synthetic key + $key =~ s/[\W_]//g; # strip non-alphanumerics + $algbyname{$key}; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value}; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + ( $self->{algorithm}, $offset ) = decode Net::DNS::DomainName(@_); + + # Design decision: Use 32 bits, which will work until the end of time()! + @{$self}{qw(time_signed fudge)} = unpack "\@$offset xxN n", $$data; + $offset += 8; + + my $mac_size = unpack "\@$offset n", $$data; + $self->{macbin} = unpack "\@$offset xx a$mac_size", $$data; + $offset += $mac_size + 2; + + @{$self}{qw(original_id error)} = unpack "\@$offset nn", $$data; + $offset += 4; + + my $other_size = unpack "\@$offset n", $$data; + $self->{other} = unpack "\@$offset xx a$other_size", $$data; + $offset += $other_size + 2; + + croak('misplaced or corrupt TSIG') unless $limit == length $$data; + my $raw = substr $$data, 0, $self->{offset}; + $self->{rawref} = \$raw; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $macbin = $self->macbin; + unless ($macbin) { + my ( $offset, undef, $packet ) = @_; + + my $sigdata = $self->sig_data($packet); # form data to be signed + $macbin = $self->macbin( $self->_mac_function($sigdata) ); + $self->original_id( $packet->header->id ); + } + + my $rdata = $self->{algorithm}->canonical; + + # Design decision: Use 32 bits, which will work until the end of time()! + $rdata .= pack 'xxN n', $self->time_signed, $self->fudge; + + $rdata .= pack 'na*', length($macbin), $macbin; + + $rdata .= pack 'nn', $self->original_id, $self->{error}; + + my $other = $self->other; + $rdata .= pack 'na*', length($other), $other; + + return $rdata; +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->algorithm(157); + $self->class('ANY'); + $self->error(0); + $self->fudge(300); + $self->other(''); +} + + +sub _size { ## estimate encoded size + my $self = shift; + my $clone = bless {%$self}, ref($self); # shallow clone + length $clone->encode( 0, undef, new Net::DNS::Packet() ); +} + + +sub encode { ## overide RR method + my $self = shift; + + my $kname = $self->{owner}->encode(); # uncompressed key name + my $rdata = eval { $self->_encode_rdata(@_) } || ''; + pack 'a* n2 N n a*', $kname, TSIG, ANY, 0, length $rdata, $rdata; +} + + +sub string { ## overide RR method + my $self = shift; + + my $owner = $self->{owner}->string; + my $type = $self->type; + my $algorithm = $self->algorithm; + my $time_signed = $self->time_signed; + my $fudge = $self->fudge; + my $signature = $self->mac; + my $original_id = $self->original_id; + my $error = $self->error; + my $other = $self->other; + + return <<"QQ"; +; $owner $type +; algorithm: $algorithm +; time signed: $time_signed fudge: $fudge +; signature: $signature +; original id: $original_id +; $error $other +QQ +} + + +sub algorithm { &_algorithm; } + + +sub key { + my $self = shift; + + $self->keybin( MIME::Base64::decode( join "", @_ ) ) if scalar @_; + MIME::Base64::encode( $self->keybin(), "" ) if defined wantarray; +} + + +sub keybin { &_keybin; } + + +sub time_signed { + my $self = shift; + + $self->{time_signed} = 0 + shift if scalar @_; + $self->{time_signed} = time() unless $self->{time_signed}; +} + + +sub fudge { + my $self = shift; + + $self->{fudge} = 0 + shift if scalar @_; + $self->{fudge} || 0; +} + + +sub mac { + my $self = shift; + + $self->macbin( pack "H*", map { die "!hex!" if m/[^0-9A-Fa-f]/; $_ } join "", @_ ) if scalar @_; + unpack "H*", $self->macbin() if defined wantarray; +} + + +sub macbin { + my $self = shift; + + $self->{macbin} = shift if scalar @_; + $self->{macbin} || ""; +} + + +sub prior_mac { + my $self = shift; + return unpack "H*", $self->prior_macbin() unless scalar @_; + $self->prior_macbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub prior_macbin { + my $self = shift; + + $self->{prior_macbin} = shift if scalar @_; + $self->{prior_macbin} || ""; +} + + +sub request_mac { + my $self = shift; + return unpack "H*", $self->request_macbin() unless scalar @_; + $self->request_macbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub request_macbin { + my $self = shift; + + $self->{request_macbin} = shift if scalar @_; + $self->{request_macbin} || ""; +} + + +sub original_id { + my $self = shift; + + $self->{original_id} = 0 + shift if scalar @_; + $self->{original_id} || 0; +} + + +sub error { + my $self = shift; + $self->{error} = rcodebyname(shift) if scalar @_; + rcodebyval( $self->{error} ); +} + + +sub other { + my $self = shift; + $self->{other} = shift if scalar @_; + my $time = $self->{error} == 18 ? pack 'xxN', time() : ''; + $self->{other} = $time unless $self->{other}; +} + + +sub other_data { &other; } # uncoverable pod + + +sub sig_function { + my $self = shift; + + return $self->{sig_function} unless scalar @_; + $self->{sig_function} = shift; +} + +sub sign_func { &sig_function; } # uncoverable pod + + +sub sig_data { + my ( $self, $message ) = @_; + + if ( ref($message) ) { + die 'missing packet reference' unless $message->isa('Net::DNS::Packet'); + my @unsigned = grep ref($_) ne ref($self), @{$message->{additional}}; + local $message->{additional} = \@unsigned; # remake header image + my @part = qw(question answer authority additional); + my @size = map scalar( @{$message->{$_}} ), @part; + if ( my $rawref = $self->{rawref} ) { + delete $self->{rawref}; + my $hbin = pack 'n6', $self->original_id, $message->{status}, @size; + $message = join '', $hbin, substr $$rawref, length $hbin; + } else { + my $data = $message->data; + my $hbin = pack 'n6', $message->{id}, $message->{status}, @size; + $message = join '', $hbin, substr $data, length $hbin; + } + } + + # Design decision: Use 32 bits, which will work until the end of time()! + my $time = pack 'xxN n', $self->time_signed, $self->fudge; + + # Insert the prior MAC if present (multi-packet message). + $self->prior_macbin( $self->{link}->macbin ) if $self->{link}; + my $prior_macbin = $self->prior_macbin; + return pack 'na* a* a*', length($prior_macbin), $prior_macbin, $message, $time if $prior_macbin; + + # Insert the request MAC if present (used to validate responses). + my $req_mac = $self->request_macbin; + my $sigdata = $req_mac ? pack( 'na*', length($req_mac), $req_mac ) : ''; + + $sigdata .= $message || ''; + + my $kname = $self->{owner}->canonical; # canonical key name + $sigdata .= pack 'a* n N', $kname, ANY, 0; + + $sigdata .= $self->{algorithm}->canonical; # canonical algorithm name + + $sigdata .= $time; + + $sigdata .= pack 'n', $self->{error}; + + my $other = $self->other; + $sigdata .= pack 'na*', length($other), $other; + + return $sigdata; +} + + +sub create { + my $class = shift; + my $karg = shift; + croak 'argument undefined' unless defined $karg; + + if ( ref($karg) ) { + if ( $karg->isa('Net::DNS::Packet') ) { + my $sigrr = $karg->sigrr; + croak 'no TSIG in request packet' unless defined $sigrr; + return new Net::DNS::RR( # ( request, options ) + name => $sigrr->name, + type => 'TSIG', + algorithm => $sigrr->algorithm, + request_macbin => $sigrr->macbin, + @_ + ); + + } elsif ( ref($karg) eq __PACKAGE__ ) { + my $tsig = $karg->_chain; + $tsig->{macbin} = undef; + return $tsig; + + } elsif ( ref($karg) eq 'Net::DNS::RR::KEY' ) { + return new Net::DNS::RR( + name => $karg->name, + type => 'TSIG', + algorithm => $karg->algorithm, + key => $karg->key, + @_ + ); + } + + croak "Usage: create $class(keyfile)\n\tcreate $class(keyname, key)" + + } elsif ( scalar(@_) == 1 ) { + my $key = shift; # ( keyname, key ) + return new Net::DNS::RR( + name => $karg, + type => 'TSIG', + key => $key + ); + + } elsif ( $karg =~ /private$/ ) { # ( keyfile, options ) + require File::Spec; + require Net::DNS::ZoneFile; + my $keyfile = new Net::DNS::ZoneFile($karg); + my ( $alg, $key, $junk ); + while ( $keyfile->_getline ) { + ( $junk, $alg ) = split if /Algorithm:/; + ( $junk, $key ) = split if /Key:/; + } + + my ( $vol, $dir, $file ) = File::Spec->splitpath( $keyfile->name ); + croak "misnamed private key" unless $file =~ /^K([^+]+)+.+private$/; + my $kname = $1; + return new Net::DNS::RR( + name => $kname, + type => 'TSIG', + algorithm => $alg, + key => $key, + @_ + ); + + } else { # ( keyfile, options ) + require Net::DNS::ZoneFile; + my $keyrr = new Net::DNS::ZoneFile($karg)->read; + croak 'key file incompatible with TSIG' unless $keyrr->type eq 'KEY'; + return new Net::DNS::RR( + name => $keyrr->name, + type => 'TSIG', + algorithm => $keyrr->algorithm, + key => $keyrr->key, + @_ + ); + } +} + + +sub verify { + my $self = shift; + my $data = shift; + + unless ( abs( time() - $self->time_signed ) < $self->fudge ) { + $self->error(18); # bad time + return; + } + + if ( scalar @_ ) { + my $arg = shift; + + unless ( ref($arg) ) { + $self->error(16); # bad sig (multi-packet) + return; + } + + my $signerkey = lc( join '+', $self->name, $self->algorithm ); + if ( $arg->isa('Net::DNS::Packet') ) { + my $request = $arg->sigrr; # request TSIG + my $rqstkey = lc( join '+', $request->name, $request->algorithm ); + $self->error(17) unless $signerkey eq $rqstkey; + $self->request_macbin( $request->macbin ); + + } elsif ( $arg->isa(__PACKAGE__) ) { + my $priorkey = lc( join '+', $arg->name, $arg->algorithm ); + $self->error(17) unless $signerkey eq $priorkey; + $self->prior_macbin( $arg->macbin ); + + } else { + croak 'Usage: $tsig->verify( $reply, $query )'; + } + } + return if $self->{error}; + + my $sigdata = $self->sig_data($data); # form data to be verified + my $tsigmac = $self->_mac_function($sigdata); + my $tsig = $self->_chain; + + my $macbin = $self->macbin; + my $maclen = length $macbin; + my $minlen = length($tsigmac) >> 1; # per RFC4635, 3.1 + $self->error(16) unless $macbin eq substr $tsigmac, 0, $maclen; + $self->error(1) if $maclen < $minlen or $maclen < 10 or $maclen > length $tsigmac; + + return $self->{error} ? undef : $tsig; +} + +sub vrfyerrstr { + my $self = shift; + return $self->error; +} + + +######################################## + +{ + my %digest = ( + '157' => ['Digest::MD5'], + '161' => ['Digest::SHA'], + '162' => ['Digest::SHA', 224, 64], + '163' => ['Digest::SHA', 256, 64], + '164' => ['Digest::SHA', 384, 128], + '165' => ['Digest::SHA', 512, 128], + ); + + + my %keytable; + + sub _algorithm { ## install sig function in key table + my $self = shift; + + if ( my $algname = shift ) { + + unless ( my $digtype = _algbyname($algname) ) { + $self->{algorithm} = new Net::DNS::DomainName($algname); + + } else { + $algname = _algbyval($digtype); + $self->{algorithm} = new Net::DNS::DomainName($algname); + + my ( $hash, @param ) = @{$digest{$digtype}}; + my ( undef, @block ) = @param; + my $digest = new $hash(@param); + my $function = sub { + my $hmac = new Digest::HMAC( shift, $digest, @block ); + $hmac->add(shift); + return $hmac->digest; + }; + + $self->sig_function($function); + + my $keyname = ( $self->{owner} || return )->canonical; + $keytable{$keyname}{digest} = $function; + } + } + + return $self->{algorithm}->name if defined wantarray; + } + + + sub _keybin { ## install key in key table + my $self = shift; + croak 'Unauthorised access to TSIG key material denied' unless scalar @_; + my $keyref = $keytable{$self->{owner}->canonical} ||= {}; + my $private = shift; # closure keeps private key private + $keyref->{key} = sub { + my $function = $keyref->{digest}; + return &$function( $private, @_ ); + }; + return undef; + } + + + sub _mac_function { ## apply keyed hash function to argument + my $self = shift; + + my $owner = $self->{owner}->canonical; + $self->algorithm( $self->algorithm ) unless $keytable{$owner}{digest}; + my $keyref = $keytable{$owner}; + $keyref->{digest} = $self->sig_function unless $keyref->{digest}; + my $function = $keyref->{key}; + &$function(@_); + } +} + + +# _chain() creates a new TSIG object linked to the original +# RR, for the purpose of signing multi-message transfers. + +sub _chain { + my $self = shift; + $self->{link} = undef; + bless {%$self, link => $self}, ref($self); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $tsig = create Net::DNS::RR::TSIG( $keyfile ); + + $tsig = create Net::DNS::RR::TSIG( $keyfile, + fudge => 300 + ); + +=head1 DESCRIPTION + +Class for DNS Transaction Signature (TSIG) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 algorithm + + $algorithm = $rr->algorithm; + $rr->algorithm( $algorithm ); + +A domain name which specifies the name of the algorithm. + +=head2 key + + $rr->key( $key ); + +Base64 representation of the key material. + +=head2 keybin + + $rr->keybin( $keybin ); + +Binary representation of the key material. + +=head2 time_signed + + $time_signed = $rr->time_signed; + $rr->time_signed( $time_signed ); + +Signing time as the number of seconds since 1 Jan 1970 00:00:00 UTC. +The default signing time is the current time. + +=head2 fudge + + $fudge = $rr->fudge; + $rr->fudge( $fudge ); + +"fudge" represents the permitted error in the signing time. +The default fudge is 300 seconds. + +=head2 mac + + $mac = $rr->mac; + +Returns the message authentication code (MAC) as a string of hex +characters. The programmer must call the Net::DNS::Packet data() +object method before this will return anything meaningful. + +=cut + + +=head2 macbin + + $macbin = $rr->macbin; + $rr->macbin( $macbin ); + +Binary message authentication code (MAC). + +=head2 prior_mac + + $prior_mac = $rr->prior_mac; + $rr->prior_mac( $prior_mac ); + +Prior message authentication code (MAC). + +=head2 prior_macbin + + $prior_macbin = $rr->prior_macbin; + $rr->prior_macbin( $prior_macbin ); + +Binary prior message authentication code. + +=head2 request_mac + + $request_mac = $rr->request_mac; + $rr->request_mac( $request_mac ); + +Request message authentication code (MAC). + +=head2 request_macbin + + $request_macbin = $rr->request_macbin; + $rr->request_macbin( $request_macbin ); + +Binary request message authentication code. + +=head2 original_id + + $original_id = $rr->original_id; + $rr->original_id( $original_id ); + +The message ID from the header of the original packet. + +=head2 error + +=head2 vrfyerrstr + + $rcode = $tsig->error; + +Returns the RCODE covering TSIG processing. Common values are +NOERROR, BADSIG, BADKEY, and BADTIME. See RFC 2845 for details. + + +=head2 other + + $other = $tsig->other; + +This field should be empty unless the error is BADTIME, in which +case it will contain the server time as the number of seconds since +1 Jan 1970 00:00:00 UTC. + +=head2 sig_function + + sub signing_function { + my ( $keybin, $data ) = @_; + + my $hmac = new Digest::HMAC( $keybin, 'Digest::MD5' ); + $hmac->add( $data ); + return $hmac->digest; + } + + $tsig->sig_function( \&signing_function ); + +This sets the signing function to be used for this TSIG record. +The default signing function is HMAC-MD5. + + +=head2 sig_data + + $sigdata = $tsig->sig_data($packet); + +Returns the packet packed according to RFC2845 in a form for signing. This +is only needed if you want to supply an external signing function, such as is +needed for TSIG-GSS. + + +=head2 create + + $tsig = create Net::DNS::RR::TSIG( $keyfile ); + + $tsig = create Net::DNS::RR::TSIG( $keyfile, + fudge => 300 + ); + +Returns a TSIG RR constructed using the parameters in the specified +key file, which is assumed to have been generated by dnssec-keygen. + + $tsig = create Net::DNS::RR::TSIG( $keyname, $key ); + +The two argument form is supported for backward compatibility. + +=head2 verify + + $verify = $tsig->verify( $data ); + $verify = $tsig->verify( $packet ); + + $verify = $tsig->verify( $reply, $query ); + + $verify = $tsig->verify( $packet, $prior ); + +The boolean verify method will return true if the hash over the +packet data conforms to the data in the TSIG itself + + +=head1 TSIG Keys + +TSIG keys are symmetric keys generated using dnssec-keygen: + + $ dnssec-keygen -a HMAC-SHA1 -b 160 -n HOST + + The key will be stored as a private and public keyfile pair + K+161+.private and K+161+.key + + where + is the DNS name of the key. + + is the (generated) numerical identifier used to + distinguish this key. + +Other algorithms may be substituted for HMAC-SHA1 in the above example. + +It is recommended that the keyname be globally unique and incorporate +the fully qualified domain names of the resolver and nameserver in +that order. It should be possible for more than one key to be in use +simultaneously between any such pair of hosts. + +Although the formats differ, the private and public keys are identical +and both should be stored and handled as secret data. + + +=head1 Configuring BIND Nameserver + +The following lines must be added to the /etc/named.conf file: + + key { + algorithm HMAC-SHA1; + secret ""; + }; + + is the name of the key chosen when the key was generated. + + is the key string extracted from the generated key file. + + +=head1 ACKNOWLEDGMENT + +Most of the code in the Net::DNS::RR::TSIG module was contributed +by Chris Turbeville. + +Support for external signing functions was added by Andrew Tridgell. + +TSIG verification, BIND keyfile handling and support for HMAC-SHA1, +HMAC-SHA224, HMAC-SHA256, HMAC-SHA384 and HMAC-SHA512 functions was +added by Dick Franks. + + +=head1 BUGS + +A 32-bit representation of time is used, contrary to RFC2845 which +demands 48 bits. This design decision will need to be reviewed +before the code stops working on 7 February 2106. + + +=head1 COPYRIGHT + +Copyright (c)2000,2001 Michael Fuhr. + +Portions Copyright (c)2002,2003 Chris Reinhardt. + +Portions Copyright (c)2013 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC2845, RFC4635 + +L + +=cut diff --git a/lib/Net/DNS/RR/TXT.pm b/lib/Net/DNS/RR/TXT.pm new file mode 100644 index 0000000..21cd0e4 --- /dev/null +++ b/lib/Net/DNS/RR/TXT.pm @@ -0,0 +1,165 @@ +package Net::DNS::RR::TXT; + +# +# $Id: TXT.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=encoding utf8 + +=head1 NAME + +Net::DNS::RR::TXT - DNS TXT resource record + +=cut + + +use integer; + +use Carp; +use Net::DNS::Text; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + my $text; + my $txtdata = $self->{txtdata} = []; + while ( $offset < $limit ) { + ( $text, $offset ) = decode Net::DNS::Text( $data, $offset ); + push @$txtdata, $text; + } + + croak('corrupt TXT data') unless $offset == $limit; # more or less FUBAR +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $txtdata = $self->{txtdata}; + join '', map $_->encode, @$txtdata; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $txtdata = $self->{txtdata}; + my @txtdata = map $_->string, @$txtdata; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->{txtdata} = [map Net::DNS::Text->new($_), @_]; +} + + +sub txtdata { + my $self = shift; + + $self->{txtdata} = [map Net::DNS::Text->new($_), @_] if scalar @_; + + my $txtdata = $self->{txtdata} || []; + + return ( map $_->value, @$txtdata ) if wantarray; + + join ' ', map $_->value, @$txtdata if defined wantarray; +} + + +sub char_str_list { return (&txtdata); } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR( 'name TXT txtdata ...' ); + + $rr = new Net::DNS::RR( name => 'name', + type => 'TXT', + txtdata => 'single text string' + ); + + $rr = new Net::DNS::RR( name => 'name', + type => 'TXT', + txtdata => [ 'multiple', 'strings', ... ] + ); + + use utf8; + $rr = new Net::DNS::RR( 'jp TXT 古池や　蛙飛込む　水の音' ); + +=head1 DESCRIPTION + +Class for DNS Text (TXT) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 txtdata + + $string = $rr->txtdata; + @list = $rr->txtdata; + + $rr->txtdata( @list ); + +When invoked in scalar context, txtdata() returns a concatenation +of the descriptive text elements each separated by a single space +character. + +In a list context, txtdata() returns a list of the text elements. + + +=head1 COPYRIGHT + +Copyright (c)2011 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 3.3.14, RFC3629 + +=cut diff --git a/lib/Net/DNS/RR/URI.pm b/lib/Net/DNS/RR/URI.pm new file mode 100644 index 0000000..ae25d83 --- /dev/null +++ b/lib/Net/DNS/RR/URI.pm @@ -0,0 +1,181 @@ +package Net::DNS::RR::URI; + +# +# $Id: URI.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::URI - DNS URI resource record + +=cut + + +use integer; + +use Net::DNS::Text; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + @{$self}{qw(priority weight)} = unpack( "\@$offset n2", $$data ); + $offset += 4; + $self->{target} = decode Net::DNS::Text( $data, $offset, $limit - $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $target = $self->{target}; + pack 'n2 a*', @{$self}{qw(priority weight)}, $target->raw; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $target = $self->{target}; + my @rdata = ( $self->priority, $self->weight, $target->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + map $self->$_(shift), qw(priority weight target); +} + + +sub priority { + my $self = shift; + + $self->{priority} = 0 + shift if scalar @_; + $self->{priority} || 0; +} + + +sub weight { + my $self = shift; + + $self->{weight} = 0 + shift if scalar @_; + $self->{weight} || 0; +} + + +sub target { + my $self = shift; + + $self->{target} = new Net::DNS::Text(shift) if scalar @_; + $self->{target}->value if $self->{target}; +} + + +# order RRs by numerically increasing priority, decreasing weight +my $function = sub { + my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); + $a->{priority} <=> $b->{priority} + || $b->{weight} <=> $a->{weight}; +}; + +__PACKAGE__->set_rrsort_func( 'priority', $function ); + +__PACKAGE__->set_rrsort_func( 'default_sort', $function ); + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name URI priority weight target'); + +=head1 DESCRIPTION + +Class for DNS Service (URI) resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 priority + + $priority = $rr->priority; + $rr->priority( $priority ); + +The priority of the target URI in this RR. +The range of this number is 0-65535. +A client MUST attempt to contact the URI with the lowest-numbered +priority it can reach; weighted selection being used to distribute +load across targets with equal priority. + +=head2 weight + + $weight = $rr->weight; + $rr->weight( $weight ); + +A server selection mechanism. The weight field specifies a relative +weight for entries with the same priority. Larger weights SHOULD be +given a proportionately higher probability of being selected. The +range of this number is 0-65535. + +=head2 target + + $target = $rr->target; + $rr->target( $target ); + +The URI of the target. Resolution of the URI is according to the +definitions for the Scheme of the URI. + + +=head1 COPYRIGHT + +Copyright (c)2015 Dick Franks. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, +RFC7553 + +=cut diff --git a/lib/Net/DNS/RR/X25.pm b/lib/Net/DNS/RR/X25.pm new file mode 100644 index 0000000..fa9e108 --- /dev/null +++ b/lib/Net/DNS/RR/X25.pm @@ -0,0 +1,132 @@ +package Net::DNS::RR::X25; + +# +# $Id: X25.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::X25 - DNS X25 resource record + +=cut + + +use integer; + +use Net::DNS::Text; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + $self->{address} = decode Net::DNS::Text( $data, $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + $self->{address}->encode; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->{address}->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +sub address { + my $self = shift; + + $self->{address} = new Net::DNS::Text(shift) if scalar @_; + $self->{address}->value if $self->{address}; +} + + +sub PSDNaddress { &address; } + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name X25 PSDNaddress'); + +=head1 DESCRIPTION + +Class for DNS X25 resource records. + +=head1 METHODS + +The available methods are those inherited from the base class augmented +by the type-specific methods defined in this package. + +Use of undocumented package features or direct access to internal data +structures is discouraged and could result in program termination or +other unpredictable behaviour. + + +=head2 PSDNaddress + +=head2 address + + $address = $rr->address; + $rr->address( $address ); + +The PSDN-address is a string of decimal digits, beginning with +the 4 digit DNIC (Data Network Identification Code), as specified +in X.121. + + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +All rights reserved. + +Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1183 Section 3.1 + +=cut diff --git a/lib/Net/DNS/Resolver.pm b/lib/Net/DNS/Resolver.pm new file mode 100644 index 0000000..aced7c4 --- /dev/null +++ b/lib/Net/DNS/Resolver.pm @@ -0,0 +1,777 @@ +package Net::DNS::Resolver; + +# +# $Id: Resolver.pm 1598 2017-10-03 09:48:30Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1598 $)[1]; + +=head1 NAME + +Net::DNS::Resolver - DNS resolver class + +=cut + + +use strict; +use warnings; + +use constant CONFIG => defined eval "require Net::DNS::Resolver::$^O"; + +use constant OS_CONF => join '::', __PACKAGE__, CONFIG ? $^O : 'UNIX'; + +use base OS_CONF; + + +1; + +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + + $resolver = new Net::DNS::Resolver(); + + # Perform a lookup, using the searchlist if appropriate. + $reply = $resolver->search( 'example.com' ); + + # Perform a lookup, without the searchlist + $reply = $resolver->query( 'example.com', 'MX' ); + + # Perform a lookup, without pre or post-processing + $reply = $resolver->send( 'example.com', 'MX', 'IN' ); + + # Send a prebuilt query packet + $query = new Net::DNS::Packet( ... ); + $reply = $resolver->send( $query ); + +=head1 DESCRIPTION + +Instances of the Net::DNS::Resolver class represent resolver objects. +A program can have multiple resolver objects, each maintaining its +own state information such as the nameservers to be queried, whether +recursion is desired, etc. + +=head1 METHODS + +=head2 new + + # Use the default configuration + $resolver = new Net::DNS::Resolver(); + + # Use my own configuration file + $resolver = new Net::DNS::Resolver( config_file => '/my/dns.conf' ); + + # Set options in the constructor + $resolver = new Net::DNS::Resolver( + nameservers => [ '10.1.1.128', '10.1.2.128' ], + recurse => 0, + debug => 1 + ); + +Returns a resolver object. If no arguments are supplied, C +returns an object having the default configuration. + +On Unix and Linux systems, +the default values are read from the following files, +in the order indicated: + +=over + +F, +F<$HOME/.resolv.conf>, +F<./.resolv.conf> + +=back + + +The following keywords are recognised in resolver configuration files: + +=over + +B address + +IP address of a name server that the resolver should query. + +B localdomain + +The domain suffix to be appended to a short non-absolute name. + +B domain ... + +A space-separated list of domains in the desired search path. + +B option:value ... + +A space-separated list of key:value items. + +=back + +Except for F, files will only be read if owned by the +effective userid running the program. In addition, several environment +variables may contain configuration information; see L. + +Note that the domain and searchlist keywords are mutually exclusive. +If both are present, the resulting behaviour is unspecified. +If neither is present, the domain is determined from the local hostname. + +On Windows systems, an attempt is made to determine the system defaults +using the registry. Systems with many dynamically configured network +interfaces may confuse L. + + + # Use my own configuration file + $resolver = new Net::DNS::Resolver( config_file => '/my/dns.conf' ); + +You can include a configuration file of your own when creating a +resolver object. This is supported on both Unix and Windows. + +If a custom configuration file is specified at first instantiation, +all other configuration files and environment variables are ignored. + + + # Set options in the constructor + $resolver = new Net::DNS::Resolver( + nameservers => [ '10.1.1.128', '10.1.2.128' ], + recurse => 0 + ); + +Explicit arguments to C override the corresponding configuration +variables. The argument list consists of a sequence of (name=>value) +pairs, each interpreted as an invocation of the corresponding method. + + +=head2 print + + $resolver->print; + +Prints the resolver state on the standard output. + + +=head2 query + + $packet = $resolver->query( 'mailhost' ); + $packet = $resolver->query( 'mailhost.example.com' ); + $packet = $resolver->query( '192.0.2.1' ); + $packet = $resolver->query( 'example.com', 'MX' ); + $packet = $resolver->query( 'annotation.example.com', 'TXT', 'IN' ); + +Performs a DNS query for the given name; the search list is not applied. +If C is true, and the number of dots is less than C, +the default domain will be appended unless name is absolute. + +The record type and class can be omitted; they default to A and IN. +If the name looks like an IP address (IPv4 or IPv6), +then a query within in-addr.arpa or ip6.arpa will be performed. + +Returns a L object, or C if no answers were found. +The reason for failure may be determined using C. + +If you need to examine the response packet, whether it contains +any answers or not, use the C method instead. + + +=head2 search + + $packet = $resolver->search( 'mailhost' ); + $packet = $resolver->search( 'mailhost.example.com' ); + $packet = $resolver->search( '192.0.2.1' ); + $packet = $resolver->search( 'example.com', 'MX' ); + $packet = $resolver->search( 'annotation.example.com', 'TXT', 'IN' ); + +Performs a DNS query for the given name, applying the searchlist if +appropriate. The search algorithm is as follows: + +Unless the number of dots is less than C, +perform an initial query using the unmodified name. + +If C is true and the name has no terminal dot, +try appending each suffix in the search list. + +The record type and class can be omitted; they default to A and IN. +If the name looks like an IP address (IPv4 or IPv6), +then a query within in-addr.arpa or ip6.arpa will be performed. + +Returns a L object, or C if no answers were found. +The reason for failure may be determined using C. + +If you need to examine the response packet, whether it contains +any answers or not, use the C method instead. + + +=head2 send + + $packet = $resolver->send( $query ); + + $packet = $resolver->send( 'mailhost.example.com' ); + $packet = $resolver->query( '192.0.2.1' ); + $packet = $resolver->send( 'example.com', 'MX' ); + $packet = $resolver->send( 'annotation.example.com', 'TXT', 'IN' ); + +Performs a DNS query for the given name. +Neither the searchlist nor the default domain will be appended. + +The argument list can be either a pre-built query L +or a list of strings. +The record type and class can be omitted; they default to A and IN. +If the name looks like an IP address (IPv4 or IPv6), +then a query within in-addr.arpa or ip6.arpa will be performed. + +Returns a L object whether there were any answers or not. +Use C<< $packet->header->ancount >> or C<< $packet->answer >> to find out +if there were any records in the answer section. +Returns C if no response was received. + + +=head2 axfr + + @zone = $resolver->axfr(); + @zone = $resolver->axfr( 'example.com' ); + @zone = $resolver->axfr( 'example.com', 'IN' ); + + $iterator = $resolver->axfr(); + $iterator = $resolver->axfr( 'example.com' ); + $iterator = $resolver->axfr( 'example.com', 'IN' ); + + $rr = $iterator->(); + +Performs a zone transfer using the resolver nameservers list, +attempted in the order listed. + +If the zone is omitted, it defaults to the first zone listed +in the resolver search list. + +If the class is omitted, it defaults to IN. + + +When called in list context, C returns a list of L +objects. The redundant SOA record that terminates the zone transfer +is not returned to the caller. + +In deferrence to RFC1035(6.3), a complete zone transfer is expected +to return all records in the zone or nothing at all. +When no resource records are returned by C, +the reason for failure may be determined using C. + +Here is an example that uses a timeout and TSIG verification: + + $resolver->tcp_timeout( 10 ); + $resolver->tsig( 'Khmac-sha1.example.+161+24053.private' ); + @zone = $resolver->axfr( 'example.com' ); + + foreach $rr (@zone) { + $rr->print; + } + + +When called in scalar context, C returns an iterator object. +Each invocation of the iterator returns a single L +or C when the zone is exhausted. + +An exception is raised if the zone transfer can not be completed. + +The redundant SOA record that terminates the zone transfer is not +returned to the caller. + +Here is the example above, implemented using an iterator: + + $resolver->tcp_timeout( 10 ); + $resolver->tsig( 'Khmac-sha1.example.+161+24053.private' ); + $iterator = $resolver->axfr( 'example.com' ); + + while ( $rr = $iterator->() ) { + $rr->print; + } + + +=head2 bgsend + + $handle = $resolver->bgsend( $packet ) || die $resolver->errorstring; + + $handle = $resolver->bgsend( 'mailhost.example.com' ); + $handle = $resolver->bgsend( '192.0.2.1' ); + $handle = $resolver->bgsend( 'example.com', 'MX' ); + $handle = $resolver->bgsend( 'annotation.example.com', 'TXT', 'IN' ); + +Performs a background DNS query for the given name and returns immediately +without waiting for the response. The program can then perform other tasks +while awaiting the response from the nameserver. + +The argument list can be either a L object or a list +of strings. The record type and class can be omitted; they default to +A and IN. If the name looks like an IP address (IPv4 or IPv6), +then a query within in-addr.arpa or ip6.arpa will be performed. + +Returns an opaque handle which is passed to subsequent invocations of +the C and C methods. +Errors are indicated by returning C in which case +the reason for failure may be determined using C. + +The response L object is obtained by calling C. + +B: +Programs should make no assumptions about the nature of the handles +returned by C which should be used strictly as described here. + + +=head2 bgread + + $handle = $resolver->bgsend( 'www.example.com' ); + $packet = $resolver->bgread($handle); + +Reads the answer from a background query. +The argument is the handle returned by C. + +Returns a L object or C if no response was +received before the timeout interval expired. + + +=head2 bgbusy + + $handle = $resolver->bgsend( 'foo.example.com' ); + + while ($resolver->bgbusy($handle)) { + ... + } + + $packet = $resolver->bgread($handle); + +Returns true while awaiting the response or for the transaction to time out. +The argument is the handle returned by C. + +Truncated UDP packets will be retried transparently using TCP while +continuing to assert busy to the caller. + + +=head2 bgisready + + until ($resolver->bgisready($handle)) { + ... + } + +C is the logical complement of C which is retained +for backward compatibility. + + +=head2 debug + + print 'debug flag: ', $resolver->debug, "\n"; + $resolver->debug(1); + +Get or set the debug flag. +If set, calls to C, C, and C will print +debugging information on the standard output. +The default is false. + + +=head2 defnames + + print 'defnames flag: ', $resolver->defnames, "\n"; + $resolver->defnames(0); + +Get or set the defnames flag. +If true, calls to C will append the default domain to +resolve names that are not fully qualified. +The default is true. + + +=head2 dnsrch + + print 'dnsrch flag: ', $resolver->dnsrch, "\n"; + $resolver->dnsrch(0); + +Get or set the dnsrch flag. +If true, calls to C will apply the search list to resolve +names that are not fully qualified. +The default is true. + + +=head2 domain + + $domain = $resolver->domain; + $resolver->domain( 'domain.example' ); + +Gets or sets the resolver default domain. + + +=head2 igntc + + print 'igntc flag: ', $resolver->igntc, "\n"; + $resolver->igntc(1); + +Get or set the igntc flag. +If true, truncated packets will be ignored. +If false, the query will be retried using TCP. +The default is false. + + +=head2 nameserver, nameservers + + @nameservers = $resolver->nameservers(); + $resolver->nameservers( '192.0.2.1', '192.0.2.2', '2001:DB8::3' ); + +Gets or sets the nameservers to be queried. + +Also see the IPv6 transport notes below + + +=head2 persistent_tcp + + print 'Persistent TCP flag: ', $resolver->persistent_tcp, "\n"; + $resolver->persistent_tcp(1); + +Get or set the persistent TCP setting. +If true, L will keep a TCP socket open for each host:port +to which it connects. +This is useful if you are using TCP and need to make a lot of queries +or updates to the same nameserver. + +The default is false unless you are running a SOCKSified Perl, +in which case the default is true. + + +=head2 persistent_udp + + print 'Persistent UDP flag: ', $resolver->persistent_udp, "\n"; + $resolver->persistent_udp(1); + +Get or set the persistent UDP setting. +If true, a L resolver will use the same UDP socket +for all queries within each address family. + +This avoids the cost of creating and tearing down UDP sockets, +but also defeats source port randomisation. + + +=head2 port + + print 'sending queries to port ', $resolver->port, "\n"; + $resolver->port(9732); + +Gets or sets the port to which queries are sent. +Convenient for nameserver testing using a non-standard port. +The default is port 53. + + +=head2 recurse + + print 'recursion flag: ', $resolver->recurse, "\n"; + $resolver->recurse(0); + +Get or set the recursion flag. +If true, this will direct nameservers to perform a recursive query. +The default is true. + + +=head2 retrans + + print 'retrans interval: ', $resolver->retrans, "\n"; + $resolver->retrans(3); + +Get or set the retransmission interval +The default is 5 seconds. + + +=head2 retry + + print 'number of tries: ', $resolver->retry, "\n"; + $resolver->retry(2); + +Get or set the number of times to try the query. +The default is 4. + + +=head2 searchlist + + @searchlist = $resolver->searchlist; + $resolver->searchlist( 'a.example', 'b.example', 'c.example' ); + +Gets or sets the resolver search list. + + +=head2 srcaddr + + $resolver->srcaddr('192.0.2.1'); + +Sets the source address from which queries are sent. +Convenient for forcing queries from a specific interface on a +multi-homed host. The default is to use any local address. + + +=head2 srcport + + $resolver->srcport(5353); + +Sets the port from which queries are sent. +The default is 0, meaning any port. + + +=head2 tcp_timeout + + print 'TCP timeout: ', $resolver->tcp_timeout, "\n"; + $resolver->tcp_timeout(10); + +Get or set the TCP timeout in seconds. +The default is 120 seconds (2 minutes). + + +=head2 udp_timeout + + print 'UDP timeout: ', $resolver->udp_timeout, "\n"; + $resolver->udp_timeout(10); + +Get or set the bgsend() UDP timeout in seconds. +The default is 30 seconds. + + +=head2 udppacketsize + + print "udppacketsize: ", $resolver->udppacketsize, "\n"; + $resolver->udppacketsize(2048); + +Get or set the UDP packet size. +If set to a value not less than the default DNS packet size, +an EDNS extension will be added indicating support for +large UDP datagrams. + + +=head2 usevc + + print 'usevc flag: ', $resolver->usevc, "\n"; + $resolver->usevc(1); + +Get or set the usevc flag. +If true, queries will be performed using virtual circuits (TCP) +instead of datagrams (UDP). +The default is false. + + +=head2 answerfrom + + print 'last answer was from: ', $resolver->answerfrom, "\n"; + +Returns the IP address from which the most recent packet was +received in response to a query. + + +=head2 errorstring + + print 'query status: ', $resolver->errorstring, "\n"; + +Returns a string containing error information from the most recent +DNS protocol interaction. +C is meaningful only when interrogated immediately +after the corresponding method call. + + +=head2 dnssec + + print "dnssec flag: ", $resolver->dnssec, "\n"; + $resolver->dnssec(0); + +The dnssec flag causes the resolver to transmit DNSSEC queries +and to add a EDNS0 record as required by RFC2671 and RFC3225. +The actions of, and response from, the remote nameserver is +determined by the settings of the AD and CD flags. + +Calling the C method with a non-zero value will also set the +UDP packet size to the default value of 2048. If that is too small or +too big for your environment, you should call the C +method immediately after. + + $resolver->dnssec(1); # DNSSEC using default packetsize + $resolver->udppacketsize(1250); # lower the UDP packet size + +A fatal exception will be raised if the C method is called +but the L library has not been installed. + + +=head2 adflag + + $resolver->dnssec(1); + $resolver->adflag(1); + print "authentication desired flag: ", $resolver->adflag, "\n"; + +Gets or sets the AD bit for dnssec queries. This bit indicates that +the caller is interested in the returned AD (authentic data) bit but +does not require any dnssec RRs to be included in the response. +The default value is false. + + +=head2 cdflag + + $resolver->dnssec(1); + $resolver->cdflag(1); + print "checking disabled flag: ", $resolver->cdflag, "\n"; + +Gets or sets the CD bit for dnssec queries. This bit indicates that +authentication by upstream nameservers should be suppressed. +Any dnssec RRs required to execute the authentication procedure +should be included in the response. +The default value is false. + + +=head2 tsig + + $resolver->tsig( $tsig ); + + $resolver->tsig( 'Khmac-sha1.example.+161+24053.private' ); + + $resolver->tsig( 'Khmac-sha1.example.+161+24053.key' ); + + $resolver->tsig( 'Khmac-sha1.example.+161+24053.key', + fudge => 60 + ); + + $resolver->tsig( $key_name, $key ); + + $resolver->tsig( undef ); + +Set the TSIG record used to automatically sign outgoing queries, zone +transfers and updates. Automatic signing is disabled if called with +undefined arguments. + +The default resolver behaviour is not to sign any packets. You must +call this method to set the key if you would like the resolver to +sign and verify packets automatically. + +Packets can also be signed manually; see the L +and L manual pages for examples. TSIG records +in manually-signed packets take precedence over those that the +resolver would add automatically. + + +=head1 ENVIRONMENT + +The following environment variables can also be used to configure +the resolver: + +=head2 RES_NAMESERVERS + + # Bourne Shell + RES_NAMESERVERS="192.0.2.1 192.0.2.2 2001:DB8::3" + export RES_NAMESERVERS + + # C Shell + setenv RES_NAMESERVERS "192.0.2.1 192.0.2.2 2001:DB8::3" + +A space-separated list of nameservers to query. + +=head2 RES_SEARCHLIST + + # Bourne Shell + RES_SEARCHLIST="a.example.com b.example.com c.example.com" + export RES_SEARCHLIST + + # C Shell + setenv RES_SEARCHLIST "a.example.com b.example.com c.example.com" + +A space-separated list of domains to put in the search list. + +=head2 LOCALDOMAIN + + # Bourne Shell + LOCALDOMAIN=example.com + export LOCALDOMAIN + + # C Shell + setenv LOCALDOMAIN example.com + +The default domain. + +=head2 RES_OPTIONS + + # Bourne Shell + RES_OPTIONS="retrans:3 retry:2 inet6" + export RES_OPTIONS + + # C Shell + setenv RES_OPTIONS "retrans:3 retry:2 inet6" + +A space-separated list of resolver options to set. Options that +take values are specified as C. + + +=head1 IPv6 TRANSPORT + +The Net::DNS::Resolver library will enable IPv6 transport if the +L library package is available. + +The C, C, C, and C methods +with non-zero argument may be used to configure transport selection. + +The behaviour of the C method illustrates the transport +selection mechanism. If, for example, IPv6 is not available or IPv4 +transport has been forced, the C method will only return +IPv4 addresses: + + $resolver->nameservers( '192.0.2.1', '192.0.2.2', '2001:DB8::3' ); + $resolver->force_v4(1); + print join ' ', $resolver->nameservers(); + +will print + + 192.0.2.1 192.0.2.2 + + +=head1 CUSTOMISED RESOLVERS + +Net::DNS::Resolver is actually an empty subclass. At compile time a +super class is chosen based on the current platform. A side benefit of +this allows for easy modification of the methods in Net::DNS::Resolver. +You can simply add a method to the namespace! + +For example, if we wanted to cache lookups: + + package Net::DNS::Resolver; + + my %cache; + + sub search { + $self = shift; + + $cache{"@_"} ||= $self->SUPER::search(@_); + } + + +=head1 COPYRIGHT + +Copyright (c)1997-2000 Michael Fuhr. + +Portions Copyright (c)2002-2004 Chris Reinhardt. + +Portions Copyright (c)2005 Olaf M. Kolkman, NLnet Labs. + +Portions Copyright (c)2014,2015 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, +L, L, L, +L, RFC 1034, RFC 1035 + +=cut + diff --git a/lib/Net/DNS/Resolver/Base.pm b/lib/Net/DNS/Resolver/Base.pm new file mode 100644 index 0000000..c63a8bd --- /dev/null +++ b/lib/Net/DNS/Resolver/Base.pm @@ -0,0 +1,1209 @@ +package Net::DNS::Resolver::Base; + +# +# $Id: Base.pm 1608 2017-12-07 10:10:38Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1608 $)[1]; + + +# +# Implementation notes wrt IPv6 support when using perl before 5.20.0. +# +# In general we try to be gracious to those stacks that do not have IPv6 support. +# The socket code is conditionally compiled depending upon the availability of +# IO::Socket::IP or the deprecated IO::Socket::INET6 package. +# +# We have chosen not to use mapped IPv4 addresses, there seem to be issues +# with this; as a result we use separate sockets for each family type. +# +# inet_pton is not available on WIN32, so we only use the getaddrinfo +# call to translate IP addresses to socketaddress. +# +# The configuration options force_v4, force_v6, prefer_v4 and prefer_v6 +# are provided to control IPv6 behaviour for test purposes. +# +# Olaf Kolkman, RIPE NCC, December 2003. +# [Revised March 2016] + + +use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.32; 1;'; + +use constant USE_SOCKET_INET => defined eval 'require IO::Socket::INET'; + +use constant USE_SOCKET_INET6 => defined eval 'require IO::Socket::INET6'; + +use constant IPv4 => USE_SOCKET_IP || USE_SOCKET_INET; +use constant IPv6 => USE_SOCKET_IP || USE_SOCKET_INET6; + + +# If SOCKSified Perl, use TCP instead of UDP and keep the socket open. +use constant SOCKS => scalar eval 'require Config; $Config::Config{usesocks}'; + + +# Allow taint tests to be optimised away when appropriate. +use constant UNCND => $] < 5.008; ## eval '${^TAINT}' breaks old compilers +use constant TAINT => UNCND || eval '${^TAINT}'; +use constant TESTS => TAINT && defined eval 'require Scalar::Util'; + + +use strict; +use warnings; +use integer; +use Carp; +use IO::Select; +use IO::Socket; + +use Net::DNS::RR; +use Net::DNS::Packet; + +use constant PACKETSZ => 512; + + +# +# Set up a closure to be our class data. +# +{ + my $defaults = bless { + nameservers => [qw(::1 127.0.0.1)], + nameserver4 => ['127.0.0.1'], + nameserver6 => ['::1'], + port => 53, + srcaddr4 => '0.0.0.0', + srcaddr6 => '::', + srcport => 0, + searchlist => [], + retrans => 5, + retry => 4, + usevc => ( SOCKS ? 1 : 0 ), + igntc => 0, + recurse => 1, + defnames => 1, + dnsrch => 1, + ndots => 1, + debug => 0, + tcp_timeout => 120, + udp_timeout => 30, + persistent_tcp => ( SOCKS ? 1 : 0 ), + persistent_udp => 0, + dnssec => 0, + adflag => 0, # see RFC6840, 5.7 + cdflag => 0, # see RFC6840, 5.9 + udppacketsize => 0, # value bounded below by PACKETSZ + force_v4 => ( IPv6 ? 0 : 1 ), + force_v6 => 0, # only relevant if IPv6 is supported + prefer_v4 => 0, + prefer_v6 => 0, + }, + __PACKAGE__; + + + sub _defaults { return $defaults; } +} + + +# These are the attributes that the user may specify in the new() constructor. +my %public_attr = ( + map( ( $_ => $_ ), keys %{&_defaults}, qw(domain nameserver srcaddr) ), + map( ( $_ => 0 ), qw(nameserver4 nameserver6 srcaddr4 srcaddr6) ), + ); + + +my $initial; + +sub new { + my ( $class, %args ) = @_; + + my $self; + my $base = $class->_defaults; + my $init = $initial; + $initial ||= [%$base]; + if ( my $file = $args{config_file} ) { + my $conf = bless {@$initial}, $class; + $conf->_read_config_file($file); # user specified config + $self = bless {_untaint(%$conf)}, $class; + %$base = %$self unless $init; # define default configuration + + } elsif ($init) { + $self = bless {%$base}, $class; + + } else { + $class->_init(); # define default configuration + $self = bless {%$base}, $class; + } + + while ( my ( $attr, $value ) = each %args ) { + next unless $public_attr{$attr}; + my $ref = ref($value); + croak "usage: $class->new( $attr => [...] )" + if $ref && ( $ref ne 'ARRAY' ); + $self->$attr( $ref ? @$value : $value ); + } + + return $self; +} + + +my %resolv_conf = ( ## map traditional resolv.conf option names + attempts => 'retry', + inet6 => 'prefer_v6', + timeout => 'retrans', + ); + +my %res_option = ( ## any resolver attribute plus those listed above + %public_attr, + %resolv_conf, + ); + +sub _option { + my ( $self, $name, @value ) = @_; + my $attribute = $res_option{lc $name} || return; + push @value, 1 unless scalar @value; + $self->$attribute(@value); +} + + +sub _untaint { + return TAINT ? map ref($_) ? [_untaint(@$_)] : do { /^(.*)$/; $1 }, @_ : @_; +} + + +sub _read_env { ## read resolver config environment variables + my $self = shift; + + $self->nameservers( map split, $ENV{RES_NAMESERVERS} ) if defined $ENV{RES_NAMESERVERS}; + + $self->domain( $ENV{LOCALDOMAIN} ) if defined $ENV{LOCALDOMAIN}; + + $self->searchlist( map split, $ENV{RES_SEARCHLIST} ) if defined $ENV{RES_SEARCHLIST}; + + foreach ( map split, $ENV{RES_OPTIONS} || '' ) { + $self->_option( split m/:/ ); + } +} + + +sub _read_config_file { ## read resolver config file + my $self = shift; + my $file = shift; + + local *FILE; + open( FILE, $file ) or croak "$file: $!"; + + my @nameserver; + my @searchlist; + + local $_; + while () { + s/[;#].*$//; # strip comments + + /^nameserver/ && do { + my ( $keyword, @ip ) = grep defined, split; + push @nameserver, @ip; + next; + }; + + /^domain/ && do { + my ( $keyword, $domain ) = grep defined, split; + $self->domain($domain); + next; + }; + + /^search/ && do { + my ( $keyword, @domain ) = grep defined, split; + push @searchlist, @domain; + next; + }; + + /^option/ && do { + my ( $keyword, @option ) = grep defined, split; + foreach (@option) { + $self->_option( split m/:/ ); + } + }; + } + + close(FILE); + + $self->nameservers(@nameserver) if @nameserver; + $self->searchlist(@searchlist) if @searchlist; +} + + +sub string { + my $self = shift; + $self = $self->_defaults unless ref($self); + + my @nslist = $self->nameservers(); + my ($force) = ( grep( $self->{$_}, qw(force_v6 force_v4) ), 'force_v4' ); + my ($prefer) = ( grep( $self->{$_}, qw(prefer_v6 prefer_v4) ), 'prefer_v4' ); + return <{searchlist}} +;; defnames = $self->{defnames} dnsrch = $self->{dnsrch} +;; igntc = $self->{igntc} usevc = $self->{usevc} +;; recurse = $self->{recurse} port = $self->{port} +;; retrans = $self->{retrans} retry = $self->{retry} +;; tcp_timeout = $self->{tcp_timeout} persistent_tcp = $self->{persistent_tcp} +;; udp_timeout = $self->{udp_timeout} persistent_udp = $self->{persistent_udp} +;; ${prefer} = $self->{$prefer} ${force} = $self->{$force} +;; debug = $self->{debug} ndots = $self->{ndots} +END +} + + +sub print { print &string; } + + +sub domain { + my $self = shift; + my ($head) = $self->searchlist(@_); + my @list = grep defined, $head; + wantarray ? @list : "@list"; +} + +sub searchlist { + my $self = shift; + $self = $self->_defaults unless ref($self); + + return $self->{searchlist} = [@_] unless defined wantarray; + $self->{searchlist} = [@_] if scalar @_; + my @searchlist = @{$self->{searchlist}}; +} + + +sub nameservers { + my $self = shift; + $self = $self->_defaults unless ref($self); + + my @ip; + foreach my $ns ( grep defined, @_ ) { + if ( _ipv4($ns) || _ipv6($ns) ) { + push @ip, $ns; + + } else { + my $defres = ref($self)->new( debug => $self->{debug} ); + $defres->{persistent} = $self->{persistent}; + + my $names = {}; + my $packet = $defres->search( $ns, 'A' ); + my @iplist = _cname_addr( $packet, $names ); + + if (IPv6) { + $packet = $defres->search( $ns, 'AAAA' ); + push @iplist, _cname_addr( $packet, $names ); + } + + my %unique = map( ( $_ => $_ ), @iplist ); + + my @address = values(%unique); # tainted + carp "unresolvable name: $ns" unless scalar @address; + + push @ip, @address; + } + } + + if ( scalar(@_) || !defined(wantarray) ) { + my @ipv4 = grep _ipv4($_), @ip; + my @ipv6 = grep _ipv6($_), @ip; + $self->{nameservers} = \@ip; + $self->{nameserver4} = \@ipv4; + $self->{nameserver6} = \@ipv6; + } + + my @ns4 = $self->{force_v6} ? () : @{$self->{nameserver4}}; + my @ns6 = $self->{force_v4} ? () : @{$self->{nameserver6}}; + my @nameservers = @{$self->{nameservers}}; + @nameservers = ( @ns4, @ns6 ) if $self->{prefer_v4} || !scalar(@ns6); + @nameservers = ( @ns6, @ns4 ) if $self->{prefer_v6} || !scalar(@ns4); + + return @nameservers if scalar @nameservers; + + my $error = 'no nameservers'; + $error = 'IPv4 transport disabled' if scalar(@ns4) < scalar @{$self->{nameserver4}}; + $error = 'IPv6 transport disabled' if scalar(@ns6) < scalar @{$self->{nameserver6}}; + $self->errorstring($error); + return @nameservers; +} + +sub nameserver { &nameservers; } # uncoverable pod + +sub _cname_addr { + + # TODO 20081217 + # This code does not follow CNAME chains, it only looks inside the packet. + # Out of bailiwick will fail. + my @null; + my $packet = shift || return @null; + my $names = shift; + + map $names->{lc( $_->qname )}++, $packet->question; + map $names->{lc( $_->cname )}++, grep $_->can('cname'), $packet->answer; + + my @addr = grep $_->can('address'), $packet->answer; + map $_->address, grep $names->{lc( $_->name )}, @addr; +} + + +sub answerfrom { + my $self = shift; + $self->{answerfrom} = shift if scalar @_; + return $self->{answerfrom}; +} + +sub _reset_errorstring { + shift->{errorstring} = ''; +} + +sub errorstring { + my $self = shift; + my $text = shift || return $self->{errorstring}; + $self->_diag( 'errorstring:', $text ); + return $self->{errorstring} = $text; +} + + +sub query { + my $self = shift; + my $name = shift || '.'; + + my @sfix; + + if ( $self->{defnames} && ( ( $name =~ tr/././ ) < $self->{ndots} ) ) { + @sfix = $self->domain unless $name =~ m/:|\.\d*$/; + } + + my $fqdn = join '.', $name, @sfix; + $self->_diag( 'query(', $fqdn, @_, ')' ); + my $packet = $self->send( $fqdn, @_ ) || return; + return $packet->header->ancount ? $packet : undef; +} + + +sub search { + my $self = shift; + + return $self->query(@_) unless $self->{dnsrch}; + + my $name = shift || '.'; + + my @sfix = ( $name =~ m/:|\.\d*$/ ) ? () : @{$self->{searchlist}}; + my ( $domain, @etc ) = ( $name =~ tr/././ ) < $self->{ndots} ? (@sfix) : ( undef, @sfix ); + + foreach my $suffix ( $domain, @etc ) { + my $fqname = $suffix ? join( '.', $name, $suffix ) : $name; + $self->_diag( 'search(', $fqname, @_, ')' ); + my $packet = $self->send( $fqname, @_ ) || next; + return $packet->header->ancount ? $packet : next; + } + + return undef; +} + + +sub send { + my $self = shift; + my $packet = $self->_make_query_packet(@_); + my $packet_data = $packet->data; + + return $self->_send_tcp( $packet, $packet_data ) + if $self->{usevc} || length $packet_data > $self->_packetsz; + + my $ans = $self->_send_udp( $packet, $packet_data ) || return; + + return $ans if $self->{igntc}; + return $ans unless $ans->header->tc; + + $self->_diag('packet truncated: retrying using TCP'); + $self->_send_tcp( $packet, $packet_data ); +} + + +sub _send_tcp { + my ( $self, $query, $query_data ) = @_; + + $self->_reset_errorstring; + + my $tcp_packet = pack 'n a*', length($query_data), $query_data; + my @ns = $self->nameservers(); + my $lastanswer; + my $timeout = $self->{tcp_timeout}; + + foreach my $ip (@ns) { + my $socket = $self->_create_tcp_socket($ip) || next; + my $select = IO::Select->new($socket); + + $self->_diag( 'tcp send', "[$ip]" ); + + $socket->send($tcp_packet); + $self->errorstring($!); + + next unless $select->can_read($timeout); # uncoverable branch + + my $buffer = _read_tcp($socket); + $self->answerfrom($ip); + $self->_diag( 'answer from', "[$ip]", length($buffer), 'bytes' ); + + my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); + $self->errorstring($@); + next unless $self->_accept_reply( $reply, $query ); + $reply->answerfrom($ip); + + if ( $self->{tsig_rr} && !$reply->verify($query) ) { + $self->errorstring( $reply->verifyerr ); + next; + } + + $lastanswer = $reply; + + my $rcode = $reply->header->rcode; + $self->errorstring($rcode); # historical quirk + return $reply if $rcode eq 'NOERROR'; + return $reply if $rcode eq 'NXDOMAIN'; + } + + $self->{errorstring} = $lastanswer->header->rcode if $lastanswer; + $self->errorstring('query timed out') unless $self->{errorstring}; + return $lastanswer; +} + + +sub _send_udp { + my ( $self, $query, $query_data ) = @_; + + $self->_reset_errorstring; + + my @ns = $self->nameservers; + my $port = $self->{port}; + my $retrans = $self->{retrans} || 1; + my $retry = $self->{retry} || 1; + my $servers = scalar(@ns); + my $timeout = $servers ? do { no integer; $retrans / $servers } : 0; + my $lastanswer; + + # Perform each round of retries. +RETRY: for ( 1 .. $retry ) { # assumed to be a small number + + # Try each nameserver. + my $select = IO::Select->new(); + +NAMESERVER: foreach my $ns (@ns) { + + # state vector replaces corresponding element of @ns array + unless ( ref $ns ) { + my $socket = $self->_create_udp_socket($ns) || next; + my $dst_sockaddr = $self->_create_dst_sockaddr( $ns, $port ); + $ns = [$socket, $ns, $dst_sockaddr]; + } + + my ( $socket, $ip, $dst_sockaddr, $failed ) = @$ns; + next if $failed; + + $self->_diag( 'udp send', "[$ip]:$port" ); + + $select->add($socket); + $socket->send( $query_data, 0, $dst_sockaddr ); + $self->errorstring( $$ns[3] = $! ); + + # handle failure to detect taint inside socket->send() + die 'Insecure dependency while running with -T switch' + if TESTS && Scalar::Util::tainted($dst_sockaddr); + + my $reply; + while ( my ($socket) = $select->can_read($timeout) ) { + my $peer = $socket->peerhost; + $self->answerfrom($peer); + + my $buffer = _read_udp( $socket, $self->_packetsz ); + $self->_diag( "answer from [$peer]", length($buffer), 'bytes' ); + + my $packet = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); + $self->errorstring($@); + next unless $self->_accept_reply( $packet, $query ); + $reply = $packet; + $reply->answerfrom($peer); + last; + } #SELECT LOOP + + next unless $reply; + + if ( $self->{tsig_rr} && !$reply->verify($query) ) { + $self->errorstring( $$ns[3] = $reply->verifyerr ); + next; + } + + $lastanswer = $reply; + + my $rcode = $reply->header->rcode; + $self->errorstring($rcode); # historical quirk + return $reply if $rcode eq 'NOERROR'; + return $reply if $rcode eq 'NXDOMAIN'; + $$ns[3] = $rcode; + } #NAMESERVER LOOP + + no integer; + $timeout += $timeout; + } #RETRY LOOP + + $self->{errorstring} = $lastanswer->header->rcode if $lastanswer; + $self->errorstring('query timed out') unless $self->{errorstring}; + return $lastanswer; +} + + +sub bgsend { + my $self = shift; + my $packet = $self->_make_query_packet(@_); + my $packet_data = $packet->data; + + return $self->_bgsend_tcp( $packet, $packet_data ) + if $self->{usevc} || length $packet_data > $self->_packetsz; + + return $self->_bgsend_udp( $packet, $packet_data ); +} + + +sub _bgsend_tcp { + my ( $self, $packet, $packet_data ) = @_; + + $self->_reset_errorstring; + + my $tcp_packet = pack 'n a*', length($packet_data), $packet_data; + + foreach my $ip ( $self->nameservers ) { + my $socket = $self->_create_tcp_socket($ip) || next; + + $self->_diag( 'bgsend', "[$ip]" ); + + $socket->blocking(0); + $socket->send($tcp_packet); + $self->errorstring($!); + + my $expire = time() + $self->{tcp_timeout}; + ${*$socket}{net_dns_bg} = [$expire, $packet]; + return $socket; + } + + return undef; +} + + +sub _bgsend_udp { + my ( $self, $packet, $packet_data ) = @_; + + $self->_reset_errorstring; + + my $port = $self->{port}; + + foreach my $ip ( $self->nameservers ) { + my $socket = $self->_create_udp_socket($ip) || next; + my $dst_sockaddr = $self->_create_dst_sockaddr( $ip, $port ); + + $self->_diag( 'bgsend', "[$ip]:$port" ); + + $socket->send( $packet_data, 0, $dst_sockaddr ); + $self->errorstring($!); + + # handle failure to detect taint inside $socket->send() + die 'Insecure dependency while running with -T switch' + if TESTS && Scalar::Util::tainted($dst_sockaddr); + + my $expire = time() + $self->{udp_timeout}; + ${*$socket}{net_dns_bg} = [$expire, $packet]; + return $socket; + } + + return undef; +} + + +sub bgbusy { + my ( $self, $handle ) = @_; + return unless $handle; + + my $appendix = ${*$handle}{net_dns_bg} ||= [time() + $self->{udp_timeout}]; + my ( $expire, $query, $read ) = @$appendix; + return if ref($read); + + return time() <= $expire unless IO::Select->new($handle)->can_read(0); + + return if $self->{igntc}; + return unless $handle->socktype() == SOCK_DGRAM; + return unless $query; # SpamAssassin 3.4.1 workaround + + my $ans = $self->_bgread($handle); + $$appendix[2] = [$ans]; + return unless $ans; + return unless $ans->header->tc; + + $self->_diag('packet truncated: retrying using TCP'); + my $tcp = $self->_bgsend_tcp( $query, $query->data ) || return; + return defined( $_[1] = $tcp ); +} + + +sub bgisready { ## historical + !&bgbusy; # uncoverable pod +} + + +sub bgread { + while (&bgbusy) { # side effect: TCP retry + IO::Select->new( $_[1] )->can_read(0.02); # use 3 orders of magnitude less CPU + } + &_bgread; +} + + +sub _bgread { + my ( $self, $handle ) = @_; + return unless $handle; + + my $appendix = ${*$handle}{net_dns_bg}; + my ( $expire, $query, $read ) = @$appendix; + return shift(@$read) if ref($read); + + unless ( IO::Select->new($handle)->can_read(0) ) { + $self->errorstring('timed out'); + return; + } + + my $peer = $handle->peerhost; + $self->answerfrom($peer); + + my $dgram = $handle->socktype() == SOCK_DGRAM; + my $buffer = $dgram ? _read_udp( $handle, $self->_packetsz ) : _read_tcp($handle); + $self->_diag( "answer from [$peer]", length($buffer), 'bytes' ); + + my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); + $self->errorstring($@); + return unless $self->_accept_reply( $reply, $query ); + $reply->answerfrom($peer); + + return $reply unless $self->{tsig_rr} && !$reply->verify($query); + $self->errorstring( $reply->verifyerr ); + return; +} + + +sub _accept_reply { + my ( $self, $reply, $query ) = @_; + + return unless $reply; + + my $header = $reply->header; + return unless $header->qr; + + return 1 unless $query; # SpamAssassin 3.4.1 workaround + return $header->id == $query->header->id; +} + + +sub axfr { ## zone transfer + eval { + my $self = shift; + + # initialise iterator state vector + my ( $select, $verify, @rr, $soa ) = $self->_axfr_start(@_); + + my $iterator = sub { ## iterate over RRs + my $rr = shift(@rr); + + if ( ref($rr) eq 'Net::DNS::RR::SOA' ) { + return $soa = $rr unless $soa; + $select = undef; + return if $rr->encode eq $soa->encode; + croak $self->errorstring('mismatched final SOA'); + } + + return $rr if scalar @rr; + + my $reply; + ( $reply, $verify ) = $self->_axfr_next( $select, $verify ); + @rr = $reply->answer; + return $rr; + }; + + return $iterator unless wantarray; + + my @zone; ## subvert iterator to assemble entire zone + while ( my $rr = $iterator->() ) { + push @zone, $rr, @rr; # copy RRs en bloc + @rr = pop(@zone); # leave last one in @rr + } + return @zone; + }; +} + + +sub axfr_start { ## historical + my $self = shift; # uncoverable pod + defined( $self->{axfr_iter} = $self->axfr(@_) ); +} + + +sub axfr_next { ## historical + shift->{axfr_iter}->(); # uncoverable pod +} + + +sub _axfr_start { + my $self = shift; + my $dname = scalar(@_) ? shift : $self->domain; + my @class = @_; + + my $request = $self->_make_query_packet( $dname, 'AXFR', @class ); + my $content = $request->data; + my $TCP_msg = pack 'n a*', length($content), $content; + + $self->_diag("axfr_start( $dname @class )"); + + my ( $select, $reply, $rcode ); + foreach my $ns ( $self->nameservers ) { + my $socket = $self->_create_tcp_socket($ns) || next; + + $self->_diag("axfr_start nameserver [$ns]"); + + $select = IO::Select->new($socket); + $socket->send($TCP_msg); + $self->errorstring($!); + + ($reply) = $self->_axfr_next($select); + last if ( $rcode = $reply->header->rcode ) eq 'NOERROR'; + } + + croak $self->errorstring unless $reply; + + $self->errorstring($rcode); # historical quirk + + my $verify = $request->sigrr ? $request : undef; + unless ($verify) { + croak $self->errorstring unless $rcode eq 'NOERROR'; + return ( $select, $verify, $reply->answer ); + } + + my $verifyok = $reply->verify($verify); + croak $self->errorstring( $reply->verifyerr ) unless $verifyok; + croak $self->errorstring unless $rcode eq 'NOERROR'; + return ( $select, $verifyok, $reply->answer ); +} + + +sub _axfr_next { + my $self = shift; + my $select = shift || return; + my $verify = shift; + + my ($socket) = $select->can_read( $self->{tcp_timeout} ); + croak $self->errorstring('timed out') unless $socket; + + $self->answerfrom( $socket->peerhost ); + + my $buffer = _read_tcp($socket); + $self->_diag( 'received', length($buffer), 'bytes' ); + + my $packet = Net::DNS::Packet->new( \$buffer ); + croak $@, $self->errorstring('corrupt packet') if $@; + + return ( $packet, $verify ) unless $verify; + + my $verifyok = $packet->verify($verify); + croak $self->errorstring( $packet->verifyerr ) unless $verifyok; + return ( $packet, $verifyok ); +} + + +# +# Usage: $data = _read_tcp($socket); +# +sub _read_tcp { + my $socket = shift; + + my ( $s1, $s2 ); + $socket->recv( $s1, 2 ); # one lump + $socket->recv( $s2, 2 - length $s1 ); # or two? + my $size = unpack 'n', pack( 'a*a*@2', $s1, $s2 ); + + my $buffer = ''; + while ( ( my $read = length $buffer ) < $size ) { + + # During some of my tests recv() returned undef even + # though there was no error. Checking the amount + # of data read appears to work around that problem. + + my $recv_buf; + $socket->recv( $recv_buf, $size - $read ); + + $buffer .= $recv_buf || last; + } + return $buffer; +} + + +# +# Usage: $data = _read_udp($socket, $length); +# +sub _read_udp { + my $socket = shift; + my $buffer = ''; + $socket->recv( $buffer, shift ); + return $buffer; +} + + +sub _create_tcp_socket { + my $self = shift; + my $ip = shift; + + my $sock_key = "TCP[$ip]"; + my $socket; + + if ( $socket = $self->{persistent}{$sock_key} ) { + $self->_diag( 'using persistent socket', $sock_key ); + return $socket if $socket->connected; + $self->_diag('socket disconnected (trying to connect)'); + } + + my $ip6_addr = IPv6 && _ipv6($ip); + + $socket = IO::Socket::IP->new( + LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, + LocalPort => $self->{srcport}, + PeerAddr => $ip, + PeerPort => $self->{port}, + Proto => 'tcp', + Timeout => $self->{tcp_timeout}, + ) + if USE_SOCKET_IP; + + unless (USE_SOCKET_IP) { + $socket = IO::Socket::INET6->new( + LocalAddr => $self->{srcaddr6}, + LocalPort => $self->{srcport}, + PeerAddr => $ip, + PeerPort => $self->{port}, + Proto => 'tcp', + Timeout => $self->{tcp_timeout}, + ) + if USE_SOCKET_INET6 && $ip6_addr; + + $socket = IO::Socket::INET->new( + LocalAddr => $self->{srcaddr4}, + LocalPort => $self->{srcport} || undef, + PeerAddr => $ip, + PeerPort => $self->{port}, + Proto => 'tcp', + Timeout => $self->{tcp_timeout}, + ) + unless $ip6_addr; + } + + $self->errorstring("no socket $sock_key $!") unless $socket; + $self->{persistent}{$sock_key} = $self->{persistent_tcp} ? $socket : undef; + return $socket; +} + + +sub _create_udp_socket { + my $self = shift; + my $ip = shift; + + my $ip6_addr = IPv6 && _ipv6($ip); + my $sock_key = IPv6 && $ip6_addr ? 'UDP/IPv6' : 'UDP/IPv4'; + my $socket; + return $socket if $socket = $self->{persistent}{$sock_key}; + + $socket = IO::Socket::IP->new( + LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, + LocalPort => $self->{srcport}, + Proto => 'udp', + Type => SOCK_DGRAM + ) + if USE_SOCKET_IP; + + unless (USE_SOCKET_IP) { + $socket = IO::Socket::INET6->new( + LocalAddr => $self->{srcaddr6}, + LocalPort => $self->{srcport}, + Proto => 'udp', + Type => SOCK_DGRAM + ) + if USE_SOCKET_INET6 && $ip6_addr; + + $socket = IO::Socket::INET->new( + LocalAddr => $self->{srcaddr4}, + LocalPort => $self->{srcport} || undef, + Proto => 'udp', + Type => SOCK_DGRAM + ) + unless $ip6_addr; + } + + $self->errorstring("no socket $sock_key $!") unless $socket; + $self->{persistent}{$sock_key} = $self->{persistent_udp} ? $socket : undef; + return $socket; +} + + +{ + no strict qw(subs); + my @udp = ( + flags => Socket::AI_NUMERICHOST, + protocol => Socket::IPPROTO_UDP, + socktype => SOCK_DGRAM + ); + + my $ip4 = USE_SOCKET_IP ? {family => AF_INET, @udp} : {}; + my $ip6 = USE_SOCKET_IP ? {family => AF_INET6, @udp} : {}; + + my $inet6 = USE_SOCKET_INET6 ? [AF_INET6, SOCK_DGRAM, 0, Socket6::AI_NUMERICHOST()] : []; + + sub _create_dst_sockaddr { ## create UDP destination sockaddr structure + my ( $self, $ip, $port ) = @_; + + unless (USE_SOCKET_IP) { + return sockaddr_in( $port, inet_aton($ip) ) unless _ipv6($ip); + return ( Socket6::getaddrinfo( $ip, $port, @$inet6 ) )[3] + if USE_SOCKET_INET6; + } + + ( grep ref, Socket::getaddrinfo( $ip, $port, _ipv6($ip) ? $ip6 : $ip4 ), {} )[0]->{addr} + if USE_SOCKET_IP; # NB: errors raised in socket->send + } +} + + +# Lightweight versions of subroutines from Net::IP module, recoded to fix RT#96812 + +sub _ipv4 { + for (shift) { + return if m/[^.0-9]/; # dots and digits only + return m/\.\d+\./; # dots separated by digits + } +} + +sub _ipv6 { + for (shift) { + return unless m/:.*:/; # must contain two colons + return 1 unless m/[^:0-9A-Fa-f]/; # colons and hexdigits only + return 1 if m/^[:.0-9A-Fa-f]+\%.+$/; # RFC4007 scoped address + return m/^[:0-9A-Fa-f]+:[.0-9]+$/; # prefix : dotted digits + } +} + + +sub _make_query_packet { + my $self = shift; + + my ($packet) = @_; + if ( ref($packet) ) { + my $header = $packet->header; + $header->rd( $self->{recurse} ) if $header->opcode eq 'QUERY'; + + } else { + $packet = Net::DNS::Packet->new(@_); + + my $header = $packet->header; + $header->ad( $self->{adflag} ); # RFC6840, 5.7 + $header->cd( $self->{cdflag} ); # RFC6840, 5.9 + $header->do(1) if $self->{dnssec}; + $header->rd( $self->{recurse} ); + } + + $packet->edns->size( $self->{udppacketsize} ); # advertise UDPsize for local stack + + if ( $self->{tsig_rr} ) { + $packet->sign_tsig( $self->{tsig_rr} ) unless $packet->sigrr; + } + + return $packet; +} + + +sub dnssec { + my $self = shift; + + return $self->{dnssec} unless scalar @_; + + # increase default udppacket size if flag set + $self->udppacketsize(2048) if $self->{dnssec} = shift; + + return $self->{dnssec}; +} + + +sub force_v6 { + my $self = shift; + my $value = scalar(@_) ? shift() : $self->{force_v6}; + $self->{force_v6} = $value ? do { $self->{force_v4} = 0; 1 } : 0; +} + +sub force_v4 { + my $self = shift; + my $value = scalar(@_) ? shift() : $self->{force_v4}; + $self->{force_v4} = $value ? do { $self->{force_v6} = 0; 1 } : 0; +} + +sub prefer_v6 { + my $self = shift; + my $value = scalar(@_) ? shift() : $self->{prefer_v6}; + $self->{prefer_v6} = $value ? do { $self->{prefer_v4} = 0; 1 } : 0; +} + +sub prefer_v4 { + my $self = shift; + my $value = scalar(@_) ? shift() : $self->{prefer_v4}; + $self->{prefer_v4} = $value ? do { $self->{prefer_v6} = 0; 1 } : 0; +} + + +sub srcaddr { + my $self = shift; + for (@_) { + my $hashkey = _ipv6($_) ? 'srcaddr6' : 'srcaddr4'; + $self->{$hashkey} = $_; + } + return shift; +} + + +sub tsig { + my $self = shift; + $self->{tsig_rr} = eval { + local $SIG{__DIE__}; + require Net::DNS::RR::TSIG; + Net::DNS::RR::TSIG->create(@_); + }; + croak "${@}unable to create TSIG record" if $@; +} + + +# if ($self->{udppacketsize} > PACKETSZ +# then we use EDNS and $self->{udppacketsize} +# should be taken as the maximum packet_data length +sub _packetsz { + my $udpsize = shift->{udppacketsize} || 0; + return $udpsize > PACKETSZ ? $udpsize : PACKETSZ; +} + +sub udppacketsize { + my $self = shift; + $self->{udppacketsize} = shift if scalar @_; + return $self->_packetsz; +} + + +# +# Keep this method around. Folk depend on it although it is neither documented nor exported. +# +my $warned; + +sub make_query_packet { ## historical + unless ( $warned++ ) { # uncoverable pod + local $SIG{__WARN__}; + carp 'deprecated method; see RT#37104'; + } + &_make_query_packet; +} + + +sub _diag { ## debug output + my $self = shift; + print "\n;; @_\n" if $self->{debug}; +} + + +our $AUTOLOAD; + +sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) + +sub AUTOLOAD { ## Default method + my ($self) = @_; + + my $name = $AUTOLOAD; + $name =~ s/.*://; + croak "$name: no such method" unless $public_attr{$name}; + + no strict q/refs/; + *{$AUTOLOAD} = sub { + my $self = shift; + $self = $self->_defaults unless ref($self); + $self->{$name} = shift || 0 if scalar @_; + return $self->{$name}; + }; + + goto &{$AUTOLOAD}; +} + + +1; + +__END__ + + +=head1 NAME + +Net::DNS::Resolver::Base - DNS resolver base class + +=head1 SYNOPSIS + + use base qw(Net::DNS::Resolver::Base); + +=head1 DESCRIPTION + +This class is the common base class for the different platform +sub-classes of L. + +No user serviceable parts inside, see L +for all your resolving needs. + + +=head1 METHODS + +=head2 new, domain, searchlist, nameservers, print, string, errorstring, + +=head2 search, query, send, bgsend, bgbusy, bgread, axfr, answerfrom, + +=head2 force_v4, force_v6, prefer_v4, prefer_v6, + +=head2 dnssec, srcaddr, tsig, udppacketsize + +See L. + + +=head1 COPYRIGHT + +Copyright (c)2003,2004 Chris Reinhardt. + +Portions Copyright (c)2005 Olaf Kolkman. + +Portions Copyright (c)2014-2017 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L + +=cut + diff --git a/lib/Net/DNS/Resolver/MSWin32.pm b/lib/Net/DNS/Resolver/MSWin32.pm new file mode 100644 index 0000000..5f7c5ea --- /dev/null +++ b/lib/Net/DNS/Resolver/MSWin32.pm @@ -0,0 +1,145 @@ +package Net::DNS::Resolver::MSWin32; + +# +# $Id: MSWin32.pm 1568 2017-05-27 06:40:20Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1568 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::MSWin32 - MS Windows resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + +use Carp; + +our $Registry; + +use constant WINHLP => defined eval 'require Win32::IPHelper'; +use constant WINREG => defined eval 'use Win32::TieRegistry qw(KEY_READ REG_DWORD); 1'; + + +sub _init { + my $defaults = shift->_defaults; + + my $debug = 0; + + my $FIXED_INFO = {}; + + my $err = Win32::IPHelper::GetNetworkParams($FIXED_INFO); + croak "GetNetworkParams() error %u: %s\n", $err, Win32::FormatMessage($err) if $err; + + if ($debug) { + require Data::Dumper; + print Data::Dumper::Dumper $FIXED_INFO; + } + + + my @nameservers = map $_->{IpAddress}, @{$FIXED_INFO->{DnsServersList}}; + $defaults->nameservers(@nameservers); + + my $devolution = 0; + my $domainname = $FIXED_INFO->{DomainName} || ''; + my @searchlist = grep length, $domainname; + + if (WINREG) { + + # The Win32::IPHelper does not return searchlist. + # Make best effort attempt to get searchlist from the registry. + + my @root = qw(HKEY_LOCAL_MACHINE SYSTEM CurrentControlSet Services); + + my $leaf = join '\\', @root, qw(Tcpip Parameters); + my $reg_tcpip = $Registry->Open( $leaf, {Access => KEY_READ} ); + + unless ( defined $reg_tcpip ) { # Didn't work, Win95/98/Me? + $leaf = join '\\', @root, qw(VxD MSTCP); + $reg_tcpip = $Registry->Open( $leaf, {Access => KEY_READ} ); + } + + if ( defined $reg_tcpip ) { + my $searchlist = $reg_tcpip->GetValue('SearchList') || ''; + push @searchlist, split m/[\s,]+/, $searchlist; + + my ( $value, $type ) = $reg_tcpip->GetValue('UseDomainNameDevolution'); + $devolution = defined $value && $type == REG_DWORD ? hex $value : 0; + } + } + + + # fix devolution if configured, and simultaneously + # eliminate duplicate entries (but keep the order) + my @list; + my %seen; + foreach (@searchlist) { + s/\.+$//; + push( @list, $_ ) unless $seen{lc $_}++; + + next unless $devolution; + + # while there are more than two labels, cut + while (s#^[^.]+\.(.+\..+)$#$1#) { + push( @list, $_ ) unless $seen{lc $_}++; + } + } + $defaults->searchlist(@list); + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + $defaults->_read_env; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS::Resolver; + +=head1 DESCRIPTION + +This class implements the OS specific portions of C. + +No user serviceable parts inside, see L +for all your resolving needs. + +=head1 COPYRIGHT + +Copyright (c)2003 Chris Reinhardt. + +Portions Copyright (c)2009 Olaf Kolkman, NLnet Labs + +All rights reserved. + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + +=head1 SEE ALSO + +L, L, L + +=cut + diff --git a/lib/Net/DNS/Resolver/Recurse.pm b/lib/Net/DNS/Resolver/Recurse.pm new file mode 100644 index 0000000..04d012d --- /dev/null +++ b/lib/Net/DNS/Resolver/Recurse.pm @@ -0,0 +1,326 @@ +package Net::DNS::Resolver::Recurse; + +# +# $Id: Recurse.pm 1623 2018-01-26 14:23:54Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1623 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::Recurse - DNS recursive resolver + + +=head1 SYNOPSIS + + use Net::DNS::Resolver::Recurse; + + $resolver = new Net::DNS::Resolver::Recurse(); + + $packet = $resolver->query ( 'www.example.com', 'A' ); + $packet = $resolver->search( 'www.example.com', 'A' ); + $packet = $resolver->send ( 'www.example.com', 'A' ); + + +=head1 DESCRIPTION + +This module is a subclass of Net::DNS::Resolver. + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver); + + +=head1 METHODS + +This module inherits almost all the methods from Net::DNS::Resolver. +Additional module-specific methods are described below. + + +=head2 hints + +This method specifies a list of the IP addresses of nameservers to +be used to discover the addresses of the root nameservers. + + $resolver->hints(@ip); + +If no hints are passed, the priming query is directed to nameservers +drawn from a built-in list of IP addresses. + +=cut + +my @hints; +my $root = []; + +sub hints { + my $self = shift; + + splice @hints, 0, 0, splice( @hints, int( rand scalar @hints ) ); # cut deck + return @hints unless scalar @_; + $root = []; + @hints = @_; +} + + +=head2 query, search, send + +The query(), search() and send() methods produce the same result +as their counterparts in Net::DNS::Resolver. + + $packet = $resolver->send( 'www.example.com.', 'A' ); + +Server-side recursion is suppressed by clearing the recurse flag in +query packets and recursive name resolution is performed explicitly. + +The query() and search() methods are inherited from Net::DNS::Resolver +and invoke send() indirectly. + +=cut + +sub send { + return &Net::DNS::Resolver::Base::send if ref $_[1]; # send Net::DNS::Packet + + my $self = shift; + my $res = bless {persistent => {'.' => $root}, %$self}, ref($self); + + my $question = new Net::DNS::Question(@_); + my $original = pop(@_); # sneaky extra argument needed + $original = $question unless ref($original); # to preserve original request + + my ( $head, @tail ) = $question->{qname}->label; + my $domain = lc( join( '.', @tail ) || '.' ); + my $nslist = $res->{persistent}->{$domain} ||= []; + unless ( defined $head ) { + my $defres = new Net::DNS::Resolver(); + $defres->nameservers( $res->_hints ); # fall back to inbuilt list + $defres->udppacketsize(1024); # RFC8109 + my @config = $defres->nameserver( $res->hints ); + return $defres->send(qw(. NS)); + } + + if ( scalar @$nslist ) { + $self->_diag("using cached nameservers for $domain"); + } else { + $domain = lc $question->qname if $question->qtype ne 'NULL'; + my $packet = $res->send( $domain, 'NULL', 'IN', $original ); + return unless $packet; + + my @answer = $packet->answer; # return authoritative answer + return $packet if $packet->header->aa && grep $_->name eq $original->qname, @answer; + + my @auth = grep $_->type eq 'NS', $packet->answer, $packet->authority; + my %auth = map { lc $_->nsdname => lc $_->name } @auth; + my %glue; + my @glue = grep $_->can('address'), $packet->additional; + foreach ( grep $auth{lc $_->name}, @glue ) { + push @{$glue{lc $_->name}}, $_->address; + } + + my %zone = reverse %auth; + foreach my $zone ( keys %zone ) { + my @nsname = grep $auth{$_} eq $zone, keys %auth; + my @list = map $glue{$_} ? $glue{$_} : $_, @nsname; + @{$res->{persistent}->{$zone}} = @list; + return $packet if length($zone) > length($domain); + $self->_diag("cache nameservers for $zone"); + @$nslist = @list; + } + } + + my $query = new Net::DNS::Packet(); + $query->{question} = [$original]; + $res = bless {%$res}, qw(Net::DNS::Resolver) if $nslist eq $root; + $res->udppacketsize(1024); + $res->recurse(0); + + splice @$nslist, 0, 0, splice( @$nslist, int( rand scalar @$nslist ) ); # cut deck + + foreach my $ns (@$nslist) { + if ( ref $ns ) { + my @ip = map @$_, grep ref($_), @$nslist; + $res->nameservers(@ip); # cached IP list + } else { + $self->_diag("find missing glue for $ns"); + my $name = $ns; # suppress deep recursion by + $ns = []; # inserting placeholder in cache + $ns = [$res->nameservers($name)]; # substitute IP list in situ + } + + my $reply = $res->send($query); + next unless $reply; + + $self->_callback($reply); + return $reply; + } +} + + +sub query_dorecursion { &send; } # uncoverable pod + + +=head2 callback + +This method specifies a code reference to a subroutine, +which is then invoked at each stage of the recursive lookup. + +For example to emulate dig's C<+trace> function: + + my $coderef = sub { + my $packet = shift; + + printf ";; Received %d bytes from %s\n\n", + $packet->answersize, $packet->answerfrom; + }; + + $resolver->callback($coderef); + +The callback subroutine is not called +for queries for missing glue records. + +=cut + +sub callback { + my $self = shift; + + ( $self->{callback} ) = grep ref($_) eq 'CODE', @_; +} + +sub _callback { + my $callback = shift->{callback}; + $callback->(@_) if $callback; +} + +sub recursion_callback { &callback; } # uncoverable pod + + +######################################## + +{ + require Net::DNS::ZoneFile; + + my $dug = new Net::DNS::ZoneFile( \*DATA ); + my @rr = $dug->read; + + my @auth = grep $_->type eq 'NS', @rr; + my %auth = map { lc $_->nsdname => 1 } @auth; + my %glue; + my @glue = grep $auth{lc $_->name}, @rr; + foreach ( grep $_->can('address'), @glue ) { + push @{$glue{lc $_->name}}, $_->address; + } + my @ip = map @$_, values %glue; + + + sub _hints { ## default hints + splice @ip, 0, 0, splice( @ip, int( rand scalar @ip ) ); # cut deck + return @ip; + } +} + + +1; + + +=head1 ACKNOWLEDGEMENT + +This package is an improved and compatible reimplementation of the +Net::DNS::Resolver::Recurse.pm created by Rob Brown in 2002, +whose contribution is gratefully acknowledged. + + +=head1 COPYRIGHT + +Copyright (c)2014 Dick Franks. + +Portions Copyright (c)2002 Rob Brown. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L + +=cut + + +__DATA__ ## DEFAULT HINTS + +; <<>> DiG 9.9.4-P2-RedHat-9.9.4-18.P2.fc20 <<>> @b.root-servers.net . -t NS +; (2 servers found) +;; global options: +cmd +;; Got answer: +;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 47020 +;; flags: qr aa rd; QUERY: 1, ANSWER: 13, AUTHORITY: 0, ADDITIONAL: 27 +;; WARNING: recursion requested but not available + +;; OPT PSEUDOSECTION: +; EDNS: version: 0, flags:; udp: 4096 +;; QUESTION SECTION: +;. IN NS + +;; ANSWER SECTION: +. 518400 IN NS c.root-servers.net. +. 518400 IN NS k.root-servers.net. +. 518400 IN NS l.root-servers.net. +. 518400 IN NS j.root-servers.net. +. 518400 IN NS b.root-servers.net. +. 518400 IN NS g.root-servers.net. +. 518400 IN NS h.root-servers.net. +. 518400 IN NS d.root-servers.net. +. 518400 IN NS a.root-servers.net. +. 518400 IN NS f.root-servers.net. +. 518400 IN NS i.root-servers.net. +. 518400 IN NS m.root-servers.net. +. 518400 IN NS e.root-servers.net. + +;; ADDITIONAL SECTION: +a.root-servers.net. 3600000 IN A 198.41.0.4 +b.root-servers.net. 3600000 IN A 192.228.79.201 +c.root-servers.net. 3600000 IN A 192.33.4.12 +d.root-servers.net. 3600000 IN A 199.7.91.13 +e.root-servers.net. 3600000 IN A 192.203.230.10 +f.root-servers.net. 3600000 IN A 192.5.5.241 +g.root-servers.net. 3600000 IN A 192.112.36.4 +h.root-servers.net. 3600000 IN A 198.97.190.53 +i.root-servers.net. 3600000 IN A 192.36.148.17 +j.root-servers.net. 3600000 IN A 192.58.128.30 +k.root-servers.net. 3600000 IN A 193.0.14.129 +l.root-servers.net. 3600000 IN A 199.7.83.42 +m.root-servers.net. 3600000 IN A 202.12.27.33 +a.root-servers.net. 3600000 IN AAAA 2001:503:ba3e::2:30 +b.root-servers.net. 3600000 IN AAAA 2001:500:84::b +c.root-servers.net. 3600000 IN AAAA 2001:500:2::c +d.root-servers.net. 3600000 IN AAAA 2001:500:2d::d +e.root-servers.net. 3600000 IN AAAA 2001:500:a8::e +f.root-servers.net. 3600000 IN AAAA 2001:500:2f::f +g.root-servers.net. 3600000 IN AAAA 2001:500:12::d0d +h.root-servers.net. 3600000 IN AAAA 2001:500:1::53 +i.root-servers.net. 3600000 IN AAAA 2001:7fe::53 +j.root-servers.net. 3600000 IN AAAA 2001:503:c27::2:30 +k.root-servers.net. 3600000 IN AAAA 2001:7fd::1 +l.root-servers.net. 3600000 IN AAAA 2001:500:9f::42 +m.root-servers.net. 3600000 IN AAAA 2001:dc3::35 + diff --git a/lib/Net/DNS/Resolver/UNIX.pm b/lib/Net/DNS/Resolver/UNIX.pm new file mode 100644 index 0000000..98dfce8 --- /dev/null +++ b/lib/Net/DNS/Resolver/UNIX.pm @@ -0,0 +1,92 @@ +package Net::DNS::Resolver::UNIX; + +# +# $Id: UNIX.pm 1573 2017-06-12 11:03:59Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1573 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::UNIX - Unix resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +my @config_file = grep -f $_ && -r _, '/etc/resolv.conf'; + +my $dotfile = '.resolv.conf'; +my @dotpath = grep defined, $ENV{HOME}, '.'; +my @dotfile = grep -f $_ && -o _, map "$_/$dotfile", @dotpath; + + +local $ENV{PATH} = '/bin:/usr/bin'; +my $uname = eval {`uname -n 2>/dev/null`} || ''; +chomp $uname; +my ( $host, @domain ) = split /\./, $uname, 2; +__PACKAGE__->domain(@domain); + + +sub _init { + my $defaults = shift->_defaults; + + map $defaults->_read_config_file($_), @config_file; + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + map $defaults->_read_config_file($_), @dotfile; + + $defaults->_read_env; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS::Resolver; + +=head1 DESCRIPTION + +This class implements the OS specific portions of C. + +No user serviceable parts inside, see L +for all your resolving needs. + +=head1 COPYRIGHT + +Copyright (c)2003 Chris Reinhardt. + +All rights reserved. + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + +=head1 SEE ALSO + +L, L, L + +=cut + diff --git a/lib/Net/DNS/Resolver/android.pm b/lib/Net/DNS/Resolver/android.pm new file mode 100644 index 0000000..2a0255a --- /dev/null +++ b/lib/Net/DNS/Resolver/android.pm @@ -0,0 +1,97 @@ +package Net::DNS::Resolver::android; + +# +# $Id: android.pm 1568 2017-05-27 06:40:20Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1568 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::android - Android resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +my $config_file = 'resolv.conf'; +my @config_path = ( $ENV{ANDROID_ROOT} || '/system' ); +my @config_file = grep -f $_ && -r _, map "$_/etc/$config_file", @config_path; + +my $dotfile = '.resolv.conf'; +my @dotpath = grep defined, $ENV{HOME}, '.'; +my @dotfile = grep -f $_ && -o _, map "$_/$dotfile", @dotpath; + + +sub _init { + my $defaults = shift->_defaults; + + my @nameserver; + for ( 1 .. 4 ) { + my $ret = `getprop net.dns$_` || next; + chomp $ret; + push @nameserver, $ret || next; + } + + $defaults->nameserver(@nameserver) if @nameserver; + + + map $defaults->_read_config_file($_), @config_file; + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + map $defaults->_read_config_file($_), @dotfile; + + $defaults->_read_env; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS::Resolver; + +=head1 DESCRIPTION + +This class implements the OS specific portions of C. + +No user serviceable parts inside, see L +for all your resolving needs. + +=head1 COPYRIGHT + +Copyright (c)2014 Dick Franks. + +All rights reserved. + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + +=head1 SEE ALSO + +L, L, L + +=cut + diff --git a/lib/Net/DNS/Resolver/cygwin.pm b/lib/Net/DNS/Resolver/cygwin.pm new file mode 100644 index 0000000..94df27b --- /dev/null +++ b/lib/Net/DNS/Resolver/cygwin.pm @@ -0,0 +1,182 @@ +package Net::DNS::Resolver::cygwin; + +# +# $Id: cygwin.pm 1568 2017-05-27 06:40:20Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1568 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::cygwin - Cygwin resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +sub _getregkey { + my $key = join '/', @_; + + local *LM; + open( LM, "<$key" ) or return ''; + my $value = ; + $value =~ s/\0+$// if $value; + close(LM); + + return $value || ''; +} + + +sub _init { + my $defaults = shift->_defaults; + + local *LM; + + my $root = '/proc/registry/HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Services/Tcpip/Parameters'; + + unless ( -d $root ) { + + # Doesn't exist, maybe we are on 95/98/Me? + $root = '/proc/registry/HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Services/VxD/MSTCP'; + -d $root || Carp::croak "can't read registry: $!"; + } + + # Best effort to find a useful domain name for the current host + # if domain ends up blank, we're probably (?) not connected anywhere + # a DNS server is interesting either... + my $domain = _getregkey( $root, 'Domain' ) || _getregkey( $root, 'DhcpDomain' ); + + # If nothing else, the searchlist should probably contain our own domain + # also see below for domain name devolution if so configured + # (also remove any duplicates later) + my $devolution = _getregkey( $root, 'UseDomainNameDevolution' ); + my $searchlist = _getregkey( $root, 'SearchList' ); + my @searchlist = ( $domain, split m/[\s,]+/, $searchlist ); + + + # This is (probably) adequate on NT4 + my @nt4nameservers; + foreach ( grep length, _getregkey( $root, 'NameServer' ), _getregkey( $root, 'DhcpNameServer' ) ) { + push @nt4nameservers, split m/[\s,]+/; + last; + } + + + # but on W2K/XP the registry layout is more advanced due to dynamically + # appearing connections. So we attempt to handle them, too... + # opt to silently fail if something isn't ok (maybe we're on NT4) + # If this doesn't fail override any NT4 style result we found, as it + # may be there but is not valid. + # drop any duplicates later + my @nameservers; + + my $dnsadapters = join '/', $root, 'DNSRegisteredAdapters'; + if ( opendir( LM, $dnsadapters ) ) { + my @adapters = grep !/^\.\.?$/, readdir(LM); + closedir(LM); + foreach my $adapter (@adapters) { + my $ns = _getregkey( $dnsadapters, $adapter, 'DNSServerAddresses' ); + until ( length($ns) < 4 ) { + push @nameservers, join '.', unpack( 'C4', $ns ); + substr( $ns, 0, 4 ) = ''; + } + } + } + + my $interfaces = join '/', $root, 'Interfaces'; + if ( opendir( LM, $interfaces ) ) { + my @ifacelist = grep !/^\.\.?$/, readdir(LM); + closedir(LM); + foreach my $iface (@ifacelist) { + my $ip = _getregkey( $interfaces, $iface, 'DhcpIPAddress' ) + || _getregkey( $interfaces, $iface, 'IPAddress' ); + next unless $ip; + next if $ip eq '0.0.0.0'; + + foreach ( + grep length, + _getregkey( $interfaces, $iface, 'NameServer' ), + _getregkey( $interfaces, $iface, 'DhcpNameServer' ) + ) { + push @nameservers, split m/[\s,]+/; + last; + } + } + } + + @nameservers = @nt4nameservers unless @nameservers; + $defaults->nameservers(@nameservers); + + + # fix devolution if configured, and simultaneously + # eliminate duplicate entries (but keep the order) + my @list; + my %seen; + foreach (@searchlist) { + s/\.+$//; + push( @list, $_ ) unless $seen{lc $_}++; + + next unless $devolution; + + # while there are more than two labels, cut + while (s#^[^.]+\.(.+\..+)$#$1#) { + push( @list, $_ ) unless $seen{lc $_}++; + } + } + $defaults->searchlist(@list); + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + $defaults->_read_env; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS::Resolver; + +=head1 DESCRIPTION + +This class implements the OS specific portions of C. + +No user serviceable parts inside, see L +for all your resolving needs. + +=head1 COPYRIGHT + +Copyright (c)2003 Sidney Markowitz. + +All rights reserved. + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + +=head1 SEE ALSO + +L, L, L + +=cut + diff --git a/lib/Net/DNS/Resolver/os2.pm b/lib/Net/DNS/Resolver/os2.pm new file mode 100644 index 0000000..526f386 --- /dev/null +++ b/lib/Net/DNS/Resolver/os2.pm @@ -0,0 +1,87 @@ +package Net::DNS::Resolver::os2; + +# +# $Id: os2.pm 1568 2017-05-27 06:40:20Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1568 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::os2 - OS2 resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +my $config_file = 'resolv'; +my @config_path = ( $ENV{ETC} || '/etc' ); +my @config_file = grep -f $_ && -r _, map "$_/$config_file", @config_path; + +my $dotfile = '.resolv.conf'; +my @dotpath = grep defined, $ENV{HOME}, '.'; +my @dotfile = grep -f $_ && -o _, map "$_/$dotfile", @dotpath; + + +sub _init { + my $defaults = shift->_defaults; + + map $defaults->_read_config_file($_), @config_file; + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + map $defaults->_read_config_file($_), @dotfile; + + $defaults->_read_env; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS::Resolver; + +=head1 DESCRIPTION + +This class implements the OS specific portions of C. + +No user serviceable parts inside, see L +for all your resolving needs. + +=head1 COPYRIGHT + +Copyright (c)2012 Dick Franks. + +All rights reserved. + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + +=head1 SEE ALSO + +L, L, L + +=cut + diff --git a/lib/Net/DNS/Resolver/os390.pm b/lib/Net/DNS/Resolver/os390.pm new file mode 100644 index 0000000..44c5e71 --- /dev/null +++ b/lib/Net/DNS/Resolver/os390.pm @@ -0,0 +1,185 @@ +package Net::DNS::Resolver::os390; + +# +# $Id: os390.pm 1579 2017-06-26 11:36:57Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1579 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::os390 - IBM OS/390 resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +local $ENV{PATH} = '/bin:/usr/bin'; +my $sysname = eval {`sysvar SYSNAME 2>/dev/null`} || ''; +chomp $sysname; + + +my %RESOLVER_SETUP; ## placeholders for unimplemented search list elements + +my @dataset = ( ## plausible places to seek resolver configuration + $RESOLVER_SETUP{GLOBALTCPIPDATA}, + $ENV{RESOLVER_CONFIG}, # MVS dataset or Unix file name + "/etc/resolv.conf", + $RESOLVER_SETUP{SYSTCPD}, + "//TCPIP.DATA", # .TCPIP.DATA + "//'${sysname}.TCPPARMS(TCPDATA)'", + "//'SYS1.TCPPARMS(TCPDATA)'", + $RESOLVER_SETUP{DEFAULTTCPIPDATA}, + "//'TCPIP.TCPIP.DATA'" + ); + + +my $dotfile = '.resolv.conf'; +my @dotpath = grep defined, $ENV{HOME}, '.'; +my @dotfile = grep -f $_ && -o _, map "$_/$dotfile", @dotpath; + + +my %option = ( ## map MVS config option names + NSPORTADDR => 'port', + RESOLVERTIMEOUT => 'retrans', + RESOLVERUDPRETRIES => 'retry', + SORTLIST => 'sortlist', + ); + + +sub _init { + my $defaults = shift->_defaults; + my %stop; + local $ENV{PATH} = '/bin:/usr/bin'; + + foreach my $dataset ( Net::DNS::Resolver::Base::_untaint( grep defined, @dataset ) ) { + eval { + local *FILE; # "cat" able to read MVS dataset + open( FILE, qq[cat "$dataset" 2>/dev/null |] ) or die "$dataset: $!"; + + my @nameserver; + my @searchlist; + local $_; + + while () { + s/[;#].*$//; # strip comment + s/^\s+//; # strip leading white space + next unless $_; # skip empty line + + next if m/^\w+:/ && !m/^$sysname:/oi; + s/^\w+:\s*//; # discard qualifier + + + m/^(NSINTERADDR|nameserver)/i && do { + my ( $keyword, @ip ) = grep defined, split; + push @nameserver, @ip; + next; + }; + + + m/^(DOMAINORIGIN|domain)/i && do { + my ( $keyword, @domain ) = grep defined, split; + $defaults->domain(@domain) unless $stop{domain}++; + next; + }; + + + m/^search/i && do { + my ( $keyword, @domain ) = grep defined, split; + push @searchlist, @domain; + next; + }; + + + m/^option/i && do { + my ( $keyword, @option ) = grep defined, split; + foreach (@option) { + my ( $attribute, @value ) = split m/:/; + $defaults->_option( $attribute, @value ) + unless $stop{$attribute}++; + } + next; + }; + + + m/^RESOLVEVIA/i && do { + my ( $keyword, $value ) = grep defined, split; + $defaults->_option( 'usevc', $value eq 'TCP' ) + unless $stop{usevc}++; + next; + }; + + + m/^\w+\s*/ && do { + my ( $keyword, @value ) = grep defined, split; + my $attribute = $option{uc $keyword} || next; + $defaults->_option( $attribute, @value ) + unless $stop{$attribute}++; + }; + } + + close(FILE); + + $defaults->nameserver(@nameserver) if @nameserver && !$stop{nameserver}++; + $defaults->searchlist(@searchlist) if @searchlist && !$stop{search}++; + }; + warn $@ if $@; + } + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + map $defaults->_read_config_file($_), @dotfile; + + $defaults->_read_env; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS::Resolver; + +=head1 DESCRIPTION + +This class implements the OS specific portions of C. + +No user serviceable parts inside, see L +for all your resolving needs. + +=head1 COPYRIGHT + +Copyright (c)2017 Dick Franks. + +All rights reserved. + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + +=head1 SEE ALSO + +L, L, L + +=cut + diff --git a/lib/Net/DNS/Text.pm b/lib/Net/DNS/Text.pm new file mode 100644 index 0000000..d88e79e --- /dev/null +++ b/lib/Net/DNS/Text.pm @@ -0,0 +1,324 @@ +package Net::DNS::Text; + +# +# $Id: Text.pm 1601 2017-10-10 14:17:01Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1601 $)[1]; + + +=head1 NAME + +Net::DNS::Text - DNS text representation + +=head1 SYNOPSIS + + use Net::DNS::Text; + + $object = new Net::DNS::Text('example'); + $string = $object->string; + + $object = decode Net::DNS::Text( \$data, $offset ); + ( $object, $next ) = decode Net::DNS::Text( \$data, $offset ); + + $data = $object->encode; + $text = $object->value; + +=head1 DESCRIPTION + +The C module implements a class of text objects +with associated class and instance methods. + +Each text object instance has a fixed identity throughout its +lifetime. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + + +use constant ASCII => ref eval { + require Encode; + Encode::find_encoding('ascii'); +}; + +use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see UTR#16 3.6] + Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); +}; + + +=head1 METHODS + +=head2 new + + $object = new Net::DNS::Text('example'); + +Creates a text object which encapsulates a single character +string component of a resource record. + +Arbitrary single-byte characters can be represented by \ followed +by exactly three decimal digits. Such characters are devoid of +any special meaning. + +A character preceded by \ represents itself, without any special +interpretation. + +=cut + +my ( %escape, %unescape ); ## precalculated ASCII escape tables + +sub new { + my $self = bless [], shift; + croak 'argument undefined' unless defined $_[0]; + + local $_ = &_encode_utf8; + + s/^\042(.*)\042$/$1/s; # strip paired quotes + + s/\134\134/\134\060\071\062/g; # disguise escaped escape + s/\134([\060-\071]{3})/$unescape{$1}/eg; # numeric escape + s/\134(.)/$1/g; # character escape + + while ( length $_ > 255 ) { + my $chunk = substr( $_, 0, 255 ); # carve into chunks + substr( $chunk, -length($1) ) = '' if $chunk =~ /.([\300-\377][\200-\277]*)$/; + push @$self, $chunk; + substr( $_, 0, length $chunk ) = ''; + } + push @$self, $_; + + return $self; +} + + +=head2 decode + + $object = decode Net::DNS::Text( \$buffer, $offset ); + + ( $object, $next ) = decode Net::DNS::Text( \$buffer, $offset ); + +Creates a text object which represents the decoded data at the +indicated offset within the data buffer. + +The argument list consists of a reference to a scalar containing +the wire-format data and offset of the text data. + +The returned offset value indicates the start of the next item in +the data buffer. + +=cut + +sub decode { + my $class = shift; + my $buffer = shift; # reference to data buffer + my $offset = shift || 0; # offset within buffer + my $size = shift; # specify size of unbounded text + + unless ( defined $size ) { + $size = unpack "\@$offset C", $$buffer; + $offset++; + } + + my $next = $offset + $size; + croak 'corrupt wire-format data' if $next > length $$buffer; + + my $self = bless [unpack( "\@$offset a$size", $$buffer )], $class; + + return wantarray ? ( $self, $next ) : $self; +} + + +=head2 encode + + $data = $object->encode; + +Returns the wire-format encoded representation of the text object +suitable for inclusion in a DNS packet buffer. + +=cut + +sub encode { + my $self = shift; + join '', map pack( 'C a*', length $_, $_ ), @$self; +} + + +=head2 raw + + $data = $object->raw; + +Returns the wire-format encoded representation of the text object +without the explicit length field. + +=cut + +sub raw { + my $self = shift; + join '', map pack( 'a*', $_ ), @$self; +} + + +=head2 value + + $value = $text->value; + +Character string representation of the text object. + +=cut + +sub value { + return unless defined wantarray; + my $self = shift; + _decode_utf8( join '', @$self ); +} + + +=head2 string + + $string = $text->string; + +Conditionally quoted zone file representation of the text object. + +=cut + +sub string { + my $self = shift; + + my @s = map split( '', $_ ), @$self; # escape non-printable + my $string = _decode_utf8( join '', map $escape{$_}, @s ); + + return $string unless $string =~ /^$|[ \t\n\r\f]/; # unquoted contiguous + + $string =~ s/\\([$();@])/$1/g; # nothing special within quotes + join '', '"', $string, '"'; # quoted string +} + + +######################################## + +# perlcc: address of encoding objects must be determined at runtime +my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law: +my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't. + + +sub _decode_utf8 { ## UTF-8 to perl internal encoding + local $_ = shift; + + # partial transliteration for non-ASCII character encodings + tr + [\040-\176\000-\377] + [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII; + + my $z = length($_) - length($_); # pre-5.18 taint workaround + ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->decode($_), $z ) : $_; +} + + +sub _encode_utf8 { ## perl internal encoding to UTF-8 + local $_ = shift; + + # partial transliteration for non-ASCII character encodings + tr + [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~] + [\040-\176] unless ASCII; + + my $z = length($_) - length($_); # pre-5.18 taint workaround + ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; +} + + +%escape = eval { ## precalculated ASCII/UTF-8 escape table + my %table; + my @C0 = ( 0 .. 31 ); # control characters + my @NA = UTF8 ? ( 192, 193, 216 .. 223, 245 .. 255 ) : ( 128 .. 255 ); + + foreach ( 0 .. 255 ) { # transparent + $table{pack( 'C', $_ )} = pack 'C', $_; + } + + foreach ( 34, 36, 40, 41, 59, 64, 92 ) { # escape character + $table{pack( 'C', $_ )} = pack 'C2', 92, $_; + } + + foreach my $n ( @C0, 127, @NA ) { # \ddd + my $codepoint = sprintf( '%03u', $n ); + + # partial transliteration for non-ASCII character encodings + $codepoint =~ tr [0-9] [\060-\071]; + + $table{pack( 'C', $n )} = pack 'C a3', 92, $codepoint; + } + + return %table; +}; + + +%unescape = eval { ## precalculated numeric escape table + my %table; + + foreach my $n ( 0 .. 255 ) { + my $key = sprintf( '%03u', $n ); + + # partial transliteration for non-ASCII character encodings + $key =~ tr [0-9] [\060-\071]; + + $table{$key} = pack 'C', $n; + $table{$key} = pack 'C2', 92, $n if $n == 92; # escaped escape + } + + return %table; +}; + + +1; +__END__ + + +######################################## + +=head1 BUGS + +Coding strategy is intended to avoid creating unnecessary argument +lists and stack frames. This improves efficiency at the expense of +code readability. + +Platform specific character coding features are conditionally +compiled into the code. + + +=head1 COPYRIGHT + +Copyright (c)2009-2011 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, RFC1035, RFC3629, +Unicode Technical Report #16 + +=cut + diff --git a/lib/Net/DNS/Update.pm b/lib/Net/DNS/Update.pm new file mode 100644 index 0000000..dfc10d9 --- /dev/null +++ b/lib/Net/DNS/Update.pm @@ -0,0 +1,286 @@ +package Net::DNS::Update; + +# +# $Id: Update.pm 1571 2017-06-03 20:14:15Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1571 $)[1]; + + +=head1 NAME + +Net::DNS::Update - DNS dynamic update packet + +=head1 SYNOPSIS + + use Net::DNS; + + $update = new Net::DNS::Update( 'example.com', 'IN' ); + + $update->push( prereq => nxrrset('foo.example.com. A') ); + $update->push( update => rr_add('foo.example.com. 86400 A 192.168.1.2') ); + +=head1 DESCRIPTION + +Net::DNS::Update is a subclass of Net::DNS::Packet, to be used for +making DNS dynamic updates. + +Programmers should refer to RFC2136 for dynamic update semantics. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use base qw(Net::DNS::Packet); + +use Net::DNS::Resolver; + + +=head1 METHODS + +=head2 new + + $update = new Net::DNS::Update; + $update = new Net::DNS::Update( 'example.com' ); + $update = new Net::DNS::Update( 'example.com', 'HS' ); + +Returns a Net::DNS::Update object suitable for performing a DNS +dynamic update. Specifically, it creates a packet with the header +opcode set to UPDATE and the zone record type to SOA (per RFC 2136, +Section 2.3). + +Programs must use the push() method to add RRs to the prerequisite, +update, and additional sections before performing the update. + +Arguments are the zone name and the class. The zone and class may +be undefined or omitted and default to the default domain from the +resolver configuration and IN respectively. + +=cut + +sub new { + shift; + my ( $zone, @class ) = @_; + + my ($domain) = grep defined && length, $zone, Net::DNS::Resolver->searchlist; + + eval { + local $SIG{__DIE__}; + + my $self = __PACKAGE__->SUPER::new( $domain, 'SOA', @class ); + + my $header = $self->header; + $header->opcode('UPDATE'); + $header->qr(0); + $header->rd(0); + + return $self; + } || croak $@; +} + + +=head2 push + + $ancount = $update->push( prereq => $rr ); + $nscount = $update->push( update => $rr ); + $arcount = $update->push( additional => $rr ); + + $nscount = $update->push( update => $rr1, $rr2, $rr3 ); + $nscount = $update->push( update => @rr ); + +Adds RRs to the specified section of the update packet. + +Returns the number of resource records in the specified section. + +Section names may be abbreviated to the first three characters. + +=cut + +sub push { + my $self = shift; + my $list = $self->_section(shift); + my @arg = grep ref($_), @_; + + my ($zone) = $self->zone; + my $zclass = $zone->zclass; + my @rr = grep $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ), @arg; + + CORE::push( @$list, @rr ); +} + + +=head2 unique_push + + $ancount = $update->unique_push( prereq => $rr ); + $nscount = $update->unique_push( update => $rr ); + $arcount = $update->unique_push( additional => $rr ); + + $nscount = $update->unique_push( update => $rr1, $rr2, $rr3 ); + $nscount = $update->unique_push( update => @rr ); + +Adds RRs to the specified section of the update packet provided +that the RRs are not already present in the same section. + +Returns the number of resource records in the specified section. + +Section names may be abbreviated to the first three characters. + +=cut + +sub unique_push { + my $self = shift; + my $list = $self->_section(shift); + my @arg = grep ref($_), @_; + + my ($zone) = $self->zone; + my $zclass = $zone->zclass; + my @rr = grep $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ), @arg; + + my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } @rr, @$list; + + scalar( @$list = values %unique ); +} + + +1; + +__END__ + + +=head1 EXAMPLES + +The first example below shows a complete program. +Subsequent examples show only the creation of the update packet. + +Although the examples are presented using the string form of RRs, +the corresponding ( name => value ) form may also be used. + +=head2 Add a new host + + #!/usr/bin/perl + + use Net::DNS; + + # Create the update packet. + my $update = new Net::DNS::Update('example.com'); + + # Prerequisite is that no A records exist for the name. + $update->push( pre => nxrrset('foo.example.com. A') ); + + # Add two A records for the name. + $update->push( update => rr_add('foo.example.com. 86400 A 192.168.1.2') ); + $update->push( update => rr_add('foo.example.com. 86400 A 172.16.3.4') ); + + # Send the update to the zone's primary master. + my $resolver = new Net::DNS::Resolver; + $resolver->nameservers('primary-master.example.com'); + + my $reply = $resolver->send($update); + + # Did it work? + if ($reply) { + if ( $reply->header->rcode eq 'NOERROR' ) { + print "Update succeeded\n"; + } else { + print 'Update failed: ', $reply->header->rcode, "\n"; + } + } else { + print 'Update failed: ', $resolver->errorstring, "\n"; + } + + +=head2 Add an MX record for a name that already exists + + my $update = new Net::DNS::Update('example.com'); + $update->push( prereq => yxdomain('example.com') ); + $update->push( update => rr_add('example.com MX 10 mailhost.example.com') ); + +=head2 Add a TXT record for a name that does not exist + + my $update = new Net::DNS::Update('example.com'); + $update->push( prereq => nxdomain('info.example.com') ); + $update->push( update => rr_add('info.example.com TXT "yabba dabba doo"') ); + +=head2 Delete all A records for a name + + my $update = new Net::DNS::Update('example.com'); + $update->push( prereq => yxrrset('foo.example.com A') ); + $update->push( update => rr_del('foo.example.com A') ); + +=head2 Delete all RRs for a name + + my $update = new Net::DNS::Update('example.com'); + $update->push( prereq => yxdomain('byebye.example.com') ); + $update->push( update => rr_del('byebye.example.com') ); + +=head2 Perform a DNS update signed using a BIND private key file + + my $update = new Net::DNS::Update('example.com'); + $update->push( update => rr_add('foo.example.com A 10.1.2.3') ); + $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.private" ); + my $reply = $resolver->send( $update ); + $reply->verify( $update ) || die $reply->verifyerr; + +=head2 Signing the DNS update using a BIND public key file + + $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.key" ); + +=head2 Signing the DNS update using a customised TSIG record + + $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.private", + fudge => 60 + ); + +=head2 Another way to sign a DNS update + + my $key_name = 'tsig-key'; + my $key = 'awwLOtRfpGE+rRKF2+DEiw=='; + + my $tsig = new Net::DNS::RR("$key_name TSIG $key"); + $tsig->fudge(60); + + my $update = new Net::DNS::Update('example.com'); + $update->push( update => rr_add('foo.example.com A 10.1.2.3') ); + $update->push( additional => $tsig ); + + +=head1 COPYRIGHT + +Copyright (c)1997-2000 Michael Fuhr. + +Portions Copyright (c)2002,2003 Chris Reinhardt. + +Portions Copyright (c)2015 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, L, +L, L, RFC 2136, RFC 2845 + +=cut + diff --git a/lib/Net/DNS/ZoneFile.pm b/lib/Net/DNS/ZoneFile.pm new file mode 100644 index 0000000..57f5bca --- /dev/null +++ b/lib/Net/DNS/ZoneFile.pm @@ -0,0 +1,595 @@ +package Net::DNS::ZoneFile; + +# +# $Id: ZoneFile.pm 1623 2018-01-26 14:23:54Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1623 $)[1]; + + +=head1 NAME + +Net::DNS::ZoneFile - DNS zone file + +=head1 SYNOPSIS + + use Net::DNS::ZoneFile; + + $zonefile = new Net::DNS::ZoneFile( 'named.example' ); + + while ( $rr = $zonefile->read ) { + $rr->print; + } + + @zone = $zonefile->read; + + +=head1 DESCRIPTION + +Each Net::DNS::ZoneFile object instance represents a zone file +together with any subordinate files introduced by the $INCLUDE +directive. Zone file syntax is defined by RFC1035. + +A program may have multiple zone file objects, each maintaining +its own independent parser state information. + +The parser supports both the $TTL directive defined by RFC2308 +and the BIND $GENERATE syntax extension. + +All RRs in a zone file must have the same class, which may be +specified for the first RR encountered and is then propagated +automatically to all subsequent records. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; +use IO::File; + +use constant PERLIO => defined eval 'require PerlIO'; + +require Net::DNS::Domain; +require Net::DNS::RR; + + +=head1 METHODS + + +=head2 new + + $zonefile = new Net::DNS::ZoneFile( 'filename', ['example.com'] ); + + $handle = new IO::File( 'filename', '<:encoding(ISO8859-7)' ); + $zonefile = new Net::DNS::ZoneFile( $handle, ['example.com'] ); + +The new() constructor returns a Net::DNS::ZoneFile object which +represents the zone file specified in the argument list. + +The specified file or file handle is open for reading and closed when +exhausted or all references to the ZoneFile object cease to exist. + +The optional second argument specifies $ORIGIN for the zone file. + +Character encoding is specified indirectly by creating a file handle +with the desired encoding layer, which is then passed as an argument +to new(). The specified encoding is propagated to files introduced +by $include directives. + +=cut + +sub new { + my $self = bless {}, shift; + my $file = shift; + $self->_origin(shift); + + if ( ref($file) ) { + $self->{filename} = $self->{handle} = $file; + $self->{fileopen} = {}; + return $self if ref($file) =~ /IO::File|FileHandle|GLOB|Text/; + croak 'argument not a file handle'; + } + + $self->{filename} = $file ||= ''; + $self->{handle} = new IO::File($file) or croak "$! $file"; + $self->{fileopen}{$file}++; + return $self; +} + + +=head2 read + + $rr = $zonefile->read; + @rr = $zonefile->read; + +When invoked in scalar context, read() returns a Net::DNS::RR object +representing the next resource record encountered in the zone file, +or undefined if end of data has been reached. + +When invoked in list context, read() returns the list of Net::DNS::RR +objects in the order that they appear in the zone file. + +Comments and blank lines are silently disregarded. + +$INCLUDE, $ORIGIN, $TTL and $GENERATE directives are processed +transparently. + +=cut + +sub read { + my ($self) = @_; + + return &_read unless ref $self; # compatibility interface + + local $SIG{__DIE__}; + + if (wantarray) { + my @zone; # return entire zone + eval { + my $rr; + push( @zone, $rr ) while $rr = $self->_getRR; + }; + croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@; + return @zone; + } + + my $rr = eval { $self->_getRR }; # return single RR + croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@; + return $rr; +} + + +=head2 name + + $filename = $zonefile->name; + +Returns the name of the current zone file. +Embedded $INCLUDE directives will cause this to differ from the +filename argument supplied when the object was created. + +=cut + +sub name { + return shift->{filename}; +} + + +=head2 line + + $line = $zonefile->line; + +Returns the number of the last line read from the current zone file. + +=cut + +sub line { + my $self = shift; + return $self->{eom} if defined $self->{eom}; + return $self->{handle}->input_line_number; +} + + +=head2 origin + + $origin = $zonefile->origin; + +Returns the fully qualified name of the current origin within the +zone file. + +=cut + +sub origin { + my $context = shift->{context}; + return &$context( sub { new Net::DNS::Domain('@') } )->string; +} + + +=head2 ttl + + $ttl = $zonefile->ttl; + +Returns the default TTL as specified by the $TTL directive. + +=cut + +sub ttl { + return shift->{TTL}; +} + + +=head1 COMPATIBILITY WITH Net::DNS::ZoneFile 1.04 + +Applications which depended on the defunct Net::DNS::ZoneFile 1.04 +CPAN distribution will continue to operate with minimal change using +the compatibility interface described below. + + use Net::DNS::ZoneFile; + + $listref = Net::DNS::ZoneFile->read( $filename ); + $listref = Net::DNS::ZoneFile->read( $filename, $include_dir ); + + $listref = Net::DNS::ZoneFile->readfh( $handle, $include_dir ); + + $listref = Net::DNS::ZoneFile->parse( $string ); + $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); + $listref = Net::DNS::ZoneFile->parse( \$string, $include_dir ); + + $_->print for @$listref; + +The optional second argument specifies the default path for filenames. +The current working directory is used by default. + +Although not available in the original implementation, the RR list can +be obtained directly by calling any of these methods in list context. + + @rr = Net::DNS::ZoneFile->read( $filename, $include_dir ); + + +=head2 read + + $listref = Net::DNS::ZoneFile->read( $filename, $include_dir ); + @rr = Net::DNS::ZoneFile->read( $filename, $include_dir ); + +read() parses the specified zone file and returns a reference to the +list of Net::DNS::RR objects representing the RRs in the file. +The return value is undefined if the zone data can not be parsed. + +When called in list context, the partial result is returned if an +error is encountered by the parser. + +=cut + +our $include_dir; ## dynamically scoped + +sub _filename { ## rebase unqualified filename + my $name = shift; + return $name if ref($name); ## file handle + return $name unless $include_dir; + require File::Spec; + return $name if File::Spec->file_name_is_absolute($name); + return $name if -f $name; + return File::Spec->catfile( $include_dir, $name ); +} + + +sub _read { + my ($arg1) = @_; + shift if !ref($arg1) && $arg1 eq __PACKAGE__; + my $filename = shift; + local $include_dir = shift; + + my $zonefile = new Net::DNS::ZoneFile( _filename($filename) ); + my @zone; + eval { + local $SIG{__DIE__}; + my $rr; + push( @zone, $rr ) while $rr = $zonefile->_getRR; + }; + return wantarray ? @zone : \@zone unless $@; + carp $@; + return wantarray ? @zone : undef; +} + + +{ + + package Net::DNS::ZoneFile::Text; + + use overload ( '<>' => 'readline' ); + + sub new { + my $self = bless {}, shift; + my $data = shift; + $self->{data} = [split /\n/, ref($data) ? $$data : $data]; + return $self; + } + + sub readline { + my $self = shift; + $self->{line}++; + return shift( @{$self->{data}} ); + } + + sub close { + shift->{data} = []; + return 1; + } + + sub input_line_number { + return shift->{line}; + } + +} + + +=head2 readfh + + $listref = Net::DNS::ZoneFile->readfh( $handle, $include_dir ); + +readfh() parses data from the specified file handle and returns a +reference to the list of Net::DNS::RR objects representing the RRs +in the file. + +=cut + +sub readfh { + return &_read; +} + + +=head2 parse + + $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); + $listref = Net::DNS::ZoneFile->parse( \$string, $include_dir ); + +parse() interprets the zone file text in the argument string and +returns a reference to the list of Net::DNS::RR objects representing +the RRs. + +=cut + +sub parse { + my ($text) = reverse @_; + return &readfh( new Net::DNS::ZoneFile::Text($text), @_ ); +} + + +######################################## + + +{ + + package Net::DNS::ZoneFile::Generator; + + use overload ( '<>' => 'readline' ); + + sub new { + my $self = bless {}, shift; + my ( $range, $template, $line ) = @_; + + $template =~ s/\\\$/\\036/g; # disguise escaped dollar + $template =~ s/\$\$/\\036/g; # disguise escaped dollar + + my ( $bound, $step ) = split m#[/]#, $range; # initial iterator state + my ( $first, $last ) = split m#[-]#, $bound; + $first ||= 0; + $last ||= $first; + $step = abs( $step || 1 ); # coerce step to match range + $step = -$step if $last < $first; + $self->{count} = int( ( $last - $first ) / $step ) + 1; + + @{$self}{qw(instant step template line)} = ( $first, $step, $template, $line ); + return $self; + } + + sub readline { + my $self = shift; + return undef unless $self->{count}-- > 0; # EOF + + my $instant = $self->{instant}; # update iterator state + $self->{instant} += $self->{step}; + + local $_ = $self->{template}; # copy template + while (/\$\{(.*)\}/) { # interpolate ${...} + my $s = _format( $instant, split /\,/, $1 ); + s/\$\{$1\}/$s/eg; + } + + s/\$/$instant/eg; # interpolate $ + return $_; + } + + sub close { + shift->{count} = 0; # suppress iterator + return 1; + } + + sub input_line_number { + return shift->{line}; # fixed: identifies $GENERATE + } + + + sub _format { ## convert $GENERATE iteration number to specified format + my $number = shift; # per ISC BIND 9.7 + my $offset = shift || 0; + my $length = shift || 0; + my $format = shift || 'd'; + + my $value = $number + $offset; + my $digit = $length || 1; + return substr sprintf( "%01.$digit$format", $value ), -$length if $format =~ /[doxX]/; + + my $nibble = join( '.', split //, sprintf ".%32.32lx", $value ); + return reverse lc( substr $nibble, -$length ) if $format =~ /[n]/; + return reverse uc( substr $nibble, -$length ) if $format =~ /[N]/; + die "unknown $format format"; + } + +} + + +sub _generate { ## expand $GENERATE into input stream + my ( $self, $range, $template ) = @_; + + my $handle = new Net::DNS::ZoneFile::Generator( $range, $template, $self->line ); + + delete $self->{latest}; # forget previous owner + $self->{parent} = bless {%$self}, ref($self); # save state, create link + $self->{handle} = $handle; +} + + +my $LEX_REGEX = q/("[^"]*"|"[^"]*$)|;[^\n]*|([()])|(^\s)|[ \t\n\r\f]/; + +sub _getline { ## get line from current source + my $self = shift; + + my $fh = $self->{handle}; + while (<$fh>) { + next if /^\s*;/; # discard comment line + next unless /\S/; # discard blank line + + if (/[(]/) { # concatenate multi-line RR + s/\\\\/\\092/g; # disguise escaped escape + s/\\"/\\034/g; # disguise escaped quote + s/\\\(/\\040/g; # disguise escaped bracket + s/\\\)/\\041/g; # disguise escaped bracket + s/\\;/\\059/g; # disguise escaped semicolon + my @token = grep defined && length, split /$LEX_REGEX/o; + if ( grep( $_ eq '(', @token ) && !grep( $_ eq ')', @token ) ) { + while (<$fh>) { + $_ = pop(@token) . $_; # splice fragmented string + s/\\\\/\\092/g; # disguise escaped escape + s/\\"/\\034/g; # disguise escaped quote + s/\\\(/\\040/g; # disguise escaped bracket + s/\\\)/\\041/g; # disguise escaped bracket + s/\\;/\\059/g; # disguise escaped semicolon + my @part = grep defined && length, split /$LEX_REGEX/o; + push @token, @part; + last if grep $_ eq ')', @part; + } + $_ = join ' ', @token; # reconstitute RR string + } + } + + return $_ unless /^\$/; # RR string + + if (/^\$INCLUDE/) { # directive + my ( $keyword, @argument ) = split; + die '$INCLUDE incomplete' unless @argument; + $fh = $self->_include(@argument); + + } elsif (/^\$GENERATE/) { # directive + my ( $keyword, $range, @template ) = split; + die '$GENERATE incomplete' unless $range; + $fh = $self->_generate( $range, "@template\n" ); + + } elsif (/^\$ORIGIN/) { # directive + my ( $keyword, $origin, @etc ) = split; + die '$ORIGIN incomplete' unless $origin; + my $context = $self->{context}; + &$context( sub { $self->_origin($origin); } ); + + } elsif (/^\$TTL/) { # directive + my ( $keyword, $ttl, @etc ) = split; + die '$TTL incomplete' unless defined $ttl; + $self->{TTL} = Net::DNS::RR::ttl( {}, $ttl ); + + } else { # unrecognised + my ($keyword) = split; + die "unknown '$keyword' directive"; + } + } + + $self->{eom} = $self->line; # end of file + $fh->close(); + my $link = $self->{parent} || return undef; # end of zone + %$self = %$link; # end $INCLUDE + $self->_getline; # resume input +} + + +sub _getRR { ## get RR from current source + my $self = shift; + + local $_; + $self->_getline || return undef; # line already in $_ + + my $noname = s/^\s/\@\t/; # placeholder for empty RR name + + # construct RR object with context specific dynamically scoped $ORIGIN + my $context = $self->{context}; + my $rr = &$context( sub { Net::DNS::RR->_new_string($_) } ); + + my $latest = $self->{latest}; # overwrite placeholder + $rr->{owner} = $latest->{owner} if $noname && $latest; + + $self->{class} = $rr->class unless $self->{class}; # propagate RR class + $rr->class( $self->{class} ); + + $self->{TTL} ||= $rr->minimum if $rr->type eq 'SOA'; # default TTL + $rr->{'ttl'} = $self->{TTL} unless defined $rr->{'ttl'}; + + return $self->{latest} = $rr; +} + + +sub _include { ## open $INCLUDE file + my $self = shift; + my $file = _filename(shift); + my $root = shift; + + my $opened = {%{$self->{fileopen}}}; + croak qq(recursive \$INCLUDE $file) if $opened->{$file}++; + + my @discipline = PERLIO ? ( join ':', '<', PerlIO::get_layers $self->{handle} ) : (); + my $handle = new IO::File( $file, @discipline ) or croak "$! $file"; + + delete $self->{latest}; # forget previous owner + $self->{parent} = bless {%$self}, ref($self); # save state, create link + $self->{context} = origin Net::DNS::Domain($root) if $root; + $self->{filename} = $file; + $self->{fileopen} = $opened; + return $self->{handle} = $handle; +} + + +sub _origin { ## change $ORIGIN (scope: current file) + my $self = shift; + $self->{context} = origin Net::DNS::Domain(shift); + delete $self->{latest}; # forget previous owner +} + + +1; +__END__ + + +=head1 ACKNOWLEDGEMENTS + +This package is designed as an improved and compatible replacement +for Net::DNS::ZoneFile 1.04 which was created by Luis Munoz in 2002 +as a separate CPAN module. + +The present implementation is the result of an agreement to merge our +two different approaches into one package integrated into Net::DNS. +The contribution of Luis Munoz is gratefully acknowledged. + +Thanks are also due to Willem Toorop for his constructive criticism +of the initial version and invaluable assistance during testing. + + +=head1 COPYRIGHT + +Copyright (c)2011-2012 Dick Franks. + +All rights reserved. + + +=head1 LICENSE + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, provided +that the above copyright notice appear in all copies and that both that +copyright notice and this permission notice appear in supporting +documentation, and that the name of the author not be used in advertising +or publicity pertaining to distribution of the software without specific +prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + + +=head1 SEE ALSO + +L, L, L, RFC1035 Section 5.1, +RFC2308, BIND 9 Administrator Reference Manual + +=cut + diff --git a/t/00-install.t b/t/00-install.t new file mode 100644 index 0000000..229eba9 --- /dev/null +++ b/t/00-install.t @@ -0,0 +1,94 @@ +# $Id: 00-install.t 1605 2017-11-27 11:37:40Z willem $ -*-perl-*- + +use strict; +use Test::More; +use File::Spec; +use File::Find; +use ExtUtils::MakeMaker; + + +eval { + my %macro; # extract Makefile macros + open MAKEFILE, 'Makefile' or die $!; + while () { + $macro{$1} = $2 if /^([A-Z_]+)\s+=\s+(.*)$/; + } + close MAKEFILE; + + my %install_type = qw(perl INSTALLPRIVLIB site INSTALLSITELIB vendor INSTALLVENDORLIB); + my $install_site = join '', '$(DESTDIR)$(', $install_type{$macro{INSTALLDIRS}}, ')'; + for ($install_site) { + s/\$\(([A-Z_]+)\)/$macro{$1}/eg while /\$\(/; # expand Makefile macros + s|([/])[/]+|$1|g; # remove gratuitous //s + } + + local @INC = grep !m/\bblib\W(arch|lib)$/i, @INC; + eval 'require Net::DNS'; + my @version = grep $_, ( 'version', $Net::DNS::VERSION ); + + my $nameregex = '\W+Net\WDNS.pm$'; + my @installed = grep $_ && m/$nameregex/io, values %INC; + my %noinstall; + + foreach (@installed) { + my $path = $1 if m/^(.+)$nameregex/i; + my %seen; + foreach (@INC) { + $seen{$_}++; # find $path in @INC + last if $_ eq $path; + } + foreach ( grep !$seen{$_}, @INC ) { + $noinstall{$_}++; # mark hidden libraries + } + } + + warn <<"AMEN" if $noinstall{$install_site}; + +## +## The install location for this version of Net::DNS differs +## from the existing @version in your perl library. +## @installed +## +## The installation will be rendered ineffective because the +## library search finds the existing version before reaching +## $install_site +## +## Makefile has been generated to support build and test only. +## +AMEN + +}; + + +my @files; +my $blib = File::Spec->catfile(qw(blib lib)); + +find( sub { push( @files, $File::Find::name ) if /\.pm$/ && !/Template/ }, $blib ); + +my %manifest; +open MANIFEST, 'MANIFEST' or plan skip_all => "MANIFEST: $!"; +while () { + chomp; + my ( $volume, $directory, $name ) = File::Spec->splitpath($_); + $manifest{lc $name}++ if $name; +} +close MANIFEST; + +plan skip_all => 'No versions from git checkouts' if -e '.git'; + +plan skip_all => 'Not sure how to parse versions.' unless eval { MM->can('parse_version') }; + +plan tests => scalar @files; + +foreach my $file ( sort @files ) { # reconcile files with MANIFEST + my $version = MM->parse_version($file); + ok( $version =~ /[\d.]{3}/, "file version: $version\t$file" ); + my ( $volume, $directory, $name ) = File::Spec->splitpath($file); + diag("File not in MANIFEST: $file") unless $manifest{lc $name}; +} + + +exit; + +__END__ + diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..4b10308 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,93 @@ +# $Id: 00-load.t 1611 2018-01-02 09:41:24Z willem $ -*-perl-*- + +use strict; +use Test::More; + + +my @module = qw( + Net::DNS + Net::DNS::SEC + Data::Dumper + Digest::BubbleBabble + Digest::GOST + Digest::HMAC + Digest::MD5 + Digest::SHA + Encode + File::Spec + IO::File + IO::Select + IO::Socket + IO::Socket::INET + IO::Socket::INET6 + IO::Socket::IP + MIME::Base64 + Net::LibIDN + Net::LibIDN2 + PerlIO + Scalar::Util + Socket + Time::Local + Win32::API + Win32::IPHelper + Win32::TieRegistry + ); + +my @diag; +foreach my $module (@module) { + eval "require $module"; + my $version = eval { $module->VERSION } || next; + push @diag, sprintf "%-25s %s", $module, $version; +} +diag join "\n\t", "\nThese tests were run using:", @diag; + + +plan tests => 20 + scalar(@Net::DNS::EXPORT); + + +use_ok('Net::DNS'); + +is( Net::DNS->version, $Net::DNS::VERSION, 'Net::DNS->version' ); + + +# +# Check on-demand loading using this (incomplete) list of RR packages +my @rrs = qw( A AAAA CNAME MX NS NULL PTR SOA TXT ); + +sub is_rr_loaded { + my $rr = shift; + return $INC{"Net/DNS/RR/$rr.pm"} ? 1 : 0; +} + +# +# Make sure that we start with none of the RR packages loaded +foreach my $rr (@rrs) { + ok( !is_rr_loaded($rr), "not yet loaded Net::DNS::RR::$rr" ); +} + +# +# Check that each RR package is loaded on demand +local $SIG{__WARN__} = sub { }; # suppress warnings + +foreach my $rr (@rrs) { + my $object = eval { new Net::DNS::RR( name => '.', type => $rr ); }; + diag($@) if $@; # report exceptions + + ok( is_rr_loaded($rr), "loaded package Net::DNS::RR::$rr" ); +} + + +# +# Check that Net::DNS symbol table was imported correctly +{ + no strict 'refs'; + foreach my $sym (@Net::DNS::EXPORT) { + ok( defined &{$sym}, "$sym is imported" ); + } +} + + +exit; + +__END__ + diff --git a/t/00-pod.t b/t/00-pod.t new file mode 100644 index 0000000..12dbfb8 --- /dev/null +++ b/t/00-pod.t @@ -0,0 +1,22 @@ +# $Id: 00-pod.t 1381 2015-08-25 07:36:09Z willem $ +# + +use strict; +use Test::More; + +my %prerequisite = qw( + Test::Pod 1.45 + ); + +while ( my ( $package, $rev ) = each %prerequisite ) { + eval "use $package $rev"; + next unless $@; + plan skip_all => "$package $rev required for testing POD"; + exit; +} + + +my @poddirs = qw( blib demo ); +my @allpods = all_pod_files(@poddirs); +all_pod_files_ok(@allpods); + diff --git a/t/01-resolver-env.t b/t/01-resolver-env.t new file mode 100644 index 0000000..ac76081 --- /dev/null +++ b/t/01-resolver-env.t @@ -0,0 +1,34 @@ +# $Id: 01-resolver-env.t 1412 2015-10-12 08:19:51Z willem $ -*-perl-*- + +use strict; + +use Test::More tests => 10; + +local $ENV{'RES_NAMESERVERS'} = '10.0.3.128 10.0.4.128'; +local $ENV{'RES_SEARCHLIST'} = 'net-dns.org lib.net-dns.org'; +local $ENV{'LOCALDOMAIN'} = 'net-dns.org'; +local $ENV{'RES_OPTIONS'} = 'retrans:3 retry:2 debug bogus'; + +use Net::DNS; + +my $res = Net::DNS::Resolver->new; +ok( $res->isa('Net::DNS::Resolver'), 'new() created object' ); + +is( $res->domain, 'net-dns.org', 'domain works' ); + +my @search = $res->searchlist; +is( $search[0], 'net-dns.org', 'searchlist correct' ); +is( $search[1], 'lib.net-dns.org', 'searchlist correct' ); + +my @servers = $res->nameservers; +ok( scalar(@servers), "nameservers() works" ); +is( $servers[0], '10.0.3.128', 'nameservers list correct' ); +is( $servers[1], '10.0.4.128', 'nameservers list correct' ); + +is( $res->retrans, 3, 'retrans works' ); +is( $res->retry, 2, 'retry works' ); +is( $res->debug, 1, 'debug() works' ); + + +exit; + diff --git a/t/01-resolver-file.t b/t/01-resolver-file.t new file mode 100644 index 0000000..ac409bf --- /dev/null +++ b/t/01-resolver-file.t @@ -0,0 +1,67 @@ +# $Id: 01-resolver-file.t 1573 2017-06-12 11:03:59Z willem $ + +use strict; +use File::Spec; +use Test::More tests => 16; + +use Net::DNS; + + +local $ENV{'RES_NAMESERVERS'}; +local $ENV{'RES_SEARCHLIST'}; +local $ENV{'LOCALDOMAIN'}; +local $ENV{'RES_OPTIONS'}; + +my $class = 'Net::DNS::Resolver'; + +my $config = File::Spec->catfile(qw(t custom.txt)); # .txt to run on Windows + +{ + $class->domain('domain.default'); + my $resolver = $class->new( config_file => $config ); + ok( $resolver->isa($class), "new( config_file => '$config' )" ); + + my @servers = $resolver->nameservers; + ok( scalar(@servers), 'nameservers list populated' ); + is( $servers[0], '10.0.1.128', 'nameservers list correct' ); + is( $servers[1], '10.0.2.128', 'nameservers list correct' ); + + my @search = $resolver->searchlist; + ok( scalar(@search), 'searchlist populated' ); + is( $search[0], 'alt.net-dns.org', 'searchlist correct' ); + is( $search[1], 'ext.net-dns.org', 'searchlist correct' ); + + is( $resolver->domain, 'alt.net-dns.org', 'domain correct' ); + + is( $class->domain, $resolver->domain, 'initial config sets defaults' ); +} + + +{ + $class->domain('domain.default'); + my $resolver = $class->new( config_file => $config ); + ok( $resolver->isa($class), "new( config_file => $config )" ); + + my @servers = $resolver->nameservers; + ok( scalar(@servers), 'nameservers list populated' ); + + my $domain = 'alt.net-dns.org'; + my @search = $resolver->searchlist; + ok( scalar(@search), 'searchlist populated' ); + is( shift(@search), $domain, 'searchlist correct' ); + + is( $resolver->domain, $domain, 'domain correct' ); + + isnt( $class->domain, $resolver->domain, 'default config unchanged' ); +} + + +{ # file presumed not to exist + eval { new $class( config_file => 'nonexist.txt' ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "new( config_file => ?\t[$exception]" ); +} + + +exit; + diff --git a/t/01-resolver-flags.t b/t/01-resolver-flags.t new file mode 100644 index 0000000..61bad28 --- /dev/null +++ b/t/01-resolver-flags.t @@ -0,0 +1,38 @@ +# $Id: 01-resolver-flags.t 1444 2016-01-05 10:01:10Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 23; + +use Net::DNS; + + +my $res = Net::DNS::Resolver->new(); +ok( $res->isa('Net::DNS::Resolver'), 'new() created object' ); + + +ok( !$res->dnssec(), "default dnssec flag off" ); +my $udpsize = $res->udppacketsize(); + +$res->dnssec(1); +ok( $res->dnssec(), "dnssec flag toggles on" ); +my $size = $res->udppacketsize(); +isnt( $size, $udpsize, "dnssec(1) sets udppacketsize ($size)" ); + +$res->dnssec(0); +ok( !$res->dnssec(), "dnssec flag toggles off" ); + + +my @flag = qw(adflag cdflag force_v4 force_v6 prefer_v4 prefer_v6); +foreach my $flag (@flag) { + my $default = $res->$flag(); + my $changed = $default ? 0 : 1; + ok( defined $default, "default $flag $default" ); + $res->$flag($changed); + is( $res->$flag(), $changed, "toggle $flag $changed" ); + $res->$flag($default); + is( $res->$flag(), $default, "toggle $flag $default" ); +} + + +exit; + diff --git a/t/01-resolver-opt.t b/t/01-resolver-opt.t new file mode 100644 index 0000000..eba04a1 --- /dev/null +++ b/t/01-resolver-opt.t @@ -0,0 +1,67 @@ +# $Id: 01-resolver-opt.t 1573 2017-06-12 11:03:59Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 30; + +use Net::DNS; + + +# +# Check that we can set things in new() +# +my %test_config = ( + domain => 'net-dns.org', + searchlist => ['net-dns.org', 't.net-dns.org'], + nameservers => ['10.0.0.1', '10.0.0.2'], + debug => 1, + defnames => 0, + dnsrch => 0, + recurse => 0, + retrans => 6, + retry => 5, + persistent_tcp => 1, + persistent_udp => 1, + tcp_timeout => 60, + udp_timeout => 60, + usevc => 1, + port => 54, + srcport => 53, + adflag => 1, + cdflag => 0, + dnssec => 0, + ); + +foreach my $key ( sort keys %test_config ) { + my $resolver = Net::DNS::Resolver->new( $key => $test_config{$key} ); + my @returned = $resolver->$key; + my %returned = ( $key => scalar(@returned) > 1 ? [@returned] : shift(@returned) ); + is_deeply( $returned{$key}, $test_config{$key}, "$key is correct" ); +} + + +# +# Check that new() is vetting things properly. +# +foreach my $test (qw(nameservers searchlist)) { + foreach my $input ( {}, \1 ) { + my $res = eval { Net::DNS::Resolver->new( $test => $input ); }; + ok( $@, 'Invalid input caught' ); + ok( !$res, 'No resolver returned' ); + } +} + + +my %bad_input = ( + errorstring => 'set', + answerfrom => 'set', + answersize => 'set', + ); + +while ( my ( $key, $value ) = each %bad_input ) { + my $res = Net::DNS::Resolver->new( $key => $value ); + isnt( $res->{$key}, 'set', "$key is not set" ); +} + + +exit; + diff --git a/t/01-resolver.t b/t/01-resolver.t new file mode 100644 index 0000000..547021e --- /dev/null +++ b/t/01-resolver.t @@ -0,0 +1,133 @@ +# $Id: 01-resolver.t 1593 2017-09-04 14:23:26Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 27; + + +BEGIN { + eval { + open( TOUCH, '>.resolv.conf' ) || die $!; # owned by effective UID + close(TOUCH); + }; +} + + +use Net::DNS; + + +my $resolver = Net::DNS::Resolver->new(); +my $class = ref($resolver); + +for (@Net::DNS::Resolver::ISA) { + diag $_ unless /[:]UNIX$/; +} + +ok( $resolver->isa('Net::DNS::Resolver'), 'new() created object' ); + +ok( $resolver->print, '$resolver->print' ); + +ok( $class->new( debug => 1 )->_diag(@Net::DNS::Resolver::ISA), 'debug message' ); + + +{ ## check class methods + $class->nameservers(qw(127.0.0.1 ::1)); + ok( scalar( $class->nameservers ), '$class->nameservers' ); + $class->searchlist(qw(sub1.example.com sub2.example.com)); + ok( scalar( $class->searchlist ), '$class->searchlist' ); + $class->domain('example.com'); + ok( $class->domain, '$class->domain' ); + ok( $class->srcport(1234), '$class->srcport' ); + ok( $class->string(), '$class->string' ); +} + + +{ ## check instance methods + ok( $resolver->domain('example.com'), '$resolver->domain' ); + ok( $resolver->searchlist('example.com'), '$resolver->searchlist' ); + $resolver->nameservers(qw(127.0.0.1 ::1)); + ok( scalar( $resolver->nameservers() ), '$resolver->nameservers' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->nameservers(qw(127.0.0.1 ::1 ::ffff:127.0.0.1 fe80::1234%1)); + $resolver->force_v4(0); # set by default if no IPv6 + $resolver->prefer_v6(1); + my ($address) = $resolver->nameserver(); + is( $address, '::1', '$resolver->prefer_v6(1)' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->nameservers(qw(127.0.0.1 ::1)); + $resolver->force_v6(0); + $resolver->prefer_v4(1); + my ($address) = $resolver->nameserver(); + is( $address, '127.0.0.1', '$resolver->prefer_v4(1)' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->force_v6(1); + ok( !$resolver->nameservers(qw(127.0.0.1)), '$resolver->force_v6(1)' ); + like( $resolver->errorstring, '/IPv4.+disabled/', 'errorstring: IPv4 disabled' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->force_v4(1); + ok( !$resolver->nameservers(qw(::)), '$resolver->force_v4(1)' ); + like( $resolver->errorstring, '/IPv6.+disabled/', 'errorstring: IPv6 disabled' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + foreach my $ip (qw(127.0.0.1 ::1)) { + is( $resolver->srcaddr($ip), $ip, "\$resolver->srcaddr($ip)" ); + } +} + + +{ ## exercise possibly unused socket code + ## check for smoke and flames only + my $resolver = Net::DNS::Resolver->new( tcp_timeout => 1 ); + foreach my $ip (qw(127.0.0.1 ::1)) { + eval { $resolver->_create_udp_socket($ip) }; + is( $@, '', "\$resolver->_create_udp_socket($ip)" ); + eval { $resolver->_create_dst_sockaddr( $ip, 53 ) }; + is( $@, '', "\$resolver->_create_dst_sockaddr($ip,53)" ); + eval { $resolver->_create_tcp_socket($ip) }; + is( $@, '', "\$resolver->_create_tcp_socket($ip)" ); + } +} + + +{ ## check for exception on bogus AUTOLOAD method + eval { $resolver->bogus(); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown method:\t[$exception]" ); + + is( $resolver->DESTROY, undef, 'DESTROY() exists to defeat pre-5.18 AUTOLOAD' ); +} + + +eval { ## exercise warning for make_query_packet() + local *STDERR; + my $filename = '01-resolver.tmp'; + open( STDERR, ">$filename" ) || die "Could not open $filename for writing"; + $resolver->make_query_packet('example.com'); # carp + $resolver->make_query_packet('example.com'); # silent + close(STDERR); + unlink($filename); +}; + + +exit; + +__END__ + diff --git a/t/02-IDN.t b/t/02-IDN.t new file mode 100644 index 0000000..8825e8f --- /dev/null +++ b/t/02-IDN.t @@ -0,0 +1,86 @@ +# $Id: 02-IDN.t 1601 2017-10-10 14:17:01Z willem $ -*-perl-*- + +use strict; +use Test::More; + + ## vvv verbatim from Domain.pm +use constant ASCII => ref eval { + require Encode; + Encode::find_encoding('ascii'); +}; + +use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see UTR#16 3.6] + Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); +}; + +use constant LIBIDN => defined eval 'require Net::LibIDN'; +use constant LIBIDN2 => ref eval 'require Net::LibIDN2; Net::LibIDN2->can("idn2_to_ascii_8")'; + ## ^^^ verbatim from Domain.pm + + +use constant LIBIDNOK => LIBIDN && scalar eval { + my $cn = pack( 'U*', 20013, 22269 ); + Net::LibIDN::idn_to_ascii( $cn, 'utf-8' ) eq 'xn--fiqs8s'; +}; + +use constant LIBIDN2OK => LIBIDN2 && scalar eval { + my $cn = pack( 'U*', 20013, 22269 ); + Net::LibIDN2::idn2_to_ascii_8( $cn, 9 ) eq 'xn--fiqs8s'; +}; + + +my $codeword = unpack 'H*', '[|'; +my %codename = ( + '5b7c' => 'ASCII superset', + 'ba4f' => 'EBCDIC cp37', + 'ad4f' => 'EBCDIC cp1047', + 'bb4f' => 'EBCDIC posix-bc' + ); +my $encoding = $codename{lc $codeword} || "not recognised [$codeword]"; +diag "character encoding: $encoding" unless $encoding =~ /ASCII/; + + +plan skip_all => 'Encode package not installed' unless eval { require Encode; }; + +plan skip_all => 'Encode: ASCII encoding not available' unless ASCII; + +plan skip_all => 'Encode: UTF-8 encoding not available' unless UTF8; + +plan skip_all => 'No LibIDN or LibIDN2 installed' unless LIBIDN || LIBIDN2; + +plan skip_all => 'Net::LibIDN not working' if LIBIDN && !LIBIDNOK; + +plan skip_all => 'Net::LibIDN2 not working' if LIBIDN2 && !LIBIDN2OK; + +plan tests => 12; + + +use_ok('Net::DNS::Domain'); + + +my $a_label = 'xn--fiqs8s'; +my $u_label = eval { pack( 'U*', 20013, 22269 ); }; + +is( new Net::DNS::Domain($a_label)->name, $a_label, 'IDN A-label domain->name' ); +is( new Net::DNS::Domain($a_label)->fqdn, "$a_label.", 'IDN A-label domain->fqdn' ); +is( new Net::DNS::Domain($a_label)->string, "$a_label.", 'IDN A-label domain->string' ); +is( new Net::DNS::Domain($a_label)->xname, $u_label, 'IDN A-label domain->xname' ); + +is( new Net::DNS::Domain($u_label)->name, $a_label, 'IDN U-label domain->name' ); +is( new Net::DNS::Domain($u_label)->fqdn, "$a_label.", 'IDN U-label domain->fqdn' ); +is( new Net::DNS::Domain($u_label)->string, "$a_label.", 'IDN U-label domain->string' ); +is( new Net::DNS::Domain($u_label)->xname, $u_label, 'IDN U-label domain->xname' ); + + +is( new Net::DNS::Domain($u_label)->xname, $u_label, 'IDN cached domain->xname' ); + +is( new Net::DNS::Domain('xn--')->xname, 'xn--', 'IDN bogus domain->xname' ); + + +eval { new Net::DNS::Domain( pack 'U*', 65533, 92, 48, 65533 ); }; +my $exception = $1 if $@ =~ /^(.+)\n/; +ok( $exception ||= '', "invalid name\t[$exception]" ); + + +exit; + diff --git a/t/02-domain.t b/t/02-domain.t new file mode 100644 index 0000000..b3609bd --- /dev/null +++ b/t/02-domain.t @@ -0,0 +1,239 @@ +# $Id: 02-domain.t 1611 2018-01-02 09:41:24Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 53; + + +use_ok('Net::DNS::Domain'); + + +{ + my $name = 'example.com'; + my $domain = new Net::DNS::Domain($name); + ok( $domain->isa('Net::DNS::Domain'), 'object returned by new() constructor' ); + + my $same = new Net::DNS::Domain($name); + is( $same, $domain, "same name returns cached object" ); + + my %cache; + my ( $i, $j ); + for ( ; ; ) { + $j = ( $i++ >> 1 ) + 1; + my $fill = "name-$i"; + my $test = "name-$j"; + $cache{$fill} = new Net::DNS::Domain($fill); + last unless $cache{$test} == new Net::DNS::Domain($test); + } + my $size = $i - $j; + ok( $size, "name cache at least $size deep" ); +} + + +{ + my $domain = eval { new Net::DNS::Domain(); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "empty argument list\t[$exception]" ); +} + + +{ + my $domain = eval { new Net::DNS::Domain(undef); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "argument undefined\t[$exception]" ); +} + + +{ + my $domain = new Net::DNS::Domain('name'); + is( $domain->name, 'name', '$domain->name() without trailing dot' ); + is( $domain->fqdn, 'name.', '$domain->fqdn() with trailing dot' ); + is( $domain->string, 'name.', '$domain->string() with trailing dot' ); +} + + +{ + my $root = new Net::DNS::Domain('.'); + is( $root->name, '.', '$root->name() represented by single dot' ); + is( $root->fqdn, '.', '$root->fqdn() represented by single dot' ); + is( $root->xname, '.', '$root->xname() represented by single dot' ); + is( $root->string, '.', '$root->string() represented by single dot' ); +} + + +{ + my $domain = new Net::DNS::Domain('example.com'); + my $labels = @{[$domain->label]}; + is( $labels, 2, 'domain labels separated by dots' ); +} + + +use constant ESC => '\\'; + +{ + my $case = ESC . '.'; + my $domain = new Net::DNS::Domain("example${case}com"); + my $labels = @{[$domain->label]}; + is( $labels, 1, "$case devoid of special meaning" ); +} + + +{ + my $case = ESC . ESC; + my $domain = new Net::DNS::Domain("example${case}.com"); + my $labels = @{[$domain->label]}; + is( $labels, 2, "$case devoid of special meaning" ); +} + + +{ + my $case = ESC . ESC . ESC . '.'; + my $domain = new Net::DNS::Domain("example${case}com"); + my $labels = @{[$domain->label]}; + is( $labels, 1, "$case devoid of special meaning" ); +} + + +{ + my $case = '\092'; + my $domain = new Net::DNS::Domain("example${case}.com"); + my $labels = @{[$domain->label]}; + is( $labels, 2, "$case devoid of special meaning" ); +} + + +{ + my $name = 'simple-name'; + my $simple = new Net::DNS::Domain($name); + is( $simple->name, $name, "$name absolute by default" ); + + my $create = origin Net::DNS::Domain(undef); + my $domain = &$create( sub { new Net::DNS::Domain($name); } ); + is( $domain->name, $name, "$name absolute if origin undefined" ); +} + + +{ + my $name = 'simple-name'; + my $create = origin Net::DNS::Domain('.'); + my $domain = &$create( sub { new Net::DNS::Domain($name); } ); + is( $domain->name, $name, "$name absolute if origin '.'" ); + my @label = $domain->label; + is( scalar(@label), 1, "$name has single label" ); +} + + +{ + my $name = 'simple-name'; + my $suffix = 'example.com'; + my $create = origin Net::DNS::Domain($suffix); + my $domain = &$create( sub { new Net::DNS::Domain($name); } ); + my $expect = new Net::DNS::Domain("$name.$suffix"); + is( $domain->name, $expect->name, "origin appended to $name" ); + + my $root = new Net::DNS::Domain('@'); + is( $root->name, '.', 'bare @ represents root by default' ); + + my $origin = &$create( sub { new Net::DNS::Domain('@'); } ); + is( $origin->name, $suffix, 'bare @ represents defined origin' ); +} + + +{ + foreach my $char (qw($ ' " ; @)) { + my $name = $char . 'example.com.'; + my $domain = new Net::DNS::Domain($name); + is( $domain->string, ESC . $name, "escape leading $char in string" ); + } +} + + +{ + foreach my $part (qw(_rvp._tcp *)) { + my $name = "$part.example.com."; + my $domain = new Net::DNS::Domain($name); + is( $domain->string, $name, "permit leading $part" ); + } +} + + +{ + my $ldh = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-0123456789'; + my $domain = new Net::DNS::Domain($ldh); + is( $domain->name, $ldh, '63 octet LDH character label' ); +} + + +{ + my $name = 'LO-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-O-NG!'; + my $domain = eval { new Net::DNS::Domain("$name") }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "long domain label\t[$exception]" ); +} + + +{ + my $domain = eval { new Net::DNS::Domain('.example.com') }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "empty initial label\t[$exception]" ); +} + + +{ + my $domain = eval { new Net::DNS::Domain("example..com"); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "empty interior label\t[$exception]" ); +} + + +{ + my $name = 'example.com'; + my $domain = new Net::DNS::Domain("$name..."); + is( $domain->name, $name, 'ignore gratuitous trailing dots' ); +} + + +{ + foreach my $case ( + '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015', + '\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031' + ) { + my $domain = new Net::DNS::Domain($case); + is( $domain->name, $case, "C0 controls:\t$case" ); + } +} + + +{ + foreach my $case ( + '\032!"#$%&\'()*+,-\./', # 32 .. 47 + '0123456789:;<=>?', # 48 .. + '@ABCDEFGHIJKLMNO', # 64 .. + 'PQRSTUVWXYZ[\\\\]^_', # 80 .. + '`abcdefghijklmno', # 96 .. + 'pqrstuvwxyz{|}~\127' # 112 .. + ) { + my $domain = new Net::DNS::Domain($case); + is( $domain->name, $case, "G0 graphics:\t$case" ); + } +} + + +{ + foreach my $case ( + '\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143', + '\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159', + '\160\161\162\163\164\165\166\167\168\169\170\171\172\173\174\175', + '\176\177\178\179\180\181\182\183\184\185\186\187\188\189\190\191', + '\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207', + '\208\209\210\211\212\213\214\215\216\217\218\219\220\221\222\223', + '\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239', + '\240\241\242\243\244\245\246\247\248\249\250\251\252\253\254\255' + ) { + my $domain = new Net::DNS::Domain($case); + is( $domain->name, $case, "8-bit codes:\t$case" ); + } +} + + +exit; + diff --git a/t/02-domainname.t b/t/02-domainname.t new file mode 100644 index 0000000..99da9e4 --- /dev/null +++ b/t/02-domainname.t @@ -0,0 +1,213 @@ +# $Id: 02-domainname.t 1355 2015-06-05 08:23:04Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 51; + + +BEGIN { + use_ok('Net::DNS::DomainName'); +} + + +{ + my $domain = new Net::DNS::DomainName(''); + is( $domain->name, '.', 'DNS root represented as single dot' ); + + my @label = $domain->_wire; + is( scalar(@label), 0, "DNS root name has zero labels" ); + + my $binary = unpack 'H*', $domain->encode; + my $expect = '00'; + is( $binary, $expect, 'DNS root wire-format representation' ); +} + + +{ + my $ldh = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-0123456789'; + my $domain = new Net::DNS::DomainName($ldh); + my $subdomain = new Net::DNS::DomainName("sub.$ldh"); + is( $domain->name, $ldh, '63 octet LDH character label' ); + + my @label = $domain->_wire; + is( scalar(@label), 1, "name has single label" ); + + my $buffer = $domain->encode; + my $hex = '3f' + . '4142434445464748494a4b4c4d4e4f505152535455565758595a' + . '6162636465666768696a6b6c6d6e6f707172737475767778797a' + . '2d30313233343536373839' . '00'; + is( lc unpack( 'H*', $buffer ), $hex, 'simple wire-format encoding' ); + + my ( $decoded, $offset ) = decode Net::DNS::DomainName( \$buffer ); + is( $decoded->name, $domain->name, 'simple wire-format decoding' ); + + is( decode Net::DNS::DomainName( \$subdomain->encode )->name, $subdomain->name, 'simple wire-format decoding' ); + + my $data = '03737562c000c000c000'; + $buffer .= pack( 'H*', $data ); + + my $cache = {}; + ( $decoded, $offset ) = decode Net::DNS::DomainName( \$buffer, $offset, $cache ); + is( $decoded->name, $subdomain->name, 'compressed wire-format decoding' ); + + my @labels = $decoded->_wire; + is( scalar(@labels), 2, "decoded name has two labels" ); + + $decoded = decode Net::DNS::DomainName( \$buffer, $offset, $cache ); + is( $decoded->name, $domain->name, 'compressed wire-format decoding' ); +} + + +{ + my $buffer = pack 'H*', '0200'; + eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt wire-format\t[$exception]" ); +} + + +{ + my $buffer = pack 'H*', 'c002'; + eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "bad compression pointer\t[$exception]" ); +} + + +{ + my $buffer = pack 'H*', 'c000'; + eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "name compression loop\t[$exception]" ); +} + + +{ + my $hex = '40' + . '4142434445464748494a4b4c4d4e4f505152535455565758595a' + . '6162636465666768696a6b6c6d6e6f707172737475767778797a' + . '2d30313233343536373839ff' . '00'; + my $buffer = pack 'H*', $hex; + eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unsupported wire-format\t[$exception]" ); +} + + +{ + my $hex = '80' + . '4142434445464748494a4b4c4d4e4f505152535455565758595a' + . '6162636465666768696a6b6c6d6e6f707172737475767778797a' + . '2d30313233343536373839ff' + . '4142434445464748494a4b4c4d4e4f505152535455565758595a' + . '6162636465666768696a6b6c6d6e6f707172737475767778797a' + . '2d30313233343536373839ff' . '00'; + my $buffer = pack 'H*', $hex; + eval { my $domain = decode Net::DNS::DomainName( \$buffer ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unsupported wire-format\t[$exception]" ); +} + + +{ + foreach my $case ( + '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015', + '\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031' + ) { + my $domain = new Net::DNS::DomainName($case); + my $binary = $domain->encode; + my $result = decode Net::DNS::DomainName( \$binary )->name; + is( unpack( 'H*', $result ), unpack( 'H*', $case ), "C0 controls:\t$case" ); + } +} + + +{ + foreach my $case ( + '\032!"#$%&\'()*+,-\./', # 32 .. 47 + '0123456789:;<=>?', # 48 .. + '@ABCDEFGHIJKLMNO', # 64 .. + 'PQRSTUVWXYZ[\\\\]^_', # 80 .. + '`abcdefghijklmno', # 96 .. + 'pqrstuvwxyz{|}~\127' # 112 .. + ) { + my $domain = new Net::DNS::DomainName($case); + my $binary = $domain->encode; + my $result = decode Net::DNS::DomainName( \$binary )->name; + is( unpack( 'H*', $result ), unpack( 'H*', $case ), "G0 graphics:\t$case" ); + } +} + + +{ + foreach my $case ( + '\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143', + '\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159', + '\160\161\162\163\164\165\166\167\168\169\170\171\172\173\174\175', + '\176\177\178\179\180\181\182\183\184\185\186\187\188\189\190\191', + '\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207', + '\208\209\210\211\212\213\214\215\216\217\218\219\220\221\222\223', + '\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239', + '\240\241\242\243\244\245\246\247\248\249\250\251\252\253\254\255' + ) { + my $domain = new Net::DNS::DomainName($case); + my $binary = $domain->encode; + my $result = decode Net::DNS::DomainName( \$binary )->name; + is( unpack( 'H*', $result ), unpack( 'H*', $case ), "8-bit codes:\t$case" ); + } +} + + +{ + my $domain = new Net::DNS::DomainName( uc 'EXAMPLE.COM' ); + my $hash = {}; + my $data = $domain->encode( 0, $hash ); + my $compress = $domain->encode( length $data, $hash ); + my $canonical = $domain->encode( length $data ); + my $decoded = decode Net::DNS::DomainName( \$data ); + my $downcased = new Net::DNS::DomainName( lc $domain->name )->encode( 0, {} ); + ok( $domain->isa('Net::DNS::DomainName'), 'object returned by new() constructor' ); + ok( $decoded->isa('Net::DNS::DomainName'), 'object returned by decode() constructor' ); + is( length $compress, length $data, 'Net::DNS::DomainName wire encoding is uncompressed' ); + isnt( $data, $downcased, 'Net::DNS::DomainName wire encoding preserves case' ); + is( length $canonical, length $data, 'Net::DNS::DomainName canonical form is uncompressed' ); + isnt( $canonical, $downcased, 'Net::DNS::DomainName canonical form preserves case' ); +} + + +{ + my $domain = new Net::DNS::DomainName1035( uc 'EXAMPLE.COM' ); + my $hash = {}; + my $data = $domain->encode( 0, $hash ); + my $compress = $domain->encode( length $data, $hash ); + my $canonical = $domain->encode( length $data ); + my $decoded = decode Net::DNS::DomainName1035( \$data ); + my $downcased = new Net::DNS::DomainName1035( lc $domain->name )->encode( 0x4000, {} ); + ok( $domain->isa('Net::DNS::DomainName1035'), 'object returned by new() constructor' ); + ok( $decoded->isa('Net::DNS::DomainName1035'), 'object returned by decode() constructor' ); + isnt( length $compress, length $data, 'Net::DNS::DomainName1035 wire encoding is compressible' ); + isnt( $data, $downcased, 'Net::DNS::DomainName1035 wire encoding preserves case' ); + is( length $canonical, length $data, 'Net::DNS::DomainName1035 canonical form is uncompressed' ); + is( $canonical, $downcased, 'Net::DNS::DomainName1035 canonical form is lower case' ); +} + + +{ + my $domain = new Net::DNS::DomainName2535( uc 'EXAMPLE.COM' ); + my $hash = {}; + my $data = $domain->encode( 0, $hash ); + my $compress = $domain->encode( length $data, $hash ); + my $canonical = $domain->encode( length $data ); + my $decoded = decode Net::DNS::DomainName2535( \$data ); + my $downcased = new Net::DNS::DomainName2535( lc $domain->name )->encode( 0, {} ); + ok( $domain->isa('Net::DNS::DomainName2535'), 'object returned by new() constructor' ); + ok( $decoded->isa('Net::DNS::DomainName2535'), 'object returned by decode() constructor' ); + is( length $compress, length $data, 'Net::DNS::DomainName2535 wire encoding is uncompressed' ); + isnt( $data, $downcased, 'Net::DNS::DomainName2535 wire encoding preserves case' ); + is( length $canonical, length $data, 'Net::DNS::DomainName2535 canonical form is uncompressed' ); + is( $canonical, $downcased, 'Net::DNS::DomainName2535 canonical form is lower case' ); +} + + +exit; + diff --git a/t/02-mailbox.t b/t/02-mailbox.t new file mode 100644 index 0000000..4ecd395 --- /dev/null +++ b/t/02-mailbox.t @@ -0,0 +1,134 @@ +# $Id: 02-mailbox.t 1406 2015-10-05 08:25:49Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 43; + + +BEGIN { + use_ok('Net::DNS::Mailbox'); +} + + +{ + my $name = 'mbox@example.com'; + my $mailbox = new Net::DNS::Mailbox($name); + ok( $mailbox->isa('Net::DNS::Mailbox'), 'object returned by new() constructor' ); +} + + +{ + my $mailbox = eval { new Net::DNS::Mailbox(); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "empty argument list\t[$exception]" ); +} + + +{ + my $mailbox = eval { new Net::DNS::Mailbox(undef); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "argument undefined\t[$exception]" ); +} + + +{ + my %testcase = ( + '.' => '<>', + '<>' => '<>', + 'a' => 'a', + 'a.b' => 'a@b', + 'a.b.c' => 'a@b.c', + 'a.b.c.d' => 'a@b.c.d', + 'a@b' => 'a@b', + 'a@b.c' => 'a@b.c', + 'a@b.c.d' => 'a@b.c.d', + 'a\.b.c.d' => 'a.b@c.d', + 'a\.b@c.d' => 'a.b@c.d', + 'empty <>' => '<>', + 'fore aft' => 'a.b@c.d', + 'nested <
>' => 'address', + 'obscure <<<>>>' => 'right', + ); + + foreach my $test ( sort keys %testcase ) { + my $expect = $testcase{$test}; + my $mailbox = new Net::DNS::Mailbox($test); + my $data = $mailbox->encode; + my $decoded = decode Net::DNS::Mailbox( \$data ); + is( $decoded->address, $expect, "encode/decode mailbox $test" ); + } +} + + +{ + my %testcase = ( + '"(a.b)"@c.d' => '"(a.b)"@c.d', + '"[a.b]"@c.d' => '"[a.b]"@c.d', + '"a,b"@c.d' => '"a,b"@c.d', + '"a:b"@c.d' => '"a:b"@c.d', + '"a;b"@c.d' => '"a;b"@c.d', + '"a@b"@c.d' => '"a@b"@c.d', + ); + + foreach my $test ( sort keys %testcase ) { + my $expect = $testcase{$test}; + my $mailbox = new Net::DNS::Mailbox($test); + my $data = $mailbox->encode; + my $decoded = decode Net::DNS::Mailbox( \$data ); + is( $decoded->address, $expect, "encode/decode mailbox $test" ); + } +} + + +{ + my $mailbox = new Net::DNS::Mailbox( uc 'MBOX.EXAMPLE.COM' ); + my $hash = {}; + my $data = $mailbox->encode( 1, $hash ); + my $compress = $mailbox->encode( length $data, $hash ); + my $canonical = $mailbox->encode( length $data ); + my $decoded = decode Net::DNS::Mailbox( \$data ); + my $downcased = new Net::DNS::Mailbox( lc $mailbox->name )->encode( 0, {} ); + ok( $mailbox->isa('Net::DNS::Mailbox'), 'object returned by Net::DNS::Mailbox->new()' ); + ok( $decoded->isa('Net::DNS::Mailbox'), 'object returned by Net::DNS::Mailbox->decode()' ); + is( length $compress, length $data, 'Net::DNS::Mailbox encoding is uncompressed' ); + isnt( $data, $downcased, 'Net::DNS::Mailbox encoding preserves case' ); + is( length $canonical, length $data, 'Net::DNS::Mailbox canonical form is uncompressed' ); + isnt( $canonical, $downcased, 'Net::DNS::Mailbox canonical form preserves case' ); +} + + +{ + my $mailbox = new Net::DNS::Mailbox1035( uc 'MBOX.EXAMPLE.COM' ); + my $hash = {}; + my $data = $mailbox->encode( 1, $hash ); + my $compress = $mailbox->encode( length $data, $hash ); + my $canonical = $mailbox->encode( length $data ); + my $decoded = decode Net::DNS::Mailbox1035( \$data ); + my $downcased = new Net::DNS::Mailbox1035( lc $mailbox->name )->encode( 0, {} ); + ok( $mailbox->isa('Net::DNS::Mailbox1035'), 'object returned by Net::DNS::Mailbox1035->new()' ); + ok( $decoded->isa('Net::DNS::Mailbox1035'), 'object returned by Net::DNS::Mailbox1035->decode()' ); + isnt( length $compress, length $data, 'Net::DNS::Mailbox1035 encoding is compressible' ); + isnt( $data, $downcased, 'Net::DNS::Mailbox1035 encoding preserves case' ); + is( length $canonical, length $data, 'Net::DNS::Mailbox1035 canonical form is uncompressed' ); + is( $canonical, $downcased, 'Net::DNS::Mailbox1035 canonical form is lower case' ); +} + + +{ + my $mailbox = new Net::DNS::Mailbox2535( uc 'MBOX.EXAMPLE.COM' ); + my $hash = {}; + my $data = $mailbox->encode( 1, $hash ); + my $compress = $mailbox->encode( length $data, $hash ); + my $canonical = $mailbox->encode( length $data ); + my $decoded = decode Net::DNS::Mailbox2535( \$data ); + my $downcased = new Net::DNS::Mailbox2535( lc $mailbox->name )->encode( 0, {} ); + ok( $mailbox->isa('Net::DNS::Mailbox2535'), 'object returned by Net::DNS::Mailbox2535->new()' ); + ok( $decoded->isa('Net::DNS::Mailbox2535'), 'object returned by Net::DNS::Mailbox2535->decode()' ); + is( length $compress, length $data, 'Net::DNS::Mailbox2535 encoding is uncompressed' ); + isnt( $data, $downcased, 'Net::DNS::Mailbox2535 encoding preserves case' ); + is( length $canonical, length $data, 'Net::DNS::Mailbox2535 canonical form is uncompressed' ); + is( $canonical, $downcased, 'Net::DNS::Mailbox2535 canonical form is lower case' ); +} + + +exit; + diff --git a/t/02-text.t b/t/02-text.t new file mode 100644 index 0000000..67a3683 --- /dev/null +++ b/t/02-text.t @@ -0,0 +1,181 @@ +# $Id: 02-text.t 1555 2017-03-22 09:47:16Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 37; + + +use_ok('Net::DNS::Text'); + + +{ + my $string = 'example'; + my $object = new Net::DNS::Text($string); + ok( $object->isa('Net::DNS::Text'), 'object returned by new() constructor' ); + is( $object->value, $string, 'expected object->value' ); + is( $object->string, $string, 'expected object->string' ); +} + + +{ + eval { my $object = new Net::DNS::Text(); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "empty argument list\t[$exception]" ); +} + + +{ + eval { my $object = new Net::DNS::Text(undef); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "argument undefined\t[$exception]" ); +} + + +{ + my $sample = ''; + my $expect = '""'; + my $result = new Net::DNS::Text($sample)->string; + is( $result, $expect, 'null argument' ); +} + + +{ + my $sample = 'example'; + my $escape = '\e\x\a\m\p\l\e'; + my $result = new Net::DNS::Text($escape)->string; + is( $result, $sample, 'character escape' ); +} + + +{ + my $sample = 'A'; + my $escape = '\065'; + my $result = new Net::DNS::Text($escape)->string; + is( $result, $sample, 'numeric escape' ); +} + + +{ + my $string = 'a' x 256; + my $object = new Net::DNS::Text($string); + is( scalar(@$object), 2, 'new() splits long argument' ); + is( length( $object->value ), length($string), 'object->value reassembles string' ); + is( length( $object->string ), length($string), 'object->string reassembles string' ); +} + + +{ + my $utf8 = '\192\160'; + my $filler = 'a' x 254; + my $string = join '', $filler, $utf8; + my $object = new Net::DNS::Text($string); + is( length( $object->[0] ), length($filler), 'new() does not break UTF8 sequence' ); +} + + +{ + my $sample = 'x\000x\031x\127x\128x\159\160\255x'; + my $expect = '7800781f787f7880789fa0ff78'; + my $length = sprintf '%02x', length pack( 'H*', $expect ); + my $object = new Net::DNS::Text($sample); + my $buffer = $object->encode; + is( unpack( 'H*', $buffer ), $length . $expect, 'encode() returns expected data' ); + is( unpack( 'H*', $object->raw ), $expect, 'raw() returns expected data' ); +} + + +{ + my $sample = 'example'; + my $buffer = new Net::DNS::Text($sample)->encode; + my $object = decode Net::DNS::Text( \$buffer ); + ok( $object->isa('Net::DNS::Text'), 'object returned by decode() constructor' ); + is( $object->string, $sample, 'object matches original data' ); + my ( $x, $next ) = decode Net::DNS::Text( \$buffer ); + is( $next, length $buffer, 'expected offset returned by decode()' ); +} + + +{ + my $sample = 'example'; + my $buffer = new Net::DNS::Text($sample)->encode; + my ( $object, $next ) = decode Net::DNS::Text( \$buffer, 1, length($buffer) - 1 ); + is( $object->string, $sample, 'decode() extracts arbitrary substring' ); + is( $next, length $buffer, 'expected offset returned by decode()' ); +} + + +{ + my $sample = 'example'; + my $buffer = substr new Net::DNS::Text($sample)->encode, 0, 2; + eval { my $object = decode Net::DNS::Text( \$buffer ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt wire-format\t[$exception]" ); +} + + +{ + my %testcase = ( + '000102030405060708090a0b0c0d0e0f' => + '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015', + '101112131415161718191a1b1c1d1e1f' => + '\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031', + ); + + foreach my $hexcode ( sort keys %testcase ) { + my $string = $testcase{$hexcode}; + my $content = pack 'H*', $hexcode; + my $buffer = pack 'C a*', length $content, $content; + my $decoded = decode Net::DNS::Text( \$buffer ); + my $compare = $decoded->string; + is( $compare, qq($string), "C0 controls:\t$string" ); + } +} + + +{ + my %testcase = ( + '202122232425262728292a2b2c2d2e2f' => q|" !\"#$%&'()*+,-./"|, + '303132333435363738393a3b3c3d3e3f' => '0123456789:\;<=>?', + '404142434445464748494a4b4c4d4e4f' => '\@ABCDEFGHIJKLMNO', + '505152535455565758595a5b5c5d5e5f' => 'PQRSTUVWXYZ[\\\\]^_', + '606162636465666768696a6b6c6d6e6f' => '`abcdefghijklmno', + '707172737475767778797a7b7c7d7e7f' => 'pqrstuvwxyz{|}~\127' + ); + + foreach my $hexcode ( sort keys %testcase ) { + my $string = $testcase{$hexcode}; + my $content = pack 'H*', $hexcode; + my $buffer = pack 'C a*', length $content, $content; + my $decoded = decode Net::DNS::Text( \$buffer ); + my $compare = $decoded->string; + is( $compare, qq($string), "G0 graphics:\t$string" ); + } +} + + +{ + my %testcase = ( + '808182838485868788898a8b8c8d8e8f' => + '\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143', + '909192939495969798999a9b9c9d9e9f' => + '\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159', + 'a0a1a2a3a4a5a6a7a8a9aaabacadaeaf' => + '\160\161\162\163\164\165\166\167\168\169\170\171\172\173\174\175', + 'b0b1b2b3b4b5b6b7b8b9babbbcbdbebf' => + '\176\177\178\179\180\181\182\183\184\185\186\187\188\189\190\191', + 'c0c1c2c3c4c5c6c7c8c9cacbcccdcecf' => + '\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207', + 'd0d1d2d3d4d5d6d7d8d9dadbdcdddedf' => + '\208\209\210\211\212\213\214\215\216\217\218\219\220\221\222\223', + 'e0e1e2e3e4e5e6e7e8e9eaebecedeeef' => + '\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239', + 'f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff' => + '\240\241\242\243\244\245\246\247\248\249\250\251\252\253\254\255' + ); + + foreach my $hexcode ( sort keys %testcase ) { + my $string = $testcase{$hexcode}; + my $encoded = new Net::DNS::Text($string)->encode; + is( unpack( 'xH*', $encoded ), $hexcode, qq(8-bit codes:\t$string) ); + } +} + diff --git a/t/03-header.t b/t/03-header.t new file mode 100644 index 0000000..814574f --- /dev/null +++ b/t/03-header.t @@ -0,0 +1,172 @@ +# $Id: 03-header.t 1527 2017-01-18 21:42:48Z willem $ + +use strict; +use Test::More; + +use Net::DNS::Packet; +use Net::DNS::Parameters; + +my @op = keys %Net::DNS::Parameters::opcodebyname; +my @rc = keys %Net::DNS::Parameters::rcodebyname; + +plan tests => 76 + scalar(@op) + scalar(@rc); + + +my $packet = new Net::DNS::Packet(qw(. NS IN)); +my $header = $packet->header; +ok( $header->isa('Net::DNS::Header'), 'packet->header object' ); + + +sub waggle { + my $object = shift; + my $attribute = shift; + my @sequence = @_; + for my $value (@sequence) { + my $change = $object->$attribute($value); + my $stored = $object->$attribute(); + is( $stored, $value, "expected value after header->$attribute($value)" ); + } +} + + +{ ## check conversion functions + foreach ( sort( keys %Net::DNS::Parameters::opcodebyname ), 15 ) { + my $expect = /NS_NOTIFY/i ? 'NOTIFY' : uc($_); + my $name = eval { + my $val = opcodebyname($_); + opcodebyval( opcodebyname($val) ); + }; + my $exception = $@ =~ /^(.+)\n/ ? $1 : ''; + is( $name, $expect, "opcodebyname('$_')\t$exception" ); + } + + foreach my $testcase ('BOGUS') { + eval { opcodebyname($testcase); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "opcodebyname($testcase)\t[$exception]" ); + } +} + +{ + foreach ( sort( keys %Net::DNS::Parameters::rcodebyname ), 4000 ) { + my $expect = /BADVERS/i ? 'BADSIG' : uc($_); + my $name = eval { + my $val = rcodebyname($_); + rcodebyval( rcodebyname($val) ); + }; + my $exception = $@ =~ /^(.+)\n/ ? $1 : ''; + is( $name, $expect, "rcodebyname('$_')\t$exception" ); + } + + foreach my $testcase ('BOGUS') { + eval { rcodebyname($testcase); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "rcodebyname($testcase)\t[$exception]" ); + } +} + + +my $newid = new Net::DNS::Packet->header->id; +waggle( $header, 'id', $header->id, $newid, $header->id ); + +waggle( $header, 'opcode', qw(STATUS UPDATE QUERY) ); +waggle( $header, 'rcode', qw(REFUSED FORMERR NOERROR) ); + +waggle( $header, 'qr', 1, 0, 1, 0 ); +waggle( $header, 'aa', 1, 0, 1, 0 ); +waggle( $header, 'tc', 1, 0, 1, 0 ); +waggle( $header, 'rd', 0, 1, 0, 1 ); +waggle( $header, 'ra', 1, 0, 1, 0 ); +waggle( $header, 'ad', 1, 0, 1, 0 ); +waggle( $header, 'cd', 1, 0, 1, 0 ); + + +# +# Is $header->string remotely sane? +# +like( $header->string, '/opcode = QUERY/', 'string() has QUERY opcode' ); +like( $header->string, '/qdcount = 1/', 'string() has qdcount correct' ); +like( $header->string, '/ancount = 0/', 'string() has ancount correct' ); +like( $header->string, '/nscount = 0/', 'string() has nscount correct' ); +like( $header->string, '/arcount = 0/', 'string() has arcount correct' ); + +$header->opcode('UPDATE'); +like( $header->string, '/opcode = UPDATE/', 'string() has UPDATE opcode' ); +like( $header->string, '/zocount = 1/', 'string() has zocount correct' ); +like( $header->string, '/prcount = 0/', 'string() has prcount correct' ); +like( $header->string, '/upcount = 0/', 'string() has upcount correct' ); +like( $header->string, '/adcount = 0/', 'string() has adcount correct' ); + + +# +# Check that the aliases work +# +my $rr = new Net::DNS::RR('example.com. 10800 A 192.0.2.1'); +my @rr = ( $rr, $rr ); +$packet->push( prereq => $rr ); +$packet->push( update => $rr, @rr ); +$packet->push( additional => @rr, @rr ); + +is( $header->zocount, $header->qdcount, 'zocount value matches qdcount' ); +is( $header->prcount, $header->ancount, 'prcount value matches ancount' ); +is( $header->upcount, $header->nscount, 'upcount value matches nscount' ); +is( $header->adcount, $header->arcount, 'adcount value matches arcount' ); + + +foreach my $method (qw(qdcount ancount nscount arcount)) { + local $Net::DNS::Header::warned; + eval { + local $SIG{__WARN__} = sub { die @_ }; + $header->$method(1); + }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "$method read-only:\t[$exception]" ); + + eval { + local $SIG{__WARN__} = sub { die @_ }; + $header->$method(1); + }; + my $repeated = $1 if $@ =~ /^(.+)\n/; + ok( !$repeated, "$method exception not repeated" ); +} + + +my $data = $packet->data; + +my $packet2 = new Net::DNS::Packet( \$data ); + +my $string = $packet->header->string; + +is( $packet2->header->string, $string, 'encode/decode transparent' ); + + +SKIP: { + my $size = $header->size; + my $edns = $header->edns; + ok( $edns->isa('Net::DNS::RR::OPT'), 'header->edns object' ); + + skip( 'EDNS header extensions not supported', 10 ) unless $edns->isa('Net::DNS::RR::OPT'); + + waggle( $header, 'do', 0, 1, 0, 1 ); + waggle( $header, 'rcode', qw(BADVERS BADMODE BADNAME FORMERR NOERROR) ); + + my $packet = new Net::DNS::Packet(); # empty EDNS size solicitation + my $udplim = 1280; + $packet->edns->size($udplim); + my $encoded = $packet->data; + my $decoded = new Net::DNS::Packet( \$encoded ); + is( $decoded->edns->size, $udplim, 'EDNS size request assembled correctly' ); +} + + +eval { ## exercise printing functions + my $filename = "03-header.tmp"; + open( TEMP, ">$filename" ) || die "Could not open $filename for writing"; + select( ( select(TEMP), $header->print )[0] ); + close(TEMP); + unlink($filename); +}; + + +exit; + diff --git a/t/03-question.t b/t/03-question.t new file mode 100644 index 0000000..4b3de23 --- /dev/null +++ b/t/03-question.t @@ -0,0 +1,275 @@ +# $Id: 03-question.t 1595 2017-09-12 09:10:56Z willem $ -*-perl-*- + +use strict; + +use Net::DNS::Question; +use Net::DNS::Parameters; +local $Net::DNS::Parameters::DNSEXTLANG; # suppress Extlang type queries + +use Test::More tests => 121 + keys(%classbyname) + keys(%typebyname); + + +{ ## check type conversion functions + my ($anon) = 65500; + is( typebyval(1), 'A', "typebyval(1)" ); + is( typebyval($anon), "TYPE$anon", "typebyval($anon)" ); + is( typebyname("TYPE$anon"), $anon, "typebyname('TYPE$anon')" ); + is( typebyname("TYPE0$anon"), $anon, "typebyname('TYPE0$anon')" ); + + my $large = 1 << 16; + foreach my $testcase ( "BOGUS", "Bogus", "TYPE$large" ) { + eval { typebyname($testcase); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "typebyname($testcase)\t[$exception]" ); + } + + eval { typebyval($large); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "typebyval($large)\t[$exception]" ); + + foreach ( sort keys %Net::DNS::Parameters::typebyname ) { + my $expect = /[*]/ ? 'ANY' : uc($_); + my $name = eval { typebyval( typebyname($_) ) }; + my $exception = $@ =~ /^(.+)\n/ ? $1 : ''; + is( $name, $expect, "typebyname('$_')\t$exception" ); + } +} + + +{ ## check class conversion functions + my ($anon) = 65500; + is( classbyval(1), 'IN', "classbyval(1)" ); + is( classbyval($anon), "CLASS$anon", "classbyval($anon)" ); + is( classbyname("CLASS$anon"), $anon, "classbyname('CLASS$anon')" ); + is( classbyname("CLASS0$anon"), $anon, "classbyname('CLASS0$anon')" ); + + my $large = 1 << 16; + foreach my $testcase ( "BOGUS", "Bogus", "CLASS$large" ) { + eval { classbyname($testcase); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "classbyname($testcase)\t[$exception]" ); + } + + eval { classbyval($large); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "classbyval($large)\t[$exception]" ); + + foreach ( sort keys %Net::DNS::Parameters::classbyname ) { + my $expect = /[*]/ ? 'ANY' : uc($_); + my $name = eval { classbyval( classbyname($_) ) }; + my $exception = $@ =~ /^(.+)\n/ ? $1 : ''; + is( $name, $expect, "classbyname('$_')\t$exception" ); + } +} + + +{ + my $name = 'example.com'; + my $question = new Net::DNS::Question( $name, 'A', 'IN' ); + ok( $question->isa('Net::DNS::Question'), 'object returned by new() constructor' ); + + is( $question->qname, $name, '$question->qname returns expected value' ); + is( $question->qtype, 'A', '$question->qtype returns expected value' ); + is( $question->qclass, 'IN', '$question->qclass returns expected value' ); + is( $question->name, $question->qname, '$question->name returns expected value' ); + is( $question->type, $question->qtype, '$question->type returns expected value' ); + is( $question->zname, $question->qname, '$question->zname returns expected value' ); + is( $question->ztype, $question->qtype, '$question->ztype returns expected value' ); + is( $question->zclass, $question->class, '$question->zclass returns expected value' ); + + my $string = $question->string; + my $expected = "$name.\tIN\tA"; + is( $string, $expected, '$question->string returns text representation of object' ); + + my $test = 'new() argument undefined or absent'; + is( new Net::DNS::Question( $name, 'A', undef )->string, $expected, "$test\t( $name,\tA,\tundef\t)" ); + is( new Net::DNS::Question( $name, 'A', () )->string, $expected, "$test\t( $name,\tA,\t\t)" ); + is( new Net::DNS::Question( $name, undef, 'IN' )->string, $expected, "$test\t( $name,\tundef,\tIN\t)" ); + is( new Net::DNS::Question( $name, (), 'IN' )->string, $expected, "$test\t( $name,\t\tIN\t)" ); + is( new Net::DNS::Question( $name, undef, undef )->string, $expected, "$test\t( $name,\tundef,\tundef\t)" ); + is( new Net::DNS::Question( $name, (), () )->string, $expected, "$test\t( $name \t\t\t)" ); +} + + +{ + my $test = 'new() arguments in zone file order'; + my $fqdn = 'example.com.'; + foreach my $class (qw(IN CLASS1 ANY)) { + foreach my $type (qw(A TYPE1 ANY)) { + my $testcase = new Net::DNS::Question( $fqdn, $class, $type )->string; + my $expected = new Net::DNS::Question( $fqdn, $type, $class )->string; + is( $testcase, $expected, "$test\t( $fqdn,\t$class,\t$type\t)" ); + } + } +} + + +{ + my $question = eval { new Net::DNS::Question(undef); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "argument undefined\t[$exception]" ); +} + + +{ + foreach my $method (qw(qname qtype qclass name)) { + my $question = eval { new Net::DNS::Question('.')->$method('name'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "$method read-only:\t[$exception]" ); + } +} + + +{ + my $wiredata = pack 'H*', '000001'; + my $question = eval { decode Net::DNS::Question( \$wiredata ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt wire-format\t[$exception]" ); +} + + +{ + my $test = 'decoded object matches encoded data'; + foreach my $class (qw(IN HS ANY)) { + foreach my $type (qw(A AAAA MX NS SOA ANY)) { + my $question = new Net::DNS::Question( 'example.com', $type, $class ); + my $encoded = $question->encode; + my $expected = $question->string; + my $decoded = decode Net::DNS::Question( \$encoded ); + is( $decoded->string, $expected, "$test\t$expected" ); + } + } +} + + +{ + my $question = new Net::DNS::Question('example.com'); + my $encoded = $question->encode; + my ( $decoded, $offset ) = decode Net::DNS::Question( \$encoded ); + is( $offset, length($encoded), 'returned offset has expected value' ); +} + + +{ + my @part = ( 1 .. 4 ); + while (@part) { + my $test = 'interpret IPv4 prefix as PTR query'; + my $prefix = join '.', @part; + my $domain = new Net::DNS::Question($prefix); + my $actual = $domain->qname; + my $invert = join '.', reverse 'in-addr.arpa', @part; + my $inaddr = new Net::DNS::Question($invert); + my $expect = $inaddr->qname; + is( $actual, $expect, "$test\t$prefix" ); + pop @part; + } +} + + +{ + foreach my $type (qw(NS SOA ANY)) { + my $test = "query $type in in-addr.arpa namespace"; + my $question = new Net::DNS::Question( '1.2.3.4', $type ); + my $qtype = $question->qtype; + my $string = $question->string; + is( $qtype, $type, "$test\t$string" ); + } +} + + +{ + foreach my $n ( 32, 24, 16, 8 ) { + my $ip4 = '1.2.3.4'; + my $test = "accept CIDR address/$n prefix syntax"; + my $m = ( ( $n + 7 ) >> 3 ) << 3; + my $actual = new Net::DNS::Question("$ip4/$n"); + my $expect = new Net::DNS::Question("$ip4/$m"); + my $string = $expect->qname; + is( $actual->qname, $expect->qname, "$test\t$string" ); + } +} + + +{ + is( new Net::DNS::Question('1:2:3:4:5:6:7:8')->string, + "8.0.0.0.7.0.0.0.6.0.0.0.5.0.0.0.4.0.0.0.3.0.0.0.2.0.0.0.1.0.0.0.ip6.arpa.\tIN\tPTR", + 'interpret IPv6 address as PTR query in ip6.arpa namespace' + ); + is( new Net::DNS::Question('::ffff:192.0.2.1')->string, + "1.2.0.192.in-addr.arpa.\tIN\tPTR", + 'interpret IPv6 form of IPv4 address as query in in-addr.arpa' + ); + is( new Net::DNS::Question('1:2:3:4:5:6:192.0.2.1')->string, + "1.0.2.0.0.0.0.c.6.0.0.0.5.0.0.0.4.0.0.0.3.0.0.0.2.0.0.0.1.0.0.0.ip6.arpa.\tIN\tPTR", + 'interpret IPv6 + embedded IPv4 address as query in ip6.arpa' + ); + is( new Net::DNS::Question(':x:')->string, + ":x:.\tIN\tA", + 'non-address character precludes interpretation as PTR query' + ); + is( new Net::DNS::Question(':.:')->string, + ":.:.\tIN\tA", + 'non-numeric character precludes interpretation as PTR query' + ); +} + + +{ + my @part = ( 1 .. 8 ); + while (@part) { + my $n = 16 * scalar(@part); + my $test = 'interpret IPv6 prefix as PTR query'; + my $prefix = join ':', @part; + my $actual = new Net::DNS::Question($prefix)->qname; + my $expect = new Net::DNS::Question("$prefix/$n")->qname; + is( $actual, $expect, "$test\t$prefix" ) if $prefix =~ /:/; + pop @part; + } +} + + +{ + foreach my $n ( 16, 12, 8, 4 ) { + my $ip6 = '1234:5678:9012:3456:7890:1234:5678:9012'; + my $test = "accept IPv6 address/$n prefix syntax"; + my $m = ( ( $n + 3 ) >> 2 ) << 2; + my $actual = new Net::DNS::Question("$ip6/$n"); + my $expect = new Net::DNS::Question("$ip6/$m"); + my $string = $expect->qname; + is( $actual->qname, $expect->qname, "$test\t$string" ); + } +} + + +{ + my $expected = length new Net::DNS::Question('1:2:3:4:5:6:7:8')->qname; + foreach my $i ( reverse 0 .. 6 ) { + foreach my $j ( $i + 3 .. 9 ) { + my $ip6 = join( ':', 1 .. $i ) . '::' . join( ':', $j .. 8 ); + my $name = new Net::DNS::Question("$ip6")->qname; + is( length $name, $expected, "check length of expanded IPv6 address\t$ip6" ); + } + } +} + + +eval { ## exercise but do not test print + my $object = new Net::DNS::Question('example.com'); + my $filename = '03-question.txt'; + open( TEMP, ">$filename" ) || die "Could not open $filename for writing"; + select( ( select(TEMP), $object->print )[0] ); + close(TEMP); + unlink($filename); +}; + + + ## exercise but do not test ad hoc RRtype registration +Net::DNS::Parameters::register( 'TOY', 65280 ); # RR type name and number +Net::DNS::Parameters::register( 'TOY', 65280 ); # ignore duplicate entry +eval { Net::DNS::Parameters::register('ANY') }; # reject CLASS identifier +eval { Net::DNS::Parameters::register('A') }; # reject conflicting type name +eval { Net::DNS::Parameters::register( 'Z', 1 ) }; # reject conflicting type number + + +exit; + diff --git a/t/03-rr.t b/t/03-rr.t new file mode 100644 index 0000000..8bbccf6 --- /dev/null +++ b/t/03-rr.t @@ -0,0 +1,331 @@ +# $Id: 03-rr.t 1597 2017-09-22 08:04:02Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 108; + +use Net::DNS::RR; +local $Net::DNS::Parameters::DNSEXTLANG; # suppress Extlang type queries + + +{ ## check exception raised for unparsable argument + foreach my $testcase ( undef, '', ' ', '. NULL x', '. OPT x', '. ATMA x', [], {} ) { + eval { new Net::DNS::RR($testcase) }; + my $exception = $1 if $@ =~ /^(.+)\n/; + my $test = defined $testcase ? "'$testcase'" : 'undef'; + ok( $exception ||= '', "new Net::DNS::RR($test)\t[$exception]" ); + } +} + + +{ ## check plausible ways to create empty record + foreach my $testcase ( + 'example.com A', + 'example.com IN', + 'example.com IN A', + 'example.com IN 123 A', + 'example.com 123 A', + 'example.com 123 IN A', + 'example.com 123 In Aaaa', + 'example.com A \\# 0', + ) { + my $rr = new Net::DNS::RR("$testcase"); + is( length( $rr->rdata ), 0, "new Net::DNS::RR( $testcase )" ); + } +} + + +{ ## check basic functions + my ( $name, $class, $ttl, $type, $rdata ) = qw(example.com IN 123 A 192.0.2.1); + my $rr = new Net::DNS::RR("$name $ttl $class $type $rdata"); + my $rdlen = length( $rr->rdata ); + is( $rr->owner, $name, 'expected value returned by $rr->owner' ); + is( $rr->type, $type, 'expected value returned by $rr->type' ); + is( $rr->class, $class, 'expected value returned by $rr->class' ); + is( $rr->ttl, $ttl, 'expected value returned by $rr->ttl' ); + is( $rr->rdstring, $rdata, 'expected value returned by $rr->rdstring' ); + is( $rr->rdlength, $rdlen, 'expected value returned by $rr->rdlength' ); +} + + +{ ## check basic parsing of all acceptable forms of A record + my $example = new Net::DNS::RR('example.com. 0 IN A 192.0.2.1'); + my $expected = $example->string; + foreach my $testcase ( + join( "\t", qw( example.com 0 IN A ), q(\# 4 c0 00 02 01) ), + join( "\t", qw( example.com 0 IN A ), q(\# 4 c0000201 ) ), + 'example.com 0 IN A 192.0.2.1', + 'example.com 0 IN TYPE1 192.0.2.1', + 'example.com 0 CLASS1 A 192.0.2.1', + 'example.com 0 CLASS1 TYPE1 192.0.2.1', + 'example.com 0 A 192.0.2.1', + 'example.com 0 TYPE1 192.0.2.1', + 'example.com IN A 192.0.2.1', + 'example.com IN TYPE1 192.0.2.1', + 'example.com CLASS1 A 192.0.2.1', + 'example.com CLASS1 TYPE1 192.0.2.1', + 'example.com A 192.0.2.1', + 'example.com TYPE1 192.0.2.1', + 'example.com IN 0 A 192.0.2.1', + 'example.com IN 0 TYPE1 192.0.2.1', + 'example.com CLASS1 0 A 192.0.2.1', + 'example.com CLASS1 0 TYPE1 192.0.2.1', + ) { + my $rr = new Net::DNS::RR("$testcase"); + $rr->ttl( $example->ttl ); # TTL only shown if defined + is( $rr->string, $expected, "new Net::DNS::RR( $testcase )" ); + } +} + + +{ ## check parsing of comments, quotes and brackets + my $example = new Net::DNS::RR('example.com. 0 IN TXT "txt-data"'); + my $expected = $example->string; + foreach my $testcase ( + q(example.com 0 IN TXT txt-data ; space delimited), + q(example.com 0 TXT txt-data), + q(example.com IN TXT txt-data), + q(example.com TXT txt-data), + q(example.com IN 0 TXT txt-data), + q(example.com 0 IN TXT txt-data ; tab delimited), + q(example.com 0 TXT txt-data), + q(example.com IN TXT txt-data), + q(example.com TXT txt-data), + q(example.com IN 0 TXT txt-data), + q(example.com 0 IN TXT "txt-data" ; "quoted"), + q(example.com 0 TXT "txt-data"), + q(example.com IN TXT "txt-data"), + q(example.com TXT "txt-data"), + q(example.com IN 0 TXT "txt-data"), + 'example.com ( 0 IN TXT txt-data ) ; bracketed', + ) { + my $rr = new Net::DNS::RR("$testcase"); + $rr->ttl( $example->ttl ); # TTL only shown if defined + is( $rr->string, $expected, "new Net::DNS::RR( $testcase )" ); + } +} + + +{ ## check parsing of implemented RR type with hexadecimal RDATA + my @common = qw( example.com. 3600 IN TXT ); + my $expected = join "\t", @common, q("two separate" "quoted strings"); + my $testcase = join "\t", @common, q(\# 28 0c74776f2073657061726174650e71756f74656420737472696e6773); + my $rr = new Net::DNS::RR("$testcase"); + is( $rr->string, $expected, "new Net::DNS::RR( $testcase )" ); +} + + +{ ## check for exception if RFC3597 format hexadecimal data inconsistent + foreach my $testcase ( '\# 0 c0 00 02 01', '\# 3 c0 00 02 01', '\# 5 c0 00 02 01' ) { + eval { new Net::DNS::RR("example.com 3600 IN A $testcase") }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "mismatched length: $testcase\t[$exception]" ); + } +} + + +{ ## check object construction from attribute list + foreach my $testcase ( + [ type => 'A', address => '192.0.2.1' ], + [ type => 'A', address => ['192.0.2.1'] ], + ) { + my $rr = new Net::DNS::RR(@$testcase); + is( length( $rr->rdata ), 4, "new Net::DNS::RR( @$testcase )" ); + } + + foreach my $testcase ( + [ type => 'A', rdata => '' ], + [ name => 'example.com', type => 'MX' ], + [ type => 'MX', class => 'IN', ttl => 123 ], + ) { + my $rr = new Net::DNS::RR(@$testcase); + is( length( $rr->rdata ), 0, "new Net::DNS::RR( @$testcase )" ); + } +} + + +{ ## check for exception for nonexistent attribute + my $method = 'bogus'; + foreach my $testcase ( + [ type => 'A' ], + [ type => 'ATMA' ], + [ type => 'ATMA', unimplemented => 'x' ], + ) { + eval { new Net::DNS::RR( @$testcase )->$method('x') }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown method:\t[$exception]" ); + } + my $rr = new Net::DNS::RR( type => 'A' ); + is( $rr->$method, undef, 'suppress repeated unknown method exception' ); + is( $rr->DESTROY, undef, 'DESTROY() exists to defeat pre-5.18 AUTOLOAD' ); +} + + +{ ## check for exception on bad class method + eval { xxxx Net::DNS::RR( type => 'X' ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown class method:\t[$exception]" ); +} + + +{ ## check for exception if RR name not recognised + eval { new Net::DNS::RR('example.com. IN BOGUS') }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unrecognised RR type:\t[$exception]" ); +} + + +{ ## check for exception when abusing $rr->type() + my $rr = new Net::DNS::RR( type => 'A' ); + eval { $rr->type('X'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "cannot change type:\t[$exception]" ); +} + + +{ ## check for exception when abusing $rr->ttl() + my $rr = new Net::DNS::RR( type => 'A' ); + eval { $rr->ttl('1year'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown time unit:\t[$exception]" ); +} + + +{ ## check for exception when abusing $rr->rdata() + my $rr = new Net::DNS::RR( type => 'SOA' ); + eval { $rr->rdata( pack 'H* H*', '00c000', '00000001' x 5 ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "compressed rdata:\t[$exception]" ); +} + + +{ ## check propagation of exception in string() + ## (relies on bug that nobody cares enough to fix) + my $rr = new Net::DNS::RR( type => 'MINFO', emailbx => '.' ); + eval { + local $SIG{__WARN__} = sub { die @_ }; + $rr->string(); + }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception in string:\t[$exception]" ); +} + + +{ ## check propagation of exception in rdstring() + ## (relies on bug that nobody cares enough to fix) + my $rr = new Net::DNS::RR( type => 'MINFO', emailbx => '.' ); + eval { + local $SIG{__WARN__} = sub { die @_ }; + $rr->rdatastr(); + }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception in rdstring:\t[$exception]" ); +} + + +{ ## check encode/decode functions + foreach my $testcase ( + 'example.com A', + 'example.com IN', + 'example.com IN A', + 'example.com IN 123 A', + 'example.com 123 A', + 'example.com 123 IN A', + 'example.com A 192.0.2.1', + ) { + my $rr = new Net::DNS::RR("$testcase"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR(\$encoded); + $rr->ttl( $decoded->ttl ) unless $rr->ttl; + is( $decoded->string, $rr->string, "encode/decode $testcase" ); + } + + my $opt = new Net::DNS::RR( type => 'OPT' ); + my $encoded = $opt->encode; + my ( $decoded, $offset ) = decode Net::DNS::RR(\$encoded); + is( $decoded->string, $opt->string, "encode/decode OPT RR" ); + is( $offset, length($encoded), "decode returns offset of next RR" ); +} + + +{ ## check canonical encode function + foreach my $testcase ( + 'example.com 123 IN A', + 'EXAMPLE.com 123 A 192.0.2.1', + ) { + my $rr = new Net::DNS::RR("$testcase"); + my $expected = unpack 'H*', $rr->encode(0); + my $canonical = unpack 'H*', $rr->canonical; + is( $canonical, $expected, "canonical encode $testcase" ); + } +} + + +{ + foreach my $testcase ( + '', + '000001', + '0000010001000000010004', + ) { + my $wiredata = pack 'H*', $testcase; + my $question = eval { decode Net::DNS::RR(\$wiredata); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt wire-format\t[$exception]" ); + } +} + + +{ ## check plain and generic formats + my @testcase = ( + [owner => 'example.com.', type => 'A'], + [owner => 'example.com.', type => 'A', rdata => ''], + ['example.com. IN NS a.iana-servers.net.'], + ['example.com. IN SOA ( + sns.dns.icann.org. noc.dns.icann.org. + 2015082417 ;serial + 7200 ;refresh + 3600 ;retry + 1209600 ;expire + 3600 ;minimum + )'], + [owner => 'example.com.', type => 'ATMA'], # unimplemented + [owner => 'example.com.', type => 'ATMA', rdata => ''], + [owner => 'example.com.', type => 'ATMA', rdata => 'octets'], + ); + foreach my $testcase (@testcase) { + my $rr = new Net::DNS::RR(@$testcase); + my $type = $rr->type; + my $plain = new Net::DNS::RR( $rr->plain ); + is( $plain->string, $rr->string, "parse rr->plain format $type" ); + my $rfc3597 = new Net::DNS::RR( $rr->generic ); + is( $rfc3597->string, $rr->string, "parse rr->generic format $type" ); + } +} + + +{ ## check RR sorting functions + foreach my $attr ( [], ['preference'], ['X'] ) { + my $func = Net::DNS::RR::MX->get_rrsort_func(@$attr); + is( ref($func), 'CODE', "MX->get_rrsort_func(@$attr)" ); + } +} + + +eval { ## exercise printing functions + require Data::Dumper; + local $Data::Dumper::Maxdepth; + local $Data::Dumper::Sortkeys; + my $object = new Net::DNS::RR('example.com A 192.0.2.1'); + my $filename = "03-rr.tmp"; + open( TEMP, ">$filename" ) || die "Could not open $filename for writing"; + select( ( select(TEMP), $object->print )[0] ); + select( ( select(TEMP), $object->dump )[0] ); + $Data::Dumper::Maxdepth = 6; + $Data::Dumper::Sortkeys = 1; + select( ( select(TEMP), $object->dump )[0] ); + close(TEMP); + unlink($filename); +}; + + +exit; + diff --git a/t/04-packet-truncate.t b/t/04-packet-truncate.t new file mode 100644 index 0000000..aca7dc1 --- /dev/null +++ b/t/04-packet-truncate.t @@ -0,0 +1,155 @@ +# $Id: 04-packet-truncate.t 1449 2016-02-01 12:27:12Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 33; + +use Net::DNS; +use Net::DNS::ZoneFile; + +my $source = new Net::DNS::ZoneFile( \*DATA ); + +my @rr = $source->read; + +{ + my $packet = new Net::DNS::Packet('query.example.'); + $packet->push( answer => @rr ); + $packet->push( authority => @rr ); + $packet->push( additional => @rr ); + my $unlimited = length $packet->data; + my %before = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional); + my $truncated = length $packet->truncate($unlimited); + ok( $truncated == $unlimited, "unconstrained packet length $unlimited" ); + + foreach my $section (qw(answer authority additional)) { + my $before = $before{$section}; + my $after = scalar( $packet->$section ); + is( $after, $before, "$section section unchanged, $before RRs" ); + } + ok( !$packet->header->tc, 'header->tc flag not set' ); +} + + +{ + my $packet = new Net::DNS::Packet('query.example.'); + $packet->push( answer => @rr ); + $packet->push( authority => @rr ); + $packet->push( additional => @rr ); + my $unlimited = length $packet->data; + my %before = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional); + my $truncated = length $packet->truncate; # exercise default size + ok( $truncated < $unlimited, "long packet was $unlimited, now $truncated" ); + + foreach my $section (qw(answer authority additional)) { + my $before = $before{$section}; + my $after = scalar( $packet->$section ); + ok( $after < $before, "$section section was $before RRs, now $after" ); + } + ok( $packet->header->tc, 'header->tc flag set' ); +} + + +{ + my $packet = new Net::DNS::Packet('query.example.'); + $packet->push( answer => @rr ); + $packet->push( authority => @rr ); + $packet->push( additional => @rr ); + + my $tsig = eval { $packet->sign_tsig( 'tsig.example', 'ARDJZgtuTDzAWeSGYPAu9uJUkX0=' ) }; + + my $unlimited = length $packet->data; + my %before = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional); + my $truncated = length $packet->data(512); # explicit minimum size + ok( $truncated < $unlimited, "signed packet was $unlimited, now $truncated" ); + + foreach my $section (qw(answer authority additional)) { + my $before = $before{$section}; + my $after = scalar( $packet->$section ); + ok( $after < $before, "$section section was $before RRs, now $after" ); + } + my $sigrr = $packet->sigrr; + is( $sigrr, $tsig, 'TSIG still in additional section' ); + ok( $packet->header->tc, 'header->tc flag set' ); +} + + +{ + my $packet = new Net::DNS::Packet('query.example.'); + my @auth = map Net::DNS::RR->new( type => 'NS', nsdname => $_->name ), @rr; + $packet->unique_push( authority => @auth ); + $packet->push( additional => @rr ); + $packet->edns->size(2048); # + all bells and whistles + my $unlimited = length $packet->data; + my %before = map { ( $_, scalar $packet->$_ ) } qw(answer authority additional); + my $truncated = length $packet->truncate; + ok( $truncated < $unlimited, "referral packet was $unlimited, now $truncated" ); + + foreach my $section (qw(answer authority)) { + my $before = $before{$section}; + my $after = scalar( $packet->$section ); + is( $after, $before, "$section section unchanged, $before RRs" ); + } + + foreach my $section (qw(additional)) { + my $before = $before{$section}; + my $after = scalar( $packet->$section ); + ok( $after <= $before, "$section section was $before RRs, now $after" ); + } + ok( !$packet->header->tc, 'header->tc flag not set' ); +} + + +{ + my $packet = new Net::DNS::Packet('query.example.'); + $packet->push( additional => @rr, @rr ); # two of everything + my $unlimited = length $packet->data; + my $truncated = length $packet->truncate( $unlimited >> 1 ); + ok( $truncated, "check RRsets in truncated additional section" ); + + my %rrset; + foreach my $rr ( grep $_->type eq 'A', $packet->additional ) { + my $name = $rr->name; + $rrset{"$name. A"}++; + } + + foreach my $rr ( grep $_->type eq 'AAAA', $packet->additional ) { + my $name = $rr->name; + $rrset{"$name. AAAA"}++; + } + + my $expect = 2; + foreach my $key ( sort keys %rrset ) { + is( $rrset{$key}, $expect, "$key ; $expect RRs" ); + } +} + + +exit; + + +__DATA__ + +a.example. A 198.41.0.4 +a.example. AAAA 2001:503:ba3e::2:30 +b.example. A 192.228.79.201 +b.example. AAAA 2001:500:84::b +c.example. A 192.33.4.12 +c.example. AAAA 2001:500:2::c +d.example. A 199.7.91.13 +d.example. AAAA 2001:500:2d::d +e.example. A 192.203.230.10 +f.example. A 192.5.5.241 +f.example. AAAA 2001:500:2f::f +g.example. A 192.112.36.4 +h.example. A 128.63.2.53 +h.example. AAAA 2001:500:1::803f:235 +i.example. A 192.36.148.17 +i.example. AAAA 2001:7fe::53 +j.example. A 192.58.128.30 +j.example. AAAA 2001:503:c27::2:30 +k.example. A 193.0.14.129 +k.example. AAAA 2001:7fd::1 +l.example. A 199.7.83.42 +l.example. AAAA 2001:500:3::42 +m.example. A 202.12.27.33 +m.example. AAAA 2001:dc3::35 + diff --git a/t/04-packet.t b/t/04-packet.t new file mode 100644 index 0000000..e9083a0 --- /dev/null +++ b/t/04-packet.t @@ -0,0 +1,238 @@ +# $Id: 04-packet.t 1449 2016-02-01 12:27:12Z willem $ -*-perl-*- + +use strict; + +BEGIN { + use Test::More tests => 99; + + use_ok('Net::DNS'); +} + + +# new() class constructor method must return object of appropriate class +my $object = Net::DNS::Packet->new(); +ok( $object->isa('Net::DNS::Packet'), 'new() object' ); + +ok( $object->header, 'header() method works' ); +ok( $object->header->isa('Net::DNS::Header'), 'header() returns header object' ); + +ok( $object->edns, 'edns() method works' ); +ok( $object->edns->isa('Net::DNS::RR::OPT'), 'edns() returns OPT RR object' ); + +like( $object->string, '/HEADER/', 'string() returns representation of packet' ); +$object->header->opcode('UPDATE'); +like( $object->string, '/UPDATE/', 'string() returns representation of update' ); + + +# Empty packet created when new() arguments omitted +my $empty = Net::DNS::Packet->new(); +ok( $empty, 'create empty packet' ); +foreach my $method ( qw(question answer authority additional), qw(zone pre prerequisite update) ) { + my @result = $empty->$method; + ok( @result == 0, "$method() returns empty list" ); +} + + +# Create a DNS query packet +my ( $domain, $type, $class ) = qw(example.test MX IN); +my $question = Net::DNS::Question->new( $domain, $type, $class ); + +my $packet = Net::DNS::Packet->new( $domain, $type, $class ); +like( $packet->string, "/$class\t$type/", 'create query packet' ); + +my @question = $packet->question; +ok( @question && @question == 1, 'packet->question() returns single element list' ); +my ($q) = @question; +ok( $q->isa('Net::DNS::Question'), 'list element is a question object' ); +is( $q->string, $question->string, 'question object correct' ); + + +# data() method returns non-empty scalar +my $packet_data = $packet->data; +ok( $packet_data, 'packet->data() method works' ); + + +# new(\$data) class constructor method returns object of appropriate class +my $packet2 = Net::DNS::Packet->new( \$packet_data ); +ok( $packet2->isa('Net::DNS::Packet'), 'new(\$data) object' ); +is( $packet2->string, $packet->string, 'decoded packet matches original' ); +is( unpack( 'H*', $packet2->data ), unpack( 'H*', $packet_data ), 'retransmitted packet matches original' ); + + +# new(\$data) class constructor captures exception text when data truncated +my @data = unpack 'C*', $packet->data; +while (@data) { + pop(@data); + my $truncated = pack 'C*', @data; + my $length = length $truncated; + my $object = Net::DNS::Packet->new( \$truncated ); + my $exception = $@; + $exception =~ s/\n.*$//g; + ok( $exception, "truncated ($length octets):\t[$exception]" ); +} + + +# Use push() to add RRs to each section +my $update = Net::DNS::Packet->new('.'); +my $index; +foreach my $section (qw(answer authority additional)) { + my $i = ++$index; + my $rr1 = Net::DNS::RR->new( + Name => "$section$i.example.test", + Type => "A", + Address => "10.0.0.$i" + ); + my $string1 = $rr1->string; + my $count1 = $update->push( $section, $rr1 ); + like( $update->string, "/$string1/", "push first RR into $section section" ); + is( $count1, 1, "push() returns $section RR count" ); + + my $j = ++$index; + my $rr2 = Net::DNS::RR->new( + Name => "$section$j.example.test", + Type => "A", + Address => "10.0.0.$j" + ); + my $string2 = $rr2->string; + my $count2 = $update->push( $section, $rr2 ); + like( $update->string, "/$string2/", "push second RR into $section section" ); + is( $count2, 2, "push() returns $section RR count" ); +} + +# Add enough distinct labels to render compression unusable at some point +for ( 0 .. 255 ) { + $update->push( 'answer', Net::DNS::RR->new( "X$_ TXT \"" . pack( "A255", "x" ) . '"' ) ); +} +$update->push( 'answer', Net::DNS::RR->new('XY TXT ""') ); +$update->push( 'answer', Net::DNS::RR->new('VW.XY TXT ""') ); + +# Decode data buffer and compare with original +my $buffer = $update->data; +my $decoded = eval { Net::DNS::Packet->new( \$buffer ) }; +ok( $decoded, 'new() from data buffer works' ); +is( $decoded->answersize, length($buffer), '$decoded->answersize() works' ); +$decoded->answerfrom('local'); +ok( $decoded->answerfrom(), '$decoded->answerfrom() works' ); +ok( $decoded->string(), '$decoded->string() works' ); +foreach my $count (qw(qdcount ancount nscount arcount)) { + is( $decoded->header->$count, $update->header->$count, "check header->$count correct" ); +} + + +foreach my $section (qw(question)) { + my @original = map { $_->string } $update->$section; + my @content = map { $_->string } $decoded->$section; + is_deeply( \@content, \@original, "check content of $section section" ); +} + +foreach my $section (qw(answer authority additional)) { + my @original = map { $_->ttl(0); $_->string } $update->$section; # almost! need TTL defined + my @content = map { $_->string } $decoded->$section; + is_deeply( \@content, \@original, "check content of $section section" ); +} + + +# check that pop() removes RR from section Memo to self: no RR in question section! +foreach my $section (qw(answer authority additional)) { + my $c1 = $update->push( $section, Net::DNS::RR->new('X TXT ""') ); + my $rr = $update->pop($section); + my $c2 = $update->push($section); + is( $c2, $c1 - 1, "pop() RR from $section section" ); +} + + +# Test using a predefined answer. +# This is an answer that was generated by a bind server, with an option munged on the end. + +my $BIND = pack( 'H*', +'22cc85000001000000010001056461636874036e657400001e0001c00c0006000100000e100025026e730472697065c012046f6c6166c02a7754e1ae0000a8c0000038400005460000001c2000002910000000800000050000000130' + ); + +my $bind = Net::DNS::Packet->new( \$BIND ); + +is( $bind->header->qdcount, 1, 'check question count in synthetic packet header' ); +is( $bind->header->ancount, 0, 'check answer count in synthetic packet header' ); +is( $bind->header->nscount, 1, 'check authority count in synthetic packet header' ); +is( $bind->header->adcount, 1, 'check additional count in synthetic packet header' ); + +my ($rr) = $bind->additional; + +is( $rr->type, 'OPT', 'Additional section packet is EDNS0 type' ); +is( $rr->size, '4096', 'EDNS0 packet size correct' ); + + +{ ## check tolerance of invalid pop + my $packet = new Net::DNS::Packet('example.com'); + my $case1 = $packet->pop(''); + my $case2 = $packet->pop('bogus'); +} + + +{ ## check $packet->reply() + my $packet = new Net::DNS::Packet('example.com'); + my $reply = $packet->reply(); + ok( $reply->isa('Net::DNS::Packet'), '$packet->reply() returns packet' ); + eval { $reply->reply(); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "reply->reply()\t[$exception]" ); + my $udpmax = 2048; + $packet->edns->size($udpmax); + $packet->data; + is( $packet->reply($udpmax)->edns->size(), $udpmax, 'packet->reply() supports EDNS' ); +} + + +{ ## check $packet->sigrr + my $packet = new Net::DNS::Packet(); + is( $packet->sigrr(), undef, 'sigrr() undef for empty packet' ); + $packet->push( additional => new Net::DNS::RR( type => 'OPT' ) ); + is( $packet->sigrr(), undef, 'sigrr() undef for unsigned packet' ); + is( $packet->verify(), undef, 'verify() fails for unsigned packet' ); + ok( $packet->verifyerr(), 'verifyerr() returned for unsigned packet' ); +} + + +{ ## go through the motions of SIG0 + my $packet = new Net::DNS::Packet('example.com'); + my $sig = new Net::DNS::RR( type => 'SIG' ); + ok( $packet->sign_sig0($sig), 'sign_sig0() returns SIG0 record' ); + is( ref( $packet->sigrr() ), ref($sig), 'sigrr() returns SIG RR' ); + + eval { $packet->sign_sig0( [] ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "sign_sig0([])\t[$exception]" ); +} + + +{ ## check exception raised for bad TSIG + my $packet = new Net::DNS::Packet('example.com'); + my $bogus = new Net::DNS::RR( type => 'NULL' ); + eval { $packet->sign_tsig($bogus); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "sign_tsig([])\t[$exception]" ); +} + + +eval { ## exercise but do not test print + require Data::Dumper; + local $Data::Dumper::Maxdepth; + local $Data::Dumper::Sortkeys; + my $object = new Net::DNS::Packet('example.com'); + my $buffer = $object->data; + my $corrupt = substr $buffer, 0, 10; + my $filename = '04-packet.txt'; + open( TEMP, ">$filename" ) || die "Could not open $filename for writing"; + select( ( select(TEMP), $object->print )[0] ); + select( ( select(TEMP), $object->dump )[0] ); + $Data::Dumper::Maxdepth = 6; + $Data::Dumper::Sortkeys = 1; + select( ( select(TEMP), $object->dump )[0] ); + select( ( select(TEMP), Net::DNS::Packet->new( \$buffer, 1 ) )[0] ); + select( ( select(TEMP), Net::DNS::Packet->new( \$corrupt, 1 ) )[0] ); + close(TEMP); + unlink($filename); +}; + + +exit; + diff --git a/t/05-A.t b/t/05-A.t new file mode 100644 index 0000000..3104e5f --- /dev/null +++ b/t/05-A.t @@ -0,0 +1,82 @@ +# $Id: 05-A.t 1028 2012-10-23 20:18:49Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 12; + + +use Net::DNS; + + +my $name = 'A.example'; +my $type = 'A'; +my $code = 1; +my @attr = qw( address ); +my @data = qw( 192.0.2.1 ); +my @also = qw( ); + +my $wire = 'c0000201'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my %testcase = ( + '1.2.3.4' => '1.2.3.4', + '1.2.4' => '1.2.0.4', + '1.4' => '1.0.0.4', + ); + + foreach my $address ( sort keys %testcase ) { + my $expect = $testcase{$address}; + my $rr = new Net::DNS::RR( name => $name, type => $type, address => $address ); + is( $rr->address, $expect, "address completion:\t$address" ); + } +} + + +exit; + diff --git a/t/05-AAAA.t b/t/05-AAAA.t new file mode 100644 index 0000000..6d3cf69 --- /dev/null +++ b/t/05-AAAA.t @@ -0,0 +1,165 @@ +# $Id: 05-AAAA.t 1354 2015-06-05 08:20:53Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 136; + + +use Net::DNS; + + +my $name = 'AAAA.example'; +my $type = 'AAAA'; +my $code = 28; +my @attr = qw( address ); +my @data = qw( 1:203:405:607:809:a0b:c0d:e0f ); +my @also = qw( ); + +my $wire = '000102030405060708090a0b0c0d0e0f'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my %testcase = ( + '0:0:0:0:0:0:0:0' => '::', + '0:0:0:0:0:0:0:8' => '::8', + '0:0:0:0:0:0:7:0' => '::7:0', + '0:0:0:0:0:6:0:0' => '::6:0:0', + '0:0:0:0:0:6:0:8' => '::6:0:8', + '0:0:0:0:5:0:0:0' => '::5:0:0:0', + '0:0:0:0:5:0:0:8' => '::5:0:0:8', + '0:0:0:0:5:0:7:0' => '::5:0:7:0', + '0:0:0:4:0:0:0:0' => '0:0:0:4::', + '0:0:0:4:0:0:0:8' => '::4:0:0:0:8', + '0:0:0:4:0:0:7:0' => '::4:0:0:7:0', + '0:0:0:4:0:6:0:0' => '::4:0:6:0:0', + '0:0:0:4:0:6:0:8' => '::4:0:6:0:8', + '0:0:3:0:0:0:0:0' => '0:0:3::', + '0:0:3:0:0:0:0:8' => '0:0:3::8', + '0:0:3:0:0:0:7:0' => '0:0:3::7:0', + '0:0:3:0:0:6:0:0' => '::3:0:0:6:0:0', + '0:0:3:0:0:6:0:8' => '::3:0:0:6:0:8', + '0:0:3:0:5:0:0:0' => '0:0:3:0:5::', + '0:0:3:0:5:0:0:8' => '::3:0:5:0:0:8', + '0:0:3:0:5:0:7:0' => '::3:0:5:0:7:0', + '0:2:0:0:0:0:0:0' => '0:2::', + '0:2:0:0:0:0:0:8' => '0:2::8', + '0:2:0:0:0:0:7:0' => '0:2::7:0', + '0:2:0:0:0:6:0:0' => '0:2::6:0:0', + '0:2:0:0:0:6:0:8' => '0:2::6:0:8', + '0:2:0:0:5:0:0:0' => '0:2:0:0:5::', + '0:2:0:0:5:0:0:8' => '0:2::5:0:0:8', + '0:2:0:0:5:0:7:0' => '0:2::5:0:7:0', + '0:2:0:4:0:0:0:0' => '0:2:0:4::', + '0:2:0:4:0:0:0:8' => '0:2:0:4::8', + '0:2:0:4:0:0:7:0' => '0:2:0:4::7:0', + '0:2:0:4:0:6:0:0' => '0:2:0:4:0:6::', + '0:2:0:4:0:6:0:8' => '0:2:0:4:0:6:0:8', + '1:0:0:0:0:0:0:0' => '1::', + '1:0:0:0:0:0:0:8' => '1::8', + '1:0:0:0:0:0:7:0' => '1::7:0', + '1:0:0:0:0:6:0:0' => '1::6:0:0', + '1:0:0:0:0:6:0:8' => '1::6:0:8', + '1:0:0:0:5:0:0:0' => '1::5:0:0:0', + '1:0:0:0:5:0:0:8' => '1::5:0:0:8', + '1:0:0:0:5:0:7:0' => '1::5:0:7:0', + '1:0:0:4:0:0:0:0' => '1:0:0:4::', + '1:0:0:4:0:0:0:8' => '1:0:0:4::8', + '1:0:0:4:0:0:7:0' => '1::4:0:0:7:0', + '1:0:0:4:0:6:0:0' => '1::4:0:6:0:0', + '1:0:0:4:0:6:0:8' => '1::4:0:6:0:8', + '1:0:3:0:0:0:0:0' => '1:0:3::', + '1:0:3:0:0:0:0:8' => '1:0:3::8', + '1:0:3:0:0:0:7:0' => '1:0:3::7:0', + '1:0:3:0:0:6:0:0' => '1:0:3::6:0:0', + '1:0:3:0:0:6:0:8' => '1:0:3::6:0:8', + '1:0:3:0:5:0:0:0' => '1:0:3:0:5::', + '1:0:3:0:5:0:0:8' => '1:0:3:0:5::8', + '1:0:3:0:5:0:7:0' => '1:0:3:0:5:0:7:0', + ); + + foreach my $address ( sort keys %testcase ) { + my $compact = $testcase{$address}; + my $rr1 = new Net::DNS::RR( name => $name, type => $type, address => $address ); + is( $rr1->address_short, $compact, "address compression:\t$address" ); + my $rr2 = new Net::DNS::RR( name => $name, type => $type, address => $compact ); + is( $rr2->address_long, $address, "address expansion:\t$compact" ); + } +} + + +{ + my %testcase = ( + '1' => '1:0:0:0:0:0:0:0', + '1:' => '1:0:0:0:0:0:0:0', + '1:2' => '1:2:0:0:0:0:0:0', + '1:2:' => '1:2:0:0:0:0:0:0', + '1:2:3' => '1:2:3:0:0:0:0:0', + '1:2:3:' => '1:2:3:0:0:0:0:0', + '1:2:3:4' => '1:2:3:4:0:0:0:0', + '1:2:3:4:' => '1:2:3:4:0:0:0:0', + '1:2:3:4:5' => '1:2:3:4:5:0:0:0', + '1:2:3:4:5:' => '1:2:3:4:5:0:0:0', + '1:2:3:4:5:6' => '1:2:3:4:5:6:0:0', + '1:2:3:4:5:6:' => '1:2:3:4:5:6:0:0', + '1:2:3:4:5:6:7' => '1:2:3:4:5:6:7:0', + '1:2:3:4:5:6:7:' => '1:2:3:4:5:6:7:0', + '::ffff:1.2.3.4' => '0:0:0:0:0:ffff:102:304', + '::ffff:1.2.4' => '0:0:0:0:0:ffff:102:4', + '::ffff:1.4' => '0:0:0:0:0:ffff:100:4', + ); + + foreach my $address ( sort keys %testcase ) { + my $expect = new Net::DNS::RR( name => $name, type => $type, address => $testcase{$address} ); + my $rr = new Net::DNS::RR( name => $name, type => $type, address => $address ); + is( $rr->address, $expect->address, "address completion:\t$address" ); + } +} + + +exit; + diff --git a/t/05-AFSDB.t b/t/05-AFSDB.t new file mode 100644 index 0000000..a22a1da --- /dev/null +++ b/t/05-AFSDB.t @@ -0,0 +1,87 @@ +# $Id: 05-AFSDB.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 15; + + +use Net::DNS; + + +my $name = 'AFSDB.example'; +my $type = 'AFSDB'; +my $code = 18; +my @attr = qw( subtype hostname ); +my @data = qw( 12345 host.example.com ); +my @also = qw( ); + +my $wire = '303904686f7374076578616d706c6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-APL.t b/t/05-APL.t new file mode 100644 index 0000000..5bdd38c --- /dev/null +++ b/t/05-APL.t @@ -0,0 +1,91 @@ +# $Id: 05-APL.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 31; + + +use Net::DNS; + + +my $name = 'APL.example'; +my $type = 'APL'; +my $code = 42; +my @attr = qw( aplist ); +my @data = qw( 1:224.0.0.0/4 2:FF00::0/16 !1:192.168.38.0/28 1:224.0.0.0/0 2:FF00::0/0 ); +my @also = qw( string negate family address ); # apitem attributes + +my $wire = '00010401e000021001ff00011c83c0a8260001000000020000'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + foreach my $item ( $rr->aplist ) { + foreach (@also) { + ok( defined( $item->$_ ), "aplist item->$_() attribute" ); + } + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); + + my @wire = unpack 'C*', $encoded; + $wire[length($empty) - 1]--; + my $wireformat = pack 'C*', @wire; + eval { decode Net::DNS::RR( \$wireformat ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt wire-format\t[$exception]" ); +} + + +{ + eval { new Net::DNS::RR("$name $type 0:0::0/0"); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown address family\t[$exception]" ); +} + + +exit; + + diff --git a/t/05-CAA.t b/t/05-CAA.t new file mode 100644 index 0000000..6cfe256 --- /dev/null +++ b/t/05-CAA.t @@ -0,0 +1,84 @@ +# $Id: 05-CAA.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 17; + +use Net::DNS; + + +my $name = 'CAA.example'; +my $type = 'CAA'; +my $code = 257; +my @attr = qw( flags tag value ); +my @data = qw( 128 issue example.net ); +my @also = qw( critical ); + +my $wire = '800569737375656578616d706c652e6e6574'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + next if /certificate/; + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } + + ok( $rr->critical(1), 'set $rr->critical' ); + ok( !$rr->critical(0), 'clear $rr->critical' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + + +exit; + diff --git a/t/05-CDNSKEY.t b/t/05-CDNSKEY.t new file mode 100644 index 0000000..b9c330e --- /dev/null +++ b/t/05-CDNSKEY.t @@ -0,0 +1,140 @@ +# $Id: 05-CDNSKEY.t 1586 2017-08-15 09:01:57Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 35; + + +my $name = 'CDNSKEY.example'; +my $type = 'CDNSKEY'; +my $code = 60; +my @attr = qw( flags protocol algorithm publickey ); + +my @data = ( + 256, 3, 5, join '', qw( + AQPSKmynfzW4kyBv015MUG2DeIQ3 + Cbl+BBZH4b/0PY1kxkmvHjcZc8no + kfzj31GajIQKY+5CptLr3buXA10h + WqTkF7H6RfoRqXQeogmMHfpftf6z + Mv1LyBUgia7za6ZEzOJBOztyvhjL + 742iU/TpPSEDhm2SNKLijfUppn1U + aNvv4w== ) + ); +my @also = qw( keybin keylength keytag privatekeyname zone revoke sep ); + +my $wire = join '', qw( 010003050103D22A6CA77F35B893206FD35E4C506D8378843709B97E041647E1 + BFF43D8D64C649AF1E371973C9E891FCE3DF519A8C840A63EE42A6D2EBDDBB97 + 035D215AA4E417B1FA45FA11A9741EA2098C1DFA5FB5FEB332FD4BC8152089AE + F36BA644CCE2413B3B72BE18CBEF8DA253F4E93D2103866D9234A2E28DF529A6 + 7D5468DBEFE3 ); + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name NULL"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach ( @attr, qw(keylength keytag rdstring) ) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + + $rr->algorithm(255); + is( $rr->algorithm(), 255, 'algorithm number accepted' ); + $rr->algorithm('RSASHA1'); + is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); + is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); + is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); +} + + +{ + my @arg = qw(0 3 0 AA==); # per RFC8078(4), erratum 5049 + my $rr = new Net::DNS::RR("$name. $type @arg"); + ok( ref($rr), "DNSKEY delete: $name. $type @arg" ); + is( $rr->flags(), 0, 'DNSKEY delete: flags 0' ); + is( $rr->protocol(), 3, 'DNSKEY delete: protocol 3' ); + is( $rr->algorithm(), 0, 'DNSKEY delete: algorithm 0' ); + + is( $rr->string(), "$name.\tIN\t$type\t@arg", 'DNSKEY delete: presentation format' ); + + my $rdata = unpack 'H*', $rr->rdata(); + is( $rdata, '0000030000', 'DNSKEY delete: rdata wire-format' ); +} + + +{ + my @arg = qw(0 3 0 0); # per RFC8078(4) as published + my $rr = new Net::DNS::RR("$name. $type @arg"); + is( $rr->rdstring(), '0 3 0 AA==', 'DNSKEY delete: accept old format' ); +} + + +{ + my @arg = qw(0 0 0 -); # unexpected empty field + my $rr = new Net::DNS::RR("$name. $type @arg"); + is( $rr->rdstring(), '0 3 0 -', 'DNSKEY delete: represent empty key' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + + +exit; + diff --git a/t/05-CDS.t b/t/05-CDS.t new file mode 100644 index 0000000..c5e5a67 --- /dev/null +++ b/t/05-CDS.t @@ -0,0 +1,120 @@ +# $Id: 05-CDS.t 1586 2017-08-15 09:01:57Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 31; + + +use Net::DNS; + + +my $name = 'CDS.example'; +my $type = 'CDS'; +my $code = 59; +my @attr = qw( keytag algorithm digtype digest ); +my @data = ( 60485, 5, 1, '2bb183af5f22588179a53b0a98631fad1a292118' ); +my @also = qw( digestbin babble ); + +my $wire = join '', qw( EC45 05 01 2BB183AF5F22588179A53B0A98631FAD1A292118 ); + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name $type"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach ( @attr, 'rdstring' ) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + + $rr->algorithm(255); + is( $rr->algorithm(), 255, 'algorithm number accepted' ); + $rr->algorithm('RSASHA1'); + is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); + is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); + is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); + + $rr->digtype('SHA-256'); + is( $rr->digtype(), 2, 'digest type mnemonic accepted' ); + is( $rr->digtype('MNEMONIC'), 'SHA-256', 'rr->digtype("MNEMONIC") returns mnemonic' ); + is( $rr->digtype(), 2, 'rr->digtype("MNEMONIC") preserves value' ); +} + + +{ + my @arg = qw(0 0 0 00); # per RFC8078(4), erratum 5049 + my $rr = new Net::DNS::RR("$name. $type @arg"); + ok( ref($rr), "DS delete: $name. $type @arg" ); + is( $rr->keytag(), 0, 'DS delete: keytag 0' ); + is( $rr->algorithm(), 0, 'DS delete: algorithm 0' ); + is( $rr->digtype(), 0, 'DS delete: digtype 0' ); + + is( $rr->string(), "$name.\tIN\t$type\t@arg", 'DS delete: presentation format' ); + + my $rdata = unpack 'H*', $rr->rdata(); + is( $rdata, '0000000000', 'DS delete: rdata wire-format' ); +} + + +{ + my @arg = qw(0 0 0 0); # per RFC8078(4) as published + my $rr = new Net::DNS::RR("$name. $type @arg"); + is( $rr->rdstring(), '0 0 0 00', 'DS delete: accept old format' ); +} + + +{ + my @arg = qw(0 0 0 -); # unexpected empty field + my $rr = new Net::DNS::RR("$name. $type @arg"); + is( $rr->rdstring(), '0 0 0 -', 'DS delete: represent empty digest' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + + +exit; + diff --git a/t/05-CERT.t b/t/05-CERT.t new file mode 100644 index 0000000..713d937 --- /dev/null +++ b/t/05-CERT.t @@ -0,0 +1,108 @@ +# $Id: 05-CERT.t 1528 2017-01-18 21:44:58Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 24; + + +my $name = 'CERT.example'; +my $type = 'CERT'; +my $code = 37; +my @attr = qw( certtype keytag algorithm cert ); +my @data = qw( 1 2 3 MTIzNDU2Nzg5YWJjZGVmZ2hpamtsbW5vcHFyc3R1dnd4eXo= ); +my @also = qw( certificate format tag ); + +my $wire = '00010002033132333435363738396162636465666768696a6b6c6d6e6f707172737475767778797a'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + next if /certificate/; + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + is( Net::DNS::RR->new("foo IN CERT 0 2 3 foo=")->certtype, 0, 'certtype may be zero' ); + is( Net::DNS::RR->new("foo IN CERT 1 0 3 foo=")->keytag, 0, 'keytag may be zero' ); + is( Net::DNS::RR->new("foo IN CERT 1 2 0 foo=")->algorithm, 0, 'algorithm may be zero' ); + is( Net::DNS::RR->new("foo IN CERT 1 2 3 '' ")->cert, '', 'cert may be empty' ); +} + + +{ + my $rr = Net::DNS::RR->new("foo IN CERT 1 2 3 foo="); + is( $rr->algorithm('MNEMONIC'), 'DSA', 'algorithm mnemonic' ); + $rr->algorithm(255); + is( $rr->algorithm('MNEMONIC'), 255, 'algorithm with no mnemonic' ); + + eval { $rr->algorithm('X'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown mnemonic\t[$exception]" ); +} + + +{ + my $rr = Net::DNS::RR->new("foo IN CERT 1 2 3 foo="); + is( $rr->certtype('PKIX'), 1, 'valid certtype mnemonic' ); + eval { $rr->certtype('X'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown mnemonic\t[$exception]" ); +} + + +exit; + diff --git a/t/05-CNAME.t b/t/05-CNAME.t new file mode 100644 index 0000000..36b3a8d --- /dev/null +++ b/t/05-CNAME.t @@ -0,0 +1,87 @@ +# $Id: 05-CNAME.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 13; + + +use Net::DNS; + + +my $name = 'CNAME.example'; +my $type = 'CNAME'; +my $code = 5; +my @attr = qw( cname ); +my @data = qw( example.com ); +my @also = qw( ); + +my $wire = '076578616d706c6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed < length $predecessor, 'encoded RDATA compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-CSYNC.t b/t/05-CSYNC.t new file mode 100644 index 0000000..bd12917 --- /dev/null +++ b/t/05-CSYNC.t @@ -0,0 +1,90 @@ +# $Id: 05-CSYNC.t 1370 2015-07-01 13:48:40Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 20; + + +use Net::DNS; + + +my $name = 'alpha.example.com'; +my $type = 'CSYNC'; +my $code = 62; +my @attr = qw( SOAserial flags typelist); +my @data = qw( 66 3 A NS AAAA); +my @hash = ( 66, 3, q(A NS AAAA) ); +my @also = qw( immediate soaminimum ); + +my $wire = '000000420003000460000008'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @hash; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + my $a = join ' ', sort split /\s+/, $rr->$_; # typelist order unspecified + my $b = join ' ', sort split /\s+/, $hash->{$_}; + is( $a, $b, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } + + ok( $rr->immediate(1), 'set $rr->immediate' ); + ok( !$rr->immediate(0), 'clear $rr->immediate' ); + + ok( $rr->soaminimum(1), 'set $rr->soaminimum' ); + ok( !$rr->soaminimum(0), 'clear $rr->soaminimum' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + + +exit; + diff --git a/t/05-DHCID.t b/t/05-DHCID.t new file mode 100644 index 0000000..92be12e --- /dev/null +++ b/t/05-DHCID.t @@ -0,0 +1,99 @@ +# $Id: 05-DHCID.t 1559 2017-04-10 07:39:44Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 15; + + +my $name = 'DHCID.example'; +my $type = 'DHCID'; +my $code = 49; +my @attr = qw( identifiertype digesttype digest ); +my @data = ( 2, 1, pack 'H*', '4f6266757363617465644964656e7469747944617461' ); +my @also = qw( rdata ); + +my $wire = '0002014f6266757363617465644964656e7469747944617461'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + $rr->print; +} + + +exit; + diff --git a/t/05-DLV.t b/t/05-DLV.t new file mode 100644 index 0000000..7583003 --- /dev/null +++ b/t/05-DLV.t @@ -0,0 +1,71 @@ +# $Id: 05-DLV.t 1333 2015-03-03 19:39:52Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 13; + + +use Net::DNS; + + +my $name = 'DLV.example'; +my $type = 'DLV'; +my $code = 32769; +my @attr = qw( keytag algorithm digtype digest ); +my @data = ( 42495, 5, 1, '0ffbeba0831b10b8b83440dab81a2148576da9f6' ); +my @also = qw( digestbin babble ); + +my $wire = join '', qw( A5FF 05 01 0FFBEBA0831B10B8B83440DAB81A2148576DA9F6 ); + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name $type"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + + + $rr->algorithm('RSASHA512'); + is( $rr->algorithm(), 10, 'algorithm mnemonic accepted' ); + + $rr->digtype('SHA256'); + is( $rr->digtype(), 2, 'digest type mnemonic accepted' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} +exit; + diff --git a/t/05-DNAME.t b/t/05-DNAME.t new file mode 100644 index 0000000..41b4da1 --- /dev/null +++ b/t/05-DNAME.t @@ -0,0 +1,87 @@ +# $Id: 05-DNAME.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 14; + + +use Net::DNS; + + +my $name = 'DNAME.example'; +my $type = 'DNAME'; +my $code = 39; +my @attr = qw( target ); +my @data = qw( example.com ); +my @also = qw( dname ); + +my $wire = '076578616d706c6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-DNSKEY.t b/t/05-DNSKEY.t new file mode 100644 index 0000000..c3f31e2 --- /dev/null +++ b/t/05-DNSKEY.t @@ -0,0 +1,124 @@ +# $Id: 05-DNSKEY.t 1526 2017-01-16 09:17:54Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 32; + + +my $name = 'DNSKEY.example'; +my $type = 'DNSKEY'; +my $code = 48; +my @attr = qw( flags protocol algorithm publickey ); + +my @data = ( + 256, 3, 5, join '', qw( + AQPSKmynfzW4kyBv015MUG2DeIQ3 + Cbl+BBZH4b/0PY1kxkmvHjcZc8no + kfzj31GajIQKY+5CptLr3buXA10h + WqTkF7H6RfoRqXQeogmMHfpftf6z + Mv1LyBUgia7za6ZEzOJBOztyvhjL + 742iU/TpPSEDhm2SNKLijfUppn1U + aNvv4w== ) + ); +my @also = qw( keybin keylength keytag privatekeyname zone revoke sep ); + +my $wire = join '', qw( 010003050103D22A6CA77F35B893206FD35E4C506D8378843709B97E041647E1 + BFF43D8D64C649AF1E371973C9E891FCE3DF519A8C840A63EE42A6D2EBDDBB97 + 035D215AA4E417B1FA45FA11A9741EA2098C1DFA5FB5FEB332FD4BC8152089AE + F36BA644CCE2413B3B72BE18CBEF8DA253F4E93D2103866D9234A2E28DF529A6 + 7D5468DBEFE3 ); + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name NULL"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach ( @attr, qw(keylength keytag rdstring) ) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + my $class = ref($rr); + + $rr->algorithm(255); + is( $rr->algorithm(), 255, 'algorithm number accepted' ); + $rr->algorithm('RSASHA1'); + is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); + is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); + is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); + + eval { $rr->algorithm('X'); }; + my $exception1 = $1 if $@ =~ /^(.+)\n/; + ok( $exception1 ||= '', "unknown mnemonic\t[$exception1]" ); + + eval { $rr->algorithm(0); }; + my $exception2 = $1 if $@ =~ /^(.+)\n/; + ok( $exception2 ||= '', "disallowed algorithm 0\t[$exception2]" ); + + is( $class->algorithm('RSASHA256'), 8, 'class method algorithm("RSASHA256")' ); + is( $class->algorithm(8), 'RSASHA256', 'class method algorithm(8)' ); + is( $class->algorithm(255), 255, 'class method algorithm(255)' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + + +exit; + diff --git a/t/05-DS.t b/t/05-DS.t new file mode 100644 index 0000000..17e6cfd --- /dev/null +++ b/t/05-DS.t @@ -0,0 +1,158 @@ +# $Id: 05-DS.t 1595 2017-09-12 09:10:56Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 37; + + +use Net::DNS; + + +my $name = 'DS.example'; +my $type = 'DS'; +my $code = 43; +my @attr = qw( keytag algorithm digtype digest ); +my @data = ( 60485, 5, 1, '2bb183af5f22588179a53b0a98631fad1a292118' ); +my @also = qw( digestbin babble ); + +my $wire = join '', qw( EC45 05 01 2BB183AF5F22588179A53B0A98631FAD1A292118 ); + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name $type"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach ( @attr, 'rdstring' ) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + my $class = ref($rr); + + $rr->algorithm(255); + is( $rr->algorithm(), 255, 'algorithm number accepted' ); + $rr->algorithm('RSASHA1'); + is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); + is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); + is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); + + eval { $rr->algorithm('X'); }; + my $exception1 = $1 if $@ =~ /^(.+)\n/; + ok( $exception1 ||= '', "unknown mnemonic\t[$exception1]" ); + + eval { $rr->algorithm(0); }; + my $exception2 = $1 if $@ =~ /^(.+)\n/; + ok( $exception2 ||= '', "disallowed algorithm 0\t[$exception2]" ); + + is( $class->algorithm('RSASHA256'), 8, 'class method algorithm("RSASHA256")' ); + is( $class->algorithm(8), 'RSASHA256', 'class method algorithm(8)' ); + is( $class->algorithm(255), 255, 'class method algorithm(255)' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + my $class = ref($rr); + + $rr->digtype('SHA256'); + is( $rr->digtype(), 2, 'digest type mnemonic accepted' ); + is( $rr->digtype('MNEMONIC'), 'SHA-256', 'rr->digtype("MNEMONIC") returns mnemonic' ); + is( $rr->digtype(), 2, 'rr->digtype("MNEMONIC") preserves value' ); + + eval { $rr->digtype(0); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "disallowed digtype 0\t[$exception]" ); + + is( $class->digtype('SHA256'), 2, 'class method digtype("SHA256")' ); + is( $class->digtype(2), 'SHA-256', 'class method digtype(2)' ); + is( $class->digtype(255), 255, 'class method digtype(255)' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + eval { $rr->digest('123456789XBCDEF'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt hexadecimal\t[$exception]" ); +} + + +{ + my $keyrr = new Net::DNS::RR( type => 'DNSKEY', keybin => '' ); + eval { create Net::DNS::RR::DS( $keyrr, ( 'digtype' => 255 ) ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "create: wrong digtype\t[$exception]" ); +} + + +{ + my $keyrr = new Net::DNS::RR( type => 'DNSKEY', protocol => 0 ); + eval { create Net::DNS::RR::DS($keyrr); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "create: non-DNSSEC key\t[$exception]" ); +} + + +{ + my $keyrr = new Net::DNS::RR( type => 'DNSKEY', flags => 0x8000 ); + eval { create Net::DNS::RR::DS($keyrr); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "create: non-auth key\t[$exception]" ); +} + + +{ + my $keyrr = new Net::DNS::RR( type => 'DNSKEY', flags => 0x200 ); + eval { create Net::DNS::RR::DS($keyrr); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "create: non-ZONE key\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + + +exit; + diff --git a/t/05-EUI48.t b/t/05-EUI48.t new file mode 100644 index 0000000..e81ebc5 --- /dev/null +++ b/t/05-EUI48.t @@ -0,0 +1,66 @@ +# $Id: 05-EUI48.t 1139 2013-12-11 09:57:34Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 9; + + +use Net::DNS; + + +my $name = 'EUI48.example'; +my $type = 'EUI48'; +my $code = 108; +my @attr = qw( address ); +my @data = qw( 5e-ef-10-00-00-2a ); +my @also = qw( ); + +my $wire = '5eef1000002a'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + +exit; + diff --git a/t/05-EUI64.t b/t/05-EUI64.t new file mode 100644 index 0000000..dcd8ccc --- /dev/null +++ b/t/05-EUI64.t @@ -0,0 +1,66 @@ +# $Id: 05-EUI64.t 1139 2013-12-11 09:57:34Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 9; + + +use Net::DNS; + + +my $name = 'EUI64.example'; +my $type = 'EUI64'; +my $code = 109; +my @attr = qw( address ); +my @data = qw( 00-00-5e-ef-10-00-00-2a ); +my @also = qw( ); + +my $wire = '00005eef1000002a'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + +exit; + diff --git a/t/05-HINFO.t b/t/05-HINFO.t new file mode 100644 index 0000000..d0f35ec --- /dev/null +++ b/t/05-HINFO.t @@ -0,0 +1,75 @@ +# $Id: 05-HINFO.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 12; + + +use Net::DNS; + + +my $name = 'HINFO.example'; +my $type = 'HINFO'; +my $code = 13; +my @attr = qw( cpu os ); +my @data = qw( VAX-11/750 VMS ); +my @also = qw( ); + +my $wire = '0a5641582d31312f37353003564d53'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-HIP.t b/t/05-HIP.t new file mode 100644 index 0000000..f9c11cb --- /dev/null +++ b/t/05-HIP.t @@ -0,0 +1,138 @@ +# $Id: 05-HIP.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 24; + + +my $name = 'HIP.example'; +my $type = 'HIP'; +my $code = 55; +my @attr = qw( pkalgorithm hit key servers ); +my @data = qw( 2 200100107b1a74df365639cc39f1d578 + AwEAAbdxyhNuSutc5EMzxTs9LBPCIkOFH8cIvM4p9+LrV4e19WzK00+CI6zBCQTdtWsuxKbWIy87UOoJTwkUs7lBu+Upr1gsNrut79ryra+bSRGQb1slImA8YVJyuIDsj7kwzG7jnERNqnWxZ48AWkskmdHaVDP4BcelrTI3rMXdXF5D + rvs1.example.com + rvs2.example.com ); +my @also = qw( keybin ); + +my $wire = join '', qw( 10020084200100107b1a74df365639cc39f1d57803010001b771ca136e4aeb5c + e44333c53b3d2c13c22243851fc708bcce29f7e2eb5787b5f56ccad34f8223ac + c10904ddb56b2ec4a6d6232f3b50ea094f0914b3b941bbe529af582c36bbadef + daf2adaf9b4911906f5b2522603c615272b880ec8fb930cc6ee39c444daa75b1 + 678f005a4b2499d1da5433f805c7a5ad3237acc5dd5c5e430472767331076578 + 616d706c6503636f6d000472767332076578616d706c6503636f6d00 + ); + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + next if /server/; + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + for (qw(servers)) { + my ($rvs) = $rr->$_; # test limitation: single element list + is( $rvs, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); + + my @wire = unpack 'C*', $encoded; + $wire[length($empty) - 1]--; + my $wireformat = pack 'C*', @wire; + eval { decode Net::DNS::RR( \$wireformat ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt wire-format\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + eval { $rr->hit('123456789XBCDEF'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt hexadecimal\t[$exception]" ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + isnt( $rr->canonical, $lc->encode, 'canonical RDATA names not downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + is( $rr->pubkey, $rr->key, "historical 'pubkey'" ); + is( ref( $rr->rendezvousservers ), 'ARRAY', "historical 'rendezvousservers'" ); + $rr->print; +} + + +exit; + diff --git a/t/05-IPSECKEY.t b/t/05-IPSECKEY.t new file mode 100644 index 0000000..fb05335 --- /dev/null +++ b/t/05-IPSECKEY.t @@ -0,0 +1,152 @@ +# $Id: 05-IPSECKEY.t 1611 2018-01-02 09:41:24Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 39; + + +my $name = '38.2.0.192.in-addr.arpa'; +my $type = 'IPSECKEY'; +my $code = 45; +my @attr = qw( precedence gatetype algorithm gateway key ); +my @data = qw( 10 3 2 gateway.example.com AQNRU3mG7TVTO2BkR47usntb102uFJtugbo6BSGvgqt4AQ== ); +my @also = qw( pubkey keybin ); + +my $wire = +'0a03020767617465776179076578616d706c6503636f6d00010351537986ed35533b6064478eeeb27b5bd74dae149b6e81ba3a0521af82ab7801'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + isnt( $rr->canonical, $lc->encode, 'canonical RDATA names not downcased' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + foreach ( undef, qw(192.0.2.38 2001:db8:0:8002:0:0:2000:1 gateway.example.com) ) { + my $gateway = $_ || '.'; + $rr->gateway($gateway); + is( scalar( $rr->gateway ), $_, "rr->gateway( '$gateway' )" ); + my $rr2 = new Net::DNS::RR( $rr->string ); + is( $rr2->rdstring, $rr->rdstring, 'new/string transparent' ); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + is( $decoded->rdstring, $rr->rdstring, 'encode/decode transparent' ); + } +} + + +{ + my $rr = eval { new Net::DNS::RR( type => $type, gateway => 'X' ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unrecognised gateway type\t[$exception]" ); +} + + +{ + my $rr = eval { new Net::DNS::RR(". $type \\# 3 01ff05"); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception raised in decode\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + $rr->{gatetype} = 255; + eval { $rr->encode }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception raised in encode\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + $rr->{gatetype} = 255; + eval { my $gateway = $rr->gateway; }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception raised in gateway\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "$_ attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + +exit; + + diff --git a/t/05-ISDN.t b/t/05-ISDN.t new file mode 100644 index 0000000..9115ff3 --- /dev/null +++ b/t/05-ISDN.t @@ -0,0 +1,75 @@ +# $Id: 05-ISDN.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 13; + + +use Net::DNS; + + +my $name = 'ISDN.example'; +my $type = 'ISDN'; +my $code = 20; +my @attr = qw( address sa ); +my @data = qw( 150862028003217 004 ); +my @also = qw( ISDNaddress ); + +my $wire = '0f31353038363230323830303332313703303034'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-KEY.t b/t/05-KEY.t new file mode 100644 index 0000000..70e8ffa --- /dev/null +++ b/t/05-KEY.t @@ -0,0 +1,84 @@ +# $Id: 05-KEY.t 1354 2015-06-05 08:20:53Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 16; + + +my $name = 'KEY.example'; +my $type = 'KEY'; +my $code = 25; +my @attr = qw( flags protocol algorithm publickey ); +my @data = ( + 256, 3, 5, join '', qw( AQPSKmynfzW4kyBv015MUG2DeIQ3 + Cbl+BBZH4b/0PY1kxkmvHjcZc8no + kfzj31GajIQKY+5CptLr3buXA10h + WqTkF7H6RfoRqXQeogmMHfpftf6z + Mv1LyBUgia7za6ZEzOJBOztyvhjL + 742iU/TpPSEDhm2SNKLijfUppn1U + aNvv4w== ) + ); +my @also = qw( keybin keylength keytag privatekeyname zone revoke sep ); + +my $wire = join '', qw( 010003050103D22A6CA77F35B893206FD35E4C506D8378843709B97E041647E1 + BFF43D8D64C649AF1E371973C9E891FCE3DF519A8C840A63EE42A6D2EBDDBB97 + 035D215AA4E417B1FA45FA11A9741EA2098C1DFA5FB5FEB332FD4BC8152089AE + F36BA644CCE2413B3B72BE18CBEF8DA253F4E93D2103866D9234A2E28DF529A6 + 7D5468DBEFE3 ); + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name NULL"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); +} + + +exit; + + diff --git a/t/05-KX.t b/t/05-KX.t new file mode 100644 index 0000000..6966725 --- /dev/null +++ b/t/05-KX.t @@ -0,0 +1,87 @@ +# $Id: 05-KX.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 15; + + +use Net::DNS; + + +my $name = 'KX.example'; +my $type = 'KX'; +my $code = 36; +my @attr = qw( preference exchange ); +my @data = qw( 10 kx.example.com ); +my @also = qw( ); + +my $wire = '000a026b78076578616d706c6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-L32.t b/t/05-L32.t new file mode 100644 index 0000000..604e888 --- /dev/null +++ b/t/05-L32.t @@ -0,0 +1,75 @@ +# $Id: 05-L32.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 12; + + +use Net::DNS; + + +my $name = 'L32.example'; +my $type = 'L32'; +my $code = 105; +my @attr = qw( preference locator32 ); +my @data = qw( 10 10.1.2.0 ); +my @also = qw( ); + +my $wire = '000a0a010200'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-L64.t b/t/05-L64.t new file mode 100644 index 0000000..c71a332 --- /dev/null +++ b/t/05-L64.t @@ -0,0 +1,75 @@ +# $Id: 05-L64.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 12; + + +use Net::DNS; + + +my $name = 'L64.example'; +my $type = 'L64'; +my $code = 106; +my @attr = qw( preference locator64 ); +my @data = qw( 10 2001:db8:1140:1000 ); +my @also = qw( ); + +my $wire = '000a20010db811401000'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-LOC.t b/t/05-LOC.t new file mode 100644 index 0000000..e508ba3 --- /dev/null +++ b/t/05-LOC.t @@ -0,0 +1,76 @@ +# $Id: 05-LOC.t 1390 2015-09-11 11:42:11Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 24; + + +use Net::DNS; + + +my $name = 'LOC.example'; +my $type = 'LOC'; +my $code = 29; +my @attr = qw( latitude longitude altitude size hp vp ); +my @data = qw( 42.35799 -71.014338 -44 2000 10 10 ); +my @also = qw( version latlon horiz_pre vert_pre ); + +my $wire = '002513138916cb3c70c310df00988550'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-LP.t b/t/05-LP.t new file mode 100644 index 0000000..be930e8 --- /dev/null +++ b/t/05-LP.t @@ -0,0 +1,89 @@ +# $Id: 05-LP.t 1381 2015-08-25 07:36:09Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 17; + + +use Net::DNS; + + +my $name = 'LP.example'; +my $type = 'LP'; +my $code = 107; +my @attr = qw( preference target ); +my @data = qw( 10 locator.example.com ); +my @also = qw( FQDN fqdn ); + +my $wire = join '', qw( 000a076c6f6361746f72076578616d706c6503636f6d00 ); + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + isnt( $rr->canonical, $lc->encode, 'canonical RDATA names not downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-MINFO.t b/t/05-MINFO.t new file mode 100644 index 0000000..c563ccf --- /dev/null +++ b/t/05-MINFO.t @@ -0,0 +1,87 @@ +# $Id: 05-MINFO.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 15; + + +use Net::DNS; + + +my $name = 'MINFO.example'; +my $type = 'MINFO'; +my $code = 14; +my @attr = qw( rmailbx emailbx ); +my @data = qw( rp@example.com rp@example.net ); +my @also = qw( ); + +my $wire = '027270076578616d706c6503636f6d00027270076578616d706c65036e657400'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed < length $predecessor, 'encoded RDATA compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-MX.t b/t/05-MX.t new file mode 100644 index 0000000..386a7fa --- /dev/null +++ b/t/05-MX.t @@ -0,0 +1,91 @@ +# $Id: 05-MX.t 1354 2015-06-05 08:20:53Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 18; + + +use Net::DNS; + + +my $name = 'MX.example'; +my $type = 'MX'; +my $code = 15; +my @attr = qw( preference exchange ); +my @data = qw( 10 mx.example.com ); +my @also = qw( ); + +my $wire = '000a026d78076578616d706c6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed < length $predecessor, 'encoded RDATA compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ ## incomplete RR (specimen test for widely used constructs) + my $empty = new Net::DNS::RR( type => $type ); + is( $empty->preference, 0, 'unspecified integer returns 0 (not default value)' ); + is( $empty->exchange, undef, 'unspecified domain name returns undefined' ); + + my $part = new Net::DNS::RR( type => $type, exchange => 'mx.example' ); + is( $part->preference, 10, 'unspecified integer returns default value' ); + ok( $part->exchange, 'domain name defined as expected' ); + is( $part->preference(0), 0, 'zero integer replaces default value' ); +} + + +exit; + diff --git a/t/05-NAPTR.t b/t/05-NAPTR.t new file mode 100644 index 0000000..197e76a --- /dev/null +++ b/t/05-NAPTR.t @@ -0,0 +1,87 @@ +# $Id: 05-NAPTR.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 23; + + +use Net::DNS; + + +my $name = '2.1.2.1.5.5.5.0.7.7.1.e164.arpa.'; +my $type = 'NAPTR'; +my $code = 35; +my @attr = qw( order preference flags service regexp replacement ); +my @data = qw( 100 10 u sip+E2U !^.*$!sip:information@foo.se!i . ); +my @also = qw( ); + +my $wire = '0064000a0175077369702b4532551e215e2e2a24217369703a696e666f726d6174696f6e40666f6f2e7365216900'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR('. NAPTR 100 50 "s" "http+N2L+N2C+N2R" "" www.example.com.'); + my $rr = new Net::DNS::RR('. NAPTR 100 50 "s" "http+N2L+N2C+N2R" "" WWW.EXAMPLE.COM.'); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-NID.t b/t/05-NID.t new file mode 100644 index 0000000..a838792 --- /dev/null +++ b/t/05-NID.t @@ -0,0 +1,75 @@ +# $Id: 05-NID.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 12; + + +use Net::DNS; + + +my $name = 'NID.example'; +my $type = 'NID'; +my $code = 104; +my @attr = qw( preference nodeid ); +my @data = qw( 10 0014:4fff:ff20:ee64 ); +my @also = qw( ); + +my $wire = '000a00144fffff20ee64'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-NS.t b/t/05-NS.t new file mode 100644 index 0000000..6c788f6 --- /dev/null +++ b/t/05-NS.t @@ -0,0 +1,87 @@ +# $Id: 05-NS.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 13; + + +use Net::DNS; + + +my $name = 'NS.example'; +my $type = 'NS'; +my $code = 2; +my @attr = qw( nsdname ); +my @data = qw( ns.example.com ); +my @also = qw( ); + +my $wire = '026e73076578616d706c6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed < length $predecessor, 'encoded RDATA compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-NSEC.t b/t/05-NSEC.t new file mode 100644 index 0000000..3822ab8 --- /dev/null +++ b/t/05-NSEC.t @@ -0,0 +1,97 @@ +# $Id: 05-NSEC.t 1595 2017-09-12 09:10:56Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 16; + + +use Net::DNS; + + +my $name = 'alpha.example.com'; +my $type = 'NSEC'; +my $code = 47; +my @attr = qw( nxtdname typelist); +my @data = qw( host.example.com A NS NSEC RRSIG SOA ); +my @hash = ( qw( host.example.com ), q(A NS NSEC RRSIG SOA) ); +my @also = qw( ); + +my $wire = '04686f7374076578616d706c6503636f6d000006620000000003'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @hash; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + my $a = join ' ', sort split /\s+/, $rr->$_; # typelist order unspecified + my $b = join ' ', sort split /\s+/, $hash->{$_}; + is( $a, $b, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( !length $compressed < length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + isnt( $rr->canonical, $lc->encode, 'canonical RDATA names not downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + $rr->typebm(''); + is( $rr->typebm(), '', "historical 'typebm'" ); +} + + +exit; + diff --git a/t/05-NSEC3.t b/t/05-NSEC3.t new file mode 100644 index 0000000..1b29fb2 --- /dev/null +++ b/t/05-NSEC3.t @@ -0,0 +1,106 @@ +# $Id: 05-NSEC3.t 1389 2015-09-09 13:09:43Z willem $ -*-perl-*- +# + +use strict; +use Test::More tests => 26; +use Net::DNS; + + +my $name = '0p9mhaveqvm6t7vbl5lop2u3t2rp3tom.example'; +my $type = 'NSEC3'; +my $code = 50; +my @attr = qw( algorithm flags iterations salt hnxtname typelist ); +my @data = qw( 1 1 12 aabbccdd 2t7b4g4vsa5smi47k61mv5bv1a22bojr NS SOA MX RRSIG DNSKEY NSEC3PARAM ); +my @hash = ( qw( 1 1 12 aabbccdd 2t7b4g4vsa5smi47k61mv5bv1a22bojr ), q(NS SOA MX RRSIG DNSKEY NSEC3PARAM) ); +my @also = qw( hashalgo optout ); + +my $wire = '0101000c04aabbccdd14174eb2409fe28bcb4887a1836f957f0a8425e27b000722010000000290'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @hash; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + my $a = join ' ', sort split /\s+/, $rr->$_; # typelist order unspecified + my $b = join ' ', sort split /\s+/, $hash->{$_}; + is( $a, $b, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my @rdata = qw(1 1 12 - 2t7b4g4vsa5smi47k61mv5bv1a22bojr A); + my $rr = new Net::DNS::RR(". $type @rdata"); + my $class = ref($rr); + + $rr->algorithm('SHA-1'); + is( $rr->algorithm(), 1, 'algorithm mnemonic accepted' ); + is( $rr->algorithm('MNEMONIC'), 'SHA-1', "rr->algorithm('MNEMONIC')" ); + is( $class->algorithm('SHA-1'), 1, "class method algorithm('SHA-1')" ); + is( $class->algorithm(1), 'SHA-1', "class method algorithm(1)" ); + is( $class->algorithm(255), 255, "class method algorithm(255)" ); + + eval { $rr->algorithm('X'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown mnemonic\t[$exception]" ); +} + + +{ + my @rdata = qw(1 1 12 - 2t7b4g4vsa5smi47k61mv5bv1a22bojr A); + my $rr = new Net::DNS::RR(". $type @rdata"); + is( $rr->salt, '', 'parse RR with salt field placeholder' ); + is( $rr->rdstring, "@rdata", 'placeholder denotes empty salt field' ); + is( unpack( 'H*', $rr->saltbin ), '', 'null salt binary value' ); + + eval { $rr->salt('123456789XBCDEF'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt hexadecimal\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + +exit; + + diff --git a/t/05-NSEC3PARAM.t b/t/05-NSEC3PARAM.t new file mode 100644 index 0000000..0e99c17 --- /dev/null +++ b/t/05-NSEC3PARAM.t @@ -0,0 +1,93 @@ +# $Id: 05-NSEC3PARAM.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 22; + + +use Net::DNS; + + +my $name = 'example'; +my $type = 'NSEC3PARAM'; +my $code = 51; +my @attr = qw( algorithm flags iterations salt ); +my @data = qw( 1 1 12 aabbccdd ); +my @also = qw( hashalgo ); + +my $wire = '0101000c04aabbccdd'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + # check parsing of RR with null salt (RT#95034) + my $string = 'nosalt.example. IN NSEC3PARAM 2 0 12 -'; + my $rr = eval { Net::DNS::RR->new($string) }; + diag $@ if $@; + ok( $rr, 'NSEC3PARAM created with null salt' ); + is( $rr->salt, '', 'NSEC3PARAM null salt value' ); + is( unpack( 'H*', $rr->saltbin ), '', 'NSEC3PARAM null salt binary value' ); + is( $rr->string, $string, 'NSEC3PARAM null salt binary value' ); +} + + +{ + my $rr = eval { Net::DNS::RR->new('corrupt.example NSEC3PARAM 2 0 12 aabbccfs') }; + ok( !$rr, 'NSEC3PARAM not created with corrupt hex data' ); +} + + +exit; + diff --git a/t/05-NULL.t b/t/05-NULL.t new file mode 100644 index 0000000..cb73ac6 --- /dev/null +++ b/t/05-NULL.t @@ -0,0 +1,71 @@ +# $Id: 05-NULL.t 1340 2015-04-28 11:39:55Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 10; + + +use Net::DNS; + + +my $name = 'NULL.example'; +my $type = 'NULL'; +my $code = 10; +my @attr = qw( ); +my @data = ('\# 4 61626364'); +my @also = qw( rdlength rdata ); + +my $wire = '61626364'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + rdata => 'arbitrary data', + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +exit; + diff --git a/t/05-OPENPGPKEY.t b/t/05-OPENPGPKEY.t new file mode 100644 index 0000000..77436e9 --- /dev/null +++ b/t/05-OPENPGPKEY.t @@ -0,0 +1,92 @@ +# $Id: 05-OPENPGPKEY.t 1597 2017-09-22 08:04:02Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 8; + + +my $name = '8d5730bd8d76d417bf974c03f59eedb7af98cb5c3dc73ea8ebbd54b7._openpgpkey.example.com'; +my $type = 'OPENPGPKEY'; +my $code = 61; +my @attr = qw( key ); +my @data = join '', qw( + AQPSKmynfzW4kyBv015MUG2DeIQ3Cbl+BBZH4b/0PY1kxkmvHjcZc8nokfzj31GajIQKY+5CptLr + 3buXA10hWqTkF7H6RfoRqXQeogmMHfpftf6zMv1LyBUgia7za6ZEzOJBOztyvhjL742iU/TpPSED + hm2SNKLijfUppn1UaNvv4w== ); +my @also = qw( keybin ); + +my $wire = join '', qw( 0103D22A6CA77F35B893206FD35E4C506D8378843709B97E041647E1 + BFF43D8D64C649AF1E371973C9E891FCE3DF519A8C840A63EE42A6D2EBDDBB97 + 035D215AA4E417B1FA45FA11A9741EA2098C1DFA5FB5FEB332FD4BC8152089AE + F36BA644CCE2413B3B72BE18CBEF8DA253F4E93D2103866D9234A2E28DF529A6 + 7D5468DBEFE3 ); + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name $type")->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + +exit; + + diff --git a/t/05-OPT.t b/t/05-OPT.t new file mode 100644 index 0000000..2ecc8f8 --- /dev/null +++ b/t/05-OPT.t @@ -0,0 +1,208 @@ +# $Id: 05-OPT.t 1543 2017-02-28 19:27:23Z willem $ -*-perl-*- + +use strict; +use Test::More; + +use Net::DNS; +use Net::DNS::Parameters; + +my @opt = keys %Net::DNS::Parameters::ednsoptionbyval; + +plan tests => 42 + scalar(@opt); + + +my $name = '.'; +my $type = 'OPT'; +my $code = 41; +my @attr = qw( size rcode flags ); +my @data = qw( 1280 0 32768 ); +my @also = qw( version ); + +my $wire = '0000290500000080000000'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR( name => '.', type => $type )->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + like( $string, '/EDNS/', 'string method works' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + my $value = $rr->$_; + ok( defined $rr->$_, "additional attribute rr->$_()" ); + } + + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $encoded; + my $hex2 = uc unpack 'H*', $decoded->encode; + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex1, $wire, 'encoded RDATA matches example' ); +} + + +{ + my $rr = new Net::DNS::RR( name => '.', type => $type ); + foreach (@attr) { + my $initial = 0x5A5; + my $changed = 0xA5A; + $rr->{$_} = $initial; + is( $rr->$_($changed), $changed, "rr->$_(x) returns function argument" ); + is( $rr->$_(), $changed, "rr->$_(x) changes attribute value" ); + } +} + + +foreach my $method (qw(class ttl)) { + my $rr = new Net::DNS::RR( name => '.', type => $type ); + eval { + local $SIG{__WARN__} = sub { die @_ }; + $rr->$method(1); + }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "$method method:\t[$exception]" ); + + eval { + local $SIG{__WARN__} = sub { die @_ }; + $rr->$method(0); + }; + my $repeated = $1 if $@ =~ /^(.+)\n/; + ok( !$repeated, "$method exception not repeated $@" ); +} + + +{ + my $rr = new Net::DNS::RR( name => '.', type => $type, rcode => 16 ); + $rr->{rdlength} = 0; # inbound OPT RR only + like( $rr->string, '/BADVER/', 'opt->rcode(16)' ); +} + + +{ + my $rr = new Net::DNS::RR( name => '.', type => $type, rcode => 1 ); + like( $rr->string, '/NOERROR/', 'opt->rcode(1)' ); +} + + +{ + my $edns = new Net::DNS::RR( name => '.', type => $type ); + + ok( ref($edns), 'new OPT RR created' ); + + is( scalar( $edns->options ), 0, 'EDNS option list initially empty' ); + + ok( !$edns->_format_option(0), 'format non-existent option(0)' ); + + my $non_existent = $edns->option(0); + is( $non_existent, undef, '$undef = option(0)' ); + + my @non_existent = $edns->option(0); + is( scalar(@non_existent), 0, '@empty = option(0)' ); + + ok( !$edns->_specified, 'state unmodified by existence probes' ); + + $edns->option( 0 => '' ); + is( scalar( $edns->options ), 1, 'insert EDNS option' ); + + $edns->option( 0 => undef ); + is( scalar( $edns->options ), 0, 'delete EDNS option' ); + + + foreach my $option ( sort { $a <=> $b } keys %Net::DNS::Parameters::ednsoptionbyval ) { + $edns->option( $option => 'rawbytes' ); + } + + + $edns->option( 4 => '' ); + is( length( $edns->option(4) ), 0, "option 4 => ''" ); + + + $edns->option( DAU => [1, 2, 3, 4] ); + is( length( $edns->option(5) ), 4, 'option DAU => (1, 2, 3, 4)' ); + + + $edns->option( 8 => ( pack 'H*', '000120007b7b7b7b' ) ); + my %option8 = $edns->option(8); + $edns->option( 'CLIENT-SUBNET' => (%option8) ); + is( length( $edns->option(8) ), 8, "option CLIENT-SUBNET => (%option8)" ); + $edns->option( 'CLIENT-SUBNET' => {%option8, 'SOURCE-PREFIX-LENGTH' => 15} ); + is( length( $edns->option(8) ), 6, "option CLIENT-SUBNET => {'SOURCE-PREFIX-LENGTH' => 15, ...}" ); + + + my $timer = 604800; + my $option9 = $edns->option( EXPIRE => ( 'EXPIRE-TIMER' => $timer ) ); + is( scalar( $edns->option(9) ), $option9, "option EXPIRE => ('EXPIRE-TIMER' => $timer)" ); + + + my $client = $edns->option( COOKIE => ( 'CLIENT-COOKIE' => 'rawbytes' ) ); + is( length( $edns->option(10) ), 8, "option COOKIE => ('CLIENT-COOKIE' => ... )" ); + + my %option10 = $edns->option(10); + $edns->option( COOKIE => {%option10, 'SERVER-COOKIE' => 'cookedbytes'} ); + is( length( $edns->option(10) ), 19, "option COOKIE => {'SERVER-COOKIE' => ... }" ); + + + my $t = 200; + my $option11 = $edns->option( 'TCP-KEEPALIVE' => ( TIMEOUT => $t ) ); + is( scalar( $edns->option(11) ), $option11, "option TCP-KEEPALIVE => (TIMEOUT => $t)" ); + + + $edns->option( PADDING => ( 'OPTION-LENGTH' => 100 ) ); + is( length( $edns->option(12) ), 100, "option PADDING => ('OPTION-LENGTH' => 100)" ); + + + $edns->option( CHAIN => ( 'TRUST-POINT' => '' ) ); + is( length( $edns->option(13) ), 0, "option CHAIN => ''" ); + + my $option13 = $edns->option( CHAIN => ( 'TRUST-POINT' => 'com.' ) ); + is( scalar( $edns->option(13) ), $option13, "option CHAIN => ('TRUST-POINT' => 'com.')" ); + + + foreach my $option ( sort { $a <=> $b } keys %Net::DNS::Parameters::ednsoptionbyval ) { + my $content = $edns->option($option); # check option interpretation + + my @interpretation = $edns->option($option); + $edns->option( $option => (@interpretation) ); + + my $uninterpreted = $edns->option($option); + is( $uninterpreted, $content, "compose/decompose option $option" ); + } + + + eval { $edns->option( 65001 => ( '', '' ) ) }; + chomp $@; + ok( $@, "unable to compose option:\t[$@]" ); + + + my $bogus = 'BOGUS-OPTION'; + eval { ednsoptionbyname($bogus) }; + chomp $@; + ok( $@, "ednsoptionbyname($bogus)\t[$@]" ); + + + my $options = $edns->options; + my $encoded = $edns->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my @result = $decoded->options; + is( scalar(@result), $options, 'expected number of options' ); + + $edns->print; +} + + +exit; + diff --git a/t/05-PTR.t b/t/05-PTR.t new file mode 100644 index 0000000..4e0781a --- /dev/null +++ b/t/05-PTR.t @@ -0,0 +1,87 @@ +# $Id: 05-PTR.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 13; + + +use Net::DNS; + + +my $name = '1.2.0.192.in-addr.arpa'; +my $type = 'PTR'; +my $code = 12; +my @attr = qw( ptrdname ); +my @data = qw( example.com ); +my @also = qw( ); + +my $wire = '076578616d706c6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed < length $predecessor, 'encoded RDATA compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-PX.t b/t/05-PX.t new file mode 100644 index 0000000..047b0a1 --- /dev/null +++ b/t/05-PX.t @@ -0,0 +1,87 @@ +# $Id: 05-PX.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 17; + + +use Net::DNS; + + +my $name = '*.net2.it'; +my $type = 'PX'; +my $code = 26; +my @attr = qw( preference map822 mapx400 ); +my @data = qw( 10 net2.it PRMD-net2.ADMDb.C-it ); +my @also = qw( ); + +my $wire = '000a046e657432026974000950524d442d6e6574320541444d446204432d697400'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-RP.t b/t/05-RP.t new file mode 100644 index 0000000..40db76b --- /dev/null +++ b/t/05-RP.t @@ -0,0 +1,87 @@ +# $Id: 05-RP.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 15; + + +use Net::DNS; + + +my $name = 'RP.example'; +my $type = 'RP'; +my $code = 17; +my @attr = qw( mbox txtdname ); +my @data = qw( rp@example.com txt.example.net ); +my @also = qw( ); + +my $wire = '027270076578616d706c6503636f6d0003747874076578616d706c65036e657400'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-RRSIG.t b/t/05-RRSIG.t new file mode 100644 index 0000000..4488598 --- /dev/null +++ b/t/05-RRSIG.t @@ -0,0 +1,198 @@ +# $Id: 05-RRSIG.t 1528 2017-01-18 21:44:58Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + Time::Local + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 73; + + +my $name = 'net-dns.org'; +my $type = 'RRSIG'; +my $code = 46; +my @attr = qw( typecovered algorithm labels orgttl sigexpiration siginception keytag signame signature ); +my @data = ( + qw( NS 7 2 3600 20130914141655 20130815141655 60909 net-dns.org ), + join '', qw( IRlCjYNZCkddjoFw6UGxAga/EvxgENl+IESuyRH9vlrys + yqne0gPpclC++raP3+yRA+gDIHrMkIwsLudqod4iuoA73 + Mw1NxETS6lm2eQTDNzLSY6dnJxZBqXypC3Of7bF3UmR/G + NhcFIThuV/qFq+Gs+g0TJ6eyMF6ydYhjS31k= ) + ); +my @also = qw( sig sigin sigex vrfyerrstr ); + +my $wire = +'0002070200000E1052346FD7520CE2D7EDED076E65742D646E73036F7267002119428D83590A475D8E8170E941B10206BF12FC6010D97E2044AEC911FDBE5AF2B32AA77B480FA5C942FBEADA3F7FB2440FA00C81EB324230B0BB9DAA87788AEA00EF7330D4DC444D2EA59B67904C33732D263A767271641A97CA90B739FEDB17752647F18D85C1484E1B95FEA16AF86B3E8344C9E9EC8C17AC9D6218D2DF59'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name $type"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); +} + + +{ + my @rdata = @data; + my $sig = pop @rdata; + my $lc = new Net::DNS::RR( lc(". $type @rdata ") . $sig ); + my $rr = new Net::DNS::RR( uc(". $type @rdata ") . $sig ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + is( $rr->encode, $lc->encode, 'encoded RDATA names downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach ( @attr, 'rdstring' ) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + my $class = ref($rr); + + $rr->algorithm(255); + is( $rr->algorithm(), 255, 'algorithm number accepted' ); + $rr->algorithm('RSASHA1'); + is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); + is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); + is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); + + eval { $rr->algorithm('X'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown mnemonic\t[$exception]" ); + + is( $class->algorithm('RSASHA256'), 8, 'class method algorithm("RSASHA256")' ); + is( $class->algorithm(8), 'RSASHA256', 'class method algorithm(8)' ); + is( $class->algorithm(255), 255, 'class method algorithm(255)' ); +} + + +{ + my $object = new Net::DNS::RR( type => $type ); + my $class = ref($object); + my $scalar = ''; + my %testcase = ( ## test callable with invalid arguments + '_CreateSig' => [$object, $scalar, $object], + '_CreateSigData' => [$object, $scalar], + '_string2time' => [undef], + '_time2string' => [undef], + '_VerifySig' => [$object, $object, $object], + 'create' => [$class, $scalar, $object], + 'verify' => [$object, $object, $object], + ); + + foreach my $method ( sort keys %testcase ) { + my $arglist = $testcase{$method}; + $object->{algorithm} = 0; # induce exception + no strict q/refs/; + my $subroutine = join '::', $class, $method; + eval { &$subroutine(@$arglist); }; + my $exception = $1 if $@ =~ /^(.*)\n*/; + ok( defined $exception, "$method method callable\t[$exception]" ); + } +} + + +{ + my %testcase = ( ## test time conversion edge cases + -1 => '21060207062815', + 0x00000000 => '19700101000000', + 0x7fffffff => '20380119031407', + 0x80000000 => '20380119031408', + 0xf4d41f7f => '21000228235959', + 0xf4d41f80 => '21000301000000', + 0xffffffff => '21060207062815', + ); + + foreach my $time ( sort keys %testcase ) { + my $string = $testcase{$time}; + my $result = Net::DNS::RR::RRSIG::_time2string($time); + is( $result, $string, "_time2string($time)" ); + + # Test indirectly: $timeval can be 64-bit or negative 32-bit integer + my $timeval = Net::DNS::RR::RRSIG::_string2time($string); + my $timestr = Net::DNS::RR::RRSIG::_time2string($timeval); + is( $timestr, $string, "_string2time($string)" ); + } + + my $timenow = time(); + my $timeval = Net::DNS::RR::RRSIG::_string2time($timenow); + is( $timeval, $timenow, "_string2time( time() )\t$timeval" ); +} + + +{ + ok( Net::DNS::RR::RRSIG::_ordered( undef, 0 ), '_ordered( undef, 0 )' ); + ok( Net::DNS::RR::RRSIG::_ordered( 0, 1 ), '_ordered( 0, 1 )' ); + ok( Net::DNS::RR::RRSIG::_ordered( 0x7fffffff, 0x80000000 ), '_ordered( 0x7fffffff, 0x80000000 )' ); + ok( Net::DNS::RR::RRSIG::_ordered( 0xffffffff, 0 ), '_ordered( 0xffffffff, 0 )' ); + ok( Net::DNS::RR::RRSIG::_ordered( -2, -1 ), '_ordered( -2, -1 )' ); + ok( Net::DNS::RR::RRSIG::_ordered( -1, 0 ), '_ordered( -1, 0 )' ); + ok( !Net::DNS::RR::RRSIG::_ordered( undef, undef ), '!_ordered( undef, undef )' ); + ok( !Net::DNS::RR::RRSIG::_ordered( 0, undef ), '!_ordered( 0, undef )' ); + ok( !Net::DNS::RR::RRSIG::_ordered( 0x80000000, 0x7fffffff ), '!_ordered( 0x80000000, 0x7fffffff )' ); + ok( !Net::DNS::RR::RRSIG::_ordered( 0, 0xffffffff ), '!_ordered( 0, 0xffffffff )' ); + ok( !Net::DNS::RR::RRSIG::_ordered( -1, -2 ), '!_ordered( -1, -2 )' ); + ok( !Net::DNS::RR::RRSIG::_ordered( 0, -1 ), '!_ordered( 0, -1 )' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + +exit; + + diff --git a/t/05-RT.t b/t/05-RT.t new file mode 100644 index 0000000..1a509c8 --- /dev/null +++ b/t/05-RT.t @@ -0,0 +1,89 @@ +# $Id: 05-RT.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 16; + + +BEGIN { + use_ok('Net::DNS'); +} + + +my $name = '*.prime.com'; +my $type = 'RT'; +my $code = 21; +my @attr = qw( preference intermediate ); +my @data = qw( 90 relay.prime.com ); +my @also = qw( ); + +my $wire = '005a0572656c6179057072696d6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-SIG.t b/t/05-SIG.t new file mode 100644 index 0000000..cdc29c6 --- /dev/null +++ b/t/05-SIG.t @@ -0,0 +1,204 @@ +# $Id: 05-SIG.t 1528 2017-01-18 21:44:58Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + Time::Local + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 75; + + +my $name = '.'; +my $type = 'SIG'; +my $code = 24; +my @attr = qw( typecovered algorithm labels orgttl sigexpiration siginception keytag signame signature ); +my @data = ( + qw( TYPE0 1 0 0 20150814181655 20150814181155 2871 rsamd5.example ), + join '', qw( GOjsIo2JXz2ASClRhdbD5W+IYkq+Eo5iF9l3R+LYS/14Q + fxqX2M9YHPvuLfz5ORAdnqyuKJTi3/LsrHmF/cUzwY3UM + ZJDeGce77WiUJlR93VRKZ4fTs/wPP7JHxgAIhhlYFB4xs + vISZr/tgvblxwJSpa4pJIahUuitfaiijFwQw= ) + ); +my @also = qw( sig sigex sigin vrfyerrstr _size ); + +my $wire = +'000001000000000055CE309755CE2F6B0B37067273616D6435076578616D706C650018E8EC228D895F3D8048295185D6C3E56F88624ABE128E6217D97747E2D84BFD7841FC6A5F633D6073EFB8B7F3E4E440767AB2B8A2538B7FCBB2B1E617F714CF063750C6490DE19C7BBED689426547DDD544A6787D3B3FC0F3FB247C60008861958141E31B2F21266BFED82F6E5C70252A5AE292486A152E8AD7DA8A28C5C10C'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name $type"); + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + + my @wire = unpack 'C*', $encoded; + my $wireformat = pack 'C*', @wire, 0; + eval { decode Net::DNS::RR( \$wireformat ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "misplaced SIG RR\t[$exception]" ); +} + + +{ + my @rdata = @data; + my $sig = pop @rdata; + my $lc = new Net::DNS::RR( lc(". $type @rdata ") . $sig ); + my $rr = new Net::DNS::RR( uc(". $type @rdata ") . $sig ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + is( $rr->encode, $lc->encode, 'encoded RDATA names downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach ( @attr, 'rdstring' ) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + my $class = ref($rr); + + $rr->algorithm(255); + is( $rr->algorithm(), 255, 'algorithm number accepted' ); + $rr->algorithm('RSASHA1'); + is( $rr->algorithm(), 5, 'algorithm mnemonic accepted' ); + is( $rr->algorithm('MNEMONIC'), 'RSASHA1', 'rr->algorithm("MNEMONIC") returns mnemonic' ); + is( $rr->algorithm(), 5, 'rr->algorithm("MNEMONIC") preserves value' ); + + eval { $rr->algorithm('X'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown mnemonic\t[$exception]" ); + + is( $class->algorithm('RSASHA256'), 8, 'class method algorithm("RSASHA256")' ); + is( $class->algorithm(8), 'RSASHA256', 'class method algorithm(8)' ); + is( $class->algorithm(255), 255, 'class method algorithm(255)' ); +} + + +{ + my $object = new Net::DNS::RR(". $type"); + my $class = ref($object); + my $scalar = ''; + my %testcase = ( ## test callable with invalid arguments + '_CreateSig' => [$object, $scalar, $object], + '_CreateSigData' => [$object, $object], + '_string2time' => [undef], + '_time2string' => [undef], + '_VerifySig' => [$object, $object, $object], + 'create' => [$class, $scalar, $object], + 'verify' => [$object, $object, $object], + ); + + foreach my $method ( sort keys %testcase ) { + my $arglist = $testcase{$method}; + $object->{algorithm} = 0; # induce exception + no strict q/refs/; + my $subroutine = join '::', $class, $method; + eval { &$subroutine(@$arglist); }; + my $exception = $1 if $@ =~ /^(.*)\n*/; + ok( defined $exception, "$method method callable\t[$exception]" ); + } +} + + +{ + my %testcase = ( ## test time conversion edge cases + -1 => '21060207062815', + 0x00000000 => '19700101000000', + 0x7fffffff => '20380119031407', + 0x80000000 => '20380119031408', + 0xf4d41f7f => '21000228235959', + 0xf4d41f80 => '21000301000000', + 0xffffffff => '21060207062815', + ); + + foreach my $time ( sort keys %testcase ) { + my $string = $testcase{$time}; + my $result = Net::DNS::RR::SIG::_time2string($time); + is( $result, $string, "_time2string($time)" ); + + # Test indirectly: $timeval can be 64-bit or negative 32-bit integer + my $timeval = Net::DNS::RR::SIG::_string2time($string); + my $timestr = Net::DNS::RR::SIG::_time2string($timeval); + is( $timestr, $string, "_string2time($string)" ); + } + + my $timenow = time(); + my $timeval = Net::DNS::RR::SIG::_string2time($timenow); + is( $timeval, $timenow, "_string2time( time() )\t$timeval" ); +} + + +{ + ok( Net::DNS::RR::SIG::_ordered( undef, 0 ), '_ordered( undef, 0 )' ); + ok( Net::DNS::RR::SIG::_ordered( 0, 1 ), '_ordered( 0, 1 )' ); + ok( Net::DNS::RR::SIG::_ordered( 0x7fffffff, 0x80000000 ), '_ordered( 0x7fffffff, 0x80000000 )' ); + ok( Net::DNS::RR::SIG::_ordered( 0xffffffff, 0 ), '_ordered( 0xffffffff, 0 )' ); + ok( Net::DNS::RR::SIG::_ordered( -2, -1 ), '_ordered( -2, -1 )' ); + ok( Net::DNS::RR::SIG::_ordered( -1, 0 ), '_ordered( -1, 0 )' ); + ok( !Net::DNS::RR::SIG::_ordered( undef, undef ), '!_ordered( undef, undef )' ); + ok( !Net::DNS::RR::SIG::_ordered( 0, undef ), '!_ordered( 0, undef )' ); + ok( !Net::DNS::RR::SIG::_ordered( 0x80000000, 0x7fffffff ), '!_ordered( 0x80000000, 0x7fffffff )' ); + ok( !Net::DNS::RR::SIG::_ordered( 0, 0xffffffff ), '!_ordered( 0, 0xffffffff )' ); + ok( !Net::DNS::RR::SIG::_ordered( -1, -2 ), '!_ordered( -1, -2 )' ); + ok( !Net::DNS::RR::SIG::_ordered( 0, -1 ), '!_ordered( 0, -1 )' ); +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + +exit; + + diff --git a/t/05-SMIMEA.t b/t/05-SMIMEA.t new file mode 100644 index 0000000..eb02a1f --- /dev/null +++ b/t/05-SMIMEA.t @@ -0,0 +1,89 @@ +# $Id: 05-SMIMEA.t 1449 2016-02-01 12:27:12Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 19; + + +use Net::DNS; + + +my $name = 'c93f1e400f26708f98cb19d936620da35eec8f72e57f9eec01c1afd6._smimecert.example.com'; +my $type = 'SMIMEA'; +my $code = 53; +my @attr = qw( usage selector matchingtype certificate ); +my @data = qw( 1 1 1 d2abde240d7cd3ee6b4b28c54df034b97983a1d16e8a410e4561cb106618e971 ); +my @also = qw( certbin babble ); + +my $wire = qw( 010101d2abde240d7cd3ee6b4b28c54df034b97983a1d16e8a410e4561cb106618e971 ); + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ) +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + eval { $rr->certificate('123456789XBCDEF'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt hexadecimal\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + + +exit; + diff --git a/t/05-SOA.t b/t/05-SOA.t new file mode 100644 index 0000000..6208987 --- /dev/null +++ b/t/05-SOA.t @@ -0,0 +1,150 @@ +# $Id: 05-SOA.t 1381 2015-08-25 07:36:09Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 40; + + +use Net::DNS; + + +my $name = 'SOA.example'; +my $type = 'SOA'; +my $code = 6; +my @attr = qw( mname rname serial refresh retry expire minimum ); +my @data = qw( ns.example.net rp@example.com 0 14400 1800 604800 7200 ); +my @also = qw( ); + +my $wire = '026e73076578616d706c65036e657400027270076578616d706c6503636f6d0000000000000038400000070800093a8000001c20'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed < length $predecessor, 'encoded RDATA compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + use integer; + my $initial = -1; ## exercise 32-bit compatibility code on 64-bit hardware + foreach my $serial ( 2E9, 3E9, 4E9, 1E9, 2E9, 4E9, 1E9, 3E9 ) { + my $rr = new Net::DNS::RR("name SOA mname rname $initial"); + $rr->serial($serial); + is( $rr->serial, 0 + $serial, "rr->serial($serial) steps from $initial to $serial" ); + $initial = $serial; + } +} + + +{ + use integer; + my $rr = new Net::DNS::RR('name SOA mname rname 1'); + my $initial = $rr->serial; + $rr->serial(SEQUENTIAL); + is( $rr->serial, ++$initial, 'rr->serial(SEQUENTIAL) increments existing serial number' ); + + my $pre31wrap = 0x7FFFFFFF; + my $post31wrap = 0x80000000; + $rr->serial($pre31wrap); + $rr->serial(SEQUENTIAL); + is( $rr->serial, 0 + $post31wrap, "rr->serial(SEQUENTIAL) wraps from $pre31wrap to $post31wrap" ); + + my $pre32wrap = 0xFFFFFFFF; + my $post32wrap = 0x00000000; + $rr->serial($pre32wrap); + $rr->serial(SEQUENTIAL); + is( $rr->serial, 0 + $post32wrap, "rr->serial(SEQUENTIAL) wraps from $pre32wrap to $post32wrap" ); +} + + +{ + use integer; + my $rr = new Net::DNS::RR('name SOA mname rname 2000000000'); + my $predate = $rr->serial; + my $postdate = YYYYMMDDxx; + my $postincr = $postdate + 1; + is( $rr->serial($postdate), $postdate, "rr->serial(YYYYMMDDxx) steps from $predate to $postdate" ); + is( $rr->serial($postdate), $postincr, "rr->serial(YYYYMMDDxx) increments $postdate to $postincr" ); +} + + +{ + use integer; + my $pretime = UNIXTIME; + my $rr = new Net::DNS::RR("name SOA mname rname $pretime"); + sleep 5; + my $posttime = UNIXTIME; + my $postincr = $posttime + 1; + is( $rr->serial($posttime), $posttime, "rr->serial(UNIXTIME) steps from $pretime to $posttime" ); + is( $rr->serial($posttime), $postincr, "rr->serial(UNIXTIME) increments $posttime to $postincr" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->serial(YYYYMMDDxx); + $rr->print; +} + + +exit; + diff --git a/t/05-SPF.t b/t/05-SPF.t new file mode 100644 index 0000000..5b1ce65 --- /dev/null +++ b/t/05-SPF.t @@ -0,0 +1,70 @@ +# $Id: 05-SPF.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 10; + + +use Net::DNS; + + +my $name = 'SPF.example'; +my $type = 'SPF'; +my $code = 99; +my @attr = qw( spfdata ); +my @data = ('v=spf1 +mx a:colo.example.com/28 -all'); +my @also = qw( txtdata ); + +my $wire = '25763d73706631202b6d7820613a636f6c6f2e6578616d706c652e636f6d2f3238202d616c6c'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + my $r1 = join '', $rr->$_; + is( $r1, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + my $r1 = join '', $rr->$_; + my $r2 = join '', $rr2->$_; + is( $r2, $r1, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +exit; + diff --git a/t/05-SRV.t b/t/05-SRV.t new file mode 100644 index 0000000..d56e87b --- /dev/null +++ b/t/05-SRV.t @@ -0,0 +1,87 @@ +# $Id: 05-SRV.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 19; + + +use Net::DNS; + + +my $name = '_foo._tcp.example.com'; +my $type = 'SRV'; +my $code = 33; +my @attr = qw( priority weight port target ); +my @data = qw( 1 3 9 fast.example.com ); +my @also = qw( ); + +my $wire = '0001000300090466617374076578616d706c6503636f6d00'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $lc = new Net::DNS::RR( lc ". $type @data" ); + my $rr = new Net::DNS::RR( uc ". $type @data" ); + my $hash = {}; + my $predecessor = $rr->encode( 0, $hash ); + my $compressed = $rr->encode( length $predecessor, $hash ); + ok( length $compressed == length $predecessor, 'encoded RDATA not compressible' ); + isnt( $rr->encode, $lc->encode, 'encoded RDATA names not downcased' ); + is( $rr->canonical, $lc->encode, 'canonical RDATA names downcased' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-SSHFP.t b/t/05-SSHFP.t new file mode 100644 index 0000000..9913e4c --- /dev/null +++ b/t/05-SSHFP.t @@ -0,0 +1,92 @@ +# $Id: 05-SSHFP.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; + +BEGIN { + use Test::More; + use Net::DNS; + + plan tests => 18; +} + + +my $name = 'host.example'; +my $type = 'SSHFP'; +my $code = 44; +my @attr = qw( algorithm fptype fp ); +my @data = qw( 2 1 123456789abcdef67890123456789abcdef67890 ); +my @also = qw( fingerprint fpbin babble ); + +my $wire = '0201123456789abcdef67890123456789abcdef67890'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + eval { $rr->fp('123456789XBCDEF'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt hexadecimal\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +{ + my $rr = new Net::DNS::RR("$name $type @data"); + $rr->print; +} + + +exit; + diff --git a/t/05-TKEY.t b/t/05-TKEY.t new file mode 100644 index 0000000..ddf7805 --- /dev/null +++ b/t/05-TKEY.t @@ -0,0 +1,83 @@ +# $Id: 05-TKEY.t 1559 2017-04-10 07:39:44Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 24; + + +use Net::DNS; + + +my $name = 'TKEY.example'; +my $type = 'TKEY'; +my $code = 249; +my @attr = qw( algorithm inception expiration mode error key other ); +my $fake = pack 'H*', '64756d6d79'; +my @data = ( qw( alg.example 1434806118 1434806118 1 17 ), $fake, $fake ); +my @also = qw( other_data ); + +my $wire = '03616c67076578616d706c6500558567665585676600010011000564756d6d79000564756d6d79'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); + + my @wire = unpack 'C*', $encoded; + $wire[length($empty) - 1]--; + my $wireformat = pack 'C*', @wire; + eval { decode Net::DNS::RR( \$wireformat ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt wire-format\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-TLSA.t b/t/05-TLSA.t new file mode 100644 index 0000000..fac327e --- /dev/null +++ b/t/05-TLSA.t @@ -0,0 +1,85 @@ +# $Id: 05-TLSA.t 1381 2015-08-25 07:36:09Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 19; + + +use Net::DNS; + + +my $name = '_443._tcp.www.example.com'; +my $type = 'TLSA'; +my $code = 52; +my @attr = qw( usage selector matchingtype certificate ); +my @data = + qw( 1 1 2 92003ba34942dc74152e2f2c408d29eca5a520e7f2e06bb944f4dca346baf63c1b177615d466f6c4b71c216a50292bd58c9ebdd2f74e38fe51ffd48c43326cbc ); +my @also = qw( certbin babble ); + +my $wire = +'01010292003ba34942dc74152e2f2c408d29eca5a520e7f2e06bb944f4dca346baf63c1b177615d466f6c4b71c216a50292bd58c9ebdd2f74e38fe51ffd48c43326cbc'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ) +} + + +{ + my $rr = new Net::DNS::RR(". $type @data"); + eval { $rr->certificate('123456789XBCDEF'); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt hexadecimal\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-TSIG.t b/t/05-TSIG.t new file mode 100644 index 0000000..487cdfc --- /dev/null +++ b/t/05-TSIG.t @@ -0,0 +1,585 @@ +# $Id: 05-TSIG.t 1561 2017-04-19 13:08:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::HMAC + Digest::MD5 + Digest::SHA + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "use $package; 1;"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 68; + + +sub mysign { + my ( $key, $data ) = @_; + my $hmac = new Digest::HMAC( $key, 'Digest::MD5' ); + $hmac->add($data); + return $hmac->digest; +} + + +my $name = '123456789-test'; +my $type = 'TSIG'; +my $code = 250; +my @attr = qw( algorithm time_signed fudge sig_function ); +my @data = ( qw( fake.alg 100001 600 ), \&mysign ); +my @also = qw( mac prior_mac request_mac error sign_func other_data _size ); + +my $wire = '0466616b6503616c67000000000186a102580010a5d31d3ce3b7122b4a598c225d9c3f2a04d200000000'; + + +my $hash = {}; +@{$hash}{@attr} = @data; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash, + keybin => pack( 'H*', '66616b65206b6579' ), + ); + + my $string = $rr->string; + like( $rr->string, "/$$hash{algorithm}/", 'got expected rr->string' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + ok( defined $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $buffer = $empty; ## Note: TSIG RR gets destroyed by decoder + my $rxbin = decode Net::DNS::RR( \$buffer )->encode; + my $packet = Net::DNS::Packet->new( $name, 'TKEY', 'IN' ); + $packet->header->id(1234); # fix packet id + $packet->header->rd(1); + my $encoded = $buffer = $rr->encode( 0, {}, $packet ); + my $decoded = decode Net::DNS::RR( \$buffer ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + + my @wire = unpack 'C*', $encoded; + my $wireformat = pack 'C*', @wire, 0; + eval { decode Net::DNS::RR( \$wireformat ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "misplaced SIG RR\t[$exception]" ); +} + + +{ + my $rr = new Net::DNS::RR( type => 'TSIG', key => '' ); + ok( !$rr->verify(), 'verify fails on empty TSIG' ); + ok( $rr->vrfyerrstr(), 'vrfyerrstr() reports failure' ); + ok( !$rr->other(), 'other undefined' ); + ok( $rr->time_signed(), 'time_signed() defined' ); + my $key = eval { $rr->key(); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "write-only key attribute\t[$exception]" ); +} + + +{ + my $correct = '123456789ABCDEF'; + my $corrupt = '123456789XBCDEF'; + foreach my $method (qw(mac request_mac prior_mac)) { + my $rr = new Net::DNS::RR( type => 'TSIG', $method => $correct ); + ok( $rr->$method($correct), "correct hex $method" ); + eval { $rr->$method($corrupt); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt hex $method\t[$exception]" ); + } +} + + +{ + # Check default signing function using test cases from RFC2202, section 2. + + my $tsig = new Net::DNS::RR( type => 'TSIG', fudge => 300 ); + my $function = $tsig->sig_function; # default signing function + my $algorithm = $tsig->algorithm; # default algorithm + + is( $algorithm, 'HMAC-MD5.SIG-ALG.REG.INT', 'Check algorithm correctly identified' ); + + { + my $data = pack 'H*', '4869205468657265'; + my $key = "\x0b" x 16; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '9294727a3638bb1c13f48ef8158bfc9d'; + is( $result, $expect, "Check signing function for $algorithm" ); + } + + { + my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; + my $key = pack 'H*', '4a656665'; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '750c783e6ab0b503eaa86e310a5db738'; + is( $result, $expect, "Check $algorithm with key shorter than hash size" ); + } + + { + my $data = "\xdd" x 50; + my $key = "\xaa" x 16; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '56be34521d144c88dbb8c733f0e8b3f6'; + is( $result, $expect, "Check $algorithm with data longer than hash size" ); + } + + { + my $data = "\xcd" x 50; + my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '697eaf0aca3a3aea3a75164746ffaa79'; + is( $result, $expect, "Check $algorithm with key and data longer than hash" ); + } + + { + my $data = pack 'H*', join '', qw( + 54657374205573696e67204c61726765 + 72205468616e20426c6f636b2d53697a + 65204b6579202d2048617368204b6579 + 204669727374 ); + my $key = "\xaa" x 80; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd'; + is( $result, $expect, "Check $algorithm with key longer than block size" ); + } + + { + my $data = pack 'H*', join '', qw( + 54657374205573696e67204c61726765 + 72205468616e20426c6f636b2d53697a + 65204b657920616e64204c6172676572 + 205468616e204f6e6520426c6f636b2d + 53697a652044617461 ); + my $key = "\xaa" x 80; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '6f630fad67cda0ee1fb1f562db3aa53e'; + is( $result, $expect, "Check $algorithm with both long key and long data" ); + } +} + + +{ + # Check HMAC-SHA1 signing function using test cases from RFC2202, section 3. + + my $tsig = new Net::DNS::RR( type => 'TSIG', algorithm => 'HMAC-SHA' ); # alias HMAC-SHA1 + my $algorithm = $tsig->algorithm; + my $function = $tsig->sig_function; + + is( $algorithm, 'HMAC-SHA1', 'Check algorithm correctly identified' ); + + { + my $data = pack 'H*', '4869205468657265'; + my $key = "\x0b" x 20; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = 'b617318655057264e28bc0b6fb378c8ef146be00'; + is( $result, $expect, "Check signing function for $algorithm" ); + } + + { + my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; + my $key = pack 'H*', '4a656665'; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = 'effcdf6ae5eb2fa2d27416d5f184df9c259a7c79'; + is( $result, $expect, "Check $algorithm with key shorter than hash size" ); + } + + { + my $data = "\xdd" x 50; + my $key = "\xaa" x 20; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '125d7342b9ac11cd91a39af48aa17b4f63f175d3'; + is( $result, $expect, "Check $algorithm with data longer than hash size" ); + } + + { + my $data = "\xcd" x 50; + my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '4c9007f4026250c6bc8414f9bf50c86c2d7235da'; + is( $result, $expect, "Check $algorithm with key and data longer than hash" ); + } + + { + my $data = pack 'H*', join '', qw( + 54657374205573696e67204c61726765 + 72205468616e20426c6f636b2d53697a + 65204b6579202d2048617368204b6579 + 204669727374 ); + my $key = "\xaa" x 80; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = 'aa4ae5e15272d00e95705637ce8a3b55ed402112'; + is( $result, $expect, "Check $algorithm with key longer than block size" ); + } + + { + my $data = pack 'H*', join '', qw( + 54657374205573696e67204c61726765 + 72205468616e20426c6f636b2d53697a + 65204b657920616e64204c6172676572 + 205468616e204f6e6520426c6f636b2d + 53697a652044617461 ); + my $key = "\xaa" x 80; + my $result = lc unpack( 'H*', &$function( $key, $data ) ); + my $expect = 'e8e99d0f45237d786d6bbaa7965c7808bbff1a91'; + is( $result, $expect, "Check $algorithm with both long key and long data" ); + } +} + + +{ + # Check HMAC-SHA224 signing function using test cases from RFC4634, section 8.4. + + my $tsig = new Net::DNS::RR( type => 'TSIG', algorithm => 162 ); # alias HMAC-SHA224 + my $algorithm = $tsig->algorithm; + my $function = $tsig->sig_function; + + is( $algorithm, 'HMAC-SHA224', 'Check algorithm correctly identified' ); + + { + my $data = pack 'H*', '4869205468657265'; + my $key = "\x0b" x 20; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '896FB1128ABBDF196832107CD49DF33F47B4B1169912BA4F53684B22'; + is( $result, $expect, "Check signing function for $algorithm" ); + } + + { + my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; + my $key = pack 'H*', '4a656665'; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = 'A30E01098BC6DBBF45690F3A7E9E6D0F8BBEA2A39E6148008FD05E44'; + is( $result, $expect, "Check $algorithm with key shorter than hash size" ); + } + + { + my $data = "\xdd" x 50; + my $key = "\xaa" x 20; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '7FB3CB3588C6C1F6FFA9694D7D6AD2649365B0C1F65D69D1EC8333EA'; + is( $result, $expect, "Check $algorithm with data longer than hash size" ); + } + + { + my $data = "\xcd" x 50; + my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '6C11506874013CAC6A2ABC1BB382627CEC6A90D86EFC012DE7AFEC5A'; + is( $result, $expect, "Check $algorithm with key and data longer than hash" ); + } + + { + my $data = pack 'H*', join '', qw( + 54657374205573696e67204c61726765 + 72205468616e20426c6f636b2d53697a + 65204b6579202d2048617368204b6579 + 204669727374 ); + my $key = "\xaa" x 131; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '95E9A0DB962095ADAEBE9B2D6F0DBCE2D499F112F2D2B7273FA6870E'; + is( $result, $expect, "Check $algorithm with key longer than block size" ); + } + + { + my $data = pack 'H*', join '', qw( + 54686973206973206120746573742075 + 73696e672061206c6172676572207468 + 616e20626c6f636b2d73697a65206b65 + 7920616e642061206c61726765722074 + 68616e20626c6f636b2d73697a652064 + 6174612e20546865206b6579206e6565 + 647320746f2062652068617368656420 + 6265666f7265206265696e6720757365 + 642062792074686520484d414320616c + 676f726974686d2e ); + my $key = "\xaa" x 131; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '3A854166AC5D9F023F54D517D0B39DBD946770DB9C2B95C9F6F565D1'; + is( $result, $expect, "Check $algorithm with both long key and long data" ); + } +} + + +{ + # Check HMAC-SHA256 signing function using test cases from RFC4634, section 8.4. + + my $tsig = new Net::DNS::RR( type => 'TSIG', algorithm => 'HMAC-SHA256' ); + my $algorithm = $tsig->algorithm; + my $function = $tsig->sig_function; + + { + my $data = pack 'H*', '4869205468657265'; + my $key = "\x0b" x 20; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = 'B0344C61D8DB38535CA8AFCEAF0BF12B881DC200C9833DA726E9376C2E32CFF7'; + is( $result, $expect, "Check signing function for $algorithm" ); + } + + { + my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; + my $key = pack 'H*', '4a656665'; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '5BDCC146BF60754E6A042426089575C75A003F089D2739839DEC58B964EC3843'; + is( $result, $expect, "Check $algorithm with key shorter than hash size" ); + } + + { + my $data = "\xdd" x 50; + my $key = "\xaa" x 20; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '773EA91E36800E46854DB8EBD09181A72959098B3EF8C122D9635514CED565FE'; + is( $result, $expect, "Check $algorithm with data longer than hash size" ); + } + + { + my $data = "\xcd" x 50; + my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '82558A389A443C0EA4CC819899F2083A85F0FAA3E578F8077A2E3FF46729665B'; + is( $result, $expect, "Check $algorithm with key and data longer than hash" ); + } + + { + my $data = pack 'H*', join '', qw( + 54657374205573696e67204c61726765 + 72205468616e20426c6f636b2d53697a + 65204b6579202d2048617368204b6579 + 204669727374 ); + my $key = "\xaa" x 131; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '60E431591EE0B67F0D8A26AACBF5B77F8E0BC6213728C5140546040F0EE37F54'; + is( $result, $expect, "Check $algorithm with key longer than block size" ); + } + + { + my $data = pack 'H*', join '', qw( + 54686973206973206120746573742075 + 73696e672061206c6172676572207468 + 616e20626c6f636b2d73697a65206b65 + 7920616e642061206c61726765722074 + 68616e20626c6f636b2d73697a652064 + 6174612e20546865206b6579206e6565 + 647320746f2062652068617368656420 + 6265666f7265206265696e6720757365 + 642062792074686520484d414320616c + 676f726974686d2e ); + my $key = "\xaa" x 131; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = '9B09FFA71B942FCB27635FBCD5B0E944BFDC63644F0713938A7F51535C3A35E2'; + is( $result, $expect, "Check $algorithm with both long key and long data" ); + } +} + + +{ + # Check HMAC-SHA384 signing function using test cases from RFC4634, section 8.4. + + my $tsig = new Net::DNS::RR( type => 'TSIG', algorithm => 'HMAC-SHA384' ); + my $algorithm = $tsig->algorithm; + my $function = $tsig->sig_function; + + { + my $data = pack 'H*', '4869205468657265'; + my $key = "\x0b" x 20; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + AFD03944D84895626B0825F4AB46907F + 15F9DADBE4101EC682AA034C7CEBC59C + FAEA9EA9076EDE7F4AF152E8B2FA9CB6 ); + is( $result, $expect, "Check signing function for $algorithm" ); + } + + { + my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; + my $key = pack 'H*', '4a656665'; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + AF45D2E376484031617F78D2B58A6B1B + 9C7EF464F5A01B47E42EC3736322445E + 8E2240CA5E69E2C78B3239ECFAB21649 ); + is( $result, $expect, "Check $algorithm with key shorter than hash size" ); + } + + { + my $data = "\xdd" x 50; + my $key = "\xaa" x 20; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + 88062608D3E6AD8A0AA2ACE014C8A86F + 0AA635D947AC9FEBE83EF4E55966144B + 2A5AB39DC13814B94E3AB6E101A34F27 ); + is( $result, $expect, "Check $algorithm with data longer than hash size" ); + } + + { + my $data = "\xcd" x 50; + my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + 3E8A69B7783C25851933AB6290AF6CA7 + 7A9981480850009CC5577C6E1F573B4E + 6801DD23C4A7D679CCF8A386C674CFFB ); + is( $result, $expect, "Check $algorithm with key and data longer than hash" ); + } + + { + my $data = pack 'H*', join '', qw( + 54657374205573696e67204c61726765 + 72205468616e20426c6f636b2d53697a + 65204b6579202d2048617368204b6579 + 204669727374 ); + my $key = "\xaa" x 131; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + 4ECE084485813E9088D2C63A041BC5B4 + 4F9EF1012A2B588F3CD11F05033AC4C6 + 0C2EF6AB4030FE8296248DF163F44952 ); + is( $result, $expect, "Check $algorithm with key longer than block size" ); + } + + { + my $data = pack 'H*', join '', qw( + 54686973206973206120746573742075 + 73696e672061206c6172676572207468 + 616e20626c6f636b2d73697a65206b65 + 7920616e642061206c61726765722074 + 68616e20626c6f636b2d73697a652064 + 6174612e20546865206b6579206e6565 + 647320746f2062652068617368656420 + 6265666f7265206265696e6720757365 + 642062792074686520484d414320616c + 676f726974686d2e ); + my $key = "\xaa" x 131; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + 6617178E941F020D351E2F254E8FD32C + 602420FEB0B8FB9ADCCEBB82461E99C5 + A678CC31E799176D3860E6110C46523E ); + is( $result, $expect, "Check $algorithm with both long key and long data" ); + } +} + + +{ + # Check HMAC-SHA512 signing function using test cases from RFC4634, section 8.4. + + my $tsig = new Net::DNS::RR( type => 'TSIG', algorithm => 'HMAC-SHA512' ); + my $algorithm = $tsig->algorithm; + my $function = $tsig->sig_function; + + { + my $data = pack 'H*', '4869205468657265'; + my $key = "\x0b" x 20; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + 87AA7CDEA5EF619D4FF0B4241A1D6CB0 + 2379F4E2CE4EC2787AD0B30545E17CDE + DAA833B7D6B8A702038B274EAEA3F4E4 + BE9D914EEB61F1702E696C203A126854 ); + is( $result, $expect, "Check signing function for $algorithm" ); + } + + { + my $data = pack 'H*', '7768617420646f2079612077616e7420666f72206e6f7468696e673f'; + my $key = pack 'H*', '4a656665'; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + 164B7A7BFCF819E2E395FBE73B56E0A3 + 87BD64222E831FD610270CD7EA250554 + 9758BF75C05A994A6D034F65F8F0E6FD + CAEAB1A34D4A6B4B636E070A38BCE737 ); + is( $result, $expect, "Check $algorithm with key shorter than hash size" ); + } + + { + my $data = "\xdd" x 50; + my $key = "\xaa" x 20; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + FA73B0089D56A284EFB0F0756C890BE9 + B1B5DBDD8EE81A3655F83E33B2279D39 + BF3E848279A722C806B485A47E67C807 + B946A337BEE8942674278859E13292FB ); + is( $result, $expect, "Check $algorithm with data longer than hash size" ); + } + + { + my $data = "\xcd" x 50; + my $key = pack 'H*', '0102030405060708090a0b0c0d0e0f10111213141516171819'; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + B0BA465637458C6990E5A8C5F61D4AF7 + E576D97FF94B872DE76F8050361EE3DB + A91CA5C11AA25EB4D679275CC5788063 + A5F19741120C4F2DE2ADEBEB10A298DD ); + is( $result, $expect, "Check $algorithm with key and data longer than hash" ); + } + + { + my $data = pack 'H*', join '', qw( + 54657374205573696e67204c61726765 + 72205468616e20426c6f636b2d53697a + 65204b6579202d2048617368204b6579 + 204669727374 ); + my $key = "\xaa" x 131; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + 80B24263C7C1A3EBB71493C1DD7BE8B4 + 9B46D1F41B4AEEC1121B013783F8F352 + 6B56D037E05F2598BD0FD2215D6A1E52 + 95E64F73F63F0AEC8B915A985D786598 ); + is( $result, $expect, "Check $algorithm with key longer than block size" ); + } + + { + my $data = pack 'H*', join '', qw( + 54686973206973206120746573742075 + 73696e672061206c6172676572207468 + 616e20626c6f636b2d73697a65206b65 + 7920616e642061206c61726765722074 + 68616e20626c6f636b2d73697a652064 + 6174612e20546865206b6579206e6565 + 647320746f2062652068617368656420 + 6265666f7265206265696e6720757365 + 642062792074686520484d414320616c + 676f726974686d2e ); + my $key = "\xaa" x 131; + my $result = uc unpack( 'H*', &$function( $key, $data ) ); + my $expect = join '', qw( + E37B6A775DC87DBAA4DFA9F96E5E3FFD + DEBD71F8867289865DF5A32D20CDC944 + B6022CAC3C4982B10D5EEB55C3E4DE15 + 134676FB6DE0446065C97440FA8C6A58 ); + is( $result, $expect, "Check $algorithm with both long key and long data" ); + } +} + + +exit; + + diff --git a/t/05-TXT.t b/t/05-TXT.t new file mode 100644 index 0000000..3b8c0c0 --- /dev/null +++ b/t/05-TXT.t @@ -0,0 +1,112 @@ +# $Id: 05-TXT.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 52; + + +use Net::DNS; + + +my $name = 'TXT.example'; +my $type = 'TXT'; +my $code = 16; +my @attr = qw( txtdata ); +my @data = qw( arbitrary_text ); + +my $wire = '0e6172626974726172795f74657874'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); + + my @wire = unpack 'C*', $encoded; + $wire[length($empty) - 1]--; + my $wireformat = pack 'C*', @wire; + eval { decode Net::DNS::RR( \$wireformat ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt wire-format\t[$exception]" ); +} + + +{ + foreach my $testcase ( + q|contiguous|, q|three unquoted strings|, + q|"in quotes"|, q|"two separate" "quoted strings"|, + q|"" empty|, q|" " space|, + q|!|, q|\"|, + q|#|, q|\$|, + q|%|, q|&|, + q|'|, q|\(|, + q|\)|, q|*|, + q|+|, q|,|, + q|-|, q|.|, + q|/|, q|:|, + q|\;|, q|<|, + q|=|, q|>|, + q|?|, q|\@|, + q|[|, q|\\\\|, + q|]|, q|^|, + q|_|, q|`|, + q|{|, q(|), + q|}|, q|~|, + q|0|, q|1|, + join( q|\227\128\128|, + q|\229\143\164\230\177\160\227\130\132|, + q|\232\155\153\233\163\155\232\190\188\227\130\128|, + q|\230\176\180\227\129\174\233\159\179| ) + ) { + my $string = "$name. TXT $testcase"; + my $expect = new Net::DNS::RR($string)->string; # test for consistent parsing + my $result = new Net::DNS::RR($expect)->string; + is( $result, $expect, $string ); + } +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-URI.t b/t/05-URI.t new file mode 100644 index 0000000..1801f08 --- /dev/null +++ b/t/05-URI.t @@ -0,0 +1,68 @@ +# $Id: 05-URI.t 1390 2015-09-11 11:42:11Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 11; + +use Net::DNS; + + +my $name = '_ftp._tcp.example.net'; +my $type = 'URI'; +my $code = 256; +my @attr = qw( priority weight target ); +my @data = qw( 10 1 ftp://ftp1.example.com/public ); +my @also = qw( ); + +my $wire = '000A00016674703A2F2F667470312E6578616D706C652E636F6D2F7075626C6963'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $empty = new Net::DNS::RR("$name $type"); + my $nodata = $empty->string; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = uc unpack 'H*', $decoded->encode; + my $hex2 = uc unpack 'H*', $encoded; + my $hex3 = uc unpack 'H*', substr( $encoded, length $empty->encode ); + is( $hex1, $hex2, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/05-X25.t b/t/05-X25.t new file mode 100644 index 0000000..191a787 --- /dev/null +++ b/t/05-X25.t @@ -0,0 +1,75 @@ +# $Id: 05-X25.t 1362 2015-06-23 08:47:14Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 11; + + +use Net::DNS; + + +my $name = 'relay.prime.com'; +my $type = 'X25'; +my $code = 19; +my @attr = qw( address ); +my @data = qw( 311061700956 ); +my @also = qw( PSDNaddress ); + +my $wire = '0c333131303631373030393536'; + + +{ + my $typecode = unpack 'xn', new Net::DNS::RR(". $type")->encode; + is( $typecode, $code, "$type RR type code = $code" ); + + my $hash = {}; + @{$hash}{@attr} = @data; + + my $rr = new Net::DNS::RR( + name => $name, + type => $type, + %$hash + ); + + my $string = $rr->string; + my $rr2 = new Net::DNS::RR($string); + is( $rr2->string, $string, 'new/string transparent' ); + + is( $rr2->encode, $rr->encode, 'new($string) and new(%hash) equivalent' ); + + foreach (@attr) { + is( $rr->$_, $hash->{$_}, "expected result from rr->$_()" ); + } + + foreach (@also) { + is( $rr2->$_, $rr->$_, "additional attribute rr->$_()" ); + } + + + my $null = new Net::DNS::RR("$name NULL")->encode; + my $empty = new Net::DNS::RR("$name $type")->encode; + my $rxbin = decode Net::DNS::RR( \$empty )->encode; + my $txtext = new Net::DNS::RR("$name $type")->string; + my $rxtext = new Net::DNS::RR($txtext)->encode; + my $encoded = $rr->encode; + my $decoded = decode Net::DNS::RR( \$encoded ); + my $hex1 = unpack 'H*', $encoded; + my $hex2 = unpack 'H*', $decoded->encode; + my $hex3 = unpack 'H*', substr( $encoded, length $null ); + is( $hex2, $hex1, 'encode/decode transparent' ); + is( $hex3, $wire, 'encoded RDATA matches example' ); + is( length($empty), length($null), 'encoded RDATA can be empty' ); + is( length($rxbin), length($null), 'decoded RDATA can be empty' ); + is( length($rxtext), length($null), 'string RDATA can be empty' ); +} + + +{ + my $rr = new Net::DNS::RR(". $type"); + foreach (@attr) { + ok( !$rr->$_(), "'$_' attribute of empty RR undefined" ); + } +} + + +exit; + diff --git a/t/06-packet-unique-push.t b/t/06-packet-unique-push.t new file mode 100644 index 0000000..baee03c --- /dev/null +++ b/t/06-packet-unique-push.t @@ -0,0 +1,106 @@ +# $Id: 06-packet-unique-push.t 1561 2017-04-19 13:08:13Z willem $ + +use strict; + +BEGIN { + use Test::More tests => 45; + + use_ok('Net::DNS'); +} + + +# Matching of RR name is not case sensitive +my $domain = 'example.com'; +my $method = 'unique_push'; +my $packet = Net::DNS::Packet->new($domain); + +my $rr_1 = Net::DNS::RR->new('bla.foo 100 IN TXT "text" ;lower case'); +my $rr_2 = Net::DNS::RR->new('bla.Foo 100 IN Txt "text" ;mixed case'); +my $rr_3 = Net::DNS::RR->new('bla.foo 100 IN TXT "mixed CASE"'); +my $rr_4 = Net::DNS::RR->new('bla.foo 100 IN TXT "MIXED case"'); + +$packet->unique_push( "answer", $rr_1 ); +$packet->unique_push( "answer", $rr_2 ); +is( $packet->header->ancount, 1, "unique_push case sensitivity test 1" ); + +$packet->unique_push( "answer", $rr_3 ); +$packet->unique_push( "answer", $rr_4 ); +is( $packet->header->ancount, 3, "unique_push case sensitivity test 2" ); + + +my %sections = ( + answer => 'ancount', + authority => 'nscount', + additional => 'arcount', + ); + +my @tests = ( + [ 1, + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + ], + [ 2, + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + Net::DNS::RR->new('bar.example.com 60 IN A 192.0.2.1'), + ], + [ 1, + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + Net::DNS::RR->new('foo.example.com 90 IN A 192.0.2.1'), + ], + [ 3, + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.2'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.3'), + ], + [ 3, + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.2'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.3'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + ], + [ 3, + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.2'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.1'), + Net::DNS::RR->new('foo.example.com 60 IN A 192.0.2.4'), + Net::DNS::RR->new('foo.example.com 60 HS A 192.0.2.4'), + ], + [ 3, + Net::DNS::RR->new('foo.example.com IN A'), + Net::DNS::RR->new('foo.example.com ANY A'), + Net::DNS::RR->new('foo.example.com NONE A'), + ], + ); + + +foreach my $test (@tests) { + my ( $expect, @rrs ) = @$test; + + while ( my ( $section, $count_meth ) = each %sections ) { + + my $packet = new Net::DNS::Update($domain); + + $packet->$method( $section => @rrs ); + + my $count = $packet->header->$count_meth(); + is( $count, $expect, "$method $section => RR, RR, ..." ); + + } + + # + # Now do it again, pushing each RR individually. + # + while ( my ( $section, $count_meth ) = each %sections ) { + + my $packet = new Net::DNS::Update($domain); + + foreach my $rr (@rrs) { + $packet->$method( $section => $rr ); + } + + my $count = $packet->header->$count_meth(); + is( $count, $expect, "$method $section => RR" ); + } +} + diff --git a/t/06-update.t b/t/06-update.t new file mode 100644 index 0000000..93ffeb4 --- /dev/null +++ b/t/06-update.t @@ -0,0 +1,275 @@ +# $Id: 06-update.t 1571 2017-06-03 20:14:15Z willem $ -*-perl-*- + +use strict; +use Test::More tests => 85; + +use Net::DNS; + + +sub is_empty { + local $_ = shift; + + return 0 unless defined $_; + return 1 unless length $_; + + return 1 if /\\# 0/; + return 1 if /; no data/; + return 1 if /; rdlength = 0/; + return 0; +} + + +#------------------------------------------------------------------------------ +# Canned data. +#------------------------------------------------------------------------------ + +my $zone = "example.com"; +my $name = "foo.example.com"; +my $class = "HS"; +my $class2 = "CH"; +my $type = "A"; +my $ttl = 43200; +my $rdata = "10.1.2.3"; + +#------------------------------------------------------------------------------ +# Packet creation. +#------------------------------------------------------------------------------ + +{ + my $packet = new Net::DNS::Update( $zone, $class ); + my ($z) = $packet->zone; + + ok( $packet, 'new() returned packet' ); + is( $packet->header->opcode, 'UPDATE', 'header opcode correct' ); + is( $z->zname, $zone, 'zname from explicit argument' ); + is( $z->zclass, $class, 'zclass correct' ); + is( $z->ztype, 'SOA', 'ztype correct' ); +} + + +{ + Net::DNS::Resolver->domain($zone); # overides config files + my $packet = new Net::DNS::Update(); + my ($z) = $packet->zone; + is( $z->zname, $zone, 'zname from resolver defaults' ); +} + + +{ + Net::DNS::Resolver->domain(''); # overides config files + my $packet = eval { new Net::DNS::Update(undef); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "argument undefined\t[$exception]" ); +} + + +#------------------------------------------------------------------------------ +# RRset exists (value-independent). +#------------------------------------------------------------------------------ + +{ + my $arg = "$name $ttl $class $type"; + my $rr = yxrrset($arg); + + ok( $rr, "yxrrset($arg)" ); #9 + is( $rr->name, $name, 'yxrrset - right name' ); + is( $rr->ttl, 0, 'yxrrset - ttl 0' ); + is( $rr->class, 'ANY', 'yxrrset - class ANY' ); + is( $rr->type, $type, "yxrrset - type $type" ); + ok( is_empty( $rr->rdstring ), 'yxrrset - data empty' ); +} + +#------------------------------------------------------------------------------ +# RRset exists (value-dependent). +#------------------------------------------------------------------------------ + +{ + my $arg = "$name $ttl $class $type $rdata"; + my $rr = yxrrset($arg); + + ok( $rr, "yxrrset($arg)" ); + is( $rr->name, $name, 'yxrrset - right name' ); + is( $rr->ttl, 0, 'yxrrset - ttl 0' ); + is( $rr->class, $class, "yxrrset - class $class" ); + is( $rr->type, $type, "yxrrset - type $type" ); + is( $rr->rdstring, $rdata, 'yxrrset - right data' ); +} + + +#------------------------------------------------------------------------------ +# RRset does not exist. +#------------------------------------------------------------------------------ + +{ + my $arg = "$name $ttl $class $type $rdata"; + my $rr = nxrrset($arg); + + ok( $rr, "nxrrset($arg)" ); #21 + is( $rr->name, $name, 'nxrrset - right name' ); + is( $rr->ttl, 0, 'nxrrset - ttl 0' ); + is( $rr->class, 'NONE', 'nxrrset - class NONE' ); + is( $rr->type, $type, "nxrrset - type $type" ); + ok( is_empty( $rr->rdstring ), 'nxrrset - data empty' ); +} + + +#------------------------------------------------------------------------------ +# Name is in use. +#------------------------------------------------------------------------------ + +{ + my @arg = "$name"; + my $rr = yxdomain(@arg); + + ok( $rr, "yxdomain(@arg)" ); #27 + is( $rr->name, $name, 'yxdomain - right name' ); + is( $rr->ttl, 0, 'yxdomain - ttl 0' ); + is( $rr->class, 'ANY', 'yxdomain - class ANY' ); + is( $rr->type, 'ANY', 'yxdomain - type ANY' ); + ok( is_empty( $rr->rdstring ), 'yxdomain - data empty' ); +} + +{ + my @arg = ( name => $name ); + my $rr = yxdomain(@arg); + + ok( $rr, "yxdomain(@arg)" ); + is( $rr->name, $name, 'yxdomain - right name' ); + is( $rr->ttl, 0, 'yxdomain - ttl 0' ); + is( $rr->class, 'ANY', 'yxdomain - class ANY' ); + is( $rr->type, 'ANY', 'yxdomain - type ANY' ); + ok( is_empty( $rr->rdstring ), 'yxdomain - data empty' ); +} + + +#------------------------------------------------------------------------------ +# Name is not in use. +#------------------------------------------------------------------------------ + +{ + my @arg = "$name"; + my $rr = nxdomain(@arg); + + ok( $rr, "nxdomain(@arg)" ); #39 + is( $rr->name, $name, 'nxdomain - right name' ); + is( $rr->ttl, 0, 'nxdomain - ttl 0' ); + is( $rr->class, 'NONE', 'nxdomain - class NONE' ); + is( $rr->type, 'ANY', 'nxdomain - type ANY' ); + ok( is_empty( $rr->rdstring ), 'nxdomain - data empty' ); +} + +{ + my @arg = ( name => $name ); + my $rr = nxdomain(@arg); + + ok( $rr, "nxdomain(@arg)" ); + is( $rr->name, $name, 'nxdomain - right name' ); + is( $rr->ttl, 0, 'nxdomain - ttl 0' ); + is( $rr->class, 'NONE', 'nxdomain - class NONE' ); + is( $rr->type, 'ANY', 'nxdomain - type ANY' ); + ok( is_empty( $rr->rdstring ), 'nxdomain - data empty' ); +} + + +#------------------------------------------------------------------------------ +# Add to an RRset. +#------------------------------------------------------------------------------ + +{ + my $arg = "$name $ttl $class $type $rdata"; + my $rr = rr_add($arg); + + ok( $rr, "rr_add($arg)" ); #51 + is( $rr->name, $name, 'rr_add - right name' ); + is( $rr->ttl, $ttl, "rr_add - ttl $ttl" ); + is( $rr->class, $class, "rr_add - class $class" ); + is( $rr->type, $type, "rr_add - type $type" ); + is( $rr->rdstring, $rdata, 'rr_add - right data' ); +} + +{ + my $arg = "$name $class $type $rdata"; + my $rr = rr_add($arg); + + ok( $rr, "rr_add($arg)" ); + is( $rr->name, $name, 'rr_add - right name' ); + is( $rr->ttl, 86400, "rr_add - ttl 86400" ); + is( $rr->class, $class, "rr_add - class $class" ); + is( $rr->type, $type, "rr_add - type $type" ); + is( $rr->rdstring, $rdata, 'rr_add - right data' ); +} + + +#------------------------------------------------------------------------------ +# Delete an RRset. +#------------------------------------------------------------------------------ + +{ + my $arg = "$name $class $type"; + my $rr = rr_del($arg); + + ok( $rr, "rr_del($arg)" ); #63 + is( $rr->name, $name, 'rr_del - right name' ); + is( $rr->ttl, 0, 'rr_del - ttl 0' ); + is( $rr->class, 'ANY', 'rr_del - class ANY' ); + is( $rr->type, $type, "rr_del - type $type" ); + ok( is_empty( $rr->rdstring ), 'rr_del - data empty' ); +} + +#------------------------------------------------------------------------------ +# Delete All RRsets From A Name. +#------------------------------------------------------------------------------ + +{ + my $arg = "$name"; + my $rr = rr_del($arg); + + ok( $rr, "rr_del($arg)" ); + is( $rr->name, $name, 'rr_del - right name' ); + is( $rr->ttl, 0, 'rr_del - ttl 0' ); + is( $rr->class, 'ANY', 'rr_del - class ANY' ); + is( $rr->type, 'ANY', 'rr_del - type ANY' ); + ok( is_empty( $rr->rdstring ), 'rr_del - data empty' ); +} + + +#------------------------------------------------------------------------------ +# Delete An RR From An RRset. +#------------------------------------------------------------------------------ + +{ + my $arg = "$name $class $type $rdata"; + my $rr = rr_del($arg); + + ok( $rr, "rr_del($arg)" ); + is( $rr->name, $name, 'rr_del - right name' ); + is( $rr->ttl, 0, 'rr_del - ttl 0' ); + is( $rr->class, 'NONE', 'rr_del - class NONE' ); + is( $rr->type, $type, "rr_del - type $type" ); + is( $rr->rdstring, $rdata, 'rr_del - right data' ); +} + + +#------------------------------------------------------------------------------ +# Make sure RRs in an update packet have the same class as the zone, unless +# the class is NONE or ANY. +#------------------------------------------------------------------------------ + +{ + my $packet = Net::DNS::Update->new( $zone, $class ); + ok( $packet, 'packet created' ); #81 + + $packet->push( "pre", yxrrset("$name $class $type $rdata") ); + $packet->push( "pre", yxrrset("$name $class2 $type $rdata") ); + $packet->push( "pre", yxrrset("$name $class2 $type") ); + $packet->push( "pre", nxrrset("$name $class2 $type") ); + + my @pre = $packet->pre; + + is( scalar(@pre), 4, '"pre" length correct' ); + is( $pre[0]->class, $class, 'first class right' ); + is( $pre[1]->class, $class, 'second class right' ); + is( $pre[2]->class, 'ANY', 'third class right' ); + is( $pre[3]->class, 'NONE', 'fourth class right' ); +} + diff --git a/t/07-rrsort.t b/t/07-rrsort.t new file mode 100644 index 0000000..8e571fe --- /dev/null +++ b/t/07-rrsort.t @@ -0,0 +1,92 @@ +# $Id: 07-rrsort.t 1381 2015-08-25 07:36:09Z willem $ -*-perl-*- + +use Test::More; +use strict; +use Net::DNS qw(rrsort); + +plan tests => 22; + +my $rr1=Net::DNS::RR->new("example.com. 600 IN SRV 0 0 5060 A.example.com."); +is(ref($rr1),"Net::DNS::RR::SRV","SRV RR1 created"); +my $rr2=Net::DNS::RR->new("example.com. 600 IN SRV 1 0 5060 A.example.com."); +is(ref($rr2),"Net::DNS::RR::SRV","SRV RR2 created"); +my $rr3=Net::DNS::RR->new("example.com. 600 IN SRV 2 0 5060 A.example.com."); +is(ref($rr3),"Net::DNS::RR::SRV","SRV RR3 created"); +my $rr4=Net::DNS::RR->new("example.com. 600 IN SRV 3 0 5060 A.example.com."); +is(ref($rr4),"Net::DNS::RR::SRV","SRV RR4 created"); +my $rr5=Net::DNS::RR->new("example.com. 600 IN SRV 3 1 5060 A.example.com."); +is(ref($rr5),"Net::DNS::RR::SRV","SRV RR5 created"); +my $rr6=Net::DNS::RR->new("example.com. 600 IN SRV 3 2 5060 A.example.com."); +is(ref($rr6),"Net::DNS::RR::SRV","SRV RR6 created"); +my $rr7=Net::DNS::RR->new("example.com. 600 IN SRV 1 3 5070 A.example.com."); +is(ref($rr7),"Net::DNS::RR::SRV","SRV RR7 created"); +my $rr8=Net::DNS::RR->new("example.com. 600 IN SRV 3 3 5070 A.example.com."); +is(ref($rr8),"Net::DNS::RR::SRV","SRV RR8 created"); +my $rr9=Net::DNS::RR->new("example.com. 600 IN A 192.168.0.1"); +is(ref($rr9),"Net::DNS::RR::A","A RR9 created"); + + +my @rrarray=($rr1, $rr2, $rr3, $rr4, $rr5, $rr6, $rr7, $rr8, $rr9); +my @expectedrdata=($rr1, $rr2, $rr3, $rr7, $rr4, $rr5, $rr6, $rr8); +my @expectedpriority=($rr1, $rr7, $rr2, $rr3, $rr8, $rr6, $rr5, $rr4); + + + +is (scalar rrsort("SRV"),0,"rrsort returns properly with undefined arguments"); + +is (scalar rrsort("SRV",@rrarray),8,"rrsort returns properly with undefined attribute (1)"); + +is (scalar rrsort("SRV",,@rrarray),8,"rrsort returns properly with undefined attribute (2)"); + +is (scalar rrsort("SRV","",@rrarray),8,"rrsort returns properly with undefined attribute (3)"); + +my @prioritysorted= rrsort("SRV","priority",@rrarray); +my @defaultsorted= rrsort("SRV",@rrarray); +my @portsorted= rrsort("SRV","port",@rrarray); + +my @foosorted= rrsort("SRV","foo",@rrarray); +is (scalar @foosorted,8,"rrsort returns properly with undefined attribute (4)"); + +is (scalar @prioritysorted,8,"rrsort correctly maintains RRs test 1"); +is (scalar @portsorted,8,"rrsort correctly maintains RRs test 2"); +is (scalar rrsort("A","priority",@rrarray),1,"rrsort correctly maintains RRs test 3"); +is (scalar rrsort("MX","priority",@rrarray),0,"rrsort correctly maintains RRs test 4"); + +ok (eq_array(\@expectedpriority, \@prioritysorted), "Sorting on SRV priority works"); +ok (eq_array(\@expectedpriority, \@defaultsorted), "Default SRV sort works"); + + + +# +# Test with MX RRs. +# + +my $mxrr1=Net::DNS::RR->new("example.com. 600 IN MX 10 mx1.example.com"); +my $mxrr2=Net::DNS::RR->new("example.com. 600 IN MX 6 mx2.example.com"); + +my $mxrr3=Net::DNS::RR->new("example.com. 600 IN MX 66 mx3.example.com"); +my $mxrr4=Net::DNS::RR->new("example.com. 600 IN RT 6 rt1.example.com"); + + +my @mxrrarray=($mxrr1, $mxrr2, $mxrr3, $mxrr4); +my @expectedmxarray=($mxrr2,$mxrr1,$mxrr3); +my @sortedmxarray=rrsort("MX",@mxrrarray); + +ok (eq_array(\@expectedmxarray,\@sortedmxarray),"MX sorting"); + + + + +my $nsrr1=Net::DNS::RR->new("example.com. 600 IN NS ns2.example.com"); +my $nsrr2=Net::DNS::RR->new("example.com. 600 IN NS ns4.example.com"); +my $nsrr3=Net::DNS::RR->new("example.com. 600 IN NS ns1.example.com"); +my $nsrr4=Net::DNS::RR->new("example.com. 600 IN RT 6 rt1.example.com"); + +my @nsrrarray=($nsrr1, $nsrr2, $nsrr3, $nsrr4); +my @expectednsarray=($nsrr3,$nsrr1,$nsrr2); +my @sortednsarray=rrsort("NS",@nsrrarray); + + + + +ok (eq_array(\@expectednsarray,\@sortednsarray),"NS sorting"); diff --git a/t/07-zonefile.t b/t/07-zonefile.t new file mode 100644 index 0000000..d79020e --- /dev/null +++ b/t/07-zonefile.t @@ -0,0 +1,514 @@ +# $Id: 07-zonefile.t 1601 2017-10-10 14:17:01Z willem $ -*-perl-*- + +use strict; +use IO::File; + +use Test::More tests => 91; + + ## vvv verbatim from Domain.pm +use constant ASCII => ref eval { + require Encode; + Encode::find_encoding('ascii'); +}; + +use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see UTR#16 3.6] + Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); +}; + +use constant LIBIDN => defined eval 'require Net::LibIDN'; +use constant LIBIDN2 => ref eval 'require Net::LibIDN2; Net::LibIDN2->can("idn2_to_ascii_8")'; + ## ^^^ verbatim from Domain.pm + + +use constant LIBIDNOK => LIBIDN && scalar eval { + my $cn = pack( 'U*', 20013, 22269 ); + Net::LibIDN::idn_to_ascii( $cn, 'utf-8' ) eq 'xn--fiqs8s'; +}; + +use constant LIBIDN2OK => LIBIDN2 && scalar eval { + my $cn = pack( 'U*', 20013, 22269 ); + Net::LibIDN2::idn2_to_ascii_8( $cn, 9 ) eq 'xn--fiqs8s'; +}; + + +use_ok('Net::DNS::ZoneFile'); + + +my @file; +my $seq; + +END { + unlink $_ foreach @file; +} + +sub source { ## zone file builder + my $text = shift; + my @args = @_; + + my $tag = ++$seq; + my $file = "zone$tag.txt"; + + my $handle = new IO::File( $file, '>' ); # create test file + die "Failed to create $file" unless $handle; + eval { binmode($handle) }; # suppress encoding layer + push @file, $file; + + print $handle $text; + close $handle; + + return new Net::DNS::ZoneFile( $file, @args ); +} + + +my $recursive = join ' ', '$INCLUDE', source('$INCLUDE zone1.txt')->name; + + +{ + eval { new Net::DNS::ZoneFile(undef); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "new(): invalid argument\t[$exception]" ); +} + + +{ + eval { new Net::DNS::ZoneFile( [] ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "new(): not a file handle\t[$exception]" ); +} + + +{ + eval { new Net::DNS::ZoneFile('zone0.txt'); }; # presumed not to exist + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "new(): non-existent file\t[$exception]" ); +} + + +{ ## public methods + my $zonefile = source(''); + ok( $zonefile->isa('Net::DNS::ZoneFile'), 'new ZoneFile object' ); + + ok( defined $zonefile->name, 'zonefile->name always defined' ); + ok( defined $zonefile->line, 'zonefile->line always defined' ); + ok( defined $zonefile->origin, 'zonefile->origin always defined' ); + ok( !defined $zonefile->ttl, 'zonefile->ttl initially undefined' ); + my @rr = $zonefile->read; + is( scalar(@rr), 0, 'zonefile->read to end of file' ); + is( $zonefile->line, 0, 'zonefile->line zero if file empty' ); + + is( $zonefile->origin, '.', 'zonefile->origin defaults to DNS root' ); +} + + +{ ## initial origin + my $tld = 'test'; + my $absolute = source( '', "$tld." ); + is( $absolute->origin, "$tld.", 'new ZoneFile with absolute origin' ); + + my $relative = source( '', "$tld" ); + is( $relative->origin, "$tld.", 'new ZoneFile->origin always absolute' ); +} + + +{ ## line numbering + my $lines = 10; + my $zonefile = source( "\n" x $lines ); + is( $zonefile->line, 0, 'zonefile->line zero before calling read()' ); + my @rr = $zonefile->read; + is( $zonefile->line, $lines, 'zonefile->line number incremented by read()' ); +} + + +{ + my $zonefile = source <<'EOF'; +$TTL +EOF + eval { $zonefile->read; }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception:\t[$exception]" ); +} + + +{ + my $zonefile = source <<'EOF'; +$INCLUDE +EOF + eval { $zonefile->read; }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception:\t[$exception]" ); +} + + +{ + my $zonefile = source <<'EOF'; +$ORIGIN +EOF + eval { $zonefile->read; }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception:\t[$exception]" ); +} + + +{ + my $zonefile = source <<'EOF'; +$GENERATE +EOF + eval { $zonefile->read; }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception:\t[$exception]" ); +} + + +{ + my $zonefile = source <<'EOF'; +$BOGUS +EOF + eval { $zonefile->read; }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "exception:\t[$exception]" ); +} + + +{ ## $TTL directive at start of zone file + my $zonefile = source <<'EOF'; +$TTL 54321 +rr0 SOA mname rname 99 6h 1h 1w 12345 +EOF + is( $zonefile->read->ttl, 54321, 'SOA TTL set from $TTL directive' ); +} + + +{ ## no $TTL directive, default implicit + my $zonefile = source <<'EOF'; +rr0 SOA mname rname 99 6h 1h 1w 0 +rr1 NULL +EOF + is( $zonefile->read->ttl, 0, 'SOA TTL set from zero SOA minimum field' ); + is( $zonefile->read->ttl, 0, 'implicit zero default from SOA record' ); +} + + +{ ## $TTL directive following implicit default + my $zonefile = source <<'EOF'; +rr0 SOA mname rname 99 6h 1h 1w 12345 +rr1 NULL +$TTL 54321 +rr2 NULL +rr3 3h NULL +EOF + is( $zonefile->read->ttl, 12345, 'SOA TTL set from SOA minimum field' ); + is( $zonefile->read->ttl, 12345, 'implicit default from SOA record' ); + is( $zonefile->read->ttl, 54321, 'explicit default from $TTL directive' ); + is( $zonefile->read->ttl, 10800, 'explicit TTL value overrides default' ); + is( $zonefile->ttl, 54321, '$zonefile->ttl set from $TTL directive' ); +} + + +{ ## $INCLUDE directive + my $include = source <<'EOF'; +rr2 NULL +EOF + + my $directive = join ' ', '$INCLUDE', $include->name, '.'; + my $misdirect = join ' ', '$INCLUDE zone0.txt ; presumed not to exist'; + my $zonefile = source <<"EOF"; +rr1 NULL +$directive +rr3 NULL +$recursive +$misdirect +EOF + + my $fn1 = $zonefile->name; + my $rr1 = $zonefile->read; + is( $rr1->name, 'rr1', 'zonefile->read expected record' ); + is( $zonefile->name, $fn1, 'zonefile->name identifies file' ); + is( $zonefile->line, 1, 'zonefile->line identifies record' ); + + my $fn2 = $include->name; + my $rr2 = $zonefile->read; + my $sfx = $zonefile->origin; + is( $rr2->name, 'rr2', 'zonefile->read expected record' ); + is( $zonefile->name, $fn2, 'zonefile->name identifies file' ); + is( $zonefile->line, 1, 'zonefile->line identifies record' ); + + my $rr3 = $zonefile->read; + is( $rr3->name, 'rr3', 'zonefile->read expected record' ); + is( $zonefile->name, $fn1, 'zonefile->name identifies file' ); + is( $zonefile->line, 3, 'zonefile->line identifies record' ); + + { + my @rr = eval { $zonefile->read }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "recursive include\t[$exception]" ); + } + + { + my @rr = eval { $zonefile->read }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "non-existent include\t[$exception]" ); + } + is( $zonefile->name, $fn1, 'zonefile->name identifies file' ); + is( $zonefile->line, 5, 'zonefile->line identifies directive' ); +} + + +my $zonefile; +{ ## $ORIGIN directive + my $nested = source <<'EOF'; +nested NULL +EOF + + my $origin = 'example.com'; + my $ORIGIN = '$ORIGIN'; + my $inner = join ' ', '$INCLUDE', $nested->name; + my $include = source <<"EOF"; +$ORIGIN $origin +@ NS host +$inner +@ NULL +$ORIGIN relative +@ NULL +EOF + + my $outer = join ' ', '$INCLUDE', $include->name; + $zonefile = source <<"EOF"; +$outer +outer NULL + +$ORIGIN $origin + NULL +EOF + + my $ns = $zonefile->read; + is( $ns->name, $origin, '@ NS has expected name' ); + is( $ns->nsdname, "host.$origin", '@ NS has expected rdata' ); + + my $rr = $zonefile->read; + my $expect = join '.', 'nested', $origin; + is( $rr->name, $expect, 'scope of $ORIGIN encompasses nested $INCLUDE' ); + + is( $zonefile->read->name, $origin, 'scope of $ORIGIN continues after $INCLUDE' ); + + is( $zonefile->read->name, "relative.$origin", '$ORIGIN can be relative to current $ORIGIN' ); + + is( $zonefile->read->name, 'outer', 'scope of $ORIGIN curtailed by end of file' ); + is( $zonefile->read->name, $origin, 'implicit owner following $ORIGIN directive' ); +} + + +{ ## $GENERATE directive + my $zonefile = source <<'EOF'; +$GENERATE 0-0 @ TXT $ +$GENERATE 10-30/10 @ TXT $ +$GENERATE 30-10/-10 @ TXT $ +$GENERATE 123-123 @ TXT ${,,} +$GENERATE 123-123 @ TXT ${0,0,d} +$GENERATE 123-123 @ TXT ${0,0,o} +$GENERATE 123-123 @ TXT ${0,0,x} +$GENERATE 123-123 @ TXT ${0,0,X} +$GENERATE 123-123 @ TXT ${0,4,X} +$GENERATE 123-123 @ TXT ${4096,4,X} +$GENERATE 11259375 @ TXT ${0,6,n} +$GENERATE 11259375 @ TXT ${0,16,N} +$GENERATE 0-0 @ TXT ${0,0,Z} +EOF + is( $zonefile->read->rdstring, '0', 'generate TXT $' ); + is( $zonefile->read->rdstring, '10', 'generate TXT $ with step 10' ); + is( $zonefile->read->rdstring, '20', 'generate TXT $ with step 10' ); + is( $zonefile->read->rdstring, '30', 'generate TXT $ with step 10' ); + is( $zonefile->read->rdstring, '30', 'generate TXT $ with step -10' ); + is( $zonefile->read->rdstring, '20', 'generate TXT $ with step -10' ); + is( $zonefile->read->rdstring, '10', 'generate TXT $ with step -10' ); + is( $zonefile->read->rdstring, '123', 'generate TXT ${,,}' ); + is( $zonefile->read->rdstring, '123', 'generate TXT ${0,0,d}' ); + is( $zonefile->read->rdstring, '173', 'generate TXT ${0,0,o}' ); + is( $zonefile->read->rdstring, '7b', 'generate TXT ${0,0,x}' ); + is( $zonefile->read->rdstring, '7B', 'generate TXT ${0,0,X}' ); + is( $zonefile->read->rdstring, '007B', 'generate TXT ${0,4,X}' ); + is( $zonefile->read->rdstring, '107B', 'generate TXT ${4096,4,X}' ); + is( $zonefile->read->rdstring, 'f.e.d.', 'generate TXT ${0,6,n}' ); + is( $zonefile->read->rdstring, 'F.E.D.C.B.A.0.0.', 'generate TXT ${0,16,N}' ); + eval { $zonefile->read; }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unknown format:\t[$exception]" ); +} + + +{ + my $zonefile = source <<'EOF'; +$TTL 1234 +$ORIGIN example. +hosta A 192.0.2.1 +; whole line comment + ; indented comment +; vvv empty line + +; ^^^ empty line +; vvv line with white space + +; ^^^ line with white space + MX 10 hosta ; end of line comment + + TXT ( multiline ; interspersed ( mischievously ) + resource ; with ( confusing ) + record ) ; comments + TXT (string) + TXT "(string)" +EOF + is( $zonefile->read->name, 'hosta.example', 'name of simple RR as expected' ); + is( $zonefile->read->name, 'hosta.example', 'name of simple RR propagated from previous RR' ); + my $multilineRR = $zonefile->read; + is( $multilineRR->name, 'hosta.example', 'name of multiline RR propagated from previous RR' ); + is( $multilineRR->txtdata, 'multiline resource record', 'multiline RR correctly reassembled' ); + my $following = $zonefile->read; + is( $following->name, 'hosta.example', 'name of following RR as expected' ); + is( $following->txtdata, 'string', 'superfluous brackets ignored' ); + is( $zonefile->read->txtdata, '(string)', 'quoted brackets protected' ); +} + + +{ ## CLASS coersion + my $zonefile = source <<'EOF'; +rr0 CH NULL +rr1 CLASS1 NULL +rr2 CLASS2 NULL +rr3 CLASS3 NULL +EOF + my $rr = $zonefile->read; + foreach ( $zonefile->read ) { + is( $_->class, $rr->class, 'rr->class matches initial record' ); + } +} + + +{ ## compatibility with defunct Net::DNS::ZoneFile 1.04 distro + my $listref = Net::DNS::ZoneFile->read( $zonefile->name ); + ok( scalar(@$listref), 'read(): entire zone file' ); +} + + +{ + my $listref = Net::DNS::ZoneFile->read( $zonefile->name, '.' ); + ok( scalar(@$listref), 'read(): zone file via path' ); +} + + +{ + eval { + local $SIG{__WARN__} = sub { }; # presumed not to exist + my $listref = Net::DNS::ZoneFile->read( '/zone0.txt', '.' ); + }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "read(): non-existent file\t[$exception]" ); +} + + +{ + eval { + local $SIG{__WARN__} = sub { }; # presumed not to exist + my $listref = Net::DNS::ZoneFile->read( 'zone0.txt', 't' ); + }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "read(): non-existent file\t[$exception]" ); +} + + +{ + my $listref = Net::DNS::ZoneFile::read( $zonefile->name, '.' ); + ok( scalar(@$listref), 'read(): called as subroutine (not object-oriented)' ); +} + + +{ + my $string = ""; + my $listref = Net::DNS::ZoneFile->parse( \$string ); + is( scalar(@$listref), 0, 'parse(): empty string' ); +} + + +{ + my $string = <<'EOF'; +a1.example A 192.0.2.1 +a2.example A 192.0.2.2 +EOF + my $listref = Net::DNS::ZoneFile->parse( \$string ); # this also tests readfh() + is( scalar(@$listref), 2, 'parse(): RR string' ); +} + + +{ + my $string = <<'EOF'; +a1.example A 192.0.2.1 +$BOGUS +a2.example A 192.0.2.2 +EOF + local $SIG{__WARN__} = sub { }; + my $listref = Net::DNS::ZoneFile->parse( \$string ); + is( $listref, undef, 'parse(): erroneous string' ); +} + + +{ + my $string = <<'EOF'; +a1.example A 192.0.2.1 +a2.example A 192.0.2.2 +EOF + my @list = Net::DNS::ZoneFile->parse($string); + is( scalar(@list), 2, 'parse(): RR string into array' ); +} + + +{ + my $string = <<'EOF'; +a1.example A 192.0.2.1 +$BOGUS +a2.example A 192.0.2.2 +EOF + local $SIG{__WARN__} = sub { }; + my @list = Net::DNS::ZoneFile->parse($string); + is( scalar(@list), 1, 'parse(): erroneous string into array' ); +} + + +{ + my $listref = Net::DNS::ZoneFile::parse('a.example. A 192.0.2.1'); + ok( scalar(@$listref), 'parse(): called as subroutine (not object-oriented)' ); +} + + +SKIP: { ## Non-ASCII zone content + skip( 'Unicode/UTF-8 not supported', 4 ) unless UTF8; + + my $greek = pack 'C*', 103, 114, 9, 84, 88, 84, 9, 229, 224, 241, 231, 234, 225, 10; + my $file1 = source($greek); + my $fh1 = new IO::File( $file1->name, '<:encoding(ISO8859-7)' ); # Greek + my $zone1 = new Net::DNS::ZoneFile($fh1); + my $txtgr = $zone1->read; + my $text = pack 'U*', 949, 944, 961, 951, 954, 945; + is( $txtgr->txtdata, $text, 'ISO8859-7 TXT rdata' ); + + eval { binmode(DATA) }; # suppress encoding layer + my $jptxt = join "\n", ; + my $file2 = source($jptxt); + my $fh2 = new IO::File( $file2->name, '<:utf8' ); # UTF-8 character encoding + my $zone2 = new Net::DNS::ZoneFile($fh2); + my $txtrr = $zone2->read; # TXT RR with kanji RDATA + my @rdata = $txtrr->txtdata; + my $rdata = $txtrr->txtdata; + is( length($rdata), 12, 'Unicode/UTF-8 TXT rdata' ); + is( scalar(@rdata), 1, 'Unicode/UTF-8 TXT contiguous' ); + + skip( 'Non-ASCII domain - IDNA not supported', 1 ) unless LIBIDNOK || LIBIDN2OK; + + my $jpnull = $zone2->read; # NULL RR with kanji owner name + is( $jpnull->name, 'xn--wgv71a', 'Unicode/UTF-8 domain name' ); +} + + +exit; + +__END__ +jp TXT 古池や　蛙飛込む　水の音 ; Unicode text string +日本 NULL ; Unicode domain name + diff --git a/t/08-IPv4.t b/t/08-IPv4.t new file mode 100644 index 0000000..297e640 --- /dev/null +++ b/t/08-IPv4.t @@ -0,0 +1,626 @@ +# $Id: 08-IPv4.t 1628 2018-02-01 13:29:13Z willem $ -*-perl-*- + +use strict; +use Test::More; + +BEGIN { + local @INC = ( @INC, qw(t) ); + require NonFatal; +} + +use Net::DNS; +use IO::Select; + +my $debug = 0; + +my @hints = qw( + 198.41.0.4 + 192.228.79.201 + 192.33.4.12 + 199.7.91.13 + 192.203.230.10 + 192.5.5.241 + 192.112.36.4 + 198.97.190.53 + 192.36.148.17 + 192.58.128.30 + 193.0.14.129 + 199.7.83.42 + 202.12.27.33 + ); + +my $NOIP = qw(0.0.0.0); + +my @nsdname = qw( + ns.net-dns.org + mcvax.nlnet.nl + ns.nlnetlabs.nl + ); + + +exit( plan skip_all => 'Online tests disabled.' ) if -e 't/online.disabled'; +exit( plan skip_all => 'Online tests disabled.' ) unless -e 't/online.enabled'; + + +eval { + my $resolver = new Net::DNS::Resolver( igntc => 1 ); + exit plan skip_all => 'No nameservers' unless $resolver->nameservers; + + my $reply = $resolver->send(qw(. NS IN)) || die; + + my @ns = grep $_->type eq 'NS', $reply->answer, $reply->authority; + exit plan skip_all => 'Local nameserver broken' unless scalar @ns; + + 1; +} || exit( plan skip_all => 'Non-responding local nameserver' ); + + +eval { + my $resolver = new Net::DNS::Resolver( nameservers => [@hints] ); + exit plan skip_all => 'No IPv4 transport' unless $resolver->nameservers; + + my $reply = $resolver->send(qw(. NS IN)) || die; + my $from = $reply->answerfrom(); + + my @ns = grep $_->type eq 'NS', $reply->answer, $reply->authority; + exit plan skip_all => "Unexpected response from $from" unless scalar @ns; + + exit plan skip_all => "Non-authoritative response from $from" unless $reply->header->aa; + + 1; +} || exit( plan skip_all => 'Unable to reach global root nameservers' ); + + +my $IP = eval { + my $resolver = new Net::DNS::Resolver(); + $resolver->nameservers(@nsdname); + $resolver->force_v4(1); + [$resolver->nameservers()]; +}; +exit( plan skip_all => 'Unable to resolve nameserver name' ) unless scalar @$IP; + +diag join( "\n\t", 'will use nameservers', @$IP ) if $debug; + +Net::DNS::Resolver->debug($debug); + + +plan tests => 94; + +NonFatalBegin(); + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $udp = $resolver->send(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->send(...) UDP' ); + + $resolver->usevc(1); + + my $tcp = $resolver->send(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->send(...) TCP' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->dnssec(1); + $resolver->udppacketsize(513); + + $resolver->igntc(1); + my $udp = $resolver->send(qw(net-dns.org DNSKEY IN)); + ok( $udp && $udp->header->tc, '$resolver->send(...) truncated UDP reply' ); + + $resolver->igntc(0); + my $retry = $resolver->send(qw(net-dns.org DNSKEY IN)); + ok( $retry && !$retry->header->tc, '$resolver->send(...) automatic TCP retry' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->igntc(0); + + my $udp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->bgsend(...) UDP' ); + while ( $resolver->bgbusy($udp) ) { sleep 1; } + ok( $resolver->bgisready($udp), '$resolver->bgisready($udp)' ); + ok( $resolver->bgread($udp), '$resolver->bgread($udp)' ); + + $resolver->usevc(1); + + my $tcp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->bgsend(...) TCP' ); + while ( $resolver->bgbusy($tcp) ) { sleep 1; } + ok( $resolver->bgread($tcp), '$resolver->bgread($tcp)' ); + + ok( !$resolver->bgbusy(undef), '!$resolver->bgbusy(undef)' ); + ok( !$resolver->bgread(undef), '!$resolver->bgread(undef)' ); + + $resolver->udp_timeout(0); + ok( !$resolver->bgread( ref($udp)->new ), '!$resolver->bgread(Socket->new)' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->dnssec(1); + $resolver->udppacketsize(513); + $resolver->igntc(1); + + my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); + ok( $handle, '$resolver->bgsend(...) truncated UDP' ); + my $packet = $resolver->bgread($handle); + ok( $packet && $packet->header->tc, '$resolver->bgread($udp) ignore UDP truncation' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->dnssec(1); + $resolver->udppacketsize(513); + $resolver->igntc(0); + + my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); + ok( $handle, '$resolver->bgsend(...) truncated UDP' ); + my $packet = $resolver->bgread($handle); + ok( $packet && !$packet->header->tc, '$resolver->bgread($tcp) background TCP retry' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->dnssec(1); + $resolver->udppacketsize(513); + $resolver->igntc(0); + + my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); + $resolver->nameserver($NOIP); + my $packet = $resolver->bgread($handle); + ok( $packet && $packet->header->tc, '$resolver->bgread($udp) background TCP fail' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + delete ${*$handle}{net_dns_bg}; + my $bgread = $resolver->bgread($handle); + ok( $bgread, '$resolver->bgread($udp) workaround for SpamAssassin' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->persistent_udp(1); + + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $handle, '$resolver->bgsend(...) persistent UDP' ); + my $bgread = $resolver->bgread($handle); + ok( $bgread, '$resolver->bgread($udp)' ); + my $test = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $test, '$resolver->bgsend(...) persistent UDP' ); + is( $test, $handle, 'same UDP socket object used' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->persistent_tcp(1); + $resolver->usevc(1); + + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $handle, '$resolver->bgsend(...) persistent TCP' ); + my $bgread = $resolver->bgread($handle); + ok( $bgread, '$resolver->bgread($tcp)' ); + my $test = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $test, '$resolver->bgsend(...) persistent TCP' ); + is( $test, $handle, 'same TCP socket object used' ); + eval { close($handle) }; + my $recover = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $recover, 'connection recovered after close' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->srcaddr($NOIP); + + my $udp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->bgsend(...) specify UDP local address' ); + + $resolver->usevc(1); + + my $tcp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->bgsend(...) specify TCP local address' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->srcport(2345); + + my $udp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->bgsend(...) specify UDP source port' ); + + $resolver->usevc(1); + + my $tcp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->bgsend(...) specify TCP source port' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + my $badport = -1; + $resolver->srcport($badport); + + my $udp = $resolver->send(qw(net-dns.org SOA IN)); + ok( !$udp, "\$resolver->send(...) reject UDP source port $badport" ); + + $resolver->usevc(1); + + my $tcp = $resolver->send(qw(net-dns.org SOA IN)); + ok( !$tcp, "\$resolver->send(...) reject TCP source port $badport" ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + my $badport = -1; + $resolver->srcport($badport); + + my $udp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( !$udp, "\$resolver->bgsend(...) reject UDP source port $badport" ); + + $resolver->usevc(1); + + my $tcp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( !$tcp, "\$resolver->bgsend(...) reject TCP source port $badport" ); +} + + +SKIP: { + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->domain('net-dns.org'); + eval { $resolver->tsig( $resolver->query(qw(tsig-md5 KEY))->answer ) }; + skip( 'automatic TSIG tests', 3 ) if $@; + + $resolver->igntc(1); + + my $udp = $resolver->send(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->send(...) UDP + automatic TSIG' ); + + $resolver->usevc(1); + + my $tcp = $resolver->send(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->send(...) TCP + automatic TSIG' ); + + my $bgread; + foreach my $ip (@$IP) { + $resolver->nameserver($ip); + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + last if $bgread = $resolver->bgread($handle); + } + ok( $bgread, '$resolver->bgsend/read TCP + automatic TSIG' ); +} + + +SKIP: { + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->igntc(1); + + eval { $resolver->tsig( 'MD5.example', 'MD5keyMD5keyMD5keyMD5keyMD5=' ) }; + skip( 'failed TSIG tests', 3 ) if $@; + + my $udp = $resolver->send(qw(net-dns.org SOA IN)); + ok( !$udp, '$resolver->send(...) UDP + failed TSIG' ); + + $resolver->usevc(1); + + my $tcp = $resolver->send(qw(net-dns.org SOA IN)); + ok( !$tcp, '$resolver->send(...) TCP + failed TSIG' ); + + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + my $bgread = $resolver->bgread($handle); + ok( !$bgread, '$resolver->bgsend/read TCP + failed TSIG' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->retrans(0); + $resolver->retry(0); + + my @query = ( undef, qw(SOA IN) ); + ok( $resolver->query(@query), '$resolver->query( undef, ... ) defaults to "." ' ); + ok( $resolver->search(@query), '$resolver->search( undef, ... ) defaults to "." ' ); + + $resolver->defnames(0); + $resolver->dnsrch(0); + ok( $resolver->search(@query), '$resolver->search() without dnsrch & defnames' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->searchlist('net'); + + my @query = (qw(us SOA IN)); + ok( $resolver->query(@query), '$resolver->query( name, ... )' ); + ok( $resolver->search(@query), '$resolver->search( name, ... )' ); + + $resolver->defnames(0); + $resolver->dnsrch(0); + ok( $resolver->query(@query), '$resolver->query() without defnames' ); + ok( $resolver->search(@query), '$resolver->search() without dnsrch' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $udp = $resolver->query(qw(bogus.net-dns.org A IN)); + ok( !$udp, '$resolver->query() nonexistent name UDP' ); + + $resolver->usevc(1); + + my $tcp = $resolver->query(qw(bogus.net-dns.org A IN)); + ok( !$tcp, '$resolver->query() nonexistent name TCP' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + my $update = new Net::DNS::Update(qw(example.com)); + ok( $resolver->send($update), '$resolver->send($update) UDP' ); + $resolver->usevc(1); + ok( $resolver->send($update), '$resolver->send($update) TCP' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $NOIP ); + $resolver->retrans(0); + $resolver->retry(0); + $resolver->tcp_timeout(0); + + my @query = (qw(:: SOA IN)); + my $query = new Net::DNS::Packet(@query); + ok( !$resolver->query(@query), '$resolver->query() failure' ); + ok( !$resolver->search(@query), '$resolver->search() failure' ); + + $query->edns->option( 65001, pack 'x500' ); # pad to force TCP + ok( !$resolver->send($query), '$resolver->send() failure' ); + ok( !$resolver->bgsend($query), '$resolver->bgsend() failure' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $mx = 'mx2.t.net-dns.org'; + my @rr = rr( $resolver, $mx, 'MX' ); + + is( scalar(@rr), 2, 'Net::DNS::rr() works with specified resolver' ); + is( scalar rr( $resolver, $mx, 'MX' ), 2, 'Net::DNS::rr() works in scalar context' ); + is( scalar rr( $mx, 'MX' ), 2, 'Net::DNS::rr() works with default resolver' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $mx = 'mx2.t.net-dns.org'; + my @mx = mx( $resolver, $mx ); + + is( scalar(@mx), 2, 'Net::DNS::mx() works with specified resolver' ); + + # some people seem to use mx() in scalar context + is( scalar mx( $resolver, $mx ), 2, 'Net::DNS::mx() works in scalar context' ); + + is( scalar mx($mx), 2, 'Net::DNS::mx() works with default resolver' ); + + is( scalar mx('bogus.t.net-dns.org'), 0, "Net::DNS::mx() works for bogus name" ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->tcp_timeout(10); + + my @zone = $resolver->axfr('net-dns.org'); + ok( scalar(@zone), '$resolver->axfr() returns entire zone in list context' ); + + my @notauth = $resolver->axfr('bogus.net-dns.org'); + my $notauth = $resolver->errorstring; + ok( !scalar(@notauth), "mismatched zone\t[$notauth]" ); + + my $iterator = $resolver->axfr('net-dns.org'); + ok( ref($iterator), '$resolver->axfr() returns iterator in scalar context' ); + + my $soa = eval { $iterator->() }; + is( ref($soa), 'Net::DNS::RR::SOA', '$iterator->() returns initial SOA RR' ); + + my $i; + eval { + return unless $soa; + $soa->serial(undef); # force SOA mismatch + while ( $iterator->() ) { $i++; } + }; + my ($exception) = split /\n/, "$@\n"; + ok( $i, '$iterator->() iterates through remaining RRs' ); + ok( !eval { $iterator->() }, '$iterator->() returns undef after last RR' ); + ok( $exception, "iterator exception\t[$exception]" ); + + my $axfr_start = $resolver->axfr_start('net-dns.org'); + ok( $axfr_start, '$resolver->axfr_start() (historical)' ); + ok( eval { $resolver->axfr_next() }, '$resolver->axfr_next() (historical)' ); + ok( $resolver->answerfrom(), '$resolver->answerfrom() works' ); + + $resolver->srcport(-1); + my @badsocket = $resolver->axfr(); + my $badsocket = $resolver->errorstring; + ok( !scalar(@badsocket), "bad AXFR socket\t[$badsocket]" ); +} + + +SKIP: { + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->domain('net-dns.org'); + eval { $resolver->tsig( $resolver->query(qw(tsig-md5 KEY))->answer ) }; + skip( 'TSIG AXFR tests', 4 ) if $@; + $resolver->tcp_timeout(10); + + my @zone = $resolver->axfr(); + ok( scalar(@zone), '$resolver->axfr() with TSIG verify' ); + + my @notauth = $resolver->axfr('bogus.net-dns.org'); + my $notauth = $resolver->errorstring; + ok( !scalar(@notauth), "mismatched zone\t[$notauth]" ); + + eval { $resolver->tsig( 'MD5.example', 'MD5keyMD5keyMD5keyMD5keyMD5=' ) }; + my @unverifiable = $resolver->axfr(); + my $errorstring = $resolver->errorstring; + ok( !scalar(@unverifiable), "mismatched key\t[$errorstring]" ); + + eval { $resolver->tsig(undef) }; + my ($exception) = split /\n/, "$@\n"; + ok( $exception, "undefined TSIG\t[$exception]" ); +} + + +SKIP: { + my $resolver = Net::DNS::Resolver->new( nameservers => $NOIP ); + eval { $resolver->tsig( 'MD5.example', 'MD5keyMD5keyMD5keyMD5keyMD5=' ) }; + skip( 'TSIG AXFR tests', 2 ) if $@; + + my $query = new Net::DNS::Packet(qw(. SOA IN)); + ok( $resolver->bgsend($query), '$resolver->bgsend() + automatic TSIG' ); + ok( $resolver->bgsend($query), '$resolver->bgsend() + existing TSIG' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->nameservers(); + ok( !$resolver->send(qw(. NS)), 'no nameservers' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->nameserver('cname.t.net-dns.org'); + ok( scalar( $resolver->nameservers ), 'resolve nameserver cname' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + my @warnings; + local $SIG{__WARN__} = sub { push( @warnings, "@_" ); }; + my $ns = 'bogus.example.com.'; + my @ip = $resolver->nameserver($ns); + + my ($warning) = split /\n/, "@warnings\n"; + ok( $warning, "unresolved nameserver warning\t[$warning]" ) + || diag "\tnon-existent '$ns' resolved: @ip"; +} + + +{ ## exercise exceptions in _axfr_next() + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->domain('net-dns.org'); + eval { $resolver->tsig( $resolver->query(qw(tsig-md5 KEY))->answer ) }; + $resolver->tcp_timeout(10); + + { + my $select = new IO::Select(); + eval { $resolver->_axfr_next($select); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "TCP time out\t[$exception]" ); + } + + { + my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); + my $socket = $resolver->_bgsend_tcp( $packet, $packet->data ); + my $select = new IO::Select($socket); + while ( $resolver->bgbusy($socket) ) { sleep 1 } + my $discarded = ''; ## [size][id][status] [qdcount]... + $socket->recv( $discarded, 6 ) if $socket; + eval { $resolver->_axfr_next($select); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt data\t[$exception]" ); + } + +SKIP: { + my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); + my $socket = $resolver->_bgsend_tcp( $packet, $packet->data ); + my $tsigrr = $packet->sigrr; + skip( 'verify fail', 1 ) unless $tsigrr; + + my $select = new IO::Select($socket); + eval { $resolver->_axfr_next( $select, $tsigrr ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "verify fail\t[$exception]" ); + } +} + + +{ ## exercise error paths in _send_???() and bgbusy() + my $resolver = Net::DNS::Resolver->new( nameservers => $IP, retry => 1 ); + my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); + + my $mismatch = $resolver->_make_query_packet(qw(net-dns.org SOA)); + ok( !$resolver->_send_tcp( $mismatch, $packet->data ), '_send_tcp() id mismatch' ); + ok( !$resolver->_send_udp( $mismatch, $packet->data ), '_send_udp() id mismatch' ); + my $handle = $resolver->_bgsend_udp( $mismatch, $packet->data ); + ok( !$resolver->bgread($handle), 'bgbusy() id mismatch' ); +} + + +{ ## exercise error paths in _accept_reply() + my $resolver = Net::DNS::Resolver->new( nameservers => $NOIP ); + + my $query = new Net::DNS::Packet(qw(net-dns.org SOA IN)); + my $reply = new Net::DNS::Packet(qw(net-dns.org SOA IN)); + $reply->header->qr(1); + + ok( !$resolver->_accept_reply(undef), '_accept_reply() corrupt reply' ); + + ok( !$resolver->_accept_reply($query), '_accept_reply() qr not set' ); + + ok( !$resolver->_accept_reply( $reply, $query ), '_accept_reply() id mismatch' ); +} + + +{ ## exercise error path in _read_tcp() + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->tcp_timeout(10); + + my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); + my $socket = $resolver->_bgsend_tcp( $packet, $packet->data ); + while ( $resolver->bgbusy($socket) ) { sleep 1 } + + my $size_buf = ''; + $socket->recv( $size_buf, 2 ) if $socket; + my ($size) = unpack 'n*', $size_buf; + my $discarded = ''; ## data dependent: last 16 bits must not all be zero + $socket->recv( $discarded, $size - 2 ) if $size; + + ok( !$resolver->_bgread($socket), '_read_tcp() corrupt data' ); +} + + +{ ## exercise Net::DNS::Extlang query + ok( Net::DNS::RR->new('. MD'), 'Net::DNS::Extlang query' ); +} + + +NonFatalEnd(); + +exit; + +__END__ + diff --git a/t/08-IPv6.t b/t/08-IPv6.t new file mode 100644 index 0000000..fbeab2f --- /dev/null +++ b/t/08-IPv6.t @@ -0,0 +1,629 @@ +# $Id: 08-IPv6.t 1628 2018-02-01 13:29:13Z willem $ -*-perl-*- + +use strict; +use Test::More; + +BEGIN { + local @INC = ( @INC, qw(t) ); + require NonFatal; +} + +use Net::DNS; +use IO::Select; + +my $debug = 0; + +my @hints = qw( + 2001:503:ba3e::2:30 + 2001:500:84::b + 2001:500:2::c + 2001:500:2d::d + 2001:500:a8::e + 2001:500:2f::f + 2001:500:12::d0d + 2001:500:1::53 + 2001:7fe::53 + 2001:503:c27::2:30 + 2001:7fd::1 + 2001:500:9f::42 + 2001:dc3::35 + ); + +my $NOIP = qw(::); + +my @nsdname = qw( + ns.net-dns.org + mcvax.nlnet.nl + ns.nlnetlabs.nl + ); + + +exit( plan skip_all => 'Online tests disabled.' ) if -e 't/online.disabled'; +exit( plan skip_all => 'Online tests disabled.' ) unless -e 't/online.enabled'; + +exit( plan skip_all => 'IPv6 tests disabled.' ) if -e 't/IPv6.disabled'; +exit( plan skip_all => 'IPv6 tests disabled.' ) unless -e 't/IPv6.enabled'; + + +eval { + my $resolver = new Net::DNS::Resolver( igntc => 1 ); + exit plan skip_all => 'No nameservers' unless $resolver->nameservers; + + my $reply = $resolver->send(qw(. NS IN)) || die; + + my @ns = grep $_->type eq 'NS', $reply->answer, $reply->authority; + exit plan skip_all => 'Local nameserver broken' unless scalar @ns; + + 1; +} || exit( plan skip_all => 'Non-responding local nameserver' ); + + +eval { + my $resolver = new Net::DNS::Resolver( nameservers => [@hints] ); + exit plan skip_all => 'No IPv6 transport' unless $resolver->nameservers; + + my $reply = $resolver->send(qw(. NS IN)) || die; + my $from = $reply->answerfrom(); + + my @ns = grep $_->type eq 'NS', $reply->answer, $reply->authority; + exit plan skip_all => "Unexpected response from $from" unless scalar @ns; + + exit plan skip_all => "Non-authoritative response from $from" unless $reply->header->aa; + + 1; +} || exit( plan skip_all => 'Unable to reach global root nameservers' ); + + +my $IP = eval { + my $resolver = new Net::DNS::Resolver(); + $resolver->nameservers(@nsdname); + $resolver->force_v6(1); + [$resolver->nameservers()]; +}; +exit( plan skip_all => 'Unable to resolve nameserver name' ) unless scalar @$IP; + +diag join( "\n\t", 'will use nameservers', @$IP ) if $debug; + +Net::DNS::Resolver->debug($debug); + + +plan tests => 94; + +NonFatalBegin(); + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $udp = $resolver->send(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->send(...) UDP' ); + + $resolver->usevc(1); + + my $tcp = $resolver->send(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->send(...) TCP' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->dnssec(1); + $resolver->udppacketsize(513); + + $resolver->igntc(1); + my $udp = $resolver->send(qw(net-dns.org DNSKEY IN)); + ok( $udp && $udp->header->tc, '$resolver->send(...) truncated UDP reply' ); + + $resolver->igntc(0); + my $retry = $resolver->send(qw(net-dns.org DNSKEY IN)); + ok( $retry && !$retry->header->tc, '$resolver->send(...) automatic TCP retry' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->igntc(0); + + my $udp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->bgsend(...) UDP' ); + while ( $resolver->bgbusy($udp) ) { sleep 1; } + ok( $resolver->bgisready($udp), '$resolver->bgisready($udp)' ); + ok( $resolver->bgread($udp), '$resolver->bgread($udp)' ); + + $resolver->usevc(1); + + my $tcp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->bgsend(...) TCP' ); + while ( $resolver->bgbusy($tcp) ) { sleep 1; } + ok( $resolver->bgread($tcp), '$resolver->bgread($tcp)' ); + + ok( !$resolver->bgbusy(undef), '!$resolver->bgbusy(undef)' ); + ok( !$resolver->bgread(undef), '!$resolver->bgread(undef)' ); + + $resolver->udp_timeout(0); + ok( !$resolver->bgread( ref($udp)->new ), '!$resolver->bgread(Socket->new)' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->dnssec(1); + $resolver->udppacketsize(513); + $resolver->igntc(1); + + my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); + ok( $handle, '$resolver->bgsend(...) truncated UDP' ); + my $packet = $resolver->bgread($handle); + ok( $packet && $packet->header->tc, '$resolver->bgread($udp) ignore UDP truncation' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->dnssec(1); + $resolver->udppacketsize(513); + $resolver->igntc(0); + + my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); + ok( $handle, '$resolver->bgsend(...) truncated UDP' ); + my $packet = $resolver->bgread($handle); + ok( $packet && !$packet->header->tc, '$resolver->bgread($tcp) background TCP retry' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->dnssec(1); + $resolver->udppacketsize(513); + $resolver->igntc(0); + + my $handle = $resolver->bgsend(qw(net-dns.org DNSKEY IN)); + $resolver->nameserver($NOIP); + my $packet = $resolver->bgread($handle); + ok( $packet && $packet->header->tc, '$resolver->bgread($udp) background TCP fail' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + delete ${*$handle}{net_dns_bg}; + my $bgread = $resolver->bgread($handle); + ok( $bgread, '$resolver->bgread($udp) workaround for SpamAssassin' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->persistent_udp(1); + + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $handle, '$resolver->bgsend(...) persistent UDP' ); + my $bgread = $resolver->bgread($handle); + ok( $bgread, '$resolver->bgread($udp)' ); + my $test = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $test, '$resolver->bgsend(...) persistent UDP' ); + is( $test, $handle, 'same UDP socket object used' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->persistent_tcp(1); + $resolver->usevc(1); + + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $handle, '$resolver->bgsend(...) persistent TCP' ); + my $bgread = $resolver->bgread($handle); + ok( $bgread, '$resolver->bgread($tcp)' ); + my $test = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $test, '$resolver->bgsend(...) persistent TCP' ); + is( $test, $handle, 'same TCP socket object used' ); + eval { close($handle) }; + my $recover = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $recover, 'connection recovered after close' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->srcaddr($NOIP); + + my $udp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->bgsend(...) specify UDP local address' ); + + $resolver->usevc(1); + + my $tcp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->bgsend(...) specify TCP local address' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->srcport(2345); + + my $udp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->bgsend(...) specify UDP source port' ); + + $resolver->usevc(1); + + my $tcp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->bgsend(...) specify TCP source port' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + my $badport = -1; + $resolver->srcport($badport); + + my $udp = $resolver->send(qw(net-dns.org SOA IN)); + ok( !$udp, "\$resolver->send(...) reject UDP source port $badport" ); + + $resolver->usevc(1); + + my $tcp = $resolver->send(qw(net-dns.org SOA IN)); + ok( !$tcp, "\$resolver->send(...) reject TCP source port $badport" ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + my $badport = -1; + $resolver->srcport($badport); + + my $udp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( !$udp, "\$resolver->bgsend(...) reject UDP source port $badport" ); + + $resolver->usevc(1); + + my $tcp = $resolver->bgsend(qw(net-dns.org SOA IN)); + ok( !$tcp, "\$resolver->bgsend(...) reject TCP source port $badport" ); +} + + +SKIP: { + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->domain('net-dns.org'); + eval { $resolver->tsig( $resolver->query(qw(tsig-md5 KEY))->answer ) }; + skip( 'automatic TSIG tests', 3 ) if $@; + + $resolver->igntc(1); + + my $udp = $resolver->send(qw(net-dns.org SOA IN)); + ok( $udp, '$resolver->send(...) UDP + automatic TSIG' ); + + $resolver->usevc(1); + + my $tcp = $resolver->send(qw(net-dns.org SOA IN)); + ok( $tcp, '$resolver->send(...) TCP + automatic TSIG' ); + + my $bgread; + foreach my $ip (@$IP) { + $resolver->nameserver($ip); + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + last if $bgread = $resolver->bgread($handle); + } + ok( $bgread, '$resolver->bgsend/read TCP + automatic TSIG' ); +} + + +SKIP: { + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->igntc(1); + + eval { $resolver->tsig( 'MD5.example', 'MD5keyMD5keyMD5keyMD5keyMD5=' ) }; + skip( 'failed TSIG tests', 3 ) if $@; + + my $udp = $resolver->send(qw(net-dns.org SOA IN)); + ok( !$udp, '$resolver->send(...) UDP + failed TSIG' ); + + $resolver->usevc(1); + + my $tcp = $resolver->send(qw(net-dns.org SOA IN)); + ok( !$tcp, '$resolver->send(...) TCP + failed TSIG' ); + + my $handle = $resolver->bgsend(qw(net-dns.org SOA IN)); + my $bgread = $resolver->bgread($handle); + ok( !$bgread, '$resolver->bgsend/read TCP + failed TSIG' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->retrans(0); + $resolver->retry(0); + + my @query = ( undef, qw(SOA IN) ); + ok( $resolver->query(@query), '$resolver->query( undef, ... ) defaults to "." ' ); + ok( $resolver->search(@query), '$resolver->search( undef, ... ) defaults to "." ' ); + + $resolver->defnames(0); + $resolver->dnsrch(0); + ok( $resolver->search(@query), '$resolver->search() without dnsrch & defnames' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->searchlist('net'); + + my @query = (qw(us SOA IN)); + ok( $resolver->query(@query), '$resolver->query( name, ... )' ); + ok( $resolver->search(@query), '$resolver->search( name, ... )' ); + + $resolver->defnames(0); + $resolver->dnsrch(0); + ok( $resolver->query(@query), '$resolver->query() without defnames' ); + ok( $resolver->search(@query), '$resolver->search() without dnsrch' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $udp = $resolver->query(qw(bogus.net-dns.org A IN)); + ok( !$udp, '$resolver->query() nonexistent name UDP' ); + + $resolver->usevc(1); + + my $tcp = $resolver->query(qw(bogus.net-dns.org A IN)); + ok( !$tcp, '$resolver->query() nonexistent name TCP' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + my $update = new Net::DNS::Update(qw(example.com)); + ok( $resolver->send($update), '$resolver->send($update) UDP' ); + $resolver->usevc(1); + ok( $resolver->send($update), '$resolver->send($update) TCP' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $NOIP ); + $resolver->retrans(0); + $resolver->retry(0); + $resolver->tcp_timeout(0); + + my @query = (qw(:: SOA IN)); + my $query = new Net::DNS::Packet(@query); + ok( !$resolver->query(@query), '$resolver->query() failure' ); + ok( !$resolver->search(@query), '$resolver->search() failure' ); + + $query->edns->option( 65001, pack 'x500' ); # pad to force TCP + ok( !$resolver->send($query), '$resolver->send() failure' ); + ok( !$resolver->bgsend($query), '$resolver->bgsend() failure' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $mx = 'mx2.t.net-dns.org'; + my @rr = rr( $resolver, $mx, 'MX' ); + + is( scalar(@rr), 2, 'Net::DNS::rr() works with specified resolver' ); + is( scalar rr( $resolver, $mx, 'MX' ), 2, 'Net::DNS::rr() works in scalar context' ); + is( scalar rr( $mx, 'MX' ), 2, 'Net::DNS::rr() works with default resolver' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + + my $mx = 'mx2.t.net-dns.org'; + my @mx = mx( $resolver, $mx ); + + is( scalar(@mx), 2, 'Net::DNS::mx() works with specified resolver' ); + + # some people seem to use mx() in scalar context + is( scalar mx( $resolver, $mx ), 2, 'Net::DNS::mx() works in scalar context' ); + + is( scalar mx($mx), 2, 'Net::DNS::mx() works with default resolver' ); + + is( scalar mx('bogus.t.net-dns.org'), 0, "Net::DNS::mx() works for bogus name" ); +} + + +{ + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->tcp_timeout(10); + + my @zone = $resolver->axfr('net-dns.org'); + ok( scalar(@zone), '$resolver->axfr() returns entire zone in list context' ); + + my @notauth = $resolver->axfr('bogus.net-dns.org'); + my $notauth = $resolver->errorstring; + ok( !scalar(@notauth), "mismatched zone\t[$notauth]" ); + + my $iterator = $resolver->axfr('net-dns.org'); + ok( ref($iterator), '$resolver->axfr() returns iterator in scalar context' ); + + my $soa = eval { $iterator->() }; + is( ref($soa), 'Net::DNS::RR::SOA', '$iterator->() returns initial SOA RR' ); + + my $i; + eval { + return unless $soa; + $soa->serial(undef); # force SOA mismatch + while ( $iterator->() ) { $i++; } + }; + my ($exception) = split /\n/, "$@\n"; + ok( $i, '$iterator->() iterates through remaining RRs' ); + ok( !eval { $iterator->() }, '$iterator->() returns undef after last RR' ); + ok( $exception, "iterator exception\t[$exception]" ); + + my $axfr_start = $resolver->axfr_start('net-dns.org'); + ok( $axfr_start, '$resolver->axfr_start() (historical)' ); + ok( eval { $resolver->axfr_next() }, '$resolver->axfr_next() (historical)' ); + ok( $resolver->answerfrom(), '$resolver->answerfrom() works' ); + + $resolver->srcport(-1); + my @badsocket = $resolver->axfr(); + my $badsocket = $resolver->errorstring; + ok( !scalar(@badsocket), "bad AXFR socket\t[$badsocket]" ); +} + + +SKIP: { + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->domain('net-dns.org'); + eval { $resolver->tsig( $resolver->query(qw(tsig-md5 KEY))->answer ) }; + skip( 'TSIG AXFR tests', 4 ) if $@; + $resolver->tcp_timeout(10); + + my @zone = $resolver->axfr(); + ok( scalar(@zone), '$resolver->axfr() with TSIG verify' ); + + my @notauth = $resolver->axfr('bogus.net-dns.org'); + my $notauth = $resolver->errorstring; + ok( !scalar(@notauth), "mismatched zone\t[$notauth]" ); + + eval { $resolver->tsig( 'MD5.example', 'MD5keyMD5keyMD5keyMD5keyMD5=' ) }; + my @unverifiable = $resolver->axfr(); + my $errorstring = $resolver->errorstring; + ok( !scalar(@unverifiable), "mismatched key\t[$errorstring]" ); + + eval { $resolver->tsig(undef) }; + my ($exception) = split /\n/, "$@\n"; + ok( $exception, "undefined TSIG\t[$exception]" ); +} + + +SKIP: { + my $resolver = Net::DNS::Resolver->new( nameservers => $NOIP ); + eval { $resolver->tsig( 'MD5.example', 'MD5keyMD5keyMD5keyMD5keyMD5=' ) }; + skip( 'TSIG AXFR tests', 2 ) if $@; + + my $query = new Net::DNS::Packet(qw(. SOA IN)); + ok( $resolver->bgsend($query), '$resolver->bgsend() + automatic TSIG' ); + ok( $resolver->bgsend($query), '$resolver->bgsend() + existing TSIG' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->nameservers(); + ok( !$resolver->send(qw(. NS)), 'no nameservers' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + $resolver->nameserver('cname.t.net-dns.org'); + ok( scalar( $resolver->nameservers ), 'resolve nameserver cname' ); +} + + +{ + my $resolver = Net::DNS::Resolver->new(); + my @warnings; + local $SIG{__WARN__} = sub { push( @warnings, "@_" ); }; + my $ns = 'bogus.example.com.'; + my @ip = $resolver->nameserver($ns); + + my ($warning) = split /\n/, "@warnings\n"; + ok( $warning, "unresolved nameserver warning\t[$warning]" ) + || diag "\tnon-existent '$ns' resolved: @ip"; +} + + +{ ## exercise exceptions in _axfr_next() + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->domain('net-dns.org'); + eval { $resolver->tsig( $resolver->query(qw(tsig-md5 KEY))->answer ) }; + $resolver->tcp_timeout(10); + + { + my $select = new IO::Select(); + eval { $resolver->_axfr_next($select); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "TCP time out\t[$exception]" ); + } + + { + my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); + my $socket = $resolver->_bgsend_tcp( $packet, $packet->data ); + my $select = new IO::Select($socket); + while ( $resolver->bgbusy($socket) ) { sleep 1 } + my $discarded = ''; ## [size][id][status] [qdcount]... + $socket->recv( $discarded, 6 ) if $socket; + eval { $resolver->_axfr_next($select); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "corrupt data\t[$exception]" ); + } + +SKIP: { + my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); + my $socket = $resolver->_bgsend_tcp( $packet, $packet->data ); + my $tsigrr = $packet->sigrr; + skip( 'verify fail', 1 ) unless $tsigrr; + + my $select = new IO::Select($socket); + eval { $resolver->_axfr_next( $select, $tsigrr ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "verify fail\t[$exception]" ); + } +} + + +{ ## exercise error paths in _send_???() and bgbusy() + my $resolver = Net::DNS::Resolver->new( nameservers => $IP, retry => 1 ); + my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); + + my $mismatch = $resolver->_make_query_packet(qw(net-dns.org SOA)); + ok( !$resolver->_send_tcp( $mismatch, $packet->data ), '_send_tcp() id mismatch' ); + ok( !$resolver->_send_udp( $mismatch, $packet->data ), '_send_udp() id mismatch' ); + my $handle = $resolver->_bgsend_udp( $mismatch, $packet->data ); + ok( !$resolver->bgread($handle), 'bgbusy() id mismatch' ); +} + + +{ ## exercise error paths in _accept_reply() + my $resolver = Net::DNS::Resolver->new( nameservers => $NOIP ); + + my $query = new Net::DNS::Packet(qw(net-dns.org SOA IN)); + my $reply = new Net::DNS::Packet(qw(net-dns.org SOA IN)); + $reply->header->qr(1); + + ok( !$resolver->_accept_reply(undef), '_accept_reply() corrupt reply' ); + + ok( !$resolver->_accept_reply($query), '_accept_reply() qr not set' ); + + ok( !$resolver->_accept_reply( $reply, $query ), '_accept_reply() id mismatch' ); +} + + +{ ## exercise error path in _read_tcp() + my $resolver = Net::DNS::Resolver->new( nameservers => $IP ); + $resolver->tcp_timeout(10); + + my $packet = $resolver->_make_query_packet(qw(net-dns.org SOA)); + my $socket = $resolver->_bgsend_tcp( $packet, $packet->data ); + while ( $resolver->bgbusy($socket) ) { sleep 1 } + + my $size_buf = ''; + $socket->recv( $size_buf, 2 ) if $socket; + my ($size) = unpack 'n*', $size_buf; + my $discarded = ''; ## data dependent: last 16 bits must not all be zero + $socket->recv( $discarded, $size - 2 ) if $size; + + ok( !$resolver->_bgread($socket), '_read_tcp() corrupt data' ); +} + + +{ ## exercise Net::DNS::Extlang query + ok( Net::DNS::RR->new('. MD'), 'Net::DNS::Extlang query' ); +} + + +NonFatalEnd(); + +exit; + +__END__ + diff --git a/t/08-recurse.t b/t/08-recurse.t new file mode 100644 index 0000000..6ab1182 --- /dev/null +++ b/t/08-recurse.t @@ -0,0 +1,141 @@ +# $Id: 08-recurse.t 1549 2017-03-08 09:54:14Z willem $ -*-perl-*- + +use strict; +use Test::More; + +BEGIN { + local @INC = ( @INC, qw(t) ); + require NonFatal; +} + +use Net::DNS; +use Net::DNS::Resolver::Recurse; + + +exit( plan skip_all => 'Online tests disabled.' ) if -e 't/online.disabled'; +exit( plan skip_all => 'Online tests disabled.' ) unless -e 't/online.enabled'; + + +eval { + my $resolver = new Net::DNS::Resolver(); + exit plan skip_all => 'No nameservers' unless $resolver->nameservers; + + my $reply = $resolver->send(qw(. NS IN)) || die; + + my @ns = grep $_->type eq 'NS', $reply->answer, $reply->authority; + exit plan skip_all => 'Local nameserver broken' unless scalar @ns; + + 1; +} || exit( plan skip_all => 'Non-responding local nameserver' ); + + +eval { + my $resolver = new Net::DNS::Resolver::Recurse(); + exit plan skip_all => "No nameservers" unless $resolver->nameservers; + + my $reply = $resolver->send(qw(. NS IN)) || die; + my $from = $reply->answerfrom(); + + my @ns = grep $_->type eq 'NS', $reply->answer; + exit plan skip_all => "No NS RRs in response from $from" unless scalar @ns; + + exit plan skip_all => "Non-authoritative response from $from" unless $reply->header->aa; + + 1; +} || exit( plan skip_all => 'Unable to reach global root nameservers' ); + + +plan 'no_plan'; + +NonFatalBegin(); + + +{ + my $res = Net::DNS::Resolver::Recurse->new( debug => 0 ); + + ok( $res->isa('Net::DNS::Resolver::Recurse'), 'new() created object' ); + + my $packet = $res->query_dorecursion( 'www.net-dns.org', 'A' ); + ok( $packet, 'got a packet' ); + ok( scalar $packet->answer, 'answer section has RRs' ) if $packet; +} + + +{ + # test the callback + my $res = Net::DNS::Resolver::Recurse->new( debug => 0 ); + + my $count = 0; + + $res->recursion_callback( + sub { + ok( shift->isa('Net::DNS::Packet'), 'callback argument is a packet' ); + $count++; + } ); + + $res->query_dorecursion( 'a.t.net-dns.org', 'A' ); + + ok( $count >= 3, "Lookup took $count queries which is at least 3" ); +} + + +{ + my $res = Net::DNS::Resolver::Recurse->new( debug => 0 ); + + my $count = 0; + + $res->recursion_callback( + sub { + $count++; + } ); + + $res->query_dorecursion( '2a04:b900:0:0:8:0:0:60', 'PTR' ); + + ok( $count >= 3, "Reverse lookup took $count queries" ); +} + + +SKIP: { + my @hints = new Net::DNS::Resolver::Recurse()->_hints; + my $res = Net::DNS::Resolver::Recurse->new(); + is( scalar( $res->hints() ), 0, "hints() initially empty" ); + $res->hints(@hints); + is( scalar( $res->hints ), scalar(@hints), "hints() set" ); + + my $reply = $res->send( ".", "NS" ); + ok( $reply, 'got response to priming query' ); + skip( 'no response to priming query', 3 ) unless $reply; + my $from = $reply->answerfrom(); + + ok( $reply->header->aa, "authoritative response from $from" ); + + my @ns = grep $_->type eq 'NS', $reply->answer; + ok( scalar(@ns), "NS RRs in response from $from" ); + + my @ar = grep $_->can('address'), $reply->additional; + ok( scalar(@ar), "address RRs in response from $from" ); +} + + +{ + my $res = Net::DNS::Resolver::Recurse->new(); + $res->retrans(0); + $res->retry(0); + $res->srcport(-1); + + ok( !$res->send( "www.net-dns.org", "A" ), 'fail if no reachable server' ); +} + + +{ + Net::DNS::Resolver->retry(0); + my $res = Net::DNS::Resolver::Recurse->new(); + $res->hints( '0.0.0.0', '::' ); + + ok( !$res->send( "www.net-dns.org", "A" ), 'fail if no usable hint' ); +} + + +NonFatalEnd(); + +exit; diff --git a/t/21-TSIG-create.t b/t/21-TSIG-create.t new file mode 100644 index 0000000..d6f2737 --- /dev/null +++ b/t/21-TSIG-create.t @@ -0,0 +1,146 @@ +# $Id: 21-TSIG-create.t 1439 2015-12-07 10:37:41Z willem $ -*-perl-*- + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::HMAC + Digest::MD5 + Digest::SHA + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 11; + + +my $tsig = new Net::DNS::RR( type => 'TSIG' ); +my $class = ref($tsig); + + +{ + my $keyname = 'keyname.example'; + my $keytext = 'xdX9m8UtQNbJUzUgQ4xDtUNZAmU='; + my $tsig = create $class( $keyname, $keytext ); + is( ref($tsig), $class, 'create TSIG from argument list' ); +} + + +my $privatekey = 'Khmac-md5.example.+157+53335.private'; +END { unlink($privatekey) if defined $privatekey; } + +open( KEY, ">$privatekey" ) or die "$privatekey $!"; +print KEY <<'END'; +Private-key-format: v1.2 +Algorithm: 157 (HMAC_MD5) +Key: ARDJZgtuTDzAWeSGYPAu9uJUkX0= +END +close KEY; + +{ + my $tsig = create $class($privatekey); + is( ref($tsig), $class, 'create TSIG from private key' ); +} + + +my $publickey = 'Khmac-sha1.example.+161+39562.key'; +END { unlink($publickey) if defined $publickey; } + +open( KEY, ">$publickey" ) or die "$publickey $!"; +print KEY <<'END'; +HMAC-SHA1.example. IN KEY 512 3 161 xdX9m8UtQNbJUzUgQ4xDtUNZAmU= +END +close KEY; + +{ + my $tsig = create $class($publickey); + is( ref($tsig), $class, 'create TSIG from public key' ); +} + + +{ + my $packet = new Net::DNS::Packet('query.example'); + $packet->sign_tsig($privatekey); + my $tsig = create $class($packet); + is( ref($tsig), $class, 'create TSIG from signed packet' ); +} + + +{ + my $chain = eval { create $class($tsig); }; + is( ref($chain), $class, 'create successor to existing TSIG' ); +} + + +{ + eval { create $class(); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "empty argument list\t[$exception]" ); +} + + +{ + eval { create $class(undef); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "argument undefined\t[$exception]" ); +} + + +{ + my $null = new Net::DNS::RR( type => 'NULL' ); + eval { create $class($null); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unexpected argument\t[$exception]" ); +} + + +{ + my $packet = new Net::DNS::Packet('query.example'); + eval { create $class($packet); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "no TSIG in packet\t[$exception]" ); +} + + +my $badprivatekey = 'K+161+39562.private'; +END { unlink($badprivatekey) if defined $badprivatekey; } + +open( KEY, ">$badprivatekey" ) or die "$badprivatekey $!"; +print KEY <<'END'; +Private-key-format: v1.2 +Algorithm: 161 (HMAC_SHA1) +Key: xdX9m8UtQNbJUzUgQ4xDtUNZAmU= +END +close KEY; + +{ + eval { create $class($badprivatekey); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "misnamed private key\t[$exception]" ); +} + + +my $dnskey = 'Kbad.example.+161+39562.key'; +END { unlink($dnskey) if defined $dnskey; } + +open( KEY, ">$dnskey" ) or die "$dnskey $!"; +print KEY <<'END'; +HMAC-SHA1.example. IN DNSKEY 512 3 161 xdX9m8UtQNbJUzUgQ4xDtUNZAmU= +END +close KEY; + +{ + eval { create $class($dnskey); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unrecognised public key\t[$exception]" ); +} + + +__END__ + diff --git a/t/22-TSIG-verify.t b/t/22-TSIG-verify.t new file mode 100644 index 0000000..757e954 --- /dev/null +++ b/t/22-TSIG-verify.t @@ -0,0 +1,215 @@ +# $Id: 22-TSIG-verify.t 1474 2016-04-12 13:21:25Z willem $ -*-perl-*- + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::HMAC + Digest::MD5 + Digest::SHA + MIME::Base64 + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 28; + + +my $tsig = new Net::DNS::RR( type => 'TSIG' ); +my $class = ref($tsig); + + +my $privatekey = 'Khmac-sha1.example.+161+39562.private'; +END { unlink($privatekey) if defined $privatekey; } + +open( KEY, ">$privatekey" ) or die "$privatekey $!"; +print KEY <<'END'; +Private-key-format: v1.2 +Algorithm: 161 (HMAC_SHA1) +Key: xdX9m8UtQNbJUzUgQ4xDtUNZAmU= +END +close KEY; + + +my $publickey = 'Khmac-md5.example.+157+53335.key'; +END { unlink($publickey) if defined $publickey; } + +open( KEY, ">$publickey" ) or die "$publickey $!"; +print KEY <<'END'; +HMAC-MD5.example. IN KEY 512 3 157 ARDJZgtuTDzAWeSGYPAu9uJUkX0= +END +close KEY; + + +{ + my $packet = new Net::DNS::Packet('query.example'); + $packet->sign_tsig($privatekey); + $packet->data; + + my $verified = $packet->verify(); + ok( $verified, 'verify signed packet' ); + is( ref($verified), $class, 'packet->verify returns TSIG' ); + is( $packet->verifyerr, 'NOERROR', 'observe packet->verifyerr' ); +} + + +{ + my $packet = new Net::DNS::Packet('query.example'); + $packet->sign_tsig($privatekey); + $packet->data; + $packet->push( update => rr_add( type => 'NULL' ) ); + + my $verified = $packet->verify(); + ok( !$verified, 'unverifiable signed packet' ); + is( $verified, undef, 'failed packet->verify returns undef' ); + is( $packet->verifyerr, 'BADSIG', 'observe packet->verifyerr' ); +} + + +{ + my $query = new Net::DNS::Packet('query.example'); + $query->sign_tsig($privatekey); + $query->data; + + my $reply = $query->reply; + $reply->sign_tsig($query); + $reply->data; + + my $verified = $reply->verify($query); + ok( $verified, 'verify reply packet' ); + is( $reply->verifyerr, 'NOERROR', 'observe packet->verifyerr' ); +} + + +{ + my @packet = map { new Net::DNS::Packet($_) } 0 .. 3; + my $signed = $privatekey; + foreach my $packet (@packet) { + $signed = $packet->sign_tsig($signed); + $packet->data; + is( ref($signed), $class, 'sign multi-packet' ); + } + + my @verified; + foreach my $packet (@packet) { + my ($verified) = $packet->verify(@verified); + @verified = ($verified); + ok( $verified, 'verify multi-packet' ); + } + + my @state; + $packet[2]->sigrr->fudge(0); + foreach my $packet (@packet) { + my $tsig = $packet->verify(@state); + @state = ($tsig); + my $result = $packet->verifyerr; + ok( $result, "unverifiable multi-packet: $result" ); + } +} + + +{ + my $packet = new Net::DNS::Packet('query.example'); + $packet->sign_tsig( $privatekey, fudge => 0 ); + my $encoded = $packet->data; + sleep 1; + + my $query = new Net::DNS::Packet( \$encoded ); + my $verified = $query->verify(); + is( $query->verifyerr, 'BADTIME', 'unverifiable query packet: BADTIME' ); +} + + +{ + my $packet = new Net::DNS::Packet(); + $packet->sign_tsig($privatekey); + $packet->sigrr->error('BADTIME'); + my $encoded = $packet->data; + my $decoded = new Net::DNS::Packet( \$encoded ); + ok( $decoded->sigrr->other, 'time appended to BADTIME response' ); +} + + +{ + my $query = new Net::DNS::Packet('query.example'); + $query->sign_tsig($privatekey); + $query->data; + + my $reply = $query->reply; + $reply->sign_tsig($publickey); + $reply->data; + + my $verified = $reply->verify($query); + is( $reply->verifyerr, 'BADKEY', 'unverifiable reply packet: BADKEY' ); +} + + +{ + my $packet0 = new Net::DNS::Packet(); + my $chain = $packet0->sign_tsig($privatekey); + $packet0->data; + my $packet1 = new Net::DNS::Packet(); + $packet1->sign_tsig($chain); + $packet1->data; + + my $packetx = new Net::DNS::Packet(); + $packetx->sign_tsig($publickey); + $packetx->data; + my $tsig = $packetx->verify(); + my $verified = $packet1->verify($tsig); + is( $packet1->verifyerr, 'BADKEY', 'unverifiable multi-packet: BADKEY' ); +} + + +{ + my $packet = new Net::DNS::Packet(); + $packet->sign_tsig($publickey); + $packet->data; + $packet->sigrr->macbin( substr $packet->sigrr->macbin, 0, 9 ); + + $packet->verify(); + is( $packet->verifyerr, 'FORMERR', 'signature too short: FORMERR' ); +} + + +{ + my $packet = new Net::DNS::Packet(); + $packet->sign_tsig($publickey); + $packet->data; + my $macbin = $packet->sigrr->macbin; + $packet->sigrr->macbin( join '', $packet->sigrr->macbin, 'x' ); + + $packet->verify(); + is( $packet->verifyerr, 'FORMERR', 'signature too long: FORMERR' ); +} + + +{ + my $packet = new Net::DNS::Packet(); + $packet->sign_tsig($privatekey); + + my $null = new Net::DNS::RR( type => 'NULL' ); + eval { $packet->sigrr->verify($null); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unexpected argument\t[$exception]" ); +} + + +{ + my $packet = new Net::DNS::Packet(); + $packet->sign_tsig($privatekey); + + my $null = new Net::DNS::RR( type => 'NULL' ); + eval { $packet->sigrr->verify( $packet, $null ); }; + my $exception = $1 if $@ =~ /^(.+)\n/; + ok( $exception ||= '', "unexpected argument\t[$exception]" ); +} + + +__END__ + diff --git a/t/31-NSEC-typelist.t b/t/31-NSEC-typelist.t new file mode 100644 index 0000000..2912eb3 --- /dev/null +++ b/t/31-NSEC-typelist.t @@ -0,0 +1,62 @@ +# $Id: 31-NSEC-typelist.t 1595 2017-09-12 09:10:56Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; +use Net::DNS::Parameters; +local $Net::DNS::Parameters::DNSEXTLANG; # suppress Extlang type queries + +my @prerequisite = qw( + Net::DNS::RR::NSEC + Net::DNS::DomainName + ); + +foreach my $package (@prerequisite) { + next if eval "use $package; 1;"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 79; + + +my $rr = new Net::DNS::RR( + type => 'NSEC', + nxtdname => 'irrelevant', + ); + +foreach my $rrtype ( 0, 256, 512, 768, 1024 ) { + my $type = typebyval($rrtype); + $rr->typelist($type); + my $rdata = $rr->rdata; + my ( $name, $offset ) = decode Net::DNS::DomainName( \$rdata ); + my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; + is( $w, $rrtype >> 8, "expected window number for $type" ); +} + +foreach my $rrtype ( 0, 7, 8, 15, 16, 23, 24, 31, 32, 39 ) { + my $type = typebyval($rrtype); + $rr->typelist($type); + my $rdata = $rr->rdata; + my ( $name, $offset ) = decode Net::DNS::DomainName( \$rdata ); + my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; + is( $l, 1 + ( $rrtype >> 3 ), "expected map length for $type" ); +} + +foreach my $rrtype ( 0 .. 40, 42 .. 64 ) { + my $type = typebyval($rrtype); + $rr->typelist($type); + my $rdata = $rr->rdata; + my ( $name, $offset ) = decode Net::DNS::DomainName( \$rdata ); + my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; + my $last = unpack 'C', reverse $bitmap; + is( $last, ( 0x80 >> ( $rrtype % 8 ) ), "expected map bit for $type" ); +} + + +exit; + +__END__ + + diff --git a/t/32-NSEC3-typelist.t b/t/32-NSEC3-typelist.t new file mode 100644 index 0000000..008fc72 --- /dev/null +++ b/t/32-NSEC3-typelist.t @@ -0,0 +1,65 @@ +# $Id: 32-NSEC3-typelist.t 1595 2017-09-12 09:10:56Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; +use Net::DNS::Parameters; +local $Net::DNS::Parameters::DNSEXTLANG; # suppress Extlang type queries + +my @prerequisite = qw( + Net::DNS::RR::NSEC3 + Net::DNS::Text + ); + +foreach my $package (@prerequisite) { + next if eval "use $package; 1;"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 79; + + +my $rr = new Net::DNS::RR( + type => 'NSEC3', + hnxtname => 'irrelevant', + ); + +foreach my $rrtype ( 0, 256, 512, 768, 1024 ) { + my $type = typebyval($rrtype); + $rr->typelist($type); + my $rdata = $rr->rdata; + my ( $text, $offset ) = decode Net::DNS::Text( \$rdata, 4 ); + ( $text, $offset ) = decode Net::DNS::Text( \$rdata, $offset ); + my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; + is( $w, $rrtype >> 8, "expected window number for $type" ); +} + +foreach my $rrtype ( 0, 7, 8, 15, 16, 23, 24, 31, 32, 39 ) { + my $type = typebyval($rrtype); + $rr->typelist($type); + my $rdata = $rr->rdata; + my ( $text, $offset ) = decode Net::DNS::Text( \$rdata, 4 ); + ( $text, $offset ) = decode Net::DNS::Text( \$rdata, $offset ); + my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; + is( $l, 1 + ( $rrtype >> 3 ), "expected map length for $type" ); +} + +foreach my $rrtype ( 0 .. 40, 42 .. 64 ) { + my $type = typebyval($rrtype); + $rr->typelist($type); + my $rdata = $rr->rdata; + my ( $text, $offset ) = decode Net::DNS::Text( \$rdata, 4 ); + ( $text, $offset ) = decode Net::DNS::Text( \$rdata, $offset ); + my ( $w, $l, $bitmap ) = unpack "\@$offset CCa*", $rdata; + my $last = unpack 'C', reverse $bitmap; + is( $last, ( 0x80 >> ( $rrtype % 8 ) ), "expected map bit for $type" ); +} + + +exit; + +__END__ + + diff --git a/t/33-NSEC3-hash.t b/t/33-NSEC3-hash.t new file mode 100644 index 0000000..7d014a7 --- /dev/null +++ b/t/33-NSEC3-hash.t @@ -0,0 +1,59 @@ +# $Id: 33-NSEC3-hash.t 1561 2017-04-19 13:08:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::SHA + Net::DNS::RR::NSEC3 + ); + +foreach my $package (@prerequisite) { + next if eval "use $package; 1;"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 12; + + +my $algorithm = 1; +my $iteration = 12; +my $salt = pack 'H*', 'aabbccdd'; + + +ok( Net::DNS::RR::NSEC3::name2hash( 1, 'example' ), "defaulted arguments" ); +ok( Net::DNS::RR::NSEC3::name2hash( 1, 'example', 12, $salt ), "explicit arguments" ); + + +my %testcase = ( ## test vectors from RFC5155 + 'example' => '0p9mhaveqvm6t7vbl5lop2u3t2rp3tom', + 'a.example' => '35mthgpgcu1qg68fab165klnsnk3dpvl', + 'ai.example' => 'gjeqe526plbf1g8mklp59enfd789njgi', + 'ns1.example' => '2t7b4g4vsa5smi47k61mv5bv1a22bojr', + 'ns2.example' => 'q04jkcevqvmu85r014c7dkba38o0ji5r', + 'w.example' => 'k8udemvp1j2f7eg6jebps17vp3n8i58h', + '*.w.example' => 'r53bq7cc2uvmubfu5ocmm6pers9tk9en', + 'x.w.example' => 'b4um86eghhds6nea196smvmlo4ors995', + 'y.w.example' => 'ji6neoaepv8b5o6k4ev33abha8ht9fgc', + 'x.y.w.example' => '2vptu5timamqttgl4luu9kg21e0aor3s', + ); + + +my @name = qw(example a.example ai.example ns1.example ns2.example + w.example *.w.example x.w.example y.w.example x.y.w.example); + +foreach my $name (@name) { + my $hash = $testcase{$name}; + my @args = ( $algorithm, $name, $iteration, $salt ); + is( Net::DNS::RR::NSEC3::name2hash(@args), $hash, "H($name)" ); +} + + +exit; + +__END__ + + diff --git a/t/34-NSEC3-flags.t b/t/34-NSEC3-flags.t new file mode 100644 index 0000000..9c33ca3 --- /dev/null +++ b/t/34-NSEC3-flags.t @@ -0,0 +1,38 @@ +# $Id: 34-NSEC3-flags.t 1561 2017-04-19 13:08:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Net::DNS::RR::NSEC3 + ); + +foreach my $package (@prerequisite) { + next if eval "use $package; 1;"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 3; + + +my $rr = new Net::DNS::RR( type => 'NSEC3' ); + + +my $optout = $rr->optout; +ok( !$optout, 'Boolean optout flag has default value' ); + +$rr->optout( !$optout ); +ok( $rr->optout, 'Boolean optout flag toggled' ); + +$rr->optout($optout); +ok( !$optout, 'Boolean optout flag restored' ); + + +exit; + +__END__ + + diff --git a/t/35-NSEC3-match.t b/t/35-NSEC3-match.t new file mode 100644 index 0000000..b76e083 --- /dev/null +++ b/t/35-NSEC3-match.t @@ -0,0 +1,55 @@ +# $Id: 35-NSEC3-match.t 1561 2017-04-19 13:08:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::SHA + Net::DNS::RR::NSEC3 + ); + +foreach my $package (@prerequisite) { + next if eval "use $package; 1;"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 10; + + +my $algorithm = 1; ## test vectors from RFC5155 +my $flags = 0; +my $iteration = 12; +my $salt = 'aabbccdd'; +my $hnxtname = 'irrelevant'; + +my @name = qw(example a.example ai.example ns1.example ns2.example + w.example *.w.example x.w.example y.w.example x.y.w.example); +my %testcase = ( + 'example' => '0p9mhaveqvm6t7vbl5lop2u3t2rp3tom', + 'a.example' => '35mthgpgcu1qg68fab165klnsnk3dpvl', + 'ai.example' => 'gjeqe526plbf1g8mklp59enfd789njgi', + 'ns1.example' => '2t7b4g4vsa5smi47k61mv5bv1a22bojr', + 'ns2.example' => 'q04jkcevqvmu85r014c7dkba38o0ji5r', + 'w.example' => 'k8udemvp1j2f7eg6jebps17vp3n8i58h', + '*.w.example' => 'r53bq7cc2uvmubfu5ocmm6pers9tk9en', + 'x.w.example' => 'b4um86eghhds6nea196smvmlo4ors995', + 'y.w.example' => 'ji6neoaepv8b5o6k4ev33abha8ht9fgc', + 'x.y.w.example' => '2vptu5timamqttgl4luu9kg21e0aor3s', + ); + +foreach my $name (@name) { + my $hash = $testcase{$name}; + my @args = ( $algorithm, $flags, $iteration, $salt, $hnxtname ); + my $nsec3 = new Net::DNS::RR("$hash.example. NSEC3 @args"); + ok( $nsec3->match($name), "nsec3->match($name)" ); +} + + +exit; + +__END__ + + diff --git a/t/36-NSEC3-covered.t b/t/36-NSEC3-covered.t new file mode 100644 index 0000000..c048bda --- /dev/null +++ b/t/36-NSEC3-covered.t @@ -0,0 +1,131 @@ +# $Id: 36-NSEC3-covered.t 1561 2017-04-19 13:08:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::SHA + Net::DNS::RR::NSEC3 + ); + +foreach my $package (@prerequisite) { + next if eval "use $package; 1;"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 18; + + +## Tests based on example zone from RFC5155, Appendix A +## as amended by erratum 4993 + +my %H = ( + 'example' => '0p9mhaveqvm6t7vbl5lop2u3t2rp3tom', + 'a.example' => '35mthgpgcu1qg68fab165klnsnk3dpvl', + 'ai.example' => 'gjeqe526plbf1g8mklp59enfd789njgi', + 'ns1.example' => '2t7b4g4vsa5smi47k61mv5bv1a22bojr', + 'ns2.example' => 'q04jkcevqvmu85r014c7dkba38o0ji5r', + 'w.example' => 'k8udemvp1j2f7eg6jebps17vp3n8i58h', + '*.w.example' => 'r53bq7cc2uvmubfu5ocmm6pers9tk9en', + 'x.w.example' => 'b4um86eghhds6nea196smvmlo4ors995', + 'y.w.example' => 'ji6neoaepv8b5o6k4ev33abha8ht9fgc', + 'x.y.w.example' => '2vptu5timamqttgl4luu9kg21e0aor3s', + 'xx.example' => 't644ebqk9bibcna874givr6joj62mlhv', +); + +my %name = reverse %H; +foreach ( sort keys %name ) { print "$_\t$name{$_}\n" } + + +## Exercise examples from RFC5155, Appendix B + +ok( Net::DNS::RR->new("$H{'example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'ns1.example'} MX DNSKEY NS SOA NSEC3PARAM RRSIG )")->covered('c.x.w.example'), + 'B.1: NSEC3 covers "next closer" name (c.x.w.example.)' ); + +ok( Net::DNS::RR->new("$H{'x.w.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'ai.example'} MX RRSIG )")->match('x.w.example'), + 'B.1: NSEC3 matches closest encloser (x.w.example.)' ); + +ok( Net::DNS::RR->new("$H{'a.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'x.w.example'} NS DS RRSIG )")->covered('*.x.w.example'), + 'B.1: NSEC3 covers wildcard at closest encloser (*.x.w.example.)' ); + + +ok( Net::DNS::RR->new("$H{'ns1.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'x.y.w.example'} A RRSIG )")->match('ns1.example'), + 'B.2: NSEC3 matches QNAME (example.) proving MX and CNAME absent' ); + +ok( Net::DNS::RR->new("$H{'y.w.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'w.example'} )")->match('y.w.example'), + 'B.2.1: NSEC3 matches empty non-terminal (y.w.example.)' ); + + +ok( Net::DNS::RR->new("$H{'a.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'x.w.example'} NS DS RRSIG )")->covered('c.example'), + 'B.3: NSEC3 covers "next closer" name (c.example.)' ); + +ok( Net::DNS::RR->new("$H{'example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'ns1.example'} MX DNSKEY NS SOA NSEC3PARAM RRSIG )")->match('example'), + 'B.3: NSEC3 matches closest provable encloser (example.)' ); + + +ok( Net::DNS::RR->new("$H{'ns2.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'*.w.example'} A RRSIG )")->covered('z.w.example'), + 'B.4: NSEC3 covers "next closer" name (z.w.example.)' ); + + +ok( Net::DNS::RR->new("$H{'w.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'ns2.example'} )")->match('w.example'), + 'B.5: NSEC3 matches closest encloser (w.example.)' ); + +ok( Net::DNS::RR->new("$H{'ns2.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'*.w.example'} A RRSIG )")->covered('z.w.example'), + 'B.5: NSEC3 covers "next closer name" (z.w.example.)' ); + +ok( Net::DNS::RR->new("$H{'*.w.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'xx.example'} MX RRSIG )")->match('*.w.example'), + 'B.5: NSEC3 matches wildcard at closest encloser (*.w.example.)' ); + + +ok( Net::DNS::RR->new("$H{'example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'ns1.example'} MX DNSKEY NS SOA NSEC3PARAM RRSIG )")->match('example'), + 'B.6: NSEC3 matches QNAME (example.) and shows DS type bit not set' ); + + +## covered() returns false for hashed name not strictly between ownerhash and nexthash + +ok( !Net::DNS::RR->new("$H{'example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'ns1.example'} A RRSIG )")->covered('.'), + 'ancestor name not covered (.)' ); # too few matching labels + +ok( !Net::DNS::RR->new("$H{'ns2.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'*.w.example'} A RRSIG )")->covered('unrelated.name'), + 'name out of zone not covered (unrelated.name.)' ); # non-matching label + + +ok( !Net::DNS::RR->new("$H{'a.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'w.example'} )")->covered('a.example'), + 'owner name not covered (a.example.)' ); + +ok( !Net::DNS::RR->new("$H{'a.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'w.example'} )")->covered('w.example'), + 'next hashed name not covered (w.example.)' ); + +ok( !Net::DNS::RR->new("$H{'a.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'w.example'} )")->covered('xx.example'), + 'name beyond next hashed name not covered (xx.example.)' ); + +ok( !Net::DNS::RR->new("$H{'a.example'}.example. NSEC3 1 1 12 aabbccdd ( + $H{'example'} )")->covered('xx.example'), + 'name beyond last hashed name not covered (xx.example.)' ); + + +exit; + +__END__ + + diff --git a/t/37-NSEC3-base32.t b/t/37-NSEC3-base32.t new file mode 100644 index 0000000..76d2120 --- /dev/null +++ b/t/37-NSEC3-base32.t @@ -0,0 +1,49 @@ +# $Id: 37-NSEC3-base32.t 1561 2017-04-19 13:08:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Net::DNS::RR::NSEC3 + ); + +foreach my $package (@prerequisite) { + next if eval "use $package; 1"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 30; + + +my %testcase = ( + chr(85) x 1 => 'ak', + chr(85) x 2 => 'alag', + chr(85) x 3 => 'alala', + chr(85) x 4 => 'alalal8', + chr(85) x 5 => 'alalalal', + chr(85) x 6 => 'alalalalak', + chr(85) x 7 => 'alalalalalag', + chr(85) x 8 => 'alalalalalala', + chr(85) x 9 => 'alalalalalalal8', + chr(85) x 10 => 'alalalalalalalal', + ); + + +foreach my $binary ( sort keys %testcase ) { + my $base32 = $testcase{$binary}; + my $encode = Net::DNS::RR::NSEC3::_encode_base32hex($binary); + my $decode = Net::DNS::RR::NSEC3::_decode_base32hex($base32); + is( $encode, $base32, 'base32hex encode correct' ); + is( length($decode), length($binary), 'decode length correct' ); + ok( $decode eq $binary, 'base32hex decode correct' ); +} + + +exit; + +__END__ + + diff --git a/t/41-DNSKEY-keytag.t b/t/41-DNSKEY-keytag.t new file mode 100644 index 0000000..68d2093 --- /dev/null +++ b/t/41-DNSKEY-keytag.t @@ -0,0 +1,56 @@ +# $Id: 41-DNSKEY-keytag.t 1352 2015-06-02 08:13:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + Net::DNS::RR::DNSKEY; + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 4; + + +my $key = new Net::DNS::RR <<'END'; +RSASHA1.example. IN DNSKEY 256 3 5 ( + AwEAAZHbngk6sMoFHN8fsYY6bmGR4B9UYJIqDp+mORLEH53Xg0f6RMDtfx+H3/x7bHTUikTr26bV + AqsxOs2KxyJ2Xx9RGG0DB9O4gpANljtTq2tLjvaQknhJpSq9vj4CqUtr6Wu152J2aQYITBoQLHDV + i8mIIunparIKDmhy8TclVXg9 ; Key ID = 1623 + ) +END + +ok( $key, 'set up DNSKEY record' ); + + +my $keytag = $key->keytag; +is( $keytag, 1623, 'numerical keytag has expected value' ); + + +my $newkey = <<'END'; + AwEAAcNz+cEA/Zkl/8u5/kfJKPNSbmXbdMpk6jM4bMWTEhZlaEOJE+GYsbM+HvjMgEMz00eDpvDR + XEMl1o4x60SgW8ap44deky/KAYzDC80rIZrvjDx8DPzF3yIikrGc8P7Eq+0zbWrYyiHRg5DllIT4 + 5NCz6EMtji1RQloWCaXuAzCN +END + +my $keybin = $key->keybin; +$key->key($newkey); +isnt( $key->keytag, $keytag, 'keytag recalculated from modified key' ); + + +$key->keybin($keybin); +is( $key->keytag, $keytag, 'keytag recalculated from restored key' ); + + +exit; + +__END__ + + diff --git a/t/42-DNSKEY-flags.t b/t/42-DNSKEY-flags.t new file mode 100644 index 0000000..f88fe6c --- /dev/null +++ b/t/42-DNSKEY-flags.t @@ -0,0 +1,52 @@ +# $Id: 42-DNSKEY-flags.t 1367 2015-06-29 08:53:56Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + Net::DNS::RR::DNSKEY; + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 16; + + +my $dnskey = new Net::DNS::RR <<'END'; +RSASHA1.example. IN DNSKEY 256 3 5 ( + AwEAAZHbngk6sMoFHN8fsYY6bmGR4B9UYJIqDp+mORLEH53Xg0f6RMDtfx+H3/x7bHTUikTr26bV + AqsxOs2KxyJ2Xx9RGG0DB9O4gpANljtTq2tLjvaQknhJpSq9vj4CqUtr6Wu152J2aQYITBoQLHDV + i8mIIunparIKDmhy8TclVXg9 ; Key ID = 1623 + ) +END + +ok( $dnskey, 'set up DNSKEY record' ); + +$dnskey->flags(0); +foreach my $flag ( qw(sep zone revoke) ) { + my $boolean = $dnskey->$flag(0); + ok( !$boolean, "Boolean $flag flag has expected value" ); + + my $keytag = $dnskey->keytag; + $dnskey->$flag( !$boolean ); + ok( $dnskey->$flag, "Boolean $flag flag toggled" ); + isnt( $dnskey->keytag, $keytag, "keytag recalculated using modified $flag flag" ); + + $dnskey->$flag($boolean); + ok( !$dnskey->$flag, "Boolean $flag flag restored" ); + + is( $dnskey->keytag, $keytag, "keytag recalculated using restored $flag flag" ); +} + +exit; + +__END__ + + diff --git a/t/43-DNSKEY-keylength.t b/t/43-DNSKEY-keylength.t new file mode 100644 index 0000000..bff3354 --- /dev/null +++ b/t/43-DNSKEY-keylength.t @@ -0,0 +1,85 @@ +# $Id: 43-DNSKEY-keylength.t 1367 2015-06-29 08:53:56Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + MIME::Base64 + Net::DNS::RR::DNSKEY; + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 9; + + +my $rsa = new Net::DNS::RR <<'END'; +RSASHA1.example. IN DNSKEY 256 3 5 ( + AwEAAZHbngk6sMoFHN8fsYY6bmGR4B9UYJIqDp+mORLEH53Xg0f6RMDtfx+H3/x7bHTUikTr26bV + AqsxOs2KxyJ2Xx9RGG0DB9O4gpANljtTq2tLjvaQknhJpSq9vj4CqUtr6Wu152J2aQYITBoQLHDV + i8mIIunparIKDmhy8TclVXg9 ; Key ID = 1623 + ) +END + +ok( $rsa, 'set up RSA public key' ); + +is( $rsa->keylength, 1024, 'RSA keylength has expected value' ); + +my $longformat = pack 'xn a*', unpack 'C a*', $rsa->keybin; +$rsa->keybin($longformat); +is( $rsa->keylength, 1024, 'keylength for long format RSA key' ); + + +my $dsa = new Net::DNS::RR <<'END'; +DSA.example. IN DNSKEY 256 3 3 ( + CMKzsCaT2Jy1w/sPdpigEE+nbeJ/x5C6cruWvStVum6/YulcR7MHeujx9c2iBDbo3kW4X8/l+qgk + 7ZEZ+yV5lphWtJMmMtOHIU+YdAhgLpt84NKhcupWL8wfuBW/97cqIv5Z+51fwn0YEAcZsoCrE0nL + 5+31VfkK9LTNuVo38hsbWa3eWZFalID5NesF6sJRgXZoAyeAH46EQVCq1UBnnaHslvSDkdb+Z1kT + bMQ64ZVI/sBRXRbqIcDlXVZurCTDV7JL9KZwwfeyrQcnVyYh5mdHPsXbpX5NQJvoqPgvRZWBpP4h + pjkAm9UrUbow9maPCQ1JQ3JuiU5buh9cjAI+QIyGMujKLT2OsogSZD2IFUciaZBL/rSe0gmAUv0q + XrczmIYFUCoRGZ6+lKVqQQ6f2U7Gsr6zRbeJN+JCVD6BJ52zjLUaWUPHbakhZb/wMO7roX/tnA/w + zoDYBIIF7yuRYWblgPXBJTK2Bp07xre8lKCRbzY4J/VXZFziZgHgcn9tkHnrfov04UG9zlWEdT6X + E/60HjrP ; Key ID = 53244 + ) +END + +ok( $dsa, 'set up DSA public key' ); + +is( $dsa->keylength, 1024, 'DSA keylength has expected value' ); + + +my $eccgost = new Net::DNS::RR <<'END'; +ECC-GOST.example. IN DNSKEY 256 3 12 ( + 6VwgNT1BXxXNVpTQXcJQ82PcsCYmI60oN88Plbl028ruvl6DqJby/uBGULHT5FXmZiXBJozE6kP0 + +BirN9YPBQ== ; Key ID = 46387 + ) +END + +ok( $eccgost, 'set up ECC-GOST public key' ); + +is( $eccgost->keylength, 256, 'ECC-GOST keylength has expected value' ); + + +my $ecdsa = new Net::DNS::RR <<'END'; +ECDSAP256SHA256.example. IN DNSKEY 256 3 13 ( + 7Y4BZY1g9uzBwt3OZexWk7iWfkiOt0PZ5o7EMip0KBNxlBD+Z58uWutYZIMolsW8v/3rfgac45lO + IikBZK4KZg== ; Key ID = 44222 + ) +END + +ok( $ecdsa, 'set up ECDSA public key' ); + +is( $ecdsa->keylength, 256, 'ECDSA keylength has expected value' ); + + +exit; + +__END__ + + diff --git a/t/51-DS-SHA1.t b/t/51-DS-SHA1.t new file mode 100644 index 0000000..0ee985c --- /dev/null +++ b/t/51-DS-SHA1.t @@ -0,0 +1,53 @@ +# $Id: 51-DS-SHA1.t 1352 2015-06-02 08:13:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::SHA + MIME::Base64 + Net::DNS::RR::KEY + Net::DNS::RR::DS + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 3; + + +# Simple known-answer tests based upon the examples given in RFC3658, section 2.7 + +my $key = new Net::DNS::RR <<'END'; +dskey.example. IN KEY 256 3 1 ( + AQPwHb4UL1U9RHaU8qP+Ts5bVOU1s7fYbj2b3CCbzNdj + 4+/ECd18yKiyUQqKqQFWW5T3iVc8SJOKnueJHt/Jb/wt + ) ; key id = 28668 +END + +my $ds = new Net::DNS::RR <<'END'; +dskey.example. IN DS 28668 1 1 ( + 49fd46e6c4b45c55d4ac69cbd3cd34ac1afe51de + ;xidez-ticuv-kicur-galah-hehyp-sopys-roges-titap-sakoz-vygat-vyxox + ) +END + + +my $test = create Net::DNS::RR::DS( $key, digtype => 'SHA1', ); + +is( $test->string, $ds->string, 'created DS matches RFC3658 example DS' ); + +ok( $test->verify($key), 'created DS verifies RFC3658 example KEY' ); + +ok( $ds->verify($key), 'RFC3658 example DS verifies example KEY' ); + +$test->print; + +__END__ + + diff --git a/t/52-DS-SHA256.t b/t/52-DS-SHA256.t new file mode 100644 index 0000000..62069bf --- /dev/null +++ b/t/52-DS-SHA256.t @@ -0,0 +1,57 @@ +# $Id: 52-DS-SHA256.t 1352 2015-06-02 08:13:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::SHA + MIME::Base64 + Net::DNS::RR::DNSKEY + Net::DNS::RR::DS + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 3; + + +# Simple known-answer tests based upon the examples given in RFC4509, section 2.3 + +my $dnskey = new Net::DNS::RR <<'END'; +dskey.example.com. 86400 IN DNSKEY 256 3 5 ( AQOeiiR0GOMYkDshWoSKz9Xz + fwJr1AYtsmx3TGkJaNXVbfi/ + 2pHm822aJ5iI9BMzNXxeYCmZ + DRD99WYwYqUSdjMmmAphXdvx + egXd/M5+X7OrzKBaMbCVdFLU + Uh6DhweJBjEVv5f2wwjM9Xzc + nOf+EPbtG9DMBmADjFDc2w/r + ljwvFw== + ) ; key id = 60485 +END + +my $ds = new Net::DNS::RR <<'END'; +dskey.example.com. 86400 IN DS 60485 5 2 ( D4B7D520E7BB5F0F67674A0C + CEB1E3E0614B93C4F9E99B83 + 83F6A1E4469DA50A ) +END + + +my $test = create Net::DNS::RR::DS( $dnskey, digtype => 'SHA256' ); + +is( $test->string, $ds->string, 'created DS matches RFC4509 example DS' ); + +ok( $test->verify($dnskey), 'created DS verifies RFC4509 example DNSKEY' ); + +ok( $ds->verify($dnskey), 'RFC4509 example DS verifies DNSKEY' ); + +$test->print; + +__END__ + + diff --git a/t/54-DS-SHA384.t b/t/54-DS-SHA384.t new file mode 100644 index 0000000..0c14575 --- /dev/null +++ b/t/54-DS-SHA384.t @@ -0,0 +1,57 @@ +# $Id: 54-DS-SHA384.t 1352 2015-06-02 08:13:13Z willem $ -*-perl-*- +# + +use strict; +use Test::More; +use Net::DNS; + +my @prerequisite = qw( + Digest::SHA + MIME::Base64 + Net::DNS::RR::DNSKEY + Net::DNS::RR::DS + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 3; + + +# Simple known-answer tests based upon the examples given in RFC6605, section 6.2 + +my $dnskey = new Net::DNS::RR <<'END'; +example.net. 3600 IN DNSKEY 257 3 14 ( + xKYaNhWdGOfJ+nPrL8/arkwf2EY3MDJ+SErKivBVSum1 + w/egsXvSADtNJhyem5RCOpgQ6K8X1DRSEkrbYQ+OB+v8 + /uX45NBwY8rp65F6Glur8I/mlVNgF6W/qTI37m40 ) +END + +my $ds = new Net::DNS::RR <<'END'; +example.net. 3600 IN DS 10771 14 4 ( + 72d7b62976ce06438e9c0bf319013cf801f09ecc84b8 + d7e9495f27e305c6a9b0563a9b5f4d288405c3008a94 + 6df983d6 ) +END + + +my $test = create Net::DNS::RR::DS( + $dnskey, + digtype => 'SHA384', + ttl => 3600 + ); + +is( $test->string, $ds->string, 'created DS matches RFC6605 example DS' ); + +ok( $test->verify($dnskey), 'created DS verifies RFC6605 example DNSKEY' ); + +ok( $ds->verify($dnskey), 'RFC6605 example DS verifies DNSKEY' ); + +$ds->print; + +__END__ + + diff --git a/t/61-SIG0-RSAMD5.t b/t/61-SIG0-RSAMD5.t new file mode 100644 index 0000000..c1de5fa --- /dev/null +++ b/t/61-SIG0-RSAMD5.t @@ -0,0 +1,223 @@ +# $Id: 61-SIG0-RSAMD5.t 1611 2018-01-02 09:41:24Z willem $ -*-perl-*- +# + +use strict; +use Test::More; + +my @prerequisite = qw( + MIME::Base64 + Time::Local + Net::DNS::RR::SIG + Net::DNS::SEC + Net::DNS::SEC::RSA + Crypt::OpenSSL::Bignum + Crypt::OpenSSL::RSA + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 29; + +use_ok('Net::DNS::SEC'); + + +my $key = new Net::DNS::RR <<'END'; +RSAMD5.example. IN KEY 512 3 1 ( + AwEAAcUHtdNvhdBKMkUle+MJ+ntJ148yfsITtZC0g93EguURfU113BQVk6tzgXP/aXs4OptkCgrL + sTapAZr5+vQ8jNbLp/uUTqEUzBRMBqi0W78B3aEb7vEsC0FB6VLoCcjylDcKzzWHm4rj1ACN2Zbu + 6eT88lDYHTPiGQskw5LGCze7 ; Key ID = 2871 + ) +END + +ok( $key, 'set up RSA public key' ); + + +my $keyfile = $key->privatekeyname; + +END { unlink($keyfile) if defined $keyfile; } + +open( KEY, ">$keyfile" ) or die "$keyfile $!"; +print KEY <<'END'; +Private-key-format: v1.2 +Algorithm: 1 (RSA) +Modulus: xQe102+F0EoyRSV74wn6e0nXjzJ+whO1kLSD3cSC5RF9TXXcFBWTq3OBc/9pezg6m2QKCsuxNqkBmvn69DyM1sun+5ROoRTMFEwGqLRbvwHdoRvu8SwLQUHpUugJyPKUNwrPNYebiuPUAI3Zlu7p5PzyUNgdM+IZCyTDksYLN7s= +PublicExponent: AQAB +PrivateExponent: yOATgH0y8Ci1F8ofhFmoBgpCurvAgB2X/vALgQ3YZbJvDYob1l4pL6OTV7AO2pF5LvPPSTJielfUSyyRrnANJSST/Dr19DgpSpnY2GWE7xmJ6/QqnIaJ2+10pFzVRXShijJZjt9dY7JXmNIoQ+JseE08aquKHFEGVfsvkThk8Q== +Prime1: 9lyWnGhbZZwVQo/qNHjVeWEDyc0hsc/ynT4Qp/AjVhROY+eJnBEvhtmqj3sq2gDQm2ZfT8uubSH5ZkNrnJjL2Q== +Prime2: zL0L5kwZXqUyRiPqZgbhFEib210WZne+AI88iyi39tU/Iplx1Q6DhHmOuPhUgCCj2nqQhWs9BAkQwemLylfHsw== +Exponent1: rcETgHChtYJmBDIYTrXCaf8get2wnAY76ObzPF7DrVxZBWExzt7YFFXEU7ncuTDF8DQ9mLvg45uImLWIWkPx0Q== +Exponent2: qtb8vPi3GrDCGKETkHshCank09EDRhGY7CKZpI0fpMogWqCrydrIh5xfKZ2d9SRHVaF8QrhPO7TM1OIqkXdZ3Q== +Coefficient: IUxSSCxp+TotMTbloOt/aTtxlaz0b5tSS7dBoLa7//tmHZvHQjftEw8KbXC89QhHd537YZX4VcK/uYbU6SesRA== +END +close(KEY); + + +my $bad1 = new Net::DNS::RR <<'END'; +RSAMD5.example. IN KEY 512 3 1 ( + AwEAAdDembFMoX8rZTqTjHT8PbCZHbTJpDgtuL0uXpJqPZ6ZKnGdQsXVn4BSs8VJlH7+NEv+7Spq + Ncxjx6o86HhrvFg5DsDMhEi5MIqlt1OcUYa0zUhFSkb+yzOSnPL7doSoaW8pxoX4uDemkfyOY9xN + tNCNBJcvmp1Uvdnttf7LUorD ; Key ID = 21130 + ) +END + + +my $bad2 = new Net::DNS::RR <<'END'; +RSASHA1.example. IN KEY ( 512 3 5 + AwEAAcosvYOe384kf7szGV4YxwfliKk9VTlO8HEQnlQs4glpMwtwCm8E9zxQRMG1W9CsM7tcHKq8 + 52KcapenPMkYCseeI7sRtD4k5eF6Us7SaYNRYG6qBhXkSRr41aTroqq+I9IMgAGMzUpC2a9rzn+f + Hs5pZA2CKzoR1+9Jv4vKu5MF ; Key ID = 16351 + ) +END + + +{ + my $packet = new Net::DNS::Packet('example'); + $packet->sign_sig0($keyfile); + $packet->data; + ok( $packet->sigrr->sigbin, 'sign packet using private key' ); + + my $verified = $packet->verify($key); + ok( $verified, 'verify packet using public key' ); + is( $packet->verifyerr, '', 'observe no packet->verifyerr' ); +} + + +{ + my $packet = new Net::DNS::Packet('example'); + $packet->sign_sig0($keyfile); + my $buffer = $packet->data; + + my $decoded = new Net::DNS::Packet( \$buffer ); + my $verified = $decoded->verify($key); + ok( $verified, 'verify decoded packet using public key' ); + is( $decoded->verifyerr, '', 'observe no packet->verifyerr' ); +} + + +{ + my $packet = new Net::DNS::Packet('example'); + $packet->sign_sig0($keyfile); + $packet->data; + + my $verified = $packet->verify($bad1); + ok( !$verified, 'verify fails using wrong key' ); + ok( $packet->verifyerr, 'observe packet->verifyerr' ); +} + + +{ + my $packet = new Net::DNS::Packet('example'); + $packet->sign_sig0($keyfile); + $packet->data; + + my $verified = $packet->verify($bad2); + ok( !$verified, 'verify fails using wrong key' ); + ok( $packet->verifyerr, 'observe packet->verifyerr' ); +} + + +{ + my $packet = new Net::DNS::Packet('example'); + $packet->sign_sig0($keyfile); + $packet->data; + + $packet->push( answer => rr_add('bogus. A 10.1.2.3') ); + my $verified = $packet->verify($key); + ok( !$verified, 'verify fails for modified packet' ); + ok( $packet->verifyerr, 'observe packet->verifyerr' ); +} + + +{ + my $packet = new Net::DNS::Packet('example'); + $packet->sign_sig0($keyfile); + $packet->data; + + my $verified = $packet->verify( [$bad1, $bad2, $key] ); + ok( $verified, 'verify packet using array of keys' ); + is( $packet->verifyerr, '', 'observe no packet->verifyerr' ); +} + + +{ + my $packet = new Net::DNS::Packet('example'); + $packet->sign_sig0($keyfile); + $packet->data; + + $packet->push( answer => rr_add('bogus. A 10.1.2.3') ); + my $verified = $packet->verify( [$bad1, $bad2, $key] ); + ok( !$verified, 'verify failure using array of keys' ); + ok( $packet->verifyerr, 'observe packet->verifyerr' ); +} + + +{ + my $data = new Net::DNS::Packet('example')->data; + my $sig = create Net::DNS::RR::SIG( $data, $keyfile ); + ok( $sig->sigbin, 'create SIG over data using private key' ); + + my $verified = $sig->verify( $data, $key ); + ok( $verified, 'verify data using public key' ); + is( $sig->vrfyerrstr, '', 'observe no sig->vrfyerrstr' ); +} + + +{ + my $data = new Net::DNS::Packet('example')->data; + my $time = time() + 3; + my %args = ( + siginception => $time, + sigexpiration => $time, + ); + my $object = create Net::DNS::RR::SIG( $data, $keyfile, %args ); + + ok( !$object->verify( $data, $key ), 'verify fails for postdated SIG' ); + ok( $object->vrfyerrstr, 'observe sig->vrfyerrstr' ); + sleep 1 until $time < time(); + ok( !$object->verify( $data, $key ), 'verify fails for expired SIG' ); + ok( $object->vrfyerrstr, 'observe sig->vrfyerrstr' ); +} + + +{ + my $object = new Net::DNS::RR( type => 'SIG' ); + my $keyrec = new Net::DNS::RR( type => 'KEY' ); + my $nonkey = new Net::DNS::RR( type => 'DS' ); + my $packet = new Net::DNS::Packet(); + my $array = []; + my @testcase = ( ## test verify() with invalid arguments + [$array, $keyrec], + [$object, $keyrec], + [$packet, $keyrec], + [$packet, $nonkey], + ); + + foreach my $arglist (@testcase) { + my @argtype = map ref($_), @$arglist; + $object->typecovered('A'); # induce failure + eval { $object->verify(@$arglist); }; + my $exception = $1 if $@ =~ /^(.*)\n*/; + ok( defined $exception, "verify(@argtype)\t[$exception]" ); + } +} + + +{ + my $packet = new Net::DNS::Packet('query.example'); + $packet->sign_sig0($keyfile); + my $signed = $packet->data; # signing occurs in SIG->encode + $packet->sigrr->sigbin(''); # signature destroyed + my $unsigned = eval { $packet->data }; # unable to regenerate SIG0 + my $exception = $1 if $@ =~ /^(.*)\n*/; + ok( defined $exception, "missing key\t[$exception]" ); +} + + +exit; + +__END__ + diff --git a/t/65-RRSIG-RSASHA1.t b/t/65-RRSIG-RSASHA1.t new file mode 100644 index 0000000..0f00cf9 --- /dev/null +++ b/t/65-RRSIG-RSASHA1.t @@ -0,0 +1,222 @@ +# $Id: 65-RRSIG-RSASHA1.t 1392 2015-09-13 16:30:51Z willem $ -*-perl-*- +# + +use strict; +use Test::More; + +my @prerequisite = qw( + MIME::Base64 + Time::Local + Net::DNS::RR::RRSIG + Net::DNS::SEC + Net::DNS::SEC::RSA + Crypt::OpenSSL::Bignum + Crypt::OpenSSL::RSA + ); + +foreach my $package (@prerequisite) { + next if eval "require $package"; + plan skip_all => "$package not installed"; + exit; +} + +plan tests => 30; + +use_ok('Net::DNS::SEC'); + + +my $ksk = new Net::DNS::RR <<'END'; +RSASHA1.example. IN DNSKEY 257 3 5 ( + AwEAAefP0RzK3K39a5wznjeWA1PssI2dxqPb9SL+ppY8wcimOuEBmSJP5n6/bwg923VFlRiYJHe5 + if4saxWCYenQ46hWz44sK943K03tfHkxo54ayAk/7dMj1wQ7Dby5FJ1AAMGZZO65BlKSD+2BTcwp + IL9mAYuhHYfkG6FTEEKgHVmOVmtyKWA3gl3RrSSgXzTWnUS5b/jEeh2SflXG9eXabaoVXEHQN+oJ + dTiAiErZW4+Zlx5pIrSycZBpIdWvn4t71L3ik6GctQqG9ln12j2ngji3blVI3ENMnUc237jUeYsy + k7E5TughQctLYOFXHaeTMgJt0LUTyv3gIgDTRmvgQDU= ; Key ID = 4501 + ) +END + +ok( $ksk, 'set up RSA public ksk' ); + + +my $keyfile = $ksk->privatekeyname; + +END { unlink($keyfile) if defined $keyfile; } + +open( KSK, ">$keyfile" ) or die "$keyfile $!"; +print KSK <<'END'; +Private-key-format: v1.2 +Algorithm: 5 (RSASHA1) +Modulus: 58/RHMrcrf1rnDOeN5YDU+ywjZ3Go9v1Iv6mljzByKY64QGZIk/mfr9vCD3bdUWVGJgkd7mJ/ixrFYJh6dDjqFbPjiwr3jcrTe18eTGjnhrICT/t0yPXBDsNvLkUnUAAwZlk7rkGUpIP7YFNzCkgv2YBi6Edh+QboVMQQqAdWY5Wa3IpYDeCXdGtJKBfNNadRLlv+MR6HZJ+Vcb15dptqhVcQdA36gl1OICIStlbj5mXHmkitLJxkGkh1a+fi3vUveKToZy1Cob2WfXaPaeCOLduVUjcQ0ydRzbfuNR5izKTsTlO6CFBy0tg4Vcdp5MyAm3QtRPK/eAiANNGa+BANQ== +PublicExponent: AQAB +PrivateExponent: qVfDp4j61ZAAAMgkmO7Z14FdKNdNuX6CAeKNx8rytaXZ9W25dLtx4r3uWtL1cyI13RWn7l54VFoWkEwDQ0/6P4vLbE0QbvFWjUMkX1TH9kQSRc+R6WCRPuH1Ex0R1h5fbw6kEVDRMZjKUfLX5oFVDv1xu5Mjg5Y8KQoJIuLdDgHtRRV7ZETcGcSXBQ1eY2rNxui2YzM0mtqzApgGq7pLb3GfiM5aqW5fSdRaFajGC2VIXkN3jZYxAryT8EYJ6uRFJk0X3VegEwj6keHOem/tBV2DaNlv1JWidauPeU67evKNTQVW3h3AbQxnOtegdWrRKoa9Ksf27bgoKAlveHIfsQ== +Prime1: +s1y+iP+AoB4UVS4S5njIZD21AWm36JTaqEvRPdevjuzc9q7yJATROdRdcAitdSPHeRC8xtQw/C9zGhJRdynlxfmUTeyYgM0EYHYiG7PLwkW5Wu9EeXJ7/Fpct51L+ednloQ0d7tYP/5QUd6cqbFGGKH0yF5zZMO0k+ZZ/saeCs= +Prime2: 7J2eVZ5Psue4BTNya8PMA89cC0Gf51zFeQ8dPBZIOpN28DJN2EN6C6fwGtnr6BO+M/6loXzcekPGgRkpNcQ6MzJup8hZQmU8RxESAMlmQzOtaBbtmMwPa0p6IcZBUWpbRaKwQ4ZjAUS9R13PFwgEU+a855o0XRRTupdmyZ6OmR8= +Exponent1: nGakbdMmIx9EaMuhRhwIJTWGhz+jCdDrnhI4LRTqM019oiDke7VFHvH1va18t9F/Ek/3ZC1Dl304jxD1qKhqpnGUAk/uYOrIfKZxhts7PoS3j4g5VsDqxkPQ035gq+gPReG6nXYcqCHYqVnOxVK0lHlVZFd64rTzSDm1W7+eiRM= +Exponent2: evAuKygVGsxghXtEkQ9rOfOMTGDtdyVxiMO8mdKt9plV69kHLz1n9RRtoVXmx28ynQtK/YvFdlUulzb+fWwWHTGv4scq8V9uITKSWwxJcNMx3upCyugDfuh0aoX6vBV5lMXBtWPmnusbOTBZgArvTLSPI/qwCEiedE1j34/dYVs= +Coefficient: JTEzUDflC+G0if7uqsJ2sw/x2aCHMjsCxYSmx2bJOW/nhQTQpzafL0N8E6WmKuEP4qAaqQjWrDyxy0XcAJrfcojJb+a3j2ndxYpev7Rq8f7P6M7qqVL0Nzj9rWFH7pyvWMnH584viuhPcDogy8ymHpNNuAF+w98qjnGD8UECiV4= +END +close(KSK); + + +my $bad1 = new Net::DNS::RR <<'END'; +RSASHA1.example. IN DNSKEY 256 3 5 ( + AwEAAZHbngk6sMoFHN8fsYY6bmGR4B9UYJIqDp+mORLEH53Xg0f6RMDtfx+H3/x7bHTUikTr26bV + AqsxOs2KxyJ2Xx9RGG0DB9O4gpANljtTq2tLjvaQknhJpSq9vj4CqUtr6Wu152J2aQYITBoQLHDV + i8mIIunparIKDmhy8TclVXg9 ; Key ID = 1623 + ) +END + + +my $bad2 = new Net::DNS::RR <<'END'; +ECDSAP256SHA256.example. IN DNSKEY ( 256 3 13 + 7Y4BZY1g9uzBwt3OZexWk7iWfkiOt0PZ5o7EMip0KBNxlBD+Z58uWutYZIMolsW8v/3rfgac45lO + IikBZK4KZg== ; Key ID = 44222 + ) +END + + +my @rrset = ( $bad1, $ksk ); +my @badrrset = ($bad1); + +{ + my $object = create Net::DNS::RR::RRSIG( \@rrset, $keyfile ); + ok( $object->sig(), 'create RRSIG over rrset using private ksk' ); + + my $verified = $object->verify( \@rrset, $ksk ); + ok( $verified, 'verify using public ksk' ); + is( $object->vrfyerrstr, '', 'observe no object->vrfyerrstr' ); +} + + +{ + my $object = create Net::DNS::RR::RRSIG( \@rrset, $keyfile ); + + my $verified = $object->verify( \@badrrset, $bad1 ); + ok( !$verified, 'verify fails using wrong key' ); + ok( $object->vrfyerrstr, 'observe rrsig->vrfyerrstr' ); +} + + +{ + my $object = create Net::DNS::RR::RRSIG( \@rrset, $keyfile ); + + my $verified = $object->verify( \@badrrset, $bad2 ); + ok( !$verified, 'verify fails using key with wrong algorithm' ); + ok( $object->vrfyerrstr, 'observe rrsig->vrfyerrstr' ); +} + + +{ + my $object = create Net::DNS::RR::RRSIG( \@rrset, $keyfile ); + + my $verified = $object->verify( \@rrset, [$bad1, $bad2, $ksk] ); + ok( $verified, 'verify using array of keys' ); + is( $object->vrfyerrstr, '', 'observe no rrsig->vrfyerrstr' ); +} + + +{ + my $object = create Net::DNS::RR::RRSIG( \@rrset, $keyfile ); + + my $verified = $object->verify( \@badrrset, [$bad1, $bad2, $ksk] ); + ok( !$verified, 'verify fails using wrong rrset' ); + ok( $object->vrfyerrstr, 'observe rrsig->vrfyerrstr' ); +} + + +{ + my $wild = new Net::DNS::RR('*.example. A 10.1.2.3'); + my $match = new Net::DNS::RR('leaf.twig.example. A 10.1.2.3'); + my $object = create Net::DNS::RR::RRSIG( [$wild], $keyfile ); + + my $verified = $object->verify( [$match], $ksk ); + ok( $verified, 'wildcard matches child domain name' ); + is( $object->vrfyerrstr, '', 'observe no rrsig->vrfyerrstr' ); +} + + +{ + my $wild = new Net::DNS::RR('*.example. A 10.1.2.3'); + my $bogus = new Net::DNS::RR('example. A 10.1.2.3'); + my $object = create Net::DNS::RR::RRSIG( [$wild], $keyfile ); + + my $verified = $object->verify( [$bogus], $ksk ); + ok( !$verified, 'wildcard does not match parent domain' ); + ok( $object->vrfyerrstr, 'observe rrsig->vrfyerrstr' ); +} + + +{ + my $time = time() + 3; + my %args = ( + siginception => $time, + sigexpiration => $time, + ); + my $object = create Net::DNS::RR::RRSIG( \@rrset, $keyfile, %args ); + + ok( !$object->verify( \@rrset, $ksk ), 'verify fails for postdated RRSIG' ); + ok( $object->vrfyerrstr, 'observe rrsig->vrfyerrstr' ); + sleep 1 until $time < time(); + ok( !$object->verify( \@rrset, $ksk ), 'verify fails for expired RRSIG' ); + ok( $object->vrfyerrstr, 'observe rrsig->vrfyerrstr' ); +} + + +{ + my $object = new Net::DNS::RR( type => 'RRSIG' ); + my $class = ref($object); + my $array = []; + my $dnskey = new Net::DNS::RR( type => 'DNSKEY' ); + my $private = new Net::DNS::SEC::Private($keyfile); + my $packet = new Net::DNS::Packet(); + my $rr1 = new Net::DNS::RR( name => 'example', type => 'A' ); + my $rr2 = new Net::DNS::RR( name => 'differs', type => 'A' ); + my $rr3 = new Net::DNS::RR( type => 'A', ttl => 1 ); + my $rr4 = new Net::DNS::RR( type => 'A', ttl => 2 ); + my $rr5 = new Net::DNS::RR( class => 'IN', type => 'A' ); + my $rr6 = new Net::DNS::RR( class => 'ANY', type => 'A' ); + my $rr7 = new Net::DNS::RR( type => 'A' ); + my $rr8 = new Net::DNS::RR( type => 'AAAA' ); + my @testcase = ( ## test create() with invalid arguments + [$dnskey, $dnskey], + [$array, $private], + [[$rr1, $rr2], $private], + [[$rr3, $rr4], $private], + [[$rr5, $rr6], $private], + [[$rr7, $rr8], $private], + ); + + foreach my $arglist (@testcase) { + my @argtype = map ref($_), @$arglist; + eval { $class->create(@$arglist); }; + my $exception = $1 if $@ =~ /^(.*)\n*/; + ok( defined $exception, "create(@argtype)\t[$exception]" ); + } +} + + +{ + my $object = new Net::DNS::RR( type => 'RRSIG' ); + my $packet = new Net::DNS::Packet(); + my $dnskey = new Net::DNS::RR( type => 'DNSKEY' ); + my $dsrec = new Net::DNS::RR( type => 'DS' ); + my $scalar = 'SCALAR'; + my @testcase = ( ## test verify() with invalid arguments + [$packet, $dnskey], + [$dnskey, $dsrec], + [$dnskey, $scalar], + ); + + foreach my $arglist (@testcase) { + my @argtype = map ref($_) || $_, @$arglist; + eval { $object->verify(@$arglist); }; + my $exception = $1 if $@ =~ /^(.*)\n*/; + ok( defined $exception, "verify(@argtype)\t[$exception]" ); + } +} + + +exit; + +__END__ + diff --git a/t/99-cleanup.t b/t/99-cleanup.t new file mode 100644 index 0000000..022a354 --- /dev/null +++ b/t/99-cleanup.t @@ -0,0 +1,13 @@ +# $Id: 99-cleanup.t 795 2009-01-26 17:28:44Z olaf $ -*-perl-*- +use Test::More; +plan tests => 1; + +diag ("Cleaning"); + +unlink("t/online.disabled") if (-e "t/online.disabled"); +unlink("t/IPv6.disabled") if (-e "t/IPv6.disabled"); + +ok(1,"Dummy"); + + + diff --git a/t/NonFatal.pm b/t/NonFatal.pm new file mode 100644 index 0000000..116c060 --- /dev/null +++ b/t/NonFatal.pm @@ -0,0 +1,63 @@ +# $Id: NonFatal.pm 1608 2017-12-07 10:10:38Z willem $ -*-perl-*- + +# Test::More calls functions from Test::Builder. Those functions all eventually +# call Test::Builder::ok (on a builder instance) for reporting the status. +# Here we define a new builder inherited from Test::Builder, with a redefined +# ok method that always reports the test to have completed successfully. +# +# The functions NonFatalBegin and NonFatalEnd re-bless the builder in use by +# Test::More (Test::More->builder) to be of type Test::NonFatal and +# Test::Builder respectively. Tests that are between those functions will thus +# always appear to succeed. The failure report itself is not suppressed. +# +# Note that the builder is only re-blessed when the file 't/online.nonfatal' +# exists. +# +# This is just a quick hack to allow for non-fatal unit tests. It has many +# problems such as for example that blocks marked by the NonFatalBegin and +# NonFatalEnd subroutines may not be nested. +# + +use strict; +use Test::More; + +use constant NONFATAL => eval { -e 't/online.nonfatal' }; + +my @failed; + +END { + my $n = scalar(@failed); + my $s = $n > 1 ? 's' : ''; + diag( join "\n\t", "\tDisregarding $n failed sub-test$s", @failed ) if $n; +} + + +{ + package Test::NonFatal; + + use base qw(Test::Builder); + + sub ok { + my ( $self, $test, $name ) = ( @_, '' ); + + return $self->SUPER::ok( 1, $name ) if $test; + + $self->SUPER::ok( 1, "NOT OK, but tolerating failure, $name" ); + + push @failed, $name; + return $test; + } +} + + +sub NonFatalBegin { + bless Test::More->builder, qw(Test::NonFatal) if NONFATAL; +} + +sub NonFatalEnd { + bless Test::More->builder, qw(Test::Builder) if NONFATAL; +} + + +1; + diff --git a/t/custom.txt b/t/custom.txt new file mode 100644 index 0000000..31b29af --- /dev/null +++ b/t/custom.txt @@ -0,0 +1,5 @@ +# $Id: custom.txt 1573 2017-06-12 11:03:59Z willem $ +domain alt.net-dns.org +search alt.net-dns.org ext.net-dns.org +nameserver 10.0.1.128 10.0.2.128 +options attempts:2 inet6 bogus