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.441 by root, Sat Aug 30 05:19:03 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;
… …
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
1630use re 'eval';
1631
1632my $group;
1633my $interior; $interior = qr{
1634 # match a pod interior sequence sans C<< >>
1635 (?:
1636 \ (.*?)\ (?{ $group = $^N })
1637 | < (??{$interior}) >
1638 )
1639}x;
1640
1641sub expand_cfpod {
1642 my ($self, $pod) = @_;
1643
1644 my $xml;
1645
1646 while () {
1647 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1648 $group = $1;
1649
1650 $group =~ s/&/&amp;/g;
1651 $group =~ s/</&lt;/g;
1652
1653 $xml .= $group;
1654 } elsif ($pod =~ m%\G
1655 ([BCGHITU])
1656 <
1657 (?:
1658 ([^<>]*) (?{ $group = $^N })
1659 | < $interior >
1660 )
1661 >
1662 %gcsx
1663 ) {
1664 my ($code, $data) = ($1, $group);
1665
1666 if ($code eq "B") {
1667 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1668 } elsif ($code eq "I") {
1669 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1670 } elsif ($code eq "U") {
1671 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1672 } elsif ($code eq "C") {
1673 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1674 } elsif ($code eq "T") {
1675 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1676 } elsif ($code eq "G") {
1677 my ($male, $female) = split /\|/, $data;
1678 $data = $self->gender ? $female : $male;
1679 $xml .= expand_cfpod ($self, $data);
1680 } elsif ($code eq "H") {
1681 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1682 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1683 "")
1684 [$self->{hintmode}];
1685 } else {
1686 $xml .= "error processing '$code($data)' directive";
1687 }
1688 } else {
1689 if ($pod =~ /\G(.+)/) {
1690 warn "parse error while expanding $pod (at $1)";
1691 }
1692 last;
1693 }
1694 }
1695
1696 for ($xml) {
1697 # create single paragraphs (very hackish)
1698 s/(?<=\S)\n(?=\w)/ /g;
1699
1700 # compress some whitespace
1701 s/\s+\n/\n/g; # ws line-ends
1702 s/\n\n+/\n/g; # double lines
1703 s/^\n+//; # beginning lines
1704 s/\n+$//; # ending lines
1705 }
1706
1707 $xml
1708}
1709
1710no re 'eval';
1711
1712sub hintmode {
1713 $_[0]{hintmode} = $_[1] if @_ > 1;
1714 $_[0]{hintmode}
1715}
1716 1630
1717=item $player->ext_reply ($msgid, @msg) 1631=item $player->ext_reply ($msgid, @msg)
1718 1632
1719Sends an ext reply to the player. 1633Sends an ext reply to the player.
1720 1634
… …
2534 2448
2535=item $player_object->enter_link 2449=item $player_object->enter_link
2536 2450
2537Freezes 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}>).
2538 2452
2539The 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.
2540I<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.
2541 2457
2542Will never block. 2458Will never block.
2543 2459
2544=item $player_object->leave_link ($map, $x, $y) 2460=item $player_object->leave_link ($map, $x, $y)
2545 2461
… …
2603 2519
2604 $map->load; 2520 $map->load;
2605 $map->load_neighbours; 2521 $map->load_neighbours;
2606 2522
2607 return unless $self->contr->active; 2523 return unless $self->contr->active;
2524 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2608 $self->activate_recursive; 2525 $self->activate_recursive;
2609 2526
2610 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2527 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2611 $self->enter_map ($map, $x, $y); 2528 $self->enter_map ($map, $x, $y);
2612} 2529}
… …
2905 if ($self->can_msg) { 2822 if ($self->can_msg) {
2906 # default colour, mask it out 2823 # default colour, mask it out
2907 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2824 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2908 if $color & cf::NDI_DEF; 2825 if $color & cf::NDI_DEF;
2909 2826
2910 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2827 my $pkt = "msg "
2828 . $self->{json_coder}->encode (
2911 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2829 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2830 );
2831
2832 # try lzf for large packets
2833 $pkt = "lzf " . Compress::LZF::compress $pkt
2834 if 1024 <= length $pkt and $self->{can_lzf};
2835
2836 # split very large packets
2837 if (8192 < length $pkt and $self->{can_lzf}) {
2838 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2839 $pkt = "frag";
2840 }
2841
2842 $self->send_packet ($pkt);
2912 } else { 2843 } else {
2913 if ($color >= 0) { 2844 if ($color >= 0) {
2914 # replace some tags by gcfclient-compatible ones 2845 # replace some tags by gcfclient-compatible ones
2915 for ($msg) { 2846 for ($msg) {
2916 1 while 2847 1 while
… …
3428 }; 3359 };
3429 warn $@ if $@; 3360 warn $@ if $@;
3430 } 3361 }
3431} 3362}
3432 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
3433sub main { 3383sub main {
3384 atomic;
3385
3434 # we must not ever block the main coroutine 3386 # we must not ever block the main coroutine
3435 local $Coro::idle = sub { 3387 local $Coro::idle = sub {
3436 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#
3437 (async { 3389 (async {
3438 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3390 $Coro::current->{desc} = "IDLE BUG HANDLER";
… …
3447 load_extensions; 3399 load_extensions;
3448 3400
3449 $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
3450 } 3402 }
3451 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
3452 EV::loop; 3409 EV::loop;
3453} 3410}
3454 3411
3455############################################################################# 3412#############################################################################
3456# initialisation and cleanup 3413# initialisation and cleanup
… …
3464 }; 3421 };
3465 } 3422 }
3466} 3423}
3467 3424
3468sub write_runtime_sync { 3425sub write_runtime_sync {
3469 my $runtime = "$LOCALDIR/runtime";
3470
3471 # first touch the runtime file to show we are still running: 3426 # first touch the runtime file to show we are still running:
3472 # the fsync below can take a very very long time. 3427 # the fsync below can take a very very long time.
3473 3428
3474 IO::AIO::aio_utime $runtime, undef, undef; 3429 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3475 3430
3476 my $guard = cf::lock_acquire "write_runtime"; 3431 my $guard = cf::lock_acquire "write_runtime";
3477 3432
3478 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3433 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3479 or return; 3434 or return;
3480 3435
3481 my $value = $cf::RUNTIME + 90 + 10; 3436 my $value = $cf::RUNTIME + 90 + 10;
3482 # 10 is the runtime save interval, for a monotonic clock 3437 # 10 is the runtime save interval, for a monotonic clock
3483 # 60 allows for the watchdog to kill the server. 3438 # 60 allows for the watchdog to kill the server.
… …
3493 aio_utime $fh, undef, undef; 3448 aio_utime $fh, undef, undef;
3494 3449
3495 close $fh 3450 close $fh
3496 or return; 3451 or return;
3497 3452
3498 aio_rename "$runtime~", $runtime 3453 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3499 and return; 3454 and return;
3500 3455
3501 warn "runtime file written.\n"; 3456 warn "runtime file written.\n";
3502 3457
3503 1 3458 1
… …
3587sub post_cleanup { 3542sub post_cleanup {
3588 my ($make_core) = @_; 3543 my ($make_core) = @_;
3589 3544
3590 warn Carp::longmess "post_cleanup backtrace" 3545 warn Carp::longmess "post_cleanup backtrace"
3591 if $make_core; 3546 if $make_core;
3547
3548 my $fh = pidfile;
3549 unlink $PIDFILE if <$fh> == $$;
3592} 3550}
3593 3551
3594# a safer delete_package, copied from Symbol 3552# a safer delete_package, copied from Symbol
3595sub clear_package($) { 3553sub clear_package($) {
3596 my $pkg = shift; 3554 my $pkg = shift;
… …
3877 $msg =~ s/\n//; 3835 $msg =~ s/\n//;
3878 3836
3879 # limit the # of concurrent backtraces 3837 # limit the # of concurrent backtraces
3880 if ($_log_backtrace < 2) { 3838 if ($_log_backtrace < 2) {
3881 ++$_log_backtrace; 3839 ++$_log_backtrace;
3840 my $perl_bt = Carp::longmess $msg;
3882 async { 3841 async {
3883 $Coro::current->{desc} = "abt $msg"; 3842 $Coro::current->{desc} = "abt $msg";
3884 3843
3885 my @bt = fork_call { 3844 my @bt = fork_call {
3886 @addr = map { sprintf "%x", $_ } @addr; 3845 @addr = map { sprintf "%x", $_ } @addr;
… …
3897 } 3856 }
3898 3857
3899 @funcs 3858 @funcs
3900 }; 3859 };
3901 3860
3902 LOG llevInfo, "[ABT] $msg\n"; 3861 LOG llevInfo, "[ABT] $perl_bt\n";
3862 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3903 LOG llevInfo, "[ABT] $_\n" for @bt; 3863 LOG llevInfo, "[ABT] $_\n" for @bt;
3904 --$_log_backtrace; 3864 --$_log_backtrace;
3905 }; 3865 };
3906 } else { 3866 } else {
3907 LOG llevInfo, "[ABT] $msg\n"; 3867 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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