New widget 
Author Message
 New widget

--Message-Boundary-12228
Content-type: text/plain; charset=US-ASCII
Content-transfer-encoding: 7BIT
Content-description: Mail message body

Hi everyone. In preparation for Tk-DKW-0.02, I created another
widget. It's a detachable/dockable frame. If you are interested in
experimenting with it, place the attached module Tearoff.pm in your
perl lib/site/Tk directory and run the attached example tearoff.pl.


Damion K. Wilson

--Message-Boundary-12228
Content-type: text/plain; charset=US-ASCII
Content-transfer-encoding: 7BIT
Content-description: Text from file 'tearoff.pl'

#! /usr/bin/perl

use Tk::Tearoff;
use Tk::Frame;
use Tk::Text;
use Tk;

my $l_MainWindow = MainWindow->new();

my $l_Window1 = $l_MainWindow->Tearoff
   (
    -relief => 'raised',
    -borderwidth => 1,
   );

my $l_Window3 = $l_MainWindow->Tearoff
  (
   -relief => 'raised',
   -borderwidth => 1,
  );

my $l_Window2 = $l_MainWindow->Frame
   (
    -relief => 'raised',
    -borderwidth => 2,
   );

$l_Window1->Label (-text => 'This is the tearoff')->pack();
$l_Window2->Text (-width => 80)->pack (-expand => true, -fill => both, -padx => 6, -pady => 6);
$l_Window3->Label (-text => 'This is another tearoff')->pack(-side => 'left', -anchor => 'nw');
$l_Window3->Entry ()->pack(-side => 'left', -anchor => 'nw');

$l_Window1->pack (-expand => false, -fill => x, -anchor => nw);
$l_Window3->pack (-expand => false, -fill => x, -anchor => nw);
$l_Window2->pack (-expand => true, -fill => both, -anchor => nw);

Tk::MainLoop();
--Message-Boundary-12228
Content-type: text/plain; charset=US-ASCII
Content-transfer-encoding: 7BIT
Content-description: Text from file 'Tearoff.pm'

package Tk::Tearoff;

use Tk;
use Tk::Frame;


use strict;

$VERSION = '1.01';

Tk::Widget->Construct ('Tearoff');

sub DESTROY
   {
    for (my $l_Index = 0; $l_Index <= $#Tk::Tearoff::g_ObjectList; ++$l_Index)
       {
        next unless ($Tk::Tearoff::g_ObjectList [$l_Index] eq $_[0]);

       }

    $_[0]->{m_Tearoff}->Destroy() if (defined ($_[0]->{m_Tearoff}));
   }

sub Populate
   {
    my $this = shift;

    $this->{m_Tearoff} = $this->ConstructTearoff();
    $this->bind ('<Expose>' => sub {$this->RefreshDropZone();});

    return $this;
   }

sub ConstructTearoff
   {
    my $this = shift;

    my $l_TopLevel = $this->toplevel()->Toplevel
       (
        '-relief' => 'raised',
        '-borderwidth' => 1,
       );

    my $l_DragButton = $l_TopLevel->Component
       (
        'Frame' => 'DragButton',
        '-relief' => 'flat',
        '-borderwidth' => 1,
       );

    my $l_ClientFrame = $l_TopLevel->Frame
       (
        '-relief' => 'raised',
        '-borderwidth' => 1,
       );

    $l_DragButton->pack
       (
        '-expand' => 'false',
        '-fill' => 'both',
        '-anchor' => 'nw',
        '-side' => 'left',
       );

    $l_ClientFrame->pack
       (
        '-expand' => 'true',
        '-fill' => 'both',
        '-anchor' => 'nw',
        '-side' => 'left',
       );

    for (my $l_Index = 0; $l_Index < 2; ++$l_Index)
       {
        my $l_Widget = $l_DragButton->Frame
           (
            '-background' => 'white',
            '-borderwidth' => 2,
            '-relief' => 'raised',
            '-width' => 2,
           );

        $l_Widget->bind ('<ButtonRelease-1>' => sub {$this->DragButtonRelease ($l_TopLevel);});
        $l_Widget->bind ('<ButtonPress-1>' => sub {$this->DragButtonPress ($l_TopLevel);});
        $l_Widget->bind ('<B1-Motion>' => sub {$this->DragButtonMotion ($l_TopLevel);});

        $l_Widget->pack
           (
            '-expand' => 'true',
            '-fill' => 'y',
            '-anchor' => 'center',
            '-side' => 'left',
            '-padx' => 1,
            '-pady' => 0,
           );
       }

    $l_DragButton->bind ('<ButtonRelease-1>' => sub {$this->DragButtonRelease ($l_TopLevel);});
    $l_DragButton->bind ('<ButtonPress-1>' => sub {$this->DragButtonPress ($l_TopLevel);});
    $l_DragButton->bind ('<B1-Motion>' => sub {$this->DragButtonMotion ($l_TopLevel);});

    $this->Delegates ('Construct' => $l_ClientFrame);

    $l_TopLevel->overrideredirect (1);
    $l_TopLevel->raise();

    $this->Dock ($l_TopLevel);

    return $l_TopLevel;
   }

sub Dock
   {

    if (! defined ($this->{m_Tearoff}) && defined ($p_TopLevel))
       {
        $this->{m_BorderWidth} = $this->cget ('-borderwidth');
        $this->GeometryRequest ($this->width(), (split (/[x+]/, $p_TopLevel->geometry()))[1]);
        $p_TopLevel->geometry ('+'.$this->rootx().'+'.$this->rooty());
        $this->configure ('-borderwidth' => 0);
        $this->{m_Tearoff} = $p_TopLevel;
        $p_TopLevel->{m_Parent} = $this;
        $p_TopLevel->{m_Undocked} = 0;
       }
   }

sub Undock
   {

    if (defined ($p_TopLevel->{m_Parent}))
       {
        $p_TopLevel->{m_Parent}->configure ('-borderwidth' => $this->{m_BorderWidth});
        $p_TopLevel->{m_Parent}->{m_Tearoff} = undef;
        $p_TopLevel->{m_Parent} = undef;
        $p_TopLevel->{m_Undocked} = 1;
       }
   }

sub DragButtonPress
   {

    my $l_DragButton = $p_TopLevel->Subwidget ('DragButton');

    if (defined ($p_TopLevel->{m_Parent}))
       {
        $p_TopLevel->{m_Parent}->GeometryRequest ($p_TopLevel->{m_Parent}->reqwidth(), 0);
        $p_TopLevel->{m_Parent}->Undock ($p_TopLevel);
        $p_TopLevel->geometry ($p_TopLevel->{m_Width}.'x'.$p_TopLevel->height());
       }

    $p_TopLevel->{m_OffsetX} = $l_DragButton->pointerx() - $l_DragButton->rootx();
    $p_TopLevel->{m_OffsetY} = $l_DragButton->pointery() - $l_DragButton->rooty();
    $p_TopLevel->raise();
   }

sub DragButtonMotion
   {

    my $l_DragButton = $p_TopLevel->Subwidget ('DragButton');

    my $l_Found = 0;

    if (! defined ($p_TopLevel->{m_Parent}))
       {
        $p_TopLevel->geometry
           (
            '+'.($l_DragButton->pointerx() - $p_TopLevel->{m_OffsetX}).
            '+'.($l_DragButton->pointery() - $p_TopLevel->{m_OffsetY})
           );
       }

    return if ($p_TopLevel->{m_Undocked});

    for (my $l_Index = 0; $l_Index <= $#Tk::Tearoff::g_ObjectList; ++$l_Index)
       {
        $l_Found = 1 if ($Tk::Tearoff::g_ObjectList [$l_Index]->{m_Tearoff} eq $p_TopLevel);
       }

    return if ($l_Found);

    for (my $l_Index = 0; $l_Index <= $#Tk::Tearoff::g_ObjectList; ++$l_Index)
       {
        my $l_DropZone = $Tk::Tearoff::g_ObjectList [$l_Index];

        ($l_DropZone->Dock ($p_TopLevel), last) if
           (
            $l_DragButton->pointery() >= $l_DropZone->rooty() - 5 &&
            $l_DragButton->pointery() <= $l_DropZone->rooty() + 5 &&
            $l_DragButton->pointerx() >= $l_DropZone->rootx() &&
            $l_DragButton->pointerx() <= $l_DropZone->rootx() + $l_DropZone->width()
           );
       }
   }

sub DragButtonRelease
   {
    $_[1]->{m_Undocked} = 0;
   }

sub RefreshDropZone
   {
    my $this = shift;

    my $l_TopLevel = $this->{m_Tearoff};

    return unless (defined ($l_TopLevel) && $l_TopLevel->IsMapped());

    $l_TopLevel->{m_Width} = $l_TopLevel->width() unless (defined ($l_TopLevel->{m_Width}));
    $l_TopLevel->{m_Undocked} = 0;
    $l_TopLevel->raise();

    $l_TopLevel->geometry
       (
        $this->width().'x'.
        (split (/[x+]/, $l_TopLevel->geometry()))[1].'+'.
        $this->rootx().'+'.
        $this->rooty()
       );

    $this->GeometryRequest
       (
        $this->width(),
        (split (/[x+]/, $l_TopLevel->geometry()))[1]
       );
   }

1;
--Message-Boundary-12228--
==========================================================================
This message was posted through the Stanford campus mailing list
server.  If you wish to unsubscribe from this mailing list, send the



Thu, 10 May 2001 03:00:00 GMT  
 New widget

Quote:

> Hi everyone. In preparation for Tk-DKW-0.02, I created another
> widget. It's a detachable/dockable frame. If you are interested in
> experimenting with it, place the attached module Tearoff.pm in your
> perl lib/site/Tk directory and run the attached example tearoff.pl.

Interesting... what do you use a widget like this for?  Ok, now for
my observations:

1) The overrideredirect(1) has an interesting affect with Linix/fvwm - the
   torn-off toplevels appear in every virtual window, overlay whatever
   widgets happen to be there.  Not sure you can do anything about this.

2) use strict/-w shows this:

Unquoted string "true" may clash with future reserved word at ./frog line 28.
Unquoted string "both" may clash with future reserved word at ./frog line 28.
Unquoted string "false" may clash with future reserved word at ./frog line 32.
Unquoted string "x" may clash with future reserved word at ./frog line 32.
Unquoted string "nw" may clash with future reserved word at ./frog line 32.
Unquoted string "false" may clash with future reserved word at ./frog line 33.
Unquoted string "x" may clash with future reserved word at ./frog line 33.
Unquoted string "nw" may clash with future reserved word at ./frog line 33.
Unquoted string "true" may clash with future reserved word at ./frog line 34.
Unquoted string "both" may clash with future reserved word at ./frog line 34.
Unquoted string "nw" may clash with future reserved word at ./frog line 34.
Use of uninitialized value at /usr/lib/perl5/site_perl/5.005/Tk/Tearoff.pm line 185.
Use of uninitialized value at /usr/lib/perl5/site_perl/5.005/Tk/Tearoff.pm line 185.
Use of uninitialized value at /usr/lib/perl5/site_perl/5.005/Tk/Tearoff.pm line 185.
Use of uninitialized value at /usr/lib/perl5/site_perl/5.005/Tk/Tearoff.pm line 185.
Use of uninitialized value at /usr/lib/perl5/site_perl/5.005/Tk/Tearoff.pm line 185.
Use of uninitialized value at /usr/lib/perl5/site_perl/5.005/Tk/Tearoff.pm line 185.
Use of uninitialized value during global destruction.
Use of uninitialized value during global destruction.
Use of uninitialized value during global destruction.

Ignoring the test code, this patch mostly fixes above:

*** Tearoff.pm.orig     Sun Nov 22 14:33:51 1998
--- Tearoff.pm  Sun Nov 22 14:32:04 1998
***************
*** 9,15 ****

  $VERSION = '1.01';

  Tk::Widget->Construct ('Tearoff');

--- 9,15 ----

  $VERSION = '1.01';

! use base qw (Tk::Frame Tk::Derived Tk::Widget);

  Tk::Widget->Construct ('Tearoff');

***************
*** 19,29 ****
     {
      for (my $l_Index = 0; $l_Index <= $#Tk::Tearoff::g_ObjectList; ++$l_Index)
         {
          next unless ($Tk::Tearoff::g_ObjectList [$l_Index] eq $_[0]);

         }

!     $_[0]->{m_Tearoff}->Destroy() if (defined ($_[0]->{m_Tearoff}));
     }

  sub Populate
--- 19,30 ----
     {
      for (my $l_Index = 0; $l_Index <= $#Tk::Tearoff::g_ObjectList; ++$l_Index)
         {
+       next unless defined $Tk::Tearoff::g_ObjectList [$l_Index]->{m_Tearoff};
          next unless ($Tk::Tearoff::g_ObjectList [$l_Index] eq $_[0]);

         }

!     $_[0]->{m_Tearoff}->destroy() if (defined ($_[0]->{m_Tearoff}));
     }

  sub Populate
***************
*** 182,188 ****

      for (my $l_Index = 0; $l_Index <= $#Tk::Tearoff::g_ObjectList; ++$l_Index)
         {
!       $l_Found = 1 if ($Tk::Tearoff::g_ObjectList [$l_Index]->{m_Tearoff} eq $p_TopLevel);
         }

      return if ($l_Found);
--- 183,190 ----

      for (my $l_Index = 0; $l_Index <= $#Tk::Tearoff::g_ObjectList; ++$l_Index)
         {
!       next unless defined $Tk::Tearoff::g_ObjectList [$l_Index]->{m_Tearoff};
!       $l_Found = 1 if ($Tk::Tearoff::g_ObjectList [$l_Index]->{m_Tearoff} eq $p_TopLevel);
         }

      return if ($l_Found);

3) Two things to note about above patch:

        a) Proper way to define ISA method lookup is via "use base".
        b) DESTROY is problematic: it calls Destroy(), but I think you mean destroy().  But you can't
       really use destroy() because Tk state is indeterminate - perhaps you can use OnDestroy()
       instead.
==========================================================================
This message was posted through the Stanford campus mailing list
server.  If you wish to unsubscribe from this mailing list, send the



Thu, 10 May 2001 03:00:00 GMT  
 New widget

Quote:



> >! use base qw (Tk::Frame Tk::Derived Tk::Widget);

> use base qw(Tk::Frame);

> Should be sufficient, a Frame ISA Tk::Derived and a Tk::Widget already.

True.
==========================================================================
This message was posted through the Stanford campus mailing list
server.  If you wish to unsubscribe from this mailing list, send the



Fri, 11 May 2001 03:00:00 GMT  
 
 [ 3 post ] 

 Relevant Pages 

1. listbox, a Tlistbox, and new widgets

2. Creating a new widget

3. Tips on new widget intergration

4. New widget: Tk::LockDisplay

5. how to create new widgets ?

6. new widget: Tk::XMLViewer

7. New widgets and method arguments

8. How do I track down a coredump in my new widget

9. creating new widget

10. New widgets on CPAN

11. Newer version of Enhanced Text widget available

12. RFC: Namespace for new module (tab widgets in HTML)

 

 
Powered by phpBB® Forum Software