Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Copyright (c) 1995-1999 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 = '3.016'; # $Id: //depot/Tk8/Tk/Clipboard.pm#16 $ | |
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 { $w->insert('insert',$w->clipboardGet)}; | |
68 | } | |
69 | ||
70 | sub clipboardOperations | |
71 | { | |
72 | my @class = (); | |
73 | my $mw = shift; | |
74 | if (ref $mw) | |
75 | { | |
76 | $mw = $mw->DelegateFor('bind'); | |
77 | } | |
78 | else | |
79 | { | |
80 | push(@class,$mw); | |
81 | $mw = shift; | |
82 | } | |
83 | while (@_) | |
84 | { | |
85 | my $op = shift; | |
86 | $mw->Tk::bind(@class,"<<$op>>","clipboard$op"); | |
87 | } | |
88 | } | |
89 | ||
90 | # These methods work for Entry and Text | |
91 | # and can be overridden where they don't work | |
92 | ||
93 | sub deleteSelected | |
94 | { | |
95 | my $w = shift; | |
96 | catch { $w->delete('sel.first','sel.last') }; | |
97 | } | |
98 | ||
99 | ||
100 | 1; | |
101 | __END__ | |
102 | ||
103 | sub getSelected | |
104 | { | |
105 | my $w = shift; | |
106 | my $val = Tk::catch { $w->get('sel.first','sel.last') }; | |
107 | return $val; | |
108 | } | |
109 | ||
110 |