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.443 by root, Sun Aug 31 10:05:26 2008 UTC vs.
Revision 1.446 by root, Tue Sep 16 16:03:02 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;
… …
1623 1626
1624=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1627=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1625 1628
1626Expand crossfire pod fragments into protocol xml. 1629Expand crossfire pod fragments into protocol xml.
1627 1630
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
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
1723=cut 1635=cut
… …
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}
… …
3444 }; 3359 };
3445 warn $@ if $@; 3360 warn $@ if $@;
3446 } 3361 }
3447} 3362}
3448 3363
3364sub pidfile() {
3365 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3366 or die "$PIDFILE: $!";
3367 flock $fh, &Fcntl::LOCK_EX
3368 or die "$PIDFILE: flock: $!";
3369 $fh
3370}
3371
3372# make sure only one server instance is running at any one time
3373sub atomic {
3374 my $fh = pidfile;
3375
3376 my $pid = <$fh>;
3377 kill 9, $pid if $pid > 0;
3378
3379 seek $fh, 0, 0;
3380 print $fh $$;
3381}
3382
3449sub main { 3383sub main {
3384 atomic;
3385
3450 # we must not ever block the main coroutine 3386 # we must not ever block the main coroutine
3451 local $Coro::idle = sub { 3387 local $Coro::idle = sub {
3452 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3388 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3453 (async { 3389 (async {
3454 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3390 $Coro::current->{desc} = "IDLE BUG HANDLER";
… …
3463 load_extensions; 3399 load_extensions;
3464 3400
3465 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3401 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3466 } 3402 }
3467 3403
3404 utime time, time, $RUNTIMEFILE;
3405
3406 # no (long-running) fork's whatsoever before this point(!)
3407 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3408
3468 EV::loop; 3409 EV::loop;
3469} 3410}
3470 3411
3471############################################################################# 3412#############################################################################
3472# initialisation and cleanup 3413# initialisation and cleanup
… …
3480 }; 3421 };
3481 } 3422 }
3482} 3423}
3483 3424
3484sub write_runtime_sync { 3425sub write_runtime_sync {
3485 my $runtime = "$LOCALDIR/runtime";
3486
3487 # first touch the runtime file to show we are still running: 3426 # first touch the runtime file to show we are still running:
3488 # the fsync below can take a very very long time. 3427 # the fsync below can take a very very long time.
3489 3428
3490 IO::AIO::aio_utime $runtime, undef, undef; 3429 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3491 3430
3492 my $guard = cf::lock_acquire "write_runtime"; 3431 my $guard = cf::lock_acquire "write_runtime";
3493 3432
3494 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3433 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3495 or return; 3434 or return;
3496 3435
3497 my $value = $cf::RUNTIME + 90 + 10; 3436 my $value = $cf::RUNTIME + 90 + 10;
3498 # 10 is the runtime save interval, for a monotonic clock 3437 # 10 is the runtime save interval, for a monotonic clock
3499 # 60 allows for the watchdog to kill the server. 3438 # 60 allows for the watchdog to kill the server.
… …
3509 aio_utime $fh, undef, undef; 3448 aio_utime $fh, undef, undef;
3510 3449
3511 close $fh 3450 close $fh
3512 or return; 3451 or return;
3513 3452
3514 aio_rename "$runtime~", $runtime 3453 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3515 and return; 3454 and return;
3516 3455
3517 warn "runtime file written.\n"; 3456 warn "runtime file written.\n";
3518 3457
3519 1 3458 1
… …
3603sub post_cleanup { 3542sub post_cleanup {
3604 my ($make_core) = @_; 3543 my ($make_core) = @_;
3605 3544
3606 warn Carp::longmess "post_cleanup backtrace" 3545 warn Carp::longmess "post_cleanup backtrace"
3607 if $make_core; 3546 if $make_core;
3547
3548 my $fh = pidfile;
3549 unlink $PIDFILE if <$fh> == $$;
3608} 3550}
3609 3551
3610# a safer delete_package, copied from Symbol 3552# a safer delete_package, copied from Symbol
3611sub clear_package($) { 3553sub clear_package($) {
3612 my $pkg = shift; 3554 my $pkg = shift;
… …
3893 $msg =~ s/\n//; 3835 $msg =~ s/\n//;
3894 3836
3895 # limit the # of concurrent backtraces 3837 # limit the # of concurrent backtraces
3896 if ($_log_backtrace < 2) { 3838 if ($_log_backtrace < 2) {
3897 ++$_log_backtrace; 3839 ++$_log_backtrace;
3840 my $perl_bt = Carp::longmess $msg;
3898 async { 3841 async {
3899 $Coro::current->{desc} = "abt $msg"; 3842 $Coro::current->{desc} = "abt $msg";
3900 3843
3901 my @bt = fork_call { 3844 my @bt = fork_call {
3902 @addr = map { sprintf "%x", $_ } @addr; 3845 @addr = map { sprintf "%x", $_ } @addr;
… …
3913 } 3856 }
3914 3857
3915 @funcs 3858 @funcs
3916 }; 3859 };
3917 3860
3918 LOG llevInfo, "[ABT] $msg\n"; 3861 LOG llevInfo, "[ABT] $perl_bt\n";
3862 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3919 LOG llevInfo, "[ABT] $_\n" for @bt; 3863 LOG llevInfo, "[ABT] $_\n" for @bt;
3920 --$_log_backtrace; 3864 --$_log_backtrace;
3921 }; 3865 };
3922 } else { 3866 } else {
3923 LOG llevInfo, "[ABT] $msg\n"; 3867 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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