File: dnd_demo

package info (click to toggle)
perl-tk 1:800.025-2
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 18,444 kB
  • ctags: 19,081
  • sloc: ansic: 206,740; perl: 40,187; makefile: 4,371; sh: 2,373; yacc: 762
file content (617 lines) | stat: -rwxr-xr-x 16,393 bytes parent folder | download | duplicates (4)
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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
#!/usr/local/bin/perl -w
#
# Demo code to exhibit features of dynamic construction and destruction of 
# local (within app.) Drag and Drop sources and sinks. Written for and tested 
# with Perl v5.004_01 and Tk version 400.202, on a DEC Alpha (OSI) platform.
#
# Drag and drop is only possible after the 'New' button has been used, and
# DropSites cease to respond once they've been filled. After the 'Save' button
# is used, dragging from the listbox is no longer possible.
#
# Pod documentation appended is a draft outline for the official documentation,
# and is almost certainly neither complete nor correct. Comments/suggestions 
# for improvements welcomed.
#
# John Attwood (ja1@sanger.ac.uk), May '98
#


use Tk;
use Tk::Table;
use Tk::DragDrop;
use Tk::DropSite;
use strict;

my ($ButtonClr, $ListClr, $DfltClr) = ("SkyBlue1", "LightSkyBlue2", "#d9d9d9");
my ($rows, $marker_repeat) = (9, 4);
my $font3 = '-*-fixed-*-*-*-*-*-140-*-*-*-*-*-*';
my ($rdgel_ref, $user_id, $session_id, $source, @clones, @enzymes, @reqs, 
    @lbls, @drops, $method);
my $changed = 0; 

#
# Create a main window with a listbox, a table and some buttons 
#

my $w = MainWindow->new();
$w->title("Drag and Drop demo");
$w->iconname("DnD demo");
my $w_buttons = $w->Frame;
$w->Label(-text => "The radiobuttons control the contents of the drag window " .
	  "(choice must be made before pressing New).")
    ->pack(-side => 'bottom');
$w->Label(-text => "Use New to set up DnD, then drag rows from listbox to blue " .
		  "DropSites in the Table. Use Save to inhibit further " .
	  "Drag/Dropping.")
    ->pack(-side => 'bottom');
my $tf = $w->Frame->pack(-side => 'right');
my $table = $tf->Table(-rows => 10,
		      -columns => 3,
		      -scrollbars => '',
		      -fixedrows => 1,
		      -fixedcolumns => 1,
		      -takefocus => 1,
		     );
$table->pack(-side => 'bottom', -fill => 'both');
my $geltitle = $tf->Label(-relief => 'raised')->pack(-side => 'top', 
						     -fill => 'x');
$w_buttons->pack(qw(-side bottom -fill x -pady 0.5m));
											 
$w_buttons->Button(
		   -background => $ButtonClr,
		   -text    => 'Quit',
		   -command => [\&Done],
)->pack(qw(-side right -expand 1));
my $save_btn = $w_buttons->Button(
		   -background => $ButtonClr,
		   -text    => 'Save',
		   -command => [\&SaveGel],
		   -state => 'disabled'
)->pack(qw(-side right -expand 1));
$method = 'variable';
$w_buttons->Button(-background => $ButtonClr, -text => "New",
	    -command => \&NewGel)->pack(-side => 'right');
my $bf = $w_buttons->Frame->pack(-side => 'left');
$bf->Radiobutton(-text => 'Image', -value => 'image',
		 -variable => \$method)->pack(-side => 'top',
					      -anchor => 'nw');
$bf->Radiobutton(-text => 'Text', -value => 'text',
		 -variable => \$method)->pack(-side => 'top',
					      -anchor => 'nw');
$bf->Radiobutton(-text => 'Variable', -value => 'variable',
		 -variable => \$method)->pack(-side => 'top',
					      -anchor => 'nw');
my $aw = $w->Frame->pack(qw(-side bottom));
$aw->Label(-text => "Requests Outstanding")->pack(-side => 'top', 
						  -fill => 'x');
my $lb = $aw->Listbox(-height => 10, -width => 62, 
		      -background => $DfltClr, -font => $font3);
$lb->pack(-side => 'left', -fill => 'y');
my $awsb = $aw->Scrollbar(-command => [$lb => 'yview']);
$awsb->pack(-side => 'right', -fill => 'y');
$lb->configure(-yscrollcommand => [$awsb => 'set']);

#
# Make the listbox a Drag and Drop source, but disable this for now by
# binding -startcommand to a routine which does nothing but return true
# (indicating that it has handled the Drag initialisation itself)
#
# The last 3 parameters to the DragDrop invocation are (mutually exclusive)
# alternatives, the commented-out versions allow fixed text or a fixed image
# to be displayed in the Drag window, whilst defining a -startcommand callback
# allows us to choose the text on the fly and show visually exactly what is 
# being dragged.
#

$source = $lb->DragDrop(-event => '<B1-Motion>',
			-sitetypes => [qw(Local)],
			-handlers => [[\&send_string],
				      [-type => 'FILE_NAME', 
				       \&send_file]],
			-startcommand => [\&DragInhibit],
#			-image => $image,    #use an image, not text
#			-text => "this is it", #fixed text string
			);


#
# Generate a bitmap for use with Drag and Drop.
#

my $image = $w->Bitmap('win', # -file => 'win.xbm'
		       -data => "#define win.xbm_width 16
#define win.xbm_height 16
static char win.xbm_bits[] = {
   0xff, 0xff, 0x0d, 0xb0, 0xff, 0xff, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80,
   0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80,
   0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0xff, 0xff};
");

#
# Populate the table and listbox
#

BuildTable();
Fill_lb();

#
# Let the user interact
#

MainLoop();

######################################################################
#
# End of main program, start of subroutines
#
#

#
# Put some data into the listbox so that it can be dragged and dropped
#

sub Fill_lb {
    my @data = (
"W08A5           HindIII      01-JAN-98 ja1        Re-requested        19070",
"Ab113C11        BamHI        01-JAN-98 ja1        Re-requested        18399",
"Ab113C11        EcoRI        01-JAN-98 ja1        Re-requested        18400",
"Ab113C11        HindIII      01-JAN-98 ja1        Re-requested        18401",
"cP91H8          EcoRI        01-JAN-98 ja1        Re-requested        18535",
"cP91H8          HindIII      01-JAN-98 ja1        Re-requested        18536"
		);
    $lb->delete('0','end');
    $lb->insert('end',@data);
}

#
# Populate the rows and columns of the table. Inactive (marker) rows just have
# a label; remainder have a label (which will become a dropsite) plus two
# readonly text-entry fields to display the dropped data
#

sub BuildTable {
    my ($row);

    $table->put(0, 1, $table->Label(-text => "Clone", 
				    -relief => 'raised', 
				    -width => 15)); 
    $table->put(0, 2, $table->Label(-text => "Enzyme", 
				    -relief => 'raised', 
				    -width => 15)); 
    foreach $row (1..$rows) {
	if (($row - 1) % $marker_repeat == 0) {
	    my $lbl = $table->Label(-text => "Marker", 
				    -relief => 'sunken', 
				    -width => 15);
	    $table->put($rows - $row + 1,0,$lbl);
	} else {
	    my $lbl = $table->Label(-text => "Lane $row", 
				    -relief => 'sunken',
				    );
	    $lbls[$row] = $lbl;
	    $table->put($rows - $row + 1,0,$lbl);
	    my $centry = $table->Entry(-width => 15, 
				       -textvariable => \$clones[$row], 
				       -state => 'disabled');
	    $table->put($rows - $row + 1,1,$centry);
	    my $dentry = $table->Entry(-width => 15, 
				       -textvariable => \$enzymes[$row], 
				       -state => 'disabled');
	    $table->put($rows - $row + 1,2,$dentry);
	}
    }
}

#
# Make active Dropsites respond (by changing their relief) when dragged object
# passes over them
#

sub SiteEntry {
    my ($lbl, $entry, @data) = @_;
    $lbl->configure(-relief => $entry == 1 ? 'raised' : 'sunken');
}

#
# This handler would be invoked if our drop handler specified FILE_NAME as
# the data type. Not used here, but included for illustration.
#

sub send_file {
     my ($offset,$max) = @_;

     return __FILE__;
}

#
# get current selection from listbox and return it to dropsite
#

sub send_string
{
 my ($offset,$max) = @_;
    my ($lb_sel) = $lb->curselection;
    my ($req) = $lb->get($lb_sel);
 return $req;
}

#
# Handle a drop - get dragged text, break into components and place in arrays
# to be displayed in table, delete source from listbox, kill the dropsite and
# make its colour revert to default.
#

sub Dropit {
    my ($row,$seln) = @_;
    print "$row  $seln\n";
    my ($rdreq) = $lb->SelectionGet('-selection'=>$seln,'STRING');
    print "$rdreq\n";
    my ($clone, $enz) = split " ", $rdreq;
    $clones[$row] = $clone;
    $enzymes[$row] = $enz;
    my ($lb_sel) = $lb->curselection;
    $lb->delete($lb_sel);
    $lb->selectionSet($lb_sel);
    $reqs[$row] = $rdreq;
    $drops[$row]->delete;
    $lbls[$row]->configure(-bg => $DfltClr);
    $changed = 1;
}

#
# Empty the table contents
#

sub cleargel {
    my ($title) = @_;
    my $i;

    foreach $i (0..$rows) {
	$clones[$i] = $enzymes[$i] = "";
    }
    $geltitle->configure(-text => "Gel: $title");
    $changed = 0;
}

# Activate the DragDrop source by redefining -startcommand to something
# useful and which returns 0 to indicate that the StartDrag process hasn't
# been handled and should be managed by the object's own code.
# Make all labels in active table rows into dropsites, colouring them blue.
#

sub NewGel {
    my $i;

    cleargel("Untitled");
    print "$method\n";
    if ($method eq 'variable') {
	$source->configure(-startcommand => [\&DragSetup, $lb]);
	$source->configure(-image => undef);
    } elsif ($method eq 'text') {
	$source->configure(-text => "Dragging");
	$source->configure(-image => undef);
	$source->configure(-startcommand => \&DragOK);
    } else {
	$source->configure(-image => 'win');
	$source->configure(-startcommand => \&DragOK);
    }
    $lb->configure(-background => $ListClr);
    foreach $i (1..$rows) {
	if (($i - 1) % $marker_repeat > 0) {
	    $lbls[$i]->configure(-background => $ButtonClr);
	    $drops[$i] = $lbls[$i]->DropSite(-droptypes => [qw(Local)], 
			   -dropcommand => [\&Dropit,$i],
			   -entercommand => [\&SiteEntry, $lbls[$i]],
			   );
	}
    }
    $save_btn->configure(-state => 'normal');
    Fill_lb();
}

#
# Stop the listbox being a DnD source
# Kill off any active dropsites and turn everything grey again
#

sub SaveGel {
    my $gel = "newgel2";
    my ($statement, $sth, $lane);

    cleargel("<none>");
    $save_btn->configure(-state => 'disabled');
    $source->configure(-startcommand => [\&DragInhibit]);
    $lb->configure(-background => $DfltClr);
    foreach $lane (1..$rows) {
	if (($lane - 1) % $marker_repeat > 0) {
	    $drops[$lane]->delete;
	    $lbls[$lane]->configure(-bg => $DfltClr);
	}
    }
    Fill_lb();
}

#
# Disable Dragging by pretending that we've handled the initialisation
# of the drag window ourselves
#

sub DragInhibit {
    return 1;
}

#
# Enable dragging by asking the DragDrop object to initialise it for us
#

sub DragOK {
    return 0;
}

#
# Make the drag window show the text of what's being transferred
#
# Caution advised here in case we turn out to be dragging 2K of text!
#
# Returns 0 to indicate that the drag initialisation still needs to be
# handled by the source object.

sub DragSetup {
    my ($lb) = @_;

    my ($lb_sel) = $lb->curselection;
    my ($row) = $lb->get($lb_sel);
    my ($clone, $enzyme) = split " ", $row;
    my $text = sprintf "%s/%s", $clone, $enzyme;
    $source->configure(-text => $text);

    return 0;
}


#
# Clean up and quit
#

sub Done {
    exit 0;
}

END {

}

__END__

=head1 NAME


DragDrop - create and manipulate widgets whose selections can be dragged and dropped

DropSite - create and manipulate DropSites for Dragged selections

=head1 SYNOPSIS

    use Tk::DragDrop;
    use Tk::DropSite;

    $source = $widget->DragDrop(-event => '<Event>',
				-sitetypes => ['Local'],
				-handlers => [[\&callback],
					      [-type => 'TYPENAME', 
					        \&callback]],
			        );

    $drop = $widget->DropSite(-droptypes => ['Local'], 
			      -dropcommand => [\&Dropit,?params?],
			      );

=head1 DESCRIPTION

B<NB> This is unofficial documentation, believed to be correct but neither
complete not definitive. B<Caveat programmer!>

B<DragDrop> implements drag-and-drop for Tk apps. It should work on
any platform for local (within one application) droptypes, but only the Sun
interface is defined for global (interapplication) droptypes.

User can drag objects with the mouse (Button-1 by default) from
DragDrop sources, and drop them on DropSites. By default, pressing any key 
during the Drag operation will abort it. There is support for different
types of information transfer (eg STRING, ATOM, INTEGER - see Tk::Selection
and/or the X Inter-Client Communication Conventions Manual (ICCCM) 
for details) and also user-defined types (eg FILE_NAME in the example
code below) via user-defined handlers.

Local (intra-application) transfer is via the X Selection mechanism. Global 
(interapplication) transfer uses the Sun protocols defined in the
Tk::DragDrop::Sunconstant module.

=head2 Example Code


 use Tk;
 use Tk::DragDrop;
 use Tk::DropSite;

 @data = ('One','Two','Three', 'Four');

 $w = MainWindow->new();
 $lb = $w->Listbox->pack;
 $lb->insert('end', @data);
 $lab = $w->Label(-text => "Drop here!")->pack;

 $source = $lb->DragDrop(-event => '<B1-Motion>',
			 -sitetypes => [qw(Local)],
			 -handlers => [[\&send_string],
				       [-type => 'FILE_NAME', 
					\&send_file]]);
 $drop = $lab->DropSite(-droptypes => [qw(Local)], 
			-dropcommand => [\&Dropit, $lb],
			-entercommand => [\&SiteEntry, $lab],
			);
 MainLoop();

 sub send_file {
     my ($offset,$max) = @_;

     return __FILE__;
 }

 sub send_string {
    my ($offset,$max) = @_;

    my ($lb_sel) = $lb->curselection;
    my ($req) = $lb->get($lb_sel);
    return $req;
 }

 sub Dropit {
    my ($lb,$seln) = @_;

    my ($req) = $lb->SelectionGet('-selection'=>$seln,'STRING');
    print "$req\n";
 }

 sub SiteEntry {
     my ($w, $entry, @data) = @_;
     $w->configure(-relief => $entry == 1 ? 'raised' : 'sunken');
 }
 

=head1 CONFIGURATION

The non-standard options recognised by B<DragDrop> are as follows:-

=over 4

=item B<-event>

The event which will initiate dragging.

=item B<-sitetypes>

Whether the applications served by this source will be local ('local'), 
global ('Sun') or both (I<undef>).

=item B<-handlers>

Handler routines for each supported type of data to be 
transferred

=item B<-image>

Optionally a (bitmap) image to display instead of text when an
item is being dragged.

=item B<-startcommand>

Optionally a callback invoked before dragging is initiated. Subroutine
(which is called without any parameters) must return 0 if Drag is to be
allowed, otherwise the event will be ignored. Defaults to I<undef>.

=item B<-predropcommand>

Optionally a callback invoked before dropping occurs. Subroutine
(which will be called with the source application ID string and the 
dropsite widget as parameters) must return 0 if Drop is allowed, 
otherwise no handler is called. Defaults to I<undef>.

=item B<-postdropcommand>

Optionally a callback invoked after dropping occurs. Subroutine will
be called with the source application ID string and need not return
any specific value. Defaults to I<undef>.

=item B<-cursor>

Optionally the cursor to use whilst dragging. Defaults to 'hand2'

=item B<-text>

Optionally some fixed text to display in the drag window. 
Defaults to the classname of the parent widget.

=back

The non-standard options recognised by B<DropSite> are as follows:-

=over 4

=item B<-droptypes>

Whether items will be dropped from local ('local'), global ('Sun') 
or both (I<undef>) applications

=item B<-dropcommand>

Callback subroutine to invoke when something is dropped here

=item B<-entercommand>

Optionally, callback routine to invoke whenever dragged object
enters or leaves the DropSite. Defaults to I<undef>.

=back

=head1 METHODS

B<DragDrop> supports the following methods:-




B<DropSite> supports the following methods:-

=over 4

=item B<-delete>

Remove this object from the list of registered DropSites

=back

=head1 DEFAULT BINDINGS

=over 4

When the window representing the dragged object is mapped,
the Mapped method is called (class binding).

Any button motion invokes the Drag method (class binding).

Any button release invokes the Drop method (class binding).

Any keypress whilst dragging invokes the Done method,
aborting the drag (class binding).

Button 1 invokes the StartDrag method (instance binding).

=back

=head1 BUGS

There is currently no way a DragDrop source can remove an event
binding once it has been installed (however this can be done
manually by removing the binding from the parent widget).

Destroying a DragDrop source doesn't remove the binding from the
parent widget, causing Tk to complain if the bound callback is 
later invoked.

DropSites can't be within a scrolling Table (this is a Table bug,
not a DragDrop one).

=head1 AUTHORS

B<Nick Ing-Simmons> nik@tiuk.ti.com : Original module code

B<John Attwood> ja1@sanger.ac.uk    : This demo and draft pod docs


=cut