diff options
Diffstat (limited to 'Master/tlpkg/tlperl/bin/ptked')
-rwxr-xr-x | Master/tlpkg/tlperl/bin/ptked | 368 |
1 files changed, 0 insertions, 368 deletions
diff --git a/Master/tlpkg/tlperl/bin/ptked b/Master/tlpkg/tlperl/bin/ptked deleted file mode 100755 index e0c537d96f4..00000000000 --- a/Master/tlpkg/tlperl/bin/ptked +++ /dev/null @@ -1,368 +0,0 @@ -#!/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 - - - - - - - |