PageRenderTime 51ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 0ms

/modules/ideone.pl

http://pbot2-pl.googlecode.com/
Perl | 799 lines | 699 code | 92 blank | 8 comment | 99 complexity | 06bb2bc25137038c47600e06d3a3fdec MD5 | raw file
Possible License(s): LGPL-2.0 
    

  1. #!/usr/bin/perl
    2. 

  2. 

  3. # use warnings;
    4. 

  4. use strict;
    5. 

  5. use feature qw(switch);
    6. 

  6. 

  7. use SOAP::Lite;
    8. 

  8. $SOAP::Constants::DO_NOT_USE_XML_PARSER = 1;
    9. 

  9. use IPC::Open2;
    10. 

  10. use HTML::Entities;
    11. 

  11. use Text::Balanced qw(extract_codeblock extract_delimited);
    12. 

  12. 

  13. my $user = 'test';
    14. 

  14. my $pass = 'test';
    15. 

  15. my $soap = SOAP::Lite->new(proxy => 'http://ideone.com/api/1/service');
    16. 

  16. my $result;
    17. 

  17. 

  18. my $MAX_UNDO_HISTORY = 100;
    19. 

  19. 

  20. my $output = "";
    21. 

  21. my $nooutput = 'No output.';
    22. 

  22. 

  23. my %languages = (
    24. 

  24.   'Ada'                          => { 'id' =>    '7', 'name' => 'Ada (gnat-4.3.2)'                                 },
    25. 

  25.   'asm'                          => { 'id' =>   '13', 'name' => 'Assembler (nasm-2.07)'                            },
    26. 

  26.   'nasm'                         => { 'id' =>   '13', 'name' => 'Assembler (nasm-2.07)'                            },
    27. 

  27.   'gas'                          => { 'id' =>   '45', 'name' => 'Assembler (gcc-4.3.4)'                            },
    28. 

  28.   'Assembler'                    => { 'id' =>   '13', 'name' => 'Assembler (nasm-2.07)'                            },
    29. 

  29.   'Assembler'                    => { 'id' =>   '13', 'name' => 'Assembler (nasm-2.07)'                            },
    30. 

  30.   'gawk'                         => { 'id' =>  '104', 'name' => 'AWK (gawk) (gawk-3.1.6)'                          },
    31. 

  31.   'mawk'                         => { 'id' =>  '105', 'name' => 'AWK (mawk) (mawk-1.3.3)'                          },
    32. 

  32.   'Bash'                         => { 'id' =>   '28', 'name' => 'Bash (bash 4.0.35)'                               },
    33. 

  33.   'bc'                           => { 'id' =>  '110', 'name' => 'bc (bc-1.06.95)'                                  },
    34. 

  34.   'Brainfuck'                    => { 'id' =>   '12', 'name' => 'Brainf**k (bff-1.0.3.1)'                          },
    35. 

  35.   'bf'                           => { 'id' =>   '12', 'name' => 'Brainf**k (bff-1.0.3.1)'                          },
    36. 

  36.   'gnu89'                        => { 'id' =>   '11', 'name' => 'C (gcc-4.3.4)'                                    },
    37. 

  37.   'C89'                          => { 'id' =>   '11', 'name' => 'C (gcc-4.3.4)'                                    },
    38. 

  38.   'C'                            => { 'id' =>   '11', 'name' => 'C (gcc-4.3.4)'                                    },
    39. 

  39.   'C#'                           => { 'id' =>   '27', 'name' => 'C# (gmcs 2.0.1)'                                  },
    40. 

  40.   'C++'                          => { 'id' =>    '1', 'name' => 'C++ (gcc-4.3.4)'                                  },
    41. 

  41.   'C99'                          => { 'id' =>   '34', 'name' => 'C99 strict (gcc-4.3.4)'                           },
    42. 

  42.   'CLIPS'                        => { 'id' =>   '14', 'name' => 'CLIPS (clips 6.24)'                               },
    43. 

  43.   'Clojure'                      => { 'id' =>  '111', 'name' => 'Clojure (clojure 1.1.0)'                          },
    44. 

  44.   'COBOL'                        => { 'id' =>  '118', 'name' => 'COBOL (open-cobol-1.0)'                           },
    45. 

  45.   'COBOL85'                      => { 'id' =>  '106', 'name' => 'COBOL 85 (tinycobol-0.65.9)'                      },
    46. 

  46.   'clisp'                        => { 'id' =>   '32', 'name' => 'Common Lisp (clisp) (clisp 2.47)'                 },
    47. 

  47.   'D'                            => { 'id' =>  '102', 'name' => 'D (dmd) (dmd-2.042)'                              },
    48. 

  48.   'Erlang'                       => { 'id' =>   '36', 'name' => 'Erlang (erl-5.7.3)'                               },
    49. 

  49.   'Forth'                        => { 'id' =>  '107', 'name' => 'Forth (gforth-0.7.0)'                             },
    50. 

  50.   'Fortran'                      => { 'id' =>    '5', 'name' => 'Fortran (gfortran-4.3.4)'                         },
    51. 

  51.   'Go'                           => { 'id' =>  '114', 'name' => 'Go (gc 2010-01-13)'                               },
    52. 

  52.   'Haskell'                      => { 'id' =>   '21', 'name' => 'Haskell (ghc-6.8.2)'                              },
    53. 

  53.   'Icon'                         => { 'id' =>   '16', 'name' => 'Icon (iconc 9.4.3)'                               },
    54. 

  54.   'Intercal'                     => { 'id' =>    '9', 'name' => 'Intercal (c-intercal 28.0-r1)'                    },
    55. 

  55.   'Java'                         => { 'id' =>   '10', 'name' => 'Java (sun-jdk-1.6.0.17)'                          },
    56. 

  56.   'JS'                           => { 'id' =>   '35', 'name' => 'JavaScript (rhino) (rhino-1.6.5)'                 },
    57. 

  57.   'JScript'                      => { 'id' =>   '35', 'name' => 'JavaScript (rhino) (rhino-1.6.5)'                 },
    58. 

  58.   'JavaScript'                   => { 'id' =>   '35', 'name' => 'JavaScript (rhino) (rhino-1.6.5)'                 },
    59. 

  59.   'JavaScript-rhino'             => { 'id' =>   '35', 'name' => 'JavaScript (rhino) (rhino-1.6.5)'                 },
    60. 

  60.   'JavaScript-spidermonkey'      => { 'id' =>  '112', 'name' => 'JavaScript (spidermonkey) (spidermonkey-1.7)'     },
    61. 

  61.   'Lua'                          => { 'id' =>   '26', 'name' => 'Lua (luac 5.1.4)'                                 },
    62. 

  62.   'Nemerle'                      => { 'id' =>   '30', 'name' => 'Nemerle (ncc 0.9.3)'                              },
    63. 

  63.   'Nice'                         => { 'id' =>   '25', 'name' => 'Nice (nicec 0.9.6)'                               },
    64. 

  64.   'Ocaml'                        => { 'id' =>    '8', 'name' => 'Ocaml (ocamlopt 3.10.2)'                          },
    65. 

  65.   'Pascal'                       => { 'id' =>   '22', 'name' => 'Pascal (fpc) (fpc 2.2.0)'                         },
    66. 

  66.   'Pascal-fpc'                   => { 'id' =>   '22', 'name' => 'Pascal (fpc) (fpc 2.2.0)'                         },
    67. 

  67.   'Pascal-gpc'                   => { 'id' =>    '2', 'name' => 'Pascal (gpc) (gpc 20070904)'                      },
    68. 

  68.   'Perl'                         => { 'id' =>    '3', 'name' => 'Perl (perl 5.8.8)'                                },
    69. 

  69.   'PHP'                          => { 'id' =>   '29', 'name' => 'PHP (php 5.2.11)'                                 },
    70. 

  70.   'Pike'                         => { 'id' =>   '19', 'name' => 'Pike (pike 7.6.86)'                               },
    71. 

  71.   'Prolog'                       => { 'id' =>  '108', 'name' => 'Prolog (gnu) (gprolog-1.3.1)'                     },
    72. 

  72.   'Prolog-gnu'                   => { 'id' =>  '108', 'name' => 'Prolog (gnu) (gprolog-1.3.1)'                     },
    73. 

  73.   'Prolog-swi'                   => { 'id' =>   '15', 'name' => 'Prolog (swi) (swipl 5.6.64)'                      },
    74. 

  74.   'Python'                       => { 'id' =>    '4', 'name' => 'Python (python 2.6.4)'                            },
    75. 

  75.   'Python3'                      => { 'id' =>  '116', 'name' => 'Python3 (python-3.1.1)'                           },
    76. 

  76.   'R'                            => { 'id' =>  '117', 'name' => 'R (R-2.9.2)'                                      },
    77. 

  77.   'Ruby'                         => { 'id' =>   '17', 'name' => 'Ruby (ruby 1.8.7)'                                },
    78. 

  78.   'Scala'                        => { 'id' =>   '39', 'name' => 'Scala (Scalac 2.7.7)'                             },
    79. 

  79.   'Scheme'                       => { 'id' =>   '33', 'name' => 'Scheme (guile) (guile 1.8.5)'                     },
    80. 

  80.   'Smalltalk'                    => { 'id' =>   '23', 'name' => 'Smalltalk (gst 3.1)'                              },
    81. 

  81.   'Tcl'                          => { 'id' =>   '38', 'name' => 'Tcl (tclsh 8.5.7)'                                },
    82. 

  82.   'Unlambda'                     => { 'id' =>  '115', 'name' => 'Unlambda (unlambda-2.0.0)'                        },
    83. 

  83.   'VB'                           => { 'id' =>  '101', 'name' => 'Visual Basic .NET (mono-2.4.2.3)'                 },
    84. 

  84. );
    85. 

  85. 

  86. # C    11
    87. 

  87. # C99  34
    88. 

  88. # C++  1
    89. 

  89. 

  90. my %preludes = ( 
    91. 

  91.                  '34'  => "#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n#include <unistd.h>\n#include <math.h>\n#include <limits.h>\n#include <sys/types.h>\n#include <stdint.h>\n",
    92. 

  92.                  '11'  => "#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n#include <unistd.h>\n#include <math.h>\n#include <limits.h>\n#include <sys/types.h>\n#include <stdint.h>\n",
    93. 

  93.                  '1'   => "#include <iostream>\n#include <cstdio>\n",
    94. 

  94.                );
    95. 

  95. 

  96. if($#ARGV <= 0) {
    97. 

  97.   print "Usage: cc [-lang=<language>] <code>\n";
    98. 

  98.   exit 0;
    99. 

  99. }
    100. 

  100. 

  101. my $nick = shift @ARGV;
    102. 

  102. my $code = join ' ', @ARGV;
    103. 

  103. my @last_code;
    104. 

  104. 

  105. if(open FILE, "< ideone_last_code.txt") {
    106. 

  106.   while(my $line = <FILE>) {
    107. 

  107.     chomp $line;
    108. 

  108.     push @last_code, $line;
    109. 

  109.   }
    110. 

  110.   close FILE;
    111. 

  111. }
    112. 

  112. 

  113. if($code =~ m/^\s*show\s*$/i) {
    114. 

  114.   if(defined $last_code[0]) {
    115. 

  115.     print "$nick: $last_code[0]\n";
    116. 

  116.   } else {
    117. 

  117.     print "$nick: No recent code to show.\n"
    118. 

  118.   }
    119. 

  119.   exit 0;
    120. 

  120. }
    121. 

  121. 

  122. my $got_run;
    123. 

  123. 

  124. if($code =~ m/^\s*run\s*$/i) {
    125. 

  125.   if(defined $last_code[0]) {
    126. 

  126.     $code = $last_code[0];
    127. 

  127.     $got_run = 1;
    128. 

  128.   } else {
    129. 

  129.     print "$nick: No recent code to run.\n";
    130. 

  130.     exit 0;
    131. 

  131.   }
    132. 

  132. } else { 
    133. 

  133.   my $subcode = $code;
    134. 

  134.   my $got_undo = 0;
    135. 

  135.   my $got_sub = 0;
    136. 

  136. 

  137.   while($subcode =~ s/^\s*(and)?\s*undo//) {
    138. 

  138.     splice @last_code, 0, 1;
    139. 

  139.     if(not defined $last_code[0]) {
    140. 

  140.       print "$nick: No more undos remaining.\n";
    141. 

  141.       exit 0;
    142. 

  142.     } else {
    143. 

  143.       $code = $last_code[0];
    144. 

  144.       $got_undo = 1;
    145. 

  145.     }
    146. 

  146.   }
    147. 

  147. 

  148.   my @replacements;
    149. 

  149.   my $prevchange = $last_code[0];
    150. 

  150.   my $got_changes = 0;
    151. 

  151. 

  152.   while(1) {
    153. 

  153.     $got_sub = 0;
    154. 

  154.     $got_changes = 0;
    155. 

  155. 

  156.     if($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) {
    157. 

  157.       my $modifier = 'first';
    158. 

  158. 

  159.       $subcode =~ s/^\s*(and)?\s*//;
    160. 

  160.       $subcode =~ s/remove\s*([^']+)?\s*//i;
    161. 

  161.       $modifier = $1 if defined $1;
    162. 

  162.       $modifier =~ s/\s+$//;
    163. 

  163. 

  164.       my ($e, $r) = extract_delimited($subcode, "'");
    165. 

  165. 

  166.       my $text;
    167. 

  167. 

  168.       if(defined $e) {
    169. 

  169.         $text = $e;
    170. 

  170.         $text =~ s/^'//;
    171. 

  171.         $text =~ s/'$//;
    172. 

  172.         $subcode = "replace $modifier '$text' with ''$r";
    173. 

  173.       } else {
    174. 

  174.         print "$nick: Unbalanced single quotes.  Usage: !cc remove [all, first, .., tenth, last] 'text' [and ...]\n";
    175. 

  175.         exit 0;
    176. 

  176.       }
    177. 

  177.       next;
    178. 

  178.     }
    179. 

  179. 

  180.     if($subcode =~ s/^\s*(and)?\s*add '//) {
    181. 

  181.       $subcode = "'$subcode";
    182. 

  182. 

  183.       my ($e, $r) = extract_delimited($subcode, "'");
    184. 

  184. 

  185.       my $text;
    186. 

  186. 

  187.       if(defined $e) {
    188. 

  188.         $text = $e;
    189. 

  189.         $text =~ s/^'//;
    190. 

  190.         $text =~ s/'$//;
    191. 

  191.         $subcode = $r;
    192. 

  192. 

  193.         $got_sub = 1;
    194. 

  194.         $got_changes = 1;
    195. 

  195. 

  196.         if(not defined $prevchange) {
    197. 

  197.           print "$nick: No recent code to append to.\n";
    198. 

  198.           exit 0;
    199. 

  199.         }
    200. 

  200. 

  201.         $code = $prevchange;
    202. 

  202.         $code =~ s/$/ $text/;
    203. 

  203.         $prevchange = $code;
    204. 

  204.       } else {
    205. 

  205.         print "$nick: Unbalanced single quotes.  Usage: !cc add 'text' [and ...]\n";
    206. 

  206.         exit 0;
    207. 

  207.       }
    208. 

  208.       next;
    209. 

  209.     }
    210. 

  210. 

  211.     if($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*'/i) {
    212. 

  212.       $got_sub = 1;
    213. 

  213.       my $modifier = 'first';
    214. 

  214. 

  215.       $subcode =~ s/^\s*(and)?\s*//;
    216. 

  216.       $subcode =~ s/replace\s*([^']+)?\s*//i;
    217. 

  217.       $modifier = $1 if defined $1;
    218. 

  218.       $modifier =~ s/\s+$//;
    219. 

  219. 

  220.       my ($from, $to);
    221. 

  221.       my ($e, $r) = extract_delimited($subcode, "'");
    222. 

  222. 

  223.       if(defined $e) {
    224. 

  224.         $from = $e;
    225. 

  225.         $from =~ s/^'//;
    226. 

  226.         $from =~ s/'$//;
    227. 

  227.         $from = quotemeta $from;
    228. 

  228.         $subcode = $r;
    229. 

  229.         $subcode =~ s/\s*with\s*//i;
    230. 

  230.       } else {
    231. 

  231.         print "$nick: Unbalanced single quotes.  Usage: !cc replace 'from' with 'to' [and ...]\n";
    232. 

  232.         exit 0;
    233. 

  233.       }
    234. 

  234. 

  235.       ($e, $r) = extract_delimited($subcode, "'");
    236. 

  236. 

  237.       if(defined $e) {
    238. 

  238.         $to = $e;
    239. 

  239.         $to =~ s/^'//;
    240. 

  240.         $to =~ s/'$//;
    241. 

  241.         $subcode = $r;
    242. 

  242.       } else {
    243. 

  243.         print "$nick: Unbalanced single quotes.  Usage: !cc replace 'from' with 'to' [and replace ... with ... [and ...]]\n";
    244. 

  244.         exit 0;
    245. 

  245.       }
    246. 

  246. 

  247.       given($modifier) {
    248. 

  248.         when($_ eq 'all'    ) {}
    249. 

  249.         when($_ eq 'last'   ) {}
    250. 

  250.         when($_ eq 'first'  ) { $modifier = 1; }
    251. 

  251.         when($_ eq 'second' ) { $modifier = 2; }
    252. 

  252.         when($_ eq 'third'  ) { $modifier = 3; }
    253. 

  253.         when($_ eq 'fourth' ) { $modifier = 4; }
    254. 

  254.         when($_ eq 'fifth'  ) { $modifier = 5; }
    255. 

  255.         when($_ eq 'sixth'  ) { $modifier = 6; }
    256. 

  256.         when($_ eq 'seventh') { $modifier = 7; }
    257. 

  257.         when($_ eq 'eighth' ) { $modifier = 8; }
    258. 

  258.         when($_ eq 'nineth' ) { $modifier = 9; }
    259. 

  259.         when($_ eq 'tenth'  ) { $modifier = 10; }
    260. 

  260.         default { print "$nick: Bad replacement modifier '$modifier'; valid modifiers are 'all', 'first', 'second', ..., 'tenth', 'last'\n"; exit 0; }
    261. 

  261.       }
    262. 

  262. 

  263.       my $replacement = {};
    264. 

  264.       $replacement->{'from'} = $from;
    265. 

  265.       $replacement->{'to'} = $to;
    266. 

  266.       $replacement->{'modifier'} = $modifier;
    267. 

  267. 

  268.       push @replacements, $replacement;
    269. 

  269.       next;
    270. 

  270.     }
    271. 

  271. 

  272.     if($subcode =~ m/^\s*(and)?\s*s\/.*\//) {
    273. 

  273.       $got_sub = 1;
    274. 

  274.       $subcode =~ s/^\s*(and)?\s*s//;
    275. 

  275. 

  276.       my ($regex, $to);
    277. 

  277.       my ($e, $r) = extract_delimited($subcode, '/');
    278. 

  278. 

  279.       if(defined $e) {
    280. 

  280.         $regex = $e;
    281. 

  281.         $regex =~ s/^\///;
    282. 

  282.         $regex =~ s/\/$//;
    283. 

  283.         $subcode = "/$r";
    284. 

  284.       } else {
    285. 

  285.         print "$nick: Unbalanced slashes.  Usage: !cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n";
    286. 

  286.         exit 0;
    287. 

  287.       }
    288. 

  288. 

  289.       ($e, $r) = extract_delimited($subcode, '/');
    290. 

  290. 

  291.       if(defined $e) {
    292. 

  292.         $to = $e;
    293. 

  293.         $to =~ s/^\///;
    294. 

  294.         $to =~ s/\/$//;
    295. 

  295.         $subcode = $r;
    296. 

  296.       } else {
    297. 

  297.         print "$nick: Unbalanced slashes.  Usage: !cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n";
    298. 

  298.         exit 0;
    299. 

  299.       }
    300. 

  300. 

  301.       my $suffix;
    302. 

  302.       $suffix = $1 if $subcode =~ s/^([^ ]+)//;
    303. 

  303. 

  304.       if(length $suffix and $suffix =~ m/[^gi]/) {
    305. 

  305.         print "$nick: Bad regex modifier '$suffix'.  Only 'i' and 'g' are allowed.\n";
    306. 

  306.         exit 0;
    307. 

  307.       }
    308. 

  308.       if(defined $prevchange) {
    309. 

  309.         $code = $prevchange;
    310. 

  310.       } else {
    311. 

  311.         print "$nick: No recent code to change.\n";
    312. 

  312.         exit 0;
    313. 

  313.       }
    314. 

  314. 

  315.       my $ret = eval {
    316. 

  316.         my $ret;
    317. 

  317.         my $a;
    318. 

  318.         my $b;
    319. 

  319.         my $c;
    320. 

  320.         my $d;
    321. 

  321.         my $e;
    322. 

  322.         my $f;
    323. 

  323.         my $g;
    324. 

  324.         my $h;
    325. 

  325.         my $i;
    326. 

  326.         my $before;
    327. 

  327.         my $after;
    328. 

  328. 

  329.         if(not length $suffix) {
    330. 

  330.           $ret = $code =~ s|$regex|$to|;
    331. 

  331.           $a = $1;
    332. 

  332.           $b = $2;
    333. 

  333.           $c = $3;
    334. 

  334.           $d = $4;
    335. 

  335.           $e = $5;
    336. 

  336.           $f = $6;
    337. 

  337.           $g = $7;
    338. 

  338.           $h = $8;
    339. 

  339.           $i = $9;
    340. 

  340.           $before = $`;
    341. 

  341.           $after = $';
    342. 

  342.         } elsif($suffix =~ /^i$/) {
    343. 

  343.           $ret = $code =~ s|$regex|$to|i; 
    344. 

  344.           $a = $1;
    345. 

  345.           $b = $2;
    346. 

  346.           $c = $3;
    347. 

  347.           $d = $4;
    348. 

  348.           $e = $5;
    349. 

  349.           $f = $6;
    350. 

  350.           $g = $7;
    351. 

  351.           $h = $8;
    352. 

  352.           $i = $9;
    353. 

  353.           $before = $`;
    354. 

  354.           $after = $';
    355. 

  355.         } elsif($suffix =~ /^g$/) {
    356. 

  356.           $ret = $code =~ s|$regex|$to|g;
    357. 

  357.           $a = $1;
    358. 

  358.           $b = $2;
    359. 

  359.           $c = $3;
    360. 

  360.           $d = $4;
    361. 

  361.           $e = $5;
    362. 

  362.           $f = $6;
    363. 

  363.           $g = $7;
    364. 

  364.           $h = $8;
    365. 

  365.           $i = $9;
    366. 

  366.           $before = $`;
    367. 

  367.           $after = $';
    368. 

  368.         } elsif($suffix =~ /^ig$/ or $suffix =~ /^gi$/) {
    369. 

  369.           $ret = $code =~ s|$regex|$to|gi;
    370. 

  370.           $a = $1;
    371. 

  371.           $b = $2;
    372. 

  372.           $c = $3;
    373. 

  373.           $d = $4;
    374. 

  374.           $e = $5;
    375. 

  375.           $f = $6;
    376. 

  376.           $g = $7;
    377. 

  377.           $h = $8;
    378. 

  378.           $i = $9;
    379. 

  379.           $before = $`;
    380. 

  380.           $after = $';
    381. 

  381.         }
    382. 

  382. 

  383.         if($ret) {
    384. 

  384.           $code =~ s/\$1/$a/g;
    385. 

  385.           $code =~ s/\$2/$b/g;
    386. 

  386.           $code =~ s/\$3/$c/g;
    387. 

  387.           $code =~ s/\$4/$d/g;
    388. 

  388.           $code =~ s/\$5/$e/g;
    389. 

  389.           $code =~ s/\$6/$f/g;
    390. 

  390.           $code =~ s/\$7/$g/g;
    391. 

  391.           $code =~ s/\$8/$h/g;
    392. 

  392.           $code =~ s/\$9/$i/g;
    393. 

  393.           $code =~ s/\$`/$before/g;
    394. 

  394.           $code =~ s/\$'/$after/g;
    395. 

  395.         }
    396. 

    397. 

  397.         return $ret;
    398. 

  398.       };
    399. 

    400. 

  400.       if($@) {
    401. 

  401.         print "$nick: $@\n";
    402. 

  402.         exit 0;
    403. 

  403.       }
    404. 

    405. 

  405.       if($ret) {
    406. 

  406.         $got_changes = 1;
    407. 

  407.       }
    408. 

    409. 

  409.       $prevchange = $code;
    410. 

  410.     }
    411. 

    412. 

  412.     if($got_sub and not $got_changes) {
    413. 

  413.       print "$nick: No substitutions made.\n";
    414. 

  414.       exit 0;
    415. 

  415.     } elsif($got_sub and $got_changes) {
    416. 

  416.       next;
    417. 

  417.     }
    418. 

    419. 

  419.     last;
    420. 

  420.   }
    421. 

    422. 

  422.   if($#replacements > -1) {
    423. 

  423.     @replacements = sort { $a->{'from'} cmp $b->{'from'} or $a->{'modifier'} <=> $b->{'modifier'} } @replacements;
    424. 

    425. 

  425.     my ($previous_from, $previous_modifier);
    426. 

    427. 

  427.     foreach my $replacement (@replacements) {
    428. 

  428.       my $from = $replacement->{'from'};
    429. 

  429.       my $to = $replacement->{'to'};
    430. 

  430.       my $modifier = $replacement->{'modifier'};
    431. 

    432. 

  432.       if(defined $previous_from) {
    433. 

  433.         if($previous_from eq $from and $previous_modifier =~ /^\d+$/) {
    434. 

  434.           $modifier -= $modifier - $previous_modifier;
    435. 

  435.         }
    436. 

  436.       }
    437. 

    438. 

  438.       if(defined $prevchange) {
    439. 

  439.         $code = $prevchange;
    440. 

  440.       } else {
    441. 

  441.         print "$nick: No recent code to change.\n";
    442. 

  442.         exit 0;
    443. 

  443.       }
    444. 

    445. 

  445.       my $ret = eval {
    446. 

  446.         my $got_change;
    447. 

    448. 

  448.         my ($first_char, $last_char, $first_bound, $last_bound);
    449. 

  449.         $first_char = $1 if $from =~ m/^(.)/;
    450. 

  450.         $last_char = $1 if $from =~ m/(.)$/;
    451. 

    452. 

  452.         if($first_char =~ /\W/) {
    453. 

  453.           $first_bound = '.';
    454. 

  454.         } else {
    455. 

  455.           $first_bound = '\b';
    456. 

  456.         }
    457. 

    458. 

  458.         if($last_char =~ /\W/) {
    459. 

  459.           $last_bound = '\B';
    460. 

  460.         } else {
    461. 

  461.           $last_bound = '\b';
    462. 

  462.         }
    463. 

    464. 

  464.         if($modifier eq 'all') {
    465. 

  465.           while($code =~ s/($first_bound)$from($last_bound)/$1$to$2/) {
    466. 

  466.             $got_change = 1;
    467. 

  467.           }
    468. 

  468.         } elsif($modifier eq 'last') {
    469. 

  469.           if($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) {
    470. 

  470.             $got_change = 1;
    471. 

  471.           }
    472. 

  472.         } else {
    473. 

  473.           my $count = 0;
    474. 

  474.           my $unescaped = $from;
    475. 

  475.           $unescaped =~ s/\\//g;
    476. 

  476.           if($code =~ s/($first_bound)$from($last_bound)/if(++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/gex) {
    477. 

  477.             $got_change = 1;
    478. 

  478.           }
    479. 

  479.         }
    480. 

  480.         return $got_change;
    481. 

  481.       };
    482. 

    483. 

  483.       if($@) {
    484. 

  484.         print "$nick: $@\n";
    485. 

  485.         exit 0;
    486. 

  486.       }
    487. 

    488. 

  488.       if($ret) {
    489. 

  489.         $got_sub = 1;
    490. 

  490.         $got_changes = 1;
    491. 

  491.       }
    492. 

    493. 

  493.       $prevchange = $code;
    494. 

  494.       $previous_from = $from;
    495. 

  495.       $previous_modifier = $modifier;
    496. 

  496.     }
    497. 

    498. 

  498.     if($got_sub and not $got_changes) {
    499. 

  499.       print "$nick: No replacements made.\n";
    500. 

  500.       exit 0;
    501. 

  501.     }
    502. 

  502.   }
    503. 

    504. 

  504.   open FILE, "> ideone_last_code.txt";
    505. 

    506. 

  506.   unless ($got_undo and not $got_sub) {
    507. 

  507.     unshift @last_code, $code;
    508. 

  508.   }
    509. 

    510. 

  510.   my $i = 0;
    511. 

  511.   foreach my $line (@last_code) {
    512. 

  512.     last if(++$i > $MAX_UNDO_HISTORY);
    513. 

  513.     print FILE "$line\n";
    514. 

  514.   }
    515. 

  515.   close FILE;
    516. 

    517. 

  517.   if($got_undo and not $got_sub) {
    518. 

  518.     print "$nick: $code\n";
    519. 

  519.     exit 0;
    520. 

  520.   }
    521. 

  521. }
    522. 

    523. 

  523. unless($got_run) {
    524. 

  524.   open FILE, ">> ideone_log.txt";
    525. 

  525.   print FILE "$nick: $code\n";
    526. 

  526. }
    527. 

    528. 

  528. my $lang = "C99";
    529. 

  529. $lang = $1 if $code =~ s/-lang=([^\b\s]+)//i;
    530. 

    531. 

  531. $lang = "C" if $code =~ s/-nowarn[ings]*//i;
    532. 

    533. 

  533. my $show_link = 0;
    534. 

  534. $show_link = 1 if $code =~ s/-showurl//i;
    535. 

    536. 

  536. my $found = 0;
    537. 

  537. my @langs;
    538. 

  538. foreach my $l (sort { uc $a cmp uc $b } keys %languages) {
    539. 

  539.   push @langs, sprintf("      %-30s => %s", $l, $languages{$l}{'name'});
    540. 

  540.   if(uc $lang eq uc $l) {
    541. 

  541.     $lang = $l;
    542. 

  542.     $found = 1;
    543. 

  543.   }
    544. 

  544. }
    545. 

    546. 

  546. if(not $found) {
    547. 

  547.   print "$nick: Invalid language '$lang'.  Supported languages are:\n", (join ",\n", @langs), "\n";
    548. 

  548.   exit 0;
    549. 

  549. }
    550. 

    551. 

  551. my $input = "";
    552. 

  552. $input = $1 if $code =~ s/-input=(.*)$//i;
    553. 

    554. 

  554. $code =~ s/#include <([^>]+)>/\n#include <$1>\n/g;
    555. 

  555. $code =~ s/#([^ ]+) (.*?)\\n/\n#$1 $2\n/g;
    556. 

  556. $code =~ s/#([\w\d_]+)\\n/\n#$1\n/g;
    557. 

    558. 

  558. my $precode = $preludes{$languages{$lang}{'id'}} . $code;
    559. 

  559. $code = '';
    560. 

    561. 

  561. if($languages{$lang}{'id'} == 1 or $languages{$lang}{'id'} == 11 or $languages{$lang}{'id'} == 34) {
    562. 

  562.   my $has_main = 0;
    563. 

  563.   
    564. 

  564.   my $prelude = '';
    565. 

  565.   $prelude = "$1$2" if $precode =~ s/^\s*(#.*)(#.*?[>\n])//s;
    566. 

  566.   
    567. 

  567.   while($precode =~ s/([ a-zA-Z0-9_*\[\]]+)\s+([a-zA-Z0-9_*]+)\s*\((.*?)\)\s*({.*)//) {
    568. 

  568.     my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4);
    569. 

    570. 

  570.     my @extract = extract_codeblock($potential_body, '{}');
    571. 

  571.     my $body;
    572. 

  572.     if(not defined $extract[0]) {
    573. 

  573.       $output .= "error: unmatched brackets for function '$ident';\n";
    574. 

  574.       $body = $extract[1];
    575. 

  575.     } else {
    576. 

  576.       $body = $extract[0];
    577. 

  577.       $precode .= $extract[1];
    578. 

  578.     }
    579. 

  579.     $code .= "$ret $ident($params) $body\n\n";
    580. 

  580.     $has_main = 1 if $ident eq 'main';
    581. 

  581.   }
    582. 

    583. 

  583.   $precode =~ s/^\s+//;
    584. 

  584.   $precode =~ s/\s+$//;
    585. 

    586. 

  586.   if(not $has_main) {
    587. 

  587.     $code = "$prelude\n\n$code\n\nint main(int argc, char **argv) { $precode\n;\n return 0;}\n";
    588. 

  588.     $nooutput = "Success [no output].";
    589. 

  589.   } else {
    590. 

  590.     $code = "$prelude\n\n$precode\n\n$code\n";
    591. 

  591.     $nooutput = "No output.";
    592. 

  592.   }
    593. 

  593. } else {
    594. 

  594.   $code = $precode;
    595. 

  595. }
    596. 

    597. 

  597. if($languages{$lang}{'id'} == 1 or $languages{$lang}{'id'} == 11 or $languages{$lang}{'id'} == 35
    598. 

  598.      or $languages{$lang}{'id'} == 27 or $languages{$lang}{'id'} == 10 or $languages{$lang}{'id'} == 34) {
    599. 

  599.   $code = pretty($code) 
    600. 

  600. }
    601. 

    602. 

  602. $code =~ s/\\n/\n/g if $languages{$lang}{'id'} == 13 or $languages{$lang}{'id'} == 101 or $languages{$lang}{'id'} == 45;
    603. 

  603. $code =~ s/;/\n/g if $languages{$lang}{'id'} == 13 or $languages{$lang}{'id'} == 45;
    604. 

  604. $code =~ s/\|n/\n/g;
    605. 

  605. $code =~ s/^\s+//;
    606. 

  606. $code =~ s/\s+$//;
    607. 

    608. 

  608. $result = get_result($soap->createSubmission($user, $pass, $code, $languages{$lang}{'id'}, $input, 1, 1));
    609. 

    610. 

  610. my $url = $result->{link};
    611. 

    612. 

  612. # wait for compilation/execution to complete
    613. 

  613. while(1) {
    614. 

  614.   $result = get_result($soap->getSubmissionStatus($user, $pass, $url));
    615. 

  615.   last if $result->{status} == 0;
    616. 

  616.   sleep 1;
    617. 

  617. }
    618. 

    619. 

  619. $result = get_result($soap->getSubmissionDetails($user, $pass, $url, 0, 0, 1, 1, 1));
    620. 

    621. 

  621. my $COMPILER_ERROR = 11;
    622. 

  622. my $RUNTIME_ERROR = 12;
    623. 

  623. my $TIMELIMIT = 13;
    624. 

  624. my $SUCCESSFUL = 15;
    625. 

  625. my $MEMORYLIMIT = 17;
    626. 

  626. my $ILLEGAL_SYSCALL = 19;
    627. 

  627. my $INTERNAL_ERROR = 20;
    628. 

    629. 

  629. # signals extracted from ideone.com
    630. 

  630. my @signame;
    631. 

  631. $signame[0] = 'SIGZERO';
    632. 

  632. $signame[1] = 'SIGHUP';
    633. 

  633. $signame[2] = 'SIGINT';
    634. 

  634. $signame[3] = 'SIGQUIT';
    635. 

  635. $signame[4] = 'SIGILL';
    636. 

  636. $signame[5] = 'SIGTRAP';
    637. 

  637. $signame[6] = 'SIGABRT';
    638. 

  638. $signame[7] = 'SIGBUS';
    639. 

  639. $signame[8] = 'SIGFPE';
    640. 

  640. $signame[9] = 'SIGKILL';
    641. 

  641. $signame[10] = 'SIGUSR1';
    642. 

  642. $signame[11] = 'SIGSEGV';
    643. 

  643. $signame[12] = 'SIGUSR2';
    644. 

  644. $signame[13] = 'SIGPIPE';
    645. 

  645. $signame[14] = 'SIGALRM';
    646. 

  646. $signame[15] = 'SIGTERM';
    647. 

  647. $signame[16] = 'SIGSTKFLT';
    648. 

  648. $signame[17] = 'SIGCHLD';
    649. 

  649. $signame[18] = 'SIGCONT';
    650. 

  650. $signame[19] = 'SIGSTOP';
    651. 

  651. $signame[20] = 'SIGTSTP';
    652. 

  652. $signame[21] = 'SIGTTIN';
    653. 

  653. $signame[22] = 'SIGTTOU';
    654. 

  654. $signame[23] = 'SIGURG';
    655. 

  655. $signame[24] = 'SIGXCPU';
    656. 

  656. $signame[25] = 'SIGXFSZ';
    657. 

  657. $signame[26] = 'SIGVTALRM';
    658. 

  658. $signame[27] = 'SIGPROF';
    659. 

  659. $signame[28] = 'SIGWINCH';
    660. 

  660. $signame[29] = 'SIGIO';
    661. 

  661. $signame[30] = 'SIGPWR';
    662. 

  662. $signame[31] = 'SIGSYS';
    663. 

  663. $signame[32] = 'SIGNUM32';
    664. 

  664. $signame[33] = 'SIGNUM33';
    665. 

  665. $signame[34] = 'SIGRTMIN';
    666. 

  666. $signame[35] = 'SIGNUM35';
    667. 

  667. $signame[36] = 'SIGNUM36';
    668. 

  668. $signame[37] = 'SIGNUM37';
    669. 

  669. $signame[38] = 'SIGNUM38';
    670. 

  670. $signame[39] = 'SIGNUM39';
    671. 

  671. $signame[40] = 'SIGNUM40';
    672. 

  672. $signame[41] = 'SIGNUM41';
    673. 

  673. $signame[42] = 'SIGNUM42';
    674. 

  674. $signame[43] = 'SIGNUM43';
    675. 

  675. $signame[44] = 'SIGNUM44';
    676. 

  676. $signame[45] = 'SIGNUM45';
    677. 

  677. $signame[46] = 'SIGNUM46';
    678. 

  678. $signame[47] = 'SIGNUM47';
    679. 

  679. $signame[48] = 'SIGNUM48';
    680. 

  680. $signame[49] = 'SIGNUM49';
    681. 

  681. $signame[50] = 'SIGNUM50';
    682. 

  682. $signame[51] = 'SIGNUM51';
    683. 

  683. $signame[52] = 'SIGNUM52';
    684. 

  684. $signame[53] = 'SIGNUM53';
    685. 

  685. $signame[54] = 'SIGNUM54';
    686. 

  686. $signame[55] = 'SIGNUM55';
    687. 

  687. $signame[56] = 'SIGNUM56';
    688. 

  688. $signame[57] = 'SIGNUM57';
    689. 

  689. $signame[58] = 'SIGNUM58';
    690. 

  690. $signame[59] = 'SIGNUM59';
    691. 

  691. $signame[60] = 'SIGNUM60';
    692. 

  692. $signame[61] = 'SIGNUM61';
    693. 

  693. $signame[62] = 'SIGNUM62';
    694. 

  694. $signame[63] = 'SIGNUM63';
    695. 

  695. $signame[64] = 'SIGRTMAX';
    696. 

  696. $signame[65] = 'SIGIOT';
    697. 

  697. $signame[66] = 'SIGCLD';
    698. 

  698. $signame[67] = 'SIGPOLL';
    699. 

  699. $signame[68] = 'SIGUNUSED';
    700. 

    701. 

  701. if($result->{result} != $SUCCESSFUL or $languages{$lang}{'id'} == 13) {
    702. 

  702.   $output .= $result->{cmpinfo};
    703. 

  703.   $output =~ s/[\n\r]/ /g;
    704. 

  704. }
    705. 

    706. 

  706.   if($result->{result} == $RUNTIME_ERROR) {
    707. 

  707.     $output .= "\n[Runtime error]";
    708. 

  708.     if($result->{signal}) {
    709. 

  709.       $output .= "\n[Signal: $signame[$result->{signal}] ($result->{signal})]";
    710. 

  710.     }
    711. 

  711.   } else {
    712. 

  712.     if($result->{signal}) {
    713. 

  713.       $output .= "\n[Exit code: $result->{signal}]";
    714. 

  714.     }
    715. 

  715.   }
    716. 

    717. 

  717. if($result->{result} == $TIMELIMIT) {
    718. 

  718.   $output .= "\n[Time limit exceeded]";
    719. 

  719. }
    720. 

    721. 

  721. if($result->{result} == $MEMORYLIMIT) {
    722. 

  722.   $output .= "\n[Out of memory]";
    723. 

  723. }
    724. 

    725. 

  725. if($result->{result} == $ILLEGAL_SYSCALL) {
    726. 

  726.   $output .= "\n[Disallowed system call]";
    727. 

  727. }
    728. 

    729. 

  729. if($result->{result} == $INTERNAL_ERROR) {
    730. 

  730.   $output .= "\n[Internal error]";
    731. 

  731. }
    732. 

    733. 

  733. $output .= "\n" . $result->{stderr};
    734. 

  734. $output .= "\n" . $result->{output}; 
    735. 

    736. 

  736. $output = decode_entities($output);
    737. 

    738. 

  738. $output =~ s/cc1: warnings being treated as errors//;
    739. 

  739. $output =~ s/ Line \d+ ://g;
    740. 

  740. $output =~ s/ \(first use in this function\)//g;
    741. 

  741. $output =~ s/error: \(Each undeclared identifier is reported only once.*?\)//msg;
    742. 

  742. $output =~ s/prog\.c:[:\s\d]*//g;
    743. 

  743. $output =~ s/ld: warning: cannot find entry symbol _start; defaulting to [^ ]+//;
    744. 

  744. $output =~ s/error: (.*?) error/error: $1; error/msg;
    745. 

    746. 

  746. my $left_quote = chr(226) . chr(128) . chr(152);
    747. 

  747. my $right_quote = chr(226) . chr(128) . chr(153);
    748. 

  748. $output =~ s/$left_quote/'/g;
    749. 

  749. $output =~ s/$right_quote/'/g;
    750. 

    751. 

  751. $output = $nooutput if $output =~ m/^\s+$/;
    752. 

    753. 

  753. unless($got_run) {
    754. 

  754.   print FILE localtime() . "\n";
    755. 

  755.   print FILE "$nick: [ http://ideone.com/$url ] $output\n\n";
    756. 

  756.   close FILE;
    757. 

  757. }
    758. 

    759. 

  759. if($show_link) {
    760. 

  760.   print "$nick: [ http://ideone.com/$url ] $output\n";
    761. 

  761. } else {
    762. 

  762.   print "$nick: $output\n";
    763. 

  763. }
    764. 

    765. 

  765. # ---------------------------------------------
    766. 

    767. 

  767. sub get_result {
    768. 

  768.   my $result = shift @_;
    769. 

    770. 

  770.   use Data::Dumper;
    771. 

    772. 

  772.   if($result->fault) {
    773. 

  773.     print join ', ', $result->faultcode, $result->faultstring, $result->faultdetail;
    774. 

  774.     exit 0;
    775. 

  775.   } else {
    776. 

  776.     if($result->result->{error} ne "OK") {
    777. 

  777.       print "error\n";
    778. 

  778.       print Dumper($result->result->{error});
    779. 

  779.       exit 0;
    780. 

  780.     } else {
    781. 

  781.       return $result->result;
    782. 

  782.     }
    783. 

  783.   }
    784. 

  784. }
    785. 

    786. 

  786. sub pretty {
    787. 

  787.   my $code = join '', @_;
    788. 

  788.   my $result;
    789. 

    790. 

  790.   my $pid = open2(\*IN, \*OUT, 'astyle -xUpf');
    791. 

  791.   print OUT "$code\n";
    792. 

  792.   close OUT;
    793. 

  793.   while(my $line = <IN>) {
    794. 

  794.     $result .= $line;
    795. 

  795.   }
    796. 

  796.   close IN;
    797. 

  797.   waitpid($pid, 0);
    798. 

  798.   return $result;
    799. 

  799. }
    800. 

    801.