/tools/SDLBot.pl

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