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",
      x => "center",
      y => "center";

   $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->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.80
Committed:	Tue May 30 08:12:50 2006 UTC (17 years, 11 months ago) by elmex
Branch:	MAIN
Changes since 1.79:	+3 -2 lines
Log Message:	fixed a bug with the binding dialog (center) and added todo item for me
#	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	elmex	1.80	title => "Bind Action",
397			x => "center",
398			y => "center";
399	elmex	1.73
400			$w->add (my $vb = new CFClient::UI::VBox);
401			$vb->add (new CFClient::UI::Label
402			text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
403			."You can only bind 0-9 and F1-F15 without modifiers."
404			);
405			$vb->add (my $entry = new CFClient::UI::Entry
406			text => "",
407			on_key_down => sub {
408			my ($entry, $ev) = @_;
409
410			my $mod = $ev->{mod};
411			my $sym = $ev->{sym};
412
413			# XXX: This seems a little bit hackisch to me, but i have to ignore them
414			if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
415			return;
416			}
417
418			if ($mod == CFClient::KMOD_NONE
419			and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
420			and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
421			{
422			$::STATUSBOX->add (
423			"Can't bind key ".CFClient::SDL_GetKeyName ($sym)
424			." directly without modifier! It would damage the completer handling."
425			);
426			return;
427			}
428
429			$entry->focus_out;
430
431			$::CFG->{bindings}->{$mod}->{$sym} = $cmd;
432	elmex	1.74	$::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
433	elmex	1.73
434			$w->destroy
435			});
436
437			$entry->focus_in;
438			$w->show;
439			}
440
441			sub keycombo_to_name {
442			my ($mod, $sym) = @_;
443
444			my $mods = join '+',
445			map { $ALLOWED_MODIFIERS{$_} }
446			grep { $_ & $mod }
447			keys %ALLOWED_MODIFIERS;
448			$mods .= "+" if $mods ne '';
449
450			return $mods . CFClient::SDL_GetKeyName ($sym);
451			}
452
453			sub clear_command_list {
454			$CMDBOX->clear () if $CMDBOX;
455			}
456
457			sub set_command_list {
458			my ($list) = @_;
459
460			return unless $CMDBOX;
461
462			$CMDBOX->clear ();
463			$CURRENT_CMDS = $list;
464
465			my $idx = 0;
466
467			for (@$list) {
468			$CMDBOX->add (my $hb = new CFClient::UI::HBox);
469
470			my $i = $idx;
471			$hb->add (new CFClient::UI::Button
472	elmex	1.74	text => "delete",
473	elmex	1.73	tooltip => "Deletes the action from the record",
474			on_activate => sub {
475			$CMDBOX->remove ($hb);
476			$list->[$i] = undef;
477			});
478
479			$hb->add (new CFClient::UI::Label text => $_);
480
481			$idx++
482			}
483			}
484
485			# if $show is 1 the recorder will be shown
486			sub start {
487			my ($show) = @_;
488
489			$RECORD_WINDOW->show if $show;
490
491			$REC_BTN->set_text ("stop recording");
492			$REC_BTN->{recording} = 1;
493			clear_command_list;
494			$::CONN->start_record;
495			}
496
497			# if $autobind is 1 the recorder will be automatically
498			# jump into the binding query and hide the recorder window
499			sub stop {
500			my ($autobind) = @_;
501
502			$REC_BTN->set_text ("start recording");
503			$REC_BTN->{recording} = 0;
504
505			my $rec = $::CONN->stop_record;
506			return unless ref $rec eq 'ARRAY';
507			set_command_list ($rec);
508
509			if ($autobind) {
510			open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
511			$RECORD_WINDOW->hide;
512			}
513			}
514
515			sub make_window {
516			$RECORD_WINDOW = new CFClient::UI::FancyFrame
517			req_y => 1,
518			req_x => -1,
519			title => "Action Recorder";
520
521			$RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
522			$vb->add ($REC_BTN = new CFClient::UI::Button
523			text => "start recording",
524			tooltip => "Start/Stops recording of actions."
525	elmex	1.74	."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
526	elmex	1.73	."All subsequent actions after the recording started will be captured."
527			."The actions are displayed after the record was stopped."
528			."To bind the action you have to click on the 'Bind' button",
529			on_activate => sub {
530			my ($btn) = @_;
531
532			unless ($btn->{recording}) {
533			start;
534			} else {
535			stop;
536			}
537			});
538			$vb->add ($CMDBOX = new CFClient::UI::VBox);
539			$vb->add (new CFClient::UI::Button
540			text => "bind",
541			tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
542			on_activate => sub {
543			open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
544			});
545
546			$RECORD_WINDOW
547			}
548
549	root	1.1	1;
550
551			=back
552
553			=head1 AUTHOR
554
555			Marc Lehmann <schmorp@schmorp.de>
556			http://home.schmorp.de/
557
558			=cut
559