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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC vs.
Revision 1.97 by root, Fri Dec 22 06:03:20 2006 UTC

…		…
1	package cf;	1	package cf;
		2
		3	use utf8;
		4	use strict;
2		5
3	use Symbol;	6	use Symbol;
4	use List::Util;	7	use List::Util;
5	use Storable;	8	use Storable;
6	use Opcode;	9	use Opcode;
7	use Safe;	10	use Safe;
8	use Safe::Hole;	11	use Safe::Hole;
9		12
		13	use Coro;
		14	use Coro::Event;
		15	use Coro::Timer;
		16	use Coro::Signal;
		17	use Coro::Semaphore;
		18
10	use IO::AIO ();	19	use IO::AIO;
11	use YAML::Syck ();	20	use YAML::Syck ();
12	use Time::HiRes;	21	use Time::HiRes;
13	use Event;	22
14	$Event::Eval = 1; # no idea why this is required, but it is	23	use Event; $Event::Eval = 1; # no idea why this is required, but it is
15		24
16	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?	25	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17	$YAML::Syck::ImplicitUnicode = 1;	26	$YAML::Syck::ImplicitUnicode = 1;
18		27
19	use strict;	28	$Coro::main->prio (Coro::PRIO_MIN);
20		29
21	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	30	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22		31
23	our %COMMAND = ();	32	our %COMMAND = ();
24	our %COMMAND_TIME = ();	33	our %COMMAND_TIME = ();
140		149
141	#############################################################################	150	#############################################################################
142		151
143	=head2 ATTACHABLE OBJECTS	152	=head2 ATTACHABLE OBJECTS
144		153
145	You can define and attach attachments to each "attachable" object in	154	Many objects in crossfire are so-called attachable objects. That means you can
146	crossfire+ (objects, players, clients, maps and the special "global"	155	attach callbacks/event handlers (a collection of which is called an "attachment")
		156	to it. All such attachable objects support the following methods.
		157
147	class). In the following description, CLASS can be any of C<global>,	158	In the following description, CLASS can be any of C<global>, C<object>
148	C<object> C<player>, C<client> or C<map>.	159	C<player>, C<client> or C<map> (i.e. the attachable objects in
		160	crossfire+).
149		161
150	=over 4	162	=over 4
151		163
		164	=item $attachable->attach ($attachment, key => $value...)
		165
		166	=item $attachable->detach ($attachment)
		167
		168	Attach/detach a pre-registered attachment to a specific object and give it
		169	the specified key/value pairs as arguments.
		170
		171	Example, attach a minesweeper attachment to the given object, making it a
		172	10x10 minesweeper game:
		173
		174	$obj->attach (minesweeper => width => 10, height => 10);
		175
		176	=item $bool = $attachable->attached ($name)
		177
		178	Checks wether the named attachment is currently attached to the object.
		179
		180	=item cf::CLASS->attach ...
		181
		182	=item cf::CLASS->detach ...
		183
		184	Define an anonymous attachment and attach it to all objects of the given
		185	CLASS. See the next function for an explanation of its arguments.
		186
		187	You can attach to global events by using the C<cf::global> class.
		188
		189	Example, log all player logins:
		190
		191	cf::player->attach (
		192	on_login => sub {
		193	my ($pl) = @_;
		194	...
		195	},
		196	);
		197
		198	Example, attach to the jeweler skill:
		199
		200	cf::object->attach (
		201	type => cf::SKILL,
		202	subtype => cf::SK_JEWELER,
		203	on_use_skill => sub {
		204	my ($sk, $ob, $part, $dir, $msg) = @_;
		205	...
		206	},
		207	);
		208
152	=item cf::CLASS::attachment $name, ...	209	=item cf::CLASS::attachment $name, ...
153		210
154	Register an attachment by name through which attachable objects can refer	211	Register an attachment by C<$name> through which attachable objects of the
155	to this attachment.	212	given CLASS can refer to this attachment.
156		213
157	=item $bool = $attachable->attached ($name)	214	Some classes such as crossfire maps and objects can specify attachments
		215	that are attached at load/instantiate time, thus the need for a name.
158		216
159	Checks wether the named attachment is currently attached to the object.
160
161	=item $attachable->attach ($attachment, key => $value...)
162
163	=item $attachable->detach ($attachment)
164
165	Attach/detach a pre-registered attachment either to a specific object
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	217	These calls expect any number of the following handler/hook descriptions:
172	descriptions:
173		218
174	=over 4	219	=over 4
175		220
176	=item prio => $number	221	=item prio => $number
177		222
…		…
202	Look for sub functions of the name C<< on_I<event> >> in the given	247	Look for sub functions of the name C<< on_I<event> >> in the given
203	package and register them. Only handlers for eevents supported by the	248	package and register them. Only handlers for eevents supported by the
204	object/class are recognised.	249	object/class are recognised.
205		250
206	=back	251	=back
		252
		253	Example, define an attachment called "sockpuppet" that calls the given
		254	event handler when a monster attacks:
		255
		256	cf::object::attachment sockpuppet =>
		257	on_skill_attack => sub {
		258	my ($self, $victim) = @_;
		259	...
		260	}
		261	}
		262
		263	=item $attachable->valid
		264
		265	Just because you have a perl object does not mean that the corresponding
		266	C-level object still exists. If you try to access an object that has no
		267	valid C counterpart anymore you get an exception at runtime. This method
		268	can be used to test for existence of the C object part without causing an
		269	exception.
207		270
208	=cut	271	=cut
209		272
210	# the following variables are defined in .xs and must not be re-created	273	# the following variables are defined in .xs and must not be re-created
211	our @CB_GLOBAL = (); # registry for all global events	274	our @CB_GLOBAL = (); # registry for all global events
…		…
367	}	430	}
368		431
369	0	432	0
370	}	433	}
371		434
372	=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...	435	=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
373		436
374	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
375
376	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
377
378	=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)	437	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
379		438
380	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
381
382	Generate a global/object/player/map-specific event with the given arguments.	439	Generate an object-specific event with the given arguments.
383		440
384	This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be	441	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
385	removed in future versions), and there is no public API to access override	442	removed in future versions), and there is no public API to access override
386	results (if you must, access C<@cf::invoke_results> directly).	443	results (if you must, access C<@cf::invoke_results> directly).
387
388	=back
389
390	=cut
391
392	#############################################################################
393
394	=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
395
396	Attachable objects includes objects, players, clients and maps.
397
398	=over 4
399
400	=item $object->valid
401
402	Just because you have a perl object does not mean that the corresponding
403	C-level object still exists. If you try to access an object that has no
404	valid C counterpart anymore you get an exception at runtime. This method
405	can be used to test for existence of the C object part without causing an
406	exception.
407		444
408	=back	445	=back
409		446
410	=cut	447	=cut
411		448
…		…
712		749
713	=head2 CORE EXTENSIONS	750	=head2 CORE EXTENSIONS
714		751
715	Functions and methods that extend core crossfire objects.	752	Functions and methods that extend core crossfire objects.
716		753
		754	=head3 cf::player
		755
717	=over 4	756	=over 4
718		757
719	=item cf::player::exists $login	758	=item cf::player::exists $login
720		759
721	Returns true when the given account exists.	760	Returns true when the given account exists.
…		…
725	sub cf::player::exists($) {	764	sub cf::player::exists($) {
726	cf::player::find $_[0]	765	cf::player::find $_[0]
727	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;	766	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
728	}	767	}
729		768
		769	=item $player->ext_reply ($msgid, $msgtype, %msg)
		770
		771	Sends an ext reply to the player.
		772
		773	=cut
		774
		775	sub cf::player::ext_reply($$$%) {
		776	my ($self, $id, %msg) = @_;
		777
		778	$msg{msgid} = $id;
		779
		780	$self->send ("ext " . to_json \%msg);
		781	}
		782
		783	=back
		784
		785	=head3 cf::object::player
		786
		787	=over 4
		788
730	=item $player_object->reply ($npc, $msg[, $flags])	789	=item $player_object->reply ($npc, $msg[, $flags])
731		790
732	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>	791	Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
733	can be C<undef>. Does the right thing when the player is currently in a	792	can be C<undef>. Does the right thing when the player is currently in a
734	dialogue with the given NPC character.	793	dialogue with the given NPC character.
735		794
736	=cut	795	=cut
737		796
738	# rough implementation of a future "reply" method that works	797	# rough implementation of a future "reply" method that works
739	# with dialog boxes.	798	# with dialog boxes.
		799	#TODO: the first argument must go, split into a $npc->reply_to ( method
740	sub cf::object::player::reply($$$;$) {	800	sub cf::object::player::reply($$$;$) {
741	my ($self, $npc, $msg, $flags) = @_;	801	my ($self, $npc, $msg, $flags) = @_;
742		802
743	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;	803	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;
744		804
…		…
748	$msg = $npc->name . " says: $msg" if $npc;	808	$msg = $npc->name . " says: $msg" if $npc;
749	$self->message ($msg, $flags);	809	$self->message ($msg, $flags);
750	}	810	}
751	}	811	}
752		812
753	=item $player->ext_reply ($msgid, $msgtype, %msg)
754
755	Sends an ext reply to the player.
756
757	=cut
758
759	sub cf::player::ext_reply($$$%) {
760	my ($self, $id, %msg) = @_;
761
762	$msg{msgid} = $id;
763
764	$self->send ("ext " . to_json \%msg);
765	}
766
767	=item $player_object->may ("access")	813	=item $player_object->may ("access")
768		814
769	Returns wether the given player is authorized to access resource "access"	815	Returns wether the given player is authorized to access resource "access"
770	(e.g. "command_wizcast").	816	(e.g. "command_wizcast").
771		817
…		…
778	(ref $cf::CFG{"may_$access"}	824	(ref $cf::CFG{"may_$access"}
779	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	825	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
780	: $cf::CFG{"may_$access"})	826	: $cf::CFG{"may_$access"})
781	}	827	}
782		828
783	=cut	829	=head3 cf::client
784		830
785	#############################################################################	831	=over 4
		832
		833	=item $client->send_drawinfo ($text, $flags)
		834
		835	Sends a drawinfo packet to the client. Circumvents output buffering so
		836	should not be used under normal circumstances.
		837
		838	=cut
		839
		840	sub cf::client::send_drawinfo {
		841	my ($self, $text, $flags) = @_;
		842
		843	utf8::encode $text;
		844	$self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
		845	}
		846
		847
		848	=item $success = $client->query ($flags, "text", \&cb)
		849
		850	Queues a query to the client, calling the given callback with
		851	the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
		852	C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
		853
		854	Queries can fail, so check the return code. Or don't, as queries will become
		855	reliable at some point in the future.
		856
		857	=cut
		858
		859	sub cf::client::query {
		860	my ($self, $flags, $text, $cb) = @_;
		861
		862	return unless $self->state == ST_PLAYING
		863	\|\| $self->state == ST_SETUP
		864	\|\| $self->state == ST_CUSTOM;
		865
		866	$self->state (ST_CUSTOM);
		867
		868	utf8::encode $text;
		869	push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
		870
		871	$self->send_packet ($self->{query_queue}[0][0])
		872	if @{ $self->{query_queue} } == 1;
		873	}
		874
		875	cf::client->attach (
		876	on_reply => sub {
		877	my ($ns, $msg) = @_;
		878
		879	# this weird shuffling is so that direct followup queries
		880	# get handled first
		881	my $queue = delete $ns->{query_queue};
		882
		883	(shift @$queue)->[1]->($msg);
		884
		885	push @{ $ns->{query_queue} }, @$queue;
		886
		887	if (@{ $ns->{query_queue} } == @$queue) {
		888	if (@$queue) {
		889	$ns->send_packet ($ns->{query_queue}[0][0]);
		890	} else {
		891	$ns->state (ST_PLAYING);
		892	}
		893	}
		894	},
		895	);
		896
		897	=item $client->coro (\&cb)
		898
		899	Create a new coroutine, running the specified callback. The coroutine will
		900	be automatically cancelled when the client gets destroyed (e.g. on logout,
		901	or loss of connection).
		902
		903	=cut
		904
		905	sub cf::client::coro {
		906	my ($self, $cb) = @_;
		907
		908	my $coro; $coro = async {
		909	eval {
		910	$cb->();
		911	};
		912	warn $@ if $@;
		913	delete $self->{_coro}{$coro+0};
		914	};
		915
		916	$self->{_coro}{$coro+0} = $coro;
		917	}
		918
		919	cf::client->attach (
		920	on_destroy => sub {
		921	my ($ns) = @_;
		922
		923	$_->cancel for values %{ (delete $ns->{_coro}) \|\| {} };
		924	},
		925	);
		926
		927	=back
		928
786		929
787	=head2 SAFE SCRIPTING	930	=head2 SAFE SCRIPTING
788		931
789	Functions that provide a safe environment to compile and execute	932	Functions that provide a safe environment to compile and execute
790	snippets of perl code without them endangering the safety of the server	933	snippets of perl code without them endangering the safety of the server

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC vs. Revision 1.97 by root, Fri Dec 22 06:03:20 2006 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC vs.
Revision 1.97 by root, Fri Dec 22 06:03:20 2006 UTC