1: #!/usr/bin/perl -w
2:
3: # Feel need to prove someone's satan's pawn?
4: # This script mutilates given name to make the
5: # sum of ASCII codes 666 (or any number for that).
6: # Currently quite limited in mutilation strength, I ran
7: # out of interest.
8:
9: $debug=0;
10:
11: @number=(666);
12: $verbose=1;
13: $quitfirst=0;
14: $viewnumber=0;
15: $factual=0;
16: $listnumber=0;
17:
18: while (@ARGV) {
19: $t = shift(@ARGV);
20:
21: if ($t eq "-help") {
22: print<<END_OF_HELP
23: Usage: satanizer.pl [parameters] <name>
24:
25: "Here is the wisdom. Let him that hath understanding count the number of
26: the beast; for it is the number of a man; and his number is
27: Six hundred threescore and six"
28:
29: This program will help you in easily identifying the people who carry
30: Shai'tan, the Prince of Lies, in their heart through the number of 666.
31: Just supply the name of person to be examined on the command line and
32: program will report his true loyalties.
33:
34: Parameters:
35:
36: -number NUM[,NUM...] Use alternative number(s) instead of 666. You
37: may also supply multiple numbers, in which
38: case all of them will be checked.
39: -silent Output only matching names, name-per-line, no
40: useless babble included.
41: -stop In case of multiple numbers, stop after first
42: matching number.
43: -list-number Under -silent, append the number that matched
44: after the name in output.
45: -view-number Report which number the person would match to
46: without mutilation.
47: -proper Speak sensibly.
48: -file FILE Get the names to be used from FILE, name per
49: line. Further names on command line will be
50: ignored.
51:
52: DISCLAIMER: If you are offended by this program, I laugh at you. Please
53: send emails condemning me to hell for blashpemy to kaatunut\@iki.fi, I
54: will enjoy them.
55:
56: Send bug reports to kaatunut\@iki.fi.
57: END_OF_HELP
58: ;
59: exit;
60: } elsif ($t eq "-version") {
61: print<<END_OF_TEXT
62: Satanize 0.1
63:
64: (c) 2000, Juhan Aslak Näkkäläjärvi
65:
66: This program is free software, and is under the GPL license.
67: END_OF_TEXT
68: } elsif ($t eq "-number") {
69: @number=split /,/,shift(@ARGV);
70: } elsif ($t eq "-silent") {
71: $verbose=0;
72: } elsif ($t eq "-stop") {
73: $quitfirst=1;
74: } elsif ($t eq "-list-number") {
75: $listnumber=1;
76: } elsif ($t eq "-view-number") {
77: $viewnumber=1;
78: } elsif ($t eq "-proper") {
79: $factual=1;
80: } elsif ($t eq "-file") {
81: $filename=shift(@ARGV);
82: open(FILE,$filename) or die "can't open $filename!";
83: push @name,$_ while (<FILE>);
84: close(FILE);
85: chomp @name;
86: } elsif (substr($t,0,1) eq "-") {
87: print "Unknown parameter \'$t\'.\n";
88: } elsif (!@name) {
89: $name[0]=$t;
90: while (@ARGV) {
91: $name[0].=" ".shift(@ARGV);
92: }
93: }
94: }
95: if (!defined $listnumber) {
96: if (!$verbose && !$quitfirst) {
97: $listnumber=0;
98: } else {
99: $listnumber=1;
100: }
101: }
102:
103: if (!@name) {
104: print "You need to supply a name.\n";
105: exit;
106: }
107:
108: for $j (0 .. $#name) {
109: for $i (0 .. $#number) {
110: my $t;
111:
112: $ret=satanize($name[$j],$number[$i],\$mutilation,\$t,0);
113:
114: if ($viewnumber) {
115: print "$name[$j]\'s number is $t\n";
116: $viewnumber=0;
117: }
118:
119: if (!$ret) {
120: if (satanize($mutilation,$number[$i],0,\$t,1),$t!=$number[$i]) {
121: die "satanization failure";
122: }
123: if ($verbose) {
124: if ($factual) {
125: print "$mutilation matches to $number[$i].\n";
126: } elsif ($number[$i]==666) {
127: print "$mutilation is the Satan's incarnate on earth!\n";
128: } else {
129: print "$mutilation was born to the number $number[$i].\n";
130: }
131: } else {
132: print "$mutilation";
133: print " - $number[$i]" if $listnumber;
134: print "\n";
135: }
136: last if $quitfirst;
137: } elsif ($verbose) {
138: if ($ret==1) {
139: if ($factual) {
140: print
141: "$name[$j] cannot be made to have asciisum of $number[$i] by any currently ".
142: "used mutilation methods. Try changing non-trivial spelling (ie. letters).\n";
143: } elsif ($number[$i]==666) {
144: print
145: "$name[$j]\'s waveform seems to indicate that it is a human. It might be a ".
146: "guise though, try changing some letters in the name.\n";
147: } else {
148: print
149: "$name[$j]\'s waveform does not match to number $number[$i].\n";
150: }
151: } elsif ($ret==2) {
152: if ($factual) {
153: print
154: "$name[$j] has too few non-whitespaces to reach $number[$i]. Try adding some.\n";
155: } elsif ($number[$i]==666) {
156: print
157: "$name[$j] has some satanic breed but it lacks strength.\n";
158: } else {
159: print
160: "$name[$j] has shown potential tendencies towards number $number[$i], but it ".
161: "has no power to reach that.\n";
162: }
163: } elsif ($ret==3) {
164: if ($factual) {
165: print
166: "$name[$j] has too many non-whitespaces to reach $number[$i]. Try removing some.\n";
167: } elsif ($number[$i]==666) {
168: print
169: "$name[$j] has some satanic breed but it cannot contain its powers.\n";
170: } else {
171: print
172: "$name[$j] has shown potential tendencies towards number $number[$i], but it ".
173: "cannot contain its powers.\n";
174: }
175: } else {
176: print "ACK! $name[$j] must be Satan Himself, you shouldn't ".
177: "see this message ever :(\n";
178: }
179: }
180: }
181: }
182: ## satanize(name,number,outname,outnumber,short)
183: sub satanize {
184: my($name,$number)=@_;
185: my $num=0;
186: my $times=0;
187: my $lcase_num=0,$ucase_num=0,$space_num=0;
188: my($c,$i,@upl,@downl,@spacel);
189:
190: for $i (0 .. (length $name)-1) {
191: $c=substr($name,$i,1);
192: $num+=ord $c;
193: if ($c eq " ") {
194: $space_num++;
195: push @spacel,$i;
196: } elsif ($c ne uc $c) {
197: $lcase_num++;
198: push @downl,$i;
199: } elsif ($c ne lc $c) {
200: $ucase_num++;
201: push @upl,$i;
202: }
203: }
204:
205: ${$_[3]}=$num if $viewnumber || $_[4];
206: return $num if $_[4];
207:
208: if ($num==$number) {
209: ${$_[2]}=$name;
210: return 0;
211: }
212:
213: if ((abs($number-$num) % abs(ord('a')-ord('A')))) {
214: print "nondivisible\n" if $debug;
215: return 1; # not divisible
216: }
217: $times=($number-$num)/abs(ord('a')-ord('A'));
218: if (($times<0 && (-$times)>($lcase_num+$space_num)) ||
219: ($times>0 && $times>$ucase_num)) {
220: print "not enough space: $times transformations needed\n" if $debug;
221: return 2 if $times>0;
222: return 3 if $times<0;
223: }
224: # capitalizing rule: find existing capitalized points and start adding to them
225: # decapitalizing rule: drop capitalized letters randomly
226: # spacing rule: remove random spaces after everything is capitalized
227: ${$_[2]}=$name;
228: if ($times<0) { # Capitalize
229: my $p=0;
230: if (!@upl || $upl[0]!=0) {
231: splice @upl,0,0,-1;
232: }
233: print "capitalize $times times\n" if $debug;
234: while ($times && @upl) {
235: do {
236: $upl[$p]++;
237: if ($upl[$p]>=(length ${$_[2]})
238: || (substr(${$_[2]},$upl[$p],1)
239: ne lc substr(${$_[2]},$upl[$p],1))) {
240: # kill this pointer (and move to next in row):
241: # at the end of string or at ucase character
242: print "kill pointer $p at $upl[$p]\n" if $debug;
243: splice @upl,$p,1;
244: if (@upl) {
245: $p=0 if $p > $#upl;
246: redo;
247: } else {
248: print "break\n" if $debug;
249: last;
250: }
251: } elsif (substr(${$_[2]},$upl[$p],1)
252: eq uc substr(${$_[2]},$upl[$p],1)) {
253: # ignore: uppercase or special character-
254: # but uppercase was checked above so spec char
255: redo;
256: }
257: } while (0);
258: last if not @upl;
259: substr(${$_[2]},$upl[$p],1)=uc substr(${$_[2]},$upl[$p],1);
260: print " =>${$_[2]}\n" if $debug;
261: $p++;
262: $p=0 if $p>=@upl;
263: print "p now: $p\n" if $debug;
264: $times++;
265: }
266: if ($times) { # time to remove some spaces!
267: my @kill_list;
268: while ($times) {
269: $p=int rand @spacel;
270: push @kill_list,$spacel[$p];
271: splice @spacel,$p,1;
272: $times++;
273: }
274: @kill_list=reverse sort @kill_list;
275: print "kill ".@kill_list." spaces\n" if $debug;
276: for $i (0 .. $#kill_list) {
277: substr(${$_[2]},$kill_list[$i],1)="";
278: }
279: }
280: return 0;
281: } else {
282: my $p;
283: print "decapitalize $times times\n" if $debug;
284: while ($times) {
285: $p=int rand @upl;
286: substr(${$_[2]},$upl[$p],1)=lc substr(${$_[2]},$upl[$p],1);
287: splice @upl,$p,1;
288: $times--;
289: }
290: return 0;
291: }
292: print "bug- shouldn't be here\n";
293: return 100;
294: }