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

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

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.72 by root, Sun Oct 1 11:41: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.72 by root, Sun Oct 1 11:41:37 2006 UTC vs.
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC