1package Net::DNS::Header;
2
3use strict;
4use warnings;
5
6our $VERSION = (qw$Id: Header.pm 1812 2020-10-07 18:09:53Z willem $)[2];
7
8
9=head1 NAME
10
11Net::DNS::Header - DNS packet header
12
13=head1 SYNOPSIS
14
15    use Net::DNS;
16
17    $packet = Net::DNS::Packet->new();
18    $header = $packet->header;
19
20
21=head1 DESCRIPTION
22
23C<Net::DNS::Header> represents the header portion of a DNS packet.
24
25=cut
26
27
28use integer;
29use Carp;
30
31use Net::DNS::Parameters qw(:opcode :rcode);
32
33
34=head1 METHODS
35
36
37=head2 $packet->header
38
39    $packet = Net::DNS::Packet->new();
40    $header = $packet->header;
41
42Net::DNS::Header objects emanate from the Net::DNS::Packet header()
43method, and contain an opaque reference to the parent Packet object.
44
45Header objects may be assigned to suitably scoped lexical variables.
46They should never be stored in global variables or persistent data
47structures.
48
49
50=head2 string
51
52    print $packet->header->string;
53
54Returns a string representation of the packet header.
55
56=cut
57
58sub string {
59	my $self = shift;
60
61	my $id	   = $self->id;
62	my $qr	   = $self->qr;
63	my $opcode = $self->opcode;
64	my $rcode  = $self->rcode;
65	my $qd	   = $self->qdcount;
66	my $an	   = $self->ancount;
67	my $ns	   = $self->nscount;
68	my $ar	   = $self->arcount;
69
70	my $opt = $$self->edns;
71	my $edns = $opt->_specified ? $opt->string : '';
72
73	return <<END . $edns if $opcode eq 'UPDATE';
74;;	id = $id
75;;	qr = $qr		opcode = $opcode	rcode = $rcode
76;;	zocount = $qd	prcount = $an	upcount = $ns	adcount = $ar
77END
78
79	my $aa = $self->aa;
80	my $tc = $self->tc;
81	my $rd = $self->rd;
82	my $ra = $self->ra;
83	my $zz = $self->z;
84	my $ad = $self->ad;
85	my $cd = $self->cd;
86	my $do = $self->do;
87
88	return <<END . $edns;
89;;	id = $id
90;;	qr = $qr	aa = $aa	tc = $tc	rd = $rd	opcode = $opcode
91;;	ra = $ra	z  = $zz	ad = $ad	cd = $cd	rcode  = $rcode
92;;	qdcount = $qd	ancount = $an	nscount = $ns	arcount = $ar
93;;	do = $do
94END
95}
96
97
98=head2 print
99
100    $packet->header->print;
101
102Prints the string representation of the packet header.
103
104=cut
105
106sub print {
107	print &string;
108	return;
109}
110
111
112=head2 id
113
114    print "query id = ", $packet->header->id, "\n";
115    $packet->header->id(1234);
116
117Gets or sets the query identification number.
118
119A random value is assigned if the argument value is undefined.
120
121=cut
122
123sub id {
124	my ( $self, @arg ) = @_;
125	$$self->{id} = shift(@arg) if scalar @arg;
126	return $$self->{id} if defined $$self->{id};
127	return $$self->{id} = int rand(0xffff);
128}
129
130
131=head2 opcode
132
133    print "query opcode = ", $packet->header->opcode, "\n";
134    $packet->header->opcode("UPDATE");
135
136Gets or sets the query opcode (the purpose of the query).
137
138=cut
139
140sub opcode {
141	my ( $self, $arg ) = @_;
142	my $opcode;
143	for ( $$self->{status} ) {
144		return opcodebyval( ( $_ >> 11 ) & 0x0f ) unless defined $arg;
145		$opcode = opcodebyname($arg);
146		$_ = ( $_ & 0x87ff ) | ( $opcode << 11 );
147	}
148	return $opcode;
149}
150
151
152=head2 rcode
153
154    print "query response code = ", $packet->header->rcode, "\n";
155    $packet->header->rcode("SERVFAIL");
156
157Gets or sets the query response code (the status of the query).
158
159=cut
160
161sub rcode {
162	my ( $self, $arg ) = @_;
163	my $rcode;
164	for ( $$self->{status} ) {
165		my $opt = $$self->edns;
166		unless ( defined $arg ) {
167			return rcodebyval( $_ & 0x0f ) unless $opt->_specified;
168			$rcode = ( $opt->rcode & 0xff0 ) | ( $_ & 0x00f );
169			$opt->rcode($rcode);			# write back full 12-bit rcode
170			return $rcode == 16 ? 'BADVERS' : rcodebyval($rcode);
171		}
172		$rcode = rcodebyname($arg);
173		$opt->rcode($rcode);				# full 12-bit rcode
174		$_ &= 0xfff0;					# low 4-bit rcode
175		$_ |= ( $rcode & 0x000f );
176	}
177	return $rcode;
178}
179
180
181=head2 qr
182
183    print "query response flag = ", $packet->header->qr, "\n";
184    $packet->header->qr(0);
185
186Gets or sets the query response flag.
187
188=cut
189
190sub qr {
191	return shift->_dnsflag( 0x8000, @_ );
192}
193
194
195=head2 aa
196
197    print "response is ", $packet->header->aa ? "" : "non-", "authoritative\n";
198    $packet->header->aa(0);
199
200Gets or sets the authoritative answer flag.
201
202=cut
203
204sub aa {
205	return shift->_dnsflag( 0x0400, @_ );
206}
207
208
209=head2 tc
210
211    print "packet is ", $packet->header->tc ? "" : "not ", "truncated\n";
212    $packet->header->tc(0);
213
214Gets or sets the truncated packet flag.
215
216=cut
217
218sub tc {
219	return shift->_dnsflag( 0x0200, @_ );
220}
221
222
223=head2 rd
224
225    print "recursion was ", $packet->header->rd ? "" : "not ", "desired\n";
226    $packet->header->rd(0);
227
228Gets or sets the recursion desired flag.
229
230=cut
231
232sub rd {
233	return shift->_dnsflag( 0x0100, @_ );
234}
235
236
237=head2 ra
238
239    print "recursion is ", $packet->header->ra ? "" : "not ", "available\n";
240    $packet->header->ra(0);
241
242Gets or sets the recursion available flag.
243
244=cut
245
246sub ra {
247	return shift->_dnsflag( 0x0080, @_ );
248}
249
250
251=head2 z
252
253Unassigned bit, should always be zero.
254
255=cut
256
257sub z {
258	return shift->_dnsflag( 0x0040, @_ );
259}
260
261
262=head2 ad
263
264    print "The response has ", $packet->header->ad ? "" : "not", "been verified\n";
265
266Relevant in DNSSEC context.
267
268(The AD bit is only set on a response where signatures have been
269cryptographically verified or the server is authoritative for the data
270and is allowed to set the bit by policy.)
271
272=cut
273
274sub ad {
275	return shift->_dnsflag( 0x0020, @_ );
276}
277
278
279=head2 cd
280
281    print "checking was ", $packet->header->cd ? "not" : "", "desired\n";
282    $packet->header->cd(0);
283
284Gets or sets the checking disabled flag.
285
286=cut
287
288sub cd {
289	return shift->_dnsflag( 0x0010, @_ );
290}
291
292
293=head2 qdcount, zocount
294
295    print "# of question records: ", $packet->header->qdcount, "\n";
296
297Returns the number of records in the question section of the packet.
298In dynamic update packets, this field is known as C<zocount> and refers
299to the number of RRs in the zone section.
300
301=cut
302
303our $warned;
304
305sub qdcount {
306	my $self = shift;
307	return $$self->{count}[0] || scalar @{$$self->{question}} unless scalar @_;
308	carp 'header->qdcount attribute is read-only' unless $warned++;
309	return;
310}
311
312
313=head2 ancount, prcount
314
315    print "# of answer records: ", $packet->header->ancount, "\n";
316
317Returns the number of records in the answer section of the packet
318which may, in the case of corrupt packets, differ from the actual
319number of records.
320In dynamic update packets, this field is known as C<prcount> and refers
321to the number of RRs in the prerequisite section.
322
323=cut
324
325sub ancount {
326	my $self = shift;
327	return $$self->{count}[1] || scalar @{$$self->{answer}} unless scalar @_;
328	carp 'header->ancount attribute is read-only' unless $warned++;
329	return;
330}
331
332
333=head2 nscount, upcount
334
335    print "# of authority records: ", $packet->header->nscount, "\n";
336
337Returns the number of records in the authority section of the packet
338which may, in the case of corrupt packets, differ from the actual
339number of records.
340In dynamic update packets, this field is known as C<upcount> and refers
341to the number of RRs in the update section.
342
343=cut
344
345sub nscount {
346	my $self = shift;
347	return $$self->{count}[2] || scalar @{$$self->{authority}} unless scalar @_;
348	carp 'header->nscount attribute is read-only' unless $warned++;
349	return;
350}
351
352
353=head2 arcount, adcount
354
355    print "# of additional records: ", $packet->header->arcount, "\n";
356
357Returns the number of records in the additional section of the packet
358which may, in the case of corrupt packets, differ from the actual
359number of records.
360In dynamic update packets, this field is known as C<adcount>.
361
362=cut
363
364sub arcount {
365	my $self = shift;
366	return $$self->{count}[3] || scalar @{$$self->{additional}} unless scalar @_;
367	carp 'header->arcount attribute is read-only' unless $warned++;
368	return;
369}
370
371sub zocount { return &qdcount; }
372sub prcount { return &ancount; }
373sub upcount { return &nscount; }
374sub adcount { return &arcount; }
375
376
377=head1 EDNS Protocol Extensions
378
379
380=head2 do
381
382    print "DNSSEC_OK flag was ", $packet->header->do ? "not" : "", "set\n";
383    $packet->header->do(1);
384
385Gets or sets the EDNS DNSSEC OK flag.
386
387=cut
388
389sub do {
390	return shift->_ednsflag( 0x8000, @_ );
391}
392
393
394=head2 Extended rcode
395
396EDNS extended rcodes are handled transparently by $packet->header->rcode().
397
398
399=head2 UDP packet size
400
401    $udp_max = $packet->header->size;
402    $udp_max = $packet->edns->size;
403
404EDNS offers a mechanism to advertise the maximum UDP packet size
405which can be assembled by the local network stack.
406
407UDP size advertisement can be viewed as either a header extension or
408an EDNS feature.  Endless debate is avoided by supporting both views.
409
410=cut
411
412sub size {
413	my $self = shift;
414	return $$self->edns->size(@_);
415}
416
417
418=head2 edns
419
420    $header  = $packet->header;
421    $version = $header->edns->version;
422    @options = $header->edns->options;
423    $option  = $header->edns->option(n);
424    $udp_max = $packet->edns->size;
425
426Auxiliary function which provides access to the EDNS protocol
427extension OPT RR.
428
429=cut
430
431sub edns {
432	my $self = shift;
433	return $$self->edns;
434}
435
436
437########################################
438
439sub _dnsflag {
440	my $self = shift;
441	my $flag = shift;
442	for ( $$self->{status} ) {
443		my $set = $_ | $flag;
444		my $not = $set - $flag;
445		$_ = (shift) ? $set : $not if scalar @_;
446		$flag = ( $_ & $flag ) ? 1 : 0;
447	}
448	return $flag;
449}
450
451
452sub _ednsflag {
453	my ( $self, $flag, @val ) = @_;
454	my $edns = $$self->edns->flags || 0;
455	return $flag & $edns ? 1 : 0 unless scalar @val;
456	my $set = $flag | $edns;
457	my $not = $set - $flag;
458	my $val = shift(@val) ? $set : $not;
459	$$self->edns->flags($val) unless $val == $edns;
460	return ( $val & $flag ) ? 1 : 0;
461}
462
463
4641;
465__END__
466
467
468########################################
469
470=head1 COPYRIGHT
471
472Copyright (c)1997 Michael Fuhr.
473
474Portions Copyright (c)2002,2003 Chris Reinhardt.
475
476Portions Copyright (c)2012 Dick Franks.
477
478All rights reserved.
479
480
481=head1 LICENSE
482
483Permission to use, copy, modify, and distribute this software and its
484documentation for any purpose and without fee is hereby granted, provided
485that the above copyright notice appear in all copies and that both that
486copyright notice and this permission notice appear in supporting
487documentation, and that the name of the author not be used in advertising
488or publicity pertaining to distribution of the software without specific
489prior written permission.
490
491THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
492IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
493FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
494THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
495LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
496FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
497DEALINGS IN THE SOFTWARE.
498
499
500=head1 SEE ALSO
501
502L<perl>, L<Net::DNS>, L<Net::DNS::Packet>, L<Net::DNS::RR::OPT>
503RFC 1035 Section 4.1.1
504
505=cut
506
507