ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.70 by root, Sun Oct 1 10:55:37 2006 UTC vs.
Revision 1.85 by root, Mon Dec 11 22:56:57 2006 UTC

… …
5use Storable; 5use Storable;
6use Opcode; 6use Opcode;
7use Safe; 7use Safe;
8use Safe::Hole; 8use Safe::Hole;
9 9
10use IO::AIO ();
11use YAML::Syck ();
10use Time::HiRes; 12use Time::HiRes;
11use Event; 13use Event;
12$Event::Eval = 1; # no idea why this is required, but it is 14$Event::Eval = 1; # no idea why this is required, but it is
13 15
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1;
18
14use strict; 19use strict;
15 20
21our %COMMAND = ();
22our %COMMAND_TIME = ();
23our %EXTCMD = ();
24
16_init_vars; 25_init_vars;
17 26
18our %COMMAND = ();
19our @EVENT; 27our @EVENT;
20our $LIBDIR = maps_directory "perl"; 28our $LIBDIR = maps_directory "perl";
21 29
22our $TICK = MAX_TIME * 1e-6; 30our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 31our $TICK_WATCHER;
24our $NEXT_TICK; 32our $NEXT_TICK;
25 33
26our %CFG; 34our %CFG;
27 35
36our $UPTIME; $UPTIME ||= time;
37
28############################################################################# 38#############################################################################
29 39
30=head2 GLOBAL VARIABLES 40=head2 GLOBAL VARIABLES
31 41
32=over 4 42=over 4
43
44=item $cf::UPTIME
45
46The timestamp of the server start (so not actually an uptime).
33 47
34=item $cf::LIBDIR 48=item $cf::LIBDIR
35 49
36The perl library directory, where extensions and cf-specific modules can 50The perl library directory, where extensions and cf-specific modules can
37be found. It will be added to C<@INC> automatically. 51be found. It will be added to C<@INC> automatically.
… …
74}; 88};
75 89
76my %ext_pkg; 90my %ext_pkg;
77my @exts; 91my @exts;
78my @hook; 92my @hook;
79my %command;
80my %extcmd;
81 93
82=head2 UTILITY FUNCTIONS 94=head2 UTILITY FUNCTIONS
83 95
84=over 4 96=over 4
85 97
… …
108 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 120 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
109 JSON::Syck::Dump $_[0] 121 JSON::Syck::Dump $_[0]
110} 122}
111 123
112=back 124=back
125
126=cut
113 127
114############################################################################# 128#############################################################################
115 129
116=head2 EVENTS AND OBJECT ATTACHMENTS 130=head2 EVENTS AND OBJECT ATTACHMENTS
117 131
… …
420This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 434This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
421removed in future versions), and there is no public API to access override 435removed in future versions), and there is no public API to access override
422results (if you must, access C<@cf::invoke_results> directly). 436results (if you must, access C<@cf::invoke_results> directly).
423 437
424=back 438=back
439
440=cut
425 441
426############################################################################# 442#############################################################################
427 443
428=head2 METHODS VALID FOR ALL CORE OBJECTS 444=head2 METHODS VALID FOR ALL CORE OBJECTS
429 445
… …
510 unlink $filename; 526 unlink $filename;
511 unlink "$filename.pst"; 527 unlink "$filename.pst";
512 } 528 }
513} 529}
514 530
531sub object_freezer_as_string {
532 my ($rdata, $objs) = @_;
533
534 use Data::Dumper;
535
536 $$rdata . Dumper $objs
537}
538
515sub object_thawer_load { 539sub object_thawer_load {
516 my ($filename) = @_; 540 my ($filename) = @_;
517 541
518 local $/; 542 local $/;
519 543
… …
544 if exists $src->{_attachment}; 568 if exists $src->{_attachment};
545 }, 569 },
546; 570;
547 571
548############################################################################# 572#############################################################################
549# old plug-in events 573# command handling &c
550 574
551sub inject_event { 575=item cf::register_command $name => \&callback($ob,$args);
552 my $extension = shift;
553 my $event_code = shift;
554 576
555 my $cb = $hook[$event_code]{$extension} 577Register a callback for execution when the client sends the user command
556 or return; 578$name.
557 579
558 &$cb 580=cut
559}
560
561sub inject_global_event {
562 my $event = shift;
563
564 my $cb = $hook[$event]
565 or return;
566
567 List::Util::max map &$_, values %$cb
568}
569
570sub inject_command {
571 my ($name, $obj, $params) = @_;
572
573 for my $cmd (@{ $command{$name} }) {
574 $cmd->[1]->($obj, $params);
575 }
576
577 -1
578}
579 581
580sub register_command { 582sub register_command {
581 my ($name, $time, $cb) = @_; 583 my ($name, $cb) = @_;
582 584
583 my $caller = caller; 585 my $caller = caller;
584 #warn "registering command '$name/$time' to '$caller'"; 586 #warn "registering command '$name/$time' to '$caller'";
585 587
586 push @{ $command{$name} }, [$time, $cb, $caller]; 588 push @{ $COMMAND{$name} }, [$caller, $cb];
587 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
588} 589}
590
591=item cf::register_extcmd $name => \&callback($pl,$packet);
592
593Register a callbackf ro execution when the client sends an extcmd packet.
594
595If the callback returns something, it is sent back as if reply was being
596called.
597
598=cut
589 599
590sub register_extcmd { 600sub register_extcmd {
591 my ($name, $cb) = @_; 601 my ($name, $cb) = @_;
592 602
593 my $caller = caller; 603 my $caller = caller;
594 #warn "registering extcmd '$name' to '$caller'"; 604 #warn "registering extcmd '$name' to '$caller'";
595 605
596 $extcmd{$name} = [$cb, $caller]; 606 $EXTCMD{$name} = [$cb, $caller];
597} 607}
608
609attach_to_players
610 on_command => sub {
611 my ($pl, $name, $params) = @_;
612
613 my $cb = $COMMAND{$name}
614 or return;
615
616 for my $cmd (@$cb) {
617 $cmd->[1]->($pl->ob, $params);
618 }
619
620 cf::override;
621 },
622 on_extcmd => sub {
623 my ($pl, $buf) = @_;
624
625 my $msg = eval { from_json $buf };
626
627 if (ref $msg) {
628 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
629 if (my %reply = $cb->[0]->($pl, $msg)) {
630 $pl->ext_reply ($msg->{msgid}, %reply);
631 }
632 }
633 } else {
634 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
635 }
636
637 cf::override;
638 },
639;
598 640
599sub register { 641sub register {
600 my ($base, $pkg) = @_; 642 my ($base, $pkg) = @_;
601 643
602 #TODO 644 #TODO
… …
621 . "#line 1 \"$path\"\n{\n" 663 . "#line 1 \"$path\"\n{\n"
622 . (do { local $/; <$fh> }) 664 . (do { local $/; <$fh> })
623 . "\n};\n1"; 665 . "\n};\n1";
624 666
625 eval $source 667 eval $source
626 or die "$path: $@"; 668 or die $@ ? "$path: $@\n"
669 : "extension disabled.\n";
627 670
628 push @exts, $pkg; 671 push @exts, $pkg;
629 $ext_pkg{$base} = $pkg; 672 $ext_pkg{$base} = $pkg;
630 673
631# no strict 'refs'; 674# no strict 'refs';
… …
644# for my $idx (0 .. $#PLUGIN_EVENT) { 687# for my $idx (0 .. $#PLUGIN_EVENT) {
645# delete $hook[$idx]{$pkg}; 688# delete $hook[$idx]{$pkg};
646# } 689# }
647 690
648 # remove commands 691 # remove commands
649 for my $name (keys %command) { 692 for my $name (keys %COMMAND) {
650 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 693 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
651 694
652 if (@cb) { 695 if (@cb) {
653 $command{$name} = \@cb; 696 $COMMAND{$name} = \@cb;
654 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
655 } else { 697 } else {
656 delete $command{$name};
657 delete $COMMAND{"$name\000"}; 698 delete $COMMAND{$name};
658 } 699 }
659 } 700 }
660 701
661 # remove extcmds 702 # remove extcmds
662 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 703 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
663 delete $extcmd{$name}; 704 delete $EXTCMD{$name};
664 } 705 }
665 706
666 if (my $cb = $pkg->can ("unload")) { 707 if (my $cb = $pkg->can ("unload")) {
667 eval { 708 eval {
668 $cb->($pkg); 709 $cb->($pkg);
… …
684 } or warn "$ext not loaded: $@"; 725 } or warn "$ext not loaded: $@";
685 } 726 }
686} 727}
687 728
688############################################################################# 729#############################################################################
689# extcmd framework, basically convert ext <msg>
690# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
691
692attach_to_players
693 on_extcmd => sub {
694 my ($pl, $buf) = @_;
695
696 my $msg = eval { from_json $buf };
697
698 if (ref $msg) {
699 if (my $cb = $extcmd{$msg->{msgtype}}) {
700 if (my %reply = $cb->[0]->($pl, $msg)) {
701 $pl->ext_reply ($msg->{msgid}, %reply);
702 }
703 }
704 } else {
705 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
706 }
707
708 cf::override;
709 },
710;
711
712#############################################################################
713# load/save/clean perl data associated with a map 730# load/save/clean perl data associated with a map
714 731
715*cf::mapsupport::on_clean = sub { 732*cf::mapsupport::on_clean = sub {
716 my ($map) = @_; 733 my ($map) = @_;
717 734
… …
762sub cf::player::exists($) { 779sub cf::player::exists($) {
763 cf::player::find $_[0] 780 cf::player::find $_[0]
764 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 781 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
765} 782}
766 783
767=item $player->reply ($npc, $msg[, $flags]) 784=item $player_object->reply ($npc, $msg[, $flags])
768 785
769Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 786Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
770can be C<undef>. Does the right thing when the player is currently in a 787can be C<undef>. Does the right thing when the player is currently in a
771dialogue with the given NPC character. 788dialogue with the given NPC character.
772 789
… …
799 $msg{msgid} = $id; 816 $msg{msgid} = $id;
800 817
801 $self->send ("ext " . to_json \%msg); 818 $self->send ("ext " . to_json \%msg);
802} 819}
803 820
804=back 821=item $player_object->may ("access")
822
823Returns wether the given player is authorized to access resource "access"
824(e.g. "command_wizcast").
825
826=cut
827
828sub cf::object::player::may {
829 my ($self, $access) = @_;
830
831 $self->flag (cf::FLAG_WIZ) ||
832 (ref $cf::CFG{"may_$access"}
833 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
834 : $cf::CFG{"may_$access"})
835}
805 836
806=cut 837=cut
807 838
808############################################################################# 839#############################################################################
809 840
… …
811 842
812Functions that provide a safe environment to compile and execute 843Functions that provide a safe environment to compile and execute
813snippets of perl code without them endangering the safety of the server 844snippets of perl code without them endangering the safety of the server
814itself. Looping constructs, I/O operators and other built-in functionality 845itself. Looping constructs, I/O operators and other built-in functionality
815is not available in the safe scripting environment, and the number of 846is not available in the safe scripting environment, and the number of
816functions and methods that cna be called is greatly reduced. 847functions and methods that can be called is greatly reduced.
817 848
818=cut 849=cut
819 850
820our $safe = new Safe "safe"; 851our $safe = new Safe "safe";
821our $safe_hole = new Safe::Hole; 852our $safe_hole = new Safe::Hole;
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 943 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 944}
914 945
915=back 946=back
916 947
948=cut
949
917############################################################################# 950#############################################################################
918 951
919=head2 EXTENSION DATABASE SUPPORT 952=head2 EXTENSION DATABASE SUPPORT
920 953
921Crossfire maintains a very simple database for extension use. It can 954Crossfire maintains a very simple database for extension use. It can
… …
955 988
956Immediately write the database to disk I<if it is dirty>. 989Immediately write the database to disk I<if it is dirty>.
957 990
958=cut 991=cut
959 992
993our $DB;
994
960{ 995{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 996 my $path = cf::localdir . "/database.pst";
963 997
964 sub db_load() { 998 sub db_load() {
965 warn "loading database $path\n";#d# remove later 999 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 1000 $DB = stat $path ? Storable::retrieve $path : { };
967 } 1001 }
968 1002
969 my $pid; 1003 my $pid;
970 1004
971 sub db_save() { 1005 sub db_save() {
972 warn "saving database $path\n";#d# remove later 1006 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 1007 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 1008 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 1009 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 1010 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 1011 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 1012 cf::_exit 0 if defined $pid;
979 } 1013 }
980 } 1014 }
981 1015
… …
995 $idle->start; 1029 $idle->start;
996 } 1030 }
997 1031
998 sub db_get($;$) { 1032 sub db_get($;$) {
999 @_ >= 2 1033 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1034 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1035 : ($DB->{$_[0]} ||= { })
1002 } 1036 }
1003 1037
1004 sub db_put($$;$) { 1038 sub db_put($$;$) {
1005 if (@_ >= 3) { 1039 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1040 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1041 } else {
1008 $db->{$_[0]} = $_[1]; 1042 $DB->{$_[0]} = $_[1];
1009 } 1043 }
1010 db_dirty; 1044 db_dirty;
1011 } 1045 }
1012 1046
1013 attach_global 1047 attach_global
… …
1019} 1053}
1020 1054
1021############################################################################# 1055#############################################################################
1022# the server's main() 1056# the server's main()
1023 1057
1058sub cfg_load {
1059 open my $fh, "<:utf8", cf::confdir . "/config"
1060 or return;
1061
1062 local $/;
1063 *CFG = YAML::Syck::Load <$fh>;
1064}
1065
1024sub main { 1066sub main {
1067 cfg_load;
1025 db_load; 1068 db_load;
1026 load_extensions; 1069 load_extensions;
1027 Event::loop; 1070 Event::loop;
1028} 1071}
1029 1072
… …
1081 1124
1082 # reload cf.pm 1125 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1126 $msg->("reloading cf.pm");
1084 require cf; 1127 require cf;
1085 1128
1086 # load database again 1129 # load config and database again
1130 cf::cfg_load;
1087 cf::db_load; 1131 cf::db_load;
1088 1132
1089 # load extensions 1133 # load extensions
1090 $msg->("load extensions"); 1134 $msg->("load extensions");
1091 cf::load_extensions; 1135 cf::load_extensions;
… …
1104 warn $_[0]; 1148 warn $_[0];
1105 print "$_[0]\n"; 1149 print "$_[0]\n";
1106 }; 1150 };
1107} 1151}
1108 1152
1153register "<global>", __PACKAGE__;
1154
1109register_command "perl-reload", 0, sub { 1155register_command "perl-reload" => sub {
1110 my ($who, $arg) = @_; 1156 my ($who, $arg) = @_;
1111 1157
1112 if ($who->flag (FLAG_WIZ)) { 1158 if ($who->flag (FLAG_WIZ)) {
1113 _perl_reload { 1159 _perl_reload {
1114 warn $_[0]; 1160 warn $_[0];
1115 $who->message ($_[0]); 1161 $who->message ($_[0]);
1116 }; 1162 };
1117 } 1163 }
1118}; 1164};
1119 1165
1120register "<global>", __PACKAGE__;
1121
1122unshift @INC, $LIBDIR; 1166unshift @INC, $LIBDIR;
1123 1167
1124$TICK_WATCHER = Event->timer ( 1168$TICK_WATCHER = Event->timer (
1125 prio => 1, 1169 prio => 1,
1170 async => 1,
1126 at => $NEXT_TICK || 1, 1171 at => $NEXT_TICK || 1,
1127 cb => sub { 1172 cb => sub {
1128 cf::server_tick; # one server iteration 1173 cf::server_tick; # one server iteration
1129 1174
1130 my $NOW = Event::time; 1175 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1176 $NEXT_TICK += $TICK;
1132 1177
1133 # if we are delayed by four ticks, skip them all 1178 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1179 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1180
1136 $TICK_WATCHER->at ($NEXT_TICK); 1181 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1182 $TICK_WATCHER->start;
1138 }, 1183 },
1139); 1184);
1140 1185
1186IO::AIO::max_poll_time $TICK * 0.2;
1187
1188Event->io (fd => IO::AIO::poll_fileno,
1189 poll => 'r',
1190 prio => 5,
1191 cb => \&IO::AIO::poll_cb);
1192
11411 11931
1142 1194

Diff Legend

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