sub update results from the CPAN

Deliantra-Client

      ->filter_json_single_key_object ("\fw" => sub {
         $self->{widget}{$_[0]}
      })
      ->filter_json_single_key_object ("\fc" => sub {
         my ($id) = @_;
         sub {
            $self->send_exti_msg (w_e => $id, @_);
         }
      });

   # destroy widgets on logout
   $self->{on_stop_game_guard} = $self->{map_widget}{root}->connect (stop_game => sub {
      for my $ws (values %{delete $self->{widgetset} || {}}) {
         $_->destroy
            for values %{delete $ws->{w} || {}};
      }

      delete $self->{items};
      $::INV->clear;
      $::INVR->clear;
      $::INVR_HB->clear;
      $::FLOORBOX->clear;
   });

   $self->{map_widget}->add_command (@$_)
      for @cmd_help;

   {
      $self->{dialogue} = my $tex = $TEX_DIALOGUE;
      $self->{map}->set_texture (1, @$tex{qw(name w h s t)}, @{$tex->{minified}});
   }

   {
      $self->{noface} = my $tex = $TEX_NOFACE;
      $self->{map}->set_texture (2, @$tex{qw(name w h s t)}, @{$tex->{minified}});
   }

#   $self->{expire_count} = DC::DB::FIRST_TILE_ID; # minimum non-fixed tile id
#   $self->{expire_w} = EV::timer 1, 1, sub {
#      my $count = (int @{ $self->{texture} } / MIN_TEXTURE_UNUSED) || 1;
# 
#      for ($self->{map}->expire_textures ($self->{expire_count}, $count)) {
#         warn DC::SvREFCNT $self->{texture}[$_];
#         $self->{texture}[$_]->unload;
#         warn "expire texture $_\n";#d#
#      }
# 
#      ($self->{expire_count} += $count) < @{ $self->{texture} }
#         or $self->{expire_count} = DC::DB::FIRST_TILE_ID;
#      warn "count is $count\n";#d#
#   };

   $self->{open_container} = 0;

   # per server
   $self->{mapcache} = "mapcache_$self->{host}_$self->{port}";

   $self
}

sub update_fx_want {
   my ($self) = @_;

   $self->send_exti_msg (fx_want => {
      3 => !!$::CFG->{bgm_enable},   # FT_MUSIC
      5 => !!$::CFG->{audio_enable}, # FT_SOUND
      6 => 1,                        # FT_RSRC
   });
}

sub ext_capabilities {
   my ($self, %cap) = @_;

   $self->update_fx_want;

   $self->send_exti_req (resource => "exp_table", sub {
      my ($exp_table) = @_;

      $self->register_face_handler ($exp_table, sub {
         my ($face) = @_;

         $self->{exp_table} = $self->{json_coder}->decode (delete $face->{data});
         $_->() for values %{ $self->{on_exp_update} || {} };
      });

      ()
   });

   if (my $ts = $cap{tileset}) {
      if (my ($default) = grep $_->[2] & 1, @$ts) {
         $self->{tileset} = $default;
         $self->{tilesize} = $default->[3];
         $self->setup_req (tileset => $default->[0]);

         my $w = int $self->{mapw} * 32 / $self->{tilesize};
         my $h = int $self->{maph} * 32 / $self->{tilesize};

         $self->setup_req (mapsize => "${w}x${h}");
      }
   }
}

sub ext_ambient_music {
   my ($self, $songs) = @_;
   &::audio_music_set_ambient ($songs);
}

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

sub widget_associate {
   my ($self, $ws, $id, $widget) = @_;

   $widget ||= new DC::UI::Bin;

   $widget->{s_id} = $id;
   $self->{widget}{$id} = $widget;

   if ($ws) {
      $widget->{s_ws} = $ws;
      $self->{widgetset}{$ws}{w}{$id} = $widget;
   }

DC/Protocol.pm view on Meta::CPAN

   [&CS_STAT_RES_PARA     => \&_stat_numdiff, "paralyse"],
   [&CS_STAT_TURN_UNDEAD  => \&_stat_numdiff, "turnundead"],
   [&CS_STAT_RES_FEAR     => \&_stat_numdiff, "fear"],
   [&CS_STAT_RES_DEPLETE  => \&_stat_numdiff, "depletion"],
   [&CS_STAT_RES_DEATH    => \&_stat_numdiff, "death"],
   [&CS_STAT_RES_HOLYWORD => \&_stat_numdiff, "godpower"],
   [&CS_STAT_RES_BLIND    => \&_stat_numdiff, "blind"],
);

sub stats_update {
   my ($self, $stats) = @_;

   my $prev = $self->{prev_stats} || { };

   if (my @diffs =
          (
             ($stats->{+CS_STAT_EXP64} > $prev->{+CS_STAT_EXP64} ? ($stats->{+CS_STAT_EXP64} - $prev->{+CS_STAT_EXP64}) . " experience gained" : ()),
             map {
                $stats->{$_} && $prev->{$_} 
                   && $stats->{$_}[1] > $prev->{$_}[1] ? "($self->{skill_info}{$_}+" . ($stats->{$_}[1] - $prev->{$_}[1]) . ")" : ()
             } sort { $a <=> $b } keys %{$self->{skill_info}}
          )
   ) {
      my $msg = join " ", @diffs;
      $self->{statusbox}->add ($msg, group => "experience $msg", fg => [0.5, 1, 0.5, 0.8], timeout => 5);
   }

   if (
      my @diffs = map $_->[1]->($self, $_->[2], $prev->{$_->[0]}, $stats->{$_->[0]}), @statchange
   ) {
      my $msg = "<b>stat change</b>: " . (join " ", map "($_)", @diffs);
      $self->{statusbox}->add ($msg, group => "stat $msg", fg => [0.8, 1, 0.2, 1], timeout => 20);
   }

   $self->update_stats_window ($stats, $prev);

   $self->{prev_stats} = { %$stats };
}

my %RES_TBL = (
   phys  => CS_STAT_RES_PHYS,
   magic => CS_STAT_RES_MAG,
   fire  => CS_STAT_RES_FIRE,
   elec  => CS_STAT_RES_ELEC,
   cold  => CS_STAT_RES_COLD,
   conf  => CS_STAT_RES_CONF,
   acid  => CS_STAT_RES_ACID,
   drain => CS_STAT_RES_DRAIN,
   ghit  => CS_STAT_RES_GHOSTHIT,
   pois  => CS_STAT_RES_POISON,
   slow  => CS_STAT_RES_SLOW,
   para  => CS_STAT_RES_PARA,
   tund  => CS_STAT_TURN_UNDEAD,
   fear  => CS_STAT_RES_FEAR,
   depl  => CS_STAT_RES_DEPLETE,
   deat  => CS_STAT_RES_DEATH,
   holyw => CS_STAT_RES_HOLYWORD,
   blind => CS_STAT_RES_BLIND,
);

sub update_stats_window {
   my ($self, $stats, $prev) = @_;

   # I love text protocols...

   my $hp   = $stats->{+CS_STAT_HP} * 1;
   my $hp_m = $stats->{+CS_STAT_MAXHP} * 1;
   my $sp   = $stats->{+CS_STAT_SP} * 1;
   my $sp_m = $stats->{+CS_STAT_MAXSP} * 1;
   my $fo   = $stats->{+CS_STAT_FOOD} * 1;
   my $fo_m = 999;
   my $gr   = $stats->{+CS_STAT_GRACE} * 1;
   my $gr_m = $stats->{+CS_STAT_MAXGRACE} * 1;

   $::GAUGES->{hp}      ->set_value ($hp, $hp_m);
   $::GAUGES->{mana}    ->set_value ($sp, $sp_m);
   $::GAUGES->{food}    ->set_value ($fo, $fo_m);
   $::GAUGES->{grace}   ->set_value ($gr, $gr_m);
   $::GAUGES->{exp}     ->set_label ("Exp: " . (::formsep ($stats->{+CS_STAT_EXP64}))#d#
                                     . " (lvl " . ($stats->{+CS_STAT_LEVEL} * 1) . ")");
   $::GAUGES->{exp}     ->set_value ($stats->{+CS_STAT_LEVEL}, $stats->{+CS_STAT_EXP64});
   $::GAUGES->{range}   ->set_text ($stats->{+CS_STAT_RANGE});
   my $title = $stats->{+CS_STAT_TITLE};
   $title =~ s/^Player: //;
   $::STATWIDS->{title} ->set_text ("Title: " . $title);

   $::STATWIDS->{st_str} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_STR});
   $::STATWIDS->{st_dex} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_DEX});
   $::STATWIDS->{st_con} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_CON});
   $::STATWIDS->{st_int} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_INT});
   $::STATWIDS->{st_wis} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_WIS});
   $::STATWIDS->{st_pow} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_POW});
   $::STATWIDS->{st_cha} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_CHA});
   $::STATWIDS->{st_wc}  ->set_text (sprintf "%d"  , $stats->{+CS_STAT_WC});
   $::STATWIDS->{st_ac}  ->set_text (sprintf "%d"  , $stats->{+CS_STAT_AC});
   $::STATWIDS->{st_dam} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_DAM});
   $::STATWIDS->{st_arm} ->set_text (sprintf "%d"  , $stats->{+CS_STAT_RES_PHYS});
   $::STATWIDS->{st_spd} ->set_text (sprintf "%.1f", $stats->{+CS_STAT_SPEED});
   $::STATWIDS->{st_wspd}->set_text (sprintf "%.1f", $stats->{+CS_STAT_WEAP_SP});
 
   $self->update_weight;

   $::STATWIDS->{"res_$_"}->set_text (sprintf "%d%%", $stats->{$RES_TBL{$_}})
      for keys %RES_TBL;

   my $sktbl = $::STATWIDS->{skill_tbl};
   my @skills = keys %{ $self->{skill_info} };

   my @order = sort { $stats->{$b->[0]}[1] <=> $stats->{$a->[0]}[1] or $a->[1] cmp $b->[1] }
               map [$_, $self->{skill_info}{$_}],
               grep exists $stats->{$_},
               @skills;
  
   if ($self->{stat_order} ne join ",", map $_->[0], @order) {
      $self->{stat_order} = join ",", map $_->[0], @order;

      $sktbl->clear;

      my $sw = $self->{skillwid}{""} ||= [
         0, 0, (new DC::UI::Label text => "Experience", align => 1),
         1, 0, (new DC::UI::Label text => "Lvl.", align => 1),

DC/Protocol.pm view on Meta::CPAN

         tooltip_font => $::FONT_FIXED,
      ) if $type eq "info";
   }
}

sub spell_add {
   my ($self, $spell) = @_;

   # try to create single paragraphs out of the multiple lines sent by the server
   $spell->{message} =~ s/(?<=\S)\n(?=\w)/ /g;
   $spell->{message} =~ s/\n+$//;
   $spell->{message} ||= "Server did not provide a description for this spell.";

   $::SPELL_LIST->add_spell ($spell);

   $self->{map_widget}->add_command ("invoke $spell->{name}", DC::asxml $spell->{message});
   $self->{map_widget}->add_command ("cast $spell->{name}", DC::asxml $spell->{message});
}

sub spell_delete {
   my ($self, $spell) = @_;

   $::SPELL_LIST->remove_spell ($spell);
}

sub setup {
   my ($self, $setup) = @_;

   $self->{map_widget}->set_tilesize ($self->{tilesize});
   $::MAP->resize ($self->{mapw}, $self->{maph});
}

sub addme_success {
   my ($self) = @_;

   my %skill_help;

   for my $node (DC::Pod::find skill_description => "*") {
      my (undef, @par) = DC::Pod::section_of $node;
      $skill_help{$node->[DC::Pod::N_KW][0]} = DC::Pod::as_label @par;
   };
 
   for my $skill (values %{$self->{skill_info}}) {
      $self->{map_widget}->add_command ("ready_skill $skill",
                                        (DC::asxml "Ready the skill '$skill'\n\n")
                                        . $skill_help{$skill});
      $self->{map_widget}->add_command ("use_skill $skill",
                                        (DC::asxml "Immediately use the skill '$skill'\n\n")
                                        . $skill_help{$skill});
   }
}

sub eof {
   my ($self) = @_;

   $self->{map_widget}->clr_commands;

   ::stop_game ();
}

sub update_floorbox {
   $DC::UI::ROOT->on_refresh ($::FLOORBOX => sub {
      return unless $::CONN;

      $::FLOORBOX->clear;

      my @add;

      my $row;
      for (sort { $b->{count} <=> $a->{count} } values %{ $::CONN->{container}{$::CONN->{open_container} || 0} }) {
         next if $_->{tag} & 0x80000000;
         if ($row < 6) {
            local $_->{face_widget}; # hack to force recreation of widget
            local $_->{desc_widget}; # hack to force recreation of widget
            DC::Item::update_widgets $_;

            push @add,
               0, $row, $_->{face_widget},
               1, $row, $_->{desc_widget};

            $row++;
         } else {
            push @add, 1, $row, new DC::UI::Button
               text        => "More...",
               on_activate => sub { ::toggle_player_page ($::INVENTORY_PAGE); 0 },
            ;
            last;
         }
      }
      if ($::CONN->{open_container}) {
         push @add, 1, $row++, new DC::UI::Button
            text        => "Close container",
            on_activate => sub { $::CONN->send ("apply $::CONN->{open_container}") }
         ;
      }

      $::FLOORBOX->add_at (@add);
   });

   $::WANT_REFRESH = 1;
}

sub set_opencont {
   my ($conn, $tag, $name) = @_;
   $conn->{open_container} = $tag;
   update_floorbox;

   $::INVR_HB->clear;
   $::INVR_HB->add (new DC::UI::Label expand => 1, text => $name);

   if ($tag != 0) { # Floor isn't closable, is it?
      $::INVR_HB->add (new DC::UI::Button
         text     => "Close container",
         tooltip  => "Close the currently open container (if one is open)",
         on_activate => sub {
            $::CONN->send ("apply $tag") # $::CONN->{open_container}")
               if $tag != 0;
            0
         },
      );
   }

   $::INVR->set_items ($conn->{container}{$tag});
}

sub update_containers {
   my ($self) = @_;

   $DC::UI::ROOT->on_refresh ("update_containers_$self" => sub {
      my $todo = delete $self->{update_container}
         or return;

      for my $tag (keys %$todo) {
         update_floorbox if $tag == 0 or $tag == $self->{open_container};
         if ($tag == 0) {
            $::INVR->set_items ($self->{container}{0})
               if $tag == $self->{open_container};
         } elsif ($tag == $self->{player}{tag}) {
            $::INV->set_items ($self->{container}{$tag})
         } else {
            $::INVR->set_items ($self->{container}{$tag})
               if $tag == $self->{open_container};
         }
      }
   });
}

sub container_add {
   my ($self, $tag, $items) = @_;

   $self->{update_container}{$tag}++;
   $self->update_containers;
}

sub container_clear {
   my ($self, $tag) = @_;

   $self->{update_container}{$tag}++;
   $self->update_containers;
}

sub item_delete {
   my ($self, @items) = @_;

   $self->{update_container}{$_->{container}}++
      for @items;
   
   $self->update_containers;
}

sub item_update {
   my ($self, $item) = @_;

   #print "item_update: $item->{tag} in $item->{container} pt($self->{player}{tag}) oc($::CONN->{open_container}) f($item->{flags})\n";

   DC::Item::update_widgets $item;
   
   if ($item->{tag} == $::CONN->{open_container} && not ($item->{flags} & F_OPEN)) {
      set_opencont ($::CONN, 0, "Floor");

   } elsif ($item->{flags} & F_OPEN) {
      set_opencont ($::CONN, $item->{tag}, DC::Item::desc_string $item);

   } else {
      $self->{update_container}{$item->{container}}++;
      $self->update_containers;
   }
}

sub player_update {
   my ($self, $player) = @_;

   $self->update_weight;
}

sub update_weight {
   my ($self) = @_;

   my $weight = .001 * $self->{player}{weight};
   my $limit  = .001 * $self->{stat}{+CS_STAT_WEIGHT_LIM};

   $::STATWIDS->{weight}->set_text (sprintf "Weight: %.1fkg", $weight);
   $::STATWIDS->{m_weight}->set_text (sprintf "Max Weight: %.1fkg", $limit);
   $::STATWIDS->{i_weight}->set_text (sprintf "%.1f/%.1fkg", $weight, $limit);
}

sub update_server_info {
   my ($self) = @_;

   my @yesno = ("<span foreground='red'>no</span>", "<span foreground='green'>yes</span>");

   my $version = JSON::XS->new->encode ($self->{s_version});

   $::SERVER_INFO->set_markup (
      "server <tt>$self->{host}:$self->{port}</tt>\n"
    . "protocol version <tt>$version</tt>\n"
    . "minimap support $yesno[$self->{setup}{mapinfocmd} > 0]\n"
    . "extended command support $yesno[$self->{setup}{extcmd} > 0]\n"
    . "examine command support $yesno[$self->{setup}{excmd} > 0]\n"
    . "editing support $yesno[!!$self->{editor_support}]\n"
    . "map attributes $yesno[$self->{setup}{extmap} > 0]\n"
    . "big image protocol support $yesno[$self->{setup}{fxix} > 0]\n"
    . "client support $yesno[$self->{cfplus_ext} > 0]"
      . ($self->{cfplus_ext} > 0 ? ", version $self->{cfplus_ext}" : "") ."\n"
    . "map size $self->{mapw}Ã—$self->{maph}\n"
   );

}

sub logged_in {
   my ($self) = @_;

   $self->send_ext_req (cfplus_support => version => 2, sub {
      my (%msg) = @_;

      $self->{cfplus_ext} = $msg{version};
      $self->update_server_info;

      if ($self->{cfplus_ext} >= 2) {
         $self->send_ext_req ("editor_support", sub {
            $self->{editor_support} = { @_ };
            $self->update_server_info;

            0
         });
      }

      0
   });

   $self->update_server_info;

   $self->send_command ("output-rate $::CFG->{output_rate}") if $::CFG->{output_rate} > 0;
   $self->send_pickup ($::CFG->{pickup});
}

sub lookat {
   my ($self, $x, $y) = @_;

   if ($self->{cfplus_ext}) {
      $self->send_ext_req (lookat => $x, $y, sub {
         my (%msg) = @_;

         if (exists $msg{npc_dialog}) {
            # start npc chat dialog
            $self->{npc_dialog} = new DC::NPCDialog::
               token => $msg{npc_dialog},

DC/Protocol.pm view on Meta::CPAN

      force_h => $::HEIGHT * 0.7,
      title   => "NPC Dialog",
      kw      => { hi => 0, yes => 0, no => 0 },
      has_close_button => 1,
      @_,
   );

   DC::weaken (my $this = $self);

   $self->connect (delete => sub { $this->destroy; 1 });

   # better use a pane...
   $self->add (my $hbox = new DC::UI::HBox);
   $hbox->add ($self->{textview} = new DC::UI::TextScroller expand => 1);

   $hbox->add (my $vbox = new DC::UI::VBox);

   $vbox->add (new DC::UI::Label text => "Message Entry:");
   $vbox->add ($self->{entry} = new DC::UI::Entry
      tooltip     => "#npc_message_entry",
      on_activate => sub {
         my ($entry, $text) = @_;

         return unless $text =~ /\S/;

         $entry->set_text ("");
         $this->send ($text);

         0
      },
   );

   $vbox->add ($self->{options} = new DC::UI::VBox);

   $self->{bye_button} = new DC::UI::Button
      text        => "Bye (close)",
      tooltip     => "Use this button to end talking to the NPC. This also closes the dialog window.",
      on_activate => sub { $this->destroy; 1 },
   ;

   $self->update_options;

   $self->{id} = "npc-channel-" . $self->{conn}->token;
   $self->{conn}->connect_ext ($self->{id} => sub {
      $this->feed (@_) if $this;
   });

   $self->{conn}->send_ext_msg (npc_dialog_begin => $self->{id}, $self->{token});

   $self->{entry}->grab_focus;

   $self->{textview}->add_paragraph ({
      fg     => [1, 1, 0, 1],
      markup => "<small>[starting conversation with <b>$self->{title}</b>]</small>\n\n",
   });

   $self->show;
   $self
};

sub update_options {
   my ($self) = @_;

   DC::weaken $self;

   $self->{options}->clear;
   $self->{options}->add ($self->{bye_button});

   for my $kw (sort keys %{ $self->{kw} }) {
      $self->{options}->add (new DC::UI::Button
         text => $kw,
         on_activate => sub {
            $self->send ($kw);
            0
         },
      );
   }
}

sub feed {
   my ($self, $type, @arg) = @_;

   DC::weaken $self;

   if ($type eq "update") {
      my (%info) = @arg;

      $self->{kw}{$_} = 1 for @{$info{add_topics} || []};
      $self->{kw}{$_} = 0 for @{$info{del_topics} || []};
      
      if (exists $info{msg}) {
         my $text = "\n" . DC::Protocol::sanitise_xml $info{msg};
         my $match = join "|", map "\\b\Q$_\E\\b", sort { (length $b) <=> (length $a) } keys %{ $self->{kw} };
         my @link;
         $text =~ s{
            ($match)
         }{
            my $kw = $1;

            push @link, new DC::UI::Label
               markup     => "<span foreground='#c0c0ff' underline='single'>$kw</span>",
               can_hover  => 1,
               can_events => 1,
               padding_x  => 0,
               padding_y  => 0,
               on_button_up => sub {
                  $self->send ($kw);
               };

            "\x{fffc}"
         }giex;
         
         $self->{textview}->add_paragraph ({ markup => $text, widget => \@link });
         $self->{textview}->scroll_to_bottom;
      }

      $self->update_options;
   } else {
      $self->destroy;
   }

( run in 0.973 second using v1.01-cache-2.11-cpan-39bf76dae61 )