2 # Copyright (C) 2019 all contributors <meta@public-inbox.org>
3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
5 # Used for purging messages entirely from a public-inbox. Currently
6 # supports v2 inboxes only, for now.
9 use Getopt::Long qw(:config gnu_getopt no_ignore_case auto_abbrev);
10 use PublicInbox::Config;
11 use PublicInbox::MIME;
12 use PublicInbox::Admin qw(resolve_repo_dir);
13 use PublicInbox::Filter::Base;
14 *REJECT = *PublicInbox::Filter::Base::REJECT;
16 my $usage = "$0 [--all] [INBOX_DIRS] </path/to/message";
18 eval { require PublicInbox::V2Writable } or die
19 "DBI, DBD::SQLite and Search::Xapian required for purge\n";
20 my $config = eval { PublicInbox::Config->new };
21 my $cfgfile = PublicInbox::Config::default_file();
27 'verbose|v!' => \$verbose,
29 GetOptions(%opts) or die "bad command-line args\n", $usage, "\n";
31 # TODO: clean this up and share code with -index via ::Admin
32 my %dir2ibx; # ( path => Inbox object )
34 $config and $config->each_inbox(sub {
36 push @inboxes, $ibx if $all && $ibx->{version} != 1;
37 $dir2ibx{$ibx->{mainrepo}} = $ibx;
41 $config or die "--all specified, but $cfgfile not readable\n";
42 @ARGV and die "--all specified, but directories specified\n";
45 my @dirs = scalar(@ARGV) ? @ARGV : ('.');
48 foreach my $dir (@dirs) {
50 my $dir = resolve_repo_dir($dir, \$v);
55 my $ibx = $dir2ibx{$dir} ||= do {
56 warn "$dir not configured in $cfgfile\n";
58 my $name = "unconfigured-$u";
59 PublicInbox::Inbox->new({
62 -primary_address => "$name\@example.com",
70 die "v1 inboxes currently not supported by -purge\n\t",
71 join("\n\t", @err), "\n";
75 my $data = do { local $/; scalar <STDIN> };
76 $data =~ s/\A[\r\n]*From [^\r\n]*\r?\n//s;
79 foreach my $ibx (@inboxes) {
80 my $mime = PublicInbox::MIME->new($data);
81 my $v2w = PublicInbox::V2Writable->new($ibx, 0);
83 my $commits = $v2w->purge($mime) || [];
85 if (my $scrub = $ibx->filter($v2w)) {
86 my $scrubbed = $scrub->scrub($mime, 1);
88 if ($scrubbed && $scrubbed != REJECT()) {
89 my $scrub_commits = $v2w->purge($scrubbed);
90 push @$commits, @$scrub_commits if $scrub_commits;
96 if ($verbose) { # should we consider this machine-parseable?
97 print "$ibx->{mainrepo}:";
98 if (scalar @$commits) {
99 print join("\n\t", '', @$commits), "\n";
104 $n_purged += scalar @$commits;
107 # behave like "rm -f"
108 exit(0) if ($force || $n_purged);
110 warn "Not found\n" if $verbose;