## ------------------------------------------------------------------------
## Widget package, responsible for all Tcl/Tk widgets and any other widgets
## Widgets are blessed to this package or to its sub-packages
## such as Tcl:Tk::Widget::Button, which ISA-Tcl::pTk::Widget
##

package Tcl::pTk::Widget;

our ($VERSION) = ('0.94');

use IO::Handle; 

use Class::ISA;  # Used for finding the base class of a derived widget
use Tcl::pTk::Callback;
use Tcl::pTk::MegaWidget;
use Tcl::pTk::Derived;
use Tcl::pTk::Trace;
use Tcl::pTk::Frame;
use Tcl::pTk::HList;
use Tcl::pTk::Text;
use Tcl::pTk::Entry;
use Tcl::pTk::Photo;
use Tcl::pTk::Bitmap;
use Tcl::pTk::XEvent;  # Limited XEvent support
use Tcl::pTk::Font;

use Scalar::Util (qw /blessed/); # Used only for it's blessed function

# Setup camel-case commands for pack, and the font commands
use Tcl::pTk::Submethods(
                    'pack'  => [qw(configure forget info propagate slaves)],
                    'place'  => [qw(configure forget info  slaves)],
                    'font'  => [qw(actual configure create delete families measure metrics names )],
                    'form'  => [qw(check configure forget grid info slaves)],
                  );


use strict;

# Generate tk methods (like $widget->appname, which mapps to 'tk appname' in tcl/tk
Direct2 Tcl::pTk::Submethods (
   'tk'   => [qw(appname caret scaling useinputmethods windowingsystem)],
   );

# command for optionAdd, optionClear, etc.
Direct3 Tcl::pTk::Submethods (
   'option'    =>  [qw(add clear readfile)]
   ); 

our ($bindActive);  # flag = 1 if we are in a binding (used in servicing Tcl::pTk::break's in bindings)
############################## Widget Mapping Structures ############################

# global widget counter, only for autogenerated widget names.
my $gwcnt = '01'; 


# perlTk<->Tcl::pTk mapping in form [widget, wprefix, ?package?]
# These will be looked up 1st in AUTOLOAD
my %ptk2tcltk =
    (
     Button      => ['button', 'btn',],
     Checkbutton => ['checkbutton', 'cb',],
     Canvas      => ['canvas', 'can',],
     Entry       => ['entry', 'ent',],
     Frame       => ['frame', 'f',],
     LabelFrame  => ['labelframe', 'lf',],
     Labelframe  => ['labelframe', 'lf',],
     #LabFrame    => ['labelframe', 'lf',],
     Label       => ['label', 'lbl',],
     Listbox     => ['listbox', 'lb',],
     Message     => ['message', 'msg',],
     Menu        => ['menu', 'mnu',],
     Menubutton  => ['menubutton', 'mbtn',],
     Panedwindow => ['panedwindow', 'pw',],
     Bitmap	 => ['image', 'bmp',],
     Photo	 => ['image', 'pht',],
     Radiobutton => ['radiobutton', 'rb',],
     Text        => ['text', 'text',],
     Scrollbar   => ['scrollbar','sb',],
     Scale       => ['scale','scl',],
     Toplevel    => ['toplevel', 'top',],

     Table       => ['table', 'tbl', 'Tktable'],

     Separator   => ['Separator', 'sep', 'BWidget'],

     # BrowseEntry now implement as perl widget, compatible with perltk
     #BrowseEntry => ['ComboBox', 'combo', 'BWidget'],
     ComboBox    => ['ComboBox', 'combo', 'BWidget'],
     ListBox     => ['ListBox', 'lb', 'BWidget'],
     BWTree      => ['Tree', 'bwtree', 'BWidget'],

     TileNoteBook => ['tile::notebook', 'tnb', 'tile'],

     Treectrl    => ['treectrl', 'treectrl', 'treectrl'],
     Spinbox     => ['spinbox', 'spn',],

     # Balloon     => ['tixBalloon', 'bl', 'Tix'],
     HList       => ['tixHList', 'hlist', 'Tix'],
     TixTree        => ['tixTree', 'tree', 'Tix'],
     TList       => ['tixTList', 'tlist', 'Tix'],
     NoteBook    => ['tixNoteBook', 'nb', 'Tix'],
     ScrollableFrame    => ['ScrollableFrame', 'sframe', 'BWidget', 'auto_load ScrollableFrame'],
     Tktable    => ['table', 'table', 'Tktable', 'auto_load Tktable'],
     );

# Default ISAs for autoloaded widgets. If not defined in files anywhere else,
#   then the ISAs will defined as shown below when widget is created. If widget
#   isn't in the lookup below, then its ISA is set to Tcl::pTk::Widget
my %ptk2tcltk_ISAs =
    (
     Checkbutton => [qw/ Tcl::pTk::Button /],
     Entry       => [qw/ Tcl::pTk::Clipboard Tcl::pTk::Widget /],
     Listbox     => [qw/ Tcl::pTk::Clipboard Tcl::pTk::Widget /],
     Radiobutton => [qw/ Tcl::pTk::Button /],
     );

# Set the container names for the autoloaded widgets above that have set ISAs other than
#   the default Tcl::pTk::Widget
sub Tcl::pTk::Radiobutton::containerName{
    return 'Radiobutton';
}
sub Tcl::pTk::Checkbutton::containerName{
    return 'Checkbutton';
}

# Mapping of perltk widget methods to Tcl method names
#  This is needed because perltk sometimes has slightly different
#   names for the same tcl/tk methods
# This is a 2D lookup table of Widget class => ptkMethodName => TclMethodName
my %ptk2tcltk_methodMap = (
        'Tcl::pTk::Menu'  => {
                'Post' => 'post'
        }
);
    
# Mapping of pTk camelCase names to Tcl commands.
# These do not require the actual widget name.
# These will be looked up 2nd in AUTOLOAD
# $w->mapCommand(...) => @qwargs ...
my %ptk2tcltk_mapper =
    (
     "optionAdd"        => [ qw(option add) ],
     "font"             => [ qw(font) ],
     "fontCreate"       => [ qw(font create) ],
     "fontNames"        => [ qw(font names) ],
     "waitVariable"     => [ qw(vwait) ], # was tkwait variable
     "idletasks"        => [ qw(update idletasks) ],
);
# winfo subroutines, to be checked 4th in AUTOLOAD
# $w->wmcommand(...) => wm|winfo wmcommand $w ...
#  Note: wmcommands removed and put in Wm.pm, for better compatibility with perl/tk
my %ptk2tcltk_wm =
    (
    ( 
	 # list of widget pTk methods mapped to 'winfo' Tcl/Tk methods
	 # following lines result in pairs  'method' => 'winfo'
	 map {$_=>'winfo'} qw(
	     atom atomname
	     cells children class colormapfull 
	     depth
	     fpixels
             geometry
	     height
	     id interps ismapped
	     manager
	     name
	     pathname pixels pointerx pointery pointerxy
	     reqheight reqwidth  rgb  rootx rooty
	     screen screencells screendepth screenvisual
	     screenheight screenwidth screenmmheight screenmmwidth server
	     viewable visual visualid visualsavailable vrootheight vrootwidth
	     vrootx vrooty
	     width
	     x y
         ),
     ),
     );

my $ptk_w_names = join '|', sort keys %ptk2tcltk;

#  create_ptk_widget_sub creates subroutine similar to following:
#sub Button {
#  my $self = shift; # this will be a parent widget for newer button
#  my $int = $self->interp;
#  my $w    = w_uniq($self, "btn");
#  # create 'button' widget with a unique path
#  return $int->button($w,@_);
#}
my %replace_options =
    (
      # perltk's HList -indicatorcmd expects to see the pathname and the event type supplied to the callback
      #  tixHlist -indicatorcmd only defines the pathname to be supplied. So we have to supply an interfacing
      #  routine for this option to emulate the perltk behaivor
      tixHList   => 
                {separator=>'-separator', 
                -indicatorcmd => sub{ my $w = shift; $w->_procIndicatorCmd(@_)} },
      entry      => 
                {
                   -validatecommand => sub{ my $w = shift; $w->_procValidateCommand(@_)} },
      'ttk::entry'      => 
                {
                   -validatecommand => sub{ my $w = shift; $w->_procValidateCommand(@_)} },
     ComboBox   => {-choices=>'-values'},
     table      => {-columns=>'-cols'},
     toplevel   => {-title=>sub{shift->title(@_)},OnDestroy=>sub{},-overanchor=>undef},
     labelframe => {-label=>'-text', -labelside => undef},
     );
    
my %pure_perl_tk = (); # hash to keep track of pure-perl widgets

############################## End Widget Mapping Structures ############################



use overload
    # Stringified widgets will return the pathname
    '""' => sub{ my $self = shift; $self->path},  
    
    # Equality operation will check the pathname for equal or not equal
    'eq' => sub {my $self = shift; return $self->path eq shift}, 
    '==' => sub {my $self = shift; return $self->path eq shift},
    'ne' => sub {my $self = shift; return $self->path ne shift},
    '!=' => sub {my $self = shift; return $self->path ne shift};

    
# Aliases for some functions
sub Containing { shift->containing(@_)  };

sub containing {
    my $self = shift;
    my $int  = $self->interp;
    my $path = $int->icall('winfo', 'containing', @_);
    #print "path = $path\n";
    
    my $widget;
    
    # winfo children returns widget paths, so map them to objects
    # If a path returned, turn it into a widget
    if( $path ){
                my $widgets = $int->widgets();
                $widgets = $widgets->{RPATH};
                $widget = $widgets->{$path};
    }
    #print "Containing returning $widget\n";
    return $widget;
}    
    

sub path {
    my $self = shift;
    return $Tcl::pTk::Wpath->{ $self->{winID} };
}
# returns interpreter that is associated with widget
sub interp {
    my $self = shift;
    unless (exists $Tcl::pTk::Wint->{ $self->{winID} }) {
	print caller;
	die "do not exist: ",$self->{winID};
    }
    return $Tcl::pTk::Wint->{ $self->{winID} };
}

# Call an interpreter command on a widget
sub call{
    my $self = shift;
    my @args = @_;
    my $interp = $self->interp;
    
    # Go thru each arg and look for callback (i.e -command ) args
    my $lastArg;
    my $callMethod = 'invoke'; # For speed, use invoke for calling the interp, unless we need to use call (i.e. callback supplied, -variable, etc)
    $callMethod = 'call' if( $Tcl::pTk::DEBUG ); # fallback to call for debugging, so we get good stack traces
    foreach my $arg(@args){
            
            if( defined($lastArg) && !ref($lastArg) && ( $lastArg =~ /^-\w+/ ) ){
                    if(  $lastArg =~ /command|cmd$/ && defined($arg) ) {  # Check for last arg something like -command
            
                            #print "Found command arg $lastArg => $arg\n";
                            
                            # Create Callback object from arg, unless it already is a callback
                            my $cb;
                            if( blessed($arg) && $arg->isa('Tcl::pTk::Callback')){
                                    $cb = $arg;
                            }
                            else{
                                    $cb = Tcl::pTk::Callback->new($arg);
                            }
                            
                            # Store callback in the Configuration store of the widget
                            #   This is to be compatible with perltk's method of storing subrefs as callback objects
                            #     (as opposed to raw subrefs).
                            $self->Tcl::pTk::Derived::_configure($lastArg, $cb);
                            
                            # Make a subref that will execute the callback
                            my $cbSub = sub{ 
                                        my @callbackArgs = @_;
                                        # Get rid of extra stuff from the args to be supplied for old Tcl.pm's
                                        splice(@callbackArgs, 0, 3) if( $Tcl::VERSION < 0.98); # remove ClientData, Interp and CmdName
                                        #print "Callback Args = '".join("', '", @callbackArgs)."'\n";
                                        $cb->Call(@callbackArgs)
                            };
                            
                            $arg = $cbSub; # cbSub will actually be sent to Tcl::call
                            $callMethod = 'call'; # need to use call, rather than invoke
                    }
                    elsif(  $lastArg =~ /variable$/ ){  # Check for last arg something like -textvariable
 
                            # Store -variable options in the Configuration store of the widget
                            #   This is to be compatible with perltk's way of being able to retieve the actual
                            #    scalar reference 
                            #      For example, $entry->configure(-textvariable => \$text),
                            #                   $entry->cget(-textvariable) <= should return \$text
                            #     
                            $self->Tcl::pTk::Derived::_configure($lastArg, $arg); # Store in config store for retrieval later
                            $callMethod = 'call'; # need to use call, rather than invoke
                            
                    }
           }
           if( ref($arg) eq 'SCALAR'){ # scalar refs or code need to be turned to tcl variables, so we use call, not invoke
                   $callMethod = 'call';
           }
                
            
            $lastArg = $arg;
    }

    local $^W = 0; # Turn warnings off temporarily so we don't get 'use of undef value' messages    
    
    # Translate any empty strings to undefs, for compatibility with perltk
    if( wantarray ){ 
            my @retvals =  $interp->$callMethod(@args);
            return map defined($_) && !ref($_) && ($_ eq '') ? undef : $_, @retvals;
    }
    else{
            my $retval =  $interp->$callMethod(@args);
            return defined($retval) && !ref($retval) && ($retval eq '') ? undef : $retval;
    }

}
    

# provide cget method (rather than autoload, so megawidget code can 
# reference it.)
sub cget {
    my $self = shift;
    my @args = @_;
    
    my $option = $args[0];

    # replace options, if _replace_options hash is defined
    if( defined($self->{_replace_options}) ){
            my $replace_options = $self->{_replace_options};
            if( defined($replace_options->{$option}) ){
                    my $newOption = $replace_options->{$option};
                    $option = $newOption unless(ref($newOption) eq 'CODE'); # do all replacements, except for code references
                    $args[0] = $option;
            }
    }
    
    # Return the Callback object if a -command type option is requested,
    #   for compatibility with perlTk
    if( defined($option) && !ref($option) && ( $option =~ /^-\w+/ )){
            if( $option =~ /command|cmd$/  ){ # Check the option for something like -command
        
                    # Retreive callback from the configuration store of the widget
                    #   This is to be compatible with perltk's method of storing subrefs as callback objects
                    #     (as opposed to raw subrefs)
                    return $self->Tcl::pTk::Derived::_cget(@args);
            }
            if( $option =~ /variable$/) { # Check the option for something like -textvariable
                    # Retreive scalar ref from the configuration store of the widget
                    #   This is to be compatible with perltk way of being able to retreive the scalar
                    #     -textvariable using a cget call.
                    return $self->Tcl::pTk::Derived::_cget(@args);
            }
    }          
    
    # Return an image object, if one requested
    #   for compatibility with perlTk
    if( defined($option) and $option eq '-image' ){
            my $name = $self->call($self->path, 'cget', '-image');
            if( $name){
                    # Turn image into an object;
                    my $type = $self->call('image', 'type', $name);
                    $type = ucfirst($type);
                    my $package = "Tcl::pTk::$type";
                    my $obj = $self->interp->declare_widget($name, $package);
                    return $obj;
            }
            return $name;
    }

    # Return an font object, if one requested
    #   for compatibility with perlTk
    if( defined($option) and $option eq '-font' ){
            my $name = $self->call($self->path, 'cget', '-font');
            $name = 'TkDefaultFont' unless defined($name); # Set default Tk font name, if none returned
            # Turn font name into an object
            #  (We don't create a font object here, because the font already exists)
            my $obj = bless {name => $name, interp => $self->interp}, 'Tcl::pTk::Font';
            return $obj;
    }
    
    return $self->call($self->path, 'cget', @args);
}



# provide eventGenerate method (can't be autoloaded properly using the current autoload lookup tables
sub eventGenerate {
    my $self = shift;
    my @args = @_;
    return $self->call('event', 'generate', $self->path, @args);
}

# provide eventInfo method (can't be autoloaded properly using the current autoload lookup tables
sub eventInfo {
    my $self = shift;
    my @args = @_;
    return $self->call('event', 'info', @args);
}

# provide eventDelete method (can't be autoloaded properly using the current autoload lookup tables
sub eventDelete {
    my $self = shift;
    my @args = @_;
    return $self->call('event', 'delete', @args);
}

# provide eventDelete method (can't be autoloaded properly using the current autoload lookup tables
sub eventAdd {
    my $self = shift;
    my @args = @_;
    return $self->call('event', 'add', @args);
}

# provide configure method (rather than autoload, so megawidget code can 
# reference it.)
sub configure {
    my $self = shift;
    my @args = @_;
    
   
    if( @args){ # Normal usage: configure called with args
            
            if( defined( $self->{_replace_options} )){ # apply any replace_options, if needed
                    my %args = @_;
                    my $replace_options_wid = $self->{_replace_options};
                    my @code_todo = process_replace_options($replace_options_wid, \%args);
                    $_->[0]->($self,$_->[1]) for @code_todo;
                    if( %args){
                            return $self->call($self->path, 'configure', %args) 
                    }
                    else{
                            return;
                    }
            }
            else{  # No replace_options, call like normal
            
                    return $self->call($self->path, 'configure', @args);  # Normal usage
            }
    }
    
    # configure called with no args: Fixup the return arrays to be 1D
    my @return = $self->call($self->path, 'configure', @args);  # Normal usage
    
    # Make sure the output is a 2D array (consistent with perltk)
    if( @return && !ref($return[0]) ){ # Parse each element into an array
            foreach my $returnElement(@return){
                    my @pieces = split(/\s+/, $returnElement);
                    $returnElement = [@pieces];
            }
            
    }
    
    # Check for -command args. If set, these should be callbacks
    if( @return ){
            foreach my $configElem (@return){
                    next unless ref($configElem);
                    next unless $configElem->[0] =~ /command|cmd$/; # Check the option for something like -command
                    
                    # Replace the returned tcl command name with the stored callback
                    my $callback = $self->Tcl::pTk::Derived::_cget( $configElem->[0] );
                    $configElem->[4] = $callback;
            }
    }
                    
    
    return @return;
                    
}


# returns (and optionally creates) data hash assotiated with widget
sub widget_data {
    my $self = shift;
    return ($Tcl::pTk::Wdata->{$self->path} || ($Tcl::pTk::Wdata->{$self->path}={}));
}

# few convenience methods
sub tooltip {
    my $self = shift;
    my $ttext = shift;
    $self->interp->packageRequire('tooltip');
    $self->call("tooltip::tooltip",$self,$ttext);
    $self;
}

### font can't be autoloaded, because it creates a problem with widget delegation if it is autoloaded. ###
#    e.g. calling $t->fontCreate, where $t is a megawidget (or scrolled widget) can cause deep recursion errors
#      without this sub
sub font
{
  my $w = shift;
  
  # For font create, we need to create a font object
  if( $_[0] eq 'create' ){
          my $option = shift;
          return $w->Font(@_);
  }
  
  if( $_[0] eq 'actual' && scalar(@_) > 1){ # Call the wrapper for $font->actual in Tcl::pTk::Font.pm that works around the Tcl font bug
          my $option = shift;
          my $font = shift;
          if( !ref($font) ){ # font is not an object, turn it into one
                # Turn font name into an object
                #  (We don't create a font object here, because the font already exists)
                $font = bless {name => $font, interp => $w->interp}, 'Tcl::pTk::Font';
          }
          return $font->actual(@_);
  }
                  
  
  $w->call('font', @_);
}

#
# few geometry methods here
sub pack
{
 local $SIG{'__DIE__'} = \&Carp::croak;
 my $w = shift;
 if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x)
  {
   # maybe array/scalar context issue with slaves
   my $command = shift;
   
   if( $command eq 'slaves'){
    # pack slaves returns widget paths, so map them to objects
    my @wids = $w->call('pack', $command, $w, @_);
    my $widgets = $w->interp->widgets();
    $widgets = $widgets->{RPATH};
    my @childs = @$widgets{@wids};
    return grep defined($_), @childs; # only return widgets we found in our lookup;   
   }
   else{ # Not packSlaves
    $w->call('pack', $command, $w, @_);
   }
  }
 else
  {
   # Two things going on here:
   # 1. Add configure on the front so that we can drop leading '-'
   $w->call('pack', 'configure',$w, @_);
   # 2. Return the widget rather than nothing
   return $w;
  }
}

# Wrapper for place, similar to pack above
sub place
{
 local $SIG{'__DIE__'} = \&Carp::croak;
 my $w = shift;
 if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x)
  {
   # maybe array/scalar context issue with slaves
   my $command = shift;
   if( $command eq 'slaves'){
    # place slaves returns widget paths, so map them to objects
    my @wids = $w->call('pack', $command, $w, @_);
    my $widgets = $w->interp->widgets();
    $widgets = $widgets->{RPATH};
    my @childs = @$widgets{@wids};
    return grep defined($_), @childs; # only return widgets we found in our lookup;   
   }
   else{ # Not packSlaves
    $w->call('place', $command, $w, @_);
   }
  }
 else
  {
   # Two things going on here:
   # 1. Add configure on the front so that we can drop leading '-'
   $w->call('place', 'configure',$w, @_);
   # 2. Return the widget rather than nothing
   return $w;
  }
}


sub grid {
    my $self = shift;
    my @args = @_;
    
    # Allow Tcl::pTk::Widget->grid calls
    my $widget = $self;
    if( !ref($self)){
            foreach (@args){
                    if( ref($_) and $_->isa('Tcl::pTk::Widget')){
                            $widget = $_;
                            last;
                    }
            }
    }
    
    unshift @args, $self if( ref($self)); 
    $widget->call("grid",@args);
    $self;
}
sub gridSlaves {
    # grid slaves returns widget names, so map them to their objects
    my $self = shift;
    my $int  = $self->interp;
    my @wids = $self->call("grid","slaves",$self,@_);
    map($int->widget($_), @wids);
}
sub lower {
    my $self = shift;
    $self->call("lower",$self,@_);
    $self;
}
sub raise {
    my $self = shift;
    my $wp = $self->path;
    $self->call('raise',$wp,@_);
}

=head2 _bind_widget_helper

Internal method to process bind callbacks.
        
This creates a L<Tcl::pTk::Callback> object from the callback and stores the object
in the widget's internal data-store, so it can be returned if the binding is queried (for perltk 
compatibility).

B<Usage:>

   my $subref = $self->_bind_widget_helper($callback, $tag, $sequence);


=cut

sub _bind_widget_helper{
        my $self     = shift;
        my $callback = shift;
        my $tag      = shift;
        my $sequence = shift;

        # Make Tcl::pTk::Callback out of callback supplied
        my $cb;
        
        if( $callback ){ # Create callback object if callback defined and nonempty
                $cb = Tcl::pTk::Callback->new($callback);
        }
        else{
                $cb = undef; # We might be unsetting a callback (with an undef of empty string, so make it undef in either case

        }
        
        # Store in widget_data if this is a class binding (i.e. if tag supplied)
        if ( defined($tag) ) {
                my $widget_data = $self->interp->widget_data($tag);    # Get callback stored with widget data
                $widget_data->{$sequence} = $cb;
        }
        else {                                                         # Store in the actual widget store
                $self->{_bind_}{$sequence} = $cb;
        }
        
        return $cb;

}

sub bind_path { # this is overridden in scrolled widgets
    return shift->path;
}

# Widget bind method
# Usage:
#   Getting Bindings
#     @sequences = $widget->bind();    # returns active event sequence patterns for the given widget
#     @sequences = $widget->bind($tag); # returns active event sequence patterns for the given tag
#     $callback  = $widget->bind($sequence) # return callback (if defined) for the given sequence pattern
#     $callback  = $widget->bind($tag, $sequence) # return callback (if defined) for the given tag and sequence pattern
#   Setting Bindings:
#     $widget->bind(sequence, sub { ... });       # Make subref into a callback, and associated with the sequence
#     $widget->bind(tag, sequence, sub { ... });  # Make subref into a callback, and associated with the tag and sequence
sub bind {
    my $self = shift;
    
    ### Getting Bindings ###
    if ( scalar(@_) == 0 ){ # No Args supplied: @sequences = $widget->bind() usage
	return $self->call("bind",$self->bind_path);
    }
    elsif( @_ == 1  and defined($_[0]) and $_[0] =~ /^</){ # One sequence arg supplied: $callback = $widget->bind($sequence) usage
        my $sequence = $_[0];
        $sequence = $self->expandSeq($sequence); # get un-abbreviated version of sequence
        # Return the callback for this sequence (if it exists)
        return $self->{_bind_}{$sequence};
    }
    elsif( @_ == 1){  # One arg supplied, must be a tag: @sequences = $widget->bind($tag) usage
        my $tag = $_[0];
	return $self->call("bind",$tag);
    }
    elsif( @_ == 2 and defined($_[1]) and $_[1] =~ /^</){ # Two Args supplied and second is a sequence: 
        # $callback  = $widget->bind($tag, $sequence) usage
        my ($tag, $sequence) = @_;
       $sequence = $self->expandSeq($sequence); # get un-abbreviated version of sequence

        my $widget_data = $self->interp->widget_data($tag); # Get callback stored with widget data
        return $widget_data->{$sequence};
    }
    
    ### Setting Bindings ###
    my ($tag, $sequence, $callback);
    if( $_[0] =~ /^</){   # $widget->bind(sequence, sub { ... })  usage
        $sequence = shift;
        $callback = shift;
    }
    else{                 # $widget->bind(tag, sequence, sub { ... }) usage

        $tag = shift;
        $sequence = shift;
        $callback = shift;
    }
    
    $sequence = $self->expandSeq($sequence); # get un-abbreviated version of sequence
    
    my $cb;
    my $cbRef;
    $cb = $self->_bind_widget_helper($callback, $tag, $sequence);
    
    if( defined($callback) && $callback ne ''){ # don't call createTclBindRef if unsetting a binding (i.e. sub ref is undef or '')
            # Make a subref that will execute the callback, supplying $self as the event source
            $cbRef = $cb->createTclBindRef($self);
    }
    else{
            $cbRef = ''; # When unsetting a binding, set to empty string
            
    }

    # We create our own Tcl subs here, with a wrapper that catches Tcl::pTk::break events, so Tcl::pTk::break call
    #   work like Tk::break calls in perl/tk. Calling a Tcl::pTk::break in a event binding will stop processing of
    #   the current and any subsequent bindings.
    
    my $tclsubName;
    my $events;
    if( ref($cbRef) eq 'CODE'){ # Plain-old sub-ref is the binding     
	    $tclsubName = $self->interp->create_tcl_sub($cbRef);
    }
    elsif( ref($cbRef) eq 'ARRAY'){ # subrefs with args
 	    # We have been passed something like [\&subroutine, $arg1, ...]
	    # Create a proc in Tcl that invokes this subroutine with args
           
           my $arg = $cbRef;
 
            ### The following modified from code in Tcl::call in handling callbacks ###
	    # Look for Tcl::Ev objects as the first arg - these must be
	    # passed through for Tcl to evaluate.  Used primarily for %-subs
	    if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') {
		$events = splice(@$arg, 1, 1);
	    }
	    $tclsubName = 
		$self->interp->create_tcl_sub(sub {
		    splice(@_, 0, 3) if( $Tcl::VERSION < 0.98); # remove ClientData, Interp and CmdName
		    $arg->[0]->(@_, @$arg[1..$#$arg]);
		}, $events);
    }
    else{
            $tclsubName = ''; # Must be resetting a binding (i.e. supplying the empty string)
    }

    # If this is just a widget binding (i.e. not a class binding), 
    #   Add this tcl name to the _bindsubs_ widget store. This will be used to keep track of the tcl
    #   subs we have created for this widget, so they can be deleted
    if( defined($tag) && $tclsubName ){
            $self->{_bindsubs_}{$tclsubName} = 1;
    }
    
    my $bindpath = $self->bind_path;
    
    # if non-widget binding (e.g. class binding), use $tag as the bindpath
    $bindpath = $tag if( defined $tag ); 
    
    if( $tclsubName ){
            # The following wraps the tclsub created above with code that will catch
            #   Tcl::pTk::break calls and break out of the event bindings
            $self->interp->Eval("bind $bindpath $sequence {
                set catchVal [catch {$tclsubName} retVal]
                #puts \"catchVal = \$catchVal retval = \$retVal\"
                if {\$catchVal != 0} {
                        if { \$retVal != \"_TK_BREAK_\\n\" } { # BREAK returns are not errors
                                return -code error \$retVal
                        } else {
                                break
                        }
                } 
            }");
    }
    else{  # tclsubName is empty, must be resetting an existing binding
        if( defined($tag)){ # tag version of bind
                $self->interp->call("bind",$tag, $sequence, $cbRef);

        }
        else{  # just the sequence version of bind
                $self->interp->call("bind", $self->bind_path, $sequence, $cbRef);
        }
    }
            
}

# Utility method to expand a sequence to the non-abbreviated form
#   (e.g. <1> would be <Button-1>
#
sub expandSeq{
   my $self     = shift;
   my $sequence = shift;
   
   my $interp = $self->interp;

   # Get the unabbreviated tag by setting a sequence to a _bogus_ tag
   #   and then reading it back
   $interp->icall('bind', '_bogus_', $sequence, sub{});

   my ($seq2) = $interp->icall('bind', '_bogus_');

   # Zero-out the tag for next time
   $interp->icall('bind', '_bogus_', $sequence, '');
   
   return $seq2;
}
   
# Implementation of the tcl bindtag proc. 
#   Usage in perltk: 
#         # Setting bindtags
#        $widget->bindtags($tag1, $tag2, ...);
#
#        # Getting bindtags
#        @tags = $widget->bindtags();
sub bindtags{
    my $self = shift;
    my $interp  = $self->interp;
    my $path = $self->path;
    return $interp->icall('bindtags', $path, @_);
}


sub form
{

 my $w = shift;
 my $int = $w->interp;
 $int->pkg_require("Tix");
 if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x)
  {
   my $subcommand = shift;
   $w->call('tixForm', $subcommand, $w, @_);
  }
 else
  {
   # Two things going on here:
   # 1. Add configure on the front so that we can drop leading '-'
   $w->call('tixForm', $w, @_);
   # 2. Return the widget rather than nothing
   return $w;
  }
}


# TODO -- this method could be AUTOLOADed
sub focus {
    my $self = shift;
    my $wp = $self->path;
    $self->call('focus',$wp,@_);
}

sub destroy {
    my $self = shift;
    my $int = $self->interp;
    my $wp = $self->path;
    #print STDERR "calling destroy\n";
    $self->call('destroy',$wp,@_);
    #print STDERR "deleting widget refs in destroy\n";

    $int->delete_widget_refs($wp);
    #print STDERR "deleting widget refs complete\n";
    
    # delete any bindsubs
    if( defined($self->{_bindsubs_})){
            my $bindsubs = $self->{_bindsubs_};
            foreach my $subName( keys %$bindsubs ){
                    $int->delete_ref($subName);
            }
    }
}

# for compatibility 
sub GeometryRequest {
    my $self = shift;
    my $wp = $self->path;
    my ($width,$height) = @_;
    unless( $self->path eq $self->toplevel){
            warn("Warning: Tcl::pTk Implementation of GeometryRequest only works with toplevel windows");
            # Try setting width/height
            $self->configure(-width => $width, -height => $height);
    }
    else{
            $self->call('wm','geometry',$wp,"=${width}x$height");
    }
}
sub grab {
    my $self = shift;
    my $wp = $self->path;
    $self->call('grab',$wp,@_);
}

# grabSave method copied from ptk's Widget.pm. Needed for BrowseEntry, etc megawidgets to work
sub grabSave
{
 my ($w) = @_;
 my $grab = $w->grabCurrent;
 return sub {} if (!defined $grab);
 my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab';
 return sub { eval {local $SIG{'__DIE__'};  $grab->$method() } };
}

# focusSave method copied from ptk's Widget.pm. Needed for DialogBox, etc megawidgets to work
sub focusSave
{
 my ($w) = @_;
 my $focus = $w->focusCurrent;
 return sub {} if (!defined $focus);
 return sub { eval {local $SIG{'__DIE__'};  $focus->focus } };
}

sub focusCurrent
{
    my $self = shift;
    my $wp = $self->path;
    my $widget = $self->call('focus','-displayof',$wp);

    if( $widget){ # Return an actual widget object by looking it up in the Tcl:Tk $widgets hash
            #print "widget = $widget\n";
            my $widgets = Tcl::pTk::widgets();
            my $widgetObj = $widgets->{RPATH}{$widget};
            $widget = $widgetObj;
    }
    return undef if(defined($widget) && $widget eq ''); # for compatibility with perltk
    return $widget;
  
}

sub focusForce
{
    my $self = shift;
    my $wp = $self->path;
    my $val = $self->call('focus','-force',$wp);

    return $val;
  
}

sub focusFollowsMouse {
    my $self = shift;
    my $interp = $self->interp;
    $interp->icall('tk_focusFollowsMouse');
}

sub grabRelease {
    my $self = shift;
    my $wp = $self->path;
    $self->call('grab','release',$wp,@_);
}
sub grabGlobal {
    my $self = shift;
    my $wp = $self->path;
    $self->call('grab','-global',$wp,@_);
}
sub grabCurrent {
    my $self = shift;
    my $wp = $self->path;
    my $widget = $self->call('grab','current',$wp,@_);
    
    if( $widget){ # Return an actual widget object by looking it up in the Tcl:Tk $widgets hash
            #print "widget = $widget\n";
            my $widgets = Tcl::pTk::widgets();
            my $widgetObj = $widgets->{RPATH}{$widget};
            $widget = $widgetObj;
    }
    return undef if(defined($widget) && $widget eq ''); # for compatibility with perltk
    return $widget;
    
}

sub grabStatus {
    my $self = shift;
    my $wp = $self->path;
    $self->call('grab','status',$wp,@_);
}

sub packAdjust {
    # old name, becomes pack configure
    my $self = shift;
    my $wp = $self->path;
    $self->call('pack','configure',$wp,@_);
}
sub optionGet {
    my $self = shift;
    my $wp = $self->path;
    $self->call('option','get',$wp,@_);
}

sub update {
    my $self = shift;
    $self->interp->update;
}

sub getOpenFile {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    $self->call('tk_getOpenFile', %args);
}
sub getSaveFile {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    $self->call('tk_getSaveFile', %args);
}
sub chooseDirectory {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    $self->call('tk_chooseDirectory', %args);
}
sub messageBox {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    # messageBox should handle pTk's "YesNo" and return "Yes" in
    # addition to Tk's standard all-lc in/out.
    $args{'-type'} = lc $args{'-type'} if defined $args{'-type'};
    $args{'-default'} = lc $args{'-default'} if defined $args{'-default'};
    my $retVal = $self->call('tk_messageBox', %args);
    if( $retVal ){
            $retVal = ucfirst($retVal); # response is first char upper case
                                        # for compatibility with perl/tk
    }
    return $retVal;
}

sub chooseColor {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    $self->call('tk_chooseColor', %args);
}

# subroutine Darken copied from perlTk/Widget.pm
# tkDarken --
# Given a color name, computes a new color value that darkens (or
# brightens) the given color by a given percent.
#
# Arguments:
# color - Name of starting color.
# perecent - Integer telling how much to brighten or darken as a
# percent: 50 means darken by 50%, 110 means brighten
# by 10%.
sub Darken {
    my ($w,$color,$percent) = @_;
    my @l = $w->rgb($color);
    my $red = $l[0]/256;
    my $green = $l[1]/256;
    my $blue = $l[2]/256;
    $red = int($red*$percent/100);
    $red = 255 if ($red > 255);
    $green = int($green*$percent/100);
    $green = 255 if ($green > 255);
    $blue = int($blue*$percent/100);
    $blue = 255 if ($blue > 255);
    sprintf('#%02x%02x%02x',$red,$green,$blue);
}

sub PathName {
    my $wid = shift;
    return $wid->path;
}
sub Exists {
    my $wid = shift;
    my $wp = $wid->path;
    return $wid->interp->icall('winfo','exists',$wp);
}

# Alias for Exists. Some tk programs use this, although it doesn't appear to be documented
sub exists {
    my $wid = shift;
    $wid->Exists(@_);
}

sub toplevel {
    my $wid = shift;
    my $int = $wid->interp;
    my $tlp = $int->icall('winfo','toplevel',$wid->path);
    if ($tlp eq '.') {return $int->mainwindow}
    return $int->widget($tlp);
}
sub parent {
    my $wid = shift;
    my $int = $wid->interp;
    my $res = $int->icall('winfo','parent',$wid->path);
    if ($res eq '') {return undef}
    if ($res eq '.') {return $int->mainwindow}
    return $int->widget($res);
}

# Alias for Parent
sub Parent {
    my $self = shift;
    $self->parent(@_);
}

sub bell {
    my $self = shift;
    my $ret = $self->call('bell', @_);
}

sub children {
    my $self = shift;
    my $int  = $self->interp;
    my @wids = $self->call('winfo', 'children', $self->path, @_);
    
    # winfo children returns widget paths, so map them to objects
    my $widgets = $int->widgets();
    $widgets = $widgets->{RPATH};
    my @childs = @$widgets{@wids};
    return grep defined($_), @childs; # only return widgets we found in our lookup;
}

sub Subwidget {
    my $self = shift;
    my $name = shift;
    my $int  = $self->interp;
    my $subwid = $self->call($self->path, 'subwidget', $name);
    return $int->widget($subwid);
}

##############################################################
### Modification of perl/tk's After mechanism to work with Tcl::pTk
###  perl/tk's mechanism ensures that any pending after callbacks are canceled when
###   a widget is destroyed.

# This is supposed to replicate Tcl::pTk::after behaviour,
# but does auto-cancel when widget is deleted.
require Tcl::pTk::After;

sub afterCancel
{
 my ($w,$what) = @_;
 if (defined $what)
  {
   return $what->cancel if ref($what);
   carp "dubious cancel of $what" if 0 && $^W;
   $w->Tcl::pTk::after('cancel' => $what);
  }
}

sub afterIdle
{
 my $w = shift;
 # Set the Tcl::pTk package variable $current_widget so that any
 #   sub-ref gets assigned to the proper widget in Tcl.pm
 Tcl::pTk::_current_refs_widget($w->path);
 return Tcl::pTk::After->new($w,'idle','once',@_);
}

sub afterInfo {
    my ($w, $id) = @_;
    if (defined $id) {
	return ($id->[4], $id->[2], $id->[3]);
    } else {
	return sort( keys %{$w->{_After_}} );
    }
}

sub after
{
 my $w = shift;
 my $t = shift;
 if (@_)
  {
   if ($t ne 'cancel')
    {
     require Tcl::pTk::After;
     # Set the Tcl::pTk package variable $current_widget so that any
     #   sub-ref gets assigned to the proper widget in Tcl.pm
     Tcl::pTk::_current_refs_widget($w->path);
     return Tcl::pTk::After->new($w,$t,'once',@_)
    }
   while (@_)
    {
     my $what = shift;
     $w->afterCancel($what);
    }
  }
 else
  {
    # Set the Tcl::pTk package variable $current_widget so that any
    #   sub-ref gets assigned to the proper widget in Tcl.pm
    Tcl::pTk::_current_refs_widget($w->path);
   $w->Tcl::pTk::after($t);
  }
}

sub repeat
{
 require Tcl::pTk::After;
 my $w = shift;
 my $t = shift;
 return Tcl::pTk::After->new($w,$t,'repeat',@_);
}

#################################################

#
# Getimage compatability routine
#

my %image_formats =
    (
     xpm => 'photo',
     gif => 'photo',
     ppm => 'photo',
     xbm => 'bitmap'
     );

my %images; # Cached images (keyed by interperter, and image name

# we use a specific order here, rather than just the keys of %image_formats,
#  so for example xpm files are found before xbm, for compatibility with perl/tk
my @image_types = (qw/ xpm gif ppm xbm/);

sub Getimage {
    my $self = shift;
    my $name = shift;
    my $int  = $self->interp;

    return $images{$int}{$name} if $images{$int}{$name};

    foreach my $ext (@image_types) {
	my $path;
	foreach my $dir (@INC) {
	    $path = "$dir/Tcl/pTk/images/$name.$ext";
            
            if( -f $path){ # File found, check that we can load Img package before accepting a xpm file
                my $load = 1;
                if ($ext eq "xpm") {  
                    $load = $int->pkg_require('Img');
                }
                last if $load;
            }
	}
	next unless -f $path;
	# Found image $path
	my @args = ('image', 'create', $image_formats{$ext}, -file => $path);
	if ($image_formats{$ext} ne "bitmap") {
	    push @args, -format => $ext;
	}
	$images{$int}{$name} = $self->call(@args);
	return $images{$int}{$name};
    }

    # Try built-in bitmaps from Tix
    #$images->{$name} = $self->Pixmap( -id => $name );
    #return $images->{$name};
    Tcl::pTk::_DEBUG(1, "Getimage: MISSING IMAGE $name\n") if $Tcl::pTk::DEBUG;
    return;
}

#
# some class methods to provide same syntax as perlTk do
# In this case all widget names are generated automatically.
#


sub w_uniq {
    my ($self, $type) = @_;
    # create unique widget id with path "$self.$type<uniqid>"
    # assume produced names are unique (without checking for already generated
    # names) since $gwcnt incremented *each* call to w_uniq
    # Issues to resolve:
    #  - widgets created in Tcl could (rarely!) have same hence conflicting
    #    name, should detect such cases
    #  - could be reasonable to respect user's -name option, for compatibility
    if (!defined($type)) {
	my ($package, $callerfile, $callerline) = caller;
	warn "$callerfile:$callerline called w_uniq(@_)";
	$type = "unk";
    }
    my $wp = $self->path;
    # Ensure that we don't end up with '..btn01' as a widget name
    $wp = '' if $wp eq '.';
    $gwcnt++;
    Tcl::pTk::_current_refs_widget("$wp.$type$gwcnt");
    return "$wp.$type$gwcnt";
}


sub create_ptk_widget_sub {
    my ($interp,$wtype,$fast) = @_;
    my ($ttktype,$wpref,$tpkg,$tcmd) = @{$ptk2tcltk{$wtype}};
    $wpref ||= lcfirst $wtype;

    if (exists $replace_options{$ttktype}) {
	return sub {
	    my $self = shift; # this will be a parent widget for newer widget
	    my $int = $self->interp;
            
            # Load any required packages
            if( $tpkg ){
                    my $ver = $int->pkg_require($tpkg);
                    die("Error Loading Package $tpkg") unless( defined $ver );
            }
            $int->Eval($tcmd)        if $tcmd; 
            
            # Take care of any Name => $wpref syntax during the creation
            #  (For compatibility with perltk)
            if( $_[0] and $_[0] eq 'Name'){
                    shift;
                    $wpref = lcfirst shift;
                    $wpref =~ s/\s+/_/g; # no spaces allowed in window names in tcl
            }
            
	    my $w    = w_uniq($self, $wpref); # create uniq pref's widget id
            my $replace_options_wid = $replace_options{$ttktype}; # replace_options for the current widget

            my %args = @_;
            my @code_todo = process_replace_options($replace_options_wid, \%args);
            my $packageName = "Tcl::pTk::$wtype";
            $packageName->InitClass($self); # Any Class initialization is performed here
            my $wid  = $int->create_widget($self, $w, $ttktype, $packageName, %args);
	    $_->[0]->($wid,$_->[1]) for @code_todo;
            
            # Add replace_options to the widget hash to we can translate for any configure calls
            $wid->{_replace_options} = $replace_options_wid;
            
	    return $wid;
	};
    }
    return $fast ? sub {
	my $self = shift; # this will be a parent widget for newer widget
	my $int  = $self->interp;

        # Load any required packages
        if( $tpkg ){
            my $ver = $int->pkg_require($tpkg);
            die("Error Loading Package $tpkg") unless( defined $ver );
        }
        $int->Eval($tcmd)        if $tcmd;
            
        # Take care of any Name => $wpref syntax during the creation
        #  (For compatibility with perltk)
        if( $_[0] and $_[0] eq 'Name'){
            shift;
            $wpref = lcfirst shift;
            $wpref =~ s/\s+/_/g; # no spaces allowed in window names in tcl
        }

        my $w    = w_uniq($self, $wpref); # create uniq pref's widget id
	my $wid  = $int->declare_widget($int->invoke($ttktype,$w,@_), "Tcl::pTk::$wtype");
        $wid->SetBindtags; # set perl/tk compatible bindtags on the widget

	return $wid;
    } : sub {
	my $self = shift; # this will be a parent widget for newer widget
	my $int  = $self->interp;

        # Load any required packages
        if( $tpkg ){
            my $ver = $int->pkg_require($tpkg);
            die("Error Loading Package $tpkg") unless( defined $ver );
        }
        $int->Eval($tcmd)        if $tcmd;

        # Take care of any Name => $wpref syntax during the creation
        #  (For compatibility with perltk)
        if( $_[0] and $_[0] eq 'Name'){
            shift;
            $wpref = lcfirst shift;
            $wpref =~ s/\s+/_/g; # no spaces allowed in window names in tcl
        }

        my %args = @_;

        my $w    = w_uniq($self, $wpref); # create uniq pref's widget id
        my $packageName = "Tcl::pTk::$wtype";
        $packageName->InitClass($self); # Any Class initialization is performed here
	my $wid  = $int->create_widget($self, $w, $ttktype, $packageName, %args);


	return $wid;
    };
}

##############################################
#
#  InitClass method. Copied from perl-tk
#    Called during intialization of every widget
sub InitClass
{
 my ($package,$parent) = @_;
 croak "Unexpected type of parent $parent" unless(ref $parent);
 croak "$parent is not a widget" unless($parent->IsWidget);

 my $mw = $parent->MainWindow;
 my $hash = $mw->TkHash('_ClassInit_');
 unless (exists $hash->{$package})
  {
   $package->Install($mw);
   $hash->{$package} = $package->ClassInit($mw);
  }
}

# InitObject method. Copied from perl-tk
sub InitObject
{
 my ($obj,$args) = @_;
 # per object initialization, for example populating
 # with sub-widgets, adding a few object bindings to augment
 # inherited class bindings, changing binding tags.
 # Also another chance to mess with %$args before configure...
}

# Stub for Install: Called when a Tk widget class is first loaded
#   Override in a megawidget if needed
sub Install
{
 # Dynamically loaded widgets add their core commands
 # to the Tk base class here
 my ($package,$mw) = @_;
}

# Stub for Classinit: Called when a Tk widget class is first loaded
#   Override in a megawidget or subwidget if needed
#     Typically overridden to create extra class bindings
sub ClassInit
{
 # Carry out class bindings (or whatever)
 my ($package,$mw) = @_;
 return $package;
}

=head2 process_replace_options

Method to process the replace_options hash for a widget. This will be called at widget creation
or I<configure> calls to perform any replacement/translation of options for another.

B<Usage:>

   @code_todo = process_replace_options($replace_options, $args);
      where:
         $replace_options: Hash of options names => replacements or codeRef to perform
         $args:            Input/Output Args
         @code_todo:       Array of any code that needs to be performed after widget creation

=cut

sub process_replace_options{
        my $replace_options_wid = shift;
        my $args                = shift;
        my @code_todo;
        for ( keys %$replace_options_wid ) {
                if ( defined( $replace_options_wid->{$_} ) ) {
                        if ( exists $args->{$_} ) {
                                if ( ref( $replace_options_wid->{$_} ) eq 'CODE' ) {
                                        push @code_todo, [ $replace_options_wid->{$_}, delete $args->{$_} ];
                                }
                                else {
                                        $args->{ $replace_options_wid->{$_} } = delete $args->{$_};
                                }
                        }
                }
                else {
                        delete $args->{$_} if exists $args->{$_};
                }
        }
        
        return @code_todo;

}

sub LabFrame {
    my $self = shift; # this will be a parent widget for newer labframe
    my $int  = $self->interp;
    my $w    = w_uniq($self, "lf"); # create uniq pref's widget id
    my $ttktype = "labelframe";
    my %args = @_;
    for (keys %{$replace_options{$ttktype}}) {
	if (defined($replace_options{$ttktype}->{$_})) {
	    $args{$replace_options{$ttktype}->{$_}} =
		delete $args{$_} if exists $args{$_};
	} else {
	    delete $args{$_} if exists $args{$_};
	}
    }
    create_widget_package('LabFrame');
    my $lf = $int->declare_widget($self->call($ttktype, $w, %args), "Tcl::pTk::LabFrame");
    create_method_in_widget_package('LabFrame',
	Subwidget => sub {
	    my $lf = shift;
	    warn "LabFrame $lf ignoring Subwidget(@_)\n";
	    return $lf;
	},
    );
    return $lf;
}


# Text
sub _prepare_ptk_Text {
    require Tcl::pTk::Text; # get more Text p/Tk compat methods
}


# Listbox
sub _prepare_ptk_Listbox {
    create_method_in_widget_package ('Listbox');
}

# Canvas
sub _prepare_ptk_Canvas {
    create_method_in_widget_package ('Canvas', 
	raise => sub {
	    my $self = shift;
	    my $wp = $self->path;
	    $self->call($wp,'raise',@_);
	},
	lower => sub {
	    my $self = shift;
	    my $wp = $self->path;
	    $self->call($wp,'lower',@_);
	},
	bind => sub {
	    my $self = shift;
            
            # Getting Bindings:
            if( $#_ == 0){ # Usage: my @bindings = $canvas->bind($tag) 
                my $tag = $_[0];
                return $self->call($self->bind_path,'bind',$tag);
            }
            elsif( $#_ == 1){ # Usage: my $binding = $canvas->bind($tag, $sequence)
                my ($tag, $sequence) = @_;
               $sequence = $self->expandSeq($sequence); # get un-abbreviated version of sequence

               my $widget_data = $self->interp->widget_data($tag); # Get callback stored with widget data
               return $widget_data->{$sequence};
            }
            # Setting Bindings
	    elsif ($#_==2) {  # Usage: $canvas->bind($tag, $seq, $sub)
		my ($tag, $seq, $sub) = @_;

                $seq = $self->expandSeq($seq); # get un-abbreviated version of sequence
		$sub = $self->_bind_widget_helper($sub, $tag, $seq);
 
                # Make a subref that will execute the callback, supplying $self as the event source
                my $cbRef = $sub->createTclBindRef($self);

		$self->interp->call($self->bind_path,'bind',$tag,$seq,$cbRef);
	    }
	    else {
		$self->interp->call($self->bind_path,'bind',@_);
	    }
	},
	CanvasBind => sub {
	    my $self = shift;
	    my $item = shift;
	    #$self->SUPER::bind($item,@_); # Not sure why this doesn't work
	    $self->Tcl::pTk::Widget::bind($item,@_); # have to call package explicitly
	},
	CanvasFocus => sub {
	    my $self = shift;
	    $self->Tcl::pTk::Widget::focus(@_); # have to call package explicitly
	},
	focus => sub {
	    my $self = shift;
	    $self->call($self->path,'focus',@_);
	},
        BalloonInfo => sub {  # Sub that enables attaching balloon to items in a canvas
                              #  See balloon.pl demo for example
         my ($canvas,$balloon,$X,$Y,@opt) = @_;
         my @tags = ($canvas->find('withtag', 'current'),$canvas->gettags('current'));
         foreach my $opt (@opt)
          {
           my $info = $balloon->GetOption($opt,$canvas);
           if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH'))
            {
             $balloon->Subclient($tags[0]);
             foreach my $tag (@tags)
              {
               next unless defined($tag);
               return $info->{$tag} if exists $info->{$tag};
              }
             return '';
            }
           return $info;
          }
        }
    );
}

# menu compatibility
sub _process_underline {
    my $self = shift;
    # Suck out "~" which represents the char to underline
    my $args = shift;
    if (defined($args->{'-label'}) && $args->{'-label'} =~ /~/) {
	my $und = index($args->{'-label'}, '~');
	$args->{'-underline'} = $und;
	$args->{'-label'} =~ s/~//;
    }
};
# internal sub helper for menu
sub _addcascade {
    my $mnu = shift;
    my $mnup = $mnu->path;
    my $int = $mnu->interp;

    #print "In Add Cascade mnup = $mnup ";
    
    # Create submenu with predefined naming convention ($mnu.m+1), so we can return it
    #  if the menu method is called on the menu button
    my $entries = $mnu->index('end');
    $entries++;
    my $smnu = $int->widget($mnu->call('menu',"$mnu.m$entries"), "Tcl::pTk::Menu");
    #my $smnu = $mnu->Menu; # return unique widget id
    
    #print  " smenu = $smnu\n";
    
    my %args = @_;
    #print "Add Cascade args = ".join(", ", %args)."\n";
    my $tearoff = delete $args{'-tearoff'};
    if (defined($tearoff)) {
        $smnu->configure(-tearoff => $tearoff);
    }
    $args{'-menu'} = $smnu;
    my $mis = delete $args{'-menuitems'};
    $mnu->_process_menuitems($int,$smnu,$mis);
    $mnu->_process_underline(\%args);
    #$int->call("$mnu",'add','cascade', %args);
    $mnu->Cascade(%args);
}
# internal helper sub to process perlTk's -menuitems option
sub _process_menuitems {
    my $self = shift;
    my ($int,$mnu,$mis) = @_;
    for (@$mis) {
	if (ref) {
	    my $label = $_->[1];
	    my %a = @$_[2..$#$_];
	    $a{'-state'} = delete $a{state} if exists $a{state};
	    $a{'-label'} = $label;
	    my $cmd = lc($_->[0]);
	    if ($cmd eq 'separator') {$int->invoke($mnu->path,'add','separator');}
	    elsif ($cmd eq 'cascade') {
		$mnu->_process_underline(\%a);
	        $mnu->_addcascade(%a);
	    }
	    else {
		$cmd=~s/^button$/command/;
		$mnu->_process_underline(\%a);
                 #print "calling Call ".$mnu->path." add command ".join(", ", %a)."\n";

	        $mnu->call($mnu->path,'add',$cmd, %a);
	    }
	}
	else {
	    if ($_ eq '-' or $_ eq '') {
		$int->invoke($mnu->path,'add','separator');
	    }
	    else {
		die "in menubutton: '$_' not implemented";
	    }
	}
    }
}


sub NoteBook {
    my $self = shift; # this will be a parent widget for newer notebook
    my $int = $self->interp;
    my $w    = w_uniq($self, "nb"); # return unique widget id
    $int->pkg_require('Tix');
    my %args = @_;
    delete $args{'-tabpady'};
    delete $args{'-inactivebackground'};
    create_widget_package('NoteBook');
    my $bw = $int->declare_widget($self->call('tixNoteBook', $w, %args), "Tcl::pTk::NoteBook");
    create_method_in_widget_package('NoteBook',
	add=>sub {
	    my $bw = shift;
	    my $int = $bw->interp;
	    my $wp = $bw->call($bw,'add',@_);
	    my $ww = $int->declare_widget($wp);
	    return $ww;
	},
	raise=>sub {
	    my $bw = shift;
	    my $int = $bw->interp;
	    return $bw->call($bw,'raise',@_);
	},
    );
    return $bw;
}



# ----------------------------------------------------------------------------
#   Scrolled implementation.
#      This is copied from Tk::Widget.pm
sub Scrolled
{
 my ($parent,$kind,%args) = @_;
 $kind = 'Pane' if $kind eq 'Frame';
 # Find args that are Frame create time args
 my @args = $parent->CreateArgs($parent,\%args);
 my $name = delete $args{'Name'};
 push(@args,'Name' => $name) if (defined $name);
 my $cw = $parent->Frame(@args);
 @args = ();
 # Now remove any args that Frame can handle
 foreach my $k ('-scrollbars',map($_->[0],$cw->configure))
  {
   push(@args,$k,delete($args{$k})) if (exists $args{$k})
  }
 # Anything else must be for target widget - pass at widget create time
 my $w  = $cw->$kind(%args);
 # Now re-set %args to be ones Frame can handle
 %args = @args;
 $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'],
                   '-background' => [$w,'background','Background'],
                   '-foreground' => [$w,'foreground','Foreground'],
                  );
 $cw->AddScrollbars($w);

 # Check for existing mousewheel bindings.
 # If there aren't any, then add them
 my $mouseWheel = $cw->bind(ref($w), '<MouseWheel>'); # Check for class binding
 $mouseWheel = 1 if( $w->isa('Tcl::pTk::Text')); # Text is a special case, it has already has mousewheel binding
 if( !$mouseWheel ){
 	$cw->MouseWheelBind($w) unless $mouseWheel;

 }
 #else{
 #	print "wheelbinding alread exists for $w\n";
 #}

 $cw->Default("\L$kind" => $w);
 $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w);
 $cw->ConfigDefault(\%args);
 $cw->configure(%args);
 return $cw;
}
# end-of-scrolled
# ----------------------------------------------------------------------------

# MainWindow method, For pTk compatiblity. Returns the main-window for any widget
sub MainWindow{
    my $self = shift;
    my $interp = $self->interp;
    return $interp->mainwindow();
}




#
#  These walk and descendants routines are copied from perltk Widget.pm
#
# walk and descendants adapted from Stephen's composite
# versions as they only use core features they can go here.
# hierachy is reversed in that descendants calls walk rather
# than vice versa as this avoids building a list.
# Walk should possibly be enhanced so allow early termination
# like '-prune' of find.

sub Walk
{
 # Traverse a widget hierarchy while executing a subroutine.
 my($cw, $proc, @args) = @_;
 my $subwidget;
 foreach $subwidget ($cw->children)
  {
   $subwidget->Walk($proc,@args);
   &$proc($subwidget, @args);
  }
} # end walk

sub Descendants
{
 # Return a list of widgets derived from a parent widget and all its
 # descendants of a particular class.
 # If class is not passed returns the entire widget hierarchy.

 my($widget, $class) = @_;
 my(@widget_tree)    = ();

 $widget->Walk(
               sub { my ($widget,$list,$class) = @_;
                     push(@$list, $widget) if  (!defined($class) or $class eq $widget->class);
                   },
               \@widget_tree, $class
              );
 return @widget_tree;
}

# TODO -- document clearly how to use this subroutine
sub Declare {
    my $w       = shift;
    my $wtype   = shift;
    my $ttktype = shift;
    my %args    = @_;

    # Allow overriding of existing widgets.
    # XXX This should still die if we have created any single instance
    # XXX of this widget already.
    #die "$wtype already created\n" if defined $ptk2tcltk{$wtype};
    if (!exists $args{'-prefix'}) {
	$args{'-prefix'} ||= lcfirst $ttktype;
	$args{'-prefix'} =~ s/\W+//g;
    }
    $wtype = quotemeta($wtype); # to prevent chars corrupting regexp
    $ptk2tcltk{$wtype} = [$ttktype, $args{'-prefix'}, $args{'-require'},
			  $args{'-command'}];
    $ptk_w_names .= "|$wtype";
    
    # If ISA args supplied, set the ptk2tcltk_ISAs hash for the widgetname
    #   
    if(defined $args{'-isa'}){
            $ptk2tcltk_ISAs{$wtype} = $args{'-isa'};
    }

}

#############################################################
# Sub to pre-declare auto-loaded widgets
#   This is called during startup to make all auto-loaded widgets (i.e. widgets
#   in the ptk2tcltk hash) inherit from Tcl::pTk::Widget.
#  Predeclaring widgets is needed for sub-classes of auto-loaded widgets to work, without
#   creating the autoloaded widget first. See t/emptyMenuSubclass.t for an example
#
#
#
sub declareAutoWidget{
        my $interp = shift;
        foreach my $widgetname ( sort keys %ptk2tcltk ){
                
                # defined widget package, unless it has been defined already
                unless( defined( &{"Tcl::pTk::Widget::$widgetname"} ) ){


                        Tcl::pTk::Widget::create_widget_package($widgetname);
                        my $sub = Tcl::pTk::Widget::create_ptk_widget_sub($interp,$widgetname,'');

                        # Real Widget sub created in Tcl::pTk namespace
                        no strict 'refs';
                        *{"Tcl::pTk::$widgetname"} = $sub;
                        
                        # Name the anonymous sub, if in debug mode
                        Sub::Name::subname("Tcl::pTk::$widgetname", $sub) if( $Tcl::pTk::DEBUG);

                         # Delegate sub created in Tcl::pTk::Widget namespace
                         # DelegateFor  trickyness is to allow Frames and other derived things
                         # to force creation in a delegate e.g. a ScrlText with embeded windows
                         # need those windows to be children of the Text to get clipping right
                         # and not of the Frame which contains the Text and the scrollbars.
                         my $class = "Tcl::pTk::$widgetname";
                         *{'Tcl::pTk::Widget::'.$widgetname}  = $sub =  sub { $class->new(shift->DelegateFor('Construct'),@_) };
                         subname('Tcl::pTk::Widget::'.$widgetname, $sub) if($Tcl::pTk::DEBUG); # Name the anonymous sub, if in debug mode

                                          
                }

        }
}

#############################################################
# Sub to set the autoload-widget ISAs based on the entries in the
#  ptk2tcltk_ISAs hash
#    Input: Widget Name
sub setAutoWidgetISAs{
    my $widgetname = shift;

    no strict 'refs'; # Allow us to refer to package ISAs variables by string
    
    unless( @{"Tcl::pTk::${widgetname}::ISA"} ){ # only create ISA if it is empty (i.e. hasn't been set)
            if( defined($ptk2tcltk_ISAs{$widgetname})){ # Use lookup table, if it is there 
                    my $ISAentry = $ptk2tcltk_ISAs{$widgetname};
                    @{"Tcl::pTk::${widgetname}::ISA"} = @$ISAentry;
                    #print STDERR "Declaring autowidget $widgetname ".join(", ", @$ISAentry)."\n";
            }
            else{ # Not defined in table, use default
                    @{"Tcl::pTk::${widgetname}::ISA"} = qw(Tcl::pTk::Widget);                    
                    #print STDERR "Declaring Default autowidget $widgetname Tcl::pTk::Widget\n";
            }
    }
    
}
 
                
# here we create Widget package, used for both standard cases like
# 'Button', 'Label', and so on, and for all other widgets like Balloon
# returns 1 if actually package created, i.e. called first time
# TODO : document better and provide as public way of doing things?
my %created_w_packages; # (may be look in global stash %:: ?)
sub create_widget_package {
    my $widgetname = shift;
    unless (exists $created_w_packages{$widgetname}) {
	$created_w_packages{$widgetname} = {};
	die "not allowed widg name $widgetname" unless $widgetname=~/^\w+$/;
	{
	    no strict 'refs';
	    # create Widget package itself;
	    # internally, this is just creating few essential subs in widget's package
	    # method subs will be created later automatically when needed:
	    #
            setAutoWidgetISAs($widgetname); # Set widget inheritance/ISAs

            my $destroySub;
            unless( defined( &{"Tcl::pTk::${widgetname}::DESTROY"} ) ){ # (AUTOLOAD protection)    
                    *{"Tcl::pTk::${widgetname}::DESTROY"} = $destroySub = sub {}; 
                    # Name the sub we just created, if debug mode
                    Sub::Name::subname("Tcl::pTk::${widgetname}::DESTROY", $destroySub) if( $Tcl::pTk::DEBUG);
            }
            
	    eval "
	    sub Tcl::pTk::${widgetname}::AUTOLOAD {
	        \$Tcl::pTk::Widget::AUTOLOAD = \${Tcl::pTk::${widgetname}::AUTOLOAD};
	        return &Tcl::pTk::Widget::AUTOLOAD;
	    }
	    ";
	    # if there exists sub _prepare_ptk_XXXXXX then call it
	    if (exists ${"Tcl::pTk::Widget::"}{"_prepare_ptk_$widgetname"}) {
		${"Tcl::pTk::Widget::"}{"_prepare_ptk_$widgetname"}->();
	    }
            
            
            
	}
	# Add this widget class to ptk_w_names so the AUTOLOADer properly
	# identifies it for creating class methods
	#$widgetname = quotemeta($widgetname); # (no need to prevent chars corrupting regexp)
	$ptk_w_names .= "|$widgetname";
	return 1;
    }
    return 0;
}
# this subroutine creates a method in widget's package
sub create_method_in_widget_package {
    my $widgetname = shift;
    create_widget_package($widgetname);
    while ($#_>0) {
	my $widgetmethod = shift;
	my $sub = shift;
	next if exists $created_w_packages{$widgetname}->{$widgetmethod};
	$created_w_packages{$widgetname}->{$widgetmethod}++;
	no strict 'refs';
	my $package = "Tcl::pTk::$widgetname";
	*{"${package}::$widgetmethod"} = $sub;
	*{"${package}::_$widgetmethod"} = $sub;
    }
}


# Alias for Width and Height
#   Some perltk programs use these, although they don't appear to be documented.
sub Width{
        my $self = shift;
        $self->width(@_);
}
sub Height{
        my $self = shift;
        $self->height(@_);
}

# Wrapper to implement the waitVisibility method
sub waitVisibility{
        my $self = shift;
        
        $self->call('tkwait', 'visibility', $self->path);
}

########### Busy and UnBusy related methods. Adapted from perl/tk Widget.pm ########
sub BusyRecurse
{
 my ($restore,$w,$cursor,$recurse,$top) = @_;
 my $c = $w->cget('-cursor');
 my @tags = $w->bindtags;
 if ($top || defined($c))
  {
   push(@$restore, sub { return unless Tcl::pTk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) });
   $w->configure(-cursor => $cursor);
  }
 else
  {
   push(@$restore, sub { return unless Tcl::pTk::Exists($w); $w->bindtags(\@tags) });
  }
 $w->bindtags(['Busy',@tags]);
 if ($recurse)
  {
   foreach my $child ($w->children)
    {
     BusyRecurse($restore,$child,$cursor,1,0);
    }
  }
 return $restore;
}

sub Busy
{
 my ($w,@args) = @_;
 return unless $w->viewable;
 my($sub, %args);
 for(my $i=0; $i<=$#args; $i++)
  {
   if (ref $args[$i] eq 'CODE')
    {
     if (defined $sub)
      {
       croak "Multiple code definitions not allowed in Tcl::pTk::Busy";
      }
     $sub = $args[$i];
    }
   else
    {
     $args{$args[$i]} = $args[$i+1]; $i++;
    }
  }
 my $cursor  = delete $args{'-cursor'};
 my $recurse = delete $args{'-recurse'};
 $cursor  = 'watch' unless defined $cursor;
 unless (exists $w->{'Busy'})
  {
   my @old = ($w->grabSave);
   my $key;
   my @config;
   foreach $key (keys %args)
    {
     push(@config,$key => $w->cget($key));
    }
   if (@config)
    {
     push(@old, sub { $w->Tcl::pTk::Widget::configure(@config) });
     $w->Tcl::pTk::Widget::configure(%args);
    }
   unless ($w->bind('Busy'))
    {
     $w->bind('Busy','<Any-KeyPress>',[_busy => 1]);
     $w->bind('Busy','<Any-KeyRelease>',[_busy => 0]);
     $w->bind('Busy','<Any-ButtonPress>',[_busy => 1]);
     $w->bind('Busy','<Any-ButtonRelease>',[_busy => 0]);
     $w->bind('Busy','<Any-Motion>',[_busy => 0]);
    }
   $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1);
  }
 my $g = $w->grabCurrent;
 if (defined $g)
  {
   # warn "$g has the grab";
   $g->grabRelease;
  }
 $w->update;
 eval {local $SIG{'__DIE__'};  $w->grab };
 $w->update;
 if ($sub)
  {
   eval { $sub->() };
   my $err = $@;
   $w->Unbusy(-recurse => $recurse);
   die $err if $err;
  }
}

sub _busy
{
 my ($w,$f) = @_;
 $w->bell if $f;
 Tcl::pTk::break();
}

sub Unbusy
{
 my ($w) = @_;
 $w->grabRelease if Tcl::pTk::Exists($w);
 $w->update;
 my $old = delete $w->{'Busy'};
 if (defined $old)
  {
   local $SIG{'__DIE__'};
   eval { &{pop(@$old)} } while (@$old);
  }
 $w->update if Tcl::pTk::Exists($w);
}


#
# Perl-based fileevent implementation. This only performs 'readable' fileevent polling
#   TODO. Modify the Tcl package to support the Tcl's CreateFileHandler sub so we can implement
#         fileevent similar to the way perl/tk and python's tkinter does it.
sub fileevent{
        my $widget = shift;
        my $handle = shift; # Handle to check
        my $mode   = shift; # Only 'readable' currently supported
        my $cb     = shift; # Callback to execute, set to undef or blank to cancel a fileevent
        my $delay  = shift || 250; # Default polling interval/delay is 250 mS
        
        $handle->autoflush;
        
        croak("Error, fileevent mode = '$mode'. Only 'readable' mode currently handled") unless( $mode eq 'readable');

        my $mw = $widget->MainWindow;
        my $hash = $mw->TkHash('_fileevent_');
        
        if( $cb ){ # Register the callback for the handle
                $hash->{$handle} = 1;
        }
        else{  # Unregister the callback for the handle
                delete $hash->{$handle};
                return;
        }
        
        # Turn cb into a callback
        $cb = Tcl::pTk::Callback->new($cb);
        
        # Include ioctl defaults for non-windows
        unless( $^O =~ /mswin32/i){
                no warnings;
                local $^W = 0; # get rid of warning messages with ioctl.ph on unix
                require 'sys/ioctl.ph';
        }
        
        $widget->_FE_helper($handle, $cb, $widget, $delay);
        
}

# Helper sub that performs the fileevent polling
sub _FE_helper{
       
   my $self = shift;
   
   my ($handle, $cb, $widget, $delay) = @_;
   
   my $handleClosed; # Flag = 1 if handle has closed
   
   # Stop if the handle is not valid
   return if( !($handle->opened) ); 
 
   # Stop if this fileevent has been deleted.
   my $mw = $self->MainWindow;
   my $hash = $mw->TkHash('_fileevent_');
   return unless( defined( $hash->{$handle}) );

   my $size;
   my $handleEOF;
   # Windows version of checking if io handle is readable
   if( $^O =~ /mswin32/i){
   
           # See how big the hande is, if non-zero, read it
           $size = -s $handle;
           #print "size = $size\n";
   }
   else{ # Non-windows version of checking if a io handle is readable
           
           # Use ioctl to see if handle readable
           my $buff = chr(0) x 30;
           ioctl($handle, FIONREAD(), $buff);
           my $bytes = unpack("I", $buff);
           $size = $bytes;
           #print "Size = $size\n";

           # If no size seen, then check for handle that is closed
           if( !$size ){
                   
                   ### We use a non-blocking sysread to determine if the handle is closed.
                   ##  This appears to not mess with the file buffering like a eof() check does on linux
                   my $block = $handle->blocking; # Save blocking state, for restoring later
                   # Turn blocking off, if it isn't already
                   $handle->blocking(0);
                   my $line;
                   my $rc = sysread($handle, $line, 1);
                   if (defined $rc and $rc == 0){ # Check for handle being closes
                           # 
                           #print "closed\n";
                           $size = 1; # Even though handle is at eof, we will call the user callback
                                      #  to emulate Tk's behavior of defining a handle as readable when
                                      #   if has a eof waiting.
                           $handleEOF = 1;
                   }
                   $handle->blocking($block); # set blocking back
           }
   }
           
   if ($size) {
      $cb->Call();
   }
   
   $widget->after($delay, sub{ $self->_FE_helper($handle, $cb, $widget, $delay) });
}

#######
# Inteface to the tk_setPalette command
sub setPalette{
        my $self = shift;
        my @args = @_;
        
        return $self->call('tk_setPalette', @args);
}  

# Inteface to the tk_bisque command
sub bisque{
        my $self = shift;
        my @args = @_;
        
        return $self->call('tk_bisque', @args);
}  



# Wrapper method for Entry's -validatecommand (thru the %replace_options hash in Tcl::pTk::Widget)
#
# perltk's HList -indicatorcmd expects to see certain args supplied to the validateCmd.
#   (proposed value, characters added/delete, current value, index, action type).
#   This wrapper ensures these parameters are supplied to the give callback.
#
sub Tcl::pTk::Widget::_procValidateCommand{
        my $self = shift;
        my $value = shift;
                
        if( ref($value) ne 'CODE' and ref($value) ne 'ARRAY' ){
                croak("Error in ".__PACKAGE__."::_procValidateCommand Supplied value for -validatecmd is not a code or array reference\n");
        }
        
        my $callback = Tcl::pTk::Callback->new($value);
        
        $self->{_validatecommand} = $callback;
        
        # Create command substitutions for the parameters to be supplied to the callback
        my @TclEv = ('%P', '%P','%S', '%s', '%i', '%d'); # First entry '%P' is getting eaten by Tcl.pm, not sure why
                                                         #  So it is repeated here twice.
        my $TclEvArg = Tcl::Ev(@TclEv);
        my $tclcmd = [sub{
                my $entry = shift;
                my $retVal = $self->{_validatecommand}->Call(@_);
                # Make sure we return a 1 or a zero, needed by tcl for the validate command
                return $retVal ? 1 : 0;
                 },
                 $TclEvArg];
        
        $self->interp->call($self->path, 'configure', -validatecommand => $tclcmd)
}


# IS routine used by Balloon.pm (Used for testing equality?)
sub IS
{
 return (defined $_[1]) && $_[0] == $_[1];
}

# BalloonInfo used by Balloon.pm
sub BalloonInfo
{
 my ($widget,$balloon,$X,$Y,@opt) = @_;
 foreach my $opt (@opt)
  {
   my $info = $balloon->GetOption($opt,$widget);
   return $info if defined $info;
  }
}


##### Selection Commands, for compatibility with perl/tk #####

# Selection methods. Copied/Modified from Tk.pm

sub SelectionOwn{
   my $widget = shift;
   my $int    = $widget->interp;
   $int->call('selection', 'own', (@_, $widget->path));
}

sub SelectionOwner{
   my $widget = shift;
   my $int    = $widget->interp;
   my $path = $int->call('selection', 'own', '-displayof', $widget->path, @_);
    # If a path returned, turn it into a widget
    my $owner;
    if( $path ){
                my $widgets = $int->widgets();
                $widgets = $widgets->{RPATH};
                $owner = $widgets->{$path};
    }
    return $owner;
}

sub SelectionClear{
   my $widget = shift;
   my $int    = $widget->interp;
   $int->call('selection', 'clear', '-displayof', $widget->path, @_);

}

sub SelectionExists{
   my $widget = shift;
   my $int    = $widget->interp;
   $int->call('selection', 'exists', '-displayof', $widget->path, @_);
}

sub SelectionHandle{
   my $widget = shift;
   my $callback = pop;
   my $int    = $widget->interp;

    if( defined($callback)){
            # Turn into callback, if not one already
            unless( blessed($callback) and $callback->isa('Tcl::pTk::Callback')){
                    $callback = Tcl::pTk::Callback->new($callback);
            }
            return $widget->interp->call('selection', 'handle', @_, $widget, 
                        sub{ 
                                # Get the proper args for the callback (selection beginning and end)
                                my @args = @_;
                                splice(@args, 0, 3) if( $Tcl::VERSION < 0.98); # remove ClientData, Interp and CmdName
                                $callback->Call(@args)
                        } );

    }
    
    # Callback not defined, must be reseting the selection handler
    return $widget->interp->call('selection', 'handle', @_, $widget, $callback );
    
    
}

sub SelectionGet{
   my $widget = shift;
   my $int    = $widget->interp;
   $int->call('selection', 'get', '-displayof', $widget->path, @_);
}


# Scrolling and mousewhile bind methods copied from Tk::Widget
sub XscrollBind
{
 my ($mw,$class) = @_;
 $mw->bind($class,'<Left>',         ['xview','scroll',-1,'units']);
 $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']);
 $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
 $mw->bind($class,'<Right>',        ['xview','scroll',1,'units']);
 $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']);
 $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']);

 $mw->bind($class,'<Home>',         ['xview','moveto',0]);
 $mw->bind($class,'<End>',          ['xview','moveto',1]);
 $mw->XMouseWheelBind($class);
}

sub PriorNextBind
{
 my ($mw,$class) = @_;
 $mw->bind($class,'<Next>',     ['yview','scroll',1,'pages']);
 $mw->bind($class,'<Prior>',    ['yview','scroll',-1,'pages']);
}

sub XMouseWheelBind
{
 my ($mw,$class) = @_;
 # <4> and <5> are how mousewheel looks on X
 # <4> and <5> are how mousewheel looks on X
 $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. 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://www.inria.fr/koala/colas/mouse-wheel-scroll/
   $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 definded 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
);

###################################################################################3
#### Method to return the hash of auto-wrapped methods that should return
## a list. This method can be overridden in subclasses to provide a per-subclass
# way to specify list-context for auto-wrapped widgets
sub _retListContext{
        return \%lists;
}


################### Menu Functions ############################
## Originally Copied from Tk::Widget ####
sub PostPopupMenu
{
 my ($w, $X, $Y) = @_;
 if (@_ < 3)
  {
   my $e = $w->XEvent;
   $X = $e->X;
   $Y = $e->Y;
  }
 my $menu = $w->menu;
 $menu->Post($X,$Y) if defined $menu;
}

sub FillMenu
{
 my ($w,$menu,@labels) = @_;
 foreach my $lab (@labels)
  {
   my $method = $lab.'MenuItems';
   $method =~ s/~//g;
   $method =~ s/[\s-]+/_/g;
   if ($w->can($method))
    {
     $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method());
    }
  }
 return $menu;
}

sub menu
{
 my ($w,$menu) = @_;
 if (@_ > 1)
  {
   $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'};
   $w->{'_MENU_'} = $menu;
  }
 return unless defined wantarray;
 unless (exists $w->{'_MENU_'})
  {
   $w->_OnDestroy('_MENU_');
   $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0);
   $w->FillMenu($menu,$w->MenuLabels);
  }
 return $w->{'_MENU_'};
}



sub FileMenuItems
{
 my ($w) = @_;
 return [ ["command"=>'E~xit', -command => [ $w->toplevel, 'WmDeleteWindow']]];
}

##########################################################################################

# Autoload fo Tcl::pTk::Widget
sub AUTOLOAD {
    my $w = shift;
    my ($method,$package,$wtype) = ($Tcl::pTk::Widget::AUTOLOAD,undef,undef);
    my $fullName = $method;
    
    # Split out package, wtype and method from the full name of the method
    my @packageComponents = split('::', $method);
    $method  = pop @packageComponents;
    
    # Take care of SUPER methods
    my $super;
    if( $packageComponents[-1]  eq 'SUPER'){
            pop @packageComponents;
            $super = 1;
    }
    
    $wtype   = $packageComponents[-1];
    $package = join("::", @packageComponents)."::";
    
    if( !$method ){
            die("Tcl::pTk::Widget::AUTOLOAD can handle method '$fullName'");
    }
    


    # Handle Megawidget cases, where a method call might be delegated to a 
    #   subwidget of the megawidget
    if( ref($w) && !$w->can($method) 
            && $w->can('Delegate')
            && $method !~ /^(ConfigSpecs|Delegates)/ ){
        my $delegate = $w->Delegates;
        if (%$delegate || tied %$delegate){           
                my $widget = $delegate->{$method};
                $widget = $delegate->{DEFAULT} unless (defined $widget);
                if (defined $widget){
                        my $subwidget = (ref $widget) ? $widget : $w->Subwidget($widget);
                        if (defined $subwidget){
                                no strict 'refs';
                                # print "AUTOLOAD: $what\n";
                                *{$fullName} = sub { shift->Delegate($method,@_) };
                                
                                $DB::sub = $fullName; #tell the debugger what is going on
                                unshift @_, $w; # put the first arg back on
                                goto &$fullName;
                        }
                        else{
                                croak "No delegate subwidget '$widget' for $method";
                        }
                }
        }
    }
    
  
    
    # if someone calls $widget->_method(...) then it is considered as faster
    # version of method, similar to calling $widget->method(...) but via
    # 'invoke' instead of 'call', thus faster
    my $fast = '';
    $method =~ s/^_// and do {
	$fast='_';
	if (exists $::{"Tcl::pTk::${wtype}::"}{$method}) {
	    no strict 'refs';
	    *{"::Tcl::pTk::${wtype}::_$method"} = *{"::Tcl::pTk::${wtype}::$method"};
	    return $w->$method(@_);
	}
    };

    # search for right corresponding Tcl/Tk method, and create it afterwards
    # (so no consequent AUTOLOAD will happen)

    # Precedence ordering is important

    # 0. Check to see if is is a method that should be mapped
    my $mappedMethodName;
    my $origMethodName;
    if( defined( $ptk2tcltk_methodMap{ref($w)}) and
            defined( $mappedMethodName = $ptk2tcltk_methodMap{ref($w)}{$method}) ){
        #XXX Does this lookup needed to figure out inheritance too??
        $origMethodName = $method;
        $method = $mappedMethodName;
    }
            
    
    # 1. Check to see if it is a known widget method
    if (exists $ptk2tcltk{$method}) {
	create_widget_package($method);
	my $sub = create_ptk_widget_sub($w->interp,$method,$fast);
	no strict 'refs';
	*{"$package$fast$method"} = $sub;
	*{"$package$fast$origMethodName"} = $sub if( $mappedMethodName); # Create another entry for mapped so we don't get AUTOLOADED again
        
        
        # Name the anonymous sub, if in debug mode
        Sub::Name::subname("$package$fast$method", $sub) if( $Tcl::pTk::DEBUG);
        
	return $sub->($w,@_);
    }
    # 2. Check to see if it is a known mappable sub (widget unused)
    if (exists $ptk2tcltk_mapper{$method}) {
	my $sub = $fast ? sub {
	    my $self = shift;
	    $self->interp->invoke(@{$ptk2tcltk_mapper{$method}},@_);
	} : sub {
	    my $self = shift;
	    $self->call(@{$ptk2tcltk_mapper{$method}},@_);
	};
	no strict 'refs';
	*{"$package$fast$method"} = $sub;
	*{"$package$fast$origMethodName"} = $sub if( $mappedMethodName); # Create another entry for mapped so we don't get AUTOLOADED again
        # Name the anonymous sub, if in debug mode
        Sub::Name::subname("$package$fast$method", $sub) if( $Tcl::pTk::DEBUG);
	return $sub->($w,@_);
    }
    # 3. Check to see if it is a known 'wm' command
    # XXX: What about toplevel vs. inner widget checking?
    if (exists $ptk2tcltk_wm{$method}) {
	my $sub = $fast ? sub {
	    my $self = shift;
	    $self->interp->invoke($ptk2tcltk_wm{$method}, $method, $self->path, @_);
	} : sub {
	    my $self = shift;
	    $self->call($ptk2tcltk_wm{$method}, $method, $self->path, @_);
	};
	no strict 'refs';
	*{"$package$fast$method"} = $sub unless($super);
	*{"$package$fast$origMethodName"} = $sub if( $mappedMethodName); # Create another entry for mapped so we don't get AUTOLOADED again
        # Name the anonymous sub, if in debug mode
        Sub::Name::subname("$package$fast$method", $sub) if( $Tcl::pTk::DEBUG);
	return $sub->($w,@_);
    }
    #
    # 3.5) If the method is "containerName", find a base class of the $package that
    #       is a mapped tcl-tk widget. This enables perl/tk subwidgets to be defind
    #       from tcl-tk widgets (for example Tcl::pTk::Tree, which is derived 
    #       from the tcl-tk widget HList)
    if( $method eq 'containerName'){
            my $packageLookup = $package;
            $packageLookup =~ s/\:\:$//; # get rid of trailing double-colons, if present
            my @lookupPaths = Class::ISA::super_path($packageLookup);
            unshift @lookupPaths, $packageLookup; # Add our own package, which might be a mapped tcl-tk widget
            # Look for a base widget of the package that is a defined tcl widget
            my $baseWidget;
            my $basePackage;
            foreach my $lookupPath(@lookupPaths){
                    my ($basename) = $lookupPath =~ /::(\w+)$/;
                    if( defined($ptk2tcltk{$basename}) ){  # lookup for base widget
                            $baseWidget = $basename;
                            $basePackage = $lookupPath;
                            last;
                    }
            }
            
            if( defined( $baseWidget ) ){ # baseWidget found, create containerName method that returns its name.
                                          #  (e.g. Tcl::pTk::HList::containerName would return HList)
                    no strict 'refs';
                    no warnings; # Turn off warnings, to avoid redefined warning messages
                    my $containerSub = sub{ return $baseWidget };
                    my $containerSubName = $package."containerName";
                    *{"$containerSubName"} = $containerSub;
                    #print "Creating sub $containerSubName\n";
                    # Name the anonymous sub, if in debug mode
                    Sub::Name::subname($containerSubName, $containerSub) if( $Tcl::pTk::DEBUG);
                    return $containerSub->($w,@_);
            }
    }
    # 4. Check to see if it is a camelCase method.  If so, split it apart.
    # code below will always create subroutine that calls a method.
    # This could be changed to create only known methods and generate error
    # if method is, for example, misspelled.
    # so following check will be like 
    #    if (exists $knows_method_names{$method}) {...}
    my $sub;
    if ($method =~ /^([a-z]+)([A-Z][a-z]+)$/) {
        my ($meth, $submeth) = ($1, lcfirst($2));
	if ($meth eq "grid" || $meth eq "pack") {
	    # grid/pack commands reorder $wp in the call.
	    $sub = $fast ? sub {
		my $w = shift;
		$w->interp->invoke($meth, $submeth, $w->path, @_);
	    } : sub {
		my $w = shift;
		$w->call($meth, $submeth, $w->path, @_);
	    };
	} elsif ($meth eq "after") {
	    # after commands don't include $wp in the call
	    $sub = $fast ? sub {
		my $w = shift;
		scalar($w->interp->invoke($meth, $submeth, @_));
	    } : sub {
		my $w = shift;
		scalar($w->call($meth, $submeth, @_));
	    };
	} else {
	    # Default camel-case, break into $wp $method $submethod and call
	    # if method was created with 'create_method_in_widget_package' it should
	    # be called instead...
	    if (exists $created_w_packages{$wtype}->{$meth}) {
		$sub = sub {
		    my $w = shift;
		    $w->$meth($submeth,@_);
		};
	    } else {
		# ... otherwise ordinary camel case invocation
                my $lists = $w->_retListContext();
                
		if (exists $lists->{$method}) {
		    $sub = $fast ? sub {
			my $w = shift;
			$w->interp->invoke($w->path, $meth, $submeth, @_);
		    } : sub {
			my $w = shift;
			$w->call($w->path, $meth, $submeth, @_);
		    };
		} else {
		    $sub = $fast ? sub {
			my $w = shift;
			scalar($w->interp->invoke($w->path, $meth, $submeth, @_));
		    } : sub {
			my $w = shift;
			scalar($w->call($w->path, $meth, $submeth, @_));
		    };
		}
	    }
	}
    }
    elsif ($method =~ /^([a-z]+)([A-Z][A-Za-z]+)$/) {
	# even more camelCaseMethod
        my ($meth, $submeth) = ($1, $2);
	my @submethods = map{lcfirst($_)} $submeth=~/([A-Z][a-z]+)/g;
	# Default camel-case, break into $wp $method $submethod and call
	# if method was created with 'create_method_in_widget_package' it should
	# be called instead...
	if (exists $created_w_packages{$wtype}->{$meth}) {
	    $sub = sub {
	        my $w = shift;
	        $w->$meth(@submethods,@_);
	    };
	} else {
	    # ... otherwise ordinary camel case invocation
            my $lists = $w->_retListContext();
	    if (exists $lists->{$method}) {
	        $sub = $fast ? sub {
	    	my $w = shift;
	    	$w->interp->invoke($w->path, $meth, @submethods, @_);
	        } : sub {
	    	my $w = shift;
	    	$w->call($w->path, $meth, @submethods, @_);
	        };
	    } else {
	        $sub = $fast ? sub {
	    	my $w = shift;
	    	scalar($w->interp->invoke($w->path, $meth, @submethods, @_));
	        } : sub {
	    	my $w = shift;
	    	scalar($w->call($w->path, $meth, @submethods, @_));
	        };
	    }
	}
    }
    else {
	# Default case, call as submethod of $wp
        my $lists = $w->_retListContext();
	if (exists $lists->{$method}) {
	    $sub = $fast ? sub {
		my $w = shift;
		$w->interp->invoke($w, $method, @_);
	    } : sub {
		my $w = shift;
		$w->call($w, $method, @_);
	    };
	} else {
	    $sub = $fast ? sub {
		my $w = shift;
		scalar($w->interp->invoke($w, $method, @_));
	    } : sub {
		my $w = shift;
		scalar($w->call($w, $method, @_));
	    };
	}
    }
    {
	# create method $method in package $package
	no strict 'refs';
        # Name the anonymous sub, if in debug mode
        Sub::Name::subname("$package$fast$method", $sub) if( $Tcl::pTk::DEBUG);
	*{"$package$fast$origMethodName"} = $sub if( $mappedMethodName); # Create another entry for mapped so we don't get AUTOLOADED again
	*{"$package$fast$method"} = $sub unless $super;
    }
    # call freshly-created method (next time it will not go through AUTOLOAD)
    return $sub->($w,@_);
}


1;


