← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 02:36:06 2017
Reported on Sun Nov 5 02:56:20 2017

Filename/usr/local/lib/perl5/site_perl/mach/5.24/Razor2/Client/Agent.pm
StatementsExecuted 27 statements in 13.4ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11111.1ms32.0msRazor2::Client::Agent::::BEGIN@18Razor2::Client::Agent::BEGIN@18
1112.12ms6.87msRazor2::Client::Agent::::BEGIN@16Razor2::Client::Agent::BEGIN@16
11149µs266µsRazor2::Client::Agent::::BEGIN@13Razor2::Client::Agent::BEGIN@13
11137µs107µsRazor2::Client::Agent::::BEGIN@22Razor2::Client::Agent::BEGIN@22
11136µs522µsRazor2::Client::Agent::::BEGIN@15Razor2::Client::Agent::BEGIN@15
11134µs147µsRazor2::Client::Agent::::BEGIN@26Razor2::Client::Agent::BEGIN@26
11133µs96.9msRazor2::Client::Agent::::BEGIN@20Razor2::Client::Agent::BEGIN@20
11130µs84µsRazor2::Client::Agent::::BEGIN@23Razor2::Client::Agent::BEGIN@23
11129µs13.1msRazor2::Client::Agent::::BEGIN@21Razor2::Client::Agent::BEGIN@21
11128µs173µsRazor2::Client::Agent::::BEGIN@25Razor2::Client::Agent::BEGIN@25
11124µs38µsRazor2::Client::Agent::::BEGIN@14Razor2::Client::Agent::BEGIN@14
11117µs17µsRazor2::Client::Agent::::BEGIN@24Razor2::Client::Agent::BEGIN@24
0000s0sRazor2::Client::Agent::::_helpRazor2::Client::Agent::_help
0000s0sRazor2::Client::Agent::::adminitRazor2::Client::Agent::adminit
0000s0sRazor2::Client::Agent::::checkitRazor2::Client::Agent::checkit
0000s0sRazor2::Client::Agent::::create_home_confRazor2::Client::Agent::create_home_conf
0000s0sRazor2::Client::Agent::::do_confRazor2::Client::Agent::do_conf
0000s0sRazor2::Client::Agent::::doitRazor2::Client::Agent::doit
0000s0sRazor2::Client::Agent::::get_server_infoRazor2::Client::Agent::get_server_info
0000s0sRazor2::Client::Agent::::loadservercacheRazor2::Client::Agent::loadservercache
0000s0sRazor2::Client::Agent::::local_checkRazor2::Client::Agent::local_check
0000s0sRazor2::Client::Agent::::logRazor2::Client::Agent::log
0000s0sRazor2::Client::Agent::::log2fileRazor2::Client::Agent::log2file
0000s0sRazor2::Client::Agent::::logerrRazor2::Client::Agent::logerr
0000s0sRazor2::Client::Agent::::logllRazor2::Client::Agent::logll
0000s0sRazor2::Client::Agent::::newRazor2::Client::Agent::new
0000s0sRazor2::Client::Agent::::parse_mboxRazor2::Client::Agent::parse_mbox
0000s0sRazor2::Client::Agent::::raise_errorRazor2::Client::Agent::raise_error
0000s0sRazor2::Client::Agent::::read_optionsRazor2::Client::Agent::read_options
0000s0sRazor2::Client::Agent::::read_whitelistRazor2::Client::Agent::read_whitelist
0000s0sRazor2::Client::Agent::::readserversRazor2::Client::Agent::readservers
0000s0sRazor2::Client::Agent::::registeritRazor2::Client::Agent::registerit
0000s0sRazor2::Client::Agent::::reportitRazor2::Client::Agent::reportit
0000s0sRazor2::Client::Agent::::writeserversRazor2::Client::Agent::writeservers
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::Agent -- UI routines for razor agents.
4##
5## Copyright (c) 2002, 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: Agent.pm,v 1.98 2006/10/18 06:15:08 rsoderberg Exp $
10
11package Razor2::Client::Agent;
12
13266µs2482µs
# spent 266µs (49+217) within Razor2::Client::Agent::BEGIN@13 which was called: # once (49µs+217µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 13
use lib qw(lib);
# spent 266µs making 1 call to Razor2::Client::Agent::BEGIN@13 # spent 217µs making 1 call to lib::import
142102µs252µs
# spent 38µs (24+14) within Razor2::Client::Agent::BEGIN@14 which was called: # once (24µs+14µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 14
use strict;
# spent 38µs making 1 call to Razor2::Client::Agent::BEGIN@14 # spent 14µs making 1 call to strict::import
15285µs21.01ms
# spent 522µs (36+485) within Razor2::Client::Agent::BEGIN@15 which was called: # once (36µs+485µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 15
use Getopt::Long;
# spent 522µs making 1 call to Razor2::Client::Agent::BEGIN@15 # spent 485µs making 1 call to Getopt::Long::import
162547µs27.77ms
# spent 6.87ms (2.12+4.75) within Razor2::Client::Agent::BEGIN@16 which was called: # once (2.12ms+4.75ms) by Mail::SpamAssassin::Plugin::Razor2::new at line 16
use IO::File;
# spent 6.87ms making 1 call to Razor2::Client::Agent::BEGIN@16 # spent 902µs making 1 call to Exporter::import
17
182366µs232.4ms
# spent 32.0ms (11.1+20.9) within Razor2::Client::Agent::BEGIN@18 which was called: # once (11.1ms+20.9ms) by Mail::SpamAssassin::Plugin::Razor2::new at line 18
use Razor2::String qw(fisher_yates_shuffle);
# spent 32.0ms making 1 call to Razor2::Client::Agent::BEGIN@18 # spent 419µs making 1 call to Exporter::import
19
202118µs2194ms
# spent 96.9ms (33µs+96.9) within Razor2::Client::Agent::BEGIN@20 which was called: # once (33µs+96.9ms) by Mail::SpamAssassin::Plugin::Razor2::new at line 20
use base qw(Razor2::Client::Core);
# spent 96.9ms making 1 call to Razor2::Client::Agent::BEGIN@20 # spent 96.9ms making 1 call to base::import
21296µs226.2ms
# spent 13.1ms (29µs+13.1) within Razor2::Client::Agent::BEGIN@21 which was called: # once (29µs+13.1ms) by Mail::SpamAssassin::Plugin::Razor2::new at line 21
use base qw(Razor2::Client::Config);
# spent 13.1ms making 1 call to Razor2::Client::Agent::BEGIN@21 # spent 13.1ms making 1 call to base::import
22280µs2177µs
# spent 107µs (37+70) within Razor2::Client::Agent::BEGIN@22 which was called: # once (37µs+70µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 22
use base qw(Razor2::Logger);
# spent 107µs making 1 call to Razor2::Client::Agent::BEGIN@22 # spent 70µs making 1 call to base::import
23266µs2137µs
# spent 84µs (30+54) within Razor2::Client::Agent::BEGIN@23 which was called: # once (30µs+54µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 23
use base qw(Razor2::String);
# spent 84µs making 1 call to Razor2::Client::Agent::BEGIN@23 # spent 54µs making 1 call to base::import
24272µs117µs
# spent 17µs within Razor2::Client::Agent::BEGIN@24 which was called: # once (17µs+0s) by Mail::SpamAssassin::Plugin::Razor2::new at line 24
use Razor2::Preproc::Manager;
# spent 17µs making 1 call to Razor2::Client::Agent::BEGIN@24
25292µs2318µs
# spent 173µs (28+145) within Razor2::Client::Agent::BEGIN@25 which was called: # once (28µs+145µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 25
use Data::Dumper;
# spent 173µs making 1 call to Razor2::Client::Agent::BEGIN@25 # spent 145µs making 1 call to Exporter::import
26211.7ms2261µs
# spent 147µs (34+113) within Razor2::Client::Agent::BEGIN@26 which was called: # once (34µs+113µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 26
use vars qw( $VERSION $PROTOCOL );
# spent 147µs making 1 call to Razor2::Client::Agent::BEGIN@26 # spent 113µs making 1 call to vars::import
27
28
2912µs$PROTOCOL = $Razor2::Client::Version::PROTOCOL;
3016µs$VERSION = $Razor2::Client::Version::VERSION;
31
- -
34sub new {
35 my ($class, $breed) = @_;
36
37 # For Taint Friendliness
38 delete $ENV{PATH};
39 delete $ENV{BASH_ENV};
40
41 my @valid_program_names = qw(
42 razor-check
43 razor-report
44 razor-revoke
45 razor-admin
46 );
47
48 my $ok = 0;
49 foreach (@valid_program_names) { $breed =~ /$_$/ and $ok = $_; }
50 unless ($ok) {
51 if ($breed =~ /razor-client$/) {
52 # We no longer create symlinks, but for backwards compatibility
53 # return success.
54 exit 0;
55 }
56 die "Invalid program name, must be one of: @valid_program_names\n";
57 }
58
59 $ok =~ /razor-(.*)$/;
60 my %me = (
61 name_version => "Razor-Agents v$VERSION", # used in register
62 breed => $1,
63 preproc => new Razor2::Preproc::Manager (no_deHTMLcomment => 1),
64 preproc_vr8 => new Razor2::Preproc::Manager (no_deHTML => 1),
65 global_razorhome => '/usr/local/etc',
66 );
67
68
69 return bless \%me, $class;
70}
71
72sub do_conf {
73 my $self = shift;
74
75 # parse config-related cmd-line args
76 #
77
78 # identity is parsed later after razorhome is fully resolved
79
80 if ($self->{opt}->{config}) {
81 if ($self->{opt}->{create_conf}) {
82 $self->{razorconf} = $self->{opt}->{config};
83 } elsif (-r $self->{opt}->{config}) {
84 $self->{razorconf} = $self->{opt}->{config};
85 } else {
86 return $self->error("Can't read conf file: $self->{opt}->{config}")
87 }
88 }
89 if ($self->{opt}->{razorhome}) {
90 if (-d $self->{opt}->{razorhome}) {
91 $self->{razorhome} = $self->{opt}->{razorhome};
92 } else {
93 return $self->error("Can't read: $self->{opt}->{razorhome}")
94 unless $self->{opt}->{create_conf};
95 }
96 # once razorhome is successfully overridden, override the global razorhome as well.
97 $self->{global_razorhome} = $self->{razorhome};
98 }
99 return unless $self->read_conf();
100
101 if ($self->{opt}->{create_conf}) {
102 $self->{force_discovery} = 1;
103 $self->{force_bootstrap_discovery} = 1;
104 $self->log(8," -create will force complete discovery");
105 }
106 if ($self->{opt}->{force_discovery}) {
107 $self->{force_discovery} = 1;
108 $self->{force_bootstrap_discovery} = 1;
109 $self->log(8," -discover will force complete discovery");
110 }
111 if ($self->{opt}->{debug} && !$self->{opt}->{debuglevel}) {
112 $self->{conf}->{debuglevel} ||= 9;
113 $self->{conf}->{debuglevel} = 9 if $self->{conf}->{debuglevel} < 9;
114 }
115
116
117 #
118 # Note: we start logging before we process '-create' ,
119 # so logfile will not go into a newly created razorhome
120 #
121 #my $logto = $self->{opt}->{debug} ? "stdout" : "file:$self->{conf}->{logfile}";
122 my $logto;
123 if ($self->{opt}->{debug}) {
124 $logto = 'stdout';
125 } elsif ($self->{conf}->{logfile} eq 'syslog') {
126 $logto = 'syslog';
127 } elsif ($self->{conf}->{logfile} eq 'sys-syslog') {
128 $logto = 'sys-syslog';
129 } else {
130 $logto = "file:$self->{conf}->{logfile}";
131 }
132 if (exists $self->{conf}->{logfile}) {
133 my $debuglevel = exists $self->{conf}->{debuglevel} ? $self->{conf}->{debuglevel} : 9;
134 my $logger = new Razor2::Logger (
135 LogDebugLevel => $debuglevel,
136 LogTo => $logto,
137 LogPrefix => $self->{breed},
138 LogTimestamp => 1,
139 DontDie => 1,
140 Log2FileDir => defined($self->{conf}->{tmp_dir}) ? $self->{conf}->{tmp_dir} : "/tmp",
141 );
142 $self->{logref} = ref($logger) ? $logger : 0;
143 # log error strings at loglevel 11. Pick a high number 'cuz
144 # if its really an error, it will be in errstr for caller
145 $self->{logerrors} = 11;
146 }
147 $self->logobj(15,"cmd-line options", $self->{opt});
148 $self->{preproc}->{rm}->{log} = $self->{logref};
149
150 # creates razorhome, and sets $self->{razorhome} if successful
151 return $self->errprefix("Could not create 'razorhome'") unless $self->create_home_conf();
152 $self->compute_identity;
153
154 $self->log(5,"computed razorhome=$self->{razorhome}, conf=$self->{razorconf}, ident=$self->{identity}");
155 return 1;
156}
157
158# if a debug log statement requires extra work, check this call before doing it.
159sub logll {
160 my ($self, $loglevel) = @_;
161 return unless $self->{logref};
162 return 1 if ($self->{logref}->{LogDebugLevel} >= $loglevel);
163 return;
164}
165
166sub create_home_conf {
167 my $self = shift;
168
169 unless ($self->{opt}->{create_conf}) {
170 #
171 # if the global razorhome exists, don't create anything
172 # without '-create' option
173 #
174 return 1 if (-d $self->{global_razorhome});
175
176 #
177 # if there is not global razorhome,
178 # try to create razorhome one anyway.
179 # if it fails, thats ok.
180 #
181 $self->create_home($self->{razorhome_computed});
182 $self->errstrrst; # nuke error string
183 return 1;
184 }
185
186 #
187 # user passed in 'create' option, so create.
188 #
189 my $rhome = $self->{opt}->{razorhome}
190 ? $self->{opt}->{razorhome}
191 : $self->{razorhome_computed};
192
193 if ($rhome) {
194
195 if (-d $rhome) {
196 $self->log(6,"Not creating razorhome $rhome, already exists");
197 } else {
198 return unless $self->create_home($rhome);
199 }
200 }
201
202
203 if ($self->{opt}->{config}) {
204
205 # if create and conf specified, exit if write is not successful
206 #
207 $self->{razorconf} = $self->{opt}->{config};
208 return $self->write_conf();
209
210 } else {
211
212 # else just try and create, if fail ok.
213 #
214 $self->compute_razorconf();
215 $self->{razorconf} ||= $self->{computed_razorconf};
216 $self->write_conf();
217 $self->errstrrst; # nuke error string
218 }
219 return 1;
220}
221
222# wrapper for log
223sub log {
224 my $self = shift;
225 my $level = shift;
226 my $msg = shift;
227
228 if ($self->{logref}) {
229 return $self->{logref}->log($level, $msg);
230 } elsif ($self->{opt}->{debug}) {
231 print " Razor-Log: $msg\n" if $self->{opt}->{debug};
232 }
233}
234sub log2file {
235 my $self = shift;
236 return unless $self->{logref};
237 return $self->{logref}->log2file(@_);
238}
239
240sub doit {
241 my $self = shift;
242 my $args = shift;
243 my $r;
244
245 $self->log(2," $self->{name_version} starting razor-$self->{breed} $self->{args}");
246# $self->log(9,"uname -a: ". `uname -a`) if $self->logll(9);
247
248 $r = $self->checkit($args) if $self->{breed} eq 'check';
249 $r = $self->adminit($args) if $self->{breed} eq 'admin';
250 $r = $self->reportit($args) if $self->{breed} eq 'report';
251 $r = $self->reportit($args) if $self->{breed} eq 'revoke';
252
253 # return exit code
254 # 0, 1 => ok
255 # > 1 => error (caller should prolly print $self->errstr)
256 #
257 if ($r > 1) {
258 my $msg = $self->errstr;
259 $self->log(1,"razor-$self->{breed} error: ". $msg);
260 } else {
261 $self->log(8,"razor-$self->{breed} finished successfully.");
262 }
263 return $r;
264}
265
266
267sub _help {
268 my ($self,$breed) = @_;
269
270 chomp(my $all = <<EOFALL);
271 -h Print this usage message.
272 -v Print version number and exit
273 -d Turn on debugging. Logs to stdout.
274 -s Simulate Only. Does not connect to server.
275 -conf=file Use this config file instead of <razorhome>/razor.conf
276 -home=dir Use this as razorhome
277 -ident=file Use this identity file instead of <razorhome>/identity
278 -rs Use this razor server instead of reading .lst
279EOFALL
280 chomp(my $sigs = <<EOFSIGS);
281 -H Compute and print signature.
282 -S | --sig Accept a signatures to check on the command line
283 -e eng Engine used to compute sig, integer
284 -ep4 val String value required when engine == 4
285EOFSIGS
286
287 chomp(my $mbox = <<EOFMBOX);
288 -M | --mbox Accept a mailbox name on the command line (default)
289 If no filename, mbox, or signatures, input read from stdin.
290EOFMBOX
291
292 my %b;
293 $b{check} = <<EOFCHECK;
294
295razor-check [options] [ filename | -M mbox | -S signatures | < filename ]
296$all
297$sigs
298$mbox
299
300See razor-check(1) manpage for details.
301
302EOFCHECK
303
304 $b{report} = <<EOFREPORT;
305
306razor-report [options] [ filename | -M mbox | -S signatures -e engine]
307$all
308$sigs
309$mbox
310 -i file Use identity from this file
311 -f Stay in foreground.
312 -a Authenticate only. Exit 0 if authenticated, 1 if not
313 Stays in foreground.
314
315See razor-report(1) manpage for details.
316
317EOFREPORT
318
319 $b{admin} = <<EOFREGISTER;
320
321razor-admin [options] [ -register | -create | -discover ]
322$all
323 -create Create razorhome, does discover, does not register
324 -discover Discover Razor servers: write .lst files
325 -register Register a new identity
326 -user name Request 'name' when registering (requires -register)
327 -pass pass Request 'password' when registering (requires -register)
328 -l Make new identity the the default identity.
329 Used only when registering.
330
331See razor-admin(1) manpage for details.
332
333EOFREGISTER
334
335 $b{revoke} = <<EOFREVOKE;
336
337razor-revoke [options] filename
338$all
339$mbox
340 -i file Use identity from this file
341 -f Stay in foreground.
342 -a Authenticate only. exit 0 if authenticated, 1 if not
343 Stays in foreground.
344
345See razor-revoke(1) manpage for details.
346
347EOFREVOKE
348
349 my $future = <<EOFFUTURE;
350EOFFUTURE
351
352 return $b{$self->{breed}};
353}
354
355
356# maybe this should be in Client::Config
357#
358sub read_options {
359 my ($self, $agent) = @_;
360 $self->{args} = join ' ', @ARGV;
361 Getopt::Long::Configure ("no_ignore_case");
362 my %opt;
363 #
364 # These options override what is loaded in config file
365 # the names on the right should match keys in config file
366 #
367 my $ret = GetOptions(
368 's' => \$opt{simulate},
369 'd' => \$opt{debug},
370 'verbose' => \$opt{debug},
371 'v' => \$opt{version},
372 'h' => \$opt{usage},
373 'help' => \$opt{usage},
374 'H' => \$opt{printhash},
375 'C=s' => \$opt{printcleaned},
376 'sig=s' => \$opt{sig},
377 'S=s' => \$opt{sig},
378 'e=s' => \$opt{sigengine},
379 'ep4=s' => \$opt{sigep4},
380 'mbox' => \$opt{mbox},
381 'M' => \$opt{mbox},
382 'n' => \$opt{negative},
383 'conf=s' => \$opt{config},
384 'config=s' => \$opt{config},
385 'home=s' => \$opt{razorhome},
386 'f' => \$opt{foreground},
387 'noml' => \$opt{noml},
388 'user=s' => \$opt{user},
389 'u=s' => \$opt{user},
390 'pass=s' => \$opt{pass},
391 'a' => \$opt{authen_only},
392 'rs=s' => \$opt{server},
393 'server=s' => \$opt{server},
394 'r' => \$opt{register},
395 'register' => \$opt{register},
396 'l' => \$opt{symlink},
397 'i=s' => \$opt{identity},
398 'ident=s' => \$opt{identity},
399 'create' => \$opt{create_conf},
400'logfile=s' => \$opt{logfile},
401 'discover' => \$opt{force_discovery},
402 'dl=s' => \$opt{debuglevel},
403'debuglevel=s' => \$opt{debuglevel},
404'whitelist=s' => \$opt{whitelist},
405 'lm=s' => \$opt{logic_method},
406 'le=s' => \$opt{logic_engines},
407 );
408
409 if ($ret == 0) {
410 $self->error("failed to parse command line options.\n");
411 return;
412 }
413
414 # remove elements not set in the cmd-line
415 foreach (keys %opt) { delete $opt{$_} unless defined $opt{$_}; }
416
417 if ($opt{usage}) {
418 $self->error($self->_help);
419 return;
420 } elsif ($opt{mbox} && $opt{sig}) {
421 $self->error("--mbox and --sig are mutually exclusive.\n");
422 return;
423 } elsif ($opt{sig} && !$opt{sigengine}) {
424 $self->error("--sig requires -e (engine used to generate sig)\n");
425 return;
426 #
427 # fixme - require ep4 if -e 4 is used ?
428 #
429 } elsif ($opt{version}) {
430 $self->error("Razor Agents $VERSION, protocol version $PROTOCOL");
431 return;
432 }
433 $self->{opt} = \%opt;
434 return 1;
435}
436
- -
439# returns 0 if match (spam)
440# returns 1 if no match (legit)
441# returns 2 if error
442sub checkit {
443
444 my $self = shift;
445 my $args = shift;
446
447 # check for spam.
448 # input can be one of
449 # file - single mail
450 # mbox - many mail
451 # sig - 1 or more sigs
452 # or a filehandle provided via args
453
454 my $objects;
455 if ($self->{conf}->{sig}) {
456 my @sigs;
457 #
458 # cmd-line sigs
459 #
460 # prepare 1 mail object per sig
461 #
462 foreach my $sig (split ',', $self->{conf}->{sig}) {
463 $sig =~ s/^\s*//; $sig =~ s/\s*$//;
464 my $hr = {
465 eng => $self->{conf}->{sigengine},
466 sig => $sig,
467 };
468 $hr->{ep4} = "7542-10";
469 $hr->{ep4} = $self->{conf}->{sigep4} if $self->{conf}->{sigep4};
470 push @sigs, $hr;
471 }
472 $self->log (5,"received ". (scalar @sigs) ." valid cmd-line sigs.");
473 $objects = $self->prepare_objects(\@sigs) or return 2;
474 } else {
475
476 my $mails = $self->parse_mbox($args) or return 2;
477
478 $objects = $self->prepare_objects($mails) or return 2;
479
480 #
481 # if mail is whitelisted, its not spam.
482 # flag it so it we don't check it against server
483 #
484 foreach my $obj (@$objects) {
485 if ($self->local_check($obj)) {
486 $obj->{skipme} = 1;
487 $obj->{spam} = 0;
488 } else {
489 next;
490 }
491 }
492
493 }
494
495 # compute_sigs needs server info like ep4, so get_server_info first
496 $self->get_server_info() or return 2;
497 my $printable_sigs = $self->compute_sigs($objects) or return 2;
498
499 if ($self->{opt}->{printhash}) {
500 my $i = 0;
501 foreach (@$printable_sigs) {
502 if ($self->{opt}->{sigengine}) {
503 next unless (/ e$self->{opt}->{sigengine}: /);
504 }
505 print "$_\n";
506 $i++;
507 }
508 $self->log (4, "Done. Printed $i sig(s) for ". scalar(@$objects) ." mail(s)");
509 }
510 if ($self->{opt}->{printcleaned}) {
511 my $totalp = 0;
512 my $totalc = 0;
513 foreach my $obj (@$objects) {
514 my $n = 0;
515 mkdir("$self->{opt}->{printcleaned}/cleaned");
516 foreach ($obj->{headers}, @{$obj->{bodyparts_cleaned}}) {
517 my $fn = "$self->{opt}->{printcleaned}/cleaned/mail$obj->{id}.". $n++;
518 $self->write_file($fn, $_);
519 $totalc++;
520 }
521 $n = 0;
522 mkdir("$self->{opt}->{printcleaned}/uncleaned");
523 foreach ($obj->{headers}, @{$obj->{bodyparts}}) {
524 my $fn = "$self->{opt}->{printcleaned}/uncleaned/mail$obj->{id}.". $n++;
525 $self->write_file($fn, $_);
526 $totalp++;
527 }
528 }
529 $self->log (4, "Done. $totalp uncleaned, $totalc cleaned mails saved in $self->{opt}->{printcleaned}");
530 print "Done. $totalp uncleaned, $totalc cleaned mails saved in $self->{opt}->{printcleaned}\n";
531 return 1;
532
533 }
534
535 return 1 if $self->{opt}->{printhash};
536
537 # only check good objects
538 my @goodones; # this should be optimized!
539 foreach my $obj (@$objects) {
540 next if $obj->{skipme};
541 push @goodones, $obj;
542 }
543 unless (scalar @goodones) {
544 $self->log (4,"Done. No valid mail or signatures to check.");
545 return 1;
546 }
547
548 if ($self->{conf}->{simulate}) {
549 $self->log (4, "Done. (simulate only)");
550 return 1;
551 }
552
553 #
554 # Connect to catalogue server
555 #
556 $self->{s}->{list} = $self->{s}->{catalogue};
557 $self->nextserver();
558 $self->connect() or return 2;
559
560 #
561 # Check against server
562 #
563 $self->check (\@goodones) or return 2;
564 $self->disconnect() or return 2;
565
566
567 #
568 # print out responses and exit
569 #
570 my $only1check = (scalar(@$objects) == 1) ? 1 : 0;
571 my $has_spam = 0;
572 foreach my $obj (@$objects) {
573
574 $obj->{spam} = 0 if $obj->{skipme};
575 $obj->{spam} = 0 unless defined $obj->{spam};
576
577 if ($obj->{spam} > 0) {
578 return 0 if $only1check;
579 $has_spam = 1;
580 print $obj->{id} ."\n";
581 next;
582
583 } elsif ($obj->{spam} == 0) {
584 return 1 if $only1check;
585 print "-". $obj->{id} ."\n" if $self->{conf}->{negative};
586 next;
587
588 } else {
589 # error
590 #
591 $self->logobj(1,"bad 'spam' in checkit", $obj);
592 return 2 if $only1check;
593 print "-". $obj->{id} ."\n" if $self->{conf}->{negative};
594 next;
595 }
596 }
597 return 0 if $has_spam;
598 return 1;
599}
600
- -
603# returns 0 if success
604# returns 2 if error
605sub adminit {
606 my $self = shift;
607
608 my $done_something = 0;
609
610 if ($self->{opt}->{create_conf}) {
611 $done_something++;
612 # $self->create_home_conf() is always checked
613 }
614
615 if ( $self->{opt}->{force_discovery} ||
616 $self->{opt}->{create_conf}) {
617 $done_something++;
618 # get_server_info() calls nextserver() which calls discovery()
619 $self->get_server_info() or return 2;
620 }
621
622 if ($self->{opt}->{register}) {
623 $done_something++;
624 my $r = $self->registerit();
625 return $r if $r;
626 }
627
628 unless ($done_something) {
629 $self->error("An option needs to be specified, -h for help.");
630 return 2;
631 }
632
633 return 0;
634}
635
636# returns 0 if success
637# returns 2 if error
638sub registerit {
639 my($self, $auto) = @_;
640
641 unless ($self->{razorhome} || $self->{opt}->{identity}) {
642 $self->errprefix("Unable to register without a valid razorhome or identity");
643 return 2;
644 }
645
646 my $ident;
647
648 if (exists $self->{opt}->{user}
649 && ($ident = $self->get_ident)
650 && $ident->{user} eq $self->{opt}->{user} ) {
651 $self->error("You are already registered as user=$ident->{user} in $self->{razorhome}");
652 return 2;
653 }
654 if ($self->{conf}->{simulate}) {
655 $self->log(5,"Done - simulate only.");
656 return 0;
657 }
658
659 if ($self->{opt}->{create_conf}) {
660 $self->log(3, "Register create successful.");
661 return 0;
662 }
663
664 if ($auto) {
665 $self->log(3, "Write test underway");
666 my($ident) = {
667 user => 'writetest',
668 pass => 'writetest',
669 };
670 my($fn);
671 unless ($fn = $self->save_ident($ident)) {
672 $self->log(3, "Unable to write identity to home");
673 return 2;
674 }
675 unlink($fn) or return 2;
676 $self->log(3, "Write test completed");
677 }
678
679 $self->get_server_info() or return 2;
680 $self->connect() or return 2;
681
682 $self->log(3, "Attempting to register.");
683 # attempt to register the user/pass
684 $ident = $self->register_identity($self->{opt}->{user}, $self->{opt}->{pass});
685
686 $self->disconnect() or return 2;
687
688 unless (ref $ident) {
689 $self->log(3, "Failed to register identity.");
690 return 2;
691 }
692
693 if (my $fn = $self->save_ident($ident)) {
694 my $msg = "Register successful. Identity stored in $fn";
695 $self->log(3, $msg);
696 print "$msg\n";
697 return 0;
698 } else {
699 $self->log(3, "Register failed.");
700 return 2;
701 }
702}
703
704#
705# handles report and revoke
706#
707# returns 0 if success
708# returns 2 if error
709sub reportit {
710
711 my ($self, $args) = @_;
712
713 my $ident = $self->get_ident;
714 unless ($ident) {
715 $self->log(3, "Razor2 identity not found. Attempting to register automatically.");
716 if ($self->registerit("auto")) {
717 $self->log(3, "Automatic registration failed.");
718 $self->errprefix("Bootstrap Error: Your Razor2 identity was not found.\n " .
719 " If you haven't registered, please do so:\n" .
720 " \"razor-admin -register -user=[name/email_address] -pass=[password]\".\n".
721 " (Further information can be found in the razor-admin(1) manpage)\n" .
722 " If you did register, please ensure your identity symlink (or file) is in order.\n");
723 return 2;
724 }
725 $ident = $self->get_ident;
726 unless ($ident) {
727 $self->log(3, "Unable to load automatically registered identity.");
728 $self->errprefix("Bootstrap Error: Your Razor2 identity was not found.\n " .
729 " If you haven't registered, please do so:\n" .
730 " \"razor-admin -register -user=[name/email_address] -pass=[password]\".\n".
731 " (Further information can be found in the razor-admin(1) manpage)\n" .
732 " If you did register, please ensure your identity symlink (or file) is in order.\n");
733 return 2;
734 }
735 }
736
737 if (!$self->{opt}{foreground} &&
738 (@ARGV < 1 || $ARGV[0] eq "-" || $ARGV[0] eq "")) {
739 if (-t STDIN) {
740 $self->error("Unable to read from a TTY using STDIN while forked. \n" .
741 "Doing so leads to undefined behaviour in certain shells.");
742 return 2;
743 }
744 }
745
746 # background myself
747 unless ($self->{opt}->{foreground}) {
748 chdir '/';
749 fork && return 0;
750 POSIX::setsid;
751 # close 0, 1, 2;
752 }
753
754 if ($self->{opt}->{authen_only}) {
755 $self->authenticate($ident) or return;
756 $self->log(5,"Done - authenticate only.");
757 return 0 if $self->{authenticated};
758 return 2;
759 }
760
761 my $mails = $self->parse_mbox($args) or return 2;
762
763 my $objects = $self->prepare_objects($mails) or return 2;
764
765
766 # compute_sigs needs server info like ep4, so get_server_info first
767 $self->get_server_info() or return 2;
768
769 my $printable_sigs = $self->compute_sigs($objects) or return 2;
770
771 if ($self->{opt}->{printhash}) {
772 foreach (@$printable_sigs) {
773 if ($self->{opt}->{sigengine}) {
774 next unless (/ e$self->{opt}->{sigengine}: /);
775 }
776 print "$_\n";
777 }
778 exit 0;
779 }
780
781 if ( $self->{conf}->{simulate}) {
782 $self->log (4, "Done. (simulate only)");
783 exit 0;
784 }
785 unless (scalar @$objects) {
786 $self->log (4,"Done. No valid mail or signatures to check.");
787 exit 1;
788 }
789
790 $self->{s}->{list} = $self->{s}->{nomination};
791 $self->nextserver();
792 $self->connect() or return 2;
793 $self->authenticate($ident) or return 2;
794 $self->report($objects) or return 2;
795 $self->disconnect() or return 2;
796
797
798 if ($self->{opt}->{foreground}) {
799 foreach my $obj (@$objects) {
800 # my $line = debugobj($obj->{r});
801 # $line =~ /(\S+=\S+)/s; # could be res=0|1, err=xxx
802 # print "$obj->{id}: $1\n";
803 #print "$obj->{id}\n" if $obj->{r}->{res} == '1';
804 }
805 }
806 return 0;
807}
808
809
810sub parse_mbox {
811 my ($self, $args) = @_;
812
813 my @mails;
814 my @message;
815 my $passed_fh = 0;
816 my $aref;
817
818 # There are different kinds of mbox formats, we just split on simplest case.
819 # djb defines mbox, mboxrd, mboxcl, mboxcl2
820 # http://www.qmail.org/qmail-manual-html/man5/mbox.html
821 #
822 # non-mbox support added, thanx to Aaron Hopkins <aaron@die.net>
823
824 if (exists $$args{"fh"}) {
825 @ARGV = ();
826 push @ARGV, $$args{'fh'};
827 $passed_fh = 1;
828 } elsif (exists $$args{"aref"}) {
829 $aref = $$args{"aref"};
830 } elsif (!scalar @ARGV) {
831 push @ARGV, "-"
832 }
833
834 if ($$args{'aref'}) {
835 my @foo = (\join'', @{$$args{'aref'}});
836 return \@foo;
837 }
838
839 foreach my $file (@ARGV) {
840 my $fh = new IO::File;
841 my @message = ();
842 if (ref $file) {
843 $fh = $file
844 } else {
845 open $fh, "<$file" or return $self->error("Can't open $file: $!");
846 }
847
848 my $line = <$fh>;
849 next unless $line;
850
851 if ($line =~ /^From /) {
852 $self->log(8,"reading mbox formatted mail from ".
853 ($file eq '-' ? "<stdin>" : $file));
854 while (1) {
855 push @message, $line;
856 $line = <$fh>;
857 if (!defined($line) || $line =~ /^From /) {
858 push @mails, \join ('', @message);
859 @message = ();
860 last unless defined $line;
861 }
862 }
863 } else {
864 $self->log(8,"reading straight RFC822 mail from ".
865 ($file eq '-' ? "<stdin>" : $file));
866 push @mails, \join ('', map {s/^(>*From )/>$1/; $_} $line, <$fh>);
867 }
868 close $fh unless $passed_fh;
869 }
870
871 my $cnt = scalar @mails;
872 $self->log (6, "read $cnt mail". ($cnt>1 ? 's' : '') );
873
874 return \@mails;
875}
876
- -
879sub raise_error {
880 my ($self, $errstr) = @_;;
881 my $str;
882 if (ref $self) {
883 $str = $self->errstr;
884 }
885 $str = $errstr if $errstr;
886 my ($code) = $str =~ /Razor Error (\d+):/;
887 $code = 255 unless $code;
888 print "FATAL: $str";
889 exit $code;
890}
891
892# returns 1 if mail should be skipped
893#
894sub local_check {
895 my ($self, $obj) = @_;
896 my ($headers, $body) = split /\n\r*\n/, ${$obj->{orig_mail}}, 2;
897
898 $headers =~ s/\n\s+//sg; # merge multi-line headers
899
900 if ($self->{conf}->{ignorelist}) {
901 if ($headers =~ /\n((X-)?List-Id[^\n]+)/i) {
902 my $listid = $1;
903 my ($line1) = substr(${$obj->{orig_mail}}, 0, 50) =~ /^([^\n]+)/;
904 $self->log (5,"Mailing List post; mail ". $obj->{id} ." not spam.");
905 #$self->log (5,"Mailing List post; mail ". $obj->{id} ." not spam.\n $line1\n $listid");
906 return 1;
907 }
908 }
909 return 0 if $self->{no_whitelist};
910 if (-s $self->{conf}->{whitelist}) {
911 $self->read_whitelist;
912 foreach my $sh (keys %{$self->{whitelist}}) {
913 if ($sh ne 'sha1') {
914 while ($headers =~ /^$sh:\s+(.*)$/img) {
915 last unless $1;
916 my $fc = $1;
917 $self->log (13,"whitelist checking headers for match $sh: $fc");
918 foreach my $address (@{$self->{whitelist}->{$sh}}) {
919 if ($fc =~ /$address/i) {
920 $self->log (3,"ignoring mail $obj->{id}, whitelisted by rule: $sh: $address");
921 return 1;
922 }
923 }
924 }
925 }
926 }
927 $self->log (12,"Whitelist rules did not match mail $obj->{id}");
928 } elsif ($self->{conf}->{whitelist}) {
929 $self->log (6,"skipping whitelist file (empty?): $self->{conf}->{whitelist}");
930 $self->{no_whitelist} = 1;
931 }
932 return 0;
933}
934
- -
937sub read_whitelist {
938 my ($self) = @_;
939 return if $self->{whitelist};
940
941 my %whitelist;
942 my $lines = $self->read_file($self->{conf}->{whitelist},0,1);
943 for (@$lines) {
944 s/^\s*//;
945 next if /^#/;
946 chomp;
947 my ($type, $value) = split /\s+/, $_, 2;
948 $type =~ y/A-Z/a-z/ if $type;
949 push @{$whitelist{$type}}, $value if ($type && $value);
950 }
951 $self->{whitelist} = \%whitelist;
952 $self->log (8,"loaded ". scalar(keys %whitelist) ." different types of whitelist");
953 #$self->logobj (15,"loaded whitelist:", \%whitelist);
954 return 1;
955}
956
957
958sub logerr {
959 my ($self,$msg) = @_;
960 $msg = $self->errstr unless $msg;
961 $self->log(1,"$self->{breed} error: ". $msg);
962 return;
963}
964
- -
967# see nextserver() for explanation of how data is stored
968#
969sub get_server_info {
970 my $self = shift;
971
972 unless (exists $self->{s}) { $self->{s} = {}; }
973
974 if ($self->{opt}->{server}) { # cmd-line
975 $self->{s}->{list} = [$self->{opt}->{server}];
976 $self->log(8,"Using cmd-line server ($self->{opt}->{server}), skipping .lst files");
977 } else {
978 $self->readservers;
979 }
980 $self->loadservercache;
981 #$self->logobj(6,"find_closest_server server info (before nextserver)", $self->{s});
982 $self->{loaded_servers} = 1;
983 return $self->nextserver; # this will connect and get state info if not cached
984}
985
986
987# see nextserver() for explanation of how data is stored
988#
989sub readservers {
990 my $self = shift;
991
992 unless (exists $self->{s}) { $self->{s} = {}; }
993
994 # read .lst files
995 foreach my $lf (qw(discovery nomination catalogue)) {
996
997 my $h = $self->read_file($self->{conf}->{"listfile_$lf"},0,1) or next;
998 $self->{s}->{$lf} = [];
999 foreach (@$h) {
1000 push @{$self->{s}->{$lf}}, $1
1001 if /^(([^\.\s]+\.)+[^\.\s]+(:\S+)?)/;
1002 }
1003 if (defined($self->{s}->{$lf}) && ref($self->{s}->{$lf})) {
1004 $self->log(11,"Read ". scalar(@{$self->{s}->{$lf}}) ." from server listfile: ".
1005 $self->{conf}->{"listfile_$lf"});
1006 }
1007 }
1008 foreach my $lf (qw(discovery nomination catalogue)) {
1009 next unless defined($self->{s}->{$lf});
1010 next unless ref($self->{s}->{$lf});
1011 next unless @{$self->{s}->{$lf}} > 1;
1012 fisher_yates_shuffle($self->{s}->{$lf});
1013 }
1014 if ($self->{breed} =~ /^check/) {
1015 $self->{s}->{list} = $self->{s}->{catalogue};
1016 $self->{s}->{listfile} = $self->{conf}->{listfile_catalogue}; # for discovery()
1017 } else {
1018 $self->{s}->{list} = $self->{s}->{nomination};
1019 $self->{s}->{listfile} = $self->{conf}->{listfile_nomination}; # for discovery()
1020 }
1021}
1022
1023sub loadservercache {
1024 my $self = shift;
1025
1026 #
1027 # Read in server-specific config, using defaults for stuff not found
1028 #
1029 # NOTE: this reads all server.*.conf files in razor home, not just those in .lst
1030 #
1031
1032 # load defaults for .lst servers
1033 foreach (qw(nomination catalogue)) {
1034 next unless $self->{s}->{$_};
1035 foreach my $server (@{$self->{s}->{$_}}) {
1036 next if $self->{s}->{allconfs}->{$server}; # avoid repeats
1037 $self->{s}->{allconfs}->{$server} = $self->default_server_conf();
1038 $self->log(9,"Assigning defaults to $server");
1039 }
1040 }
1041 my @fns;
1042 my $sep = '\.';
1043 $sep = '_' if $^O eq 'VMS';
1044 if (opendir D,$self->{razorhome}) {
1045 @fns = map {s/_/./g; "$self->{razorhome}/$_";} grep /^server$sep[\S]+\.conf$/, readdir D;
1046 @fns = map { /^(\S+)$/, $1 } @fns; # untaint
1047 closedir D;
1048 }
1049 foreach (@fns) {
1050 /server\.(.+)\.conf$/ and my $sn = $1;
1051 next unless $sn;
1052 $self->{s}->{allconfs}->{$sn} = $self->read_file($_, $self->{s}->{allconfs}->{$sn} );
1053 if ($self->{s}->{allconfs}->{$sn}) {
1054 #$self->log(8,"Loaded server specific conf info for $sn");
1055 } else {
1056 $self->log(5,"loadservercache skipping $_");
1057 }
1058 }
1059
1060 return $self;
1061}
1062
1063
1064sub writeservers {
1065 my $self = shift;
1066
1067 unless ($self->{razorhome}) {
1068 $self->log(5,"no razorhome, not caching server info to disk");
1069 return;
1070 }
1071
1072 foreach (@{$self->{s}->{modified_lst}}) {
1073 my $fn = $self->{conf}->{"listfile_$_"};
1074 $self->write_file($fn, $self->{s}->{$_}, 0, 0, 1)
1075 || $self->log(5,"writeservers skipping .lst file: $fn");
1076 }
1077 $self->log(11,"No bootstrap_discovery (DNS) recently, not recording .lst files")
1078 unless scalar (@{$self->{s}->{modified_lst}});
1079 $self->{s}->{modified_lst} = [];
1080
1081 foreach (@{$self->{s}->{modified}}) {
1082 my $fn = "$self->{razorhome}/server.$_.conf";
1083 my $header = "#\n# Autogenerated by $self->{name_version}, ". localtime() ."\n";
1084 $self->write_file($fn, $self->{s}->{allconfs}->{$_}, 0, $header)
1085 || $self->debug("writeservers skipping $fn");
1086 }
1087 $self->{s}->{modified} = [];
1088 $self->errstrrst; # nuke error string if write errors
1089 return $self;
1090}
1091
1092
1093113µs1;
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.