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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.70 by root, Sun Oct 1 10:55:37 2006 UTC vs.
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC

…		…
5	use Storable;	5	use Storable;
6	use Opcode;	6	use Opcode;
7	use Safe;	7	use Safe;
8	use Safe::Hole;	8	use Safe::Hole;
9		9
		10	use IO::AIO ();
		11	use YAML::Syck ();
10	use Time::HiRes;	12	use Time::HiRes;
11	use Event;	13	use Event;
12	$Event::Eval = 1; # no idea why this is required, but it is	14	$Event::Eval = 1; # no idea why this is required, but it is
13		15
		16	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
		17	$YAML::Syck::ImplicitUnicode = 1;
		18
14	use strict;	19	use strict;
15		20
		21	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
		22
		23	our %COMMAND = ();
		24	our %COMMAND_TIME = ();
		25	our %EXTCMD = ();
		26
16	_init_vars;	27	_init_vars;
17		28
18	our %COMMAND = ();
19	our @EVENT;	29	our @EVENT;
20	our $LIBDIR = maps_directory "perl";	30	our $LIBDIR = datadir . "/ext";
21		31
22	our $TICK = MAX_TIME * 1e-6;	32	our $TICK = MAX_TIME * 1e-6;
23	our $TICK_WATCHER;	33	our $TICK_WATCHER;
24	our $NEXT_TICK;	34	our $NEXT_TICK;
25		35
26	our %CFG;	36	our %CFG;
27		37
		38	our $UPTIME; $UPTIME \|\|= time;
		39
28	#############################################################################	40	#############################################################################
29		41
30	=head2 GLOBAL VARIABLES	42	=head2 GLOBAL VARIABLES
31		43
32	=over 4	44	=over 4
		45
		46	=item $cf::UPTIME
		47
		48	The timestamp of the server start (so not actually an uptime).
33		49
34	=item $cf::LIBDIR	50	=item $cf::LIBDIR
35		51
36	The perl library directory, where extensions and cf-specific modules can	52	The perl library directory, where extensions and cf-specific modules can
37	be found. It will be added to C<@INC> automatically.	53	be found. It will be added to C<@INC> automatically.
…		…
58	print STDERR "cfperl: $msg";	74	print STDERR "cfperl: $msg";
59	LOG llevError, "cfperl: $msg";	75	LOG llevError, "cfperl: $msg";
60	};	76	};
61	}	77	}
62		78
		79	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
		80	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
		81	@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
		82	@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
		83	@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
63	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	84	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
64		85
65	# we bless all objects into (empty) derived classes to force a method lookup	86	# we bless all objects into (empty) derived classes to force a method lookup
66	# within the Safe compartment.	87	# within the Safe compartment.
67	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {	88	for my $pkg (qw(
		89	cf::global
		90	cf::object cf::object::player
		91	cf::client cf::player
		92	cf::arch cf::living
		93	cf::map cf::party cf::region
		94	)) {
68	no strict 'refs';	95	no strict 'refs';
69	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	96	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
70	}	97	}
71		98
72	$Event::DIED = sub {	99	$Event::DIED = sub {
…		…
74	};	101	};
75		102
76	my %ext_pkg;	103	my %ext_pkg;
77	my @exts;	104	my @exts;
78	my @hook;	105	my @hook;
79	my %command;
80	my %extcmd;
81		106
82	=head2 UTILITY FUNCTIONS	107	=head2 UTILITY FUNCTIONS
83		108
84	=over 4	109	=over 4
85		110
…		…
109	JSON::Syck::Dump $_[0]	134	JSON::Syck::Dump $_[0]
110	}	135	}
111		136
112	=back	137	=back
113		138
		139	=cut
		140
114	#############################################################################	141	#############################################################################
115		142
116	=head2 EVENTS AND OBJECT ATTACHMENTS	143	=head2 ATTACHABLE OBJECTS
		144
		145	You can define and attach attachments to each "attachable" object in
		146	crossfire+ (objects, players, clients, maps and the special "global"
		147	class). In the following description, CLASS can be any of C<global>,
		148	C<object> C<player>, C<client> or C<map>.
117		149
118	=over 4	150	=over 4
119		151
120	=item $object->attach ($attachment, key => $value...)	152	=item cf::CLASS::attachment $name, ...
121		153
122	=item $object->detach ($attachment)	154	Register an attachment by name through which attachable objects can refer
		155	to this attachment.
123		156
124	Attach/detach a pre-registered attachment to an object.
125
126	=item $player->attach ($attachment, key => $value...)
127
128	=item $player->detach ($attachment)
129
130	Attach/detach a pre-registered attachment to a player.
131
132	=item $map->attach ($attachment, key => $value...)
133
134	=item $map->detach ($attachment)
135
136	Attach/detach a pre-registered attachment to a map.
137
138	=item $bool = $object->attached ($name)
139
140	=item $bool = $player->attached ($name)
141
142	=item $bool = $map->attached ($name)	157	=item $bool = $attachable->attached ($name)
143		158
144	Checks wether the named attachment is currently attached to the object.	159	Checks wether the named attachment is currently attached to the object.
145		160
146	=item cf::attach_global ...	161	=item $attachable->attach ($attachment, key => $value...)
147		162
148	Attach handlers for global events.	163	=item $attachable->detach ($attachment)
149		164
150	This and all following C<attach_*>-functions expect any number of the	165	Attach/detach a pre-registered attachment either to a specific object
151	following handler/hook descriptions:	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
		172	descriptions:
152		173
153	=over 4	174	=over 4
154		175
155	=item prio => $number	176	=item prio => $number
156		177
…		…
158	by another C<prio> setting). Lower priority handlers get executed	179	by another C<prio> setting). Lower priority handlers get executed
159	earlier. The default priority is C<0>, and many built-in handlers are	180	earlier. The default priority is C<0>, and many built-in handlers are
160	registered at priority C<-1000>, so lower priorities should not be used	181	registered at priority C<-1000>, so lower priorities should not be used
161	unless you know what you are doing.	182	unless you know what you are doing.
162		183
		184	=item type => $type
		185
		186	(Only for C<< cf::object->attach >> calls), limits the attachment to the
		187	given type of objects only (the additional parameter C<subtype> can be
		188	used to further limit to the given subtype).
		189
163	=item on_I<event> => \&cb	190	=item on_I<event> => \&cb
164		191
165	Call the given code reference whenever the named event happens (event is	192	Call the given code reference whenever the named event happens (event is
166	something like C<instantiate>, C<apply>, C<use_skill> and so on, and which	193	something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
167	handlers are recognised generally depends on the type of object these	194	handlers are recognised generally depends on the type of object these
…		…
176	package and register them. Only handlers for eevents supported by the	203	package and register them. Only handlers for eevents supported by the
177	object/class are recognised.	204	object/class are recognised.
178		205
179	=back	206	=back
180		207
181	=item cf::attach_to_type $object_type, $subtype, ...
182
183	Attach handlers for a specific object type (e.g. TRANSPORT) and
184	subtype. If C<$subtype> is zero or undef, matches all objects of the given
185	type.
186
187	=item cf::attach_to_objects ...
188
189	Attach handlers to all objects. Do not use this except for debugging or
190	very rare events, as handlers are (obviously) called for I<all> objects in
191	the game.
192
193	=item cf::attach_to_players ...
194
195	Attach handlers to all players.
196
197	=item cf::attach_to_maps ...
198
199	Attach handlers to all maps.
200
201	=item cf:register_attachment $name, ...
202
203	Register an attachment by name through which objects can refer to this
204	attachment.
205
206	=item cf:register_player_attachment $name, ...
207
208	Register an attachment by name through which players can refer to this
209	attachment.
210
211	=item cf:register_map_attachment $name, ...
212
213	Register an attachment by name through which maps can refer to this
214	attachment.
215
216	=cut	208	=cut
217		209
218	# the following variables are defined in .xs and must not be re-created	210	# the following variables are defined in .xs and must not be re-created
219	our @CB_GLOBAL = (); # registry for all global events	211	our @CB_GLOBAL = (); # registry for all global events
220	our @CB_OBJECT = (); # all objects (should not be used except in emergency)	212	our @CB_OBJECT = (); # all objects (should not be used except in emergency)
221	our @CB_PLAYER = ();	213	our @CB_PLAYER = ();
		214	our @CB_CLIENT = ();
222	our @CB_TYPE = (); # registry for type (cf-object class) based events	215	our @CB_TYPE = (); # registry for type (cf-object class) based events
223	our @CB_MAP = ();	216	our @CB_MAP = ();
224		217
225	my %attachment;	218	my %attachment;
226		219
227	sub _attach_cb($\%$$$) {	220	sub _attach_cb($$$$) {
228	my ($registry, $undo, $event, $prio, $cb) = @_;	221	my ($registry, $event, $prio, $cb) = @_;
229		222
230	use sort 'stable';	223	use sort 'stable';
231		224
232	$cb = [$prio, $cb];	225	$cb = [$prio, $cb];
233		226
234	@{$registry->[$event]} = sort	227	@{$registry->[$event]} = sort
235	{ $a->[0] cmp $b->[0] }	228	{ $a->[0] cmp $b->[0] }
236	@{$registry->[$event] \|\| []}, $cb;	229	@{$registry->[$event] \|\| []}, $cb;
237
238	push @{$undo->{cb}}, [$event, $cb];
239	}	230	}
240		231
241	# attach handles attaching event callbacks	232	# attach handles attaching event callbacks
242	# the only thing the caller has to do is pass the correct	233	# the only thing the caller has to do is pass the correct
243	# registry (== where the callback attaches to).	234	# registry (== where the callback attaches to).
244	sub _attach(\@$@) {	235	sub _attach {
245	my ($registry, $klass, @arg) = @_;	236	my ($registry, $klass, @arg) = @_;
246		237
		238	my $object_type;
247	my $prio = 0;	239	my $prio = 0;
248
249	my %undo = (
250	registry => $registry,
251	cb => [],
252	);
253
254	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;	240	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
255		241
256	while (@arg) {	242	while (@arg) {
257	my $type = shift @arg;	243	my $type = shift @arg;
258		244
259	if ($type eq "prio") {	245	if ($type eq "prio") {
260	$prio = shift @arg;	246	$prio = shift @arg;
261		247
		248	} elsif ($type eq "type") {
		249	$object_type = shift @arg;
		250	$registry = $CB_TYPE[$object_type] \|\|= [];
		251
		252	} elsif ($type eq "subtype") {
		253	defined $object_type or Carp::croak "subtype specified without type";
		254	my $object_subtype = shift @arg;
		255	$registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] \|\|= [];
		256
262	} elsif ($type eq "package") {	257	} elsif ($type eq "package") {
263	my $pkg = shift @arg;	258	my $pkg = shift @arg;
264		259
265	while (my ($name, $id) = each %cb_id) {	260	while (my ($name, $id) = each %cb_id) {
266	if (my $cb = $pkg->can ($name)) {	261	if (my $cb = $pkg->can ($name)) {
267	_attach_cb $registry, %undo, $id, $prio, $cb;	262	_attach_cb $registry, $id, $prio, $cb;
268	}	263	}
269	}	264	}
270		265
271	} elsif (exists $cb_id{$type}) {	266	} elsif (exists $cb_id{$type}) {
272	_attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;	267	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
273		268
274	} elsif (ref $type) {	269	} elsif (ref $type) {
275	warn "attaching objects not supported, ignoring.\n";	270	warn "attaching objects not supported, ignoring.\n";
276		271
277	} else {	272	} else {
278	shift @arg;	273	shift @arg;
279	warn "attach argument '$type' not supported, ignoring.\n";	274	warn "attach argument '$type' not supported, ignoring.\n";
280	}	275	}
281	}	276	}
282
283	\%undo
284	}	277	}
285		278
286	sub _attach_attachment {	279	sub _object_attach {
287	my ($obj, $name, %arg) = @_;	280	my ($obj, $name, %arg) = @_;
288		281
289	return if exists $obj->{_attachment}{$name};	282	return if exists $obj->{_attachment}{$name};
290
291	my $res;
292		283
293	if (my $attach = $attachment{$name}) {	284	if (my $attach = $attachment{$name}) {
294	my $registry = $obj->registry;	285	my $registry = $obj->registry;
295		286
296	for (@$attach) {	287	for (@$attach) {
297	my ($klass, @attach) = @$_;	288	my ($klass, @attach) = @$_;
298	$res = _attach @$registry, $klass, @attach;	289	_attach $registry, $klass, @attach;
299	}	290	}
300		291
301	$obj->{$name} = \%arg;	292	$obj->{$name} = \%arg;
302	} else {	293	} else {
303	warn "object uses attachment '$name' that is not available, postponing.\n";	294	warn "object uses attachment '$name' that is not available, postponing.\n";
304	}	295	}
305		296
306	$obj->{_attachment}{$name} = undef;	297	$obj->{_attachment}{$name} = undef;
307
308	$res->{attachment} = $name;
309	$res
310	}	298	}
311		299
312	*cf::object::attach =	300	sub cf::attachable::attach {
313	*cf::player::attach =	301	if (ref $_[0]) {
314	*cf::map::attach = sub {	302	_object_attach @_;
315	my ($obj, $name, %arg) = @_;	303	} else {
316		304	_attach shift->_attach_registry, @_;
317	_attach_attachment $obj, $name, %arg;	305	}
318	};	306	};
319		307
320	# all those should be optimised	308	# all those should be optimised
321	*cf::object::detach =	309	sub cf::attachable::detach {
322	*cf::player::detach =
323	*cf::map::detach = sub {
324	my ($obj, $name) = @_;	310	my ($obj, $name) = @_;
325		311
		312	if (ref $obj) {
326	delete $obj->{_attachment}{$name};	313	delete $obj->{_attachment}{$name};
327	reattach ($obj);	314	reattach ($obj);
		315	} else {
		316	Carp::croak "cannot, currently, detach class attachments";
		317	}
328	};	318	};
329		319
330	*cf::object::attached =	320	sub cf::attachable::attached {
331	*cf::player::attached =
332	*cf::map::attached = sub {
333	my ($obj, $name) = @_;	321	my ($obj, $name) = @_;
334		322
335	exists $obj->{_attachment}{$name}	323	exists $obj->{_attachment}{$name}
336	};
337
338	sub attach_global {
339	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
340	}	324	}
341		325
342	sub attach_to_type {	326	for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {
343	my $type = shift;	327	eval "#line " . __LINE__ . " 'cf.pm'
344	my $subtype = shift;	328	sub cf::\L$klass\E::_attach_registry {
		329	(\\\@CB_$klass, KLASS_$klass)
		330	}
345		331
346	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_	332	sub cf::\L$klass\E::attachment {
347	}
348
349	sub attach_to_objects {
350	_attach @CB_OBJECT, KLASS_OBJECT, @_
351	}
352
353	sub attach_to_players {
354	_attach @CB_PLAYER, KLASS_PLAYER, @_
355	}
356
357	sub attach_to_maps {
358	_attach @CB_MAP, KLASS_MAP, @_
359	}
360
361	sub register_attachment {
362	my $name = shift;	333	my \$name = shift;
363		334
364	$attachment{$name} = [[KLASS_OBJECT, @_]];
365	}
366
367	sub register_player_attachment {
368	my $name = shift;
369
370	$attachment{$name} = [[KLASS_PLAYER, @_]];
371	}
372
373	sub register_map_attachment {
374	my $name = shift;
375
376	$attachment{$name} = [[KLASS_MAP, @_]];	335	\$attachment{\$name} = [[KLASS_$klass, \@_]];
		336	}
		337	";
		338	die if $@;
377	}	339	}
378		340
379	our $override;	341	our $override;
380	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	342	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
381		343
…		…
411		373
412	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)	374	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
413		375
414	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)	376	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
415		377
		378	=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
		379
416	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)	380	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
417		381
418	Generate a global/object/player/map-specific event with the given arguments.	382	Generate a global/object/player/map-specific event with the given arguments.
419		383
420	This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be	384	This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
421	removed in future versions), and there is no public API to access override	385	removed in future versions), and there is no public API to access override
422	results (if you must, access C<@cf::invoke_results> directly).	386	results (if you must, access C<@cf::invoke_results> directly).
423		387
424	=back	388	=back
425		389
		390	=cut
		391
426	#############################################################################	392	#############################################################################
427		393
428	=head2 METHODS VALID FOR ALL CORE OBJECTS	394	=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
		395
		396	Attachable objects includes objects, players, clients and maps.
429		397
430	=over 4	398	=over 4
431		399
432	=item $object->valid, $player->valid, $map->valid	400	=item $object->valid
433		401
434	Just because you have a perl object does not mean that the corresponding	402	Just because you have a perl object does not mean that the corresponding
435	C-level object still exists. If you try to access an object that has no	403	C-level object still exists. If you try to access an object that has no
436	valid C counterpart anymore you get an exception at runtime. This method	404	valid C counterpart anymore you get an exception at runtime. This method
437	can be used to test for existence of the C object part without causing an	405	can be used to test for existence of the C object part without causing an
…		…
439		407
440	=back	408	=back
441		409
442	=cut	410	=cut
443		411
444	*cf::object::valid =
445	*cf::player::valid =
446	*cf::map::valid = \&cf::_valid;
447
448	#############################################################################	412	#############################################################################
449	# object support	413	# object support
450		414
451	sub instantiate {	415	sub instantiate {
452	my ($obj, $data) = @_;	416	my ($obj, $data) = @_;
…		…
471		435
472	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {	436	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
473	if (my $attach = $attachment{$name}) {	437	if (my $attach = $attachment{$name}) {
474	for (@$attach) {	438	for (@$attach) {
475	my ($klass, @attach) = @$_;	439	my ($klass, @attach) = @$_;
476	_attach @$registry, $klass, @attach;	440	_attach $registry, $klass, @attach;
477	}	441	}
478	} else {	442	} else {
479	warn "object uses attachment '$name' that is not available, postponing.\n";	443	warn "object uses attachment '$name' that is not available, postponing.\n";
480	}	444	}
481	}	445	}
…		…
510	unlink $filename;	474	unlink $filename;
511	unlink "$filename.pst";	475	unlink "$filename.pst";
512	}	476	}
513	}	477	}
514		478
		479	sub object_freezer_as_string {
		480	my ($rdata, $objs) = @_;
		481
		482	use Data::Dumper;
		483
		484	$$rdata . Dumper $objs
		485	}
		486
515	sub object_thawer_load {	487	sub object_thawer_load {
516	my ($filename) = @_;	488	my ($filename) = @_;
517		489
518	local $/;	490	local $/;
519		491
…		…
529	}	501	}
530		502
531	()	503	()
532	}	504	}
533		505
534	attach_to_objects	506	cf::object->attach (
535	prio => -1000000,	507	prio => -1000000,
536	on_clone => sub {	508	on_clone => sub {
537	my ($src, $dst) = @_;	509	my ($src, $dst) = @_;
538		510
539	@{$dst->registry} = @{$src->registry};	511	@{$dst->registry} = @{$src->registry};
…		…
541	%$dst = %$src;	513	%$dst = %$src;
542		514
543	%{$dst->{_attachment}} = %{$src->{_attachment}}	515	%{$dst->{_attachment}} = %{$src->{_attachment}}
544	if exists $src->{_attachment};	516	if exists $src->{_attachment};
545	},	517	},
546	;	518	);
547		519
548	#############################################################################	520	#############################################################################
549	# old plug-in events	521	# command handling &c
550		522
551	sub inject_event {	523	=item cf::register_command $name => \&callback($ob,$args);
552	my $extension = shift;
553	my $event_code = shift;
554		524
555	my $cb = $hook[$event_code]{$extension}	525	Register a callback for execution when the client sends the user command
556	or return;	526	$name.
557		527
558	&$cb	528	=cut
559	}
560
561	sub inject_global_event {
562	my $event = shift;
563
564	my $cb = $hook[$event]
565	or return;
566
567	List::Util::max map &$_, values %$cb
568	}
569
570	sub inject_command {
571	my ($name, $obj, $params) = @_;
572
573	for my $cmd (@{ $command{$name} }) {
574	$cmd->[1]->($obj, $params);
575	}
576
577	-1
578	}
579		529
580	sub register_command {	530	sub register_command {
581	my ($name, $time, $cb) = @_;	531	my ($name, $cb) = @_;
582		532
583	my $caller = caller;	533	my $caller = caller;
584	#warn "registering command '$name/$time' to '$caller'";	534	#warn "registering command '$name/$time' to '$caller'";
585		535
586	push @{ $command{$name} }, [$time, $cb, $caller];	536	push @{ $COMMAND{$name} }, [$caller, $cb];
587	$COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
588	}	537	}
		538
		539	=item cf::register_extcmd $name => \&callback($pl,$packet);
		540
		541	Register a callbackf ro execution when the client sends an extcmd packet.
		542
		543	If the callback returns something, it is sent back as if reply was being
		544	called.
		545
		546	=cut
589		547
590	sub register_extcmd {	548	sub register_extcmd {
591	my ($name, $cb) = @_;	549	my ($name, $cb) = @_;
592		550
593	my $caller = caller;	551	my $caller = caller;
594	#warn "registering extcmd '$name' to '$caller'";	552	#warn "registering extcmd '$name' to '$caller'";
595		553
596	$extcmd{$name} = [$cb, $caller];	554	$EXTCMD{$name} = [$cb, $caller];
597	}	555	}
		556
		557	cf::player->attach (
		558	on_command => sub {
		559	my ($pl, $name, $params) = @_;
		560
		561	my $cb = $COMMAND{$name}
		562	or return;
		563
		564	for my $cmd (@$cb) {
		565	$cmd->[1]->($pl->ob, $params);
		566	}
		567
		568	cf::override;
		569	},
		570	on_extcmd => sub {
		571	my ($pl, $buf) = @_;
		572
		573	my $msg = eval { from_json $buf };
		574
		575	if (ref $msg) {
		576	if (my $cb = $EXTCMD{$msg->{msgtype}}) {
		577	if (my %reply = $cb->[0]->($pl, $msg)) {
		578	$pl->ext_reply ($msg->{msgid}, %reply);
		579	}
		580	}
		581	} else {
		582	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
		583	}
		584
		585	cf::override;
		586	},
		587	);
598		588
599	sub register {	589	sub register {
600	my ($base, $pkg) = @_;	590	my ($base, $pkg) = @_;
601		591
602	#TODO	592	#TODO
…		…
621	. "#line 1 \"$path\"\n{\n"	611	. "#line 1 \"$path\"\n{\n"
622	. (do { local $/; <$fh> })	612	. (do { local $/; <$fh> })
623	. "\n};\n1";	613	. "\n};\n1";
624		614
625	eval $source	615	eval $source
626	or die "$path: $@";	616	or die $@ ? "$path: $@\n"
		617	: "extension disabled.\n";
627		618
628	push @exts, $pkg;	619	push @exts, $pkg;
629	$ext_pkg{$base} = $pkg;	620	$ext_pkg{$base} = $pkg;
630		621
631	# no strict 'refs';	622	# no strict 'refs';
…		…
644	# for my $idx (0 .. $#PLUGIN_EVENT) {	635	# for my $idx (0 .. $#PLUGIN_EVENT) {
645	# delete $hook[$idx]{$pkg};	636	# delete $hook[$idx]{$pkg};
646	# }	637	# }
647		638
648	# remove commands	639	# remove commands
649	for my $name (keys %command) {	640	for my $name (keys %COMMAND) {
650	my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };	641	my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
651		642
652	if (@cb) {	643	if (@cb) {
653	$command{$name} = \@cb;	644	$COMMAND{$name} = \@cb;
654	$COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
655	} else {	645	} else {
656	delete $command{$name};
657	delete $COMMAND{"$name\000"};	646	delete $COMMAND{$name};
658	}	647	}
659	}	648	}
660		649
661	# remove extcmds	650	# remove extcmds
662	for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {	651	for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
663	delete $extcmd{$name};	652	delete $EXTCMD{$name};
664	}	653	}
665		654
666	if (my $cb = $pkg->can ("unload")) {	655	if (my $cb = $pkg->can ("unload")) {
667	eval {	656	eval {
668	$cb->($pkg);	657	$cb->($pkg);
…		…
672		661
673	Symbol::delete_package $pkg;	662	Symbol::delete_package $pkg;
674	}	663	}
675		664
676	sub load_extensions {	665	sub load_extensions {
677	my $LIBDIR = maps_directory "perl";
678
679	for my $ext (<$LIBDIR/*.ext>) {	666	for my $ext (<$LIBDIR/*.ext>) {
680	next unless -r $ext;	667	next unless -r $ext;
681	eval {	668	eval {
682	load_extension $ext;	669	load_extension $ext;
683	1	670	1
684	} or warn "$ext not loaded: $@";	671	} or warn "$ext not loaded: $@";
685	}	672	}
686	}	673	}
687		674
688	#############################################################################	675	#############################################################################
689	# extcmd framework, basically convert ext <msg>
690	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
691
692	attach_to_players
693	on_extcmd => sub {
694	my ($pl, $buf) = @_;
695
696	my $msg = eval { from_json $buf };
697
698	if (ref $msg) {
699	if (my $cb = $extcmd{$msg->{msgtype}}) {
700	if (my %reply = $cb->[0]->($pl, $msg)) {
701	$pl->ext_reply ($msg->{msgid}, %reply);
702	}
703	}
704	} else {
705	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
706	}
707
708	cf::override;
709	},
710	;
711
712	#############################################################################
713	# load/save/clean perl data associated with a map	676	# load/save/clean perl data associated with a map
714		677
715	*cf::mapsupport::on_clean = sub {	678	*cf::mapsupport::on_clean = sub {
716	my ($map) = @_;	679	my ($map) = @_;
717		680
…		…
719	defined $path or return;	682	defined $path or return;
720		683
721	unlink "$path.pst";	684	unlink "$path.pst";
722	};	685	};
723		686
724	attach_to_maps prio => -10000, package => cf::mapsupport::;	687	cf::map->attach (prio => -10000, package => cf::mapsupport::);
725		688
726	#############################################################################	689	#############################################################################
727	# load/save perl data associated with player->ob objects	690	# load/save perl data associated with player->ob objects
728		691
729	sub all_objects(@) {	692	sub all_objects(@) {
730	@_, map all_objects ($_->inv), @_	693	@_, map all_objects ($_->inv), @_
731	}	694	}
732		695
733	# TODO: compatibility cruft, remove when no longer needed	696	# TODO: compatibility cruft, remove when no longer needed
734	attach_to_players	697	cf::player->attach (
735	on_load => sub {	698	on_load => sub {
736	my ($pl, $path) = @_;	699	my ($pl, $path) = @_;
737		700
738	for my $o (all_objects $pl->ob) {	701	for my $o (all_objects $pl->ob) {
739	if (my $value = $o->get_ob_key_value ("_perl_data")) {	702	if (my $value = $o->get_ob_key_value ("_perl_data")) {
…		…
741		704
742	%$o = %{ Storable::thaw pack "H*", $value };	705	%$o = %{ Storable::thaw pack "H*", $value };
743	}	706	}
744	}	707	}
745	},	708	},
746	;	709	);
747		710
748	#############################################################################	711	#############################################################################
749		712
750	=head2 CORE EXTENSIONS	713	=head2 CORE EXTENSIONS
751		714
…		…
762	sub cf::player::exists($) {	725	sub cf::player::exists($) {
763	cf::player::find $_[0]	726	cf::player::find $_[0]
764	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;	727	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
765	}	728	}
766		729
767	=item $player->reply ($npc, $msg[, $flags])	730	=item $player_object->reply ($npc, $msg[, $flags])
768		731
769	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>	732	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
770	can be C<undef>. Does the right thing when the player is currently in a	733	can be C<undef>. Does the right thing when the player is currently in a
771	dialogue with the given NPC character.	734	dialogue with the given NPC character.
772		735
…		…
799	$msg{msgid} = $id;	762	$msg{msgid} = $id;
800		763
801	$self->send ("ext " . to_json \%msg);	764	$self->send ("ext " . to_json \%msg);
802	}	765	}
803		766
804	=back	767	=item $player_object->may ("access")
		768
		769	Returns wether the given player is authorized to access resource "access"
		770	(e.g. "command_wizcast").
		771
		772	=cut
		773
		774	sub cf::object::player::may {
		775	my ($self, $access) = @_;
		776
		777	$self->flag (cf::FLAG_WIZ) \|\|
		778	(ref $cf::CFG{"may_$access"}
		779	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
		780	: $cf::CFG{"may_$access"})
		781	}
805		782
806	=cut	783	=cut
807		784
808	#############################################################################	785	#############################################################################
809		786
…		…
811		788
812	Functions that provide a safe environment to compile and execute	789	Functions that provide a safe environment to compile and execute
813	snippets of perl code without them endangering the safety of the server	790	snippets of perl code without them endangering the safety of the server
814	itself. Looping constructs, I/O operators and other built-in functionality	791	itself. Looping constructs, I/O operators and other built-in functionality
815	is not available in the safe scripting environment, and the number of	792	is not available in the safe scripting environment, and the number of
816	functions and methods that cna be called is greatly reduced.	793	functions and methods that can be called is greatly reduced.
817		794
818	=cut	795	=cut
819		796
820	our $safe = new Safe "safe";	797	our $safe = new Safe "safe";
821	our $safe_hole = new Safe::Hole;	798	our $safe_hole = new Safe::Hole;
…		…
828		805
829	=pod	806	=pod
830		807
831	The following fucntions and emthods are available within a safe environment:	808	The following fucntions and emthods are available within a safe environment:
832		809
833	cf::object contr pay_amount pay_player	810	cf::object contr pay_amount pay_player map
834	cf::object::player player	811	cf::object::player player
835	cf::player peaceful	812	cf::player peaceful
		813	cf::map trigger
836		814
837	=cut	815	=cut
838		816
839	for (	817	for (
840	["cf::object" => qw(contr pay_amount pay_player)],	818	["cf::object" => qw(contr pay_amount pay_player map)],
841	["cf::object::player" => qw(player)],	819	["cf::object::player" => qw(player)],
842	["cf::player" => qw(peaceful)],	820	["cf::player" => qw(peaceful)],
		821	["cf::map" => qw(trigger)],
843	) {	822	) {
844	no strict 'refs';	823	no strict 'refs';
845	my ($pkg, @funs) = @$_;	824	my ($pkg, @funs) = @$_;
846	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	825	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
847	for @funs;	826	for @funs;
…		…
912	*{"safe::$fun"} = $safe_hole->wrap ($cb);	891	*{"safe::$fun"} = $safe_hole->wrap ($cb);
913	}	892	}
914		893
915	=back	894	=back
916		895
		896	=cut
		897
917	#############################################################################	898	#############################################################################
918		899
919	=head2 EXTENSION DATABASE SUPPORT	900	=head2 EXTENSION DATABASE SUPPORT
920		901
921	Crossfire maintains a very simple database for extension use. It can	902	Crossfire maintains a very simple database for extension use. It can
…		…
955		936
956	Immediately write the database to disk I<if it is dirty>.	937	Immediately write the database to disk I<if it is dirty>.
957		938
958	=cut	939	=cut
959		940
		941	our $DB;
		942
960	{	943	{
961	my $db;
962	my $path = cf::localdir . "/database.pst";	944	my $path = cf::localdir . "/database.pst";
963		945
964	sub db_load() {	946	sub db_load() {
965	warn "loading database $path\n";#d# remove later	947	warn "loading database $path\n";#d# remove later
966	$db = stat $path ? Storable::retrieve $path : { };	948	$DB = stat $path ? Storable::retrieve $path : { };
967	}	949	}
968		950
969	my $pid;	951	my $pid;
970		952
971	sub db_save() {	953	sub db_save() {
972	warn "saving database $path\n";#d# remove later	954	warn "saving database $path\n";#d# remove later
973	waitpid $pid, 0 if $pid;	955	waitpid $pid, 0 if $pid;
974	if (0 == ($pid = fork)) {	956	if (0 == ($pid = fork)) {
975	$db->{_meta}{version} = 1;	957	$DB->{_meta}{version} = 1;
976	Storable::nstore $db, "$path~";	958	Storable::nstore $DB, "$path~";
977	rename "$path~", $path;	959	rename "$path~", $path;
978	cf::_exit 0 if defined $pid;	960	cf::_exit 0 if defined $pid;
979	}	961	}
980	}	962	}
981		963
…		…
984	sub db_sync() {	966	sub db_sync() {
985	db_save if $dirty;	967	db_save if $dirty;
986	undef $dirty;	968	undef $dirty;
987	}	969	}
988		970
989	my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {	971	my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
990	db_sync;	972	db_sync;
991	});	973	});
992		974
993	sub db_dirty() {	975	sub db_dirty() {
994	$dirty = 1;	976	$dirty = 1;
995	$idle->start;	977	$idle->start;
996	}	978	}
997		979
998	sub db_get($;$) {	980	sub db_get($;$) {
999	@_ >= 2	981	@_ >= 2
1000	? $db->{$_[0]}{$_[1]}	982	? $DB->{$_[0]}{$_[1]}
1001	: ($db->{$_[0]} \|\|= { })	983	: ($DB->{$_[0]} \|\|= { })
1002	}	984	}
1003		985
1004	sub db_put($$;$) {	986	sub db_put($$;$) {
1005	if (@_ >= 3) {	987	if (@_ >= 3) {
1006	$db->{$_[0]}{$_[1]} = $_[2];	988	$DB->{$_[0]}{$_[1]} = $_[2];
1007	} else {	989	} else {
1008	$db->{$_[0]} = $_[1];	990	$DB->{$_[0]} = $_[1];
1009	}	991	}
1010	db_dirty;	992	db_dirty;
1011	}	993	}
1012		994
1013	attach_global	995	cf::global->attach (
1014	prio => 10000,	996	prio => 10000,
1015	on_cleanup => sub {	997	on_cleanup => sub {
1016	db_sync;	998	db_sync;
1017	},	999	},
1018	;	1000	);
1019	}	1001	}
1020		1002
1021	#############################################################################	1003	#############################################################################
1022	# the server's main()	1004	# the server's main()
1023		1005
		1006	sub cfg_load {
		1007	open my $fh, "<:utf8", cf::confdir . "/config"
		1008	or return;
		1009
		1010	local $/;
		1011	*CFG = YAML::Syck::Load <$fh>;
		1012	}
		1013
1024	sub main {	1014	sub main {
		1015	cfg_load;
1025	db_load;	1016	db_load;
1026	load_extensions;	1017	load_extensions;
1027	Event::loop;	1018	Event::loop;
1028	}	1019	}
1029		1020
…		…
1035		1026
1036	$msg->("reloading...");	1027	$msg->("reloading...");
1037		1028
1038	eval {	1029	eval {
1039	# cancel all watchers	1030	# cancel all watchers
1040	$_->cancel for Event::all_watchers;	1031	for (Event::all_watchers) {
		1032	$_->cancel if $_->data & WF_AUTOCANCEL;
		1033	}
1041		1034
1042	# unload all extensions	1035	# unload all extensions
1043	for (@exts) {	1036	for (@exts) {
1044	$msg->("unloading <$_>");	1037	$msg->("unloading <$_>");
1045	unload_extension $_;	1038	unload_extension $_;
…		…
1081		1074
1082	# reload cf.pm	1075	# reload cf.pm
1083	$msg->("reloading cf.pm");	1076	$msg->("reloading cf.pm");
1084	require cf;	1077	require cf;
1085		1078
1086	# load database again	1079	# load config and database again
		1080	cf::cfg_load;
1087	cf::db_load;	1081	cf::db_load;
1088		1082
1089	# load extensions	1083	# load extensions
1090	$msg->("load extensions");	1084	$msg->("load extensions");
1091	cf::load_extensions;	1085	cf::load_extensions;
…		…
1104	warn $_[0];	1098	warn $_[0];
1105	print "$_[0]\n";	1099	print "$_[0]\n";
1106	};	1100	};
1107	}	1101	}
1108		1102
		1103	register "<global>", __PACKAGE__;
		1104
1109	register_command "perl-reload", 0, sub {	1105	register_command "perl-reload" => sub {
1110	my ($who, $arg) = @_;	1106	my ($who, $arg) = @_;
1111		1107
1112	if ($who->flag (FLAG_WIZ)) {	1108	if ($who->flag (FLAG_WIZ)) {
1113	_perl_reload {	1109	_perl_reload {
1114	warn $_[0];	1110	warn $_[0];
1115	$who->message ($_[0]);	1111	$who->message ($_[0]);
1116	};	1112	};
1117	}	1113	}
1118	};	1114	};
1119		1115
1120	register "<global>", __PACKAGE__;
1121
1122	unshift @INC, $LIBDIR;	1116	unshift @INC, $LIBDIR;
1123		1117
1124	$TICK_WATCHER = Event->timer (	1118	$TICK_WATCHER = Event->timer (
1125	prio => 1,	1119	prio => 0,
1126	at => $NEXT_TICK \|\| 1,	1120	at => $NEXT_TICK \|\| 1,
		1121	data => WF_AUTOCANCEL,
1127	cb => sub {	1122	cb => sub {
1128	cf::server_tick; # one server iteration	1123	cf::server_tick; # one server iteration
1129		1124
1130	my $NOW = Event::time;	1125	my $NOW = Event::time;
1131	$NEXT_TICK += $TICK;	1126	$NEXT_TICK += $TICK;
1132		1127
1133	# if we are delayed by four ticks, skip them all	1128	# if we are delayed by four ticks or more, skip them all
1134	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;	1129	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135		1130
1136	$TICK_WATCHER->at ($NEXT_TICK);	1131	$TICK_WATCHER->at ($NEXT_TICK);
1137	$TICK_WATCHER->start;	1132	$TICK_WATCHER->start;
1138	},	1133	},
1139	);	1134	);
1140		1135
		1136	IO::AIO::max_poll_time $TICK * 0.2;
		1137
		1138	Event->io (fd => IO::AIO::poll_fileno,
		1139	poll => 'r',
		1140	prio => 5,
		1141	data => WF_AUTOCANCEL,
		1142	cb => \&IO::AIO::poll_cb);
		1143
1141	1	1144	1
1142		1145

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.70 by root, Sun Oct 1 10:55:37 2006 UTC vs. Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.70 by root, Sun Oct 1 10:55:37 2006 UTC vs.
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC