mirror of
https://git.proxmox.com/git/proxmox-spamassassin
synced 2025-04-28 12:19:37 +00:00
622 lines
17 KiB
Perl
622 lines
17 KiB
Perl
# <@LICENSE>
|
|
# Licensed to the Apache Software Foundation (ASF) under one or more
|
|
# contributor license agreements. See the NOTICE file distributed with
|
|
# this work for additional information regarding copyright ownership.
|
|
# The ASF licenses this file to you under the Apache License, Version 2.0
|
|
# (the "License"); you may not use this file except in compliance with
|
|
# the License. You may obtain a copy of the License at:
|
|
#
|
|
# http://www.apache.org/licenses/LICENSE-2.0
|
|
#
|
|
# Unless required by applicable law or agreed to in writing, software
|
|
# distributed under the License is distributed on an "AS IS" BASIS,
|
|
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
# See the License for the specific language governing permissions and
|
|
# limitations under the License.
|
|
# </@LICENSE>
|
|
|
|
=head1 NAME
|
|
|
|
Mail::SpamAssassin::Plugin::AuthRes - use Authentication-Results header fields
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
=head2 SpamAssassin configuration:
|
|
|
|
loadplugin Mail::SpamAssassin::Plugin::AuthRes
|
|
|
|
authres_trusted_authserv myserv.example.com
|
|
authres_networks all
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This plugin parses Authentication-Results header fields and can supply the
|
|
results obtained to other plugins, so as to avoid repeating checks that have
|
|
been performed already.
|
|
|
|
=cut
|
|
|
|
package Mail::SpamAssassin::Plugin::AuthRes;
|
|
|
|
use Mail::SpamAssassin::Plugin;
|
|
use Mail::SpamAssassin::Logger;
|
|
use strict;
|
|
use warnings;
|
|
# use bytes;
|
|
use re 'taint';
|
|
|
|
our @ISA = qw(Mail::SpamAssassin::Plugin);
|
|
|
|
# list of valid methods and values
|
|
# https://www.iana.org/assignments/email-auth/email-auth.xhtml
|
|
# some others not in that list:
|
|
# dkim-atps=neutral
|
|
# dmarc=bestguesspass (some microsoft stuff)
|
|
my %method_result = (
|
|
'arc' => {'fail'=>1,'none'=>1,'pass'=>1},
|
|
'auth' => {'fail'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'temperror'=>1},
|
|
'dkim' => {'fail'=>1,'neutral'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'policy'=>1,'temperror'=>1},
|
|
'dkim-adsp' => {'discard'=>1,'fail'=>1,'none'=>1,'nxdomain'=>1,'pass'=>1,'permerror'=>1,'temperror'=>1,'unknown'=>1},
|
|
'dkim-atps' => {'fail'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'temperror'=>1,'neutral'=>1},
|
|
'dmarc' => {'bestguesspass'=>1,'fail'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'temperror'=>1},
|
|
'dnswl' => {'none'=>1,'pass'=>1,'permerror'=>1,'temperror'=>1},
|
|
'domainkeys' => {'fail'=>1,'neutral'=>1,'none'=>1,'permerror'=>1,'policy'=>1,'pass'=>1,'temperror'=>1},
|
|
'iprev' => {'fail'=>1,'pass'=>1,'permerror'=>1,'temperror'=>1},
|
|
'rrvs' => {'fail'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'temperror'=>1,'unknown'=>1},
|
|
'sender-id' => {'fail'=>1,'hardfail'=>1,'neutral'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'policy'=>1,'softfail'=>1,'temperror'=>1},
|
|
'smime' => {'fail'=>1,'neutral'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'policy'=>1,'temperror'=>1},
|
|
'spf' => {'fail'=>1,'hardfail'=>1,'neutral'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'policy'=>1,'softfail'=>1,'temperror'=>1},
|
|
'vbr' => {'fail'=>1,'none'=>1,'pass'=>1,'permerror'=>1,'temperror'=>1},
|
|
);
|
|
my %method_ptype_prop = (
|
|
'arc' => {'smtp' => {'remote-ip'=>1}, 'header' => {'oldest-pass'=>1}, 'arc' => {'chain'=>1}},
|
|
'auth' => {'smtp' => {'auth'=>1,'mailfrom'=>1}},
|
|
'dkim' => {'header' => {'d'=>1,'i'=>1,'b'=>1,'a'=>1,'s'=>1}},
|
|
'dkim-adsp' => {'header' => {'from'=>1}},
|
|
'dkim-atps' => {'header' => {'from'=>1}},
|
|
'dmarc' => {'header' => {'from'=>1}, 'policy' => {'dmarc'=>1}},
|
|
'dnswl' => {'dns' => {'zone'=>1,'sec'=>1}, 'policy' => {'ip'=>1,'txt'=>1}},
|
|
'domainkeys' => {'header' => {'d'=>1,'from'=>1,'sender'=>1}},
|
|
'iprev' => {'policy' => {'iprev'=>1}},
|
|
'rrvs' => {'smtp' => {'rcptto'=>1}},
|
|
'sender-id' => {'header' => {'*'=>1}},
|
|
'smime' => {'body' => {'smime-part'=>1,'smime-identifer'=>1,'smime-serial'=>1,'smime-issuer'=>1}},
|
|
'spf' => {'smtp' => {'mailfrom'=>1,'mfrom'=>1,'helo'=>1,'rcpttodomain'=>1}},
|
|
'vbr' => {'header' => {'md'=>1,'mv'=>1}},
|
|
);
|
|
|
|
# Some MIME helpers
|
|
my $QUOTED_STRING = qr/"((?:[^"\\]++|\\.)*+)"?/;
|
|
my $TOKEN = qr/[^\s\x00-\x1f\x80-\xff\(\)\<\>\@\,\;\:\/\[\]\?\=\"]+/;
|
|
my $ATOM = qr/[a-zA-Z0-9\@\!\#\$\%\&\\\'\*\+\-\/\=\?\^\_\`\{\|\}\~]+/;
|
|
|
|
sub new {
|
|
my ($class, $mailsa) = @_;
|
|
|
|
# the usual perlobj boilerplate to create a subclass object
|
|
$class = ref($class) || $class;
|
|
my $self = $class->SUPER::new($mailsa);
|
|
bless ($self, $class);
|
|
|
|
$self->set_config($mailsa->{conf});
|
|
|
|
# process first as other plugins might depend on us
|
|
$self->register_method_priority("parsed_metadata", -10);
|
|
|
|
$self->register_eval_rule("check_authres_result", $Mail::SpamAssassin::Conf::TYPE_HEAD_EVALS);
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub set_config {
|
|
my ($self, $conf) = @_;
|
|
my @cmds;
|
|
|
|
=head1 ADMINISTRATOR SETTINGS
|
|
|
|
=over
|
|
|
|
=item authres_networks internal/trusted/all (default: internal)
|
|
|
|
Process Authenticated-Results headers set by servers from these networks
|
|
(refers to SpamAssassin *_networks zones). Any header outside this is
|
|
completely ignored (affects all module settings).
|
|
|
|
internal = internal_networks
|
|
trusted = internal_networks + trusted_networks
|
|
all = all above + all external
|
|
|
|
Setting "all" is safe only if your MX servers filter properly all incoming
|
|
A-R headers, and you use authres_trusted_authserv to match your authserv-id.
|
|
This is suitable for default OpenDKIM for example. These settings might
|
|
also be required if your filters do not insert A-R header to correct
|
|
position above the internal Received header (some known offenders: OpenDKIM,
|
|
OpenDMARC, amavisd-milter).
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
push (@cmds, {
|
|
setting => 'authres_networks',
|
|
is_admin => 1,
|
|
default => 'internal',
|
|
type => $Mail::SpamAssassin::Conf::CONF_TYPE_STRING,
|
|
code => sub {
|
|
my ($self, $key, $value, $line) = @_;
|
|
if (!defined $value || $value =~ /^$/) {
|
|
return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
|
|
}
|
|
$value = lc($value);
|
|
if ($value =~ /^(?:internal|trusted|all)$/) {
|
|
$self->{authres_networks} = $value;
|
|
} else {
|
|
return $Mail::SpamAssassin::Conf::INVALID_VALUE;
|
|
}
|
|
}
|
|
});
|
|
|
|
=over
|
|
|
|
=item authres_trusted_authserv authservid1 id2 ... (default: none)
|
|
|
|
Trusted authentication server IDs (the domain-name-like first word of
|
|
Authentication-Results field, also known as C<authserv-id>).
|
|
|
|
Note that if set, ALL A-R headers are ignored unless a match is found.
|
|
|
|
Use strongly recommended, possibly along with authres_networks all.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
push (@cmds, {
|
|
setting => 'authres_trusted_authserv',
|
|
is_admin => 1,
|
|
default => {},
|
|
type => $Mail::SpamAssassin::Conf::CONF_TYPE_HASH_KEY_VALUE,
|
|
code => sub {
|
|
my ($self, $key, $value, $line) = @_;
|
|
if (!defined $value || $value =~ /^$/) {
|
|
return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
|
|
}
|
|
foreach my $id (split(/\s+/, lc $value)) {
|
|
$self->{authres_trusted_authserv}->{$id} = 1;
|
|
}
|
|
}
|
|
});
|
|
|
|
=over
|
|
|
|
=item authres_ignored_authserv authservid1 id2 ... (default: none)
|
|
|
|
Ignored authentication server IDs (the domain-name-like first word of
|
|
Authentication-Results field, also known as C<authserv-id>).
|
|
|
|
Any A-R header is ignored if match is found.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
push (@cmds, {
|
|
setting => 'authres_ignored_authserv',
|
|
is_admin => 1,
|
|
default => {},
|
|
type => $Mail::SpamAssassin::Conf::CONF_TYPE_HASH_KEY_VALUE,
|
|
code => sub {
|
|
my ($self, $key, $value, $line) = @_;
|
|
if (!defined $value || $value =~ /^$/) {
|
|
return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
|
|
}
|
|
foreach my $id (split(/\s+/, lc $value)) {
|
|
$self->{authres_ignored_authserv}->{$id} = 1;
|
|
}
|
|
}
|
|
});
|
|
|
|
$conf->{parser}->register_commands(\@cmds);
|
|
}
|
|
|
|
=head1 METADATA
|
|
|
|
Parsed headers are stored in $pms-E<gt>{authres_parsed}, as a hash of array
|
|
of hashes where results are collected by method. For example, the header
|
|
field:
|
|
|
|
Authentication-Results: server.example.com;
|
|
spf=pass smtp.mailfrom=bounce.example.org;
|
|
dkim=pass header.i=@example.org;
|
|
dkim=fail header.i=@another.signing.domain.example
|
|
|
|
Produces the following structure:
|
|
|
|
$pms->{authres_parsed} = {
|
|
'dkim' => [
|
|
{
|
|
'properties' => {
|
|
'header' => {
|
|
'i' => '@example.org'
|
|
}
|
|
},
|
|
'authserv' => 'server.example.com',
|
|
'result' => 'pass',
|
|
'version' => 1,
|
|
'reason' => ''
|
|
},
|
|
{
|
|
'properties' => {
|
|
'header' => {
|
|
'i' => '@another.signing.domain.example'
|
|
}
|
|
},
|
|
'result' => 'fail',
|
|
'authserv' => 'server.example.com',
|
|
'version' => 1,
|
|
'reason' => ''
|
|
},
|
|
],
|
|
}
|
|
|
|
Within each array, the order of results is the original, which should be most
|
|
recent results first.
|
|
|
|
For checking result of methods, $pms-E<gt>{authres_result} is available:
|
|
|
|
$pms->{authres_result} = {
|
|
'dkim' => 'pass',
|
|
'spf' => 'fail',
|
|
}
|
|
|
|
=head1 EVAL FUNCTIONS
|
|
|
|
=over 4
|
|
|
|
=item header RULENAME eval:check_authres_result(method, result)
|
|
|
|
Can be used to check results.
|
|
|
|
Reference of valid result methods and values:
|
|
C<https://www.iana.org/assignments/email-auth/email-auth.xhtml>
|
|
|
|
Additionally the result value of 'missing' can be used to check if there is
|
|
no result at all.
|
|
|
|
ifplugin Mail::SpamAssassin::Plugin::AuthRes
|
|
ifplugin !(Mail::SpamAssassin::Plugin::SPF)
|
|
header SPF_PASS eval:check_authres_result('spf', 'pass')
|
|
header SPF_FAIL eval:check_authres_result('spf', 'fail')
|
|
header SPF_SOFTFAIL eval:check_authres_result('spf', 'softfail')
|
|
header SPF_TEMPFAIL eval:check_authres_result('spf', 'tempfail')
|
|
endif
|
|
ifplugin !(Mail::SpamAssassin::Plugin::DKIM)
|
|
header DKIM_VERIFIED eval:check_authres_result('dkim', 'pass')
|
|
header DKIM_INVALID eval:check_authres_result('dkim', 'fail')
|
|
endif
|
|
endif
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub check_authres_result {
|
|
my ($self, $pms, $method, $wanted_result) = @_;
|
|
|
|
my $result = $pms->{authres_result}->{$method};
|
|
$wanted_result = lc($wanted_result);
|
|
|
|
if ($wanted_result eq 'missing') {
|
|
return !defined($result) ? 1 : 0;
|
|
}
|
|
|
|
return 0 unless defined $result;
|
|
return ($wanted_result eq $result) ? 1 : 0;
|
|
}
|
|
|
|
sub parsed_metadata {
|
|
my ($self, $opts) = @_;
|
|
|
|
my $pms = $opts->{permsgstatus};
|
|
|
|
my @authres;
|
|
my $nethdr;
|
|
|
|
if ($pms->{conf}->{authres_networks} eq 'internal') {
|
|
$nethdr = 'ALL-INTERNAL';
|
|
} elsif ($pms->{conf}->{authres_networks} eq 'trusted') {
|
|
$nethdr = 'ALL-TRUSTED';
|
|
} else {
|
|
$nethdr = 'ALL';
|
|
}
|
|
|
|
foreach my $hdr (split(/^/m, $pms->get($nethdr))) {
|
|
if ($hdr =~ /^((?:Arc\-)?Authentication-Results):\s*(.+)/i) {
|
|
push @authres, [$1,$2];
|
|
}
|
|
}
|
|
|
|
if (!@authres) {
|
|
dbg("authres: no Authentication-Results headers found from %s",
|
|
$pms->{conf}->{authres_networks});
|
|
return 0;
|
|
}
|
|
|
|
foreach (@authres) {
|
|
eval {
|
|
$self->parse_authres($pms, $_->[0], $_->[1]);
|
|
} or do {
|
|
dbg("authres: skipping header, $@");
|
|
}
|
|
}
|
|
|
|
$pms->{authres_result} = {};
|
|
# Set $pms->{authres_result} info for all found methods
|
|
# 'pass' will always win if multiple results
|
|
foreach my $method (keys %method_result) {
|
|
my $parsed = $pms->{authres_parsed}->{$method};
|
|
next if !$parsed;
|
|
foreach my $pref (@$parsed) {
|
|
if (!$pms->{authres_result}->{$method} ||
|
|
$pref->{result} eq 'pass')
|
|
{
|
|
$pms->{authres_result}->{$method} = $pref->{result};
|
|
}
|
|
}
|
|
}
|
|
|
|
if (%{$pms->{authres_result}}) {
|
|
dbg("authres: results: %s",
|
|
join(' ', map { $_.'='.$pms->{authres_result}->{$_} }
|
|
sort keys %{$pms->{authres_result}}));
|
|
} else {
|
|
dbg("authres: no results");
|
|
}
|
|
}
|
|
|
|
sub parse_authres {
|
|
my ($self, $pms, $hdrname, $hdr) = @_;
|
|
|
|
dbg("authres: parsing $hdrname: $hdr");
|
|
|
|
my $authserv;
|
|
my $version = 1;
|
|
my @methods;
|
|
my $arc_index;
|
|
|
|
local $_ = $hdr;
|
|
|
|
if ($hdrname =~ /^ARC-/i) {
|
|
if (!/\Gi\b/gcs) {
|
|
die("missing arc index: $hdr");
|
|
}
|
|
skip_cfws();
|
|
if (!/\G=/gcs) {
|
|
die("invalid arc index: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
if (!/\G(\d+)/gcs) {
|
|
die("invalid arc index: ".substr($_, pos())."\n");
|
|
}
|
|
$arc_index = $1;
|
|
if ($arc_index < 1 || $arc_index > 50) {
|
|
die("invalid arc index: $arc_index\n");
|
|
}
|
|
skip_cfws();
|
|
if (!/\G;/gcs) {
|
|
die("missing delimiter: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
}
|
|
|
|
# authserv-id
|
|
if (!/\G($TOKEN)/gcs) {
|
|
die("invalid authserv: ".substr($_, pos())."\n");
|
|
}
|
|
$authserv = lc($1);
|
|
|
|
# some invalid headers start with spf=foo etc, missing authserv-id
|
|
if (/\G=/gcs) {
|
|
die("missing authserv: $hdr\n");
|
|
}
|
|
|
|
if (%{$pms->{conf}->{authres_trusted_authserv}}) {
|
|
if (!$pms->{conf}->{authres_trusted_authserv}->{$authserv}) {
|
|
die("authserv not trusted: $authserv\n");
|
|
}
|
|
}
|
|
if ($pms->{conf}->{authres_ignored_authserv}->{$authserv}) {
|
|
die("ignored authserv: $authserv\n");
|
|
}
|
|
|
|
# skip authserv version
|
|
skip_cfws();
|
|
if (/\G\d+/gcs) {
|
|
skip_cfws();
|
|
}
|
|
|
|
if (!/\G;/gcs) {
|
|
die("missing delimiter: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
|
|
while (pos() < length()) {
|
|
my ($method, $result);
|
|
my $reason = '';
|
|
my $props = {};
|
|
|
|
# some silly generators add duplicate authserv-id; here
|
|
if (/\G\Q${authserv}\E\s*;/gcs) {
|
|
skip_cfws();
|
|
}
|
|
|
|
# skip none method
|
|
if (/\Gnone\b/igcs) {
|
|
die("method none\n");
|
|
}
|
|
|
|
# method / version = result
|
|
if (!/\G([\w-]+)/gcs) {
|
|
die("invalid method: ".substr($_, pos())."\n");
|
|
}
|
|
$method = lc($1);
|
|
if (!exists $method_result{$method}) {
|
|
die("unknown method: $method: $hdr\n");
|
|
}
|
|
skip_cfws();
|
|
if (/\G\//gcs) {
|
|
skip_cfws();
|
|
if (!/\G\d+/gcs) {
|
|
die("invalid $method version: ".substr($_, pos())."\n");
|
|
}
|
|
$version = $1;
|
|
skip_cfws();
|
|
}
|
|
if (!/\G=/gcs) {
|
|
die("missing result for $method: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
if (!/\G(\w+)/gcs) {
|
|
die("invalid result for $method: ".substr($_, pos())."\n");
|
|
}
|
|
$result = $1;
|
|
if (!exists $method_result{$method}{$result}) {
|
|
die("unknown result for $method: $result\n");
|
|
}
|
|
skip_cfws();
|
|
|
|
# reason = value
|
|
if (/\Greason\b/igcs) {
|
|
skip_cfws();
|
|
if (!/\G=/gcs) {
|
|
die("invalid reason: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
if (!/\G$QUOTED_STRING|($TOKEN)/gcs) {
|
|
die("invalid reason: ".substr($_, pos())."\n");
|
|
}
|
|
$reason = defined $1 ? $1 : $2;
|
|
skip_cfws();
|
|
}
|
|
|
|
# action = value (some microsoft ARC stuff?)
|
|
if (/\Gaction\b/igcs) {
|
|
skip_cfws();
|
|
if (!/\G=/gcs) {
|
|
die("invalid action: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
if (!/\G$QUOTED_STRING|$TOKEN/gcs) {
|
|
die("invalid action: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
}
|
|
|
|
# ptype.property = value
|
|
while (pos() < length()) {
|
|
my ($ptype, $property, $value);
|
|
|
|
# no props?
|
|
if (/\G(?:;|$)/gcs) {
|
|
skip_cfws();
|
|
last;
|
|
}
|
|
|
|
# ptype
|
|
if (!/\G([\w-]+)/gcs) {
|
|
die("invalid ptype: ".substr($_,pos())."\n");
|
|
}
|
|
$ptype = lc($1);
|
|
if (!exists $method_ptype_prop{$method}{$ptype}) {
|
|
die("unknown ptype: $method/$ptype\n");
|
|
}
|
|
skip_cfws();
|
|
|
|
# dot
|
|
if (!/\G\./gcs) {
|
|
die("missing property: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
|
|
# property
|
|
if (!/\G([\w-]+)/gcs) {
|
|
die("invalid property: ".substr($_, pos())."\n");
|
|
}
|
|
$property = lc($1);
|
|
if (!exists $method_ptype_prop{$method}{$ptype}{$property} &&
|
|
!exists $method_ptype_prop{$method}{$ptype}{'*'}) {
|
|
die("unknown property for $method/$ptype: $property\n");
|
|
}
|
|
skip_cfws();
|
|
|
|
# =
|
|
if (!/\G=/gcs) {
|
|
die("missing property value: ".substr($_, pos())."\n");
|
|
}
|
|
skip_cfws();
|
|
|
|
# value:
|
|
# The grammar is ( value / [ [ local-part ] "@" ] domain-name )
|
|
# where value := token / quoted-string
|
|
# and local-part := dot-atom / quoted-string / obs-local-part
|
|
if (!/\G$QUOTED_STRING|($ATOM(?:\.$ATOM)*|$TOKEN)(?=(?:[\s;]|$))/gcs) {
|
|
die("invalid $method/$ptype.$property value: ".substr($_, pos())."\n");
|
|
}
|
|
$value = defined $1 ? $1 : $2;
|
|
skip_cfws();
|
|
|
|
$props->{$ptype}->{$property} = $value;
|
|
|
|
if (/\G(?:;|$)/gcs) {
|
|
skip_cfws();
|
|
last;
|
|
}
|
|
}
|
|
|
|
push @methods, [$method, {
|
|
'authserv' => $authserv,
|
|
'version' => $version,
|
|
'result' => $result,
|
|
'reason' => $reason,
|
|
'properties' => $props,
|
|
'arc_index' => $arc_index,
|
|
}];
|
|
}
|
|
|
|
# paranoid check..
|
|
if (pos() < length()) {
|
|
die("parse ended prematurely? ".substr($_, pos())."\n");
|
|
}
|
|
|
|
# Pushed to pms only if header parsed completely
|
|
foreach my $marr (@methods) {
|
|
push @{$pms->{authres_parsed}->{$marr->[0]}}, $marr->[1];
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
# skip whitespace and comments
|
|
sub skip_cfws {
|
|
/\G\s*/gcs;
|
|
if (/\G\(/gcs) {
|
|
my $i = 1;
|
|
while (/\G.*?([()]|\z)/gcs) {
|
|
$1 eq ')' ? $i-- : $i++;
|
|
last if !$i;
|
|
}
|
|
die("comment not ended\n") if $i;
|
|
/\G\s*/gcs;
|
|
}
|
|
}
|
|
|
|
#sub check_cleanup {
|
|
# my ($self, $opts) = @_;
|
|
# my $pms = $opts->{permsgstatus};
|
|
# use Data::Dumper;
|
|
# print STDERR Dumper($pms->{authres_parsed});
|
|
# print STDERR Dumper($pms->{authres_result});
|
|
#}
|
|
|
|
1;
|