view release on metacpan or  search on metacpan

lib/File/VirusScan/Engine/Daemon/FPROT/V4.pm  view on Meta::CPAN

			return $result;
		}
	}

}

# TODO FIXME
# This is unbelievably ugly code, but as I have no way of testing it
# against an F-PROT daemon, it's been ported nearly verbatim from
# MIMEDefang.  It is in desperate need of cleanup!
sub _scan
{
	my ($self, $item) = @_;

	my $host     = $self->{host};
	my $baseport = $self->{base_port};

	# Default error message when reaching end of function
	my $errmsg = "Could not connect to F-Prot Daemon at $host:$baseport";

	# Try 5 ports in order to find an active scanner; they may
	# change the port when they find and spawn an updated demon
	# executable
	SEARCH_DEMON: foreach my $port ($baseport .. ($baseport + 4)) {

		# TODO: Timeout value?
		# TODO: Why aren't we using a HTTP client instead of
		# rolling our own HTTP?
		my $sock = IO::Socket::INET->new(
			PeerAddr => $host,
			PeerPort => $port
		);

		next if !defined $sock;

		# The arguments (following the '?' sign in the HTTP
		# request) are the same as for the command line F-Prot,
		# the additional -remote-dtd suppresses the unuseful
		# XML DTD prefix
		my @args = qw( -dumb -archive -packed -remote-dtd );
		my $uri = "$item?" . join('%20', @args);
		if(!$sock->print("GET $uri HTTP/1.0\n\n")) {
			my $err = $!;
			$sock->close;
			return File::VirusScan::Result->error("Could not write to socket: $err");
		}

		if(!$sock->flush) {
			my $err = $!;
			$sock->close;
			return File::VirusScan::Result->error("Could not flush socket: $err");
		}

		# Fetch HTTP Header
		## Maybe dropped, if no validation checks are to be made
		while (my $output = $sock->getline) {
			if($output =~ /^\s*$/) {
				last;  # End of headers
				#### Below here: Validating the protocol
				#### If the protocol is not recognized, it's assumed that the
				#### endpoint is not an F-Prot demon, hence,
				#### the next port is probed.
			} elsif($output =~ /^HTTP(.*)/) {
				my $h = $1;
				next SEARCH_DEMON unless $h =~ m!/1\.0\s+200\s!;
			} elsif($output =~ /^Server:\s*(\S*)/) {
				next SEARCH_DEMON if $1 !~ /^fprotd/;
			}
		}

		# Parsing XML results
		my $xml = HTML::TokeParser->new($sock);
		my $t   = $xml->get_tag('fprot-results');
		unless ($t) {  # This is an essential tag --> assume a broken demon
			$errmsg = 'Demon did not return <fprot-results> tag';
			last SEARCH_DEMON;
		}

		if($t->[1]{'version'} ne '1.0') {
			$errmsg = "Incompatible F-Protd results version: " . $t->[1]{'version'};
			last SEARCH_DEMON;
		}

		my $curText;   # temporarily accumulated information
		my $virii = '';  # name(s) of virus(es) found
		my $code;        # overall exit code
		my $msg = '';    # accumulated message of virus scanner
		while ($t = $xml->get_token) {
			my $tag = $t->[1];
			if($t->[0] eq 'S') {  # Start tag
				              # Accumulate the information temporarily
				              # into $curText until the </detected> tag is found
				my $text = $xml->get_trimmed_text;

				# $tag 'filename' of no use in MIMEDefang
				if($tag eq 'name') {
					$virii .= (length $virii ? " " : "") . $text;
					$curText .= "Found the virus: '$text'\n";
				} elsif($tag eq 'accuracy' || $tag eq 'disinfectable' || $tag eq 'message') {
					$curText .= "\t$tag: $text\n";
				} elsif($tag eq 'error') {
					$msg .= "\nError: $text\n";
				} elsif($tag eq 'summary') {
					$code = $t->[2]{'code'} if defined $t->[2]{'code'};
				}
			} elsif($t->[0] eq 'E') {  # End tag
				if($tag eq 'detected') {

					# move the cached information to the
					# accumulated message
					$msg .= "\n$curText" if $curText;
					undef $curText;
				} elsif($tag eq 'fprot-results') {
					last;      # security check
				}
			}
		}
		$sock->close;

## Check the exit code (man f-protd)
## NOTE: These codes are different from the ones of the command line version!