#!/opt/perl/bin/perl -w

use Tk;
use strict;


my $mw = 'MainWindow'->new();

my $tb = $mw->Frame->pack( -fill => 'x' );

$tb->Button( 
  -text => "GET CLIPBOARD", 
  -command => \&get_clipboard 
)->pack( -side => 'left' );
$tb->Button( 
  -text => "SET CLIPBOARD", 
  -command => \&set_clipboard 
)->pack( -side => 'left' );


MainLoop();



sub get_clipboard {
 
 print "\n";
 
 my $own =  $mw->SelectionExists( -selection => 'CLIPBOARD' );
 
 if( $own ) {
   printf "Owner of CLIPBOARD is 0x%x\n",$own;
   eval {
     my @targ = $mw->SelectionGet( 
        -selection => 'CLIPBOARD', 'TARGETS' 
     );
     
     for my $targ ( @targ ) {
       
       my @t = $mw->SelectionGet( 
         -selection => 'CLIPBOARD', $targ 
       );
       
       local $" = ', ';
       print "$targ => [ @t ]\n";
     
     }
   };
   my $e = $@;
   if( $e ) {
     print $e;
   }
  }
}


sub set_clipboard {
 
 print "\n";
 
 $mw->SelectionOwn( -selection => 'CLIPBOARD' );
 
 $mw->SelectionHandle( -selection => 'CLIPBOARD',
    -type => 'MULTIPLE',  
    -format => 'INTEGER',
    sub { return ( 325, 323, 324, 462 ) }
 );
 
 my $file = "/home/philou/Desktop/gtkperl-tutorial.ps";

 $mw->SelectionHandle( -selection => 'CLIPBOARD',
    -type => 'x-special/gnome-copied-files',  
    sub { return "copy\nfile://$file" }
 );
 
 $mw->SelectionHandle( -selection => 'CLIPBOARD',
    -type => 'UTF8_STRING',  
    sub { return "file://$file\n" }
 );
 
}
[download]