forked from github/kensanata.oddmuse
4d10ef389a
Mail subscriptions for blog posts that are many years old make no sense to me. Here's a script to purge those old subscriptions.
121 lines
3.2 KiB
Perl
121 lines
3.2 KiB
Perl
#! /usr/bin/perl
|
||
# Copyright (C) 2010–2021 Alex Schroeder <alex@gnu.org>
|
||
|
||
# This program is free software: you can redistribute it and/or modify it under
|
||
# the terms of the GNU General Public License as published by the Free Software
|
||
# Foundation, either version 3 of the License, or (at your option) any later
|
||
# version.
|
||
#
|
||
# This program is distributed in the hope that it will be useful, but WITHOUT
|
||
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
||
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||
#
|
||
# You should have received a copy of the GNU General Public License along with
|
||
# this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
=head1 NAME
|
||
|
||
unsubscribe.pl - mass unsubscribe from Oddmuse
|
||
|
||
=head2 SYNOPSIS
|
||
|
||
B<perl unsubscribe.pl> F<MAILDB> [B<--regexp=>I<REGEXP>]
|
||
|
||
B<perl unsubscribe.pl> F<MAILDB> [B<--dump>]
|
||
|
||
=head2 DESCRIPTION
|
||
|
||
If you use the Mail Extension to Oddmuse, you end up with subscriptions to very
|
||
old pages. This script helps you unsubsribe people from old pages.
|
||
|
||
C<--regexp> indicates a regular expression matching pages names
|
||
|
||
The mandatory F<MAILDB> argument is the file containing all the mail
|
||
subscriptions.
|
||
|
||
=head2 EXAMPLES
|
||
|
||
Make a copy, unsubscribe people, check a dump of the remaining subscriptions,
|
||
and move the file back to the wiki data directory.
|
||
|
||
cp ~/alexschroeder/mail.db copy.db
|
||
perl ~/src/oddmuse/scripts/unsubscribe.pl copy.db --regexp='20[01][0-9]'
|
||
perl ~/src/oddmuse/scripts/unsubscribe.pl copy.db --dump
|
||
mv copy.db ~/alexschroeder/mail.db
|
||
|
||
=cut;
|
||
|
||
use Modern::Perl;
|
||
use Getopt::Long;
|
||
use Encode qw(encode_utf8 decode_utf8);
|
||
use DB_File;
|
||
|
||
binmode(STDOUT, ":utf8");
|
||
|
||
my $re = "";
|
||
my $confirm;
|
||
my $dump;
|
||
|
||
GetOptions ("regexp=s" => \$re,
|
||
"dump" => \$dump,
|
||
"confirm" => \$confirm, );
|
||
|
||
my $file = shift;
|
||
|
||
die "Not a file: $file" unless -f $file;
|
||
die "Unknown arguments: @ARGV" if @ARGV;
|
||
|
||
sub UrlEncode {
|
||
my $str = shift;
|
||
return '' unless $str;
|
||
my @letters = split(//, encode_utf8($str));
|
||
my %safe = map {$_ => 1} ('a' .. 'z', 'A' .. 'Z', '0' .. '9', '-', '_', '.', '!', '~', '*', "'", '(', ')', '#');
|
||
foreach my $letter (@letters) {
|
||
$letter = sprintf("%%%02x", ord($letter)) unless $safe{$letter};
|
||
}
|
||
return join('', @letters);
|
||
}
|
||
|
||
sub UrlDecode {
|
||
my $str = shift;
|
||
return '' unless $str;
|
||
$str =~ s/%([0-9a-f][0-9a-f])/chr(hex($1))/eig;
|
||
return decode_utf8($str);
|
||
}
|
||
|
||
tie my %h, "DB_File", $file;
|
||
my $FS = "\x1e";
|
||
|
||
if ($dump) {
|
||
for my $key (keys %h) {
|
||
my @value = split /$FS/, UrlDecode($h{$key});
|
||
say UrlDecode($key), ": @value";
|
||
}
|
||
exit;
|
||
}
|
||
|
||
for my $raw (keys %h) {
|
||
if ($raw =~ /@/) {
|
||
# email address
|
||
my $mail = UrlDecode($raw);
|
||
my $value = $h{$raw};
|
||
my @subscriptions = grep !/$re/, map { UrlDecode($_) } split /$FS/, $value;
|
||
if (@subscriptions) {
|
||
$h{$raw} = join $FS, map { UrlEncode($_) } @subscriptions if $confirm;
|
||
say "> $mail: remains subscribed to @subscriptions";
|
||
} else {
|
||
delete $h{$raw} if $confirm;
|
||
say "> $mail: unsubscribe from all pages";
|
||
}
|
||
} else {
|
||
my $id = UrlDecode($raw);
|
||
next unless $id =~ /$re/;
|
||
delete $h{$raw} if $confirm;
|
||
say "Delete $id";
|
||
}
|
||
}
|
||
|
||
untie %h;
|
||
|
||
say "Use --confirm to actually do it" unless $confirm;
|