chainmail-0.2.4/0002777000175000017500000000000010211432423010441 500000000000000chainmail-0.2.4/perl/0002777000175000017500000000000010211432424011404 500000000000000chainmail-0.2.4/perl/Chainmail/0002777000175000017500000000000010211432424013271 500000000000000chainmail-0.2.4/perl/Chainmail/Version.pm.in0000644000175000017500000000013507173401135015602 00000000000000package Chainmail::Version; $VERSION = "@VERSION@"; sub version { return "$VERSION"; } 1; chainmail-0.2.4/perl/Chainmail/DeliveryMethod/0002777000175000017500000000000010211432424016215 500000000000000chainmail-0.2.4/perl/Chainmail/DeliveryMethod/DirectSMTP/0002777000175000017500000000000010211432424020133 500000000000000chainmail-0.2.4/perl/Chainmail/DeliveryMethod/DirectSMTP/Connection.pm0000644000175000017500000001246307367022046022525 00000000000000package Chainmail::DeliveryMethod::DirectSMTP::Connection; use IO::Socket::INET; use Chainmail::Report; use Socket qw(:DEFAULT :crlf);; sub _clean_data{ # turn LF into CR LF to keep qmail happy my $data = shift; $data =~ s/(?{sock}=IO::Socket::INET->new(PeerAddr => $peer, PeerPort => $peerport, Proto => 'tcp') or return undef; $self->{PeerName} = $peer; $self->{PeerPort} = $peerport; $self->{Transcript} = ""; bless ($self,$class); $self->{PeerGreeting} = $self->suck(); _response($self->{PeerGreeting},220) or die "server won't say hello\n"; $self->{PeerGreeting} =~ /ESMTP/ and $self->{PeerESMTP} = "probably"; return $self; } sub sockhost{ my$self=shift; my$sock=$self->{sock}; return $sock->sockhost(); } sub peerhost{ my$self=shift; my$sock=$self->{sock}; return $sock->peerhost(); } sub peername{ my$self=shift; return $self->{PeerName} . ":" . $self->{PeerPort}; } sub helo { my $self = shift; my $host = $self->sockhost(); my $response; if (!defined($self->{PlainSMTP})) { $self->say("EHLO [$host]" . CRLF); $response = $self->suck(); do{ $response = $self->suck() while (_response($response,220)); if (!_response($response)) { inform "unexpected response from server to EHLO, trying HELO (standard SMTP)"; #everybody is ESMTP these days, except PACIFIC-CARRIER-ANNEX.mit.edu. $self->{PeerESMTP} = "none"; goto no_esmtp; } else { $response = $self->suck(); my $ext = $response; $ext =~ s/^[\s]*250[-\s]*([^\n\r]*)/$1/; push @{$self->{PeerESMTPExts}}, uc $ext; } } while $response =~ /^[\s]*[0-9]+-/; $self->{PeerESMTP} = "definitely"; return 2; } no_esmtp: $self->say("HELO [$host]" . CRLF); my $r; ($r = $self->responses()) and die("HELO rejected: $r\n"); return 1; } sub quit { my $self = shift; $self->say("QUIT" . CRLF); } sub peer_supports{ my ($self,$ext) = @_; return 0 if(defined $self->{PlainSMTP}); return 0 if(!defined $self->{PeerESMTPExts}); for my $e (@{$self->{PeerESMTPExts}}) { return 1 if ($e =~ /^$ext([\s]|$)/); } return 0; } sub mail { my ($self,$data,$senders,$recipients) = @_; $data = _clean_data($data); my $len = length $data; my $sendaddr; my (@successful,@failed); $senders = [] unless $senders; push @{$senders}, Chainmail::Address->new([],[], ""); # Try an empty address if nothing else goes for my $sender (@{$senders}) { $sendaddr = $sender->get_address(); debug "trying " . $sendaddr; eval{ $self->from($sendaddr,$len); }; goto got_sender if(!$@); } die("all senders rejected\n"); got_sender: for my $recipient (@$recipients) { eval{ $self->to($recipient->get_address(),$len,$sendaddr); }; if ($@) { push @failed,$recipient; } else { push @successful,$recipient; } } if (@successful) { $self->data($data,$len); } return @failed; } sub from { my ($self,$addr,$length) = @_; my $msg = "MAIL FROM:<$addr>"; $msg .= " SIZE=$length" if($self->peer_supports("SIZE")); $self->say($msg . CRLF); my $resp; ($resp = $self->responses()) and die("sender rejected: $resp\n"); } sub to { my ($self,$addr,$length,$sender,$dsn) = @_; my $msg = "RCPT TO:<$addr>"; $msg .= " NOTIFY=$dsn ORCPT=rfc822;$sender" if (defined($dsn) && $self->peer_supports("DSN")); $self->say($msg . CRLF); my $resp; ($resp = $self->responses()) and die("recipient rejected: $resp\n"); } sub data { my ($self,$data,$length)=@_; $self->say("DATA" . CRLF); my $resp; $resp = $self->responses(354); if($resp){ die("DATA command rejected: $resp\n"); } $self->say_raw("$data." . CRLF); if($resp = $self->responses()) { die("message rejected: $resp\n"); } } sub say { my($self,$message)=@_; my $dbg = "> " . $self->peername() . ":\t" . $message; inform($dbg); $self->{Transcript} .= $dbg; $self->say_raw($message); } sub say_raw{ my($self,$message)=@_; my $sock = $self->{sock}; (print $sock $message) or die "unable to write to socket: $!\n"; } sub suck { my($self)=@_; my$sock=$self->{sock}; my$buf; my$response; do { if( ! sysread($sock,$buf,1) ) { die("EOF or error on socket, connection closed?\n"); } $response .= $buf; } while($buf ne LF); my $dbg = "< " . $self->peername() . ":\t" . $response; inform($dbg); $self->{Transcript} .= $dbg; return $response; } sub get_transcript { my $self=shift; return $self->{Transcript}; } sub responses { my ($self,$expected) = @_; # $expected can be undef as _response will sort it out my $response; do{ $response = $self->suck(); if (!(_response($response,$expected))) { return $response; } } while $response =~ /^[\s]*[0-9]+-/; undef; } sub close { my $self = shift; $self->{sock}->close(); } 1; chainmail-0.2.4/perl/Chainmail/DeliveryMethod/Sendmail.pm0000644000175000017500000000167207174347511020247 00000000000000package Chainmail::DeliveryMethod::Sendmail; use Chainmail::Report; use Chainmail::Config; sub deliver { shift; my $message = shift; my @replytos = $message->get_reply_to(); my $replyto = $replytos[0]->get_text(); my @recipients = $message->get_recipients(); if ( !(@recipients) ) { die "no recipients\n"; } my $contents = $message->get_contents(); $_ = $contents; $contents .= "\n" unless /((\n)|(\n\.))$/; my $recipient_list = ""; foreach my $r (@recipients) { $recipient_list .= "'" . $r->get_text() . "' "; } open(SENDMAIL, "| " . Chainmail::Config::sendmail() . " -f '$replyto' $recipient_list" ) || die "can't fork $sendmail_prog: $!\n"; local $SIG{PIPE} = sub { die "chainmail: pipe broke to $sendmail_prog" }; print SENDMAIL "$contents"; close SENDMAIL || die "chainmail: error closing pipe to $sendmail_prog: $! $?\n"; return undef; } 1; chainmail-0.2.4/perl/Chainmail/DeliveryMethod/DirectSMTP.pm0000644000175000017500000000342307243562314020422 00000000000000package Chainmail::DeliveryMethod::DirectSMTP; require Chainmail::DeliveryMethod::DirectSMTP::Connection; use Chainmail::Report; use Chainmail::Config; use Chainmail::FailedMessage; use IO::Socket::INET; use POSIX; use Socket qw(:DEFAULT :crlf);; sub deliver { my ($message,$host) = @_; my @replytos = $message->get_reply_to(); my @senders = $message->get_senders(); my @recipients = $message->get_recipients(); my @from=(@replytos,@senders); my @failed_recipients; my @successful_recipients; if ( !(@recipients) || !defined($recipients[0])) { die "no recipients\n"; } my $data = $message->get_contents(); $host = Chainmail::Config::smtp_relay() unless $host; $host or die "no host to connect to\n"; inform("connecting to host $host"); my $sock = Chainmail::DeliveryMethod::DirectSMTP::Connection->new($host,25) or die("couldn't connect to $host: $!\n"); my $sockhost = $sock->sockhost(); my $peerhost = $sock->peerhost(); my $time = asctime(gmtime()); chomp $time; inform "local end " . $sockhost . " remote " . $peerhost . " at " . $time . " GMT"; eval { $sock->helo(); @unsuccessful_recipients = $sock->mail($data,\@from,\@recipients); }; my $result = $@; eval{ $sock->quit(); $sock->close(); }; my$failure = undef; debug("SMTP failed: $result") if $result; if($result || @unsuccessful_recipients){ my $transcript = "Transcript of connection to $host ($peerhost) at " . localtime(time) . "\n" . $sock->get_transcript(); $failure = Chainmail::FailedMessage->new(); $failure->message($message); $failure->transcript($transcript); $failure->failed(@unsuccessful_recipients or @recipients); } return $failure; } 1; chainmail-0.2.4/perl/Chainmail/DeliveryMethod/Enqueue.pm0000644000175000017500000000432307243562314020113 00000000000000package Chainmail::DeliveryMethod::Enqueue; use Chainmail::Config; use Chainmail::Report; use Chainmail::Queue; use Fcntl; sub deliver { my ($message,$failed) = @_; $failed = 0 unless $failed; my$child=fork; # want a new pid for uniqueness if(!defined $child){ die "can't fork: $!\n"; } if ($child!=0){ waitpid($child,0); return undef; } my @replytos = $message->get_reply_to(); my @senders = $message->get_senders(); my @recipients = $message->get_recipients(); if ( !(@recipients) ) { die "no recipients\n"; } my$directory=Chainmail::Queue::get_directory(); my ($handle,$filename,$target) = open_maildir($directory); my @names = ("reply-to","from","to"); my $ni = 0; print $handle queue_tag() . "failed $failed "; foreach my $set (\@replytos,\@senders,\@recipients) { print $handle $names[$ni++] ." ("; foreach my $address (@{$set}) { my $addr = $address->get_address(); $addr =~ s/\\/\\\\/g; $addr =~ s/,/\\,/g; print $handle $addr . ","; } print $handle ") "; } print $handle "\n"; print $handle $message->get_contents(); close $handle || die "problem closing $filename: $!\n"; die "supposedly unique $directory/$target exists already\n" if -e $target; link $filename, $target or die "error linking $directory/$filename to $directory/$target: $!\n"; unlink $filename or die "can't unlink $directory/$filename: $!\n"; debug("delivery to $directory/$target successful\n"); exit 0; } sub open_maildir { my $directory = shift; debug("trying to deliver to maildir $directory\n"); chdir $directory || die "unable to access $directory\n"; foreach my $dir ("new","tmp","cur","undeliverable") { (-e $dir or mkdir $dir) } my $time = time; my $pid = $$; my $host = Chainmail::Config::get_hostname(); my $base = "$time.$pid.$host"; my $file = "tmp/$base"; die "unique file $directory/$file exists\n" if -e $file ; (sysopen(MESSAGE,$file,O_WRONLY|O_CREAT|O_EXCL)) || die "unable to open unique file $directory/$file\n"; debug("successfully opened $file\n"); return (MESSAGE,$file,"new/$base"); } 1; chainmail-0.2.4/perl/Chainmail/DeliveryMethod/LookupSMTP.pm0000644000175000017500000000467507243562314020473 00000000000000package Chainmail::DeliveryMethod::LookupSMTP; use Chainmail::DeliveryMethod::DirectSMTP; use Chainmail::Report; use Chainmail::Config; use Chainmail::FailedMessage; use Chainmail::MessageType::Raw; use Net::DNS; sub deliver { my ($message,$host) = @_; my @recipients = $message->get_recipients(); my @successful_recipients = (); my $transcript = ""; if ( !(@recipients) || !defined($recipients[0])) { die "no recipients\n"; } recipient: for my $recipient (@recipients) { my $domain = $recipient->get_domain(); my %mx = _find_mx($domain); my @single = ($recipient); my $msg = Chainmail::MessageType::Raw->new($message); $msg->set_recipients($recipient); foreach my $host (sort {$mx{$a} <=> $mx{$b}} keys %mx) { my $hostinfo; if (defined $mx{$host}) { $hostinfo = "Host $host obtained by MX lookup on $domain (preference " . $mx{$host} . ")"; } else { $hostinfo = "Host $domain has no MX records so using (CNAME) $host"; } debug "trying $host"; my$failed; eval{ $failed = Chainmail::DeliveryMethod::DirectSMTP::deliver($msg,$host); }; if ($@){ debug("internal error from DirectSMTP for $host: $@"); $transcript .= "$hostinfo\n$@"; } else { if($failed){ $transcript .= "$hostinfo\n" . $failed->transcript() ; } else { next recipient; } } } push @failed_recipients,$recipients; } return undef if(!@failed_recipients); my$fail=Chainmail::FailedMessage->new(); $fail->message($message); $fail->failed(@failed_recipients); $fail->transcript($transcript); debug("LookupSMTP: failure notice\n$transcript"); return $fail; } sub _find_mx { my $domain = shift; my $res = (shift || new Net::DNS::Resolver); my %mx; my%backup; # Add the option to try to contact the host directly. $backup{$domain} = undef; debug("searching for mailexchangers for $domain"); my $query = $res->query($domain, "MX"); if (!$query) { debug "can't find DNS MX records for $domain: " . $res->errorstring; return %backup; } foreach my $rr ($query->answer) { if($rr->type eq "CNAME"){#FIXME: are CNAMES always given out for MX queries? inform("$domain is in fact " . $rr->cname); return _find_mx($rr->cname,$res); } if($rr->type eq "MX"){ $mx{$rr->exchange}=$rr->preference; inform "for $domain, MX\t" . $rr->preference . "\t" . $rr->exchange; } } return %mx or %backup; } 1; chainmail-0.2.4/perl/Chainmail/DeliveryMethod/Dynamic.pm0000644000175000017500000000176307174347511020100 00000000000000package Chainmail::DeliveryMethod::Dynamic; use Chainmail::Recipient; use Chainmail::MessageType::Raw; use Chainmail::Report; use Chainmail::FailedMessage; sub deliver{ my $message=shift; my$transcript=""; if(!$message->get_recipients()){ die("no recipients\n"); } for my $method (@_){ debug("trying $method"); eval "require Chainmail::DeliveryMethod::$method;"; if($@){ die "can't require $method: $@\n"; } my $fail = eval "Chainmail::DeliveryMethod::${method}::deliver(\$message)"; if($@){ debug("internal error from $method: $@"); $transcript .= "\nError from method $method: $@\n"; # lots of newlines on purpose } else { if($fail){ my$message = $fail->message(); $transcript .= $fail->transcript(); } else { return undef; } } } my$fail = Chainmail::FailedMessage->new(); $fail->message($message); $fail->failed($message->get_recipients()); $fail->transcript($transcript); return $fail; } 1; chainmail-0.2.4/perl/Chainmail/MessageType/0002777000175000017500000000000010211432424015517 500000000000000chainmail-0.2.4/perl/Chainmail/MessageType/Rfc822/0002777000175000017500000000000010211432424016465 500000000000000chainmail-0.2.4/perl/Chainmail/MessageType/Rfc822/FieldParser.pm0000644000175000017500000003250607243562314021160 00000000000000package Chainmail::MessageType::Rfc822::FieldParser; use Chainmail::Report; use Chainmail::Config; require Chainmail::Address; my $add_address_to_address_list = sub { my $self = shift; my $address = shift; enter( "Add address to list hook" ); if (!defined( $address )) { error( "sent an undefined address!" ); leave(); return; } push @{$self->{ADDRESSES}}, $address; leave(); }; my $call_address_transform = sub { my $self = shift; my $address = shift; return $address->transform(); }; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; @{$self->{IGNORED_TOKENS}} = ( "WHITESPACE" ); $self->{CURRENT_TOKEN} = undef; $self->{TOKENS} = (); $self->{TOKEN_STACK} = (); $self->{TOKEN_DUMP} = (); $self->{CONTEXT} = (); $self->{ADDRESSES} = (); $self->{ADDRESS_INFO} = undef; $self->{ADDRESS_HOOK} = $add_address_to_address_list; $self->{DISCARD_TOKENS} = undef; bless ($self, $class); return $self; } sub add_info { my $self = shift; my $new_info = shift; if ( defined $self->{ADDRESS_INFO} ) { $self->{ADDRESS_INFO} .= " $new_info"; } else { $self->{ADDRESS_INFO} = $new_info; } } sub lex { my $self = shift; my $text = shift; local $_; enter( "Lexing RFC 822 header field" ); debug( "field is:\n\t$text" ); @{$self->{TOKENS}} = (); (leave(),return undef) if length( $text ) == 0 ; # Tokens my $endline = qr/(?:\n|\r\n)/; my $linear_ws = qr/(?:$endline)?[ \t]/; my $quoted_pair = qr/\\./s; my $special_chars = '\(\)\<\>\@\,\;\:\.\[\]\"'; my $atom = qr/[^$special_chars\t\n ]+/; my $quoted_string = qr/\"(?:(?:[^\"\\]|$quoted_pair)*)\"/; my $dtext = qr/[^\r\n\[\]\\\"]/; my $domain_literal = qr/\[(?:$dtext|$quoted_string)*\]/; my %token_types = ( WHITESPACE => qr/(?:$linear_ws)+/ , QUOTED_STRING => qr/$quoted_string/ , ATOM => qr/$atom/ , DOMAIN_LITERAL => qr/$domain_literal/ , AT_SIGN => qr/\@/ , OPEN_ANGLE_BRACKET => qr/\ qr/\>/ , # OPEN_SQUARE_BRACKET => qr/\[/ , # CLOSE_SQUARE_BRACKET => qr/\]/ , COLON => ":" , COMMA => ",", SEMICOLON => ";", STOP => "\\." ) ; $_ = $text; chomp; my $t; get_token: do { if ( /^\(/s ) { my$next; ($t,$next) = $self->_strip_leading_comment( $_ ); debug( "got comment $t" ); push @{$self->{TOKENS}},$self->make_token( "COMMENT",$t ) ; $_ = $next; } else { foreach $t (keys %token_types) { my $r = $token_types{$t}; if ( /^($r)(.*)/s ) { debug( "got token \"$1\" (type $t)" ); push @{$self->{TOKENS}}, $self->make_token( $t, $1 ); $_ = $2; goto get_token; } } fatal_error("unable to tokenize \"$_\"") unless ! length; } } while length; leave(); return 1; } sub make_token { my $self = shift; my $type = shift; my $value = shift; my $return = { "TYPE"=>$type,"VALUE"=>$value }; return $return; } sub _strip_leading_comment { my $self = shift; my $text = shift; enter( "Stripping leading comment" ); my $char; my $comment = ""; while ( length $text) { $text =~ /^([^\\]|\\.)(.*)/s; # remove first char from string. FIXME $char = $1; $text = $2; $comment .= $char; $brackets++ if $char eq "\(" ; if ( $char eq "\)") { $brackets --; ( leave(), return ( $comment,$text ) ) if $brackets == 0 ; } } error( "unterminated comment (no unquoted closing bracket)" ); leave(); } sub grab_addresses { my $self = shift; enter( "Grabbing addresses from RFC 822 header field" ); $self->{ADDRESS_HOOK} = $add_address_to_address_list; $self->parse( ) if ( !defined (@{$self->{ADDRESSES}}) ); leave(); return @{$self->{ADDRESSES}} unless ( !defined (@{$self->{ADDRESSES}}) ); return undef; } sub transform_addresses { my $self = shift; enter( "Transforming addresses in RFC 822 header field" ); $self->{ADDRESS_HOOK} = $call_address_transform; $self->parse( shift ); $self->{TOKENS} = $self->{TOKEN_DUMP}; leave(); return 1; } sub _got_address { my($self,$addr_obj)=@_; debug( "got address " . $addr_obj->get_text() ); if ( !defined $self->{ADDRESS_HOOK} ) { error( "address manipulation hook is undefined!" ); } else { @_ = ( $self, $addr_obj ); &{$self->{ADDRESS_HOOK}}; } push @{$self->{TOKEN_DUMP}},$self->make_token( "ADDRESS",$addr_obj ); $self->{ADDRESS_INFO} = undef; } sub unfold{ my $self = shift; my $text = shift; $text =~ s/[\n\r]+\s+/ /g; return $text; } sub parse { my $self = shift; my $text = shift; enter( "Parsing RFC 822 address header field" ); if ( !defined( @{$self->{TOKENS}} ) ) { (leave (), return undef) if !defined $text; $self->lex( $self->unfold($text) ); } @{$self->{ADDRESSES}} = (); @{$self->{TOKEN_STACK}} = @{$self->{TOKENS}}; @{$self->{TOKEN_DUMP}} = (); $self->{DISCARD_TOKENS} = 0; (error( "no tokens to read!" ),leave(), return undef) if !defined $self->{TOKEN_STACK}; $self->{CURRENT_TOKEN} = undef; $self->get_next_token(); $self->addresses(); leave(); return 1; } sub get_text { my $self = shift; my $text = undef; foreach my $tok (@{$self->{TOKENS}}) { if ( $tok->{TYPE} eq "ADDRESS" ) { $text .= " " . $tok->{VALUE}->get_text() . " "; } else { $text .= $tok->{VALUE}; } } return $text; } sub get_pretty_text { my $self = shift; my $text = undef; my $has_ws = 1; foreach my $tok (@{$self->{TOKENS}}) { if ( $tok->{TYPE} eq "ADDRESS" ) { $text .= " " unless $has_ws; $text .= $tok->{VALUE}->get_text(); next; } if ( $tok->{TYPE} eq "WHITESPACE" ) { #$text .= " " unless $has_ws; #$has_ws = 1; # ignore it completely next; } if($tok->{TYPE} eq "COMMA" ) { $text .= ",\n\t"; $has_ws = 1; next; } $text .= " " unless $has_ws; $text .= $tok->{VALUE}; $has_ws = 0; } return $text; } sub require_token { my $self = shift; my $demand = shift; my $peek_ahead = 11; # Number of tokens to look at to find the $demand. my $t; for (my $i =0; $i < $peek_ahead; $i++ ) { $t = $self->peek_token( $i ); if ( (defined $t) && ($t->{TYPE} eq $demand) ) { while ( !(defined ($self->token( $demand )) ) ) { push @_, $self->{DISCARD_TOKENS}; $self->{DISCARD_TOKENS} = 1; $self->parse_error( "discarding token to satisfy demand for $demand" ); $self->get_next_token(); $self->{DISCARD_TOKENS} = pop @_ ; } return $t->{VALUE}; } } $self->parse_error( "could not satisfy request for a token of type $demand even looking ahead $peek_ahead tokens" ); return undef; } sub token { my $self = shift; my $request = shift; defined $self->{CURRENT_TOKEN} or return undef; $self->skip_ignored_tokens(); if (( !defined( $request)) || ( $self->{CURRENT_TOKEN}->{TYPE} eq $request )) { my $r = $self->{CURRENT_TOKEN}->{VALUE}; $self->get_next_token(); return $r; } return undef; } sub skip_ignored_tokens { my $self = shift; do { if ( $self->{CURRENT_TOKEN}->{TYPE} eq "COMMENT" ) { debug("removing comment " . $self->{CURRENT_TOKEN}->{VALUE}); $self->{CURRENT_TOKEN}->{VALUE} =~ /\(((.)*?)\)$/s || $self->parse_error( "Regexp failed to strip brackets from comment ", $self->{CURRENT_TOKEN}->{VALUE} ); $self->add_info( $1 ) if length $1; } else { foreach my $t (@{$self->{IGNORED_TOKENS}}) { if ( $self->{CURRENT_TOKEN}->{TYPE} eq $t ) { debug("removing invalid $t: " . $self->{CURRENT_TOKEN}->{VALUE}); goto found; } } return; found: } } while $self->get_next_token(); } sub get_next_token { my $self = shift; if (defined $self->{CURRENT_TOKEN}) { my $token = shift @{$self->{TOKEN_STACK}}; if ($self->{DISCARD_TOKENS} == 0) { push @{$self->{TOKEN_DUMP}}, $token; } } $self->{CURRENT_TOKEN} = ${$self->{TOKEN_STACK}}[0]; return undef if !defined $self->{CURRENT_TOKEN}; debug( "parser ate token: " . $self->{CURRENT_TOKEN}->{TYPE} ); return $self->{CURRENT_TOKEN}; } sub token_is { my $self = shift; $self->skip_ignored_tokens(); if ( defined( $self->peek_token (0)) ) { return ( $self->peek_token(0)->{TYPE} eq shift ); } else { return undef; } } sub peek_token { my $self = shift; my $index = shift; return ${$self->{TOKEN_STACK}}[$index]; } sub parse_error { my $self = shift; my $message = shift; error $message; debug ( "token list is:" ); foreach $token (@{$self->{TOKEN_STACK}}) { debug( "\t\ttoken type=". $token->{TYPE} . " value=\"". $token->{VALUE} . "\" address=" . $token ); } return ""; } sub group { my $self = shift; enter( "Named e-mail group" ); my $group_name = $self->phrase(); $self->{ADDRESS_INFO} = undef; $self->require_token( "COLON" ); $self->addresses(); $self->require_token( "SEMICOLON") or $self->parse_error( "named group of addresses apparently not terminated by semi-colon" ); leave(); } sub phrase { my $self = shift; enter( "Phrase; list of words or quoted strings" ); my $w; my $r = undef; while ( defined ($w = $self->word()) ) { $r .= "$w " if length $w;} chop $r if defined $r; leave(); return $r; } sub word { my $self = shift; ($self->token( "ATOM" ) ) or return $self->token( "QUOTED_STRING"); } sub route { my $self = shift; enter( "Parsing route to address" ); inform( "routed address; route is being ignored" ); do { $self->token( "AT_SIGN" ); do { $self->sub_domain(); } while( $self->token( "STOP" ) ); } while( $self->token( "COMMA" ) ); $self->token( "COLON" ); leave(); } sub sub_domain { my $self = shift; return $self->word(); } sub route_addr { my $self = shift; enter( "Angle bracketed
" ); $self->token( "OPEN_ANGLE_BRACKET" ); if($self->token_is( "CLOSE_ANGLE_BRACKET" )) { my$a=Chainmail::Address->new( [], [], $self->{ADDRESS_INFO}); $self->_got_address($a); } else{ if ($self->token_is( "AT_SIGN")) { $self->route(); } $self->addr_spec(); } $self->require_token( "CLOSE_ANGLE_BRACKET") or $self->parse_error( "unterminated < bracket" ); leave(); } sub addr_spec { my $self = shift; enter( "Address (addr-spec\@domain)" ); my@localpart; my@domain; my $t; my $addr_obj; if ($self->token_is( "ADDRESS" )) { $addr_obj = $self->token(); goto addr_obj_got; } do { $t = $self->word(); if ( defined $t ) { $t = $1 if $t =~ /\"((.)*?)\"$/s; push @localpart, $t; } else { $self->parse_error( "not valid address part (token types ATOM or QUOTED_STRING)" ); } } while ( defined( $self->token( "STOP") ) ); $self->token ("AT_SIGN") or goto address_finished; if($self->token_is("DOMAIN_LITERAL")){ my $literal = $self->token ("DOMAIN_LITERAL"); push @domain,$literal; } else { do { $t = $self->sub_domain(); if (!$t) { if (!@domain) { $self->parse_error("empty domain after @"); leave(); return; } else { goto address_finished; # someone has finished an address with a dot. } } push @domain, $t; } while ( defined ($self->token( "STOP") ) ); } address_finished: $addr_obj = Chainmail::Address->new( \@localpart, \@domain, $self->{ADDRESS_INFO}); addr_obj_got: $self->_got_address($addr_obj); leave(); } sub addresses { my $self = shift; my $state = "Set of comma separated addresses"; enter( $state ); do { $self->address(); } while( defined( $self->token ("COMMA") ) ); leave( $state ); } sub address { my $self = shift; my $token = undef; for( my $i=0; ( defined( $token = $self->peek_token( $i ) ) ); $i++ ) { if ($token->{TYPE} eq "COLON") { debug( "Guessing group" ); return $self->group(); } else { if ($token->{TYPE} eq "OPEN_ANGLE_BRACKET") { debug( "Guessing
" ); $self->{DISCARD_TOKENS} = 1; $self->add_info( $self->phrase() ); $self->route_addr(); $self->{DISCARD_TOKENS} = 0; return; } else { last if ($token->{TYPE} eq "COMMA"); } } } debug("Falling back on guess addr_spec\@domain"); $self->{DISCARD_TOKENS} = 1; $self->addr_spec(); $self->{DISCARD_TOKENS} = 0; return; } 1; chainmail-0.2.4/perl/Chainmail/MessageType/Rfc822.pm0000644000175000017500000002136107175332663016763 00000000000000use IO::Handle; # STDERR->autoflush(1); # STDOUT->autoflush(1); package Chainmail::MessageType::Rfc822; use Chainmail::MessageType::Rfc822::FieldParser; use Chainmail::Address; use Chainmail::Report; use Chainmail::Lib; use Chainmail::Config; use Socket; @sender_fields = ( # From the sendmail bat book. In descending order of preference. "Resent-Sender", "Resent-From", "Resent-Reply-To", "Sender", "From", "Apparently-From", "Reply-To", "Full-Name", "Return-Receipt-To", ); @reply_to_fields = ( "Reply-To", # picked +/- at random "From", "Apparently-From", "Resent-From", "Sender", "Resent-Sender", "Return-Receipt-To" ); @error_recipient_fields = ( "Errors-To", "Return-Path", @sender_fields ); @resent_recip_fields = ("Resent-To", "Resent-Cc", "Resent-Bcc" ); @recip_fields = ( "To", "Cc", "Bcc", "Apparently-To" ); @recipient_fields = [ # Also from sendmail. # List of lists; if anything in a list matches # then the following lists are not tried at all @resent_recip_fields, @recip_fields ]; @nonrecipient_fields = ( "X-loop" ); @hide_fields = ( "Bcc", "Resent-Bcc" ); @add_if_absent_fields = ( "Message-ID", "Date", # "X-Mailer" ); @replace_fields = ( # Only replace if present # "Comment" ); @prepend_fields = ( "Received" ); # Unconditional @address_fields = ( # Should be all address fields @sender_fields, @error_recipient_fields, @resent_recip_fields, @recip_fields, @nonrecipient_fields ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; $self->{BODY} = undef; $self->{HEADER} = undef; @{$self->{FIELD}} = (); bless ($self, $class); return $self; } sub parse { my $self = shift; my $text = shift; my $header; if ( $text =~ /^from ([^\n]*)(?:\n)?(.*)/si ) { inform( "UNIX mailbox style from line: \"$1\" is being ignored" ); $text = $2; } ($self->{HEADER},$self->{BODY}) = split /\n\n/, $text, 2; # $self->{BODY} .= "\n" # unless $self->{BODY} =~ /\n$/s; $self->parse_header(); return $self; } sub parse_header { my $self = shift; local $_; enter( "Parsing RFC822 header" ); @{$self->{FIELD}} = (); $_ = $self->{HEADER}; do { /^((?:[^\n]*(?:\n\s)?)*)\n?(.*)/s || fatal_error( "regexp failed to find top field of header:\n\t$_" ); $field = $1; $_ = $2; $field =~ /^([^:]+?)\s*:(.*)/s || fatal_error( "regexp failed to split header field:\n\t$field" ) ; $name = $1; $value = $2; debug( "header-field $name is \"$value\"" ); if ( member( $name,@replace_fields ) ) { $value = $self->generate_field( $name ); } my $parser = undef; if ( member( $name,@address_fields ) ) { $parser = Chainmail::MessageType::Rfc822::FieldParser->new(); $parser->transform_addresses( $value ); } push @{$self->{FIELD}}, $self->_make_field( $name, $value, $parser ); } while (length); my %add_fields; @add_fields{ @add_if_absent_fields } = @add_if_absent_fields; # foreach $name (@add_if_absent_fields) # { # $add_fields{ $name } = '1'; # } foreach my $field (@{$self->{FIELD}}) { if ( member( $field->{NAME}, @replace_fields ) ) { $field->{VALUE} = $self->generate_field( $field->{NAME} ); } if ( $name = member( $field->{NAME}, keys %add_fields ) ) { debug( "field $name already present" ); debug( "field $name does not exist") if !exists($add_fields{ $name }); delete $add_fields{ $name }; # keep the case } } foreach my $name (keys %add_fields) { push @{$self->{FIELD}}, $self->_make_field( $name, $self->generate_field( $name ) ); } foreach my $name (@prepend_fields) { unshift @{$self->{FIELD}}, $self->_make_field( $name, $self->generate_field( $name ) ) ; } leave(); } sub get_contents { my $self = shift; return $self->construct_header() . "\n" . $self->{BODY}; } sub construct_header { my $self = shift; my $text = ""; $self->parse_header() if !defined @{$self->{FIELD}}; field: foreach my $field ( @{$self->{FIELD}} ) { error( "empty field address $field found when re-constructing header") if (!defined $field || !defined $field->{NAME}); foreach (@hide_fields){ next field if(lc($field->{NAME}) eq lc); } $text .= $field->{NAME} . ": "; if( defined $field->{PARSER} ) { $text .= $field->{PARSER}->get_pretty_text(); } else { my $line .= $field->{VALUE}; $line =~ s/^[\s]*//; $text .= $line; } $text .= "\n"; } return $text; } sub get_senders { my $self = shift; @_ = $self->get_multifield_addresses( @sender_fields ); return @_; } sub get_reply_to { my $self = shift; my @addrs = $self->get_multifield_addresses( @reply_to_fields ); if (!(@addrs)) { my ($name,$passwd,$uid,$gid, $quota,$comment,$gcos,$dir,$shell,$expire) = getpwuid($>); push @addrs, Chainmail::Address->new( $name, undef, $gecos ); } return @addrs; } sub get_recipients { my $self = shift; my $addr_list = (); my @addrs = (); foreach $addr_list (@recipient_fields) { push @addrs, $self->get_multifield_addresses( @{$addr_list} ); } if (! (@addrs) ) { debug( "no recipient addresses found" ); return undef; } my @nonaddrs = $self->get_multifield_addresses( @nonrecipient_fields ); my @good_addrs; foreach my $recip (@addrs) { foreach my $noperson (@nonaddrs) { goto dont_add if $recip->get_address() eq $noperson->get_address(); } push @good_addrs, $recip; next; dont_add: debug( $recip->get_address() . " was removed from recipient list" ); } return @good_addrs; } sub get_addresses { my $self = shift; my $field_name = lc( shift ); my @addrs = (); foreach my $field (@{$self->{FIELD}}) { if ( lc( $field->{NAME} ) eq $field_name ) { debug( "getting addresses from field: $field_name" ); if ( (!defined ($field->{PARSER})) ) { error( "field $field_name apparently has not been parsed yet" ); return; } @_ = $field->{PARSER}->grab_addresses(); foreach my $address ( @_ ) { debug( "adding address " . $address->get_text() . " to address list" ); # This line is currently needed (1999 08 23), # because otherwise perl (5.005) garbage collects the address. # Now, that's what I call a BUG (or have I misunderstood something?). } push @addrs, @_ if( defined @_ && defined $_[0] ); } } return @addrs; } sub get_multifield_addresses { my $self = shift; my @fields = @_; my @addrs; my $f; my @temp; foreach $f (@fields) { @temp = $self->get_addresses( $f ); (push @addrs, @temp) if ( @temp && defined( $temp[ 0 ] )); } return @addrs; } sub generate_date { my @days_of_week = ( "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" ); my @months = ( "Jan" , "Feb" , "Mar" , "Apr" , "May" , "Jun" , "Jul" , "Aug" , "Sep" , "Oct" , "Nov" , "Dec" ); my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime(); my $day = $days_of_week[ $wday ]; my $date = $mday . " " . $months[ $mon ] . " " . ($year+1900); # Strictly by RFC822 year should be 2 digit, but nobody seems to care (fixed in RFC1123). my $time = sprintf( "%02d", $hour ) . ":" . sprintf( "%02d", $min ) . ":" . sprintf( "%02d", $sec ) . " GMT"; # TODO: get real timezone return "$day, $date $time"; } sub generate_field { my $self = shift; my $name = lc( shift ); if ( $name eq "received" ) { my $date = generate_date(); my $domain = get_hostname(); my $string = "by " . $domain . " (chainmail); $date"; return $string; } if ( $name eq "date" ) { return generate_date(); } if ( $name eq "message-id" ) { my $noconflict = crypt( rand(4294967296) , join '',('.', '/', 0..9, 'A'..'Z', 'a'..'z') [rand 64, rand 64] ); $noconflict =~ tr/a-zA-Z0-9//cd; return "<" . $noconflict . "-" . time . "-$$-chainmail@" . get_hostname() .">"; } return "chainmail - generate field is not yet implemented for $name"; } sub _make_field { my $self = shift; my $name= shift; my $value= shift; my $parser= shift; my $field; $field->{ NAME } = $name; $field->{ VALUE } = $value; $field->{ PARSER } = $parser if defined $parser; return $field; } 1; chainmail-0.2.4/perl/Chainmail/MessageType/Raw.pm0000644000175000017500000000221607174347511016541 00000000000000package Chainmail::MessageType::Raw; require Chainmail::Address; use Chainmail::Report; use Chainmail::Lib; use Chainmail::Config; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; my$msg = shift or die; bless ($self, $class); if(ref $msg){ $self->{BODY} = $msg->get_contents(); @{$self->{TO}} = ($msg->get_recipients()); @{$self->{FROM}} = ($msg->get_senders()); @{$self->{REPLYTO}} = ($msg->get_reply_to()); } else{ $self->{BODY} = $msg; $self->{TO} = shift; $self->{FROM} = shift; $self->{REPLYTO} = shift; } return $self; } sub set_recipients { my($self,@recip)=@_; @{$self->{TO}}=@recip; } sub set_senders { my($self,@recip)=@_; @{$self->{FROM}}=@recip; } sub set_reply_to { my($self,@recip)=@_; @{$self->{REPLYTO}}=@recip; } sub get_recipients { my $self = shift; return @{$self->{TO}}; } sub get_senders { my $self = shift; return @{$self->{FROM}}; } sub get_reply_to { my $self = shift; return @{$self->{REPLYTO}}; } sub get_contents{my$self=shift; return $self->{BODY}; } chainmail-0.2.4/perl/Chainmail/Address.pm0000644000175000017500000000561507243562314015152 00000000000000package Chainmail::Address; use Chainmail::Report; use Chainmail::Config; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; $self->{LOCAL_PART} = shift; $self->{DOMAIN} = shift; $self->{INFO} = shift; bless ($self, $class); return $self; } sub get_address { my $self = shift; my $part; my $local_part = $self->get_local_part(); if (!defined $local_part) { return ""; } # debug( "constructed address $local_part\@$domain"); return "$local_part\@" . $self->get_domain(); } sub get_local_part { my $self = shift; local( $_ ); if ( (!defined @{$self->{LOCAL_PART}}) || !defined( @{$self->{LOCAL_PART}}[0])) { debug( "no local part to address (get_local_part)" ); return undef; } foreach my $part (@{$self->{LOCAL_PART}}) { if( $part =~ /^[A-Za-z_]([A-Za-z\-0-9_]*[A-Za-z0-9_])?$/ ) { $_ .= "$part."; } else { $_ .= "\"$part\"."; } } chop; return $_; } sub get_domain { my $self = shift; my $domain = ""; foreach $part (@{$self->{DOMAIN}}) { $domain .= "$part."; } if ( !length $domain ) { $domain = Chainmail::Config::generate_domain( $local_part, $self->{INFO} ); } else { chop $domain; } return $domain; } sub get_info { my $self = shift; return undef if !defined $self->{INFO}; $self->{INFO} = $1 while $self->{INFO} =~/\"((.)*?)\"$/s; # Escape all unquoted quotes $self->{INFO} =~ s/(?{INFO} ; } sub guess_name { my $self = shift; my $name = $self->get_info() ; enter( "guessing name" ); (leave(), return $name) if defined $name ; if ( (!defined @{$self->{LOCAL_PART}}) || !defined( @{$self->{LOCAL_PART}}[0])) { debug( "could not guess name because address is empty" ); leave(); return undef; } foreach my $part (@{$self->{LOCAL_PART}}) { $name .= "$part "; } (debug( "found address has insinuously empty local part"), leave(), return undef) if length($name) == 0; chop $name; leave(); return $name; } sub get_text { my $self = shift; my $name = ($self->get_info() or undef); # $self->guess_name or (error("could not find any reasonable name"),return undef); if(defined $name){ $name = "\"$name\"" if ($name =~ /[^\s\w]/); $name .= " "; } else { $name = ""; } return $name . "<" . $self->get_address() . ">"; } sub transform { my $self = shift; if (!defined( $self->{LOCAL_PART}) || !defined( $self->{LOCAL_PART}[0] )) { debug( "attempt to transform an empty address!" ); return undef; } else { return Chainmail::Config::transform_address( \$self ); } } 1; chainmail-0.2.4/perl/Chainmail/Report.pm0000644000175000017500000000242707175632716015046 00000000000000package Chainmail::Report; require Exporter; require Chainmail::Config; @ISA = qw(Exporter); @EXPORT = qw(enter leave error fatal_error debug inform); my @state = (); sub enter { my $message = shift; debug( "entering state:\n\t$message" ); unshift @state, $message; } sub leave { my $real = shift; my $s = shift @state; if (defined $real) { if ( $s ne $real ) { fatal_error( "leaving real state:\n $real\nbut context stack thinks it's:\n$s" ); return; } debug( "context stack ok here" ); } debug( "leaving state:\n\t$s" ); } sub debug { return if !Chainmail::Config::do_debugging(); my $message = shift; chomp $message; print STDERR "Debug: $message\n"; } sub inform { my $message = shift; chomp $message; print STDERR "${0}\[${$}\]: $message\n"; } sub error { my $message = shift; print STDERR "Error: $message\n"; debug("error occurred in context (stack):" ) if (@state && defined $state[0]); foreach my $s (@state) { debug( "\t$s" ); } } sub fatal_error { my $message = shift; print STDERR "\nBombing out on fatal error!\n"; error( $message ); die; } 1; chainmail-0.2.4/perl/Chainmail/Config.pm0000644000175000017500000000406107243562314014764 00000000000000package Chainmail::Config; use Sys::Hostname; use Net::hostent; use Chainmail::Version; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(transform_address generate_domain get_hostname get_hostent do_debugging debug_on debug_off queue_directory queue_tag smtp_relay best_address max_tries sendmail logfile); $debug = 0; sub do_debugging # 1 means do debugging { return $debug; } sub debug_on { $debug++; } sub debug_off { $debug-- if $debug; } sub get_hostent() { return gethost( hostname() ); } sub get_hostname() { my @names = @{get_hostent()->aliases}; my $host = best_address( @names ); } sub best_address { my $best=undef; my $c; while(defined($c = shift)){ $best = better_address($c,$best); } return $best; } sub better_address { my ($left,$right)=@_; return $right if(!defined($left)); return $left if(!defined($right)); # most dots wins return $right if($left =~ y/\./\./ < $right =~ y/\./\./); return $left; } sub generate_domain { my $local_part = shift; my $nameinfo = shift; return get_hostname(); } sub home_directory{ my ($name,$passwd,$uid,$gid, $quota,$comment,$gcos,$dir,$shell,$expire) = getpwuid (shift or $<); die "unable to get home directory for user uid $uid\n" unless $dir; return $dir; } sub queue_directory { my$dir = home_directory(); for my$d ("$dir/.outgoing-queue", "$dir/.outgoing-queue/new", "$dir/.outgoing-queue/tmp", "$dir/.outgoing-queue/cur") { mkdir $d,0770; } return "$dir/.outgoing-queue"; } sub logfile{return home_directory() . "/.chainmail-log"; } sub sendmail { return "/usr/sbin/sendmail";} sub smtp_relay { return "smtp.isp"; } sub transform_address { my $address = shift; #is a reference # do nothing. } sub queue_tag{return "X-Chainmail-" . Chainmail::Version::version() . "-Queue: "} sub max_tries{return 3;} 1; chainmail-0.2.4/perl/Chainmail/Lib.pm0000644000175000017500000000047107071672265014274 00000000000000package Chainmail::Lib; use Chainmail::Report; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(member); sub member { my $name = lc(shift); my @list = @_; foreach my $member (@list) { if ( $name eq lc($member) ) { return $member; } } return undef; } chainmail-0.2.4/perl/Chainmail/Queue.pm0000644000175000017500000000034707172700653014647 00000000000000package Chainmail::Queue; require Exporter; require Chainmail::Config; @ISA = qw(Exporter); @EXPORT = qw(get_directory); sub get_directory { return Chainmail::Config::queue_directory(); } chainmail-0.2.4/perl/Chainmail/Recipient.pm0000644000175000017500000000113707172700653015503 00000000000000package Chainmail::Recipient; require Chainmail::Report; use Chainmail::Config; @ISA = qw(Chainmail::Address); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = shift; bless($self,$class); return $self; } sub error { my ($self,$error)=@_; return $self->{ERROR} unless $error; $self->{ERROR} = $error; } sub error_details { my ($self,$error)=@_; return $self->{ERRORDETAILS} unless $error; $self->{ERRORDETAILS} = $error; } sub dsn { my ($self,$dsn)=@_; return $self->{DSN} unless $dsn; $self->{DSN} = $dsn; } chainmail-0.2.4/perl/Chainmail/FailedMessage.pm0000644000175000017500000000120407174350016016241 00000000000000package Chainmail::FailedMessage; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless($self,$class); return $self; } sub message { my($self,$msg)=@_; if($msg){ $self->{MESSAGE} = $msg; return; } $msg = $self->{MESSAGE}; my @failed = $self->failed(); my $m = Chainmail::MessageType::Raw->new($msg); $m->set_recipients(@failed); return $m; } sub transcript { my($self,$msg)=@_; return $self->{TRANSCRIPT} unless $msg; $self->{TRANSCRIPT} = $msg; } sub failed { my($self,@f)=@_; return @{$self->{FAILED}} unless @f; @{$self->{FAILED}} = @f; } 1; chainmail-0.2.4/perl/Chainmail/Version.pm0000664000175000017500000000013110211432423015162 00000000000000package Chainmail::Version; $VERSION = "0.2.4"; sub version { return "$VERSION"; } 1; chainmail-0.2.4/perl/Net/0002777000175000017500000000000010211432424012132 500000000000000chainmail-0.2.4/perl/Net/DNS/0002777000175000017500000000000010211432424012556 500000000000000chainmail-0.2.4/perl/Net/DNS/RR/0002777000175000017500000000000010211432424013101 500000000000000chainmail-0.2.4/perl/Net/DNS/RR/NSAP.pm0000644000175000017500000001157407172700760014137 00000000000000package Net::DNS::RR::NSAP; # $Id: NSAP.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my $afi = unpack("\@$offset C", $$data); $self->{"afi"} = sprintf("%02x", $afi); ++$offset; if ($self->{"afi"} eq "47") { my @idi = unpack("\@$offset C2", $$data); $offset += 2; my $dfi = unpack("\@$offset C", $$data); $offset += 1; my @aa = unpack("\@$offset C3", $$data); $offset += 3; my @rsvd = unpack("\@$offset C2", $$data); $offset += 2; my @rd = unpack("\@$offset C2", $$data); $offset += 2; my @area = unpack("\@$offset C2", $$data); $offset += 2; my @id = unpack("\@$offset C6", $$data); $offset += 6; my $sel = unpack("\@$offset C", $$data); $offset += 1; $self->{"idi"} = sprintf("%02x" x 2, @idi); $self->{"dfi"} = sprintf("%02x" x 1, $dfi); $self->{"aa"} = sprintf("%02x" x 3, @aa); $self->{"rsvd"} = sprintf("%02x" x 2, @rsvd); $self->{"rd"} = sprintf("%02x" x 2, @rd); $self->{"area"} = sprintf("%02x" x 2, @area); $self->{"id"} = sprintf("%02x" x 6, @id); $self->{"sel"} = sprintf("%02x" x 1, $sel); } else { # What to do for unsupported versions? } } return bless $self, $class; } sub idp { my $self = shift; return join(".", $self->{"afi"}, $self->{"idi"}); } sub dsp { my $self = shift; return join(".", $self->{"dfi"}, $self->{"aa"}, $self->rsvd, $self->{"rd"}, $self->{"area"}, $self->{"id"}, $self->{"sel"}); } sub rsvd { my $self = shift; return exists $self->{"rsvd"} ? $self->{"rsvd"} : "0000"; } sub rdatastr { my $self = shift; my $rdatastr; if (exists $self->{"afi"}) { if ($self->{"afi"} eq "47") { $rdatastr = join(".", $self->idp, $self->dsp); } else { $rdatastr = "; AFI $self->{afi} not supported"; } } else { $rdatastr = "; no data"; } return $rdatastr; } sub rr_rdata { my $self = shift; my $rdata = ""; if (exists $self->{"afi"}) { $rdata .= pack("C", hex($self->{"afi"})); if ($self->{"afi"} eq "47") { $rdata .= str2bcd($self->{"idi"}, 2); $rdata .= str2bcd($self->{"dfi"}, 1); $rdata .= str2bcd($self->{"aa"}, 3); $rdata .= str2bcd(0, 2); # rsvd $rdata .= str2bcd($self->{"rd"}, 2); $rdata .= str2bcd($self->{"area"}, 2); $rdata .= str2bcd($self->{"id"}, 6); $rdata .= str2bcd($self->{"sel"}, 1); } # Checks for other versions would go here. } return $rdata; } #------------------------------------------------------------------------------ # Usage: str2bcd(STRING, NUM_BYTES) # # Takes a string representing a hex number of arbitrary length and # returns an equivalent BCD string of NUM_BYTES length (with # NUM_BYTES * 2 digits), adding leading zeros if necessary. #------------------------------------------------------------------------------ # This can't be the best way.... sub str2bcd { my ($string, $bytes) = @_; my $retval = ""; my $digits = $bytes * 2; $string = sprintf("%${digits}s", $string); $string =~ tr/ /0/; my $i; for ($i = 0; $i < $bytes; ++$i) { my $bcd = substr($string, $i*2, 2); $retval .= pack("C", hex $bcd); } return $retval; } 1; __END__ =head1 NAME Net::DNS::RR::NSAP - DNS NSAP resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Network Service Access Point (NSAP) resource records. =head1 METHODS =head2 idp print "idp = ", $rr->idp, "\n"; Returns the RR's initial domain part (the AFI and IDI fields). =head2 dsp print "dsp = ", $rr->dsp, "\n"; Returns the RR's domain specific part (the DFI, AA, Rsvd, RD, Area, ID, and SEL fields). =head2 afi print "afi = ", $rr->afi, "\n"; Returns the RR's authority and format identifier. C currently supports only AFI 47 (GOSIP Version 2). =head2 idi print "idi = ", $rr->idi, "\n"; Returns the RR's initial domain identifier. =head2 dfi print "dfi = ", $rr->dfi, "\n"; Returns the RR's DSP format identifier. =head2 aa print "aa = ", $rr->aa, "\n"; Returns the RR's administrative authority. =head2 rsvd print "rsvd = ", $rr->rsvd, "\n"; Returns the RR's reserved field. =head2 rd print "rd = ", $rr->rd, "\n"; Returns the RR's routing domain identifier. =head2 area print "area = ", $rr->area, "\n"; Returns the RR's area identifier. =head2 id print "id = ", $rr->id, "\n"; Returns the RR's system identifier. =head2 sel print "sel = ", $rr->sel, "\n"; Returns the RR's NSAP selector. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1706. =cut chainmail-0.2.4/perl/Net/DNS/RR/EID.pm0000644000175000017500000000200007172700760013757 00000000000000package Net::DNS::RR::EID; # $Id: EID.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; return bless $self, $class; } 1; __END__ =head1 NAME Net::DNS::RR::EID - DNS EID resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Endpoint Identifier (EID) resource records. =head1 METHODS =head2 rdlength print "rdlength = ", $rr->rdlength, "\n"; Returns the length of the record's data section. =head2 rdata $rdata = $rr->rdata; Returns the record's data section as binary data. =head1 COPYRIGHT Copyright (c) 1997 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, draft-ietf-nimrod-dns-I.txt =cut chainmail-0.2.4/perl/Net/DNS/RR/PTR.pm0000644000175000017500000000277407172700760014045 00000000000000package Net::DNS::RR::PTR; # $Id: PTR.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my($ptrdname) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"ptrdname"} = $ptrdname; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string) { $string =~ s/\.+$//; $self->{"ptrdname"} = $string; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"ptrdname"} ? "$self->{ptrdname}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"ptrdname"}) { $rdata .= $packet->dn_comp($self->{"ptrdname"}, $offset); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::PTR - DNS PTR resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Pointer (PTR) resource records. =head1 METHODS =head2 ptrdname print "ptrdname = ", $rr->ptrdname, "\n"; Returns the domain name associated with this record. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.12 =cut chainmail-0.2.4/perl/Net/DNS/RR/MINFO.pm0000644000175000017500000000370307172700760014241 00000000000000package Net::DNS::RR::MINFO; # $Id: MINFO.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($rmailbx, $emailbx); ($rmailbx, $offset) = Net::DNS::Packet::dn_expand($data, $offset); ($emailbx, $offset) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"rmailbx"} = $rmailbx; $self->{"emailbx"} = $emailbx; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && ($string =~ /^(\S+)\s+(\S+)$/)) { $self->{"rmailbx"} = $1; $self->{"emailbx"} = $2; $self->{"rmailbx"} =~ s/\.+$//; $self->{"emailbx"} =~ s/\.+$//; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"rmailbx"} ? "$self->{rmailbx}. $self->{emailbx}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"rmailbx"}) { $rdata .= $packet->dn_comp($self->{"rmailbx"}, $offset); $rdata .= $packet->dn_comp($self->{"emailbx"}, $offset + length $rdata); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::MINFO - DNS MINFO resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Mailbox Information (MINFO) resource records. =head1 METHODS =head2 rmailbx print "rmailbx = ", $rr->rmailbx, "\n"; Returns the RR's responsible mailbox field. See RFC 1035. =head2 emailbx print "emailbx = ", $rr->emailbx, "\n"; Returns the RR's error mailbox field. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.7 =cut chainmail-0.2.4/perl/Net/DNS/RR/NULL.pm0000644000175000017500000000175607172700760014151 00000000000000package Net::DNS::RR::NULL; # $Id: NULL.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; return bless $self, $class; } 1; __END__ =head1 NAME Net::DNS::RR::NULL - DNS NULL resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Null (NULL) resource records. =head1 METHODS =head2 rdlength print "rdlength = ", $rr->rdlength, "\n"; Returns the length of the record's data section. =head2 rdata $rdata = $rr->rdata; Returns the record's data section as binary data. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.10 =cut chainmail-0.2.4/perl/Net/DNS/RR/LOC.pm0000644000175000017500000002134307172700760014006 00000000000000package Net::DNS::RR::LOC; # $Id: LOC.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA @EXPORT @EXPORT_OK @poweroften $reference_alt $reference_latlon $conv_sec $conv_min $conv_deg $default_min $default_sec $default_size $default_horiz_pre $default_vert_pre); require Exporter; use Net::DNS; use Net::DNS::Packet; @ISA = qw(Net::DNS::RR Exporter); @EXPORT = qw(); @EXPORT_OK = qw(); # Powers of 10 from 0 to 9 (used to speed up calculations). @poweroften = (1, 10, 100, 1_000, 10_000, 100_000, 1_000_000, 10_000_000, 100_000_000, 1_000_000_000); # Reference altitude in centimeters (see RFC 1876). $reference_alt = 100_000 * 100; # Reference lat/lon (see RFC 1876). $reference_latlon = 2**31; # Conversions to/from thousandths of a degree. $conv_sec = 1000; $conv_min = 60 * $conv_sec; $conv_deg = 60 * $conv_min; # Defaults (from RFC 1876, Section 3). $default_min = 0; $default_sec = 0; $default_size = 1; $default_horiz_pre = 10_000; $default_vert_pre = 10; sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($version) = unpack("\@$offset C", $$data); ++$offset; $self->{"version"} = $version; if ($version == 0) { my ($size) = unpack("\@$offset C", $$data); $size = precsize_ntoval($size); ++$offset; my ($horiz_pre) = unpack("\@$offset C", $$data); $horiz_pre = precsize_ntoval($horiz_pre); ++$offset; my ($vert_pre) = unpack("\@$offset C", $$data); $vert_pre = precsize_ntoval($vert_pre); ++$offset; my ($latitude) = unpack("\@$offset N", $$data); $offset += &Net::DNS::INT32SZ; my ($longitude) = unpack("\@$offset N", $$data); $offset += &Net::DNS::INT32SZ; my ($altitude) = unpack("\@$offset N", $$data); $offset += &Net::DNS::INT32SZ; $self->{"size"} = $size; $self->{"horiz_pre"} = $horiz_pre; $self->{"vert_pre"} = $vert_pre; $self->{"latitude"} = $latitude; $self->{"longitude"} = $longitude; $self->{"altitude"} = $altitude; } else { # What to do for unsupported versions? } } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && $string =~ /^ (\d+) \s+ # deg lat ((\d+) \s+)? # min lat (([\d.]+) \s+)? # sec lat (N|S) \s+ # hem lat (\d+) \s+ # deg lon ((\d+) \s+)? # min lon (([\d.]+) \s+)? # sec lon (E|W) \s+ # hem lon (-?[\d.]+) m? # altitude (\s+ ([\d.]+) m?)? # size (\s+ ([\d.]+) m?)? # horiz precision (\s+ ([\d.]+) m?)? # vert precision /ix) { # What to do for other versions? my $version = 0; my ($latdeg, $latmin, $latsec, $lathem) = ($1, $3, $5, $6); my ($londeg, $lonmin, $lonsec, $lonhem) = ($7, $9, $11, $12); my ($alt, $size, $horiz_pre, $vert_pre) = ($13, $15, $17, $19); $latmin = $default_min unless $latmin; $latsec = $default_sec unless $latsec; $lathem = uc($lathem); $lonmin = $default_min unless $lonmin; $lonsec = $default_sec unless $lonsec; $lonhem = uc($lonhem); $size = $default_size unless $size; $horiz_pre = $default_horiz_pre unless $horiz_pre; $vert_pre = $default_vert_pre unless $vert_pre; $self->{"version"} = $version; $self->{"size"} = $size * 100; $self->{"horiz_pre"} = $horiz_pre * 100; $self->{"vert_pre"} = $vert_pre * 100; $self->{"latitude"} = dms2latlon($latdeg, $latmin, $latsec, $lathem); $self->{"longitude"} = dms2latlon($londeg, $lonmin, $lonsec, $lonhem); $self->{"altitude"} = $alt * 100 + $reference_alt; } return bless $self, $class; } sub rdatastr { my $self = shift; my $rdatastr; if (exists $self->{"version"}) { if ($self->{"version"} == 0) { my $lat = $self->{"latitude"}; my $lon = $self->{"longitude"}; my $altitude = $self->{"altitude"}; my $size = $self->{"size"}; my $horiz_pre = $self->{"horiz_pre"}; my $vert_pre = $self->{"vert_pre"}; $altitude = ($altitude - $reference_alt) / 100; $size /= 100; $horiz_pre /= 100; $vert_pre /= 100; $rdatastr = latlon2dms($lat, "NS") . " " . latlon2dms($lon, "EW") . " " . sprintf("%.2fm", $altitude) . " " . sprintf("%.2fm", $size) . " " . sprintf("%.2fm", $horiz_pre) . " " . sprintf("%.2fm", $vert_pre); } else { $rdatastr = "; version " . $self->{"version"} . " not supported"; } } else { $rdatastr = "; no data"; } return $rdatastr; } sub rr_rdata { my $self = shift; my $rdata = ""; if (exists $self->{"version"}) { $rdata .= pack("C", $self->{"version"}); if ($self->{"version"} == 0) { $rdata .= pack("C3", precsize_valton($self->{"size"}), precsize_valton($self->{"horiz_pre"}), precsize_valton($self->{"vert_pre"})); $rdata .= pack("N3", $self->{"latitude"}, $self->{"longitude"}, $self->{"altitude"}); } else { # What to do for other versions? } } return $rdata; } sub precsize_ntoval { my $prec = shift; my $mantissa = (($prec >> 4) & 0x0f) % 10; my $exponent = ($prec & 0x0f) % 10; return $mantissa * $poweroften[$exponent]; } sub precsize_valton { my $val = shift; my $exponent = 0; while ($val > 10) { $val /= 10; ++$exponent; } return (int($val) << 4) | ($exponent & 0x0f); } sub latlon2dms { my ($rawmsec, $hems) = @_; # Tried to use modulus here, but Perl dumped core if # the value was >= 2**31. my ($abs, $deg, $min, $sec, $msec, $hem); $abs = abs($rawmsec - $reference_latlon); $deg = int($abs / $conv_deg); $abs -= $deg * $conv_deg; $min = int($abs / $conv_min); $abs -= $min * $conv_min; $sec = int($abs / $conv_sec); $abs -= $sec * $conv_sec; $msec = $abs; $hem = substr($hems, ($rawmsec >= $reference_latlon ? 0 : 1), 1); return sprintf("%d %02d %02d.%03d %s", $deg, $min, $sec, $msec, $hem); } sub dms2latlon { my ($deg, $min, $sec, $hem) = @_; my ($retval); $retval = ($deg * $conv_deg) + ($min * $conv_min) + ($sec * $conv_sec); $retval = -$retval if ($hem eq "S") || ($hem eq "W"); $retval += $reference_latlon; return $retval; } sub latlon { my $self = shift; my ($retlat, $retlon); if ($self->{"version"} == 0) { $retlat = latlon2deg($self->{"latitude"}); $retlon = latlon2deg($self->{"longitude"}); } else { $retlat = $retlon = undef; } return ($retlat, $retlon); } sub latlon2deg { my $rawmsec = shift; my $deg; $deg = ($rawmsec - $reference_latlon) / $conv_deg; return $deg; } 1; __END__ =head1 NAME Net::DNS::RR::LOC - DNS LOC resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Location (LOC) resource records. See RFC 1876 for details. =head1 METHODS =head2 version print "version = ", $rr->version, "\n"; Returns the version number of the representation; programs should always check this. C currently supports only version 0. =head2 size print "size = ", $rr->size, "\n"; Returns the diameter of a sphere enclosing the described entity, in centimeters. =head2 horiz_pre print "horiz_pre = ", $rr->horiz_pre, "\n"; Returns the horizontal precision of the data, in centimeters. =head2 vert_pre print "vert_pre = ", $rr->vert_pre, "\n"; Returns the vertical precision of the data, in centimeters. =head2 latitude print "latitude = ", $rr->latitude, "\n"; Returns the latitude of the center of the sphere described by the C method, in thousandths of a second of arc. 2**31 represents the equator; numbers above that are north latitude. =head2 longitude print "longitude = ", $rr->longitude, "\n"; Returns the longitude of the center of the sphere described by the C method, in thousandths of a second of arc. 2**31 represents the prime meridian; numbers above that are east longitude. =head2 latlon ($lat, $lon) = $rr->latlon; system("xearth", "-pos", "fixed $lat $lon"); Returns the latitude and longitude as floating-point degrees. Positive numbers represent north latitude or east longitude; negative numbers represent south latitude or west longitude. =head2 altitude print "altitude = ", $rr->altitude, "\n"; Returns the altitude of the center of the sphere described by the C method, in centimeters, from a base of 100,000m below the WGS 84 reference spheroid used by GPS. =head1 COPYRIGHT Copyright (c) 1997 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. Some of the code and documentation is based on RFC 1876 and on code contributed by Christopher Davis. =head1 SEE ALSO L, L, L, L, L, L, L, RFC 1876 =cut chainmail-0.2.4/perl/Net/DNS/RR/MR.pm0000644000175000017500000000273307172700760013711 00000000000000package Net::DNS::RR::MR; # $Id: MR.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my($newname) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"newname"} = $newname; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string) { $string =~ s/\.+$//; $self->{"newname"} = $string; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"newname"} ? "$self->{newname}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"newname"}) { $rdata .= $packet->dn_comp($self->{"newname"}, $offset); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::MR - DNS MR resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Mail Rename (MR) resource records. =head1 METHODS =head2 newname print "newname = ", $rr->newname, "\n"; Returns the RR's new name field. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.8 =cut chainmail-0.2.4/perl/Net/DNS/RR/TXT.pm0000644000175000017500000000305307172700760014046 00000000000000package Net::DNS::RR::TXT; # $Id: TXT.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($len) = unpack("\@$offset C", $$data); ++$offset; my $txtdata = substr($$data, $offset, $len); $offset += $len; $self->{"txtdata"} = $txtdata; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && $string =~ /^\s*["']?(.*?)["']?\s*$/) { $self->{"txtdata"} = $1; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"txtdata"} ? qq("$self->{txtdata}") : "; no data"; } sub rr_rdata { my $self = shift; my $rdata = ""; if (exists $self->{"txtdata"}) { $rdata .= pack("C", length $self->{"txtdata"}); $rdata .= $self->{"txtdata"}; } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::TXT - DNS TXT resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Text (TXT) resource records. =head1 METHODS =head2 txtdata print "txtdata = ", $rr->txtdata, "\n"; Returns the descriptive text. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.14 =cut chainmail-0.2.4/perl/Net/DNS/RR/RP.pm0000644000175000017500000000376707172700760013724 00000000000000package Net::DNS::RR::RP; # $Id: RP.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($mbox, $txtdname); ($mbox, $offset) = Net::DNS::Packet::dn_expand($data, $offset); ($txtdname, $offset) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"mbox"} = $mbox; $self->{"txtdname"} = $txtdname; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && ($string =~ /^(\S+)\s+(\S+)$/)) { $self->{"mbox"} = $1; $self->{"txtdname"} = $2; $self->{"mbox"} =~ s/\.+$//; $self->{"txtdname"} =~ s/\.+$//; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"mbox"} ? "$self->{mbox}. $self->{txtdname}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"mbox"}) { $rdata .= $packet->dn_comp($self->{"mbox"}, $offset); $rdata .= $packet->dn_comp($self->{"txtdname"}, $offset + length $rdata); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::RP - DNS RP resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Responsible Person (RP) resource records. =head1 METHODS =head2 mbox print "mbox = ", $rr->mbox, "\n"; Returns a domain name that specifies the mailbox for the responsible person. =head2 txtdname print "txtdname = ", $rr->txtdname, "\n"; Returns a domain name that specifies a TXT record containing further information about the responsible person. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1183 Section 2.2 =cut chainmail-0.2.4/perl/Net/DNS/RR/CNAME.pm0000644000175000017500000000275207172700760014217 00000000000000package Net::DNS::RR::CNAME; # $Id: CNAME.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my($cname) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"cname"} = $cname; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string) { $string =~ s/\.+$//; $self->{"cname"} = $string; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"cname"} && $self->{"cname"} ? "$self->{cname}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"cname"}) { $rdata = $packet->dn_comp($self->{"cname"}, $offset); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::CNAME - DNS CNAME resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Canonical Name (CNAME) resource records. =head1 METHODS =head2 cname print "cname = ", $rr->cname, "\n"; Returns the RR's canonical name. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.1 =cut chainmail-0.2.4/perl/Net/DNS/RR/NAPTR.pm0000644000175000017500000000726707172700760014266 00000000000000package Net::DNS::RR::NAPTR; # $Id: NAPTR.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS; use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($order) = unpack("\@$offset n", $$data); $offset += &Net::DNS::INT16SZ; my ($preference) = unpack("\@$offset n", $$data); $offset += &Net::DNS::INT16SZ; my ($len) = unpack("\@$offset C", $$data); ++$offset; my ($flags) = unpack("\@$offset a$len", $$data); $offset += $len; $len = unpack("\@$offset C", $$data); ++$offset; my ($service) = unpack("\@$offset a$len", $$data); $offset += $len; $len = unpack("\@$offset C", $$data); ++$offset; my ($regexp) = unpack("\@$offset a$len", $$data); $offset += $len; my($replacement) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"order"} = $order; $self->{"preference"} = $preference; $self->{"flags"} = $flags; $self->{"service"} = $service; $self->{"regexp"} = $regexp; $self->{"replacement"} = $replacement; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && $string =~ /^ (\d+) \s+ (\d+) \s+ ['"] (.*?) ['"] \s+ ['"] (.*?) ['"] \s+ ['"] (.*?) ['"] \s+ (\S+) $/x) { $self->{"order"} = $1; $self->{"preference"} = $2; $self->{"flags"} = $3; $self->{"service"} = $4; $self->{"regexp"} = $5; $self->{"replacement"} = $6; $self->{"replacement"} =~ s/\.+$//; } return bless $self, $class; } sub rdatastr { my $self = shift; my $rdatastr; if (exists $self->{"order"}) { $rdatastr = $self->{"order"} . ' ' . $self->{"preference"} . ' "' . $self->{"flags"} . '" "' . $self->{"service"} . '" "' . $self->{"regexp"} . '" ' . $self->{"replacement"} . '.'; } else { $rdatastr = "; no data"; } return $rdatastr; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"order"}) { $rdata .= pack("n2", $self->{"order"}, $self->{"preference"}); $rdata .= pack("C", length $self->{"flags"}); $rdata .= $self->{"flags"}; $rdata .= pack("C", length $self->{"service"}); $rdata .= $self->{"service"}; $rdata .= pack("C", length $self->{"regexp"}); $rdata .= $self->{"regexp"}; $rdata .= $packet->dn_comp($self->{"replacement"}, $offset + length $rdata); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::NAPTR - DNS NAPTR resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Naming Authority Pointer (NAPTR) resource records. =head1 METHODS =head2 order print "order = ", $rr->order, "\n"; Returns the order field. =head2 preference print "preference = ", $rr->preference, "\n"; Returns the preference field. =head2 flags print "flags = ", $rr->flags, "\n"; Returns the flags field. =head2 service print "service = ", $rr->service, "\n"; Returns the service field. =head2 regexp print "regexp = ", $rr->regexp, "\n"; Returns the regexp field. =head2 replacement print "replacement = ", $rr->replacement, "\n"; Returns the replacement field. =head1 COPYRIGHT Copyright (c) 1997 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. B is based on code contributed by Ryan Moats. =head1 SEE ALSO L, L, L, L, L, L, L, RFC 2168 =cut chainmail-0.2.4/perl/Net/DNS/RR/MX.pm0000644000175000017500000000363007172700760013714 00000000000000package Net::DNS::RR::MX; # $Id: MX.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS; use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($preference) = unpack("\@$offset n", $$data); $offset += &Net::DNS::INT16SZ; my ($exchange) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"preference"} = $preference; $self->{"exchange"} = $exchange; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && ($string =~ /^(\d+)\s+(\S+)$/)) { $self->{"preference"} = $1; $self->{"exchange"} = $2; $self->{"exchange"} =~ s/\.+$//;; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"preference"} ? "$self->{preference} $self->{exchange}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"preference"}) { $rdata .= pack("n", $self->{"preference"}); $rdata .= $packet->dn_comp($self->{"exchange"}, $offset + length $rdata); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::MX - DNS MX resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Mail Exchanger (MX) resource records. =head1 METHODS =head2 preference print "preference = ", $rr->preference, "\n"; Returns the preference for this mail exchange. =head2 exchange print "exchange = ", $rr->exchange, "\n"; Returns name of this mail exchange. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.9 =cut chainmail-0.2.4/perl/Net/DNS/RR/RT.pm0000644000175000017500000000367707172700760013730 00000000000000package Net::DNS::RR::RT; # $Id: RT.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS; use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($preference) = unpack("\@$offset n", $$data); $offset += &Net::DNS::INT16SZ; my ($intermediate) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"preference"} = $preference; $self->{"intermediate"} = $intermediate; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && ($string =~ /^(\d+)\s+(\S+)$/)) { $self->{"preference"} = $1; $self->{"intermediate"} = $2; $self->{"intermediate"} =~ s/\.+$//; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"preference"} ? "$self->{preference} $self->{intermediate}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"preference"}) { $rdata .= pack("n", $self->{"preference"}); $rdata .= $packet->dn_comp($self->{"intermediate"}, $offset + length $rdata); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::RT - DNS RT resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Route Through (RT) resource records. =head1 METHODS =head2 preference print "preference = ", $rr->preference, "\n"; Returns the preference for this route. =head2 intermediate print "intermediate = ", $rr->intermediate, "\n"; Returns the domain name of the intermediate host. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1183 Section 3.3 =cut chainmail-0.2.4/perl/Net/DNS/RR/PX.pm0000644000175000017500000000457007172700760013723 00000000000000package Net::DNS::RR::PX; # $Id: PX.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS; use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($preference, $map822, $mapx400); ($preference) = unpack("\@$offset n", $$data); $offset += &Net::DNS::INT16SZ; ($map822, $offset) = Net::DNS::Packet::dn_expand($data, $offset); ($mapx400, $offset) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"preference"} = $preference; $self->{"map822"} = $map822; $self->{"mapx400"} = $mapx400; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && ($string =~ /^(\d+)\s+(\S+)\s+(\S+)$/)) { $self->{"preference"} = $1; $self->{"map822"} = $2; $self->{"mapx400"} = $3; $self->{"map822"} =~ s/\.+$//;; $self->{"mapx400"} =~ s/\.+$//;; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"preference"} ? "$self->{preference} $self->{map822}. $self->{mapx400}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"preference"}) { $rdata .= pack("n", $self->{"preference"}); $rdata .= $packet->dn_comp($self->{"map822"}, $offset + length $rdata); $rdata .= $packet->dn_comp($self->{"mapx400"}, $offset + length $rdata); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::PX - DNS PX resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS X.400 Mail Mapping Information (PX) resource records. =head1 METHODS =head2 preference print "preference = ", $rr->preference, "\n"; Returns the preference given to this RR. =head2 map822 print "map822 = ", $rr->map822, "\n"; Returns the RFC822 part of the RFC1327 mapping information. =head2 mapx400 print "mapx400 = ", $rr->mapx400, "\n"; Returns the X.400 part of the RFC1327 mapping information. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1664 Section 4, RFC 1327 =cut chainmail-0.2.4/perl/Net/DNS/RR/MG.pm0000644000175000017500000000273107172700760013674 00000000000000package Net::DNS::RR::MG; # $Id: MG.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($mgmname) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"mgmname"} = $mgmname; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string) { $string =~ s/\.+$//; $self->{"mgmname"} = $string; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"mgmname"} ? "$self->{mgmname}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"mgmname"}) { $rdata .= $packet->dn_comp($self->{"mgmname"}, $offset); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::MG - DNS MG resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Mail Group (MG) resource records. =head1 METHODS =head2 mgmname print "mgmname = ", $rr->mgmname, "\n"; Returns the RR's mailbox field. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.6 =cut chainmail-0.2.4/perl/Net/DNS/RR/HINFO.pm0000644000175000017500000000360507172700760014235 00000000000000package Net::DNS::RR::HINFO; # $Id: HINFO.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($cpu, $os, $len); ($len) = unpack("\@$offset C", $$data); ++$offset; $cpu = substr($$data, $offset, $len); $offset += $len; ($len) = unpack("\@$offset C", $$data); ++$offset; $os = substr($$data, $offset, $len); $offset += $len; $self->{"cpu"} = $cpu; $self->{"os"} = $os; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && $string =~ /^["'](.*?)["']\s+["'](.*?)["']$/) { $self->{"cpu"} = $1; $self->{"os"} = $2; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"cpu"} ? qq("$self->{cpu}" "$self->{os}") : "; no data"; } sub rr_rdata { my $self = shift; my $rdata = ""; if (exists $self->{"cpu"}) { $rdata .= pack("C", length $self->{"cpu"}); $rdata .= $self->{"cpu"}; $rdata .= pack("C", length $self->{"os"}); $rdata .= $self->{"os"}; } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::HINFO - DNS HINFO resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Host Information (HINFO) resource records. =head1 METHODS =head2 cpu print "cpu = ", $rr->cpu, "\n"; Returns the CPU type for this RR. =head2 os print "os = ", $rr->os, "\n"; Returns the operating system type for this RR. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.2 =cut chainmail-0.2.4/perl/Net/DNS/RR/SRV.pm0000644000175000017500000000451507172700760014045 00000000000000package Net::DNS::RR::SRV; # $Id: SRV.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS; use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($priority, $weight, $port) = unpack("\@$offset n3", $$data); $offset += 3 * &Net::DNS::INT16SZ; my($target) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"priority"} = $priority; $self->{"weight"} = $weight; $self->{"port"} = $port; $self->{"target"} = $target; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && ($string =~ /^(\d+)\s+(\d+)\s+(\d+)\s+(\S+)$/)) { $self->{"priority"} = $1; $self->{"weight"} = $2; $self->{"port"} = $3; $self->{"target"} = $4; $self->{"target"} =~ s/\.+$//; } return bless $self, $class; } sub rdatastr { my $self = shift; my $rdatastr; if (exists $self->{"priority"}) { $rdatastr = "$self->{priority} $self->{weight} " . "$self->{port} $self->{target}."; } else { $rdatastr = "; no data"; } return $rdatastr; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"priority"}) { $rdata .= pack("n3", $self->{"priority"}, $self->{"weight"}, $self->{"port"}); $rdata .= $packet->dn_comp($self->{"target"}, $offset + length $rdata); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::SRV - DNS SRV resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Service (SRV) resource records. =head1 METHODS =head2 priority print "priority = ", $rr->priority, "\n"; Returns the priority for this target host. =head2 weight print "weight = ", $rr->weight, "\n"; Returns the weight for this target host. =head2 port print "port = ", $rr->port, "\n"; Returns the port on this target host for the service. =head2 target print "target = ", $rr->target, "\n"; Returns the target host. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 2052 =cut chainmail-0.2.4/perl/Net/DNS/RR/X25.pm0000644000175000017500000000277007172700760013752 00000000000000package Net::DNS::RR::X25; # $Id: X25.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($len) = unpack("\@$offset C", $$data); ++$offset; my $psdn = substr($$data, $offset, $len); $offset += $len; $self->{"psdn"} = $psdn; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && $string =~ /^\s*["']?(.*?)["']?\s*$/) { $self->{"psdn"} = $1; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"psdn"} ? qq("$self->{psdn}") : "; no data"; } sub rr_rdata { my $self = shift; my $rdata = ""; if (exists $self->{"psdn"}) { $rdata .= pack("C", length $self->{"psdn"}); $rdata .= $self->{"psdn"}; } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::X25 - DNS X25 resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS X25 resource records. =head1 METHODS =head2 psdn print "psdn = ", $rr->psdn, "\n"; Returns the PSDN address. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1183 Section 3.1 =cut chainmail-0.2.4/perl/Net/DNS/RR/AFSDB.pm0000644000175000017500000000365607172700760014217 00000000000000package Net::DNS::RR::AFSDB; # $Id: AFSDB.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS; use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($subtype) = unpack("\@$offset n", $$data); $offset += &Net::DNS::INT16SZ; my($hostname) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"subtype"} = $subtype; $self->{"hostname"} = $hostname; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && ($string =~ /^(\d+)\s+(\S+)$/)) { $self->{"subtype"} = $1; $self->{"hostname"} = $2; $self->{"hostname"} =~ s/\.+$//;; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"subtype"} ? "$self->{subtype} $self->{hostname}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"subtype"}) { $rdata .= pack("n", $self->{"subtype"}); $rdata .= $packet->dn_comp($self->{"hostname"}, $offset + length $rdata); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::AFSDB - DNS AFSDB resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS AFS Data Base (AFSDB) resource records. =head1 METHODS =head2 subtype print "subtype = ", $rr->subtype, "\n"; Returns the RR's subtype field. Use of the subtype field is documented in RFC 1183. =head2 hostname print "hostname = ", $rr->hostname, "\n"; Returns the RR's hostname field. See RFC 1183. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1183 Section 1 =cut chainmail-0.2.4/perl/Net/DNS/RR/NS.pm0000644000175000017500000000274607172700760013717 00000000000000package Net::DNS::RR::NS; # $Id: NS.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my($nsdname) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"nsdname"} = $nsdname; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string) { $string =~ s/\.+$//; $self->{"nsdname"} = $string; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"nsdname"} ? "$self->{nsdname}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"nsdname"}) { $rdata .= $packet->dn_comp($self->{"nsdname"}, $offset); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::NS - DNS NS resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Name Server (NS) resource records. =head1 METHODS =head2 nsdname print "nsdname = ", $rr->nsdname, "\n"; Returns the domain name of the nameserver. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.11 =cut chainmail-0.2.4/perl/Net/DNS/RR/A.pm0000644000175000017500000000312707172700760013551 00000000000000package Net::DNS::RR::A; # $Id: A.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Socket; use Net::DNS; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my $addr = inet_ntoa(substr($$data, $offset, 4)); $self->{"address"} = $addr; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && ($string =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)\s*$/) && ($1 >= 0) && ($1 <= 255) && ($2 >= 0) && ($2 <= 255) && ($3 >= 0) && ($3 <= 255) && ($4 >= 0) && ($4 <= 255) ) { $self->{"address"} = "$1.$2.$3.$4"; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"address"} && $self->{"address"} ? $self->{"address"} : "; no data"; } sub rr_rdata { my $self = shift; my $rdata = exists $self->{"address"} ? inet_aton($self->{"address"}) : ""; return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::A - DNS A resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Address (A) resource records. =head1 METHODS =head2 address print "address = ", $rr->address, "\n"; Returns the RR's address field. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.4.1 =cut chainmail-0.2.4/perl/Net/DNS/RR/NIMLOC.pm0000644000175000017500000000201207172700760014342 00000000000000package Net::DNS::RR::NIMLOC; # $Id: NIMLOC.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; return bless $self, $class; } 1; __END__ =head1 NAME Net::DNS::RR::NIMLOC - DNS NIMLOC resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Nimrod Locator (NIMLOC) resource records. =head1 METHODS =head2 rdlength print "rdlength = ", $rr->rdlength, "\n"; Returns the length of the record's data section. =head2 rdata $rdata = $rr->rdata; Returns the record's data section as binary data. =head1 COPYRIGHT Copyright (c) 1997 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, draft-ietf-nimrod-dns-I.txt =cut chainmail-0.2.4/perl/Net/DNS/RR/SOA.pm0000644000175000017500000000705707172700760014021 00000000000000package Net::DNS::RR::SOA; # $Id: SOA.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($mname, $rname); ($mname, $offset) = Net::DNS::Packet::dn_expand($data, $offset); ($rname, $offset) = Net::DNS::Packet::dn_expand($data, $offset); my ($serial, $refresh, $retry, $expire, $minimum) = unpack("\@$offset N5", $$data); $self->{"mname"} = $mname; $self->{"rname"} = $rname; $self->{"serial"} = $serial; $self->{"refresh"} = $refresh; $self->{"retry"} = $retry; $self->{"expire"} = $expire; $self->{"minimum"} = $minimum; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string) { $string =~ tr/()//d; $string =~ s/;.*$//mg; my ($mname, $rname, $serial, $refresh, $retry, $expire, $minimum) = $string =~ /(\S+)/g; $mname =~ s/\.+$//; $rname =~ s/\.+$//; $self->{"mname"} = $mname; $self->{"rname"} = $rname; $self->{"serial"} = $serial; $self->{"refresh"} = $refresh; $self->{"retry"} = $retry; $self->{"expire"} = $expire; $self->{"minimum"} = $minimum; } return bless $self, $class; } sub rdatastr { my $self = shift; my $rdatastr; if (exists $self->{"mname"}) { $rdatastr = "$self->{mname}. $self->{rname}. (\n"; $rdatastr .= "\t" x 5 . "$self->{serial}\t; Serial\n"; $rdatastr .= "\t" x 5 . "$self->{refresh}\t; Refresh\n"; $rdatastr .= "\t" x 5 . "$self->{retry}\t; Retry\n"; $rdatastr .= "\t" x 5 . "$self->{expire}\t; Expire\n"; $rdatastr .= "\t" x 5 . "$self->{minimum} )\t; Minimum TTL"; } else { $rdatastr = "; no data"; } return $rdatastr; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; # Assume that if one field exists, they all exist. Script will # print a warning otherwise. if (exists $self->{"mname"}) { $rdata .= $packet->dn_comp($self->{"mname"}, $offset); $rdata .= $packet->dn_comp($self->{"rname"}, $offset + length $rdata); $rdata .= pack("N5", $self->{"serial"}, $self->{"refresh"}, $self->{"retry"}, $self->{"expire"}, $self->{"minimum"}); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::SOA - DNS SOA resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Start of Authority (SOA) resource records. =head1 METHODS =head2 mname print "mname = ", $rr->mname, "\n"; Returns the domain name of the original or primary nameserver for this zone. =head2 rname print "rname = ", $rr->rname, "\n"; Returns a domain name that specifies the mailbox for the person responsible for this zone. =head2 serial print "serial = ", $rr->serial, "\n"; Returns the zone's serial number. =head2 refresh print "refresh = ", $rr->refresh, "\n"; Returns the zone's refresh interval. =head2 retry print "retry = ", $rr->retry, "\n"; Returns the zone's retry interval. =head2 expire print "expire = ", $rr->expire, "\n"; Returns the zone's expire interval. =head2 minimum print "minimum = ", $rr->minimum, "\n"; Returns the minimum (default) TTL for records in this zone. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.13 =cut chainmail-0.2.4/perl/Net/DNS/RR/AAAA.pm0000644000175000017500000000464507172700760014062 00000000000000package Net::DNS::RR::AAAA; # $Id: AAAA.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my @addr = unpack("\@$offset n8", $$data); $self->{"address"} = sprintf("%x:%x:%x:%x:%x:%x:%x:%x", @addr); } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string) { my @addr; # I think this is correct, per RFC 1884 Sections 2.2 & 2.4.4. if ($string =~ /^(.*):(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { my ($front, $a, $b, $c, $d) = ($1, $2, $3, $4, $5); $string = $front . sprintf(":%x:%x", ($a << 8 | $b), ($c << 8 | $d)); } if ($string =~ /^(.*)::(.*)$/) { my ($front, $back) = ($1, $2); my @front = split(/:/, $front); my @back = split(/:/, $back); my $fill = 8 - (@front ? $#front + 1 : 0) - (@back ? $#back + 1 : 0); my @middle = (0) x $fill; @addr = (@front, @middle, @back); } else { @addr = split(/:/, $string); if (@addr < 8) { @addr = ((0) x (8 - @addr), @addr); } } $self->{"address"} = sprintf("%x:%x:%x:%x:%x:%x:%x:%x", map { hex $_ } @addr); } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"address"} && $self->{"address"} ? $self->{"address"} : "; no data"; } sub rr_rdata { my $self = shift; my $rdata = ""; if (exists $self->{"address"}) { my @addr = split(/:/, $self->{"address"}); $rdata .= pack("n8", map { hex $_ } @addr); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::AAAA - DNS AAAA resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS IPv6 Address (AAAA) resource records. =head1 METHODS =head2 address print "address = ", $rr->address, "\n"; Returns the RR's address field. =head1 BUGS The C method returns only the preferred method of address representation ("x:x:x:x:x:x:x:x", as documented in RFC 1884, Section 2.2, Para 1). =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1886 Section 2, RFC 1884 Sections 2.2 & 2.4.4 =cut chainmail-0.2.4/perl/Net/DNS/RR/ISDN.pm0000644000175000017500000000412007172700760014120 00000000000000package Net::DNS::RR::ISDN; # $Id: ISDN.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my ($address, $sa, $len); ($len) = unpack("\@$offset C", $$data); ++$offset; $address = substr($$data, $offset, $len); $offset += $len; if ($len + 1 < $self->{"rdlength"}) { ($len) = unpack("\@$offset C", $$data); ++$offset; $sa = substr($$data, $offset, $len); $offset += $len; } else { $sa = ""; } $self->{"address"} = $address; $self->{"sa"} = $sa; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string && $string =~ /^['"](.*?)['"]/) { $self->{"address"} = $1; my $rest = $'; if ($rest =~ /^\s+['"](.*?)['"]$/) { $self->{"sa"} = $1; } else { $self->{"sa"} = ""; } } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"address"} ? qq("$self->{address}" "$self->{sa}") : "; no data"; } sub rr_rdata { my $self = shift; my $rdata = ""; if (exists $self->{"address"}) { $rdata .= pack("C", length $self->{"address"}); $rdata .= $self->{"address"}; if ($self->{"sa"}) { $rdata .= pack("C", length $self->{"sa"}); $rdata .= $self->{"sa"}; } } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::ISDN - DNS ISDN resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS ISDN resource records. =head1 METHODS =head2 address print "address = ", $rr->address, "\n"; Returns the RR's address field. =head2 sa print "subaddress = ", $rr->sa, "\n"; Returns the RR's subaddress field. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1183 Section 3.2 =cut chainmail-0.2.4/perl/Net/DNS/RR/MB.pm0000644000175000017500000000277307172700760013675 00000000000000package Net::DNS::RR::MB; # $Id: MB.pm,v 1.1 2000/10/16 22:32:16 john Exp $ use strict; use vars qw(@ISA); use Net::DNS::Packet; @ISA = qw(Net::DNS::RR); sub new { my ($class, $self, $data, $offset) = @_; if ($self->{"rdlength"} > 0) { my($madname) = Net::DNS::Packet::dn_expand($data, $offset); $self->{"madname"} = $madname; } return bless $self, $class; } sub new_from_string { my ($class, $self, $string) = @_; if ($string) { $string =~ s/\.+$//; $self->{"madname"} = $string; } return bless $self, $class; } sub rdatastr { my $self = shift; return exists $self->{"madname"} ? "$self->{madname}." : "; no data"; } sub rr_rdata { my ($self, $packet, $offset) = @_; my $rdata = ""; if (exists $self->{"madname"}) { $rdata .= $packet->dn_comp($self->{"madname"}, $offset); } return $rdata; } 1; __END__ =head1 NAME Net::DNS::RR::MB - DNS MB resource record =head1 SYNOPSIS C; =head1 DESCRIPTION Class for DNS Mailbox (MB) resource records. =head1 METHODS =head2 madname print "madname = ", $rr->madname, "\n"; Returns the domain name of the host which has the specified mailbox. =head1 COPYRIGHT Copyright (c) 1997 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, RFC 1035 Section 3.3.3 =cut chainmail-0.2.4/perl/Net/DNS/Resolver.pm0000644000175000017500000006635207172700751014660 00000000000000package Net::DNS::Resolver; =head1 NAME Net::DNS::Resolver - DNS resolver class =head1 SYNOPSIS C =head1 DESCRIPTION Instances of the C 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. Resolver configuration is read from the following files, in the order indicated: /etc/resolv.conf $HOME/.resolv.conf ./.resolv.conf The following keywords are recognized in resolver configuration files: =over 4 =item B The default domain. =item B A space-separated list of domains to put in the search list. =item B A space-separated list of nameservers to query. =back Files except for F must be owned by the effective userid running the program or they won't be read. In addition, several environment variables can also contain configuration information; see L. =head1 METHODS =cut use strict; use vars qw( $VERSION $resolv_conf $dotfile @confpath %default %global $AUTOLOAD ); use Carp; use Socket; use IO::Socket; use IO::Select; use Net::DNS; use Net::DNS::Packet; # $Id: Resolver.pm,v 1.1 2000/10/16 22:32:09 john Exp $ $VERSION = $Net::DNS::VERSION; #------------------------------------------------------------------------------ # Configurable defaults. #------------------------------------------------------------------------------ $resolv_conf = "/etc/resolv.conf"; $dotfile = ".resolv.conf"; push(@confpath, $ENV{"HOME"}) if exists $ENV{"HOME"}; push(@confpath, "."); %default = ( "nameservers" => ["127.0.0.1"], "port" => "53", "domain" => "", "searchlist" => [], "retrans" => 5, "retry" => 4, "usevc" => 0, "stayopen" => 0, "igntc" => 0, "recurse" => 1, "defnames" => 1, "dnsrch" => 1, "debug" => 0, "errorstring" => "unknown error or no error", "answerfrom" => "", "answersize" => 0, "tcp_timeout" => 120, ); %global = ( "id" => int(rand(65535)), ); =head2 new $res = new Net::DNS::Resolver; Creates a new DNS resolver object. =cut sub new { my $class = shift; my $self = { %default }; return bless $self, $class; } # # Some people have reported that Net::DNS dies because AUTOLOAD picks up # calls to DESTROY. # sub DESTROY {} sub res_init { read_config($resolv_conf) if (-f $resolv_conf) and (-r $resolv_conf); my $dir; foreach $dir (@confpath) { my $file = "$dir/$dotfile"; read_config($file) if (-f $file) and (-r $file) and (-o $file); } read_env(); if (!$default{"domain"} && @{$default{"searchlist"}}) { $default{"domain"} = $default{"searchlist"}[0]; } elsif (!@{$default{"searchlist"}} && $default{"domain"}) { $default{"searchlist"} = [ $default{"domain"} ]; } } sub read_config { my $file = shift; my @ns; my @searchlist; local *FILE; open(FILE, $file) or Carp::confess "can't open $file: $!"; while () { s/\s*[;#].*//; next if /^\s*$/; SWITCH: { /^\s*domain\s+(\S+)/ && do { $default{"domain"} = $1; last SWITCH; }; /^\s*search\s+(.*)/ && do { push(@searchlist, split(" ", $1)); last SWITCH; }; /^\s*nameserver\s+(.*)/ && do { my $ns; foreach $ns (split(" ", $1)) { $ns = "0.0.0.0" if $ns eq "0"; push @ns, $ns; } last SWITCH; }; } } close FILE; $default{"nameservers"} = [ @ns ] if @ns; $default{"searchlist"} = [ @searchlist ] if @searchlist; } sub read_env { $default{"nameservers"} = [ split(" ", $ENV{"RES_NAMESERVERS"}) ] if exists $ENV{"RES_NAMESERVERS"}; $default{"searchlist"} = [ split(" ", $ENV{"RES_SEARCHLIST"}) ] if exists $ENV{"RES_SEARCHLIST"}; $default{"domain"} = $ENV{"LOCALDOMAIN"} if exists $ENV{"LOCALDOMAIN"}; if (exists $ENV{"RES_OPTIONS"}) { my @env = split(" ", $ENV{"RES_OPTIONS"}); foreach (@env) { my ($name, $val) = split(/:/); $val = 1 unless defined $val; $default{$name} = $val if exists $default{$name}; } } } =head2 print $res->print; Prints the resolver state on the standard output. =cut sub print { my $self = shift; print $self->string; } =head2 string print $res->string; Returns a string representation of the resolver state. =cut sub string { my $self = shift; return ";; RESOLVER state:\n" . ";; domain = $self->{domain}\n" . ";; searchlist = @{$self->{searchlist}}\n" . ";; nameservers = @{$self->{nameservers}}\n" . ";; port = $self->{port}\n" . ";; tcp_timeout = " . (defined $self->{"tcp_timeout"} ? $self->{"tcp_timeout"} : "indefinite") . "\n" . ";; retrans = $self->{retrans} " . "retry = $self->{retry}\n" . ";; usevc = $self->{usevc} " . "stayopen = $self->{stayopen} " . "igntc = $self->{igntc}\n" . ";; defnames = $self->{defnames} " . "dnsrch = $self->{dnsrch}\n" . ";; recurse = $self->{recurse} " . "debug = $self->{debug}\n"; } sub nextid { return $global{"id"}++; } =head2 searchlist @searchlist = $res->searchlist; $res->searchlist("foo.com", "bar.com", "baz.org"); Gets or sets the resolver search list. =cut sub searchlist { my $self = shift; $self->{"searchlist"} = [ @_ ] if @_; return @{$self->{"searchlist"}}; } =head2 nameservers @nameservers = $res->nameservers; $res->nameservers("192.168.1.1", "192.168.2.2", "192.168.3.3"); Gets or sets the nameservers to be queried. =head2 port print "sending queries to port ", $res->port, "\n"; $res->port(9732); Gets or sets the port to which we send queries. This can be useful for testing a nameserver running on a non-standard port. The default is port 53. =cut sub nameservers { my $self = shift; my $defres = new Net::DNS::Resolver; if (@_) { my @a; my $ns; foreach $ns (@_) { #if ($ns =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { if ($ns =~ /^\d+(\.\d+){0,3}$/) { push @a, ($ns eq "0") ? "0.0.0.0" : $ns; } else { my @names; if ($ns !~ /\./) { if (defined $defres->searchlist) { @names = map { $ns . "." . $_ } $defres->searchlist; } elsif (defined $defres->domain) { @names = ($ns . "." . $defres->domain); } } else { @names = ($ns); } my $packet = $defres->search($ns); $self->errorstring($defres->errorstring); if (defined($packet)) { push @a, cname_addr([@names], $packet); } } } $self->{"nameservers"} = [ @a ]; } return @{$self->{"nameservers"}}; } sub cname_addr { my $names = shift; my $packet = shift; my $rr; my @addr; my @names = @{$names}; foreach $rr ($packet->answer) { next unless grep {$rr->name} @names; if ($rr->type eq "CNAME") { @names = ($rr->cname); } elsif ($rr->type eq "A") { push @addr, $rr->address; } } return @addr; } =head2 search $packet = $res->search("mailhost"); $packet = $res->search("mailhost.foo.com"); $packet = $res->search("192.168.1.1"); $packet = $res->search("foo.com", "MX"); $packet = $res->search("user.passwd.foo.com", "TXT", "HS"); Performs a DNS query for the given name, applying the searchlist if appropriate. The search algorithm is as follows: =over 4 =item 1. If the name contains at least one dot, try it as is. =item 2. If the name doesn't end in a dot then append each item in the search list to the name. This is only done if B is true. =item 3. If the name doesn't contain any dots, try it as is. =back The record type and class can be omitted; they default to A and IN. If the name looks like an IP address (4 dot-separated numbers), then an appropriate PTR query will be performed. Returns a C object, or C if no answers were found. =cut sub search { my $self = shift; my ($name, $type, $class) = @_; my $ans; $type = "A" unless defined($type); $class = "IN" unless defined($class); # 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"; } # If the name contains at least one dot then try it as is first. if (index($name, ".") >= 0) { print ";; search($name, $type, $class)\n" if $self->{"debug"}; $ans = $self->query($name, $type, $class); return $ans if (defined $ans) && ($ans->header->ancount > 0); } # If the name doesn't end in a dot then apply the search list. my $domain; if (($name !~ /\.$/) && $self->{"dnsrch"}) { foreach $domain (@{$self->{"searchlist"}}) { my $newname = "$name.$domain"; print ";; search($newname, $type, $class)\n" if $self->{"debug"}; $ans = $self->query($newname, $type, $class); return $ans if (defined $ans) && ($ans->header->ancount > 0); } } # Finally, if the name has no dots then try it as is. if (index($name, ".") < 0) { print ";; search($name, $type, $class)\n" if $self->{"debug"}; $ans = $self->query("$name.", $type, $class); return $ans if (defined $ans) && ($ans->header->ancount > 0); } # No answer was found. return undef; } =head2 query $packet = $res->query("mailhost"); $packet = $res->query("mailhost.foo.com"); $packet = $res->query("192.168.1.1"); $packet = $res->query("foo.com", "MX"); $packet = $res->query("user.passwd.foo.com", "TXT", "HS"); Performs a DNS query for the given name; the search list is not applied. If the name doesn't contain any dots and B is true then the default domain will be appended. The record type and class can be omitted; they default to A and IN. If the name looks like an IP address (4 dot-separated numbers), then an appropriate PTR query will be performed. Returns a C object, or C if no answers were found. =cut sub query { my $self = shift; my ($name, $type, $class) = @_; $type = "A" unless defined($type); $class = "IN" unless defined($class); # If the name doesn't contain any dots then append the default domain. if ((index($name, ".") < 0) && $self->{"defnames"}) { $name .= ".$self->{domain}"; } # 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"; } print ";; query($name, $type, $class)\n" if $self->{"debug"}; my $packet = new Net::DNS::Packet($name, $type, $class); my $ans = $self->send($packet); return (defined($ans) && ($ans->header->ancount > 0)) ? $ans : undef; } =head2 send $packet = $res->send($packet_object); $packet = $res->send("mailhost.foo.com"); $packet = $res->send("foo.com", "MX"); $packet = $res->send("user.passwd.foo.com", "TXT", "HS"); 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 C 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 (4 dot-separated numbers), then an appropriate PTR query will be performed. Returns a C object whether there were any answers or not. Use C<$packet>->C
->C or C<$packet>->C to find out if there were any records in the answer section. Returns C if there was an error. =cut sub send { my $self = shift; my $packet = $self->make_query_packet(@_); my $packet_data = $packet->data; my $ans; if ($self->{"usevc"} || length $packet_data > &Net::DNS::PACKETSZ) { $ans = $self->send_tcp($packet, $packet_data); } else { $ans = $self->send_udp($packet, $packet_data); if ($ans && $ans->header->tc && !$self->{"igntc"}) { print ";;\n;; packet truncated: retrying using TCP\n" if $self->{"debug"}; $ans = $self->send_tcp($packet, $packet_data); } } return $ans; } sub send_tcp { my ($self, $packet, $packet_data) = @_; unless (@{$self->{"nameservers"}}) { $self->{"errorstring"} = "no nameservers"; print ";; ERROR: no nameservers\n" if $self->{"debug"}; return; } $self->errorstring($default{"errorstring"}); my $timeout = $self->{"tcp_timeout"}; my $ns; foreach $ns (@{$self->{"nameservers"}}) { # 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; print ";; send_tcp($ns:", $self->{"port"}, ")\n" if $self->{"debug"}; my $sock = IO::Socket::INET->new(PeerAddr => $ns, PeerPort => $self->{"port"}, Proto => "tcp", Timeout => $timeout); $^W = $old_wflag; unless ($sock) { $self->errorstring("connection failed"); print ";; ERROR: connection failed\n" if $self->{"debug"}; next; } my $lenmsg = pack("n", length($packet_data)); print ";; sending ", length($packet_data), " bytes\n" if $self->{"debug"}; unless ($sock->send($lenmsg)) { $self->errorstring($!); print ";; ERROR: length send failed: $!\n" if $self->{"debug"}; next; } unless ($sock->send($packet_data)) { $self->errorstring($!); print ";; ERROR: data send failed: $!\n" if $self->{"debug"}; next; } my $sel = new IO::Select($sock); if ($sel->can_read($timeout)) { my $buf = read_tcp($sock, &Net::DNS::INT16SZ); next unless length($buf); my ($len) = unpack("n", $buf); next unless $len; unless ($sel->can_read($timeout)) { $self->errorstring("timeout"); print ";; TIMEOUT\n" if $self->{"debug"}; next; } $buf = read_tcp($sock, $len); $self->answerfrom($sock->peerhost); $self->answersize(length $buf); print ";; received ", length($buf), " bytes\n" if $self->{"debug"}; unless (length($buf) == $len) { $self->errorstring("expected $len bytes, " . "received " . length($buf)); next; } my ($ans, $err) = new Net::DNS::Packet(\$buf, $self->{"debug"}); if (defined $ans) { $self->errorstring($ans->header->rcode); $ans->answerfrom($self->answerfrom); $ans->answersize($self->answersize); } elsif (defined $err) { $self->errorstring($err); } return $ans; } else { $self->errorstring("timeout"); next; } } return; } sub send_udp { my ($self, $packet, $packet_data) = @_; my $retrans = $self->{"retrans"}; my $timeout = $retrans; my ($ns, @ns); my ($i, $j); $self->errorstring($default{"errorstring"}); # 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; @ns = grep { $_ } map { IO::Socket::INET->new(PeerAddr => $_, PeerPort => $self->{"port"}, Proto => "udp"); } @{$self->{"nameservers"}}; $^W = $old_wflag; unless (@ns) { $self->errorstring("no nameservers"); return; } my $sel = new IO::Select(@ns); # Perform each round of retries. for ($i = 0; $i < $self->{"retry"}; ++$i, $retrans *= 2, $timeout = int($retrans / ($#ns + 1))) { $timeout = 1 if ($timeout < 1); # Try each nameserver. foreach $ns ($sel->handles) { print ";; send_udp(", $ns->peerhost, ":", $ns->peerport, ")\n" if $self->{"debug"}; unless ($ns->send($packet_data)) { print ";; send error: $!\n" if $self->{"debug"}; $sel->remove($ns); next; } my @ready = $sel->can_read($timeout); my $ready; foreach $ready (@ready) { my $buf = ""; if ($ready->recv($buf, &Net::DNS::PACKETSZ)) { $self->answerfrom($ready->peerhost); $self->answersize(length $buf); print ";; answer from ", $ready->peerhost, ":", $ready->peerport, " : ", length($buf), " bytes\n" if $self->{"debug"}; my ($ans, $err) = new Net::DNS::Packet(\$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"}; $sel->remove($ready); return unless $sel->handles; } } } } $self->errorstring("query timed out"); return; } =head2 bgsend $socket = $res->bgsend($packet_object); $socket = $res->bgsend("mailhost.foo.com"); $socket = $res->bgsend("foo.com", "MX"); $socket = $res->bgsend("user.passwd.foo.com", "TXT", "HS"); Performs a background DNS query for the given name, i.e., sends a query packet to the first nameserver listed in C<$res>->C and returns immediately without waiting for a response. The program can then perform other tasks while waiting for a response from the nameserver. The argument list can be either a C 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 (4 dot-separated numbers), then an appropriate PTR query will be performed. Returns an C object. The program must determine when the socket is ready for reading and call C<$res>->C to get the response packet. You can use C<$res>->C or C to find out if the socket is ready before reading it. =cut sub bgsend { my $self = shift; unless (@{$self->{"nameservers"}}) { $self->errorstring("no nameservers"); return; } $self->errorstring($default{"errorstring"}); my $packet = $self->make_query_packet(@_); my $ns = $self->{"nameservers"}->[0]; my $sock = IO::Socket::INET->new(PeerAddr => $ns, PeerPort => $self->{"port"}, Proto => "udp"); unless ($sock) { $self->errorstring("couldn't get socket"); return; } print ";; bgsend(", $ns->peerhost, ":", $ns->peerport, ")\n" if $self->{"debug"}; unless ($sock->send($packet->data)) { my $err = $!; print ";; send ERROR($ns): $err\n"; $self->errorstring($err); return; } return $sock; } =head2 bgread $packet = $res->bgread($socket); undef $socket; Reads the answer from a background query (see L). The argument is an C object returned by C. Returns a C object or C on error. The programmer should close or destroy the socket object after reading it. =cut sub bgread { my $self = shift; my $sock = shift; my $buf = ""; if ($sock->recv($buf, &Net::DNS::PACKETSZ)) { print ";; answer from ", $sock->peerhost, ":", $sock->peerport, " : ", length($buf), " bytes\n" if $self->{"debug"}; my ($ans, $err) = new Net::DNS::Packet(\$buf, $self->{"debug"}); if (defined $ans) { $self->errorstring($ans->header->rcode); } elsif (defined $err) { $self->errorstring($err); } return $ans; } else { $self->errorstring($!); return; } } =head2 bgisready $socket = $res->bgsend("foo.bar.com"); until ($res->bgisready($socket)) { # do some other processing } $packet = $res->bgread($socket); $socket = undef; Determines whether a socket is ready for reading. The argument is an C object returned by C<$res>->C. Returns true if the socket is ready, false if not. =cut sub bgisready { my $self = shift; my $sel = new IO::Select(@_); my @ready = $sel->can_read(0.0); return @ready > 0; } sub make_query_packet { my $self = shift; my $packet; if (ref($_[0]) eq "Net::DNS::Packet") { $packet = shift; } else { my ($name, $type, $class) = @_; $type = "A" unless defined($type); $class = "IN" unless defined($class); # 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 = new Net::DNS::Packet($name, $type, $class); } $packet->header->rd($self->{"recurse"}); return $packet; } =head2 axfr @zone = $res->axfr; @zone = $res->axfr("foo.com"); @zone = $res->axfr("passwd.foo.com", "HS"); Performs a zone transfer from the first nameserver listed in C. If the zone is omitted, it defaults to the first zone listed in the resolver's search list. If the class is omitted, it defaults to IN. Returns a list of C objects, or C if the zone transfer failed. The redundant SOA record that terminates the zone transfer is not returned to the caller. Here's an example that uses a timeout: $res->tcp_timeout(10); @zone = $res->axfr("foo.com"); if (@zone) { foreach $rr (@zone) { $rr->print; } } else { print "Zone transfer failed: ", $res->errorstring, "\n"; } =cut sub axfr { 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 = new Net::DNS::Packet($dname, "AXFR", $class); my $data = $packet->data; my $ns = $self->{"nameservers"}->[0]; print ";; axfr nameserver = $ns\n" if $self->{"debug"}; # 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; my $sock = new IO::Socket::INET(PeerAddr => $ns, PeerPort => $self->{"port"}, Proto => "tcp", Timeout => $self->{"tcp_timeout"}); $^W = $old_wflag; unless ($sock) { $self->errorstring("couldn't connect"); return; } my $lenmsg = pack("n", length($data)); unless ($sock->send($lenmsg)) { $self->errorstring($!); return; } unless ($sock->send($data)) { $self->errorstring($!); return; } my $sel = new IO::Select; $sel->add($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); 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); 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) = new Net::DNS::Packet(\$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; } # # Usage: $data = read_tcp($socket, $nbytes); # sub read_tcp { my ($sock, $nbytes) = @_; my $buf = ""; my $buf2; while (length($buf) < $nbytes) { $sock->recv($buf2, $nbytes - length($buf)); last unless length($buf2); $buf .= $buf2; } return $buf; } =head2 tcp_timeout print "TCP timeout: ", $res->tcp_timeout, "\n"; $res->tcp_timeout(10); Get or set the TCP timeout in seconds. A timeout of C means indefinite. The default is 120 seconds (2 minutes). =head2 retrans print "retrans interval: ", $res->retrans, "\n"; $res->retrans(3); Get or set the retransmission interval. The default is 5. =head2 retry print "number of tries: ", $res->retry, "\n"; $res->retry(2); Get or set the number of times to try the query. The default is 4. =head2 recurse print "recursion flag: ", $res->recurse, "\n"; $res->recurse(0); Get or set the recursion flag. If this is true, nameservers will be requested to perform a recursive query. The default is true. =head2 defnames print "defnames flag: ", $res->defnames, "\n"; $res->defnames(0); Get or set the defnames flag. If this is true, calls to B will append the default domain to names that contain no dots. The default is true. =head2 dnsrch print "dnsrch flag: ", $res->dnsrch, "\n"; $res->dnsrch(0); Get or set the dnsrch flag. If this is true, calls to B will apply the search list. The default is true. =head2 debug print "debug flag: ", $res->debug, "\n"; $res->debug(1); Get or set the debug flag. If set, calls to B, B, and B will print debugging information on the standard output. The default is false. =head2 usevc print "usevc flag: ", $res->usevc, "\n"; $res->usevc(1); Get or set the usevc flag. If true, then queries will be performed using virtual circuits (TCP) instead of datagrams (UDP). The default is false. =head2 igntc print "igntc flag: ", $res->igntc, "\n"; $res->igntc(1); Get or set the igntc flag. If true, truncated packets will be ignored. If false, truncated packets will cause the query to be retried using TCP. The default is false. =head2 errorstring print "query status: ", $res->errorstring, "\n"; Returns a string containing the status of the most recent query. =head2 answerfrom print "last answer was from: ", $res->answerfrom, "\n"; Returns the IP address from which we received the last answer in response to a query. =head2 answersize print "size of last answer: ", $res->answersize, "\n"; Returns the size in bytes of the last answer we received in response to a query. =cut sub AUTOLOAD { my $self = shift; my $name = $AUTOLOAD; $name =~ s/.*://; Carp::confess "$name: no such method" unless exists $self->{$name}; $self->{$name} = shift if @_; return $self->{$name}; } =head1 ENVIRONMENT The following environment variables can also be used to configure the resolver: =head2 RES_NAMESERVERS # Bourne Shell RES_NAMESERVERS="192.168.1.1 192.168.2.2 192.168.3.3" export RES_NAMESERVERS # C Shell setenv RES_NAMESERVERS "192.168.1.1 192.168.2.2 192.168.3.3" A space-separated list of nameservers to query. =head2 RES_SEARCHLIST # Bourne Shell RES_SEARCHLIST="foo.com bar.com baz.org" export RES_SEARCHLIST # C Shell setenv RES_SEARCHLIST "foo.com bar.com baz.org" A space-separated list of domains to put in the search list. =head2 LOCALDOMAIN # Bourne Shell LOCALDOMAIN=foo.com export LOCALDOMAIN # C Shell setenv LOCALDOMAIN foo.com The default domain. =head2 RES_OPTIONS # Bourne Shell RES_OPTIONS="retrans:3 retry:2 debug" export RES_OPTIONS # C Shell setenv RES_OPTIONS "retrans:3 retry:2 debug" A space-separated list of resolver options to set. Options that take values are specified as I