view release on metacpan or  search on metacpan

lib/Tcl/pTk/Widget.pm  view on Meta::CPAN

 $mw->bind($class,'<Shift-4>',      ['xview','scroll',-1,'units']);
 $mw->bind($class,'<Shift-5>',      ['xview','scroll',1,'units']);
}

sub YMouseWheelBind
{
 my ($mw,$class) = @_;
 # <4> and <5> are how mousewheel looks on X
 $mw->bind($class,'<4>',         ['yview','scroll',-1,'units']);
 $mw->bind($class,'<5>',         ['yview','scroll',1,'units']);
}

sub YscrollBind
{
 my ($mw,$class) = @_;
 $mw->PriorNextBind($class);
 $mw->bind($class,'<Up>',       ['yview','scroll',-1,'units']);
 $mw->bind($class,'<Down>',     ['yview','scroll',1,'units']);
 $mw->YMouseWheelBind($class);
}

sub XYscrollBind
{
 my ($mw,$class) = @_;
 $mw->YscrollBind($class);
 $mw->XscrollBind($class);
 # <4> and <5> are how mousewheel looks on X
}

sub MouseWheelBind
{
 my($mw,$class) = @_;

 # The MouseWheel will typically only fire on Windows and macOS.
 # However, one could use the "event generate" command to produce
 # MouseWheel events on other platforms.

 $mw->bind($class, '<MouseWheel>',
    $mw->windowingsystem eq 'aqua'
	    ?  [ sub { $_[0]->yview('scroll',-($_[1]),'units') }, Tcl::pTk::Ev("D")]
	    :  [ sub { $_[0]->yview('scroll',-int(($_[1]/120)),'units') }, Tcl::pTk::Ev("D")]);

 if ($mw->windowingsystem eq 'x11')
  {
   # Support for mousewheels on Linux/Unix commonly comes through mapping
   # the wheel to the extended buttons.  If you have a mousewheel, find
   # Linux configuration info at:
   #   http://linuxreviews.org/howtos/xfree/mouse/
   $mw->bind($class, '<4>',
		 sub { $_[0]->yview('scroll', -3, 'units')
			   unless $Tk::strictMotif;
		   });
   $mw->bind($class, '<5>',
		 sub { $_[0]->yview('scroll', 3, 'units')
			   unless $Tk::strictMotif;
		   });
  }
}

# Clipboard functions defined in perl/tk
sub clipboardClear{
        my $self = shift;
        $self->call('clipboard', 'clear', @_);
}
sub clipboardAppend{
        my $self = shift;
        $self->call('clipboard', 'append', @_);
}
sub clipboardGet{
        my $self = shift;
        $self->call('clipboard', 'get', @_);
}


# Method to get the patchlevel of the tcl we are using
sub tclPatchlevel{
        my $self = shift;
        return $self->interp->icall('info', 'patchlevel');
}

# Method to get the version of the tcl we are using
sub tclVersion{
        my $self = shift;
        return $self->interp->icall('info', 'tclversion');
}

# Pixmap: Alias for the Photo method
# There is no direct Pixmap widget in Tcl/Tk (like perl/tk), however the Photo widget
#   works the same way.
sub Pixmap{
        my $self = shift;
        $self->Photo(@_);
}

sub DESTROY {}			# do not let AUTOLOAD catch this method

#
# Let Tcl/Tk process required method via AUTOLOAD mechanism
#

# %lists hash holds names of auto-wrapped tcl/tk methods that should return *lists* of values
# (other auto-wrapped methods not listed here are expected to return single value)
#  This is a global list applicable for Tcl::pTk::Widget and subclasses. The
#   _retListContext method can be overridden in subclasses to provide a per-subclass
#   way to specify list-context for auto-wrapped methods
my %lists = map {$_=>1} qw(
    bbox configure dlineinfo dump
    markNames tagBind
    windowNames
    windowConfigure
    formInfo formSlaves
    find
    get
    gettags
    pointerxy
    infoChildren
    itemconfigure
    imageNames
    imageConfigure
    tagNames
    tagRanges
    tagConfigure
    xview
    yview
    coords
    border
    infoBbox
    infoSelection
    pages
    pageconfigure
);