home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Ghostview.pm < prev    next >
Encoding:
Text File  |  1997-08-10  |  2.8 KB  |  155 lines
  1. require Tk::Ghostscript;
  2. require Tk::DSC;
  3.  
  4. package Tk::Ghostview;
  5. use strict qw(subs);
  6.  
  7. use Tk::Pretty;
  8.  
  9. @ISA = qw(Tk::Ghostscript);
  10.  
  11. Construct Tk::Widget 'Ghostview';
  12.  
  13. $scale  = 72;
  14. $width  = 11*$scale;
  15. $height = 11*$scale;
  16.  
  17. sub scale
  18. {
  19.  my ($w,$val) = @_;
  20.  my $var = \$w->{Configure}{'-scale'};
  21.  if (@_ > 1)
  22.   {
  23.    $$var = $val;
  24.   }
  25.  return $$var;
  26. }
  27.  
  28. sub file
  29. {
  30.  my ($w,$val) = @_;
  31.  my $var = \$w->{Configure}{'-file'};
  32.  if (@_ > 1)
  33.   {
  34.    $$var = $val;
  35.    my $doc = DSC->new($w,$val);
  36.    $w->{'DOC'} = $doc;
  37.    $w->toplevel->title($doc->{'Title'});
  38.   }
  39.  return $$var;
  40. }
  41.  
  42. sub Populate
  43. {
  44.  my ($w,$args) = @_;
  45.  $w->SUPER::Populate($args);
  46.  $w->{'RedrawPending'} = 0;
  47.  $w->{'PAGE'} = 0;
  48.  $w->ConfigSpecs('-file'  => ['METHOD',undef,undef,undef]);
  49.  $w->ConfigSpecs('-scale' => ['METHOD',undef,undef,72.0]);
  50. }
  51.  
  52. sub ClassInit
  53. {
  54.  my ($class,$mw) = @_;
  55.  $class->SUPER::ClassInit($mw);
  56.  $mw->bind($class,'<Expose>','Expose');
  57.  $mw->bind($class,'<Next>','Next');
  58.  $mw->bind($class,'<Prior>','Prior');
  59.  $mw->bind($class,'<Home>','Home');
  60.  $mw->bind($class,'<End>','End');
  61. }
  62.  
  63. sub Doc  { shift->{'DOC'}  }
  64. sub Page { shift->{'PAGE'} }
  65.  
  66. sub Contents { shift->Doc->Contents }
  67.  
  68. sub Orientation
  69. {
  70.  my ($gs,$orient) = @_;
  71.  $gs->orientation($orient);
  72.  $gs->Expose;
  73. }
  74.  
  75. sub Expose
  76. {
  77.  my $gs = shift;
  78.  $gs->DoWhenIdle(['DrawPage',$gs]) unless($gs->{'RedrawPending'}++);
  79. }
  80.  
  81. sub SetPage
  82. {
  83.  my ($gs,$new) = @_;
  84.  my $doc = $gs->Doc;
  85.  my $page = $gs->Page;
  86.  $new = $#{$doc->{'Posn'}} if ($new > $#{$doc->{'Posn'}});
  87.  $new = 0 if ($new < 0);
  88.  if ($page != $new || !exists $gs->{'pid'})
  89.   {
  90.    $gs->{'PAGE'} = $new;
  91.    $gs->Expose;
  92.   }
  93. }
  94.  
  95. sub Next
  96. {
  97.  my $gs = shift;
  98.  $gs->SetPage($gs->Page+1);
  99. }
  100.  
  101. sub Prior
  102. {
  103.  my $gs = shift;
  104.  $gs->SetPage($gs->Page-1);
  105. }
  106.  
  107. sub Home
  108. {
  109.  my $gs = shift;
  110.  $gs->SetPage(0);
  111. }
  112.  
  113. sub End
  114. {
  115.  my $gs = shift;
  116.  my $doc = $gs->Doc;
  117.  $gs->SetPage($#{$doc->{'Posn'}});
  118. }
  119.  
  120. sub DrawPage
  121. {
  122.  my $gs = shift;
  123.  my $doc = $gs->Doc;
  124.  my $page = $gs->Page;
  125.  $gs->{'RedrawPending'} = 0;
  126.  $gs->Postscript("/GS_Standard save def\n");
  127.  if (0)
  128.   {
  129.    my ($llx,$lly,$urx,$ury) = $gs->BoundingBox;
  130.    $gs->printf("0.9 setgray\n");     
  131.    $gs->printf("%g %g moveto\n",$llx,$lly);
  132.    $gs->printf("%g %g lineto\n",$urx,$lly);
  133.    $gs->printf("%g %g lineto\n",$urx,$ury);
  134.    $gs->printf("%g %g lineto\n",$llx,$ury);
  135.    $gs->printf("closepath fill\n");
  136.    $gs->printf("0 setgray\n");     
  137.   }
  138.  if (defined $doc)
  139.   {
  140.    if (exists $doc->{'BeginProlog'})
  141.     {                        
  142.      $doc->CopySection($gs,'Prolog');
  143.     }                        
  144.    else                      
  145.     {                        
  146.      $doc->CopyTill($gs,0,'^%!','EndProlog','Page:','Trailer');
  147.     }                        
  148.    $doc->CopySection($gs,'Setup') if (exists $doc->{'BeginSetup'});
  149.    $doc->SendPage($gs,$page);
  150.   }
  151.  $gs->Postscript("GS_Standard restore\n");
  152. }
  153.  
  154. 1;
  155.