view release on metacpan or  search on metacpan

CursorControl.pm  view on Meta::CPAN

package Tk::CursorControl;

require 5.005_62;
use Tk 800.015;
use Carp;
use strict;

$Tk::CursorControl::VERSION = '0.4';

my $AlreadyInit   = 0;
my $CurrentObject = 0;
my $Main;

#Create Aliases to some public methods.
*jail = \&confine;
*free = \&release;
*Show = \&show;

Construct Tk::Widget 'CursorControl';

sub new {
  my ( $me, $parent ) = @_;
  my $class = ref($me) || $me;
  my $self = {};
  bless $self => $class;

  # provide access to class data
  $self->{_Init}       = \$AlreadyInit;
  $self->{_CurrentObj} = \$CurrentObject;

  # set MainWindow reference in 'accessible' class data
  $Main = $parent->MainWindow;
  $parent->OnDestroy( sub { $self->DESTROY } );
  $self->{MAIN} = \$Main if ( defined $Main );

  if ( ${ $self->{_Init} } == 0 ) {
    ++${ $self->{_Init} };
    $self->_init;
    ${ $self->{_CurrentObj} } =
      $self;    #store object in case user tries to create two!
    return $self;
  }
  else {
    ++${ $self->{_Init} };    # DESTROY will be called, so increment anyway
        # These error messages are now suppressed - JD October 13, 2003
        # Thanks for the suggestion Ala.
    ### carp "A $class object has ALREADY been created !";
    ### carp "The object returned is the original object for $class";
   # This means that either a module already called Tk::CursorControl on behalf
   # of the user (i.e. via a 'use SomeModule' where the code within SomeModule
   # creates a Tk::CursorControl object ---OR--- the programmer didn't read the
   # documentation and tried to create two or more CursorControl objects for one
   # MainWindow.
    return ${ $self->{_CurrentObj} };    #return ORIGINALLY created object
  }
}

# For erroneous understanding of this Class!
sub _errmsg { croak "You cannot $_[1] a ", ref( $_[0] ); }

########## Public NON-methods ##########
# Just in case someone treats this like a Tk widget
# Override geometry managers

sub pack      { $_[0]->_errmsg('pack') }
sub grid      { $_[0]->_errmsg('grid') }
sub form      { $_[0]->_errmsg('form') }
sub place     { $_[0]->_errmsg('place') }
sub configure { $_[0]->_errmsg('configure') }
sub cget      { $_[0]->_errmsg('cget') }

########## Public Methods ##########
sub confine {
  my ( $self, $widget ) = @_;
  unless ( defined $widget ) {
    carp "\$cursor->confine(\$widget)";
    return;
  }

  #free the cursor if already confined elsewhere
  $self->release if ( $self->{Confined} );

  #does the widget exist? is it mapped?
  return unless ( $self->_check($widget) );