view release on metacpan or  search on metacpan

Tk/Widget.pm  view on Meta::CPAN

                } elsif ($callback =~ /ARRAY/) {
                    if (ref $callback->[0]) {
                        push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0] );
                    } else {
                        push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0] );
                    }
                    foreach my $arg (@$callback[1 .. $#$callback]) {
                        if (ref $arg) {
                            push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg );
                        } else {
                            push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg );
                        }
			
                        if (ref $arg eq 'Tk::Ev') {
                            if ($arg =~ /SCALAR/) {
                                push @out, sprintf( ": '$$arg'" );
                            } else {
                                push @out, sprintf( ": '%s'", join("' '", @$arg) );
                            }
                        }

                        push @out, sprintf( "\n" );
                    } # forend callback arguments
                } # ifend callback

            } # forend all bindings for one tag

        } # ifend have bindings

    } # forend all tags
    push @out, sprintf( "\n" );
    return @out;

} # end bindDump


sub ASkludge
{
 my ($hash,$sense) = @_;
 foreach my $key (%$hash)
  {
   if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR')
    {
     if ($sense)
      {
       my $val = ${$hash->{$key}};
       require Tie::Scalar;
       tie ${$hash->{$key}},'Tie::StdScalar';
       ${$hash->{$key}} = $val;
      }
     else
      {
       untie ${$hash->{$key}};
      }
    }
  }
}



# clipboardKeysyms --
# This procedure is invoked to identify the keys that correspond to
# the "copy", "cut", and "paste" functions for the clipboard.
#
# Arguments:
# copy - Name of the key (keysym name plus modifiers, if any,
# such as "Meta-y") used for the copy operation.
# cut - Name of the key used for the cut operation.
# paste - Name of the key used for the paste operation.
#
# This method is obsolete use clipboardOperations and abstract
# event types instead. See Clipboard.pm and Mainwindow.pm

sub clipboardKeysyms
{
 my @class = ();
 my $mw    = shift;
 if (ref $mw)
  {
   $mw = $mw->DelegateFor('bind');
  }
 else
  {
   push(@class,$mw);
   $mw = shift;
  }
 if (@_)
  {
   my $copy  = shift;
   $mw->Tk::bind(@class,"<$copy>",'clipboardCopy')   if (defined $copy);
  }
 if (@_)
  {
   my $cut   = shift;
   $mw->Tk::bind(@class,"<$cut>",'clipboardCut')     if (defined $cut);
  }
 if (@_)
  {
   my $paste = shift;
   $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste);
  }
}

sub pathname
{
 my ($w,$id) = @_;
 my $x = $w->winfo('pathname',-displayof  => oct($id));
 return $x->PathName;
}

# ::tk::UnderlineAmpersand --
# This procedure takes some text with ampersand and returns
# text w/o ampersand and position of the ampersand.
# Double ampersands are converted to single ones.
# Position returned is -1 when there is no ampersand.
#
sub UnderlineAmpersand
{
 my (undef,$text) = @_;
 if ($text =~ m{(?<!&)&(?!&)}g)
  {
   my $idx = pos $text;
   $text =~ s{(?<!&)&(?!&)}{};
   ($text, $idx);
  }
 else
  {
   ($text, -1);
  }
}

# ::tk::SetAmpText -- 
# Given widget path and text with "magic ampersands",
# sets -text and -underline options for the widget
#
sub SetAmpText
{
 my ($w,$text) = @_;
 my ($newtext,$under) =  $w->UnderlineAmpersand($text);
 $w->configure(-text => $newtext, -underline => $under);
}

# ::tk::AmpWidget --
# Creates new widget, turning -text option into -text and
# -underline options, returned by ::tk::UnderlineAmpersand.
#
sub AmpWidget
{
 my ($w,$class,%args) = @_;
 my @options;
 while(my($opt,$val) = each %args)
  {
   if ($opt eq "-text")
    {
     my ($newtext,$under) = $w->UnderlineAmpersand($val);
     push @options, -text => $newtext, -underline => $under;
    }
   else
    {
     push @options, $opt, $val;