http://qs321.pair.com?node_id=1196827


in reply to Re: want way to drag tk window
in thread want way to drag tk window

Very nice tybalt89!

One suggestion I'd offer is to trap the '<Motion>' event as well, to see the window move any time mouse button 1 is down (not just the final release).

You can do that with these minor modifications to your solution:

#!/usr/bin/perl # http://perlmonks.org/?node_id=1196818 use strict; use warnings; use Tk; # golux: flag to detect mouse button 1 pressed my $b_mouse1 = 0; sub xy { $_[0]->XEvent->x, $_[0]->XEvent->y } my $mw = MainWindow->new; $mw->overrideredirect(1); $mw->Label( -text => 'Press 1, Move, then Release in green Canvas to move window +', )->pack(-fill => 'x'); my $c = $mw->Canvas(-width => 500, -height => 400, -bg => 'green', )->pack; $c->Tk::bind('<1>' => \&leftdown); $c->Tk::bind('<Motion>' => \&motion); # golux: also detect Moti +on $c->Tk::bind('<ButtonRelease-1>' => \&leftup); $mw->Button(-text => 'Exit', -command => sub { $mw->destroy }, )->pack(-fill => 'x'); MainLoop; my ($startx, $starty); sub leftup { # golux: moved the "heavy lifting" into subroutine motion(); the # only thing we need do here is clear the mouse button 1 down flag. $b_mouse1 = 0; } sub leftdown { $b_mouse1 = 1; ($startx, $starty) = &xy; } sub motion { $b_mouse1 or return; my $oldposition = $mw->geometry; my ($endx, $endy) = &xy; my $deltax = $endx - $startx; my $deltay = $endy - $starty; # golux: Not enough to look for \d+, we need to look for [-\d]+, s +ince # the (X,Y) coordinates can also be negative my $newposition = $oldposition =~ s/\+\K([-\d]+)\+([-\d]+)$/ ($1 + $deltax) . '+' . ($2 + $deltay) / +er; $mw->geometry( $newposition ); print "$newposition\n"; }

Instead of moving the window at the end, this moves it any time motion is detected; the only thing needed when mouse button 1 is released is to clear the flag $b_mouse1.

I should elaborate on one thing -- when I tested this (in Windows) I noticed that dragging the window too far up or left caused it to become "stuck". The reason turned out that the one (or both) of the (X, Y) coordinates were negative, which needed to be checked for in your regex to overcome that problem.

say  substr+lc crypt(qw $i3 SI$),4,5

Replies are listed 'Best First'.
Re^3: want way to drag tk window
by redss (Monk) on Aug 06, 2017 at 00:07 UTC
    Awesome, thanks to both of you!

    I should mention, the code works on linux but not windows, I get a syntax error only on windows, strange:

    Unrecognized escape \K passed through at c:\t\junk32.pl line 58. Bareword found where operator expected at c:\t\junk32.pl line 58, near + "s/\+\K([-\d]+)\+([-\d]+)$/ ($1 + $deltax) . '+' . ($2 + $deltay) /e +r" syntax error at c:\t\junk32.pl line 58, near "s/\+\K([-\d]+)\+([-\d]+) +$/ ($1 + $deltax) . '+' . ($2 + $deltay) /er"

      Here's a version without both \K and the /r option to the s///.
      It should run on older perls.

      It also uses B1-Motion to avoid an extra flag.

      #!/usr/bin/perl # http://perlmonks.org/?node_id=1196818 use strict; use warnings; use Tk; sub xy { $_[0]->XEvent->x, $_[0]->XEvent->y } my $mw = MainWindow->new; $mw->overrideredirect(1); $mw->Label( -text => 'Press 1, Move, then Release in green Canvas to move window +', )->pack(-fill => 'x'); my $c = $mw->Canvas(-width => 500, -height => 400, -bg => 'green', )->pack; $c->Tk::bind('<1>' => \&leftdown); $c->Tk::bind('<B1-Motion>' => \&leftmotion); $mw->Button(-text => 'Exit', -command => sub { $mw->destroy }, )->pack(-fill => 'x'); MainLoop; my ($startx, $starty); sub leftmotion { my ($endx, $endy) = &xy; my $deltax = $endx - $startx; my $deltay = $endy - $starty; my ($size, $x, $y) = split /\+/, $mw->geometry; $mw->geometry( "$size+" . ($x + $deltax) . "+" . ($y + $deltay) ); } sub leftdown { ($startx, $starty) = &xy; }
      Try, instead of:
      my $newposition = $oldposition =~ s/\+\K([-\d]+)\+([-\d]+)$/ ($1 + $deltax) . '+' . ($2 + $deltay) / +er;
      doing this:
      $oldposition =~ /^(\d+)x(\d+)\+?([-\d]+)\+?([-\d]+)/; my ($newx, $newy) = ($3 + $deltax, $4 + $deltay); my $newposition = "${1}x${2}+${newx}+${newy}"
      say  substr+lc crypt(qw $i3 SI$),4,5

      Your Windows perl is older. \K is a moderately more recent feature.