#!/usr/local/bin/perl -w
use
vars
qw($VERSION $portfile)
;
$VERSION
=
'4.030'
;
my
%opt
;
INIT
{
my
$home
=
$ENV
{
'HOME'
} ||
$ENV
{
'HOMEDRIVE'
}.
$ENV
{
'HOMEPATH'
};
$portfile
=
"$home/.ptkedsn"
;
my
$port
=
$ENV
{
'PTKEDPORT'
};
return
if
$^C;
GetOptions(\
%opt
,
qw(server! encoding=s geometry=s)
);
unless
(
defined
$port
)
{
if
(
open
(SN,
"$portfile"
))
{
$port
= <SN>;
close
(SN);
}
}
if
(
defined
$port
)
{
my
$sock
= IO::Socket::INET->new(
PeerAddr
=>
'localhost'
,
PeerPort
=>
$port
,
Proto
=>
'tcp'
);
if
(
$sock
)
{
binmode
(
$sock
);
$sock
->autoflush;
foreach
my
$file
(
@ARGV
)
{
unless
(
print
$sock
"$file\n"
)
{
die
"Cannot print $file to socket:$!"
;
}
print
"Requested '$file'\n"
;
}
$sock
->
close
||
die
"Cannot close socket:$!"
;
exit
(0);
}
else
{
warn
"Cannot connect to server on $port:$!"
;
}
}
}
{
@Tk::TextUndoPtked::ISA
=
qw(Tk::TextUndo)
;
Construct Tk::Widget
'TextUndoPtked'
;
sub
Save {
my
$w
=
shift
;
$w
->SUPER::Save(
@_
);
$w
->toplevel->title(
$w
->FileName);
}
sub
Load {
my
$w
=
shift
;
$w
->SUPER::Load(
@_
);
$w
->toplevel->title(
$w
->FileName);
}
sub
MenuLabels {
shift
->SUPER::MenuLabels,
'Encoding'
}
sub
Encoding
{
my
(
$w
,
$enc
) =
@_
;
if
(
@_
> 1)
{
$enc
=
$w
->getEncoding(
$enc
)
unless
ref
(
$enc
);
$w
->{ENCODING} =
$enc
;
$enc
=
$enc
->name;
$w
->{ENCODINGNAME} =
$enc
;
$w
->PerlIO_layers(
":encoding($enc)"
);
}
return
$w
->{ENCODING};
}
sub
EncodingMenuItems
{
my
(
$w
) =
@_
;
my
@menu
;
my
@encoding_defs
= (
[
'Unicode (UTF-8)'
,
'utf-8-strict'
],
[
'Western (iso-8859-1)'
,
'iso-8859-1'
],
[
'Western (Windows-1252)'
,
'cp1252'
],
[
"Western with \x{20ac} (iso-8859-15)"
,
'iso-8859-15'
],
[
'Central European (Windows-1250)'
,
'cp1250'
],
);
if
(!
grep
{
$_
->[1] eq Tk::SystemEncoding()->name }
@encoding_defs
)
{
unshift
@encoding_defs
, [
'System'
, Tk::SystemEncoding()->name];
}
for
my
$encoding_def
(
@encoding_defs
)
{
my
(
$label
,
$encoding
) =
@$encoding_def
;
push
@menu
, [
radiobutton
=>
$label
,
-command
=> [
$w
,
Encoding
=>
$encoding
],
-variable
=> \
$w
->{ENCODINGNAME},
-value
=>
$encoding
];
}
return
[
@menu
];
}
}
my
$top
= MainWindow->new();
$top
->geometry(
'+0+0'
);
if
(
$opt
{
'server'
})
{
my
$sock
= IO::Socket::INET->new(
Listen
=> 5,
Proto
=>
'tcp'
);
die
"Cannot open listen socket:$!"
unless
defined
$sock
;
binmode
(
$sock
);
my
$port
=
$sock
->sockport;
$ENV
{
'PTKEDPORT'
} =
$port
;
open
(SN,
">$portfile"
) ||
die
"Cannot open $portfile:$!"
;
print
SN
$port
;
close
(SN);
print
"Accepting connections on $port\n"
;
$top
->fileevent(
$sock
,
'readable'
,
sub
{
print
"accepting $sock\n"
;
my
$client
=
$sock
->
accept
;
if
(
defined
$client
)
{
binmode
(
$client
);
print
"Connection $client\n"
;
$top
->fileevent(
$client
,
'readable'
,[\
&EditRequest
,
$client
]);
}
});
}
Tk::Event::HandleSignals();
$SIG
{
'INT'
} =
sub
{
$top
->WmDeleteWindow };
$top
->iconify;
$top
->optionAdd(
'*TextUndoPtked.Background'
=>
'#fff5e1'
);
$top
->fontCreate(
'ptked'
,
-family
=>
'courier'
,
-size
=> ($^O eq
'MSWin32'
? 11 : -12),
-weight
=>
'normal'
,
-slant
=>
'roman'
);
$top
->optionAdd(
'*TextUndoPtked.Font'
=>
'ptked'
);
if
(
@ARGV
)
{
foreach
my
$file
(
@ARGV
)
{
Create_Edit(
$file
);
}
}
else
{
Create_Edit();
}
sub
EditRequest
{
my
(
$client
) =
@_
;
local
$_
;
while
(<
$client
>)
{
chomp
(
$_
);
print
"'$_'\n"
,
Create_Edit(
$_
);
}
warn
"Odd $!"
unless
eof
(
$client
);
$top
->fileevent(
$client
,
'readable'
,
''
);
print
"Close $client\n"
;
$client
->
close
;
}
MainLoop;
unlink
(
"$portfile"
);
exit
(0);
sub
Create_Edit
{
my
$path
=
shift
;
my
$ed
=
$top
->Toplevel(
-title
=>
$path
);
$ed
->geometry(
$opt
{geometry})
if
$opt
{geometry};
$ed
->withdraw;
$top
->{
'Edits'
}++;
$ed
->OnDestroy([\
&RemoveEdit
,
$top
]);
my
$t
=
$ed
->Scrolled(
'TextUndoPtked'
,
-wrap
=>
'none'
,
-scrollbars
=>
'se'
,
);
$t
->
pack
(
-expand
=> 1,
-fill
=>
'both'
);
$t
=
$t
->Subwidget(
'scrolled'
);
$t
->Encoding(
$opt
{encoding} || Tk::SystemEncoding()->name);
my
$menu
=
$t
->menu;
$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
=>
sub
{
return
1
unless
(
eval
{
$t
->tagNextrange(
sel
=>
'1.0'
,
'end'
)});
$dd
->configure(
-text
=>
$t
->get(
'sel.first'
,
'sel.last'
));
});
$t
->DropSite(
-motioncommand
=>
sub
{
my
(
$x
,
$y
) =
@_
;
$t
->markSet(
insert
=>
"\@$x,$y"
);
},
-dropcommand
=> [\
&HandleDrop
,
$t
],
);
$ed
->protocol(
'WM_DELETE_WINDOW'
,[
ConfirmExit
=>
$t
]);
$t
->
bind
(
'<F3>'
,\
&DoFind
);
$ed
->idletasks;
if
(
defined
$path
&& -e
$path
)
{
$t
->Load(
$path
);
}
else
{
$t
->FileName(
$path
);
}
$ed
->deiconify;
$t
->update;
$t
->focus;
}
sub
Ouch
{
warn
join
(
','
,
'Ouch'
,
@_
);
}
sub
RemoveEdit
{
my
$top
=
shift
;
if
(--
$top
->{
'Edits'
} == 0)
{
$top
->destroy
unless
$opt
{
's'
};
}
}
sub
HandleDrop
{
my
(
$t
,
$seln
,
$x
,
$y
) =
@_
;
my
$string
;
Tk::
catch
{
$string
=
$t
->SelectionGet(
-selection
=>
$seln
,
'FILE_NAME'
) };
if
($@)
{
Tk::
catch
{
$string
=
$t
->SelectionGet(
-selection
=>
$seln
) };
if
($@)
{
my
@targets
=
$t
->SelectionGet(
-selection
=>
$seln
,
'TARGETS'
);
$t
->messageBox(
-text
=>
"Targets : "
.
join
(
' '
,
@targets
));
}
else
{
$t
->markSet(
insert
=>
"\@$x,$y"
);
$t
->insert(
insert
=>
$string
);
}
}
else
{
Create_Edit(
$string
);
}
}
my
$str
;
sub
DoFind
{
my
$t
=
shift
;
$str
=
shift
if
(
@_
);
my
$posn
=
$t
->
index
(
'insert+1c'
);
$t
->tag(
'remove'
,
'sel'
,
'1.0'
,
'end'
);
local
$_
;
while
(
$t
->compare(
$posn
,
'<'
,
'end'
))
{
my
(
$line
,
$col
) =
split
(/\./,
$posn
);
$_
=
$t
->get(
"$line.0"
,
"$posn lineend"
);
pos
(
$_
) =
$col
;
if
(/\G(.*)
$str
/g)
{
$col
+=
length
($1);
$posn
=
"$line.$col"
;
$t
->SetCursor(
$posn
);
$t
->tag(
'add'
,
'sel'
,
$posn
,
"$line."
.
pos
(
$_
));
$t
->focus;
return
;
}
$posn
=
$t
->
index
(
"$posn lineend + 1c"
);
}
}
sub
AskFind
{
my
(
$t
) =
@_
;
unless
(
exists
$t
->{
'AskFind'
})
{
my
$d
=
$t
->{
'AskFind'
} =
$t
->Toplevel(
-popover
=>
'cursor'
,
-popanchor
=>
'nw'
);
$d
->title(
'Find...'
);
$d
->withdraw;
$d
->transient(
$t
->toplevel);
my
$e
=
$d
->Entry->
pack
;
$e
->
bind
(
'<Return>'
,
sub
{
$d
->withdraw; DoFind(
$t
,
$e
->get); });
$d
->protocol(
WM_DELETE_WINDOW
=>[
withdraw
=>
$d
]);
}
$t
->{
'AskFind'
}->Popup;
$t
->update;
$t
->{
'AskFind'
}->focusNext;
}
sub
About
{
my
$mw
=
shift
;
$mw
->Dialog(
-text
=>
<<"END",-popover => $mw)->Show;
$0 version $VERSION
perl$]/Tk$Tk::VERSION
Copyright © 1995-2004 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.
END
}