view release on metacpan or  search on metacpan

lib/Net/DNS/Extlang.pm  view on Meta::CPAN

	my ($decode);
	my $offoff = 0;
	  
	foreach my $f (@$rrfields) {
		my ($type, $quals, $name) = ($f->{type}, $f->{quals}, $f->{name});

		my $cch = _cchunk($f, 'default' => [ '???', '???', -1 ],
			'I1' => [ 'C', 1, undef ],
			'I2' => [ 'n', 2, undef ],
			'I4' => [ 'N', 4, undef ],
			'A' => [ 'a4', 4, undef ],
			'AA' => ['a8', 8, undef ],
			'AAAA' => ['a16', 8, undef ],
			'N' => [ undef, 0, '($self->{#F#}, $offset) = decode Net::DNS::DomainName( $data, $offset, @opaque );'],
			'N[C]' => [ undef, 0, '($self->{#F#}, $offset) = decode Net::DNS::DomainName1035( $data, $offset, @opaque );'],
			'N[A,C]' => [ undef, 0, '($self->{#F#}, $offset) = decode Net::DNS::DomainName1035( $data, $offset, @opaque );'],
			'S' => [ undef, 0, '( $self->{#F#}, $offset ) = decode Net::DNS::Text( $data, $offset );' ],
			'S[M]' => [ undef, -1, $stringdecode ],
			'S[X]' => [ undef, -1, $onestringdecode ],
			'B64' => [ undef, -1, '$self->{#F#_bin} = substr $$data, $offset, $self->{rdlength} - ($offset-$origoffset);'],
			'X' => [ undef, -1, '$self->{#F#_bin} = substr $$data, $offset, $self->{rdlength} - ($offset-$origoffset);'],
			'X[C]' => [ undef, 0, $countdecode ],
			'B32' => [ undef, 0, $countdecode ],
			'R[L]' => [ undef, -1, '$self->{#F#} = substr $$data, $offset, $self->{rdlength} - ($offset-$origoffset);'],
			'T' => [ 'N', 4, undef ],
			'R' => [ 'n', 2, undef ],
			'X6' => [ 'a6', 6, undef ],
			'X8' => [ 'a8', 8, undef ],
				
				 );
		
		my ($pat, $size, $code) = @$cch;
		croak "$name field after end of decoded data" if $offoff < 0;

		if($pat) {
			$decode .= "\t\$self->{$name} = unpack \"\\\@\$offset $pat\",\$\$data;\n\t\$offset += $size;\n";
			$offoff += $size;
		} else {
			$decode .= _csub("\t$code\n", F => $name);
			if($size < 0) { $offoff = -1; }
			else { $offoff += $size; } # 0 for offset updated, -1 for not so this has to be last
		}
	}

	return $decode ? <<"CODE" : '';
sub _decode_rdata {			## decode rdata from wire-format octet string
	my (\$self, \$data, \$offset, \@opaque ) = \@_;
	my \$origoffset = \$offset;
	## \$data	reference to a wire-format packet buffer
	## \$offset	location of rdata within packet buffer

$decode}
CODE
}


# turn fields into binary data
# triple of pack codes, and code to create the stuff to pack, size
# default code is the field
# size of -1 means unknown, will fail if something later wants it
# stores the data into $encdata

sub _fieldencode {
	my ($rrfields) = @_;
	my ($packpat, @args, $packcode);
	  
	foreach my $f (@$rrfields) {
		my ($type, $quals, $name) = ($f->{type}, $f->{quals}, $f->{name});

		my $cch = _cchunk($f, 'default' => [ '???', '???', -1 ],
			'I1' => [ 'C', undef, 1 ],
			'I2' => [ 'n', undef, 2 ],
			'I4' => [ 'N', undef, 4 ],
			'A' => [ 'a4', undef, 4 ],
			'AA' => [ 'a8', undef, 8 ],
			'AAAA' => [ 'a16', undef,16 ],
			'N' => [ 'a*', '#F#->encode(#O#, @opaque)', -1 ],
			'N[A]' => [ 'a*', '#F#->encode(#O#, @opaque)', -1 ],
			'N[A,C]' => [ 'a*', '#F#->encode(#O#, @opaque)', -1 ],
			'S' => [ 'a*', ' #F#->encode', -1 ],  # encode provides the length
			'S[X]' => [ 'a*', '#F#->raw', -1 ],
			'S[M]' => [ 'a*', 'join("", map( $_->encode, @{#F#}))', -1 ],
			'B64' => [ 'a*', undef, -1 ],
			'X[C]' => [ 'Ca*', 'length(#F#),#F#', -1 ],
			'B32' => [ 'Ca*', 'length(#F#),#F#', -1 ],
			'X' => [ 'a*', undef, -1 ],
			'T' => [ 'N', undef, 4 ],
			'R' => [ 'n', undef, 2 ],
			'R[L]' => [ 'a*', undef, -1 ],
			'X6' => [ 'a6', undef, 6 ],
			'X8' => [ 'a8', undef, 8 ],
				 );
		
		my ($pat, $field, $size) = @$cch;
		$field = '#F#' unless $field;

		# handle names that need to know the offset
		if($field =~ m{#O#}) {
			if($packpat) {	# flush out any pending stuff
				if($packcode) {
					$packcode .= "\t\$encdata .= ";
				} else {
					$packcode = "\t\$encdata = ";
				}
				if($packpat =~ m{^(a\*)+$}) { # all a's, just concat
					$packcode .= join(" . ", @args) . ";\n";
				} else {
					$packcode .= "pack '$packpat'," . join(", ", @args) . ";\n";
				}
				$packpat = ""; @args = ();
			}
			if($packcode) {
				$field =~ s{#O#}{\$offset+(length \$encdata)};
			} else {
				$field =~ s{#O#}{\$offset}; # first field, plain offset
			}
		}
		$packpat .= $pat;

		for ($field) {
			s/#F#/join('', '$self->{', _bn($type, $name, $quals), '}')/eg;
			push @args, $_;
		}
	}
	# now generate the code
	if($packpat) {
		if($packcode) {
			$packcode .= "\t\$encdata .= ";
		} else {
			$packcode = "\t\$encdata = ";
		}
		if($packpat =~ m{^(a\*)+$}) { # all a's, just concat
			$packcode .= join(" . ", @args) . ";\n";
		} else {
			$packcode .= "pack '$packpat'," . join(", ", @args) . ";\n";
		}
	}

	return $packcode ? <<"CODE" : '';
sub _encode_rdata {			## encode rdata as wire-format octet string
	my (\$self, \$offset, \@opaque) = \@_;
	my \$encdata = '';

$packcode}
CODE
}


# parse arguments to make a new RR
sub _fieldparse {
	my ($rrfields) = @_;
	my ($decode, $eaten);		# $eaten means all the arguments have been eaten
	  
	foreach my $f (@$rrfields) {
		my ($type, $quals, $name) = ($f->{type}, $f->{quals}, $f->{name});

		carp("Field with no argument $name") if $eaten;

		#print "parse $type $name ";
		# check for a field that takes multiple arguments
		my $val = _cchunk($f, 'default' => 'shift',
			'S[M]' => '@_',
			'B64' => '@_',
			'X' => '@_',
			'X[C]' => 'shift',
			'R[L]' => '@_',
			       );
		#print "$val\n";
		$eaten = 1 if $val =~ m'@_';
		$decode .= _csub("	\$self->#FIELD#(#VAL#);\n",
			FIELD => $name,
			VAL => $val);
	}

	return $decode ? <<"CODE" : '';
sub _parse_rdata {			## populate RR from rdata in argument list
	my \$self = shift;

$decode}
CODE
}


# format RR fields into an array
sub _fieldformat {
	my ($rrfields) = @_;
	my (@rdata);		# $eaten means all the arguments have been eaten
	  
	foreach my $f (@$rrfields) {
		my ($type, $quals, $name) = ($f->{type}, $f->{quals}, $f->{name});

		my $fmt = _cchunk($f, 'default' => '$self->{#FIELD#}',
			'N' => '$self->{#FIELD#}->string',
			'N[C]' => '$self->{#FIELD#}->string',
			'N[C,A]' => '$self->#FIELD#}->string',
			'S' => '$self->{#FIELD#}->string',
			'S[M]' => '(map $_->string, @{$self->{#FIELD#}})',
			'A' => '$self->#FIELD#()',
			'AA' => "sprintf('%x:%x:%x:%x', unpack 'n4',\$self->{#FIELD#})",
			'AAAA' => '$self->#FIELD#_short',
			'B64' => 'split(/\s+/, encode_base64( $self->{#FIELD#_bin}))',
			'B32' => '$self->#FIELD#()',