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