In a YaBB Forum (http://www.yabbforum.com), removes deadbeat members created by spamming attempts

YaBBCullDeadbeatMembers.pl

#!/usr/bin/perl

=com

This script takes one parameter, the path/to/Members subdirectory of a YaBB 2.4 directory.  It deletes files of any members who have registered more than 72 hours ago, and have never posted any posts that have not been removed.  Presumably such members were registered by spammers' robots.

It also modifies the 'memberlist.txt' and 'memberinfo.txt' files in there appropriately, deleting the culled members.  It does not touch the 'memberlist.inactive', which appears to be records of "new members who have not yet registered".

This script has been tested in Mac OS X and should work in any Unix system.

Do not put a slash after "Members" in the parameter.

*Do* run this on a copy, or make a backup copy of your Members directoroy prior to running this on your data, because any members found to be unreadable will be deleted.  This has the advantage of clearing out corrupt cruft, but has the disadvantage that if YaBB changes their file format, all of your members will probably be judged as unreadable and deleted.  To change this behavior, see Note DeleteUnreadable below.

=cut


use strict ;
use File::Basename ;
require File::Util ;


=com
From the documentation for Cwd,
"If you ask to override your chdir() built-in function,
  use Cwd qw(chdir);
then your PWD environment variable will be kept up to date. Note that it will only be kept up to date if all packages which use chdir import it from Cwd."
We certainlly want our PWD variable to be kept up to date, so we do it!...
=cut
use Cwd qw(chdir) ;
=com
# Archive::Zip was abandoned because it does not properly copy symbolic links.
use Archive::Zip qw( :ERROR_CODES :CONSTANTS ) ;
=cut


my $verbose = 1 ;
my $fileUtil = File::Util->new() ;

# Open access to configuration file specified as the argument
#my $configPath = '/Users/jk/Documents/Programming/Projects/Bookdog/Bookdog.shipconfig.txt' ;
my $configPath = $ARGV[0] ;

my $membersDir = $ARGV[0] ;


# Parse the files and create the list of @keepers, the members whom we are going to keep.
print ("*** Parsing members...\n") ;
my @keepers ;
my @rawNames = $fileUtil->list_dir($membersDir, qw/--no-fsdots --files-only/) ;
my $i ;

my $nNew = 0 ;
my $nActive = 0 ;
my $nDeadbeat = 0 ;
my $nUnreadable = 0 ;
my $nTotal = 0 ;
my $cutoffTime = time - (72 * 60 * 60) ;
for ($i=0; $i<@rawNames; $i++) {
	my $rawName = $rawNames[$i] ;
	my @splits = split(/\./, $rawName) ;
	my $name = $splits[0] ;
	my $suffix = $splits[1] ;
	my $n = length(@splits) ;
	if ($suffix eq "vars") {
		open (VARS, $membersDir . "/" . $rawName) ;
		my $j = 0 ;
		my @varsLines ;
		my $zeroPosts = -1 ;
		my $shouldHavePostedByNow = -1 ;
		while (my $aLine = <VARS>) {
			chomp($aLine) ;
			my $substring ;
			
			# Look for the line
			#   'postcount',"NNN"
			# and extract the NNN, which is a number, as $postCount
			$substring = substr($aLine, 0, 13) ;
			if ($substring eq "'postcount',\"") {
				my $gotIt = $aLine =~ m/"(\d+)"/ ;
				my $postCount = -1 ;
				if ($gotIt) {
					$postCount = $1 ;
					if ($postCount == 0) {
						$zeroPosts = 1 ;
					}
					else {
						$zeroPosts = 0 ;
					}
				}
			}

			# Look for the line
			#   'regtime',"NNNNNNNNNN"
			# and extract the NNNNNNNNNN, which is a number, as $retime
			# (It is the registration time since Unix epoch.)
			$substring = substr($aLine, 0, 11) ;
			if ($substring eq "'regtime',\"") {
				my $gotIt = $aLine =~ m/"(\d+)"/ ;
				my $regtime = -1 ;
				if ($gotIt) {
					$regtime = $1 ;
					if ($regtime < $cutoffTime) {
						$shouldHavePostedByNow = 1 ;
					}
					else {
						$shouldHavePostedByNow = 0 ;
					}
				}
			}
			
			# If we've got both values we need, stop looking and summarize
			if (($zeroPosts != -1) && ($shouldHavePostedByNow != -1)) {
				if ($zeroPosts == 0) {
					printf("Keeping active $name\n") ;
					$nActive++ ;
					push (@keepers, $name) ;
				}
				elsif ($shouldHavePostedByNow == 0) {
					$nNew++ ;
					printf("Keeping new $name\n") ;
					push (@keepers, $name) ;
				}
				else {
					$nDeadbeat++ ;
				}
				last ;
			}
		}
		
		# If we've got both values we need, stop looking and summarize
		if (($zeroPosts == -1) || ($shouldHavePostedByNow == -1)) {
			$nUnreadable++ ;
			# Note DeleteUnreadable:
			# To keep unreadable members, uncomment the next line.
			# push (@keepers, $name) ;
		}
		
		$nTotal++ ;
		close(VARS) ;
	}
}

# Because Perl does not have a "isInArray() or isInList() function, we create a hash of undefined (I think) values whose keys are the members of @keepers.  Then in the loop which follows, we ask if a given key exists.
my %hashOfKeepers ;
@hashOfKeepers{@keepers} = () ;


print ("*** Deleting deadbeat members' .var files...\n") ;
# Cull zero-post members by deleting all of their files.
for ($i=0; $i<@rawNames; $i++) {
	my $rawName = $rawNames[$i] ;
	my @splits = split(/\./, $rawName) ;
	my $name = $splits[0] ;
	if (!(exists($hashOfKeepers{$name}))) {
		if ($rawName ne "memberinfo.txt") {
			if ($rawName ne "memberlist.txt") {
				if ($rawName ne "memberlist.inactive") {
					my $path = $membersDir . "/" . $rawName ;
					unlink($path) ;
				}
			}
		}
	}
}

print ("*** Results:\n") ;
print ("  Culled $nDeadbeat deadbeat members\n") ;
print ("  Culled $nUnreadable unreadable members\n") ;
print ("  Kept $nActive active members\n") ;
print ("  Kept $nNew new members\n") ;
print ("  Total processed: $nTotal\n") ;


# Parse memberlist.txt and create new text for it containing only lines of kept members.
{
	print ("*** Fixing memberlist.txt...\n") ;
	my $memberListPath = $membersDir . "/" . "memberlist.txt" ;
	open (MEMBERLIST, $memberListPath) or die("Could not [1] open $memberListPath\n") ;
	my @linesToKeep ;
	while (my $aLine = <MEMBERLIST>) {
		# Don't chomp; leave newlines.
		my ($name, $someNumber) = split(/\t/, $aLine) ;
		# I'm not sure someNumber is.  Looks like it might be date joined in Unix time.  We just pass it through.
		if ((exists($hashOfKeepers{$name}))) {
			print ("   Will keep: $name\n") ;
			push @linesToKeep, $aLine ;
		}
	}
	close(MEMBERLIST) ;
	
	# Overwrite memberlist.txt with the kept members
	#    >  truncate is to overwrite/truncate
	open (MEMBERLIST,">$memberListPath") or die("Could not [2] open $memberListPath\n") ;
	for ($i=0; $i<@linesToKeep; $i++) {
		# $linesToKeep[$i] includes a newline on the end
		print MEMBERLIST "$linesToKeep[$i]" ;
	}
	close (MEMBERLIST) ;
}

# Parse memberinfo.txt and create new text for it containing only lines of kept members.
{
	print ("*** Fixing memberinfo.txt...\n") ;
	my $memberInfoPath = $membersDir . "/" . "memberinfo.txt" ;
	open (MEMBERINFO, $memberInfoPath) or die("Could not [1] open $memberInfoPath\n") ;
	my @linesToKeep ;
	while (my $aLine = <MEMBERINFO>) {
		# Example aLine:
		# SharylLin	Sharyl Lindley|rothsteinuz@hotmail.com||0|
		# Don't chomp; leave newlines.
		my ($name, $pipeSeparatedFields) = split(/\t/, $aLine) ;
		if ((exists($hashOfKeepers{$name}))) {
			print ("   Will keep: $name\n") ;
			push @linesToKeep, $aLine ;
		}
	}
	close(MEMBERINFO) ;
	
	# Overwrite memberinfo.txt with the kept members
	#    >  truncate is to overwrite/truncate
	open (MEMBERINFO,">$memberInfoPath") or die("Could not [2] open $memberInfoPath\n") ;
	for ($i=0; $i<@linesToKeep; $i++) {
		# $linesToKeep[$i] includes a newline on the end
		print MEMBERINFO "$linesToKeep[$i]" ;
	}
	close (MEMBERINFO) ;
}

print ("*** Done.\n") ;