diff --git a/tools/topsubcount b/tools/topsubcount
new file mode 100755
index 0000000000000000000000000000000000000000..743e6fa00d3081875e14d007b50d8d0cff153864
--- /dev/null
+++ b/tools/topsubcount
@@ -0,0 +1,26 @@
+#!/usr/bin/perl -w
+# topsubcount - find the addresses with the most subscriptions
+# NOTE: this script requires the current user has read access to the db
+# Matt Taggart <taggart@riseup.net> 2018-02
+
+$listsql='mysql -N --batch --database=sympa --execute "select user_subscriber,list_subscriber from subscriber_table"';
+
+open(LISTDUMP, "$listsql|") or die "cannot get dump of address+list pairs from database\n";
+
+while (<LISTDUMP>) {
+   chomp;
+   # match sane address and list
+   m/^<?(.*\@.*?)>?\s*\t(.*)$/;
+   $address=$1;
+   $list=$2;
+
+   # hash of arrays, key is address, arrays contain list names
+   push @{ $subcount{$address} }, $list;
+}
+
+# sort by number of lists subscribed
+foreach $address ( sort { scalar @{ $subcount{$b} } <=> scalar @{ $subcount{$a} } } keys %subcount) {
+#foreach $address ( sort keys %subcount) {
+   print "$address ", scalar @{ $subcount{$address} }, "\n";
+}
+