File Coverage

blib/lib/Tk/ToolBar.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package Tk::ToolBar;
2            
3 1     1   6770 use 5.005;
  1         3  
  1         45  
4 1     1   5 use strict;
  1         2  
  1         34  
5 1     1   5776 use Tk::Frame;
  0            
  0            
6             use Tk::Balloon;
7            
8             use base qw/Tk::Frame/;
9             use Tk::widgets qw(Frame);
10            
11             use Carp;
12             use POSIX qw/ceil/;
13            
14             Construct Tk::Widget 'ToolBar';
15            
16             use vars qw/$VERSION/;
17             $VERSION = '0.12';
18            
19             my $edgeH = 24;
20             my $edgeW = 5;
21            
22             my $sepH = 24;
23             my $sepW = 3;
24            
25             my %sideToSticky = qw(
26             top n
27             right e
28             left w
29             bottom s
30             );
31            
32             my $packIn = '';
33             my @allWidgets = ();
34             my $floating = 0;
35             my %packIn;
36             my %containers;
37             my %isDummy;
38            
39             1;
40            
41             sub ClassInit {
42             my ($class, $mw) = @_;
43             $class->SUPER::ClassInit($mw);
44            
45             # load the images.
46             my $imageFile = Tk->findINC('ToolBar/tkIcons');
47            
48             if (defined $imageFile) {
49             local *F;
50             open F, $imageFile;
51            
52             local $_;
53            
54             while () {
55             chomp;
56             my ($n, $d) = (split /:/)[0, 4];
57            
58             $mw->Photo($n, -data => $d);
59             }
60             close F;
61             } else {
62             carp <
63             WARNING: can not find tkIcons. Your installation of Tk::ToolBar is broken.
64             No icons will be loaded.
65             EOW
66             ;
67             }
68             }
69            
70             sub Populate {
71             my ($self, $args) = @_;
72            
73             $self->SUPER::Populate($args);
74             $self->{MW} = $self->parent;
75             $self->{SIDE} = exists $args->{-side} ? delete $args->{-side} : 'top';
76             $self->{STICKY} = exists $args->{-sticky} ? delete $args->{-sticky} : 'nsew';
77             $self->{USECC} = exists $args->{-cursorcontrol} ? delete $args->{-cursorcontrol} : 1;
78             $self->{STYLE} = exists $args->{-mystyle} ? delete $args->{-mystyle} : 0;
79             $packIn = exists $args->{-in} ? delete $args->{-in} : '';
80            
81             if ($packIn) {
82             unless ($packIn->isa('Tk::ToolBar')) {
83             croak "value of -packin '$packIn' is not a Tk::ToolBar object";
84             } else {
85             $self->{SIDE} = $packIn->{SIDE};
86             }
87             }
88            
89             unless ($self->{STICKY} =~ /$sideToSticky{$self->{SIDE}}/) {
90             croak "can't place '$self->{STICKY}' toolbar on '$self->{SIDE}' side";
91             }
92            
93             $self->{CONTAINER} = $self->{MW}->Frame;
94             $self->_packSelf;
95            
96             my $edge = $self->{CONTAINER}->Frame(qw/
97             -borderwidth 2
98             -relief ridge
99             /);
100            
101             $self->{EDGE} = $edge;
102            
103             $self->_packEdge($edge, 1);
104            
105             $self->ConfigSpecs(
106             -movable => [qw/METHOD movable Movable 1/],
107             -close => [qw/PASSIVE close Close 15/],
108             -activebackground => [qw/METHOD activebackground ActiveBackground/, Tk::ACTIVE_BG],
109             -indicatorcolor => [qw/PASSIVE indicatorcolor IndicatorColor/, '#00C2F1'],
110             -indicatorrelief => [qw/PASSIVE indicatorrelief IndicatorRelief flat/],
111             -float => [qw/PASSIVE float Float 1/],
112             );
113            
114             push @allWidgets => $self;
115            
116             $containers{$self->{CONTAINER}} = $self;
117            
118             $self->{BALLOON} = $self->{MW}->Balloon;
119            
120             # check for Tk::CursorControl
121             $self->{CC} = undef;
122             if ($self->{USECC}) {
123             local $^W = 0; # suppress message from Win32::API
124             eval "require Tk::CursorControl";
125             unless ($@) {
126             # CC is installed. Use it.
127             $self->{CC} = $self->{MW}->CursorControl;
128             }
129             }
130             }
131            
132             sub activebackground {
133             my ($self, $c) = @_;
134            
135             return unless $c; # ignore falses.
136            
137             $self->{ACTIVE_BG} = $c;
138             }
139            
140             sub _packSelf {
141             my $self = shift;
142            
143             my $side = $self->{SIDE};
144             my $fill = 'y';
145             if ($side eq 'top' or $side eq 'bottom') { $fill = 'x' }
146            
147             if ($packIn && $packIn != $self) {
148             my $side = $packIn->{SIDE} =~ /top|bottom/ ? 'left' : 'top';
149            
150             $self->{CONTAINER}->pack(-in => $packIn->{CONTAINER},
151             -side => $side,
152             -anchor => ($fill eq 'x' ? 'w' : 'n'),
153             -expand => 0);
154             $self->{CONTAINER}->raise;
155             $packIn{$self->{CONTAINER}} = $packIn->{CONTAINER};
156             } else {
157             # force a certain look! for now.
158             my $slave = ($self->{MW}->packSlaves)[0];
159            
160             $self->configure(qw/-relief raised -borderwidth 1/);
161             $self->pack(-side => $side, -fill => $fill,
162             $slave ? (-before => $slave) : ()
163             );
164            
165             $self->{CONTAINER}->pack(-in => $self,
166             -anchor => ($fill eq 'x' ? 'w' : 'n'),
167             -expand => 0);
168            
169             $packIn{$self->{CONTAINER}} = $self;
170             }
171             }
172            
173             sub _packEdge {
174             my $self = shift;
175             my $e = shift;
176             my $w = shift;
177            
178             my $s = $self->{SIDE};
179            
180             my ($pack, $pad, $nopad, $fill);
181            
182             if ($s eq 'top' or $s eq 'bottom') {
183             if ($w) {
184             $e->configure(-height => $edgeH, -width => $edgeW);
185             } else {
186             $e->configure(-height => $sepH, -width => $sepW);
187             }
188             $pack = 'left';
189             $pad = '-padx';
190             $nopad = '-pady';
191             $fill = 'y';
192             } else {
193             if ($w) {
194             $e->configure(-height => $edgeW, -width => $edgeH);
195             } else {
196             $e->configure(-height => $sepW, -width => $sepH);
197             }
198            
199             $pack = 'top';
200             $pad = '-pady';
201             $nopad = '-padx';
202             $fill = 'x';
203             }
204            
205             if (exists $self->{SEPARATORS}{$e}) {
206             $e->configure(-cursor => $pack eq 'left' ? 'sb_h_double_arrow' : 'sb_v_double_arrow');
207             $self->{SEPARATORS}{$e}->pack(-side => $pack,
208             -fill => $fill);
209             }
210            
211             $e->pack(-side => $pack, $pad => 5,
212             $nopad => 0, -expand => 0);
213             }
214            
215             sub movable {
216             my ($self, $value) = @_;
217            
218             if (defined $value) {
219             $self->{ISMOVABLE} = $value;
220             my $e = $self->_edge;
221            
222             if ($value) {
223             $e->configure(qw/-cursor fleur/);
224             $self->afterIdle(sub {$self->_enableEdge()});
225             } else {
226             $e->configure(-cursor => undef);
227             $self->_disableEdge($e);
228             }
229             }
230            
231             return $self->{ISMOVABLE};
232             }
233            
234             sub _enableEdge {
235             my ($self) = @_;
236            
237             my $e = $self->_edge;
238             my $hilte = $self->{MW}->Frame(-bg => $self->cget('-indicatorcolor'),
239             -relief => $self->cget('-indicatorrelief'));
240            
241             my $dummy = $self->{MW}->Frame(
242             qw/
243             -borderwidth 2
244             -relief ridge
245             /);
246            
247             $self->{DUMMY} = $dummy;
248            
249             my $drag = 0;
250             #my $floating = 0;
251             my $clone;
252            
253             my @mwSize; # extent of mainwindow.
254            
255             $e->bind('<1>' => sub {
256             $self->{CC}->confine($self->{MW}) if defined $self->{CC};
257             my $geom = $self->{MW}->geometry;
258             my ($rx, $ry) = ($self->{MW}->rootx, $self->{MW}->rooty);
259            
260             if ($geom =~ /(\d+)x(\d+)/) {#\+(\d+)\+(\d+)/) {
261             # @mwSize = ($3, $4, $1 + $3, $2 + $4);
262             @mwSize = ($rx, $ry, $1 + $rx, $2 + $ry);
263             } else {
264             @mwSize = ();
265             }
266            
267             if (!$self->{ISCLONE} && $self->{CLONE}) {
268             $self->{CLONE}->destroy;
269             $self->{CLONE} = $clone = undef;
270             @allWidgets = grep Tk::Exists, @allWidgets;
271             }
272            
273             });
274            
275             $e->bind('' => sub {
276             my ($x, $y) = ($self->pointerx - $self->{MW}->rootx - ceil($e->width /2) - $e->x,
277             $self->pointery - $self->{MW}->rooty - ceil($e->height/2) - $e->y);
278            
279             my ($px, $py) = $self->pointerxy;
280            
281             $dummy = $self->{ISCLONE} ? $self->{CLONE}{DUMMY} : $self->{DUMMY};
282            
283             unless ($drag or $floating) {
284             $drag = 1;
285             $dummy->raise;
286             my $noclone = $self->{ISCLONE} ? $self->{CLONE} : $self;
287             $noclone->packForget;
288             $noclone->{CONTAINER}->pack(-in => $dummy);
289             $noclone->{CONTAINER}->raise;
290             ref($_) eq 'Tk::Frame' && $_->raise for $noclone->{CONTAINER}->packSlaves;
291             }
292             $hilte->placeForget;
293            
294             if ($self->cget('-float') &&
295             (@mwSize and
296             $px < $mwSize[0] or
297             $py < $mwSize[1] or
298             $px > $mwSize[2] or
299             $py > $mwSize[3])) {
300            
301             # we are outside .. switch to toplevel mode.
302             $dummy->placeForget;
303             $floating = 1;
304            
305             unless ($self->{CLONE} || $self->{ISCLONE}) {
306             # clone it.
307             my $clone = $self->{MW}->Toplevel(qw/-relief ridge -borderwidth 2/);
308             $clone->withdraw;
309             $clone->overrideredirect(1);
310             $self->_clone($clone);
311             $self->{CLONE} = $clone;
312             }
313            
314             $clone = $self->{ISCLONE} || $self->{CLONE};
315             $clone->deiconify unless $clone->ismapped;
316             $clone->geometry("+$px+$py");
317            
318             } else {
319             $self->{ISCLONE}->withdraw if $self->{CLONE} && $self->{ISCLONE};
320            
321             $dummy->place('-x' => $x, '-y' => $y);
322             $floating = 0;
323            
324             if (my $newSide = $self->_whereAmI($x, $y)) {
325             # still inside main window.
326             # highlight the close edge.
327             $clone && $clone->ismapped && $clone->withdraw;
328             #$self->{ISCLONE}->withdraw if $self->{CLONE} && $self->{ISCLONE};
329            
330             my ($op, $pp);
331             if ($newSide =~ /top/) {
332             $op = [qw/-height 5/];
333             $pp = [qw/-relx 0 -relwidth 1 -y 0/];
334             } elsif ($newSide =~ /bottom/) {
335             $op = [qw/-height 5/];
336             $pp = [qw/-relx 0 -relwidth 1 -y -5 -rely 1/];
337             } elsif ($newSide =~ /left/) {
338             $op = [qw/-width 5/];
339             $pp = [qw/-x 0 -relheight 1 -y 0/];
340             } elsif ($newSide =~ /right/) {
341             $op = [qw/-width 5/];
342             $pp = [qw/-x -5 -relx 1 -relheight 1 -y 0/];
343             }
344            
345             $hilte->configure(@$op);
346             $hilte->place(@$pp);
347             $hilte->raise;
348             }
349             }
350             });
351            
352             $e->bind('' => sub {
353             my $noclone = $self->{ISCLONE} ? $self->{CLONE} : $self;
354             $noclone->{CC}->free($noclone->{MW}) if defined $noclone->{CC};
355             return unless $drag;
356            
357             $drag = 0;
358             $dummy->placeForget;
359            
360             # forget everything if it's cloned.
361             return if $clone && $clone->ismapped;
362            
363             # destroy the clone.
364             #$clone->destroy;
365            
366             #return unless $self->_whereAmI(1);
367             $noclone->_whereAmI(1);
368             $hilte->placeForget;
369            
370             # repack everything now.
371             my $ec = $noclone->_edge;
372             my @allSlaves = grep {$_ ne $ec} $noclone->{CONTAINER}->packSlaves;
373             $_ ->packForget for $noclone, @allSlaves, $noclone->{CONTAINER};
374            
375             $noclone->_packSelf;
376             $noclone->_packEdge($ec, 1);
377             $noclone->_packWidget($_) for @allSlaves;
378             });
379             }
380            
381             sub _whereAmI {
382             my $self = shift;
383            
384             my $flag = 0;
385             my ($x, $y);
386            
387             if (@_ == 1) {
388             $flag = shift;
389             my $e = $self->_edge;
390             ($x, $y) = ($self->pointerx - $self->{MW}->rootx - ceil($e->width /2) - $e->x,
391             $self->pointery - $self->{MW}->rooty - ceil($e->height/2) - $e->y);
392             } else {
393             ($x, $y) = @_;
394             }
395            
396             my $x2 = $x + $self->{CONTAINER}->width;
397             my $y2 = $y + $self->{CONTAINER}->height;
398            
399             my $w = $self->{MW}->Width;
400             my $h = $self->{MW}->Height;
401            
402             # bound check
403             $x = 1 if $x <= 0;
404             $y = 1 if $y <= 0;
405             $x = $w - 1 if $x >= $w;
406             $y = $h - 1 if $y >= $h;
407            
408             $x2 = 0 if $x2 <= 0;
409             $y2 = 0 if $y2 <= 0;
410             $x2 = $w - 1 if $x2 >= $w;
411             $y2 = $h - 1 if $y2 >= $h;
412            
413             my $dx = 0;
414             my $dy = 0;
415            
416             my $close = $self->cget('-close');
417            
418             if ($x < $close) { $dx = $x }
419             elsif ($w - $x2 < $close) { $dx = $x2 - $w }
420            
421             if ($y < $close) { $dy = $y }
422             elsif ($h - $y2 < $close) { $dy = $y2 - $h }
423            
424             $packIn = '';
425             if ($dx || $dy) {
426             my $newSide;
427             if ($dx && $dy) {
428             # which is closer?
429             if (abs($dx) < abs($dy)) {
430             $newSide = $dx > 0 ? 'left' : 'right';
431             } else {
432             $newSide = $dy > 0 ? 'top' : 'bottom';
433             }
434             } elsif ($dx) {
435             $newSide = $dx > 0 ? 'left' : 'right';
436             } else {
437             $newSide = $dy > 0 ? 'top' : 'bottom';
438             }
439            
440             # make sure we're stickable on that side.
441             return undef unless $self->{STICKY} =~ /$sideToSticky{$newSide}/;
442            
443             $self->{SIDE} = $newSide if $flag;
444             return $newSide;
445             } elsif ($flag) {
446             # check for overlaps.
447             for my $w (@allWidgets) {
448             next if $w == $self;
449            
450             my $x1 = $w->x;
451             my $y1 = $w->y;
452             my $x2 = $x1 + $w->width;
453             my $y2 = $y1 + $w->height;
454            
455             if ($x > $x1 and $y > $y1 and $x < $x2 and $y < $y2) {
456             $packIn = $w;
457             last;
458             }
459             }
460            
461             $self->{SIDE} = $packIn->{SIDE} if $packIn;
462             # if ($packIn) {
463             # $self->{SIDE} = $packIn->{SIDE};
464             # } else {
465             # return undef;
466             # }
467             } else {
468             return undef;
469             }
470            
471             return 1;
472             }
473            
474             sub _disableEdge {
475             my ($self, $e) = @_;
476            
477             $e->bind('' => undef);
478             $e->bind('' => undef);
479             }
480            
481             sub _edge {
482             $_[0]->{EDGE};
483             }
484            
485             sub ToolButton {
486             my $self = shift;
487             my %args = @_;
488            
489             my $type = delete $args{-type} || 'Button';
490            
491             unless ($type eq 'Button' or
492             $type eq 'Checkbutton' or
493             $type eq 'Menubutton' or
494             $type eq 'Radiobutton') {
495            
496             croak "toolbutton can be only 'Button', 'Menubutton', 'Checkbutton', or 'Radiobutton'";
497             }
498            
499             my $m = delete $args{-tip} || '';
500             my $x = delete $args{-accelerator} || '';
501            
502             my $but = $self->{CONTAINER}->$type(%args,
503             $self->{STYLE} ? () : (
504             -relief => 'flat',
505             -borderwidth => 1,
506             ),
507             );
508            
509             $self->_createButtonBindings($but);
510             $self->_configureWidget ($but);
511            
512             push @{$self->{WIDGETS}} => $but;
513             $self->_packWidget($but);
514            
515             $self->{BALLOON}->attach($but, -balloonmsg => $m) if $m;
516             $self->{MW}->bind($x => [$but, 'invoke']) if $x;
517            
518             # change the bind tags.
519             #$but->bindtags([$but, ref($but), $but->toplevel, 'all']);
520            
521             return $but;
522             }
523            
524             sub ToolLabel {
525             my $self = shift;
526            
527             my $l = $self->{CONTAINER}->Label(@_);
528            
529             push @{$self->{WIDGETS}} => $l;
530            
531             $self->_packWidget($l);
532            
533             return $l;
534             }
535            
536             sub ToolEntry {
537             my $self = shift;
538             my %args = @_;
539            
540             my $m = delete $args{-tip} || '';
541             $args{-width} = 5 unless exists $args{-width};
542             my $l = $self->{CONTAINER}->Entry(%args);
543            
544             push @{$self->{WIDGETS}} => $l;
545            
546             $self->_packWidget($l);
547             $self->{BALLOON}->attach($l, -balloonmsg => $m) if $m;
548            
549             return $l;
550             }
551            
552             sub ToolLabEntry {
553             my $self = shift;
554             my %args = @_;
555            
556             require Tk::LabEntry;
557             my $m = delete $args{-tip} || '';
558             $args{-width} = 5 unless exists $args{-width};
559             my $l = $self->{CONTAINER}->LabEntry(%args);
560            
561             push @{$self->{WIDGETS}} => $l;
562            
563             $self->_packWidget($l);
564             $self->{BALLOON}->attach($l, -balloonmsg => $m) if $m;
565            
566             return $l;
567             }
568            
569             sub ToolOptionmenu {
570             my $self = shift;
571             my %args = @_;
572            
573             my $m = delete $args{-tip} || '';
574             my $l = $self->{CONTAINER}->Optionmenu(%args);
575            
576             push @{$self->{WIDGETS}} => $l;
577            
578             $self->_packWidget($l);
579             $self->{BALLOON}->attach($l, -balloonmsg => $m) if $m;
580            
581             return $l;
582             }
583            
584             sub ToolBrowseEntry {
585             my $self = shift;
586             my %args = @_;
587            
588             require Tk::BrowseEntry;
589             my $m = delete $args{-tip} || '';
590             my $l = $self->{CONTAINER}->BrowseEntry(%args);
591            
592             push @{$self->{WIDGETS}} => $l;
593            
594             $self->_packWidget($l);
595             $self->{BALLOON}->attach($l, -balloonmsg => $m) if $m;
596            
597             return $l;
598             }
599            
600             sub separator {
601             my $self = shift;
602             my %args = @_;
603            
604             my $move = 1;
605             $move = $args{-movable} if exists $args{-movable};
606             my $just = $args{-space} || 0;
607            
608             my $f = $self->{CONTAINER}->Frame(-width => $just, -height => 0);
609            
610             my $sep = $self->{CONTAINER}->Frame(qw/
611             -borderwidth 5
612             -relief sunken
613             /);
614            
615             $isDummy{$f} = $self->{SIDE};
616            
617             push @{$self->{WIDGETS}} => $sep;
618             $self->{SEPARATORS}{$sep} = $f;
619             $self->_packWidget($sep);
620            
621             $self->_createSeparatorBindings($sep) if $move;
622            
623             if ($just eq 'right' || $just eq 'bottom') {
624             # just figure out the good width.
625             }
626            
627             return 1;
628             }
629            
630             sub _packWidget {
631             my ($self, $b) = @_;
632            
633             return $self->_packEdge($b) if exists $self->{SEPARATORS}{$b};
634            
635             my ($side, $pad, $nopad) = $self->{SIDE} =~ /^top$|^bottom$/ ?
636             qw/left -padx -pady/ : qw/top -pady -padx/;
637            
638             if (ref($b) eq 'Tk::LabEntry') {
639             $b->configure(-labelPack => [-side => $side]);
640             }
641            
642             my @extra;
643             if (exists $packIn{$b}) {
644             @extra = (-in => $packIn{$b});
645            
646             # repack everything now.
647             my $top = $containers{$b};
648             $top->{SIDE} = $self->{SIDE};
649            
650             my $e = $top->_edge;
651             my @allSlaves = grep {$_ ne $e} $b->packSlaves;
652             $_ ->packForget for @allSlaves;
653            
654             $top->_packEdge($e, 1);
655             $top->_packWidget($_) for @allSlaves;
656             }
657            
658             if (exists $isDummy{$b}) { # swap width/height if we need to.
659             my ($w, $h);
660            
661             if ($side eq 'left' && $isDummy{$b} =~ /left|right/) {
662             $w = 0;
663             $h = $b->height;
664             } elsif ($side eq 'top' && $isDummy{$b} =~ /top|bottom/) {
665             $w = $b->width;
666             $h = 0;
667             }
668            
669             $b->configure(-width => $h, -height => $w) if defined $w;
670             $isDummy{$b} = $self->{SIDE};
671             }
672            
673             $b->pack(-side => $side, $pad => 4, $nopad => 0, @extra);
674             }
675            
676             sub _packWidget_old {
677             my ($self, $b) = @_;
678            
679             return $self->_packEdge($b) if exists $self->{SEPARATORS}{$b};
680            
681             my ($side, $pad, $nopad) = $self->{SIDE} =~ /^top$|^bottom$/ ?
682             qw/left -padx -pady/ : qw/top -pady -padx/;
683            
684             if (ref($b) eq 'Tk::LabEntry') {
685             $b->configure(-labelPack => [-side => $side]);
686             }
687            
688             my @extra;
689             if (exists $packIn{$b}) {
690             @extra = (-in => $packIn{$b});
691            
692             # repack everything now.
693             my $top = $containers{$b};
694             $top->{SIDE} = $self->{SIDE};
695            
696             my $e = $top->_edge;
697             my @allSlaves = grep {$_ ne $e} $b->packSlaves;
698             $_ ->packForget for @allSlaves;
699            
700             $top->_packEdge($e, 1);
701             $top->_packWidget($_) for @allSlaves;
702             }
703            
704             $b->pack(-side => $side, $pad => 4, $nopad => 0, @extra);
705             }
706            
707             sub _configureWidget {
708             my ($self, $w) = @_;
709            
710             $w->configure(-activebackground => $self->{ACTIVE_BG});
711             }
712            
713             sub _createButtonBindings {
714             my ($self, $b) = @_;
715            
716             my $bg = $b->cget('-bg');
717            
718             $b->bind('' => [$b, 'configure', qw/-relief raised/]);
719             $b->bind('' => [$b, 'configure', qw/-relief flat/]);
720             }
721            
722             sub _createSeparatorBindings {
723             my ($self, $s) = @_;
724            
725             my ($ox, $oy);
726            
727             $s->bind('<1>' => sub {
728             $ox = $s->XEvent->x;
729             $oy = $s->XEvent->y;
730             });
731            
732             $s->bind('' => sub {
733             my $x = $s->XEvent->x;
734             my $y = $s->XEvent->y;
735            
736             my $f = $self->{SEPARATORS}{$s};
737            
738             if ($self->{SIDE} =~ /top|bottom/) {
739             my $dx = $x - $ox;
740            
741             my $w = $f->width + $dx;
742             $w = 0 if $w < 0;
743            
744             $f->GeometryRequest($w, $f->height);
745             } else {
746             my $dy = $y - $oy;
747            
748             my $h = $f->height + $dy;
749             $h = 0 if $h < 0;
750            
751             $f->GeometryRequest($f->width, $h);
752             }
753             });
754             }
755            
756             sub Button { goto &ToolButton }
757             sub Label { goto &ToolLabel }
758             sub Entry { goto &ToolEntry }
759             sub LabEntry { goto &ToolLabEntry }
760             sub Optionmenu { goto &ToolOptionmenu }
761             sub BrowseEntry { goto &ToolBrowseEntry }
762            
763             sub _clone {
764             my ($self, $top, $in) = @_;
765            
766             my $new = $top->ToolBar(qw/-side top -cursorcontrol/, $self->{USECC}, ($in ? (-in => $in, -movable => 0) : ()));
767             my $e = $self->_edge;
768            
769             my @allSlaves = grep {$_ ne $e} $self->{CONTAINER}->packSlaves;
770             for my $w (@allSlaves) {
771             my $t = ref $w;
772             $t =~ s/Tk:://;
773            
774             if ($t eq 'Frame' && exists $containers{$w}) { # embedded toolbar
775             my $obj = $containers{$w};
776             $obj->_clone($top, $new);
777             }
778            
779             if ($t eq 'Frame' && exists $self->{SEPARATORS}{$w}) { # separator
780             $new->separator;
781             }
782            
783             my %c = map { $_->[0], $_->[4] || $_->[3] } grep {defined $_->[4] || $_->[3] } grep @$_ > 2, $w->configure;
784             delete $c{$_} for qw/-offset -class -tile -visual -colormap -labelPack/;
785            
786             if ($t =~ /.button/) {
787             $new->Button(-type => $t,
788             %c);
789             } else {
790             $new->$t(%c);
791             }
792             }
793            
794             $new ->{MW} = $self->{MW};
795             $new ->{CLONE} = $self;
796             $new ->{ISCLONE} = $top;
797             $self->{ISCLONE} = 0;
798             }
799            
800             __END__