home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / HTML / FormatPS.pm < prev    next >
Encoding:
Perl POD Document  |  2004-06-02  |  27.3 KB  |  1,064 lines
  1.  
  2. require 5;
  3. package HTML::FormatPS;
  4.  
  5. =head1 NAME
  6.  
  7. HTML::FormatPS - Format HTML as PostScript
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.   use HTML::TreeBuilder;
  12.   $tree = HTML::TreeBuilder->new->parse_file("test.html");
  13.  
  14.   use HTML::FormatPS;
  15.   $formatter = HTML::FormatPS->new(
  16.            FontFamily => 'Helvetica',
  17.            PaperSize  => 'Letter',
  18.   );
  19.   print $formatter->format($tree);
  20.  
  21. Or, for short:
  22.  
  23.   use HTML::FormatPS;
  24.   print HTML::FormatPS->format_file(
  25.     "test.html",
  26.       'FontFamily' => 'Helvetica',
  27.       'PaperSize'  => 'Letter',
  28.   );
  29.  
  30. =head1 DESCRIPTION
  31.  
  32. The HTML::FormatPS is a formatter that outputs PostScript code.
  33. Formatting of HTML tables and forms is not implemented.
  34.  
  35. You might specify the following parameters when constructing the formatter
  36. object (or when calling format_file or format_string):
  37.  
  38. =over 4
  39.  
  40. =item PaperSize
  41.  
  42. What kind of paper should we format for.  The value can be one of
  43. these: A3, A4, A5, B4, B5, Letter, Legal, Executive, Tabloid,
  44. Statement, Folio, 10x14, Quarto.
  45.  
  46. The default is "A4".
  47.  
  48. =item PaperWidth
  49.  
  50. The width of the paper, in points.  Setting PaperSize also defines this
  51. value.
  52.  
  53. =item PaperHeight
  54.  
  55. The height of the paper, in points.  Setting PaperSize also defines
  56. this value.
  57.  
  58. =item LeftMargin
  59.  
  60. The left margin, in points.
  61.  
  62. =item RightMargin
  63.  
  64. The right margin, in points.
  65.  
  66. =item HorizontalMargin
  67.  
  68. Both left and right margin at the same time.  The default value is 4 cm.
  69.  
  70. =item TopMargin
  71.  
  72. The top margin, in points.
  73.  
  74. =item BottomMargin
  75.  
  76. The bottom margin, in points.
  77.  
  78. =item VerticalMargin
  79.  
  80. Both top and bottom margin at the same time.  The default value is 2 cm,
  81.  
  82.  
  83. =item PageNo
  84.  
  85. This parameter determines if we should put page numbers on the pages.
  86. The default value is true; so you have to set this value to 0 in order to
  87. suppress page numbers.  (The "No" in "PageNo" means number/numero!)
  88.  
  89. =item FontFamily
  90.  
  91. This parameter specifies which family of fonts to use for the formatting.
  92. Legal values are "Courier", "Helvetica" and "Times".  The default is
  93. "Times".
  94.  
  95. =item FontScale
  96.  
  97. This is a scaling factor for all the font sizes.  The default value is 1.
  98.  
  99. For example, if you want everything to be almost three times as large,
  100. you could set this to 2.7.  If you wanted things just a bit smaller than
  101. normal, you could set it to .92.
  102.  
  103. =item Leading
  104.  
  105. This option (pronounced "ledding", not "leeding") controls how much is
  106. space between lines. This is a factor of the font size used for that
  107. line.  Default is 0.1 -- so between two 12-point lines, there will be
  108. 1.2 points of space.
  109.  
  110. =item StartPage
  111.  
  112. Assuming you have PageNo on, StartPage controls what the page number of
  113. the first page will be. By default, it is 1. So if you set this to 87,
  114. the first page would say "87" on it, the next "88", and so on.
  115.  
  116. =item NoProlog
  117.  
  118. If this option is set to a true value, HTML::FormatPS will make a point of
  119. I<not> emitting the PostScript prolog before the document. By default,
  120. this is off, meaning that HTML::FormatPS I<will> emit the prolog. This
  121. option is of interest only to advanced users.
  122.  
  123. =item NoTrailer
  124.  
  125. If this option is set to a true value, HTML::FormatPS will make a point of
  126. I<not> emitting the PostScript trailer at the end of the document. By
  127. default, this is off, meaning that HTML::FormatPS I<will> emit the bit
  128. of PostScript that ends the document. This option is of interest only to
  129. advanced users.
  130.  
  131. =back
  132.  
  133. =head1 SEE ALSO
  134.  
  135. L<HTML::Formatter>
  136.  
  137.  
  138. =head1 TO DO
  139.  
  140. =over
  141.  
  142. =item *
  143.  
  144. Support for some more character styles, notably including:
  145. strike-through, underlining, superscript, and subscript.
  146.  
  147. =item *
  148.  
  149. Support for Unicode.
  150.  
  151. =item *
  152.  
  153. Support for Win-1252 encoding, since that's what most people
  154. mean when they use characters in the range 0x80-0x9F in HTML.
  155.  
  156. =item *
  157.  
  158. And, if it's ever even reasonably possible, support for tables.
  159.  
  160. =back
  161.  
  162. I would welcome email from people who can help me out or advise
  163. me on the above.
  164.  
  165.  
  166.  
  167. =head1 COPYRIGHT
  168.  
  169. Copyright (c) 1995-2002 Gisle Aas, and 2002- Sean M. Burke. All rights
  170. reserved.
  171.  
  172. This library is free software; you can redistribute it and/or
  173. modify it under the same terms as Perl itself.
  174.  
  175. This program is distributed in the hope that it will be useful, but
  176. without any warranty; without even the implied warranty of
  177. merchantability or fitness for a particular purpose.
  178.  
  179.  
  180. =head1 AUTHOR
  181.  
  182. Current maintainer: Sean M. Burke <sburke@cpan.org>
  183.  
  184. Original author: Gisle Aas <gisle@aas.no>
  185.  
  186. =cut
  187.  
  188. use Carp;
  189. use strict;
  190. use vars qw(@ISA $VERSION);
  191.  
  192. use HTML::Formatter ();
  193. BEGIN { *DEBUG = \&HTML::Formatter::DEBUG unless defined &DEBUG }
  194.  
  195. @ISA = qw(HTML::Formatter);
  196.  
  197. $VERSION = sprintf("%d.%02d", q$Revision: 2.04 $ =~ /(\d+)\.(\d+)/);
  198.  
  199. use vars qw(%PaperSizes %FontFamilies @FontSizes %param $DEBUG);
  200.  
  201. # A few routines that convert lengths into points
  202. sub mm { $_[0] * 72 / 25.4; }
  203. sub in { $_[0] * 72; }
  204.  
  205. %PaperSizes =
  206. (
  207.  A3        => [mm(297), mm(420)],
  208.  A4        => [mm(210), mm(297)],
  209.  A5        => [mm(148), mm(210)],
  210.  B4        => [729,     1032   ],
  211.  B5        => [516,     729    ],
  212.  Letter    => [in(8.5), in(11) ],
  213.  Legal     => [in(8.5), in(14) ],
  214.  Executive => [in(7.5), in(10) ],
  215.  Tabloid   => [in(11),  in(17) ],
  216.  Statement => [in(5.5), in(8.5)],
  217.  Folio     => [in(8.5), in(13) ],
  218.  "10x14"   => [in(10),  in(14) ],
  219.  Quarto    => [610,     780    ],
  220. );
  221.  
  222. %FontFamilies =
  223. (
  224.  Courier   => [qw(Courier
  225.           Courier-Bold
  226.           Courier-Oblique
  227.           Courier-BoldOblique)],
  228.  
  229.  Helvetica => [qw(Helvetica
  230.           Helvetica-Bold
  231.           Helvetica-Oblique
  232.           Helvetica-BoldOblique)],
  233.  
  234.  Times     => [qw(Times-Roman
  235.           Times-Bold
  236.           Times-Italic
  237.           Times-BoldItalic)],
  238. );
  239.  
  240.       # size   0   1   2   3   4   5   6   7
  241. @FontSizes = ( 5,  6,  8, 10, 12, 14, 18, 24, 32);
  242.  
  243. sub BOLD   () { 0x01; }
  244. sub ITALIC () { 0x02; }
  245.  
  246. %param =
  247. (
  248.  papersize        => 'papersize',
  249.  paperwidth       => 'paperwidth',
  250.  paperheight      => 'paperheigth',
  251.  leftmargin       => 'lmW',
  252.  rightmargin      => 'rmW',
  253.  horizontalmargin => 'mW',
  254.  topmargin        => 'tmH',
  255.  bottommargin     => 'bmH',
  256.  verticalmargin   => 'mH',
  257.  no_prolog        => 'no_prolog',
  258.  no_trailer       => 'no_trailer',
  259.  pageno           => 'printpageno',
  260.  startpage        => 'startpage',
  261.  fontfamily       => 'family',
  262.  fontscale        => 'fontscale',
  263.  leading          => 'leading',
  264. );
  265.  
  266.  
  267. sub new
  268. {
  269.     my $class = shift;
  270.     my $self = $class->SUPER::new(@_);
  271.  
  272.     # Obtained from the <title> element
  273.     $self->{title} = "";
  274.  
  275.     # The font ID last sent to the PostScript output (this may be
  276.     # temporarily different from the "current font" as read from
  277.     # the HTML input).  Initially none.
  278.     $self->{psfontid} = "";
  279.     
  280.     # Pending horizontal space.  A list [ " ", $fontid, $width ],
  281.     # or undef if no space is pending.
  282.     $self->{hspace} = undef;
  283.     
  284.     $self;
  285. }
  286.  
  287. sub default_values
  288. {
  289.     (
  290.      shift->SUPER::default_values(),
  291.  
  292.      family      => "Times",
  293.      mH          => mm(40),
  294.      mW          => mm(20),
  295.      printpageno => 1,
  296.      startpage   => 1,  # yes, you can start numbering at 10, or whatever.
  297.      fontscale   => 1,
  298.      leading     => 0.1,
  299.      papersize   => 'A4',
  300.      paperwidth  => mm(210),
  301.      paperheight => mm(297),
  302.     )
  303. }
  304.  
  305. sub configure
  306. {
  307.     my($self, $hash) = @_;
  308.     my($key,$val);
  309.     while (($key, $val) = each %$hash) {
  310.     $key = lc $key;
  311.     croak "Illegal parameter ($key => $val)" unless exists $param{$key};
  312.     $key = $param{$key};
  313.     {
  314.         $key eq "family" && do {
  315.         $val = "\u\L$val";
  316.         croak "Unknown font family ($val)"
  317.           unless exists $FontFamilies{$val};
  318.         $self->{family} = $val;
  319.         last;
  320.         };
  321.         $key eq "papersize" && do {
  322.         $self->papersize($val) ||
  323.           croak sprintf
  324.                   "Unknown papersize '%s'.\nThe knowns are: %s.\nAborting",
  325.                       $val,
  326.                       join(', ',  sort keys %PaperSizes)
  327.                 ;
  328.         last;
  329.         };
  330.         $self->{$key} = lc $val;
  331.     }
  332.     }
  333. }
  334.  
  335. sub papersize
  336. {
  337.     my($self, $val) = @_;
  338.     $val = "\u\L$val";
  339.     my($width, $height) = @{$PaperSizes{$val} || return 0};
  340.     return 0 unless defined $width;
  341.     $self->{papersize} = $val;
  342.     $self->{paperwidth} = $width;
  343.     $self->{paperheight} = $height;
  344.     1;
  345. }
  346.  
  347.  
  348. sub fontsize
  349. {
  350.     my $self = shift;
  351.     my $size = $self->{font_size}[-1];
  352.     $size = 8 if $size > 8;
  353.     $size = 3 if $size < 0;
  354.     $FontSizes[$size] * $self->{fontscale};
  355. }
  356.  
  357. # Determine the current font and set font-related members.
  358. # If $plain_with_size is given (a number), use a plain font
  359. # of that size.  Otherwise, use the font specified by the
  360. # HTML context.  Returns the "font ID" of the current font.
  361.  
  362. sub setfont
  363. {
  364.     my($self, $plain_with_size) = @_;
  365.     my $index = 0;
  366.     my $family = $self->{family} || 'Times';
  367.     my $size = $plain_with_size;
  368.     unless ($plain_with_size) {
  369.     $index |= BOLD   if $self->{bold};
  370.     $index |= ITALIC if $self->{italic} || $self->{underline};
  371.     $family = 'Courier' if $self->{teletype};
  372.     $size = $self->fontsize;
  373.     }
  374.     my $font = $FontFamilies{$family}[$index];
  375.     my $font_with_size = "$font-$size";
  376.     if ($self->{currentfont} eq $font_with_size) {
  377.     return $self->{currentfontid};
  378.     }
  379.     $self->{currentfont} = $font_with_size;
  380.     $self->{pointsize} = $size;
  381.     my $fontmod = "Font::Metrics::$font";
  382.     $fontmod =~ s/-//g;
  383.     my $fontfile = $fontmod . ".pm";
  384.     $fontfile =~ s,::,/,g;
  385.     require $fontfile;
  386.     {
  387.     no strict 'refs';
  388.     $self->{wx} = \@{ "${fontmod}::wx" };
  389.     }
  390.     $font = $self->{fonts}{$font_with_size} || do {
  391.     my $fontID = "F" . ++$self->{fno};
  392.     $self->{fonts}{$font_with_size} = $fontID;
  393.     $fontID;
  394.     };
  395.     $self->{currentfontid} = $font;
  396.     return $font;
  397. }
  398.  
  399. # Construct PostScript code for setting the current font according 
  400. # to $fontid, or an empty string if no font change is needed.
  401. # Assumes the return string will always be output as PostScript if
  402. # nonempty, so that our notion of the current PostScript font
  403. # stays in sync with that of the PostScript interpreter.
  404.  
  405. sub switchfont
  406. {
  407.     my($self, $fontid) = @_;
  408.     if ($self->{psfontid} eq $fontid) {
  409.     return "";
  410.     } else {
  411.     $self->{psfontid} = $fontid;
  412.     return "$fontid SF";
  413.     }
  414. }
  415.  
  416. # Like setfont + switchfont.
  417.  
  418. sub findfont
  419. {
  420.     my($self, $plain_with_size) = @_;
  421.     return $self->switchfont($self->setfont($plain_with_size));
  422. }
  423.  
  424. sub width
  425. {
  426.     my $self = shift;
  427.     my $w = 0;
  428.     my $wx = $self->{wx};
  429.     my $sz = $self->{pointsize};
  430.     for (unpack("C*", $_[0])) {
  431.     $w += $wx->[$_] * $sz   # unless  $_ eq 0xAD; # optional hyphen
  432.     }
  433.     $w;
  434. }
  435.  
  436.  
  437. sub begin
  438. {
  439.     my $self = shift;
  440.     $self->SUPER::begin;
  441.  
  442.     # Margins are in points
  443.     $self->{lm} = $self->{lmW} || $self->{mW};
  444.     $self->{rm} = $self->{paperwidth}  - ($self->{rmW} || $self->{mW});
  445.     $self->{tm} = $self->{paperheight} - ($self->{tmH} || $self->{mH});
  446.     $self->{bm} = $self->{bmH} || $self->{mH};
  447.  
  448.     $self->{'orig_margins'} = # used only by the debug-mode print-area marker
  449.         [  map { sprintf "%.1f", $_}
  450.          @{$self}{qw(lm bm rm tm)}
  451.     ];
  452.  
  453.     # Font setup
  454.     $self->{fno} = 0;
  455.     $self->{fonts} = {};
  456.     $self->{en} = 0.55 * $self->fontsize(3);
  457.  
  458.     # Initial position
  459.     $self->{xpos} = $self->{lm};  # top of the current line
  460.     $self->{ypos} = $self->{tm};
  461.  
  462.     $self->{pageno} = 1;
  463.     $self->{visible_page_number} = $self->{startpage};
  464.  
  465.     $self->{line} = "";
  466.     $self->{showstring} = "";
  467.     $self->{currentfont} = "";
  468.     $self->{prev_currentfont} = "";
  469.     $self->{largest_pointsize} = 0;
  470.  
  471.     $self->newpage;
  472. }
  473.  
  474.  
  475. sub end
  476. {
  477.     my $self = shift;
  478.     
  479.     $self->showline;
  480.     $self->endpage if $self->{'out'};
  481.     my $pages = $self->{pageno} - 1;
  482.  
  483.     my @prolog = ();
  484.     push(@prolog, "%!PS-Adobe-3.0\n");
  485.     #push(@prolog,"%%Title: No title\n"); # should look for the <title> element
  486.     push(@prolog, "%%Creator: " . $self->version_tag . "\n");
  487.     push(@prolog, "%%CreationDate: " . localtime() . "\n");
  488.     push(@prolog, "%%Pages: $pages\n");
  489.     push(@prolog, "%%PageOrder: Ascend\n");
  490.     push(@prolog, "%%Orientation: Portrait\n");
  491.     my($pw, $ph) = map { int($_); } @{$self}{qw(paperwidth paperheight)};
  492.  
  493.     push(@prolog, "%%DocumentMedia: Plain $pw $ph 0 white ()\n");
  494.     push(@prolog, "%%DocumentNeededResources: \n");
  495.     my($full, %seenfont);
  496.     for $full (sort keys %{$self->{fonts}}) {
  497.     $full =~ s/-\d+$//;
  498.     next if $seenfont{$full}++;
  499.     push(@prolog, "%%+ font $full\n");
  500.     }
  501.     push(@prolog, "%%DocumentSuppliedResources: procset newencode 1.0 0\n");
  502.     push(@prolog, "%%+ encoding ISOLatin1Encoding\n");
  503.     push(@prolog, "%%EndComments\n");
  504.     push(@prolog, <<'EOT');
  505.  
  506. %%BeginProlog
  507. /S/show load def
  508. /M/moveto load def
  509. /SF/setfont load def
  510.  
  511. %%BeginResource: encoding ISOLatin1Encoding
  512. systemdict /ISOLatin1Encoding known not {
  513.     /ISOLatin1Encoding [
  514.     /space /space /space /space /space /space /space /space
  515.     /space /space /space /space /space /space /space /space
  516.     /space /space /space /space /space /space /space /space
  517.     /space /space /space /space /space /space /space /space
  518.     
  519.     /space /exclam /quotedbl /numbersign /dollar /percent /ampersand
  520.         /quoteright
  521.     /parenleft /parenright /asterisk /plus /comma /minus /period /slash
  522.     /zero /one /two /three /four /five /six /seven
  523.     /eight /nine /colon /semicolon /less /equal /greater /question
  524.     /at /A /B /C /D /E /F /G
  525.     /H /I /J /K /L /M /N /O
  526.     /P /Q /R /S /T /U /V /W
  527.     /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore
  528.     /quoteleft /a /b /c /d /e /f /g
  529.     /h /i /j /k /l /m /n /o
  530.     /p /q /r /s /t /u /v /w
  531.     /x /y /z /braceleft /bar /braceright /asciitilde /space
  532.     
  533.     /space /space /space /space /space /space /space /space
  534.     /space /space /space /space /space /space /space /space
  535.     /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
  536.     /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron
  537.     
  538.     /space /exclamdown /cent /sterling /currency /yen /brokenbar /section
  539.     /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen
  540.         /registered /macron
  541.     /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph
  542.         /periodcentered
  543.     /cedillar /onesuperior /ordmasculine /guillemotright /onequarter
  544.         /onehalf /threequarters /questiondown
  545.     /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla
  546.     /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex
  547.         /Idieresis
  548.     /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply
  549.     /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn
  550.         /germandbls
  551.     /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla
  552.     /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex
  553.         /idieresis
  554.     /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide
  555.     /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn
  556.         /ydieresis
  557.     ] def
  558. } if
  559. %%EndResource
  560. %%BeginResource: procset newencode 1.0 0
  561. /NE { %def
  562.    findfont begin
  563.       currentdict dup length dict begin
  564.      { %forall
  565.         1 index/FID ne {def} {pop pop} ifelse
  566.      } forall
  567.      /FontName exch def
  568.      /Encoding exch def
  569.      currentdict dup
  570.       end
  571.    end
  572.    /FontName get exch definefont pop
  573. } bind def
  574. %%EndResource
  575. %%EndProlog
  576. EOT
  577.  
  578.     push(@prolog, "\n%%BeginSetup\n");
  579.     for $full (sort keys %{$self->{fonts}}) {
  580.     my $short = $self->{fonts}{$full};
  581.     $full =~ s/-(\d+)$//;
  582.     my $size = $1;
  583.     push(@prolog, "ISOLatin1Encoding/$full-ISO/$full NE\n");
  584.     push(@prolog, "/$short/$full-ISO findfont $size scalefont def\n");
  585.     }
  586.     push(@prolog, "%%EndSetup\n");
  587.  
  588.     $self->collect("\n%%Trailer\n%%EOF\n")
  589.       unless $self->{'no_trailer'};
  590.     
  591.     unshift(@{$self->{output}}, @prolog)
  592.       unless $self->{'no_prolog'};
  593. }
  594.  
  595.  
  596. sub header_start
  597. {
  598.     my($self, $level, $node) = @_;
  599.     # If we are close enough to be bottom of the page, start a new page
  600.     # instead of this:
  601.     DEBUG > 1 and print "  Heading of level $level\n";
  602.     $self->vspace(1 + (6-$level) * 0.4);
  603.     $self->{bold}++;
  604.     push(@{$self->{font_size}}, 8 - $level);
  605.     1;
  606. }
  607.  
  608.  
  609. sub header_end
  610. {
  611.     my($self, $level, $node) = @_;
  612.     $self->vspace(1);
  613.     $self->{bold}--;
  614.     pop(@{$self->{font_size}});
  615.     1;
  616. }
  617.  
  618. sub hr_start
  619. {
  620.     my $self = shift;
  621.     DEBUG > 1 and print "  Making an HR.\n";
  622.     $self->showline;
  623.     $self->vspace(0.5);
  624.     $self->skip_vspace;
  625.     my $lm = $self->{lm};
  626.     my $rm = $self->{rm};
  627.     my $y = $self->{ypos};
  628.     $self->collect(sprintf "newpath %.1f %.1f M %.1f %.1f lineto stroke\n",
  629.            $lm, $y, $rm, $y);
  630.     $self->vspace(0.5);
  631. }
  632.  
  633.  
  634. sub skip_vspace
  635. {
  636.     my $self = shift;
  637.     DEBUG > 2 and print "   Skipping some amount of vspace.\n";
  638.     if (defined $self->{vspace}) {
  639.     $self->showline;
  640.     if ($self->{'out'}) {
  641.         $self->{ypos} -= $self->{vspace} * 10 * $self->{fontscale};
  642.  
  643.         if ($self->{ypos} < $self->{bm}) {
  644.         DEBUG > 2 and printf "   Skipping %s bits of vspace meant moving y down by %.1f to %.1f (via fontscale %s), forcing a pagebreak.\n",
  645.           $self->{'vspace'},
  646.           $self->{'ypos'},
  647.                   $self->{'vspace'} * 10 * $self->{fontscale},
  648.           $self->{'fontscale'},
  649.         ;
  650.         $self->newpage;
  651.         } else {
  652.         DEBUG > 2 and printf "   Skipping %s bits of vspace meant moving y down by %.1f to %.1f up.\n",
  653.           $self->{vspace},
  654.           $self->{'ypos'},
  655.                   $self->{vspace} * 10 * $self->{fontscale},
  656.           $self->{'fontscale'},
  657.         ;
  658.         }
  659.     } else {
  660.         DEBUG > 2 and printf "   Would skip $$self{vspace} bits of vspace, but 'out' is false.\n", $$self{'ypos'};
  661.     }
  662.     $self->{xpos} = $self->{lm};
  663.     $self->{vspace} = undef;
  664.     $self->{hspace} = undef;
  665.     } else {
  666.       DEBUG > 2 and print "   (But no vspace to skip.)\n";
  667.     }
  668.     DEBUG > 3 and print "    Done skipping that vspace.\n";
  669.     return;
  670. }
  671.  
  672.  
  673. sub show
  674. {
  675.     my $self = shift;
  676.     my $str = $self->{showstring};
  677.     $str =~ tr/\x01//d;
  678.     return unless length $str;
  679.     
  680.     $str =~ s/[^\x00-\xff]/\xA4/g;
  681.      # replace any Unicode characters with the otherwise useless
  682.      #  International Communist Conspiracy money logo!
  683.     
  684.     $str =~ s/([\(\)\\])/\\$1/g;    # must escape parentheses and backslash
  685.     $self->{line} .= "($str)S\n";
  686.     $self->{showstring} = "";
  687. }
  688.  
  689.  
  690. sub showline
  691. {
  692.     my $self = shift;
  693.     $self->show;
  694.     my $line = $self->{line};
  695.     unless( length $line ) {
  696.         DEBUG > 2
  697.          and print "   Showline is a no-op because line buffer is empty\n";
  698.         return;
  699.     }
  700.     
  701.     if( DEBUG > 2 ) {
  702.         my $l = $line;
  703.         $l =~ tr/\n/\xB6/;
  704.         print "   Showline is going to emit <$l>\n";
  705.     }
  706.     
  707.     $self->{ypos} -= $self->{largest_pointsize} || $self->{pointsize};
  708.     if ($self->{ypos} < $self->{bm}) {
  709.         DEBUG > 2
  710.          and print "   Showline has to start a new page first.\n";
  711.         
  712.         DEBUG > 2 and print "   vspace value before newpage: ",
  713.           defined($self->{vspace}) ? $self->{vspace} : 'undef', "\n";
  714.  
  715.         DEBUG > 10 and $self->dump_state;
  716.     $self->newpage;
  717.          # newpage might alter currentfont!
  718.         
  719.         DEBUG > 2 and print "  vspace value after newpage: ",
  720.           defined($self->{vspace}) ? $self->{vspace} : 'undef', "\n";
  721.  
  722.         DEBUG > 2 and printf "   Moving y from %.1f down to %.f because of pointsize %s\n",
  723.          $self->{ypos}, $self->{ypos} - $self->{pointsize}, $self->{pointsize},
  724.         ;
  725.  
  726.     $self->{ypos} -= $self->{pointsize};
  727.     
  728.         DEBUG > 2 and printf "   Newpage's (x,y) is (%.1f, %.1f).\n",
  729.          @$self{'xpos', 'ypos'};
  730.  
  731.     # must set current font again
  732.     my $font = $self->{prev_currentfont};
  733.     if ($font) {
  734.         $self->collect("$self->{fonts}{$font} SF\n\n");
  735.     }
  736.  
  737.         DEBUG > 10 and $self->dump_state;
  738.         DEBUG > 2 and print "   End of doing newpage.\n";
  739.     }
  740.  
  741.     #DEBUG > 2 and $self->dump_state;
  742.     
  743.  
  744.     my $lm = $self->{lm};
  745.     my $x = $lm;
  746.     if ($self->{center}) {
  747.     # Unfortunately, the center attribute is gone when we get here,
  748.     # so this code is never activated
  749.     my $linewidth = $self->{xpos} - $lm;
  750.     $x += ($self->{rm} - $lm - $linewidth) / 2;
  751.     }
  752.  
  753.     $self->collect(sprintf "%.1f %.1f M\n", $x, $self->{ypos});  # moveto
  754.     $line =~ s/\s\)S$/)S/;  # many lines will end uselessly with space
  755.     $self->collect($line);
  756.     $self->{'out'}++;
  757.  
  758.     if( DEBUG > 3 ) {
  759.         my $l = $line;
  760.         $l =~ tr/\n/\xB6/;
  761.         print "   Showline has just emitted <$l>\n";
  762.     }
  763.  
  764.     DEBUG > 3 and print "   vspace value after collection: ",
  765.           defined($self->{vspace}) ? $self->{vspace} : 'undef', "\n";
  766.  
  767.     if ($self->{bullet}) {
  768.     # Putting this behind the first line of the list item
  769.     # makes it more likely that we get the right font.  We should
  770.     # really set the font that we want to use.
  771.     my $bullet = $self->{bullet};
  772.     if ($bullet eq '*') {
  773.         # There is no character that is really suitable.  Let's make
  774.         # a medium-sized filled cirle ourself.
  775.         my $radius = $self->{pointsize} / 8;
  776.             DEBUG > 2 and
  777.              print "   Adding code for a '*' bullet for that line.\n";
  778.  
  779.         $self->collect(sprintf "newpath %.1f %.1f %.1f 0 360 arc fill\n",
  780.                $self->{bullet_pos} + $radius,
  781.                $self->{ypos} + $radius * 2,
  782.                $radius,
  783.         );
  784.     } else {
  785.             DEBUG > 2 and
  786.              print "   Adding code for a '$bullet' bullet for that line.\n";
  787.  
  788.         $self->collect(sprintf "%.1f (%s) stringwidth pop sub %.1f add %.1f M\n", # moveto
  789.                $self->{bullet_pos},
  790.                $bullet,
  791.                $self->{pointsize} * 0.62,
  792.                $self->{ypos},
  793.         );
  794.         $self->collect("($bullet)S\n");
  795.     }
  796.     $self->{bullet} = '';
  797.  
  798.     }
  799.  
  800.     $self->{prev_currentfont} = $self->{currentfont};
  801.     $self->{largest_pointsize} = 0;
  802.     $self->{line} = "";
  803.     $self->{xpos} = $lm;
  804.     # Additional linespacing
  805.  
  806.     DEBUG > 2 and printf "   Leading makes me move down from (%.1f, %.1f) by (%.1f * %.1f = %.1f).\n", @$self{'xpos', 'ypos'}, $self->{leading}, $self->{pointsize} , $self->{leading} * $self->{pointsize};
  807.  
  808.     $self->{ypos} -= $self->{leading} * $self->{pointsize};
  809.     DEBUG > 2 and printf "   Showline ends by setting (x,y) to (%.1f, %.1f).\n",
  810.      @$self{'xpos', 'ypos'};
  811.     
  812.     return;
  813. }
  814.  
  815.  
  816. sub endpage
  817. {
  818.     my $self = shift;
  819.     DEBUG > 1 and print "  Ending page $$self{pageno}\n";
  820.     # End previous page
  821.     $self->collect("showpage\n");
  822.     $self->{visible_page_number}++;
  823.     $self->{pageno}++;
  824. }
  825.  
  826.  
  827. sub newpage
  828. {
  829.     my $self = shift;
  830.     
  831.     local $self->{'pointsize'} = $self->{'pointsize'};
  832.      # That's needed for protecting against one bit of the
  833.      #  potential side-effects from from page-numbering code
  834.  
  835.     if ($self->{'out'}) { # whether we've sent anything to the current page so far.
  836.         DEBUG > 2 and print "   Newpage sees that 'out' is true ($$self{'out'}), so calls endpage.\n";
  837.     $self->endpage;
  838.         $self->collect( sprintf
  839.          "%% %s has sent %s write-events to the above page.\n",
  840.          ref($self), $self->{'out'},
  841.         );
  842.     }
  843.  
  844.     $self->{'out'} = 0;
  845.     my $pageno = $self->{pageno};
  846.     my $visible_page_number = $self->{visible_page_number};
  847.  
  848.     $self->collect("\n%%Page: $pageno $pageno\n");
  849.     DEBUG and print " Starting page $pageno\n";
  850.  
  851.     # Print area marker (just for debugging)
  852.     if ($DEBUG or DEBUG > 5) {
  853.     my($llx, $lly, $urx, $ury) = @{ $self->{'orig_margins'} };
  854.     $self->collect("gsave 0.1 setlinewidth\n");
  855.     $self->collect("clippath 0.9 setgray fill 1 setgray\n");
  856.     $self->collect("$llx $lly moveto $urx $lly lineto $urx $ury lineto $llx $ury lineto closepath fill\n");
  857.     $self->collect("grestore\n");
  858.     }
  859.  
  860.     # Print page number
  861.     if ($self->{printpageno}) {
  862.         DEBUG > 2 and print "   Printing page number $visible_page_number (really page $pageno).\n";
  863.     $self->collect("%% Title and pageno\n");
  864.     my $f = $self->findfont(8);
  865.     $self->collect("$f\n") if $f;
  866.         my $x = $self->{paperwidth};
  867.         if ($x) { $x -= 30; } else { $x = 30; }
  868.         $self->collect(sprintf "%.1f 30.0 M($visible_page_number)S\n", $x);
  869.     $x = $self->{lm};
  870.     $self->{title} =~ tr/\x01//d;
  871.     $self->collect(sprintf "%.1f 30.0 M($self->{title})S\n", $x);
  872.     } else {
  873.         DEBUG > 2 and print "   Pointedly not printing page number.\n";
  874.     }
  875.     $self->collect("\n");
  876.  
  877.     DEBUG > 2 and printf "  Newpage ends by setting (x,y) to (%.1f across, %.1f up)\n",
  878.      @$self{'lm','tm'};
  879.     
  880.     $self->{xpos} = $self->{lm};
  881.     $self->{ypos} = $self->{tm};
  882. }
  883.  
  884.  
  885. sub out   # Output a word
  886. {
  887.     my($self, $text) = @_;
  888.     
  889.     $text =~ tr/\xA0\xAD/ /d;
  890.     DEBUG > 3 and print "    Trapping new word <$text>\n";
  891.     
  892.     if ($self->{collectingTheTitle}) {
  893.         # Both collect and print the title
  894.         $text =~ s/([\(\)\\])/\\$1/g; # Escape parens and the backslash
  895.         $self->{title} .= $text;
  896.     return;
  897.     }
  898.  
  899.     my $fontid = $self->setfont();
  900.     my $w = $self->width($text);
  901.  
  902.     if ($text =~ /^\s*$/) {
  903.         $self->{hspace} = [ " ", $fontid, $w ];
  904.         return;
  905.     }
  906.  
  907.     $self->skip_vspace;
  908.  
  909.     # determine spacing / line breaks needed before text
  910.     if ($self->{hspace}) {
  911.     my ($stext, $sfont, $swidth) = @{$self->{hspace}};
  912.     if ($self->{xpos} + $swidth + $w > $self->{rm}) {
  913.         # line break
  914.         $self->showline;
  915.     } else {
  916.         # no line break; output a space
  917.             $self->show_with_font($stext, $sfont, $swidth);
  918.     }
  919.     $self->{hspace} = undef;
  920.     }
  921.  
  922.     # output the text
  923.     $self->show_with_font($text, $fontid, $w);
  924. }
  925.  
  926.  
  927. sub show_with_font {
  928.     my ($self, $text, $fontid, $w) = @_;
  929.  
  930.     my $fontps = $self->switchfont($fontid);
  931.     if (length $fontps) {
  932.     $self->show;
  933.     $self->{line} .= "$fontps\n";
  934.     }
  935.  
  936.     $self->{xpos} += $w;
  937.     $self->{showstring} .= $text;
  938.  
  939.     DEBUG > 4 and print "     Appending to string buffer: \"$text\" with font $fontid\n";
  940.     DEBUG > 4 and printf "     xpos is now %.1f across.\n", ${$self}{'xpos'};
  941.  
  942.     $self->{largest_pointsize} = $self->{pointsize}
  943.       if $self->{largest_pointsize} < $self->{pointsize};
  944.     $self->{'out'}++;
  945. }
  946.  
  947.  
  948. sub pre_out
  949. {
  950.     my($self, $text) = @_;
  951.     $self->skip_vspace;
  952.     $self->tt_start;
  953.     my $font = $self->findfont();
  954.     if (length $font) {
  955.     $self->show;
  956.     $self->{line} .= "$font\n";
  957.     }
  958.     while ($text =~ s/(.*)\n//) {
  959.         $self->{'out'}++;
  960.     $self->{showstring} .= $1;
  961.     $self->showline;
  962.     }
  963.     $self->{showstring} .= $text;
  964.     $self->tt_end;
  965.     1;
  966. }
  967.  
  968. sub bullet
  969. {
  970.     my($self, $bullet) = @_;
  971.     $self->{bullet} = $bullet;
  972.     $self->{bullet_pos} = $self->{lm};
  973. }
  974.  
  975. sub adjust_lm
  976. {
  977.     my $self = shift;
  978.     DEBUG > 1 and printf "  Adjusting lm by %s, called by %s line %s\n",
  979.       $_[0], (caller(1))[3,2];
  980.     $self->showline;
  981.     
  982.     DEBUG > 2 and printf "  ^=Changing lm from %.1f to %.1f, because en=%.1f\n",
  983.       $self->{lm},
  984.       $self->{lm} + $_[0] * $self->{en},
  985.       $self->{en},
  986.     ;
  987.     
  988.     $self->{lm} += $_[0] * $self->{en};
  989.     1;
  990. }
  991.  
  992.  
  993. sub adjust_rm
  994. {
  995.     my $self = shift;
  996.     DEBUG > 1 and printf "  Adjusting rm by %s, called by %s line %s\n",
  997.       $_[0], (caller(1))[3,2];
  998.  
  999.     $self->showline;
  1000.  
  1001.     DEBUG > 2 and printf "  ^ Changing rm from %.1f to %.1f, because en=%.1f\n",
  1002.       $self->{lm},
  1003.       $self->{lm} + $_[0] * $self->{en},
  1004.       $self->{en},
  1005.     ;
  1006.  
  1007.     $self->{rm} += $_[0] * $self->{en};
  1008. }
  1009.  
  1010. sub head_start {
  1011.     1;
  1012. }
  1013.  
  1014. sub head_end {
  1015.     1;
  1016. }
  1017.  
  1018. sub title_start {
  1019.     my($self) = @_;
  1020.     $self->{collectingTheTitle} = 1;
  1021.     1;
  1022. }
  1023.  
  1024. sub title_end {
  1025.     my($self) = @_;
  1026.     $self->{collectingTheTitle} = 0;
  1027.     1;
  1028. }
  1029.  
  1030. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1031.  
  1032. my($counter, $last_state_filename);
  1033.  
  1034. # For use in circumstances of total desperation:
  1035.  
  1036. sub dump_state {
  1037.     my $self = shift;
  1038.     require Data::Dumper;
  1039.  
  1040.     ++$counter;
  1041.     my $filename = sprintf("state%04d.txt", $counter);
  1042.     open(STATE, ">$filename") or die "Can't write-open $filename: $!";
  1043.     printf STATE "%s line %s\n", (caller(1) )[3,2];
  1044.     {
  1045.       local( $self->{'wx'}     ) = '<SUPPRESSED>' ;
  1046.       local( $self->{'output'} ) = '<SUPPRESSED>' ;
  1047.       print STATE Data::Dumper::Dumper($self);
  1048.     }
  1049.     close(STATE);
  1050.     sleep 0;
  1051.  
  1052.     if( $last_state_filename ) {
  1053.       system("perl -S diff.bat $last_state_filename $filename > $filename.diff");
  1054.     }
  1055.  
  1056.     $last_state_filename = $filename;
  1057.     return 1;
  1058. }
  1059.  
  1060. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1061.  
  1062.  
  1063. 1;
  1064.