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.442 by root, Sun Aug 31 09:03:31 2008 UTC vs.
Revision 1.447 by root, Fri Sep 19 01:39:45 2008 UTC

… …
81our %EXT_MAP = (); # pluggable maps 81our %EXT_MAP = (); # pluggable maps
82 82
83our $RELOAD; # number of reloads so far 83our $RELOAD; # number of reloads so far
84our @EVENT; 84our @EVENT;
85 85
86our $CONFDIR = confdir; 86our $CONFDIR = confdir;
87our $DATADIR = datadir; 87our $DATADIR = datadir;
88our $LIBDIR = "$DATADIR/ext"; 88our $LIBDIR = "$DATADIR/ext";
89our $PODDIR = "$DATADIR/pod"; 89our $PODDIR = "$DATADIR/pod";
90our $MAPDIR = "$DATADIR/" . mapdir; 90our $MAPDIR = "$DATADIR/" . mapdir;
91our $LOCALDIR = localdir; 91our $LOCALDIR = localdir;
92our $TMPDIR = "$LOCALDIR/" . tmpdir; 92our $TMPDIR = "$LOCALDIR/" . tmpdir;
93our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 93our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
94our $PLAYERDIR = "$LOCALDIR/" . playerdir; 94our $PLAYERDIR = "$LOCALDIR/" . playerdir;
95our $RANDOMDIR = "$LOCALDIR/random"; 95our $RANDOMDIR = "$LOCALDIR/random";
96our $BDBDIR = "$LOCALDIR/db"; 96our $BDBDIR = "$LOCALDIR/db";
97our $PIDFILE = "$LOCALDIR/pid";
98our $RUNTIMEFILE = "$LOCALDIR/runtime";
99
97our %RESOURCE; 100our %RESOURCE;
98 101
99our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 102our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
100our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 103our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
101our $NEXT_TICK; 104our $NEXT_TICK;
… …
126 129
127binmode STDOUT; 130binmode STDOUT;
128binmode STDERR; 131binmode STDERR;
129 132
130# read virtual server time, if available 133# read virtual server time, if available
131unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 134unless ($RUNTIME || !-e $RUNTIMEFILE) {
132 open my $fh, "<", "$LOCALDIR/runtime" 135 open my $fh, "<", $RUNTIMEFILE
133 or die "unable to read runtime file: $!"; 136 or die "unable to read $RUNTIMEFILE file: $!";
134 $RUNTIME = <$fh> + 0.; 137 $RUNTIME = <$fh> + 0.;
135} 138}
136 139
137mkdir $_ 140mkdir $_
138 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 141 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
… …
727 730
728############################################################################# 731#############################################################################
729 732
730=head2 ATTACHABLE OBJECTS 733=head2 ATTACHABLE OBJECTS
731 734
732Many objects in crossfire are so-called attachable objects. That means you can 735Many objects in deliantra are so-called attachable objects. That means you can
733attach callbacks/event handlers (a collection of which is called an "attachment") 736attach callbacks/event handlers (a collection of which is called an "attachment")
734to it. All such attachable objects support the following methods. 737to it. All such attachable objects support the following methods.
735 738
736In the following description, CLASS can be any of C<global>, C<object> 739In the following description, CLASS can be any of C<global>, C<object>
737C<player>, C<client> or C<map> (i.e. the attachable objects in 740C<player>, C<client> or C<map> (i.e. the attachable objects in
… …
787=item cf::CLASS::attachment $name, ... 790=item cf::CLASS::attachment $name, ...
788 791
789Register an attachment by C<$name> through which attachable objects of the 792Register an attachment by C<$name> through which attachable objects of the
790given CLASS can refer to this attachment. 793given CLASS can refer to this attachment.
791 794
792Some classes such as crossfire maps and objects can specify attachments 795Some classes such as deliantra maps and objects can specify attachments
793that are attached at load/instantiate time, thus the need for a name. 796that are attached at load/instantiate time, thus the need for a name.
794 797
795These calls expect any number of the following handler/hook descriptions: 798These calls expect any number of the following handler/hook descriptions:
796 799
797=over 4 800=over 4
… …
1385 1388
1386=back 1389=back
1387 1390
1388=head2 CORE EXTENSIONS 1391=head2 CORE EXTENSIONS
1389 1392
1390Functions and methods that extend core crossfire objects. 1393Functions and methods that extend core deliantra objects.
1391 1394
1392=cut 1395=cut
1393 1396
1394package cf::player; 1397package cf::player;
1395 1398
… …
1523 my ($pl) = @_; 1526 my ($pl) = @_;
1524 1527
1525 my $name = $pl->ob->name; 1528 my $name = $pl->ob->name;
1526 1529
1527 $pl->{deny_save} = 1; 1530 $pl->{deny_save} = 1;
1528 $pl->password ("*"); # this should lock out the player until we nuked the dir 1531 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1529 1532
1530 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1533 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1531 $pl->deactivate; 1534 $pl->deactivate;
1532 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1535 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1533 $pl->ob->check_score; 1536 $pl->ob->check_score;
… …
1619 } 1622 }
1620 1623
1621 \@paths 1624 \@paths
1622} 1625}
1623 1626
1624=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1627=item $protocol_xml = $player->expand_cfpod ($cfpod)
1625 1628
1626Expand crossfire pod fragments into protocol xml. 1629Expand deliantra pod fragments into protocol xml.
1627
1628=cut
1629
1630sub expand_cfpod {
1631 my ($self, $pod) = @_;
1632
1633 my @nest = [qr<\G$>, undef, ""];
1634 my $xml;
1635
1636 for ($pod) {
1637 while () {
1638 if (/\G( (?: [^BCEGHITUZ&>\n\ ]+ | [BCEGHITUZ](?!<) | \ (?!>) )+ )/xgcs) {
1639 $xml .= $1;
1640 } elsif (/\G\n(?=\S)/xgcs) {
1641 $xml .= " ";
1642 } elsif (/\G\n/xgcs) {
1643 $xml .= "\n";
1644 } elsif (/\G ([BCEGHITUZ]) (< (?: <+\ | (?!<) ) )/xgcs) {
1645 my ($code, $delim) = ($1, scalar reverse $2);
1646 $delim =~ y/</>/; # delim now contains the stop sequence
1647 $delim = qr{\G\Q$delim};
1648
1649 my $cb;
1650
1651 if ($code eq "B") {
1652 $cb = sub { "<b>$_[0]</b>" };
1653 } elsif ($code eq "C") {
1654 $cb = sub { "<tt>$_[0]</tt>" };
1655 } elsif ($code eq "E") {
1656 $cb = sub { warn "E<$_[0]>\n";"&$_[0];" };
1657 } elsif ($code eq "G") {
1658 $cb = sub {
1659 my ($male, $female) = split /\|/, $_[0];
1660 $self->gender ? $female : $male
1661 };
1662 } elsif ($code eq "H") {
1663 $cb = sub {
1664 (
1665 "<fg name=\"lightblue\">[$_[0] (Use hintmode to suppress hints)]</fg>",
1666 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1667 "",
1668 )[$self->{hintmode}];
1669 };
1670 } elsif ($code eq "I") {
1671 $cb = sub { "<i>$_[0]</i>" };
1672 } elsif ($code eq "T") {
1673 $cb = sub { "<big><b>$_[0]</b></big>" };
1674 } elsif ($code eq "U") {
1675 $cb = sub { "<u>$_[0]</u>" };
1676 } elsif ($code eq "Z") {
1677 $cb = sub { };
1678 } else {
1679 die "FATAL error in expand_cfpod";
1680 }
1681
1682 push @nest, [$delim, $cb, $xml];
1683 undef $xml;
1684
1685 } elsif ($_ =~ /$nest[-1][0]/gcs) {
1686 my $nest = pop @nest;
1687
1688 if ($nest->[1]) {
1689 $xml = $nest->[2] . $nest->[1]->($xml);
1690 } else {
1691 last;
1692 }
1693 } elsif (/\G</xgcs) {
1694 $xml .= "&lt;";
1695 } elsif (/\G&/xgcs) {
1696 $xml .= "&amp;";
1697 } elsif (/\G>/xgcs) {
1698 $xml .= ">";
1699 } else {
1700 if ($pod =~ /\G(.+)/xgcs) {
1701 warn "parse error (at $1)($nest[-1][0]) while expanding cfpod:\n$pod";
1702 last;
1703 } else {
1704 warn "parse error (unclosed interior sequence at end of cfpod) while expanding cfpod:\n$pod";
1705 return "<b>Sorry, the server encountered an internal error when formatting this message, please report this.</b>";
1706 }
1707 }
1708 }
1709 }
1710
1711 $xml
1712}
1713
1714sub hintmode {
1715 $_[0]{hintmode} = $_[1] if @_ > 1;
1716 $_[0]{hintmode}
1717}
1718 1630
1719=item $player->ext_reply ($msgid, @msg) 1631=item $player->ext_reply ($msgid, @msg)
1720 1632
1721Sends an ext reply to the player. 1633Sends an ext reply to the player.
1722 1634
… …
2536 2448
2537=item $player_object->enter_link 2449=item $player_object->enter_link
2538 2450
2539Freezes the player and moves him/her to a special map (C<{link}>). 2451Freezes the player and moves him/her to a special map (C<{link}>).
2540 2452
2541The player should be reasonably safe there for short amounts of time. You 2453The player should be reasonably safe there for short amounts of time (e.g.
2542I<MUST> call C<leave_link> as soon as possible, though. 2454for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2455though, as the palyer cannot control the character while it is on the link
2456map.
2543 2457
2544Will never block. 2458Will never block.
2545 2459
2546=item $player_object->leave_link ($map, $x, $y) 2460=item $player_object->leave_link ($map, $x, $y)
2547 2461
… …
2605 2519
2606 $map->load; 2520 $map->load;
2607 $map->load_neighbours; 2521 $map->load_neighbours;
2608 2522
2609 return unless $self->contr->active; 2523 return unless $self->contr->active;
2524 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2610 $self->activate_recursive; 2525 $self->activate_recursive;
2611 2526
2612 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2527 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2613 $self->enter_map ($map, $x, $y); 2528 $self->enter_map ($map, $x, $y);
2614} 2529}
… …
2777 $self->contr->savebed ($map, $x, $y) 2692 $self->contr->savebed ($map, $x, $y)
2778 if $exit->flag (cf::FLAG_DAMNED); 2693 if $exit->flag (cf::FLAG_DAMNED);
2779 2694
2780 1 2695 1
2781 }) { 2696 }) {
2782 $self->message ("Something went wrong deep within the crossfire server. " 2697 $self->message ("Something went wrong deep within the deliantra server. "
2783 . "I'll try to bring you back to the map you were before. " 2698 . "I'll try to bring you back to the map you were before. "
2784 . "Please report this to the dungeon master!", 2699 . "Please report this to the dungeon master!",
2785 cf::NDI_UNIQUE | cf::NDI_RED); 2700 cf::NDI_UNIQUE | cf::NDI_RED);
2786 2701
2787 warn "ERROR in enter_exit: $@"; 2702 warn "ERROR in enter_exit: $@";
… …
2876); 2791);
2877 2792
2878sub cf::client::send_msg { 2793sub cf::client::send_msg {
2879 my ($self, $channel, $msg, $color, @extra) = @_; 2794 my ($self, $channel, $msg, $color, @extra) = @_;
2880 2795
2881 $msg = $self->pl->expand_cfpod ($msg); 2796 $msg = $self->pl->expand_cfpod ($msg)
2797 unless $color & cf::NDI_VERBATIM;
2882 2798
2883 $color &= cf::NDI_CLIENT_MASK; # just in case... 2799 $color &= cf::NDI_CLIENT_MASK; # just in case...
2884 2800
2885 # check predefined channels, for the benefit of C 2801 # check predefined channels, for the benefit of C
2886 if ($CHANNEL{$channel}) { 2802 if ($CHANNEL{$channel}) {
… …
2907 if ($self->can_msg) { 2823 if ($self->can_msg) {
2908 # default colour, mask it out 2824 # default colour, mask it out
2909 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2825 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2910 if $color & cf::NDI_DEF; 2826 if $color & cf::NDI_DEF;
2911 2827
2912 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2828 my $pkt = "msg "
2829 . $self->{json_coder}->encode (
2913 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2830 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2831 );
2832
2833 # try lzf for large packets
2834 $pkt = "lzf " . Compress::LZF::compress $pkt
2835 if 1024 <= length $pkt and $self->{can_lzf};
2836
2837 # split very large packets
2838 if (8192 < length $pkt and $self->{can_lzf}) {
2839 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2840 $pkt = "frag";
2841 }
2842
2843 $self->send_packet ($pkt);
2914 } else { 2844 } else {
2915 if ($color >= 0) { 2845 if ($color >= 0) {
2916 # replace some tags by gcfclient-compatible ones 2846 # replace some tags by gcfclient-compatible ones
2917 for ($msg) { 2847 for ($msg) {
2918 1 while 2848 1 while
… …
3430 }; 3360 };
3431 warn $@ if $@; 3361 warn $@ if $@;
3432 } 3362 }
3433} 3363}
3434 3364
3365sub pidfile() {
3366 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3367 or die "$PIDFILE: $!";
3368 flock $fh, &Fcntl::LOCK_EX
3369 or die "$PIDFILE: flock: $!";
3370 $fh
3371}
3372
3373# make sure only one server instance is running at any one time
3374sub atomic {
3375 my $fh = pidfile;
3376
3377 my $pid = <$fh>;
3378 kill 9, $pid if $pid > 0;
3379
3380 seek $fh, 0, 0;
3381 print $fh $$;
3382}
3383
3435sub main { 3384sub main {
3385 atomic;
3386
3436 # we must not ever block the main coroutine 3387 # we must not ever block the main coroutine
3437 local $Coro::idle = sub { 3388 local $Coro::idle = sub {
3438 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3389 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3439 (async { 3390 (async {
3440 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3391 $Coro::current->{desc} = "IDLE BUG HANDLER";
… …
3449 load_extensions; 3400 load_extensions;
3450 3401
3451 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3402 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3452 } 3403 }
3453 3404
3405 utime time, time, $RUNTIMEFILE;
3406
3407 # no (long-running) fork's whatsoever before this point(!)
3408 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3409
3454 EV::loop; 3410 EV::loop;
3455} 3411}
3456 3412
3457############################################################################# 3413#############################################################################
3458# initialisation and cleanup 3414# initialisation and cleanup
… …
3466 }; 3422 };
3467 } 3423 }
3468} 3424}
3469 3425
3470sub write_runtime_sync { 3426sub write_runtime_sync {
3471 my $runtime = "$LOCALDIR/runtime";
3472
3473 # first touch the runtime file to show we are still running: 3427 # first touch the runtime file to show we are still running:
3474 # the fsync below can take a very very long time. 3428 # the fsync below can take a very very long time.
3475 3429
3476 IO::AIO::aio_utime $runtime, undef, undef; 3430 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3477 3431
3478 my $guard = cf::lock_acquire "write_runtime"; 3432 my $guard = cf::lock_acquire "write_runtime";
3479 3433
3480 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3434 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3481 or return; 3435 or return;
3482 3436
3483 my $value = $cf::RUNTIME + 90 + 10; 3437 my $value = $cf::RUNTIME + 90 + 10;
3484 # 10 is the runtime save interval, for a monotonic clock 3438 # 10 is the runtime save interval, for a monotonic clock
3485 # 60 allows for the watchdog to kill the server. 3439 # 60 allows for the watchdog to kill the server.
… …
3495 aio_utime $fh, undef, undef; 3449 aio_utime $fh, undef, undef;
3496 3450
3497 close $fh 3451 close $fh
3498 or return; 3452 or return;
3499 3453
3500 aio_rename "$runtime~", $runtime 3454 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3501 and return; 3455 and return;
3502 3456
3503 warn "runtime file written.\n"; 3457 warn "runtime file written.\n";
3504 3458
3505 1 3459 1
… …
3589sub post_cleanup { 3543sub post_cleanup {
3590 my ($make_core) = @_; 3544 my ($make_core) = @_;
3591 3545
3592 warn Carp::longmess "post_cleanup backtrace" 3546 warn Carp::longmess "post_cleanup backtrace"
3593 if $make_core; 3547 if $make_core;
3548
3549 my $fh = pidfile;
3550 unlink $PIDFILE if <$fh> == $$;
3594} 3551}
3595 3552
3596# a safer delete_package, copied from Symbol 3553# a safer delete_package, copied from Symbol
3597sub clear_package($) { 3554sub clear_package($) {
3598 my $pkg = shift; 3555 my $pkg = shift;
… …
3879 $msg =~ s/\n//; 3836 $msg =~ s/\n//;
3880 3837
3881 # limit the # of concurrent backtraces 3838 # limit the # of concurrent backtraces
3882 if ($_log_backtrace < 2) { 3839 if ($_log_backtrace < 2) {
3883 ++$_log_backtrace; 3840 ++$_log_backtrace;
3841 my $perl_bt = Carp::longmess $msg;
3884 async { 3842 async {
3885 $Coro::current->{desc} = "abt $msg"; 3843 $Coro::current->{desc} = "abt $msg";
3886 3844
3887 my @bt = fork_call { 3845 my @bt = fork_call {
3888 @addr = map { sprintf "%x", $_ } @addr; 3846 @addr = map { sprintf "%x", $_ } @addr;
… …
3899 } 3857 }
3900 3858
3901 @funcs 3859 @funcs
3902 }; 3860 };
3903 3861
3904 LOG llevInfo, "[ABT] $msg\n"; 3862 LOG llevInfo, "[ABT] $perl_bt\n";
3863 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3905 LOG llevInfo, "[ABT] $_\n" for @bt; 3864 LOG llevInfo, "[ABT] $_\n" for @bt;
3906 --$_log_backtrace; 3865 --$_log_backtrace;
3907 }; 3866 };
3908 } else { 3867 } else {
3909 LOG llevInfo, "[ABT] $msg\n"; 3868 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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