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             $self->{spam}{$_} = 1;
 126         }
 127         close ($fh) or
 128             croak "Unable to close bug log filehandle: $!";
 129     }
 130     if (-d $self->{name}.'.d') {
 131         opendir(my $d,$self->{name}.'.d') or
 132             croak "Unable to open bug log spamdir '$self->{name}.d' for reading: $!";
 133         for my $dir (readdir($d)) {
 134             next unless $dir =~ m/([^\.].*)_(\w+)$/;
 135             $self->{spam}{$1} = 1;
 136         }
 137         closedir($d) or
 138             croak "Unable to close bug log spamdir: $!";
 139     }
 140     return $self;
 141 }
 142
 143 =item save
 144
 145 $self->save();
 146
 147 Saves changes to the bug log spam file.
 148
 149 =cut
 150
 151 sub save {
 152     my $self = shift;
 153     return unless keys %{$self->{spam}};
 154     filelock($self->{name}.'.lock');
 155     open(my $fh,'>',$self->{name}.'.tmp') or
 156         croak "Unable to open bug log spam '$self->{name}.tmp' for writing: $!";
 157     binmode($fh,':encoding(UTF-8)');
 158     for my $msgid (keys %{$self->{spam}}) {
 159         print {$fh} $msgid."\n";
 160     }
 161     close($fh) or croak "Unable to write to '$self->{name}.tmp': $!";
 162     rename($self->{name}.'.tmp',$self->{name});
 163     unfilelock();
 164 }
 165
 166 =item is_spam
 167
 168     next if ($spam_log->is_spam('12456@exmaple.com'));
 169
 170 Returns 1 if this message id confirms that the message is spam
 171
 172 Returns 0 if this message is not spam
 173
 174 =cut
 175 sub is_spam {
 176     my ($self,$msgid) = @_;
 177     return 0 if not defined $msgid or not length $msgid;
 178     $msgid =~ s/^<|>$//;
 179     if (exists $self->{spam}{$msgid} and
 180         $self->{spam}{$msgid}
 181        ) {
 182         return 1;
 183     }
 184     return 0;
 185 }
 186
 187 =item add_spam
 188
 189     $spam_log->add_spam('123456@example.com');
 190
 191 Add a message id to the spam listing.
 192
 193 You must call C<$self->save()> if you wish the changes to be written out to disk.
 194
 195 =cut
 196
 197 sub add_spam {
 198     my ($self,$msgid) = @_;
 199     $msgid =~ s/^<|>$//;
 200     $self->{spam}{$msgid} = 1;
 201 }
 202
 203 1;
 204
 205 =back
 206
 207 =cut
 208
 209 __END__
 210
 211 # Local Variables:
 212 # indent-tabs-mode: nil
 213 # cperl-indent-level: 4
 214 # End: