home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / DSC.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  3.4 KB  |  167 lines
  1. package DSC;
  2. use Tk::Pretty;
  3.  
  4. sub new
  5. {
  6.  my $package = shift;
  7.  my $gs      = shift;
  8.  my $file    = shift;
  9.  my %hash    = ();
  10.  my @label   = ();
  11.  my @posn    = ();
  12.  my %page    = ();
  13.  my $page   = -1;
  14.  my $nested = 0;
  15.  open($file,"<$file") || die "Cannot open $file:$!";
  16.  print STDERR "Reading $file ...\n";
  17.  my $posn = tell($file);
  18.  $hash{'LabelLen'} = 0;
  19.  $hash{'FH'}    = \*{$file};
  20.  $hash{'Page'}  = \%page;
  21.  $hash{'Posn'}  = \@posn;
  22.  $hash{'Label'} = \@label;
  23.  $hash{'Contents'} = \%Contents;
  24.  my $doc = bless \%hash,$package;
  25.  while (<$file>)
  26.   {
  27.    if (/^%%([^:]+):\s*(.*)$/)
  28.     {
  29.      my $key  = $1;
  30.      my $text = $2;
  31.      $text =~ s/\s+$//; 
  32.      $nested++ if ($key eq 'BeginDocument');
  33.      next if $nested; 
  34.      next if ($text =~ /\(atend\)/);
  35.      if ($key eq 'Page')
  36.       {
  37.        ($label,$num) = $text =~ /^(\S*)\s+(\d+)$/;
  38.        $num = $text =~ /^(\d+)$/ if (!defined $num);
  39.        $label = $num unless (defined $label);
  40.        if (defined $num)
  41.         {
  42.          $page++;
  43.          $posn[$page]   = $posn;
  44.          $label[$page]  = $label;
  45.          $page{$label}  = $page;
  46.          $hash{'LabelLen'} = length($label) if (length($label) > $hash{'LabelLen'});
  47.         }
  48.        else
  49.         {
  50.          warn "($label,$num) Bad $_";
  51.         }
  52.       }
  53.      elsif ($key eq 'BoundingBox')
  54.       {
  55.        $gs->BoundingBox(split(/\s+/,$text));
  56.       }
  57.      elsif ($key eq 'Orientation')
  58.       {
  59.        $gs->Orientation($text);
  60.       }
  61.      else
  62.       {
  63.        $hash{$key} = $text unless ($text =~ /\(atend\)/);
  64.       }
  65.     }
  66.    elsif (/^%%([^:]+\S)\s*$/)
  67.     {
  68.      if ($1 eq 'EndDocument') 
  69.       {
  70.        $nested--;
  71.       }
  72.      else
  73.       {
  74.        $hash{$1} = $posn unless ($nested || /Page/);
  75.       }
  76.     }
  77.    elsif (/^%@\s+\d+\s+(\w+)\s+([^\t]*)\t(.*)$/)
  78.     {
  79.      my $kind = $Contents{$1}; 
  80.      my $len2  = length($2);
  81.      my $len3  = length($3);
  82.      if (defined $kind)
  83.       {
  84.        $Contents{$1.'#Llen'} = $len2 if ($len2 > $Contents{$1.'#Llen'});
  85.        $Contents{$1.'#Tlen'} = $len3 if ($len3 > $Contents{$1.'#Tlen'});
  86.       }
  87.      else
  88.       {
  89.        $Contents{$1} = $kind = [];
  90.        $Contents{$1.'#Llen'} = $len2;
  91.        $Contents{$1.'#Tlen'} = $len3;
  92.       }
  93.      push(@$kind,[$2,$3,$page]);
  94.     }
  95.    $posn = tell($file);
  96.   }
  97.  $page++;
  98.  print STDERR "$page Pages\n";
  99.  return $doc;
  100. }
  101.  
  102. sub Contents { shift->{'Contents'} }
  103.  
  104. sub CopyTill
  105. {my $doc   = shift;
  106.  my $out   = shift;
  107.  my $posn  = shift;
  108.  my $start = shift;
  109.  my $fh = $doc->{'FH'};
  110.  if (defined ($posn))
  111.   {
  112.    my $nested = 0;
  113.    my $fh = $doc->{'FH'};
  114.    seek($fh,$posn,0) || die "Cannot seek $$fh to $posn:$!";
  115.    local $_ = <$fh>;
  116.    die "$_" unless (/^%/ && /$start/);
  117.    COPY:
  118.    while (1)
  119.     {
  120.      $nested++ if (/^%%BeginDocument/);
  121.      $nested-- if (/^%%EndDocument/);
  122.      $out->Postscript($_);
  123.      $_ = <$fh>;
  124.      last COPY if (!defined $_);
  125.      foreach $term (@_)
  126.       {
  127.        last COPY if (!$nested && /^%%$term/);
  128.       }
  129.     } 
  130.   }
  131.  else
  132.   {
  133.    die "No posn for $start";  
  134.   }
  135. }
  136.  
  137. sub SendPage
  138. {my $doc = shift;
  139.  my $out = shift;
  140.  my $num;
  141.  foreach $page (@_)
  142.   {
  143.    my $posn = $doc->{'Posn'}[$page];
  144.    $doc->CopyTill($out,$posn,"^%%Page:",'Page:','Trailer');
  145.   }
  146. }
  147.  
  148. sub CopySection
  149. {
  150.  my $doc = shift;
  151.  my $out = shift;
  152.  my $key = shift;
  153.  my $start = 'Begin'.$key;
  154.  my $end   = 'End'.$key;
  155.  my $posn = $doc->{$start};
  156.  if (defined $posn)
  157.   {
  158.    $doc->CopyTill($out,$posn,"^%%$start",$end,'Page:','Trailer');
  159.   }
  160.  else
  161.   {
  162.    warn "No $start:" . Pretty($doc);
  163.   }
  164. }
  165.  
  166. 1;
  167.