Debbugs/Log/Spam.pm

   1 # This module is part of debbugs, and is released under the terms of the GPL
   2 # version 2, or any later version (at your option). See the file README and
   3 # COPYING for more information.
   4 #
   5 # Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
   6
   7 package Debbugs::Log::Spam;
   8
   9 =head1 NAME
  10
  11 Debbugs::Log::Spam -- an interface to debbugs .log.spam files and .log.spam.d
  12 directories
  13
  14 =head1 SYNOPSIS
  15
  16 use Debbugs::Log::Spam;
  17
  18 my $spam = Debbugs::Log::Spam->new(bug_num => '12345');
  19
  20 =head1 DESCRIPTION
  21
  22 Spam in bugs can be excluded using a .log.spam file and a .log.spam.d directory.
  23 The file contains message ids, one per line, and the directory contains files
  24 named after message ids, one per file.
  25
  26 =head1 BUGS
  27
  28 None known.
  29
  30 =cut
  31
  32 use warnings;
  33 use strict;
  34 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  35 use base qw(Exporter);
  36
  37 BEGIN{
  38     $VERSION = 1;
  39     $DEBUG = 0 unless defined $DEBUG;
  40
  41     @EXPORT = ();
  42     %EXPORT_TAGS = ();
  43     @EXPORT_OK = ();
  44     Exporter::export_ok_tags(keys %EXPORT_TAGS);
  45     $EXPORT_TAGS{all} = [@EXPORT_OK];
  46
  47 }
  48
  49 use Carp;
  50 use feature 'state';
  51 use Params::Validate qw(:types validate_with);
  52 use Debbugs::Common qw(getbuglocation getbugcomponent filelock unfilelock);
  53
  54 =head1 FUNCTIONS
  55
  56 =over 4
  57
  58 =item new
  59
  60 Creates a new log spam reader.
  61
  62     my $spam_log = Debbugs::Log::Spam->new(log_spam_name => "56/123456.log.spam");
  63     my $spam_log = Debbugs::Log::Spam->new(bug_num => $nnn);
  64
  65 Parameters
  66
  67 =over
  68
  69 =item bug_num -- bug number
  70
  71 =item log_spam_name -- name of log
  72
  73 =back
  74
  75 One of the above options must be passed.
  76
  77 =cut
  78
  79 sub new {
  80     my $this = shift;
  81     state $spec =
  82         {bug_num => {type => SCALAR,
  83                      optional => 1,
  84                     },
  85          log_spam_name => {type => SCALAR,
  86                            optional => 1,
  87                           },
  88         };
  89     my %param =
  90         validate_with(params => \@_,
  91                       spec   => $spec
  92                      );
  93     if (grep({exists $param{$_} and
  94               defined $param{$_}} qw(bug_num log_spam_name)) ne 1) {
  95         croak "Exactly one of bug_num or log_spam_name".
  96             "must be passed and must be defined";
  97     }
  98
  99     my $class = ref($this) || $this;
 100     my $self = {};
 101     bless $self, $class;
 102
 103     if (exists $param{log_spam_name}) {
 104         $self->{name} = $param{log_spam_name};
 105     } elsif (exists $param{bug_num}) {
 106         my $location = getbuglocation($param{bug_num},'log.spam');
 107         my $bug_log = getbugcomponent($param{bug_num},'log.spam',$location);
 108         $self->{name} = $bug_log;
 109     }
 110     $self->_init();
 111     return $self;
 112 }
 113
 114
 115 sub _init {
 116     my $self = shift;
 117
 118     $self->{spam} = {};
 119     if (-e $self->{name}) {
 120         open(my $fh,'<',$self->{name}) or
 121             croak "Unable to open bug log spam '$self->{name}' for reading: $!";
 122         binmode($fh,':encoding(UTF-8)');
 123         while (<$fh>) {
 124             chomp;
 125             if (s/\sham$//) {
 126                 $self->{spam}{$_} = '0';
 127             } else {
 128                 $self->{spam}{$_} = '1';
 129             }
 130         }
 131         close ($fh) or
 132             croak "Unable to close bug log filehandle: $!";
 133     }
 134     if (-d $self->{name}.'.d') {
 135         opendir(my $d,$self->{name}.'.d') or
 136             croak "Unable to open bug log spamdir '$self->{name}.d' for reading: $!";
 137         for my $dir (readdir($d)) {
 138             next unless $dir =~ m/([^\.].*)_(\w+)$/;
 139             # .spam overrides .spam.d
 140             next if exists $self->{spam}{$1};
 141             # set the spam HASH to $dir so we know where this value was set from
 142             $self->{spam}{$1} = $dir;
 143         }
 144         closedir($d) or
 145             croak "Unable to close bug log spamdir: $!";
 146     }
 147     return $self;
 148 }
 149
 150 =item save
 151
 152 C<$spam_log->save();>
 153
 154 Saves changes to the bug log spam file.
 155
 156 =cut
 157
 158 sub save {
 159     my $self = shift;
 160     return unless keys %{$self->{spam}};
 161     filelock($self->{name}.'.lock');
 162     open(my $fh,'>',$self->{name}.'.tmp') or
 163         croak "Unable to open bug log spam '$self->{name}.tmp' for writing: $!";
 164     binmode($fh,':encoding(UTF-8)');
 165     for my $msgid (keys %{$self->{spam}}) {
 166         # was this message set to spam/ham by .d? If so, don't save it
 167         if ($self->{spam}{$msgid} ne '0' and
 168             $self->{spam}{$msgid} ne '1') {
 169             next;
 170         }
 171         print {$fh} $msgid;
 172         if ($self->{spam}{$msgid} eq '0') {
 173             print {$fh} ' ham';
 174         }
 175         print {$fh} "\n";
 176     }
 177     close($fh) or croak "Unable to write to '$self->{name}.tmp': $!";
 178     rename($self->{name}.'.tmp',$self->{name});
 179     unfilelock();
 180 }
 181
 182 =item is_spam
 183
 184 C<next if ($spam_log->is_spam('12456@exmaple.com'));>
 185
 186 Returns 1 if this message id confirms that the message is spam
 187
 188 Returns 0 if this message is not known to be spam
 189
 190 =cut
 191 sub is_spam {
 192     my ($self,$msgid) = @_;
 193     return 0 if not defined $msgid or not length $msgid;
 194     $msgid =~ s/^<|>$//;
 195     if (exists $self->{spam}{$msgid} and
 196         $self->{spam}{$msgid} ne '0'
 197        ) {
 198         return 1;
 199     }
 200     return 0;
 201 }
 202
 203 =item is_ham
 204
 205     next if ($spam_log->is_ham('12456@exmaple.com'));
 206
 207 Returns 1 if this message id confirms that the message is ham
 208
 209 Returns 0 if this message is not known to be ham
 210
 211 =cut
 212 sub is_ham {
 213     my ($self,$msgid) = @_;
 214     return 0 if not defined $msgid or not length $msgid;
 215     $msgid =~ s/^<|>$//;
 216     if (exists $self->{spam}{$msgid} and
 217         $self->{spam}{$msgid} eq '0'
 218        ) {
 219         return 1;
 220     }
 221     return 0;
 222 }
 223
 224
 225 =item add_spam
 226
 227     $spam_log->add_spam('123456@example.com');
 228
 229 Add a message id to the spam listing.
 230
 231 You must call C<$spam_log->save()> if you wish the changes to be written out to disk.
 232
 233 =cut
 234
 235 sub add_spam {
 236     my ($self,$msgid) = @_;
 237     $msgid =~ s/^<|>$//;
 238     $self->{spam}{$msgid} = '1';
 239 }
 240
 241 =item add_ham
 242
 243     $spam_log->add_ham('123456@example.com');
 244
 245 Add a message id to the ham listing.
 246
 247 You must call C<$spam_log->save()> if you wish the changes to be written out to disk.
 248
 249 =cut
 250
 251 sub add_ham {
 252     my ($self,$msgid) = @_;
 253     $msgid =~ s/^<|>$//;
 254     $self->{spam}{$msgid} = '0';
 255 }
 256
 257 =item remove_message
 258
 259      $spam_log->remove_message('123456@example.com');
 260
 261 Remove a message from the spam/ham listing.
 262
 263 You must call C<$spam_log->save()> if you wish the changes to be written out to disk.
 264
 265 =cut
 266
 267
 268 1;
 269
 270 =back
 271
 272 =cut
 273
 274 __END__
 275
 276 # Local Variables:
 277 # indent-tabs-mode: nil
 278 # cperl-indent-level: 4
 279 # End: