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.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
… …
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}) {
… …
3444 }; 3360 };
3445 warn $@ if $@; 3361 warn $@ if $@;
3446 } 3362 }
3447} 3363}
3448 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
3449sub main { 3384sub main {
3385 atomic;
3386
3450 # we must not ever block the main coroutine 3387 # we must not ever block the main coroutine
3451 local $Coro::idle = sub { 3388 local $Coro::idle = sub {
3452 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#
3453 (async { 3390 (async {
3454 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3391 $Coro::current->{desc} = "IDLE BUG HANDLER";
… …
3463 load_extensions; 3400 load_extensions;
3464 3401
3465 $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
3466 } 3403 }
3467 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
3468 EV::loop; 3410 EV::loop;
3469} 3411}
3470 3412
3471############################################################################# 3413#############################################################################
3472# initialisation and cleanup 3414# initialisation and cleanup
… …
3480 }; 3422 };
3481 } 3423 }
3482} 3424}
3483 3425
3484sub write_runtime_sync { 3426sub write_runtime_sync {
3485 my $runtime = "$LOCALDIR/runtime";
3486
3487 # first touch the runtime file to show we are still running: 3427 # first touch the runtime file to show we are still running:
3488 # the fsync below can take a very very long time. 3428 # the fsync below can take a very very long time.
3489 3429
3490 IO::AIO::aio_utime $runtime, undef, undef; 3430 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3491 3431
3492 my $guard = cf::lock_acquire "write_runtime"; 3432 my $guard = cf::lock_acquire "write_runtime";
3493 3433
3494 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3434 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3495 or return; 3435 or return;
3496 3436
3497 my $value = $cf::RUNTIME + 90 + 10; 3437 my $value = $cf::RUNTIME + 90 + 10;
3498 # 10 is the runtime save interval, for a monotonic clock 3438 # 10 is the runtime save interval, for a monotonic clock
3499 # 60 allows for the watchdog to kill the server. 3439 # 60 allows for the watchdog to kill the server.
… …
3509 aio_utime $fh, undef, undef; 3449 aio_utime $fh, undef, undef;
3510 3450
3511 close $fh 3451 close $fh
3512 or return; 3452 or return;
3513 3453
3514 aio_rename "$runtime~", $runtime 3454 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3515 and return; 3455 and return;
3516 3456
3517 warn "runtime file written.\n"; 3457 warn "runtime file written.\n";
3518 3458
3519 1 3459 1
… …
3603sub post_cleanup { 3543sub post_cleanup {
3604 my ($make_core) = @_; 3544 my ($make_core) = @_;
3605 3545
3606 warn Carp::longmess "post_cleanup backtrace" 3546 warn Carp::longmess "post_cleanup backtrace"
3607 if $make_core; 3547 if $make_core;
3548
3549 my $fh = pidfile;
3550 unlink $PIDFILE if <$fh> == $$;
3608} 3551}
3609 3552
3610# a safer delete_package, copied from Symbol 3553# a safer delete_package, copied from Symbol
3611sub clear_package($) { 3554sub clear_package($) {
3612 my $pkg = shift; 3555 my $pkg = shift;
… …
3893 $msg =~ s/\n//; 3836 $msg =~ s/\n//;
3894 3837
3895 # limit the # of concurrent backtraces 3838 # limit the # of concurrent backtraces
3896 if ($_log_backtrace < 2) { 3839 if ($_log_backtrace < 2) {
3897 ++$_log_backtrace; 3840 ++$_log_backtrace;
3841 my $perl_bt = Carp::longmess $msg;
3898 async { 3842 async {
3899 $Coro::current->{desc} = "abt $msg"; 3843 $Coro::current->{desc} = "abt $msg";
3900 3844
3901 my @bt = fork_call { 3845 my @bt = fork_call {
3902 @addr = map { sprintf "%x", $_ } @addr; 3846 @addr = map { sprintf "%x", $_ } @addr;
… …
3913 } 3857 }
3914 3858
3915 @funcs 3859 @funcs
3916 }; 3860 };
3917 3861
3918 LOG llevInfo, "[ABT] $msg\n"; 3862 LOG llevInfo, "[ABT] $perl_bt\n";
3863 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3919 LOG llevInfo, "[ABT] $_\n" for @bt; 3864 LOG llevInfo, "[ABT] $_\n" for @bt;
3920 --$_log_backtrace; 3865 --$_log_backtrace;
3921 }; 3866 };
3922 } else { 3867 } else {
3923 LOG llevInfo, "[ABT] $msg\n"; 3868 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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