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.78 by root, Tue Nov 7 00:15:27 2006 UTC vs.
Revision 1.88 by root, Fri Dec 15 19:29:18 2006 UTC

… …
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1; 17$YAML::Syck::ImplicitUnicode = 1;
18 18
19use strict; 19use strict;
20 20
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
21_init_vars; 27_init_vars;
22 28
23our %COMMAND = ();
24our @EVENT; 29our @EVENT;
25our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
26 31
27our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
28our $TICK_WATCHER; 33our $TICK_WATCHER;
29our $NEXT_TICK; 34our $NEXT_TICK;
30 35
31our %CFG; 36our %CFG;
32 37
33our $uptime; 38our $UPTIME; $UPTIME ||= time;
34
35$uptime ||= time;
36 39
37############################################################################# 40#############################################################################
38 41
39=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
40 43
41=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
42 49
43=item $cf::LIBDIR 50=item $cf::LIBDIR
44 51
45The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
46be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
71 78
72@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
73 80
74# we bless all objects into (empty) derived classes to force a method lookup 81# we bless all objects into (empty) derived classes to force a method lookup
75# within the Safe compartment. 82# within the Safe compartment.
76for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 83for my $pkg (qw(
84 cf::object cf::object::player
85 cf::client_socket cf::player
86 cf::arch cf::living
87 cf::map cf::party cf::region
88)) {
77 no strict 'refs'; 89 no strict 'refs';
78 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
79} 91}
80 92
81$Event::DIED = sub { 93$Event::DIED = sub {
… …
83}; 95};
84 96
85my %ext_pkg; 97my %ext_pkg;
86my @exts; 98my @exts;
87my @hook; 99my @hook;
88my %command;
89my %extcmd;
90 100
91=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
92 102
93=over 4 103=over 4
94 104
… …
523 unlink $filename; 533 unlink $filename;
524 unlink "$filename.pst"; 534 unlink "$filename.pst";
525 } 535 }
526} 536}
527 537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
544}
545
528sub object_thawer_load { 546sub object_thawer_load {
529 my ($filename) = @_; 547 my ($filename) = @_;
530 548
531 local $/; 549 local $/;
532 550
… …
557 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
558 }, 576 },
559; 577;
560 578
561############################################################################# 579#############################################################################
562# old plug-in events 580# command handling &c
563 581
564sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
565 my $extension = shift;
566 my $event_code = shift;
567 583
568 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
569 or return; 585$name.
570 586
571 &$cb 587=cut
572}
573
574sub inject_global_event {
575 my $event = shift;
576
577 my $cb = $hook[$event]
578 or return;
579
580 List::Util::max map &$_, values %$cb
581}
582
583sub inject_command {
584 my ($name, $obj, $params) = @_;
585
586 for my $cmd (@{ $command{$name} }) {
587 $cmd->[1]->($obj, $params);
588 }
589
590 -1
591}
592 588
593sub register_command { 589sub register_command {
594 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
595 591
596 my $caller = caller; 592 my $caller = caller;
597 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
598 594
599 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
600 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
601} 596}
597
598=item cf::register_extcmd $name => \&callback($pl,$packet);
599
600Register a callbackf ro execution when the client sends an extcmd packet.
601
602If the callback returns something, it is sent back as if reply was being
603called.
604
605=cut
602 606
603sub register_extcmd { 607sub register_extcmd {
604 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
605 609
606 my $caller = caller; 610 my $caller = caller;
607 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
608 612
609 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
610} 614}
615
616attach_to_players
617 on_command => sub {
618 my ($pl, $name, $params) = @_;
619
620 my $cb = $COMMAND{$name}
621 or return;
622
623 for my $cmd (@$cb) {
624 $cmd->[1]->($pl->ob, $params);
625 }
626
627 cf::override;
628 },
629 on_extcmd => sub {
630 my ($pl, $buf) = @_;
631
632 my $msg = eval { from_json $buf };
633
634 if (ref $msg) {
635 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
636 if (my %reply = $cb->[0]->($pl, $msg)) {
637 $pl->ext_reply ($msg->{msgid}, %reply);
638 }
639 }
640 } else {
641 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
642 }
643
644 cf::override;
645 },
646;
611 647
612sub register { 648sub register {
613 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
614 650
615 #TODO 651 #TODO
… …
634 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
635 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
636 . "\n};\n1"; 672 . "\n};\n1";
637 673
638 eval $source 674 eval $source
639 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
640 677
641 push @exts, $pkg; 678 push @exts, $pkg;
642 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
643 680
644# no strict 'refs'; 681# no strict 'refs';
… …
657# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
658# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
659# } 696# }
660 697
661 # remove commands 698 # remove commands
662 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
663 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
664 701
665 if (@cb) { 702 if (@cb) {
666 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
667 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
668 } else { 704 } else {
669 delete $command{$name};
670 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
671 } 706 }
672 } 707 }
673 708
674 # remove extcmds 709 # remove extcmds
675 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
676 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
677 } 712 }
678 713
679 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
680 eval { 715 eval {
681 $cb->($pkg); 716 $cb->($pkg);
… …
685 720
686 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
687} 722}
688 723
689sub load_extensions { 724sub load_extensions {
690 my $LIBDIR = maps_directory "perl";
691
692 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
693 next unless -r $ext; 726 next unless -r $ext;
694 eval { 727 eval {
695 load_extension $ext; 728 load_extension $ext;
696 1 729 1
697 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
698 } 731 }
699} 732}
700 733
701############################################################################# 734#############################################################################
702# extcmd framework, basically convert ext <msg>
703# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
704
705attach_to_players
706 on_extcmd => sub {
707 my ($pl, $buf) = @_;
708
709 my $msg = eval { from_json $buf };
710
711 if (ref $msg) {
712 if (my $cb = $extcmd{$msg->{msgtype}}) {
713 if (my %reply = $cb->[0]->($pl, $msg)) {
714 $pl->ext_reply ($msg->{msgid}, %reply);
715 }
716 }
717 } else {
718 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
719 }
720
721 cf::override;
722 },
723;
724
725#############################################################################
726# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
727 736
728*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
729 my ($map) = @_; 738 my ($map) = @_;
730 739
… …
775sub cf::player::exists($) { 784sub cf::player::exists($) {
776 cf::player::find $_[0] 785 cf::player::find $_[0]
777 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 786 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
778} 787}
779 788
780=item $object->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
781 790
782Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 791Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
783can be C<undef>. Does the right thing when the player is currently in a 792can be C<undef>. Does the right thing when the player is currently in a
784dialogue with the given NPC character. 793dialogue with the given NPC character.
785 794
… …
812 $msg{msgid} = $id; 821 $msg{msgid} = $id;
813 822
814 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
815} 824}
816 825
817=back 826=item $player_object->may ("access")
827
828Returns wether the given player is authorized to access resource "access"
829(e.g. "command_wizcast").
830
831=cut
832
833sub cf::object::player::may {
834 my ($self, $access) = @_;
835
836 $self->flag (cf::FLAG_WIZ) ||
837 (ref $cf::CFG{"may_$access"}
838 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
839 : $cf::CFG{"may_$access"})
840}
818 841
819=cut 842=cut
820 843
821############################################################################# 844#############################################################################
822 845
… …
824 847
825Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
826snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
827itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
828is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
829functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
830 853
831=cut 854=cut
832 855
833our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
834our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
1000 sub db_sync() { 1023 sub db_sync() {
1001 db_save if $dirty; 1024 db_save if $dirty;
1002 undef $dirty; 1025 undef $dirty;
1003 } 1026 }
1004 1027
1005 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1028 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1006 db_sync; 1029 db_sync;
1007 }); 1030 });
1008 1031
1009 sub db_dirty() { 1032 sub db_dirty() {
1010 $dirty = 1; 1033 $dirty = 1;
… …
1060 1083
1061 $msg->("reloading..."); 1084 $msg->("reloading...");
1062 1085
1063 eval { 1086 eval {
1064 # cancel all watchers 1087 # cancel all watchers
1065 $_->cancel for Event::all_watchers; 1088 for (Event::all_watchers) {
1089 $_->cancel if $_->data & WF_AUTOCANCEL;
1090 }
1066 1091
1067 # unload all extensions 1092 # unload all extensions
1068 for (@exts) { 1093 for (@exts) {
1069 $msg->("unloading <$_>"); 1094 $msg->("unloading <$_>");
1070 unload_extension $_; 1095 unload_extension $_;
… …
1130 warn $_[0]; 1155 warn $_[0];
1131 print "$_[0]\n"; 1156 print "$_[0]\n";
1132 }; 1157 };
1133} 1158}
1134 1159
1160register "<global>", __PACKAGE__;
1161
1135register_command "perl-reload", 0, sub { 1162register_command "perl-reload" => sub {
1136 my ($who, $arg) = @_; 1163 my ($who, $arg) = @_;
1137 1164
1138 if ($who->flag (FLAG_WIZ)) { 1165 if ($who->flag (FLAG_WIZ)) {
1139 _perl_reload { 1166 _perl_reload {
1140 warn $_[0]; 1167 warn $_[0];
1141 $who->message ($_[0]); 1168 $who->message ($_[0]);
1142 }; 1169 };
1143 } 1170 }
1144}; 1171};
1145 1172
1146register "<global>", __PACKAGE__;
1147
1148unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
1149 1174
1150$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
1151 prio => 1, 1176 prio => 1,
1152 async => 1, 1177 async => 1,
1153 at => $NEXT_TICK || 1, 1178 at => $NEXT_TICK || 1,
1179 data => WF_AUTOCANCEL,
1154 cb => sub { 1180 cb => sub {
1155 cf::server_tick; # one server iteration 1181 cf::server_tick; # one server iteration
1156 1182
1157 my $NOW = Event::time; 1183 my $NOW = Event::time;
1158 $NEXT_TICK += $TICK; 1184 $NEXT_TICK += $TICK;
… …
1163 $TICK_WATCHER->at ($NEXT_TICK); 1189 $TICK_WATCHER->at ($NEXT_TICK);
1164 $TICK_WATCHER->start; 1190 $TICK_WATCHER->start;
1165 }, 1191 },
1166); 1192);
1167 1193
1168eval { IO::AIO::max_poll_time $TICK * 0.2 }; #d# remove eval after restart 1194IO::AIO::max_poll_time $TICK * 0.2;
1169 1195
1170Event->io (fd => IO::AIO::poll_fileno, 1196Event->io (fd => IO::AIO::poll_fileno,
1171 poll => 'r', 1197 poll => 'r',
1172 prio => 5, 1198 prio => 5,
1199 data => WF_AUTOCANCEL,
1173 cb => \&IO::AIO::poll_cb); 1200 cb => \&IO::AIO::poll_cb);
1174 1201
11751 12021
1176 1203

Diff Legend

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