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.445 by root, Wed Sep 10 18:18:10 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;
… …
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;
… …
1622} 1625}
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
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
… …
2907 if ($self->can_msg) { 2819 if ($self->can_msg) {
2908 # default colour, mask it out 2820 # default colour, mask it out
2909 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2821 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2910 if $color & cf::NDI_DEF; 2822 if $color & cf::NDI_DEF;
2911 2823
2912 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2824 my $pkt = "msg "
2825 . $self->{json_coder}->encode (
2913 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2826 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2827 );
2828
2829 # try lzf for large packets
2830 $pkt = "lzf " . Compress::LZF::compress $pkt
2831 if 1024 <= length $pkt and $self->{can_lzf};
2832
2833 # split very large packets
2834 if (8192 < length $pkt and $self->{can_lzf}) {
2835 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2836 $pkt = "frag";
2837 }
2838
2839 $self->send_packet ($pkt);
2914 } else { 2840 } else {
2915 if ($color >= 0) { 2841 if ($color >= 0) {
2916 # replace some tags by gcfclient-compatible ones 2842 # replace some tags by gcfclient-compatible ones
2917 for ($msg) { 2843 for ($msg) {
2918 1 while 2844 1 while
… …
3430 }; 3356 };
3431 warn $@ if $@; 3357 warn $@ if $@;
3432 } 3358 }
3433} 3359}
3434 3360
3361sub pidfile() {
3362 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3363 or die "$PIDFILE: $!";
3364 flock $fh, &Fcntl::LOCK_EX
3365 or die "$PIDFILE: flock: $!";
3366 $fh
3367}
3368
3369# make sure only one server instance is running at any one time
3370sub atomic {
3371 my $fh = pidfile;
3372
3373 my $pid = <$fh>;
3374 kill 9, $pid if $pid > 0;
3375
3376 seek $fh, 0, 0;
3377 print $fh $$;
3378}
3379
3435sub main { 3380sub main {
3381 atomic;
3382
3436 # we must not ever block the main coroutine 3383 # we must not ever block the main coroutine
3437 local $Coro::idle = sub { 3384 local $Coro::idle = sub {
3438 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3385 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3439 (async { 3386 (async {
3440 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3387 $Coro::current->{desc} = "IDLE BUG HANDLER";
… …
3449 load_extensions; 3396 load_extensions;
3450 3397
3451 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3398 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3452 } 3399 }
3453 3400
3401 utime time, time, $RUNTIMEFILE;
3402
3403 # no (long-running) fork's whatsoever before this point(!)
3404 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3405
3454 EV::loop; 3406 EV::loop;
3455} 3407}
3456 3408
3457############################################################################# 3409#############################################################################
3458# initialisation and cleanup 3410# initialisation and cleanup
… …
3466 }; 3418 };
3467 } 3419 }
3468} 3420}
3469 3421
3470sub write_runtime_sync { 3422sub write_runtime_sync {
3471 my $runtime = "$LOCALDIR/runtime";
3472
3473 # first touch the runtime file to show we are still running: 3423 # first touch the runtime file to show we are still running:
3474 # the fsync below can take a very very long time. 3424 # the fsync below can take a very very long time.
3475 3425
3476 IO::AIO::aio_utime $runtime, undef, undef; 3426 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3477 3427
3478 my $guard = cf::lock_acquire "write_runtime"; 3428 my $guard = cf::lock_acquire "write_runtime";
3479 3429
3480 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3430 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3481 or return; 3431 or return;
3482 3432
3483 my $value = $cf::RUNTIME + 90 + 10; 3433 my $value = $cf::RUNTIME + 90 + 10;
3484 # 10 is the runtime save interval, for a monotonic clock 3434 # 10 is the runtime save interval, for a monotonic clock
3485 # 60 allows for the watchdog to kill the server. 3435 # 60 allows for the watchdog to kill the server.
… …
3495 aio_utime $fh, undef, undef; 3445 aio_utime $fh, undef, undef;
3496 3446
3497 close $fh 3447 close $fh
3498 or return; 3448 or return;
3499 3449
3500 aio_rename "$runtime~", $runtime 3450 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3501 and return; 3451 and return;
3502 3452
3503 warn "runtime file written.\n"; 3453 warn "runtime file written.\n";
3504 3454
3505 1 3455 1
… …
3589sub post_cleanup { 3539sub post_cleanup {
3590 my ($make_core) = @_; 3540 my ($make_core) = @_;
3591 3541
3592 warn Carp::longmess "post_cleanup backtrace" 3542 warn Carp::longmess "post_cleanup backtrace"
3593 if $make_core; 3543 if $make_core;
3544
3545 my $fh = pidfile;
3546 unlink $PIDFILE if <$fh> == $$;
3594} 3547}
3595 3548
3596# a safer delete_package, copied from Symbol 3549# a safer delete_package, copied from Symbol
3597sub clear_package($) { 3550sub clear_package($) {
3598 my $pkg = shift; 3551 my $pkg = shift;

Diff Legend

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