File: tkviewtest

package info (click to toggle)
libpdl-io-hdf5-perl 0.6501-2
  • links: PTS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 360 kB
  • ctags: 45
  • sloc: perl: 1,243; makefile: 15
file content (108 lines) | stat: -rwxr-xr-x 2,714 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
#!/usr/bin/perl

# Demo script using PDL::IO::HDF5 and Tk to show an HDF5 file structure
#



 use Tk;
 use PDL::IO::HDF5::tkview;
 use PDL::IO::HDF5;
 use Tk::Balloon;


 my $maxElements = 50;  # Largest Array  (in number of elements) that we 
 			# will try to show in a popup balloon

 my $filename = shift @ARGV || 'varlen.hdf5';

 my $mw = MainWindow->new;


 my $b = $mw->Balloon;
 
 my $h5 = new PDL::IO::HDF5($filename);  # open HDF5 file object

 my $tkview = new PDL::IO::HDF5::tkview( $mw, $h5);
 

my $tree = $tkview->{hl};
my $lastItem = '';
my $mouseItem;
my ($pointerX,$pointerY);
my @BBox = (0,0,0,0);
$b->attach($tree,
             -balloonposition => 'mouse',
             -postcommand => sub {

		 #print "Box for $item is ".join(", ",@BBox)."\n";
		 #print "Box for $mouseItem is ".join(", ",@BBox)."\n";
		 #print "y = $pointerY\n";
		 if( ($pointerY >= $BBox[1] ) && ($pointerY <= $BBox[3]) &&   # Popup balloon if withing bounding box
			$mouseItem =~ /$;_Dset(.+)$/ ){   			  # and a dataset item
			 my $datasetName = $1;
			 my $text = $tree->entrycget($mouseItem,'-text');
			 my $elements = 1;
			 if(  $text =~ /\: Dims (.+)$/ ){
 				 my @dims = split(',',$1);
				 my $message;
				 foreach (@dims){
					 $elements *= $_;
				 }
			}
			if( $elements > $maxElements){
				$message = "$elements Elements: Too Big To Display";
			}
			else{
				my $group = $tree->entrycget($mouseItem,'-data');
				my $PDL = $group->dataset($datasetName)->get;
				$message = "$PDL";
			}
			$b->{"clients"}{$tree}{-balloonmsg} = $message;
			return 1;
		}
		
		 0;
             },
             -motioncommand => sub {
                # my $e = $tree->XEvent;
        	# print "xevent is a ".ref($e)."\n";

                 ($pointerX,$pointerY) = $tree->pointerxy;
		 $pointerX -= $tree->rootx;
		 $pointerY -= $tree->rooty;
                 $mouseItem = $tree->nearest($pointerY);
		 # print "MouseItem = '$mouseItem'\n";
		 my $infoBBox = $tree->infoBbox($mouseItem);
		 # print "infoBBox = '$infoBBox'\n";
		 return 1 unless defined($infoBBox);
		
		 if( ref($infoBBox)){ # Handle the different ways that
		 		      # tk does the bounding box for 800.015 and 800.018, etc
		 	@BBox =  @$infoBBox;
		 }
		 else{
			@BBox = split(' ', $infoBBox);
		 }
		 # print "Bbox = ".join(", ",@BBox)."\n";
		 # print "lastItem = '$lastItem', mouseItem = '$mouseItem'\n";
		 if( ( $lastItem eq $mouseItem ) && 
			 ($pointerY >= $BBox[1] ) && ($pointerY <= $BBox[3]) ){
			 # Same item, and withing it's bounding box don't cancel the Balloon
			 0;
		 }
		 else{
			 # New item - cancel it so a new balloon will
			 # be posted
			 $lastItem = $mouseItem;
			 1;

		 }

             }

	     );


 MainLoop;