← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 03:09:29 2017
Reported on Mon Nov 6 13:20:48 2017

Filename/usr/local/lib/perl5/site_perl/mach/5.24/Razor2/Client/Core.pm
StatementsExecuted 31 statements in 23.5ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111372µs550µsRazor2::Client::Core::::BEGIN@18Razor2::Client::Core::BEGIN@18
11148µs60µsRazor2::Client::Core::::BEGIN@13Razor2::Client::Core::BEGIN@13
11131µs1.25msRazor2::Client::Core::::BEGIN@24Razor2::Client::Core::BEGIN@24
11129µs18.2msRazor2::Client::Core::::BEGIN@23Razor2::Client::Core::BEGIN@23
11126µs26µsRazor2::Client::Core::::CORE:matchRazor2::Client::Core::CORE:match (opcode)
11125µs3.62msRazor2::Client::Core::::BEGIN@14Razor2::Client::Core::BEGIN@14
11125µs86µsRazor2::Client::Core::::BEGIN@15Razor2::Client::Core::BEGIN@15
11125µs30.0msRazor2::Client::Core::::BEGIN@22Razor2::Client::Core::BEGIN@22
11123µs228µsRazor2::Client::Core::::BEGIN@21Razor2::Client::Core::BEGIN@21
11122µs356µsRazor2::Client::Core::::BEGIN@26Razor2::Client::Core::BEGIN@26
11122µs110µsRazor2::Client::Core::::BEGIN@19Razor2::Client::Core::BEGIN@19
11120µs1.97msRazor2::Client::Core::::BEGIN@16Razor2::Client::Core::BEGIN@16
11118µs109µsRazor2::Client::Core::::BEGIN@20Razor2::Client::Core::BEGIN@20
11117µs17µsRazor2::Client::Core::::BEGIN@25Razor2::Client::Core::BEGIN@25
0000s0sRazor2::Client::Core::::DESTROYRazor2::Client::Core::DESTROY
0000s0sRazor2::Client::Core::::_readRazor2::Client::Core::_read
0000s0sRazor2::Client::Core::::_sendRazor2::Client::Core::_send
0000s0sRazor2::Client::Core::::authenticateRazor2::Client::Core::authenticate
0000s0sRazor2::Client::Core::::bootstrap_discoveryRazor2::Client::Core::bootstrap_discovery
0000s0sRazor2::Client::Core::::checkRazor2::Client::Core::check
0000s0sRazor2::Client::Core::::check_logicRazor2::Client::Core::check_logic
0000s0sRazor2::Client::Core::::check_respRazor2::Client::Core::check_resp
0000s0sRazor2::Client::Core::::compute_server_confRazor2::Client::Core::compute_server_conf
0000s0sRazor2::Client::Core::::compute_sigsRazor2::Client::Core::compute_sigs
0000s0sRazor2::Client::Core::::compute_supported_enginesRazor2::Client::Core::compute_supported_engines
0000s0sRazor2::Client::Core::::connectRazor2::Client::Core::connect
0000s0sRazor2::Client::Core::::debugRazor2::Client::Core::debug
0000s0sRazor2::Client::Core::::disconnectRazor2::Client::Core::disconnect
0000s0sRazor2::Client::Core::::discoverRazor2::Client::Core::discover
0000s0sRazor2::Client::Core::::load_at_runtimeRazor2::Client::Core::load_at_runtime
0000s0sRazor2::Client::Core::::logobjRazor2::Client::Core::logobj
0000s0sRazor2::Client::Core::::make_queryRazor2::Client::Core::make_query
0000s0sRazor2::Client::Core::::newRazor2::Client::Core::new
0000s0sRazor2::Client::Core::::nextserverRazor2::Client::Core::nextserver
0000s0sRazor2::Client::Core::::obj2queriesRazor2::Client::Core::obj2queries
0000s0sRazor2::Client::Core::::parse_greetingRazor2::Client::Core::parse_greeting
0000s0sRazor2::Client::Core::::prepare_objectsRazor2::Client::Core::prepare_objects
0000s0sRazor2::Client::Core::::prepare_partsRazor2::Client::Core::prepare_parts
0000s0sRazor2::Client::Core::::queries2objRazor2::Client::Core::queries2obj
0000s0sRazor2::Client::Core::::rcheck_respRazor2::Client::Core::rcheck_resp
0000s0sRazor2::Client::Core::::registerRazor2::Client::Core::register
0000s0sRazor2::Client::Core::::reportRazor2::Client::Core::report
0000s0sRazor2::Client::Core::::zonenameRazor2::Client::Core::zonename
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1#!/usr/local/bin/perl -sw
2##
3## Razor2::Client::Core - Vipul's Razor Client API
4##
5## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
6## This code is free software; you can redistribute it and/or modify
7## it under the same terms as Perl itself.
8##
9## $Id: Core.pm,v 1.92 2006/05/27 00:00:53 rsoderberg Exp $
10
11package Razor2::Client::Core;
12
13265µs272µs
# spent 60µs (48+12) within Razor2::Client::Core::BEGIN@13 which was called: # once (48µs+12µs) by base::import at line 13
use strict;
# spent 60µs making 1 call to Razor2::Client::Core::BEGIN@13 # spent 12µs making 1 call to strict::import
14272µs27.21ms
# spent 3.62ms (25µs+3.59) within Razor2::Client::Core::BEGIN@14 which was called: # once (25µs+3.59ms) by base::import at line 14
use IO::Socket;
# spent 3.62ms making 1 call to Razor2::Client::Core::BEGIN@14 # spent 3.59ms making 1 call to IO::Socket::import
15262µs2148µs
# spent 86µs (25+62) within Razor2::Client::Core::BEGIN@15 which was called: # once (25µs+62µs) by base::import at line 15
use IO::Select;
# spent 86µs making 1 call to Razor2::Client::Core::BEGIN@15 # spent 62µs making 1 call to Exporter::import
16265µs23.91ms
# spent 1.97ms (20µs+1.95) within Razor2::Client::Core::BEGIN@16 which was called: # once (20µs+1.95ms) by base::import at line 16
use Errno qw(:POSIX);
# spent 1.97ms making 1 call to Razor2::Client::Core::BEGIN@16 # spent 1.95ms making 1 call to Exporter::import
17
182322µs1550µs
# spent 550µs (372+177) within Razor2::Client::Core::BEGIN@18 which was called: # once (372µs+177µs) by base::import at line 18
use Razor2::Client::Version;
# spent 550µs making 1 call to Razor2::Client::Core::BEGIN@18
19260µs2197µs
# spent 110µs (22+88) within Razor2::Client::Core::BEGIN@19 which was called: # once (22µs+88µs) by base::import at line 19
use Data::Dumper;
# spent 110µs making 1 call to Razor2::Client::Core::BEGIN@19 # spent 88µs making 1 call to Exporter::import
20263µs2199µs
# spent 109µs (18+90) within Razor2::Client::Core::BEGIN@20 which was called: # once (18µs+90µs) by base::import at line 20
use vars qw( $VERSION $PROTOCOL );
# spent 109µs making 1 call to Razor2::Client::Core::BEGIN@20 # spent 90µs making 1 call to vars::import
21263µs2228µs
# spent 228µs (23+205) within Razor2::Client::Core::BEGIN@21 which was called: # once (23µs+205µs) by base::import at line 21
use base qw(Razor2::String);
# spent 228µs making 1 call to Razor2::Client::Core::BEGIN@21 # spent 205µs making 1 call to base::import, recursion: max depth 1, sum of overlapping time 205µs
22288µs230.0ms
# spent 30.0ms (25µs+29.9) within Razor2::Client::Core::BEGIN@22 which was called: # once (25µs+29.9ms) by base::import at line 22
use base qw(Razor2::Logger);
# spent 30.0ms making 1 call to Razor2::Client::Core::BEGIN@22 # spent 29.9ms making 1 call to base::import, recursion: max depth 1, sum of overlapping time 29.9ms
23287µs218.2ms
# spent 18.2ms (29µs+18.2) within Razor2::Client::Core::BEGIN@23 which was called: # once (29µs+18.2ms) by base::import at line 23
use base qw(Razor2::Client::Engine);
# spent 18.2ms making 1 call to Razor2::Client::Core::BEGIN@23 # spent 18.2ms making 1 call to base::import, recursion: max depth 1, sum of overlapping time 18.2ms
24269µs21.25ms
# spent 1.25ms (31µs+1.22) within Razor2::Client::Core::BEGIN@24 which was called: # once (31µs+1.22ms) by base::import at line 24
use base qw(Razor2::Errorhandler);
# spent 1.25ms making 1 call to Razor2::Client::Core::BEGIN@24 # spent 1.22ms making 1 call to base::import, recursion: max depth 1, sum of overlapping time 1.22ms
25281µs117µs
# spent 17µs within Razor2::Client::Core::BEGIN@25 which was called: # once (17µs+0s) by base::import at line 25
use Razor2::Client::Version;
# spent 17µs making 1 call to Razor2::Client::Core::BEGIN@25
2612µs
# spent 356µs (22+334) within Razor2::Client::Core::BEGIN@26 which was called: # once (22µs+334µs) by base::import at line 29
use Razor2::String qw(hextobase64 makesis parsesis hmac_sha1 xor_key
27 prep_mail debugobj to_batched_query
28 from_batched_query hexbits2hash
29122.3ms2690µs fisher_yates_shuffle);
# spent 356µs making 1 call to Razor2::Client::Core::BEGIN@26 # spent 334µs making 1 call to Exporter::import
30
31
32385µs126µs($VERSION) = do { my @r = (q$Revision: 1.92 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
# spent 26µs making 1 call to Razor2::Client::Core::CORE:match
3312µs$PROTOCOL = $Razor2::Client::Version::PROTOCOL;
34
35
36sub new {
37 my ($class, $conf, %params) = @_;
38 my $self = {};
39 bless $self, $class;
40 $self->debug ("Razor Agents $VERSION, protocol version $PROTOCOL.");
41 return $self;
42}
43
- -
46#
47# We store server-specific config info for each server we know about.
48# All info about razor servers is stored in $self->{s}.
49#
50# Basically we get the server name/ip from {list},
51# load that server's specific info from {allconfs} into {conf},
52# and do stuff. If server is no good, we get nextserver from {list}
53#
54# $self->{s}->{list} ptr to {nomination} if report,revoke; or {catalogue} if check
55# or the cmd-line server (-rs server)
56# $self->{s}->{new_list} set to 1 when discover gets new lists
57# $self->{s}->{catalogue} array ref containing catalogue servers
58# $self->{s}->{nomination}array ref containing nomination servers
59# $self->{s}->{discovery} array ref containing discovery servers
60#
61# $self->{s}->{modified} array ref containing servers whose .conf needs updating
62# $self->{s}->{modified_lst} array ref containing which .lst files need updating
63#
64# $self->{s}->{ip} string containing ip (or dns name) of current server from {list})
65# $self->{s}->{port} string containing port, taken from server:port from {list}
66# $self->{s}->{engines} engines supported, derived from {conf}->{se}
67# $self->{s}->{conf} hash ref containing current server's config params
68# read from $razorhome/server.$ip.conf
69#
70# $self->{s}->{allconfs} hash ref of all servers' configs. key={ip}, val={conf}
71# as read from server.*.conf file
72#
73# $self->{s}->{listfile} string containing path/file of server.lst, either
74# nomination or catalogue depending $self->{breed}
75# $self->{conf}->{listfile_discovery} string containing path/file of discovery server
76#
77# NOTE: if we are razor-check, server is Catalogue Server
78# otherwise server is Nomination server.
79#
80# everytime we update our server list, $self->{s}->{list};
81# we want to write that to disk - $self->{s}->{listfile}
82#
83sub nextserver {
84 my ($self) = @_;
85 $self->log (16,"entered nextserver");
86
87 # see if we need to discover (.lst files might be too old)
88 $self->discover() or return $self->errprefix ("nextserver");
89
90 # first time we don't remove from list
91 # or if we've rediscovered.
92 shift @{$self->{s}->{list}} unless ($self->{s}->{new_list} || !$self->{s}->{ip});
93 $self->{s}->{new_list} = 0;
94
95 my $next = ${$self->{s}->{list}}[0];
96
97 # do we ever want to put current back on the end of list?
98 # push @{$self->{s}->{list}}, $self->{s}->{ip};
99
100 if ($next) {
101 ($self->{s}->{port}) = $next =~ /:(.*)$/;
102 $next =~ s/:.*$//; # optional
103 $self->{s}->{ip} = $next; # ip can be IP or DNS name
104 $self->{s}->{port} ||= $self->{conf}->{port} || 2703;
105 $self->{s}->{conf} = $self->{s}->{allconfs}->{$next};
106
107 my $svrport = "$self->{s}->{ip}:$self->{s}->{port}";
108
109 # get rid of server specific stuff
110 delete $self->{s}->{greeting};
111
112 unless (ref($self->{s}->{conf})) {
113 # never used this server before, no cached info. go get it!
114 $self->{s}->{conf} = {};
115 $self->connect; # calls parse_greeting which calls compute_server_conf
116 } else {
117 $self->compute_server_conf(1); # computes supported engines, logs info
118 }
119 $self->writeservers();
120
121 my $srl = defined($self->{s}->{conf}->{srl}) ? $self->{s}->{conf}->{srl} : "<unknown>";
122 $self->log(8, "Using next closest server $svrport, cached info srl $srl");
123 #$self->logobj(11, "Using next closest server $svrport, cached info", $self->{s}->{conf});
124 return 1;
125
126 } else {
127 return $self->error ("Razor server $self->{opt}->{server} not available at this time")
128 if $self->{opt}->{server};
129 $self->{force_discovery} = 1;
130 if ($self->{done_discovery} && !($self->discover)) {
131 return $self->errprefix("No Razor servers available at this time");
132 }
133 return $self->nextserver;
134 }
135}
136
137sub load_at_runtime {
138 my ($self,$class,$sub,$args) = @_;
139
140 $sub = 'new' unless defined $sub;
141 $args = "" unless defined $args;
142
143 eval "use $class";
144 if ($@) {
145 $self->log(2,"$class not found, please to fix.");
146 return $self->error("\n\n$@");
147 }
148 my $evalstr;
149 if ($sub && $sub ne "new") {
150 $evalstr = $class ."::$sub($args);";
151 } else {
152 $evalstr = $class . "->new($args)";
153 }
154 if (my $dude = eval $evalstr) {
155 $self->log(12,"Found and evaled $evalstr ==> $dude");
156 return $dude;
157 } else {
158 $self->log(5,"Found but problem (bad args?) with $evalstr");
159 return $self->error("Problem with $evalstr");
160 }
161}
162
163#
164# uses DNS to find Discovery servers
165# puts discovery servers in $self->{s}->{discovery}
166#
167sub bootstrap_discovery {
168 my ($self) = @_;
169 $self->log (16,"entered bootstrap_discovery");
170
171 if ($self->{conf}->{server}) {
172 $self->log(8,"no bootstap_discovery when cmd-line server specified");
173 return 1;
174 }
175 unless ($self->{force_bootstrap_discovery}) {
176 if (ref($self->{s}->{discovery}) && scalar(@{$self->{s}->{discovery}})) {
177 $self->log(8,"already have ". scalar(@{$self->{s}->{discovery}})
178 ." discovery servers");
179 return 1;
180 } elsif ($self->{done_bootstrap}) {
181 # if we've done it before {s}->{discovery} should be set
182 $self->log(8,"already have done bootstrap_discovery");
183 return 1;
184 }
185 }
186 unless (defined $self->{conf}->{listfile_discovery}) {
187 $self->log(6,"discovery listfile not defined!");
188 } elsif (-s $self->{conf}->{listfile_discovery}) {
189 my $wait = $self->{conf}->{rediscovery_wait_dns} || 604800; # 604800 secs == 7 days
190 my $randomize = int(rand($wait/7));
191 my $timeleft = ((stat ($self->{conf}->{listfile_discovery}))[9] + $wait - $randomize) - time;
192 if ($timeleft > 0) {
193 $self->log (7,"$timeleft seconds before soonest DNS discovery");
194 return 1 unless $self->{force_bootstrap_discovery};
195 $self->log (5,"forcing DNS discovery");
196 } else {
197 $self->log (5,"DNS discovery overdue by ". (0-$timeleft) ." seconds");
198 }
199 } else {
200 if (-e $self->{conf}->{listfile_discovery}) {
201 $self->log (6,"empty discovery listfile: $self->{conf}->{listfile_discovery}");
202 } else {
203 $self->log (6,"no discovery listfile: $self->{conf}->{listfile_discovery}");
204 }
205 }
206
207 $self->{s}->{discovery} = [ $self->{conf}->{razordiscovery} ];
208 push @{$self->{s}->{modified_lst}}, "discovery";
209 return 1;
210}
211
- -
214#
215# uses Discovery Servers to find closest Nomination/Catalogue Servers.
216# called every day or so of if .lst file is empty
217#
218# puts servers in $self->{s}->{list}
219#
220sub discover {
221 my ($self) = @_;
222 $self->log (16,"entered discover");
223
224 #
225 # do we need to discover?
226 #
227
228 # no discover if cmd-line server
229 return 1 if $self->{opt}->{server};
230
231 #
232 # don't discover if conf says turn_off_discovery (unless force_discovery)
233 #
234 return 1 if $self->{conf}->{turn_off_discovery} && (!($self->{force_discovery}));
235 return $self->error ("No Razor servers available at this time")
236 if $self->{done_discovery};
237
238 # so if user has their own servers, and they are temporarily down, force_discovery.
239 # good: shit will work
240 # bad: it will erase their custom server*.lst file
241 #
242 unless (defined $self->{s}->{listfile}) {
243 $self->debug ("listfile not defined!");
244 } elsif (-s $self->{s}->{listfile}) {
245 my $randomize = int(rand($self->{conf}->{rediscovery_wait}/7));
246 my $timeleft = ((stat ($self->{s}->{listfile}))[9] + $self->{conf}->{rediscovery_wait} - $randomize) - time;
247 if ($timeleft > 0) {
248 $self->debug ("$timeleft seconds before closest server discovery");
249 return 1 unless $self->{force_discovery};
250 $self->debug ("forcing discovery");
251 } else {
252 $self->debug ("server discovery overdue by ". (0-$timeleft) ." seconds");
253 }
254 } else {
255 if (-e $self->{s}->{listfile}) {
256 $self->debug ("empty listfile: $self->{s}->{listfile}");
257 } else {
258 $self->debug ("no listfile: $self->{s}->{listfile}");
259 }
260 }
261
262 #
263 # we need to discover.
264 #
265
266
267 return $self->errprefix("discover0") unless $self->bootstrap_discovery();
268
269
270 #
271 # Go ahead and do discovery for both csl and nsl.
272 #
273 my %stype = ( csl => 'catalogue', nsl => 'nomination' );
274
275 my $srvs = {csl => {}, nsl => {} };
276
277 my $list_orig = $self->{s}->{list};
278 $self->{s}->{list} = $self->{s}->{discovery};
279
280 foreach (@{$self->{s}->{discovery}}) {
281 unless (defined $_) {
282 $self->log (5,"Razor Discovery Server not defined!");
283 next;
284 }
285
286 $self->log (8,"Checking with Razor Discovery Server $_");
287
288 unless ($self->connect( server => $_, discovery_server => 1 ) ) {
289 $self->log (5,"Razor Discovery Server $_ is unreachable");
290 next;
291 }
292
293 foreach my $querytype (qw(csl nsl)) {
294 my $query = "a=g&pm=$querytype\r\n";
295 my $resp = $self->_send([$query]);
296
297 unless ($resp) {
298 $self->{s}->{list} = $list_orig;
299 return $self->errprefix("discover1");
300 }
301
302 # from_batched_query wants "-" in beginning, but not ".\r\n" at end
303 $resp->[0] =~ s/\.\r\n$//sg;
304 my $h = from_batched_query($resp->[0], {});
305
306 foreach my $href (@$h) {
307 next unless $href->{$querytype};
308 $self->log (8,"Discovery Server $_ replying with $querytype=$href->{$querytype}");
309 $srvs->{$querytype}->{$href->{$querytype}} = 1;
310 }
311 unless (keys %{$srvs->{$querytype}}) {
312 $self->log (5,"Razor Discovery Server $_ had no valid $querytype servers");
313 next;
314 }
315 }
316 }
317
318 $self->{s}->{list} = $list_orig;
319
320 foreach my $querytype (qw(csl nsl)) {
321
322 my @list = keys %{$srvs->{$querytype}};
323
324 #return $self->error("Could not get valid info from Discovery Servers")
325 # unless @list;
326 unless (@list) {
327 if ($self->{force_bootstrap_discovery}) {
328 return $self->error("Bootstrap discovery failed. Giving up.");
329 }
330 $self->log(5, "Couldn't talk to discovery servers. Will force a bootstrap...");
331 $self->{force_bootstrap_discovery} = 1;
332 return $self->error("Bootstrap discovery failed. Giving up.") unless $self->bootstrap_discovery();
333 return $self->discover();
334 }
335
336 fisher_yates_shuffle(\@list) if @list > 1;
337
338 $self->{s}->{$stype{$querytype}} = \@list;
339 push @{$self->{s}->{modified_lst}}, $stype{$querytype};
340
341 }
342
343 $self->disconnect();
344
345 unless ($self->{opt}->{server}) {
346 if ($self->{breed} =~ /^check/) {
347 $self->{s}->{list} = $self->{s}->{catalogue};
348 $self->{s}->{listfile} = $self->{conf}->{listfile_catalogue}; # for discovery()
349 } else {
350 $self->{s}->{list} = $self->{s}->{nomination};
351 $self->{s}->{listfile} = $self->{conf}->{listfile_nomination}; # for discovery()
352 }
353 }
354
355 $self->{s}->{new_list} = 1;
356
357 $self->{done_discovery} = 1;
358 $self->writeservers();
359
360 return $self;
361}
362
363
364# only for debugging and errorchecking
365#
366sub logobj {
367 my ($self, $loglevel, $prefix, @objs) = @_;
368
369 return unless $self->logll($loglevel);
370
371 foreach my $obj (@objs) {
372 my $line = debugobj($obj);
373 $self->log($loglevel, "$prefix:\n $line");
374 }
375}
376
377
378#
379# Mail Object
380#
381# Main data type used by check and report is the Mail Object.
382# an array of hash ref's, where array order matches mails in mbox (or stdin).
383#
384# key = value (not all defined)
385#
386# id = integer NOTE: only key guaranteed to exist
387# orig_mail = ref to string containing orig email (headers+body)
388# headers = headers of orig_email
389# spam = 0, not spam, >1 spam
390# skipme = 0|1 (not checked against server, usually whitelisted mail)
391# p = array ref to mimeparts. see below
392# e1 = similar to p, but special for engine 1
393#
394# e1: each mail obj contains a special part for engine 1
395#
396# skipme = 0|1 (ex: 1 if cleaned body goes to 0 len)
397# spam = 0, not spam, >1 spam
398# body = body of orig_mail
399# cleaned = body sent thru razor 1 preproc
400# e1 = hash using engine 1
401# sent = hash ref sent to server
402# resp = hash ref of server response
403#
404# p: each mail obj contains 1 or more mimeparts, which can contain:
405#
406# id = string - mailid.part
407# skipme = 0|1 (ex: 1 if cleaned body goes to 0 len)
408# spam = 0, not spam, >1 spam
409# body = bodyparts (mimeparts) of orig_email, has X-Razor & Content-* headers
410# cleaned = body sent through preprocessors (deHtml, deQP, etc..), debugging use only
411# e2 = hash using engine 2
412# e3 = hash using engine 2
413# e4 = hash using engine 2
414# sent = array ref of hash ref's sent to server
415# resp = array ref of hash ref's, where hash is parsed sis of server response
416#
417#
418sub prepare_objects {
419 my ($self, $objs) = @_;
420 my @objects;
421
422 unless ($self->{s}->{engines} ||
423 ($self->{s}->{engines} = $self->compute_supported_engines() ) ) {
424 $self->log(1, "ALLBAD. supported engines not defined");
425 }
426
427 my $i = 1;
428 if (ref($objs->[0]) eq 'HASH') { # checking cmd-line signatures
429 foreach my $o (@$objs) {
430 my $obj = { id => $i++ };
431 $obj->{p}->[0]->{id} = "$obj->{id}.0";
432 $obj->{p}->[0]->{"e$o->{eng}"} = $o->{sig};
433 $obj->{ep4} = $o->{ep4} if $o->{ep4};
434 push @objects, $obj;
435 }
436
437 } elsif (ref($objs->[0]) eq 'SCALAR') { # checking/reporting mail
438 foreach my $o (@$objs) {
439 my $obj = { id => $i++ };
440 $obj->{orig_mail} = $o;
441 $self->log2file( 16, $o, "$obj->{id}.orig_mail" ); # includes headers and all
442 push @objects, $obj;
443 }
444 $self->prepare_parts(\@objects);
445 }
446 $self->logobj(14,"prepared objs", \@objects);
447
448 return \@objects;
449}
450
451sub prepare_parts {
452 my ($self, $objs) = @_;
453
454 my $prep_mail_debug = 0; # debug print, 0=none, 1=split_mime stuff, 2=more verbose
455 $prep_mail_debug++ if $self->{conf}->{debuglevel} > 15;
456 $prep_mail_debug++ if $self->{conf}->{debuglevel} > 16;
457
458 foreach my $obj (@$objs) {
459 next if ($obj->{skipme} || !$obj->{orig_mail});
460
461 #
462 # now split up mime parts from orig mail
463 #
464 my ($headers, @bodyparts) = prep_mail (
465 $obj->{orig_mail},
466 $self->{conf}->{report_headers},
467 4 * 1024,
468 60 * 1024,
469 15 * 1024,
470 $self->{name_version},
471 $prep_mail_debug, # $debug,
472 );
473
474 my $lines = " prep_mail done: mail $obj->{id} headers=". length($$headers);
475 foreach (0..$#bodyparts) { $lines .= ", mime$_=". length(${$bodyparts[$_]}); }
476 $self->log(8,$lines);
477
478 unless (@bodyparts) {
479 $self->log(2,"empty body in mail $obj->{id}, skipping");
480 next;
481 }
482
483 $$headers =~ s/\r\n/\n/gs;
484 $obj->{headers} = $headers;
485
486 # $obj->{e1} = {
487 # id => "$obj->{id}.e1",
488 # body => $obj->{orig_mail},
489 # };
490
491 $obj->{p} = [];
492 foreach (0..$#bodyparts) {
493 $bodyparts[$_] =~ s/\r\n/\n/gs;
494 $obj->{p}->[$_] = {
495 id => "$obj->{id}.$_",
496 body => $bodyparts[$_],
497 };
498 }
499 }
500 return 1;
501}
502
503
504# given mail objects, fills out
505#
506# - e1
507#
508# and for each body part of mail object, fills out
509#
510# - cleaned
511# - e2
512# - e3
513# - e4
514#
515# also returns array ref of sigs suitable for printing
516#
517sub compute_sigs {
518 my ($self, $objects) = @_;
519 my @printable_sigs;
520
521 foreach my $obj (@$objects) {
522 next if ($obj->{skipme} || !$obj->{orig_mail});
523
524 if (${$obj->{orig_mail}} =~ /\n(Subject: [^\n]+)\n/) {
525 my $subj = substr $1, 0, 70;
526 $self->log(8,"mail ". $obj->{id} ." $subj");
527 } else {
528 $self->log(8,"mail ". $obj->{id} ." has no subject");
529 }
530
531 #
532 # clean each bodypart, removing if new length is 0
533 #
534 next unless $obj->{p};
535 foreach my $objp (@{$obj->{p}}) {
536
537 next if $objp->{skipme};
538 my $olen = length(${$objp->{body}});
539 my $clnpart = ${$objp->{body}};
540
541 # We'll do a VR8 preproc to determine emptiness
542 # of email, and store it so VR8 can use it.
543
544 my $clnpart_vr8 = $clnpart;
545 $self->{preproc_vr8}->preproc( \$clnpart_vr8 ); # in da future: $self->{s}->{conf}->{dre}
546 $objp->{cleaned_vr8} = \$clnpart_vr8;
547
548 # This for VR4 (the only other signature scheme
549 # supported at this time.
550
551 $self->{preproc}->preproc( \$clnpart );
552 $objp->{cleaned} = \$clnpart;
553
554 my $clen = length($clnpart_vr8);
555
556 $self->log2file( 15, $objp->{body}, "$objp->{id}.before_preproc.as_reported");
557 $self->log2file( 15, $objp->{cleaned}, "$objp->{id}.after_preproc");
558
559 if ($clen eq 0) {
560 $self->log(6,"preproc: mail $objp->{id} went from $olen bytes to 0, erasing");
561 $objp->{skipme} = 1;
562 next;
563 } elsif (($clen < 128) and ($clnpart =~ /^(Content\S*:[^\n]*\n\r?)+(Content\S*:[^\n]*)?\s*$/s)) {
564 $self->log(6,"preproc: mail $objp->{id} seems empty, erasing");
565 $objp->{skipme} = 1;
566 next;
567 } elsif ($clnpart_vr8 !~ /\S/) {
568 $self->log(6,"preproc: mail $objp->{id} went to all whitespace, erasing");
569 $objp->{skipme} = 1;
570 next;
571 } elsif ($clen eq $olen) {
572 $self->log(6,"preproc: mail $objp->{id} unchanged, bytes=$olen");
573 } else {
574 $self->log(6,"preproc: mail $objp->{id} went from $olen bytes to $clen ");
575 }
576 }
577
578
579 #
580 # compute sig for bodyparts that are cleaned.
581 #
582 if ($self->{s}->{conf}->{ep4}) {
583 $obj->{ep4} = $self->{s}->{conf}->{ep4};
584 } else {
585 $obj->{ep4} = '7542-10';
586 $self->log(8,"warning: no ep4 for server $self->{s}->{ip}, using $obj->{ep4}");
587 }
588
589 foreach my $objp (@{$obj->{p}}) {
590
591 next if $objp->{skipme};
592
593 $self->log(15, "mail part is [${$objp->{cleaned}}]");
594
595 if (${$objp->{cleaned}} =~ /^\s+$/) {
596 $self->log(6, "mail $objp->{id} is whitespace only; skipping!");
597 }
598
599 $self->log(6,"computing sigs for mail $objp->{id}, len ". length(${$objp->{cleaned}}));
600
601 foreach (sort keys %{$self->{s}->{engines}}) {
602
603 my $engine_no = $_;
604 my $sig;
605
606 if ($engine_no == 4) {
607
608 $sig = $self->compute_engine(
609 $engine_no,
610 $objp->{cleaned},
611 $obj->{ep4}
612 );
613
614 } elsif ($engine_no == 8) {
615
616 $sig = $self->compute_engine(
617 $engine_no,
618 $objp->{cleaned_vr8}
619 );
620
621 } else {
622
623 # Unsupported signature type, don't calculate.
624 next; # handled above
625
626 }
627
628 if ($sig) {
629
630 $objp->{"e$engine_no"} = $sig;
631
632 my @sigs;
633 if (ref $sig eq 'ARRAY') {
634 @sigs = @$sig;
635 } else {
636 push @sigs, $sig;
637 }
638
639 for (@sigs) {
640
641 my $line = "$objp->{id} e$engine_no: $_";
642 $line .= ", ep4: $obj->{ep4}" if ($engine_no eq '4');
643 push @printable_sigs, $line;
644
645 }
646
647 } else {
648
649 $self->log(6,"Engine ($engine_no) didn't produce a signature for mail $objp->{id}");
650
651 }
652
653 }
654
655 }
656
657 $self->logobj(14,"computed sigs for obj", $obj);
658
659 }
660
661 return \@printable_sigs;
662
663}
664
665
666#
667# this function is the only one that has to be aware
668# of razor protocol syntax. (not including random logging)
669# the hashes generated here are eventually sent to to_batched_query.
670#
671sub make_query {
672 my ($self, $params) = @_;
673
674
675 if ($params->{action} =~ /^check/) {
676
677 if (ref $params->{sig} eq 'ARRAY') { # Multiple signature per part, VR8
678
679 my $sigs = $params->{sig};
680 my @queries;
681 for (@$sigs) {
682 my %query = ( a => 'c', e => $params->{eng}, s => $_ );
683 push @queries, \%query;
684 }
685 return \@queries;
686
687 } else {
688
689 my %query = ( a => 'c', e => $params->{eng}, s => $params->{sig} );
690 $query{ep4} = $params->{ep4} if $query{e} eq '4';
691 return \%query;
692
693 }
694
695 } elsif ($params->{action} =~ /^rcheck/) {
696
697 my %query = ( a => 'r',
698 e => $params->{eng},
699 s => $params->{sig},
700 );
701 $query{ep4} = $params->{ep4} if $query{e} eq '4';
702 return \%query;
703
704 } elsif ($params->{action} =~ /(report)/) {
705
706 # prep_mail already truncated headers and body parts > 64K
707 my @dudes;
708 my $n = 0;
709 while ($params->{obj}->{p}->[$n]) {
710 my $line = ${$params->{obj}->{headers}};
711 while (1) {
712 my $body = $params->{obj}->{p}->[$n]->{body};
713 last unless ( (length($$body) + length($line)
714 < $self->{s}->{conf}->{bqs} * 1024));
715
716 $self->log(11, "bqs=". ($self->{s}->{conf}->{bqs} * 1024) .
717 " adding to line [len=". length($line) ."] mail $params->{obj}->{p}->[$n]->{id}"
718 ." [len=". length($$body) ."], total len=". (length($$body) + length($line)) );
719
720 $line .= "\r\n". $$body;
721 $n++;
722 last unless $params->{obj}->{p}->[$n];
723 }
724 push @dudes, $line;
725 }
726
727 my @queries;
728 foreach (@dudes) {
729 push @queries, { a => $params->{action} eq 'report' ? 'r' : 'revoke',
730 message => $_,
731 };
732 }
733 return @queries;
734
735 } elsif ($params->{action} =~ /revoke/) {
736
737 # Never send messages on revoke. Revoke all signature
738 # that we were able to compute.
739
740 my $n = 0;
741 my @queries;
742 while ($params->{obj}->{p}->[$n]) {
743 for my $engine (keys %{$self->{s}->{engines}}) {
744 my $sigs;
745 if ($sigs = $params->{obj}->{p}->[$n]->{"e$engine"}) {
746 if (ref $sigs eq 'ARRAY') {
747 for my $sig (@$sigs) {
748 push @queries, {a => 'revoke', e => $engine, s => $sig};
749 }
750 } else {
751 push @queries, {a => 'revoke', e => $engine, s => $sigs};
752 }
753 }
754 }
755 $n++;
756 }
757
758 return @queries;
759
760 }
761
762}
763
764#
765# prepare queries in correct syntax for sending over network
766#
767sub obj2queries {
768 my ($self, $objects, $action) = @_;
769 my @queries = ();
770
771 foreach my $obj (@$objects) {
772 next if $obj->{skipme};
773 push @queries, $obj->{e1}->{sent} if $obj->{e1}->{sent};
774 foreach my $objp (@{$obj->{p}}) {
775 next if $objp->{skipme};
776 #$self->log(8,"not skipping mail part $objp->{id}, sent: ". scalar(@{$objp->{sent}}));
777 push @queries, @{$objp->{sent}} if $objp->{sent};
778 }
779 }
780
781 if (scalar(@queries)) {
782 $self->log(8,"preparing ". scalar(@queries) ." queries");
783 } else {
784 $self->log(8,"objects yielded no valid queries");
785 return [];
786 }
787 my $qbatched = to_batched_query( \@queries,
788 $self->{s}->{conf}->{bql},
789 $self->{s}->{conf}->{bqs},
790 1);
791 $self->log(8,"sending ". scalar(@$qbatched) ." batches");
792
793 return $qbatched;
794}
795
796
797#
798# Parse response syntax, add info to appropriate object
799#
800sub queries2obj {
801 my ($self, $objs, $responses, $action) = @_;
802
803 my @resp;
804 foreach (@$responses) {
805 # from_batched_query wants "-" in beginning, but not ".\r\n" at end
806 s/\.\r\n$//sg;
807 my $arrayref = from_batched_query($_);
808 push @resp, @$arrayref;
809 }
810
811 $self->log(12,"processing ". scalar(@resp) ." responses");
812 $self->logobj(14,"from_batched_query", \@resp);
813
814 my $j = 0;
815 while (@resp) {
816 my $obj = $objs->[$j++];
817 return $self->error("more responses than mail objs!") unless $obj;
818 next if $obj->{skipme};
819
820 if ($obj->{e1}->{sent} && !$obj->{e1}->{skipme}) {
821 $obj->{e1}->{resp} = shift @resp;
822 $self->log(12,"adding a resp to mail $obj->{e1}->{id}") ;
823 }
824 foreach my $objp (@{$obj->{p}}) {
825 next unless $objp->{sent};
826 # for each part, shift out as many responses as there were queries
827 foreach (@{$objp->{sent}}) {
828 push @{$objp->{resp}}, shift @resp;
829 $self->log(12,"adding a resp to mail $objp->{id}");
830 }
831 }
832 #$self->logobj(13,"end of queries2obj",$obj);
833 }
834 return 1;
835}
836
837
838sub check_resp {
839 my ($self, $me, $sent, $resp, $objp) = @_;
840
841 # default is no contention
842 $objp->{ct} = 0;
843 $objp->{ct} = $resp->{ct} if exists $resp->{ct};
844
845 if (exists $resp->{err}) {
846 $self->logobj(4,"$me: got err $resp->{err} for query", $sent);
847 return 0;
848 }
849 if ($resp->{p} eq '1') {
850 if (exists $resp->{cf}) {
851 if ($resp->{cf} < $self->{s}->{min_cf}) {
852 $self->log (6,"$me: Not spam: cf $resp->{cf} < min_cf $self->{s}->{min_cf}");
853 return 0;
854 } else {
855 $self->log (6,"$me: Is spam: cf $resp->{cf} >= min_cf $self->{s}->{min_cf}");
856 return 1;
857 }
858 }
859 $self->log (6,"$me: sig found, no cf, ok.");
860 return 1;
861 }
862 if ($resp->{p} eq '0') {
863 $self->log (6,"$me: sig not found.");
864 return 0;
865 }
866 # should never get here
867 $self->logobj(2,"$me: got bad response from server - sent obj, resp obj",
868 [$sent, $resp] );
869 return 0;
870}
871
872
873sub rcheck_resp {
874 my ($self, $me, $sent, $resp) = @_;
875
876 $self->log(8,"$me: invalid $sent") unless ref($sent);
877 $self->log(8,"$me: invalid $resp") unless ref($resp);
878
879 if (exists $resp->{err}) {
880 if ($resp->{err} eq '230') {
881 $self->log(8,"$me: err 230 - server wants mail");
882 return 1;
883 }
884 $self->logobj(4,"$me: got err $resp->{err} for query", $sent);
885 return 0;
886 }
887 if ($resp->{res} eq '1') {
888 $self->log (5,"$me: Server accepted report.");
889 return 0;
890 }
891 if ($resp->{res} eq '0') {
892 $self->log (1,"$me: Server did not accept report. Shame on the server.");
893 return 0;
894 }
895 # should never get here
896 $self->logobj(2,"$me: got bad response from server - sent obj, resp obj",
897 [$sent, $resp] );
898 return 0;
899}
900
901
902sub check {
903 my ($self, $objects) = @_;
904
905 my $valid = 0;
906 foreach my $obj (@$objects) {
907 next if $obj->{skipme};
908
909 #
910 # Logic used in ordering of check queries
911 #
912 # queries should go like this: (e=engine, p=part)
913 # e1, p0e2, p0e3, p0e4, p1e2, p1e3, p1e4, etc..
914 # unless cmd-line sigs are passed.
915 #
916
917 # engine 1 is for entire mail, not parts
918 if ($obj->{e1} # cmd-line sig checks don't have this
919 && $self->{s}->{engines}->{1}) {
920 $obj->{e1}->{sent} = $self->make_query( {
921 action => 'check',
922 sig => $obj->{e1}->{e1},
923 eng => 1 } );
924 }
925 # rest of engines and mime parts
926 foreach my $objp (@{$obj->{p}}) {
927
928 if ($objp->{skipme}) {
929 $self->log(8,"mail $objp->{id} skipped in check");
930 next;
931 }
932 $objp->{sent} = [];
933 foreach (sort keys %{$self->{s}->{engines} }) {
934
935 my $engine_save = $_;
936 next if $_ eq 1; # engine 1 done above
937 my $sig = $objp->{"e$_"};
938 unless ($sig) {
939 $self->log(5,"mail $objp->{id} e$_ got no sig");
940 next;
941 }
942
943 unless ($self->{s}->{engines}->{$_}) {
944 # warn if cmd-lig sig check is not supported
945 $self->log(5,"mail $objp->{id} engine $_ is not supported, sig check skipped")
946 if ($sig && !$obj->{orig_mail});
947 next;
948 }
949
950 if (ref $sig) {
951 for (@$sig) {
952 $self->log(8,"mail $objp->{id} e$engine_save sig: $_");
953 }
954 } else {
955 $self->log(8,"mail $objp->{id} e$engine_save sig: $sig");
956 }
957
958 my $query = $self->make_query( {
959 action => 'check',
960 sig => $sig,
961 ep4 => $obj->{ep4},
962 eng => $_ } );
963
964 $valid++ if $query;
965 if (ref $query eq 'ARRAY') {
966 push @{$objp->{sent}}, @$query;
967 } else {
968 push @{$objp->{sent}}, $query;
969 }
970 }
971 }
972 }
973 unless ($valid) {
974 $self->log (5,"No queries, no spam");
975 return 1;
976 }
977
978 $self->{s}->{list} = $self->{s}->{catalogue};
979 $self->connect;
980
981 # Build query text strings
982 #
983 my $queries = $self->obj2queries($objects, 'check') or return $self->errprefix("check 1");
984
985 # send to server and store answers in mail obj
986 #
987 my $response = $self->_send($queries) or return $self->errprefix("check 2");
988 $self->queries2obj($objects, $response, 'check') or return $self->errprefix("check 3");
989
990
991 foreach my $obj (@$objects) {
992
993 # check_logic will parse response for each object, decide if its spam
994 #
995 $self->check_logic($obj);
996
997 $self->log (3,"mail $obj->{id} is ". ($obj->{spam} ? '' : 'not ') ."known spam.");
998 }
999 return 1;
1000}
1001
- -
1004sub check_logic {
1005 my ($self, $obj) = @_;
1006
1007 # default is not spam
1008 $obj->{spam} = 0;
1009 if ($obj->{skipme}) {
1010 next;
1011 }
1012
1013 #
1014 # Logic for Spam
1015 #
1016 #
1017 my $logic_method = $self->{conf}->{logic_method} || 4;
1018 my $logic_engines = $self->{conf}->{logic_engines} || 'any';
1019
1020 # cmd-line sig checks default to logic_method 1
1021 $logic_method = 1 unless $obj->{orig_mail};
1022
1023 my $leng;
1024 if ($logic_engines eq 'any') {
1025 $leng = ""; # not a hash ref, implies 'any' logic_engine
1026 } elsif ($logic_engines eq 'all') {
1027 $leng = $self->{s}->{engines};
1028 } elsif ($logic_engines =~ /^(\d\,)+$/) {
1029 $leng = {};
1030 foreach (split /,/,$logic_engines) {
1031 unless ($self->{s}->{engines}->{$_}) {
1032 $self->log(3, "logic_engine $_ not supported, skipping");
1033 next;
1034 }
1035 $leng->{$_} = 1;
1036 }
1037 } else {
1038 $self->log(3, "invalid logic_engines: $logic_engines, defaulting to 'any'");
1039 $leng = ""; # not a hash ref, implies 'any' logic_engine
1040 }
1041
1042
1043 # iterate through sent queries and responses,
1044 # perform engine analysis (logic_engines).
1045 #
1046 # engine 1 case
1047 my $sent = $obj->{e1}->{sent};
1048 my $resp = $obj->{e1}->{resp};
1049 if ($resp && $sent) {
1050 # if skipme, there would be no resp
1051 my $logmsg = "mail $obj->{id} e=1 sig=$sent->{s}";
1052 $obj->{e1}->{spam} = $self->check_resp($logmsg, $sent, $resp, $obj->{e1});
1053 }
1054 # all other engines for all parts
1055 foreach my $objp (@{$obj->{p}}) {
1056 $objp->{spam} = 0;
1057 if ($objp->{skipme}) {
1058 $self->log(8,"doh. $objp->{id} is skipped, yet has sent") if $objp->{sent};
1059 next;
1060 }
1061 next unless $objp->{sent};
1062 my $not_spam = 0;
1063 foreach (0..(scalar(@{$objp->{sent}}) - 1)) {
1064 $sent = $objp->{sent}->[$_];
1065 $resp = $objp->{resp}->[$_];
1066 unless ($resp) {
1067 $self->log(5,"doh. more sent queries than responses");
1068 next;
1069 }
1070 my $logmsg = "mail $objp->{id} e=$sent->{e} sig=$sent->{s}";
1071 my $is_spam = $self->check_resp($logmsg, $sent, $resp, $objp);
1072
1073 if (ref($leng)) {
1074 if ($leng->{$sent->{e}} && $is_spam) {
1075 $self->log(8,"logic_engines requires $sent->{e}, and it is. cool.");
1076 $objp->{spam} = 1;
1077 } elsif ($leng->{$sent->{e}} && !$is_spam) {
1078 $self->log(8,"logic_engines requires $sent->{e}, and it is not, part not spam");
1079 $not_spam = 1;
1080 } else {
1081 $self->log(8,"logic_engines doesn't care about $sent->{e}, skipping");
1082 }
1083 } else {
1084 # not a hash ref, implies 'any' logic_engine
1085 $objp->{spam} += $is_spam;
1086 }
1087 $objp->{spam} = 0 if $not_spam;
1088 }
1089 }
1090
1091 # mime part analysis (logic_methods)
1092 #
1093 if ($logic_method == 1) {
1094
1095 $obj->{spam} = 0;
1096 if ($obj->{e1}) {
1097 $obj->{spam} += $obj->{e1}->{spam} if $obj->{e1}->{spam};
1098 }
1099 foreach my $objp (@{$obj->{p}}) {
1100 $obj->{spam} += $objp->{spam} if $objp->{spam};
1101 }
1102
1103
1104 } elsif ($logic_method =~ /^(2|3)$/) {
1105 # logic_methods > 1
1106
1107 foreach my $objp (@{$obj->{p}}) {
1108 next if $objp->{skipme};
1109 next unless $objp->{body};
1110 my ($hdrs, $body) = split /\n\n/, ${$objp->{body}}, 2;
1111 $hdrs .= "\n";
1112
1113 #$self->log(8,"$objp->{id} hdrs:\n$hdrs");
1114 my $type = "<type unknown>";
1115 $objp->{is_text} = 0;
1116 $objp->{is_inline} = 0;
1117 $objp->{is_inline} = 1 if $hdrs =~ /Content-Disposition: inline/i;
1118 #$type = $1 if $hdrs =~ /Content-Type:\s([^\;\n]+)/i;
1119 $type = $1 if $hdrs =~ /Content-Type:\s([^\n]+)/i;
1120 $objp->{is_text} = 1 if $type =~ /text\//i;
1121 $objp->{is_text} = 1 if $type =~ /type unknown/; # assume text ?
1122
1123 $self->log(8,"mail $objp->{id} Type $objp->{is_text},$objp->{is_inline} $type");
1124 }
1125 }
1126
1127 if ($logic_method == 2) {
1128
1129 # in this method, only 1 dude decides if mail is spam. decider.
1130
1131 # the first part is the default decider. can be overwritten, tho.
1132 my $decider = $obj->{p}->[0];
1133
1134 # basically the first inline text/* becomes the decider.
1135 # however, if no inline, the first text/* is used
1136 my $found = 0;
1137 foreach my $objp (@{$obj->{p}}) {
1138 next if $objp->{skipme};
1139
1140 if ($objp->{is_inline} && $objp->{is_text}) {
1141 $decider = $objp;
1142 last;
1143 }
1144 if (!$found && $objp->{is_text}) {
1145 $decider = $objp;
1146 $found = 1;
1147 }
1148 }
1149 $self->log (7,"method 2: $decider->{id} is the spam decider");
1150 $obj->{spam} = $decider->{spam};
1151
1152 } elsif ($logic_method == 3) {
1153
1154 # in this method, all text/* parts must be spam for obj to be spam
1155 # non-text parts are ignored
1156
1157 my $found = 0;
1158 foreach my $objp (@{$obj->{p}}) {
1159 next if $objp->{skipme};
1160 next unless $objp->{is_text};
1161 $found = 1;
1162 $obj->{spam} = $objp->{spam};
1163 unless ($objp->{spam}) {
1164 $self->log (7,"method 3: $objp->{id} is_text but not spam, mail not spam");
1165 last;
1166 }
1167 }
1168 $self->log (7,"method 3: mail $obj->{id}: all is_text parts spam, mail spam") if $obj->{spam};
1169
1170 # if no parts where text, use the first part as spam indicator
1171 unless ($found) {
1172 $self->log (6,"method 3: mail $obj->{id}: no is_text, using part 1");
1173 $obj->{spam} = 1 if $obj->{p}->[0]->{spam};
1174 }
1175
1176 } elsif ($logic_method == 4) {
1177
1178 # in this method, if any non-contention parts is spam, mail obj is spam
1179 # contention parts are ignored.
1180
1181 $obj->{spam} = 0;
1182 foreach my $objp (@{$obj->{p}}) {
1183 next if $objp->{skipme};
1184 if ($objp->{ct}) {
1185 $self->log (7,"method 4: mail $objp->{id}: contention part, skipping");
1186 } else {
1187 $self->log (7,"method 4: mail $objp->{id}: no-contention part, spam=$objp->{spam}");
1188 $obj->{spam} = 1 if $objp->{spam};
1189 }
1190 }
1191 if ($obj->{spam}) {
1192 $self->log (7,"method 4: mail $obj->{id}: a non-contention part was spam, mail spam");
1193 } else {
1194 $self->log (7,"method 4: mail $obj->{id}: all non-contention parts not spam, mail not spam");
1195 }
1196
1197 } elsif ($logic_method == 5) {
1198
1199 # in this method, all non-contention parts must be spam for obj to be spam
1200 # contention parts are ignored.
1201
1202 my $not_spam = 0;
1203 my $is_spam = 0;
1204 foreach my $objp (@{$obj->{p}}) {
1205 next if $objp->{skipme};
1206 if ($objp->{ct}) {
1207 $self->log (7,"method 5: mail $objp->{id}: contention part, skipping");
1208 next;
1209 } else {
1210 $self->log (7,"method 5: mail $objp->{id}: no-contention part, spam=$objp->{spam}");
1211 }
1212 if ($objp->{spam}) {
1213 $is_spam = 1;
1214 } else {
1215 $not_spam = 1;
1216 }
1217 }
1218 if ($is_spam && !$not_spam) {
1219 $obj->{spam} = 1;
1220 $self->log (7,"method 5: mail $obj->{id}: all non-contention parts spam, mail spam");
1221 } else {
1222 $self->log (7,"method 5: mail $obj->{id}: a non-contention part not spam, mail not spam");
1223 $obj->{spam} = 0;
1224 }
1225
1226 }
1227 return 1;
1228}
1229
- -
1232# returns hash ref if successfully registered
1233# returns 0 if not
1234sub register {
1235 my ($self, $p,) = @_;
1236 my @queries;
1237
1238 my $registrar = $self->{name_version};
1239 my %qr = ( a => 'reg', registrar => $registrar );
1240 $qr{user} = $p->{user} if $p->{user};
1241 $qr{pass} = $p->{pass} if $p->{pass};
1242 $queries[0] = makesis(%qr);
1243
1244 $self->{s}->{list} = $self->{s}->{nomination};
1245 $self->connect;
1246
1247 my $response = $self->_send(\@queries) or return $self->errprefix("register");
1248
1249 my %resp = parsesis($$response[0]);
1250
1251 if ($resp{err} && $resp{err} eq '210') {
1252 if ($qr{user} && $qr{pass}) {
1253 my($creds) = { user => $qr{user}, pass => $qr{pass} };
1254 if ($self->authenticate($creds)) {
1255 $self->log(6, "Successfully registered provided credentials.\n");
1256 return $creds;
1257 }
1258 }
1259 return $self->error("Error $resp{err}: User exists. Try another name. aborting.\n")
1260 }
1261 return $self->error("Error $resp{err} while performing register, aborting.\n")
1262 if ($resp{err});
1263
1264 return $self->error("No success (res=$resp{res}) while performing register, aborting.\n")
1265 if ($resp{res} ne '1');
1266
1267 $self->log(6,"Successfully registered with $self->{s}->{ip} identity: $resp{user}");
1268
1269 # otherwise return hash containing 'user' and 'pass'
1270 delete $resp{res};
1271 return \%resp;
1272}
1273
1274
1275sub authenticate {
1276 my ($self, $options) = @_;
1277 my @queries;
1278
1279 unless (($options->{user} =~ /\S/) && ($options->{pass} =~ /\S/)) {
1280 return $self->error("authenticate did not get valid user + pass");
1281 }
1282
1283 my %qr = ( a => 'ai', user => $options->{user}, cn => 'razor-agents', cv => $Razor2::Client::Version::VERSION );
1284 $queries[0] = makesis(%qr);
1285
1286 $self->{s}->{list} = $self->{s}->{nomination};
1287 $self->connect;
1288
1289 my $response = $self->_send(\@queries) or return $self->errprefix("authenticate 1");
1290
1291 my %resp = parsesis($$response[0]);
1292 if ($resp{err}) {
1293 if (($resp{err} eq '213') && !defined($self->{reregistered})) {
1294 # 213 = unknown user.
1295 # Try to register with current user+pass and continue with authenticate
1296 $self->log (8,"unknown user, attempting to re-register");
1297
1298 my $id = $self->register($options);
1299 $self->{reregistered} = 1;
1300 if (($id->{user} eq $options->{user}) &&
1301 ($id->{pass} eq $options->{pass})) {
1302 $self->log (5,"re-registered user $id->{user} with $self->{s}->{ip}");
1303 return $self->authenticate($options);
1304 } else {
1305 return $self->error("Error 213 while authenticating, aborting.\n")
1306 }
1307 } else {
1308 return $self->error("Error $resp{err} while authenticating, aborting.\n")
1309 }
1310 }
1311 my ($iv1, $iv2) = xor_key($options->{pass});
1312 my ($my_digest) = hmac_sha1($resp{achal}, $iv1, $iv2);
1313
1314 %qr = ( a => 'auth', aresp => $my_digest );
1315 $queries[0] = makesis(%qr);
1316
1317 $response = $self->_send(\@queries) or return $self->errprefix("authenticate 2");
1318
1319 %resp = parsesis($$response[0]);
1320 return $self->error("Error $resp{err} while authenticating, aborting.\n") if ($resp{err});
1321 return $self->error("Authentication failed for user=$options->{user}")
1322 if ($resp{res} ne '1');
1323
1324 $self->log (5,"Authenticated user=$options->{user}");
1325 $self->{authenticated} = 1;
1326 return 1;
1327}
1328
1329
1330#
1331# handles report and revoke
1332#
1333sub report {
1334
1335 my ($self, $objs) = @_;
1336 return $self->error("report: Not Authenticated") unless $self->{authenticated};
1337
1338 return $self->error("report/revoke for engine 1 not supported")
1339 if ($self->{s}->{conf}->{dre} == 1);
1340
1341 $self->{s}->{list} = $self->{s}->{nomination};
1342 $self->connect;
1343
1344 my @robjs;
1345 my $valid = 0;
1346 if ($self->{breed} eq 'report') {
1347
1348 #
1349 # Before reporting entire email, check to see if server already has it
1350 #
1351
1352 unless ($self->{s}->{conf}->{dre}) {
1353 $self->logobj(8,"server has no default dre, using 4", $self->{s}->{conf});
1354 $self->{s}->{conf}->{dre} = 4;
1355 }
1356
1357 foreach my $obj (@$objs) {
1358 next if $obj->{skipme};
1359
1360 # handle special case for engine 1
1361 # note: razor 1 does not store emails in its db, just sigs.
1362 # so we should never get a res=230 for e=1 a=r sig=xxx
1363 #
1364 #$obj->{e1}->{sent} = $self->make_query( {
1365 # action => 'rcheck',
1366 # sig => $obj->{e1}->{e1},
1367 # eng => 1, } );
1368 #$valid++ if $obj->{e1}->{sent};
1369
1370 # rest of engines and mime parts
1371 foreach my $objp (@{$obj->{p}}) {
1372
1373 if ($objp->{skipme}) {
1374 $self->log(13,"mail $objp->{id} skipped in report");
1375 next;
1376 }
1377 my $q = $self->make_query( {
1378 action => 'rcheck',
1379 sig => $objp->{"e$self->{s}->{conf}->{dre}"},
1380 ep4 => $obj->{ep4},
1381 eng => $self->{s}->{conf}->{dre}, } );
1382 $objp->{sent} = [$q];
1383 $valid++;
1384 }
1385 }
1386 unless ($valid) {
1387 $self->log (5,"No report check queries, no spam");
1388 return 1;
1389 }
1390 $valid = 0;
1391
1392
1393 # Build query text strings - signatures computed already (see reportit)
1394 my $queries = $self->obj2queries($objs,'rcheck') or return $self->errprefix("report1");
1395
1396 # send to server and store answers in mail obj
1397 my $response = $self->_send($queries) or return $self->errprefix("report2");
1398 $self->queries2obj($objs, $response, 'rcheck') or return $self->errprefix("report3");
1399
1400
1401 #
1402 # If server wants email or certain body parts,
1403 # create new {sent} and add obj to @robjs
1404 #
1405 foreach my $obj (@$objs) {
1406
1407 next if $obj->{skipme};
1408
1409 #$self->log(12,"mail $obj->{id} read ". scalar(@{$obj->{resp}}) ." queries");
1410 # handle engine 1 special case
1411 #if ( !$obj->{e1}->{skipme} && $self->rcheck_resp(
1412 # "mail ". $obj->{id} .", orig_email, special case eng 1",
1413 # $obj->{e1}->{sent},
1414 # $obj->{e1}->{resp}
1415 # ) ) {
1416 # $self->log(5,"doh. Server should not send res=230 for eng=1 report");
1417 #}
1418 #delete $obj->{e1}->{sent};
1419
1420 my $wants_orig_mail = 0;
1421 foreach my $objp (@{$obj->{p}}) {
1422 next if $objp->{skipme};
1423
1424 $self->logobj(14,"checking response for $objp->{id}", $objp);
1425 unless ( $self->rcheck_resp(
1426 "mail $objp->{id}, eng $self->{s}->{conf}->{dre}",
1427 $objp->{sent}->[0], $objp->{resp}->[0] )) {
1428 $objp->{skipme} = 1;
1429 } else {
1430 $wants_orig_mail++;
1431 }
1432 $objp->{resp} = []; # clear responses from rcheck
1433 $objp->{sent} = [];
1434 }
1435 if ($wants_orig_mail) {
1436 # reports are special, all parts need to be together, so use part 0's sent
1437 my $objp = $obj->{p}->[0];
1438 $objp->{skipme} = 0 if $objp->{skipme};
1439 push @{$objp->{sent}}, $self->make_query( {
1440 action => 'report',
1441 obj => $obj,
1442 } );
1443 push @robjs, $obj;
1444 }
1445 $valid += $wants_orig_mail;
1446 }
1447
1448 } else { # revoke
1449
1450 foreach my $obj (@$objs) {
1451 # don't revoke eng 1
1452
1453 # engines > 1 we send all the body parts, use part 0 to store sent
1454 my $objp = $obj->{p}->[0];
1455 $objp->{sent} = [];
1456
1457 push @{$objp->{sent}}, $self->make_query( {
1458 action => 'revoke',
1459 obj => $obj,
1460 } );
1461 $valid++ if scalar(@{$objp->{sent}});
1462 $self->log (9,"revoke sent:". scalar(@{$objp->{sent}}));
1463 push @robjs, $obj;
1464 }
1465
1466 }
1467
1468 unless ($valid && scalar(@robjs)) {
1469 $self->log (3,"Finished $self->{breed}.");
1470 return 1;
1471 }
1472
1473 #$self->logobj(14,"report objs", \@robjs);
1474
1475 #
1476 # send server mails/body parts either
1477 # revoked, or requested if reporting
1478 #
1479 my $queries = $self->obj2queries( \@robjs,$self->{breed}) or return $self->errprefix("report4");
1480 my $response = $self->_send( $queries ) or return $self->errprefix("report5");
1481 $self->queries2obj( \@robjs, $response,$self->{breed}) or return $self->errprefix("report6");
1482
1483 # we just do this to log server's response
1484 #
1485 foreach my $obj (@robjs) {
1486 my $objp = $obj->{p}->[0];
1487 my $cur = -1;
1488 while ($objp->{sent}->[++$cur]) {
1489 $self->rcheck_resp(
1490 "$self->{breed}: mail $obj->{id}, $cur",
1491 $objp->{sent}->[$cur],
1492 $objp->{resp}->[$cur] ) unless ($objp->{skipme});
1493 }
1494 }
1495 $self->logobj(14,"report objs", \@robjs);
1496 $self->log (3,"Sent $self->{breed}.");
1497 return 1;
1498
1499}
1500
- -
1503sub _send {
1504 my ($self, $msg, $closesock, $skipread) = @_;
1505 $self->log (16,"entered _send");
1506
1507 unless ($self->{connected_to}) {
1508 $self->connect() or return $self->errprefix("_send");
1509 }
1510
1511 my @response;
1512 my $select = $self->{select};
1513 my $sock = ($select->handles)[0];
1514 $self->{sent_cnt} = 0 unless $self->{sent_cnt};
1515 foreach my $i (0 .. ((scalar @$msg) -1) ) {
1516 my @handles = $select->can_write (15);
1517 if ($handles[0]) {
1518 $self->log (4,"$self->{connected_to} << ". length($$msg[$i]) );
1519 if ($$msg[$i] =~ /message/) {
1520 my $line = debugobj($$msg[$i]);
1521 $self->log (6, $line );
1522 $self->log2file(16, \$$msg[$i], "sent_to.". $self->{sent_cnt});
1523 } else {
1524 $self->log (6, $$msg[$i] );
1525 }
1526 local $\;
1527 undef $\;
1528 print $sock $$msg[$i];
1529 $self->{sent_cnt}++;
1530 } else {
1531 return $self->error("Timed out (15 sec) while writing to $self->{s}->{ip}");
1532 }
1533 next if $skipread;
1534 @handles = $select->can_read (15);
1535 if ($sock=$handles[0]) {
1536 local $/;
1537 undef $/;
1538 $response[$i] = $self->_read($sock) or return $self->error("Error reading socket");
1539 $self->log (4,"$self->{connected_to} >> ". length($response[$i]) );
1540 $self->log (6,"response to sent.$self->{sent_cnt}\n". $response[$i]);
1541 } else {
1542 return $self->error("Timed out (15 sec) while reading from $self->{s}->{ip}");
1543 }
1544 }
1545 if ($closesock) {
1546 $select->remove($sock);
1547 close $sock;
1548 }
1549 return \@response;
1550}
1551
1552
1553sub _read {
1554 my ($self, $socket) = @_;
1555 my ($query, $read);
1556
1557 # fixme - need to trim this down (copied from server)
1558 #
1559
1560 unless ($read = sysread($socket, $query, 1024)) {
1561
1562 # There was an error on sysread(), could be a real error or a
1563 # blocking error.
1564
1565 if ($! == EWOULDBLOCK) {
1566 # write would block, so we try again later
1567 $self->debug ("_read: EWOULDBLOCK");
1568 return;
1569 } elsif ($! == EINTR or $! == EIO) {
1570 # sysread() got interupted by a signal.
1571 # we will process this socket on next wheelwalk.
1572 $self->debug ("_read: EINTR");
1573 return;
1574 } elsif ($! == EPIPE or $! == EISDIR or $! == EBADF or $! == EINVAL or $! == EFAULT) {
1575 $self->debug ("_read: EPIPE");
1576 return;
1577 } else {
1578 # This happens when client breaks the connection.
1579 # Find out why we don't get an EPIPE instead. FIX!
1580 $self->debug ("_read: connection_closed");
1581 return;
1582 }
1583 }
1584
1585 if ($read > 0) {
1586
1587 # Now we are absolutely sure there is data on the socket.
1588
1589 return $query;
1590
1591 } else {
1592
1593 # Otherwise we got an EOF, expire the socket
1594
1595 $self->debug ("_read: EOF, connection_closed");
1596 return;
1597
1598 }
1599}
1600
- -
1603sub connect {
1604 my ($self, %params) = @_;
1605 my $sock;
1606 $self->log (16,"entered connect");
1607
1608 if ($self->{simulate}) {
1609 return $self->error ("Razor Error 4: This is a simulation. Won't connect to $self->{s}->{ip}.");
1610 }
1611
1612 my $server = $params{server} || $self->{s}->{ip};
1613
1614 unless ($self->{s}->{ip}) {
1615 $self->{s}->{ip} = $server;
1616 }
1617
1618 if ($self->{sock} && $self->{connected_to}) {
1619 unless ($server) {
1620 $self->log (13,"no server specified, using already connected server $self->{connected_to}");
1621 return 1;
1622 }
1623 if ($server eq $self->{connected_to}) {
1624 $self->log (15,"already connected to server $self->{connected_to}");
1625 return 1;
1626 }
1627 return 1 if $self->{disconnecting};
1628 $self->log(6,"losing old server connection, $self->{connected_to}, for new server, $server");
1629 $self->disconnect;
1630 }
1631 unless ($server) {
1632 $self->log (6,"no server specified, not connecting");
1633 return;
1634 }
1635
1636 my $port = $params{port} || $self->{s}->{port};
1637 unless (defined($port) && $port =~ /^\d+$/) {
1638 my $portlog = defined($port) ? " ($port)" : "";
1639 $self->log (6, "No port specified$portlog, using 2703"); # bootstrap_discovery will come here
1640 $port = 2703;
1641 }
1642 $self->log (5,"Connecting to $server ...");
1643 if (my $proxy = $self->{conf}->{proxy}) {
1644 #
1645 # Proxy stuff never been tested
1646 #
1647 $proxy =~ s!^http://!!;
1648 $proxy =~ s!:(\d+)/?$!!;
1649 my $pport = $1 || 80;
1650 $self->debug ("HTTP tunneling through $proxy:$pport.");
1651 $sock = IO::Socket::INET->new(
1652 PeerAddr => $proxy,
1653 PeerPort => $pport,
1654 Proto => 'tcp',
1655 Timeout => 20,
1656 );
1657 unless ( $sock ) {
1658 $self->debug ("Unable to connect to proxy $proxy:$pport; Reason: $!.");
1659 } else {
1660 $sock->printf( "CONNECT %s:%d HTTP/1.0\r\n\r\n", $server, $port );
1661 if( $sock->getline =~ m!^HTTP/1\.\d+ 200 ! ){
1662 # Skip through remaining part of MIME header.
1663 while( $sock->getline !~ m!^\r! ){ ; }
1664 } else {
1665 $self->log (4, "HTTP tunneling is disabled at $proxy.");
1666 $sock = undef;
1667 }
1668 }
1669 }
1670
1671 # if proxy, we already might have a $sock.
1672 # if proxy failed to connect, try without proxy.
1673 #
1674
1675 if ($self->{conf}->{socks_server}) {
1676
1677 my $socks_module = "Net::SOCKS";
1678 eval "require $socks_module";
1679
1680 $self->log(6, "Will try to connect through the SOCKS server on $$self{conf}{socks_server}...");
1681
1682 my $socks_sock = Net::SOCKS->new (
1683 socks_addr => $$self{conf}{socks_server},
1684 socks_port => 1080,
1685 protocol_version => 4
1686 );
1687
1688 if ($socks_sock) {
1689
1690 $sock = $socks_sock->connect(peer_addr => $server, peer_port => $port);
1691 if ($sock) {
1692 $self->log(6, "Connected to $server via SOCKS server $$self{conf}{socks_server}.");
1693 }
1694
1695 }
1696
1697 }
1698
1699
1700 unless ($sock) {
1701 $sock = IO::Socket::INET->new(
1702 PeerAddr => $server,
1703 PeerPort => $port,
1704 Proto => 'tcp',
1705 Timeout => 20,
1706 );
1707 unless ( $sock ) {
1708 $self->log (3,"Unable to connect to $server:$port; Reason: $!.");
1709 return if $params{discovery_server};
1710 $self->nextserver or do { return $self->errprefix("connect1"); };
1711 return $self->connect;
1712 }
1713 }
1714
1715 my $select = new IO::Select ($sock);
1716 my @handles = $select->can_read (15);
1717 if ($handles[0]) {
1718 $self->log (8,"Connection established");
1719 my $greeting = <$sock>;
1720 # $sock->autoflush; # this is on by default as of IO::Socket 1.18
1721 $self->{sock} = $sock;
1722 $self->{connected_to} = $server;
1723 $self->{select} = $select;
1724 $self->log(4,"$server >> ". length($greeting) ." server greeting: $greeting");
1725
1726 return 1 if $params{discovery_server};
1727 unless ($self->parse_greeting($greeting) ) {
1728 $self->nextserver or return $self->errprefix("connect2");
1729 return $self->connect;
1730 }
1731 return 1;
1732 } else {
1733 $self->log (3, "Timed out (15 sec) while reading from $self->{s}->{ip}.");
1734 $select->remove($sock);
1735 $sock->close();
1736 return $self->errprefix("connect3") if $params{skip_greeting};
1737 $self->nextserver or return $self->errprefix("connect4");
1738 return $self->connect;
1739 }
1740}
1741
1742sub disconnect {
1743 my $self = shift;
1744
1745 unless ($self->{sock}) {
1746 $self->log (5,"already disconnected from server ". $self->{connected_to});
1747 return 1;
1748 }
1749
1750 $self->log (5,"disconnecting from server ". $self->{connected_to});
1751
1752 $self->{disconnecting} = 1;
1753 $self->_send(["a=q\r\n"], 0, 1);
1754 delete $self->{disconnecting};
1755
1756 delete $self->{sock}; # _send closes socket
1757
1758
1759 return 1;
1760}
1761
1762
1763sub parse_greeting {
1764 my ($self, $greeting) = @_;
1765 $self->log (16,"entered parse_greeting($greeting)");
1766
1767 my %server_greeting = parsesis($greeting);
1768 $self->{s}->{greeting} = \%server_greeting;
1769
1770 unless ($self->{s}->{greeting} && $self->{s}->{greeting}->{sn}) {
1771 $self->log(1,"Couldn't parse server greeting\n");
1772 return;
1773 }
1774
1775 # server greeting must contain: sn, srl
1776 # server greeting may contain: ep4, redirect, a,
1777
1778 #
1779 # fixme - add support for redirect, etc.
1780 #
1781
1782 #
1783 # current server config info is stored in $self->{s}->{conf}
1784 # see nextserver for more info
1785 #
1786 # If server greeting says there are new values
1787 # (which we know if greeting's srl > conf's srl)
1788 # we ask server for new values, update conf, then
1789 # put that server on modified list so it gets recorded to disk
1790 #
1791 # fixme - in the future, we could have a key with no value
1792 # in .conf file - forcing client to ask server 'a=g&pm=key'
1793 #
1794
1795 if ($self->{s}->{greeting}->{a} eq 'cg') {
1796 my $version = $Razor2::Client::Version::VERSION;
1797 my @cg = ("cn=razor-agents&cv=$version\r\n");
1798 $self->_send(\@cg, 0, 1);
1799 }
1800
1801 if (defined($self->{s}->{greeting}->{srl}) &&
1802 defined($self->{s}->{conf}->{srl}) &&
1803 $self->{s}->{greeting}->{srl} <= $self->{s}->{conf}->{srl}) {
1804
1805 $self->compute_server_conf;
1806 return 1 ;
1807 }
1808
1809 # srl > our cached srl, request update (a=g&pm=state)
1810 # and rediscover
1811 #
1812
1813 my @queries = ("a=g&pm=state\r\n");
1814
1815 my $response = $self->_send(\@queries) or return $self->errprefix("parse_greeting");
1816
1817 # should be just one response
1818 # from_batched_query wants "-" in beginning, but not ".\r\n" at end
1819 $response->[0] =~ s/\.\r\n$//sg;
1820 my $h = from_batched_query($response->[0], {});
1821
1822 foreach my $href (@$h) {
1823 foreach (sort keys %$href) {
1824 $self->{s}->{conf}->{$_} = $href->{$_};
1825 #$self->log(8,"updated: $_=$href->{$_}");
1826 }
1827 }
1828 $self->log(1,"Bad info while trying to get server state (a=g&pm=state)")
1829 unless scalar(@$h);
1830
1831 $self->{s}->{conf}->{srl} = $self->{s}->{greeting}->{srl};
1832 push @{$self->{s}->{modified}}, $self->{s}->{ip};
1833 $self->{s}->{allconfs}->{$self->{s}->{ip}} = $self->{s}->{conf}; # in case new server
1834
1835 # now we're up to date
1836 $self->log(5,"Updated to new server state srl ". $self->{s}->{conf}->{srl}
1837 ." for server ". $self->{s}->{ip});
1838
1839 $self->compute_server_conf();
1840 $self->writeservers; # writes to disk servers listed in $self->{s}->{modified}
1841
1842 $self->log(5,"srl was updated, forcing discovery ...");
1843 $self->{done_discovery} = 0;
1844 $self->{force_discovery} = 1;
1845 $self->discover();
1846
1847 return 1;
1848}
1849
1850
1851# Returns engines supported
1852#
1853# can be called with no paramaters or
1854# with hash of server supported engines
1855sub compute_supported_engines {
1856 my ($self, $orig) = @_;
1857
1858 my %all;
1859 my $se = $self->supported_engines(); # local supported engines
1860 foreach (@{$self->{conf}->{use_engines}}) {
1861 if ($orig) {
1862 $all{$_} = 1 if (exists $se->{$_}) && (exists $orig->{$_});
1863 } else {
1864 $all{$_} = 1 if exists $se->{$_};
1865 }
1866 }
1867 if ($orig) {
1868 $self->log(8, "Computed supported_engines: ". join(' ', sort(keys %all)) );
1869 } else {
1870 $self->log(8, "Client supported_engines: ". join(' ', sort(keys %all)) );
1871 }
1872 return \%all;
1873}
1874
1875
1876# called when we need to parse server conf
1877# - after initial parse_greeting
1878# - if state (srl) changes
1879# - when we switch to cached server conf info in nextserver
1880#
1881sub compute_server_conf {
1882 my ($self, $cached) = @_;
1883
1884 #
1885 # compute a confindence (cf) from razor-agent.conf's 'min_cf'
1886 # and server's average confidence (ac)
1887 #
1888 # min_cf can be 'n', 'ac', 'ac + n', or 'ac - n'
1889 # where 'n' can be 1..100
1890 #
1891 my $cf = $self->{s}->{conf}->{ac}; # default is server's ac
1892 my $min_cf = $self->{conf}->{min_cf};
1893 $min_cf =~ s/\s//g;
1894
1895 if ($min_cf =~ /^ac\+(\d+)$/) {
1896 $cf = $self->{s}->{conf}->{ac} + $1;
1897
1898 } elsif ($min_cf =~ /^ac-(\d+)$/) {
1899 $cf = $self->{s}->{conf}->{ac} - $1;
1900
1901 } elsif ($min_cf =~ /^ac$/) {
1902 $cf = $self->{s}->{conf}->{ac};
1903
1904 } elsif ($min_cf =~ /^(\d+)$/) {
1905 $cf = $min_cf;
1906 } else {
1907 $self->log(5,"Invalid min_cf $self->{conf}->{min_cf}");
1908 }
1909 $cf = 100 if $cf > 100;
1910 $cf = 0 if $cf < 0;
1911 $self->{s}->{min_cf} = $cf;
1912
1913 #
1914 # ep4 - special for vr4
1915 #
1916 $self->{s}->{conf}->{ep4} = $self->{s}->{greeting}->{ep4}
1917 if $self->{s}->{greeting}->{ep4};
1918
1919 my $info = $cached ? $self->{s}->{conf} : $self->{s}->{greeting};
1920 my $name = "Unknown-Type: ";
1921 if ($info->{sn}) {
1922 $name .= $info->{sn};
1923 $name = "Nomination" if $info->{sn} =~ /N/;
1924 $name = "Catalogue" if $info->{sn} =~ /C/;
1925 $name = "Catalogue" if $info->{sn} =~ /S/;
1926 $name = "Discovery" if $info->{sn} =~ /D/;
1927 }
1928 $self->log (6, $self->{s}->{ip} ." is a $name Server srl ".
1929 $self->{s}->{conf}->{srl} ."; computed min_cf=$cf, Server se: $self->{s}->{conf}->{se}");
1930
1931 #
1932 # Supported Engines - greeting contains hex of bits
1933 # we turn into a hash so we can just quickly do
1934 # do_eng3_stuff if $self->{s}->{engines}->{3};
1935 #
1936
1937 # if we're just computing hashes locally, ignore what engines server currently supports
1938 # fixme - this prolly should be done somewhere else
1939 if ($self->{opt}->{printhash}) {
1940 $self->log (6, "Ignore what engines server supports for -H");
1941 $self->{s}->{engines} = $self->compute_supported_engines();
1942 } else {
1943 my $se = hexbits2hash($self->{s}->{conf}->{se});
1944 $self->{s}->{engines} = $self->compute_supported_engines($se);
1945 }
1946}
1947
1948
1949# sub log2file moved to Agent.pm
1950
1951
1952sub debug {
1953 my ($self, $message) = @_;
1954 $self->log(5,$message);
1955}
1956
1957
1958sub DESTROY {
1959 my $self = shift;
1960 #$self->debug ("Agent terminated");
1961}
1962
1963
1964sub zonename {
1965 my ($zone, $type) = @_;
1966 my ($sub, $dom) = split /\./, $zone, 2;
1967 return "$sub-$type.$dom";
1968}
1969
1970
1971121µs1;
1972
1973
 
# spent 26µs within Razor2::Client::Core::CORE:match which was called: # once (26µs+0s) by base::import at line 32
sub Razor2::Client::Core::CORE:match; # opcode
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.