#!/import/bw/tools/local/perl-5.8.0/bin/perl -w
eval 'exec /import/bw/tools/local/perl-5.8.0/bin/perl -w -S $0 ${1+"$@"}'
if 0; # not running under some shell
use vars qw($VERSION $portfile);
$VERSION = '3.006'; # $Id: //depot/Tk8/ptked#23 $
my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'};
$portfile = "$home/.ptkedsn";
my $port = $ENV{'PTKEDPORT'};
if (open(SN,"$portfile"))
my $sock = IO::Socket::INET->new(PeerAddr => 'localhost',
PeerPort => $port, Proto => 'tcp');
unless (print $sock "$file\n")
die "Cannot print $file to socket:$!";
print "Requested '$file'\n";
$sock->close || die "Cannot close socket:$!";
warn "Cannot connect to server on $port:$!";
use Tk::DropSite qw(XDND KDE Sun);
use Tk::DragDrop qw(XDND KDE Sun);
use Tk::widgets qw(TextUndo Scrollbar Menu);
my $top = MainWindow->new();
my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp');
die "Cannot open listen socket:$!" unless defined $sock;
my $port = $sock->sockport;
$ENV{'PTKEDPORT'} = $port;
open(SN,">$portfile") || die "Cannot open $portfile:$!";
print "Accepting connections on $port\n";
$top->fileevent($sock,'readable',
print "accepting $sock\n";
my $client = $sock->accept;
print "Connection $client\n";
$top->fileevent($client,'readable',[\&EditRequest,$client]);
Tk::Event::HandleSignals();
$SIG{'INT'} = sub { $top->WmDeleteWindow };
$top->optionAdd('*TextUndo.Background' => '#fff5e1');
$top->fontCreate('ptked',-family => 'courier', -size => ($^O eq 'MSWin32' ? 11 : -12),
-weight => 'normal', -slant => 'roman');
$top->optionAdd('*TextUndo.Font' => 'ptked');
warn "Odd $!" unless eof($client);
$top->fileevent($client,'readable','');
my $ed = $top->Toplevel(-title => $path);
$ed->OnDestroy([\&RemoveEdit,$top]);
my $t = $ed->Scrolled('TextUndo', -wrap => 'none', -scrollbars => 'osre');
$t->pack(-expand => 1, -fill => 'both');
$t = $t->Subwidget('textundo');
$menu->cascade(-label => '~Help', -menuitems => [
[Button => '~About...', -command => [\&About,$ed]],
$ed->configure(-menu => $menu);
my $dd = $t->DragDrop(-event => '<Meta-B1-Motion>');
$t->bind(ref($t),'<Meta-B1-Motion>',\&Ouch);
$t->bind(ref($t),'<Meta-ButtonPress>',\&Ouch);
$t->bind(ref($t),'<Meta-ButtonRelease>',\&Ouch);
$dd->configure(-startcommand =>
return 1 unless (eval { $t->tagNextrange(sel => '1.0','end')});
$dd->configure(-text => $t->get('sel.first','sel.last'));
$t->DropSite(-motioncommand =>
$t->markSet(insert => "\@$x,$y");
-dropcommand => [\&HandleDrop,$t],
$ed->protocol('WM_DELETE_WINDOW',[ConfirmExit => $t]);
$t->bind('<F3>',\&DoFind);
warn join(',','Ouch',@_);
if (--$top->{'Edits'} == 0)
$top->destroy unless $opt{'s'};
{my ($t,$seln,$x,$y) = @_;
# warn join(',',Drop => @_);
Tk::catch { $string = $t->SelectionGet(-selection => $seln,'FILE_NAME') };
Tk::catch { $string = $t->SelectionGet(-selection => $seln) };
my @targets = $t->SelectionGet(-selection => $seln, 'TARGETS');
$t->messageBox(-text => "Targets : ".join(' ',@targets));
$t->markSet(insert => "\@$x,$y");
$t->insert(insert => $string);
my $posn = $t->index('insert+1c');
$t->tag('remove','sel','1.0','end');
while ($t->compare($posn,'<','end'))
my ($line,$col) = split(/\./,$posn);
$_ = $t->get("$line.0","$posn lineend");
$t->tag('add','sel',$posn,"$line.".pos($_));
$posn = $t->index("$posn lineend + 1c");
unless (exists $t->{'AskFind'})
my $d = $t->{'AskFind'} = $t->Toplevel(-popover => 'cursor', -popanchor => 'nw');
$d->transient($t->toplevel);
$e->bind('<Return>', sub { $d->withdraw; DoFind($t,$e->get); });
$d->protocol(WM_DELETE_WINDOW =>[withdraw => $d]);
$t->{'AskFind'}->focusNext;
$mw->Dialog(-text => <<"END",-popover => $mw)->Show;
Copyright © 1995-2000 Nick Ing-Simmons. All rights reserved.
This package is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
ptked - an editor in Perl/Tk
S< >B<ptked> [I<file-to-edit>]
B<ptked> is a simple text editor based on perl/Tk's TextUndo widget.