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/pclient", 0777;

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