Changeset 160

trunk/bin/whatbot

r45	r160
15	15	use Getopt::Long;
16	16
17		use lib realpath(~~getcwd()~~) . '/../lib';
	17	use lib realpath( getcwd() ) . '/../lib';
18	18	use whatbot;
19	19
20		our $VERSION = '0.9.5';
	20	our $VERSION = '0.9.6';
21	21	my $basedir = realpath( getcwd() . '/..' );
22	22
…	…
39	39	if ($@) {
40	40	print 'ERROR: whatbot requires perl 5.8 or higher.' . "\n";
	41	exit(-1);
	42	}
	43	eval {
	44	require Moose;
	45	require MooseX::Declare;
	46	};
	47	if ($@) {
	48	print 'ERROR: whatbot requires Moose and MooseX::Declare.' . "\n";
41	49	exit(-1);
42	50	}

trunk/lib/whatbot.pm

r155	r160
9	9	###########################################################################
10	10
11		package whatbot;
12		use Moose;
13
14		use Data::Dumper;
15		use whatbot::Component::Base;
16		use whatbot::Controller;
17		use whatbot::Config;
18		use whatbot::Log;
19		use whatbot::Timer;
20
21		our $VERSION = '0.9.5';
22
23		has 'base_component' => ( is => 'rw', isa => 'whatbot::Component::Base' );
24		has 'initial_config' => ( is => 'rw', isa => 'whatbot::Config' );
25		has 'kill_self' => ( is => 'rw', isa => 'Int', default => 0 );
26		has 'version' => ( is => 'ro', isa => 'Str', default => $VERSION );
27		has 'skip_extensions' => ( is => 'rw', isa => 'Int', default => 0 );
28		has 'last_message' => ( is => 'rw', isa => 'whatbot::Message' );
29
30		sub config {
31		my ( $self, $basedir, $config_path ) = @_;
	11	use MooseX::Declare;
	12
	13	class whatbot {
	14	use Data::Dumper;
	15	use whatbot::Component::Base;
	16	use whatbot::Controller;
	17	use whatbot::Config;
	18	use whatbot::Log;
	19	use whatbot::Timer;
	20
	21	our $VERSION = '0.9.6';
	22
	23	has 'base_component' => ( is => 'rw', isa => 'whatbot::Component::Base' );
	24	has 'initial_config' => ( is => 'rw', isa => 'whatbot::Config' );
	25	has 'kill_self' => ( is => 'rw', isa => 'Int', default => 0 );
	26	has 'version' => ( is => 'ro', isa => 'Str', default => $VERSION );
	27	has 'skip_extensions' => ( is => 'rw', isa => 'Int', default => 0 );
	28	has 'last_message' => ( is => 'rw', isa => 'whatbot::Message' );
	29
	30	method config ( Str $basedir, Str $config_path ) {
32	31
33		# Find configuration file
34		unless ($config_path and -e $config_path) {
35		my @try_config = (
36		$basedir . '/conf/whatbot.conf',
37		'/etc/whatbot/whatbot.conf',
38		'/etc/whatbot.conf',
39		'/usr/local/etc/whatbot/whatbot.conf',
40		'/usr/local/etc/whatbot.conf'
41		);
42		foreach (@try_config) {
43		$config_path = $_ if (-e $_);
44		}
45		unless ($config_path and -e $config_path) {
46		print 'ERROR: Configuration file not found.' . "\n";
47		return;
48		}
	32	# Find configuration file
	33	unless ($config_path and -e $config_path) {
	34	my @try_config = (
	35	$basedir . '/conf/whatbot.conf',
	36	'/etc/whatbot/whatbot.conf',
	37	'/etc/whatbot.conf',
	38	'/usr/local/etc/whatbot/whatbot.conf',
	39	'/usr/local/etc/whatbot.conf'
	40	);
	41	foreach (@try_config) {
	42	$config_path = $_ if (-e $_);
	43	}
	44	unless ($config_path and -e $config_path) {
	45	print 'ERROR: Configuration file not found.' . "\n";
	46	return;
	47	}
	48	}
	49	# Initialize configuration
	50	my $config = whatbot::Config->new(
	51	'config_file' => $config_path
	52	);
	53	$self->initial_config($config);
49	54	}
50		# Initialize configuration
51		my $config = new whatbot::Config(
52		'config_file' => $config_path
53		);
54		$self->initial_config($config);
	55
	56	method run ( $override_io? ) {
	57
	58	$self->report_error('Invalid configuration')
	59	unless ( defined $self->initial_config and $self->initial_config->config_hash );
	60
	61	$self->initial_config->{'io'} = [$override_io] if ($override_io);
	62
	63	# Start Logger
	64	my $log = new whatbot::Log(
	65	'log_directory' => $self->initial_config->log_directory
	66	);
	67	$self->report_error('Invalid configuration')
	68	unless ( defined $log and $log->log_directory );
	69
	70	# Build base component
	71	my $base_component = whatbot::Component::Base->new(
	72	'parent' => $self,
	73	'config' => $self->initial_config,
	74	'log' => $log
	75	);
	76	$self->base_component($base_component);
	77
	78	# Find and store models
	79	$self->report_error(
	80	'Invalid connection type: ' . $base_component->config->database->{'handler'}
	81	) unless ( $base_component->config->database and $base_component->config->database->{'handler'} );
	82
	83	# Start database handler
	84	my $connection_class = 'whatbot::Database::' . $base_component->config->database->{'handler'};
	85	eval "require $connection_class";
	86	if ( my $err = $@ ) {
	87	$self->report_error($@);
	88	}
	89
	90	my $database = $connection_class->new(
	91	'base_component' => $base_component
	92	);
	93	$database->connect();
	94	$self->report_error('Configured connection failed to load properly')
	95	unless ( defined $database and defined $database->handle );
	96	$base_component->database($database);
	97
	98	# Read in table definitions
	99	my %model;
	100	my $root_dir = $INC{'whatbot/Controller.pm'};
	101	$root_dir =~ s/Controller\.pm$/Database\/Table/;
	102	opendir( MODEL_DIR, $root_dir );
	103	while ( my $name = readdir(MODEL_DIR) ) {
	104	next unless ( $name =~ /^[A-z0-9]+\.pm$/ and $name ne 'Row.pm' );
	105
	106	my $command_path = $root_dir . '/' . $name;
	107	$name =~ s/\.pm//;
	108	my $class_name = 'whatbot::Database::Table::' . $name;
	109	eval {
	110	eval "require $class_name";
	111	$model{ lc($name) } = $class_name->new(
	112	'base_component' => $base_component,
	113	'handle' => $database->handle
	114	);
	115	};
	116	if ($@) {
	117	warn 'Error loading ' . $class_name . ': ' . $@;
	118	} else {
	119	$log->write('-> ' . $class_name . ' loaded.');
	120	}
	121	};
	122	$base_component->models(\%model);
	123
	124	# Start Store module
	125	$self->report_error('Invalid store type')
	126	unless ( $self->initial_config->store and $self->initial_config->store->{'handler'} );
	127
	128	my $storage = 'whatbot::Store::' . $self->initial_config->store->{'handler'};
	129	eval "require $storage";
	130	$self->report_error($@) if ($@);
	131
	132	my $store = $storage->new(
	133	'base_component' => $base_component
	134	);
	135	$store->connect();
	136	$self->report_error('Configured store failed to load properly')
	137	unless ( defined $store and defined $store->handle );
	138	$base_component->store($store);
	139
	140	# 10 RANDOMIZE TIMER
	141	my $timer = new whatbot::Timer(
	142	'base_component' => $base_component
	143	);
	144	$base_component->timer($timer);
	145
	146	# Create IO modules
	147	my @io;
	148	my %ios;
	149	foreach my $io_module ( @{$self->initial_config->io} ) {
	150	$log->error('No interface designated for one or more IO modules')
	151	unless ( defined $io_module->{'interface'} );
	152
	153	my $io_class = 'whatbot::IO::' . $io_module->{'interface'};
	154	eval "require $io_class";
	155	$self->report_error('Error loading ' . $io_class . ': ' . $@ ) if ($@);
	156	my $io_object = $io_class->new(
	157	'my_config' => $io_module,
	158	'base_component' => $base_component
	159	);
	160	$self->report_error('IO interface "' . $io_module->{'interface'} . '" failed to load properly')
	161	unless ( defined $io_object );
	162
	163	$ios{ $io_object->name } = $io_object;
	164	push(@io, $io_object);
	165	}
	166	$base_component->ios(\%ios);
	167
	168	# Parse Commands
	169	my $controller = new whatbot::Controller(
	170	'base_component' => $base_component,
	171	'skip_extensions' => $self->skip_extensions
	172	);
	173	$base_component->controller($controller);
	174	$controller->dump_command_map();
	175
	176	# Connect to IO
	177	foreach my $io_object (@io) {
	178	$log->write('Sending connect to ' . ref($io_object));
	179	$io_object->controller($controller);
	180	$io_object->connect;
	181	}
	182
	183	# Start Event Loop
	184	$log->write('whatbot initialized successfully.');
	185	while ( !$self->kill_self ) {
	186	foreach my $io_object (@io) {
	187	$io_object->event_loop();
	188	}
	189	$timer->tick();
	190	}
	191
	192	# Upon kill or interrupt, exit gracefully.
	193	$log->write('whatbot exiting.');
	194	foreach my $io_object (@io) {
	195	$log->write('Sending disconnect to ' . ref($io_object));
	196	$io_object->disconnect;
	197	}
	198	}
	199
	200	method report_error ( Str $error ) {
	201	if ( defined $self->base_component and defined $self->base_component->log ) {
	202	$self->base_component->log->error($error);
	203	}
	204	die 'ERROR: ' . $error;
	205	}
55	206	}
56
57		~~sub run {~~
58		~~my ( $self, $override_io ) = @_;~~
59
60		~~$self->report_error('Invalid configuration')~~
61		~~unless ( defined $self->initial_config and $self->initial_config->config_hash );~~
62
63		~~$self->initial_config->{'io'} = [$override_io] if ($override_io);~~
64
65		~~# Start Logger~~
66		~~my $log = new whatbot::Log(~~
67		~~'log_directory' => $self->initial_config->log_directory~~
68		);
69		~~$self->report_error('Invalid configuration')~~
70		~~unless ( defined $log and $log->log_directory );~~
71
72		~~# Build base component~~
73		~~my $base_component = new whatbot::Component::Base(~~
74		~~'parent' => $self,~~
75		~~'config' => $self->initial_config,~~
76		~~'log' => $log~~
77		);
78		~~$self->base_component($base_component);~~
79
80		~~# Find and store models~~
81		~~$self->report_error( 'Invalid connection type: ' . $base_component->config->database->{'handler'} )~~
82		~~unless ( $base_component->config->database and $base_component->config->database->{'handler'} );~~
83
84		~~my $connection_class = 'whatbot::Database::' . $base_component->config->database->{'handler'};~~
85		~~eval "require $connection_class";~~
86		~~$self->report_error($@) if ($@);~~
87
88		~~my $database = $connection_class->new(~~
89		~~'base_component' => $base_component~~
90		);
91		~~$database->connect();~~
92		~~$self->report_error('Configured connection failed to load properly')~~
93		~~unless ( defined $database and defined $database->handle );~~
94		~~$base_component->database($database);~~
95
96		~~my %model;~~
97		~~my $root_dir = $INC{'whatbot/Controller.pm'};~~
98		~~$root_dir =~ s/Controller\.pm$/Database\/Table/;~~
99		~~opendir( MODEL_DIR, $root_dir );~~
100		~~while ( my $name = readdir(MODEL_DIR) ) {~~
101		~~next unless ( $name =~ /^[A-z0-9]+\.pm$/ and $name ne 'Row.pm' );~~
102
103		~~my $command_path = $root_dir . '/' . $name;~~
104		~~$name =~ s/\.pm//;~~
105		~~my $class_name = 'whatbot::Database::Table::' . $name;~~
106		~~eval {~~
107		~~eval "require $class_name";~~
108		~~$model{ lc($name) } = $class_name->new(~~
109		~~'base_component' => $base_component,~~
110		~~'handle' => $database->handle~~
111		);
112		};
113		~~if ($@) {~~
114		~~warn 'Error loading ' . $class_name . ': ' . $@;~~
115		~~} else {~~
116		~~$log->write('-> ' . $class_name . ' loaded.');~~
117		}
118		};
119		~~$base_component->models(\%model);~~
120
121		~~# Start Store module~~
122		~~$self->report_error('Invalid store type')~~
123		~~unless ( $self->initial_config->store and $self->initial_config->store->{'handler'} );~~
124
125		~~my $storage = 'whatbot::Store::' . $self->initial_config->store->{'handler'};~~
126		~~eval "require $storage";~~
127		~~$self->report_error($@) if ($@);~~
128
129		~~my $store = $storage->new(~~
130		~~'base_component' => $base_component~~
131		);
132		~~$store->connect();~~
133		~~$self->report_error('Configured store failed to load properly')~~
134		~~unless ( defined $store and defined $store->handle );~~
135		~~$base_component->store($store);~~
136
137		~~# 10 RANDOMIZE TIMER~~
138		~~my $timer = new whatbot::Timer(~~
139		~~'base_component' => $base_component~~
140		);
141		~~$base_component->timer($timer);~~
142
143		~~# Create IO modules~~
144		~~my @io;~~
145		~~my %ios;~~
146		~~foreach my $io_module ( @{$self->initial_config->io} ) {~~
147		~~$log->error('No interface designated for one or more IO modules')~~
148		~~unless ( defined $io_module->{'interface'} );~~
149
150		~~my $io_class = 'whatbot::IO::' . $io_module->{'interface'};~~
151		~~eval "require $io_class";~~
152		~~$self->report_error($@) if ($@);~~
153		~~my $io_object = $io_class->new(~~
154		~~'my_config' => $io_module,~~
155		~~'base_component' => $base_component~~
156		);
157		~~$self->report_error('IO interface "' . $io_module->{'interface'} . '" failed to load properly')~~
158		~~unless ( defined $io_object );~~
159
160		~~$ios{ $io_object->name } = $io_object;~~
161		~~push(@io, $io_object);~~
162		}
163		~~$base_component->ios(\%ios);~~
164
165		~~# Parse Commands~~
166		~~my $controller = new whatbot::Controller(~~
167		~~'base_component' => $base_component,~~
168		~~'skip_extensions' => $self->skip_extensions~~
169		);
170		~~$base_component->controller($controller);~~
171		~~$controller->dump_command_map();~~
172
173		~~# Connect to IO~~
174		~~foreach my $io_object (@io) {~~
175		~~$log->write('Sending connect to ' . ref($io_object));~~
176		~~$io_object->controller($controller);~~
177		~~$io_object->connect;~~
178		}
179
180		~~# Start Event Loop~~
181		~~$log->write('whatbot initialized successfully.');~~
182		~~while ( !$self->kill_self ) {~~
183		~~foreach my $io_object (@io) {~~
184		~~$io_object->event_loop();~~
185		}
186		~~$timer->tick();~~
187		}
188
189		~~# Upon kill or interrupt, exit gracefully.~~
190		~~$log->write('whatbot exiting.');~~
191		~~foreach my $io_object (@io) {~~
192		~~$log->write('Sending disconnect to ' . ref($io_object));~~
193		~~$io_object->disconnect;~~
194		}
195		}
196
197		~~sub report_error {~~
198		~~my ( $self, $error ) = @_;~~
199
200		~~if ( defined $self->base_component and defined $self->base_component->log ) {~~
201		~~$self->base_component->log->error($error);~~
202		}
203		~~die 'ERROR: ' . $error;~~
204		}
205
206		1;

trunk/lib/whatbot/Command.pm

r152	r160
9	9	###########################################################################
10	10
11		package whatbot::Command;
12		use Moose;
13		no warnings 'redefine';
14		BEGIN { extends 'whatbot::Component' };
	11	use MooseX::Declare;
15	12
16		use Data::Dumper 'Dumper';
	13	class whatbot::Command extends whatbot::Component {
	14	has 'command_priority' => ( is => 'rw', isa => 'Str', default => 'Extension' );
	15	has 'require_direct' => ( is => 'rw', isa => 'Int', default => 0 );
	16	has 'my_config' => ( is => 'ro', isa => 'Maybe[HashRef]' );
17	17
18		has 'command_priority' => ( is => 'rw', isa => 'Str', default => 'Extension' );
19		has 'require_direct' => ( is => 'rw', isa => 'Int', default => 0 );
20		has 'my_config' => ( is => 'ro', isa => 'Maybe[HashRef]' );
	18	our $_attribute_cache = {};
21	19
22		our $_attribute_cache = {};
	20	sub MODIFY_CODE_ATTRIBUTES {
	21	my ( $class, $code, @attrs ) = @_;
	22
	23	$_attribute_cache = { %{ $_attribute_cache }, $code => [@attrs] };
	24	return ();
	25	}
23	26
24		sub MODIFY_CODE_ATTRIBUTES {
25		my ( $class, $code, @attrs ) = @_;
26
27		$_attribute_cache = { %{ $_attribute_cache }, $code => [@attrs] };
28		return ();
29		}
	27	sub FETCH_CODE_ATTRIBUTES {
	28	$_attribute_cache->{ $_[1] } \|\| ();
	29	}
30	30
31		~~sub FETCH_CODE_ATTRIBUTES~~ {
32		~~$_attribute_cache->{ $_[1] } \|\|~~ ();
33		}
	31	method BUILD ($) {
	32	$self->register();
	33	}
34	34
35		sub BUILD {
36		my ( $self ) = @_;
37
38		$self->register();
39		}
40
41		sub register {
42		my ($self) = @_;
43
44		$self->log->write(ref($self) . ' works without a register method, but it is recommended to make one.');
45		}
	35	method register {
	36	$self->log->write(ref($self) . ' works without a register method, but it is recommended to make one.');
	37	}
46	38
47	39
48		sub help {
49		my ($self) = @_;
50
51		return 'Help is not available for this module.';
	40	method help {
	41	return 'Help is not available for this module.';
	42	}
52	43	}
53	44

trunk/lib/whatbot/Command/Admin.pm

r155	r160
79	79	if ($inf =~ /Revision:\s+(\d+)/) {
80	80	my $rev = $1;
81		return 'Now at svn r' . $rev . '. Changed: ' . $self->last( ~~undef~~, undef, $rev);
	81	return 'Now at svn r' . $rev . '. Changed: ' . $self->last( $message, undef, $rev);
82	82	}
83	83	} else {
…	…
149	149	}
150	150
	151	sub warnvar : Command {
	152	my ( $self, $message, $var ) = @_;
	153
	154	warn Data::Dumper::Dumper( eval "$var" );
	155	return 'Check the log.';
	156	}
	157
	158	sub throw : Command {
	159	my ( $self, $message, $args ) = @_;
	160
	161	my ( $io_search, @message_split ) = split( / /, $args->[0] );
	162	my $new_message = new whatbot::Message(
	163	'to' => '',
	164	'from' => '',
	165	'content' => join( ' ', @message_split ),
	166	'base_component' => $self->parent->base_component
	167	);
	168	foreach my $io ( keys %{ $self->ios } ) {
	169	if ( $io =~ /$io_search/ ) {
	170	$self->ios->{$io}->send_message($new_message);
	171	last;
	172	}
	173	}
	174
	175	return;
	176	}
	177
151	178	1;
	179

trunk/lib/whatbot/Command/Blackjack.pm

r124	r160
153	153
154	154	unless ( keys %{ $self->game->players } ) {
155		push( @messages, 'No more players. Good work, ' . $self->insult . 's.' );
	155	my $insult = $self->insult;
	156	push( @messages, 'No more players. Good work, ' . $insult . ( $insult =~ /s$/ ? 'e' : '' ) . 's.' );
156	157	$self->end_game();
157	158	return \@messages;

trunk/lib/whatbot/Command/Blackjack/Card.pm

r109	r160
4	4
5	5	has 'value' => ( is => 'rw' );
	6	has 'color' => ( is => 'rw', isa => 'Str' );
	7	has 'unicode' => ( is => 'rw', isa => 'Str' );
6	8	has 'suit' => ( is => 'rw', isa => 'Str', trigger => sub {
7	9	my $self = shift;
…	…
9	11	$self->unicode( $self->suits->{ $self->suit }->{'uni'} );
10	12	} );
11		~~has 'color' => ( is => 'rw', isa => 'Str' );~~
12		~~has 'unicode' => ( is => 'rw', isa => 'Str' );~~
13	13	has 'suits' => ( is => 'ro', isa => 'HashRef', default => sub { {
14	14	'diamonds' => {

trunk/lib/whatbot/Command/Define.pm

r70	r160
34	34	isa => 'Str',
35	35	default => undef,
36		~~reader => 'get_error',~~
37	36	);
38	37
…	…
149	148	return "Multiple definitions for $phrase - be more specific.";
150	149	}
151		return undef if (~~$first_p =~ /see Wikipedia:Searching\./~~);
	150	return undef if ( $first_p =~ /see Wikipedia:Searching\./ or $first_p =~ /You may create the page/ );
152	151
153	152	goto RETRY unless $first_p =~ /\./;

trunk/lib/whatbot/Command/Karma.pm

r159	r160
151	151
152	152	1;
	153

trunk/lib/whatbot/Command/RSS.pm

r153	r160
76	76	} else {
77	77	my $last_entry;
78		my @items = reverse( @{ $xml_doc->{'channel'}->{'item'} } );
	78	my @items = reverse( @{ $xml_doc->{'channel'}->{'item'} } ) if ( $xml_doc->{'channel'}->{'item'} and ref( $xml_doc->{'channel'}->{'item'} ) eq 'ARRAY' );
79	79	if ( $self->last_entry->{ $feed->{'md5'} } and $self->last_entry->{ $feed->{'md5'} }->{'guid'} ) {
80	80	$last_entry = $self->last_entry->{ $feed->{'md5'} }->{'guid'};
…	…
129	129	}
130	130	$self->timer->enqueue( ( $self->my_config->{'interval'} or 60 ), \&retrieve_rss, $self );
	131	return;
131	132	}
132	133
…	…
134	135	my ( $self, $message ) = @_;
135	136
136		return ( $self->last_check ? 'Last checked on ' . $self->last_check->{'stamp'} . ', status: ' . $self->last_check->{'status'} : ~~undef~~ );
	137	return ( $self->last_check ? 'Last checked on ' . $self->last_check->{'stamp'} . ', status: ' . $self->last_check->{'status'} : 'No valid check found.' );
137	138	}
138	139

trunk/lib/whatbot/Command/Translate.pm

r86	r160
64	64	return new WWW::Babelfish(
65	65	'service' => 'Yahoo',
66		'agent' => 'Mozilla/8.0'
	66	'agent' => 'Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_6_2; de-at) AppleWebKit/531.21.8 (KHTML, like Gecko) Version/4.0.4 Safari/531.21.10'
67	67	);
68	68	}
…	…
87	87	}
88	88
89		~~$message = encode('utf8', $message);~~
90	89	my $text = $translator->translate(
91	90	'source' => $from,
…	…
93	92	'text' => $message
94	93	);
	94	warn $translator->error;
95	95	if ($text) {
96		return 'Translation: ' . ~~Encode::encode_utf8($text)~~;
	96	return 'Translation: ' . $text;
97	97	} else {
98	98	return 'Sorry, I had an error trying to translate that.';

trunk/lib/whatbot/Component.pm

r155	r160
8	8	###########################################################################
9	9
10		package whatbot::Component;
11		use Moose;
	10	use MooseX::Declare;
12	11
13		has 'base_component' => ( is => 'rw', default => sub { new whatbot::Component::Base } );
14		has 'parent' => ( is => 'rw', default => sub { $_[0]->base_component->parent } );
15		has 'config' => ( is => 'rw', default => sub { $_[0]->base_component->config } );
16		has 'ios' => ( is => 'rw', default => sub { $_[0]->base_component->ios } );
17		has 'database' => ( is => 'rw', default => sub { $_[0]->base_component->database } );
18		has 'log' => ( is => 'rw', default => sub { $_[0]->base_component->log } );
19		has 'controller' => ( is => 'rw', default => sub { $_[0]->base_component->controller } );
20		has 'timer' => ( is => 'rw', default => sub { $_[0]->base_component->timer } );
21		has 'models' => ( is => 'rw', default => sub { $_[0]->base_component->models } );
22		has 'store' => ( is => 'rw', default => sub { $_[0]->base_component->store } ); # deprecated
	12	class whatbot::Component {
	13	has 'base_component' => ( is => 'rw', default => sub { new whatbot::Component::Base } );
	14	has 'parent' => ( is => 'rw', default => sub { $_[0]->base_component->parent } );
	15	has 'config' => ( is => 'rw', default => sub { $_[0]->base_component->config } );
	16	has 'ios' => ( is => 'rw', default => sub { $_[0]->base_component->ios } );
	17	has 'database' => ( is => 'rw', default => sub { $_[0]->base_component->database } );
	18	has 'log' => ( is => 'rw', default => sub { $_[0]->base_component->log } );
	19	has 'controller' => ( is => 'rw', default => sub { $_[0]->base_component->controller } );
	20	has 'timer' => ( is => 'rw', default => sub { $_[0]->base_component->timer } );
	21	has 'models' => ( is => 'rw', default => sub { $_[0]->base_component->models } );
	22	has 'store' => ( is => 'rw', default => sub { $_[0]->base_component->store } ); # deprecated
23	23
24		sub BUILD {
25		my ( $self, $params ) = @_;
26
27		unless ( ref($self) =~ /Message/ or ref($self) =~ /Command::/ or ref($self) =~ /::Table/ ) {
28		$self->log->write(ref($self) . ' loaded.') ;
29		}
30		}
	24	method BUILD ( $params ) {
	25	unless ( ref($self) =~ /Message/ or ref($self) =~ /Command::/ or ref($self) =~ /::Table/ ) {
	26	$self->log->write(ref($self) . ' loaded.') ;
	27	}
	28	}
31	29
32		sub model {
33		my ( $self, $model_name ) = @_;
34
35		return $self->models->{ lc($model_name) } if ( $self->models->{ lc($model_name) } );
36		warn ref($self) . ' tried to reference model "' . $model_name . '" even though it does not exist.';
37		return;
	30	method model ( Str $model_name ) {
	31	return $self->models->{ lc($model_name) } if ( $self->models->{ lc($model_name) } );
	32	warn ref($self) . ' tried to reference model "' . $model_name . '" even though it does not exist.';
	33	return;
	34	}
38	35	}
39	36

trunk/lib/whatbot/Component/Base.pm

r155	r160
7	7	###########################################################################
8	8
9		package whatbot::Component::Base;
10		use Moose;
	9	use MooseX::Declare;
11	10
12		has 'parent' => ( is => 'rw', isa => 'whatbot' );
13		has 'config' => ( is => 'rw', isa => 'whatbot::Config' );
14		has 'ios' => ( is => 'rw', isa => 'HashRef' );
15		has 'database' => ( is => 'rw', isa => 'whatbot::Database' );
16		has 'log' => ( is => 'rw', isa => 'whatbot::Log' );
17		has 'controller' => ( is => 'rw', isa => 'whatbot::Controller' );
18		has 'timer' => ( is => 'rw', isa => 'whatbot::Timer' );
19		has 'models' => ( is => 'rw', isa => 'HashRef' );
20		has 'store' => ( is => 'rw', isa => 'whatbot::Store' ); # deprecated
	11	class whatbot::Component::Base {
	12	has 'parent' => ( is => 'rw', isa => 'whatbot' );
	13	has 'config' => ( is => 'rw', isa => 'whatbot::Config' );
	14	has 'ios' => ( is => 'rw', isa => 'HashRef' );
	15	has 'database' => ( is => 'rw', isa => 'whatbot::Database' );
	16	has 'log' => ( is => 'rw', isa => 'whatbot::Log' );
	17	has 'controller' => ( is => 'rw', isa => 'whatbot::Controller' );
	18	has 'timer' => ( is => 'rw', isa => 'whatbot::Timer' );
	19	has 'models' => ( is => 'rw', isa => 'HashRef' );
	20	has 'store' => ( is => 'rw', isa => 'whatbot::Store' ); # deprecated
	21	}
21	22
22	23	1;

trunk/lib/whatbot/Config.pm

r155	r160
9	9	###########################################################################
10	10
11		package whatbot::Config;
12		use Moose;
	11	use MooseX::Declare;
13	12
14		use XML::Simple;
	13	class whatbot::Config {
	14	use XML::Simple;
15	15
16		has 'config_file' => ( is => 'rw', isa => 'Str' );
17		has 'config_hash' => ( is => 'rw', isa => 'HashRef' );
18		has 'io' => ( is => 'ro', isa => 'Any' );
19		has 'store' => ( is => 'ro', isa => 'Any' );
20		~~has 'database'~~ => ( is => 'ro', isa => 'Any' );
21		has 'commands' => ( is => 'ro', isa => 'Any' );
22		has 'log_directory' => ( is => 'ro', isa => 'Any' );
	16	has 'config_file' => ( is => 'rw', isa => 'Str' );
	17	has 'config_hash' => ( is => 'rw', isa => 'HashRef' );
	18	has 'io' => ( is => 'ro', isa => 'Any' );
	19	has 'store' => ( is => 'ro', isa => 'Any' );
	20	has 'database' => ( is => 'ro', isa => 'Any' );
	21	has 'commands' => ( is => 'ro', isa => 'Any' );
	22	has 'log_directory' => ( is => 'ro', isa => 'Any' );
23	23
24		sub BUILD {
25		my ($self) = @_;
26
27		die 'ERROR: Error finding config file "' . $self->config_file . '"!' unless ( -e $self->config_file );
28		my $config;
29		eval {
30		$config = XMLin($self->config_file);
31		};
32		if ($@) {
33		die 'ERROR: Error in config file "' . $self->config_file . '"! Parser reported: ' . $@;
34		} else {
35		$self->config_hash($config);
	24	method BUILD ($) {
	25	die 'ERROR: Error finding config file "' . $self->config_file . '"!' unless ( -e $self->config_file );
	26	my $config;
	27	eval {
	28	$config = XMLin($self->config_file);
	29	};
	30	if ($@) {
	31	die 'ERROR: Error in config file "' . $self->config_file . '"! Parser reported: ' . $@;
	32	} else {
	33	$self->config_hash($config);
36	34
37		# Verify we have IO modules, and convert a single module to an array if necessary
38		if (
39		!$config->{'io'}
40		or (
41		ref($config->{'io'}) eq 'HASH'
42		and scalar(keys %{$config->{'io'}}) == 0
43		)
44		) {
45		die 'ERROR: No IO modules defined';
46		}
47		$config->{'io'} = [ $config->{'io'} ] if (ref($config->{'io'}) eq 'HASH');
48		$self->{'io'} = $config->{'io'};
	35	# Verify we have IO modules, and convert a single module to an array if necessary
	36	if (
	37	!$config->{'io'}
	38	or (
	39	ref($config->{'io'}) eq 'HASH'
	40	and scalar(keys %{$config->{'io'}}) == 0
	41	)
	42	) {
	43	die 'ERROR: No IO modules defined';
	44	}
	45	$config->{'io'} = [ $config->{'io'} ] if (ref($config->{'io'}) eq 'HASH');
	46	$self->{'io'} = $config->{'io'};
49	47
50		$self->{'store'} = ( $config->{'store'} or {} );
51		$self->{'database'} = ( $config->{'database'} or {} );
52		$self->{'commands'} = ( $config->{'commands'} or {} );
53		$self->{'log_directory'} = ( $config->{'log'}->{'directory'} or '.' );
54		$self->{'log_directory'} =~ s/\/$//;
55		}
	48	$self->{'store'} = ( $config->{'store'} or {} );
	49	$self->{'database'} = ( $config->{'database'} or {} );
	50	$self->{'commands'} = ( $config->{'commands'} or {} );
	51	$self->{'log_directory'} = ( $config->{'log'}->{'directory'} or '.' );
	52	$self->{'log_directory'} =~ s/\/$//;
	53	}
	54	}
56	55	}
57	56

trunk/lib/whatbot/Controller.pm

r152	r160
7	7	###########################################################################
8	8
9		package whatbot::Controller;
10		use Moose;
11		extends 'whatbot::Component';
12
13		use whatbot::Message;
14		use Class::Inspector;
15
16		has 'command' => ( is => 'rw', isa => 'HashRef' );
17		has 'command_name' => ( is => 'rw', isa => 'HashRef' );
18		has 'command_short_name' => ( is => 'rw', isa => 'HashRef' );
19		has 'skip_extensions' => ( is => 'rw', isa => 'Int' );
20
21		sub BUILD {
22		my ( $self ) = @_;
	9	use MooseX::Declare;
	10
	11	class whatbot::Controller extends whatbot::Component {
	12	use whatbot::Message;
	13	use Class::Inspector;
	14
	15	has 'command' => ( is => 'rw', isa => 'HashRef' );
	16	has 'command_name' => ( is => 'rw', isa => 'HashRef' );
	17	has 'command_short_name' => ( is => 'rw', isa => 'HashRef' );
	18	has 'skip_extensions' => ( is => 'rw', isa => 'Int' );
	19
	20	method BUILD ($) {
	21	$self->build_command_map();
	22	}
	23
	24	method build_command_map {
	25	my %command; # Ordered list of commands
	26	my %command_name; # Maps command names to commands
	27	my %command_short_name;
	28	my $command_namespace = 'whatbot::Command';
	29	my $root_dir = $INC{'whatbot/Controller.pm'};
	30	$root_dir =~ s/Controller\.pm/Command/;
23	31
24		$self->build_command_map();
25		}
26
27		sub build_command_map {
28		my ( $self ) = @_;
29
30		my %command; # Ordered list of commands
31		my %command_name; # Maps command names to commands
32		my %command_short_name;
33		my $command_namespace = 'whatbot::Command';
34		my $root_dir = $INC{'whatbot/Controller.pm'};
35		$root_dir =~ s/Controller\.pm/Command/;
36
37		opendir( COMMAND_DIR, $root_dir );
38		while ( my $name = readdir(COMMAND_DIR) ) {
39		next unless ( $name =~ /^[A-z0-9]+\.pm$/ );
	32	# Scan whatbot::Command directory for loadable plugins
	33	opendir( COMMAND_DIR, $root_dir );
	34	while ( my $name = readdir(COMMAND_DIR) ) {
	35	next unless ( $name =~ /^[A-z0-9]+\.pm$/ );
40	36
41		my $command_path = $root_dir . '/' . $name;
42		$name =~ s/\.pm//;
43		my $class_name = 'whatbot::Command::' . $name;
44		eval "require $class_name";
45		if ($@) {
46		$self->log->error( $class_name . ' failed to load: ' . $@ );
47		} else {
48		unless ( $class_name->can('register') ) {
49		$self->log->error( $class_name . ' failed to load due to missing methods' );
50		} else {
51		my @run_paths;
52		my %end_paths;
53		my $command_root = $class_name;
54		$command_root =~ s/$command_namespace\:\://;
55		$command_root = lc($command_root);
	37	my $command_path = $root_dir . '/' . $name;
	38	$name =~ s/\.pm//;
	39	my $class_name = 'whatbot::Command::' . $name;
	40	eval "require $class_name";
	41	if ($@) {
	42	$self->log->error( $class_name . ' failed to load: ' . $@ );
	43	} else {
	44	unless ( $class_name->can('register') ) {
	45	$self->log->error( $class_name . ' failed to load due to missing methods' );
	46	} else {
	47	my @run_paths;
	48	my %end_paths;
	49	my $command_root = $class_name;
	50	$command_root =~ s/$command_namespace\:\://;
	51	$command_root = lc($command_root);
56	52
57		# Instantiate
58		my $config;
59		if (defined $self->config->commands->{lc($name)}) {
60		$config = $self->config->commands->{lc($name)};
61		}
62		my $new_command = $class_name->new(
63		'base_component' => $self->parent->base_component,
64		'my_config' => $config
65		);
66		$new_command->controller($self);
67
68		# Determine runpaths
69		foreach my $function ( @{Class::Inspector->functions($class_name)} ) {
70		my $full_function = $class_name . '::' . $function;
71		my $coderef = \&$full_function;
	53	# Instantiate
	54	my $config;
	55	if (defined $self->config->commands->{lc($name)}) {
	56	$config = $self->config->commands->{lc($name)};
	57	}
	58	my $new_command = $class_name->new(
	59	'base_component' => $self->parent->base_component,
	60	'my_config' => $config
	61	);
	62	$new_command->controller($self);
	63
	64	# Determine runpaths
	65	foreach my $function ( @{Class::Inspector->functions($class_name)} ) {
	66	my $full_function = $class_name . '::' . $function;
	67	my $coderef = \&$full_function;
72	68
73		# Get subroutine attributes
74		if ( my $attributes = $new_command->FETCH_CODE_ATTRIBUTES($coderef) ) {
75		foreach my $attribute ( @{$attributes} ) {
76		my ( $command, $arguments ) = split( /\s*\(/, $attribute, 2 );
	69	# Get subroutine attributes
	70	if ( my $attributes = $new_command->FETCH_CODE_ATTRIBUTES($coderef) ) {
	71	foreach my $attribute ( @{$attributes} ) {
	72	my ( $command, $arguments ) = split( /\s*\(/, $attribute, 2 );
77	73
78		if ( $command eq 'Command' ) {
79		my $register = '^' . $command_root . ' +' . $function . ' ([^\b]+)';
80		if ( $command_name{$register} ) {
81		$self->error_override( $class_name, $register )
82		} else {
83		push(
84		@run_paths,
85		{
86		'match' => $register,
87		'function' => $function
88		}
89		);
90		}
91
92
93		} elsif ( $command eq 'CommandRegEx' ) {
94		$arguments =~ s/\)$//;
95		unless ( $arguments =~ /^'.*?'$/ ) {
96		$self->error_regex( $class_name, $function, $arguments );
97		} else {
98		$arguments =~ s/^'(.*?)'$/$1/;
99		my $register = '^' . $command_root . ' +' . $arguments;
	74	if ( $command eq 'Command' ) {
	75	my $register = '^' . $command_root . ' +' . $function . ' ([^\b]+)';
100	76	if ( $command_name{$register} ) {
101	77	$self->error_override( $class_name, $register )
…	…
109	85	);
110	86	}
111		}
	87
	88
	89	} elsif ( $command eq 'CommandRegEx' ) {
	90	$arguments =~ s/\)$//;
	91	unless ( $arguments =~ /^'.*?'$/ ) {
	92	$self->error_regex( $class_name, $function, $arguments );
	93	} else {
	94	$arguments =~ s/^'(.*?)'$/$1/;
	95	my $register = '^' . $command_root . ' +' . $arguments;
	96	if ( $command_name{$register} ) {
	97	$self->error_override( $class_name, $register )
	98	} else {
	99	push(
	100	@run_paths,
	101	{
	102	'match' => $register,
	103	'function' => $function
	104	}
	105	);
	106	}
	107	}
112	108
113		} elsif ( $command eq 'GlobalRegEx' ) {
114		$arguments =~ s/\)$//;
115		unless ( $arguments =~ /^'.*?'$/ ) {
116		$self->error_regex( $class_name, $function, $arguments );
117		} else {
118		$arguments =~ s/^'(.*?)'$/$1/;
119		if ( $command_name{$arguments} ) {
120		$self->error_override( $class_name, $arguments )
121		} else {
122		push(
123		@run_paths,
124		{
125		'match' => $arguments,
126		'function' => $function
127		}
128		);
129		}
130		}
	109	} elsif ( $command eq 'GlobalRegEx' ) {
	110	$arguments =~ s/\)$//;
	111	unless ( $arguments =~ /^'.*?'$/ ) {
	112	$self->error_regex( $class_name, $function, $arguments );
	113	} else {
	114	$arguments =~ s/^'(.*?)'$/$1/;
	115	if ( $command_name{$arguments} ) {
	116	$self->error_override( $class_name, $arguments )
	117	} else {
	118	push(
	119	@run_paths,
	120	{
	121	'match' => $arguments,
	122	'function' => $function
	123	}
	124	);
	125	}
	126	}
131	127
132		} elsif ( $command eq 'Monitor' ) {
133		push(
134		@run_paths,
135		{
136		'match' => '',
137		'function' => $function
138		}
139		);
	128	} elsif ( $command eq 'Monitor' ) {
	129	push(
	130	@run_paths,
	131	{
	132	'match' => '',
	133	'function' => $function
	134	}
	135	);
140	136
141		} elsif ( $command eq 'StopAfter' ) {
142		$end_paths{$function} = 1;
	137	} elsif ( $command eq 'StopAfter' ) {
	138	$end_paths{$function} = 1;
143	139
144		} else {
145		$self->log->error( $class_name . ': Invalid attribute "' . $command . '" on method "' . $function . '", ignoring.' );
146		}
147		}
148		}
149		}
150
151		# Insert end paths
152		for ( my $i = 0; $i < scalar(@run_paths); $i++ ) {
153		if ( $end_paths{ $run_paths[$i]->{'function'} } ) {
154		$run_paths[$i]->{'stop'} = 1;
155		}
156		}
157
158		$new_command->command_priority('Extension') unless ( $new_command->command_priority );
159		unless ( lc($new_command->command_priority) =~ /(extension\|last)/ and $self->skip_extensions ) {
160
161		# Add to command structure and name to command map
162		$command{ lc($new_command->command_priority) }->{$class_name} = \@run_paths;
163		$command_name{$class_name} = $new_command;
164		$command_short_name{$command_root} = $new_command;
165
166		$self->log->write('-> ' . ref($new_command) . ' loaded.');
167		}
168		}
169		}
170		}
171		close(COMMAND_DIR);
172
173		$self->command(\%command);
174		$self->command_name(\%command_name);
175		$self->command_short_name(\%command_short_name);
176		}
177
178		sub handle {
179		my ( $self, $message, $me ) = @_;
180
181		my @messages;
182		foreach my $priority ( qw( primary core extension last ) ) {
183		last if ( scalar(@messages) and $priority =~ /(extension\|last)/ );
184
185		foreach my $command_name ( keys %{ $self->command->{$priority} } ) {
186		my $command = $self->command_name->{$command_name};
187		next if ( $command->require_direct and !$message->is_direct );
188
189		foreach my $run_path ( @{ $self->command->{$priority}->{$command_name} } ) {
190		my $listen = $run_path->{'match'};
191		my $function = $run_path->{'function'};
192
193		if ( $listen eq '' or my (@matches) = $message->content =~ /$listen/i ) {
194		my $result;
195		eval {
196		$result = $command->$function( $message, \@matches );
197		};
198		if ($@) {
199		$self->log->error( 'Failure in ' . $command_name . ': ' . $@ );
200		my $return_message = new whatbot::Message(
201		'from' => '',
202		'to' => ($message->is_private == 0 ? 'public' : $message->from),
203		'content' => $command_name . ' completely failed at that last remark.',
204		'timestamp' => time,
205		'base_component' => $self->parent->base_component
206		);
207		push( @messages, $return_message);
208
209		} elsif ( defined $result ) {
210		last if ( $result eq 'last_run' );
211
212		$self->log->write('%%% Message handled by ' . $command_name)
213		unless ( defined $self->config->io->[0]->{'silent'} );
214		$result = [ $result ] if ( ref($result) ne 'ARRAY' );
215
216		foreach my $result_single ( @$result ) {
217		my $outmessage;
218		if ( ref($result_single) eq 'whatbot::Message' ) {
219		$outmessage = $result_single;
220		my $content = $outmessage->content;
221		$content =~ s/!who/$message->from/;
222		$outmessage->content($content);
223		} else {
224		$result_single =~ s/!who/$message->from/;
225		$outmessage = new whatbot::Message(
226		'from' => '',
227		'to' => ( $message->to eq 'public' ? 'public' : $message->from ),
228		'content' => $result_single,
229		'timestamp' => time,
230		'base_component' => $self->parent->base_component
231		);
232		}
233		push( @messages, $outmessage );
234		}
	140	} else {
	141	$self->log->error(
	142	$class_name . ': Invalid attribute "' . $command . '" on method "' . $function . '", ignoring.'
	143	);
	144	}
	145	}
	146	}
235	147	}
236
237		# End processing for this command if StopAfter was called.
238		last if $run_path->{'stop'};
239
	148
	149	# Insert end paths
	150	for ( my $i = 0; $i < scalar(@run_paths); $i++ ) {
	151	if ( $end_paths{ $run_paths[$i]->{'function'} } ) {
	152	$run_paths[$i]->{'stop'} = 1;
	153	}
	154	}
	155
	156	$new_command->command_priority('Extension') unless ( $new_command->command_priority );
	157	unless (
	158	lc($new_command->command_priority) =~ /(extension\|last)/
	159	and $self->skip_extensions
	160	) {
	161	# Add to command structure and name to command map
	162	$command{ lc($new_command->command_priority) }->{$class_name} = \@run_paths;
	163	$command_name{$class_name} = $new_command;
	164	$command_short_name{$command_root} = $new_command;
	165
	166	$self->log->write( '-> ' . ref($new_command) . ' loaded.' );
	167	}
240	168	}
241	169	}
242	170	}
243		}
	171	close(COMMAND_DIR);
244	172
245		return \@messages;
246		}
247
248		sub dump_command_map {
249		my ( $self ) = @_;
250
251		foreach my $priority ( qw( primary core extension ) ) {
252		my $commands = 0;
	173	$self->command(\%command);
	174	$self->command_name(\%command_name);
	175	$self->command_short_name(\%command_short_name);
	176	}
	177
	178	method handle ( whatbot::Message $message, $me? ) {
	179	my @messages;
	180	foreach my $priority ( qw( primary core extension last ) ) {
	181	last if ( scalar(@messages) and $priority =~ /(extension\|last)/ );
253	182
254		$self->log->write( uc($priority) . ':' );
	183	# Iterate through priorities, in order, check for commands that can
	184	# receive content
	185	foreach my $command_name ( keys %{ $self->command->{$priority} } ) {
	186	my $command = $self->command_name->{$command_name};
	187	next if ( $command->require_direct and !$message->is_direct );
	188
	189	# Check each method corresponding to a registered runpath to see
	190	# if it cares about our content
	191	foreach my $run_path ( @{ $self->command->{$priority}->{$command_name} } ) {
	192	my $listen = $run_path->{'match'};
	193	my $function = $run_path->{'function'};
	194
	195	if ( $listen eq '' or my (@matches) = $message->content =~ /$listen/i ) {
	196	my $result;
	197	eval {
	198	$result = $command->$function( $message, \@matches );
	199	};
	200	if ($@) {
	201	$self->log->error( 'Failure in ' . $command_name . ': ' . $@ );
	202	my $return_message = new whatbot::Message(
	203	'from' => '',
	204	'to' => ($message->is_private == 0 ? 'public' : $message->from),
	205	'content' => $command_name . ' completely failed at that last remark.',
	206	'timestamp' => time,
	207	'base_component' => $self->parent->base_component
	208	);
	209	push( @messages, $return_message);
	210
	211	} elsif ( defined $result ) {
	212	last if ( $result eq 'last_run' );
	213
	214	$self->log->write('%%% Message handled by ' . $command_name)
	215	unless ( defined $self->config->io->[0]->{'silent'} );
	216	$result = [ $result ] if ( ref($result) ne 'ARRAY' );
	217
	218	foreach my $result_single ( @$result ) {
	219	my $outmessage;
	220	if ( ref($result_single) eq 'whatbot::Message' ) {
	221	$outmessage = $result_single;
	222	my $content = $outmessage->content;
	223	$content =~ s/!who/$message->from/;
	224	$outmessage->content($content);
	225	} else {
	226	$result_single =~ s/!who/$message->from/;
	227	$outmessage = new whatbot::Message(
	228	'from' => '',
	229	'to' => ( $message->to eq 'public' ? 'public' : $message->from ),
	230	'content' => $result_single,
	231	'timestamp' => time,
	232	'base_component' => $self->parent->base_component
	233	);
	234	}
	235	push( @messages, $outmessage );
	236	}
	237	}
	238
	239	# End processing for this command if StopAfter was called.
	240	last if $run_path->{'stop'};
	241
	242	}
	243	}
	244	}
	245	}
	246
	247	return \@messages;
	248	}
	249
	250	method dump_command_map {
	251	foreach my $priority ( qw( primary core extension ) ) {
	252	my $commands = 0;
255	253
256		foreach my $command_name ( keys %{ $self->command->{$priority} } ) {
257		foreach my $run_path ( @{ $self->command->{$priority}->{$command_name} } ) {
258		$self->log->write( ' /' . $run_path->{'match'} . '/ => ' . $command_name . '->' . $run_path->{'function'} );
259		$commands++;
260		}
261		}
	254	$self->log->write( uc($priority) . ':' );
262	255
263		$self->log->write(' none') unless ($commands);
264		}
265		}
266
267		sub error_override {
268		my ( $self, $class, $name ) = @_;
269
270		$self->log->error( $class . ': More than one command being registered for "' . $name . '".' )
271		}
272
273		sub error_regex {
274		my ( $self, $class, $function, $regex ) = @_;
275
276		$self->log->error( $class . ': Invalid arguments (' . $regex . ') in method "' . $function . '".' )
	256	foreach my $command_name ( keys %{ $self->command->{$priority} } ) {
	257	foreach my $run_path ( @{ $self->command->{$priority}->{$command_name} } ) {
	258	$self->log->write( ' /' . $run_path->{'match'} . '/ => ' . $command_name . '->' . $run_path->{'function'} );
	259	$commands++;
	260	}
	261	}
	262
	263	$self->log->write(' none') unless ($commands);
	264	}
	265	}
	266
	267	method error_override ( Str $class, Str $name ) {
	268	$self->log->error( $class . ': More than one command being registered for "' . $name . '".' )
	269	}
	270
	271	method error_regex ( Str $class, Str $function, Str $regex ) {
	272	$self->log->error(
	273	$class . ': Invalid arguments (' . $regex . ') in method "' . $function . '".'
	274	);
	275	}
277	276	}
278	277

trunk/lib/whatbot/Database.pm

r155	r160
7	7	###########################################################################
8	8
9		package whatbot::Database;
10		use Moose;
11		extends 'whatbot::Component';
	9	use MooseX::Declare;
12	10
13		has 'handle' => ( is => 'rw', isa => 'Any' );
	11	class whatbot::Database extends whatbot::Component {
	12	has 'handle' => ( is => 'rw', isa => 'Any' );
14	13
15		sub connect {
16		my ( $self ) = @_;
17
18		$self->log->error( ref($self) . ' does not know how to connect.' );
	14	method connect {
	15	$self->log->error( ref($self) . ' does not know how to connect.' );
	16	}
19	17	}
20	18

trunk/lib/whatbot/IO.pm

r122	r160
7	7	###########################################################################
8	8
9		package whatbot::IO;
10		use Moose;
11		extends 'whatbot::Component';
	9	use MooseX::Declare;
12	10
13		use whatbot::Message;
	11	class whatbot::IO extends whatbot::Component {
	12	use whatbot::Message;
14	13
15		has 'my_config' => ( is => 'rw', isa => 'HashRef' );
16		has 'name' => ( is => 'rw', isa => 'Str' );
17		has 'me' => ( is => 'rw', isa => 'Str' );
	14	has 'my_config' => ( is => 'rw', isa => 'HashRef' );
	15	has 'name' => ( is => 'rw', isa => 'Str' );
	16	has 'me' => ( is => 'rw', isa => 'Str' );
18	17
19		sub BUILD {
20		my ( $self ) = @_;
	18	method BUILD ($) {
	19	unless ( defined $self->my_config ) {
	20	die 'No configuration found for ' . ref($self);
	21	}
	22	}
	23
	24	method notify ( Str $message ) {
	25	$self->log->write( '(' . $self->name . ') ' . $message )
	26	unless ( defined $self->my_config->{'silent'} );
	27	}
	28
	29	method connect {
	30	}
	31
	32	method disconnect {
	33	}
	34
	35	method event_user_enter {
	36	}
	37
	38	method event_user_leave {
	39	}
	40
	41	method event_message_public ( Str $from, $content, $optional? ) {
	42	my $message;
	43	if ( ref($content) eq 'whatbot::Message' ) {
	44	$message = $content;
	45	$self->notify('[PUB] <' . $from . '> ' . $content->content);
	46
	47	} else {
	48	$self->notify( '[PUB] <' . $from . '> ' . $content );
	49	$message = new whatbot::Message(
	50	'from' => $from,
	51	'to' => 'public',
	52	'content' => $content,
	53	'timestamp' => time,
	54	'me' => $self->me,
	55	'base_component' => $self->parent->base_component,
	56	'origin' => $self,
	57	);
	58	}
	59	if ( $from eq $self->me ) {
	60	$self->parent->last_message($message);
	61	} else {
	62	$self->parse_response( $self->controller->handle($message) );
	63	}
	64	}
	65
	66	method event_message_private ( Str $from, Str $content ) {
	67	$self->notify( '[PRI] <' . $from . '> ' . $content );
	68	unless ( $from eq $self->me ) {
	69	my $message = new whatbot::Message(
	70	'from' => $from,
	71	'to' => $self->me,
	72	'content' => $content,
	73	'timestamp' => time,
	74	'is_private' => 1,
	75	'me' => $self->me,
	76	'base_component' => $self->parent->base_component,
	77	'origin' => $self,
	78	);
	79	$self->parse_response( $self->controller->handle($message) );
	80	}
21	81
22		unless ( defined $self->my_config ) {
23		die 'No configuration found for ' . ref($self);
24		}
25		}
	82	}
26	83
27		sub notify {
28		my ( $self, $message ) = @_;
29
30		$self->log->write( '(' . $self->name . ') ' . $message )
31		unless ( defined $self->my_config->{'silent'} );
32		}
	84	method event_action ( Str $from, Str $content ) {
	85	$self->notify( '[ACT] ' . $from . ' ' . $content );
	86	}
33	87
34		sub connect {
35		my ( $self ) = @_;
36
37		}
	88	method send_message ( $message ) {
	89	}
38	90
39		sub disconnect {
40		my ( $self ) = @_;
41
42		}
43
44		sub event_user_enter {
45		my ( $self ) = @_;
46
47		}
48
49		sub event_user_leave {
50		my ( $self ) = @_;
51
52		}
53
54		sub event_message_public {
55		my ( $self, $from, $content ) = @_;
56
57		my $message;
58		if ( ref($content) eq 'whatbot::Message' ) {
59		$message = $content;
60		$self->notify('[PUB] <' . $from . '> ' . $content->content);
61
62		} else {
63		$self->notify( '[PUB] <' . $from . '> ' . $content );
64		$message = new whatbot::Message(
65		'from' => $from,
66		'to' => 'public',
67		'content' => $content,
68		'timestamp' => time,
69		'me' => $self->me,
70		'base_component' => $self->parent->base_component,
71		'origin' => $self,
72		);
73		}
74		if ( $from eq $self->me ) {
75		$self->parent->last_message($message);
76		} else {
77		$self->parse_response( $self->controller->handle($message) );
	91	method parse_response ( $messages ) {
	92	return unless ( defined $messages );
	93	foreach my $message ( @{$messages} ) {
	94	$self->send_message($message);
	95	}
78	96	}
79	97	}
80	98
81		~~sub event_message_private {~~
82		~~my ( $self, $from, $content ) = @_;~~
83
84		~~$self->notify( '[PRI] <' . $from . '> ' . $content );~~
85		~~unless ( $from eq $self->me ) {~~
86		~~my $message = new whatbot::Message(~~
87		~~'from' => $from,~~
88		~~'to' => $self->me,~~
89		~~'content' => $content,~~
90		~~'timestamp' => time,~~
91		~~'is_private' => 1,~~
92		~~'me' => $self->me,~~
93		~~'base_component' => $self->parent->base_component,~~
94		~~'origin' => $self,~~
95		);
96		~~$self->parse_response( $self->controller->handle($message) );~~
97		}
98
99		}
100
101		~~sub event_action {~~
102		~~my ( $self, $from, $content ) = @_;~~
103
104		~~$self->notify( '[ACT] ' . $from . ' ' . $content );~~
105		}
106
107		~~sub send_message {~~
108		~~my ( $self, $message ) = @_;~~
109
110		}
111
112		~~sub parse_response {~~
113		~~my ( $self, $messages ) = @_;~~
114
115		~~return undef unless ( defined $messages );~~
116		~~foreach my $message ( @{$messages} ) {~~
117		~~$self->send_message($message);~~
118		}
119		}
120
121	99	1;

trunk/lib/whatbot/IO/AIM.pm

r120	r160
7	7	###########################################################################
8	8
9		package whatbot::IO::AIM;
10		use Moose;
11		extends 'whatbot::IO';
	9	use MooseX::Declare;
12	10
13		use HTML::Strip;
	11	class whatbot::IO::AIM extends whatbot::IO {
	12	use HTML::Strip;
	13	use Net::OSCAR qw(:standard);
14	14
15		use Net::OSCAR qw(:standard);
	15	has 'aim_handle' => ( is => 'rw' );
	16	has 'strip' => ( is => 'ro', default => sub { HTML::Strip->new() } );
16	17
17		has 'aim_handle' => ( is => 'rw' );
18		has 'strip' => ( is => 'ro', default => sub { HTML::Strip->new() } );
	18	method BUILD {
	19	my $name = 'AIM_' . $self->my_config->{'screenname'};
	20	$name =~ s/ /_/g;
	21	$self->name($name);
	22	$self->me( $self->my_config->{'screenname'} );
	23	}
19	24
20		sub BUILD {
21		my ( $self ) = @_;
	25	method connect {
	26	# Create Object
	27	my $oscar = Net::OSCAR->new();
22	28
23		my $name = 'AIM_' . $self->my_config->{'screenname'};
24		$name =~ s/ /_/g;
25		$self->name($name);
26		$self->me( $self->my_config->{'screenname'} );
27		}
	29	# Set callbacks
	30	$oscar->set_callback_im_in(\&cb_message);
	31	$oscar->set_callback_signon_done(\&cb_connected);
	32	$oscar->set_callback_error(\&cb_error);
	33
	34	# Sign on
	35	$oscar->signon(
	36	$self->my_config->{'screenname'},
	37	$self->my_config->{'password'}
	38	);
	39	$oscar->{'_whatbot'} = $self;
	40	$self->aim_handle($oscar);
	41	return $self->aim_handle->do_one_loop();
	42	}
28	43
29		sub connect {
30		my ( $self ) = @_;
	44	method disconnect {
	45	return $self->aim_handle->signoff();
	46	}
	47
	48	method event_loop {
	49	eval {
	50	$self->aim_handle->do_one_loop();
	51	};
	52	return;
	53	}
	54
	55	# Send a message
	56	method send_message( $message ) {
	57	# We're going to try and be smart.
	58	my $characters_per_line = '1024';
	59	if (
	60	defined($self->my_config->{'charactersperline'})
	61	and ref($self->my_config->{'charactersperline'}) ne 'HASH'
	62	) {
	63	$characters_per_line = $self->my_config->{'charactersperline'};
	64	}
	65	my @lines;
	66	my @message_words = split( /\s/, $message->content );
31	67
32		# Create Object
33		my $oscar = Net::OSCAR->new(
34		);
	68	# If any of the words are over our maxlength, then let Net::IRC split it.
	69	# Otherwise, it's probably actual conversation, so we should split words.
	70	my $line = '';
	71	foreach my $word (@message_words) {
	72	if ( length($word) > $characters_per_line ) {
	73	my $msg = $message->content;
	74	$line = '';
	75	@lines = ();
	76	while ( length($msg) > 0 ) {
	77	push( @lines, substr($msg, 0, $characters_per_line) );
	78	$msg = substr( $msg, $characters_per_line );
	79	}
	80	@message_words = undef;
	81	} else {
	82	if (length($line) + length($word) + 1 > $characters_per_line) {
	83	push(@lines, $line);
	84	$line = '';
	85	}
	86	$line .= ' ' if ($line);
	87	$line .= $word;
	88	}
	89	}
	90	# Close out
	91	push(@lines, $line) if ($line);
35	92
36		# Set callbacks
37		$oscar->set_callback_im_in(\&cb_message);
38		$oscar->set_callback_signon_done(\&cb_connected);
39		$oscar->set_callback_error(\&cb_error);
40
41		# Sign on
42		$oscar->signon(
43		$self->my_config->{'screenname'},
44		$self->my_config->{'password'}
45		);
46		$oscar->{'_whatbot'} = $self;
47		$self->aim_handle($oscar);
48		$self->aim_handle->do_one_loop();
49		}
50
51		sub disconnect {
52		my ($self) = @_;
53
54		$self->aim_handle->signoff();
55		}
56
57		sub event_loop {
58		my ($self) = @_;
59
60		eval {
61		$self->aim_handle->do_one_loop();
62		};
63		}
64
65		# Send a message
66		sub send_message {
67		my ($self, $message) = @_;
68
69		# We're going to try and be smart.
70		my $characters_per_line = '1024';
71		if (
72		defined($self->my_config->{'charactersperline'})
73		and ref($self->my_config->{'charactersperline'}) ne 'HASH'
74		) {
75		$characters_per_line = $self->my_config->{'charactersperline'};
76		}
77		my @lines;
78		my @message_words = split( /\s/, $message->content );
79
80		# If any of the words are over our maxlength, then let Net::IRC split it.
81		# Otherwise, it's probably actual conversation, so we should split words.
82		my $line = '';
83		foreach my $word (@message_words) {
84		if ( length($word) > $characters_per_line ) {
85		my $msg = $message->content;
86		$line = '';
87		@lines = ();
88		while ( length($msg) > 0 ) {
89		push( @lines, substr($msg, 0, $characters_per_line) );
90		$msg = substr( $msg, $characters_per_line );
	93	# Send messages
	94	foreach my $out_line (@lines) {
	95	my $result = $self->aim_handle->send_im( $message->to, $out_line );
	96	if ($result > 0) {
	97	$self->event_message_private( $self->me, $out_line );
	98	} else {
	99	$self->notify('Message could not be sent');
91	100	}
92		@message_words = undef;
93		} else {
94		if (length($line) + length($word) + 1 > $characters_per_line) {
95		push(@lines, $line);
96		$line = '';
97		}
98		$line .= ' ' if ($line);
99		$line .= $word;
	101
100	102	}
101	103	}
102		# Close out
103		push(@lines, $line) if ($line);
104
105		# Send messages
106		foreach my $out_line (@lines) {
107		my $result = $self->aim_handle->send_im( $message->to, $out_line );
108		if ($result > 0) {
109		$self->event_message_private( $self->me, $out_line );
110		} else {
111		$self->notify('Message could not be sent');
112		}
113
	104
	105	#
	106	# INTERNAL
	107	#
	108
	109	# Event: Received a message
	110	method cb_message( $from, $message, $is_away_response) {
	111	$message = $self->{'_whatbot'}->strip->parse($message);
	112	$message =~ s/^[^A-z0-9]+//;
	113	$message =~ s/[\s]+$//;
	114	$self->{'_whatbot'}->event_message_private(
	115	$$from,
	116	$message,
	117	1
	118	) unless ( $is_away_response );
	119	}
	120
	121	# Event: Connected
	122	method cb_connected {
	123	$self->{'_whatbot'}->notify('Connected successfully.');
	124	}
	125
	126	# Event: Error
	127	method cb_error( $connection, $error, $description, $fatal ) {
	128	$self->{'_whatbot'}->notify($error);
114	129	}
115	130	}
116	131
117		#
118		~~# INTERNAL~~
119		#
120
121		~~# Event: Received a message~~
122		~~sub cb_message {~~
123		~~my ( $self, $from, $message, $isAwayResponse ) = @_;~~
124
125		~~$message = $self->{'_whatbot'}->strip->parse($message);~~
126		~~$message =~ s/^[^A-z0-9]+//;~~
127		~~$message =~ s/[\s]+$//;~~
128		~~$self->{'_whatbot'}->event_message_private(~~
129		~~$$from,~~
130		~~$message,~~
131		1
132		~~) if ( !$isAwayResponse );~~
133		}
134
135		~~sub cb_connected {~~
136		~~my ( $self ) = @_;~~
137
138		~~$self->{'_whatbot'}->notify('Connected successfully.');~~
139		}
140
141		~~sub cb_error {~~
142		~~my ( $self, $connection, $error, $description, $fatal );~~
143
144		~~$self->{'_whatbot'}->notify($error);~~
145		}
146
147	132	1;

trunk/lib/whatbot/IO/IRC.pm

r159	r160
9	9	###########################################################################
10	10
11		package whatbot::IO::IRC;
12		use Moose;
13		extends 'whatbot::IO';
14
15		use Net::IRC;
16
17		has 'handle' => ( is => 'rw' );
18		has 'irc_handle' => ( is => 'ro', isa => 'Net::IRC::Connection' );
19		has 'force_disconnect' => ( is => 'rw', isa => 'Int' );
20
21		sub BUILD {
22		my ( $self ) = @_;
23
24		my $name = 'IRC_' . $self->my_config->{'host'} . '_' . $self->my_config->{'channel'}->{'name'};
25		$name =~ s/ /_/g;
26		$self->name($name);
27		$self->me( $self->my_config->{'nick'} );
	11	use MooseX::Declare;
	12
	13	class whatbot::IO::IRC extends whatbot::IO {
	14	use Net::IRC;
	15
	16	has 'handle' => ( is => 'rw' );
	17	has 'irc_handle' => ( is => 'ro', isa => 'Net::IRC::Connection' );
	18	has 'force_disconnect' => ( is => 'rw', isa => 'Int' );
	19
	20	method BUILD {
	21	my $name = 'IRC_' . $self->my_config->{'host'} . '_' . $self->my_config->{'channel'}->{'name'};
	22	$name =~ s/ /_/g;
	23	$self->name($name);
	24	$self->me( $self->my_config->{'nick'} );
	25	}
	26
	27	method connect {
	28	my $handle = Net::IRC->new();
	29	$self->handle($handle);
	30	$self->log->write(
	31	'Connecting to ' .
	32	$self->my_config->{'host'} . ':' . $self->my_config->{'port'} .
	33	'.');
	34
	35	# Net::IRC Connection Parameters
	36	$self->{'irc_handle'} = $self->handle->newconn(
	37	'Server' => $self->my_config->{'host'},
	38	'Port' => $self->my_config->{'port'},
	39	'Username' => $self->my_config->{'username'},
	40	'Ircname' => $self->my_config->{'realname'},
	41	'Password' => $self->my_config->{'hostpassword'},
	42	'Nick' => $self->my_config->{'nick'},
	43	'SSL' => ( $self->my_config->{'ssl'} ? 1 : undef )
	44	);
	45
	46	# Everything's event based, so we set up all the callbacks
	47	$self->irc_handle->add_handler('msg', \&cb_private_message);
	48	$self->irc_handle->add_handler('public', \&cb_message);
	49	$self->irc_handle->add_handler('caction', \&cb_action);
	50	$self->irc_handle->add_handler('join', \&cb_join);
	51	$self->irc_handle->add_handler('part', \&cb_part);
	52	$self->irc_handle->add_handler('cping', \&cb_ping);
	53	$self->irc_handle->add_handler('topic', \&cb_topic);
	54	$self->irc_handle->add_handler('notopic', \&cb_topic);
	55
	56	$self->irc_handle->add_global_handler(376, \&cb_connect);
	57	$self->irc_handle->add_global_handler('disconnect', \&cb_disconnect);
	58	$self->irc_handle->add_global_handler(353, \&cb_names);
	59	$self->irc_handle->add_global_handler(433, \&cb_nick_taken);
	60
	61	# I can't figure out how else to use this module in an OO way,
	62	# so I just do hax. They say if it takes a lot of work, you aren't
	63	# doing it right. Fine. Tell me how to fix this, then, and don't
	64	# say POE::Component::IRC. infobot hasn't released a new version
	65	# because they're moving to POE. Rapid development my behind.
	66	$self->irc_handle->{'_whatbot'} = $self;
	67
	68	# Now we start one event loop so we can actually connect.
	69	$self->handle->do_one_loop();
	70	binmode( $self->irc_handle->socket, ":utf8" );
	71	}
	72
	73	method disconnect {
	74	$self->force_disconnect(1);
	75	$self->irc_handle->quit( $self->my_config->{'quitmessage'} );
	76	}
	77
	78	method event_loop {
	79	$self->handle->do_one_loop();
	80	}
	81
	82	# Send a message
	83	method send_message( $message ) {
	84	# We're going to try and be smart.
	85	my $characters_per_line = 450;
	86	if (
	87	defined( $self->my_config->{'charactersperline'} )
	88	and ref( $self->my_config->{'charactersperline'} ) ne 'HASH'
	89	) {
	90	$characters_per_line = $self->my_config->{'charactersperline'};
	91	}
	92	my @lines;
	93	my @message_words = split(/\s/, $message->content);
	94
	95	# If any of the words are over our maxlength, then let Net::IRC split it.
	96	# Otherwise, it's probably actual conversation, so we should split words.
	97	my $line = '';
	98	foreach my $word (@message_words) {
	99	if ( length($word) > $characters_per_line ) {
	100	my $msg = $message->content;
	101	$line = '';
	102	@lines = ();
	103	while ( length($msg) > 0 ) {
	104	push( @lines, substr($msg, 0, $characters_per_line) );
	105	$msg = substr( $msg, $characters_per_line );
	106	}
	107	@message_words = undef;
	108	} else {
	109	if ( length($line) + length($word) + 1 > $characters_per_line ) {
	110	push(@lines, $line);
	111	$line = '';
	112	}
	113	$line .= ' ' if ($line);
	114	$line .= $word;
	115	}
	116	}
	117	# Close out
	118	push(@lines, $line) if ($line);
	119
	120	# Send messages
	121	if ( $message->content =~ /^\/me (.*)/ ) {
	122	$self->irc_handle->me( $self->my_config->{'channel'}->{'name'}, $1 );
	123	$self->event_action( $self->me, $message->content );
	124	} else {
	125	foreach my $outLine (@lines) {
	126	$self->irc_handle->privmsg( $self->my_config->{'channel'}->{'name'}, $outLine );
	127	$self->event_message_public( $self->me, $outLine );
	128	sleep( int(rand(2)) );
	129	}
	130	}
	131	}
	132
	133	###########
	134	# INTERNAL
	135	###########
	136
	137	# Event: Received a user action
	138	method cb_action( $event ) {
	139	my ($message) = ( $event->args );
	140	$self->{'_whatbot'}->event_action( $event->nick, $message );
	141	}
	142
	143	# Event: Connected to server
	144	method cb_connect( $event ) {
	145	$self->{'_whatbot'}->me( $self->nick );
	146
	147	# Join default channel
	148	$self->join(
	149	$self->{'_whatbot'}->my_config->{'channel'}->{'name'},
	150	$self->{'_whatbot'}->my_config->{'channel'}->{'channelpassword'}
	151	);
	152	}
	153
	154	# Event: Disconnected from server
	155	method cb_disconnect( $event ) {
	156	unless ( $self->{'_whatbot'}->force_disconnect ) {
	157	$self->{'_whatbot'}->notify('Disconnected, attempting to reconnect...');
	158	sleep(1);
	159	$self->connect();
	160	}
	161	}
	162
	163	# Event: User joined channel
	164	method cb_join( $event ) {
	165	$self->{'_whatbot'}->event_user_enter( $event->nick );
	166	}
	167
	168	# Event: Received a public message
	169	method cb_message( $event ) {
	170	my ($message) = ( $event->args );
	171	$self->{'_whatbot'}->event_message_public( $event->nick, $message, 1 );
	172	}
	173
	174	# Event: Received channel users
	175	method cb_names( $event ) {
	176	my ( @list, $channel ) = ( $event->args );
	177	( $channel, @list ) = splice( @list, 2 );
	178
	179	$self->{'_whatbot'}->notify( $channel . ' users: ' . join(', ', @list) );
	180
	181	# When we get names, we've joined a room. If we have a join message,
	182	# display it.
	183	if (
	184	defined $self->{'_whatbot'}->my_config->{'channel'}->{'joinmessage'}
	185	and ref($self->{'_whatbot'}->my_config->{'channel'}->{'joinmessage'}
	186	) ne 'HASH') {
	187	$self->privmsg( $channel, $self->{'_whatbot'}->my_config->{'channel'}->{'joinmessage'} );
	188	}
	189	}
	190
	191	# Event: Attempted nick is taken
	192	method cb_nick_taken( $event ) {
	193	$self->{'_whatbot'}->my_config->{'username'} .= '_';
	194	$self->nick( $self->{'_whatbot'}->my_config->{'username'} );
	195	$self->{'_whatbot'}->me( $self->nick );
	196	}
	197
	198	# Event: User left a channel
	199	method cb_part( $event ) {
	200	$self->{'_whatbot'}->event_user_leave($event->nick);
	201	}
	202
	203	# Event: Received CTCP Ping request
	204	method cb_ping( $event ) {
	205	my $nick = $event->nick;
	206	$self->ctcp_reply( $nick, join ( ' ', ($event->args) ) );
	207	$self->{'_whatbot'}->notify('*** CTCP PING request from $nick received');
	208	}
	209
	210	# Event: Received a private message
	211	method cb_private_message( $event ) {
	212	my ( $message ) = ( $event->args );
	213	$self->{'_whatbot'}->event_message_private( $event->nick, $message );
	214	}
	215
	216	# Event: Channel topic change
	217	method cb_topic( $event ) {
	218	my ( $channel, $topic ) = $event->args();
	219	if ( $event->type() eq 'topic' and $channel =~ /^#/ ) {
	220	$self->{'_whatbot'}->notify('The topic for $channel is \'$topic\'.');
	221	}
	222	}
28	223	}
29	224
30		~~sub connect {~~
31		~~my ( $self ) = @_;~~
32
33		~~my $handle = new Net::IRC;~~
34		~~$self->handle($handle);~~
35		~~$self->log->write(~~
36		~~'Connecting to ' .~~
37		~~$self->my_config->{'host'} . ':' . $self->my_config->{'port'} .~~
38		~~'.');~~
39
40		~~# Net::IRC Connection Parameters~~
41		~~$self->{'irc_handle'} = $self->handle->newconn(~~
42		~~'Server' => $self->my_config->{'host'},~~
43		~~'Port' => $self->my_config->{'port'},~~
44		~~'Username' => $self->my_config->{'username'},~~
45		~~'Ircname' => $self->my_config->{'realname'},~~
46		~~'Password' => $self->my_config->{'hostpassword'},~~
47		~~'Nick' => $self->my_config->{'nick'},~~
48		~~'SSL' => ( $self->my_config->{'ssl'} ? 1 : undef )~~
49		);
50
51		~~# Everything's event based, so we set up all the callbacks~~
52		~~$self->irc_handle->add_handler('msg', \&cb_private_message);~~
53		~~$self->irc_handle->add_handler('public', \&cb_message);~~
54		~~$self->irc_handle->add_handler('caction', \&cb_action);~~
55		~~$self->irc_handle->add_handler('join', \&cb_join);~~
56		~~$self->irc_handle->add_handler('part', \&cb_part);~~
57		~~$self->irc_handle->add_handler('cping', \&cb_ping);~~
58		~~$self->irc_handle->add_handler('topic', \&cb_topic);~~
59		~~$self->irc_handle->add_handler('notopic', \&cb_topic);~~
60
61		~~$self->irc_handle->add_global_handler(376, \&cb_connect);~~
62		~~$self->irc_handle->add_global_handler('disconnect', \&cb_disconnect);~~
63		~~$self->irc_handle->add_global_handler(353, \&cb_names);~~
64		~~$self->irc_handle->add_global_handler(433, \&cb_nick_taken);~~
65
66		~~# I can't figure out how else to use this module in an OO way,~~
67		~~# so I just do hax. They say if it takes a lot of work, you aren't~~
68		~~# doing it right. Fine. Tell me how to fix this, then, and don't~~
69		~~# say POE::Component::IRC. infobot hasn't released a new version~~
70		~~# because they're moving to POE. Rapid development my behind.~~
71		~~$self->irc_handle->{'_whatbot'} = $self;~~
72
73		~~# Now we start one event loop so we can actually connect.~~
74		~~$self->handle->do_one_loop();~~
75		~~binmode( $self->irc_handle->socket, ":utf8" );~~
76		}
77
78		~~sub disconnect {~~
79		~~my ($self) = @_;~~
80
81		~~$self->force_disconnect(1);~~
82		~~$self->irc_handle->quit( $self->my_config->{'quitmessage'} );~~
83		}
84
85		~~sub event_loop {~~
86		~~my ($self) = @_;~~
87
88		~~$self->handle->do_one_loop();~~
89		}
90
91		~~# Send a message~~
92		~~sub send_message {~~
93		~~my ($self, $message) = @_;~~
94
95		~~# We're going to try and be smart.~~
96		~~my $characters_per_line = 450;~~
97		~~if (~~
98		~~defined( $self->my_config->{'charactersperline'} )~~
99		~~and ref( $self->my_config->{'charactersperline'} ) ne 'HASH'~~
100		~~) {~~
101		~~$characters_per_line = $self->my_config->{'charactersperline'};~~
102		}
103		~~my @lines;~~
104		~~my @message_words = split(/\s/, $message->content);~~
105
106		~~# If any of the words are over our maxlength, then let Net::IRC split it.~~
107		~~# Otherwise, it's probably actual conversation, so we should split words.~~
108		~~my $line = '';~~
109		~~foreach my $word (@message_words) {~~
110		~~if ( length($word) > $characters_per_line ) {~~
111		~~my $msg = $message->content;~~
112		~~$line = '';~~
113		~~@lines = ();~~
114		~~while ( length($msg) > 0 ) {~~
115		~~push( @lines, substr($msg, 0, $characters_per_line) );~~
116		~~$msg = substr( $msg, $characters_per_line );~~
117		}
118		~~@message_words = undef;~~
119		~~} else {~~
120		~~if ( length($line) + length($word) + 1 > $characters_per_line ) {~~
121		~~push(@lines, $line);~~
122		~~$line = '';~~
123		}
124		~~$line .= ' ' if ($line);~~
125		~~$line .= $word;~~
126		}
127		}
128		~~# Close out~~
129		~~push(@lines, $line) if ($line);~~
130
131		~~# Send messages~~
132		~~if ( $message->content =~ /^\/me (.*)/ ) {~~
133		~~$self->irc_handle->me( $self->my_config->{'channel'}->{'name'}, $1 );~~
134		~~$self->event_action( $self->me, $message->content );~~
135		~~} else {~~
136		~~foreach my $outLine (@lines) {~~
137		~~$self->irc_handle->privmsg( $self->my_config->{'channel'}->{'name'}, $outLine );~~
138		~~$self->event_message_public( $self->me, $outLine );~~
139		~~sleep( int(rand(2)) );~~
140		}
141		}
142		}
143
144		~~###########~~
145		~~# INTERNAL~~
146		~~###########~~
147
148		~~# Event: Received a user action~~
149		~~sub cb_action {~~
150		~~my ( $self, $event ) = @_;~~
151
152		~~my ($message) = ( $event->args );~~
153		~~$self->{'_whatbot'}->event_action( $event->nick, $message );~~
154		}
155
156		~~# Event: Connected to server~~
157		~~sub cb_connect {~~
158		~~my ( $self, $event ) = @_;~~
159
160		~~$self->{'_whatbot'}->me( $self->nick );~~
161
162		~~# Join default channel~~
163		~~$self->join(~~
164		~~$self->{'_whatbot'}->my_config->{'channel'}->{'name'},~~
165		~~$self->{'_whatbot'}->my_config->{'channel'}->{'channelpassword'}~~
166		);
167		}
168
169		~~# Event: Disconnected from server~~
170		~~sub cb_disconnect {~~
171		~~my ( $self, $event ) = @_;~~
172
173		~~unless ( $self->{'_whatbot'}->force_disconnect ) {~~
174		~~$self->{'_whatbot'}->notify('Disconnected, attempting to reconnect...');~~
175		~~sleep(1);~~
176		~~$self->connect();~~
177		}
178		}
179
180		~~# Event: User joined channel~~
181		~~sub cb_join {~~
182		~~my ( $self, $event ) = @_;~~
183
184		~~$self->{'_whatbot'}->event_user_enter( $event->nick );~~
185		}
186
187		~~# Event: Received a public message~~
188		~~sub cb_message {~~
189		~~my ( $self, $event ) = @_;~~
190
191		~~my ($message) = ( $event->args );~~
192		~~$self->{'_whatbot'}->event_message_public( $event->nick, $message, 1 );~~
193		}
194
195		~~# Event: Received channel users~~
196		~~sub cb_names {~~
197		~~my ( $self, $event ) = @_;~~
198
199		~~my ( @list, $channel ) = ( $event->args );~~
200		~~( $channel, @list ) = splice( @list, 2 );~~
201
202		~~$self->{'_whatbot'}->notify( $channel . ' users: ' . join(', ', @list) );~~
203
204		~~# When we get names, we've joined a room. If we have a join message,~~
205		~~# display it.~~
206		~~if (~~
207		~~defined $self->{'_whatbot'}->my_config->{'channel'}->{'joinmessage'}~~
208		~~and ref($self->{'_whatbot'}->my_config->{'channel'}->{'joinmessage'}~~
209		~~) ne 'HASH') {~~
210		~~$self->privmsg( $channel, $self->{'_whatbot'}->my_config->{'channel'}->{'joinmessage'} );~~
211		}
212		}
213
214		~~# Event: Attempted nick is taken~~
215		~~sub cb_nick_taken {~~
216		~~my ( $self, $event ) = @_;~~
217
218		~~$self->{'_whatbot'}->my_config->{'username'} .= '_';~~
219		~~$self->nick( $self->{'_whatbot'}->my_config->{'username'} );~~
220		~~$self->{'_whatbot'}->me( $self->nick );~~
221		}
222
223		~~# Event: User left a channel~~
224		~~sub cb_part {~~
225		~~my ( $self, $event ) = @_;~~
226
227		~~$self->{'_whatbot'}->event_user_leave($event->nick);~~
228		}
229
230		~~# Event: Received CTCP Ping request~~
231		~~sub cb_ping {~~
232		~~my ( $self, $event ) = @_;~~
233
234		~~my $nick = $event->nick;~~
235		~~$self->ctcp_reply( $nick, join ( ' ', ($event->args) ) );~~
236		~~$self->{'_whatbot'}->notify('*** CTCP PING request from $nick received');~~
237		}
238
239		~~# Event: Received a private message~~
240		~~sub cb_private_message {~~
241		~~my ( $self, $event ) = @_;~~
242
243		~~my ( $nick, $message ) = ( $event->args );~~
244		~~#$self->{'_whatbot'}->event_message($event->nick, $message, 2);~~
245		}
246
247		~~# Event: Channel topic change~~
248		~~sub cb_topic {~~
249		~~my ( $self, $event ) = @_;~~
250
251		~~my ($channel, $topic) = $event->args();~~
252		~~if ( $event->type() eq 'topic' and $channel =~ /^#/ ) {~~
253		~~$self->{'_whatbot'}->notify('The topic for $channel is \'$topic\'.');~~
254		}
255		}
256
257	225	1;
	226

trunk/lib/whatbot/IO/Log.pm

r54	r160
7	7	###########################################################################
8	8
9		package whatbot::IO::Log;
10		use Moose;
11		extends 'whatbot::IO';
	9	use MooseX::Declare;
12	10
13		use whatbot::Progress;
	11	class whatbot::IO::Log extends whatbot::IO {
	12	use whatbot::Progress;
14	13
15		has 'file_handle' => ( is => 'rw' );
16		has 'line_count' => ( is => 'rw' );
17		has 'current_line' => ( is => 'rw' );
18		has 'progress' => ( is => 'rw' );
	14	has 'file_handle' => ( is => 'rw' );
	15	has 'line_count' => ( is => 'rw' );
	16	has 'current_line' => ( is => 'rw' );
	17	has 'progress' => ( is => 'rw' );
19	18
20		sub BUILD {
21		my ( $self ) = @_;
	19	method BUILD {
	20	my $name = 'Log';
	21	$self->name($name);
	22	$self->me( $self->my_config->{'me'} );
	23	}
	24
	25	method connect {
	26	# Open log file, store scalar file_handle
	27	$self->log->write( 'Opening ' . $self->my_config->{'filepath'} );
	28	my $fh;
	29	open ( $fh, $self->my_config->{'filepath'} );
	30	$self->file_handle($fh);
22	31
23		my $name = 'Log';
24		$self->name($name);
25		$self->me( $self->my_config->{'me'} );
26		}
	32	# Get File Count
	33	my $lines = 0;
	34	my $buffer;
	35	open( FILE, $self->my_config->{'filepath'} ) or die "Can't open: $!";
	36	while ( sysread FILE, $buffer, 4096 ) {
	37	$lines += ( $buffer =~ tr/\n// );
	38	}
	39	close (FILE);
	40	$self->line_count($lines);
	41	}
27	42
28		sub connect {
29		my ( $self ) = @_;
	43	method disconnect {
	44	$self->log->write( 'Closing ' . $self->my_config->{'filepath'} );
	45	close( $self->file_handle );
	46	}
	47
	48	method event_loop {
	49	my $fh = $self->file_handle;
	50	$self->progress(
	51	new whatbot::Progress(
	52	'restrict_updates' => 1000,
	53	'max' => $self->line_count,
	54	'show_count' => 1
	55	)
	56	) unless ( defined $self->progress );
30	57
31		# Open log file, store scalar file_handle
32		$self->log->write( 'Opening ' . $self->my_config->{'filepath'} );
33		my $fh;
34		open ( $fh, $self->my_config->{'filepath'} );
35		$self->file_handle($fh);
36
37		# Get File Count
38		my $lines = 0;
39		my $buffer;
40		open( FILE, $self->my_config->{'filepath'} ) or die "Can't open: $!";
41		while ( sysread FILE, $buffer, 4096 ) {
42		$lines += ( $buffer =~ tr/\n// );
43		}
44		close (FILE);
45		$self->line_count($lines);
46		}
	58	if ( my $line = <$fh> ) {
	59	$self->{'current_line'}++;
	60	$self->parseLine($line);
	61	$self->progress->update( $self->current_line );
	62	} else {
	63	$self->progress->finish;
	64	$self->parent->kill_self(1);
	65	}
	66	}
47	67
48		sub disconnect {
49		my ( $self ) = @_;
50
51		$self->log->write( 'Closing ' . $self->my_config->{'filepath'} );
52		close( $self->file_handle );
53		}
	68	# Send a message
	69	method send_message( $message ) {
	70	}
54	71
55		sub event_loop {
56		my ( $self ) = @_;
57
58		my $fh = $self->file_handle;
59		$self->progress(
60		new whatbot::Progress(
61		'restrict_updates' => 1000,
62		'max' => $self->line_count,
63		'show_count' => 1
64		)
65		) unless ( defined $self->progress );
66
67		if ( my $line = <$fh> ) {
68		$self->{'current_line'}++;
69		$self->parseLine($line);
70		$self->progress->update( $self->current_line );
71		} else {
72		$self->progress->finish;
73		$self->parent->kill_self(1);
	72
	73	method parse_line( $line ) {
74	74	}
75	75	}
76	76
77		~~# Send a message~~
78		~~sub send_message {~~
79		~~my ( $self, $message ) = @_;~~
80
81		}
82
83
84		~~sub parse_line {~~
85		~~my ( $self, $line ) = @_;~~
86		}
87
88	77	1;

trunk/lib/whatbot/IO/Log/Infobot.pm

r56	r160
7	7	###########################################################################
8	8
9		package whatbot::IO::Log::Infobot;
10		use Moose;
11		extends 'whatbot::IO::Log';
	9	use MooseX::Declare;
12	10
13		use whatbot::Message;
	11	class whatbot::IO::Log::Infobot extends whatbot::IO::Log {
	12	use whatbot::Message;
14	13
15		sub parse_line {
16		my ( $self, $line ) = @_;
17
18		if ( $line =~ /^(\d+) \[\d+\] <(.?)\/(.?)> (.*)/ ) {
19		my $date = $1;
20		my $user = $2;
21		my $channel = $3;
22		my $message = $4;
23		return if ( !$user or $message =~ /^!/ );
	14	method parse_line( $line ) {
	15	if ( $line =~ /^(\d+) \[\d+\] <(.?)\/(.?)> (.*)/ ) {
	16	my $date = $1;
	17	my $user = $2;
	18	my $channel = $3;
	19	my $message = $4;
	20	return if ( !$user or $message =~ /^!/ );
24	21
25		$message =~ s/\\what/what/g;
26		$message =~ s/\\is/is/g;
	22	$message =~ s/\\what/what/g;
	23	$message =~ s/\\is/is/g;
27	24
28		my $message = new whatbot::Message(
29		'from' => $user,
30		'to' => $channel,
31		'content' => $message,
32		'timestamp' => $date,
33		'me' => $self->me,
34		'base_component' => $self->parent->base_component
35		);
	25	my $message = new whatbot::Message(
	26	'from' => $user,
	27	'to' => $channel,
	28	'content' => $message,
	29	'timestamp' => $date,
	30	'me' => $self->me,
	31	'base_component' => $self->parent->base_component
	32	);
36	33
37		$self->event_message_public(
38		$user,
39		$message
40		);
	34	$self->event_message_public(
	35	$user,
	36	$message
	37	);
	38	}
41	39	}
42	40	}

trunk/lib/whatbot/Log.pm

r155	r160
7	7	###########################################################################
8	8
9		package whatbot::Log;
10		use Moose;
	9	use MooseX::Declare;
11	10
12		use POSIX qw(strftime);
	11	class whatbot::Log {
	12	use POSIX qw(strftime);
13	13
14		has 'log_directory' => ( is => 'rw', isa => 'Str', required => 1 );
15		has 'last_error' => ( is => 'rw', isa => 'Str' );
	14	has 'log_directory' => ( is => 'rw', isa => 'Str', required => 1 );
	15	has 'last_error' => ( is => 'rw', isa => 'Str' );
16	16
17		sub BUILD {
18		my ( $self, $log_dir ) = @_;
	17	method BUILD ( $log_dir ) {
	18	binmode( STDOUT, ':utf8' );
	19	unless ( -e $self->log_directory ) {
	20	if ( $self->log_directory and length( $self->log_directory ) > 3 ) {
	21	my $result = mkdir( $self->log_directory );
	22	$self->write('Created directory "' . $self->log_directory . '".') if ($result);
	23	}
	24	die 'ERROR: Cannot find log directory "' . $self->log_directory . '", could not create.';
	25	}
19	26
20		binmode( STDOUT, ':utf8' );
21		unless ( -e $self->log_directory ) {
22		if ( $self->log_directory and length( $self->log_directory ) > 3 ) {
23		my $result = mkdir( $self->log_directory );
24		$self->write('Created directory "' . $self->log_directory . '".') if ($result);
25		}
26		die 'ERROR: Cannot find log directory "' . $self->log_directory . '", could not create.';
27		}
28
29		$self->write('whatbot::Log loaded successfully.');
30		}
	27	$self->write('whatbot::Log loaded successfully.');
	28	}
31	29
32		sub error {
33		my ( $self, $entry ) = @_;
34
35		$self->last_error($entry);
36		$self->write( '*ERROR: ' . $entry );
37		warn $entry;
38		}
	30	method error ( Str $entry ) {
	31	$self->last_error($entry);
	32	$self->write( '*ERROR: ' . $entry );
	33	warn $entry;
	34	}
39	35
40		sub write {
41		my ( $self, $entry ) = @_;
42
43		my $output = '[' . strftime( '%Y-%m-%d %H:%M:%S', localtime(time) ) . '] ' . $entry . "\n";
44		print $output;
45		open( LOG, '>>' . $self->log_directory . '/whatbot.log' )
46		or die 'Cannot open logfile for writing: ' . $!;
47		binmode( LOG, ':utf8' );
48		print LOG $output;
49		close(LOG);
	36	method write ( Str $entry ) {
	37	my $output = '[' . strftime( '%Y-%m-%d %H:%M:%S', localtime(time) ) . '] ' . $entry . "\n";
	38	print $output;
	39	open( LOG, '>>' . $self->log_directory . '/whatbot.log' )
	40	or die 'Cannot open logfile for writing: ' . $!;
	41	binmode( LOG, ':utf8' );
	42	print LOG $output;
	43	close(LOG);
	44	}
50	45	}
51	46

trunk/lib/whatbot/Message.pm

r152	r160
7	7	###########################################################################
8	8
9		package whatbot::Message;
10		use Moose;
11		extends "whatbot::Component";
	9	use MooseX::Declare;
12	10
13		has 'from' => ( is => 'rw', isa => 'Str', required => 1 );
14		has 'to' => ( is => 'rw', isa => 'Str', required => 1 );
15		has 'content' => ( is => 'rw', isa => 'Str', required => 1 );
16		has 'timestamp' => ( is => 'rw', isa => 'Int', default => time );
17		has 'is_private' => ( is => 'rw', isa => 'Int', default => 0 );
18		has 'is_direct' => ( is => 'rw', isa => 'Int', default => 0 );
19		has 'me' => ( is => 'rw', isa => 'Str' );
20		has 'origin' => ( is => 'rw' );
	11	class whatbot::Message extends whatbot::Component {
	12	use Encode;
21	13
22		sub BUILD {
23		my ( $self ) = @_;
	14	has 'from' => ( is => 'rw', isa => 'Str', required => 1 );
	15	has 'to' => ( is => 'rw', isa => 'Str', required => 1 );
	16	has 'content' => ( is => 'rw', isa => 'Str', required => 1 );
	17	has 'timestamp' => ( is => 'rw', isa => 'Int', default => time );
	18	has 'is_private' => ( is => 'rw', isa => 'Int', default => 0 );
	19	has 'is_direct' => ( is => 'rw', isa => 'Int', default => 0 );
	20	has 'me' => ( is => 'rw', isa => 'Str' );
	21	has 'origin' => ( is => 'rw' );
	22
	23	method BUILD ($) {
	24	my $me = $self->me;
	25
	26	# Determine if the message is talking about me
	27	if ( defined $me ) {
	28	if ( $self->content =~ /, ?$me[\?\!\. ]*?$/i ) {
	29	my $content = $self->content;
	30	$content =~ s/, ?$me[\?\!\. ]*?$//i;
	31	$self->content($content);
	32	$self->is_direct(1);
	33
	34	} elsif ( $self->content =~ /^$me[\:\,\- ]+/i ) {
	35	my $content = $self->content;
	36	$content =~ s/^$me[\:\,\- ]+//i;
	37	$self->content($content);
	38	$self->is_direct(1);
	39
	40	} elsif ( $self->content =~ /^$me \-+ /i ) {
	41	my $content = $self->content;
	42	$content =~ s/^$me \-+ //i;
	43	$self->content($content);
	44	$self->is_direct(1);
	45
	46	}
	47	}
24	48
25		my $me = $self->me;
26
27		if ( defined $me ) {
28		if ( $self->content =~ /, ?$me[\?\!\. ]*?$/i ) {
29		my $content = $self->content;
30		$content =~ s/, ?$me[\?\!\. ]*?$//i;
31		$self->content($content);
32		$self->is_direct(1);
33
34		} elsif ( $self->content =~ /^$me[\:\,\- ]+/i ) {
35		my $content = $self->content;
36		$content =~ s/^$me[\:\,\- ]+//i;
37		$self->content($content);
38		$self->is_direct(1);
39
40		} elsif ( $self->content =~ /^$me \-+ /i ) {
41		my $content = $self->content;
42		$content =~ s/^$me \-+ //i;
43		$self->content($content);
44		$self->is_direct(1);
45
46		}
47		}
48
49		$self->timestamp(time) unless ( $self->timestamp );
	49	$self->timestamp(time) unless ( $self->timestamp );
	50	}
	51
	52	method content_utf8 {
	53	return Encode::encode_utf8( $self->content );
	54	}
50	55	}
51	56

trunk/lib/whatbot/Progress.pm

r127	r160
7	7	###########################################################################
8	8
9		package whatbot::Progress;
10		use Moose;
	9	use MooseX::Declare;
11	10
12		has 'max' => ( is => 'rw', isa => 'Int' );
13		has 'restrict_updates' => ( is => 'rw', isa => 'Int' );
14		has 'show_count' => ( is => 'rw', isa => 'Int' );
	11	class whatbot::Progress {
	12	has 'max' => ( is => 'rw', isa => 'Int' );
	13	has 'restrict_updates' => ( is => 'rw', isa => 'Int' );
	14	has 'show_count' => ( is => 'rw', isa => 'Int' );
15	15
16		sub update {
17		my ( $self, $current ) = @_;
	16	method update ( Int $current ) {
	17	return if ( $self->restrict_updates and $current % $self->restrict_updates != 0 );
	18	return unless ( $self->max and $self->max > 0 );
18	19
19		return if ( $self->restrict_updates and $current % $self->restrict_updates != 0 );
20		return unless ( $self->max and $self->max > 0 );
	20	my $pct = int( ( $current / $self->max ) * 100 );
	21	my $line = '[';
	22	for ( my $c = 0; $c < int($pct * 0.7); $c++ ) {
	23	$line .= '=';
	24	}
	25	for ( my $c = 0; $c < (65 - int($pct * 0.65)); $c++ ) {
	26	$line .= '-';
	27	}
	28	$line .= '] ' . $pct . '% ';
	29	if ( $self->show_count ) {
	30	$line .= $current . '/' . $self->max;
	31	}
	32	for ( my $c = 0; $c < ( 80 - length($line) ); $c++ ) {
	33	$line .= ' ';
	34	}
	35	$line .= "\r";
	36	print $line;
	37	}
21	38
22		m~~y $pct = int( ( $current / $self->max ) * 100 );~~
23		~~my $line = '['~~;
24		~~for ( my $c = 0; $c < int($pct * 0.7); $c++ ) {~~
25		~~$line .= '='~~;
	39	method finish {
	40	$self->restrict_updates(0);
	41	$self->update( $self->max );
	42	print "\n";
26	43	}
27		~~for ( my $c = 0; $c < (65 - int($pct * 0.65)); $c++ ) {~~
28		~~$line .= '-';~~
29		}
30		~~$line .= '] ' . $pct . '% ';~~
31		~~if ( $self->show_count ) {~~
32		~~$line .= $current . '/' . $self->max;~~
33		}
34		~~for ( my $c = 0; $c < ( 80 - length($line) ); $c++ ) {~~
35		~~$line .= ' ';~~
36		}
37		~~$line .= "\r";~~
38		~~print $line;~~
39		}
40
41		~~sub finish {~~
42		~~my ( $self ) = @_;~~
43
44		~~$self->restrict_updates(0);~~
45		~~$self->update( $self->max );~~
46		~~print "\n";~~
47	44	}
48	45

trunk/lib/whatbot/Store.pm

r143	r160
7	7	###########################################################################
8	8
9		package whatbot::Store;
10		use Moose;
11		extends 'whatbot::Component';
12		use Digest::SHA1 qw(sha1_hex);
	9	use MooseX::Declare;
13	10
14		has 'handle' => ( is => 'rw', isa => 'Any' );
	11	class whatbot::Store extends whatbot::Component {
	12	use Digest::SHA1 qw(sha1_hex);
15	13
16		sub connect {
17		my ($self) = @_;
18		}
	14	has 'handle' => ( is => 'rw', isa => 'Any' );
19	15
20		sub store {
21		my ($self, $table, $assignRef) = @_;
22		}
	16	method connect {
	17	}
23	18
24		sub retrieve {
25		my ($self, $table, $columnRef, $queryRef, $numberItems) = @_;
26		}
	19	method store ( $table, $assignRef ) {
	20	}
27	21
28		sub delete {
29		my ($self, $table, $queryRef) = @_;
30		}
	22	method retrieve ( $table, $columnRef, $queryRef, $numberItems ) {
	23	}
31	24
32		sub update {
33		my ($self, $table, $assignRef, $queryRef) = @_;
34		}
	25	method delete ( $table, $queryRef ) {
	26	}
35	27
36		sub factoid {
37		my ($self, $subject, $is, $from, $plural) = @_;
	28	method update ( $table, $assignRef, $queryRef ) {
	29	}
	30
	31	method factoid ( $subject, $is?, $from?, $plural? ) {
	32	return if (!$subject);
	33
	34	my $original = $subject;
	35	$subject = lc($subject);
38	36
39		return undef if (!$subject);
40		~~my $original = $subject~~;
41		~~$subject = lc($subject~~);
	37	# Get existing factoid info, if available
	38	my ($factoid) = @{ $self->retrieve("factoid", [qw/factoid_id is_or is_plural silent/], { subject => $subject }) };
	39	return undef if (!defined($factoid) and !$is);
42	40
43		# Get existing factoid info, if available
44		my ($factoid) = @{ $self->retrieve("factoid", [qw/factoid_id is_or is_plural silent/], { subject => $subject }) };
45		return undef if (!defined($factoid) and !$is);
	41	# Assign fact info if defined
	42	if ($is) {
	43
	44	# Nuke all factoids if user says no
	45	if ($subject =~ /no, /i) {
	46	$subject =~ s/no, //i;
	47	$self->forget($subject);
	48	}
	49
	50	unless (defined $factoid) {
	51	# Check if ignore
	52	return undef if ($self->ignore($subject));
	53
	54	# Check if plural
	55	my $isPlural = $plural;
	56	# if (length($subject) > 2 and $subject =~ /s$/ and $subject !~ /'s$/) {
	57	# if ($subject =~ /(s\|z\|x\|sh\|ch\|[^aeiou]y)es$/) {
	58	# $isPlural = 1;
	59	# } elsif ($original =~ /^[A-Z][a-z]+$/) {
	60	# $isPlural = 0;
	61	# }
	62	# }
	63
	64	$self->store("factoid", {
	65	is_or => 0,
	66	is_plural => $isPlural,
	67	created => time,
	68	updated => time,
	69	subject => $subject
	70	});
	71	($factoid) = @{ $self->retrieve("factoid", [qw/factoid_id is_or is_plural silent/], { subject => $subject }) };
	72	}
	73
	74	# Remove also, because we don't care
	75	my $also = 0;
	76	if ($is =~ /^also/) {
	77	$also = 1;
	78	$is =~ s/^also //;
	79	}
	80
	81	# Nuke <reply> if not or and more than one fact
	82	if ($is =~ /^<reply>/) {
	83	my ($factoidCount) = @{ $self->retrieve("factoid_description", [ "COUNT(*) AS count" ], { factoid_id => $factoid->{factoid_id}}) };
	84	unless ($factoidCount->{count} == 0 or (defined $factoid->{is_or} and $factoid->{is_or} == 1)) {
	85	return undef;
	86	}
	87	}
	88
	89	# Nuke response if we already have a reply
	90	my ($firstFact) = @{ $self->retrieve(
	91	"factoid_description",
	92	[qw/description/],
	93	{ factoid_id => $factoid->{factoid_id} },
	94	1
	95	) };
	96	if (defined $firstFact and $firstFact->{description} =~ /^<reply>/) {
	97	return undef;
	98	}
	99
	100	# Check if exists
	101	if (defined $factoid
	102	and my ($desc) = @{ $self->retrieve("factoid_description", [qw/factoid_id/], { factoid_id => $factoid->{factoid_id}, hash => sha1_hex($is) }) }) {
	103	return undef;
	104	}
	105
	106	if ($is =~ /\\|\\|/) {
	107	$self->update('factoid', { is_or => 1 }, { factoid_id => $factoid->{factoid_id} });
	108	($factoid) = @{ $self->retrieve("factoid", [qw/factoid_id is_or is_plural silent/], { subject => $subject }) };
	109	foreach my $fact (split(/ \\|\\| /, $is)) {
	110	$self->store("factoid_description", {
	111	factoid_id => $factoid->{factoid_id},
	112	description => $fact,
	113	hash => sha1_hex($fact),
	114	user => $from,
	115	updated => time
	116	});
	117	}
	118	} else {
	119	my $result = $self->store("factoid_description", {
	120	factoid_id => $factoid->{factoid_id},
	121	description => $is,
	122	hash => sha1_hex($is),
	123	user => $from,
	124	updated => time
	125	});
	126	}
	127	}
46	128
47		# Assign fact info if defined
48		if ($is) {
49
50		# Nuke all factoids if user says no
51		if ($subject =~ /no, /i) {
52		$subject =~ s/no, //i;
53		$self->forget($subject);
54		}
55
56		unless (defined $factoid) {
57		# Check if ignore
58		return undef if ($self->ignore($subject));
59
60		# Check if plural
61		my $isPlural = $plural;
62		# if (length($subject) > 2 and $subject =~ /s$/ and $subject !~ /'s$/) {
63		# if ($subject =~ /(s\|z\|x\|sh\|ch\|[^aeiou]y)es$/) {
64		# $isPlural = 1;
65		# } elsif ($original =~ /^[A-Z][a-z]+$/) {
66		# $isPlural = 0;
67		# }
68		# }
69
70		$self->store("factoid", {
71		is_or => 0,
72		is_plural => $isPlural,
73		created => time,
74		updated => time,
75		subject => $subject
76		});
77		($factoid) = @{ $self->retrieve("factoid", [qw/factoid_id is_or is_plural silent/], { subject => $subject }) };
78		}
79
80		# Remove also, because we don't care
81		my $also = 0;
82		if ($is =~ /^also/) {
83		$also = 1;
84		$is =~ s/^also //;
85		}
86
87		# Nuke <reply> if not or and more than one fact
88		if ($is =~ /^<reply>/) {
89		my ($factoidCount) = @{ $self->retrieve("factoid_description", [ "COUNT(*) AS count" ], { factoid_id => $factoid->{factoid_id}}) };
90		unless ($factoidCount->{count} == 0 or (defined $factoid->{is_or} and $factoid->{is_or} == 1)) {
91		return undef;
92		}
93		}
94
95		# Nuke response if we already have a reply
96		my ($firstFact) = @{ $self->retrieve(
97		"factoid_description",
98		[qw/description/],
99		{ factoid_id => $factoid->{factoid_id} },
100		1
101		) };
102		if (defined $firstFact and $firstFact->{description} =~ /^<reply>/) {
103		return undef;
104		}
105
106		# Check if exists
107		if (defined $factoid
108		and my ($desc) = @{ $self->retrieve("factoid_description", [qw/factoid_id/], { factoid_id => $factoid->{factoid_id}, hash => sha1_hex($is) }) }) {
109		return undef;
110		}
111
112		if ($is =~ /\\|\\|/) {
113		$self->update("factoid", { is_or => 1 }, { factoid_id => $factoid->{factoid_id} });
114		($factoid) = @{ $self->retrieve("factoid", [qw/factoid_id is_or is_plural silent/], { subject => $subject }) };
115		foreach my $fact (split(/ \\|\\| /, $is)) {
116		$self->store("factoid_description", {
117		factoid_id => $factoid->{factoid_id},
118		description => $fact,
119		hash => sha1_hex($fact),
120		user => $from,
121		updated => time
122		});
123		}
124		} else {
125		my $result = $self->store("factoid_description", {
126		factoid_id => $factoid->{factoid_id},
127		description => $is,
128		hash => sha1_hex($is),
129		user => $from,
130		updated => time
131		});
132		}
133		}
	129	# Retrieve factoid description
	130	my @facts = @{ $self->retrieve(
	131	"factoid_description",
	132	[qw/description user/],
	133	{ factoid_id => $factoid->{factoid_id} }
	134	) };
134	135
135		# Retrieve factoid description
136		my @facts = @{ $self->retrieve(
137		"factoid_description",
138		[qw/description user/],
139		{ factoid_id => $factoid->{factoid_id} }
140		) };
	136	# If facts are given, return hashref of factoid data and facts
	137	if (@facts) {
	138	if (scalar(@facts) == 1) {
	139	return {
	140	user => $facts[0]->{user},
	141	factoid => $factoid,
	142	facts => [ $facts[0]->{description} ],
	143	};
	144	} else {
	145	$_ = $_->{description} foreach @facts;
	146	return {
	147	factoid => $factoid,
	148	facts => \@facts
	149	};
	150	}
	151	}
141	152
142		# If facts are given, return hashref of factoid data and facts
143		if (@facts) {
144		if (scalar(@facts) == 1) {
145		return {
146		user => $facts[0]->{user},
147		factoid => $factoid,
148		facts => [ $facts[0]->{description} ],
149		};
150		} else {
151		$_ = $_->{description} foreach @facts;
152		return {
153		factoid => $factoid,
154		facts => \@facts
155		};
156		}
157		}
	153	return undef;
	154	}
	155
	156	method forget ( Str $subject ) {
	157	$subject = lc($subject);
158	158
159		return undef;
160		}
	159	my ($factoid) = @{ $self->retrieve("factoid", [qw/factoid_id/], { subject => $subject }) };
	160	return undef unless (defined $factoid);
	161
	162	$self->delete("factoid_description", { factoid_id => $factoid->{factoid_id} });
	163	$self->delete("factoid", { factoid_id => $factoid->{factoid_id} });
	164
	165	return 1;
	166	}
161	167
162		~~sub forget~~ {
163		~~my ($self, $subject) = @_~~;
	168	method ignore ( Str $subject, $store? ) {
	169	$subject = lc($subject);
164	170
165		return undef if (!$subject);
166		$subject = lc($subject);
	171	my ($ignore) = @{ $self->retrieve("factoid_ignore", [qw/subject/], { subject => $subject }) };
167	172
168		my ($factoid) = @{ $self->retrieve("factoid", [qw/factoid_id/], { subject => $subject }) };
169		return undef unless (defined $factoid);
	173	if ($store and !defined $ignore) {
	174	$self->store("factoid_ignore", { subject => $subject });
	175	($ignore) = @{ $self->retrieve("factoid_ignore", [qw/subject/], { subject => $subject }) };
	176	}
170	177
171		$self->delete("factoid_description", { factoid_id => $factoid->{factoid_id} });
172		$self->delete("factoid", { factoid_id => $factoid->{factoid_id} });
	178	return $ignore;
	179	}
	180
	181	method seen ( $user, $message ) {
	182	$user = lc($user);
173	183
174		return 1;
175		}
176
177		sub ignore {
178		my ($self, $subject, $store) = @_;
	184	my ($itemRef) = @{$self->retrieve("seen", [qw/user timestamp message/], { user => $user })};
	185	if (defined $message) {
	186	$self->delete("seen", { user => $user });
	187	$self->store("seen", { user => $user, message => $message, timestamp => time });
	188	($itemRef) = @{$self->retrieve("seen", [qw/user timestamp message/], { user => $user })};
	189	}
179	190
180		return undef if (!$subject);
181		$subject = lc($subject);
182
183		my ($ignore) = @{ $self->retrieve("factoid_ignore", [qw/subject/], { subject => $subject }) };
184
185		if ($store and !defined $ignore) {
186		$self->store("factoid_ignore", { subject => $subject });
187		($ignore) = @{ $self->retrieve("factoid_ignore", [qw/subject/], { subject => $subject }) };
188		}
189
190		return $ignore;
191		}
192
193		sub seen {
194		my ($self, $user, $message) = @_;
195
196		return undef if (!$user);
197		$user = lc($user);
198
199		my ($itemRef) = @{$self->retrieve("seen", [qw/user timestamp message/], { user => $user })};
200		if (defined $message) {
201		$self->delete("seen", { user => $user });
202		$self->store("seen", { user => $user, message => $message, timestamp => time });
203		($itemRef) = @{$self->retrieve("seen", [qw/user timestamp message/], { user => $user })};
204		}
205
206		return $itemRef;
	191	return $itemRef;
	192	}
207	193	}
208	194

trunk/lib/whatbot/Store/SQLite.pm

r1	r160
16	16	"DBI:SQLite:dbname=" . $self->config->store->{database},
17	17	"",
18		""
	18	"",
	19	{ sqlite_unicode => 1 },
19	20	]);
20	21	};

trunk/lib/whatbot/Timer.pm

r152	r160
9	9	###########################################################################
10	10
11		package whatbot::Timer;
12		use Moose;
13
14		BEGIN { extends 'whatbot::Component' };
15
16		# time_queue is an array. each item is of the form:
17		# [ int time, coderef sub, ... ]
18		#
19		# "..." can be any number of args to be sent to the sub when it is called at time.
20		has 'time_queue' => ( is => 'rw', isa => 'ArrayRef', default => sub { return [] } );
21
22		has 'next_time' => ( is => 'rw', isa => 'Int', default => 0 );
23
24		sub enqueue {
25		my ( $self, $time, $sub, @args ) = @_;
26
27		if ($time < 86400) {
28		$time += time;
29		}
30
31		my $new_item = [$time, $sub, @args];
32		my $queue = $self->time_queue;
33
34		# ensure queue is always in ascending order, by inserting
35		# into the proper location
36
37		my $index = 0;
38		if (@$queue) {
39		my $index = 0;
40
41		# look for the first time which is above new_item's
42		while ($index <= $#{$queue}) {
43		my $index_time = $queue->[$index]->[0];
	11	use MooseX::Declare;
	12
	13	class whatbot::Timer extends whatbot::Component {
	14	# time_queue is an array. each item is of the form:
	15	# [ int time, coderef sub, ... ]
	16	#
	17	# "..." can be any number of args to be sent to the sub when it is called at time.
	18	has 'time_queue' => ( is => 'rw', isa => 'ArrayRef', default => sub { return [] } );
	19	has 'next_time' => ( is => 'rw', isa => 'Int', default => 0 );
	20
	21	method enqueue ( Int $time, $sub, @args ) {
	22	$time += time if ( $time < 86400 );
	23
	24	my $new_item = [$time, $sub, @args];
	25	my $queue = $self->time_queue;
	26
	27	# ensure queue is always in ascending order, by inserting
	28	# into the proper location
	29
	30	my $index = 0;
	31	if (@$queue) {
	32	my $index = 0;
	33
	34	# look for the first time which is above new_item's
	35	while ($index <= $#{$queue}) {
	36	my $index_time = $queue->[$index]->[0];
44	37
45		if ($index_time > $time) {
46		# our new item should go before this one
47		my $insert_at = $index - 1;
	38	if ($index_time > $time) {
	39	# our new item should go before this one
	40	my $insert_at = $index - 1;
48	41
49		splice @$queue, $insert_at, 0, $new_item;
	42	splice @$queue, $insert_at, 0, $new_item;
50	43
51		if ($insert_at == 0) {
52		$self->next_time($time);
53		}
	44	if ($insert_at == 0) {
	45	$self->next_time($time);
	46	}
54	47
55		return;
56		}
57		$index++;
58		}
59
60		# none were above new_item's time
61		push @$queue, $new_item;
62		} else {
63		# this is the only one
64
65		push @$queue, $new_item;
66		$self->next_time($time);
67		}
	48	return;
	49	}
	50	$index++;
	51	}
	52
	53	# none were above new_item's time
	54	push @$queue, $new_item;
	55	} else {
	56	# this is the only one
	57
	58	push @$queue, $new_item;
	59	$self->next_time($time);
	60	}
	61	}
	62
	63	method remove ( Int $time, $sub, @args ) {
	64	# remove the first perfect match. I doubt this will be called much,
	65	# but here it is anyway
	66	my $match_item = [$time, $sub, @args];
	67	my $queue = $self->time_queue;
	68
	69	if (@$queue) {
	70	my $index = 0;
	71
	72	while ($index <= $match_item) {
	73	my $item = $queue->[$index];
	74
	75	if (@$item == @$match_item) {
	76	my $i;
	77	my $ok = 1;
	78	for ($i = 0; $i <= $#$item; $i++) {
	79	if ($item->[$i] != $match_item->[$i]) {
	80	$ok = 0;
	81	}
	82	}
	83	if ($ok) {
	84	# remove it!
	85	splice @$queue, $index, 1;
	86
	87	# if we took it off the front, adjust next_time
	88	if ($index == 0) {
	89	if (@$queue) {
	90	# next time is the time of the thing at the front
	91	$self->next_time($queue->[0]->[0]);
	92	} else {
	93	$self->next_time(0);
	94	}
	95	}
	96	return 1;
	97	}
	98	}
	99	}
	100	}
	101
	102	return 0;
	103	}
	104
	105	method tick {
	106	my $next = $self->next_time;
	107	return unless $next;
	108
	109	my $now = time;
	110	return if ($now <= $next);
	111
	112	my $queue = $self->time_queue;
	113
	114	if (@$queue) {
	115	my ($when, $sub, @args) = @{$queue->[0]};
	116
	117	if ($when > $now) {
	118	# uh oh...
	119	$self->log->error("last_time in timer was not the same as the first item in the queue...");
	120	} else {
	121	&$sub(@args);
	122	shift @$queue;
	123
	124	if (@$queue) {
	125	# next time is the time of the thing at the front
	126	$self->next_time($queue->[0]->[0]);
	127	} else {
	128	$self->next_time(0);
	129	}
	130	}
	131	}
	132	}
68	133	}
69	134
70		~~sub remove {~~
71		~~my ( $self, $time, $sub, @args ) = @_;~~
72
73		~~# remove the first perfect match. I doubt this will be called much,~~
74		~~# but here it is anyway~~
75		~~my $match_item = [$time, $sub, @args];~~
76		~~my $queue = $self->time_queue;~~
77
78		~~if (@$queue) {~~
79		~~my $index = 0;~~
80
81		~~while ($index <= $match_item) {~~
82		~~my $item = $queue->[$index];~~
83
84		~~if (@$item == @$match_item) {~~
85		~~my $i;~~
86		~~my $ok = 1;~~
87		~~for ($i = 0; $i <= $#$item; $i++) {~~
88		~~if ($item->[$i] != $match_item->[$i]) {~~
89		~~$ok = 0;~~
90		}
91		}
92		~~if ($ok) {~~
93		~~# remove it!~~
94		~~splice @$queue, $index, 1;~~
95
96		~~# if we took it off the front, adjust next_time~~
97		~~if ($index == 0) {~~
98		~~if (@$queue) {~~
99		~~# next time is the time of the thing at the front~~
100		~~$self->next_time($queue->[0]->[0]);~~
101		~~} else {~~
102		~~$self->next_time(0);~~
103		}
104		}
105		~~return 1;~~
106		}
107		}
108		}
109		}
110
111		~~return 0;~~
112		}
113
114		~~sub tick {~~
115		~~my ( $self ) = @_;~~
116
117		~~my $next = $self->next_time;~~
118		~~return unless $next;~~
119
120		~~my $now = time;~~
121		~~return if ($now <= $next);~~
122
123		~~my $queue = $self->time_queue;~~
124
125		~~if (@$queue) {~~
126		~~my ($when, $sub, @args) = @{$queue->[0]};~~
127
128		~~if ($when > $now) {~~
129		~~# uh oh...~~
130		~~$self->log->error("last_time in timer was not the same as the first item in the queue...");~~
131		~~} else {~~
132		~~&$sub(@args);~~
133		~~shift @$queue;~~
134
135		~~if (@$queue) {~~
136		~~# next time is the time of the thing at the front~~
137		~~$self->next_time($queue->[0]->[0]);~~
138		~~} else {~~
139		~~$self->next_time(0);~~
140		}
141		}
142		}
143		}
144
145	135	1;
146
147	136
148	137	=pod

Legend:

trunk/bin/whatbot

trunk/lib/whatbot.pm

trunk/lib/whatbot/Command.pm

trunk/lib/whatbot/Command/Admin.pm

trunk/lib/whatbot/Command/Blackjack.pm

trunk/lib/whatbot/Command/Blackjack/Card.pm

trunk/lib/whatbot/Command/Define.pm

trunk/lib/whatbot/Command/Karma.pm

trunk/lib/whatbot/Command/RSS.pm

trunk/lib/whatbot/Command/Translate.pm

trunk/lib/whatbot/Component.pm

trunk/lib/whatbot/Component/Base.pm

trunk/lib/whatbot/Config.pm

trunk/lib/whatbot/Controller.pm

trunk/lib/whatbot/Database.pm

trunk/lib/whatbot/IO.pm

trunk/lib/whatbot/IO/AIM.pm

trunk/lib/whatbot/IO/IRC.pm

trunk/lib/whatbot/IO/Log.pm

trunk/lib/whatbot/IO/Log/Infobot.pm

trunk/lib/whatbot/Log.pm

trunk/lib/whatbot/Message.pm

trunk/lib/whatbot/Progress.pm

trunk/lib/whatbot/Store.pm

trunk/lib/whatbot/Store/SQLite.pm

trunk/lib/whatbot/Timer.pm

Download in other formats: