base.pm

雷傲极酷超级论坛LeoBBSX 040408 简体正式版

					print ';; answer from ',
					      $ready->peerhost, ':',
					      $ready->peerport, ' : ',
					      length($buf), " bytes\n"
						if $self->{'debug'};
				
					my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
				
					if (defined $ans) {
						next unless $ans->header->qr;
						next unless $ans->header->id == $packet->header->id;
						$self->errorstring($ans->header->rcode);
						$ans->answerfrom($self->answerfrom);
						$ans->answersize($self->answersize);
					} elsif (defined $err) {
						$self->errorstring($err);
					}
					
					return $ans;
				} else {
					$self->errorstring($!);
					
					print ';; recv ERROR(',
					      $ready->peerhost, ':',
					      $ready->peerport, '): ',
					      $self->errorstring, "\n"
						if $self->{'debug'};

					@ns = grep { $_->[0] ne $ready->peerhost } @ns;
					
					return unless @ns;
				}
			}
		}
	}

	if ($sel->handles) {
		$self->errorstring('query timed out');
	}
	else {
		$self->errorstring('all nameservers failed');
	}
	return;
}


sub bgsend {
	my $self = shift;

	unless (@{$self->{'nameservers'}}) {
		$self->errorstring('no nameservers');
		return;
	}

	$self->_reset_errorstring;

	my $packet = $self->make_query_packet(@_);
	my $packet_data = $packet->data;

	my $srcaddr = $self->{'srcaddr'};
	my $srcport = $self->{'srcport'};

	my $dstaddr = $self->{'nameservers'}->[0];
	my $dstport = $self->{'port'};

	my $sock = IO::Socket::INET->new(
		Proto => 'udp',
		LocalAddr => $srcaddr,
		LocalPort => ($srcport || undef),
	);

	unless ($sock) {
		$self->errorstring(q|couldn't get socket|);   #'
		return;
	}
	
	my $dst_sockaddr = sockaddr_in($dstport, inet_aton($dstaddr));

	print ";; bgsend($dstaddr:$dstport)\n" if $self->{'debug'};

	unless ($sock->send($packet_data, 0, $dst_sockaddr)) {
		my $err = $!;
		print ";; send ERROR($dstaddr): $err\n" if $self->{'debug'};
		$self->errorstring($err);
		return;
	}

	return $sock;
}


sub bgread {
	my ($self, $sock) = @_;

	my $buf = '';

	my $peeraddr = $sock->recv($buf, $self->_packetsz);
	
	if ($peeraddr) {
		print ';; answer from ', $sock->peerhost, ':',
		      $sock->peerport, ' : ', length($buf), " bytes\n"
			if $self->{'debug'};

		my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});
		
		if (defined $ans) {
			$self->errorstring($ans->header->rcode);
		} elsif (defined $err) {
			$self->errorstring($err);
		}
		
		return $ans;
	} else {
		$self->errorstring($!);
		return;
	}
}

sub bgisready {
	my $self = shift;
	my $sel = Net::DNS::Select->new(@_);
	my @ready = $sel->can_read(0.0);
	return @ready > 0;
}

sub make_query_packet {
	my $self = shift;
	my $packet;

	if (ref($_[0]) and $_[0]->isa('Net::DNS::Packet')) {
		$packet = shift;
	} else {
		my ($name, $type, $class) = @_;

		$name  ||= '';
		$type  ||= 'A';
		$class ||= 'IN';

		# If the name looks like an IP address then do an appropriate
		# PTR query.
		if ($name =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
			$name = "$4.$3.$2.$1.in-addr.arpa.";
			$type = 'PTR';
		}

		$packet = Net::DNS::Packet->new($name, $type, $class);
	}

	if ($packet->header->opcode eq 'QUERY') {
		$packet->header->rd($self->{'recurse'});
	}

    if ($self->{'dnssec'}) {
	    # RFC 3225
    	print ";; Adding EDNS extention with UDP packetsize $self->{'udppacketsize'} and DNS OK bit set\n" 
    		if $self->{'debug'};
    	
    	my $optrr = Net::DNS::RR->new(
						Type         => 'OPT',
						Name         => '',
						Class        => $self->{'udppacketsize'},  # Decimal UDPpayload
						ednsflags    => 0x8000, # first bit set see RFC 3225 
				   );
				 
	    $packet->push('additional', $optrr);
	    
	} elsif ($self->{'udppacketsize'} > &Net::DNS::PACKETSZ) {
	    print ";; Adding EDNS extention with UDP packetsize  $self->{'udppacketsize'}.\n" if $self->{'debug'};
	    # RFC 3225
	    my $optrr = Net::DNS::RR->new( 
						Type         => 'OPT',
						Name         => '',
						Class        => $self->{'udppacketsize'},  # Decimal UDPpayload
						TTL          => 0x0000 # RCODE 32bit Hex
				    );
				    
	    $packet->push('additional', $optrr);
	}
	

	if ($self->{'tsig_rr'}) {
		if (!grep { $_->type eq 'TSIG' } $packet->additional) {
			$packet->push('additional', $self->{'tsig_rr'});
		}
	}

	return $packet;
}

sub axfr {
	my $self = shift;
	my @zone;

	if ($self->axfr_start(@_)) {
		my ($rr, $err);
		while (($rr, $err) = $self->axfr_next, $rr && !$err) {
			push @zone, $rr;
		}
		@zone = () if $err && $err ne 'no zone transfer in progress';
	}

	return @zone;
}

sub axfr_old {
	warn "Use of " . __PACKAGE__ . "::axfr_old() is deprecated.  Use axfr() or axfr_start().\n";
	
	my $self = shift;
	my ($dname, $class) = @_;
	$dname ||= $self->{'searchlist'}->[0];
	$class ||= 'IN';

	unless ($dname) {
		print ";; ERROR: axfr: no zone specified\n" if $self->{'debug'};
		$self->errorstring('no zone');
		return;
	}

	print ";; axfr($dname, $class)\n" if $self->{'debug'};

	unless (@{$self->{'nameservers'}}) {
		$self->errorstring('no nameservers');
		print ";; ERROR: no nameservers\n" if $self->{'debug'};
		return;
	}

	my $packet = $self->make_query_packet($dname, 'AXFR', $class);
	my $packet_data = $packet->data;

	my $ns = $self->{'nameservers'}->[0];

	print ";; axfr nameserver = $ns\n" if $self->{'debug'};

	my $srcport = $self->{'srcport'};

	my $sock;
	my $sock_key = "$ns:$self->{'port'}";

	if ($self->{'persistent_tcp'} && $self->{'sockets'}{$sock_key}) {
		$sock = $self->{'sockets'}{$sock_key};
		print ";; using persistent socket\n" if $self->{'debug'};
	}
	else {

		# IO::Socket carps on errors if Perl's -w flag is turned on.
		# Uncomment the next two lines and the line following the "new"
		# call to turn off these messages.

		my $old_wflag = $^W;
		$^W = 0;

		$sock = IO::Socket::INET->new(
		    PeerAddr  => $ns,
		    PeerPort  => $self->{'port'},
		    LocalAddr => $self->{'srcaddr'},
		    LocalPort => ($srcport || undef),
		    Proto     => 'tcp',
		    Timeout   => $self->{'tcp_timeout'}
		);

		$^W = $old_wflag;

		unless ($sock) {
			$self->errorstring(q|couldn't connect|);
			return;
		}

		$self->{'sockets'}{$sock_key} = $sock;
	}

	my $lenmsg = pack('n', length($packet_data));

	unless ($sock->send($lenmsg)) {
		$self->errorstring($!);
		return;
	}

	unless ($sock->send($packet_data)) {
		$self->errorstring($!);
		return;
	}

	my $sel = Net::DNS::Select->new($sock);

	my @zone;
	my $soa_count = 0;
	my $timeout = $self->{'tcp_timeout'};

	while (1) {
		my @ready = $sel->can_read($timeout);
		unless (@ready) {
			$self->errorstring('timeout');
			return;
		}

		my $buf = read_tcp($sock, &Net::DNS::INT16SZ, $self->{'debug'});
		last unless length($buf);
		my ($len) = unpack('n', $buf);
		last unless $len;

		@ready = $sel->can_read($timeout);
		unless (@ready) {
			$self->errorstring('timeout');
			return;
		}

		$buf = read_tcp($sock, $len, $self->{'debug'});

		print ';; received ', length($buf), " bytes\n"
			if $self->{'debug'};

		unless (length($buf) == $len) {
			$self->errorstring("expected $len bytes, received " . length($buf));
			return;
		}

		my ($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});

		if (defined $ans) {
			if ($ans->header->ancount < 1) {
				$self->errorstring($ans->header->rcode);
				last;
			}
		}
		elsif (defined $err) {
			$self->errorstring($err);
			last;
		}

		foreach ($ans->answer) {
			# $_->print if $self->{'debug'};
			if ($_->type eq 'SOA') {
				++$soa_count;
				push @zone, $_ unless $soa_count >= 2;
			}
			else {
				push @zone, $_;
			}
		}

		last if $soa_count >= 2;
	}

	return @zone;
}


sub axfr_start {
	my $self = shift;
	my ($dname, $class) = @_;
	$dname ||= $self->{'searchlist'}->[0];
	$class ||= 'IN';

	unless ($dname) {
		print ";; ERROR: axfr: no zone specified\n" if $self->{'debug'};
		$self->errorstring('no zone');
		return;
	}

	print ";; axfr_start($dname, $class)\n" if $self->{'debug'};

	unless (@{$self->{'nameservers'}}) {
		$self->errorstring('no nameservers');
		print ";; ERROR: no nameservers\n" if $self->{'debug'};
		return;
	}

	my $packet = $self->make_query_packet($dname, 'AXFR', $class);
	my $packet_data = $packet->data;

	my $ns = $self->{'nameservers'}->[0];

	print ";; axfr_start nameserver = $ns\n" if $self->{'debug'};

	my $srcport = $self->{'srcport'};

	my $sock;
	my $sock_key = "$ns:$self->{'port'}";

	if ($self->{'persistent_tcp'} && $self->{'sockets'}->{$sock_key}) {
	    $sock = $self->{'sockets'}->{$sock_key};
	    print ";; using persistent socket\n" if $self->{'debug'};
	    
	} else {

		# IO::Socket carps on errors if Perl's -w flag is turned on.
		# Uncomment the next two lines and the line following the "new"
		# call to turn off these messages.

		#my $old_wflag = $^W;
		#$^W = 0;

		$sock = IO::Socket::INET->new(
		    PeerAddr  => $ns,
		    PeerPort  => $self->{'port'},
		    LocalAddr => $self->{'srcaddr'},
		    LocalPort => ($srcport || undef),
		    Proto     => 'tcp',
		    Timeout   => $self->{'tcp_timeout'}
		 );

		#$^W = $old_wflag;

		unless ($sock) {
			$self->errorstring(q|couldn't connect|);
			return;
		}

		$self->{'sockets'}->{$sock_key} = $sock;
	}

	my $lenmsg = pack('n', length($packet_data));

	unless ($sock->send($lenmsg)) {
		$self->errorstring($!);
		return;
	}

	unless ($sock->send($packet_data)) {
		$self->errorstring($!);
		return;
	}

	my $sel = Net::DNS::Select->new($sock);

	$self->{'axfr_sel'}       = $sel;
	$self->{'axfr_rr'}        = [];
	$self->{'axfr_soa_count'} = 0;

	return $sock;
}


sub axfr_next {
	my $self = shift;
	my $err  = '';

	unless (@{$self->{'axfr_rr'}}) {
		unless ($self->{'axfr_sel'}) {
			$err = 'no zone transfer in progress';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		my $sel = $self->{'axfr_sel'};
		my $timeout = $self->{'tcp_timeout'};

		#--------------------------------------------------------------
		# Read the length of the response packet.
		#--------------------------------------------------------------

		my @ready = $sel->can_read($timeout);
		unless (@ready) {
			$err = 'timeout';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		my $buf = read_tcp($ready[0], &Net::DNS::INT16SZ, $self->{'debug'});
		unless (length $buf) {
			$err = 'truncated zone transfer';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		my ($len) = unpack('n', $buf);
		unless ($len) {
			$err = 'truncated zone transfer';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		#--------------------------------------------------------------
		# Read the response packet.
		#--------------------------------------------------------------

		@ready = $sel->can_read($timeout);
		unless (@ready) {
			$err = 'timeout';
			$self->errorstring($err);
			return wantarray ? (undef, $err) : undef;
		}

		$buf = read_tcp($ready[0], $len, $self->{'debug'});

		print ';; received ', length($buf), " bytes\n"
			if $self->{'debug'};

		unless (length($buf) == $len) {
			$err = "expected $len bytes, received " . length($buf);
			$self->errorstring($err);
			print ";; $err\n" if $self->{'debug'};
			return wantarray ? (undef, $err) : undef;
		}

		my $ans;
		($ans, $err) = Net::DNS::Packet->new(\$buf, $self->{'debug'});

		if ($ans) {
			if ($ans->header->rcode ne 'NOERROR') {	
				$self->errorstring('Response code from server: ' . $ans->header->rcode);
				print ';; Response code from server: ' . $ans->header->rcode . "\n" if $self->{'debug'};
				return wantarray ? (undef, $err) : undef;
			}
			if ($ans->header->ancount < 1) {
				$err = 'truncated zone transfer';
				$self->errorstring($err);
				print ";; $err\n" if $self->{'debug'};
				return wantarray ? (undef, $err) : undef;
			}
		}
		else {
			$err ||= 'unknown error during packet parsing';
			$self->errorstring($err);
			print ";; $err\n" if $self->{'debug'};
			return wantarray ? (undef, $err) : undef;
		}

		foreach my $rr ($ans->answer) {
			if ($rr->type eq 'SOA') {
				if (++$self->{'axfr_soa_count'} < 2) {
					push @{$self->{'axfr_rr'}}, $rr;
				}
			}
			else {
				push @{$self->{'axfr_rr'}}, $rr;
			}
		}

		if ($self->{'axfr_soa_count'} >= 2) {
			$self->{'axfr_sel'} = undef;
		}
	}

	my $rr = shift @{$self->{'axfr_rr'}};

	return wantarray ? ($rr, undef) : $rr;
}


sub tsig {
	my $self = shift;

	if (@_ == 1) {
		if ($_[0] && ref($_[0])) {
			$self->{'tsig_rr'} = $_[0];
		}
		else {
			$self->{'tsig_rr'} = undef;
		}
	}
	elsif (@_ == 2) {
		my ($key_name, $key) = @_;
		$self->{'tsig_rr'} = Net::DNS::RR->new("$key_name TSIG $key");
	}

	return $self->{'tsig_rr'};
}

#
# Usage:  $data = read_tcp($socket, $nbytes, $debug);
#
sub read_tcp {
	my ($sock, $nbytes, $debug) = @_;
	my $buf = '';

	while (length($buf) < $nbytes) {
		my $nread = $nbytes - length($buf);
		my $read_buf = '';

		print ";; read_tcp: expecting $nread bytes\n" if $debug;

		# During some of my tests recv() returned undef even
		# though there wasn't an error.  Checking for the amount
		# of data read appears to work around that problem.

		unless ($sock->recv($read_buf, $nread)) {
			if (length($read_buf) < 1) {
				my $errstr = $!;

				print ";; ERROR: read_tcp: recv failed: $!\n"
					if $debug;

				if ($errstr eq 'Resource temporarily unavailable') {
					warn "ERROR: read_tcp: recv failed: $errstr\n";
					warn "ERROR: try setting \$res->timeout(undef)\n";
				}

				last;
			}
		}

		print ';; read_tcp: received ', length($read_buf), " bytes\n"
			if $debug;

		last unless length($read_buf);
		$buf .= $read_buf;
	}

	return $buf;
}

sub AUTOLOAD {
	my ($self) = @_;

	my $name = $AUTOLOAD;
	$name =~ s/.*://;

	Carp::croak "$name: no such method" unless exists $self->{$name};
	
	no strict q/refs/;
	
	
	*{$AUTOLOAD} = sub {
		my ($self, $new_val) = @_;
		
		if (defined $new_val) {
			$self->{"$name"} = $new_val;
		}
		
		return $self->{"$name"};
	};

	
	goto &{$AUTOLOAD};	
}



1;