home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _8f9e72eb61a64b4d569a5d16536e9951 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.9 KB  |  123 lines
  1. # Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Clipboard;
  5. use strict;
  6.  
  7. use vars qw($VERSION);
  8. $VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
  9.  
  10. use AutoLoader qw(AUTOLOAD);
  11. use Tk qw(catch);
  12.  
  13. sub clipEvents
  14. {
  15.  return qw[Copy Cut Paste];
  16. }
  17.  
  18. sub ClassInit
  19. {
  20.  my ($class,$mw) = @_;
  21.  foreach my $op ($class->clipEvents)
  22.   {
  23.    $mw->Tk::bind($class,"<<$op>>","clipboard$op");
  24.   }
  25.  return $class;
  26. }
  27.  
  28. sub clipboardSet
  29. {
  30.  my $w = shift;
  31.  $w->clipboardClear;
  32.  $w->clipboardAppend(@_);
  33. }
  34.  
  35. sub clipboardCopy
  36. {
  37.  my $w = shift;
  38.  my $val = $w->getSelected;
  39.  if (defined $val)
  40.   {
  41.    $w->clipboardSet('--',$val);
  42.   }
  43.  return $val;
  44. }
  45.  
  46. sub clipboardCut
  47. {
  48.  my $w = shift;
  49.  my $val = $w->clipboardCopy;
  50.  if (defined $val)
  51.   {
  52.    $w->deleteSelected;
  53.   }
  54.  return $val;
  55. }
  56.  
  57. sub clipboardGet
  58. {
  59.  my $w = shift;
  60.  $w->SelectionGet('-selection','CLIPBOARD',@_);
  61. }
  62.  
  63. sub clipboardPaste
  64. {
  65.  my $w = shift;
  66.  local $@;
  67.  catch
  68.   {
  69. ## Different from Tcl/Tk version:
  70. #    if ($w->windowingsystem eq 'x11')
  71. #     {
  72. #      catch
  73. #       {
  74. #        $w->deleteSelected;
  75. #       };
  76. #     }
  77.    $w->insert("insert", $w->clipboardGet);
  78.    $w->SeeInsert if $w->can('SeeInsert');
  79.   };
  80. }
  81.  
  82. sub clipboardOperations
  83. {
  84.  my @class = ();
  85.  my $mw    = shift;
  86.  if (ref $mw)
  87.   {
  88.    $mw = $mw->DelegateFor('bind');
  89.   }
  90.  else
  91.   {
  92.    push(@class,$mw);
  93.    $mw = shift;
  94.   }
  95.  while (@_)
  96.   {
  97.    my $op = shift;
  98.    $mw->Tk::bind(@class,"<<$op>>","clipboard$op");
  99.   }
  100. }
  101.  
  102. # These methods work for Entry and Text
  103. # and can be overridden where they don't work
  104.  
  105. sub deleteSelected
  106. {
  107.  my $w = shift;
  108.  catch { $w->delete('sel.first','sel.last') };
  109. }
  110.  
  111.  
  112. 1;
  113. __END__
  114.  
  115. sub getSelected
  116. {
  117.  my $w   = shift;
  118.  my $val = Tk::catch { $w->get('sel.first','sel.last') };
  119.  return $val;
  120. }
  121.  
  122.  
  123.