Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | #!/import/bw/tools/local/perl-5.8.0/bin/perl -w |
2 | ||
3 | eval 'exec /import/bw/tools/local/perl-5.8.0/bin/perl -w -S $0 ${1+"$@"}' | |
4 | if 0; # not running under some shell | |
5 | use strict; | |
6 | use IO; | |
7 | use Socket; | |
8 | use IO::Socket; | |
9 | use Cwd; | |
10 | ||
11 | use vars qw($VERSION $portfile); | |
12 | $VERSION = '3.006'; # $Id: //depot/Tk8/ptked#23 $ | |
13 | ||
14 | my %opt; | |
15 | INIT | |
16 | { | |
17 | my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'}; | |
18 | $portfile = "$home/.ptkedsn"; | |
19 | my $port = $ENV{'PTKEDPORT'}; | |
20 | return if $^C; | |
21 | getopts("s",\%opt); | |
22 | unless (defined $port) | |
23 | { | |
24 | if (open(SN,"$portfile")) | |
25 | { | |
26 | $port = <SN>; | |
27 | close(SN); | |
28 | } | |
29 | } | |
30 | if (defined $port) | |
31 | { | |
32 | my $sock = IO::Socket::INET->new(PeerAddr => 'localhost', | |
33 | PeerPort => $port, Proto => 'tcp'); | |
34 | if ($sock) | |
35 | { | |
36 | binmode($sock); | |
37 | $sock->autoflush; | |
38 | foreach my $file (@ARGV) | |
39 | { | |
40 | unless (print $sock "$file\n") | |
41 | { | |
42 | die "Cannot print $file to socket:$!"; | |
43 | } | |
44 | print "Requested '$file'\n"; | |
45 | } | |
46 | $sock->close || die "Cannot close socket:$!"; | |
47 | exit(0); | |
48 | } | |
49 | else | |
50 | { | |
51 | warn "Cannot connect to server on $port:$!"; | |
52 | } | |
53 | } | |
54 | } | |
55 | ||
56 | use Tk; | |
57 | use Tk::DropSite qw(XDND KDE Sun); | |
58 | use Tk::DragDrop qw(XDND KDE Sun); | |
59 | use Tk::widgets qw(TextUndo Scrollbar Menu); | |
60 | use Getopt::Std; | |
61 | # use Tk::ErrorDialog; | |
62 | ||
63 | ||
64 | my $top = MainWindow->new(); | |
65 | ||
66 | if ($opt{'s'}) | |
67 | { | |
68 | my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp'); | |
69 | die "Cannot open listen socket:$!" unless defined $sock; | |
70 | binmode($sock); | |
71 | ||
72 | my $port = $sock->sockport; | |
73 | $ENV{'PTKEDPORT'} = $port; | |
74 | open(SN,">$portfile") || die "Cannot open $portfile:$!"; | |
75 | print SN $port; | |
76 | close(SN); | |
77 | print "Accepting connections on $port\n"; | |
78 | $top->fileevent($sock,'readable', | |
79 | sub | |
80 | { | |
81 | print "accepting $sock\n"; | |
82 | my $client = $sock->accept; | |
83 | if (defined $client) | |
84 | { | |
85 | binmode($client); | |
86 | print "Connection $client\n"; | |
87 | $top->fileevent($client,'readable',[\&EditRequest,$client]); | |
88 | } | |
89 | }); | |
90 | } | |
91 | ||
92 | Tk::Event::HandleSignals(); | |
93 | $SIG{'INT'} = sub { $top->WmDeleteWindow }; | |
94 | ||
95 | $top->iconify; | |
96 | $top->optionAdd('*TextUndo.Background' => '#fff5e1'); | |
97 | $top->fontCreate('ptked',-family => 'courier', -size => ($^O eq 'MSWin32' ? 11 : -12), | |
98 | -weight => 'normal', -slant => 'roman'); | |
99 | $top->optionAdd('*TextUndo.Font' => 'ptked'); | |
100 | ||
101 | foreach my $file (@ARGV) | |
102 | { | |
103 | Create_Edit($file); | |
104 | } | |
105 | ||
106 | ||
107 | sub EditRequest | |
108 | { | |
109 | my ($client) = @_; | |
110 | local $_; | |
111 | while (<$client>) | |
112 | { | |
113 | chomp($_); | |
114 | print "'$_'\n", | |
115 | Create_Edit($_); | |
116 | } | |
117 | warn "Odd $!" unless eof($client); | |
118 | $top->fileevent($client,'readable',''); | |
119 | print "Close $client\n"; | |
120 | $client->close; | |
121 | } | |
122 | ||
123 | MainLoop; | |
124 | unlink("$portfile"); | |
125 | exit(0); | |
126 | ||
127 | sub Create_Edit | |
128 | { | |
129 | my $path = shift; | |
130 | my $ed = $top->Toplevel(-title => $path); | |
131 | $ed->withdraw; | |
132 | $top->{'Edits'}++; | |
133 | $ed->OnDestroy([\&RemoveEdit,$top]); | |
134 | my $t = $ed->Scrolled('TextUndo', -wrap => 'none', -scrollbars => 'osre'); | |
135 | $t->pack(-expand => 1, -fill => 'both'); | |
136 | $t = $t->Subwidget('textundo'); | |
137 | my $menu = $t->menu; | |
138 | $menu->cascade(-label => '~Help', -menuitems => [ | |
139 | [Button => '~About...', -command => [\&About,$ed]], | |
140 | ]); | |
141 | $ed->configure(-menu => $menu); | |
142 | my $dd = $t->DragDrop(-event => '<Meta-B1-Motion>'); | |
143 | $t->bind(ref($t),'<Meta-B1-Motion>',\&Ouch); | |
144 | $t->bind(ref($t),'<Meta-ButtonPress>',\&Ouch); | |
145 | $t->bind(ref($t),'<Meta-ButtonRelease>',\&Ouch); | |
146 | $dd->configure(-startcommand => | |
147 | sub | |
148 | { | |
149 | return 1 unless (eval { $t->tagNextrange(sel => '1.0','end')}); | |
150 | $dd->configure(-text => $t->get('sel.first','sel.last')); | |
151 | }); | |
152 | ||
153 | $t->DropSite(-motioncommand => | |
154 | sub | |
155 | { my ($x,$y) = @_; | |
156 | $t->markSet(insert => "\@$x,$y"); | |
157 | }, | |
158 | -dropcommand => [\&HandleDrop,$t], | |
159 | ); | |
160 | ||
161 | ||
162 | ||
163 | $ed->protocol('WM_DELETE_WINDOW',[ConfirmExit => $t]); | |
164 | $t->bind('<F3>',\&DoFind); | |
165 | ||
166 | $ed->idletasks; | |
167 | if (-e $path) | |
168 | { | |
169 | $t->Load($path); | |
170 | } | |
171 | else | |
172 | { | |
173 | $t->FileName($path); | |
174 | } | |
175 | $ed->deiconify; | |
176 | $t->update; | |
177 | $t->focus; | |
178 | } | |
179 | ||
180 | sub Ouch | |
181 | { | |
182 | warn join(',','Ouch',@_); | |
183 | } | |
184 | ||
185 | sub RemoveEdit | |
186 | { | |
187 | my $top = shift; | |
188 | if (--$top->{'Edits'} == 0) | |
189 | { | |
190 | $top->destroy unless $opt{'s'}; | |
191 | } | |
192 | } | |
193 | ||
194 | sub HandleDrop | |
195 | {my ($t,$seln,$x,$y) = @_; | |
196 | # warn join(',',Drop => @_); | |
197 | my $string; | |
198 | Tk::catch { $string = $t->SelectionGet(-selection => $seln,'FILE_NAME') }; | |
199 | if ($@) | |
200 | { | |
201 | Tk::catch { $string = $t->SelectionGet(-selection => $seln) }; | |
202 | if ($@) | |
203 | { | |
204 | my @targets = $t->SelectionGet(-selection => $seln, 'TARGETS'); | |
205 | $t->messageBox(-text => "Targets : ".join(' ',@targets)); | |
206 | } | |
207 | else | |
208 | { | |
209 | $t->markSet(insert => "\@$x,$y"); | |
210 | $t->insert(insert => $string); | |
211 | } | |
212 | } | |
213 | else | |
214 | { | |
215 | Create_Edit($string); | |
216 | } | |
217 | } | |
218 | ||
219 | ||
220 | my $str; | |
221 | ||
222 | sub DoFind | |
223 | { | |
224 | my $t = shift; | |
225 | $str = shift if (@_); | |
226 | my $posn = $t->index('insert+1c'); | |
227 | $t->tag('remove','sel','1.0','end'); | |
228 | local $_; | |
229 | while ($t->compare($posn,'<','end')) | |
230 | { | |
231 | my ($line,$col) = split(/\./,$posn); | |
232 | $_ = $t->get("$line.0","$posn lineend"); | |
233 | pos($_) = $col; | |
234 | if (/\G(.*)$str/g) | |
235 | { | |
236 | $col += length($1); | |
237 | $posn = "$line.$col"; | |
238 | $t->SetCursor($posn); | |
239 | $t->tag('add','sel',$posn,"$line.".pos($_)); | |
240 | $t->focus; | |
241 | return; | |
242 | } | |
243 | $posn = $t->index("$posn lineend + 1c"); | |
244 | } | |
245 | } | |
246 | ||
247 | sub AskFind | |
248 | { | |
249 | my ($t) = @_; | |
250 | unless (exists $t->{'AskFind'}) | |
251 | { | |
252 | my $d = $t->{'AskFind'} = $t->Toplevel(-popover => 'cursor', -popanchor => 'nw'); | |
253 | $d->title('Find...'); | |
254 | $d->withdraw; | |
255 | $d->transient($t->toplevel); | |
256 | my $e = $d->Entry->pack; | |
257 | $e->bind('<Return>', sub { $d->withdraw; DoFind($t,$e->get); }); | |
258 | $d->protocol(WM_DELETE_WINDOW =>[withdraw => $d]); | |
259 | } | |
260 | $t->{'AskFind'}->Popup; | |
261 | $t->update; | |
262 | $t->{'AskFind'}->focusNext; | |
263 | } | |
264 | ||
265 | sub About | |
266 | { | |
267 | my $mw = shift; | |
268 | $mw->Dialog(-text => <<"END",-popover => $mw)->Show; | |
269 | $0 version $VERSION | |
270 | perl$]/Tk$Tk::VERSION | |
271 | ||
272 |