Filename | /usr/local/lib/perl5/site_perl/mach/5.24/Razor2/Client/Agent.pm |
Statements | Executed 27 statements in 12.7ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 10.4ms | 30.5ms | BEGIN@18 | Razor2::Client::Agent::
1 | 1 | 1 | 2.03ms | 6.70ms | BEGIN@16 | Razor2::Client::Agent::
1 | 1 | 1 | 44µs | 239µs | BEGIN@13 | Razor2::Client::Agent::
1 | 1 | 1 | 31µs | 67µs | BEGIN@23 | Razor2::Client::Agent::
1 | 1 | 1 | 30µs | 12.4ms | BEGIN@21 | Razor2::Client::Agent::
1 | 1 | 1 | 29µs | 94.0ms | BEGIN@20 | Razor2::Client::Agent::
1 | 1 | 1 | 28µs | 44µs | BEGIN@14 | Razor2::Client::Agent::
1 | 1 | 1 | 28µs | 86µs | BEGIN@22 | Razor2::Client::Agent::
1 | 1 | 1 | 26µs | 512µs | BEGIN@15 | Razor2::Client::Agent::
1 | 1 | 1 | 23µs | 155µs | BEGIN@26 | Razor2::Client::Agent::
1 | 1 | 1 | 23µs | 140µs | BEGIN@25 | Razor2::Client::Agent::
1 | 1 | 1 | 19µs | 19µs | BEGIN@24 | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | _help | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | adminit | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | checkit | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | create_home_conf | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | do_conf | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | doit | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | get_server_info | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | loadservercache | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | local_check | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | log | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | log2file | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | logerr | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | logll | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | new | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | parse_mbox | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | raise_error | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | read_options | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | read_whitelist | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | readservers | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | registerit | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | reportit | Razor2::Client::Agent::
0 | 0 | 0 | 0s | 0s | writeservers | Razor2::Client::Agent::
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 | |||||
11 | package Razor2::Client::Agent; | ||||
12 | |||||
13 | 2 | 90µs | 2 | 434µs | # spent 239µs (44+195) within Razor2::Client::Agent::BEGIN@13 which was called:
# once (44µs+195µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 13 # spent 239µs making 1 call to Razor2::Client::Agent::BEGIN@13
# spent 195µs making 1 call to lib::import |
14 | 2 | 83µs | 2 | 58µs | # spent 44µs (28+15) within Razor2::Client::Agent::BEGIN@14 which was called:
# once (28µs+15µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 14 # spent 44µs making 1 call to Razor2::Client::Agent::BEGIN@14
# spent 15µs making 1 call to strict::import |
15 | 2 | 76µs | 2 | 998µs | # spent 512µs (26+486) within Razor2::Client::Agent::BEGIN@15 which was called:
# once (26µs+486µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 15 # spent 512µs making 1 call to Razor2::Client::Agent::BEGIN@15
# spent 486µs making 1 call to Getopt::Long::import |
16 | 2 | 557µs | 2 | 7.61ms | # spent 6.70ms (2.03+4.66) within Razor2::Client::Agent::BEGIN@16 which was called:
# once (2.03ms+4.66ms) by Mail::SpamAssassin::Plugin::Razor2::new at line 16 # spent 6.70ms making 1 call to Razor2::Client::Agent::BEGIN@16
# spent 914µs making 1 call to Exporter::import |
17 | |||||
18 | 2 | 326µs | 2 | 31.0ms | # spent 30.5ms (10.4+20.1) within Razor2::Client::Agent::BEGIN@18 which was called:
# once (10.4ms+20.1ms) by Mail::SpamAssassin::Plugin::Razor2::new at line 18 # spent 30.5ms making 1 call to Razor2::Client::Agent::BEGIN@18
# spent 450µs making 1 call to Exporter::import |
19 | |||||
20 | 2 | 114µs | 2 | 188ms | # spent 94.0ms (29µs+94.0) within Razor2::Client::Agent::BEGIN@20 which was called:
# once (29µs+94.0ms) by Mail::SpamAssassin::Plugin::Razor2::new at line 20 # spent 94.0ms making 1 call to Razor2::Client::Agent::BEGIN@20
# spent 94.0ms making 1 call to base::import |
21 | 2 | 91µs | 2 | 24.9ms | # spent 12.4ms (30µs+12.4) within Razor2::Client::Agent::BEGIN@21 which was called:
# once (30µs+12.4ms) by Mail::SpamAssassin::Plugin::Razor2::new at line 21 # spent 12.4ms making 1 call to Razor2::Client::Agent::BEGIN@21
# spent 12.4ms making 1 call to base::import |
22 | 2 | 83µs | 2 | 144µs | # spent 86µs (28+58) within Razor2::Client::Agent::BEGIN@22 which was called:
# once (28µs+58µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 22 # spent 86µs making 1 call to Razor2::Client::Agent::BEGIN@22
# spent 58µs making 1 call to base::import |
23 | 2 | 73µs | 2 | 103µs | # spent 67µs (31+36) within Razor2::Client::Agent::BEGIN@23 which was called:
# once (31µs+36µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 23 # spent 67µs making 1 call to Razor2::Client::Agent::BEGIN@23
# spent 36µs making 1 call to base::import |
24 | 2 | 72µs | 1 | 19µs | # spent 19µs within Razor2::Client::Agent::BEGIN@24 which was called:
# once (19µs+0s) by Mail::SpamAssassin::Plugin::Razor2::new at line 24 # spent 19µs making 1 call to Razor2::Client::Agent::BEGIN@24 |
25 | 2 | 72µs | 2 | 258µs | # spent 140µs (23+118) within Razor2::Client::Agent::BEGIN@25 which was called:
# once (23µs+118µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 25 # spent 140µs making 1 call to Razor2::Client::Agent::BEGIN@25
# spent 118µs making 1 call to Exporter::import |
26 | 2 | 11.0ms | 2 | 286µs | # spent 155µs (23+132) within Razor2::Client::Agent::BEGIN@26 which was called:
# once (23µs+132µs) by Mail::SpamAssassin::Plugin::Razor2::new at line 26 # spent 155µs making 1 call to Razor2::Client::Agent::BEGIN@26
# spent 132µs making 1 call to vars::import |
27 | |||||
28 | |||||
29 | 1 | 2µs | $PROTOCOL = $Razor2::Client::Version::PROTOCOL; | ||
30 | 1 | 2µs | $VERSION = $Razor2::Client::Version::VERSION; | ||
31 | |||||
- - | |||||
34 | sub 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 | |||||
72 | sub 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. | ||||
159 | sub logll { | ||||
160 | my ($self, $loglevel) = @_; | ||||
161 | return unless $self->{logref}; | ||||
162 | return 1 if ($self->{logref}->{LogDebugLevel} >= $loglevel); | ||||
163 | return; | ||||
164 | } | ||||
165 | |||||
166 | sub 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 | ||||
223 | sub 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 | } | ||||
234 | sub log2file { | ||||
235 | my $self = shift; | ||||
236 | return unless $self->{logref}; | ||||
237 | return $self->{logref}->log2file(@_); | ||||
238 | } | ||||
239 | |||||
240 | sub 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 | |||||
267 | sub _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 | ||||
279 | EOFALL | ||||
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 | ||||
285 | EOFSIGS | ||||
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. | ||||
290 | EOFMBOX | ||||
291 | |||||
292 | my %b; | ||||
293 | $b{check} = <<EOFCHECK; | ||||
294 | |||||
295 | razor-check [options] [ filename | -M mbox | -S signatures | < filename ] | ||||
296 | $all | ||||
297 | $sigs | ||||
298 | $mbox | ||||
299 | |||||
300 | See razor-check(1) manpage for details. | ||||
301 | |||||
302 | EOFCHECK | ||||
303 | |||||
304 | $b{report} = <<EOFREPORT; | ||||
305 | |||||
306 | razor-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 | |||||
315 | See razor-report(1) manpage for details. | ||||
316 | |||||
317 | EOFREPORT | ||||
318 | |||||
319 | $b{admin} = <<EOFREGISTER; | ||||
320 | |||||
321 | razor-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 | |||||
331 | See razor-admin(1) manpage for details. | ||||
332 | |||||
333 | EOFREGISTER | ||||
334 | |||||
335 | $b{revoke} = <<EOFREVOKE; | ||||
336 | |||||
337 | razor-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 | |||||
345 | See razor-revoke(1) manpage for details. | ||||
346 | |||||
347 | EOFREVOKE | ||||
348 | |||||
349 | my $future = <<EOFFUTURE; | ||||
350 | EOFFUTURE | ||||
351 | |||||
352 | return $b{$self->{breed}}; | ||||
353 | } | ||||
354 | |||||
355 | |||||
356 | # maybe this should be in Client::Config | ||||
357 | # | ||||
358 | sub 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 | ||||
442 | sub 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 | ||||
605 | sub 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 | ||||
638 | sub 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 | ||||
709 | sub 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 | |||||
810 | sub 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 | |||||
- - | |||||
879 | sub 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 | # | ||||
894 | sub 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 | |||||
- - | |||||
937 | sub 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 | |||||
958 | sub 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 | # | ||||
969 | sub 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 | # | ||||
989 | sub 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 | |||||
1023 | sub 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 | |||||
1064 | sub 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 | |||||
1093 | 1 | 13µs | 1; |