deliantra/Deliantra-Client/DC.pm

=head1 NAME

CFClient - undocumented utility garbage for our crossfire client

=head1 SYNOPSIS

 use CFClient;

=head1 DESCRIPTION

=over 4

=cut

package CFClient;

BEGIN {
   $VERSION = '0.1';

   use XSLoader;
   XSLoader::load "CFClient", $VERSION;
}

use utf8;

use Carp ();
use AnyEvent ();
use BerkeleyDB;
use Pod::POM ();
use Scalar::Util ();
use Storable (); # finally

our %STAT_TOOLTIP = (
   Str => "<b>Physical Strength</b>, determines damage dealt with weapons, how much you can carry, and how often you can attack",
   Dex => "<b>Dexterity</b>, your physical agility. Determines chance of being hit and affects armor class and speed",
   Con => "<b>Constitution</b>, physical health and toughness. Determines how many healthpoints you can have",
   Int => "<b>Intelligence</b>, your ability to learn and use skills and incantations (both prayers and magic) and determines how much spell points you can have",
   Wis => "<b>Wisdom</b>, the ability to learn and use divine magic (prayers). Determines how many grace points you can have",
   Pow => "<b>Power</b>, your magical potential. Influences the strength of spell effects, and also how much your spell and grace points increase when leveling up",
   Cha => "<b>Charisma</b>, how well you are received by NPCs. Affects buying and selling prices in shops.",

   Wc  => "<b>Weapon Class</b>, effectiveness of melee/missile attacks. Lower is more potent. Current weapon, level and Str are some things which effect the value of Wc. The value of Wc may range between 25 and -72.",
   Ac  => "<b>Armour Class</b>, how protected you are from being hit by any attack. Lower values are better. Ac is based on your race and is modified by the Dex and current armour worn. For characters that cannot wear armour, Ac improves as their level increases.",
   Dam => "<b>Damage</b>, how much damage your melee/missile attack inflicts. Higher values indicate a greater amount of damage will be inflicted with each attack.",
   Arm => "<b>Armour</b>, how much damage (from physical attacks) will be subtracted from successful hits made upon you. This value ranges between 0 to 99%. Current armour worn primarily determines Arm value. This is the same as the physical resistance.",
   Spd => "<b>Speed</b>, how fast you can move. The value of speed may range between nearly 0 (\"very slow\") to higher than 5 (\"lightning fast\"). Base speed is determined from the Dex and modified downward proportionally by the amount of weight carried which exceeds the Max Carry limit. The armour worn also sets the upper limit on speed.",
   WSp => "<b>Weapon Speed</b>, how many attacks you may make per unit of time (0.120s). Higher values indicate faster attack speed. Current weapon and Dex effect the value of weapon speed.",
);

=item guard { BLOCK }

Returns an object that executes the given block as soon as it is destroyed.

=cut

sub guard(&) {
   bless \(my $cb = $_[0]), "CFClient::Guard"
}

sub CFClient::Guard::DESTROY {
   ${$_[0]}->()
}

package CFClient::PodToPango;

use base Pod::POM::View::Text;

our $VERSION = 1; # bump if resultant formatting changes

our $indent = 0;

*view_seq_code   =
*view_seq_bold   = sub { "<b>$_[1]</b>" };
*view_seq_italic = sub { "<i>$_[1]</i>" };
*view_seq_space  =
*view_seq_link   =
*view_seq_index  = sub { CFClient::UI::Label::escape ($_[1]) };

sub view_seq_text {
   my $text = $_[1];
   $text =~ s/\s+/ /g;
   CFClient::UI::Label::escape ($text)
}

sub view_item {
   ("\t" x ($indent / 4))
   . $_[1]->title->present ($_[0])
   . "\n\n"
   . $_[1]->content->present ($_[0])
}

sub view_verbatim {
   (join "",
       map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
          split /\n/, CFClient::UI::Label::escape ($_[1]))
   . "\n"
}

sub view_textblock {
   ("\t" x ($indent / 2)) . "$_[1]\n\n"
}

sub view_head1 {
   "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
   . $_[1]->content->present ($_[0])
};

sub view_head2 {
   "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
   . $_[1]->content->present ($_[0])
};

sub view_head3 {
   "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
   . $_[1]->content->present ($_[0])
};

sub view_over {
   local $indent = $indent + $_[1]->indent;
   $_[1]->content->present ($_[0])
}

package CFClient::Database;

our @ISA = BerkeleyDB::Btree::;

sub get($$) {
   my $data;

   $_[0]->db_get ($_[1], $data) == 0
      ? $data
      : ()
}

my %DB_SYNC;

sub put($$$) {
   my ($db, $key, $data) = @_;

   $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });

   $db->db_put ($key => $data)
}

package CFClient;

sub find_rcfile($) {
   my $path;

   for (grep !ref, @INC) {
      $path = "$_/CFClient/resources/$_[0]";
      return $path if -r $path;
   }

   die "FATAL: can't find required file $_[0]\n";
}

sub read_cfg {
   my ($file) = @_;

   open CFG, $file
      or return;

   my $CFG;

   local $/;
   $CFG = eval <CFG>;

   $::CFG = $CFG;

   close CFG;
}

sub write_cfg {
   my ($file) = @_;

   open CFG, ">$file"
      or return;

   {
      require Data::Dumper;
      local $Data::Dumper::Purity = 1;
      $::CFG->{VERSION} = $::VERSION;
      print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
   }

   close CFG;
}

our $DB_ENV;

{
   use strict;

   mkdir "$Crossfire::VARDIR/cfplus", 0777;
   my $recover = $BerkeleyDB::db_version >= 4.4 
                 ? eval "DB_REGISTER | DB_RECOVER"
                 : 0;

   $DB_ENV = new BerkeleyDB::Env
                    -Home => "$Crossfire::VARDIR/cfplus",
                    -Cachesize => 1_000_000,
                    -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
#                 -ErrPrefix => "DATABASE",
                    -Verbose => 1,
                    -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
                    -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
                       or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
}

sub db_table($) {
   my ($table) = @_;

   $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;

   new CFClient::Database
      -Env      => $DB_ENV,
      -Filename => $table,
#      -Filename => "database",
#      -Subname  => $table,
      -Property => DB_CHKSUM,
      -Flags    => DB_CREATE | DB_UPGRADE,
         or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
}

my $pod_cache = db_table "pod_cache";

sub load_pod($$$$) {
   my ($path, $filtertype, $filterversion, $filtercb) = @_;

   stat $path
      or die "$path: $!";

   my $phash = join ",", $filterversion, $CFClient::PodToPango::VERSION, (stat _)[7,9];

   my ($chash, $pom) = eval { @{ Storable::thaw $pod_cache->get ("$path/$filtertype") } };

   return $pom if $chash eq $phash;

   my $pod = do {
      local $/;
      open my $pod, "<:utf8", $_[0]
         or die "$_[0]: $!";
      <$pod>
   };

   #utf8::downgrade $pod;

   $pom = $filtercb-> (Pod::POM->new->parse_text ($pod));

   $pod_cache->put ("$path/$filtertype" => Storable::nfreeze [$phash, $pom]);

   $pom
}

sub pod_to_pango($) {
   my ($pom) = @_;

   $pom->present ("CFClient::PodToPango")
}

sub pod_to_pango_list($) {
   my ($pom) = @_;

   [
      map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
         split /\n/, $pom->present ("CFClient::PodToPango")
   ]
}

package CFClient::Layout;

$CFClient::OpenGL::SHUTDOWN_HOOK{"CFClient::Layout"} = sub {
   reset_glyph_cache;
};

package CFClient::Item;

use strict;
use Crossfire::Protocol::Constants;

my $last_enter_count = 1;

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

   my $desc =
      $self->{nrof} < 2
         ? $self->{name}
         : "$self->{nrof} × $self->{name_pl}";

   $self->{flags} & F_OPEN
      and $desc .= " (open)";
   $self->{flags} & F_APPLIED
      and $desc .= " (applied)";
   $self->{flags} & F_UNPAID
      and $desc .= " (unpaid)";
   $self->{flags} & F_MAGIC
      and $desc .= " (magic)";
   $self->{flags} & F_CURSED
      and $desc .= " (cursed)";
   $self->{flags} & F_DAMNED
      and $desc .= " (damned)";
   $self->{flags} & F_LOCKED
      and $desc .= " *";

   $desc
}

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

   my $weight = ($self->{nrof} || 1) * $self->{weight};

   $weight < 0 ? "?" : $weight * 0.001
}

sub do_n_dialog {
   my ($cb) = @_;

   my $w = new CFClient::UI::FancyFrame
      on_delete => sub { $_[0]->destroy; 1 },
      has_close_button => 1,
   ;

   $w->add (my $vb = new CFClient::UI::VBox x => "center", y => "center");
   $vb->add (new CFClient::UI::Label text => "Enter item count:");
   $vb->add (my $entry = new CFClient::UI::Entry
      text => $last_enter_count,
      on_activate => sub {
         my ($entry) = @_;
         $last_enter_count = $entry->get_text;
         $cb->($last_enter_count);
         $w->hide;
         $w->destroy;

         0
      },
      on_escape => sub { $w->destroy; 1 },
   );
   $entry->grab_focus;
   $w->show;
}

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

   # necessary to avoid cyclic references
   Scalar::Util::weaken $self;

   my $button_cb = sub {
      my (undef, $ev, $x, $y) = @_;

      my $targ = $::CONN->{player}{tag};

      if ($self->{container} == $::CONN->{player}{tag}) {
         $targ = $::CONN->{open_container};
      }

      if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
         $::CONN->send ("move $targ $self->{tag} 0")
            if $targ || !($self->{flags} & F_LOCKED);
      } elsif (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 2) {
         $self->{flags} & F_LOCKED
            ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
            : $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
      } elsif ($ev->{button} == 1) {
         $::CONN->send ("examine $self->{tag}");
      } elsif ($ev->{button} == 2) {
         $::CONN->send ("apply $self->{tag}");
      } elsif ($ev->{button} == 3) {
         my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
         if ($self->{container} == $::CONN->{open_container}) {
            $move_prefix = "take";
         }

         my @menu_items = (
            ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
            ["mark",    sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
            ["ignite/thaw",  # first try of an easier use of flint&steel
               sub {
                  $::CONN->send ("mark ". pack "N", $self->{tag});
                  $::CONN->send ("command apply flint and steel");
               }
            ],
            ["apply",   sub { $::CONN->send ("apply $self->{tag}") }],
            (
               $self->{flags} & F_LOCKED
               ? (
                  ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
                 )
               : (
                  ["lock",   sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
                  ["$move_prefix all",   sub { $::CONN->send ("move $targ $self->{tag} 0") }],
                  ["$move_prefix <n>", 
                     sub {
                        do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
                     }
                  ]
               )
            ),
         );

         CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
      }

      1
   };

   my $tooltip_std = "<small>"
                   . "Left click - examine item\n"
                   . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
                   . "Middle click - apply\n"
                   . "Shift-Middle click - lock/unlock\n"
                   . "Right click - further options"
                   . "</small>\n";

   $self->{face_widget} ||= new CFClient::UI::Face 
      can_events => 1,
      can_hover  => 1,
      anim       => $self->{anim},
      animspeed  => $self->{animspeed}, # TODO# must be set at creation time
      on_button_down => $button_cb,
   ;
   $self->{face_widget}{face}      = $self->{face};
   $self->{face_widget}{anim}      = $self->{anim};
   $self->{face_widget}{animspeed} = $self->{animspeed};
   $self->{face_widget}->set_tooltip (
      "<b>Face/Animation.</b>\n"
    . "Item uses face #$self->{face}. "
    . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
    . "\n\n$tooltip_std"
   );
   
   $self->{desc_widget} ||= new CFClient::UI::Label
      can_events => 1,
      can_hover  => 1,
      ellipsise  => 2,
      align      => -1,
      on_button_down => $button_cb,
   ;
   my $desc = CFClient::Item::desc_string $self;
   $self->{desc_widget}->set_text ($desc);
   $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");

   $self->{weight_widget} ||= new CFClient::UI::Label
      can_events => 1,
      can_hover  => 1,
      ellipsise  => 0,
      align      => 0,
      on_button_down => $button_cb,
   ;
   $self->{weight_widget}->set_text (CFClient::Item::weight_string $self);

   $self->{weight_widget}->set_tooltip (
      "<b>Weight</b>.\n"
    . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
    . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
    . "\n\n$tooltip_std"
   );
}

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.103
Committed:	Sun Jul 23 08:58:43 2006 UTC (17 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.102:	+15 -1 lines
Log Message:	preliminary inventory sorting
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3	root	1.22	CFClient - undocumented utility garbage for our crossfire client
4	root	1.1
5			=head1 SYNOPSIS
6
7	root	1.22	use CFClient;
8	root	1.1
9			=head1 DESCRIPTION
10
11			=over 4
12
13			=cut
14
15	root	1.22	package CFClient;
16	root	1.1
17			BEGIN {
18			$VERSION = '0.1';
19
20	root	1.2	use XSLoader;
21	root	1.22	XSLoader::load "CFClient", $VERSION;
22	root	1.1	}
23
24	root	1.62	use utf8;
25
26	root	1.43	use Carp ();
27	root	1.52	use AnyEvent ();
28	root	1.34	use BerkeleyDB;
29	root	1.89	use Pod::POM ();
30	root	1.92	use Scalar::Util ();
31	root	1.89	use Storable (); # finally
32
33	root	1.102	our %STAT_TOOLTIP = (
34			Str => "<b>Physical Strength</b>, determines damage dealt with weapons, how much you can carry, and how often you can attack",
35			Dex => "<b>Dexterity</b>, your physical agility. Determines chance of being hit and affects armor class and speed",
36			Con => "<b>Constitution</b>, physical health and toughness. Determines how many healthpoints you can have",
37			Int => "<b>Intelligence</b>, your ability to learn and use skills and incantations (both prayers and magic) and determines how much spell points you can have",
38			Wis => "<b>Wisdom</b>, the ability to learn and use divine magic (prayers). Determines how many grace points you can have",
39			Pow => "<b>Power</b>, your magical potential. Influences the strength of spell effects, and also how much your spell and grace points increase when leveling up",
40			Cha => "<b>Charisma</b>, how well you are received by NPCs. Affects buying and selling prices in shops.",
41
42			Wc => "<b>Weapon Class</b>, effectiveness of melee/missile attacks. Lower is more potent. Current weapon, level and Str are some things which effect the value of Wc. The value of Wc may range between 25 and -72.",
43			Ac => "<b>Armour Class</b>, how protected you are from being hit by any attack. Lower values are better. Ac is based on your race and is modified by the Dex and current armour worn. For characters that cannot wear armour, Ac improves as their level increases.",
44			Dam => "<b>Damage</b>, how much damage your melee/missile attack inflicts. Higher values indicate a greater amount of damage will be inflicted with each attack.",
45			Arm => "<b>Armour</b>, how much damage (from physical attacks) will be subtracted from successful hits made upon you. This value ranges between 0 to 99%. Current armour worn primarily determines Arm value. This is the same as the physical resistance.",
46			Spd => "<b>Speed</b>, how fast you can move. The value of speed may range between nearly 0 (\"very slow\") to higher than 5 (\"lightning fast\"). Base speed is determined from the Dex and modified downward proportionally by the amount of weight carried which exceeds the Max Carry limit. The armour worn also sets the upper limit on speed.",
47			WSp => "<b>Weapon Speed</b>, how many attacks you may make per unit of time (0.120s). Higher values indicate faster attack speed. Current weapon and Dex effect the value of weapon speed.",
48			);
49
50	root	1.103	=item guard { BLOCK }
51
52			Returns an object that executes the given block as soon as it is destroyed.
53
54			=cut
55
56			sub guard(&) {
57			bless \(my $cb = $_[0]), "CFClient::Guard"
58			}
59
60			sub CFClient::Guard::DESTROY {
61			${$_[0]}->()
62			}
63
64	root	1.89	package CFClient::PodToPango;
65
66			use base Pod::POM::View::Text;
67
68			our $VERSION = 1; # bump if resultant formatting changes
69
70			our $indent = 0;
71
72			*view_seq_code =
73			*view_seq_bold = sub { "<b>$_[1]</b>" };
74			*view_seq_italic = sub { "<i>$_[1]</i>" };
75			*view_seq_space =
76			*view_seq_link =
77			*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
78
79			sub view_seq_text {
80			my $text = $_[1];
81			$text =~ s/\s+/ /g;
82			CFClient::UI::Label::escape ($text)
83			}
84
85			sub view_item {
86			("\t" x ($indent / 4))
87			. $_[1]->title->present ($_[0])
88	root	1.91	. "\n\n"
89	root	1.89	. $_[1]->content->present ($_[0])
90			}
91
92			sub view_verbatim {
93			(join "",
94			map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
95			split /\n/, CFClient::UI::Label::escape ($_[1]))
96			. "\n"
97			}
98
99			sub view_textblock {
100			("\t" x ($indent / 2)) . "$_[1]\n\n"
101			}
102
103			sub view_head1 {
104			"\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
105			. $_[1]->content->present ($_[0])
106			};
107
108			sub view_head2 {
109			"\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
110			. $_[1]->content->present ($_[0])
111			};
112
113			sub view_head3 {
114			"\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
115			. $_[1]->content->present ($_[0])
116			};
117
118			sub view_over {
119			local $indent = $indent + $_[1]->indent;
120			$_[1]->content->present ($_[0])
121			}
122
123			package CFClient::Database;
124
125			our @ISA = BerkeleyDB::Btree::;
126
127			sub get($$) {
128			my $data;
129
130			$_[0]->db_get ($_[1], $data) == 0
131			? $data
132			: ()
133			}
134
135			my %DB_SYNC;
136
137			sub put($$$) {
138			my ($db, $key, $data) = @_;
139
140			$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
141
142			$db->db_put ($key => $data)
143			}
144
145			package CFClient;
146	root	1.52
147	root	1.5	sub find_rcfile($) {
148			my $path;
149
150	root	1.46	for (grep !ref, @INC) {
151	root	1.22	$path = "$_/CFClient/resources/$_[0]";
152	root	1.5	return $path if -r $path;
153			}
154
155			die "FATAL: can't find required file $_[0]\n";
156			}
157
158			sub read_cfg {
159			my ($file) = @_;
160
161			open CFG, $file
162			or return;
163
164			my $CFG;
165
166			local $/;
167			$CFG = eval <CFG>;
168
169			$::CFG = $CFG;
170
171			close CFG;
172			}
173
174			sub write_cfg {
175			my ($file) = @_;
176
177			open CFG, ">$file"
178			or return;
179
180			{
181	elmex	1.9	require Data::Dumper;
182	root	1.5	local $Data::Dumper::Purity = 1;
183			$::CFG->{VERSION} = $::VERSION;
184			print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
185			}
186
187			close CFG;
188			}
189
190	root	1.77	our $DB_ENV;
191
192	root	1.76	{
193			use strict;
194
195	root	1.87	mkdir "$Crossfire::VARDIR/cfplus", 0777;
196	root	1.77	my $recover = $BerkeleyDB::db_version >= 4.4
197			? eval "DB_REGISTER \| DB_RECOVER"
198			: 0;
199
200			$DB_ENV = new BerkeleyDB::Env
201	root	1.76	-Home => "$Crossfire::VARDIR/cfplus",
202			-Cachesize => 1_000_000,
203			-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
204	root	1.39	# -ErrPrefix => "DATABASE",
205	root	1.76	-Verbose => 1,
206	root	1.77	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
207	root	1.78	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
208	root	1.76	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
209			}
210	root	1.34
211			sub db_table($) {
212	root	1.38	my ($table) = @_;
213
214			$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
215	root	1.76
216	root	1.34	new CFClient::Database
217			-Env => $DB_ENV,
218	root	1.38	-Filename => $table,
219			# -Filename => "database",
220			# -Subname => $table,
221	root	1.51	-Property => DB_CHKSUM,
222	root	1.34	-Flags => DB_CREATE \| DB_UPGRADE,
223	root	1.76	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
224	root	1.34	}
225
226	root	1.89	my $pod_cache = db_table "pod_cache";
227	root	1.52
228	root	1.89	sub load_pod($$$$) {
229			my ($path, $filtertype, $filterversion, $filtercb) = @_;
230	root	1.52
231	root	1.89	stat $path
232			or die "$path: $!";
233	root	1.60
234	root	1.89	my $phash = join ",", $filterversion, $CFClient::PodToPango::VERSION, (stat _)[7,9];
235	root	1.60
236	root	1.89	my ($chash, $pom) = eval { @{ Storable::thaw $pod_cache->get ("$path/$filtertype") } };
237	root	1.52
238	root	1.89	return $pom if $chash eq $phash;
239	root	1.52
240	root	1.89	my $pod = do {
241			local $/;
242			open my $pod, "<:utf8", $_[0]
243			or die "$_[0]: $!";
244			<$pod>
245			};
246	root	1.52
247	root	1.89	#utf8::downgrade $pod;
248	root	1.52
249	root	1.89	$pom = $filtercb-> (Pod::POM->new->parse_text ($pod));
250	root	1.52
251	root	1.89	$pod_cache->put ("$path/$filtertype" => Storable::nfreeze [$phash, $pom]);
252	root	1.52
253	root	1.89	$pom
254	root	1.53	}
255
256	root	1.89	sub pod_to_pango($) {
257			my ($pom) = @_;
258	root	1.52
259	root	1.89	$pom->present ("CFClient::PodToPango")
260	root	1.52	}
261
262	root	1.89	sub pod_to_pango_list($) {
263			my ($pom) = @_;
264	root	1.34
265	root	1.89	[
266			map s/^(\s)// && [40 length $1, length $_ ? $_ : " "],
267			split /\n/, $pom->present ("CFClient::PodToPango")
268			]
269	root	1.34	}
270
271	root	1.97	package CFClient::Layout;
272
273			$CFClient::OpenGL::SHUTDOWN_HOOK{"CFClient::Layout"} = sub {
274	root	1.98	reset_glyph_cache;
275	root	1.97	};
276
277	root	1.62	package CFClient::Item;
278
279	root	1.71	use strict;
280			use Crossfire::Protocol::Constants;
281
282	elmex	1.84	my $last_enter_count = 1;
283
284	root	1.62	sub desc_string {
285			my ($self) = @_;
286
287			my $desc =
288			$self->{nrof} < 2
289			? $self->{name}
290			: "$self->{nrof} × $self->{name_pl}";
291
292	root	1.71	$self->{flags} & F_OPEN
293	root	1.62	and $desc .= " (open)";
294	root	1.71	$self->{flags} & F_APPLIED
295	root	1.62	and $desc .= " (applied)";
296	root	1.71	$self->{flags} & F_UNPAID
297	root	1.62	and $desc .= " (unpaid)";
298	root	1.71	$self->{flags} & F_MAGIC
299	root	1.62	and $desc .= " (magic)";
300	root	1.71	$self->{flags} & F_CURSED
301	root	1.62	and $desc .= " (cursed)";
302	root	1.71	$self->{flags} & F_DAMNED
303	root	1.62	and $desc .= " (damned)";
304	root	1.71	$self->{flags} & F_LOCKED
305	root	1.62	and $desc .= " *";
306
307			$desc
308			}
309
310			sub weight_string {
311			my ($self) = @_;
312
313			my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
314
315			$weight < 0 ? "?" : $weight * 0.001
316			}
317
318	elmex	1.84	sub do_n_dialog {
319			my ($cb) = @_;
320
321	root	1.100	my $w = new CFClient::UI::FancyFrame
322			on_delete => sub { $_[0]->destroy; 1 },
323			has_close_button => 1,
324			;
325
326	elmex	1.84	$w->add (my $vb = new CFClient::UI::VBox x => "center", y => "center");
327			$vb->add (new CFClient::UI::Label text => "Enter item count:");
328			$vb->add (my $entry = new CFClient::UI::Entry
329			text => $last_enter_count,
330			on_activate => sub {
331			my ($entry) = @_;
332			$last_enter_count = $entry->get_text;
333			$cb->($last_enter_count);
334			$w->hide;
335	root	1.100	$w->destroy;
336
337			0
338			},
339			on_escape => sub { $w->destroy; 1 },
340	elmex	1.84	);
341	root	1.93	$entry->grab_focus;
342	elmex	1.84	$w->show;
343			}
344
345	root	1.62	sub update_widgets {
346			my ($self) = @_;
347
348	root	1.92	# necessary to avoid cyclic references
349			Scalar::Util::weaken $self;
350
351	root	1.63	my $button_cb = sub {
352			my (undef, $ev, $x, $y) = @_;
353
354	elmex	1.84	my $targ = $::CONN->{player}{tag};
355	root	1.63
356	elmex	1.84	if ($self->{container} == $::CONN->{player}{tag}) {
357			$targ = $::CONN->{open_container};
358			}
359	root	1.63
360	elmex	1.84	if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
361	root	1.79	$::CONN->send ("move $targ $self->{tag} 0")
362			if $targ \|\| !($self->{flags} & F_LOCKED);
363	elmex	1.86	} elsif (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 2) {
364			$self->{flags} & F_LOCKED
365			? $::CONN->send ("lock " . pack "CN", 0, $self->{tag})
366			: $::CONN->send ("lock " . pack "CN", 1, $self->{tag})
367	root	1.63	} elsif ($ev->{button} == 1) {
368			$::CONN->send ("examine $self->{tag}");
369			} elsif ($ev->{button} == 2) {
370			$::CONN->send ("apply $self->{tag}");
371			} elsif ($ev->{button} == 3) {
372	elmex	1.101	my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop';
373			if ($self->{container} == $::CONN->{open_container}) {
374			$move_prefix = "take";
375			}
376
377	root	1.63	my @menu_items = (
378			["examine", sub { $::CONN->send ("examine $self->{tag}") }],
379			["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
380	elmex	1.99	["ignite/thaw", # first try of an easier use of flint&steel
381			sub {
382			$::CONN->send ("mark ". pack "N", $self->{tag});
383			$::CONN->send ("command apply flint and steel");
384			}
385			],
386	root	1.63	["apply", sub { $::CONN->send ("apply $self->{tag}") }],
387			(
388	root	1.71	$self->{flags} & F_LOCKED
389	root	1.63	? (
390			["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
391			)
392			: (
393			["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
394	elmex	1.101	["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }],
395	root	1.103	["$move_prefix <n>",
396	elmex	1.84	sub {
397			do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
398			}
399			]
400	root	1.63	)
401			),
402			);
403
404			CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
405			}
406
407			1
408			};
409
410	root	1.62	my $tooltip_std = "<small>"
411			. "Left click - examine item\n"
412			. "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
413			. "Middle click - apply\n"
414	elmex	1.86	. "Shift-Middle click - lock/unlock\n"
415	root	1.62	. "Right click - further options"
416			. "</small>\n";
417
418	root	1.63	$self->{face_widget} \|\|= new CFClient::UI::Face
419			can_events => 1,
420			can_hover => 1,
421	root	1.67	anim => $self->{anim},
422	root	1.66	animspeed => $self->{animspeed}, # TODO# must be set at creation time
423	root	1.72	on_button_down => $button_cb,
424	root	1.63	;
425	root	1.62	$self->{face_widget}{face} = $self->{face};
426			$self->{face_widget}{anim} = $self->{anim};
427	root	1.65	$self->{face_widget}{animspeed} = $self->{animspeed};
428	root	1.62	$self->{face_widget}->set_tooltip (
429			"<b>Face/Animation.</b>\n"
430			. "Item uses face #$self->{face}. "
431			. ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
432			. "\n\n$tooltip_std"
433			);
434
435	root	1.63	$self->{desc_widget} \|\|= new CFClient::UI::Label
436			can_events => 1,
437			can_hover => 1,
438			ellipsise => 2,
439	root	1.68	align => -1,
440	root	1.72	on_button_down => $button_cb,
441	root	1.63	;
442			my $desc = CFClient::Item::desc_string $self;
443			$self->{desc_widget}->set_text ($desc);
444			$self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
445
446			$self->{weight_widget} \|\|= new CFClient::UI::Label
447			can_events => 1,
448			can_hover => 1,
449			ellipsise => 0,
450	root	1.68	align => 0,
451	root	1.72	on_button_down => $button_cb,
452	root	1.63	;
453	root	1.62	$self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
454
455			$self->{weight_widget}->set_tooltip (
456			"<b>Weight</b>.\n"
457			. ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
458			. ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
459			. "\n\n$tooltip_std"
460			);
461			}
462
463	root	1.1	1;
464
465			=back
466
467			=head1 AUTHOR
468
469			Marc Lehmann <schmorp@schmorp.de>
470			http://home.schmorp.de/
471
472			=cut
473