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.91 by elmex, Sun Dec 17 22:03:44 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 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;
… …
841 864
842=pod 865=pod
843 866
844The following fucntions and emthods are available within a safe environment: 867The following fucntions and emthods are available within a safe environment:
845 868
846 cf::object contr pay_amount pay_player 869 cf::object contr pay_amount pay_player map
847 cf::object::player player 870 cf::object::player player
848 cf::player peaceful 871 cf::player peaceful
872 cf::map trigger
849 873
850=cut 874=cut
851 875
852for ( 876for (
853 ["cf::object" => qw(contr pay_amount pay_player)], 877 ["cf::object" => qw(contr pay_amount pay_player map)],
854 ["cf::object::player" => qw(player)], 878 ["cf::object::player" => qw(player)],
855 ["cf::player" => qw(peaceful)], 879 ["cf::player" => qw(peaceful)],
880 ["cf::map" => qw(trigger)],
856) { 881) {
857 no strict 'refs'; 882 no strict 'refs';
858 my ($pkg, @funs) = @$_; 883 my ($pkg, @funs) = @$_;
859 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 884 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
860 for @funs; 885 for @funs;
… …
1000 sub db_sync() { 1025 sub db_sync() {
1001 db_save if $dirty; 1026 db_save if $dirty;
1002 undef $dirty; 1027 undef $dirty;
1003 } 1028 }
1004 1029
1005 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1030 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1006 db_sync; 1031 db_sync;
1007 }); 1032 });
1008 1033
1009 sub db_dirty() { 1034 sub db_dirty() {
1010 $dirty = 1; 1035 $dirty = 1;
… …
1060 1085
1061 $msg->("reloading..."); 1086 $msg->("reloading...");
1062 1087
1063 eval { 1088 eval {
1064 # cancel all watchers 1089 # cancel all watchers
1065 $_->cancel for Event::all_watchers; 1090 for (Event::all_watchers) {
1091 $_->cancel if $_->data & WF_AUTOCANCEL;
1092 }
1066 1093
1067 # unload all extensions 1094 # unload all extensions
1068 for (@exts) { 1095 for (@exts) {
1069 $msg->("unloading <$_>"); 1096 $msg->("unloading <$_>");
1070 unload_extension $_; 1097 unload_extension $_;
… …
1130 warn $_[0]; 1157 warn $_[0];
1131 print "$_[0]\n"; 1158 print "$_[0]\n";
1132 }; 1159 };
1133} 1160}
1134 1161
1162register "<global>", __PACKAGE__;
1163
1135register_command "perl-reload", 0, sub { 1164register_command "perl-reload" => sub {
1136 my ($who, $arg) = @_; 1165 my ($who, $arg) = @_;
1137 1166
1138 if ($who->flag (FLAG_WIZ)) { 1167 if ($who->flag (FLAG_WIZ)) {
1139 _perl_reload { 1168 _perl_reload {
1140 warn $_[0]; 1169 warn $_[0];
1141 $who->message ($_[0]); 1170 $who->message ($_[0]);
1142 }; 1171 };
1143 } 1172 }
1144}; 1173};
1145 1174
1146register "<global>", __PACKAGE__;
1147
1148unshift @INC, $LIBDIR; 1175unshift @INC, $LIBDIR;
1149 1176
1150$TICK_WATCHER = Event->timer ( 1177$TICK_WATCHER = Event->timer (
1151 prio => 1, 1178 prio => 0,
1152 async => 1,
1153 at => $NEXT_TICK || 1, 1179 at => $NEXT_TICK || 1,
1180 data => WF_AUTOCANCEL,
1154 cb => sub { 1181 cb => sub {
1155 cf::server_tick; # one server iteration 1182 cf::server_tick; # one server iteration
1156 1183
1157 my $NOW = Event::time; 1184 my $NOW = Event::time;
1158 $NEXT_TICK += $TICK; 1185 $NEXT_TICK += $TICK;
… …
1163 $TICK_WATCHER->at ($NEXT_TICK); 1190 $TICK_WATCHER->at ($NEXT_TICK);
1164 $TICK_WATCHER->start; 1191 $TICK_WATCHER->start;
1165 }, 1192 },
1166); 1193);
1167 1194
1168eval { IO::AIO::max_poll_time $TICK * 0.2 }; #d# remove eval after restart 1195IO::AIO::max_poll_time $TICK * 0.2;
1169 1196
1170Event->io (fd => IO::AIO::poll_fileno, 1197Event->io (fd => IO::AIO::poll_fileno,
1171 poll => 'r', 1198 poll => 'r',
1172 prio => 5, 1199 prio => 5,
1200 data => WF_AUTOCANCEL,
1173 cb => \&IO::AIO::poll_cb); 1201 cb => \&IO::AIO::poll_cb);
1174 1202
11751 12031
1176 1204

Diff Legend

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