home *** CD-ROM | disk | FTP | other *** search
/ PC World 2004 November / PCWorld_2004-11_cd.bin / software / topware / activeperl / ActivePerl-5.8.4.810-MSWin32-x86.exe / ActivePerl-5.8.4.810 / Perl / bin / ptked < prev    next >
Text File  |  2004-06-01  |  8KB  |  346 lines
  1. #!/usr/local/bin/perl -w
  2. use strict;
  3. use Socket;
  4. use IO::Socket;
  5. use Cwd;
  6. use Getopt::Long;
  7.  
  8. use vars qw($VERSION $portfile);
  9. $VERSION = sprintf '4.%03d', q$Revision: #29 $ =~ /\D(\d+)\s*$/;
  10.  
  11. my %opt;
  12. INIT
  13.  {
  14.   my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'};
  15.   $portfile = "$home/.ptkedsn";
  16.   my $port = $ENV{'PTKEDPORT'};
  17.   return if $^C;
  18.   GetOptions(\%opt,qw(server! encoding=s));
  19.   unless (defined $port)
  20.    {
  21.     if (open(SN,"$portfile"))
  22.      {
  23.       $port = <SN>;
  24.       close(SN);
  25.      }
  26.    }
  27.   if (defined $port)
  28.    {
  29.     my $sock = IO::Socket::INET->new(PeerAddr => 'localhost',
  30.                PeerPort => $port, Proto    => 'tcp');
  31.     if ($sock)
  32.      {
  33.       binmode($sock);
  34.       $sock->autoflush;
  35.       foreach my $file (@ARGV)
  36.        {
  37.         unless  (print $sock "$file\n")
  38.          {
  39.           die "Cannot print $file to socket:$!";
  40.          }
  41.         print "Requested '$file'\n";
  42.        }
  43.       $sock->close || die "Cannot close socket:$!";
  44.       exit(0);
  45.      }
  46.     else
  47.      {
  48.       warn "Cannot connect to server on $port:$!";
  49.      }
  50.    }
  51.  }
  52.  
  53. use Tk;
  54. use Tk::DropSite qw(XDND Sun);
  55. use Tk::DragDrop qw(XDND Sun);
  56. use Tk::widgets qw(TextUndo Scrollbar Menu Dialog);
  57. # use Tk::ErrorDialog;
  58.  
  59. {
  60.  package Tk::TextUndoPtked;
  61.  @Tk::TextUndoPtked::ISA = qw(Tk::TextUndo);
  62.  Construct Tk::Widget 'TextUndoPtked';
  63.  
  64.  sub Save {
  65.   my $w = shift;
  66.   $w->SUPER::Save(@_);
  67.   $w->toplevel->title($w->FileName);
  68.  }
  69.  
  70.  sub Load {
  71.   my $w = shift;
  72.   $w->SUPER::Load(@_);
  73.   $w->toplevel->title($w->FileName);
  74.  }
  75.  
  76.  sub MenuLabels { shift->SUPER::MenuLabels, 'Encoding' }
  77.  
  78.  sub Encoding
  79.  {
  80.   my ($w,$enc) = @_;
  81.   if (@_ > 1)
  82.    {
  83.     $enc = $w->getEncoding($enc) unless ref($enc);
  84.     $w->{ENCODING} = $enc;
  85.     $enc = $enc->name;
  86.     $w->PerlIO_layers(":encoding($enc)");
  87.    }
  88.   return $w->{ENCODING};
  89.  }
  90.  
  91.  sub EncodingMenuItems
  92.  {
  93.   my ($w) = @_;
  94.   return [ [ command => 'System', -command => [ $w, Encoding => Tk::SystemEncoding()->name ]],
  95.            [ command => 'UTF-8',  -command => [ $w, Encoding => 'UTF-8'] ],
  96.            [ command => 'iso-8859-1', -command => [ $w, Encoding => 'iso8859-1'] ],
  97.            [ command => 'iso-8859-15', -command => [ $w, Encoding => 'iso8859-15'] ],
  98.          ];
  99.  
  100.  }
  101.  
  102. }
  103.  
  104. my $top = MainWindow->new();
  105.  
  106. if ($opt{'server'})
  107.  {
  108.   my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp');
  109.   die "Cannot open listen socket:$!" unless defined $sock;
  110.   binmode($sock);
  111.  
  112.   my $port = $sock->sockport;
  113.   $ENV{'PTKEDPORT'} = $port;
  114.   open(SN,">$portfile") || die "Cannot open $portfile:$!";
  115.   print SN $port;
  116.   close(SN);
  117.   print "Accepting connections on $port\n";
  118.   $top->fileevent($sock,'readable',
  119.   sub
  120.   {
  121.    print "accepting $sock\n";
  122.    my $client = $sock->accept;
  123.    if (defined $client)
  124.     {
  125.      binmode($client);
  126.      print "Connection $client\n";
  127.      $top->fileevent($client,'readable',[\&EditRequest,$client]);
  128.     }
  129.    });
  130.  }
  131.  
  132. Tk::Event::HandleSignals();
  133. $SIG{'INT'} = sub { $top->WmDeleteWindow };
  134.  
  135. $top->iconify;
  136. $top->optionAdd('*TextUndoPtked.Background' => '#fff5e1');
  137. $top->fontCreate('ptked',-family => 'courier', -size => ($^O eq 'MSWin32' ? 11 : -12),
  138.                  -weight => 'normal', -slant => 'roman');
  139. $top->optionAdd('*TextUndoPtked.Font' => 'ptked');
  140.  
  141. foreach my $file (@ARGV)
  142.  {
  143.   Create_Edit($file);
  144.  }
  145.  
  146.  
  147. sub EditRequest
  148. {
  149.  my ($client) = @_;
  150.  local $_;
  151.  while (<$client>)
  152.   {
  153.    chomp($_);
  154.    print "'$_'\n",
  155.    Create_Edit($_);
  156.   }
  157.  warn "Odd $!" unless eof($client);
  158.  $top->fileevent($client,'readable','');
  159.  print "Close $client\n";
  160.  $client->close;
  161. }
  162.  
  163. MainLoop;
  164. unlink("$portfile");
  165. exit(0);
  166.  
  167. sub Create_Edit
  168. {
  169.  my $path = shift;
  170.  my $ed   = $top->Toplevel(-title => $path);
  171.  $ed->withdraw;
  172.  $top->{'Edits'}++;
  173.  $ed->OnDestroy([\&RemoveEdit,$top]);
  174.  my $t = $ed->Scrolled('TextUndoPtked', -wrap => 'none',
  175.            -scrollbars => 'se', # both required till optional fixed!
  176.          );
  177.  $t->pack(-expand => 1, -fill => 'both');
  178.  $t = $t->Subwidget('scrolled');
  179.  
  180.  $t->Encoding($opt{encoding}) if $opt{encoding};
  181.  
  182.  my $menu = $t->menu;
  183.  $menu->cascade(-label => '~Help', -menuitems => [
  184.                 [Button => '~About...', -command => [\&About,$ed]],
  185.                ]);
  186.  $ed->configure(-menu => $menu);
  187.  my $dd = $t->DragDrop(-event => '<Meta-B1-Motion>');
  188.  $t->bind(ref($t),'<Meta-B1-Motion>',\&Ouch);
  189.  $t->bind(ref($t),'<Meta-ButtonPress>',\&Ouch);
  190.  $t->bind(ref($t),'<Meta-ButtonRelease>',\&Ouch);
  191.  $dd->configure(-startcommand =>
  192.                 sub
  193.                  {
  194.                   return 1 unless (eval { $t->tagNextrange(sel => '1.0','end')});
  195.                   $dd->configure(-text => $t->get('sel.first','sel.last'));
  196.                  });
  197.  
  198.  $t->DropSite(-motioncommand =>
  199.                sub
  200.                 { my ($x,$y) = @_;
  201.                   $t->markSet(insert => "\@$x,$y");
  202.                 },
  203.                -dropcommand => [\&HandleDrop,$t],
  204.               );
  205.  
  206.  
  207.  
  208.  $ed->protocol('WM_DELETE_WINDOW',[ConfirmExit => $t]);
  209.  $t->bind('<F3>',\&DoFind);
  210.  
  211.  $ed->idletasks;
  212.  if (-e $path)
  213.   {
  214.    $t->Load($path);
  215.   }
  216.  else
  217.   {
  218.    $t->FileName($path);
  219.   }
  220.  $ed->deiconify;
  221.  $t->update;
  222.  $t->focus;
  223. }
  224.  
  225. sub Ouch
  226. {
  227.  warn join(',','Ouch',@_);
  228. }
  229.  
  230. sub RemoveEdit
  231. {
  232.  my $top = shift;
  233.  if (--$top->{'Edits'} == 0)
  234.   {
  235.    $top->destroy unless $opt{'s'};
  236.   }
  237. }
  238.  
  239. sub HandleDrop
  240. {my ($t,$seln,$x,$y) = @_;
  241.  # warn join(',',Drop => @_);
  242.  my $string;
  243.  Tk::catch { $string = $t->SelectionGet(-selection => $seln,'FILE_NAME') };
  244.  if ($@)
  245.   {
  246.    Tk::catch { $string = $t->SelectionGet(-selection => $seln) };
  247.    if ($@)
  248.     {
  249.      my @targets = $t->SelectionGet(-selection => $seln, 'TARGETS');
  250.      $t->messageBox(-text => "Targets : ".join(' ',@targets));
  251.     }
  252.    else
  253.     {
  254.      $t->markSet(insert => "\@$x,$y");
  255.      $t->insert(insert => $string);
  256.     }
  257.   }
  258.  else
  259.   {
  260.    Create_Edit($string);
  261.   }
  262. }
  263.  
  264.  
  265. my $str;
  266.  
  267. sub DoFind
  268. {
  269.  my $t = shift;
  270.  $str = shift if (@_);
  271.  my $posn = $t->index('insert+1c');
  272.  $t->tag('remove','sel','1.0','end');
  273.  local $_;
  274.  while ($t->compare($posn,'<','end'))
  275.   {
  276.    my ($line,$col) = split(/\./,$posn);
  277.    $_ = $t->get("$line.0","$posn lineend");
  278.    pos($_) = $col;
  279.    if (/\G(.*)$str/g)
  280.     {
  281.      $col += length($1);
  282.      $posn = "$line.$col";
  283.      $t->SetCursor($posn);
  284.      $t->tag('add','sel',$posn,"$line.".pos($_));
  285.      $t->focus;
  286.      return;
  287.     }
  288.    $posn = $t->index("$posn lineend + 1c");
  289.   }
  290. }
  291.  
  292. sub AskFind
  293. {
  294.  my ($t) = @_;
  295.  unless (exists $t->{'AskFind'})
  296.   {
  297.    my $d = $t->{'AskFind'} = $t->Toplevel(-popover => 'cursor', -popanchor => 'nw');
  298.    $d->title('Find...');
  299.    $d->withdraw;
  300.    $d->transient($t->toplevel);
  301.    my $e = $d->Entry->pack;
  302.    $e->bind('<Return>', sub { $d->withdraw; DoFind($t,$e->get); });
  303.    $d->protocol(WM_DELETE_WINDOW =>[withdraw => $d]);
  304.   }
  305.  $t->{'AskFind'}->Popup;
  306.  $t->update;
  307.  $t->{'AskFind'}->focusNext;
  308. }
  309.  
  310. sub About
  311. {
  312.  my $mw = shift;
  313.  
  314.  $mw->Dialog(-text => <<"END",-popover => $mw)->Show;
  315. $0 version $VERSION
  316. perl$]/Tk$Tk::VERSION
  317.  
  318. Copyright ⌐ 1995-2004 Nick Ing-Simmons. All rights reserved.
  319. This package is free software; you can redistribute it and/or
  320. modify it under the same terms as Perl itself.
  321. END
  322. }
  323.  
  324. __END__
  325.  
  326. =head1 NAME
  327.  
  328. ptked - an editor in Perl/Tk
  329.  
  330. =head1 SYNOPSIS
  331.  
  332. S<  >B<ptked> [I<file-to-edit>]
  333.  
  334. =head1 DESCRIPTION
  335.  
  336. B<ptked> is a simple text editor based on perl/Tk's TextUndo widget.
  337.  
  338. =cut
  339.  
  340.  
  341.  
  342.  
  343.  
  344.  
  345.  
  346.