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

Diff Legend

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