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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.78 by root, Tue Nov 7 00:15:27 2006 UTC vs.
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC

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

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.78 by root, Tue Nov 7 00:15:27 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.78 by root, Tue Nov 7 00:15:27 2006 UTC vs.
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC