diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/bin/ptked')
-rwxr-xr-x | Master/tlpkg/tlperl0/bin/ptked | 368 |
1 files changed, 368 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/bin/ptked b/Master/tlpkg/tlperl0/bin/ptked new file mode 100755 index 00000000000..e0c537d96f4 --- /dev/null +++ b/Master/tlpkg/tlperl0/bin/ptked @@ -0,0 +1,368 @@ +#!/usr/local/bin/perl -w +use strict; +use Socket; +use IO::Socket; +use Cwd; +use Getopt::Long; + +use vars qw($VERSION $portfile); +$VERSION = sprintf '4.%03d', q$Revision: #29 $ =~ /\D(\d+)\s*$/; + +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)); + 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:$!"; + } + } + } + +use Tk; +use Tk::DropSite qw(XDND Sun); +use Tk::DragDrop qw(XDND Sun); +use Tk::widgets qw(TextUndo Scrollbar Menu Dialog); +# use Tk::ErrorDialog; + +{ + package Tk::TextUndoPtked; + @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 = ( # use canonical encoding names for radiobutton value + ['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(); + +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->withdraw; + $top->{'Edits'}++; + $ed->OnDestroy([\&RemoveEdit,$top]); + my $t = $ed->Scrolled('TextUndoPtked', -wrap => 'none', + -scrollbars => 'se', # both required till optional fixed! + ); + $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) = @_; + # warn join(',',Drop => @_); + 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 +} + +__END__ + +=head1 NAME + +ptked - an editor in Perl/Tk + +=head1 SYNOPSIS + +S< >B<ptked> [I<file-to-edit>] + +=head1 DESCRIPTION + +B<ptked> is a simple text editor based on perl/Tk's TextUndo widget. + +=cut + + + + + + + |