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