1: #!/usr/bin/perl -w
2:
3: #I didn't intend for something so long to end up on the
4: # frontpage. I'd keep it in Craft if I could. Sorry.
5:
6: #PipsPerlMonksThemer - PPMT
7: # You can play with this craft at http://BinQ.org/ppmt/
8: # Please do... and tell me what you thinq. =)
9:
10: use CGI ":standard";
11: use LWP::UserAgent;
12:
13: my $this = "http://BinQ.org/ppmt/index.cgi";
14: my $filp = "/home/httpd/html/ppmt/filters/";
15: my $favs = "/home/httpd/html/ppmt/favoritz.txt";
16: my $meth = $ENV{'REQUEST_METHOD'};
17: my $quer = $ENV{'QUERY_STRING'};
18: my $what = param("whattodo");
19: my $monk = param("wichmonk");
20: my $site = "http://PerlMonks.org";
21: my $srch = "PerlMonks";
22:
23: my $wich = param("wichfilt");
24: my $nick = param("wichnick");
25: my $uage = new LWP::UserAgent;
26: my @flis = glob("$filp*");
27: $uage->agent("AgentName/0.1 " . $uage->agent);
28: my $requ = "";
29: my $resp = "";
30:
31:
32: print "Content-type: text/html\n\n";
33:
34: if ($quer ne "") {
35: if ($quer =~ /^filt=([^&]*)&/) { $filt = $1; $quer =~ s/^filt=[^&]*&//; }
36: if ($quer !~ /^http\:\/\//) { $quer = "http://" . $quer; }
37: $requ = new HTTP::Request GET => "$quer";
38: $resp = $uage->request($requ);
39: if ($resp->is_success) {
40: $cont = $resp->content;
41: $foun = 0;
42: open FILE, "<$filp$filt";
43: while (<FILE>) {
44: chomp ($parm = $_);
45: chomp ($sour = <FILE>);
46: chomp ($dest = <FILE>);
47: $quer =~ s/(.*\/).*/$1/;
48: $dest =~ s/\{\$quer\}/$quer/;
49: if ($filt eq "randomal") {
50: $whol = $sour;
51: if ($whol =~ /((color="?\#?|\w+="?\#|\w+=")([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})"?)/i) {
52: $redv = $3; $grnv = $4; $bluv = $5;
53: $nred = sprintf "%lx", (rand(255));
54: $ngrn = sprintf "%lx", (rand(255));
55: $nblu = sprintf "%lx", (rand(255));
56: if (length($nred) == 1) { $nred = "0" . $nred; }
57: if (length($ngrn) == 1) { $ngrn = "0" . $ngrn; }
58: if (length($nblu) == 1) { $nblu = "0" . $nblu; }
59: $whol =~ s/(color="?\#?|\w+="?\#)$redv$grnv$bluv"?/$1/i;
60: $whol =~ s/="?\#?/="\#/i;
61: #$whol =~ tr/A-Z/a-z/;
62: $nred =~ tr/a-z/A-Z/;
63: $ngrn =~ tr/a-z/A-Z/;
64: $nblu =~ tr/a-z/A-Z/;
65: $whol .= "$nred$ngrn$nblu\"";
66: $dest = $whol;
67: }
68: }
69: $dlis[$foun] = $dest;
70: if ($foun < 1024) {
71: if ($parm =~ /g/i) {
72: if ($parm =~ /i/i) {
73: $cont =~ s/$sour/SoUr${foun}dEsT/gi;
74: } else {
75: $cont =~ s/$sour/SoUr${foun}dEsT/g;
76: }
77: } else {
78: if ($parm =~ /i/i) {
79: $cont =~ s/$sour/SoUr${foun}dEsT/i;
80: } else {
81: $cont =~ s/$sour/SoUr${foun}dEsT/;
82: }
83: }
84: $foun++;
85: }
86: }
87: while ($foun) {
88: $foun--;
89: if ($parm =~ /g/i) {
90: if ($parm =~ /i/i) {
91: $cont =~ s/SoUr${foun}dEsT/$dlis[$foun]/gi;
92: } else {
93: $cont =~ s/SoUr${foun}dEsT/$dlis[$foun]/g;
94: }
95: } else {
96: if ($parm =~ /i/i) {
97: $cont =~ s/SoUr${foun}dEsT/$dlis[$foun]/i;
98: } else {
99: $cont =~ s/SoUr${foun}dEsT/$dlis[$foun]/;
100: }
101: }
102: }
103: $foun = 1;
104: close FILE;
105: print $cont;
106: } else { print "Bad luck this time\n"; }
107: } elsif ($what && $what ne "creafilt" && $what ne "delefilt") {
108: if ($what eq "mangfavs" || $what eq "updtfavs" || $what eq "add2favs") {
109: print "<html><head><title>PPMT v1.0</title></head>\n";
110: print "<body bgcolor=\"#03071b\" text=\"#03feab\"><center>\n";
111: print "<h1><a href=\"$this\">PPMT v1.0 ndx</a></h1>\n";
112: print "<h2>Favorites</h2>\n";
113: if ($what eq "add2favs") {
114: open FILE, "<$favs";
115: @fvls = <FILE>;
116: close FILE;
117: @chos = split /\s/, $fvls[0];
118: @cvlz = split /\s/, $fvls[1];
119: if ($nick !~ /\#?[0-9A-Fa-f]{6}/) { $wich = "Black"; $nick = "#000000"; }
120: if ($nick !~ /^\#/) { $nick = "\#" . $nick; }
121: if ($wich !~ /\w+/) { $wich = "Black"; }
122: $wich =~ s/\n//g; $nick =~ s/\n//g;
123: $chos[$#chos] = "$wich"; $chos[@chos] = "end\n";
124: $cvlz[$#cvlz] = "$nick"; $cvlz[@cvlz] = "end\n";
125: $fvls[0] = " " . join ' ', @chos;
126: $fvls[1] = " " . join ' ', @cvlz;
127: $fvls[@fvls] = "$wich\n";
128: $fvls[@fvls] = "$nick\n";
129: print "<h2>Adding <i>$wich</i> with value <i>$nick</i> to Favorites!</h2>\n";
130: open FILE, ">$favs";
131: foreach (@fvls) { print FILE $_; }
132: close FILE;
133: } elsif ($what eq "updtfavs") {
134: print "<h2>Updating Favorites!</h2>\n";
135: open FILE, "<$favs";
136: @fvls = <FILE>;
137: close FILE;
138: $fvls[0] = " ";
139: $fvls[1] = " ";
140: $coun = 2;
141: while ($fvls[$coun]) {
142: chomp ($kaka = $fvls[$coun++]);
143: if (param("ChooseColor$kaka") eq "YES") {
144: $fvls[0] .= "$kaka ";
145: chomp ($kaka = $fvls[$coun++]);
146: $fvls[1] .= "$kaka ";
147: }
148: }
149: $fvls[0] .= "end\n";
150: $fvls[1] .= "end\n";
151: open FILE, ">$favs";
152: foreach (@fvls) { print FILE $_; }
153: close FILE;
154: }
155: print "<table border=\"1\"><tr><td>Choose<td>Name<td>Value<td>Example\n";
156: print "<td>\ \;\ \;\ \;\ \;\ \;\ \;\ \;\ \;<td>Choose<td>Name<td>Value<td>Example</tr>\n";
157: print "<form action=\"$this\" method=\"post\">\n";
158: print "<input type=\"hidden\" name=\"whattodo\" value=\"updtfavs\">\n";
159: open FILE, "<$favs";
160: $fnmz = <FILE>;
161: $fvlz = <FILE>;
162: while (<FILE>) {
163: chomp;
164: print "<tr><td align=\"center\"><input type=\"checkbox\" name=\"ChooseColor$_\" value=\"YES\"";
165: if ($fnmz =~ /\s$_\s/) { print " checked"; }
166: print ">\n<td>$_<td>";
167: chomp ($_ = <FILE>);
168: print "$_<td bgcolor=\"$_\">\ \;\ \;<td>\ \;\ \;\ \;\ \;\ \;\ \;\ \;\ \;\n";
169: if ($_ = <FILE>) {
170: # chomp ($_ = <FILE>);
171: chomp;
172: print "<td align=\"center\"><input type=\"checkbox\" name=\"ChooseColor$_\" value=\"YES\"";
173: if ($fnmz =~ /\s$_\s/) { print " checked"; }
174: print ">\n<td>$_<td>";
175: chomp ($_ = <FILE>);
176: print "$_<td bgcolor=\"$_\">\ \;\ \;\n";
177: }
178: }
179: close FILE;
180: print "</table><input type=\"submit\" name=\"submit\" value=\"Update Favorites\"></form>\n";
181: print "<form action=\"$this\" method=\"post\">\n";
182: print "<input type=\"hidden\" name=\"whattodo\" value=\"add2favs\">\n";
183: print "Name: <input type=\"text\" name=\"wichfilt\"><br>\n";
184: print "Value: <input type=\"text\" name=\"wichnick\"><br>\n";
185: print "<input type=\"submit\" name=\"submit\" value=\"Add Choice\"></form>\n";
186: print "<br><h1><a href=\"$this\">PPMT v1.0 ndx</a></h1>\n";
187: print "</body></html>\n";
188: } else {
189: print "<html><head><title>PPMT v1.0</title></head>\n";
190: print "<body bgcolor=\"#03071b\" text=\"#03feab\"><center>\n";
191: print "<h1><a href=\"$this\">PPMT v1.0 ndx</a></h1>\n";
192: if ($what eq "updtseti") {
193: $filt = $wich;
194: $filt =~ s/^.*\///;
195: print "<h2>Updating Filter: <i>$filt</i>!</h2>\n";
196: open FILE, ">$wich";
197: $wich =~ s/.*\/([^\/]+)/$1/;
198: $clim = param("filtcoun");
199: $coun = 1;
200: $blok = "";
201: while ($coun <= $clim) {
202: $parm = param("pArM${coun}PaRm") . param("pAr2${coun}PaR2");
203: $sour = param("sOuR${coun}SoUr");
204: $dest = param("dEsT${coun}DeSt");
205: if (param("pIcK${coun}PiCk") ne "") {
206: $turd = param("pIcK${coun}PiCk");
207: if ($turd =~ /"\#[0-9A-Fa-f]{6}"/) {
208: $dest =~ s/"\#[0-9A-Fa-f]{6}"/$turd/;
209: }
210: }
211: if ($sour ne "") {
212: if ($sour =~ /^"\#?[0-9A-Fa-f]{6}"$/) {
213: if ($dest !~ /^"\#?[0-9A-Fa-f]{6}"$/) {
214: if ($dest =~ /([0-9A-Fa-f]+)/) {
215: $turd = $1;
216: $turd = "0" x (6-length($turd)) . $turd;
217: $dest = "\"\#$turd\"";
218: }
219: }
220: }
221: $sour =~ s/&/&/g;
222: $sour =~ s/"/"/g;
223: $sour =~ s/</</g;
224: $sour =~ s/>/>/g;
225: $sour =~ s/¦/\|/g;
226: $dest =~ s/&/&/g;
227: $dest =~ s/"/"/g;
228: $dest =~ s/</</g;
229: $dest =~ s/>/>/g;
230: $dest =~ s/¦/\|/g;
231: if ($parm =~ /i/i) {
232: if ($blok !~ /\s$coun\s/) {
233: if ($parm =~ /g/i) { print FILE "g"; }
234: print FILE "i\n$sour\n$dest\n";
235: }
236: $pcou = $coun;
237: while (++$pcou < $clim) {
238: if ($sour eq param("sOuR${pcou}SoUr")) { $blok .= " $pcou "; }
239: }
240: } else {
241: if ($parm =~ /g/i) { print FILE "g"; }
242: if ($blok !~ /\s$coun\s/) {
243: print FILE "\n$sour\n$dest\n";
244: }
245: }
246: }
247: $coun++;
248: }
249: close FILE;
250: $wich = $filp . $wich;
251: }
252: open FILE, "<$favs";
253: chomp ($kaka = <FILE>);
254: chomp ($poop = <FILE>);
255: close FILE;
256: @chos = split /\s/, $kaka; $#chos--; @cvlz = split /\s/, $poop; $#cvlz--;
257: $coun = 0;
258: while ($coun < @chos) {
259: $optn .= "<option value=\""$cvlz[$coun]"\">$chos[$coun]\n";
260: $coun++;
261: }
262: print "<h2>Settings for <i>$filt</i>:</h2>\n";
263: print "<form action=\"$this\" method=\"post\">\n";
264: print "<input type=\"hidden\" name=\"whattodo\" value=\"updtseti\">\n";
265: print "<input type=\"hidden\" name=\"wichfilt\" value=\"$wich\">\n";
266: print "<table border=\"1\"><tr><td>Source<td>Destination<td>Global?<td>Ignore Case?\n";
267: open FILE, "<$wich";
268: $wich =~ s/.*\/([^\/]+)/$1/;
269: $coun = 1;
270: while (<FILE>) {
271: chomp ($parm = $_);
272: print "<tr><td><input type=\"text\" size=\"32\" name=\"sOuR${coun}SoUr\" value=";
273: chomp ($kaka = <FILE>);
274: $kaka =~ s/"/"/g;
275: $kaka =~ s/</</g;
276: $kaka =~ s/>/>/g;
277: $kaka =~ s/\|/¦/g;
278: # $kaka =~ s/&/&/g;
279: print "\"$kaka\">\n<td><input type=\"text\" size=\"32\" name=\"dEsT${coun}DeSt\" value=";
280: chomp ($kaka = <FILE>);
281: $kaka =~ s/"/"/g;
282: $kaka =~ s/</</g;
283: $kaka =~ s/>/>/g;
284: $kaka =~ s/\|/¦/g;
285: # $kaka =~ s/&/&/g;
286: if ($kaka =~ /^"\#?[0-9A-Fa-f]{6}"$/) { $kaka =~ tr/a-f/A-F/; }
287: print "\"$kaka\">\n";
288: if ($coun < 8 && $kaka =~ /("\#[0-9A-Fa-f]{6}")/) { #1024
289: $turd = $1; $poop = $optn; if ($poop =~ /="$turd">/i) { $poop =~ s/(="$turd")>/$1 selected>/i; }
290: print "<select name=\"pIcK${coun}PiCk\"><option>$poop</select>\n";
291: }
292: print "<td><input type=\"checkbox\" name=\"pArM${coun}PaRm\" value=\"g\"";
293: if ($parm =~ /g/i) { print " checked"; }
294: print ">\n";
295: print "<td><input type=\"checkbox\" name=\"pAr2${coun}PaR2\" value=\"i\"";
296: if ($parm =~ /i/i) { print " checked"; }
297: print ">\n";
298: $coun++;
299: }
300: close FILE;
301: print "<tr><th colspan=\"4\">Create New Filter<tr><td><input type=\"text\" size=\"32\" name=\"sOuR${coun}SoUr\">\n";
302: print "<td><input type=\"text\" size=\"32\" name=\"dEsT${coun}DeSt\">\n";
303: print "<select name=\"pIcK${coun}PiCk\"><option>$optn</select>\n";
304: print "<td><input type=\"checkbox\" name=\"pArM${coun}PaRm\" value=\"g\">\n";
305: print "<td><input type=\"checkbox\" name=\"pAr2${coun}PaR2\" value=\"i\">\n";
306: print "</table><input type=\"hidden\" name=\"filtcoun\" value=\"$coun\">\n";
307: print "<input type=\"submit\" name=\"submit\" value=\"Update Settings\"></form>\n";
308: print "<br><h1><a href=\"$this\">PPMT v1.0 ndx</a></h1>\n";
309: print "</body></html>\n";
310: }
311: } else {
312: print "<html><head><title>PPMT v1.0</title></head>\n";
313: print "<body bgcolor=\"#03071b\" text=\"#03feab\"><center>\n";
314: print "<h1><a href=\"$this\">PPMT v1.0 ndx</a></h1>\n";
315: print "<h3>This is PipsPerlMonksThemer. Please create a new theme.</h3>\n";
316: print "<h3>See my settings for examples below. Please also be courteous and refrain from changing other Monk\'s settings. If you wish to experiment without creating a new theme, please use the AnonymousMonk theme. Also note (thanks to Aighearach) when you login, your password is sent directly to PerlMonks.org so your theme settings will be discarded once you login. I mainly intended this to be a theme specification tool so that we could define and preview different themes for potential implementation as genuine user options. Thank you very much.</h3>\n";
317: print "<h3>Email me (<a href=\"mailto:pip\@BinQ.org\">PipTigger</a>) if you have any comments or recommendations. TTFN.</h3>\n";
318: if ($what eq "creafilt") {
319: if ($monk eq "") {
320: $monk = "AnonymousMonk";
321: unlink "$filp$monk";
322: print "<h2>Auto-Deleted && Created New Theme For: <i>AnonymousMonk</i>!</h2>\n";
323: } else {
324: $monk =~ s/\W//g;
325: }
326: open FILE, ">$filp$monk";
327: $requ = new HTTP::Request GET => "$site";
328: $resp = $uage->request($requ);
329: if ($resp->is_success) {
330: $cont = $resp->content;
331: while ($cont =~ /((color="?\#?|\w+="?\#|\w+=")([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})"?)/i) {
332: $whol = $owhl = $1; $redv = $3; $grnv = $4; $bluv = $5;
333: print FILE "\n$whol\n";
334: if (param("autodata")) {
335: if (param("autodata") eq "inverted") {
336: $nred = sprintf "%lx", (255-hex("$redv"));
337: $ngrn = sprintf "%lx", (255-hex("$grnv"));
338: $nblu = sprintf "%lx", (255-hex("$bluv"));
339: } else {
340: $nred = sprintf "%lx", (rand(255));
341: $ngrn = sprintf "%lx", (rand(255));
342: $nblu = sprintf "%lx", (rand(255));
343: }
344: if (length($nred) == 1) { $nred = "0" . $nred; }
345: if (length($ngrn) == 1) { $ngrn = "0" . $ngrn; }
346: if (length($nblu) == 1) { $nblu = "0" . $nblu; }
347: $whol =~ s/(color="?\#?|\w+="?\#)$redv$grnv$bluv"?/$1/i;
348: $whol =~ s/="?\#?/="\#/i;
349: #$whol =~ tr/A-Z/a-z/;
350: $nred =~ tr/a-z/A-Z/;
351: $ngrn =~ tr/a-z/A-Z/;
352: $nblu =~ tr/a-z/A-Z/;
353: $whol .= "$nred$ngrn$nblu\"";
354: }
355: print FILE "$whol\n";
356: $cont =~ s/$owhl//;
357: }
358: print FILE "\n<FORM METHOD=\"POST\" ACTION=\"index.pl\"\n<form action=\"http://PerlMonks.org/index.pl\" method=\"post\"\n";
359: print FILE "\n<FORM METHOD=\"POST\"\n<form action=\"http://PerlMonks.org/index.pl\" method=\"post\"\n";
360: if (param("autodata") eq "randomal") {
361: $monk = "randomal";
362: }
363: if ($cont =~ /href=("?)$site\//i) {
364: $sour = $1;
365: print FILE "gi\nhref=$sour$site/\nhref=$sour$this?filt=$monk&$site/\n";
366: $cont =~ s/href=$sour$site\///gi;
367: }
368: if ($cont =~ /href=("?)\//i) {
369: $sour = $1;
370: print FILE "gi\nhref=$sour/\nhref=$sour$this?filt=$monk&$site/\n";
371: $cont =~ s/href=$sour\///gi;
372: }
373: if ($cont =~ /src=("?)\//i) {
374: $sour = $1;
375: print FILE "gi\nsrc=$sour/\nsrc=$sour$site/\n";
376: $cont =~ s/src=$sour\///gi;
377: }
378: } else { print "Bad luck this new time\n"; }
379: close FILE;
380: @flis = glob("$filp*");
381: }
382: if ($what eq "delefilt") {
383: unlink "$filp$monk";
384: @flis = glob("$filp*");
385: print "<h2>Deleted <i>$monk</i>!</h2>\n";
386: }
387: print "<table border=\"1\"><form action=\"$this\" method=\"post\">\n";
388: print "<input type=\"hidden\" name=\"whattodo\" value=\"creafilt\">\n";
389: print "<tr><td>PerlMonks UserName: <td><input type=\"text\" size=\"32\" name=\"wichmonk\">\n";
390: print "<tr><td align=\"center\">InvertColors?: <input type=\"radio\" name=\"autodata\" value=\"inverted\">\n";
391: print "<br>RandomizeColors?: <input type=\"radio\" name=\"autodata\" value=\"randomiz\">\n";
392: print "<br>AlwaysRandomColors?: <input type=\"radio\" name=\"autodata\" value=\"randomal\">\n";
393: print "<td><br><input type=\"submit\" name=\"submit\" value=\"Create New PerlMonks Theme\"></form>\n";
394: print "</td></tr></table>\n";
395: print "<table border=\"1\"><tr><td>PerlMonk:<td>Change\n";#<td>Remove\n";
396:
397: foreach $filt (@flis) {
398: $kaka = $filt;
399: $kaka =~ s/^$filp//;
400: if ($kaka ne "randomal") {
401: print "<tr><td><h3><a href=\"$this?filt=$kaka&$site\">$kaka</a></h3>\n";
402: print "<td><form action=\"$this\" method=\"post\">\n";
403: print "<input type=\"hidden\" name=\"whattodo\" value=\"chngseti\">\n";
404: print "<input type=\"hidden\" name=\"wichfilt\" value=\"$filt\">\n";
405: print "<input type=\"submit\" name=\"submit\" value=\"Settings\"></form>\n";
406: #print "<td><form action=\"$this\" method=\"post\">\n";
407: #print "<input type=\"hidden\" name=\"whattodo\" value=\"delefilt\">\n";
408: #print "<input type=\"hidden\" name=\"wichfilt\" value=\"$filt\">\n";
409: #print "<input type=\"submit\" name=\"submit\" value=\"DELETE\"></form>\n";
410: }
411: }
412: print "</table>\n";
413: print "<br><form action=\"$this\" method=\"post\">\n";
414: print "<input type=\"hidden\" name=\"whattodo\" value=\"mangfavs\">\n";
415: print "<input type=\"submit\" name=\"submit\" value=\"Manage Favorites\"></form>\n";
416: print "</body></html>\n";
417: }
418: # $requ = new HTTP::Request GET => 'http://razorstorm.net';
419: # $requ->content_type('application/x-www-form-urlencoded');
420: # $requ->content('match=www&errors=0');
421: # my $resp = $uage->request($requ);
422: # if ($resp->is_success) { print $resp->content; }
423: # else { print "Bad luck this time\n"; }
Back to
Craft