78
79
###########################################################################
81
use vars qw( %common_tags );
88
$pms->_get_tag_value_for_yesno(@_);
93
uc $pms->_get_tag_value_for_yesno(@_);
98
$pms->_get_tag_value_for_score(@_);
103
$pms->_get_tag_value_for_score(@_);
108
$pms->_get_tag_value_for_required_score(@_);
111
VERSION => \&Mail::SpamAssassin::Version,
113
SUBVERSION => sub { $Mail::SpamAssassin::SUB_VERSION },
115
RULESVERSION => sub {
117
my $conf = $pms->{conf};
120
keys %{$conf->{update_version}} if $conf->{update_version};
121
@fnames = sort @fnames if @fnames > 1;
122
join(',', map($conf->{update_version}{$_}, @fnames));
127
$pms->{conf}->{report_hostname} ||
128
Mail::SpamAssassin::Util::fq_hostname();
131
REMOTEHOSTNAME => sub {
133
$pms->{tag_data}->{'REMOTEHOSTNAME'} || "localhost";
136
REMOTEHOSTADDR => sub {
138
$pms->{tag_data}->{'REMOTEHOSTADDR'} || "127.0.0.1";
141
LASTEXTERNALIP => sub {
143
my $lasthop = $pms->{relays_external}->[0];
144
$lasthop ? $lasthop->{ip} : '';
147
LASTEXTERNALRDNS => sub {
149
my $lasthop = $pms->{relays_external}->[0];
150
$lasthop ? $lasthop->{rdns} : '';
153
LASTEXTERNALHELO => sub {
155
my $lasthop = $pms->{relays_external}->[0];
156
$lasthop ? $lasthop->{helo} : '';
159
CONTACTADDRESS => sub {
161
$pms->{conf}->{report_contact};
166
defined $pms->{bayes_score} ? sprintf("%3.4f", $pms->{bayes_score})
170
DATE => \&Mail::SpamAssassin::Util::time_to_rfc822_date,
174
my $arg = (shift || "*");
175
my $length = int($pms->{score});
176
$length = 50 if $length > 50;
182
$pms->get_autolearn_status();
185
AUTOLEARNSCORE => sub {
187
$pms->get_autolearn_points();
192
my $arg = (shift || ',');
193
join($arg, sort(@{$pms->{test_names_hit}})) || "none";
198
my $arg = (shift || ',');
199
join($arg, sort(@{$pms->{subtest_names_hit}})) || "none";
204
my $arg = (shift || ",");
206
foreach my $test (sort @{$pms->{test_names_hit}}) {
207
my $score = $pms->{conf}->{scores}->{$test};
208
$score = '0' if !defined $score;
209
$line .= $arg if $line ne '';
210
$line .= $test . "=" . $score;
212
$line ne '' ? $line : 'none';
217
$pms->get_content_preview();
222
"\n" . ($pms->{tag_data}->{REPORT} || "");
229
$pms->get($hdr,undef);
234
$pms->{main}->timer_report();
237
ADDEDHEADERHAM => sub {
239
$pms->_get_added_headers('headers_ham');
242
ADDEDHEADERSPAM => sub {
244
$pms->_get_added_headers('headers_spam');
249
$pms->_get_added_headers(
250
$pms->{is_spam} ? 'headers_spam' : 'headers_ham');
81
257
my $class = shift;
82
258
$class = ref($class) || $class;
418
661
$self->{learned_points} += $self->{conf}->{scoreset}->[$orig_scoreset]->{$test};
665
#IF ANY RULES ARE AUTOLEARN FORCE, SET THAT FLAG
666
if ($tflags->{$test} =~ /\bautolearn_force\b/) {
667
$self->{autolearn_force}++;
668
#ADD RULE NAME TO LIST
669
$self->{autolearn_force_names}.="$test,";
423
673
# ignore tests with 0 score (or undefined) in this scoreset
424
674
next if !$scores->{$test};
426
# Go ahead and add points to the proper locations
427
if (!$self->{conf}->maybe_header_only ($test)) {
676
# Go ahead and add points to the proper locations
677
# Changed logic because in testing, I was getting both head and body. Bug 5503
678
if ($self->{conf}->maybe_header_only ($test)) {
679
$self->{head_only_points} += $scores->{$test};
680
dbg("learn: auto-learn: adding head_only points $scores->{$test}");
681
} elsif ($self->{conf}->maybe_body_only ($test)) {
428
682
$self->{body_only_points} += $scores->{$test};
430
if (!$self->{conf}->maybe_body_only ($test)) {
431
$self->{head_only_points} += $scores->{$test};
683
dbg("learn: auto-learn: adding body_only points $scores->{$test}");
685
dbg("learn: auto-learn: not considered head or body scores: $scores->{$test}");
434
688
$points += $scores->{$test};
1053
1315
# public API for plugins
1317
=item $status->action_depends_on_tags($tags, $code, @args)
1319
Enqueue the supplied subroutine reference C<$code>, to become runnable when
1320
all the specified tags become available. The C<$tags> may be a simple
1321
scalar - a tag name, or a listref of tag names. The subroutine C<&$code>
1322
when called will be passed a C<permessagestatus> object as its first argument,
1323
followed by the supplied (optional) list C<@args> .
1327
sub action_depends_on_tags {
1328
my($self, $tags, $code, @args) = @_;
1331
or die "action_depends_on_tags: argument must be a subroutine ref";
1333
# tag names on which the given action depends
1334
my @dep_tags = !ref $tags ? uc $tags : map(uc($_),@$tags);
1336
# @{$self->{tagrun_subs}} list of all submitted subroutines
1337
# @{$self->{tagrun_actions}{$tag}} bitmask of action indices blocked by tag
1338
# $self->{tagrun_tagscnt}[$action_ind] count of tags still pending
1340
# store action details, obtain its index
1341
push(@{$self->{tagrun_subs}}, [$code,@args]);
1342
my $action_ind = $#{$self->{tagrun_subs}};
1344
# list dependency tag names which are not already satistied
1346
grep(!defined $self->{tag_data}{$_} || $self->{tag_data}{$_} eq '',
1349
$self->{tagrun_tagscnt}[$action_ind] = scalar @blocking_tags;
1350
$self->{tagrun_actions}{$_}[$action_ind] = 1 for @blocking_tags;
1352
if (@blocking_tags) {
1353
dbg("check: tagrun - action %s blocking on tags %s",
1354
$action_ind, join(', ',@blocking_tags));
1356
dbg("check: tagrun - tag %s was ready, action %s runnable immediately: %s",
1357
join(', ',@dep_tags), $action_ind, join(', ',$code,@args));
1358
&$code($self, @args);
1362
# tag_is_ready() will be called by set_tag(), indicating that a given
1363
# tag just received its value, possibly unblocking an action routine
1364
# as declared by action_depends_on_tags().
1366
# Well-behaving plugins should call set_tag() once when a tag is fully
1367
# assembled and ready. Multiple calls to set the same tag value are handled
1368
# gracefully, but may result in premature activation of a pending action.
1369
# Setting tag values by plugins should not be done directly but only through
1370
# the public API set_tag(), otherwise a pending action release may be missed.
1373
my($self, $tag) = @_;
1376
if (would_log('dbg', 'check')) {
1377
my $tag_val = $self->{tag_data}{$tag};
1378
dbg("check: tagrun - tag %s is now ready, value: %s",
1379
$tag, !defined $tag_val ? '<UNDEF>'
1380
: ref $tag_val ne 'ARRAY' ? $tag_val
1381
: 'ARY:[' . join(',',@$tag_val) . ']' );
1383
if (ref $self->{tagrun_actions}{$tag}) { # any action blocking on this tag?
1385
foreach my $action_pending (@{$self->{tagrun_actions}{$tag}}) {
1386
if ($action_pending) {
1387
$self->{tagrun_actions}{$tag}[$action_ind] = 0;
1388
if ($self->{tagrun_tagscnt}[$action_ind] <= 0) {
1389
# should not happen, warn and ignore
1390
warn "tagrun error: count for $action_ind is ".
1391
$self->{tagrun_tagscnt}[$action_ind]."\n";
1392
} elsif (! --($self->{tagrun_tagscnt}[$action_ind])) {
1393
my($code,@args) = @{$self->{tagrun_subs}[$action_ind]};
1394
dbg("check: tagrun - tag %s unblocking the action %s: %s",
1395
$tag, $action_ind, join(', ',$code,@args));
1396
&$code($self, @args);
1404
# debugging aid: show actions that are still pending, waiting for their
1405
# tags to receive a value
1407
sub report_unsatisfied_actions {
1410
@tags = keys %{$self->{tagrun_actions}} if ref $self->{tagrun_actions};
1411
for my $tag (@tags) {
1412
my @pending_actions = grep($self->{tagrun_actions}{$tag}[$_],
1413
(0 .. $#{$self->{tagrun_actions}{$tag}}));
1414
dbg("check: tagrun - tag %s is still blocking action %s",
1415
$tag, join(', ', @pending_actions)) if @pending_actions;
1055
1419
=item $status->set_tag($tagname, $value)
1057
Set a template tag, as used in C<add_header>, report templates, etc. This API
1058
is intended for use by plugins. Tag names will be converted to an
1059
all-uppercase representation internally.
1061
C<$value> can be a subroutine reference, which will be evaluated each time
1062
the template is expanded. Note that perl supports closures, which means
1063
that variables set in the caller's scope can be accessed inside this C<sub>.
1421
Set a template tag, as used in C<add_header>, report templates, etc.
1422
This API is intended for use by plugins. Tag names will be converted
1423
to an all-uppercase representation internally.
1425
C<$value> can be a simple scalar (string or number), or a reference to an
1426
array, in which case the public method get_tag will join array elements
1427
using a space as a separator, returning a single string for backward
1430
C<$value> can also be a subroutine reference, which will be evaluated
1431
each time the template is expanded. The first argument passed by get_tag
1432
to a called subroutine will be a PerMsgStatus object (this module's object),
1433
followed by optional arguments provided a caller to get_tag.
1435
Note that perl supports closures, which means that variables set in the
1436
caller's scope can be accessed inside this C<sub>. For example:
1066
1438
my $text = "hello world!";
1067
1439
$status->set_tag("FOO", sub {
1071
See C<Mail::SpamAssassin::Conf>'s C<TEMPLATE TAGS> section for more details on
1072
how template tags are used.
1444
See C<Mail::SpamAssassin::Conf>'s C<TEMPLATE TAGS> section for more details
1445
on how template tags are used.
1074
1447
C<undef> will be returned if a tag by that name has not been defined.
1083
$self->{tag_data}->{$tag} = $val;
1452
my($self,$tag,$val) = @_;
1453
$self->{tag_data}->{uc $tag} = $val;
1454
$self->tag_is_ready($tag);
1086
1457
# public API for plugins
1101
# expose this previously-private API
1102
return shift->_get_tag(uc shift);
1472
my($self, $tag, @args) = @_;
1474
return if !defined $tag;
1477
if (exists $common_tags{$tag}) {
1478
# tag data from traditional pre-defined tag subroutines
1479
$data = $common_tags{$tag};
1480
$data = $data->($self,@args) if ref $data eq 'CODE';
1481
$data = join(' ',@$data) if ref $data eq 'ARRAY';
1482
$data = "" if !defined $data;
1483
} elsif (exists $self->{tag_data}->{$tag}) {
1484
# tag data comes from $self->{tag_data}->{TAG}, typically from plugins
1485
$data = $self->{tag_data}->{$tag};
1486
$data = $data->($self,@args) if ref $data eq 'CODE';
1487
$data = join(' ',@$data) if ref $data eq 'ARRAY';
1488
$data = "" if !defined $data;
1493
=item $string = $status->get_tag_raw($tagname, @args)
1495
Similar to C<get_tag>, but keeps a tag name unchanged (does not uppercase it),
1496
and does not convert arrayref tag values into a single string.
1501
my($self, $tag, @args) = @_;
1503
return if !defined $tag;
1505
if (exists $common_tags{$tag}) {
1506
# tag data from traditional pre-defined tag subroutines
1507
$data = $common_tags{$tag};
1508
$data = $data->($self,@args) if ref $data eq 'CODE';
1509
$data = "" if !defined $data;
1510
} elsif (exists $self->{tag_data}->{$tag}) {
1511
# tag data comes from $self->{tag_data}->{TAG}, typically from plugins
1512
$data = $self->{tag_data}->{$tag};
1513
$data = $data->($self,@args) if ref $data eq 'CODE';
1514
$data = "" if !defined $data;
1105
1519
###########################################################################
1155
1569
sub _get_tag_value_for_score {
1156
#$pad parameter never used. removed.
1570
my ($self, $pad) = @_;
1159
1572
my $score = sprintf("%2.1f", $self->{score});
1160
1573
my $rscore = $self->_get_tag_value_for_required_score();
1162
1575
#Change due to bug 6419 to use Util function for consistency with spamd
1163
1576
#and PerMessageStatus
1164
return Mail::SpamAssassin::Util::get_tag_value_for_score($score, $rscore, $self->{is_spam});
1577
$score = Mail::SpamAssassin::Util::get_tag_value_for_score($score, $rscore, $self->{is_spam});
1579
#$pad IS PROVIDED BY THE _SCORE(PAD)_ tag
1580
if (defined $pad && $pad =~ /^(0+| +)$/) {
1581
my $count = length($1) + 3 - length($score);
1582
$score = (substr($pad, 0, $count) . $score) if $count > 0;
1167
1588
sub _get_tag_value_for_required_score {
1169
1590
return sprintf("%2.1f", $self->{conf}->{required_score});
1177
# tag data also comes from $self->{tag_data}->{TAG}
1179
$tag = "" unless defined $tag; # can be "0", so use a defined test
1181
%tags = ( YESNO => sub { $self->_get_tag_value_for_yesno(@_) },
1183
YESNOCAPS => sub { uc $self->_get_tag_value_for_yesno(@_) },
1185
SCORE => sub { $self->_get_tag_value_for_score(shift) },
1186
HITS => sub { $self->_get_tag_value_for_score(shift) },
1188
REQD => sub { $self->_get_tag_value_for_required_score() },
1190
VERSION => \&Mail::SpamAssassin::Version,
1192
SUBVERSION => sub { $Mail::SpamAssassin::SUB_VERSION },
1195
$self->{conf}->{report_hostname} ||
1196
Mail::SpamAssassin::Util::fq_hostname();
1199
REMOTEHOSTNAME => sub {
1200
$self->{tag_data}->{'REMOTEHOSTNAME'} || "localhost";
1202
REMOTEHOSTADDR => sub {
1203
$self->{tag_data}->{'REMOTEHOSTADDR'} || "127.0.0.1";
1206
LASTEXTERNALIP => sub {
1207
my $lasthop = $self->{relays_external}->[0];
1208
$lasthop ? $lasthop->{ip} : '';
1211
LASTEXTERNALRDNS => sub {
1212
my $lasthop = $self->{relays_external}->[0];
1213
$lasthop ? $lasthop->{rdns} : '';
1216
LASTEXTERNALHELO => sub {
1217
my $lasthop = $self->{relays_external}->[0];
1218
$lasthop ? $lasthop->{helo} : '';
1221
CONTACTADDRESS => sub { $self->{conf}->{report_contact} },
1224
defined($self->{bayes_score}) ?
1225
sprintf("%3.4f", $self->{bayes_score}) : "0.5"
1228
DATE => \&Mail::SpamAssassin::Util::time_to_rfc822_date,
1231
my $arg = (shift || "*");
1232
my $length = int($self->{score});
1233
$length = 50 if $length > 50;
1237
AUTOLEARN => sub { $self->get_autolearn_status() },
1239
AUTOLEARNSCORE => sub { $self->get_autolearn_points() },
1242
my $arg = (shift || ',');
1243
join($arg, sort(@{$self->{test_names_hit}})) || "none";
1247
my $arg = (shift || ',');
1248
join($arg, sort(@{$self->{subtest_names_hit}})) || "none";
1251
TESTSSCORES => sub {
1252
my $arg = (shift || ",");
1254
foreach my $test (sort @{$self->{test_names_hit}}) {
1255
my $score = $self->{conf}->{scores}->{$test};
1256
$score = '0' if !defined $score;
1257
$line .= $arg if $line ne '';
1258
$line .= $test . "=" . $score;
1260
$line ne '' ? $line : 'none';
1263
PREVIEW => sub { $self->get_content_preview() },
1265
REPORT => sub { "\n" . ($self->{tag_data}->{REPORT} || "") },
1268
my $hdr = shift || return;
1269
$self->get($hdr,undef);
1272
TIMING => sub { $self->{main}->timer_report() },
1274
ADDEDHEADERHAM => sub { $self->_get_added_headers('headers_ham') },
1276
ADDEDHEADERSPAM=> sub { $self->_get_added_headers('headers_spam') },
1278
ADDEDHEADER => sub {
1279
$self->_get_added_headers(
1280
$self->{is_spam} ? 'headers_spam' : 'headers_ham');
1286
if (exists $tags{$tag}) {
1287
$data = $tags{$tag};
1288
$data = $data->(@_) if ref $data eq 'CODE';
1289
$data = "" if !defined $data;
1290
} elsif (exists $self->{tag_data}->{$tag}) {
1291
$data = $self->{tag_data}->{$tag};
1292
$data = $data->(@_) if ref $data eq 'CODE';
1293
$data = "" if !defined $data;
1298
1594
###########################################################################
added
removed
lib/Mail/SpamAssassin/PerMsgStatus.pm
