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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.41 by root, Fri Aug 25 15:25:12 2006 UTC vs.
Revision 1.45 by root, Sat Aug 26 23:36:32 2006 UTC

…		…
13		13
14	use strict;	14	use strict;
15		15
16	our %COMMAND = ();	16	our %COMMAND = ();
17	our @EVENT;	17	our @EVENT;
18	our @PLUGIN_EVENT;
19	our %PROP_TYPE;	18	our %PROP_TYPE;
20	our %PROP_IDX;	19	our %PROP_IDX;
21	our $LIBDIR = maps_directory "perl";	20	our $LIBDIR = maps_directory "perl";
22		21
23	our $TICK = MAX_TIME * 1e-6;	22	our $TICK = MAX_TIME * 1e-6;
24	our $TICK_WATCHER;	23	our $TICK_WATCHER;
25	our $NEXT_TICK;	24	our $NEXT_TICK;
26		25
27	BEGIN {	26	BEGIN {
28	@PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30	*CORE::GLOBAL::warn = sub {	27	*CORE::GLOBAL::warn = sub {
31	my $msg = join "", @_;	28	my $msg = join "", @_;
32	$msg .= "\n"	29	$msg .= "\n"
33	unless $msg =~ /\n$/;	30	unless $msg =~ /\n$/;
34		31
…		…
69	prop_gen PLAYER_PROP => "cf::object::player";	66	prop_gen PLAYER_PROP => "cf::object::player";
70		67
71	prop_gen MAP_PROP => "cf::map";	68	prop_gen MAP_PROP => "cf::map";
72	prop_gen ARCH_PROP => "cf::arch";	69	prop_gen ARCH_PROP => "cf::arch";
73		70
74	# guessed hierarchies
75
76	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';	71	@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77	@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78		72
79	# we bless all objects into (empty) derived classes to force a method lookup	73	# we bless all objects into (empty) derived classes to force a method lookup
80	# within the Safe compartment.	74	# within the Safe compartment.
81	for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {	75	for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82	no strict 'refs';	76	no strict 'refs';
83	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;	77	@{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84	}	78	}
85		79
86	$Event::DIED = sub {	80	$Event::DIED = sub {
…		…
92	my @hook;	86	my @hook;
93	my %command;	87	my %command;
94	my %extcmd;	88	my %extcmd;
95		89
96	#############################################################################	90	#############################################################################
		91	# utility functions
		92
		93	use JSON::Syck (); # TODO# replace by JSON::PC once working
		94
		95	sub from_json($) {
		96	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
		97	JSON::Syck::Load $_[0]
		98	}
		99
		100	sub to_json($) {
		101	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
		102	JSON::Syck::Dump $_[0]
		103	}
		104
		105	#############################################################################
97	# "new" plug-in system	106	# "new" plug-in system
98		107
99	=item cf::object::attach ... # NYI	108	=item cf::object::attach ... # NYI
100		109
101	=item cf::attach_global ...	110	=item cf::attach_global ...
102		111
103	=item cf::attach_to_type ...	112	=item cf::attach_to_type $object_type, ...
104		113
105	=item cf::attach_to_objects ...	114	=item cf::attach_to_objects ...
106		115
107	=item cf::attach_to_players ...	116	=item cf::attach_to_players ...
108		117
109	=item cf::attach_to_maps ...	118	=item cf::attach_to_maps ...
		119
		120	=item cf:register_attachment $name, ...
110		121
111	prio => $number, # lower is earlier	122	prio => $number, # lower is earlier
112	on_xxx => \&cb,	123	on_xxx => \&cb,
113	package => package::,	124	package => package::,
114		125
115	=cut	126	=cut
116		127
117	# the following variables are defined in .xs and must not be re-created	128	# the following variables are defined in .xs and must not be re-created
118	our @CB_GLOBAL = (); # registry for all global events	129	our @CB_GLOBAL = (); # registry for all global events
119	our @CB_OBJECT = ();	130	our @CB_OBJECT = (); # all objects (should not be used except in emergency)
120	our @CB_PLAYER = ();	131	our @CB_PLAYER = ();
121	our @CB_TYPE = (); # registry for type (cf-object class) based events	132	our @CB_TYPE = (); # registry for type (cf-object class) based events
122	our @CB_MAP = ();	133	our @CB_MAP = ();
123		134
		135	my %attachment;
		136
124	sub _attach_cb($\%$$$) {	137	sub _attach_cb($\%$$$) {
125	my ($registry, $undo, $event, $prio, $cb) = @_;	138	my ($registry, $undo, $event, $prio, $cb) = @_;
126		139
127	use sort 'stable';	140	use sort 'stable';
128		141
…		…
136	}	149	}
137		150
138	# attach handles attaching event callbacks	151	# attach handles attaching event callbacks
139	# the only thing the caller has to do is pass the correct	152	# the only thing the caller has to do is pass the correct
140	# registry (== where the callback attaches to).	153	# registry (== where the callback attaches to).
141	sub _attach(\@$\@) {	154	sub _attach(\@$@) {
142	my ($registry, $klass, $arg) = @_;	155	my ($registry, $klass, @arg) = @_;
143		156
144	my $prio = 0;	157	my $prio = 0;
145		158
146	my %undo = (	159	my %undo = (
147	registry => $registry,	160	registry => $registry,
148	cb => [],	161	cb => [],
149	);	162	);
150		163
151	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;	164	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
152		165
153	while (@$arg) {	166	while (@arg) {
154	my $type = shift @$arg;	167	my $type = shift @arg;
155		168
156	if ($type eq "prio") {	169	if ($type eq "prio") {
157	$prio = shift @$arg;	170	$prio = shift @arg;
158		171
159	} elsif ($type eq "package") {	172	} elsif ($type eq "package") {
160	my $pkg = shift @$arg;	173	my $pkg = shift @arg;
161		174
162	while (my ($name, $id) = each %cb_id) {	175	while (my ($name, $id) = each %cb_id) {
163	if (my $cb = $pkg->can ($name)) {	176	if (my $cb = $pkg->can ($name)) {
164	_attach_cb $registry, %undo, $id, $prio, $cb;	177	_attach_cb $registry, %undo, $id, $prio, $cb;
165	}	178	}
166	}	179	}
167		180
168	} elsif (exists $cb_id{$type}) {	181	} elsif (exists $cb_id{$type}) {
169	_attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg;	182	_attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
170		183
171	} elsif (ref $type) {	184	} elsif (ref $type) {
172	warn "attaching objects not supported, ignoring.\n";	185	warn "attaching objects not supported, ignoring.\n";
173		186
174	} else {	187	} else {
175	shift @$arg;	188	shift @arg;
176	warn "attach argument '$type' not supported, ignoring.\n";	189	warn "attach argument '$type' not supported, ignoring.\n";
177	}	190	}
178	}	191	}
179		192
180	\%undo	193	\%undo
…		…
188	_attach @CB_GLOBAL, KLASS_GLOBAL, @_	201	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
189	}	202	}
190		203
191	sub attach_to_type {	204	sub attach_to_type {
192	my $type = shift;	205	my $type = shift;
		206
193	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_	207	_attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_
194	}	208	}
195		209
196	sub attach_to_objects {	210	sub attach_to_objects {
197	_attach @CB_OBJECT, KLASS_OBJECT, @_	211	_attach @CB_OBJECT, KLASS_OBJECT, @_
…		…
203		217
204	sub attach_to_maps {	218	sub attach_to_maps {
205	_attach @CB_MAP, KLASS_MAP, @_	219	_attach @CB_MAP, KLASS_MAP, @_
206	}	220	}
207		221
		222	sub register_attachment {
		223	my $name = shift;
		224
		225	$attachment{$name} = [@_];
		226	}
		227
208	our $override;	228	our $override;
		229	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
209		230
210	sub override() {	231	sub override {
211	$override = 1	232	$override = 1;
		233	@invoke_results = ();
212	}	234	}
213		235
214	sub invoke {	236	sub do_invoke {
215	my $event = shift;	237	my $event = shift;
216	my $callbacks = shift;	238	my $callbacks = shift;
		239
		240	@invoke_results = ();
217		241
218	local $override;	242	local $override;
219		243
220	for (@$callbacks) {	244	for (@$callbacks) {
221	eval { &{$_->[1]} };	245	eval { &{$_->[1]} };
…		…
231		255
232	0	256	0
233	}	257	}
234		258
235	#############################################################################	259	#############################################################################
		260	# object support
		261
		262	sub instantiate {
		263	my ($obj, $data) = @_;
		264	my $registry = $obj->registry;
		265
		266	$data = from_json $data;
		267
		268	for (@$data) {
		269	my ($pri, $name, @args) = @$_;
		270
		271	if (my $attach = $attachment{$name}) {
		272	_attach @$registry, KLASS_OBJECT, @$attach;
		273
		274	if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
		275	for (@$cb) {
		276	eval { $_->[1]->($obj, @args); };
		277	if ($@) {
		278	warn "$@";
		279	warn "... while processing '$name' instantiate with args <@args>\n";
		280	}
		281	}
		282	}
		283	} else {
		284	warn "object uses attachment $name that is not available, postponing.\n";
		285	}
		286
		287	push @{$obj->{_attachment}}, $name;
		288	}
		289	}
		290
		291	# basically do the same as instantiate, without calling instantiate
		292	sub reattach {
		293	my ($obj) = @_;
		294	my $registry = $obj->registry;
		295
		296	warn "reattach<@_, $_>\n";
		297	}
		298
		299	attach_to_objects
		300	prio => -1000000,
		301	on_clone => sub {
		302	my ($src, $dst) = @_;
		303
		304	@{$dst->registry} = @{$src->registry};
		305	warn "registry clone ", join ":", @{$src->registry};#d#
		306
		307	%$dst = %$src;
		308
		309	$dst->{_attachment} = [@{ $src->{_attachment} }]
		310	if exists $src->{_attachment};
		311
		312	warn "clone<@_>\n";#d#
		313	},
		314	;
		315
		316	#############################################################################
236	# old plug-in events	317	# old plug-in events
237		318
238	sub inject_event {	319	sub inject_event {
239	my $extension = shift;	320	my $extension = shift;
240	my $event_code = shift;	321	my $event_code = shift;
…		…
284	}	365	}
285		366
286	sub register {	367	sub register {
287	my ($base, $pkg) = @_;	368	my ($base, $pkg) = @_;
288		369
289	for my $idx (0 .. $#PLUGIN_EVENT) {	370	#TODO
290	if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
291	#warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
292	$hook[$idx]{$base} = $ref;
293	}
294	}
295	}	371	}
296		372
297	sub load_extension {	373	sub load_extension {
298	my ($path) = @_;	374	my ($path) = @_;
299		375
…		…
330	my ($pkg) = @_;	406	my ($pkg) = @_;
331		407
332	warn "removing extension $pkg\n";	408	warn "removing extension $pkg\n";
333		409
334	# remove hooks	410	# remove hooks
		411	#TODO
335	for my $idx (0 .. $#PLUGIN_EVENT) {	412	# for my $idx (0 .. $#PLUGIN_EVENT) {
336	delete $hook[$idx]{$pkg};	413	# delete $hook[$idx]{$pkg};
337	}	414	# }
338		415
339	# remove commands	416	# remove commands
340	for my $name (keys %command) {	417	for my $name (keys %command) {
341	my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };	418	my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
342		419
…		…
352	# remove extcmds	429	# remove extcmds
353	for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {	430	for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
354	delete $extcmd{$name};	431	delete $extcmd{$name};
355	}	432	}
356		433
357	if (my $cb = $pkg->can ("on_unload")) {	434	if (my $cb = $pkg->can ("unload")) {
358	eval {	435	eval {
359	$cb->($pkg);	436	$cb->($pkg);
360	1	437	1
361	} or warn "$pkg unloaded, but with errors: $@";	438	} or warn "$pkg unloaded, but with errors: $@";
362	}	439	}
…		…
408	Symbol::delete_package $k;	485	Symbol::delete_package $k;
409	}	486	}
410		487
411	# 4. get rid of safe::, as good as possible	488	# 4. get rid of safe::, as good as possible
412	Symbol::delete_package "safe::$_"	489	Symbol::delete_package "safe::$_"
413	for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);	490	for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
414		491
415	# 5. remove register_script_function callbacks	492	# 5. remove register_script_function callbacks
416	# TODO	493	# TODO
417		494
418	# 6. unload cf.pm "a bit"	495	# 6. unload cf.pm "a bit"
…		…
448	};	525	};
449	}	526	}
450	};	527	};
451		528
452	#############################################################################	529	#############################################################################
453	# utility functions
454
455	use JSON::Syck (); # TODO# replace by JSON::PC once working
456
457	sub from_json($) {
458	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
459	JSON::Syck::Load $_[0]
460	}
461
462	sub to_json($) {
463	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
464	JSON::Syck::Dump $_[0]
465	}
466
467	#############################################################################
468	# extcmd framework, basically convert ext <msg>	530	# extcmd framework, basically convert ext <msg>
469	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few	531	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
470		532
471	sub on_extcmd {	533	attach_to_players
		534	on_extcmd => sub {
472	my ($pl, $buf) = @_;	535	my ($pl, $buf) = @_;
473		536
474	my $msg = eval { from_json $buf };	537	my $msg = eval { from_json $buf };
475		538
476	if (ref $msg) {	539	if (ref $msg) {
477	if (my $cb = $extcmd{$msg->{msgtype}}) {	540	if (my $cb = $extcmd{$msg->{msgtype}}) {
478	if (my %reply = $cb->[0]->($pl, $msg)) {	541	if (my %reply = $cb->[0]->($pl, $msg)) {
479	$pl->ext_reply ($msg->{msgid}, %reply);	542	$pl->ext_reply ($msg->{msgid}, %reply);
		543	}
480	}	544	}
		545	} else {
		546	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
481	}	547	}
482	} else {	548
483	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	549	cf::override;
484	}	550	},
485		551	;
486	1
487	}
488		552
489	#############################################################################	553	#############################################################################
490	# load/save/clean perl data associated with a map	554	# load/save/clean perl data associated with a map
491		555
492	*cf::mapsupport::on_clean = sub {	556	*cf::mapsupport::on_clean = sub {
…		…
624	}	688	}
625		689
626	#############################################################################	690	#############################################################################
627	# map scripting support	691	# map scripting support
628		692
629	our $safe = new Safe "ext";	693	our $safe = new Safe "safe";
630	our $safe_hole = new Safe::Hole;	694	our $safe_hole = new Safe::Hole;
631		695
632	$SIG{FPE} = 'IGNORE';	696	$SIG{FPE} = 'IGNORE';
633		697
634	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	698	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
…		…
654	$qcode =~ s/\n/\\n/g;	718	$qcode =~ s/\n/\\n/g;
655		719
656	local $_;	720	local $_;
657	local @safe::cf::_safe_eval_args = values %vars;	721	local @safe::cf::_safe_eval_args = values %vars;
658		722
659	$code =	723	my $eval =
660	"do {\n"	724	"do {\n"
661	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"	725	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
662	. "#line 0 \"{$qcode}\"\n"	726	. "#line 0 \"{$qcode}\"\n"
663	. $code	727	. $code
664	. "\n}"	728	. "\n}"
665	;	729	;
666		730
667	sub_generation_inc;	731	sub_generation_inc;
668	my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code);	732	my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
669	sub_generation_inc;	733	sub_generation_inc;
		734
		735	if ($@) {
		736	warn "$@";
		737	warn "while executing safe code '$code'\n";
		738	warn "with arguments " . (join " ", %vars) . "\n";
		739	}
670		740
671	wantarray ? @res : $res[0]	741	wantarray ? @res : $res[0]
672	}	742	}
673		743
674	sub register_script_function {	744	sub register_script_function {

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.41 by root, Fri Aug 25 15:25:12 2006 UTC vs. Revision 1.45 by root, Sat Aug 26 23:36:32 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.41 by root, Fri Aug 25 15:25:12 2006 UTC vs.
Revision 1.45 by root, Sat Aug 26 23:36:32 2006 UTC