开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 游戏 > 外挂编程 > 查看源码
Tk.pm.svn-base
资源名称：openkore-2.0.7.zip　[点击查看]
上传用户：market2
上传日期：2018-11-18
资源大小：18786k
文件大小：25k
源码类别：

外挂编程

开发平台：

Windows_Unix

Tk.pm.svn-base：源码内容
  1. #########################################################################
  2. #  OpenKore - Tk Interface
  3. #
  4. #  Copyright (c) 2004 OpenKore development team 
  5. #
  6. #  This program is free software; you can redistribute it and/or modify
  7. #  it under the terms of the GNU General Public License as published by
  8. #  the Free Software Foundation; either version 2 of the License, or
  9. #  (at your option) any later version.
  10. #
  11. #  This program is distributed in the hope that it will be useful,
  12. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. #  GNU General Public License for more details.
  15. #
  16. #
  17. #  $Revision$
  18. #  $Id$
  19. #
  20. #########################################################################
  22. package Interface::Tk;
  23. use strict;
  24. use warnings;
  26. use Interface;
  27. use base qw/Interface/;
  28. use Plugins;
  29. use Globals;
  30. use Field;
  31. use Settings;
  32. use Misc;
  34. use Carp qw/carp croak confess/;
  35. use Time::HiRes qw/time usleep/;
  36. use Tk;
  37. use Tk::ROText;
  38. use Tk::BrowseEntry;
  39. use Tk::NoteBook;
  42. #these should go in a config file at some point.
  43. our $line_limit = 1000;
  45. ################################################################
  46. # Public Method
  47. ################################################################
  50. sub new {
  51. my $class = shift;
  52. my $self = {
  53. mw => undef,
  54. input_list => [],
  55. input_offset => 0,
  56. input_que => [],
  57. default_font=>"MS Sans Serif",
  58. input_type => "Command",
  59. input_pm => undef,
  60. total_lines => 0,
  61. last_line_end => 0,
  62. colors => {},
  63. };
  65. if ($buildType == 0) {
  66. eval "use Win32::API;";
  67. $self->{ShellExecute} = new Win32::API("shell32", "ShellExecute",
  68. "NPPPPN", "V");
  69. }
  71. bless $self, $class;
  72. $self->initTk;
  74. Plugins::addHook('mainLoop_pre', &updateHook, $self);
  75. Plugins::addHook('postloadfiles', &resetColors, $self);
  76. return $self;
  77. }
  79. sub getInput{
  80. my $self = shift;
  81. my $timeout = shift;
  82. my $msg;
  83. if ($timeout < 0) {
  84. until (defined $msg) {
  85. $self->update();
  86. if (@{ $self->{input_que} }) { 
  87. $msg = shift @{ $self->{input_que} }; 
  88. } 
  89. }
  90. } elsif ($timeout > 0) {
  91. my $end = time + $timeout;
  92. until ($end < time || defined $msg) {
  93. $self->update();
  94. if (@{ $self->{input_que} }) { 
  95. $msg = shift @{ $self->{input_que} }; 
  96. } 
  97. }
  98. } else {
  99. if (@{ $self->{input_que} }) { 
  100. $msg = shift @{ $self->{input_que} }; 
  101. } 
  102. }
  103. $self->update();
  104. $msg =~ s/n// if defined $msg;
  105. return $msg;
  106. }
  109. sub writeOutput {
  110. my $self = shift;
  111. my $type = shift || '';
  112. my $message = shift || '';
  113. my $domain = shift || '';
  115. my $scroll = 0;
  116. $scroll = 1 if (($self->{console}->yview)[1] == 1);
  118. #keep track of lines to limit the number of lines in the text widget
  119. $self->{total_lines} += $message =~ s/r?n/n/g;
  121. $self->{console}->insert('end', "n") if $self->{last_line_end};
  122. $self->{last_line_end} = $message =~ s/n$//;
  124. $self->{console}->insert('end', $message, "$type $type.$domain");
  126. #remove extra lines
  127. if ($self->{total_lines} > $line_limit) {
  128. my $overage = $self->{total_lines} - $line_limit;
  129. $self->{console}->delete('1.0', $overage+1 . ".0");
  130. $self->{total_lines} -= $overage;
  131. }
  133. $self->{console}->see('end') if $scroll;
  134. }
  136. sub updateHook {
  137. my $hookname = shift;
  138. my $r_args = shift;
  139. my $self = shift;
  140. return unless defined $self->{mw};
  141. $self->updatePos();
  142. $self->{mw}->update();
  143. $self->setAiText("@ai_seq");
  144. }
  146. sub update {
  147. my $self = shift;
  148. $self->{mw}->update();
  150. if ($buildType == 0 && $self->{SettingsObj}) {
  151. if ($self->{SettingsObj}->Wait(0)) {
  152. my $code;
  153. $self->{SettingsObj}->GetExitCode($code);
  154. Settings::parseReload("all") if $code == 0;
  155. delete $self->{SettingsObj};
  156. }
  157. }
  158. }
  160. sub title {
  161. my $self = shift;
  162. my $title = shift;
  164. if (defined $title) {
  165. if (!defined $self->{currentTitle} || $self->{currentTitle} ne $title) {
  166. $self->{mw}->title($title);
  167. $self->{currentTitle} = $title;
  168. }
  169. } else {
  170. return $self->{mw}->title();
  171. }
  172. }
  174. sub updatePos {
  175. my $self = shift;
  176. return unless defined($config{'char'}) && defined($chars[$config{'char'}]) && defined($char->{'pos_to'});
  177. my ($x,$y) = @{$char->{'pos_to'}}{'x', 'y'};
  178. $self->{status_posx}->configure( -text =>$x);
  179. $self->{status_posy}->configure( -text =>$y);
  180. if ($self->mapIsShown()) {
  181. if ($self->{map}{field} ne $field->name()) {
  182. $self->loadMap();
  183. }
  184. $self->{map}{canvas}->coords($self->{map}{ind}{player},
  185. $x - 2, $self->{map}{height} - $y - 2,
  186. $x + 2, $self->{map}{height} - $y + 2,
  187. );
  188. my $dis = $config{'attackDistance'};
  189. $self->{map}{canvas}->coords($self->{map}{ind}{range},
  190. $x - $dis, $self->{map}{height} - $y - $dis,
  191. $x + $dis, $self->{map}{height} - $y + $dis,
  192. );
  193. }
  194. }
  196. sub updateStatus {
  197. my $self = shift;
  198. my $text = shift;
  199. $self->{status_gen}->configure(-text => $text);
  200. }
  202. sub setTitle {
  203. my $self = shift;
  204. my $text = shift;
  205. $self->{mw}->title($text);
  206. }
  208. sub setAiText {
  209. my $self = shift;
  210. my ($text) = shift;
  211. $self->{status_ai}->configure(-text => $text);
  212. }
  214. sub addPM {
  215. my $self = shift;
  216. my $input_name = shift;
  217. my $found=1;
  218. my @pm_list = $self->{pminput}->cget('-choices');
  219. foreach (@pm_list){
  220. if ($_ eq $input_name) {
  221. $found = 0;
  222. last;
  223. }
  224. }
  225. if ($found) {
  226. $self->{pminput}->insert("end",$input_name);
  227. }
  228. }
  230. ################################################################
  231. # Private? Method
  232. ################################################################
  233. #FIXME many of thise methods don't support OO calls yet, update them and all their references
  234. sub initTk {
  235. my $self = shift;
  237. $self->{mw} = MainWindow->new();
  238. $self->{mw}->protocol('WM_DELETE_WINDOW', [&OnExit, $self]);
  239. #$self->{mw}->Icon(-image=>$self->{mw}->Photo(-file=>"hyb.gif"));
  240. $self->{mw}->title("$Settings::NAME");
  241. $self->{mw}->minsize(620,400);
  242. $self->{menuFont} = $self->{mw}->fontCreate(-family => $self->{default_font}, -size => 8, -weight => "bold");
  244. #------ Frame Control
  245. $self->{main_frame} = $self->{mw}->Frame()->pack(-side => 'top',-expand => 1,-fill => 'both',);
  246. $self->{btn_frame} = $self->{main_frame}->Frame()->pack(-side => 'right',-expand => 0,-fill => 'y',);
  247. $self->{console_frame} = $self->{main_frame}->Frame(-bg=>'black')->pack(-side => 'left',-expand => 1,-fill => 'both',);
  248. $self->{input_frame} = $self->{mw}->Frame(-bg=>'black')->pack(-side => 'top',-expand => 0,-fill => 'x',);
  249. $self->{status_frame} = $self->{mw}->Frame()->pack(-side => 'top',-expand => 0,-fill => 'x',);
  251. #------ subclass in console frame
  252. $self->{tabPane} = $self->{console_frame}->NoteBook(-relief=>'flat',-border=>1,-tabpadx=>1,-tabpady=>1,-font=>${$self->{menuFont}},-bg=>'#CDCDCD',-foreground=>'grey',-inactivebackground=>"#999999")->pack(-expand => 1,-fill => 'both',-side => 'top',);
  253. $self->{consoleTab} = $self->{tabPane}->add("Console",-label=>'Console');
  254. #$self->{chatTab} = $self->{tabPane}->add("Chat",-label=>'Chat');
  255. $self->{console} = $self->{consoleTab}->Scrolled('ROText',-bg=>'black',-fg=>'grey',
  256. -scrollbars => 'e',
  257. -height => 15,
  258. -wrap => 'word',
  259. -width => 55,
  260. -insertontime => 0,
  261. -background => 'black',
  262. -foreground => 'grey',
  263. -font=>[ -family => 'Courier' ,-size=>10,],
  264. -relief => 'sunken',
  265. )->pack(
  266. -expand => 1,
  267. -fill => 'both',
  268. -side => 'top',
  269. );
  271. if (0) {
  272. $self->{chatLog} = $self->{chatTab}->Scrolled('ROText',-bg=>'black',-fg=>'grey',
  273. -scrollbars => 'e',
  274. -height => 15,
  275. -wrap => 'word',
  276. -width => 55,
  277. -insertontime => 0,
  278. -background => 'black',
  279. -foreground => 'grey',
  280. -font=>[ -family => $self->{default_font} ,-size=>10,],
  281. -relief => 'sunken',
  282. )->pack(
  283. -expand => 1,
  284. -fill => 'both',
  285. -side => 'top',
  286. );
  287. }
  289. my $addButton = sub {
  290. my $label = shift;
  291. my $command = shift;
  292. return $self->{btn_frame}->Button(-text => $label, -command => $command , -takefocus => 0, -font => $self->{menuFont}, -activeforeground => "white", -activebackground => "#004E98", -relief => "flat", -anchor => "w")->pack(-fill => "x", -side => "top");
  293. };
  295. $self->{mapBtn} = $addButton->(':: Map', [&mapToggle, $self]);
  296. $self->{helpBtn} = $addButton->(':: Help', [&showManual, $self]) if ($self->{ShellExecute});
  297. $self->{exitBtn} = $addButton->(':: Exit', [&OnExit, $self]);
  299. #$self->{statusBtn} = $self->{btn_frame}->Button(-text => ":: Status", -command =>[sub{push(@{$self->{input_list}}, "s");},$self] , -takefocus => 0, -font => $self->{menuFont}, -activeforeground => "white", -activebackground => "#004E98", -relief => "flat", -anchor => "w")->pack(-fill => "x", -side => "top");
  300. #$self->{skillsBtn} = $self->{btn_frame}->Button(-text => ":: Skills", -command => sub{push(@{$self->{input_list}}, "skills");} , -takefocus => 0, -font => $self->{menuFont}, -activeforeground => "white", -activebackground => "#004E98", -relief => "flat", -anchor => "w")->pack(-fill => "x", -side => "top");
  301. #$self->{inventBtn} = $self->{btn_frame}->Button(-text => ":: Inventory", -command =>sub{push(@{$self->{input_list}}, "i");} , -takefocus => 0, -font => $self->{menuFont}, -activeforeground => "white", -activebackground => "#004E98", -relief => "flat", -anchor => "w")->pack(-fill => "x", -side => "top");
  302. #$self->{pplBtn} = $self->{btn_frame}->Button(-text => ":: Players", -command => sub{push(@{$self->{input_list}}, "pl");} , -takefocus => 0, -font => $self->{menuFont}, -activeforeground => "white", -activebackground => "#004E98", -relief => "flat", -anchor => "w")->pack(-fill => "x", -side => "top");
  303. #$self->{monBtn} = $self->{btn_frame}->Button(-text => ":: Monsters", -command =>sub{push(@{$self->{input_list}}, "ml");} , -takefocus => 0, -font => $self->{menuFont}, -activeforeground => "white", -activebackground => "#004E98", -relief => "flat", -anchor => "w")->pack(-fill => "x", -side => "top");
  305. #------ subclass in input frame
  306. $self->{pminput} = $self->{input_frame}->BrowseEntry(
  307. -bg => 'white',
  308. -insertbackground => 'white',
  309. -variable => $self->{input_pm},
  310. -width => 8,
  311. -choices => $self->{pm_list},
  312. -state =>'normal',
  313. -relief => 'sunken',
  314. ); # ->pack(
  315. # -expand=>0,
  316. # -fill => 'x',
  317. # -side => 'left',
  318. #);
  320. $self->{input} = $self->{input_frame}->Entry(
  321. -bg => 'white',
  322. -insertbackground => 'white',
  323. -relief => 'sunken',
  324. -font=>[ -family => $self->{default_font} ,-size=>8,],
  325. )->pack(
  326. -expand=>1,
  327. -fill => 'x',
  328. -side => 'left',
  329. );
  331. $self->{sinput} = $self->{input_frame}->BrowseEntry(
  332. -bg=>'black',
  333. -fg=>'grey',
  334. -variable => $self->{input_type},
  335. -choices => [qw(Command Public Party Guild)],
  336. -width => 8,
  337. -state =>'readonly',
  338. -relief => 'sunken',
  339. );#->pack (
  340. # -expand=>0,
  341. # -fill => 'x',
  342. # -side => 'left',
  343. #);
  345. #------ subclass in status frame
  346. $self->{status_gen} = $self->{status_frame}->Label(
  347. -anchor => 'w',
  348. -text => 'Ready',
  349. -font => ['Arial', 8],
  350. -bd=>0,
  351. -relief => 'sunken',
  352. )->pack(
  353. -side => 'left',
  354. -expand => 1,
  355. -fill => 'x',
  356. );
  358. $self->{status_ai} = $self->{status_frame}->Label(
  359. -text => 'Ai - Status',
  360. -font => ['Arial', 8],
  361. -width => 25,
  362. -relief => 'ridge',
  363. )->pack(
  364. -side => 'left',
  365. -expand => 0,
  366. -fill => 'x',
  367. );
  369. $self->{status_posx} = $self->{status_frame}->Label(
  370. -text => '0',
  371. -font => ['Arial', 8],
  372. -width => 4,
  373. -relief => 'ridge',
  374. )->pack(
  375. -side => 'left',
  376. -expand => 0,
  377. -fill => 'x',
  378. );
  380. $self->{status_posy} = $self->{status_frame}->Label(
  381. -text => '0',
  382. -font => ['Arial', 8],
  383. -width => 4,
  384. -relief => 'ridge',
  385. )->pack(
  386. -side => 'left',
  387. -expand => 0,
  388. -fill => 'x',
  389. );
  391. if (0) {
  392. $self->{mw}->configure(-menu => $self->{mw}->Menu(-menuitems=>
  393. [ map 
  394. ['cascade', $_->[0], -tearoff=> 0, -font=>[-family=>"Tahoma",-size=>8], -menuitems => $_->[1]],
  395. # ['~modKore',
  396. # [[qw/command E~xit  -accelerator Ctrl+X/, -font=>[-family=>"Tahoma",-size=>8], -command=>[&OnExit]],]
  397. # ],
  398. ['~View',
  399. [
  400. # [qw/command Map  -accelerator Ctrl+M/, -font=>[-family=>"Tahoma",-size=>8], -command=>[&OpenMap, $class]],
  401. [qw/command Map  -accelerator Ctrl+M/, -font=>[-family=>"Tahoma",-size=>8], -command=>[&mapToggle, undef, $self]],
  402. # '',
  403. # [qw/command Status -accelerator Alt+D/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "s");}],
  404. # [qw/command Skill -accelerator Alt+S/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "skills");}],
  405. # [qw/command Equipment -accelerator Alt+Q/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "i eq");}],
  406. # [qw/command Stat -accelerator Alt+A/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "st");}],
  407. # [qw/command Usable -accelerator Alt+E/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "i u");}],
  408. # [qw/command Non-Usable -accelerator Alt+W/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "i nu");}],
  409. # [qw/command Exp -accelerator Alt+Z/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "exp");}],
  410. # [qw/command Cart -accelerator Alt+C/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "cart");}],
  411. # '',
  412. # [cascade=>"Guild", -tearoff=> 0, -font=>[-family=>"Tahoma",-size=>8], -menuitems =>
  413. # [
  414. # [qw/command Info -accelerator ALT+F/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "guild i");}],
  415. # [qw/command Member -accelerator ALT+G/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "guild m");}],
  416. # [qw/command Position -accelerator ALT+H/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "guild p");}],
  417. #  ],
  418. # ],
  419. # '',
  420. # [cascade=>"Font Weight", -tearoff=> 0, -font=>[-family=>"Tahoma",-size=>8], -menuitems => 
  421. # [
  422. # [Checkbutton  => '~Bold', -variable => $is_bold,-font=>[-family=>"Tahoma",-size=>8],-command => [&change_fontWeight]],
  423. # ]
  424. # ],
  425. ],
  426. ],
  427. # ['~Reload',
  428. # [
  429. # [qw/command config -accelerator Ctrl+C/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload conf");}],
  430. # [qw/command mon_control  -accelerator Ctrl+W/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload mon_");}],
  431. # [qw/command item_control  -accelerator Ctrl+Q/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload items_");}],
  432. # [qw/command cart_control  -accelerator Ctrl+E/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload cart_");}],
  433. # [qw/command ppl_control  -accelerator Ctrl+D/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload ppl_");}],
  434. # [qw/command timeouts  -accelerator Ctrl+Z/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload timeouts");}],
  435. # [qw/command pickupitems  -accelerator Ctrl+V/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload pick");}],
  436. # [qw/command chatAuto  -accelerator Ctrl+A/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload chatAuto");}],
  437. # '',
  438. # [qw/command All  -accelerator Ctrl+S/, -font=>[-family=>"Tahoma",-size=>8], -command=>sub{push(@input_que, "reload all");}],
  439. # ]
  440. # ],
  441. ]
  442. ));
  444. #Binding
  445. #FIXME Do I want to quit on cut? ... NO!
  446. #$self->{mw}->bind('all','<Control-x>'=>[&OnExit]);
  447. $self->{mw}->bind('all','<Control-m>'=>[&mapToggle, $self]);
  448. #FIXME hey that's copy....
  449. #$self->{mw}->bind('all','<Control-c>'=>sub{push(@input_que, "reload conf");});
  450. #$self->{mw}->bind('all','<Control-w>'=>sub{push(@input_que, "reload mon_");});
  451. #$self->{mw}->bind('all','<Control-q>'=>sub{push(@input_que, "reload items_");});
  452. #$self->{mw}->bind('all','<Control-e>'=>sub{push(@input_que, "reload cart_");});
  453. #$self->{mw}->bind('all','<Control-d>'=>sub{push(@input_que, "reload ppl_");});
  454. #$self->{mw}->bind('all','<Control-z>'=>sub{push(@input_que, "reload timeouts");});
  455. #FIXME hey that's paste....
  456. #$self->{mw}->bind('all','<Control-v>'=>sub{push(@input_que, "reload pick");});
  457. #$self->{mw}->bind('all','<Control-a>'=>sub{push(@input_que, "reload chatAuto");});
  458. #$self->{mw}->bind('all','<Control-s>'=>sub{push(@input_que, "reload all");});
  459. #$self->{mw}->bind('all','<Alt-d>'=>sub{push(@input_que, "s");});
  460. #$self->{mw}->bind('all','<Alt-s>'=>sub{push(@input_que, "skills");});
  461. #$self->{mw}->bind('all','<Alt-q>'=>sub{push(@input_que, "i eq");});
  462. #$self->{mw}->bind('all','<Alt-a>'=>sub{push(@input_que, "st");});
  463. #$self->{mw}->bind('all','<Alt-e>'=>sub{push(@input_que, "i u");});
  464. #$self->{mw}->bind('all','<Alt-w>'=>sub{push(@input_que, "i nu");});
  465. #$self->{mw}->bind('all','<Alt-z>'=>sub{push(@input_que, "exp");});
  466. #cookiemaster cart shortcut
  467. #$self->{mw}->bind('all','<Alt-c>'=>sub{push(@input_que, "cart");});
  468. #digitalpheer guild shortcut 
  469. #$self->{mw}->bind('all','<Alt-f>'=>sub{push(@input_que, "guild i");});
  470. #$self->{mw}->bind('all','<Alt-g>'=>sub{push(@input_que, "guild m");});
  471. #$self->{mw}->bind('all','<Alt-h>'=>sub{push(@input_que, "guild p");});
  472. }
  473. $self->{input}->bind('<Up>' => [&inputUp, $self]);
  474. $self->{input}->bind('<Down>' => [&inputDown, $self]);
  475. $self->{input}->bind('<Return>' => [&inputEnter, $self]);
  476. $self->{input}->focus();
  479. if ($buildType == 0) {
  480. $self->{input}->bind('<MouseWheel>' => [&w32mWheel, $self, Ev('k')]);
  481. $self->{console}->bind('<MouseWheel>' => [&w32mWheel, $self, Ev('k')]);
  483. my $console;
  484. eval 'use Win32::Console; $console = new Win32::Console(STD_OUTPUT_HANDLE);';
  485. $console->Free();
  486. } else {
  487. #I forgot the X code. will insert later
  488. }
  490. $self->{mw}->raise();
  491. }
  493. sub errorDialog {
  494. my $self = shift;
  495. my $msg = shift;
  496. $self->{mw}->messageBox(
  497. -icon => 'error',
  498. -message => $msg,
  499. -title => 'Error',
  500. -type => 'Ok'
  501. );
  502. }
  504. sub inputUp {
  505. my $inputarea = shift; #this is redundant =
  506. my $self = shift;
  508. my $line;
  510. chomp($line = $self->{input}->get);
  511. unless ($self->{input_offset}) {
  512. $self->{input_list}[$self->{input_offset}] = $line;
  513. }
  514. $self->{input_offset}++;
  515. $self->{input_offset} -= $#{$self->{input_list}} + 1 while $self->{input_offset} > $#{$self->{input_list}};
  517. $self->{input}->delete('0', 'end');
  518. $self->{input}->insert('end', "$self->{input_list}[$self->{input_offset}]");
  519. }
  521. sub inputDown {
  522. my $inputarea = shift; #this is redundant =
  523. my $self = shift;
  525. my $line;
  527. chomp($line = $self->{input}->get);
  528. unless ($self->{input_offset}) {
  529. $self->{input_list}[$self->{input_offset}] = $line;
  530. }
  531. $self->{input_offset}--;
  532. $self->{input_offset} += $#{$self->{input_list}} + 1 while $self->{input_offset} < 0;
  534. $self->{input}->delete('0', 'end');
  535. $self->{input}->insert('end', "$self->{input_list}[$self->{input_offset}]");
  536. }
  538. sub inputEnter {
  539. my $inputarea = shift; #this is redundant =
  540. my $self = shift;
  542. my $line;
  544. $line = $self->{input}->get;
  545. $self->{input}->delete('0', 'end');
  546. return unless defined $line;
  548. $self->{input_list}[0] = $line;
  549. unshift(@{$self->{input_list}}, "");
  550. $self->{input_offset} = 0;
  551. push(@{ $self->{input_que} }, $line);
  552. }
  554. sub inputPaste {
  555. my $inputarea = shift; #this is redundant =
  556. my $self = shift;
  558. my $line;
  560. $line = $self->{input}->get;
  561. # print "'$line'n";
  563. $self->{input}->delete('0', 'end');
  565. my @lines = split(/n/, $line);
  566. $line = pop(@lines);
  567. push(@{ $self->{input_que} }, @lines);
  568. $self->{input}->insert('end', $line) if $line;
  569. }
  571. sub w32mWheel {
  572. my $action_area = shift;
  573. my $self = shift;
  574. my $zDist = shift;
  576. $self->{console}->yview('scroll', -int($zDist/40), "units");
  577. }
  579. sub OnExit{
  580. my $self = shift;
  581. if ($conState) {
  582. push(@{ $self->{input_que} }, "n");
  583. quit();
  584. } else {
  585. exit();
  586. }
  587. }
  589. sub showManual {
  590. my $self = shift;
  591. $self->{ShellExecute}->Call(0, '', 'http://openkore.sourceforge.net/manual/', '', '', 1);
  592. }
  594. sub resetColors {
  595. my $hookname = shift;
  596. my $r_args = shift;
  597. my $self = shift;
  598. return if $hookname ne 'postloadfiles';
  599. my $colors_loaded = 0;
  600. foreach my $filehash (@{ $r_args->{files} }) {
  601. if ($filehash->{file} =~ /consolecolors.txt$/) {
  602. $colors_loaded = 1;
  603. last;
  604. }
  605. }
  606. return unless $colors_loaded;
  607. my %gdefault = (-foreground => 'grey', -background => 'black');
  608. eval {
  609. $self->{console}->configure(%gdefault);
  610. $self->{input}->configure(%gdefault);
  611. $self->{pminput}->configure(%gdefault);
  612. $self->{sinput}->configure(%gdefault);
  613. };
  614. if ($@) {
  615. if ($@ =~ /unknown color name "(.*)" at/) {
  616. Log::message("Color '$1' not recognised.n");
  617. return undef if !$consoleColors{''}{'useColors'}; #don't bother throwing a lot of errors in the next section.
  618. } else {
  619. die $@;
  620. }
  621. }
  622. foreach my $type (keys %consoleColors) {
  623. next if $type eq '';
  624. my %tdefault =%gdefault;
  625. if ($consoleColors{''}{'useColors'} && $consoleColors{$type}{'default'}) {
  626. $consoleColors{$type}{'default'} =~ m|([^/]*)(?:/(.*))?|;
  627. $tdefault{-foreground} = defined($1) && $1 ne 'default' ? $1 : $gdefault{-foreground};
  628. $tdefault{-background} = defined($2) && $2 ne 'default' ? $2 : $gdefault{-background};
  629. }
  630. eval {
  631. $self->{console}->tagConfigure($type, %tdefault);
  632. };
  633. if ($@) {
  634. if ($@ =~ /unknown color name "(.*)" at/) {
  635. Log::message("Color '$1' not recognised in consolecolors.txt at [$type]: default.n");
  636. } else {
  637. die $@;
  638. }
  639. }
  640. foreach my $domain (keys %{ $consoleColors{$type} }) {
  641. my %color = %tdefault;
  642. if ($consoleColors{''}{'useColors'} && $consoleColors{$type}{$domain}) {
  643. $consoleColors{$type}{$domain} =~ m|([^/]*)(?:/(.*))?|;
  644. $color{-foreground} = defined($1) && $1 ne 'default' ? $1 : $tdefault{-foreground};
  645. $color{-background} = defined($2) && $2 ne 'default' ? $2 : $tdefault{-background};
  646. }
  647. eval {
  648. $self->{console}->tagConfigure("$type.$domain", %color);
  649. };
  650. if ($@) {
  651. if ($@ =~ /unknown color name "(.*)" at/) {
  652. Log::message("Color '$1' not recognised in consolecolors.txt at [$type]: $domain.n");
  653. } else {
  654. die $@;
  655. }
  656. }
  657. }
  658. }
  659. }
  661. sub mapToggle {
  662. my ($self);
  664. if (@_ == 1) {
  665. $self = $_[0];
  666. } elsif (@_ == 2) {
  667. $self = $_[1];
  668. } else {
  669. die "wrong number of args to mapTogglen";
  670. }
  671. if (!defined($self->{map}) && $chars[$config{'char'}] && $field) {
  672. $self->{map}{window} = $self->{mw}->Toplevel();
  673. $self->{map}{window}->protocol('WM_DELETE_WINDOW', 
  674. sub {
  675. $self->mapToggle();
  676. }
  677. );
  678. $self->{map}{window}->resizable(0,0);
  679. $self->{map}{canvas} = $self->{map}{window}->Canvas(
  680. -width => 200,
  681. -height => 200,
  682. -background => 'white',
  683. )->pack(
  684. -side => 'top'
  685. );
  686. $self->loadMap();
  689. my $dis = $config{'attackDistance'};
  690. $self->{map}{ind}{range} = $self->{map}{canvas}->createOval(
  691. -$dis, $self->{map}{height} - $dis,
  692.  $dis, $self->{map}{height} + $dis,
  693. -outline => '#0000ff',
  694. );
  695. $self->{map}{ind}{player} = $self->{map}{canvas}->createOval(
  696. -2, $self->{map}{height} - 2,
  697.  2, $self->{map}{height} + 2,
  698. -fill => '#ffcccc',
  699. -outline => '#ff0000',
  700. );
  702. # if ($main::sys{'enableMoveClick'}) {
  703. # $map_mw->bind('<Double-1>', [&dblchk , Ev('x') , Ev('y')]);
  704. # }
  705. $self->{map}{window}->bind('<1>', [&mapMove, $self, Ev('x') , Ev('y'), 2]); 
  706. $self->{map}{window}->bind('<3>', [&mapMove, $self, Ev('x') , Ev('y'), 1]); 
  707. $self->{map}{window}->bind('<Motion>', [&pointchk, $self, Ev('x') , Ev('y')]); 
  708. $self->updatePos();
  709. } elsif (defined $self->{map}) {
  710. $self->{map}{window}->destroy();
  711. undef $self->{map}{canvas};
  712. undef $self->{map}{window};
  713. undef $self->{map};
  714. }
  715. }
  717. sub pointchk {
  718. my (undef, $self, $mvcpx, $mvcpy) = @_;
  719. if (@_ == 3) {
  720. ($self, $mvcpx, $mvcpy) = @_;
  721. } elsif (@_ == 4) {
  722. (undef, $self, $mvcpx, $mvcpy) = @_;
  723. } else {
  724. die "wrong number of args to pointchkn";
  725. }
  726. $mvcpy = $self->{map}{height} - $mvcpy;
  727. my ($x,$y) = @{$char->{'pos_to'}}{'x', 'y'};
  728. $self->{map}{window}->title(sprintf "Map View: %8s p:(%3d, %3d) m:(%3d, %3d)", $field->name(), $x, $y, $mvcpx, $mvcpy);
  729. $self->{map}{window}->update; 
  730. }
  732. sub mapMove {
  733. my (undef, $self, $mvcpx, $mvcpy, $moveAttack) = @_;
  734. if (@_ == 4) {
  735. ($self, $mvcpx, $mvcpy, $moveAttack) = @_;
  736. } elsif (@_ == 5) {
  737. (undef, $self, $mvcpx, $mvcpy, $moveAttack) = @_;
  738. } else {
  739. die "wrong number of args to pointchkn";
  740. }
  741. $mvcpy = $self->{map}{height} - $mvcpy;
  742. main::aiRemove("move");
  743. main::aiRemove("route");
  744. main::aiRemove("mapRoute");
  745. main::ai_route($field->name(), $mvcpx, $mvcpy,
  746. attackOnRoute => $moveAttack,
  747. noSitAuto => 1);
  748. }
  750. sub mapIsShown {
  751. my $self = shift;
  752. return defined($self->{map});
  753. }
  755. sub loadMap {
  756. my $self = shift;
  757. return if (!$self->mapIsShown());
  758. $self->{map}{field} = $field->name();
  759. $self->{map}{canvas}->delete('map');
  760. $self->{map}{canvas}->createText(50,20,-text =>'Processing..',-tags=>'loading');
  761. $self->{map_bitmap} = $self->{map}{canvas}->Bitmap(
  762. -data => ${xbmmake($field)}
  763. );
  764. $self->{map}{canvas}->createImage(2,2,
  765. -image => $self->{map_bitmap},
  766. -anchor => 'nw',
  767. -tags=>'map'
  768. );
  769. $self->{map}{canvas}->configure(
  770. -width => $field->width(),
  771. -height => $field->height()
  772. );
  773. $self->{map}{width} = $field->width();
  774. $self->{map}{height} = $field->height();
  775. $self->{map}{canvas}->delete('loading');
  776. my ($x,$y) = @{$char->{'pos_to'}}{'x', 'y'};
  777. $self->{map}{window}->title(sprintf "Map View: %8s p:(%3d, %3d)", $field->name(), $x, $y);
  778. }
  780. # should this cache xbm files?
  782. sub xbmmake {
  783. my $field = shift;
  784. my ($hx,$hy,$mvw_x,$mvw_y);
  785. my $line = 0;
  786. my $dump = 0;
  787. $mvw_x = $field->width();
  788. $mvw_y = $field->height();
  789. if (($mvw_x % 8) == 0) {
  790. $hx = $mvw_x;
  791. } else {
  792. $hx = $mvw_x+(8-($mvw_x % 8));
  793. }
  794. for (my $j = 0; $j < $mvw_y; $j++) {
  795. $hy = ($mvw_x*($mvw_y-$j-1));
  796. for (my $k = 0; $k < $hx; $k++) {
  797. $dump += 256 if (!$field->isWalkable($k, $field->height()-$j));
  798. $dump = $dump/2;
  799. if (($k % 8) == 7) {
  800. $line .= sprintf("0x%02x,",$dump);
  801. $dump = 0;
  802. }
  803. }
  804. }
  805. $line = "#define data_width $mvw_xn#define data_height $mvw_ynstatic unsigned char data_bits[] = {n".$line."};";
  806. return $line;
  807. }
  809. 1;