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.76 by root, Mon Oct 2 15:28:36 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 ();
10use YAML::Syck (); 11use YAML::Syck ();
11use Time::HiRes; 12use Time::HiRes;
12use Event; 13use Event;
13$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
14 15
15# 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?
16$YAML::Syck::ImplicitUnicode = 1; 17$YAML::Syck::ImplicitUnicode = 1;
17 18
18use strict; 19use strict;
19 20
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
20_init_vars; 27_init_vars;
21 28
22our %COMMAND = ();
23our @EVENT; 29our @EVENT;
24our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
25 31
26our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
27our $TICK_WATCHER; 33our $TICK_WATCHER;
28our $NEXT_TICK; 34our $NEXT_TICK;
29 35
30our %CFG; 36our %CFG;
31 37
32our $uptime; 38our $UPTIME; $UPTIME ||= time;
33
34$uptime ||= time;
35 39
36############################################################################# 40#############################################################################
37 41
38=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
39 43
40=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
41 49
42=item $cf::LIBDIR 50=item $cf::LIBDIR
43 51
44The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
45be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
70 78
71@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72 80
73# 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
74# within the Safe compartment. 82# within the Safe compartment.
75for 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)) {
76 no strict 'refs'; 89 no strict 'refs';
77 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78} 91}
79 92
80$Event::DIED = sub { 93$Event::DIED = sub {
… …
82}; 95};
83 96
84my %ext_pkg; 97my %ext_pkg;
85my @exts; 98my @exts;
86my @hook; 99my @hook;
87my %command;
88my %extcmd;
89 100
90=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
91 102
92=over 4 103=over 4
93 104
… …
141 152
142=item $map->attach ($attachment, key => $value...) 153=item $map->attach ($attachment, key => $value...)
143 154
144=item $map->detach ($attachment) 155=item $map->detach ($attachment)
145 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
146Attach/detach a pre-registered attachment to a map. 163Attach/detach a pre-registered attachment to a map.
147 164
148=item $bool = $object->attached ($name) 165=item $bool = $object->attached ($name)
149 166
150=item $bool = $player->attached ($name) 167=item $bool = $player->attached ($name)
168
169=item $bool = $client->attached ($name)
151 170
152=item $bool = $map->attached ($name) 171=item $bool = $map->attached ($name)
153 172
154Checks wether the named attachment is currently attached to the object. 173Checks wether the named attachment is currently attached to the object.
155 174
… …
202 221
203=item cf::attach_to_players ... 222=item cf::attach_to_players ...
204 223
205Attach handlers to all players. 224Attach handlers to all players.
206 225
226=item cf::attach_to_clients ...
227
228Attach handlers to all players.
229
207=item cf::attach_to_maps ... 230=item cf::attach_to_maps ...
208 231
209Attach handlers to all maps. 232Attach handlers to all maps.
210 233
211=item cf:register_attachment $name, ... 234=item cf:register_attachment $name, ...
… …
227 250
228# 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
229our @CB_GLOBAL = (); # registry for all global events 252our @CB_GLOBAL = (); # registry for all global events
230our @CB_OBJECT = (); # all objects (should not be used except in emergency) 253our @CB_OBJECT = (); # all objects (should not be used except in emergency)
231our @CB_PLAYER = (); 254our @CB_PLAYER = ();
255our @CB_CLIENT = ();
232our @CB_TYPE = (); # registry for type (cf-object class) based events 256our @CB_TYPE = (); # registry for type (cf-object class) based events
233our @CB_MAP = (); 257our @CB_MAP = ();
234 258
235my %attachment; 259my %attachment;
236 260
… …
319 $res 343 $res
320} 344}
321 345
322*cf::object::attach = 346*cf::object::attach =
323*cf::player::attach = 347*cf::player::attach =
348*cf::client::attach =
324*cf::map::attach = sub { 349*cf::map::attach = sub {
325 my ($obj, $name, %arg) = @_; 350 my ($obj, $name, %arg) = @_;
326 351
327 _attach_attachment $obj, $name, %arg; 352 _attach_attachment $obj, $name, %arg;
328}; 353};
329 354
330# all those should be optimised 355# all those should be optimised
331*cf::object::detach = 356*cf::object::detach =
332*cf::player::detach = 357*cf::player::detach =
358*cf::client::detach =
333*cf::map::detach = sub { 359*cf::map::detach = sub {
334 my ($obj, $name) = @_; 360 my ($obj, $name) = @_;
335 361
336 delete $obj->{_attachment}{$name}; 362 delete $obj->{_attachment}{$name};
337 reattach ($obj); 363 reattach ($obj);
338}; 364};
339 365
340*cf::object::attached = 366*cf::object::attached =
341*cf::player::attached = 367*cf::player::attached =
368*cf::client::attached =
342*cf::map::attached = sub { 369*cf::map::attached = sub {
343 my ($obj, $name) = @_; 370 my ($obj, $name) = @_;
344 371
345 exists $obj->{_attachment}{$name} 372 exists $obj->{_attachment}{$name}
346}; 373};
… …
362 389
363sub attach_to_players { 390sub attach_to_players {
364 _attach @CB_PLAYER, KLASS_PLAYER, @_ 391 _attach @CB_PLAYER, KLASS_PLAYER, @_
365} 392}
366 393
394sub attach_to_clients {
395 _attach @CB_CLIENT, KLASS_CLIENT, @_
396}
397
367sub attach_to_maps { 398sub attach_to_maps {
368 _attach @CB_MAP, KLASS_MAP, @_ 399 _attach @CB_MAP, KLASS_MAP, @_
369} 400}
370 401
371sub register_attachment { 402sub register_attachment {
… …
376 407
377sub register_player_attachment { 408sub register_player_attachment {
378 my $name = shift; 409 my $name = shift;
379 410
380 $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, @_]];
381} 418}
382 419
383sub register_map_attachment { 420sub register_map_attachment {
384 my $name = shift; 421 my $name = shift;
385 422
… …
421 458
422=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 459=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
423 460
424=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 461=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
425 462
463=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
464
426=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 465=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
427 466
428Generate a global/object/player/map-specific event with the given arguments. 467Generate a global/object/player/map-specific event with the given arguments.
429 468
430This 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
… …
439 478
440=head2 METHODS VALID FOR ALL CORE OBJECTS 479=head2 METHODS VALID FOR ALL CORE OBJECTS
441 480
442=over 4 481=over 4
443 482
444=item $object->valid, $player->valid, $map->valid 483=item $object->valid, $player->valid, $client->valid, $map->valid
445 484
446Just 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
447C-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
448valid C counterpart anymore you get an exception at runtime. This method 487valid C counterpart anymore you get an exception at runtime. This method
449can 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
… …
453 492
454=cut 493=cut
455 494
456*cf::object::valid = 495*cf::object::valid =
457*cf::player::valid = 496*cf::player::valid =
497*cf::client::valid =
458*cf::map::valid = \&cf::_valid; 498*cf::map::valid = \&cf::_valid;
459 499
460############################################################################# 500#############################################################################
461# object support 501# object support
462 502
… …
522 unlink $filename; 562 unlink $filename;
523 unlink "$filename.pst"; 563 unlink "$filename.pst";
524 } 564 }
525} 565}
526 566
567sub object_freezer_as_string {
568 my ($rdata, $objs) = @_;
569
570 use Data::Dumper;
571
572 $$rdata . Dumper $objs
573}
574
527sub object_thawer_load { 575sub object_thawer_load {
528 my ($filename) = @_; 576 my ($filename) = @_;
529 577
530 local $/; 578 local $/;
531 579
… …
556 if exists $src->{_attachment}; 604 if exists $src->{_attachment};
557 }, 605 },
558; 606;
559 607
560############################################################################# 608#############################################################################
561# old plug-in events 609# command handling &c
562 610
563sub inject_event { 611=item cf::register_command $name => \&callback($ob,$args);
564 my $extension = shift;
565 my $event_code = shift;
566 612
567 my $cb = $hook[$event_code]{$extension} 613Register a callback for execution when the client sends the user command
568 or return; 614$name.
569 615
570 &$cb 616=cut
571}
572
573sub inject_global_event {
574 my $event = shift;
575
576 my $cb = $hook[$event]
577 or return;
578
579 List::Util::max map &$_, values %$cb
580}
581
582sub inject_command {
583 my ($name, $obj, $params) = @_;
584
585 for my $cmd (@{ $command{$name} }) {
586 $cmd->[1]->($obj, $params);
587 }
588
589 -1
590}
591 617
592sub register_command { 618sub register_command {
593 my ($name, $time, $cb) = @_; 619 my ($name, $cb) = @_;
594 620
595 my $caller = caller; 621 my $caller = caller;
596 #warn "registering command '$name/$time' to '$caller'"; 622 #warn "registering command '$name/$time' to '$caller'";
597 623
598 push @{ $command{$name} }, [$time, $cb, $caller]; 624 push @{ $COMMAND{$name} }, [$caller, $cb];
599 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
600} 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
601 635
602sub register_extcmd { 636sub register_extcmd {
603 my ($name, $cb) = @_; 637 my ($name, $cb) = @_;
604 638
605 my $caller = caller; 639 my $caller = caller;
606 #warn "registering extcmd '$name' to '$caller'"; 640 #warn "registering extcmd '$name' to '$caller'";
607 641
608 $extcmd{$name} = [$cb, $caller]; 642 $EXTCMD{$name} = [$cb, $caller];
609} 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;
610 676
611sub register { 677sub register {
612 my ($base, $pkg) = @_; 678 my ($base, $pkg) = @_;
613 679
614 #TODO 680 #TODO
… …
633 . "#line 1 \"$path\"\n{\n" 699 . "#line 1 \"$path\"\n{\n"
634 . (do { local $/; <$fh> }) 700 . (do { local $/; <$fh> })
635 . "\n};\n1"; 701 . "\n};\n1";
636 702
637 eval $source 703 eval $source
638 or die "$path: $@"; 704 or die $@ ? "$path: $@\n"
705 : "extension disabled.\n";
639 706
640 push @exts, $pkg; 707 push @exts, $pkg;
641 $ext_pkg{$base} = $pkg; 708 $ext_pkg{$base} = $pkg;
642 709
643# no strict 'refs'; 710# no strict 'refs';
… …
656# for my $idx (0 .. $#PLUGIN_EVENT) { 723# for my $idx (0 .. $#PLUGIN_EVENT) {
657# delete $hook[$idx]{$pkg}; 724# delete $hook[$idx]{$pkg};
658# } 725# }
659 726
660 # remove commands 727 # remove commands
661 for my $name (keys %command) { 728 for my $name (keys %COMMAND) {
662 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 729 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
663 730
664 if (@cb) { 731 if (@cb) {
665 $command{$name} = \@cb; 732 $COMMAND{$name} = \@cb;
666 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
667 } else { 733 } else {
668 delete $command{$name};
669 delete $COMMAND{"$name\000"}; 734 delete $COMMAND{$name};
670 } 735 }
671 } 736 }
672 737
673 # remove extcmds 738 # remove extcmds
674 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 739 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
675 delete $extcmd{$name}; 740 delete $EXTCMD{$name};
676 } 741 }
677 742
678 if (my $cb = $pkg->can ("unload")) { 743 if (my $cb = $pkg->can ("unload")) {
679 eval { 744 eval {
680 $cb->($pkg); 745 $cb->($pkg);
… …
684 749
685 Symbol::delete_package $pkg; 750 Symbol::delete_package $pkg;
686} 751}
687 752
688sub load_extensions { 753sub load_extensions {
689 my $LIBDIR = maps_directory "perl";
690
691 for my $ext (<$LIBDIR/*.ext>) { 754 for my $ext (<$LIBDIR/*.ext>) {
692 next unless -r $ext; 755 next unless -r $ext;
693 eval { 756 eval {
694 load_extension $ext; 757 load_extension $ext;
695 1 758 1
696 } or warn "$ext not loaded: $@"; 759 } or warn "$ext not loaded: $@";
697 } 760 }
698} 761}
699 762
700############################################################################# 763#############################################################################
701# extcmd framework, basically convert ext <msg>
702# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
703
704attach_to_players
705 on_extcmd => sub {
706 my ($pl, $buf) = @_;
707
708 my $msg = eval { from_json $buf };
709
710 if (ref $msg) {
711 if (my $cb = $extcmd{$msg->{msgtype}}) {
712 if (my %reply = $cb->[0]->($pl, $msg)) {
713 $pl->ext_reply ($msg->{msgid}, %reply);
714 }
715 }
716 } else {
717 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
718 }
719
720 cf::override;
721 },
722;
723
724#############################################################################
725# load/save/clean perl data associated with a map 764# load/save/clean perl data associated with a map
726 765
727*cf::mapsupport::on_clean = sub { 766*cf::mapsupport::on_clean = sub {
728 my ($map) = @_; 767 my ($map) = @_;
729 768
… …
774sub cf::player::exists($) { 813sub cf::player::exists($) {
775 cf::player::find $_[0] 814 cf::player::find $_[0]
776 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;
777} 816}
778 817
779=item $object->reply ($npc, $msg[, $flags]) 818=item $player_object->reply ($npc, $msg[, $flags])
780 819
781Sends 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>
782can 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
783dialogue with the given NPC character. 822dialogue with the given NPC character.
784 823
… …
811 $msg{msgid} = $id; 850 $msg{msgid} = $id;
812 851
813 $self->send ("ext " . to_json \%msg); 852 $self->send ("ext " . to_json \%msg);
814} 853}
815 854
816=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}
817 870
818=cut 871=cut
819 872
820############################################################################# 873#############################################################################
821 874
… …
823 876
824Functions that provide a safe environment to compile and execute 877Functions that provide a safe environment to compile and execute
825snippets of perl code without them endangering the safety of the server 878snippets of perl code without them endangering the safety of the server
826itself. Looping constructs, I/O operators and other built-in functionality 879itself. Looping constructs, I/O operators and other built-in functionality
827is not available in the safe scripting environment, and the number of 880is not available in the safe scripting environment, and the number of
828functions and methods that cna be called is greatly reduced. 881functions and methods that can be called is greatly reduced.
829 882
830=cut 883=cut
831 884
832our $safe = new Safe "safe"; 885our $safe = new Safe "safe";
833our $safe_hole = new Safe::Hole; 886our $safe_hole = new Safe::Hole;
… …
840 893
841=pod 894=pod
842 895
843The following fucntions and emthods are available within a safe environment: 896The following fucntions and emthods are available within a safe environment:
844 897
845 cf::object contr pay_amount pay_player 898 cf::object contr pay_amount pay_player map
846 cf::object::player player 899 cf::object::player player
847 cf::player peaceful 900 cf::player peaceful
901 cf::map trigger
848 902
849=cut 903=cut
850 904
851for ( 905for (
852 ["cf::object" => qw(contr pay_amount pay_player)], 906 ["cf::object" => qw(contr pay_amount pay_player map)],
853 ["cf::object::player" => qw(player)], 907 ["cf::object::player" => qw(player)],
854 ["cf::player" => qw(peaceful)], 908 ["cf::player" => qw(peaceful)],
909 ["cf::map" => qw(trigger)],
855) { 910) {
856 no strict 'refs'; 911 no strict 'refs';
857 my ($pkg, @funs) = @$_; 912 my ($pkg, @funs) = @$_;
858 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 913 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
859 for @funs; 914 for @funs;
… …
969 1024
970Immediately write the database to disk I<if it is dirty>. 1025Immediately write the database to disk I<if it is dirty>.
971 1026
972=cut 1027=cut
973 1028
1029our $DB;
1030
974{ 1031{
975 my $db;
976 my $path = cf::localdir . "/database.pst"; 1032 my $path = cf::localdir . "/database.pst";
977 1033
978 sub db_load() { 1034 sub db_load() {
979 warn "loading database $path\n";#d# remove later 1035 warn "loading database $path\n";#d# remove later
980 $db = stat $path ? Storable::retrieve $path : { }; 1036 $DB = stat $path ? Storable::retrieve $path : { };
981 } 1037 }
982 1038
983 my $pid; 1039 my $pid;
984 1040
985 sub db_save() { 1041 sub db_save() {
986 warn "saving database $path\n";#d# remove later 1042 warn "saving database $path\n";#d# remove later
987 waitpid $pid, 0 if $pid; 1043 waitpid $pid, 0 if $pid;
988 if (0 == ($pid = fork)) { 1044 if (0 == ($pid = fork)) {
989 $db->{_meta}{version} = 1; 1045 $DB->{_meta}{version} = 1;
990 Storable::nstore $db, "$path~"; 1046 Storable::nstore $DB, "$path~";
991 rename "$path~", $path; 1047 rename "$path~", $path;
992 cf::_exit 0 if defined $pid; 1048 cf::_exit 0 if defined $pid;
993 } 1049 }
994 } 1050 }
995 1051
… …
998 sub db_sync() { 1054 sub db_sync() {
999 db_save if $dirty; 1055 db_save if $dirty;
1000 undef $dirty; 1056 undef $dirty;
1001 } 1057 }
1002 1058
1003 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 {
1004 db_sync; 1060 db_sync;
1005 }); 1061 });
1006 1062
1007 sub db_dirty() { 1063 sub db_dirty() {
1008 $dirty = 1; 1064 $dirty = 1;
1009 $idle->start; 1065 $idle->start;
1010 } 1066 }
1011 1067
1012 sub db_get($;$) { 1068 sub db_get($;$) {
1013 @_ >= 2 1069 @_ >= 2
1014 ? $db->{$_[0]}{$_[1]} 1070 ? $DB->{$_[0]}{$_[1]}
1015 : ($db->{$_[0]} ||= { }) 1071 : ($DB->{$_[0]} ||= { })
1016 } 1072 }
1017 1073
1018 sub db_put($$;$) { 1074 sub db_put($$;$) {
1019 if (@_ >= 3) { 1075 if (@_ >= 3) {
1020 $db->{$_[0]}{$_[1]} = $_[2]; 1076 $DB->{$_[0]}{$_[1]} = $_[2];
1021 } else { 1077 } else {
1022 $db->{$_[0]} = $_[1]; 1078 $DB->{$_[0]} = $_[1];
1023 } 1079 }
1024 db_dirty; 1080 db_dirty;
1025 } 1081 }
1026 1082
1027 attach_global 1083 attach_global
… …
1058 1114
1059 $msg->("reloading..."); 1115 $msg->("reloading...");
1060 1116
1061 eval { 1117 eval {
1062 # cancel all watchers 1118 # cancel all watchers
1063 $_->cancel for Event::all_watchers; 1119 for (Event::all_watchers) {
1120 $_->cancel if $_->data & WF_AUTOCANCEL;
1121 }
1064 1122
1065 # unload all extensions 1123 # unload all extensions
1066 for (@exts) { 1124 for (@exts) {
1067 $msg->("unloading <$_>"); 1125 $msg->("unloading <$_>");
1068 unload_extension $_; 1126 unload_extension $_;
… …
1128 warn $_[0]; 1186 warn $_[0];
1129 print "$_[0]\n"; 1187 print "$_[0]\n";
1130 }; 1188 };
1131} 1189}
1132 1190
1191register "<global>", __PACKAGE__;
1192
1133register_command "perl-reload", 0, sub { 1193register_command "perl-reload" => sub {
1134 my ($who, $arg) = @_; 1194 my ($who, $arg) = @_;
1135 1195
1136 if ($who->flag (FLAG_WIZ)) { 1196 if ($who->flag (FLAG_WIZ)) {
1137 _perl_reload { 1197 _perl_reload {
1138 warn $_[0]; 1198 warn $_[0];
1139 $who->message ($_[0]); 1199 $who->message ($_[0]);
1140 }; 1200 };
1141 } 1201 }
1142}; 1202};
1143 1203
1144register "<global>", __PACKAGE__;
1145
1146unshift @INC, $LIBDIR; 1204unshift @INC, $LIBDIR;
1147 1205
1148$TICK_WATCHER = Event->timer ( 1206$TICK_WATCHER = Event->timer (
1149 prio => 1, 1207 prio => 0,
1150 at => $NEXT_TICK || 1, 1208 at => $NEXT_TICK || 1,
1209 data => WF_AUTOCANCEL,
1151 cb => sub { 1210 cb => sub {
1152 cf::server_tick; # one server iteration 1211 cf::server_tick; # one server iteration
1153 1212
1154 my $NOW = Event::time; 1213 my $NOW = Event::time;
1155 $NEXT_TICK += $TICK; 1214 $NEXT_TICK += $TICK;
1156 1215
1157 # if we are delayed by four ticks, skip them all 1216 # if we are delayed by four ticks or more, skip them all
1158 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1217 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1159 1218
1160 $TICK_WATCHER->at ($NEXT_TICK); 1219 $TICK_WATCHER->at ($NEXT_TICK);
1161 $TICK_WATCHER->start; 1220 $TICK_WATCHER->start;
1162 }, 1221 },
1163); 1222);
1164 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
11651 12321
1166 1233

Diff Legend

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