src/Modules/scramble.pl

   1 # Copyright (c) 2003 Chris Angell (chris62vw@hotmail.com). All rights reserved.
   2 # This program is free software; you can redistribute it and/or
   3 # modify it under the same terms as Perl itself.
   4
   5 # Turns this:
   6 # Mary had a little lamb and her fleece was white as snow
   7 # into this:
   8 # Mray had a liltte lmab and her flecee was whtie as sonw
   9
  10 use strict;
  11 use warnings;
  12
  13 package scramble;
  14
  15 sub scramble
  16 {
  17   my ($text) = @_;
  18   my $scrambled;
  19
  20   return unless &::loadPerlModule("List::Util");
  21   srand(); # fork seems to not change rand. force it here
  22   for my $orig_word (split /\s+/, $text)
  23   {
  24     # skip words that are less than four characters in length
  25     $scrambled .= "$orig_word " and next if length($orig_word) < 4;
  26
  27     # get first and last characters, and middle characters
  28     # optional characters are for punctuation, etc.
  29     my ($first, $middle, $last) = $orig_word =~ /^['"]?(.)(.+)'?(.)[,.!?;:'"]?$/;
  30
  31     my ($new_middle, $cnt);
  32
  33     # shuffle until $new_middle is different from $middle
  34     do
  35     {
  36       # theoretically, this loop could loop forever, so
  37       # a counter is used. once $cnt > 10 then use a
  38       # simple regex to scramble and call it good
  39
  40       if (++$cnt > 10)
  41       {
  42         # non-random shuffle, but good enough
  43         ($new_middle = $middle) =~ s/(.)(.)/$2$1/g;
  44       }
  45
  46       # shuffle the middle letters
  47       $new_middle = join '', List::Util::shuffle(split //, $middle);
  48     }
  49     while (($cnt < 10) && ($middle eq $new_middle));
  50
  51     # add the word to the list...
  52     $scrambled .= "$first$new_middle$last ";
  53   }
  54
  55   # remove the single trailing space, and any other space that may have
  56   # been included in the original string
  57   $scrambled =~ s/\s+$//;
  58
  59   &::performStrictReply($scrambled||'Unknown Error Condition');
  60 }
  61
  62 1;