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.71 by root, Sun Oct 1 10:59:30 2006 UTC vs.
Revision 1.92 by root, Thu Dec 21 06:42:28 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
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
16_init_vars; 27_init_vars;
17 28
18our %COMMAND = ();
19our @EVENT; 29our @EVENT;
20our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
21 31
22our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 33our $TICK_WATCHER;
24our $NEXT_TICK; 34our $NEXT_TICK;
25 35
26our %CFG; 36our %CFG;
27 37
38our $UPTIME; $UPTIME ||= time;
39
28############################################################################# 40#############################################################################
29 41
30=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
31 43
32=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
33 49
34=item $cf::LIBDIR 50=item $cf::LIBDIR
35 51
36The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
37be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
62 78
63@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
64 80
65# 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
66# within the Safe compartment. 82# within the Safe compartment.
67for 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)) {
68 no strict 'refs'; 89 no strict 'refs';
69 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
70} 91}
71 92
72$Event::DIED = sub { 93$Event::DIED = sub {
… …
74}; 95};
75 96
76my %ext_pkg; 97my %ext_pkg;
77my @exts; 98my @exts;
78my @hook; 99my @hook;
79my %command;
80my %extcmd;
81 100
82=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
83 102
84=over 4 103=over 4
85 104
… …
133 152
134=item $map->attach ($attachment, key => $value...) 153=item $map->attach ($attachment, key => $value...)
135 154
136=item $map->detach ($attachment) 155=item $map->detach ($attachment)
137 156
157Attach/detach a pre-registered attachment to a client.
158
159=item $client->attach ($attachment, key => $value...)
160
161=item $client->detach ($attachment)
162
138Attach/detach a pre-registered attachment to a map. 163Attach/detach a pre-registered attachment to a map.
139 164
140=item $bool = $object->attached ($name) 165=item $bool = $object->attached ($name)
141 166
142=item $bool = $player->attached ($name) 167=item $bool = $player->attached ($name)
168
169=item $bool = $client->attached ($name)
143 170
144=item $bool = $map->attached ($name) 171=item $bool = $map->attached ($name)
145 172
146Checks wether the named attachment is currently attached to the object. 173Checks wether the named attachment is currently attached to the object.
147 174
… …
194 221
195=item cf::attach_to_players ... 222=item cf::attach_to_players ...
196 223
197Attach handlers to all players. 224Attach handlers to all players.
198 225
226=item cf::attach_to_clients ...
227
228Attach handlers to all players.
229
199=item cf::attach_to_maps ... 230=item cf::attach_to_maps ...
200 231
201Attach handlers to all maps. 232Attach handlers to all maps.
202 233
203=item cf:register_attachment $name, ... 234=item cf:register_attachment $name, ...
… …
219 250
220# the following variables are defined in .xs and must not be re-created 251# the following variables are defined in .xs and must not be re-created
221our @CB_GLOBAL = (); # registry for all global events 252our @CB_GLOBAL = (); # registry for all global events
222our @CB_OBJECT = (); # all objects (should not be used except in emergency) 253our @CB_OBJECT = (); # all objects (should not be used except in emergency)
223our @CB_PLAYER = (); 254our @CB_PLAYER = ();
255our @CB_CLIENT = ();
224our @CB_TYPE = (); # registry for type (cf-object class) based events 256our @CB_TYPE = (); # registry for type (cf-object class) based events
225our @CB_MAP = (); 257our @CB_MAP = ();
226 258
227my %attachment; 259my %attachment;
228 260
… …
311 $res 343 $res
312} 344}
313 345
314*cf::object::attach = 346*cf::object::attach =
315*cf::player::attach = 347*cf::player::attach =
348*cf::client::attach =
316*cf::map::attach = sub { 349*cf::map::attach = sub {
317 my ($obj, $name, %arg) = @_; 350 my ($obj, $name, %arg) = @_;
318 351
319 _attach_attachment $obj, $name, %arg; 352 _attach_attachment $obj, $name, %arg;
320}; 353};
321 354
322# all those should be optimised 355# all those should be optimised
323*cf::object::detach = 356*cf::object::detach =
324*cf::player::detach = 357*cf::player::detach =
358*cf::client::detach =
325*cf::map::detach = sub { 359*cf::map::detach = sub {
326 my ($obj, $name) = @_; 360 my ($obj, $name) = @_;
327 361
328 delete $obj->{_attachment}{$name}; 362 delete $obj->{_attachment}{$name};
329 reattach ($obj); 363 reattach ($obj);
330}; 364};
331 365
332*cf::object::attached = 366*cf::object::attached =
333*cf::player::attached = 367*cf::player::attached =
368*cf::client::attached =
334*cf::map::attached = sub { 369*cf::map::attached = sub {
335 my ($obj, $name) = @_; 370 my ($obj, $name) = @_;
336 371
337 exists $obj->{_attachment}{$name} 372 exists $obj->{_attachment}{$name}
338}; 373};
… …
354 389
355sub attach_to_players { 390sub attach_to_players {
356 _attach @CB_PLAYER, KLASS_PLAYER, @_ 391 _attach @CB_PLAYER, KLASS_PLAYER, @_
357} 392}
358 393
394sub attach_to_clients {
395 _attach @CB_CLIENT, KLASS_CLIENT, @_
396}
397
359sub attach_to_maps { 398sub attach_to_maps {
360 _attach @CB_MAP, KLASS_MAP, @_ 399 _attach @CB_MAP, KLASS_MAP, @_
361} 400}
362 401
363sub register_attachment { 402sub register_attachment {
… …
368 407
369sub register_player_attachment { 408sub register_player_attachment {
370 my $name = shift; 409 my $name = shift;
371 410
372 $attachment{$name} = [[KLASS_PLAYER, @_]]; 411 $attachment{$name} = [[KLASS_PLAYER, @_]];
412}
413
414sub register_client_attachment {
415 my $name = shift;
416
417 $attachment{$name} = [[KLASS_CLIENT, @_]];
373} 418}
374 419
375sub register_map_attachment { 420sub register_map_attachment {
376 my $name = shift; 421 my $name = shift;
377 422
… …
413 458
414=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 459=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
415 460
416=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 461=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
417 462
463=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
464
418=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 465=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
419 466
420Generate a global/object/player/map-specific event with the given arguments. 467Generate a global/object/player/map-specific event with the given arguments.
421 468
422This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 469This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
… …
431 478
432=head2 METHODS VALID FOR ALL CORE OBJECTS 479=head2 METHODS VALID FOR ALL CORE OBJECTS
433 480
434=over 4 481=over 4
435 482
436=item $object->valid, $player->valid, $map->valid 483=item $object->valid, $player->valid, $client->valid, $map->valid
437 484
438Just because you have a perl object does not mean that the corresponding 485Just because you have a perl object does not mean that the corresponding
439C-level object still exists. If you try to access an object that has no 486C-level object still exists. If you try to access an object that has no
440valid C counterpart anymore you get an exception at runtime. This method 487valid C counterpart anymore you get an exception at runtime. This method
441can be used to test for existence of the C object part without causing an 488can be used to test for existence of the C object part without causing an
… …
445 492
446=cut 493=cut
447 494
448*cf::object::valid = 495*cf::object::valid =
449*cf::player::valid = 496*cf::player::valid =
497*cf::client::valid =
450*cf::map::valid = \&cf::_valid; 498*cf::map::valid = \&cf::_valid;
451 499
452############################################################################# 500#############################################################################
453# object support 501# object support
454 502
… …
514 unlink $filename; 562 unlink $filename;
515 unlink "$filename.pst"; 563 unlink "$filename.pst";
516 } 564 }
517} 565}
518 566
567sub object_freezer_as_string {
568 my ($rdata, $objs) = @_;
569
570 use Data::Dumper;
571
572 $$rdata . Dumper $objs
573}
574
519sub object_thawer_load { 575sub object_thawer_load {
520 my ($filename) = @_; 576 my ($filename) = @_;
521 577
522 local $/; 578 local $/;
523 579
… …
548 if exists $src->{_attachment}; 604 if exists $src->{_attachment};
549 }, 605 },
550; 606;
551 607
552############################################################################# 608#############################################################################
553# old plug-in events 609# command handling &c
554 610
555sub inject_event { 611=item cf::register_command $name => \&callback($ob,$args);
556 my $extension = shift;
557 my $event_code = shift;
558 612
559 my $cb = $hook[$event_code]{$extension} 613Register a callback for execution when the client sends the user command
560 or return; 614$name.
561 615
562 &$cb 616=cut
563}
564
565sub inject_global_event {
566 my $event = shift;
567
568 my $cb = $hook[$event]
569 or return;
570
571 List::Util::max map &$_, values %$cb
572}
573
574sub inject_command {
575 my ($name, $obj, $params) = @_;
576
577 for my $cmd (@{ $command{$name} }) {
578 $cmd->[1]->($obj, $params);
579 }
580
581 -1
582}
583 617
584sub register_command { 618sub register_command {
585 my ($name, $time, $cb) = @_; 619 my ($name, $cb) = @_;
586 620
587 my $caller = caller; 621 my $caller = caller;
588 #warn "registering command '$name/$time' to '$caller'"; 622 #warn "registering command '$name/$time' to '$caller'";
589 623
590 push @{ $command{$name} }, [$time, $cb, $caller]; 624 push @{ $COMMAND{$name} }, [$caller, $cb];
591 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
592} 625}
626
627=item cf::register_extcmd $name => \&callback($pl,$packet);
628
629Register a callbackf ro execution when the client sends an extcmd packet.
630
631If the callback returns something, it is sent back as if reply was being
632called.
633
634=cut
593 635
594sub register_extcmd { 636sub register_extcmd {
595 my ($name, $cb) = @_; 637 my ($name, $cb) = @_;
596 638
597 my $caller = caller; 639 my $caller = caller;
598 #warn "registering extcmd '$name' to '$caller'"; 640 #warn "registering extcmd '$name' to '$caller'";
599 641
600 $extcmd{$name} = [$cb, $caller]; 642 $EXTCMD{$name} = [$cb, $caller];
601} 643}
644
645attach_to_players
646 on_command => sub {
647 my ($pl, $name, $params) = @_;
648
649 my $cb = $COMMAND{$name}
650 or return;
651
652 for my $cmd (@$cb) {
653 $cmd->[1]->($pl->ob, $params);
654 }
655
656 cf::override;
657 },
658 on_extcmd => sub {
659 my ($pl, $buf) = @_;
660
661 my $msg = eval { from_json $buf };
662
663 if (ref $msg) {
664 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
665 if (my %reply = $cb->[0]->($pl, $msg)) {
666 $pl->ext_reply ($msg->{msgid}, %reply);
667 }
668 }
669 } else {
670 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
671 }
672
673 cf::override;
674 },
675;
602 676
603sub register { 677sub register {
604 my ($base, $pkg) = @_; 678 my ($base, $pkg) = @_;
605 679
606 #TODO 680 #TODO
… …
625 . "#line 1 \"$path\"\n{\n" 699 . "#line 1 \"$path\"\n{\n"
626 . (do { local $/; <$fh> }) 700 . (do { local $/; <$fh> })
627 . "\n};\n1"; 701 . "\n};\n1";
628 702
629 eval $source 703 eval $source
630 or die "$path: $@"; 704 or die $@ ? "$path: $@\n"
705 : "extension disabled.\n";
631 706
632 push @exts, $pkg; 707 push @exts, $pkg;
633 $ext_pkg{$base} = $pkg; 708 $ext_pkg{$base} = $pkg;
634 709
635# no strict 'refs'; 710# no strict 'refs';
… …
648# for my $idx (0 .. $#PLUGIN_EVENT) { 723# for my $idx (0 .. $#PLUGIN_EVENT) {
649# delete $hook[$idx]{$pkg}; 724# delete $hook[$idx]{$pkg};
650# } 725# }
651 726
652 # remove commands 727 # remove commands
653 for my $name (keys %command) { 728 for my $name (keys %COMMAND) {
654 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 729 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
655 730
656 if (@cb) { 731 if (@cb) {
657 $command{$name} = \@cb; 732 $COMMAND{$name} = \@cb;
658 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
659 } else { 733 } else {
660 delete $command{$name};
661 delete $COMMAND{"$name\000"}; 734 delete $COMMAND{$name};
662 } 735 }
663 } 736 }
664 737
665 # remove extcmds 738 # remove extcmds
666 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 739 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
667 delete $extcmd{$name}; 740 delete $EXTCMD{$name};
668 } 741 }
669 742
670 if (my $cb = $pkg->can ("unload")) { 743 if (my $cb = $pkg->can ("unload")) {
671 eval { 744 eval {
672 $cb->($pkg); 745 $cb->($pkg);
… …
676 749
677 Symbol::delete_package $pkg; 750 Symbol::delete_package $pkg;
678} 751}
679 752
680sub load_extensions { 753sub load_extensions {
681 my $LIBDIR = maps_directory "perl";
682
683 for my $ext (<$LIBDIR/*.ext>) { 754 for my $ext (<$LIBDIR/*.ext>) {
684 next unless -r $ext; 755 next unless -r $ext;
685 eval { 756 eval {
686 load_extension $ext; 757 load_extension $ext;
687 1 758 1
688 } or warn "$ext not loaded: $@"; 759 } or warn "$ext not loaded: $@";
689 } 760 }
690} 761}
691 762
692############################################################################# 763#############################################################################
693# extcmd framework, basically convert ext <msg>
694# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
695
696attach_to_players
697 on_extcmd => sub {
698 my ($pl, $buf) = @_;
699
700 my $msg = eval { from_json $buf };
701
702 if (ref $msg) {
703 if (my $cb = $extcmd{$msg->{msgtype}}) {
704 if (my %reply = $cb->[0]->($pl, $msg)) {
705 $pl->ext_reply ($msg->{msgid}, %reply);
706 }
707 }
708 } else {
709 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
710 }
711
712 cf::override;
713 },
714;
715
716#############################################################################
717# load/save/clean perl data associated with a map 764# load/save/clean perl data associated with a map
718 765
719*cf::mapsupport::on_clean = sub { 766*cf::mapsupport::on_clean = sub {
720 my ($map) = @_; 767 my ($map) = @_;
721 768
… …
766sub cf::player::exists($) { 813sub cf::player::exists($) {
767 cf::player::find $_[0] 814 cf::player::find $_[0]
768 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 815 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
769} 816}
770 817
771=item $player->reply ($npc, $msg[, $flags]) 818=item $player_object->reply ($npc, $msg[, $flags])
772 819
773Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 820Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
774can be C<undef>. Does the right thing when the player is currently in a 821can be C<undef>. Does the right thing when the player is currently in a
775dialogue with the given NPC character. 822dialogue with the given NPC character.
776 823
… …
803 $msg{msgid} = $id; 850 $msg{msgid} = $id;
804 851
805 $self->send ("ext " . to_json \%msg); 852 $self->send ("ext " . to_json \%msg);
806} 853}
807 854
808=back 855=item $player_object->may ("access")
856
857Returns wether the given player is authorized to access resource "access"
858(e.g. "command_wizcast").
859
860=cut
861
862sub cf::object::player::may {
863 my ($self, $access) = @_;
864
865 $self->flag (cf::FLAG_WIZ) ||
866 (ref $cf::CFG{"may_$access"}
867 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
868 : $cf::CFG{"may_$access"})
869}
809 870
810=cut 871=cut
811 872
812############################################################################# 873#############################################################################
813 874
… …
815 876
816Functions that provide a safe environment to compile and execute 877Functions that provide a safe environment to compile and execute
817snippets of perl code without them endangering the safety of the server 878snippets of perl code without them endangering the safety of the server
818itself. Looping constructs, I/O operators and other built-in functionality 879itself. Looping constructs, I/O operators and other built-in functionality
819is not available in the safe scripting environment, and the number of 880is not available in the safe scripting environment, and the number of
820functions and methods that cna be called is greatly reduced. 881functions and methods that can be called is greatly reduced.
821 882
822=cut 883=cut
823 884
824our $safe = new Safe "safe"; 885our $safe = new Safe "safe";
825our $safe_hole = new Safe::Hole; 886our $safe_hole = new Safe::Hole;
… …
832 893
833=pod 894=pod
834 895
835The following fucntions and emthods are available within a safe environment: 896The following fucntions and emthods are available within a safe environment:
836 897
837 cf::object contr pay_amount pay_player 898 cf::object contr pay_amount pay_player map
838 cf::object::player player 899 cf::object::player player
839 cf::player peaceful 900 cf::player peaceful
901 cf::map trigger
840 902
841=cut 903=cut
842 904
843for ( 905for (
844 ["cf::object" => qw(contr pay_amount pay_player)], 906 ["cf::object" => qw(contr pay_amount pay_player map)],
845 ["cf::object::player" => qw(player)], 907 ["cf::object::player" => qw(player)],
846 ["cf::player" => qw(peaceful)], 908 ["cf::player" => qw(peaceful)],
909 ["cf::map" => qw(trigger)],
847) { 910) {
848 no strict 'refs'; 911 no strict 'refs';
849 my ($pkg, @funs) = @$_; 912 my ($pkg, @funs) = @$_;
850 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 913 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
851 for @funs; 914 for @funs;
… …
961 1024
962Immediately write the database to disk I<if it is dirty>. 1025Immediately write the database to disk I<if it is dirty>.
963 1026
964=cut 1027=cut
965 1028
1029our $DB;
1030
966{ 1031{
967 my $db;
968 my $path = cf::localdir . "/database.pst"; 1032 my $path = cf::localdir . "/database.pst";
969 1033
970 sub db_load() { 1034 sub db_load() {
971 warn "loading database $path\n";#d# remove later 1035 warn "loading database $path\n";#d# remove later
972 $db = stat $path ? Storable::retrieve $path : { }; 1036 $DB = stat $path ? Storable::retrieve $path : { };
973 } 1037 }
974 1038
975 my $pid; 1039 my $pid;
976 1040
977 sub db_save() { 1041 sub db_save() {
978 warn "saving database $path\n";#d# remove later 1042 warn "saving database $path\n";#d# remove later
979 waitpid $pid, 0 if $pid; 1043 waitpid $pid, 0 if $pid;
980 if (0 == ($pid = fork)) { 1044 if (0 == ($pid = fork)) {
981 $db->{_meta}{version} = 1; 1045 $DB->{_meta}{version} = 1;
982 Storable::nstore $db, "$path~"; 1046 Storable::nstore $DB, "$path~";
983 rename "$path~", $path; 1047 rename "$path~", $path;
984 cf::_exit 0 if defined $pid; 1048 cf::_exit 0 if defined $pid;
985 } 1049 }
986 } 1050 }
987 1051
… …
990 sub db_sync() { 1054 sub db_sync() {
991 db_save if $dirty; 1055 db_save if $dirty;
992 undef $dirty; 1056 undef $dirty;
993 } 1057 }
994 1058
995 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1059 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
996 db_sync; 1060 db_sync;
997 }); 1061 });
998 1062
999 sub db_dirty() { 1063 sub db_dirty() {
1000 $dirty = 1; 1064 $dirty = 1;
1001 $idle->start; 1065 $idle->start;
1002 } 1066 }
1003 1067
1004 sub db_get($;$) { 1068 sub db_get($;$) {
1005 @_ >= 2 1069 @_ >= 2
1006 ? $db->{$_[0]}{$_[1]} 1070 ? $DB->{$_[0]}{$_[1]}
1007 : ($db->{$_[0]} ||= { }) 1071 : ($DB->{$_[0]} ||= { })
1008 } 1072 }
1009 1073
1010 sub db_put($$;$) { 1074 sub db_put($$;$) {
1011 if (@_ >= 3) { 1075 if (@_ >= 3) {
1012 $db->{$_[0]}{$_[1]} = $_[2]; 1076 $DB->{$_[0]}{$_[1]} = $_[2];
1013 } else { 1077 } else {
1014 $db->{$_[0]} = $_[1]; 1078 $DB->{$_[0]} = $_[1];
1015 } 1079 }
1016 db_dirty; 1080 db_dirty;
1017 } 1081 }
1018 1082
1019 attach_global 1083 attach_global
… …
1025} 1089}
1026 1090
1027############################################################################# 1091#############################################################################
1028# the server's main() 1092# the server's main()
1029 1093
1094sub cfg_load {
1095 open my $fh, "<:utf8", cf::confdir . "/config"
1096 or return;
1097
1098 local $/;
1099 *CFG = YAML::Syck::Load <$fh>;
1100}
1101
1030sub main { 1102sub main {
1103 cfg_load;
1031 db_load; 1104 db_load;
1032 load_extensions; 1105 load_extensions;
1033 Event::loop; 1106 Event::loop;
1034} 1107}
1035 1108
… …
1041 1114
1042 $msg->("reloading..."); 1115 $msg->("reloading...");
1043 1116
1044 eval { 1117 eval {
1045 # cancel all watchers 1118 # cancel all watchers
1046 $_->cancel for Event::all_watchers; 1119 for (Event::all_watchers) {
1120 $_->cancel if $_->data & WF_AUTOCANCEL;
1121 }
1047 1122
1048 # unload all extensions 1123 # unload all extensions
1049 for (@exts) { 1124 for (@exts) {
1050 $msg->("unloading <$_>"); 1125 $msg->("unloading <$_>");
1051 unload_extension $_; 1126 unload_extension $_;
… …
1087 1162
1088 # reload cf.pm 1163 # reload cf.pm
1089 $msg->("reloading cf.pm"); 1164 $msg->("reloading cf.pm");
1090 require cf; 1165 require cf;
1091 1166
1092 # load database again 1167 # load config and database again
1168 cf::cfg_load;
1093 cf::db_load; 1169 cf::db_load;
1094 1170
1095 # load extensions 1171 # load extensions
1096 $msg->("load extensions"); 1172 $msg->("load extensions");
1097 cf::load_extensions; 1173 cf::load_extensions;
… …
1110 warn $_[0]; 1186 warn $_[0];
1111 print "$_[0]\n"; 1187 print "$_[0]\n";
1112 }; 1188 };
1113} 1189}
1114 1190
1191register "<global>", __PACKAGE__;
1192
1115register_command "perl-reload", 0, sub { 1193register_command "perl-reload" => sub {
1116 my ($who, $arg) = @_; 1194 my ($who, $arg) = @_;
1117 1195
1118 if ($who->flag (FLAG_WIZ)) { 1196 if ($who->flag (FLAG_WIZ)) {
1119 _perl_reload { 1197 _perl_reload {
1120 warn $_[0]; 1198 warn $_[0];
1121 $who->message ($_[0]); 1199 $who->message ($_[0]);
1122 }; 1200 };
1123 } 1201 }
1124}; 1202};
1125 1203
1126register "<global>", __PACKAGE__;
1127
1128unshift @INC, $LIBDIR; 1204unshift @INC, $LIBDIR;
1129 1205
1130$TICK_WATCHER = Event->timer ( 1206$TICK_WATCHER = Event->timer (
1131 prio => 1, 1207 prio => 0,
1132 at => $NEXT_TICK || 1, 1208 at => $NEXT_TICK || 1,
1209 data => WF_AUTOCANCEL,
1133 cb => sub { 1210 cb => sub {
1134 cf::server_tick; # one server iteration 1211 cf::server_tick; # one server iteration
1135 1212
1136 my $NOW = Event::time; 1213 my $NOW = Event::time;
1137 $NEXT_TICK += $TICK; 1214 $NEXT_TICK += $TICK;
1138 1215
1139 # if we are delayed by four ticks, skip them all 1216 # if we are delayed by four ticks or more, skip them all
1140 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1217 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1141 1218
1142 $TICK_WATCHER->at ($NEXT_TICK); 1219 $TICK_WATCHER->at ($NEXT_TICK);
1143 $TICK_WATCHER->start; 1220 $TICK_WATCHER->start;
1144 }, 1221 },
1145); 1222);
1146 1223
1224IO::AIO::max_poll_time $TICK * 0.2;
1225
1226Event->io (fd => IO::AIO::poll_fileno,
1227 poll => 'r',
1228 prio => 5,
1229 data => WF_AUTOCANCEL,
1230 cb => \&IO::AIO::poll_cb);
1231
11471 12321
1148 1233

Diff Legend

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