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 / More.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  9.8 KB  |  398 lines
  1. package Tk::More;
  2.  
  3. use strict;
  4. use vars qw($VERSION @ISA);
  5.  
  6. $VERSION = substr(q$Revision: 1.2 $, 10) . "";
  7.  
  8. use Tk qw(Ev);
  9. use Tk::Derived;
  10. use Tk::Frame;
  11. @ISA = qw(Tk::Derived Tk::Frame);
  12.  
  13. Construct Tk::Widget 'More';
  14.  
  15. sub Populate {
  16.     my ($cw, $args) = @_;
  17.  
  18.     require Tk::ROText;
  19.     require Tk::LabEntry;
  20.  
  21.     $cw->SUPER::Populate($args);
  22.  
  23.     my $Entry = 'LabEntry';
  24.     my @Entry_args;
  25.     if (eval { die "Not yet";
  26.            require Tk::HistEntry;
  27.            Tk::HistEntry->VERSION(0.37);
  28.            1;
  29.        }) {
  30.     $Entry = 'HistEntry';
  31.     } else {
  32.     @Entry_args = (-labelPack=>[-side =>'left']);
  33.     }
  34.  
  35.     my $search;
  36.     my $e = $cw->$Entry(
  37.         @Entry_args,
  38.         -textvariable => \$search,
  39.         -relief => 'flat',
  40.         -state => 'disabled',
  41.         )->pack(-side=>'bottom', -fill => 'x', -expand=>'no');
  42.     $cw->Advertise('searchentry' => $e);
  43.  
  44.     my $t = $cw->ROText(-cursor=>undef)->pack(-fill => 'both' , -expand => 'yes');
  45.     $cw->Advertise('text' => $t);
  46.     $t->tagConfigure('search', -foreground => 'red');
  47.  
  48.     # reorder bindings: private widget bindings first
  49.     $t->bindtags([$t, grep { $_ ne $t->PathName } $t->bindtags]);
  50.  
  51.     $t->bind('<Key-slash>',    [$cw, 'Search', 'Next']);
  52.     $t->bind('<Key-question>', [$cw, 'Search', 'Prev']);
  53.     $t->bind('<Key-n>',        [$cw, 'ShowMatch', 'Next']);
  54.     $t->bind('<Key-N>',        [$cw, 'ShowMatch', 'Prev']);
  55.  
  56.     $t->bind('<Key-g>', $t->bind(ref($t),'<Control-Home>'));
  57.     $t->bind('<Key-G>', $t->bind(ref($t),'<Control-End>'));
  58.     $t->bind('<Home>',  $t->bind('<Key-g>'));
  59.     $t->bind('<End>',   $t->bind('<Key-G>'));
  60.  
  61.     $t->bind('<Key-j>', [$cw, 'scroll', $t,  1, 'line']);
  62.     $t->bind('<Down>',  [$cw, 'scroll', $t,  1, 'line']);
  63.     $t->bind('<Key-k>', [$cw, 'scroll', $t, -1, 'line']);
  64.     $t->bind('<Up>',    [$cw, 'scroll', $t, -1, 'line']);
  65.  
  66.     $t->bind('<Key-f>', [$cw, 'scroll', $t,  1, 'page']);
  67.     $t->bind('<Next>',  [$cw, 'scroll', $t,  1, 'page']);
  68.     $t->bind('<Key-b>', [$cw, 'scroll', $t, -1, 'page']);
  69.     $t->bind('<Prior>', [$cw, 'scroll', $t, -1, 'page']);
  70.  
  71.     $t->bind('<Right>', [sub {
  72.          return if ($_[1] =~ /(Alt|Meta)-/);
  73.          $t->xview('scroll',  1, 'units'); Tk->break;
  74.          }, Ev('s')]);
  75.     $t->bind('<Left>',  [sub {
  76.          return if ($_[1] =~ /(Alt|Meta)-/);
  77.          $t->xview('scroll', -1, 'units'); Tk->break;
  78.          }, Ev('s')]);
  79.  
  80.     $t->bind('<Return>', ['yview', 'scroll',  1, 'units']);
  81.     $t->bind('<Key-d>',  [$cw, 'scroll', $t,  1, 'halfpage']);
  82.     $t->bind('<Key-u>',  [$cw, 'scroll', $t, -1, 'halfpage']);
  83.  
  84.     $t->bind('<Key-h>', sub { $cw->Callback(-helpcommand => $t) });
  85.  
  86.     $e->bind('<Return>',[$cw, 'SearchText']);
  87.     $e->bind('<Escape>',[$cw, 'SearchTextEscape']);
  88.  
  89.     foreach my $mod (qw(Alt Meta)) {
  90.     foreach my $key (qw(n N g G j k f b d u h)) {
  91.         $t->bind("<$mod-Key-$key>" => \&Tk::NoOp);
  92.     }
  93.     }
  94.  
  95.     $cw->Delegates('DEFAULT'   => $t,
  96.            'Search'    => 'SELF',
  97.            'ShowMatch' => 'SELF',
  98.           );
  99.  
  100.     $cw->{DIRECTION} = "Next";
  101.  
  102.     $cw->ConfigSpecs(
  103.         -insertofftime => [$t, qw(insertOffTime OffTime         0)], # no blinking
  104.         -insertwidth   => [$t, qw(insertWidth   InsertWidth     0)], # invisible
  105.         -padx          => [$t, qw(padX          Pad            5p)],
  106.         -pady          => [$t, qw(padY          Pad            5p)],
  107.         -searchcase    => ['PASSIVE', 'searchCase', 'SearchCase', 1],
  108.         -helpcommand   => ['CALLBACK', undef, undef, undef],
  109.         'DEFAULT'      => [$t]
  110.         );
  111.  
  112.     $cw;
  113. }
  114.  
  115.  
  116. sub Search {
  117.     my ($cw, $direction) = @_;
  118.     $cw->{DIRECTION} = $direction;
  119.     my $e = $cw->Subwidget('searchentry');
  120.     $e->configure(-label => 'Search ' . ($direction eq 'Next'?'forward:':'backward:') );
  121.     $e->configure(-relief=>'sunken',-state=>'normal');
  122.     $e->selectionRange(0, "end");
  123.     $e->focus;
  124. }
  125.  
  126. sub SearchText {
  127.     my ($cw, %args) = @_;
  128.     my($t, $e) = ($cw->Subwidget('text'), $cw->Subwidget('searchentry'));
  129.     $cw->{DIRECTION} = $args{-direction} if $args{-direction};
  130.     my $searchterm;
  131.     if (defined $args{-searchterm}) {
  132.     $searchterm = $args{-searchterm};
  133.     $ {$e->cget('-textvariable')} = $searchterm;
  134.     } else {
  135.     $e->historyAdd if ($e->can('historyAdd'));
  136.     $searchterm = $e->get;
  137.     }
  138.     unless ($cw->search_text($t, $searchterm, 'search') ) {
  139.     $cw->bell unless $args{-quiet};
  140.     }
  141.     $e->configure(-label=>'');
  142.     $t->see('@0,0');
  143.     $cw->ShowMatch($cw->{DIRECTION}, -firsttime => 1) unless $args{-onlymatch};
  144.     $t->focus;
  145.     $e->configure(-relief=>'flat', -state=>'disabled');
  146. }
  147.  
  148. sub SearchTextEscape {
  149.     my ($cw, %args) = @_;
  150.     my($t, $e) = ($cw->Subwidget('text'), $cw->Subwidget('searchentry'));
  151.     $e->configure(-label=>'');
  152.     $t->focus;
  153.     $e->configure(-relief=>'flat', -state=>'disabled');
  154. }
  155.  
  156. sub ShowMatch {
  157.     my ($cw, $method, %args) = @_;
  158.     my $firsttime = $args{-firsttime};
  159.  
  160.     my $t = $cw->Subwidget('text');
  161.     if ($cw->{DIRECTION} ne 'Next') {
  162.     $method = 'Next' if $method eq 'Prev';
  163.     $method = 'Prev' if $method eq 'Next';
  164.     }
  165.     my $cur = (($method eq 'Prev' && !$firsttime) ||
  166.            ($method eq 'Next' &&  $firsttime)
  167.            ? $t->index('@0,0')
  168.            : $t->index('@0,'.$t->height));
  169.     $method = "tag". $method . "range"; # $method: Next or Prev
  170.     my @ins = $t->$method('search',$cur);
  171.     unless (@ins) {
  172.     # hack: Maybe the search was not performed yet? (e.g. after loading
  173.     # a new page but with the same search term)
  174.     my $e = $cw->Subwidget('searchentry');
  175.     if (!defined $ {$e->cget('-textvariable')}) {
  176.         return;
  177.     }
  178.     $cw->SearchText(-searchterm => $ {$e->cget('-textvariable')},
  179.             -onlymatch => 1);
  180.     @ins = $t->$method('search',$cur);
  181.     return if !@ins;
  182.     }
  183.     @ins = reverse @ins unless $method eq 'tagNextrange';
  184.     $t->see($ins[0]);
  185.     $ins[0];
  186. }
  187.  
  188. # Load copied from TextUndo (xxx yy marks changes)
  189. sub Load
  190. {
  191.  my ($text,$file) = @_;
  192.  if (open(FILE,"<$file"))
  193.   {
  194.    $text->MainWindow->Busy;
  195.    $text->SUPER::delete('1.0','end');
  196.    #yy delete $text->{UNDO};
  197.    while (<FILE>)
  198.     {
  199.      $text->SUPER::insert('end',$_);
  200.     }
  201.    close(FILE);
  202.    #yy $text->{FILE} = $file;
  203.    $text->markSet('insert', '@1,0');
  204.    $text->MainWindow->Unbusy;
  205.   }
  206.  else
  207.   {
  208.    $text->messageBox(-message => "Cannot open $file: $!\n");
  209.    die;
  210.   }
  211. }
  212.  
  213. # search_text copied from demo search.pl (modified)
  214. sub search_text {
  215.  
  216.     # The utility procedure below searches for all instances of a given
  217.     # string in a text widget and applies a given tag to each instance found.
  218.     # Arguments:
  219.     #
  220.     # w -       The window in which to search.  Must be a text widget.
  221.     # string -  string to search for.  The search is done
  222.     #           using exact matching only;  no special characters.
  223.     # tag -     Tag to apply to each instance of a matching string.
  224.  
  225.     my($w, $t, $string, $tag) = @_;
  226.  
  227.     return unless length($string);
  228.  
  229.     $w->tag('remove',  $tag, qw/0.0 end/);
  230.     my($current, $length, $found) = ('1.0', 0, 0);
  231.  
  232.     my $insert = $w->index('insert');
  233.     my @search_args = ('-regexp');
  234.     push @search_args, '-nocase' unless ($w->cget('-searchcase'));
  235.     eval {
  236.     while (1) {
  237.         $current = $w->search(@search_args, -count => \$length, '--', $string, $current, 'end');
  238.         last if not $current;
  239.         $found = 1;
  240.         $w->tag('add', $tag, $current, "$current + $length char");
  241.         $current = $w->index("$current + $length char");
  242.     }
  243.     $w->markSet('insert', $insert);
  244.     };
  245.     if ($@) {
  246.     $w->messageBox(-icon => "error",
  247.                -message => $@,
  248.               );
  249.     }
  250.     $found;
  251. } # end search_text
  252.  
  253. sub scroll {
  254.     my($w,$t,$no,$unit) = @_;
  255.     if ($unit =~ /^line/) {
  256.     $t->yview('scroll', $no, 'units');
  257.     } else {
  258.     my($y1,$y2) = $t->yview;
  259.     my $amount;
  260.     if ($unit =~ /^halfpage/) {
  261.         $amount = ($y2-$y1)/2;
  262.     } elsif ($unit =~ /^page/) {
  263. #          if ($no == -1) {
  264. #          # loop until top-most line is invisible
  265. #          my $inx = $t->index('@0,0');
  266. #  my $i=0;
  267. #          while ($t->bbox($inx)) {
  268. #              $t->yviewScroll(-1,'units');
  269. #              last if ($i++>1000);
  270. #          }
  271. #          goto XXX;
  272. #          }
  273.         $amount = ($y2-$y1);
  274.     } else {
  275.         die "Unknown unit $unit";
  276.     }
  277. #warn "$y1 $y2 $amount";
  278.     $y1 += ($no * $amount);
  279.     if ($no > 0) {
  280.         $y1 = 1.0 if ($y1 > 1.0);
  281.     } else {
  282.         $y1 = 0.0 if ($y1 < 0.0);
  283.     }
  284.     $t->yviewMoveto($y1);
  285.     }
  286.     #XXX:
  287.     Tk->break;
  288. }
  289.  
  290.  
  291. #package Tk::More::Status;
  292. #
  293. ## Implement status bar
  294. #
  295.  
  296. 1;
  297.  
  298. __END__
  299.  
  300. =head1 NAME
  301.  
  302. Tk::More - a 'more' or 'less' like text widget
  303.  
  304. =head1 SYNOPSIS
  305.  
  306.     use Tk::More;
  307.  
  308.     $more = $parent->More(...text widget options ...);
  309.     $more->Load(FILENAME);
  310.  
  311. =head1 DESCRIPTION
  312.  
  313. B<Tk::More> is a readonly text widget with additional key bindings as
  314. found in UNI* command line tools C<more> or C<less>. As in C<more> an
  315. additional status/command line is added at the bottom.
  316.  
  317. =head1 ADDITIONAL BINDINGS
  318.  
  319. =over 4
  320.  
  321. =item Key-g
  322.  
  323. goto beginning of file
  324.  
  325. =item Key-G
  326.  
  327. goto end of file
  328.  
  329. =item Key-f
  330.  
  331. forward screen
  332.  
  333. =item Key-b
  334.  
  335. backward screen
  336.  
  337. =item Key-k
  338.  
  339. up one line
  340.  
  341. =item Key-j
  342.  
  343. down one line
  344.  
  345. =item Key-/
  346.  
  347. search forward
  348.  
  349. =item Key-?
  350.  
  351. search backward
  352.  
  353. =item Key-n
  354.  
  355. find next match
  356.  
  357. =item Key-N
  358.  
  359. find previous match
  360.  
  361. =item Key-u
  362.  
  363. up half screen
  364.  
  365. =item Key-d
  366.  
  367. down half screen
  368.  
  369. =back
  370.  
  371. =head1 BUGS
  372.  
  373. Besides that most of more bindings are not implemented. This bugs
  374. me most (high to low priority):
  375.  
  376. * better status line implementation
  377.  
  378. * Cursor movement: up/down move displayed area regardless where
  379.   insert cursor is
  380.  
  381. * add History, Load, Search (also as popup menu)
  382.  
  383. =head1 SEE ALSO
  384.  
  385. L<Tk::ROText|Tk::ROText>, more(1), less(1)
  386.  
  387. =head1 AUTHOR
  388.  
  389. Achim Bohnet <F<ach@mpe.mpg.de>>
  390.  
  391. Currently maintained by Slaven Rezic <F<slaven@rezic.de>>.
  392.  
  393. Copyright (c) 1997-1998 Achim Bohnet. All rights reserved.  This program is
  394. free software; you can redistribute it and/or modify it under the same
  395. terms as Perl itself.
  396.  
  397. =cut
  398.