"Fossies" - the Fresh Open Source Software Archive

Member "Tk-804.036/demos/demos/widget_lib/balloon.pl" (15 Nov 2013, 5700 Bytes) of package /linux/misc/Tk-804.036.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 # Balloon, pop up help window when mouse lingers over widget.
    2 
    3 use Tk;
    4 use English;
    5 use Carp;
    6 
    7 use Tk::Frame;
    8 use Tk::Balloon;
    9 
   10 my $lmsg = "";
   11 
   12 my $top = MainWindow->new;
   13 my $f = $top->Frame;
   14 
   15 # status bar widget
   16 my $status = $top->Label(-width => 60, -relief => "sunken", -bd => 1, -anchor => 'w');
   17 $status->pack(-side => "bottom", -fill => "y", -padx => 2, -pady => 1);
   18 
   19 # create the widgets to be explained
   20 my $mb = $top->Menubutton(-relief => 'raised',
   21               -text => 'Menu button');
   22 my $xxx = 0;
   23 $mb->checkbutton(-label => 'checkbutton',
   24          -variable => \$xxx);
   25 $mb->cascade(-label => 'cascade entry');
   26 my $menu = $mb->cget(-menu);
   27 my $cm = $menu->Menu(-tearoff => 0);
   28 $mb->entryconfigure('cascade entry', -menu => $cm);
   29 $cm->command(-label => 'first');
   30 $cm->command(-label => 'second');
   31 $mb->separator;
   32 $mb->command(-label => 'Close',
   33          -command => sub {$top->destroy;});
   34 
   35 my $tm = $top->Menu(-title => "Balloon menu");
   36 $tm->cascade(-label => "Toplevel menu", -menu => $menu);
   37 $top->configure(-menu => $tm);
   38 
   39 my $b1 = $top->Button(-text => "Something Unexpected",
   40               -command => sub {$top->destroy;});
   41 my $b2 = $top->Button(-text => "Something Else Unexpected");
   42 $b2->configure(-command => sub {$b2->destroy;});
   43 
   44 # Pack the created widgets:
   45 $mb->pack(-side => "top", -expand => 1);
   46 $b1->pack(-side => "top", -expand => 1);
   47 $b2->pack(-side => "top", -expand => 1);
   48 
   49 my $t = $top->Text(-height => 10, -cursor => 'top_left_arrow')->pack;
   50 $t->insert('end',<<END);
   51 
   52 Move the mouse cursor over the buttons above and let it linger.
   53 A message will be displayed in status box below and a descriptive
   54 balloon will appear.  The top button is a menu button which has
   55 different messages set for each menu entry.  This text widget has
   56 a balloon attached to it which will change depending on which word
   57 the mouse is over.
   58 
   59 END
   60 
   61 my $clbf = $top->Frame->pack;
   62 my $cf   = $clbf->Frame->pack(-side => "left");
   63 
   64 my $c1 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8);
   65 my $c2 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8);
   66 my $id = $c1->create('text', 10, 10,
   67              -anchor => 'nw',
   68              -text => "This is a canvas.  You can also attach\nballoons to specific items in a canvas");
   69 $c1->create('rectangle', 40, 60, 80, 80,
   70         -fill => 'red',
   71         -tags => 'rectangle',);
   72 $c1->create('oval', 100, 50, 140, 90,
   73         -fill => 'blue',
   74         -tags => 'circle',);
   75 $c2->create('text', 10, 10,
   76         -anchor => 'nw',
   77         -text => "Or you can attach the balloon\nto the canvas as a whole.");
   78 
   79 my $lb = $clbf->Listbox->pack(-side => "left");
   80 $lb->insert(qw/end one two three four/);
   81 
   82 # create the balloon widget
   83 my $b = $top->Balloon(-statusbar => $status);
   84 
   85 $b->attach($mb,
   86        -msg => 'Press and hold this button to see the menu.');
   87 $b->attach($menu,
   88        #-state => 'status',
   89        -balloonposition => 'mouse',
   90        -msg => ['Use this to tear off the menu.',
   91             'This is a checkbox entry.',
   92             'cascade', # Cascade entry (ignored by Balloon)
   93             'separator', # Separator: never active so no message will be displayed for this entry.
   94             'This is a command entry - it will close this window.',
   95            ],
   96       );
   97 $b->attach($cm,
   98        -msg => 'This balloon is attached to the cascade menu, not it\'s entries',
   99        #-statusmsg => 'msg cm',
  100        #-balloonmsg => 'cm msg.',
  101       );
  102 $b->attach($b1,
  103        -balloonmsg => "Close Window",
  104        -statusmsg => "Press this button to close this window");
  105 $b->attach($b2,
  106        -balloonmsg => "Self-destruct\nButton",
  107        -statusmsg => "Press this button and it will get rid of itself");
  108 
  109 my $msg = '';
  110 my @word = ('', '');  # Indicies surrounding the current word.
  111 my @last = ('', '');  # Same for last word.
  112 $b->attach($t, -msg => \$msg,
  113        -balloonposition => 'mouse',  # Not really used since the postcommand returns the real position.
  114        -postcommand => sub { if ($word[0] eq $word[1]) {
  115                    # No word under mouse - don't post the balloon.
  116                    0;
  117                  } else {
  118                    # Have a word under mouse - change the message:
  119                    my $word = $t->get($word[0], $word[1]);
  120                    # Skip it if it contains non-word chars:
  121                    return 0 if $word =~ /\W/;
  122                    $msg = "The word under the mouse is: $word";
  123                    $t->tag('add', 'sel', $word[0] => $word[1]);
  124                    # Find a good place to put the balloon (right below the last char in the word):
  125                    my $i = $t->index("$word[1] - 1 chars");
  126                    my @p = $t->bbox($i);
  127                    my $x = $t->rootx + $p[0] + $p[2] - 4;
  128                    my $y = $t->rooty + $p[1] + $p[3] + 2;
  129                    "$x,$y";
  130                  }
  131                    },
  132        -motioncommand => sub { my $x = $t->pointerx - $t->rootx;
  133                    my $y = $t->pointery - $t->rooty;
  134                    @word = ($t->index("\@$x,$y wordstart"), $t->index("\@$x,$y wordend"));
  135                    if ($word[0] eq $last[0] and $word[1] eq $last[1]) {
  136                      # Same word - don't cancel the balloon.
  137                      0;
  138                    } else {
  139                      # New word under mouse - cancel it so a new balloon will be posted.
  140                      $t->SelectionClear;
  141                      @last = @word;
  142                      1;
  143                    }
  144                  },
  145       );
  146 $b->attach($c1,
  147        -balloonposition => 'mouse',
  148        -msg => {'rectangle' => 'You are over the red rectangle right now.',
  149             $id => 'You are over the text right now.',
  150             'circle' => 'You are over the blue circle right now.',
  151            });
  152 $b->attach($c2,
  153        -msg => 'This balloon is attached to the canvas itself.',
  154       );
  155 
  156 $b->attach($lb,
  157        -balloonposition => 'mouse',
  158        -msg => [qw/1 2 3 4/],
  159       );
  160 
  161 # As $b is a child of $top it is destroyed when $top is destroyed.
  162 # Balloon.pm now registers a handler for that, and so
  163 # this hackery is no longer required (and did not actually work
  164 # before).
  165 # $top->OnDestroy(sub { $b->destroy; });
  166 
  167 MainLoop;
  168