[ViewVC] Diff of: cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC vs.
Revision 1.101 by root, Mon Dec 25 14:43:23 2006 UTC

…		…
1	package cf;	1	package cf;
		2
		3	use utf8;
		4	use strict;
2		5
3	use Symbol;	6	use Symbol;
4	use List::Util;	7	use List::Util;
5	use Storable;	8	use Storable;
6	use Opcode;	9	use Opcode;
7	use Safe;	10	use Safe;
8	use Safe::Hole;	11	use Safe::Hole;
9		12
		13	use Coro;
		14	use Coro::Event;
		15	use Coro::Timer;
		16	use Coro::Signal;
		17	use Coro::Semaphore;
		18
10	use IO::AIO ();	19	use IO::AIO 2.3;
11	use YAML::Syck ();	20	use YAML::Syck ();
12	use Time::HiRes;	21	use Time::HiRes;
13	use Event;	22
14	$Event::Eval = 1; # no idea why this is required, but it is	23	use Event; $Event::Eval = 1; # no idea why this is required, but it is
15		24
16	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?	25	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17	$YAML::Syck::ImplicitUnicode = 1;	26	$YAML::Syck::ImplicitUnicode = 1;
18		27
19	use strict;	28	$Coro::main->prio (Coro::PRIO_MIN);
20		29
21	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	30	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22		31
23	our %COMMAND = ();	32	our %COMMAND = ();
24	our %COMMAND_TIME = ();	33	our %COMMAND_TIME = ();
25	our %EXTCMD = ();	34	our %EXTCMD = ();
26
27	_init_vars;
28		35
29	our @EVENT;	36	our @EVENT;
30	our $LIBDIR = datadir . "/ext";	37	our $LIBDIR = datadir . "/ext";
31		38
32	our $TICK = MAX_TIME * 1e-6;	39	our $TICK = MAX_TIME * 1e-6;
84	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	91	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
85		92
86	# we bless all objects into (empty) derived classes to force a method lookup	93	# we bless all objects into (empty) derived classes to force a method lookup
87	# within the Safe compartment.	94	# within the Safe compartment.
88	for my $pkg (qw(	95	for my $pkg (qw(
89	cf::global	96	cf::global cf::attachable
90	cf::object cf::object::player	97	cf::object cf::object::player
91	cf::client cf::player	98	cf::client cf::player
92	cf::arch cf::living	99	cf::arch cf::living
93	cf::map cf::party cf::region	100	cf::map cf::party cf::region
94	)) {	101	)) {
…		…
140		147
141	#############################################################################	148	#############################################################################
142		149
143	=head2 ATTACHABLE OBJECTS	150	=head2 ATTACHABLE OBJECTS
144		151
145	You can define and attach attachments to each "attachable" object in	152	Many objects in crossfire are so-called attachable objects. That means you can
146	crossfire+ (objects, players, clients, maps and the special "global"	153	attach callbacks/event handlers (a collection of which is called an "attachment")
		154	to it. All such attachable objects support the following methods.
		155
147	class). In the following description, CLASS can be any of C<global>,	156	In the following description, CLASS can be any of C<global>, C<object>
148	C<object> C<player>, C<client> or C<map>.	157	C<player>, C<client> or C<map> (i.e. the attachable objects in
		158	crossfire+).
149		159
150	=over 4	160	=over 4
151		161
		162	=item $attachable->attach ($attachment, key => $value...)
		163
		164	=item $attachable->detach ($attachment)
		165
		166	Attach/detach a pre-registered attachment to a specific object and give it
		167	the specified key/value pairs as arguments.
		168
		169	Example, attach a minesweeper attachment to the given object, making it a
		170	10x10 minesweeper game:
		171
		172	$obj->attach (minesweeper => width => 10, height => 10);
		173
		174	=item $bool = $attachable->attached ($name)
		175
		176	Checks wether the named attachment is currently attached to the object.
		177
		178	=item cf::CLASS->attach ...
		179
		180	=item cf::CLASS->detach ...
		181
		182	Define an anonymous attachment and attach it to all objects of the given
		183	CLASS. See the next function for an explanation of its arguments.
		184
		185	You can attach to global events by using the C<cf::global> class.
		186
		187	Example, log all player logins:
		188
		189	cf::player->attach (
		190	on_login => sub {
		191	my ($pl) = @_;
		192	...
		193	},
		194	);
		195
		196	Example, attach to the jeweler skill:
		197
		198	cf::object->attach (
		199	type => cf::SKILL,
		200	subtype => cf::SK_JEWELER,
		201	on_use_skill => sub {
		202	my ($sk, $ob, $part, $dir, $msg) = @_;
		203	...
		204	},
		205	);
		206
152	=item cf::CLASS::attachment $name, ...	207	=item cf::CLASS::attachment $name, ...
153		208
154	Register an attachment by name through which attachable objects can refer	209	Register an attachment by C<$name> through which attachable objects of the
155	to this attachment.	210	given CLASS can refer to this attachment.
156		211
157	=item $bool = $attachable->attached ($name)	212	Some classes such as crossfire maps and objects can specify attachments
		213	that are attached at load/instantiate time, thus the need for a name.
158		214
159	Checks wether the named attachment is currently attached to the object.
160
161	=item $attachable->attach ($attachment, key => $value...)
162
163	=item $attachable->detach ($attachment)
164
165	Attach/detach a pre-registered attachment either to a specific object
166	(C<$attachable>) or all objects of the given class (if C<$attachable> is a
167	class in a static method call).
168
169	You can attach to global events by using the C<cf::global> class.
170
171	These method calls expect any number of the following handler/hook	215	These calls expect any number of the following handler/hook descriptions:
172	descriptions:
173		216
174	=over 4	217	=over 4
175		218
176	=item prio => $number	219	=item prio => $number
177		220
…		…
203	package and register them. Only handlers for eevents supported by the	246	package and register them. Only handlers for eevents supported by the
204	object/class are recognised.	247	object/class are recognised.
205		248
206	=back	249	=back
207		250
		251	Example, define an attachment called "sockpuppet" that calls the given
		252	event handler when a monster attacks:
		253
		254	cf::object::attachment sockpuppet =>
		255	on_skill_attack => sub {
		256	my ($self, $victim) = @_;
		257	...
		258	}
		259	}
		260
		261	=item $attachable->valid
		262
		263	Just because you have a perl object does not mean that the corresponding
		264	C-level object still exists. If you try to access an object that has no
		265	valid C counterpart anymore you get an exception at runtime. This method
		266	can be used to test for existence of the C object part without causing an
		267	exception.
		268
208	=cut	269	=cut
209		270
210	# the following variables are defined in .xs and must not be re-created	271	# the following variables are defined in .xs and must not be re-created
211	our @CB_GLOBAL = (); # registry for all global events	272	our @CB_GLOBAL = (); # registry for all global events
		273	our @CB_ATTACHABLE = (); # registry for all attachables
212	our @CB_OBJECT = (); # all objects (should not be used except in emergency)	274	our @CB_OBJECT = (); # all objects (should not be used except in emergency)
213	our @CB_PLAYER = ();	275	our @CB_PLAYER = ();
214	our @CB_CLIENT = ();	276	our @CB_CLIENT = ();
215	our @CB_TYPE = (); # registry for type (cf-object class) based events	277	our @CB_TYPE = (); # registry for type (cf-object class) based events
216	our @CB_MAP = ();	278	our @CB_MAP = ();
217		279
218	my %attachment;	280	my %attachment;
219		281
220	sub _attach_cb($$$$) {	282	sub _attach_cb($$$$) {
221	my ($registry, $event, $prio, $cb) = @_;	283	my ($registry, $event, $prio, $cb) = @_;
…		…
226		288
227	@{$registry->[$event]} = sort	289	@{$registry->[$event]} = sort
228	{ $a->[0] cmp $b->[0] }	290	{ $a->[0] cmp $b->[0] }
229	@{$registry->[$event] \|\| []}, $cb;	291	@{$registry->[$event] \|\| []}, $cb;
230	}	292	}
		293
		294	# hack
		295	my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
231		296
232	# attach handles attaching event callbacks	297	# attach handles attaching event callbacks
233	# the only thing the caller has to do is pass the correct	298	# the only thing the caller has to do is pass the correct
234	# registry (== where the callback attaches to).	299	# registry (== where the callback attaches to).
235	sub _attach {	300	sub _attach {
…		…
237		302
238	my $object_type;	303	my $object_type;
239	my $prio = 0;	304	my $prio = 0;
240	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;	305	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
241		306
		307	#TODO: get rid of this hack
		308	if ($attachable_klass{$klass}) {
		309	%cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
		310	}
		311
242	while (@arg) {	312	while (@arg) {
243	my $type = shift @arg;	313	my $type = shift @arg;
244		314
245	if ($type eq "prio") {	315	if ($type eq "prio") {
246	$prio = shift @arg;	316	$prio = shift @arg;
…		…
321	my ($obj, $name) = @_;	391	my ($obj, $name) = @_;
322		392
323	exists $obj->{_attachment}{$name}	393	exists $obj->{_attachment}{$name}
324	}	394	}
325		395
326	for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {	396	for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
327	eval "#line " . __LINE__ . " 'cf.pm'	397	eval "#line " . __LINE__ . " 'cf.pm'
328	sub cf::\L$klass\E::_attach_registry {	398	sub cf::\L$klass\E::_attach_registry {
329	(\\\@CB_$klass, KLASS_$klass)	399	(\\\@CB_$klass, KLASS_$klass)
330	}	400	}
331		401
…		…
367	}	437	}
368		438
369	0	439	0
370	}	440	}
371		441
372	=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...	442	=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
373		443
374	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
375
376	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
377
378	=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)	444	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
379		445
380	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
381
382	Generate a global/object/player/map-specific event with the given arguments.	446	Generate an object-specific event with the given arguments.
383		447
384	This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be	448	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
385	removed in future versions), and there is no public API to access override	449	removed in future versions), and there is no public API to access override
386	results (if you must, access C<@cf::invoke_results> directly).	450	results (if you must, access C<@cf::invoke_results> directly).
387		451
388	=back	452	=back
389		453
390	=cut	454	=cut
391		455
392	#############################################################################	456	#############################################################################
393
394	=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
395
396	Attachable objects includes objects, players, clients and maps.
397
398	=over 4
399
400	=item $object->valid
401
402	Just because you have a perl object does not mean that the corresponding
403	C-level object still exists. If you try to access an object that has no
404	valid C counterpart anymore you get an exception at runtime. This method
405	can be used to test for existence of the C object part without causing an
406	exception.
407
408	=back
409
410	=cut
411
412	#############################################################################
413	# object support	457	# object support
414		458
415	sub instantiate {	459	cf::attachable->attach (
		460	prio => -1000000,
		461	on_instantiate => sub {
416	my ($obj, $data) = @_;	462	my ($obj, $data) = @_;
417		463
418	$data = from_json $data;	464	$data = from_json $data;
419		465
420	for (@$data) {	466	for (@$data) {
421	my ($name, $args) = @$_;	467	my ($name, $args) = @$_;
422		468
423	$obj->attach ($name, %{$args \|\| {} });	469	$obj->attach ($name, %{$args \|\| {} });
		470	}
424	}	471	},
425	}	472	on_reattach => sub {
426
427	# basically do the same as instantiate, without calling instantiate	473	# basically do the same as instantiate, without calling instantiate
428	sub reattach {
429	my ($obj) = @_;	474	my ($obj) = @_;
430	my $registry = $obj->registry;	475	my $registry = $obj->registry;
431		476
432	@$registry = ();	477	@$registry = ();
433		478
434	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };	479	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
435		480
436	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {	481	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
437	if (my $attach = $attachment{$name}) {	482	if (my $attach = $attachment{$name}) {
438	for (@$attach) {	483	for (@$attach) {
439	my ($klass, @attach) = @$_;	484	my ($klass, @attach) = @$_;
440	_attach $registry, $klass, @attach;	485	_attach $registry, $klass, @attach;
		486	}
		487	} else {
		488	warn "object uses attachment '$name' that is not available, postponing.\n";
441	}	489	}
442	} else {
443	warn "object uses attachment '$name' that is not available, postponing.\n";
444	}	490	}
445	}	491	},
446	}	492	on_clone => sub {
		493	my ($src, $dst) = @_;
		494
		495	@{$dst->registry} = @{$src->registry};
		496
		497	%$dst = %$src;
		498
		499	%{$dst->{_attachment}} = %{$src->{_attachment}}
		500	if exists $src->{_attachment};
		501	},
		502	);
447		503
448	sub object_freezer_save {	504	sub object_freezer_save {
449	my ($filename, $rdata, $objs) = @_;	505	my ($filename, $rdata, $objs) = @_;
450		506
451	if (length $$rdata) {	507	if (length $$rdata) {
…		…
501	}	557	}
502		558
503	()	559	()
504	}	560	}
505		561
506	cf::object->attach (
507	prio => -1000000,
508	on_clone => sub {
509	my ($src, $dst) = @_;
510
511	@{$dst->registry} = @{$src->registry};
512
513	%$dst = %$src;
514
515	%{$dst->{_attachment}} = %{$src->{_attachment}}
516	if exists $src->{_attachment};
517	},
518	);
519
520	#############################################################################	562	#############################################################################
521	# command handling &c	563	# command handling &c
522		564
523	=item cf::register_command $name => \&callback($ob,$args);	565	=item cf::register_command $name => \&callback($ob,$args);
524		566
…		…
712		754
713	=head2 CORE EXTENSIONS	755	=head2 CORE EXTENSIONS
714		756
715	Functions and methods that extend core crossfire objects.	757	Functions and methods that extend core crossfire objects.
716		758
		759	=head3 cf::player
		760
717	=over 4	761	=over 4
718		762
719	=item cf::player::exists $login	763	=item cf::player::exists $login
720		764
721	Returns true when the given account exists.	765	Returns true when the given account exists.
…		…
725	sub cf::player::exists($) {	769	sub cf::player::exists($) {
726	cf::player::find $_[0]	770	cf::player::find $_[0]
727	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;	771	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
728	}	772	}
729		773
		774	=item $player->ext_reply ($msgid, $msgtype, %msg)
		775
		776	Sends an ext reply to the player.
		777
		778	=cut
		779
		780	sub cf::player::ext_reply($$$%) {
		781	my ($self, $id, %msg) = @_;
		782
		783	$msg{msgid} = $id;
		784
		785	$self->send ("ext " . to_json \%msg);
		786	}
		787
		788	=back
		789
		790	=head3 cf::object::player
		791
		792	=over 4
		793
730	=item $player_object->reply ($npc, $msg[, $flags])	794	=item $player_object->reply ($npc, $msg[, $flags])
731		795
732	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>	796	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
733	can be C<undef>. Does the right thing when the player is currently in a	797	can be C<undef>. Does the right thing when the player is currently in a
734	dialogue with the given NPC character.	798	dialogue with the given NPC character.
735		799
736	=cut	800	=cut
737		801
738	# rough implementation of a future "reply" method that works	802	# rough implementation of a future "reply" method that works
739	# with dialog boxes.	803	# with dialog boxes.
		804	#TODO: the first argument must go, split into a $npc->reply_to ( method
740	sub cf::object::player::reply($$$;$) {	805	sub cf::object::player::reply($$$;$) {
741	my ($self, $npc, $msg, $flags) = @_;	806	my ($self, $npc, $msg, $flags) = @_;
742		807
743	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;	808	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;
744		809
…		…
748	$msg = $npc->name . " says: $msg" if $npc;	813	$msg = $npc->name . " says: $msg" if $npc;
749	$self->message ($msg, $flags);	814	$self->message ($msg, $flags);
750	}	815	}
751	}	816	}
752		817
753	=item $player->ext_reply ($msgid, $msgtype, %msg)
754
755	Sends an ext reply to the player.
756
757	=cut
758
759	sub cf::player::ext_reply($$$%) {
760	my ($self, $id, %msg) = @_;
761
762	$msg{msgid} = $id;
763
764	$self->send ("ext " . to_json \%msg);
765	}
766
767	=item $player_object->may ("access")	818	=item $player_object->may ("access")
768		819
769	Returns wether the given player is authorized to access resource "access"	820	Returns wether the given player is authorized to access resource "access"
770	(e.g. "command_wizcast").	821	(e.g. "command_wizcast").
771		822
…		…
778	(ref $cf::CFG{"may_$access"}	829	(ref $cf::CFG{"may_$access"}
779	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	830	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
780	: $cf::CFG{"may_$access"})	831	: $cf::CFG{"may_$access"})
781	}	832	}
782		833
783	=cut	834	=head3 cf::client
784		835
785	#############################################################################	836	=over 4
		837
		838	=item $client->send_drawinfo ($text, $flags)
		839
		840	Sends a drawinfo packet to the client. Circumvents output buffering so
		841	should not be used under normal circumstances.
		842
		843	=cut
		844
		845	sub cf::client::send_drawinfo {
		846	my ($self, $text, $flags) = @_;
		847
		848	utf8::encode $text;
		849	$self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
		850	}
		851
		852
		853	=item $success = $client->query ($flags, "text", \&cb)
		854
		855	Queues a query to the client, calling the given callback with
		856	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
		857	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
		858
		859	Queries can fail, so check the return code. Or don't, as queries will become
		860	reliable at some point in the future.
		861
		862	=cut
		863
		864	sub cf::client::query {
		865	my ($self, $flags, $text, $cb) = @_;
		866
		867	return unless $self->state == ST_PLAYING
		868	\|\| $self->state == ST_SETUP
		869	\|\| $self->state == ST_CUSTOM;
		870
		871	$self->state (ST_CUSTOM);
		872
		873	utf8::encode $text;
		874	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
		875
		876	$self->send_packet ($self->{query_queue}[0][0])
		877	if @{ $self->{query_queue} } == 1;
		878	}
		879
		880	cf::client->attach (
		881	on_reply => sub {
		882	my ($ns, $msg) = @_;
		883
		884	# this weird shuffling is so that direct followup queries
		885	# get handled first
		886	my $queue = delete $ns->{query_queue};
		887
		888	(shift @$queue)->[1]->($msg);
		889
		890	push @{ $ns->{query_queue} }, @$queue;
		891
		892	if (@{ $ns->{query_queue} } == @$queue) {
		893	if (@$queue) {
		894	$ns->send_packet ($ns->{query_queue}[0][0]);
		895	} else {
		896	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
		897	}
		898	}
		899	},
		900	);
		901
		902	=item $client->coro (\&cb)
		903
		904	Create a new coroutine, running the specified callback. The coroutine will
		905	be automatically cancelled when the client gets destroyed (e.g. on logout,
		906	or loss of connection).
		907
		908	=cut
		909
		910	sub cf::client::coro {
		911	my ($self, $cb) = @_;
		912
		913	my $coro; $coro = async {
		914	eval {
		915	$cb->();
		916	};
		917	warn $@ if $@;
		918	delete $self->{_coro}{$coro+0};
		919	};
		920
		921	$self->{_coro}{$coro+0} = $coro;
		922	}
		923
		924	cf::client->attach (
		925	on_destroy => sub {
		926	my ($ns) = @_;
		927
		928	$_->cancel for values %{ (delete $ns->{_coro}) \|\| {} };
		929	},
		930	);
		931
		932	=back
		933
786		934
787	=head2 SAFE SCRIPTING	935	=head2 SAFE SCRIPTING
788		936
789	Functions that provide a safe environment to compile and execute	937	Functions that provide a safe environment to compile and execute
790	snippets of perl code without them endangering the safety of the server	938	snippets of perl code without them endangering the safety of the server
…		…
1073	#Symbol::delete_package __PACKAGE__;	1221	#Symbol::delete_package __PACKAGE__;
1074		1222
1075	# reload cf.pm	1223	# reload cf.pm
1076	$msg->("reloading cf.pm");	1224	$msg->("reloading cf.pm");
1077	require cf;	1225	require cf;
		1226	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1078		1227
1079	# load config and database again	1228	# load config and database again
1080	cf::cfg_load;	1229	cf::cfg_load;
1081	cf::db_load;	1230	cf::db_load;
1082		1231

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC vs. Revision 1.101 by root, Mon Dec 25 14:43:23 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC vs.
Revision 1.101 by root, Mon Dec 25 14:43:23 2006 UTC