about summary refs log tree commit homepage
path: root/scripts
diff options
context:
space:
mode:
authorEric Wong <e@80x24.org>2015-01-12 01:16:04 +0000
committerEric Wong <e@80x24.org>2015-01-12 01:16:04 +0000
commit34a3b85f4c40d3bd9a50bfab2ac77536cae4fd37 (patch)
tree411a3aee5428647917901c0f6e330efdec2fee93 /scripts
parent8cd7dbc96254f6c19990fc28c266e274cc80ddfb (diff)
downloadpublic-inbox-34a3b85f4c40d3bd9a50bfab2ac77536cae4fd37.tar.gz
This prevents process growth when importing large messages.
Memory growth could be due to the sliding sbrk window in glibc malloc
or a circular reference in the Email::* Perl code somewhere.
Diffstat (limited to 'scripts')
-rwxr-xr-xscripts/import_slrnspool46
1 files changed, 30 insertions, 16 deletions
diff --git a/scripts/import_slrnspool b/scripts/import_slrnspool
index e55c96c7..dd612b1f 100755
--- a/scripts/import_slrnspool
+++ b/scripts/import_slrnspool
@@ -66,27 +66,41 @@ for (; $exit == 0 && $n < $max; $n++) {
         print STDERR $fn, "\n";
         open(my $fh, '<', $fn) or next;
         $max = $n + $max_gap;
-        my $f = Email::Filter->new(data => eval { local $/; <$fh> });
-        my $s = $f->simple;
 
-        # gmane rewrites Received headers, which increases spamminess
-        # Some older archives set Original-To
-        foreach my $x (qw(Received To)) {
-                my @h = $s->header("Original-$x");
-                if (@h) {
-                        $s->header_set($x, @h);
-                        $s->header_set("Original-$x");
+        # prevent process growth by forking a new process for each message
+        my $pid = fork;
+        die "failed to fork: $!\n" unless defined $pid;
+
+        if ($pid == 0) {
+                my $f = Email::Filter->new(data => eval { local $/; <$fh> });
+                close $fh;
+                $fh = undef;
+                my $s = $f->simple;
+
+                # gmane rewrites Received headers, which increases spamminess
+                # Some older archives set Original-To
+                foreach my $x (qw(Received To)) {
+                        my @h = $s->header("Original-$x");
+                        if (@h) {
+                                $s->header_set($x, @h);
+                                $s->header_set("Original-$x");
+                        }
                 }
-        }
 
-        # triggers for the SA HEADER_SPAM rule
-        foreach my $drop (qw(Approved)) { $s->header_set($drop) }
+                # triggers for the SA HEADER_SPAM rule
+                foreach my $drop (qw(Approved)) { $s->header_set($drop) }
 
-        # appears to be an old gmane bug:
-        $s->header_set('connect()');
+                # appears to be an old gmane bug:
+                $s->header_set('connect()');
 
-        $f->exit(0);
-        $f->pipe(@mda);
+                $f->exit(0);
+                $f->pipe(@mda);
+                exit 0;
+        } else {
+                close $fh;
+                waitpid($pid, 0);
+                die "error: $?\n" if $?;
+        }
         $ok = $n + 1;
         set_min($cfg, $ok);
 }