home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Pod.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  9.5 KB  |  466 lines
  1. package Tk::Pod;
  2. require Tk::Toplevel;
  3. require Tk::Text;
  4. require Tk::Menubar;
  5. use Tk qw(Ev);
  6. use AutoLoader;
  7. use Carp;
  8. use Tk::Pretty;
  9. use Tk::Parse;
  10. @ISA = qw(Tk::Toplevel);
  11.  
  12. Construct Tk::Widget 'Pod';
  13.  
  14. BEGIN { @POD = @INC };
  15.  
  16. sub Dir
  17. {
  18.  my $class = shift;
  19.  unshift(@POD,@_);
  20. }
  21.  
  22. sub Find
  23. {
  24.  my ($file) = @_;
  25.  my $dir;
  26.  foreach $dir ("",@POD)
  27.   {
  28.    my $prefix;
  29.    foreach $prefix ("","pod/")
  30.     {
  31.      my $suffix;
  32.      foreach $suffix ("",".pod",".pm")
  33.       {
  34.        my $path = "$dir/" . $prefix . $file . $suffix;
  35.        return $path if (-r $path && -T $path);
  36.        $path =~ s,::,/,g;
  37.        return $path if (-r $path && -T $path);
  38.       }
  39.     }
  40.   }
  41.  croak("Cannot find pod for $file in \@INC");
  42. }
  43.  
  44. sub file {
  45.   my $w = shift;
  46.   if (@_)
  47.     {
  48.       my $file = shift;
  49.       $w->{'File'} = $file;
  50.       my $path = Find($file);
  51.       $w->configure('-path' => $path);
  52.       $w->delete('1.0' => 'end');
  53.       use Benchmark;
  54.       # my $t = new Benchmark;
  55.       $w->process($path);
  56.       # print &timediff(new Benchmark, $t)->timestr,"\n";
  57.     }
  58.   else
  59.     {
  60.       return $w->{'File'};
  61.     }
  62. }
  63.  
  64. sub reload
  65. {
  66.  my ($w) = @_;
  67.  $w->Busy;
  68.  $w->delete('0.0','end');
  69.  $w->process($w->cget('-path'));
  70.  $w->Unbusy;
  71. }
  72.  
  73. sub edit
  74. {
  75.  my ($w) = @_;
  76.  my $path = $w->cget('-path');
  77.  my $edit = $ENV{'EDITOR'};
  78.  if (defined $edit)
  79.   {
  80.    if (fork)
  81.     {
  82.      wait; # parent
  83.     }
  84.    else
  85.     {
  86.      #child
  87.      if (fork)
  88.       {
  89.        # still child
  90.        exec("true");
  91.       }
  92.      else
  93.       {
  94.        # grandchild 
  95.        exec("$edit $path");
  96.       }
  97.     }
  98.   }
  99. }
  100.  
  101. sub Populate
  102. {
  103.  my ($w,$args) = @_;
  104.  $w->SUPER::Populate($args);
  105.  my $path = $args->{-path};
  106.  my $p = $w->Component('Text' => 'pod', -wrap => 'word',
  107.                        -background => 'white',
  108.                        -font => $w->Font(family => 'courier'));
  109.  $p->pack(-expand => 1, -fill => 'both');
  110.  $w->AddScrollbars($p,$args{'-scrollbars'});
  111.  
  112.  $p->tag('configure','text', -font => $w->Font(family => 'times'));
  113.  $p->tag('configure','C',-font => $w->Font(family => 'courier', weight => 'bold'));
  114.  $p->tag('configure','S',-font => $w->Font(family => 'courier', weight => 'bold', slant => 'o'));
  115.  $p->tag('configure','B',-font => $w->Font(family => 'times', weight => 'bold' ));
  116.  $p->tag('configure','I',-font => $w->Font(family => 'times',slant => 'i', weight => 'bold' ));
  117.  $p->tag('configure','S',-font => $w->Font(family => 'times',slant => 'i' ));
  118.  $p->tag('configure','F',-font => $w->Font(family => 'helvetica', weight => 'bold'));
  119.  $p->insert('0.0',"\n");
  120.  
  121.  $w->{List}   = []; # stack of =over
  122.  $w->{Item}   = undef;
  123.  $w->{'indent'} = 0;
  124.  $w->{Length}  = 64;
  125.  $w->{Indent}  = {}; # tags for various indents
  126.  $p->bind('<Double-1>',[$w, 'DoubleClick']);
  127.  
  128.  
  129.  my $mbar = $w->Component('Menubar' => 'menubar');
  130.  my $file = $mbar->Component('Menubutton' => 'file', '-text' => 'File', '-underline' => 0);
  131.  $file->pack('-side' => 'left','-anchor' => 'w');
  132.  $file->command('-label' => 'Quit',  '-underline' => 0, '-command' => ['quit',$w] );
  133.  $file->command('-label' => 'Re-Read',  '-underline' => 0, '-command' => ['reload',$w] );
  134.  $file->command('-label' => 'Edit',  '-underline' => 0, '-command' => ['edit',$w] );
  135.  
  136.  my $help = $mbar->Component('Menubutton' => 'help', '-text' => 'Help', '-underline' => 0);
  137.  $help->pack('-side' => 'right','-anchor' => 'e');
  138.  
  139.  $mbar->pack('-side' => 'top', '-fill' => 'x', '-before' => ($w->packSlaves)[0]);
  140.  $w->Delegates(Menubutton => $mbar, DEFAULT => $p);
  141.  $w->ConfigSpecs('-file' =>   ['METHOD',undef,undef,undef],
  142.                  -path   =>   ['PASSIVE',undef,undef,undef],
  143.                  -scrollbars => ['METHOD','scrollbars','Scrollbars','w'],
  144.                  DEFAULT => [$p]);
  145.  # $w->process($path);
  146.  $args->{-width} = $w->{Length};
  147.  $w->protocol('WM_DELETE_WINDOW',['quit',$w]);
  148. }
  149.  
  150. sub quit
  151. {
  152.  my ($w) = @_;
  153.  my $p = $w->parent;
  154.  $w->destroy;
  155.  foreach $w ($p->children)
  156.   {
  157.    return if ($w->toplevel eq $w);
  158.   }
  159.  $p->destroy if ($p->state eq 'withdrawn');
  160. }
  161.  
  162. %tag = qw(C 1 B 1 I 1 L 1 F 1 S 1 Z 1);
  163.  
  164. sub Font
  165. {
  166.  my ($w,%args)    = @_;
  167.  $args{'family'}  = 'times'  unless (exists $args{'family'});
  168.  $args{'weight'}  = 'medium' unless (exists $args{'weight'});
  169.  $args{'slant'}   = 'r'      unless (exists $args{'slant'});
  170.  $args{'size'}    = 140      unless (exists $args{'size'});
  171.  $args{'spacing'} = '*'     unless (exists $args{'spacing'});
  172.  $args{'slant'}   = substr($args{'slant'},0,1);
  173.  my $name = "-*-$args{'family'}-$args{'weight'}-$args{'slant'}-*-*-*-$args{'size'}-*-*-$args{'spacing'}-*-iso8859-1";
  174.  return $name;
  175. }
  176.  
  177. sub DoubleClick
  178. {
  179.  my ($w) = @_;
  180.  my $sel = $w->SelectionGet;
  181.  if (defined $sel)
  182.   {
  183.    $w->MainWindow->Pod('-file' => $sel);
  184.   }
  185. }
  186.  
  187. sub Link
  188. {
  189.  my ($w,$index,$link) = @_;
  190.  my (@range) = $w->tag('nextrange',$link,$index);
  191.  if (@range == 2)
  192.   {
  193.    $w->see($range[0]);
  194.   }
  195.  else
  196.   {
  197.    my $mw = $w->MainWindow;
  198.    my $man = $link;
  199.    my $sec;
  200.    ($man,$sec) = split(m#/#,$link) if ($link =~ m#/#);
  201.    $mw->Pod('-file' => $man);
  202.   }
  203. }
  204.  
  205. %translate =
  206. (
  207.  'lt' => '<',
  208.  'gt' => '>',
  209.  'amp' => '&'
  210.  );
  211.  
  212. # '<' and '>' have been replaced with \x7f because E<..> have been
  213. # turned into real characters.
  214. sub _expand
  215. {
  216.  my ($w,$line) = @_;
  217.  
  218.  if ($line =~ /^(.*?)\b([A-Z])\x7f(.*?)\x7f(.*)$/)
  219.   {
  220.    my ($pre,$tag,$what,$post) = ($1,$2,$3,$4);
  221.    $w->insert('end -1c',$pre);
  222.     {
  223.      my $start = $w->index('end -1c');
  224.      $what = $w->_expand($what);         
  225.      if ($tag eq 'L')
  226.       {
  227.        $tag = '!'.$what;
  228.        $w->tag('bind',$tag,'<Button-1>',[$w,'Link',Ev('@%x,%y'),$what]);
  229.        $w->tag('configure',$tag,-underline=> 1, -font => $w->Font(family => 'times',slant => 'i'));
  230.       }
  231.      $w->tag('add',$tag,$start,'end -1c');
  232.     }
  233.    $post = $w->_expand($post);
  234.    return $pre . $what . $post;
  235.   }
  236.  else
  237.   {
  238.    $w->insert('end -1c',$line);
  239.    return $line;
  240.   }
  241. }
  242.  
  243. sub expand
  244. {
  245.  my ($w,$line) = @_;
  246.  
  247.  $line =~ s/[<>]/\x7f/g;
  248.  
  249.  $line =~ s/E\x7f([a-z]*)\x7f/$translate{$1}/g;
  250.  return (_expand ($w, $line));
  251. }
  252.  
  253. sub append
  254. {
  255.  my $w = shift;
  256.  my $line;
  257.  foreach $line (@_)
  258.   {
  259.    $w->expand($line);
  260.   }
  261. }
  262.  
  263. sub text
  264. {
  265.  my ($w,$body) = @_;
  266.  $body = join(' ',split(/\s*\n/,$body));
  267.  my $start = $w->index('end -1c');
  268.  $w->append($body,"\n\n");
  269.  $w->tag('add','text',$start,'end -1c');
  270. }
  271.  
  272. sub verbatim
  273. {
  274.  my ($w,$body) = @_;
  275.  my $line;
  276.  foreach $line (split(/\n/,$body))
  277.   {
  278.    # Really need to have length after tabs expanded.
  279.    my $l = length($line)+$w->{indent};
  280.    if ($l > $w->{Length})
  281.     {
  282.      $w->{Length} = $l;
  283.      $w->configure(-width => $l) if ($w->viewable);
  284.     }
  285.   }
  286.  $w->insert('end -1c',$body . "\n\n",['verbatim']);
  287. }
  288.  
  289. sub head1
  290. {
  291.  my ($w,$title) = @_;
  292.  my $start = $w->index('end -1c');
  293.  $w->append($title);
  294.  $num = 2 unless (defined $num);
  295.  $w->tag('add',$title,$start,'end -1c');
  296.  $w->tag('configure',$title,-font => $w->Font(family => 'times', 
  297.          weight => 'bold',size => 180));
  298.  $w->tag('raise',$title,'text');
  299.  $w->append("\n\n");
  300. }
  301.  
  302. sub head2
  303. {
  304.  my ($w,$title) = @_;
  305.  my $start = $w->index('end -1c');
  306.  $w->append($title);
  307.  $w->tag('add',$title,$start,'end -1c');
  308.  $w->tag('configure',$title,
  309.          -font => $w->Font(family => 'times', weight => 'bold'));
  310.  $w->tag('raise',$title,'text');
  311.  $w->append("\n\n");
  312. }
  313.  
  314. sub IndentTag
  315. {
  316.  my ($w,$indent) = @_;
  317.  my $tag = "Indent" . ($indent+0);
  318.  unless (exists $w->{Indent}{$tag})
  319.   {
  320.    $w->{Indent}{$tag} = $indent;
  321.    $indent *= 8;
  322.    $w->tag('configure',$tag,
  323.            -lmargin2 => $indent . 'p', 
  324.            -rmargin  => $indent . 'p', 
  325.            -lmargin1 => $indent . 'p'
  326.           );
  327.   }
  328.  return $tag;
  329. }
  330.  
  331. sub enditem
  332. {
  333.  my ($w) = @_;
  334.  my $item = delete $w->{Item};
  335.  if (defined $item)
  336.   {
  337.    my ($start,$indent) = @$item;
  338.    $w->tag('add',$w->IndentTag($indent),$start,'end -1c');
  339.   }
  340. }
  341.  
  342. sub item
  343. {
  344.  my ($w,$title) = @_;
  345.  $w->enditem;
  346.  my $type = $w->{listtype};
  347.  my $indent = $w->{indent};
  348.  print "item(",join(',',@_,$type,$indent),")\n" unless ($type == 1 || $type == 3);
  349.  my $start = $w->index('end -1c');
  350.  $title =~ s/\n/ /;
  351.  $w->append($title);
  352.  $w->tag('add',$title,$start,'end -1c');
  353.  $w->tag('configure',$title,-font => $w->Font(weight => 'bold'));
  354.  $w->tag('raise',$title,'text');
  355.  $w->append("\n") if ($type == 3);
  356.  $w->append(" ")  if ($type != 3);
  357.  $w->{Item} = [ $w->index('end -1c'), $w->{indent} ];
  358. }
  359.  
  360. sub setindent 
  361. { 
  362.  my ($w,$arg) = @_; 
  363.  $w->{'indent'} = $arg 
  364. }
  365.  
  366. sub listbegin 
  367. { 
  368.  my ($w) = @_;
  369.  my $item = delete $w->{Item};
  370.  push(@{$w->{List}},$item);
  371. }
  372.  
  373. sub listend
  374. {
  375.  my ($w) = @_;
  376.  $w->enditem;
  377.  $w->{Item} = pop(@{$w->{List}});
  378. }
  379.  
  380. sub over { } 
  381.  
  382. sub back { } 
  383.  
  384. sub filename
  385. {
  386.  my ($w,$title) = @_;
  387.  $w->toplevel->title($title);
  388. }
  389.  
  390. sub setline   {}
  391. sub setloc    {}
  392. sub endfile   {}
  393. sub listtype  { my ($w,$arg) = @_; $w->{listtype} = $arg }
  394. sub cut       {} 
  395.  
  396.  
  397. sub process
  398. {
  399.  my ($w,$file) = @_;
  400.  my @save = @ARGV;
  401.  @ARGV = $file;
  402.  print STDERR "Parsing $file\n";
  403.  my (@pod) = Simplify(Parse());
  404.  my ($cmd,$arg);
  405.  print STDERR "Render $file\n";
  406.  my $update = 2;
  407.  while ($cmd = shift(@pod))
  408.   {
  409.    my $arg = shift(@pod);
  410.    $w->$cmd($arg);
  411.    unless ($update--) {
  412.      $w->update;
  413.      $update = 2;
  414.    } 
  415.   }
  416.  @ARGV = @save;
  417. }
  418.  
  419. 1;
  420. __END__
  421.  
  422. sub old_process
  423. {
  424.  my ($w,$file) = @_;
  425.  open($file,"<$file") || die "Cannot open $file:$!";
  426.  $w->filename($file);
  427.  $/ = "";  
  428.  my $cutting = 1;
  429.  while (<$file>)
  430.   {
  431.    if ($cutting)
  432.     {
  433.      next unless /^=/;
  434.      $cutting = 0;
  435.     }
  436.    chomp;
  437.    if (/^\s/)
  438.     {
  439.      $w->verbatim($_);
  440.     }
  441.    elsif (/^=/)
  442.     {
  443.      my ($cmd,$num,$title) = /^=([a-z]+)(\d*)\s*([^\0]*)$/ ;
  444.      die "$_" unless (defined $cmd);
  445.      if ($cmd eq 'cut')
  446.       {
  447.        $cutting = 1;
  448.       }
  449.      else
  450.       {
  451.        $w->$cmd($title,$num);
  452.       }
  453.     }
  454.    else
  455.     {
  456.      $w->text($_);
  457.     }
  458.   }
  459.  close($file);
  460. }
  461.  
  462.  
  463.  
  464.  
  465.  
  466.