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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.76 by root, Mon Oct 2 15:28:36 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 ();
10	use YAML::Syck ();	11	use YAML::Syck ();
11	use Time::HiRes;	12	use Time::HiRes;
12	use Event;	13	use Event;
13	$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
14		15
15	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?	16	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
16	$YAML::Syck::ImplicitUnicode = 1;	17	$YAML::Syck::ImplicitUnicode = 1;
17		18
18	use strict;	19	use strict;
19		20
		21	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
		22
		23	our %COMMAND = ();
		24	our %COMMAND_TIME = ();
		25	our %EXTCMD = ();
		26
20	_init_vars;	27	_init_vars;
21		28
22	our %COMMAND = ();
23	our @EVENT;	29	our @EVENT;
24	our $LIBDIR = maps_directory "perl";	30	our $LIBDIR = datadir . "/ext";
25		31
26	our $TICK = MAX_TIME * 1e-6;	32	our $TICK = MAX_TIME * 1e-6;
27	our $TICK_WATCHER;	33	our $TICK_WATCHER;
28	our $NEXT_TICK;	34	our $NEXT_TICK;
29		35
30	our %CFG;	36	our %CFG;
31		37
32	our $uptime;	38	our $UPTIME; $UPTIME \|\|= time;
33
34	$uptime \|\|= time;
35		39
36	#############################################################################	40	#############################################################################
37		41
38	=head2 GLOBAL VARIABLES	42	=head2 GLOBAL VARIABLES
39		43
40	=over 4	44	=over 4
		45
		46	=item $cf::UPTIME
		47
		48	The timestamp of the server start (so not actually an uptime).
41		49
42	=item $cf::LIBDIR	50	=item $cf::LIBDIR
43		51
44	The perl library directory, where extensions and cf-specific modules can	52	The perl library directory, where extensions and cf-specific modules can
45	be found. It will be added to C<@INC> automatically.	53	be found. It will be added to C<@INC> automatically.
…		…
66	print STDERR "cfperl: $msg";	74	print STDERR "cfperl: $msg";
67	LOG llevError, "cfperl: $msg";	75	LOG llevError, "cfperl: $msg";
68	};	76	};
69	}	77	}
70		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';
71	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	84	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72		85
73	# 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
74	# within the Safe compartment.	87	# within the Safe compartment.
75	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	)) {
76	no strict 'refs';	95	no strict 'refs';
77	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	96	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78	}	97	}
79		98
80	$Event::DIED = sub {	99	$Event::DIED = sub {
…		…
82	};	101	};
83		102
84	my %ext_pkg;	103	my %ext_pkg;
85	my @exts;	104	my @exts;
86	my @hook;	105	my @hook;
87	my %command;
88	my %extcmd;
89		106
90	=head2 UTILITY FUNCTIONS	107	=head2 UTILITY FUNCTIONS
91		108
92	=over 4	109	=over 4
93		110
…		…
121		138
122	=cut	139	=cut
123		140
124	#############################################################################	141	#############################################################################
125		142
126	=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>.
127		149
128	=over 4	150	=over 4
129		151
130	=item $object->attach ($attachment, key => $value...)	152	=item cf::CLASS::attachment $name, ...
131		153
132	=item $object->detach ($attachment)	154	Register an attachment by name through which attachable objects can refer
		155	to this attachment.
133		156
134	Attach/detach a pre-registered attachment to an object.
135
136	=item $player->attach ($attachment, key => $value...)
137
138	=item $player->detach ($attachment)
139
140	Attach/detach a pre-registered attachment to a player.
141
142	=item $map->attach ($attachment, key => $value...)
143
144	=item $map->detach ($attachment)
145
146	Attach/detach a pre-registered attachment to a map.
147
148	=item $bool = $object->attached ($name)
149
150	=item $bool = $player->attached ($name)
151
152	=item $bool = $map->attached ($name)	157	=item $bool = $attachable->attached ($name)
153		158
154	Checks wether the named attachment is currently attached to the object.	159	Checks wether the named attachment is currently attached to the object.
155		160
156	=item cf::attach_global ...	161	=item $attachable->attach ($attachment, key => $value...)
157		162
158	Attach handlers for global events.	163	=item $attachable->detach ($attachment)
159		164
160	This and all following C<attach_*>-functions expect any number of the	165	Attach/detach a pre-registered attachment either to a specific object
161	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:
162		173
163	=over 4	174	=over 4
164		175
165	=item prio => $number	176	=item prio => $number
166		177
…		…
168	by another C<prio> setting). Lower priority handlers get executed	179	by another C<prio> setting). Lower priority handlers get executed
169	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
170	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
171	unless you know what you are doing.	182	unless you know what you are doing.
172		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
173	=item on_I<event> => \&cb	190	=item on_I<event> => \&cb
174		191
175	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
176	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
177	handlers are recognised generally depends on the type of object these	194	handlers are recognised generally depends on the type of object these
…		…
186	package and register them. Only handlers for eevents supported by the	203	package and register them. Only handlers for eevents supported by the
187	object/class are recognised.	204	object/class are recognised.
188		205
189	=back	206	=back
190		207
191	=item cf::attach_to_type $object_type, $subtype, ...
192
193	Attach handlers for a specific object type (e.g. TRANSPORT) and
194	subtype. If C<$subtype> is zero or undef, matches all objects of the given
195	type.
196
197	=item cf::attach_to_objects ...
198
199	Attach handlers to all objects. Do not use this except for debugging or
200	very rare events, as handlers are (obviously) called for I<all> objects in
201	the game.
202
203	=item cf::attach_to_players ...
204
205	Attach handlers to all players.
206
207	=item cf::attach_to_maps ...
208
209	Attach handlers to all maps.
210
211	=item cf:register_attachment $name, ...
212
213	Register an attachment by name through which objects can refer to this
214	attachment.
215
216	=item cf:register_player_attachment $name, ...
217
218	Register an attachment by name through which players can refer to this
219	attachment.
220
221	=item cf:register_map_attachment $name, ...
222
223	Register an attachment by name through which maps can refer to this
224	attachment.
225
226	=cut	208	=cut
227		209
228	# 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
229	our @CB_GLOBAL = (); # registry for all global events	211	our @CB_GLOBAL = (); # registry for all global events
230	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)
231	our @CB_PLAYER = ();	213	our @CB_PLAYER = ();
		214	our @CB_CLIENT = ();
232	our @CB_TYPE = (); # registry for type (cf-object class) based events	215	our @CB_TYPE = (); # registry for type (cf-object class) based events
233	our @CB_MAP = ();	216	our @CB_MAP = ();
234		217
235	my %attachment;	218	my %attachment;
236		219
237	sub _attach_cb($\%$$$) {	220	sub _attach_cb($$$$) {
238	my ($registry, $undo, $event, $prio, $cb) = @_;	221	my ($registry, $event, $prio, $cb) = @_;
239		222
240	use sort 'stable';	223	use sort 'stable';
241		224
242	$cb = [$prio, $cb];	225	$cb = [$prio, $cb];
243		226
244	@{$registry->[$event]} = sort	227	@{$registry->[$event]} = sort
245	{ $a->[0] cmp $b->[0] }	228	{ $a->[0] cmp $b->[0] }
246	@{$registry->[$event] \|\| []}, $cb;	229	@{$registry->[$event] \|\| []}, $cb;
247
248	push @{$undo->{cb}}, [$event, $cb];
249	}	230	}
250		231
251	# attach handles attaching event callbacks	232	# attach handles attaching event callbacks
252	# 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
253	# registry (== where the callback attaches to).	234	# registry (== where the callback attaches to).
254	sub _attach(\@$@) {	235	sub _attach {
255	my ($registry, $klass, @arg) = @_;	236	my ($registry, $klass, @arg) = @_;
256		237
		238	my $object_type;
257	my $prio = 0;	239	my $prio = 0;
258
259	my %undo = (
260	registry => $registry,
261	cb => [],
262	);
263
264	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;
265		241
266	while (@arg) {	242	while (@arg) {
267	my $type = shift @arg;	243	my $type = shift @arg;
268		244
269	if ($type eq "prio") {	245	if ($type eq "prio") {
270	$prio = shift @arg;	246	$prio = shift @arg;
271		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
272	} elsif ($type eq "package") {	257	} elsif ($type eq "package") {
273	my $pkg = shift @arg;	258	my $pkg = shift @arg;
274		259
275	while (my ($name, $id) = each %cb_id) {	260	while (my ($name, $id) = each %cb_id) {
276	if (my $cb = $pkg->can ($name)) {	261	if (my $cb = $pkg->can ($name)) {
277	_attach_cb $registry, %undo, $id, $prio, $cb;	262	_attach_cb $registry, $id, $prio, $cb;
278	}	263	}
279	}	264	}
280		265
281	} elsif (exists $cb_id{$type}) {	266	} elsif (exists $cb_id{$type}) {
282	_attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;	267	_attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
283		268
284	} elsif (ref $type) {	269	} elsif (ref $type) {
285	warn "attaching objects not supported, ignoring.\n";	270	warn "attaching objects not supported, ignoring.\n";
286		271
287	} else {	272	} else {
288	shift @arg;	273	shift @arg;
289	warn "attach argument '$type' not supported, ignoring.\n";	274	warn "attach argument '$type' not supported, ignoring.\n";
290	}	275	}
291	}	276	}
292
293	\%undo
294	}	277	}
295		278
296	sub _attach_attachment {	279	sub _object_attach {
297	my ($obj, $name, %arg) = @_;	280	my ($obj, $name, %arg) = @_;
298		281
299	return if exists $obj->{_attachment}{$name};	282	return if exists $obj->{_attachment}{$name};
300
301	my $res;
302		283
303	if (my $attach = $attachment{$name}) {	284	if (my $attach = $attachment{$name}) {
304	my $registry = $obj->registry;	285	my $registry = $obj->registry;
305		286
306	for (@$attach) {	287	for (@$attach) {
307	my ($klass, @attach) = @$_;	288	my ($klass, @attach) = @$_;
308	$res = _attach @$registry, $klass, @attach;	289	_attach $registry, $klass, @attach;
309	}	290	}
310		291
311	$obj->{$name} = \%arg;	292	$obj->{$name} = \%arg;
312	} else {	293	} else {
313	warn "object uses attachment '$name' that is not available, postponing.\n";	294	warn "object uses attachment '$name' that is not available, postponing.\n";
314	}	295	}
315		296
316	$obj->{_attachment}{$name} = undef;	297	$obj->{_attachment}{$name} = undef;
317
318	$res->{attachment} = $name;
319	$res
320	}	298	}
321		299
322	*cf::object::attach =	300	sub cf::attachable::attach {
323	*cf::player::attach =	301	if (ref $_[0]) {
324	*cf::map::attach = sub {	302	_object_attach @_;
325	my ($obj, $name, %arg) = @_;	303	} else {
326		304	_attach shift->_attach_registry, @_;
327	_attach_attachment $obj, $name, %arg;	305	}
328	};	306	};
329		307
330	# all those should be optimised	308	# all those should be optimised
331	*cf::object::detach =	309	sub cf::attachable::detach {
332	*cf::player::detach =
333	*cf::map::detach = sub {
334	my ($obj, $name) = @_;	310	my ($obj, $name) = @_;
335		311
		312	if (ref $obj) {
336	delete $obj->{_attachment}{$name};	313	delete $obj->{_attachment}{$name};
337	reattach ($obj);	314	reattach ($obj);
		315	} else {
		316	Carp::croak "cannot, currently, detach class attachments";
		317	}
338	};	318	};
339		319
340	*cf::object::attached =	320	sub cf::attachable::attached {
341	*cf::player::attached =
342	*cf::map::attached = sub {
343	my ($obj, $name) = @_;	321	my ($obj, $name) = @_;
344		322
345	exists $obj->{_attachment}{$name}	323	exists $obj->{_attachment}{$name}
346	};
347
348	sub attach_global {
349	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
350	}	324	}
351		325
352	sub attach_to_type {	326	for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {
353	my $type = shift;	327	eval "#line " . __LINE__ . " 'cf.pm'
354	my $subtype = shift;	328	sub cf::\L$klass\E::_attach_registry {
		329	(\\\@CB_$klass, KLASS_$klass)
		330	}
355		331
356	_attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_	332	sub cf::\L$klass\E::attachment {
357	}
358
359	sub attach_to_objects {
360	_attach @CB_OBJECT, KLASS_OBJECT, @_
361	}
362
363	sub attach_to_players {
364	_attach @CB_PLAYER, KLASS_PLAYER, @_
365	}
366
367	sub attach_to_maps {
368	_attach @CB_MAP, KLASS_MAP, @_
369	}
370
371	sub register_attachment {
372	my $name = shift;	333	my \$name = shift;
373		334
374	$attachment{$name} = [[KLASS_OBJECT, @_]];
375	}
376
377	sub register_player_attachment {
378	my $name = shift;
379
380	$attachment{$name} = [[KLASS_PLAYER, @_]];
381	}
382
383	sub register_map_attachment {
384	my $name = shift;
385
386	$attachment{$name} = [[KLASS_MAP, @_]];	335	\$attachment{\$name} = [[KLASS_$klass, \@_]];
		336	}
		337	";
		338	die if $@;
387	}	339	}
388		340
389	our $override;	341	our $override;
390	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?
391		343
…		…
421		373
422	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)	374	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
423		375
424	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)	376	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
425		377
		378	=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
		379
426	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)	380	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
427		381
428	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.
429		383
430	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
…		…
435		389
436	=cut	390	=cut
437		391
438	#############################################################################	392	#############################################################################
439		393
440	=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.
441		397
442	=over 4	398	=over 4
443		399
444	=item $object->valid, $player->valid, $map->valid	400	=item $object->valid
445		401
446	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
447	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
448	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
449	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
…		…
451		407
452	=back	408	=back
453		409
454	=cut	410	=cut
455		411
456	*cf::object::valid =
457	*cf::player::valid =
458	*cf::map::valid = \&cf::_valid;
459
460	#############################################################################	412	#############################################################################
461	# object support	413	# object support
462		414
463	sub instantiate {	415	sub instantiate {
464	my ($obj, $data) = @_;	416	my ($obj, $data) = @_;
…		…
483		435
484	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {	436	for my $name (keys %{ $obj->{_attachment} \|\| {} }) {
485	if (my $attach = $attachment{$name}) {	437	if (my $attach = $attachment{$name}) {
486	for (@$attach) {	438	for (@$attach) {
487	my ($klass, @attach) = @$_;	439	my ($klass, @attach) = @$_;
488	_attach @$registry, $klass, @attach;	440	_attach $registry, $klass, @attach;
489	}	441	}
490	} else {	442	} else {
491	warn "object uses attachment '$name' that is not available, postponing.\n";	443	warn "object uses attachment '$name' that is not available, postponing.\n";
492	}	444	}
493	}	445	}
…		…
522	unlink $filename;	474	unlink $filename;
523	unlink "$filename.pst";	475	unlink "$filename.pst";
524	}	476	}
525	}	477	}
526		478
		479	sub object_freezer_as_string {
		480	my ($rdata, $objs) = @_;
		481
		482	use Data::Dumper;
		483
		484	$$rdata . Dumper $objs
		485	}
		486
527	sub object_thawer_load {	487	sub object_thawer_load {
528	my ($filename) = @_;	488	my ($filename) = @_;
529		489
530	local $/;	490	local $/;
531		491
…		…
541	}	501	}
542		502
543	()	503	()
544	}	504	}
545		505
546	attach_to_objects	506	cf::object->attach (
547	prio => -1000000,	507	prio => -1000000,
548	on_clone => sub {	508	on_clone => sub {
549	my ($src, $dst) = @_;	509	my ($src, $dst) = @_;
550		510
551	@{$dst->registry} = @{$src->registry};	511	@{$dst->registry} = @{$src->registry};
…		…
553	%$dst = %$src;	513	%$dst = %$src;
554		514
555	%{$dst->{_attachment}} = %{$src->{_attachment}}	515	%{$dst->{_attachment}} = %{$src->{_attachment}}
556	if exists $src->{_attachment};	516	if exists $src->{_attachment};
557	},	517	},
558	;	518	);
559		519
560	#############################################################################	520	#############################################################################
561	# old plug-in events	521	# command handling &c
562		522
563	sub inject_event {	523	=item cf::register_command $name => \&callback($ob,$args);
564	my $extension = shift;
565	my $event_code = shift;
566		524
567	my $cb = $hook[$event_code]{$extension}	525	Register a callback for execution when the client sends the user command
568	or return;	526	$name.
569		527
570	&$cb	528	=cut
571	}
572
573	sub inject_global_event {
574	my $event = shift;
575
576	my $cb = $hook[$event]
577	or return;
578
579	List::Util::max map &$_, values %$cb
580	}
581
582	sub inject_command {
583	my ($name, $obj, $params) = @_;
584
585	for my $cmd (@{ $command{$name} }) {
586	$cmd->[1]->($obj, $params);
587	}
588
589	-1
590	}
591		529
592	sub register_command {	530	sub register_command {
593	my ($name, $time, $cb) = @_;	531	my ($name, $cb) = @_;
594		532
595	my $caller = caller;	533	my $caller = caller;
596	#warn "registering command '$name/$time' to '$caller'";	534	#warn "registering command '$name/$time' to '$caller'";
597		535
598	push @{ $command{$name} }, [$time, $cb, $caller];	536	push @{ $COMMAND{$name} }, [$caller, $cb];
599	$COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
600	}	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
601		547
602	sub register_extcmd {	548	sub register_extcmd {
603	my ($name, $cb) = @_;	549	my ($name, $cb) = @_;
604		550
605	my $caller = caller;	551	my $caller = caller;
606	#warn "registering extcmd '$name' to '$caller'";	552	#warn "registering extcmd '$name' to '$caller'";
607		553
608	$extcmd{$name} = [$cb, $caller];	554	$EXTCMD{$name} = [$cb, $caller];
609	}	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	);
610		588
611	sub register {	589	sub register {
612	my ($base, $pkg) = @_;	590	my ($base, $pkg) = @_;
613		591
614	#TODO	592	#TODO
…		…
633	. "#line 1 \"$path\"\n{\n"	611	. "#line 1 \"$path\"\n{\n"
634	. (do { local $/; <$fh> })	612	. (do { local $/; <$fh> })
635	. "\n};\n1";	613	. "\n};\n1";
636		614
637	eval $source	615	eval $source
638	or die "$path: $@";	616	or die $@ ? "$path: $@\n"
		617	: "extension disabled.\n";
639		618
640	push @exts, $pkg;	619	push @exts, $pkg;
641	$ext_pkg{$base} = $pkg;	620	$ext_pkg{$base} = $pkg;
642		621
643	# no strict 'refs';	622	# no strict 'refs';
…		…
656	# for my $idx (0 .. $#PLUGIN_EVENT) {	635	# for my $idx (0 .. $#PLUGIN_EVENT) {
657	# delete $hook[$idx]{$pkg};	636	# delete $hook[$idx]{$pkg};
658	# }	637	# }
659		638
660	# remove commands	639	# remove commands
661	for my $name (keys %command) {	640	for my $name (keys %COMMAND) {
662	my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };	641	my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
663		642
664	if (@cb) {	643	if (@cb) {
665	$command{$name} = \@cb;	644	$COMMAND{$name} = \@cb;
666	$COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
667	} else {	645	} else {
668	delete $command{$name};
669	delete $COMMAND{"$name\000"};	646	delete $COMMAND{$name};
670	}	647	}
671	}	648	}
672		649
673	# remove extcmds	650	# remove extcmds
674	for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {	651	for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
675	delete $extcmd{$name};	652	delete $EXTCMD{$name};
676	}	653	}
677		654
678	if (my $cb = $pkg->can ("unload")) {	655	if (my $cb = $pkg->can ("unload")) {
679	eval {	656	eval {
680	$cb->($pkg);	657	$cb->($pkg);
…		…
684		661
685	Symbol::delete_package $pkg;	662	Symbol::delete_package $pkg;
686	}	663	}
687		664
688	sub load_extensions {	665	sub load_extensions {
689	my $LIBDIR = maps_directory "perl";
690
691	for my $ext (<$LIBDIR/*.ext>) {	666	for my $ext (<$LIBDIR/*.ext>) {
692	next unless -r $ext;	667	next unless -r $ext;
693	eval {	668	eval {
694	load_extension $ext;	669	load_extension $ext;
695	1	670	1
696	} or warn "$ext not loaded: $@";	671	} or warn "$ext not loaded: $@";
697	}	672	}
698	}	673	}
699		674
700	#############################################################################	675	#############################################################################
701	# extcmd framework, basically convert ext <msg>
702	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
703
704	attach_to_players
705	on_extcmd => sub {
706	my ($pl, $buf) = @_;
707
708	my $msg = eval { from_json $buf };
709
710	if (ref $msg) {
711	if (my $cb = $extcmd{$msg->{msgtype}}) {
712	if (my %reply = $cb->[0]->($pl, $msg)) {
713	$pl->ext_reply ($msg->{msgid}, %reply);
714	}
715	}
716	} else {
717	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
718	}
719
720	cf::override;
721	},
722	;
723
724	#############################################################################
725	# load/save/clean perl data associated with a map	676	# load/save/clean perl data associated with a map
726		677
727	*cf::mapsupport::on_clean = sub {	678	*cf::mapsupport::on_clean = sub {
728	my ($map) = @_;	679	my ($map) = @_;
729		680
…		…
731	defined $path or return;	682	defined $path or return;
732		683
733	unlink "$path.pst";	684	unlink "$path.pst";
734	};	685	};
735		686
736	attach_to_maps prio => -10000, package => cf::mapsupport::;	687	cf::map->attach (prio => -10000, package => cf::mapsupport::);
737		688
738	#############################################################################	689	#############################################################################
739	# load/save perl data associated with player->ob objects	690	# load/save perl data associated with player->ob objects
740		691
741	sub all_objects(@) {	692	sub all_objects(@) {
742	@_, map all_objects ($_->inv), @_	693	@_, map all_objects ($_->inv), @_
743	}	694	}
744		695
745	# TODO: compatibility cruft, remove when no longer needed	696	# TODO: compatibility cruft, remove when no longer needed
746	attach_to_players	697	cf::player->attach (
747	on_load => sub {	698	on_load => sub {
748	my ($pl, $path) = @_;	699	my ($pl, $path) = @_;
749		700
750	for my $o (all_objects $pl->ob) {	701	for my $o (all_objects $pl->ob) {
751	if (my $value = $o->get_ob_key_value ("_perl_data")) {	702	if (my $value = $o->get_ob_key_value ("_perl_data")) {
…		…
753		704
754	%$o = %{ Storable::thaw pack "H*", $value };	705	%$o = %{ Storable::thaw pack "H*", $value };
755	}	706	}
756	}	707	}
757	},	708	},
758	;	709	);
759		710
760	#############################################################################	711	#############################################################################
761		712
762	=head2 CORE EXTENSIONS	713	=head2 CORE EXTENSIONS
763		714
…		…
774	sub cf::player::exists($) {	725	sub cf::player::exists($) {
775	cf::player::find $_[0]	726	cf::player::find $_[0]
776	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;
777	}	728	}
778		729
779	=item $object->reply ($npc, $msg[, $flags])	730	=item $player_object->reply ($npc, $msg[, $flags])
780		731
781	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>
782	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
783	dialogue with the given NPC character.	734	dialogue with the given NPC character.
784		735
…		…
811	$msg{msgid} = $id;	762	$msg{msgid} = $id;
812		763
813	$self->send ("ext " . to_json \%msg);	764	$self->send ("ext " . to_json \%msg);
814	}	765	}
815		766
816	=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	}
817		782
818	=cut	783	=cut
819		784
820	#############################################################################	785	#############################################################################
821		786
…		…
823		788
824	Functions that provide a safe environment to compile and execute	789	Functions that provide a safe environment to compile and execute
825	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
826	itself. Looping constructs, I/O operators and other built-in functionality	791	itself. Looping constructs, I/O operators and other built-in functionality
827	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
828	functions and methods that cna be called is greatly reduced.	793	functions and methods that can be called is greatly reduced.
829		794
830	=cut	795	=cut
831		796
832	our $safe = new Safe "safe";	797	our $safe = new Safe "safe";
833	our $safe_hole = new Safe::Hole;	798	our $safe_hole = new Safe::Hole;
…		…
840		805
841	=pod	806	=pod
842		807
843	The following fucntions and emthods are available within a safe environment:	808	The following fucntions and emthods are available within a safe environment:
844		809
845	cf::object contr pay_amount pay_player	810	cf::object contr pay_amount pay_player map
846	cf::object::player player	811	cf::object::player player
847	cf::player peaceful	812	cf::player peaceful
		813	cf::map trigger
848		814
849	=cut	815	=cut
850		816
851	for (	817	for (
852	["cf::object" => qw(contr pay_amount pay_player)],	818	["cf::object" => qw(contr pay_amount pay_player map)],
853	["cf::object::player" => qw(player)],	819	["cf::object::player" => qw(player)],
854	["cf::player" => qw(peaceful)],	820	["cf::player" => qw(peaceful)],
		821	["cf::map" => qw(trigger)],
855	) {	822	) {
856	no strict 'refs';	823	no strict 'refs';
857	my ($pkg, @funs) = @$_;	824	my ($pkg, @funs) = @$_;
858	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	825	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
859	for @funs;	826	for @funs;
…		…
969		936
970	Immediately write the database to disk I<if it is dirty>.	937	Immediately write the database to disk I<if it is dirty>.
971		938
972	=cut	939	=cut
973		940
		941	our $DB;
		942
974	{	943	{
975	my $db;
976	my $path = cf::localdir . "/database.pst";	944	my $path = cf::localdir . "/database.pst";
977		945
978	sub db_load() {	946	sub db_load() {
979	warn "loading database $path\n";#d# remove later	947	warn "loading database $path\n";#d# remove later
980	$db = stat $path ? Storable::retrieve $path : { };	948	$DB = stat $path ? Storable::retrieve $path : { };
981	}	949	}
982		950
983	my $pid;	951	my $pid;
984		952
985	sub db_save() {	953	sub db_save() {
986	warn "saving database $path\n";#d# remove later	954	warn "saving database $path\n";#d# remove later
987	waitpid $pid, 0 if $pid;	955	waitpid $pid, 0 if $pid;
988	if (0 == ($pid = fork)) {	956	if (0 == ($pid = fork)) {
989	$db->{_meta}{version} = 1;	957	$DB->{_meta}{version} = 1;
990	Storable::nstore $db, "$path~";	958	Storable::nstore $DB, "$path~";
991	rename "$path~", $path;	959	rename "$path~", $path;
992	cf::_exit 0 if defined $pid;	960	cf::_exit 0 if defined $pid;
993	}	961	}
994	}	962	}
995		963
…		…
998	sub db_sync() {	966	sub db_sync() {
999	db_save if $dirty;	967	db_save if $dirty;
1000	undef $dirty;	968	undef $dirty;
1001	}	969	}
1002		970
1003	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 {
1004	db_sync;	972	db_sync;
1005	});	973	});
1006		974
1007	sub db_dirty() {	975	sub db_dirty() {
1008	$dirty = 1;	976	$dirty = 1;
1009	$idle->start;	977	$idle->start;
1010	}	978	}
1011		979
1012	sub db_get($;$) {	980	sub db_get($;$) {
1013	@_ >= 2	981	@_ >= 2
1014	? $db->{$_[0]}{$_[1]}	982	? $DB->{$_[0]}{$_[1]}
1015	: ($db->{$_[0]} \|\|= { })	983	: ($DB->{$_[0]} \|\|= { })
1016	}	984	}
1017		985
1018	sub db_put($$;$) {	986	sub db_put($$;$) {
1019	if (@_ >= 3) {	987	if (@_ >= 3) {
1020	$db->{$_[0]}{$_[1]} = $_[2];	988	$DB->{$_[0]}{$_[1]} = $_[2];
1021	} else {	989	} else {
1022	$db->{$_[0]} = $_[1];	990	$DB->{$_[0]} = $_[1];
1023	}	991	}
1024	db_dirty;	992	db_dirty;
1025	}	993	}
1026		994
1027	attach_global	995	cf::global->attach (
1028	prio => 10000,	996	prio => 10000,
1029	on_cleanup => sub {	997	on_cleanup => sub {
1030	db_sync;	998	db_sync;
1031	},	999	},
1032	;	1000	);
1033	}	1001	}
1034		1002
1035	#############################################################################	1003	#############################################################################
1036	# the server's main()	1004	# the server's main()
1037		1005
…		…
1058		1026
1059	$msg->("reloading...");	1027	$msg->("reloading...");
1060		1028
1061	eval {	1029	eval {
1062	# cancel all watchers	1030	# cancel all watchers
1063	$_->cancel for Event::all_watchers;	1031	for (Event::all_watchers) {
		1032	$_->cancel if $_->data & WF_AUTOCANCEL;
		1033	}
1064		1034
1065	# unload all extensions	1035	# unload all extensions
1066	for (@exts) {	1036	for (@exts) {
1067	$msg->("unloading <$_>");	1037	$msg->("unloading <$_>");
1068	unload_extension $_;	1038	unload_extension $_;
…		…
1128	warn $_[0];	1098	warn $_[0];
1129	print "$_[0]\n";	1099	print "$_[0]\n";
1130	};	1100	};
1131	}	1101	}
1132		1102
		1103	register "<global>", __PACKAGE__;
		1104
1133	register_command "perl-reload", 0, sub {	1105	register_command "perl-reload" => sub {
1134	my ($who, $arg) = @_;	1106	my ($who, $arg) = @_;
1135		1107
1136	if ($who->flag (FLAG_WIZ)) {	1108	if ($who->flag (FLAG_WIZ)) {
1137	_perl_reload {	1109	_perl_reload {
1138	warn $_[0];	1110	warn $_[0];
1139	$who->message ($_[0]);	1111	$who->message ($_[0]);
1140	};	1112	};
1141	}	1113	}
1142	};	1114	};
1143		1115
1144	register "<global>", __PACKAGE__;
1145
1146	unshift @INC, $LIBDIR;	1116	unshift @INC, $LIBDIR;
1147		1117
1148	$TICK_WATCHER = Event->timer (	1118	$TICK_WATCHER = Event->timer (
1149	prio => 1,	1119	prio => 0,
1150	at => $NEXT_TICK \|\| 1,	1120	at => $NEXT_TICK \|\| 1,
		1121	data => WF_AUTOCANCEL,
1151	cb => sub {	1122	cb => sub {
1152	cf::server_tick; # one server iteration	1123	cf::server_tick; # one server iteration
1153		1124
1154	my $NOW = Event::time;	1125	my $NOW = Event::time;
1155	$NEXT_TICK += $TICK;	1126	$NEXT_TICK += $TICK;
1156		1127
1157	# if we are delayed by four ticks, skip them all	1128	# if we are delayed by four ticks or more, skip them all
1158	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;	1129	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1159		1130
1160	$TICK_WATCHER->at ($NEXT_TICK);	1131	$TICK_WATCHER->at ($NEXT_TICK);
1161	$TICK_WATCHER->start;	1132	$TICK_WATCHER->start;
1162	},	1133	},
1163	);	1134	);
1164		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
1165	1	1144	1
1166		1145

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.76 by root, Mon Oct 2 15:28:36 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.76 by root, Mon Oct 2 15:28:36 2006 UTC vs.
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC