[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.102 by root, Wed Dec 27 15:20:54 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 {
416	my ($obj, $data) = @_;
417
418	$data = from_json $data;
419
420	for (@$data) {
421	my ($name, $args) = @$_;
422
423	$obj->attach ($name, %{$args \|\| {} });
424	}
425	}
426
427	# basically do the same as instantiate, without calling instantiate
428	sub reattach {	459	sub reattach {
		460	# basically do the same as instantiate, without calling instantiate
429	my ($obj) = @_;	461	my ($obj) = @_;
		462
430	my $registry = $obj->registry;	463	my $registry = $obj->registry;
431		464
432	@$registry = ();	465	@$registry = ();
433		466
434	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };	467	delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} \|\| {} };
…		…
443	warn "object uses attachment '$name' that is not available, postponing.\n";	476	warn "object uses attachment '$name' that is not available, postponing.\n";
444	}	477	}
445	}	478	}
446	}	479	}
447		480
		481	cf::attachable->attach (
		482	prio => -1000000,
		483	on_instantiate => sub {
		484	my ($obj, $data) = @_;
		485
		486	$data = from_json $data;
		487
		488	for (@$data) {
		489	my ($name, $args) = @$_;
		490
		491	$obj->attach ($name, %{$args \|\| {} });
		492	}
		493	},
		494	on_reattach => \&reattach,
		495	on_clone => sub {
		496	my ($src, $dst) = @_;
		497
		498	@{$dst->registry} = @{$src->registry};
		499
		500	%$dst = %$src;
		501
		502	%{$dst->{_attachment}} = %{$src->{_attachment}}
		503	if exists $src->{_attachment};
		504	},
		505	);
		506
448	sub object_freezer_save {	507	sub object_freezer_save {
449	my ($filename, $rdata, $objs) = @_;	508	my ($filename, $rdata, $objs) = @_;
450		509
451	if (length $$rdata) {	510	if (length $$rdata) {
452	warn sprintf "saving %s (%d,%d)\n",	511	warn sprintf "saving %s (%d,%d)\n",
…		…
501	}	560	}
502		561
503	()	562	()
504	}	563	}
505		564
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	#############################################################################	565	#############################################################################
521	# command handling &c	566	# command handling &c
522		567
523	=item cf::register_command $name => \&callback($ob,$args);	568	=item cf::register_command $name => \&callback($ob,$args);
524		569
…		…
712		757
713	=head2 CORE EXTENSIONS	758	=head2 CORE EXTENSIONS
714		759
715	Functions and methods that extend core crossfire objects.	760	Functions and methods that extend core crossfire objects.
716		761
		762	=head3 cf::player
		763
717	=over 4	764	=over 4
718		765
719	=item cf::player::exists $login	766	=item cf::player::exists $login
720		767
721	Returns true when the given account exists.	768	Returns true when the given account exists.
…		…
725	sub cf::player::exists($) {	772	sub cf::player::exists($) {
726	cf::player::find $_[0]	773	cf::player::find $_[0]
727	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;	774	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
728	}	775	}
729		776
		777	=item $player->ext_reply ($msgid, $msgtype, %msg)
		778
		779	Sends an ext reply to the player.
		780
		781	=cut
		782
		783	sub cf::player::ext_reply($$$%) {
		784	my ($self, $id, %msg) = @_;
		785
		786	$msg{msgid} = $id;
		787
		788	$self->send ("ext " . to_json \%msg);
		789	}
		790
		791	=back
		792
		793	=head3 cf::object::player
		794
		795	=over 4
		796
730	=item $player_object->reply ($npc, $msg[, $flags])	797	=item $player_object->reply ($npc, $msg[, $flags])
731		798
732	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>	799	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	800	can be C<undef>. Does the right thing when the player is currently in a
734	dialogue with the given NPC character.	801	dialogue with the given NPC character.
735		802
736	=cut	803	=cut
737		804
738	# rough implementation of a future "reply" method that works	805	# rough implementation of a future "reply" method that works
739	# with dialog boxes.	806	# with dialog boxes.
		807	#TODO: the first argument must go, split into a $npc->reply_to ( method
740	sub cf::object::player::reply($$$;$) {	808	sub cf::object::player::reply($$$;$) {
741	my ($self, $npc, $msg, $flags) = @_;	809	my ($self, $npc, $msg, $flags) = @_;
742		810
743	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;	811	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;
744		812
…		…
748	$msg = $npc->name . " says: $msg" if $npc;	816	$msg = $npc->name . " says: $msg" if $npc;
749	$self->message ($msg, $flags);	817	$self->message ($msg, $flags);
750	}	818	}
751	}	819	}
752		820
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")	821	=item $player_object->may ("access")
768		822
769	Returns wether the given player is authorized to access resource "access"	823	Returns wether the given player is authorized to access resource "access"
770	(e.g. "command_wizcast").	824	(e.g. "command_wizcast").
771		825
…		…
778	(ref $cf::CFG{"may_$access"}	832	(ref $cf::CFG{"may_$access"}
779	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	833	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
780	: $cf::CFG{"may_$access"})	834	: $cf::CFG{"may_$access"})
781	}	835	}
782		836
783	=cut	837	=head3 cf::client
784		838
785	#############################################################################	839	=over 4
		840
		841	=item $client->send_drawinfo ($text, $flags)
		842
		843	Sends a drawinfo packet to the client. Circumvents output buffering so
		844	should not be used under normal circumstances.
		845
		846	=cut
		847
		848	sub cf::client::send_drawinfo {
		849	my ($self, $text, $flags) = @_;
		850
		851	utf8::encode $text;
		852	$self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
		853	}
		854
		855
		856	=item $success = $client->query ($flags, "text", \&cb)
		857
		858	Queues a query to the client, calling the given callback with
		859	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
		860	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
		861
		862	Queries can fail, so check the return code. Or don't, as queries will become
		863	reliable at some point in the future.
		864
		865	=cut
		866
		867	sub cf::client::query {
		868	my ($self, $flags, $text, $cb) = @_;
		869
		870	return unless $self->state == ST_PLAYING
		871	\|\| $self->state == ST_SETUP
		872	\|\| $self->state == ST_CUSTOM;
		873
		874	$self->state (ST_CUSTOM);
		875
		876	utf8::encode $text;
		877	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
		878
		879	$self->send_packet ($self->{query_queue}[0][0])
		880	if @{ $self->{query_queue} } == 1;
		881	}
		882
		883	cf::client->attach (
		884	on_reply => sub {
		885	my ($ns, $msg) = @_;
		886
		887	# this weird shuffling is so that direct followup queries
		888	# get handled first
		889	my $queue = delete $ns->{query_queue};
		890
		891	(shift @$queue)->[1]->($msg);
		892
		893	push @{ $ns->{query_queue} }, @$queue;
		894
		895	if (@{ $ns->{query_queue} } == @$queue) {
		896	if (@$queue) {
		897	$ns->send_packet ($ns->{query_queue}[0][0]);
		898	} else {
		899	$ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
		900	}
		901	}
		902	},
		903	);
		904
		905	=item $client->coro (\&cb)
		906
		907	Create a new coroutine, running the specified callback. The coroutine will
		908	be automatically cancelled when the client gets destroyed (e.g. on logout,
		909	or loss of connection).
		910
		911	=cut
		912
		913	sub cf::client::coro {
		914	my ($self, $cb) = @_;
		915
		916	my $coro; $coro = async {
		917	eval {
		918	$cb->();
		919	};
		920	warn $@ if $@;
		921	delete $self->{_coro}{$coro+0};
		922	};
		923
		924	$self->{_coro}{$coro+0} = $coro;
		925	}
		926
		927	cf::client->attach (
		928	on_destroy => sub {
		929	my ($ns) = @_;
		930
		931	$_->cancel for values %{ (delete $ns->{_coro}) \|\| {} };
		932	},
		933	);
		934
		935	=back
		936
786		937
787	=head2 SAFE SCRIPTING	938	=head2 SAFE SCRIPTING
788		939
789	Functions that provide a safe environment to compile and execute	940	Functions that provide a safe environment to compile and execute
790	snippets of perl code without them endangering the safety of the server	941	snippets of perl code without them endangering the safety of the server
…		…
1073	#Symbol::delete_package __PACKAGE__;	1224	#Symbol::delete_package __PACKAGE__;
1074		1225
1075	# reload cf.pm	1226	# reload cf.pm
1076	$msg->("reloading cf.pm");	1227	$msg->("reloading cf.pm");
1077	require cf;	1228	require cf;
		1229	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1078		1230
1079	# load config and database again	1231	# load config and database again
1080	cf::cfg_load;	1232	cf::cfg_load;
1081	cf::db_load;	1233	cf::db_load;
1082		1234

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.102 by root, Wed Dec 27 15:20:54 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.102 by root, Wed Dec 27 15:20:54 2006 UTC