view release on metacpan or  search on metacpan

bin/deliantra  view on Meta::CPAN

our $DEBUG_STATUS;

our $INV;
our $INVR;
our $INVR_HB;

#############################################################################

# write a crash message blockingly to the socket, if possible
# this is a bit too complicated for my tastes, but it was easy.
*crash = sub($;$) {
   my ($msg, $backtrace) = @_;

   warn $msg;

   return unless $CONN;

   my $fh = $CONN->{fh}
      or return;

   my $buf = delete $CONN->{wbuf};

   $buf .= pack "n/a*", "exti " . JSON::XS::encode_json [clientlog => undef, substr $msg, 0, 8000];

   AnyEvent::Util::fh_nonblocking $fh, 0;
   syswrite $fh, $buf;
   AnyEvent::Util::fh_nonblocking $fh, 1;

   $msg =~ s/\s+$//;

   # backtrace as second step, in case it crashes, too
   crash Carp::longmess "$msg\nbacktrace, for client version $DC::VERSION, generated"
      if $backtrace;
};

sub clienterror($;$) {
   my ($msg, $backtrace) = @_;

   warn $msg;

   return unless $CONN;

   $CONN->send_exti_msg (clientlog => $msg);
   $CONN->send_exti_msg (clientlog => Carp::longmess "$msg\nbacktrace, for client version $DC::VERSION, generated") if $backtrace;
}

#############################################################################

sub status {
   $STATUSBOX->add (DC::asxml $_[0], pri => -10, group => "status", timeout => 10, fg => [1, 1, 0, 1]);
}

sub debug {
   $DEBUG_STATUS->set_text ($_[0]);
}

sub message {
   $MESSAGE_DIST->message (@_);
}

sub update_modbox {
   my $mod = DC::SDL_GetModState;

   my $markup;

   $markup .= $mod & DC::KMOD_CTRL
              ? ($MAPWIDGET->{ctrl} ? "[REPEAT]" : "[<span foreground='#888'>REPEAT</span>]")
              : "[<span foreground='#888'> once </span>]";

   $markup .= $mod & DC::KMOD_SHIFT
              ? ($MAPWIDGET->{shft} ? "[FIRE]" : "[<span foreground='#888'>FIRE</span>]")
              : "[<span foreground='#888'>move</span>]";

   $markup .= $mod & (DC::KMOD_ALT | DC::KMOD_META)
              ? "[ALT]"
              : "[<span foreground='#888'>alt</span>]";

   $markup .= $mod & DC::KMOD_NUM
              ? "[NUM]"
              : "[<span foreground='#888'>num</span>]";

   # <tt> around next statement works around some bug that keeps the
   # "font =>" from being used on windows
   $MODBOX->set_markup ("<tt>$markup</tt>");
}

#############################################################################
#TODO: maybe move into own audio module...

our $SDL_MIXER;

our $MUSIC_DEFAULT = "in_a_heartbeat.ogg";
our $MUSIC_WANT; # arryref of ambient music we want to play
our @MUSIC_HAVE; # ambient music we have on disk
our $MUSIC_START;
our @MUSIC_JINGLE; # which jingles to play next
our $MUSIC_PLAYING_DATA;
our $MUSIC_PLAYING_META;
our $MUSIC_PLAYER;
our $MUSIC_RESUME = 30; # resume music when played less than these many seconds before

our %AUDIO_CHUNK;  # audio "files"
our %AUDIO_PLAY;   # which audio faces should be played

sub audio_channel_finished {
   my ($channel) = @_;

#   warn "channel $channel finished\n";#d#
}

sub audio_sound_push($) {
   my ($face) = @_;

   $CFG->{effects_enable}
      or return;

   $AUDIO_PLAY{$face}
      or return;

   if (my $chunk = $AUDIO_CHUNK{$face}) {
      for (grep $_->[0] >= EV::now, @{(delete $AUDIO_PLAY{$face}) || []}) {

bin/deliantra  view on Meta::CPAN

      ghit  => ["Ghost hit",
         "<b>Ghost hit</b> (special attack used by ghosts and ghost-like beings)"],
   );

   for (qw/slow holyw conf fire depl magic
           drain acid pois para deat phys
           blind fear tund elec cold ghit/)
   {
      $tbl2->add_at ($col + 2, $row,
         $STATWIDS->{"res_$_"} =
            new DC::UI::Label
               font       => $FONT_FIXED,
               template   => "-100%",
               align      => 1,
               can_events => 1,
               can_hover  => 1,
               tooltip    => $resist_names{$_}->[1],
      );
      $tbl2->add_at ($col + 1, $row, new DC::UI::Image
         font       => $FONT_FIXED,
         can_hover  => 1,
         can_events => 1,
         path       => "ui/resist/resist_$_.png",
         tooltip    => $resist_names{$_}->[1],
      );
      $tbl2->add_at ($col + 0, $row, new DC::UI::Label
         text       => $resist_names{$_}->[0],
         font       => $FONT_FIXED,
         align      => 1,
         can_hover  => 1,
         can_events => 1,
         tooltip    => $resist_names{$_}->[1],
      );

      $row++;
      if ($row % 6 == 0) {
         $col += 4;
         $row = 0;
      }
   }

   #update_stats_window ({});

   $r
}

sub skill_window {
   my $sw = new DC::UI::ScrolledWindow (expand => 1);

   $sw->add ($STATWIDS->{skill_tbl} = new DC::UI::Table expand => 1, col_expand => [0, 0, 1, .1,  0, 0, 1, .1]);

   $sw
}

sub formsep($) {
   scalar reverse join ",", unpack "(A3)*", reverse $_[0] * 1
}

my $METASERVER_ATIME;

sub update_metaserver {
   my ($metaserver_dialog) = @_;

   $METASERVER = $metaserver_dialog
      if defined $metaserver_dialog;

   return if $METASERVER_ATIME > time;
   $METASERVER_ATIME = time + 60;

   my $table = $METASERVER->{table};
   $table->clear;
   $table->add_at (0, 0, my $label = new DC::UI::Label max_w => $WIDTH * 0.8, text => "fetching server list...");

   my $ok = 0;

   DC::background {
      my $ua = DC::lwp_useragent;

      DC::background_msg DC::decode_json +(DC::lwp_check $ua->get ($META_SERVER))->decoded_content;
   } sub {
      my ($msg) = @_;
      if ($msg) {
         $table->clear;

         my @tip = (
            "The current number of users logged in on the server.",
            "The hostname of the server.",
            "The time this server has been running without being restarted.",
            "Short information about this server provided by its admins.",
         );
         my @col = qw(#Users Host Uptime Version Description);
         $table->add_at ($_, 0, new DC::UI::Label
            can_hover => 1, can_events => 1, fg => [1, 1, 0],
            text => $col[$_], tooltip => $tip[$_])
               for 0 .. $#col;

         my @align = qw(1 0.5 1 1 0);

         my $y = 0;
         for my $m (@{ $msg->{servers} }) {
            my ($ip, $last, $host, $users, $version, $desc, $ibytes, $obytes, $uptime, $highlight) = 
               @$m{qw(ip age hostname users version description ibytes obytes uptime highlight)};

            for ($desc) {
               s/<br>/\n/gi;
               s/<li>/\n· /gi;
               s/<.*?>//sgi;
               s/&amp;/&/g;
               s/&lt;/</g;
               s/&gt;/>/g;
            }

            $uptime = sprintf "%dd %02d:%02d:%02d",
               (int $uptime / 86400),
               (int $uptime / 3600) % 24,
               (int $uptime / 60) % 60,
               $uptime % 60;

            $m = [$users, $host, $uptime, $version, $desc];

            $y++;