home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Packet.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-09  |  23.2 KB  |  937 lines
  1. package Net::DNS::Packet;
  2. #
  3. # $Id: Packet.pm,v 2.101 2004/01/04 04:12:57 ctriv Exp $
  4. #
  5. use strict;
  6. use vars qw(@ISA @EXPORT_OK $VERSION $AUTOLOAD);
  7.  
  8. require Exporter;
  9. @ISA = qw(Exporter);
  10. @EXPORT_OK = qw(dn_expand);
  11.  
  12. use Carp;
  13. use Net::DNS;
  14. use Net::DNS::Question;
  15. use Net::DNS::RR;
  16.  
  17. $VERSION = (qw$Revision: 2.101 $)[1];
  18.  
  19. =head1 NAME
  20.  
  21. Net::DNS::Packet - DNS packet object class
  22.  
  23. =head1 SYNOPSIS
  24.  
  25. C<use Net::DNS::Packet;>
  26.  
  27. =head1 DESCRIPTION
  28.  
  29. A C<Net::DNS::Packet> object represents a DNS packet.
  30.  
  31. =head1 METHODS
  32.  
  33. =head2 new
  34.  
  35.     $packet = Net::DNS::Packet->new("example.com");
  36.     $packet = Net::DNS::Packet->new("example.com", "MX", "IN");
  37.  
  38.     $packet = Net::DNS::Packet->new(\$data);
  39.     $packet = Net::DNS::Packet->new(\$data, 1);  # set debugging
  40.  
  41.     ($packet, $err) = Net::DNS::Packet->new(\$data);
  42.  
  43. If passed a domain, type, and class, C<new> creates a packet
  44. object appropriate for making a DNS query for the requested
  45. information.  The type and class can be omitted; they default
  46. to A and IN.
  47.  
  48. If passed a reference to a scalar containing DNS packet data,
  49. C<new> creates a packet object from that data.  A second argument
  50. can be passed to turn on debugging output for packet parsing.
  51.  
  52. If called in array context, returns a packet object and an
  53. error string.  The error string will only be defined if the
  54. packet object is undefined (i.e., couldn't be created).
  55.  
  56. Returns B<undef> if unable to create a packet object (e.g., if
  57. the packet data is truncated).'
  58.  
  59. =cut
  60.  
  61. sub new {
  62.     my $class = shift;
  63.     my %self;
  64.  
  65.     $self{"compnames"} = {};
  66.  
  67.   PARSE: {
  68.     if (ref($_[0])) {
  69.         my $data  = shift;
  70.         my $debug = shift || 0;
  71.  
  72.         #--------------------------------------------------------------
  73.         # Parse the header section.
  74.         #--------------------------------------------------------------
  75.  
  76.         print ";; HEADER SECTION\n" if $debug;
  77.  
  78.  
  79.         $self{"header"} = Net::DNS::Header->new($data);
  80.  
  81.         unless (defined $self{"header"}) {
  82.             return wantarray
  83.                    ? (undef, "header section incomplete")
  84.                    : undef;
  85.         }
  86.  
  87.         $self{"header"}->print if $debug;
  88.  
  89.         my $offset = &Net::DNS::HFIXEDSZ;
  90.  
  91.         #--------------------------------------------------------------
  92.         # Parse the question/zone section.
  93.         #--------------------------------------------------------------
  94.  
  95.         if ($debug) {
  96.             print "\n";
  97.             my $section = ($self{"header"}->opcode eq "UPDATE")
  98.                         ? "ZONE"
  99.                     : "QUESTION";
  100.             print ";; $section SECTION (",
  101.                   $self{"header"}->qdcount, " record",
  102.                   $self{"header"}->qdcount == 1 ? "" : "s",
  103.                   ")\n";
  104.         }
  105.  
  106.         $self{"question"} = [];
  107.         foreach (1 .. $self{"header"}->qdcount) {
  108.             my $qobj;
  109.             ($qobj, $offset) = parse_question($data, $offset);
  110.  
  111.             unless (defined $qobj) {
  112.                 last PARSE if $self{"header"}->tc;
  113.                 return wantarray
  114.                        ? (undef, "question section incomplete")
  115.                        : undef;
  116.             }
  117.  
  118.             push(@{$self{"question"}}, $qobj);
  119.             if ($debug) {
  120.                 print ";; ";
  121.                 $qobj->print;
  122.             }
  123.         }
  124.             
  125.         #--------------------------------------------------------------
  126.         # Parse the answer/prerequisite section.
  127.         #--------------------------------------------------------------
  128.  
  129.         if ($debug) {
  130.             print "\n";
  131.             my $section = ($self{"header"}->opcode eq "UPDATE")
  132.                     ? "PREREQUISITE"
  133.                         : "ANSWER";
  134.             print ";; $section SECTION (",
  135.                   $self{"header"}->ancount, " record",
  136.                   $self{"header"}->ancount == 1 ? "" : "s",
  137.                   ")\n";
  138.         }
  139.  
  140.         $self{"answer"} = [];
  141.         foreach (1 .. $self{"header"}->ancount) {
  142.             my $rrobj;
  143.             ($rrobj, $offset) = parse_rr($data, $offset);
  144.  
  145.             unless (defined $rrobj) {
  146.                 last PARSE if $self{"header"}->tc;
  147.                 return wantarray
  148.                        ? (undef, "answer section incomplete")
  149.                        : undef;
  150.             }
  151.             
  152.             push(@{$self{"answer"}}, $rrobj);
  153.             $rrobj->print if $debug;
  154.         }
  155.  
  156.         #--------------------------------------------------------------
  157.         # Parse the authority/update section.
  158.         #--------------------------------------------------------------
  159.  
  160.         if ($debug) {
  161.             print "\n";
  162.             my $section = ($self{"header"}->opcode eq "UPDATE")
  163.                         ? "UPDATE"
  164.                     : "AUTHORITY";
  165.             print ";; $section SECTION (",
  166.                   $self{"header"}->nscount, " record",
  167.                   $self{"header"}->nscount == 1 ? "" : "s",
  168.                   ")\n";
  169.         }
  170.  
  171.         $self{"authority"} = [];
  172.         foreach (1 .. $self{"header"}->nscount) {
  173.             my $rrobj;
  174.             ($rrobj, $offset) = parse_rr($data, $offset);
  175.  
  176.             unless (defined $rrobj) {
  177.                 last PARSE if $self{"header"}->tc;
  178.                 return wantarray
  179.                        ? (undef, "authority section incomplete")
  180.                        : undef;
  181.             }
  182.             
  183.             push(@{$self{"authority"}}, $rrobj);
  184.             $rrobj->print if $debug;
  185.         }
  186.  
  187.         #--------------------------------------------------------------
  188.         # Parse the additional section.
  189.         #--------------------------------------------------------------
  190.  
  191.         if ($debug) {
  192.             print "\n";
  193.             print ";; ADDITIONAL SECTION (",
  194.                   $self{"header"}->adcount, " record",
  195.                   $self{"header"}->adcount == 1 ? "" : "s",
  196.                   ")\n";
  197.         }
  198.  
  199.         $self{"additional"} = [];
  200.         foreach (1 .. $self{"header"}->arcount) {
  201.             my $rrobj;
  202.             ($rrobj, $offset) = parse_rr($data, $offset);
  203.  
  204.             unless (defined $rrobj) {
  205.                 last PARSE if $self{"header"}->tc;
  206.                 return wantarray
  207.                        ? (undef, "additional section incomplete")
  208.                        : undef;
  209.             }
  210.  
  211.         
  212.             push(@{$self{"additional"}}, $rrobj);
  213.             $rrobj->print if $debug;
  214.         }
  215.     } else {
  216.         my ($qname, $qtype, $qclass) = @_;
  217.  
  218.         $qtype  = "A"  unless defined $qtype;
  219.         $qclass = "IN" unless defined $qclass;
  220.  
  221.         $self{"header"} = Net::DNS::Header->new;
  222.         $self{"header"}->qdcount(1);
  223.         $self{"question"} = [ Net::DNS::Question->new($qname,
  224.                                   $qtype,
  225.                                   $qclass) ];
  226.         $self{"answer"}     = [];
  227.         $self{"authority"}  = [];
  228.         $self{"additional"} = [];
  229.     }
  230.     } # PARSE
  231.  
  232.     return wantarray
  233.         ? ((bless \%self, $class), undef)
  234.         : bless \%self, $class;
  235. }
  236.  
  237. =head2 data
  238.  
  239.     $data = $packet->data;
  240.  
  241. Returns the packet data in binary format, suitable for sending to
  242. a nameserver.
  243.  
  244. =cut
  245.  
  246. sub data {
  247.     my $self = shift;
  248.  
  249.     #----------------------------------------------------------------------
  250.     # Flush the cache of already-compressed names.  This should fix the bug
  251.     # that caused this method to work only the first time it was called.
  252.     #----------------------------------------------------------------------
  253.  
  254.     $self->{"compnames"} = {};
  255.  
  256.     #----------------------------------------------------------------------
  257.     # Get the data for each section in the packet.
  258.     #----------------------------------------------------------------------
  259.     # Note that EDNS OPT RR data should inly be appended to the additional
  260.     # section of the packet. TODO: Packet is dropped silently if is tried to
  261.     # have it appended to one of the other section
  262.  
  263.     my $data = $self->{"header"}->data;
  264.  
  265.     foreach my $question (@{$self->{"question"}}) {
  266.         $data .= $question->data($self, length $data);
  267.     }
  268.  
  269.     foreach my $rr (@{$self->{"answer"}}) {
  270.         $data .= $rr->data($self, length $data);
  271.     }
  272.  
  273.     foreach my $rr (@{$self->{"authority"}}) {
  274.         $data .= $rr->data($self, length $data);
  275.     }
  276.  
  277.     foreach my $rr (@{$self->{"additional"}}) {
  278.         $data .= $rr->data($self, length $data);
  279.     }
  280.  
  281.     return $data;
  282. }
  283.  
  284. =head2 header
  285.  
  286.     $header = $packet->header;
  287.  
  288. Returns a C<Net::DNS::Header> object representing the header section
  289. of the packet.
  290.  
  291. =cut
  292.  
  293. sub header {
  294.     my $self = shift;
  295.     return $self->{"header"};
  296. }
  297.  
  298. =head2 question, zone
  299.  
  300.     @question = $packet->question;
  301.  
  302. Returns a list of C<Net::DNS::Question> objects representing the
  303. question section of the packet.
  304.  
  305. In dynamic update packets, this section is known as C<zone> and
  306. specifies the zone to be updated.
  307.  
  308. =cut
  309.  
  310. sub question {
  311.     my $self = shift;
  312.     return @{$self->{"question"}};
  313. }
  314.  
  315. sub zone {
  316.     my $self = shift;
  317.     $self->question(@_);
  318. }
  319.  
  320. =head2 answer, pre, prerequisite
  321.  
  322.     @answer = $packet->answer;
  323.  
  324. Returns a list of C<Net::DNS::RR> objects representing the answer
  325. section of the packet.
  326.  
  327. In dynamic update packets, this section is known as C<pre> or
  328. C<prerequisite> and specifies the RRs or RRsets which must or
  329. must not preexist.
  330.  
  331. =cut
  332.  
  333. sub answer { return @{$_[0]->{'answer'}}; }
  334.  
  335. sub pre          { &answer }
  336. sub prerequisite { &answer }
  337.  
  338. =head2 authority, update
  339.  
  340.     @authority = $packet->authority;
  341.  
  342. Returns a list of C<Net::DNS::RR> objects representing the authority
  343. section of the packet.
  344.  
  345. In dynamic update packets, this section is known as C<update> and
  346. specifies the RRs or RRsets to be added or delted.
  347.  
  348. =cut
  349.  
  350. sub authority { return @{$_[0]->{'authority'}}; }
  351.  
  352. sub update    { &authority }
  353.  
  354. =head2 additional
  355.  
  356.     @additional = $packet->additional;
  357.  
  358. Returns a list of C<Net::DNS::RR> objects representing the additional
  359. section of the packet.
  360.  
  361. =cut
  362.  
  363. sub additional { return @{$_[0]->{'additional'}}; }
  364.  
  365.  
  366. =head2 print
  367.  
  368.     $packet->print;
  369.  
  370. Prints the packet data on the standard output in an ASCII format
  371. similar to that used in DNS zone files.
  372.  
  373. =cut
  374.  
  375. sub print { 
  376.     print $_[0]->string;
  377. }
  378.  
  379. =head2 string
  380.  
  381.     print $packet->string;
  382.  
  383. Returns a string representation of the packet.
  384.  
  385. =cut
  386.  
  387. sub string {
  388.     my $self = shift;
  389.     my ($qr, $rr, $section);
  390.     my $retval = "";
  391.  
  392.     if (exists $self->{"answerfrom"}) {
  393.         $retval .= ";; Answer received from $self->{answerfrom} " .
  394.                "($self->{answersize} bytes)\n;;\n";
  395.     }
  396.  
  397.     $retval .= ";; HEADER SECTION\n";
  398.     $retval .= $self->header->string;
  399.  
  400.     $retval .= "\n";
  401.     $section = ($self->header->opcode eq "UPDATE") ? "ZONE" : "QUESTION";
  402.     $retval .= ";; $section SECTION (" . $self->header->qdcount     . 
  403.            " record" . ($self->header->qdcount == 1 ? "" : "s") .
  404.            ")\n";
  405.     foreach $qr ($self->question) {
  406.         $retval .= ";; " . $qr->string . "\n";
  407.     }
  408.  
  409.     $retval .= "\n";
  410.     $section = ($self->header->opcode eq "UPDATE") ? "PREREQUISITE" : "ANSWER";
  411.     $retval .= ";; $section SECTION (" . $self->header->ancount     .
  412.            " record" . ($self->header->ancount == 1 ? "" : "s") .
  413.            ")\n";
  414.     foreach $rr ($self->answer) {
  415.         $retval .= $rr->string . "\n";
  416.     }
  417.  
  418.     $retval .= "\n";
  419.     $section = ($self->header->opcode eq "UPDATE") ? "UPDATE" : "AUTHORITY";
  420.     $retval .= ";; $section SECTION (" . $self->header->nscount     .
  421.           " record" . ($self->header->nscount == 1 ? "" : "s") .
  422.           ")\n";
  423.     foreach $rr ($self->authority) {
  424.         $retval .= $rr->string . "\n";
  425.     }
  426.  
  427.     $retval .= "\n";
  428.     $retval .= ";; ADDITIONAL SECTION (" . $self->header->arcount   .
  429.            " record" . ($self->header->arcount == 1 ? "" : "s") .
  430.            ")\n";
  431.     foreach $rr ($self->additional) {
  432.         $retval .= $rr->string . "\n";
  433.     }
  434.  
  435.     return $retval;
  436. }
  437.  
  438. =head2 answerfrom
  439.  
  440.     print "packet received from ", $packet->answerfrom, "\n";
  441.  
  442. Returns the IP address from which we received this packet.  User-created
  443. packets will return undef for this method.
  444.  
  445. =cut
  446.  
  447. sub answerfrom {
  448.     my $self = shift;
  449.  
  450.     $self->{"answerfrom"} = shift if @_;
  451.  
  452.     return exists $self->{"answerfrom"}
  453.            ? $self->{"answerfrom"}
  454.            : undef;
  455. }
  456.  
  457. =head2 answersize
  458.  
  459.     print "packet size: ", $packet->answersize, " bytes\n";
  460.  
  461. Returns the size of the packet in bytes as it was received from a
  462. nameserver.  User-created packets will return undef for this method
  463. (use C<< length $packet->data >> instead).
  464.  
  465. =cut
  466.  
  467. sub answersize {
  468.     my $self = shift;
  469.  
  470.     $self->{"answersize"} = shift if @_;
  471.  
  472.     return exists $self->{"answersize"}
  473.            ? $self->{"answersize"}
  474.            : undef;
  475. }
  476.  
  477. =head2 push
  478.  
  479.     $packet->push("pre", $rr);
  480.     $packet->push("update", $rr);
  481.     $packet->push("additional", $rr);
  482.  
  483.     $packet->push("update", $rr1, $rr2, $rr3);
  484.     $packet->push("update", @rr);
  485.  
  486. Adds RRs to the specified section of the packet.
  487.  
  488. =cut
  489.  
  490. sub push {
  491.     my ($self, $section, @rr) = @_;
  492.     my $rr;
  493.  
  494.     return unless $section;
  495.  
  496.     $section = lc $section;
  497.     if (($section eq "prerequisite") || ($section eq "prereq")) {
  498.         $section = "pre";
  499.     }
  500.  
  501.     if (($self->{"header"}->opcode eq "UPDATE")
  502.      && (($section eq "pre") || ($section eq "update")) ) {
  503.         my $zone_class = ($self->zone)[0]->zclass;
  504.         foreach $rr (@rr) {
  505.             unless ($rr->class eq "NONE" || $rr->class eq "ANY") {
  506.                 $rr->class($zone_class);
  507.             }
  508.         }
  509.     }
  510.  
  511.     if ($section eq "answer" || $section eq "pre") {
  512.         push(@{$self->{"answer"}}, @rr);
  513.         my $ancount = $self->{"header"}->ancount;
  514.         $self->{"header"}->ancount($ancount + @rr);
  515.     } elsif ($section eq "authority" || $section eq "update") {
  516.         push(@{$self->{"authority"}}, @rr);
  517.         my $nscount = $self->{"header"}->nscount;
  518.         $self->{"header"}->nscount($nscount + @rr);
  519.     } elsif ($section eq "additional") {
  520.         push(@{$self->{"additional"}}, @rr);
  521.         my $adcount = $self->{"header"}->adcount;
  522.         $self->{"header"}->adcount($adcount + @rr);
  523.     } elsif ($section eq "question") {
  524.         push(@{$self->{"question"}}, @rr);
  525.         my $qdcount = $self->{"header"}->qdcount;
  526.         $self->{"header"}->qdcount($qdcount + @rr);
  527.     } else {
  528.         Carp::carp(qq(invalid section "$section"\n));
  529.         return;
  530.     }
  531. }
  532.  
  533.  
  534.  
  535. =head2 pop
  536.  
  537.     my $rr = $packet->pop("pre");
  538.     my $rr = $packet->pop("update");
  539.     my $rr = $packet->pop("additional");
  540.  
  541. Removes RRs from the specified section of the packet.
  542.  
  543. =cut
  544.  
  545. sub pop {
  546.     my ($self, $section) = @_;
  547.  
  548.     return unless $section;
  549.     $section = lc $section;
  550.  
  551.     if (($section eq "prerequisite") || ($section eq "prereq")) {
  552.         $section = "pre";
  553.     }
  554.  
  555.     my $rr;
  556.  
  557.     if ($section eq "answer" || $section eq "pre") {
  558.         my $ancount = $self->{"header"}->ancount;
  559.         if ($ancount) {
  560.             $rr = pop @{$self->{"answer"}};
  561.             $self->{"header"}->ancount($ancount - 1);
  562.         }
  563.     } elsif ($section eq "authority" || $section eq "update") {
  564.         my $nscount = $self->{"header"}->nscount;
  565.         if ($nscount) {
  566.             $rr = pop @{$self->{"authority"}};
  567.             $self->{"header"}->nscount($nscount - 1);
  568.         }
  569.     } elsif ($section eq "additional") {
  570.         my $adcount = $self->{"header"}->adcount;
  571.         if ($adcount) {
  572.             $rr = pop @{$self->{"additional"}};
  573.             $self->{"header"}->adcount($adcount - 1);
  574.         }
  575.     } else {
  576.         Carp::cluck(qq(invalid section "$section"\n));
  577.     }
  578.  
  579.     return $rr;
  580. }
  581.  
  582. =head2 dn_comp
  583.  
  584.     $compname = $packet->dn_comp("foo.example.com", $offset);
  585.  
  586. Returns a domain name compressed for a particular packet object, to
  587. be stored beginning at the given offset within the packet data.  The
  588. name will be added to a running list of compressed domain names for
  589. future use.
  590.  
  591. =cut
  592.  
  593. sub dn_comp {
  594.     my ($self, $name, $offset) = @_;
  595.  
  596.     $name = "" unless defined($name);
  597.  
  598.     my $compname = "";
  599.     my @names = map { s/\\\././g; $_ } split(/(?=[^\\]|^)\./, $name);
  600.  
  601.     while (@names) {
  602.         my $dname = join(".", @names);
  603.  
  604.         if (exists $self->{"compnames"}->{$dname}) {
  605.             my $pointer = $self->{"compnames"}->{$dname};
  606.             $compname .= pack("n", 0xc000 | $pointer);
  607.             last;
  608.         }
  609.  
  610.         $self->{"compnames"}->{$dname} = $offset;
  611.         my $first  = shift @names;
  612.         my $length = length $first;
  613.         $compname .= pack("C a*", $length, $first);
  614.         $offset   += $length + 1;
  615.     }
  616.  
  617.     $compname .= pack("C", 0) unless @names;
  618.     return $compname;
  619. }
  620.  
  621. =head2 dn_expand
  622.  
  623.     use Net::DNS::Packet qw(dn_expand);
  624.     ($name, $nextoffset) = dn_expand(\$data, $offset);
  625.  
  626.     ($name, $nextoffset) = Net::DNS::Packet::dn_expand(\$data, $offset);
  627.  
  628. Expands the domain name stored at a particular location in a DNS
  629. packet.  The first argument is a reference to a scalar containing
  630. the packet data.  The second argument is the offset within the
  631. packet where the (possibly compressed) domain name is stored.
  632.  
  633. Returns the domain name and the offset of the next location in the
  634. packet.
  635.  
  636. Returns B<(undef, undef)> if the domain name couldn't be expanded.
  637.  
  638. =cut
  639. # '
  640.  
  641. # This is very hot code, so we try to keep things fast.  This makes for
  642. # odd style sometimes.
  643. {
  644.     if ($Net::DNS::HAVE_XS) {
  645.         *dn_expand = \&dn_expand_XS;
  646.     } else {
  647.         *dn_expand = \&dn_expand_PP;
  648.     }
  649. }
  650.  
  651. sub dn_expand_PP {
  652.     my ($packet, $offset) = @_; # $seen from $_[2] for debugging
  653.     my $name = "";
  654.     my $len;
  655.     my $packetlen = length $$packet;
  656.     my $int16sz = &Net::DNS::INT16SZ;
  657.  
  658.     # Debugging
  659.     #warn "USING PURE PERL dn_expand()\n";
  660.     #if ($seen->{$offset}) {
  661.     #    die "dn_expand: loop: offset=$offset (seen = ",
  662.     #         join(",", keys %$seen), ")\n";
  663.     #}
  664.     #$seen->{$offset} = 1;
  665.  
  666.     while (1) {
  667.         return (undef, undef) if $packetlen < ($offset + 1);
  668.  
  669.         $len = unpack("\@$offset C", $$packet);
  670.  
  671.         if ($len == 0) {
  672.             $offset++;
  673.             last;
  674.         }
  675.         elsif (($len & 0xc0) == 0xc0) {
  676.             return (undef, undef)
  677.                 if $packetlen < ($offset + $int16sz);
  678.  
  679.             my $ptr = unpack("\@$offset n", $$packet);
  680.             $ptr &= 0x3fff;
  681.             my($name2) = dn_expand_PP($packet, $ptr); # pass $seen for debugging
  682.  
  683.             return (undef, undef) unless defined $name2;
  684.  
  685.             $name .= $name2;
  686.             $offset += $int16sz;
  687.             last;
  688.         }
  689.         else {
  690.             $offset++;
  691.  
  692.             return (undef, undef)
  693.                 if $packetlen < ($offset + $len);
  694.  
  695.             my $elem = substr($$packet, $offset, $len);
  696.             $elem =~ s/\./\\./g;
  697.             $name .= "$elem.";
  698.             $offset += $len;
  699.         }
  700.     }
  701.  
  702.     $name =~ s/\.$//;
  703.     return ($name, $offset);
  704. }
  705.  
  706. =head2 sign_tsig
  707.  
  708.     $key_name = "tsig-key";
  709.     $key      = "awwLOtRfpGE+rRKF2+DEiw==";
  710.  
  711.     $update = Net::DNS::Update->new("example.com");
  712.     $update->push("update", rr_add("foo.example.com A 10.1.2.3"));
  713.  
  714.     $update->sign_tsig($key_name, $key);
  715.  
  716.     $response = $res->send($update);
  717.  
  718. Signs a packet with a TSIG resource record (see RFC 2845).  Uses the
  719. following defaults:
  720.  
  721.     algorithm   = HMAC-MD5.SIG-ALG.REG.INT
  722.     time_signed = current time
  723.     fudge       = 300 seconds
  724.  
  725. If you wish to customize the TSIG record, you'll have to create it
  726. yourself and call the appropriate Net::DNS::RR::TSIG methods.  The
  727. following example creates a TSIG record and sets the fudge to 60
  728. seconds:
  729.  
  730.     $key_name = "tsig-key";
  731.     $key      = "awwLOtRfpGE+rRKF2+DEiw==";
  732.  
  733.     $tsig = Net::DNS::RR->new("$key_name TSIG $key");
  734.     $tsig->fudge(60);
  735.  
  736.     $query = Net::DNS::Packet->new("www.example.com");
  737.     $query->sign_tsig($tsig);
  738.  
  739.     $response = $res->send($query);
  740.  
  741. You shouldn't modify a packet after signing it; otherwise authentication
  742. will probably fail.
  743.  
  744. =cut
  745.  
  746. sub sign_tsig {
  747.     my $self = shift;
  748.  
  749.     my $tsig;
  750.  
  751.     if (@_ == 1 && ref($_[0])) {
  752.         $tsig = $_[0];
  753.     }
  754.     elsif (@_ == 2) {
  755.         my ($key_name, $key) = @_;
  756.         if (defined($key_name) && defined($key)) {
  757.             $tsig = Net::DNS::RR->new("$key_name TSIG $key")
  758.         }
  759.     }
  760.  
  761.     $self->push("additional", $tsig) if $tsig;
  762.     return $tsig;
  763. }
  764.  
  765.  
  766.  
  767. =head2 sign_sig0
  768.  
  769. SIG0 support is provided through the Net::DNS::RR::SIG class. This class is not part
  770. of the default Net::DNS distribution but resides in the Net::DNS::SEC distribution.
  771.  
  772.     $update = Net::DNS::Update->new("example.com");
  773.     $update->push("update", rr_add("foo.example.com A 10.1.2.3"));
  774.     $update->sign_sig0("Kexample.com+003+25317.private");
  775.  
  776.  
  777. SIG0 support is experimental see Net::DNS::RR::SIG for details.
  778.  
  779. The method will call C<Carp::croak()> if Net::DNS::RR::SIG cannot be found.
  780.  
  781.  
  782. =cut
  783.  
  784. sub sign_sig0 {
  785.     my $self = shift;
  786.     
  787.     Carp::croak('The sign_sig0() method is only available when the Net::DNS::SEC package is installed.') 
  788.             unless $Net::DNS::DNSSEC;
  789.     
  790.     
  791.     my $sig0;
  792.     
  793.     if (@_ == 1 && ref($_[0])) {
  794.         if (UNIVERSAL::isa($_[0],"Net::DNS::RR::SIG::Private")) {
  795.             Carp::carp('Net::DNS::RR::SIG::Private is deprecated use Net::DNS::SEC::Private instead');
  796.             $sig0 = Net::DNS::RR::SIG->create('', $_[0]) if $_[0];
  797.         
  798.         } elsif (UNIVERSAL::isa($_[0],"Net::DNS::SEC::Private")) {
  799.             $sig0 = Net::DNS::RR::SIG->create('', $_[0]) if $_[0];
  800.         
  801.         } elsif (UNIVERSAL::isa($_[0],"Net::DNS::RR::SIG")) {
  802.             $sig0 = $_[0];
  803.         } else {
  804.           Carp::croak('You are passing an incompatible class as argument to sign_sig0: ' . ref($_[0]));
  805.         }
  806.     } elsif (@_ == 1 && ! ref($_[0])) {
  807.         my $key_name = $_[0];
  808.         $sig0 = Net::DNS::RR::SIG->create('', $key_name) if $key_name
  809.     }
  810.     
  811.     $self->push('additional', $sig0) if $sig0;
  812.     return $sig0;
  813. }
  814.  
  815.  
  816.  
  817.  
  818.  
  819.  
  820. #------------------------------------------------------------------------------
  821. # parse_question
  822. #
  823. #     ($queryobj, $newoffset) = parse_question(\$data, $offset);
  824. #
  825. # Parses a question section record contained at a particular location within
  826. # a DNS packet.  The first argument is a reference to the packet data.  The
  827. # second argument is the offset within the packet where the question record
  828. # begins.
  829. #
  830. # Returns a Net::DNS::Question object and the offset of the next location
  831. # in the packet.
  832. #
  833. # Returns (undef, undef) if the question object couldn't be created (e.g.,
  834. # if there isn't enough data).
  835. #------------------------------------------------------------------------------
  836.  
  837. sub parse_question {
  838.     my ($data, $offset) = @_;
  839.     my $qname;
  840.  
  841.     ($qname, $offset) = dn_expand($data, $offset);
  842.     return (undef, undef) unless defined $qname;
  843.  
  844.     return (undef, undef)
  845.         if length($$data) < ($offset + 2 * &Net::DNS::INT16SZ);
  846.  
  847.     my ($qtype, $qclass) = unpack("\@$offset n2", $$data);
  848.     $offset += 2 * &Net::DNS::INT16SZ;
  849.  
  850.     $qtype  = Net::DNS::typesbyval($qtype);
  851.     $qclass = Net::DNS::classesbyval($qclass);
  852.  
  853.     return (Net::DNS::Question->new($qname, $qtype, $qclass), $offset);
  854. }
  855.  
  856. #------------------------------------------------------------------------------
  857. # parse_rr
  858. #
  859. #    ($rrobj, $newoffset) = parse_rr(\$data, $offset);
  860. #
  861. # Parses a DNS resource record (RR) contained at a particular location
  862. # within a DNS packet.  The first argument is a reference to a scalar
  863. # containing the packet data.  The second argument is the offset within
  864. # the data where the RR is located.
  865. #
  866. # Returns a Net::DNS::RR object and the offset of the next location
  867. # in the packet.
  868. #------------------------------------------------------------------------------
  869.  
  870. sub parse_rr {
  871.     my ($data, $offset) = @_;
  872.     my $name;
  873.  
  874.     ($name, $offset) = dn_expand($data, $offset);
  875.     return (undef, undef) unless defined $name;
  876.  
  877.     return (undef, undef)
  878.         if length($$data) < ($offset + &Net::DNS::RRFIXEDSZ);
  879.  
  880.     my ($type, $class, $ttl, $rdlength) = unpack("\@$offset n2 N n", $$data);
  881.  
  882.     $type  = Net::DNS::typesbyval($type)    || $type;
  883.  
  884.     # Special case for OPT RR where CLASS should be interperted as 16 bit 
  885.     # unsigned 2671 sec 4.3
  886.     if ($type ne "OPT") {
  887.         $class = Net::DNS::classesbyval($class) || $class;
  888.     } 
  889.     # else just keep at its numerical value
  890.  
  891.     $offset += &Net::DNS::RRFIXEDSZ;
  892.  
  893.     return (undef, undef)
  894.         if length($$data) < ($offset + $rdlength);
  895.  
  896.     my $rrobj = Net::DNS::RR->new($name,
  897.                       $type,
  898.                       $class,
  899.                       $ttl,
  900.                       $rdlength, 
  901.                       $data,
  902.                       $offset);
  903.  
  904.     return (undef, undef) unless defined $rrobj;
  905.  
  906.     $offset += $rdlength;
  907.     return ($rrobj, $offset);
  908. }
  909.  
  910. sub safe_push {
  911.     Carp::croak(<<END);
  912. Net::DNS::Packet::safe_push() has been removed.  The safe_push() method
  913. is only avalible from the Net::DNS::Update class.
  914. END
  915. }
  916.  
  917. =head1 COPYRIGHT
  918.  
  919. Copyright (c) 1997-2002 Michael Fuhr. 
  920.  
  921. Portions Copyright (c) 2002-2003 Chris Reinhardt.
  922.  
  923. All rights reserved.  This program is free software; you may redistribute
  924. it and/or modify it under the same terms as Perl itself.
  925.  
  926. DNSSEC/EDNS0 functionality courtesy of Olaf M. Kolkman, RIPE NCC.
  927.  
  928. =head1 SEE ALSO
  929.  
  930. L<perl(1)>, L<Net::DNS>, L<Net::DNS::Resolver>, L<Net::DNS::Update>,
  931. L<Net::DNS::Header>, L<Net::DNS::Question>, L<Net::DNS::RR>,
  932. RFC 1035 Section 4.1, RFC 2136 Section 2, RFC 2845
  933.  
  934. =cut
  935.  
  936. 1;
  937.