1#!/usr/local/bin/perl -w
2# -*- perl -*-
3
4#
5# Author: Slaven Rezic
6#
7# Copyright (C) 1999-2013 Slaven Rezic. All rights reserved.
8# This program is free software; you can redistribute it and/or
9# modify it under the same terms as Perl itself.
10#
11# Mail: srezic@cpan.org
12# WWW:  http://www.rezic.de/eserte/
13#
14
15package Tk::WidgetDump;
16use vars qw($VERSION);
17use strict;
18
19$VERSION = '1.38_51';
20
21package # hide from CPAN indexer
22  Tk::Widget;
23use Tk;
24use Tk::Tree;
25use Tk::Balloon;
26
27sub WidgetDump {
28    my($top, %args) = @_;
29    my $t = $top->Toplevel;
30    $t->title("WidgetDump of $top");
31    $t->geometry("620x420");
32    foreach my $key (qw(Control-C q)) {
33	$t->bind("<$key>" => sub { $t->destroy });
34    }
35    $t->{Top}  = $top;
36    $t->{Args} = \%args;
37
38    bless $t, 'Tk::WidgetDump';
39
40    my $bf = $t->Frame->pack(-fill => 'x', -side => "bottom");
41
42    my $hl = $t->WD_HList->pack(-fill => 'both', -expand => 1);
43    $t->Advertise("HList" => $hl);
44
45    my $rb = $bf->Button(-text => "Refresh",
46			 -command => [$t, "WD_Refresh"],
47			)->pack(-side => "left");
48    my $cb = $bf->Button(-text => "Close",
49			 -command => [$t, "WD_Close"],
50			)->pack(-side => "left");
51    $bf->Button(-text => "Help",
52		-command => sub {
53		    if (!eval { require Tk::Pod; 1}) {
54			$bf->messageBox(-message => "Tk::Pod is not installed!");
55			return;
56		    }
57		    $bf->Pod(-file => $INC{"Tk/WidgetDump.pm"},
58			     -title => "Tk::WidgetDump documentation");
59		})->pack(-side => "right", -anchor => "e");
60    $t->bind("<Alt-r>"  => sub { $rb->invoke });
61    $t->bind("<Escape>" => sub { $cb->invoke });
62
63## NYI:
64#      $t->{TrackWidgets} = 1;
65#      my $balloon;
66#      my $pathname;
67#      $balloon = $top->Balloon
68#  	(-balloonposition => 'mouse',
69#  	 -motioncommand => sub {
70#  	     return unless $t->{TrackWidgets};
71#  	     my $ev = $top->XEvent;
72#  	     my($w_under) = $top->containing($ev->X, $ev->Y);
73#  	     $pathname = $w_under->PathName;
74#  	     1;
75#  	 });
76#      $balloon->attach($top, -msg => \$pathname);
77#      $bf->Checkbutton(-text => "Track",
78#  		     -variable => \$t->{TrackWidgets},
79#  		    )->pack(-side => 'left');
80    if(0) { # not yet...
81    $top->bind("<1>" => [ sub { return unless $t && Tk::Exists($t);
82				shift;
83				$t->SelectWidget(@_);
84			    }, Ev('X'), Ev('Y') ]);
85    }
86
87    $t;
88}
89
90sub WD_HList {
91    my($t) = @_;
92
93    my $top  = $t->{Top};
94    my $args = $t->{Args};
95
96    my $hl;
97    $hl = $t->Scrolled('Tree', -drawbranch => 1, -header => 1,
98		       #-columns => 5,
99		       -columns => 4,
100		       -scrollbars => "osow",
101		       -selectmode => "multiple",
102		       -exportselection => 1,
103		       -takefocus => 1,
104		       -width => 40,
105		       -height => 20,
106		       ($args->{-font} ? (-font => $args->{-font}) : ()),
107		       -command => sub {
108			   my $sw = $hl->info('data', $_[0]);
109			   $t->_show_widget($sw);
110		       },
111		      )->pack(-fill => 'both', -expand => 1);
112    $t->Advertise("Tree" => $hl);
113    $hl->focus;
114    $hl->headerCreate(0, -text => "Tk Name");
115    $hl->headerCreate(1, -text => "Tk Class");
116    $hl->headerCreate(2, -text => "Characteristics");
117    $hl->headerCreate(3, -text => "Perl-Class");
118    #XXX $hl->headerCreate(4, -text => "Size");
119    $t->_insert_wd($hl, $top);
120    if (exists $args->{-openinfo}) {
121#XXX needs work
122#	while(my($k,$v) = each %{ $args->{-openinfo} }) {
123#	    $hl->setmode($k, $v);
124#	}
125    } else {
126	$hl->autosetmode;
127    }
128
129    if ($hl->can("menu") and $hl->can("PostPopupMenu")) {
130	my $popup_menu = $hl->Menu
131	    (-menuitems =>
132	     [
133	      [Cascade => "~Edit", -menuitems =>
134	       [
135		[Button => "~Refresh", -command => sub { $t->WD_Refresh }],
136		[Button => "~Close", -command => sub { $t->WD_Close }],
137	       ],
138	      ],
139	      [Cascade => "~Font", -menuitems =>
140	       [
141		[Button => "~Tiny",
142		 -command => sub { $hl->configure(-font => "Helvetica 6") }],
143		[Button => "~Small",
144		 -command => sub { $hl->configure(-font => "Helvetica 8") }],
145		[Button => "~Normal",
146		 -command => sub { $hl->configure(-font => "Helvetica 10") }],
147		[Button => "~Large",
148		 -command => sub { $hl->configure(-font => "Helvetica 18") }],
149		[Button => "~Huge",
150		 -command => sub { $hl->configure(-font => "Helvetica 24") }],
151	       ]
152	      ]
153	     ]
154	    );
155	$hl->menu($popup_menu);
156	$hl->bind("<3>" => sub {
157			  my $e = $_[0]->XEvent;
158			  $_[0]->PostPopupMenu($e->X, $e->Y);
159		      });
160    }
161
162    $hl;
163}
164
165sub _WD_Size {
166    my $w = shift;
167    my $size = 0;
168    eval {
169	while(my($k,$v) = each %$w) {
170	    if (defined $v) {
171		$size += length($k) + length($v);
172	    }
173	}
174    };
175    warn $@ if $@;
176    $size;
177}
178
179sub WD_Refresh {
180    my $t = shift;
181    my %args;
182    my %openinfo;
183    my $hl = $t->Subwidget("HList");
184    foreach ($hl->info('children')) {
185	$openinfo{$_} = $hl->getmode($_);
186    }
187    my $first_seen = $hl->nearest($hl->height/2);
188    my $see;
189    if (defined $first_seen) {
190	$see = $hl->info("data",$first_seen);
191    }
192    my %pack_info = $hl->packInfo;
193
194    $hl->destroy;
195    $hl = $t->WD_HList($t->{Top}, $t->{Args});
196    $hl->pack(%pack_info);
197    $t->Advertise("HList" => $hl);
198
199    if (defined $see) {
200	$t->see($see);
201    }
202}
203
204sub WD_Close {
205    my $t = shift;
206    $t->destroy;
207}
208
209######################################################################
210
211package Tk::WidgetDump;
212use base qw(Tk::Toplevel);
213
214use File::Basename;
215
216use vars qw(%ref2widget);
217
218sub Flash {
219    my $wd = shift;
220    my $w = shift;
221    eval {
222	# Wenn ein Widget w�hrend eines Flashs nochmal ausgew�hlt wird,
223	# muss es erst einmal zur�ckgesetzt werden.
224	if (defined $wd->{OldRepeat}) {
225	    $wd->{OldRepeat}->cancel;
226	    if (defined $wd->{OldBg}) {
227		$wd->{OldWidget}->configure(-background => $wd->{OldBg});
228	    }
229	}
230
231	my $old_bg = $w->cget(-background);
232	# leicht verz�gern, damit -background nicht vom Blinken verf�lscht wird
233	$w->after(10, sub { $w->configure(-background => "red") });
234	$w->Tk::raise;
235	my $i = 0;
236
237	my $flash_rep;
238	$flash_rep = $w->repeat
239	  (500,
240	   sub {
241	       if ($i % 2 == 0) {
242		   $w->configure(-background => "red");
243	       } else {
244		   $w->configure(-background => $old_bg);
245	       }
246	       if (++$i > 8) {
247		   $flash_rep->cancel;
248		   undef $wd->{OldRepeat};
249		   $w->configure(-background => $old_bg);
250	       }
251	   });
252
253	$wd->{OldWidget} = $w;
254	$wd->{OldBg}     = $old_bg;
255        $wd->{OldRepeat} = $flash_rep;
256    };
257    warn $@ if $@;
258}
259
260sub SelectWidget {
261    my $wd = shift;
262    my($X,$Y) = @_;
263    my $w = $wd->containing($X, $Y);
264    return unless $w;
265
266    my $hl = $wd->Subwidget("Tree");
267    my $c = ($hl->info("children"))[0];
268    while (defined $c and $c ne "") {
269	if ($w eq $hl->info('data', $c)) {
270	    $hl->see($c);
271	    $hl->anchorSet($c);
272	    last;
273	}
274	$c = $hl->info("next", $c);
275    }
276
277    $wd->_show_widget($w);
278}
279
280sub WidgetInfo {
281    my $wd = shift;
282    my $w = shift;
283
284    $wd->{WidgetInfoWidget} = $w;
285
286    my $wi = $wd->_get_widget_info_window;
287    $wi->title("Widget Info for " . $w);
288
289    my $txt = $wi->Subwidget("Information");
290    $txt->delete("1.0", "end");
291
292    $txt->insert("end", "Configuration:\n\n", "title");
293    $txt->insert("end", "Option Switch\tOptionDB Name\tOptionDB Class\tDefault Value\tCurrent Value\n", "title");
294    foreach my $c ($w->configure) {
295	my $class = $c->[2];
296	my $name  = $c->[1];
297	if ($name =~ m{^-}) { # an alias
298	    my @c_alias = $w->configure($name);
299	    $class = $c_alias[2];
300	}
301	$txt->insert("end",
302		     join("\t", map { !defined $_ ? "<undef>" : $_ } @$c),
303		     ["widgetlink",
304		      "config-" . $w . ($c->[0]||"") . "-" . ($class||"")],
305		     "\n");
306    }
307    $txt->insert("end", "\n");
308
309    my $insert_method = sub {
310	my($meth, $label) = @_;
311	$label = $meth if !defined $label;
312	$txt->insert("end", "$label:\t" . $w->$meth() . "\n");
313    };
314
315    $txt->insert("end", "Miscellaneous:\n\n", "title");
316
317    $insert_method->("name", "Name");
318    $insert_method->("PathName");
319    $insert_method->("Class");
320
321    $Tk::WidgetDump::ref2widget{$w} = $w;
322
323    $txt->insert("end", "Self:\t" . $w . "\n");
324    if (defined $w->parent) {
325	$txt->insert("end", "Parent:\t" . $w->parent,
326		     ["widgetlink", "href-" . $w->parent], "\n");
327	$Tk::WidgetDump::ref2widget{$w->parent} = $w->parent;
328    }
329
330    if (defined $w->toplevel) {
331	$txt->insert("end", "Toplevel:\t" . $w->toplevel,
332		     ["widgetlink", "href-" . $w->toplevel],
333		     "\n");
334	$Tk::WidgetDump::ref2widget{$w->toplevel} = $w->toplevel;
335    }
336
337    if (defined $w->MainWindow) {
338	$txt->insert("end", "MainWindow:\t" . $w->MainWindow,
339		     ["widgetlink", "href-" . $w->MainWindow],
340		     "\n");
341	$Tk::WidgetDump::ref2widget{$w->MainWindow} = $w->MainWindow;
342    }
343
344    my @children = $w->children;
345    if (@children) {
346	$txt->insert("end", "Children:");
347	my $tab = "\t";
348	my $c_count=0;
349	foreach my $sw (@children) {
350	    $txt->insert("end", $tab . $sw,
351			 ["widgetlink", "href-" . $sw],
352			 "\n");
353	    $Tk::WidgetDump::ref2widget{$sw} = $sw;
354	    $tab = "\t";
355	    if ($c_count > 10) {
356		$txt->insert("end", $tab . "...");
357	    }
358	}
359    }
360    my @subwidgets = keys %{ $w->{SubWidget} };
361    if (@subwidgets) {
362	$txt->insert("end", "Subwidgets:");
363	my $tab = "\t";
364	my $c_count=0;
365	foreach my $sw_name (@subwidgets) {
366	    my $sw = $w->Subwidget($sw_name);
367	    $txt->insert("end", $tab . $sw_name . " => " . $sw,
368			 ["widgetlink", "href-" . $sw],
369			 "\n");
370	    $Tk::WidgetDump::ref2widget{$sw} = $sw;
371	    $tab = "\t";
372	    if ($c_count > 10) {
373		$txt->insert("end", $tab . "...");
374	    }
375	}
376    }
377
378    $insert_method->("manager", "GeomManager");
379    my $manager = $w->manager;
380    if ($manager) {
381	my $info_cmd = ($manager eq 'tixForm' ? 'formInfo' : $manager.'Info');
382	my %info = eval { $w->$info_cmd() };
383	warn $@ if $@;
384	if (keys %info) {
385	    my $need_comma;
386	    my %win_info;
387	    $txt->insert("end", "    info:\t");
388	    if ($info{-in}) {
389		$win_info{-in} = delete $info{-in};
390		$txt->insert("end", "-in => $win_info{-in}",
391			     ["widgetlink", "href-" . $win_info{-in}]);
392		$Tk::WidgetDump::ref2widget{$win_info{-in}} = $win_info{-in};
393		$need_comma++;
394	    }
395	    my $info = ($need_comma ? ", " : "") .
396		join(", ", map { "$_ => $info{$_}" } keys %info);
397	    $txt->insert("end", $info . "\n");
398	}
399    }
400    eval {
401	my(@wrapper) = $w->wrapper;
402	if (@wrapper) {
403	    $txt->insert("end", "wrapper:\t" . join(", ", @wrapper) . "\n");
404	}
405    };
406    $insert_method->("geometry");
407    $insert_method->("rootx");
408    $insert_method->("rooty");
409    $insert_method->("vrootx");
410    $insert_method->("vrooty");
411    $insert_method->("x");
412    $insert_method->("y");
413    $insert_method->("width");
414    $insert_method->("height");
415    $insert_method->("reqwidth");
416    $insert_method->("reqheight");
417    $insert_method->("id");
418    $insert_method->("ismapped");
419    $insert_method->("viewable");
420
421# XXX bindtags
422# XXX bind?
423
424    $txt->insert("end", "\nServer:\n");
425    $insert_method->("server", "    id");
426    $insert_method->("visual", "    visual");
427#XXX dokumentiert, aber nicht vorhanden?!
428#    $insert_method->("visualid", "    visualid");
429    $insert_method->("visualsavailable", "    visualsavailable");
430
431    $txt->insert("end", "\nRoot window:\n");
432    $insert_method->("vrootwidth", "    vrootwidth");
433    $insert_method->("vrootheight", "    vrootheight");
434
435    $txt->insert("end", "\nScreen:\n");
436    $insert_method->("screen", "    id");
437    $insert_method->("screencells", "    cells");
438    $insert_method->("screenwidth", "    width");
439    $insert_method->("screenheight", "    height");
440    $insert_method->("screenmmwidth", "    width (mm)");
441    $insert_method->("screenmmheight", "    height (mm)");
442    $insert_method->("screenvisual", "    visual");
443
444    $txt->insert("end", "\nColor map:\n");
445    $insert_method->("cells", "    cells");
446    $insert_method->("colormapfull", "    full");
447    $insert_method->("depth", "    depth");
448
449    $txt->insert("end", "\n");
450
451    {
452	my $b = $txt->Button(-text => "Flash widget",
453			     -command => sub {
454				 $wd->Flash($w);
455			     });
456	$txt->windowCreate("end", -window => $b);
457    }
458    my $b = $txt->Button(-text => "Method call",
459			 -command => sub {
460			     $wd->method_call($w);
461			 });
462    $txt->windowCreate("end", -window => $b);
463
464    if ($w->isa('Tk::Canvas')) {
465	my $b = $txt->Button(-text => "Canvas dump",
466			     -command => sub {
467				 $wd->canvas_dump($w);
468			     });
469	$txt->windowCreate("end", -window => $b);
470    }
471    if ($w->can('tagNames')) {
472	my $b = $txt->Button(-text => 'Tags',
473			     -command => sub {
474				 $wd->tag_dump($w);
475			     });
476	$txt->windowCreate('end', -window => $b);
477    }
478
479    my $ObjScanner;
480    if (!eval {
481		require Tk::ObjEditor;
482		$ObjScanner = "ObjEditor";
483		$Storable::forgive_me = $Storable::forgive_me = 1; # XXX hack to prevent problems with code refs
484		1;
485	    }) {
486	eval { require Tk::ObjScanner;
487	       $ObjScanner = "ObjScanner";
488	       1;
489	   };
490    }
491
492    if (defined $ObjScanner) {
493	my $b = $txt->Button
494	    (-text => $ObjScanner,
495	     -command => sub {
496		 my $t = $b->Toplevel(-title => $ObjScanner);
497		 my $os = $t->$ObjScanner
498		     (caller => $w,
499		      title  => "$ObjScanner $w",
500		      background       => 'white',
501		      selectbackground => 'beige',
502		      foldImage => $t->Photo(-file => Tk->findINC('folder.xpm')),
503		      openImage => $t->Photo(-file => Tk->findINC('openfolder.xpm')),
504		      itemImage => $t->Photo(-file => Tk->findINC('textfile.xpm')))->pack(-fill => "both", -expand => 1);
505	     });
506	$txt->windowCreate("end", -window => $b);
507    }
508
509    $b = $txt->Button
510	(-text => "Show bindings",
511	 -command => [$wd, 'show_bindings', $w]);
512    $txt->windowCreate("end",
513		       -window => $b,
514		      );
515
516}
517
518sub show_bindings {
519    my($wd, $w) = @_;
520    my $t = $wd->Toplevel(-title => 'Bindings');
521    my $ttxt = $t->Scrolled($wd->_more_widget_class)->pack(-fill => 'both',
522							   -expand => 1);
523    _text_link_config($ttxt, sub { _bind_text_tag($_[0], $wd) } );
524    foreach my $bindtag ($w->bindtags) {
525	$ttxt->insert("end", "Bind tag: $bindtag\n\n");
526	foreach my $bind ($w->Tk::bind($bindtag)) {
527	    my $cb = $w->Tk::bind($bindtag, $bind);
528	    my $label;
529	    if (UNIVERSAL::isa($cb, 'ARRAY')) {
530		$label = join ",", @$cb;
531	    } else {
532		$label = $cb;
533	    }
534	    $ttxt->insert("end", $bind . " => ");
535	    $ttxt->insert("end", $label,
536			  ["widgetlink",
537			   "bind-" . $w . "|" . $bindtag . "|" . $bind]);
538	    $ttxt->insert("end", "\n");
539	}
540	$ttxt->insert("end", "\n");
541    }
542}
543
544sub show_binding_details {
545    my($wd, $widget, $bindtag, $bind) = @_;
546    my $t = $wd->Toplevel(-title => "Binding details");
547    my $ttxt = $t->Scrolled($wd->_more_widget_class)->pack(-fill => "both", -expand => 1);
548    my $cb = $widget->Tk::bind($bindtag, $bind);
549    $ttxt->insert("end", "Binding <$bind> for bindtag <$bindtag>:\n");
550    require Data::Dumper;
551    my $txt;
552    my $dd = Data::Dumper->new([$cb],[]);
553    if ($dd->can("Deparse")) {
554	$txt = $dd->Deparse(1)->Useqq(1)->Dump;
555    } else {
556	$txt = "Sorry, your version of Data::Dumper is not capable to deparse the CODE reference.";
557    }
558    $ttxt->insert("end", $txt);
559}
560
561sub _show_widget {
562    my($wd, $w) = @_;
563    $wd->Flash($w);
564    $wd->WidgetInfo($w);
565}
566
567sub see {
568    my($wd, $w) = @_;
569    my $tree = $wd->Subwidget("Tree");
570    my $entry = ($tree->info("children"))[0];
571    while (defined $entry and $entry ne "") {
572	if ($tree->info("data", $entry) eq $w) {
573	    $tree->see($entry);
574	    return;
575	}
576	$entry = $tree->info("next", $entry);
577    }
578    warn "Widget $w not found in Widget tree\n";
579}
580
581sub _edit_config {
582    my($wd, $w, $opt, $class) = @_;
583
584    my $val;
585    eval {
586	$val = $w->cget($opt);
587    };
588    if ($@) {
589	warn $@;
590	return;
591    }
592    my $oldval = $val;
593
594    my $t = $wd->Toplevel(-title => "Edit config");
595    my $set_sub = sub {
596	eval {
597	    $w->configure($opt => $val);
598	};
599	warn $@ if $@;
600    };
601    $t->Label(-text => "Edit $opt for $w:")->pack(-side => "left");
602    my $e;
603    $e = eval 'Tk::WidgetDump::' . $class . '->entry($t, \$val, $set_sub)';
604    #warn $@ if $@;
605    if ($@) {
606	$e = eval 'Tk::WidgetDump::Entry->entry($t, \$val, $set_sub)';
607	warn $@ if $@;
608    }
609#XXX ja?
610#     $t->Button(-text => "Undef and close",
611# 	       -command => sub {
612# 		   $val = undef;
613# 		   $set_sub->();
614# 		   $t->destroy;
615# 	       }
616# 	      )->pack(-side => "left");
617    $t->Button(-text => "Set",
618	       -command => $set_sub,
619	      )->pack(-side => "left");
620    $t->Button(-text => "Close",
621	       -command => [$t, 'destroy'],
622	      )->pack(-side => "left");
623    $e->focus if Tk::Exists($e);
624    $t->bind("<Escape>" => [$t, 'destroy']);
625}
626
627sub method_call {
628    my($wd, $w) = @_;
629
630    my $t = $wd->Toplevel(-title => "Method call");
631    my $f = $t->Frame->pack(-fill => "x");
632    my $eval;
633    $f->Label(-text => "Method call on $w ->")->pack(-side => "left");
634    my $e = $f->_hist_entry({-textvariable => \$eval},
635			    {-match => 1, -dup => 0})->pack(-side => "left");
636    $e->focus;
637    my $ww = $w;
638    my $text;
639    my $doit = sub {
640	if ($e->can('historyAdd')) {
641	    $e->historyAdd;
642	}
643	$ww = $ww; # XXX ???????
644	my $cmd = '$ww->' . $eval;
645	my(@res) = eval($cmd);
646	require Data::Dumper;
647	my $res = Data::Dumper->Dumpxs([\@res, $@],[$cmd, 'Error']) .
648	          "\@res = <@res>\n";
649	warn $res;
650	$text->delete("1.0", "end");
651	$text->insert("end", $res);
652    };
653    my $close = sub {
654	$t->destroy;
655    };
656    $e->bind('<Return>' => $doit);
657    $e->bind('<Escape>' => $close);
658    $f->Button(-text => "Execute!", -command => $doit)->pack(-side => "left");
659    $f->Button(-text => "Close", -command => $close)->pack(-side => "left");
660    $text = $t->Scrolled($wd->_more_widget_class,
661			 -scrollbars => "osoe",
662			 -font => "courier 10", # XXX do not hardcode
663			 -width => 40, -height => 5)->pack(-fill => "both", -expand => 1);
664}
665
666sub _text_link_config {
667    my($txt, $code) = @_;
668    $txt->tagConfigure(qw/widgetlink -underline 1/);
669    $txt->tagConfigure(qw/hot        -foreground red/);
670    $txt->tagBind(qw/widgetlink <ButtonRelease-1>/ => $code);
671    $txt->{last_line} = '';
672    $txt->tagBind(qw/widgetlink <Enter>/ => sub {
673	my($text) = @_;
674	my $e = $text->XEvent;
675	my($x, $y) = ($e->x, $e->y);
676	$txt->{last_line} = $text->index("\@$x,$y linestart");
677	$text->tagAdd('hot', $txt->{last_line}, $txt->{last_line}." lineend");
678	$text->configure(qw/-cursor hand2/);
679    });
680    $txt->tagBind(qw/widgetlink <Leave>/ => sub {
681	my($text) = @_;
682	$text->tagRemove(qw/hot 1.0 end/);
683	$text->configure(qw/-cursor xterm/);
684    });
685    $txt->tagBind(qw/widgetlink <Motion>/ => sub {
686	my($text) = @_;
687	my $e = $text->XEvent;
688	my($x, $y) = ($e->x, $e->y);
689	my $new_line = $text->index("\@$x,$y linestart");
690	if ($new_line ne $txt->{last_line}) {
691	    $text->tagRemove(qw/hot 1.0 end/);
692	    $txt->{last_line} = $new_line;
693	    $text->tagAdd('hot', $txt->{last_line}, $txt->{last_line}." lineend");
694	}
695    });
696    $txt->tagConfigure("title", -font => "Helvetica 10 bold"); # XXX do not hardcode!
697}
698
699######################################################################
700# Canvas
701sub canvas_config {
702    my($wd, $c, $item) = @_;
703    my $t = $wd->Toplevel(-title => "Canvas config of item $item");
704
705    my $txt = $t->Scrolled($wd->_more_widget_class,
706			   -tabs => [map { (5*$_) . "c" } (1 .. 8)],
707			   -scrollbars => "osow",
708			   -wrap => "none",
709			  )->pack(-fill => "both", -expand => 1);
710    _text_link_config($txt, sub { _bind_text_tag($_[0], $wd) } );
711
712    $txt->insert("end", "Canvas Item Configuration:\n\n", "title");
713    $txt->insert("end", "Option\tDefault Value\tCurrent Value\n", "title");
714    foreach my $cc ($c->itemconfigure($item)) {
715	my @cc = @{$cc}[0,3,4];
716	$txt->insert("end",
717		     join("\t", map { !defined $_ ? "<undef>" : $_ } @cc),
718		     ["widgetlink", "cconfig-" . $c . "-" . $item . $cc[0]],
719		     "\n"
720		    );
721    }
722
723    $txt->insert("end", "\nCoords\n",
724		 ["widgetlink", "ccoords-" . $c . "-" . $item],
725		 "\n"
726		);
727
728}
729
730sub canvas_dump {
731    my($wd, $c) = @_;
732    my $t = $wd->Toplevel(-title => "Canvas dump of $c");
733    my $txt = $t->Scrolled($wd->_more_widget_class,
734			   -scrollbars => "osow",
735			   -tabs => [map { (3*$_) . "c" } (1 .. 3)],
736			  )->pack(-fill => "both", -expand => 1);
737    _text_link_config($txt, sub { _bind_text_tag($_[0], $wd) } );
738
739    $txt->insert("end", "Canvas Dump\n\n", "title");
740    $txt->insert("end", "Item number\tType\tTag list\n", "title");
741    foreach my $i ($c->find("all")) {
742	$txt->insert("end", "$i\t" . $c->type($i) . "\t[" .
743		     join(",",$c->gettags($i)) . "]",
744		     ["widgetlink", "c-" . $c . "-" . $i],
745		     "\n");
746    }
747
748}
749
750sub edit_canvas_config {
751    my($wd, $c, $item, $opt) = @_;
752
753    my $val;
754    eval {
755	$val = $c->itemcget($item, $opt);
756    };
757    if ($@) {
758	warn $@;
759	return;
760    }
761    my $oldval = $val;
762
763    my $t = $wd->Toplevel(-title => "Edit canvas config");
764    my $set_sub = sub {
765	eval {
766	    $c->itemconfigure($item, $opt => $val);
767	};
768	warn $@ if $@;
769    };
770    $t->Label(-text => "Edit $opt for canvas item $item:")->pack(-side => "left");
771    my $e;
772    $e = eval 'Tk::WidgetDump::Entry->entry($t, \$val, $set_sub)';
773    warn $@ if $@;
774    $e->focus if Tk::Exists($e);
775    $t->bind("<Escape>" => [$t, 'destroy']);
776#XXX ja?
777#     $t->Button(-text => "Undef and close",
778# 	       -command => sub {
779# 		   $val = undef;
780# 		   $set_sub->();
781# 		   $t->destroy;
782# 	       }
783# 	      )->pack(-side => "left");
784    $t->Button(-text => "Close", -command => [$t, "destroy"])->pack(-side => "left");
785}
786
787sub edit_canvas_coords {
788    my($wd, $c, $item) = @_;
789
790    my $val;
791    eval {
792	$val = join(",", $c->coords($item));
793    };
794    if ($@) {
795	warn $@;
796	return;
797    }
798
799    my $t = $wd->Toplevel(-title => "Edit canvas coords");
800    my $set_sub = sub {
801	eval {
802	    my @c = split(/,/, $val);
803	    $c->coords($item, @c);
804	};
805	warn $@ if $@;
806    };
807    $t->Label(-text => "Edit coords for canvas item $item:")->pack(-side => "left");
808    my $e;
809    $e = eval 'Tk::WidgetDump::Entry->entry($t, \$val, $set_sub)';
810    warn $@ if $@;
811    $e->focus if Tk::Exists($e);
812    $t->bind("<Escape>" => [$t, 'destroy']);
813    $t->Button(-text => "Close", -command => [$t, "destroy"]);
814}
815
816######################################################################
817# Tags
818sub tag_dump {
819    my($wd, $w) = @_;
820    my $t = $wd->Toplevel(-title => "Tag dump of $w");
821    my $txt = $t->Scrolled($wd->_more_widget_class,
822			   -width => 15,
823			   -height => 5,
824			   -scrollbars => 'osow',
825			  )->pack(-fill => "both", -expand => 1);
826    _text_link_config($txt, sub { _bind_text_tag($_[0], $wd) } );
827
828    $txt->insert('end', "Tags\n\n", 'title');
829    for my $tag_name ($w->tagNames) {
830	$txt->insert('end', $tag_name, ["widgetlink", "tag-$w-$tag_name"], "\n");
831    }
832}
833
834sub tag_options {
835    my($wd, $w, $tag) = @_;
836
837    my $t = $wd->Toplevel(-title => "Options for tag $tag");
838    my $txt = $t->Scrolled($wd->_more_widget_class,
839			   -scrollbars => 'osow',
840			   -tabs => [map { (3*$_) . "c" } (1 .. 3)],
841			  )->pack(-fill => "both", -expand => 1);
842    _text_link_config($txt, sub { _bind_text_tag($_[0], $wd) } );
843    $txt->insert('end', "Option Name\tDefault Value\tCurrent Value\n", 'title');
844    for my $option_def ($w->tagConfigure($tag)) {
845	my($key,undef,undef,$def_val,$curr_val) = @$option_def;
846	$txt->insert('end',
847		     join("\t", map { !defined $_ ? '<undef>' : $_ } ($key, $def_val, $curr_val)),
848		     ['widgetlink', "tag-config-$w-$tag-$key"],
849		     "\n");
850    }
851    $txt->insert('end', "\n");
852}
853
854sub edit_tag_option {
855    my($wd, $w, $tag, $key) = @_;
856
857    my $val;
858    eval {
859	$val = $w->tagCget($tag, $key);
860    };
861    if ($@) {
862	warn $@;
863	return;
864    }
865
866    my $t = $wd->Toplevel(-title => "Edit tag option $key");
867    my $set_sub = sub {
868	eval {
869	    $w->tagConfigure($tag, $key, $val);
870	};
871	warn $@ if $@;
872    };
873
874    $t->Label(-text => "Edit option $key for tag $tag:")->pack(-side => "left");
875    my $e;
876    $e = eval 'Tk::WidgetDump::Entry->entry($t, \$val, $set_sub)';
877    warn $@ if $@;
878    $e->focus if Tk::Exists($e);
879    $t->bind("<Escape>" => [$t, 'destroy']);
880    $t->Button(-text => "Close", -command => [$t, "destroy"]);
881}
882
883######################################################################
884# Misc
885sub _insert_wd {
886    my($wd, $hl, $top, $par) = @_;
887    my $i = 0;
888    foreach my $cw ($top->children) {
889	my $path = (defined $par ? $par . $hl->cget(-separator) : '') . $i;
890	my($name, $class, $size, $ref);
891	eval {
892	    $name  = $cw->Name  || "No name";
893	    $class = $cw->Class || "No class";
894	    $size  = $cw->_WD_Size;
895	    $ref   = ref($cw)   || "No ref";
896	};
897	warn $@ if $@;
898	$hl->add($path, -text => $name, -data => $cw);
899	$hl->itemCreate($path, 1, -text => $class);
900	if ($cw->can('_WD_Characteristics')) {
901	    my $char = $cw->_WD_Characteristics;
902	    if (!defined $char) { $char = "???" }
903	    $hl->itemCreate($path, 2, -text => $char);
904	}
905	$hl->itemCreate($path, 3, -text => $ref);
906	#XXX$hl->itemCreate($path, 4, -text => $size);
907	$wd->_insert_wd($hl, $cw, $path);
908	#if ($cw->can('_WD_Children')) {
909	#    $cw->_WD_Children;
910	#}
911	$i++;
912    }
913}
914
915sub _delete_all {
916    my($hl) = @_;
917    $hl->delete("all");
918}
919
920sub _label_title {
921    my $w = shift;
922    if (defined $w->cget(-image) and
923	$w->cget(-image) ne "") {
924	my $image = "(image)";
925	eval {
926	    my $i = $w->cget(-image);
927	    if ($i->cget(-file) ne "") {
928		$image = _crop(basename($i->cget(-file))) . " (image)";
929	    }
930	};
931	$image;
932    } elsif (defined $w->cget(-textvariable) and
933	     $w->cget(-textvariable) ne "") {
934	_crop($ { $w->cget(-textvariable) });
935    } else {
936	_crop($w->cget(-text));
937    }
938}
939
940sub _crop {
941    my $txt = shift;
942    if (defined $txt && length($txt) > 30) {
943	substr($txt, 0, 30) . "...";
944    } else {
945	$txt;
946    }
947}
948
949sub _bind_text_tag {
950    my($text, $wd) = @_;
951
952    my $index = $text->index('current');
953    my @tags = $text->tagNames($index);
954
955    my $i = _lsearch('href\-.*', @tags);
956    if ($i >= 0) {
957	my($href) = $tags[$i] =~ /href-(.*)/;
958	my $widget = $ref2widget{$href};
959	$wd->_show_widget($widget);
960	return;
961    }
962
963    $i = _lsearch('config\-.*', @tags);
964    if ($i >= 0) {
965	if ($tags[$i] =~ /^config-(.*)(-.*)-(.*)$/) {
966	    my $w_name = $1;
967	    my $opt = $2;
968	    my $class = $3;
969	    my $widget = $ref2widget{$w_name};
970	    $wd->_edit_config($widget, $opt, $class);
971	    return;
972	}
973    }
974
975    $i = _lsearch('c\-.*', @tags);
976    if ($i >= 0) {
977	if ($tags[$i] =~ /^c-(.*)-(.*)$/) {
978	    my $w_name = $1;
979	    my $item = $2;
980	    #my $canv_opt = $3;
981	    my $widget = $ref2widget{$w_name};
982	    $wd->canvas_config($widget, $item);
983	    return;
984	}
985    }
986
987    $i = _lsearch('cconfig\-.*', @tags);
988    if ($i >= 0) {
989	if ($tags[$i] =~ /^cconfig-(.*)-(.*)(-.*)$/) {
990	    my $w_name = $1;
991	    my $item = $2;
992	    my $opt = $3;
993	    my $widget = $ref2widget{$w_name};
994	    $wd->edit_canvas_config($widget, $item, $opt);
995	    return;
996	}
997    }
998
999    $i = _lsearch('ccoords\-.*', @tags);
1000    if ($i >= 0) {
1001	if ($tags[$i] =~ /^ccoords-(.*)-(.*)$/) {
1002	    my $w_name = $1;
1003	    my $item = $2;
1004	    my $widget = $ref2widget{$w_name};
1005	    $wd->edit_canvas_coords($widget, $item);
1006	    return;
1007	}
1008    }
1009
1010    $i = _lsearch('bind\-.*', @tags);
1011    if ($i >= 0) {
1012	if ($tags[$i] =~ /^bind-(.*)\|(.*)\|(.*)$/) {
1013	    my $w_name = $1;
1014	    my $bindtag = $2;
1015	    my $bind = $3;
1016	    my $widget = $ref2widget{$w_name};
1017	    $wd->show_binding_details($widget, $bindtag, $bind);
1018	    return;
1019	}
1020    }
1021
1022    $i = _lsearch('tag\-config\-.*', @tags);
1023    if ($i >= 0) {
1024	if ($tags[$i] =~ /^tag-config-([^-]+)-(.*)-(-.+)$/) {
1025	    my($w_name, $tag_name, $key) = ($1, $2, $3);
1026	    my $widget = $ref2widget{$w_name};
1027	    $wd->edit_tag_option($widget, $tag_name, $key);
1028	    return;
1029	}
1030    }
1031
1032    $i = _lsearch('tag\-.*', @tags);
1033    if ($i >= 0) {
1034	if ($tags[$i] =~ /^tag-(.*)-(.*)$/) {
1035	    my $w_name = $1;
1036	    my $tag_name = $2;
1037	    my $widget = $ref2widget{$w_name};
1038	    $wd->tag_options($widget, $tag_name);
1039	    return;
1040	}
1041    }
1042
1043    warn "Can't match $tags[$i]";
1044}
1045
1046sub _get_widget_info_window {
1047    my $wd = shift;
1048
1049    my $wi = $wd->Subwidget("WidgetInfo");
1050
1051    if ($wi and Tk::Exists($wi)) {
1052	$wi->raise;
1053	return $wi;
1054    }
1055
1056    $wi = $wd->Component(Toplevel => "WidgetInfo");
1057    $wi->title("Widget Info");
1058    if ($wi->screenwidth > 930 and
1059	$wi->screenheight > 450) {
1060	$wi->geometry("930x450");
1061    }
1062
1063    my $bf = $wi->Frame->pack(-fill => 'x', -side => "bottom");
1064
1065    my $txt = $wi->Scrolled($wd->_more_widget_class,
1066			    -tabs => [map { (5*$_) . "c" } (1 .. 8)],
1067			    -wrap => "none",
1068			   )->pack(-expand => 1, -fill => "both");
1069    _text_link_config($txt, sub { _bind_text_tag($_[0], $wd) } );
1070
1071    $wi->Advertise("Information" => $txt);
1072
1073    my $rb = $bf->Button(-text => "Refresh",
1074			-command => sub {
1075			    $wd->WidgetInfo($wd->{WidgetInfoWidget});
1076			})->pack(-side => "left");
1077    my $cb = $bf->Button(-text => "Close",
1078			-command => sub { $wi->destroy }
1079			)->pack(-side => "left");
1080    $wi->Advertise(Close => $cb);
1081
1082    $wi;
1083}
1084
1085sub _lsearch {
1086
1087    # Search the list using the supplied regular expression and return it's
1088    # ordinal, or -1 if not found.
1089
1090    my($regexp, @list) = @_;
1091    my($i);
1092
1093    for ($i=0; $i<=$#list; $i++) {
1094        return $i if $list[$i] =~ /$regexp/;
1095    }
1096    return -1;
1097
1098} # end lsearch
1099
1100{
1101    my $more_widget_class;
1102    sub _more_widget_class {
1103	return $more_widget_class if $more_widget_class;
1104	if (eval { require Tk::More; 1 }) {
1105	    return $more_widget_class = 'More';
1106	} else {
1107	    require Tk::ROText;
1108	    return $more_widget_class = 'ROText';
1109	}
1110    }
1111}
1112
1113# XXX weitermachen
1114# die Idee: die gesamten Konfigurationsdaten aller Widgets per configure
1115# feststellen und als String schreiben. Und das f�r alle Children des
1116# Widgets. Zus�tzlich die pack/grid/etc.-Information feststellen.
1117# Das alles gibt dann ein Perl-Programm. Parents bei der Rekursion merken.
1118# sub dump_as_perl {
1119#     my $top = shift;
1120
1121# }
1122
1123# sub dump_widget {
1124#     my $w = shift;
1125#     foreach $cdef ($w->configure) {
1126# #	if (defined $cdef->[4]) {
1127# #
1128#     }
1129# }
1130
1131# REPO BEGIN
1132# REPO NAME _hist_entry /home/e/eserte/src/repository
1133# REPO MD5 904022626019f774e4c0039cd8eecf78
1134sub Tk::Widget::_hist_entry {
1135    my($top, $entry_args, $hist_entry_args) = @_;
1136    my $Entry = "Entry";
1137    my @extra_args;
1138    eval {
1139	require Tk::HistEntry;
1140        Tk::HistEntry->VERSION(0.33);
1141	$Entry = "SimpleHistEntry";
1142	@extra_args = %$hist_entry_args;
1143    };
1144    $top->$Entry(%$entry_args);
1145}
1146# REPO END
1147
1148package # hide from CPAN indexer
1149  Tk::Toplevel;
1150sub _WD_Characteristics {
1151    my $w = shift;
1152    my $characteristics = eval {
1153	Tk::WidgetDump::_crop($w->title) . " (" . $w->geometry . ")";
1154    };
1155    if ($@) {
1156	# A "toplevel" which is not a real toplevel: this is true
1157	# for Tk::DragDrop, see the comments there.
1158	$characteristics = Tk::WidgetDump::_crop("toplevel-ish $w");
1159    }
1160    $characteristics;
1161}
1162
1163package # hide from CPAN indexer
1164  Tk::Label;
1165sub _WD_Characteristics {
1166    my $w = shift;
1167    Tk::WidgetDump::_label_title($w);
1168}
1169
1170package # hide from CPAN indexer
1171  Tk::Button;
1172sub _WD_Characteristics {
1173    my $w = shift;
1174    Tk::WidgetDump::_label_title($w);
1175}
1176
1177package # hide from CPAN indexer
1178  Tk::Menu;
1179sub _WD_Characteristics {
1180    my $w = shift;
1181    my $title = $w->cget(-title) || "(no title)";
1182    Tk::WidgetDump::_crop($title) . " (" . $w->cget("-type") . ")";
1183}
1184
1185sub _WD_Children {
1186    my $w = shift;
1187    my $end = $w->index("end");
1188    for my $i (0 .. $end) {
1189	warn $w->type($i);
1190    }
1191}
1192
1193
1194package # hide from CPAN indexer
1195  Tk::Menubutton;
1196sub _WD_Characteristics {
1197    my $w = shift;
1198    Tk::WidgetDump::_label_title($w);
1199}
1200
1201package # hide from CPAN indexer
1202  Tk::Listbox;
1203sub _WD_Characteristics {
1204    my $w = shift;
1205    my $first_elem = $w->get(0);
1206    if (defined $first_elem) {
1207        Tk::WidgetDump::_crop($first_elem) . " ...";
1208    } else {
1209	"";
1210    }
1211}
1212
1213package # hide from CPAN indexer
1214  Tk::HList;
1215sub _WD_Characteristics {
1216    my $w = shift;
1217    my $res = "";
1218    eval {
1219	my($first_entry) = $w->info("children");
1220	$res = Tk::WidgetDump::_crop($w->itemCget($first_entry, 0, -text)) . " ...";
1221    };
1222    $res;
1223}
1224
1225# XXX bei Refresh openlist merken und wiederherstellen
1226
1227######################################################################
1228
1229package Tk::WidgetDump::Entry;
1230sub entry {
1231    my($class, $p, $valref, $set_sub) = @_;
1232    my $e = $p->_hist_entry({-textvariable => $valref},
1233			    {-match => 1, -dup => 0});
1234    $e->bind("<Return>" => sub {
1235	if ($e->can('historyAdd')) {
1236	    $e->historyAdd;
1237	}
1238	$set_sub->();
1239    });
1240    $e->pack(-side => "left");
1241}
1242
1243package Tk::WidgetDump::BrowseEntry;
1244sub entry {
1245    my($class, $p, $valref, $set_sub) = @_;
1246    require Tk::BrowseEntry;
1247    my $e = $p->BrowseEntry(-textvariable => $valref,
1248			    -browsecmd => $set_sub)->pack(-side => "left");
1249
1250    $e->insert("end", $class->entries);
1251    $e->bind("<Return>" => $set_sub);
1252    $e;
1253}
1254
1255package Tk::WidgetDump::_MyNumEntry;
1256eval {
1257    require Tk::NumEntry;
1258    @Tk::WidgetDump::_MyNumEntry::ISA = qw(Tk::NumEntry);
1259    Construct Tk::Widget '_MyNumEntry';
1260    sub Populate {
1261	my($w, $args) = @_;
1262	$w->SUPER::Populate($args);
1263	$w->ConfigSpecs(-setcmd => ['CALLBACK']);
1264    }
1265    sub incdec {
1266	my $w = shift;
1267	my $r = $w->Tk::NumEntry::incdec(@_);
1268	$w->Callback(-setcmd => $w);
1269	$r;
1270    }
1271};
1272warn $@ if $@;
1273$Tk::WidgetDump::_MyNumEntry::can_mynumentry = 1 unless $@;
1274
1275package Tk::WidgetDump::NumEntry;
1276sub entry {
1277    eval {
1278	die "No NumEntry"
1279	    if !$Tk::WidgetDump::_MyNumEntry::can_mynumentry;
1280    };
1281    if ($@) {
1282	warn $@;
1283	shift->Tk::WidgetDump::Entry::entry(@_);
1284    } else {
1285	my($class, $p, $valref, $set_sub) = @_;
1286	my $e = $p->_MyNumEntry
1287	    (-textvariable => $valref,
1288	     -value => $$valref,
1289	     -setcmd => sub { $set_sub->() },
1290	     -command => sub { $set_sub->() }
1291	    )->pack(-side => "left");
1292	$e->bind("<Return>" => $set_sub);
1293	$e;
1294    }
1295}
1296
1297package Tk::WidgetDump::Bool;
1298sub entry {
1299    my($class, $p, $valref, $set_sub) = @_;
1300    my $e = $p->Checkbutton(-variable => $valref,
1301			    -onvalue => 1,
1302			    -offvalue => 0,
1303			    -command => $set_sub)->pack(-side => "left");
1304
1305    $e->insert("end", $class->entries);
1306    $e->bind("<Return>" => $set_sub);
1307    $e;
1308}
1309
1310package Tk::WidgetDump::Color;
1311sub entry {
1312    my($class, $p, $valref, $set_sub) = @_;
1313    require Tk::BrowseEntry;
1314    my $e = $p->BrowseEntry(-textvariable => $valref,
1315			    -browsecmd => $set_sub)->pack(-side => "left");
1316
1317    $e->insert("end", sort
1318	              keys %{+{
1319                        map { $_ =~ s/^\s+//; ((split(/\s+/, $_, 4))[3] => 1) }
1320                        split(/\n/, `showrgb`)
1321		      }}
1322	      );
1323    $e->bind("<Return>" => $set_sub);
1324    $e;
1325}
1326
1327package Tk::WidgetDump::Background;
1328use base qw(Tk::WidgetDump::Color);
1329
1330package Tk::WidgetDump::HighlightBackground;
1331use base qw(Tk::WidgetDump::Color);
1332
1333package Tk::WidgetDump::HighlightColor;
1334use base qw(Tk::WidgetDump::Color);
1335
1336package Tk::WidgetDump::Foreground;
1337use base qw(Tk::WidgetDump::Color);
1338
1339package Tk::WidgetDump::Font;
1340sub entry {
1341    my($class, $p, $valref, $set_sub) = @_;
1342    my $f = $p->Frame->pack(-side => "left");
1343    my $e = $p->Entry(-textvariable => $valref)->pack(-side => "left");
1344    $p->Button(-text => "Browse",
1345	       -command => sub {
1346		   if (!eval { require Tk::FontDialog; 1 }) {
1347		       $p->messageBox(-message => "Tk::FontDialog is not installed!");
1348		       return;
1349		   }
1350		   my $new_font = $f->FontDialog(-initfont => $$valref)->Show;
1351		   if (defined $new_font) {
1352		       $$valref = $new_font;
1353		       $set_sub->();
1354		   }
1355	       }
1356	      )->pack(-side => "left");
1357    $e->bind("<Return>" => $set_sub);
1358    $f;
1359}
1360
1361package Tk::WidgetDump::Relief;
1362use base qw(Tk::WidgetDump::BrowseEntry);
1363sub entries { qw(raised sunken flat ridge solid groove) }
1364
1365package Tk::WidgetDump::Anchor;
1366use base qw(Tk::WidgetDump::BrowseEntry);
1367sub entries { qw(center n ne e se s sw w nw) }
1368
1369package Tk::WidgetDump::Justify;
1370use base qw(Tk::WidgetDump::BrowseEntry);
1371sub entries { qw(left center right) }
1372
1373package Tk::WidgetDump::Cursor;
1374sub entry {
1375    my($class, $p, $valref, $set_sub) = @_;
1376    my $f = $p->Frame->pack(-side => "left");
1377    require Tk::BrowseEntry;
1378    require Tk::Config;
1379    my $e = $p->BrowseEntry(-textvariable => $valref,
1380			    -browsecmd => $set_sub)->pack(-side => "left");
1381    (my $xinc = $Tk::Config::xinc) =~ s/^-I//;
1382    if (open(CF, "$xinc/X11/cursorfont.h")) {
1383	while(<CF>) {
1384	    chomp;
1385	    if (/#define\s+XC_(\S+)/) {
1386		$e->insert("end", $1);
1387	    }
1388	}
1389	close CF;
1390    } else {
1391	warn "Can't open cursorfont.h";
1392    }
1393    $p->Button(-text => "Bitmapfile",
1394	       -command => sub {
1395		   my $file = $f->getOpenFile;
1396		   if (defined $file) {
1397		       $$valref = ['@' . $file, "black"];
1398		       $set_sub->();
1399		   }
1400	       }
1401	      )->pack(-side => "left");
1402    $e->bind("<Return>" => $set_sub);
1403    $f;
1404}
1405
1406$Tk::Config::xinc = $Tk::Config::xinc if 0; # peacify -w
1407
1408package Tk::WidgetDump::Command;
1409use base qw(Tk::WidgetDump::Entry);
1410
1411package Tk::WidgetDump::Image;
1412sub entry {
1413    my($class, $p, $valref, $set_sub) = @_;
1414    my $f = $p->Frame->pack(-side => "left");
1415    my $e = $p->Entry(-textvariable => $valref)->pack(-side => "left");
1416    $p->Button(-text => "Browse",
1417	       -command => sub {
1418		   my $file = $f->getOpenFile;
1419		   if (defined $file) {
1420		       my $photo = $p->Photo(-file => $file);
1421		       # XXX image cache
1422		       if ($photo) {
1423			   $$valref = $photo;
1424			   $set_sub->();
1425		       }
1426		   }
1427	       }
1428	      )->pack(-side => "left");
1429    $e->bind("<Return>" => sub {
1430		 if ($$valref eq '') {
1431		     undef $$valref;
1432		 }
1433		 $set_sub->();
1434	     });
1435    $f;
1436}
1437
1438package Tk::WidgetDump::Tile;
1439use base qw(Tk::WidgetDump::Image);
1440
1441package Tk::WidgetDump::Bitmap;
1442sub entry {
1443    my($class, $p, $valref, $set_sub) = @_;
1444    my $f = $p->Frame->pack(-side => "left");
1445    my $e = $p->Entry(-textvariable => $valref)->pack(-side => "left");
1446    $p->Button(-text => "Browse",
1447	       -command => sub {
1448		   my $file = $f->getOpenFile;
1449		   if (defined $file) {
1450		       $$valref = '@' . $file;
1451		       $set_sub->();
1452		   }
1453	       }
1454	      )->pack(-side => "left");
1455    $e->bind("<Return>" => $set_sub);
1456    $f;
1457}
1458
1459package Tk::WidgetDump::Pixels;
1460use base qw(Tk::WidgetDump::NumEntry);
1461
1462package Tk::WidgetDump::BorderWidth;
1463use base qw(Tk::WidgetDump::Pixels);
1464
1465package Tk::WidgetDump::Height;
1466use base qw(Tk::WidgetDump::Pixels);
1467
1468package Tk::WidgetDump::Width;
1469use base qw(Tk::WidgetDump::Pixels);
1470
1471package Tk::WidgetDump::HighlightThickness;
1472use base qw(Tk::WidgetDump::Pixels);
1473
1474package Tk::WidgetDump::Pad;
1475use base qw(Tk::WidgetDump::Pixels);
1476
1477package Tk::WidgetDump::Underline;
1478use base qw(Tk::WidgetDump::NumEntry);
1479
1480
1481return 1 if caller;
1482
1483######################################################################
1484
1485package main;
1486
1487# self-test
1488my $top = MainWindow->new;
1489$top->Canvas->pack->createLine(0,0,100,100);
1490#$top->withdraw;
1491$top->WidgetDump;
1492$top->WidgetDump;
1493Tk::MainLoop;
1494
1495__END__
1496
1497=head1 NAME
1498
1499Tk::WidgetDump - dump the widget hierarchie
1500
1501=head1 SYNOPSIS
1502
1503In a script:
1504
1505    use Tk::WidgetDump; # optional
1506    $mw = new MainWindow;
1507    $mw->WidgetDump; # usually before MainLoop
1508
1509From the command line for a quick widget option test:
1510
1511    perl -MTk -MTk::WidgetDump -e '$mw=tkinit; $mw->Button->pack; $mw->WidgetDump; MainLoop'
1512
1513=head1 DESCRIPTION
1514
1515C<Tk::WidgetDump> helps in debugging Perl/Tk applications. By calling
1516the C<WidgetDump> method, a new toplevel with the widget hierarchie
1517will be displayed. The hierarchie can always be refreshed by the
1518B<Refresh> button (e.g. if new widgets are added after calling the
1519C<WidgetDump> method).
1520
1521By double-clicking on a widget entry, the widget flashes and a new
1522toplevel is opened containing the configuration options of the widget.
1523It also displays other characteristics of the widget like children and
1524parent widgets, size, position, geometry management and server
1525parameters. Configuration values can also be changed on the fly.
1526Furthermore it is possible:
1527
1528=over 4
1529
1530=item *
1531
1532to navigate to the children or parents
1533
1534=item *
1535
1536to call widget methods interactively
1537
1538=item *
1539
1540to display internal widget data with L<Tk::ObjScanner|Tk::ObjScanner>
1541(if available)
1542
1543=back
1544
1545If you want to call widget methods, you have to enter the method name
1546with arguments only, e.g. (for creating a line on a canvas):
1547
1548     createLine(0,0,100,100)
1549
1550Because C<WidgetDump> is a pseudo widget, it cannot be configured
1551itself.
1552
1553=head1 BUGS
1554
1555=over
1556
1557=item * Changing configuration values
1558
1559Changes are not reflected in the configuration window, you have to hit
1560the "Refresh" button.
1561
1562=item * Tk::WidgetDump does not follow the conventions of a "real"
1563widget (ConfiSpecs etc.)
1564
1565=item * The number of open windows may be confusing
1566
1567=back
1568
1569=head1 AUTHOR
1570
1571Slaven Rezic (srezic@cpan.org)
1572
1573=head1 SEE ALSO
1574
1575L<Tk>.
1576
1577=cut
1578