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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.18 by root, Tue Jul 11 14:24:15 2006 UTC vs.
Revision 1.39 by root, Fri Aug 25 13:24:50 2006 UTC

…		…
1	package cf;	1	package cf;
2		2
3	use Symbol;	3	use Symbol;
4	use List::Util;	4	use List::Util;
5	use Storable;	5	use Storable;
		6	use Opcode;
		7	use Safe;
		8	use Safe::Hole;
		9
		10	use Time::HiRes;
6	use Event;	11	use Event;
		12	$Event::Eval = 1; # no idea why this is required, but it is
7		13
8	use strict;	14	use strict;
9		15
10	our %COMMAND;	16	our %COMMAND = ();
11	our @EVENT;	17	our @EVENT;
		18	our @PLUGIN_EVENT;
12	our %PROP_TYPE;	19	our %PROP_TYPE;
13	our %PROP_IDX;	20	our %PROP_IDX;
		21	our $LIBDIR = maps_directory "perl";
		22
		23	our $TICK = MAX_TIME * 1e-6;
		24	our $TICK_WATCHER;
		25	our $NEXT_TICK;
14		26
15	BEGIN {	27	BEGIN {
16	@EVENT = map lc, @EVENT;	28	@PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
17		29
18	*CORE::GLOBAL::warn = sub {	30	*CORE::GLOBAL::warn = sub {
19	my $msg = join "", @_;	31	my $msg = join "", @_;
20	$msg .= "\n"	32	$msg .= "\n"
21	unless $msg =~ /\n$/;	33	unless $msg =~ /\n$/;
59	prop_gen MAP_PROP => "cf::map";	71	prop_gen MAP_PROP => "cf::map";
60	prop_gen ARCH_PROP => "cf::arch";	72	prop_gen ARCH_PROP => "cf::arch";
61		73
62	# guessed hierarchies	74	# guessed hierarchies
63		75
64	@cf::object::player::ISA = 'cf::object';	76	@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
65	@cf::object::map::ISA = 'cf::object';	77	@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
		78
		79	# we bless all objects into derived classes to force a method lookup
		80	# 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)) {
		82	no strict 'refs';
		83	@{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
		84	}
66		85
67	$Event::DIED = sub {	86	$Event::DIED = sub {
68	warn "error in event callback: @_";	87	warn "error in event callback: @_";
69	};	88	};
70		89
…		…
72	my @exts;	91	my @exts;
73	my @hook;	92	my @hook;
74	my %command;	93	my %command;
75	my %extcmd;	94	my %extcmd;
76		95
		96	#############################################################################
		97	# "new" plug-in system
		98
		99	=item cf::object::attach ... # NYI
		100
		101	=item cf::attach_global ... # NYI
		102
		103	=item cf::attach_to_type ... # NYI
		104
		105	=item cf::attach_to_objects ... # NYI
		106
		107	=item cf::attach_to_players ... # NYI
		108
		109	=item cf::attach_to_maps ... # NYI
		110
		111	prio => $number, # higehr is earlier
		112	on_xxx => \&cb,
		113	package => package::,
		114
		115	=cut
		116
		117	our %CB_CLASS = (); # registry for class-based events
		118	our @CB_GLOBAL = (); # registry for all global events
		119	our @CB_TYPE = (); # registry for type (cf-object class) based events
		120
		121	sub _attach_cb($\%$$$) {
		122	my ($registry, $undo, $event, $prio, $cb) = @_;
		123
		124	use sort 'stable';
		125
		126	$cb = [$prio, $cb];
		127
		128	@{$registry->[$event]} = sort
		129	{ $a->[0] cmp $b->[0] }
		130	@{$registry->[$event] \|\| []}, $cb;
		131
		132	push @{$undo->{cb}}, [$event, $cb];
		133	}
		134
		135	# attach handles attaching event callbacks
		136	# the only thing the caller has to do is pass the correct
		137	# registry (== where the callback attaches to).
		138	sub _attach(\@$\@) {
		139	my ($registry, $klass, $arg) = @_;
		140
		141	my $prio = 0;
		142
		143	my %undo = (
		144	registry => $registry,
		145	cb => [],
		146	);
		147
		148	my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
		149
		150	while (@$arg) {
		151	my $type = shift @$arg;
		152
		153	if ($type eq "prio") {
		154	$prio = shift @$arg;
		155
		156	} elsif ($type eq "package") {
		157	my $pkg = shift @$arg;
		158
		159	while (my ($name, $id) = each %cb_id) {
		160	if (my $cb = $pkg->can ($name)) {
		161	_attach_cb $registry, %undo, $id, $prio, $cb;
		162	}
		163	}
		164
		165	} elsif (exists $cb_id{$type}) {
		166	_attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg;
		167
		168	} elsif (ref $type) {
		169	warn "attaching objects not supported, ignoring.\n";
		170
		171	} else {
		172	shift @$arg;
		173	warn "attach argument '$type' not supported, ignoring.\n";
		174	}
		175	}
		176
		177	\%undo
		178	}
		179
		180	sub cf::object::attach {
		181	die;
		182	}
		183
		184	sub attach_global {
		185	_attach @CB_GLOBAL, KLASS_GLOBAL, @_
		186	}
		187
		188	sub attach_type {
		189	my $type = shift;
		190	_attach @{$CB_TYPE[$type]}, KLASS_MAP, @_
		191	}
		192
		193	sub attach_to_objects {
		194	_attach @{$CB_CLASS{cf::object::wrap::}}, KLASS_OBJECT, @_
		195	}
		196
		197	sub attach_to_players {
		198	_attach @{$CB_CLASS{cf::player::wrap::}}, KLASS_PLAYER, @_
		199	}
		200
		201	sub attach_to_maps {
		202	_attach @{$CB_CLASS{cf::map::wrap::}}, KLASS_MAP, @_
		203	}
		204
		205	our $override;
		206
		207	sub override() {
		208	$override = 1
		209	}
		210
		211	sub invoke {
		212	my $event = shift;
		213
		214	my @cb;
		215
		216	if (my $ref = ref $_[0]) {
		217	# 1. object-specific (NYI)
		218	# 2. class-specific
		219	push @cb, @{$CB_CLASS{$ref}[$event] \|\| []};
		220	}
		221
		222	# global
		223	push @cb, @{$CB_GLOBAL[$event] \|\| []};
		224
		225	# warn "invoke id $EVENT[$event][0], args <@_> <=> @cb\n";#d#
		226
		227	local $override;
		228
		229	for (@cb) {
		230	eval { &{$_->[1]} };
		231
		232	if ($@) {
		233	warn "$@";
		234	warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n";
		235	override;
		236	}
		237
		238	return 1 if $override;
		239	}
		240
		241	0
		242	}
		243
		244	#############################################################################
		245	# old plug-in events
		246
77	sub inject_event {	247	sub inject_event {
78	my $extension = shift;	248	my $extension = shift;
79	my $event_code = shift;	249	my $event_code = shift;
80		250
81	my $cb = $hook[$event_code]{$extension}	251	my $cb = $hook[$event_code]{$extension}
…		…
123	}	293	}
124		294
125	sub register {	295	sub register {
126	my ($base, $pkg) = @_;	296	my ($base, $pkg) = @_;
127		297
128	for my $idx (0 .. $#EVENT) {	298	for my $idx (0 .. $#PLUGIN_EVENT) {
129	if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {	299	if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
130	#warn "registering $EVENT[$idx] hook to '$pkg'\n";	300	#warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
131	$hook[$idx]{$base} = $ref;	301	$hook[$idx]{$base} = $ref;
132	}	302	}
133	}	303	}
134	}	304	}
135		305
…		…
158		328
159	push @exts, $pkg;	329	push @exts, $pkg;
160	$ext_pkg{$base} = $pkg;	330	$ext_pkg{$base} = $pkg;
161		331
162	# no strict 'refs';	332	# no strict 'refs';
163	# @{"$pkg\::ISA"} = cf::ext::;	333	# @{"$pkg\::ISA"} = ext::;
164		334
165	register $base, $pkg;	335	register $base, $pkg;
166	}	336	}
167		337
168	sub unload_extension {	338	sub unload_extension {
169	my ($pkg) = @_;	339	my ($pkg) = @_;
170		340
171	warn "removing extension $pkg\n";	341	warn "removing extension $pkg\n";
172		342
173	# remove hooks	343	# remove hooks
174	for my $idx (0 .. $#EVENT) {	344	for my $idx (0 .. $#PLUGIN_EVENT) {
175	delete $hook[$idx]{$pkg};	345	delete $hook[$idx]{$pkg};
176	}	346	}
177		347
178	# remove commands	348	# remove commands
179	for my $name (keys %command) {	349	for my $name (keys %command) {
…		…
191	# remove extcmds	361	# remove extcmds
192	for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {	362	for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
193	delete $extcmd{$name};	363	delete $extcmd{$name};
194	}	364	}
195		365
		366	if (my $cb = $pkg->can ("on_unload")) {
		367	eval {
		368	$cb->($pkg);
		369	1
		370	} or warn "$pkg unloaded, but with errors: $@";
		371	}
		372
196	Symbol::delete_package $pkg;	373	Symbol::delete_package $pkg;
197	}	374	}
198		375
199	sub load_extensions {	376	sub load_extensions {
200	my $LIBDIR = maps_directory "perl";	377	my $LIBDIR = maps_directory "perl";
…		…
206	1	383	1
207	} or warn "$ext not loaded: $@";	384	} or warn "$ext not loaded: $@";
208	}	385	}
209	}	386	}
210		387
		388	sub _perl_reload(&) {
		389	my ($msg) = @_;
		390
		391	$msg->("reloading...");
		392
		393	eval {
		394	# 1. cancel all watchers
		395	$_->cancel for Event::all_watchers;
		396
		397	# 2. unload all extensions
		398	for (@exts) {
		399	$msg->("unloading <$_>");
		400	unload_extension $_;
		401	}
		402
		403	# 3. unload all modules loaded from $LIBDIR
		404	while (my ($k, $v) = each %INC) {
		405	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
		406
		407	$msg->("removing <$k>");
		408	delete $INC{$k};
		409
		410	$k =~ s/\.pm$//;
		411	$k =~ s/\//::/g;
		412
		413	if (my $cb = $k->can ("unload_module")) {
		414	$cb->();
		415	}
		416
		417	Symbol::delete_package $k;
		418	}
		419
		420	# 4. get rid of ext::, as good as possible
		421	Symbol::delete_package "ext::$_"
		422	for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
		423
		424	# 5. remove register_script_function callbacks
		425	# TODO
		426
		427	# 6. unload cf.pm "a bit"
		428	delete $INC{"cf.pm"};
		429
		430	# don't, removes xs symbols, too
		431	#Symbol::delete_package __PACKAGE__;
		432
		433	# 7. reload cf.pm
		434	$msg->("reloading cf.pm");
		435	require cf;
		436	};
		437	$msg->($@) if $@;
		438
		439	$msg->("reloaded");
		440	};
		441
		442	sub perl_reload() {
		443	_perl_reload {
		444	warn $_[0];
		445	print "$_[0]\n";
		446	};
		447	}
		448
211	register_command "perl-reload", 0, sub {	449	register_command "perl-reload", 0, sub {
212	my ($who, $arg) = @_;	450	my ($who, $arg) = @_;
213		451
214	if ($who->flag (FLAG_WIZ)) {	452	if ($who->flag (FLAG_WIZ)) {
215	$who->message ("reloading...");	453	_perl_reload {
216		454	warn $_[0];
217	warn "reloading...\n";	455	$who->message ($_[0]);
218	eval {
219	unload_extension $_ for @exts;
220	delete $INC{"cf.pm"};
221
222	# don't, removes xs symbols, too
223	#Symbol::delete_package $pkg;
224
225	require cf;
226	};	456	};
227	warn $@ if $@;
228	$who->message ($@) if $@;
229	warn "reloaded\n";
230
231	$who->message ("reloaded");
232	} else {
233	$who->message ("Intruder Alert!");
234	}	457	}
235	};	458	};
236		459
237	#############################################################################	460	#############################################################################
		461	# utility functions
		462
		463	use JSON::Syck (); # TODO# replace by JSON::PC once working
		464
		465	sub from_json($) {
		466	$JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
		467	JSON::Syck::Load $_[0]
		468	}
		469
		470	sub to_json($) {
		471	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
		472	JSON::Syck::Dump $_[0]
		473	}
		474
		475	#############################################################################
238	# extcmd framework, basically convert ext <id> <pkg> arg1 args	476	# extcmd framework, basically convert ext <msg>
239	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few	477	# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
240		478
241	sub on_extcmd {	479	sub on_extcmd {
242	my ($pl, $buf) = @_;	480	my ($pl, $buf) = @_;
243		481
244	my ($type) = $buf =~ s/^(\S+) // ? $1 : "";	482	my $msg = eval { from_json $buf };
245		483
246	$extcmd{$type}[0]->($pl, $buf)	484	if (ref $msg) {
247	if $extcmd{$type};	485	if (my $cb = $extcmd{$msg->{msgtype}}) {
		486	if (my %reply = $cb->[0]->($pl, $msg)) {
		487	$pl->ext_reply ($msg->{msgid}, %reply);
		488	}
		489	}
		490	} else {
		491	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
		492	}
		493
		494	1
248	}	495	}
249		496
250	#############################################################################	497	#############################################################################
251	# load/save/clean perl data associated with a map	498	# load/save/clean perl data associated with a map
252		499
253	*on_mapclean = sub {	500	*cf::mapsupport::on_clean = sub {
254	my ($map) = @_;	501	my ($map) = @_;
255		502
256	my $path = $map->tmpname;	503	my $path = $map->tmpname;
257	defined $path or return;	504	defined $path or return;
258		505
259	unlink "$path.cfperl";	506	unlink "$path.cfperl";
260	};	507	};
261		508
262	*on_mapin =	509	*cf::mapsupport::on_swapin =
263	*on_mapload = sub {	510	*cf::mapsupport::on_load = sub {
264	my ($map) = @_;	511	my ($map) = @_;
265		512
266	my $path = $map->tmpname;	513	my $path = $map->tmpname;
267	$path = $map->path unless defined $path;	514	$path = $map->path unless defined $path;
268		515
…		…
275	or return; # too new	522	or return; # too new
276		523
277	$map->_set_obs ($data->{obs});	524	$map->_set_obs ($data->{obs});
278	};	525	};
279		526
280	*on_mapout = sub {	527	*cf::mapsupport::on_swapout = sub {
281	my ($map) = @_;	528	my ($map) = @_;
282		529
283	my $path = $map->tmpname;	530	my $path = $map->tmpname;
284	$path = $map->path unless defined $path;	531	$path = $map->path unless defined $path;
285		532
…		…
302	} else {	549	} else {
303	unlink "$path.cfperl";	550	unlink "$path.cfperl";
304	}	551	}
305	};	552	};
306		553
		554	attach_to_maps prio => -10000, package => cf::mapsupport::;
		555
307	#############################################################################	556	#############################################################################
308	# load/save perl data associated with player->ob objects	557	# load/save perl data associated with player->ob objects
309		558
310	*on_player_load = sub {	559	sub all_objects(@) {
		560	@_, map all_objects ($_->inv), @_
		561	}
		562
		563	attach_to_players
		564	on_load => sub {
311	my ($ob, $path) = @_;	565	my ($pl, $path) = @_;
312		566
313	if (open my $fh, "<:raw", "$path.cfperl") {	567	for my $o (all_objects $pl->ob) {
314
315	#d##TODO#remove
316
317	my $data = Storable::thaw do { local $/; <$fh> };
318
319	$data->{version} <= 1
320	or return; # too new
321
322	%$ob = %{$data->{ob}};
323	return;
324	}
325
326	for my $o ($ob, $ob->inv) {
327	if (my $value = $o->get_ob_key_value ("_perl_data")) {	568	if (my $value = $o->get_ob_key_value ("_perl_data")) {
328	$o->set_ob_key_value ("_perl_data");	569	$o->set_ob_key_value ("_perl_data");
329		570
330	%$o = %{ Storable::thaw pack "H*", $value };	571	%$o = %{ Storable::thaw pack "H*", $value };
		572	}
331	}	573	}
332	}	574	},
333	};	575	on_save => sub {
334
335	*on_player_save = sub {
336	my ($ob, $path) = @_;	576	my ($pl, $path) = @_;
337		577
338	$_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)	578	$_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
339	for grep %$_, $ob, $ob->inv;	579	for grep %$_, all_objects $pl->ob;
		580	},
		581	;
340		582
341	unlink "$path.cfperl";#d##TODO#remove	583	#############################################################################
342	};	584	# core extensions - in perl
		585
		586	=item cf::player::exists $login
		587
		588	Returns true when the given account exists.
		589
		590	=cut
		591
		592	sub cf::player::exists($) {
		593	cf::player::find $_[0]
		594	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
		595	}
		596
		597	=item $player->reply ($npc, $msg[, $flags])
		598
		599	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
		600	can be C<undef>. Does the right thing when the player is currently in a
		601	dialogue with the given NPC character.
		602
		603	=cut
		604
		605	# rough implementation of a future "reply" method that works
		606	# with dialog boxes.
		607	sub cf::object::player::reply($$$;$) {
		608	my ($self, $npc, $msg, $flags) = @_;
		609
		610	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;
		611
		612	if ($self->{record_replies}) {
		613	push @{ $self->{record_replies} }, [$npc, $msg, $flags];
		614	} else {
		615	$msg = $npc->name . " says: $msg" if $npc;
		616	$self->message ($msg, $flags);
		617	}
		618	}
		619
		620	=item $player->ext_reply ($msgid, $msgtype, %msg)
		621
		622	Sends an ext reply to the player.
		623
		624	=cut
		625
		626	sub cf::player::ext_reply($$$%) {
		627	my ($self, $id, %msg) = @_;
		628
		629	$msg{msgid} = $id;
		630
		631	$self->send ("ext " . to_json \%msg);
		632	}
		633
		634	#############################################################################
		635	# map scripting support
		636
		637	our $safe = new Safe "ext";
		638	our $safe_hole = new Safe::Hole;
		639
		640	$SIG{FPE} = 'IGNORE';
		641
		642	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
		643
		644	# here we export the classes and methods available to script code
		645
		646	for (
		647	["cf::object" => qw(contr pay_amount pay_player)],
		648	["cf::object::player" => qw(player)],
		649	["cf::player" => qw(peaceful)],
		650	) {
		651	no strict 'refs';
		652	my ($pkg, @funs) = @$_;
		653	*{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
		654	for @funs;
		655	}
		656
		657	sub safe_eval($;@) {
		658	my ($code, %vars) = @_;
		659
		660	my $qcode = $code;
		661	$qcode =~ s/"/‟/g; # not allowed in #line filenames
		662	$qcode =~ s/\n/\\n/g;
		663
		664	local $_;
		665	local @ext::cf::_safe_eval_args = values %vars;
		666
		667	$code =
		668	"do {\n"
		669	. "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
		670	. "#line 0 \"{$qcode}\"\n"
		671	. $code
		672	. "\n}"
		673	;
		674
		675	sub_generation_inc;
		676	my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code);
		677	sub_generation_inc;
		678
		679	wantarray ? @res : $res[0]
		680	}
		681
		682	sub register_script_function {
		683	my ($fun, $cb) = @_;
		684
		685	no strict 'refs';
		686	*{"ext::$fun"} = $safe_hole->wrap ($cb);
		687	}
		688
		689	#############################################################################
		690	# the server's main()
		691
		692	sub main {
		693	Event::loop;
		694	}
		695
		696	#############################################################################
		697	# initialisation
343		698
344	register "<global>", __PACKAGE__;	699	register "<global>", __PACKAGE__;
345		700
346	unshift @INC, maps_directory "perl";	701	unshift @INC, $LIBDIR;
347		702
348	load_extensions;	703	load_extensions;
349		704
		705	$TICK_WATCHER = Event->timer (
		706	prio => 1,
		707	at => $NEXT_TICK \|\| 1,
		708	cb => sub {
		709	cf::server_tick; # one server iteration
		710
		711	my $NOW = Event::time;
		712	$NEXT_TICK += $TICK;
		713
		714	# if we are delayed by four ticks, skip them all
		715	$NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
		716
		717	$TICK_WATCHER->at ($NEXT_TICK);
		718	$TICK_WATCHER->start;
		719	},
		720	);
		721
350	1	722	1
351		723

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.18 by root, Tue Jul 11 14:24:15 2006 UTC vs. Revision 1.39 by root, Fri Aug 25 13:24:50 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.18 by root, Tue Jul 11 14:24:15 2006 UTC vs.
Revision 1.39 by root, Fri Aug 25 13:24:50 2006 UTC