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