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;

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;
}

mkdir "$Crossfire::VARDIR/cfplus", 0777;

our $DB_ENV;

{
   use strict;

   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"
}

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::PodToPango;

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

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"
   . $_[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::Item;

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

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 update_widgets {
   my ($self) = @_;

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

      if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
         my $targ = $::CONN->{player}{tag};

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

         $::CONN->send ("move $targ $self->{tag} 0")
            if $targ || !($self->{flags} & F_LOCKED);
      } elsif ($ev->{button} == 1) {
         $::CONN->send ("examine $self->{tag}");
      } elsif ($ev->{button} == 2) {
         $::CONN->send ("apply $self->{tag}");
      } elsif ($ev->{button} == 3) {
         my @menu_items = (
            ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
            ["mark",    sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
            ["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}) }],
                  ["drop",   sub { $::CONN->send ("move $::CONN->{open_container} $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"
                   . "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"
   );
}

package CFClient::Recorder;

our $RECORD_WINDOW;

my $CMDBOX;
my $CURRENT_CMDS;
my $REC_BTN;

my @ALLOWED_MODIFIER_KEYS = (
   (CFClient::SDLK_LSHIFT) => "LSHIFT",
   (CFClient::SDLK_LCTRL ) => "LCTRL",
   (CFClient::SDLK_LALT  ) => "LALT",
   (CFClient::SDLK_LMETA ) => "LMETA",

   (CFClient::SDLK_RSHIFT) => "RSHIFT",
   (CFClient::SDLK_RCTRL ) => "RCTRL",
   (CFClient::SDLK_RALT  ) => "RALT",
   (CFClient::SDLK_RMETA ) => "RMETA",
);

my %ALLOWED_MODIFIERS = (
   (CFClient::KMOD_LSHIFT) => "LSHIFT",
   (CFClient::KMOD_LCTRL ) => "LCTRL",
   (CFClient::KMOD_LALT  ) => "LALT",
   (CFClient::KMOD_LMETA ) => "LMETA",

   (CFClient::KMOD_RSHIFT) => "RSHIFT",
   (CFClient::KMOD_RCTRL ) => "RCTRL",
   (CFClient::KMOD_RALT  ) => "RALT",
   (CFClient::KMOD_RMETA ) => "RMETA",
);

my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
my @DIRECT_BIND_KEYS = (
   CFClient::SDLK_F1,
   CFClient::SDLK_F2,
   CFClient::SDLK_F3,
   CFClient::SDLK_F4,
   CFClient::SDLK_F5,
   CFClient::SDLK_F6,
   CFClient::SDLK_F7,
   CFClient::SDLK_F8,
   CFClient::SDLK_F9,
   CFClient::SDLK_F10,
   CFClient::SDLK_F11,
   CFClient::SDLK_F12,
   CFClient::SDLK_F13,
   CFClient::SDLK_F14,
   CFClient::SDLK_F15,
);

# this binding dialog asks for a key-combo to be pressed
# and if successful it binds the modifier+symbol to the 
# supplied actions in $cmd.
# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
sub open_binding_dialog {
   my ($cmd) = @_;

   my $w = new CFClient::UI::FancyFrame
      title => "Bind Action";

   $w->add (my $vb = new CFClient::UI::VBox);
   $vb->add (new CFClient::UI::Label
      text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
             ."You can only bind 0-9 and F1-F15 without modifiers."
   );
   $vb->add (my $entry = new CFClient::UI::Entry
      text => "",
      on_key_down => sub {
         my ($entry, $ev) = @_;

         my $mod = $ev->{mod};
         my $sym = $ev->{sym};

         # XXX: This seems a little bit hackisch to me, but i have to ignore them
         if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
            return;
         }

         if ($mod == CFClient::KMOD_NONE
             and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
             and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
         {
            $::STATUSBOX->add (
               "Can't bind key ".CFClient::SDL_GetKeyName ($sym)
               ." directly without modifier! It would damage the completer handling."
            );
            return;
         }

         $entry->focus_out;

         $::CFG->{bindings}->{$mod}->{$sym} = $cmd;
         $::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");

         $w->destroy
      });

   $entry->focus_in;
   $w->center;
   $w->show;
}

sub keycombo_to_name {
   my ($mod, $sym) = @_;

   my $mods = join '+',
                 map { $ALLOWED_MODIFIERS{$_} }
                    grep { $_ & $mod }
                       keys %ALLOWED_MODIFIERS;
   $mods .= "+" if $mods ne '';

   return $mods . CFClient::SDL_GetKeyName ($sym);
}

sub clear_command_list {
   $CMDBOX->clear () if $CMDBOX;
}

sub set_command_list {
   my ($list) = @_;

   return unless $CMDBOX;

   $CMDBOX->clear ();
   $CURRENT_CMDS = $list;

   my $idx = 0;

   for (@$list) {
      $CMDBOX->add (my $hb = new CFClient::UI::HBox);

      my $i = $idx;
      $hb->add (new CFClient::UI::Button
         text => "delete",
         tooltip => "Deletes the action from the record",
         on_activate => sub {
            $CMDBOX->remove ($hb);
            $list->[$i] = undef;
         });

      $hb->add (new CFClient::UI::Label text => $_);

      $idx++
   }
}

# if $show is 1 the recorder will be shown
sub start {
   my ($show) = @_;

   $RECORD_WINDOW->show if $show;

   $REC_BTN->set_text ("stop recording");
   $REC_BTN->{recording} = 1;
   clear_command_list;
   $::CONN->start_record;
}

# if $autobind is 1 the recorder will be automatically
# jump into the binding query and hide the recorder window
sub stop {
   my ($autobind) = @_;

   $REC_BTN->set_text ("start recording");
   $REC_BTN->{recording} = 0;

   my $rec = $::CONN->stop_record;
   return unless ref $rec eq 'ARRAY';
   set_command_list ($rec);

   if ($autobind) {
      open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
      $RECORD_WINDOW->hide;
   }
}

sub make_window {
   $RECORD_WINDOW = new CFClient::UI::FancyFrame
      req_y => 1,
      req_x => -1,
      title => "Action Recorder";

   $RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
   $vb->add ($REC_BTN = new CFClient::UI::Button
      text => "start recording",
      tooltip => "Start/Stops recording of actions."
                ."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
                ."All subsequent actions after the recording started will be captured."
                ."The actions are displayed after the record was stopped."
                ."To bind the action you have to click on the 'Bind' button",
      on_activate => sub {
         my ($btn) = @_;

         unless ($btn->{recording}) {
            start;
         } else {
            stop;
         }
      });
   $vb->add ($CMDBOX = new CFClient::UI::VBox);
   $vb->add (new CFClient::UI::Button
      text => "bind",
      tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
      on_activate => sub {
         open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
      });

   $RECORD_WINDOW
}

1;

=back

=head1 AUTHOR

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

=cut

Revision:	1.79
Committed:	Tue May 30 02:55:45 2006 UTC (17 years, 11 months ago) by root
Branch:	MAIN
Changes since 1.78:	+2 -1 lines
Log Message:	more tuning, implement generic (but suboptimal) padding
#	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.52
30	root	1.5	sub find_rcfile($) {
31			my $path;
32
33	root	1.46	for (grep !ref, @INC) {
34	root	1.22	$path = "$_/CFClient/resources/$_[0]";
35	root	1.5	return $path if -r $path;
36			}
37
38			die "FATAL: can't find required file $_[0]\n";
39			}
40
41			sub read_cfg {
42			my ($file) = @_;
43
44			open CFG, $file
45			or return;
46
47			my $CFG;
48
49			local $/;
50			$CFG = eval <CFG>;
51
52			$::CFG = $CFG;
53
54			close CFG;
55			}
56
57			sub write_cfg {
58			my ($file) = @_;
59
60			open CFG, ">$file"
61			or return;
62
63			{
64	elmex	1.9	require Data::Dumper;
65	root	1.5	local $Data::Dumper::Purity = 1;
66			$::CFG->{VERSION} = $::VERSION;
67			print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
68			}
69
70			close CFG;
71			}
72
73	root	1.75	mkdir "$Crossfire::VARDIR/cfplus", 0777;
74	root	1.34
75	root	1.77	our $DB_ENV;
76
77	root	1.76	{
78			use strict;
79
80	root	1.77	my $recover = $BerkeleyDB::db_version >= 4.4
81			? eval "DB_REGISTER \| DB_RECOVER"
82			: 0;
83
84			$DB_ENV = new BerkeleyDB::Env
85	root	1.76	-Home => "$Crossfire::VARDIR/cfplus",
86			-Cachesize => 1_000_000,
87			-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
88	root	1.39	# -ErrPrefix => "DATABASE",
89	root	1.76	-Verbose => 1,
90	root	1.77	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
91	root	1.78	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
92	root	1.76	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
93			}
94	root	1.34
95			sub db_table($) {
96	root	1.38	my ($table) = @_;
97
98			$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
99	root	1.76
100	root	1.34	new CFClient::Database
101			-Env => $DB_ENV,
102	root	1.38	-Filename => $table,
103			# -Filename => "database",
104			# -Subname => $table,
105	root	1.51	-Property => DB_CHKSUM,
106	root	1.34	-Flags => DB_CREATE \| DB_UPGRADE,
107	root	1.76	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
108	root	1.34	}
109
110	root	1.52	sub pod_to_pango($) {
111			my ($pom) = @_;
112
113			$pom->present ("CFClient::PodToPango")
114			}
115
116	root	1.60	sub pod_to_pango_list($) {
117			my ($pom) = @_;
118
119			[
120			map s/^(\s)// && [40 length $1, length $_ ? $_ : " "],
121			split /\n/, $pom->present ("CFClient::PodToPango")
122			]
123			}
124
125	root	1.52	package CFClient::PodToPango;
126
127			use base Pod::POM::View::Text;
128
129			our $indent = 0;
130
131			*view_seq_code =
132			*view_seq_bold = sub { "<b>$_[1]</b>" };
133			*view_seq_italic = sub { "<i>$_[1]</i>" };
134			*view_seq_space =
135			*view_seq_link =
136			*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
137
138			sub view_seq_text {
139			my $text = $_[1];
140			$text =~ s/\s+/ /g;
141			CFClient::UI::Label::escape ($text)
142			}
143
144			sub view_item {
145			("\t" x ($indent / 4))
146			. $_[1]->title->present ($_[0])
147			. "\n"
148			. $_[1]->content->present ($_[0])
149			}
150
151	root	1.53	sub view_verbatim {
152			(join "",
153	root	1.69	map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
154	root	1.53	split /\n/, CFClient::UI::Label::escape ($_[1]))
155			. "\n"
156			}
157
158	root	1.52	sub view_textblock {
159			("\t" x ($indent / 2)) . "$_[1]\n\n"
160			}
161
162	root	1.60	sub view_head1 {
163	root	1.69	"\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
164	root	1.60	. $_[1]->content->present ($_[0])
165			};
166
167	root	1.52	sub view_head2 {
168	root	1.69	"\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
169			. $_[1]->content->present ($_[0])
170			};
171
172			sub view_head3 {
173			"\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
174	root	1.52	. $_[1]->content->present ($_[0])
175			};
176
177			sub view_over {
178			local $indent = $indent + $_[1]->indent;
179			$_[1]->content->present ($_[0])
180			}
181
182	root	1.34	package CFClient::Database;
183
184			our @ISA = BerkeleyDB::Btree::;
185
186			sub get($$) {
187			my $data;
188
189			$_[0]->db_get ($_[1], $data) == 0
190			? $data
191	root	1.37	: ()
192	root	1.34	}
193
194			my %DB_SYNC;
195
196			sub put($$$) {
197			my ($db, $key, $data) = @_;
198
199	root	1.37	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
200	root	1.34
201	root	1.37	$db->db_put ($key => $data)
202	root	1.34	}
203
204	root	1.62	package CFClient::Item;
205
206	root	1.71	use strict;
207			use Crossfire::Protocol::Constants;
208
209	root	1.62	sub desc_string {
210			my ($self) = @_;
211
212			my $desc =
213			$self->{nrof} < 2
214			? $self->{name}
215			: "$self->{nrof} × $self->{name_pl}";
216
217	root	1.71	$self->{flags} & F_OPEN
218	root	1.62	and $desc .= " (open)";
219	root	1.71	$self->{flags} & F_APPLIED
220	root	1.62	and $desc .= " (applied)";
221	root	1.71	$self->{flags} & F_UNPAID
222	root	1.62	and $desc .= " (unpaid)";
223	root	1.71	$self->{flags} & F_MAGIC
224	root	1.62	and $desc .= " (magic)";
225	root	1.71	$self->{flags} & F_CURSED
226	root	1.62	and $desc .= " (cursed)";
227	root	1.71	$self->{flags} & F_DAMNED
228	root	1.62	and $desc .= " (damned)";
229	root	1.71	$self->{flags} & F_LOCKED
230	root	1.62	and $desc .= " *";
231
232			$desc
233			}
234
235			sub weight_string {
236			my ($self) = @_;
237
238			my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
239
240			$weight < 0 ? "?" : $weight * 0.001
241			}
242
243			sub update_widgets {
244			my ($self) = @_;
245
246	root	1.63	my $button_cb = sub {
247			my (undef, $ev, $x, $y) = @_;
248
249			if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
250			my $targ = $::CONN->{player}{tag};
251
252			if ($self->{container} == $::CONN->{player}{tag}) {
253	elmex	1.64	$targ = $::CONN->{open_container};
254	root	1.63	}
255
256	root	1.79	$::CONN->send ("move $targ $self->{tag} 0")
257			if $targ \|\| !($self->{flags} & F_LOCKED);
258	root	1.63	} elsif ($ev->{button} == 1) {
259			$::CONN->send ("examine $self->{tag}");
260			} elsif ($ev->{button} == 2) {
261			$::CONN->send ("apply $self->{tag}");
262			} elsif ($ev->{button} == 3) {
263			my @menu_items = (
264			["examine", sub { $::CONN->send ("examine $self->{tag}") }],
265			["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
266			["apply", sub { $::CONN->send ("apply $self->{tag}") }],
267			(
268	root	1.71	$self->{flags} & F_LOCKED
269	root	1.63	? (
270			["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
271			)
272			: (
273			["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
274	elmex	1.64	["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
275	root	1.63	)
276			),
277			);
278
279			CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
280			}
281
282			1
283			};
284
285	root	1.62	my $tooltip_std = "<small>"
286			. "Left click - examine item\n"
287			. "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
288			. "Middle click - apply\n"
289			. "Right click - further options"
290			. "</small>\n";
291
292	root	1.63	$self->{face_widget} \|\|= new CFClient::UI::Face
293			can_events => 1,
294			can_hover => 1,
295	root	1.67	anim => $self->{anim},
296	root	1.66	animspeed => $self->{animspeed}, # TODO# must be set at creation time
297	root	1.72	on_button_down => $button_cb,
298	root	1.63	;
299	root	1.62	$self->{face_widget}{face} = $self->{face};
300			$self->{face_widget}{anim} = $self->{anim};
301	root	1.65	$self->{face_widget}{animspeed} = $self->{animspeed};
302	root	1.62	$self->{face_widget}->set_tooltip (
303			"<b>Face/Animation.</b>\n"
304			. "Item uses face #$self->{face}. "
305			. ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
306			. "\n\n$tooltip_std"
307			);
308
309	root	1.63	$self->{desc_widget} \|\|= new CFClient::UI::Label
310			can_events => 1,
311			can_hover => 1,
312			ellipsise => 2,
313	root	1.68	align => -1,
314	root	1.72	on_button_down => $button_cb,
315	root	1.63	;
316			my $desc = CFClient::Item::desc_string $self;
317			$self->{desc_widget}->set_text ($desc);
318			$self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
319
320			$self->{weight_widget} \|\|= new CFClient::UI::Label
321			can_events => 1,
322			can_hover => 1,
323			ellipsise => 0,
324	root	1.68	align => 0,
325	root	1.72	on_button_down => $button_cb,
326	root	1.63	;
327	root	1.62	$self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
328
329			$self->{weight_widget}->set_tooltip (
330			"<b>Weight</b>.\n"
331			. ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
332			. ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
333			. "\n\n$tooltip_std"
334			);
335			}
336
337	elmex	1.73	package CFClient::Recorder;
338
339			our $RECORD_WINDOW;
340
341			my $CMDBOX;
342			my $CURRENT_CMDS;
343			my $REC_BTN;
344
345			my @ALLOWED_MODIFIER_KEYS = (
346			(CFClient::SDLK_LSHIFT) => "LSHIFT",
347			(CFClient::SDLK_LCTRL ) => "LCTRL",
348			(CFClient::SDLK_LALT ) => "LALT",
349			(CFClient::SDLK_LMETA ) => "LMETA",
350
351			(CFClient::SDLK_RSHIFT) => "RSHIFT",
352			(CFClient::SDLK_RCTRL ) => "RCTRL",
353			(CFClient::SDLK_RALT ) => "RALT",
354			(CFClient::SDLK_RMETA ) => "RMETA",
355			);
356
357			my %ALLOWED_MODIFIERS = (
358			(CFClient::KMOD_LSHIFT) => "LSHIFT",
359			(CFClient::KMOD_LCTRL ) => "LCTRL",
360			(CFClient::KMOD_LALT ) => "LALT",
361			(CFClient::KMOD_LMETA ) => "LMETA",
362
363			(CFClient::KMOD_RSHIFT) => "RSHIFT",
364			(CFClient::KMOD_RCTRL ) => "RCTRL",
365			(CFClient::KMOD_RALT ) => "RALT",
366			(CFClient::KMOD_RMETA ) => "RMETA",
367			);
368
369			my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
370			my @DIRECT_BIND_KEYS = (
371			CFClient::SDLK_F1,
372			CFClient::SDLK_F2,
373			CFClient::SDLK_F3,
374			CFClient::SDLK_F4,
375			CFClient::SDLK_F5,
376			CFClient::SDLK_F6,
377			CFClient::SDLK_F7,
378			CFClient::SDLK_F8,
379			CFClient::SDLK_F9,
380			CFClient::SDLK_F10,
381			CFClient::SDLK_F11,
382			CFClient::SDLK_F12,
383			CFClient::SDLK_F13,
384			CFClient::SDLK_F14,
385			CFClient::SDLK_F15,
386			);
387
388			# this binding dialog asks for a key-combo to be pressed
389			# and if successful it binds the modifier+symbol to the
390			# supplied actions in $cmd.
391			# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
392			sub open_binding_dialog {
393			my ($cmd) = @_;
394
395			my $w = new CFClient::UI::FancyFrame
396			title => "Bind Action";
397
398			$w->add (my $vb = new CFClient::UI::VBox);
399			$vb->add (new CFClient::UI::Label
400			text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
401			."You can only bind 0-9 and F1-F15 without modifiers."
402			);
403			$vb->add (my $entry = new CFClient::UI::Entry
404			text => "",
405			on_key_down => sub {
406			my ($entry, $ev) = @_;
407
408			my $mod = $ev->{mod};
409			my $sym = $ev->{sym};
410
411			# XXX: This seems a little bit hackisch to me, but i have to ignore them
412			if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
413			return;
414			}
415
416			if ($mod == CFClient::KMOD_NONE
417			and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
418			and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
419			{
420			$::STATUSBOX->add (
421			"Can't bind key ".CFClient::SDL_GetKeyName ($sym)
422			." directly without modifier! It would damage the completer handling."
423			);
424			return;
425			}
426
427			$entry->focus_out;
428
429			$::CFG->{bindings}->{$mod}->{$sym} = $cmd;
430	elmex	1.74	$::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
431	elmex	1.73
432			$w->destroy
433			});
434
435			$entry->focus_in;
436			$w->center;
437			$w->show;
438			}
439
440			sub keycombo_to_name {
441			my ($mod, $sym) = @_;
442
443			my $mods = join '+',
444			map { $ALLOWED_MODIFIERS{$_} }
445			grep { $_ & $mod }
446			keys %ALLOWED_MODIFIERS;
447			$mods .= "+" if $mods ne '';
448
449			return $mods . CFClient::SDL_GetKeyName ($sym);
450			}
451
452			sub clear_command_list {
453			$CMDBOX->clear () if $CMDBOX;
454			}
455
456			sub set_command_list {
457			my ($list) = @_;
458
459			return unless $CMDBOX;
460
461			$CMDBOX->clear ();
462			$CURRENT_CMDS = $list;
463
464			my $idx = 0;
465
466			for (@$list) {
467			$CMDBOX->add (my $hb = new CFClient::UI::HBox);
468
469			my $i = $idx;
470			$hb->add (new CFClient::UI::Button
471	elmex	1.74	text => "delete",
472	elmex	1.73	tooltip => "Deletes the action from the record",
473			on_activate => sub {
474			$CMDBOX->remove ($hb);
475			$list->[$i] = undef;
476			});
477
478			$hb->add (new CFClient::UI::Label text => $_);
479
480			$idx++
481			}
482			}
483
484			# if $show is 1 the recorder will be shown
485			sub start {
486			my ($show) = @_;
487
488			$RECORD_WINDOW->show if $show;
489
490			$REC_BTN->set_text ("stop recording");
491			$REC_BTN->{recording} = 1;
492			clear_command_list;
493			$::CONN->start_record;
494			}
495
496			# if $autobind is 1 the recorder will be automatically
497			# jump into the binding query and hide the recorder window
498			sub stop {
499			my ($autobind) = @_;
500
501			$REC_BTN->set_text ("start recording");
502			$REC_BTN->{recording} = 0;
503
504			my $rec = $::CONN->stop_record;
505			return unless ref $rec eq 'ARRAY';
506			set_command_list ($rec);
507
508			if ($autobind) {
509			open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
510			$RECORD_WINDOW->hide;
511			}
512			}
513
514			sub make_window {
515			$RECORD_WINDOW = new CFClient::UI::FancyFrame
516			req_y => 1,
517			req_x => -1,
518			title => "Action Recorder";
519
520			$RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
521			$vb->add ($REC_BTN = new CFClient::UI::Button
522			text => "start recording",
523			tooltip => "Start/Stops recording of actions."
524	elmex	1.74	."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
525	elmex	1.73	."All subsequent actions after the recording started will be captured."
526			."The actions are displayed after the record was stopped."
527			."To bind the action you have to click on the 'Bind' button",
528			on_activate => sub {
529			my ($btn) = @_;
530
531			unless ($btn->{recording}) {
532			start;
533			} else {
534			stop;
535			}
536			});
537			$vb->add ($CMDBOX = new CFClient::UI::VBox);
538			$vb->add (new CFClient::UI::Button
539			text => "bind",
540			tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
541			on_activate => sub {
542			open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
543			});
544
545			$RECORD_WINDOW
546			}
547
548	root	1.1	1;
549
550			=back
551
552			=head1 AUTHOR
553
554			Marc Lehmann <schmorp@schmorp.de>
555			http://home.schmorp.de/
556
557			=cut
558