#!/usr/bin/perl
#
# ----------------------------------------------------------------------------
#
#	Password list maker
#
#	Toby Oxborrow <toby@oxborrow.net>
#	Version 0.1 (July 2001)
#
# ----------------------------------------------------------------------------
#
#	!! WORDFILE NOT INCLUDED !!
#	Your system may have a dictionary file you can use, or if you go to
#	http://www.google.com and type 'wordlists' you'll find some.
#	It would probably help if you chose a names wordfile (peoples first
#	names), then a topic that your subjects might know about
#	(sci-fi, literature, sport) put these two files together and you'll
#	have the perfect input wordlist.
#
#	Takes an input wordlist file (words.txt) and generates an output file
#	(pwords.txt) containing passwords 8-15 characters long.
#	This can be used to replace randomly generated passwords, eg:
#	"j5DxaE", which are tricky to remember, however, bunched up words like
#	what this script makes are far easier.  So it would ideally be used
#	when you create some new user account for some system
#	(web site forum?) and you need a initial password.
#
#	Words from the input file >=4 and <=7 characters are mixed
#	with similar sized words to move them into the 8-15 range.
#	Eg. if an input file contained the three words:
#		aegeon
#		bagot
#		northampton
#	Then the output would be:
#		AegeonBagot
#		Northampton
#	Words greater than 15 characters are ignored, as are words
#	smaller than 4.
#
#	As you can see from the output, the inital letter is forced
#	to uppercase, the rest of the word is lowercase, this helps
#	people to remember the password.
#
#	Ideally, when mixing words it tries (15 times) to find another
#	word which doesnt start the same as the first word, so:
#		adurant
#		aediles
#		aegeon
#		aeglos
#		aegnor
#		bagot
#	*Should* return 'AdurantBagot' as part of the output based on this
#	principle.  It could fail because it picks who to try by random
#	and theoretically it may never pick the index for bagot.
#
#	If there is one suitable word for mixing left but no match, then
#	the word is ignored.  Once a word is used, it is removed from possible
#	candidates for further mixing.
#
#	By default, this script just mixes smaller words, to allow long
#	(single) words, uncomment &add_LWords; on or around line 62.
#

use strict;		# (; enable leet code ;)

my @swords;		# small words
my @lwords;		# long words

&main;

exit;


sub main()
{

	&loadWords;


	open OUTFILE, '>pwords.txt';

	&add_SWords;

#	&add_LWords;

	close OUTFILE;

}


sub loadWords()
{

	my $pword;
	my $len;

	open WORDS, '<words.txt' || die "Could not open file (WORDS) because: $!";
	while (<WORDS>) {
		chomp;
		$pword = lc($_);
		$len = length($pword);

		if (($len >= 4) && ($len <= 7)) {
			push @swords, $pword;
		} elsif (($len > 7) && ($len <= 15)) {
			push @lwords, $pword;
		}
	}
	close WORDS;

}


sub add_SWords()
{

	my $word1;
	my $word2;

	srand;

	while (1) {
		$word1 = &GetSWord();
		if ($word1 eq '__end__') { last }
		$word2 = &GetSWord($word1);
		if ($word2 eq '__end__') { last }
		print OUTFILE "$word1$word2\n";
	}

}


sub GetSWord()
{

	#srand;
	my $w = $_[0];		$w =~ m/^./;	$w = $&;
	my $x;
	my $u = @swords;	if ($u == 0) { return '__end__' }
	my $r = int(rand($u));
	my $last;
	my $word;
	my $tries = 0;

	while(1) {
		$word = @swords[$r];
		$word =~ m/^./;	$x = uc($&);
		if ($x ne $w) {
			splice @swords, $r, 1;
			$word = $x.lc($');
			return $word;
		}
		# try again...
		$last = $r;
		while ($r == $last) { $r = int(rand($u)) }
		$tries++;
		if ($tries > 10) { last }	# give up
	}

	return;

}

sub add_LWords()
{

	my $lword;

	foreach $lword (@lwords) {
		$lword =~ m/^./;
		$lword = uc($&).lc($');
		print OUTFILE "$lword\n";
	}

}