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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.94 by root, Thu Dec 21 23:02:54 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 = ();
249	my ($self, $victim) = @_;	258	my ($self, $victim) = @_;
250	...	259	...
251	}	260	}
252	}	261	}
253		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.
		270
254	=cut	271	=cut
255		272
256	# 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
257	our @CB_GLOBAL = (); # registry for all global events	274	our @CB_GLOBAL = (); # registry for all global events
258	our @CB_OBJECT = (); # all objects (should not be used except in emergency)	275	our @CB_OBJECT = (); # all objects (should not be used except in emergency)
…		…
413	}	430	}
414		431
415	0	432	0
416	}	433	}
417		434
418	=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...	435	=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
419		436
420	=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
421
422	=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
423
424	=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)	437	=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
425		438
426	=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
427
428	Generate a global/object/player/map-specific event with the given arguments.	439	Generate an object-specific event with the given arguments.
429		440
430	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
431	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
432	results (if you must, access C<@cf::invoke_results> directly).	443	results (if you must, access C<@cf::invoke_results> directly).
433
434	=back
435
436	=cut
437
438	#############################################################################
439
440	=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
441
442	Attachable objects includes objects, players, clients and maps.
443
444	=over 4
445
446	=item $object->valid
447
448	Just because you have a perl object does not mean that the corresponding
449	C-level object still exists. If you try to access an object that has no
450	valid C counterpart anymore you get an exception at runtime. This method
451	can be used to test for existence of the C object part without causing an
452	exception.
453		444
454	=back	445	=back
455		446
456	=cut	447	=cut
457		448
…		…
758		749
759	=head2 CORE EXTENSIONS	750	=head2 CORE EXTENSIONS
760		751
761	Functions and methods that extend core crossfire objects.	752	Functions and methods that extend core crossfire objects.
762		753
		754	=head3 cf::player
		755
763	=over 4	756	=over 4
764		757
765	=item cf::player::exists $login	758	=item cf::player::exists $login
766		759
767	Returns true when the given account exists.	760	Returns true when the given account exists.
…		…
771	sub cf::player::exists($) {	764	sub cf::player::exists($) {
772	cf::player::find $_[0]	765	cf::player::find $_[0]
773	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;
774	}	767	}
775		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
776	=item $player_object->reply ($npc, $msg[, $flags])	789	=item $player_object->reply ($npc, $msg[, $flags])
777		790
778	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>
779	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
780	dialogue with the given NPC character.	793	dialogue with the given NPC character.
781		794
782	=cut	795	=cut
783		796
784	# rough implementation of a future "reply" method that works	797	# rough implementation of a future "reply" method that works
785	# with dialog boxes.	798	# with dialog boxes.
		799	#TODO: the first argument must go, split into a $npc->reply_to ( method
786	sub cf::object::player::reply($$$;$) {	800	sub cf::object::player::reply($$$;$) {
787	my ($self, $npc, $msg, $flags) = @_;	801	my ($self, $npc, $msg, $flags) = @_;
788		802
789	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;	803	$flags = cf::NDI_BROWN \| cf::NDI_UNIQUE unless @_ >= 4;
790		804
…		…
794	$msg = $npc->name . " says: $msg" if $npc;	808	$msg = $npc->name . " says: $msg" if $npc;
795	$self->message ($msg, $flags);	809	$self->message ($msg, $flags);
796	}	810	}
797	}	811	}
798		812
799	=item $player->ext_reply ($msgid, $msgtype, %msg)
800
801	Sends an ext reply to the player.
802
803	=cut
804
805	sub cf::player::ext_reply($$$%) {
806	my ($self, $id, %msg) = @_;
807
808	$msg{msgid} = $id;
809
810	$self->send ("ext " . to_json \%msg);
811	}
812
813	=item $player_object->may ("access")	813	=item $player_object->may ("access")
814		814
815	Returns wether the given player is authorized to access resource "access"	815	Returns wether the given player is authorized to access resource "access"
816	(e.g. "command_wizcast").	816	(e.g. "command_wizcast").
817		817
…		…
824	(ref $cf::CFG{"may_$access"}	824	(ref $cf::CFG{"may_$access"}
825	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	825	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
826	: $cf::CFG{"may_$access"})	826	: $cf::CFG{"may_$access"})
827	}	827	}
828		828
829	=cut	829	=head3 cf::client
830		830
831	#############################################################################	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
832		929
833	=head2 SAFE SCRIPTING	930	=head2 SAFE SCRIPTING
834		931
835	Functions that provide a safe environment to compile and execute	932	Functions that provide a safe environment to compile and execute
836	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.94 by root, Thu Dec 21 23:02:54 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.94 by root, Thu Dec 21 23:02:54 2006 UTC vs.
Revision 1.97 by root, Fri Dec 22 06:03:20 2006 UTC