/tools/SDLBot.pl

http://github.com/PerlGameDev/SDL · Perl · 162 lines · 102 code · 45 blank · 15 comment · 9 complexity · 5f957a1cb357761386c86bae1a680145 MD5 · raw file

  1. package MouseImgur;
  2. # Imgur.pm
  3. # simple perl module for uploading pics to imgur.com
  4. use MIME::Base64;
  5. use LWP;
  6. use strict;
  7. use warnings;
  8. use Mouse; # a use Mouse instead
  9. has 'key' => ( is => 'rw', isa => 'Str' );
  10. # errors:
  11. # 0 -- no api key
  12. # -1 -- problem with the file
  13. sub upload {
  14. my $self = shift;
  15. my $image_path = shift;
  16. return 0 unless ( $self->key );
  17. my $res;
  18. if ( $image_path =~ /http:\/\// ) {
  19. $res = $image_path;
  20. } else {
  21. my $fh;
  22. open $fh, "<", $image_path or return -1;
  23. $res = _read_file($image_path);
  24. }
  25. $res = $self->_upload($res);
  26. return $res;
  27. }
  28. # base64'd image
  29. sub _read_file {
  30. my $fname = shift;
  31. my $fh;
  32. open $fh, "<", $fname or return -1;
  33. binmode $fh;
  34. return encode_base64( join( "" => <$fh> ) );
  35. }
  36. # errors:
  37. # 1000 No image selected
  38. # 1001 Image failed to upload
  39. # 1002 Image larger than 10MB
  40. # 1003 Invalid image type or URL
  41. # 1004 Invalid API Key
  42. # 1005 Upload failed during process
  43. # 1006 Upload failed during the copy process
  44. # 1007 Upload failed during thumbnail process
  45. sub _upload {
  46. my $self = shift;
  47. my $image = shift;
  48. return undef unless ($image);
  49. my $user_a = LWP::UserAgent->new( agent => "Perl" );
  50. my $res = $user_a->post( 'http://imgur.com/api/upload.xml', [ 'image' => $image, 'key' => $self->key ] );
  51. if ( $res->content =~ /<original_image>(.*?)<\/original_image>/ ) {
  52. return $1;
  53. } elsif ( $res->content =~ /<error_code>(\d+)<\/error_code>/ ) {
  54. return $1;
  55. } else {
  56. return -3;
  57. }
  58. }
  59. use warnings;
  60. use strict;
  61. package SDLBot;
  62. use threads;
  63. use threads::shared;
  64. use Data::Dumper;
  65. use LWP::UserAgent;
  66. use LWP::Simple;
  67. use Safe;
  68. use SDL;
  69. use SDLx::Surface;
  70. use base qw( Bot::BasicBot );
  71. my $old_count = 0;
  72. my $quite = 0;
  73. warn Dumper qx(sh -c "ulimit -a");
  74. sub said {
  75. my ( $self, $message ) = @_;
  76. if ( $message->{body} =~ /^eval:\s*/ ) {
  77. $message->{body} =~ s/^.+?eval://;
  78. warn 'Got ' . $message->{body};
  79. return eval_imgur( $message->{body} );
  80. }
  81. my $return = ticket($message);
  82. return $return if $return;
  83. }
  84. SDLBot->new(
  85. server => 'irc.perl.org',
  86. channels => ['#sdl'],
  87. nick => 'SDLevalbot',
  88. )->run();
  89. sub ticket {
  90. my $message = shift;
  91. if ( $message->{body} =~ /(TT)(\d+)/ ) {
  92. return "Ticket $2 is at http://sdlperl.ath.cx/projects/SDLPerl/ticket/$2";
  93. }
  94. }
  95. sub eval_imgur {
  96. warn 'eval';
  97. return "Can't run $_[0]" if $_[0] =~ /fork|unlink|threads|while/;
  98. my $videodriver = $ENV{SDL_VIDEODRIVER};
  99. $ENV{SDL_VIDEODRIVER} = 'dummy';
  100. my $key = '26447813009ded6a7e83986738085949';
  101. my $imgur = MouseImgur->new( key => $key );
  102. my $app = SDLx::Surface->new( width => 200, height => 200 );
  103. my $e = eval $_[0];
  104. warn 'Got eval: ' . $@;
  105. if ($@) {
  106. $e = $@;
  107. $e .= SDL::get_error();
  108. return $e;
  109. }
  110. my $image = 'foo' . rand(1000) . '.bmp';
  111. SDL::Video::save_BMP( $app, $image );
  112. my $result = $imgur->upload($image);
  113. my $r = "Imgur Upload: $result\n";
  114. unlink $image;
  115. $ENV{SDL_VIDEODRIVER} = $videodriver;
  116. return $r;
  117. }