home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / POD / Parser / DDF.pm next >
Encoding:
Perl POD Document  |  1998-04-27  |  30.1 KB  |  1,086 lines
  1. package Pod::Parser::DDF;
  2. use Pod::Parser;
  3. use Carp;
  4.  
  5. # "Impression is loosing" (sp? - is it loosing or loozing cf hakerz ?) because:
  6. # 0: The ddf output for styles can't cope with style names containing "
  7. # 1: keepregion can't be used on two adjacent regions.
  8. #    (workaround - put a newline inbetween, with arbitarily small fontsize)
  9. # 2: keepnext must be turned on at the *start* of the line. I've found that you 
  10. #    can't put two tabs first.
  11.  
  12. @ISA = qw(Pod::Parser);
  13.  
  14. $VERSION = 0.05;
  15.  
  16. use Text::DDF;
  17. use Text::Tabs;
  18.  
  19. use strict;
  20.  
  21. use vars qw($normal $title $head1 $head2 $head3 $verbatim $verbatimend $code
  22.         $file $error $index $itemkeyword $itemkeywordindex $empty
  23.         $perlrunopts $bold $italic $keepregion $keepnext %styles %cheats
  24.         $tabs_on_item_ruler %HTML_Escapes);
  25.  
  26. # Don't downcase these words in headings...
  27.  
  28. %cheats = ( "CPAN\n" => 1, "IO\n" => 1, "LC_TIME\n" => 1 );
  29.  
  30. use Data::Dumper;
  31. # print Dumper(\%Units::factors);
  32.  
  33. ## Hmm. Is this OOP style of programming making things just a little too easy?
  34.  
  35. $empty = new Text::DDF::Effect;
  36.  
  37. $bold = new Text::DDF::Effect 'bold';
  38. $italic = new Text::DDF::Effect 'italic';
  39. $keepregion = new Text::DDF::Effect 'keepregion';
  40. $keepnext = new Text::DDF::Effect 'keepnext';
  41.  
  42. $normal = new Text::DDF::Style 'Normal', qw(
  43.  font Trinity.Medium
  44.  fontsize 12pt
  45.  linespacep 120%
  46.  spaceabove 0pt
  47.  spacebelow 14pt);
  48.  
  49. $title = new Text::DDF::Style 'Title', qw(
  50.  font Homerton.Bold
  51.  fontsize 20pt
  52.  linespacep 120%
  53.  justify centre
  54.  contents 0
  55.  menuitem on
  56.  autoparagraph), '';
  57.  
  58. $head1 = new Text::DDF::Style 'Head1', qw(
  59.  font Homerton.Medium
  60.  fontsize 18pt
  61.  linespacep 120%
  62.  contents 1
  63.  shortcut 385
  64.  spacebelow 7pt
  65.  keepnext on
  66.  menuitem on
  67.  autoparagraph), '';
  68.  
  69. $head2 = new Text::DDF::Style 'Head2', qw(
  70.  font Homerton.Medium
  71.  fontsize 14pt
  72.  linespacep 120%
  73.  contents 2
  74.  shortcut 386
  75.  spacebelow 7pt
  76.  keepnext on
  77.  menuitem on
  78.  autoparagraph), '';
  79.  
  80. $head3 = $head2->Copy('Head3');
  81. $head3->Add( qw(fontsize 10pt));
  82.  
  83. $code = new Text::DDF::Style 'Code', qw(
  84.  font Corpus.Medium
  85.  menuitem on
  86.  autoparagraph), '';
  87.  
  88. $file = $code->Copy('File');
  89.  
  90. $verbatim = $code->Copy('Verbatim');
  91. # Need to squeeze more onto the page - fontsize 10
  92. $verbatim->Add( qw(
  93.  fontsize 10pt
  94.  spacebelow 0pt
  95.  leftmargin 36pt
  96.  rightmargin 0pt
  97.  returnmargin 36pt
  98.  tabs), '72pt,144pt,216pt,288pt,360pt,432pt,504pt,576pt' );
  99.  
  100. $verbatim->AddTabs( qw() );
  101.  
  102. # This is a hack to get around Impression's inability to keeptogether adjacent regions
  103. $verbatimend = new Text::DDF::Style 'Verbatim End', qw(
  104.  linespacep 0%
  105. );
  106.  
  107. # This needs to be manually applied to lines m/^perl\t/ (match the patter POD insensitive)
  108.  
  109. $perlrunopts = new Text::DDF::Style 'Perl Run Options', qw(
  110.  leftmargin 72pt
  111.  rightmargin 0pt
  112.  returnmargin 1.8pt
  113.  ruleleftmargin 0pt
  114.  rulerightmargin 0pt
  115.  menuitem on
  116.  autoparagraph), '', 'tabs', '72pt,144pt,216pt,288pt,360pt,432pt,504pt,576pt,648pt';
  117.  
  118. $error = new Text::DDF::Style 'Error', qw(
  119.  overprint off
  120.  menuitem on), 'fontcolour', 'rgb=(0,1,1)', 'backcolour', 'rgb=(1,0,0)';
  121.  
  122. $index = new Text::DDF::Style 'Index Entry', qw(
  123.  menuitem on
  124.  index), '', 'backcolour', 'rgb=(0,1,0)';
  125.  
  126. $itemkeyword = new Text::DDF::Style 'Item Keyword', qw(
  127.  bold on
  128.  menuitem on
  129.  keepnext on
  130.  spacebelow 0pt
  131.  keepnext on);
  132.  
  133. # So that the syntax can be separated
  134. # If you make this a copy (rather than an alias) of $index rember to add it to the foreach
  135. # below.
  136.  
  137. $itemkeywordindex = $index;
  138.  
  139. my $style;
  140.  
  141. foreach $style ( qw( title head1 head2 head3 code file verbatim verbatimend
  142.              error index normal itemkeyword perlrunopts) )
  143. {
  144.     # Make a hash of the form $style{head} = \$head
  145.     eval "\$styles{'$style'} = \$$style"
  146. }
  147.  
  148. %HTML_Escapes = (
  149.     'amp'    =>    '&',    #   ampersand
  150.     'lt'    =>    '<',    #   left chevron, less-than
  151.     'gt'    =>    '>',    #   right chevron, greater-than
  152.     'quot'    =>    '"',    #   double quote
  153.  
  154.     'nbsp'    =>    ' ',    #   no-break space
  155.     'iexcl'    =>    '¡',    #   inverted exclamation mark
  156.     'cent'    =>    '¢',    #   cent sign
  157.     'pound'    =>    '£',    #   pound sterling sign
  158.     'curren'    =>    '¤',    #   general currency sign
  159.     'yen'    =>    '¥',    #   yen sign
  160.     'brvbar'    =>    '¦',    #   broken (vertical) bar
  161.     'sect'    =>    '§',    #   section sign
  162.     'uml'    =>    '¨',    #   umlaut (dieresis)
  163.     'copy'    =>    '©',    #   copyright sign
  164.     'ordf'    =>    'ª',    #   ordinal indicator, feminine
  165.     'laquo'    =>    '«',    #   angle quotation mark, left
  166.     'not'    =>    '¬',    #   not sign
  167.     'shy'    =>    '­',    #   soft hyphen
  168.     'reg'    =>    '®',    #   registered sign
  169.     'macr'    =>    '¯',    #   macron
  170.     'deg'    =>    '°',    #   degree sign
  171.     'plusmn'    =>    '±',    #   plus-or-minus sign
  172.     'sup2'    =>    '²',    #   superscript two
  173.     'sup3'    =>    '³',    #   superscript three
  174.     'acute'    =>    '´',    #   acute accent
  175.     'micro'    =>    'µ',    #   micro sign
  176.     'para'    =>    '¶',    #   pilcrow (paragraph sign)
  177.     'middot'    =>    '·',    #   middle dot
  178.     'cedil'    =>    '¸',    #   cedilla
  179.     'sup1'    =>    '¹',    #   superscript one
  180.     'ordm'    =>    'º',    #   ordinal indicator, masculine
  181.     'raquo'    =>    '»',    #   angle quotation mark, right
  182.     'frac14'    =>    '¼',    #   fraction one-quarter
  183.     'frac12'    =>    '½',    #   fraction one-half
  184.     'frac34'    =>    '¾',    #   fraction three-quarters
  185.     'iquest'    =>    '¿',    #   inverted question mark
  186.     'Agrave'    =>    'À',    #   capital A, grave accent
  187.     'Aacute'    =>    'Á',    #   capital A, acute accent
  188.     'Acirc'    =>    'Â',    #   capital A, circumflex accent
  189.     'Atilde'    =>    'Ã',    #   capital A, tilde
  190.     'Auml'    =>    'Ä',    #   capital A, dieresis or umlaut mark
  191.     'Aring'    =>    'Å',    #   capital A, ring
  192.     'AElig'    =>    'Æ',    #   capital AE diphthong (ligature)
  193.     'Ccedil'    =>    'Ç',    #   capital C, cedilla
  194.     'Egrave'    =>    'È',    #   capital E, grave accent
  195.     'Eacute'    =>    'É',    #   capital E, acute accent
  196.     'Ecirc'    =>    'Ê',    #   capital E, circumflex accent
  197.     'Euml'    =>    'Ë',    #   capital E, dieresis or umlaut mark
  198.     'Igrave'    =>    'Ì',    #   capital I, grave accent
  199.     'Iacute'    =>    'Í',    #   capital I, acute accent
  200.     'Icirc'    =>    'Î',    #   capital I, circumflex accent
  201.     'Iuml'    =>    'Ï',    #   capital I, dieresis or umlaut mark
  202.     'ETH'    =>    'Ð',    #   capital Eth, Icelandic
  203.     'Ntilde'    =>    'Ñ',    #   capital N, tilde
  204.     'Ograve'    =>    'Ò',    #   capital O, grave accent
  205.     'Oacute'    =>    'Ó',    #   capital O, acute accent
  206.     'Ocirc'    =>    'Ô',    #   capital O, circumflex accent
  207.     'Otilde'    =>    'Õ',    #   capital O, tilde
  208.     'Ouml'    =>    'Ö',    #   capital O, dieresis or umlaut mark
  209.     'times'    =>    '×',    #   multiply sign
  210.     'Oslash'    =>    'Ø',    #   capital O, slash
  211.     'Ugrave'    =>    'Ù',    #   capital U, grave accent
  212.     'Uacute'    =>    'Ú',    #   capital U, acute accent
  213.     'Ucirc'    =>    'Û',    #   capital U, circumflex accent
  214.     'Uuml'    =>    'Ü',    #   capital U, dieresis or umlaut mark
  215.     'Yacute'    =>    'Ý',    #   capital Y, acute accent
  216.     'THORN'    =>    'Þ',    #   capital Thorn, Icelandic
  217.     'szlig'    =>    'ß',    #   small sharp s, German (sz ligature)
  218.     'agrave'    =>    'à',    #   small a, grave accent
  219.     'aacute'    =>    'á',    #   small a, acute accent
  220.     'acirc'    =>    'â',    #   small a, circumflex accent
  221.     'atilde'    =>    'ã',    #   small a, tilde
  222.     'auml'    =>    'ä',    #   small a, dieresis or umlaut mark
  223.     'aring'    =>    'å',    #   small a, ring
  224.     'aelig'    =>    'æ',    #   small ae diphthong (ligature)
  225.     'ccedil'    =>    'ç',    #   small c, cedilla
  226.     'egrave'    =>    'è',    #   small e, grave accent
  227.     'eacute'    =>    'é',    #   small e, acute accent
  228.     'ecirc'    =>    'ê',    #   small e, circumflex accent
  229.     'euml'    =>    'ë',    #   small e, dieresis or umlaut mark
  230.     'igrave'    =>    'ì',    #   small i, grave accent
  231.     'iacute'    =>    'í',    #   small i, acute accent
  232.     'icirc'    =>    'î',    #   small i, circumflex accent
  233.     'iuml'    =>    'ï',    #   small i, dieresis or umlaut mark
  234.     'eth'    =>    'ð',    #   small eth, Icelandic
  235.     'ntilde'    =>    'ñ',    #   small n, tilde
  236.     'ograve'    =>    'ò',    #   small o, grave accent
  237.     'oacute'    =>    'ó',    #   small o, acute accent
  238.     'ocirc'    =>    'ô',    #   small o, circumflex accent
  239.     'otilde'    =>    'õ',    #   small o, tilde
  240.     'ouml'    =>    'ö',    #   small o, dieresis or umlaut mark
  241.     'divide'    =>    '÷',    #   divide sign
  242.     'oslash'    =>    'ø',    #   small o, slash
  243.     'ugrave'    =>    'ù',    #   small u, grave accent
  244.     'uacute'    =>    'ú',    #   small u, acute accent
  245.     'ucirc'    =>    'û',    #   small u, circumflex accent
  246.     'uuml'    =>    'ü',    #   small u, dieresis or umlaut mark
  247.     'yacute'    =>    'ý',    #   small y, acute accent
  248.     'thorn'    =>    'þ',    #   small thorn, Icelandic
  249.     'yuml'    =>    'ÿ',    #   small y, dieresis or umlaut mark
  250.     'Wcirc'    =>    'Ŵ',    #   capital W, circumflex accent
  251.     'wcirc'    =>    'ŵ',    #   small w, circumflex accent
  252.     'Ycirc'    =>    'Ŷ',    #   capital Y, circumflex accent
  253.     'ycirc'    =>    'ŷ',    #   small y, circumflex accent
  254.  
  255.     'hellip'    =>    '…',    #   ellipsis
  256.     'trade'    =>    '™',    #   trademark, TM
  257.     'permil'    =>    '‰',    #   per thousand (mille)
  258.     'bull'    =>    '•',    #   bullet
  259.     'lsquo'    =>    '‘',    #   quote left
  260.     'rsquo'    =>    '’',    #   quote right
  261.     'lsaquo'    =>    '‹',    #   guille single left
  262.     'rsaquo'    =>    '›',    #   guille single right
  263.     'ldquo'    =>    '“',    #   quote double left
  264.     'rdquo'    =>    '”',    #   quote double right
  265.     'ldquor'    =>    '„',    #   quote double base
  266.     'ndash'    =>    '–',    #   en dash
  267.     'mdash'    =>    '—',    #   em dash
  268.     'minus'    =>    '−',    #   minus sign
  269.     'oelig'    =>    'œ',    #   oe ligature
  270.     'OElig'    =>    'Œ',    #   OE ligature
  271.     'dagger'    =>    '†',    #   dagger
  272.     'Dagger'    =>    '‡',    #   double dagger
  273.     'filig'    =>    'fi',    #   fi ligature
  274.     'fllig'    =>    'fl',    #   fl ligature
  275. );
  276.  
  277. # "It hasn't rained on Mars for a very long time.
  278. #  Several hundred million years of hosepipe bans."
  279.  
  280. ## implementation of appropriate subclass methods ...
  281.  
  282. sub nl2ws {
  283.     foreach( @_ ) { tr/\n\r/  / }
  284.     @_;
  285. }
  286.  
  287. sub space2hard {
  288.     foreach( @_ ) { tr/ -/ ­/; }    # Spaces to hard spaces, - to (of all things) soft
  289.                     # hyphens, as Impression won't break on these.
  290.                     # Duh.
  291.     @_;
  292. }
  293.  
  294. sub downcase_words {
  295. # Downcase all the words. (FAQ section 4)
  296.     foreach( @_ )
  297.     {
  298.     s/ (
  299.       (^\w)        #at the beginning of the line
  300.         |        # or
  301.       (\s\w)    #preceded by whitespace
  302.        )
  303.      /\U$1/xg;
  304.     s/([\w']+)/\u\L$1/g;
  305.     }
  306.     @_;
  307. }
  308.  
  309. # Apparently unnecessary "$_" interpolation allows encoding of read-only scalars...
  310. sub encode ($@) {
  311.     my $sub = shift;
  312.     my @answer;
  313.  
  314.     foreach( @_ )
  315.     {
  316.     if( ref )
  317.     {
  318.         my @copy = @$_;
  319.         my $tail = pop @copy;
  320.         my $head = shift @copy;
  321.         push @answer, [$head, encode( $sub, @copy ), $tail];
  322.     }
  323.     else
  324.     {
  325.         push @answer, &$sub( "$_" );
  326.     }
  327.     }
  328.  
  329.     @answer;
  330. }
  331.  
  332. sub __output {
  333.     my $out_fh = shift;
  334.     foreach( @_ )
  335.     {
  336.     if( ref )
  337.     {
  338.         my @copy = @$_;
  339.         my $tail = pop @copy;
  340.         print $out_fh shift @copy;
  341.         __output( $out_fh, @copy );
  342.         print $out_fh $tail;
  343.     }
  344.     else
  345.     {
  346.         print $out_fh $_;
  347.     }
  348.     }
  349.  
  350. }
  351.  
  352. sub output {
  353.     my $self = shift;
  354.     my $out_fh = $self->{OUTPUT};
  355.  
  356.     my $fill = ($self->{PRAGMAS}->{FILL} eq 'on');
  357.  
  358.     print $out_fh $self->{KEEPNEXT_HACK} if defined $self->{KEEPNEXT_HACK};
  359.     print $out_fh "\t" x ${$self->{INDENT}}[1];
  360.  
  361.     __output( $out_fh, encode( \&ddfencode, @_ ));
  362.  
  363. #    foreach( @_ )
  364. #    {
  365. #     if( ref )
  366. #     {
  367. #         print $out_fh $$_[0] if defined $$_[0];
  368. #         print $out_fh ddfencode "$$_[1]" if defined $$_[1];
  369. #         print $out_fh $$_[2] if defined $$_[2];
  370. #     }
  371. #     else
  372. #     {
  373. #         print $out_fh ddfencode "$_";
  374. #     }
  375. #    }
  376. }
  377.  
  378. sub output_raw {
  379.     my $self = shift;
  380.     my $out_fh = $self->{OUTPUT};
  381.     print $out_fh @_;
  382. }
  383.  
  384. sub error_text {
  385.     my $self  = shift;
  386.  
  387.     warn "@_";
  388.     [$error->StyleWrap(@_)];
  389. }
  390.  
  391. sub error {
  392.     my $self  = shift;
  393.     my $out_fh  = $self->{OUTPUT};
  394.  
  395.     $self->output( [$error->StyleWrap(@_)] );
  396.     warn "@_";
  397. }
  398.  
  399. $tabs_on_item_ruler = 2;
  400.  
  401. sub find_item_ruler ($$) {
  402.     my $self  = shift;
  403.     my $stylename = "Item List $_[0]";
  404.     my $style = $styles{$stylename};
  405.  
  406.     unless( defined $style )
  407.     {
  408.     # Here's the clever bit. Throw together a new ruler on the fly.
  409.     # Magic numbers: default over indent is 4
  410.  
  411.     my $offset = ($_[0] - 4) * 6;
  412.     my $right = $offset + 18;
  413.     my $left = $offset + 24;
  414.     # my $next = $offset + 108;
  415.  
  416.     $style = new Text::DDF::Style $stylename,
  417.       'leftmargin', "${left}pt",
  418.       'rightmargin', '0pt',
  419.       'returnmargin', "${offset}pt",
  420.       'menuitem', 'on',
  421.       'autoparagraph', '';
  422.  
  423.     $style->AddTabs( "r${right}pt", "${left}pt" );
  424.  
  425.     $self->output_raw( $style->Define );
  426.  
  427.     $styles{$stylename} = $style;
  428.     }
  429.  
  430.     return $style;
  431. }
  432.  
  433. sub item {
  434.     my $self  = shift;
  435.     my $item_follows = shift;
  436.     return  unless (defined  $self->{ITEM});
  437.     my $paratag = $self->{ITEM};
  438.     my $prev_indent = $self->{INDENTS}->[$#{$self->{INDEX}} - 1]
  439.               || $self->{DEF_INDENT};
  440.     undef $self->{ITEM};
  441.  
  442.     # Yes, I mean local not my.
  443.     # Want no automatic tabs in ouput in this subroutine
  444.     local ${$self->{INDENT}}[1] = 0;
  445.     # Want previous value restored at end.
  446.  
  447.     # The item ruler is roughly
  448.     # ...<...>.......>
  449.     #
  450.     #     •   Bullet
  451.     #    13   Numbered item
  452.     # Spam   Some technical term.
  453.     #
  454.     # except that perl.pod and perlmodlib.pod currently contain lines of the
  455.     #  form
  456.     # =item * some text
  457.     #
  458.     # perlrun.pod has lines
  459.     # =item 2.
  460.     #
  461.     # perlfaq4.pod has lines
  462.     # =item 2. some text
  463.     #
  464.     # The right tab is for aligning numbers and bullets.
  465.     # The next left tab starts the paragraph
  466.  
  467.     if ($paratag =~ s/^\*\s*//m )
  468.     {
  469.     if( length $paratag )
  470.     {
  471.         #    •   Text
  472.         $paratag =~ s/\n*$//m;
  473.         if( $item_follows )
  474.         {
  475.         $self->output( "\t•\t", $self->interpolate($paratag), "\n" );
  476.         }
  477.         else
  478.         {
  479.         $self->output( [$keepnext->StyleWrap("\t•\t", $self->interpolate($paratag), "\n")], @_ ? "\t\t" : '');
  480.         }
  481.     }
  482.     else
  483.     {
  484.         $self->output( "\t•" );
  485.     }
  486.     }
  487.     elsif ($paratag =~ /^[\d\.]+\s*$/)
  488.     {
  489.     $self->output( "\t", $self->interpolate ($paratag) );
  490.     }
  491.     elsif ($paratag =~ /^[\d\.]\s*/)
  492.     {
  493.     $paratag =~ /^([\d]+)\.?\s*(.*)/;
  494.     $self->output( "\t$1" );
  495.     # @_ is passed in interpolated.
  496.     unshift @_, $self->interpolate ("$2\n") if length $2;
  497.     }
  498.     else
  499.     {
  500.     $paratag =~ s/\n*$//m;
  501.     $paratag =~ s/( +[A-Z][A-Z0-9(), ]*)$//;
  502.     my $arguments = $&;
  503.     my $index = ($self->{PRAGMAS}->{ITEM_INDEX} eq 'on');
  504.  
  505.     # Yes, it's messy.
  506.     # The plan is that all arguments in perlfunc are uppercase, so we should
  507.     #  be able to identify them, and *not* wrap them in the index tag.
  508.  
  509.     $self->output(
  510.       [$itemkeyword->StyleWrap(
  511.         ( $index ? [$itemkeywordindex->StyleWrap( $self->interpolate( $paratag ) )]
  512.              : $self->interpolate( $paratag ) ),
  513.         $self->interpolate($arguments), ($item_follows || @_) ? "\n" : '') ],
  514.       scalar @_ ?  "\t" : $item_follows ? '' : "\n" );
  515.       
  516.     # $item_follows == 1 ensures a full paragraph break after =item Spam
  517.     # with no subsequent paragraph or further =item directives.
  518.     #
  519.     # ie THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR!
  520.     # in perlfunc.pod
  521.     }
  522.  
  523.     return unless @_;
  524.  
  525.     if ($_[0] =~ /^=/) {  # tricked!
  526.     warn "Tricked by $_[0]";
  527.     }
  528.  
  529.     $self->output ("\t",@_);
  530. }
  531.  
  532. ## Overloaded methods
  533. sub begin_input {
  534.     my $self = shift;
  535.     #----------------------------------------------------
  536.     # Subclasses may wish to make use of some of the
  537.     # commented-out code below for initializing pragmas
  538.     #----------------------------------------------------
  539.     $self->{PRAGMAS} = {
  540.     FILL     => 'on',
  541.     STYLE     => 'plain',
  542.     INDENT     => [0, 0, $empty],
  543.     ITEM_INDEX    => 'off',
  544.     KEEPNEXT_HACK    => undef
  545.     };
  546.     ## Initialize all PREVIOUS_XXX pragma values
  547.     my ($name, $value);
  548.     for (($name, $value) = each %{$self->{PRAGMAS}}) {
  549.     $self->{PRAGMAS}->{"PREVIOUS_${name}"} = $value;
  550.     }
  551.     #----------------------------------------------------
  552.  
  553.     # Indent no., Tabs to indent by, style
  554.     $self->{DEF_INDENT} = [4, 0, $empty];
  555.     $self->{INDENTS}    = [];
  556.     $self->{INDENT}    = $self->{DEF_INDENT};
  557.  
  558.     $self->{DONE_TITLE} = 0;
  559.  
  560.     # Define the styles
  561.  
  562.     foreach (values %styles)
  563.     {
  564.     $self->output_raw( $_->Define );
  565.     }
  566.  
  567.     return;
  568. }
  569.  
  570. =head2 end_input()
  571.  
  572. This method is invoked by B<parse_from_filehandle()> immediately I<after>
  573. processing input from a filehandle. The base class implementation does
  574. nothing but subclasses may override it to perform any per-file
  575. cleanup actions.
  576.  
  577. =cut
  578.  
  579. sub end_input {
  580.     my $self = shift;
  581.     $self->item()  if (defined $self->{ITEM});
  582. }
  583.  
  584.  
  585. =head2 pragma($pragma_name, $pragma_value)
  586.  
  587. This method is invoked for each pragma encountered inside an C<=pod>
  588. paragraph (see the description of the B<parse_pragmas()> method). The
  589. pragma name is passed in C<$pragma_name> (which should always be
  590. lowercase) and the corresponding value is C<$pragma_value>.
  591.  
  592. The base class implementation of this method does nothing.  Derived
  593. class implementations of this method should be able to recognize at
  594. least the following pragmas and take any necessary actions when they are
  595. encountered:
  596.  
  597. =over 4
  598.  
  599. =item B<fill=value>
  600.  
  601. The argument I<value> should be one of C<on>, C<off>, or C<previous>.
  602. Specifies that "filling-mode" should set to 1, 0, or its previous value
  603. (respectively). If I<value> is omitted then the default is C<on>.
  604. Derived classes may use this to decide whether or not to perform any
  605. filling (wrapping) of subsequent text.
  606.  
  607. =item B<style=value>
  608.  
  609. The argument I<value> should be one of C<bold>, C<italic>, C<code>,
  610. C<plain>, or C<previous>. Specifies that the current default paragraph
  611. font should be set to C<bold>, C<italic>, C<code>, the empty string C<>,
  612. or its previous value (respectively).  If I<value> is omitted then the
  613. default is C<plain>.  Derived classes may use this to determine the
  614. default font style to use for subsequent text.
  615.  
  616. =item B<indent=value>
  617.  
  618. The argument I<value> should be an integer value (with an optional
  619. sign).  Specifies that the current indentation level should be reset to
  620. the given value. If a plus (minus) sign precedes the number then the
  621. indentation level should be incremented (decremented) by the given
  622. number. If only a plus or minus sign is given (without a number) then
  623. the current indentation level is incremented or decremented by some
  624. default amount (to be determined by subclasses).
  625.  
  626. =back
  627.  
  628. The value returned will be 1 if the pragma name was recognized and 0 if
  629. it wasnt (in which case the pragma was ignored).
  630.  
  631. Derived classes should override this method if they wish to implement
  632. any pragmas. The base class implementation of this method does nothing
  633. but it does contain some commented-out code which subclasses may want
  634. to make use of when implementing pragmas.
  635.  
  636. =cut
  637.  
  638. sub pragma {
  639.     my $self  = shift;
  640.     ## convert remaining args to lowercase
  641.     my $name  = lc shift;
  642.     my $value = lc shift;
  643.     my $rc = 1;
  644.     local($_);
  645.     #----------------------------------------------------
  646.     # Subclasses may wish to make use of some of the
  647.     # commented-out code below for processing pragmas
  648.     #----------------------------------------------------
  649.     my ($abbrev, %abbrev_table);
  650.     if ($name eq 'fill' || $name eq 'item_index') {
  651.     my $NAME = uc $name;
  652.     %abbrev_table = ('on' => 'on',
  653.              'of' => 'off',
  654.              'p'  => 'previous');
  655.     $value = 'on' unless ((defined $value) && ($value ne ''));
  656.     return  $rc  unless ($value =~ /^(on|of|p)/io);
  657.     $abbrev = $1;
  658.     $value = $abbrev_table{$abbrev};
  659.     if ($value eq 'previous') {
  660.         $self->{PRAGMAS}->{$NAME} = $self->{PRAGMAS}->{"PREVIOUS_$NAME"};
  661.     }
  662.     else {
  663.         $self->{PRAGMAS}->{"PREVIOUS_$NAME"} = $self->{PRAGMAS}->{$NAME};
  664.         $self->{PRAGMAS}->{$NAME} = $value;
  665.     }
  666.     }
  667.     elsif ($name eq 'style') {
  668.     %abbrev_table = ('b'  => 'bold',
  669.              'i'  => 'italic',
  670.              'c'  => 'code',
  671.              'pl' => 'plain',
  672.              'pr' => 'previous');
  673.     $value = 'plain' unless ((defined $value) && ($value ne ''));
  674.     return  $rc  unless ($value =~ /^(b|i|c|pl|pr)/io);
  675.     $abbrev = $1;
  676.     $value = $abbrev_table{$abbrev};
  677.     if ($value eq 'previous') {
  678.         $self->{PRAGMAS}->{STYLE} = $self->{PRAGMAS}->{PREVIOUS_STYLE};
  679.     }
  680.     else {
  681.         $self->{PRAGMAS}->{PREVIOUS_STYLE} = $self->{PRAGMAS}->{STYLE};
  682.         $self->{PRAGMAS}->{STYLE} = $value;
  683.     }
  684.     }
  685.     elsif ($name eq 'indent') {
  686.     return $rc unless ((defined $value) && ($value =~ /^([-+]?)(\d*)$/o));
  687.     my ($sign, $number) = ($1, $2);
  688.     $value .= "4"  unless ((defined $number) && ($number ne ''));
  689.     $self->{PRAGMAS}->{PREVIOUS_INDENT} = $self->{PRAGMAS}->{INDENT};
  690.     if ($sign) {
  691.         ${$self->{PRAGMAS}->{INDENT}}[0] += (0 + $value);
  692.     }
  693.     else {
  694.         ${$self->{PRAGMAS}->{INDENT}}[0] = $value;
  695.     }
  696.     }
  697.     else {
  698.     $rc = 0;
  699.     }
  700.     #----------------------------------------------------
  701.     return $rc;
  702. }
  703.  
  704.  
  705. sub command {
  706.     my $self = shift;
  707.     my $cmd  = shift;
  708.     my $text = shift;
  709.     my $sep  = shift;
  710.     $cmd  = ''  unless (defined $cmd);
  711.     $text = ''  unless (defined $text);
  712.     $sep  = ' ' unless (defined $sep);
  713.     
  714.     nl2ws( $text );
  715.     $text =~ s/ *$/\n/;
  716.  
  717.  
  718.     # You're going to have to turn on styles such as 'item' here, and leave
  719.     # them on until you next come in. (or at close of play)
  720.     # Textblock should do pragmas.
  721.  
  722.     # Basically this stops keepnext for the following line, and two tabs.
  723.     $self->item( $cmd eq 'item' || $cmd eq 'back' )  if (defined $self->{ITEM});
  724.  
  725.     if( 1 == $self->{DONE_TITLE} )
  726.     {
  727.     $self->output_raw( $title->StyleOff );
  728.     $self->{DONE_TITLE} = 2;
  729.     }
  730.  
  731.     if( $cmd =~ /^head\d+/ )
  732.     {
  733.     # Headings.
  734.  
  735.     if( $self->{DONE_TITLE} == 0 && $text eq "NAME\n" )
  736.     {
  737.         # it's the magic word 'NAME'
  738.         $self->{DONE_TITLE} = 1;
  739.  
  740.         $self->output_raw( $title->StyleOn );
  741.     }
  742.     else
  743.     {
  744.         no strict 'refs';
  745.         # Hope there's a style defined to match this heading level...
  746.         $self->output( [${$cmd}->StyleWrap(
  747.           # Downcase the string if it is *all* shouty
  748.           # Special case for known acronyms.
  749.           ($text =~ /[a-z]/ || defined $cheats{$text} ) ? $self->interpolate($text) :
  750.         encode( \&downcase_words, $self->interpolate($text) )
  751.           )] );
  752.     }
  753.     }
  754.     elsif ($cmd eq 'over') {
  755.     push(@{$self->{INDENTS}}, $self->{INDENT});
  756.  
  757.     my $previous = ${$self->{INDENT}}[0];
  758.  
  759.     local ($^W) = 0;
  760.  
  761.     # Copy it
  762.     $self->{INDENT} = [
  763.         $previous + ($text + 0) || ${$self->{DEF_INDENT}}[0],
  764.  
  765.         $tabs_on_item_ruler, # Because this is how the ruler works.
  766.  
  767.         $self->find_item_ruler($previous) ];
  768.  
  769.     $self->output_raw( ${$self->{INDENT}}[2] -> StyleOn() );
  770.     }
  771.     elsif ($cmd eq 'back') {
  772.     $self->item() if (defined $self->{ITEM});
  773.     $self->output_raw( ${$self->{INDENT}}[2] -> StyleOff() );
  774.  
  775.  
  776.     $self->{INDENT} = pop(@{$self->{INDENTS}});
  777.     unless (defined $self->{INDENT}) {
  778.         $self->error( "Unmatched =back\n" );
  779.         $self->{INDENT} = $self->{DEF_INDENT};
  780.     }
  781.  
  782.     }
  783.     elsif ($cmd eq 'item') {
  784.     $self->{ITEM} = $text;
  785.     }
  786.     else {
  787.     $self->error( "Unrecognized directive: $cmd" );
  788.     }
  789.  
  790.     $self->{DONE_TITLE} = 2 unless $self->{DONE_TITLE} == 1;
  791. }
  792.  
  793. sub verbatim {
  794.     my $self = shift;
  795.     my $text = shift;
  796.     $self->item()  if (defined $self->{ITEM});
  797.     my $out_fh = $self->{OUTPUT};
  798.     my @lines = expand split (/\n/, $text);    # Text::Tabs::expand
  799.  
  800.     my $spaces_at_start;
  801.     my $spaces_this_line;
  802.  
  803.     # Strip off spaces common to the start of all lines
  804.     for( @lines )
  805.     {
  806.     ($spaces_this_line) = /^( *)/;
  807.  
  808.     if( defined $spaces_at_start )
  809.     {
  810.         $spaces_at_start = length $spaces_this_line
  811.         if $spaces_at_start > length $spaces_this_line;
  812.     }
  813.     else
  814.     {
  815.         $spaces_at_start = length $spaces_this_line;
  816.     }
  817.     }
  818.  
  819.     for( @lines )
  820.     {
  821.     $_ = substr $_, $spaces_at_start;
  822.     }
  823.  
  824.     ;
  825.  
  826.     # Last line needs space after paragraph so treat it specially
  827.  
  828.     local ${$self->{INDENT}}[1] = 0;
  829.  
  830.     if (@lines)
  831.     {
  832.     $self->output( [$keepregion->StyleWrap(
  833.       [$verbatim->StyleWrap( join ("\n", @lines) . "\n" )] )] )
  834.     }
  835.  
  836.     $self->output( [$verbatimend->StyleWrap("\n" )] );
  837. }
  838.  
  839. =head2 textblock($text)
  840.  
  841. This method may be overridden by subclasses to take the appropriate
  842. action when a normal block of pod text is encountered (although the base
  843. class method will usually do what you want). It is passed the text block
  844. C<$text> as a parameter.
  845.  
  846. In order to process interior sequences, subclasses implementations of
  847. this method will probably want invoke the B<interpolate()> method,
  848. passing it the text block C<$text> as a parameter and then perform any
  849. desired processing upon the returned result.
  850.  
  851. The base class implementation of this method simply prints the text block
  852. as it occurred in the input stream).
  853.  
  854. =cut
  855.  
  856. sub textblock {
  857.     my $self  = shift;
  858.     my $text  = shift;
  859.     my @text;
  860.     $text =~ tr/\n\r/  /;
  861.     $text =~ s/ +$//;
  862.  
  863.     my $keepnext_hack = $self->{KEEPNEXT_HACK};
  864.  
  865.     my $colon = $text =~ /:$/;
  866.  
  867.     # Convert -- to em dashes if we are in the title
  868.     $text =~ s/--/—/ if ($self->{DONE_TITLE} == 1);
  869.  
  870.     @text = $self->interpolate($text);
  871.  
  872.     if( $colon )
  873.     {
  874.     $self->{KEEPNEXT_HACK} = $keepnext->StyleOn();
  875.     # Last non whitespace character is ':' - probably something like:
  876.  
  877.     # that
  878.     }
  879.     
  880.     push @text, "\n";
  881.  
  882.     if (defined $self->{ITEM}) {
  883.     $self->item(0, @text);
  884.     }
  885.     else {
  886.     $self->output(@text)
  887.     }
  888.     
  889.     if( $colon )
  890.     {
  891.     $self->output_raw( $keepnext->StyleOff() );
  892.     $self->{KEEPNEXT_HACK} = $keepnext_hack;
  893.     }
  894. }
  895.  
  896. =head2 interior_sequence($seq_cmd, $seq_arg)
  897.  
  898. This method should be overridden by subclasses to take the appropriate
  899. action when an interior sequence is encountered. An interior sequence is
  900. an embedded command within a block of text which appears as a command
  901. name (usually a single uppercase character) followed immediately by
  902. a string of text which is enclosed in angle brackets. This method is
  903. passed the sequence command C<$seq_cmd> and the corresponding text
  904. $seq_arg and is invoked by the B<interpolate()> method for each
  905. interior sequence that occurs in the string that it is passed.
  906. It should return the desired text string to be used in place of
  907. the interior sequence.
  908.  
  909. Subclass implementationss of this method may wish to examine the
  910. the array referenced by C<$self-E<gt>{SEQUENCES}> which is a
  911. stack of all the interior sequences that are currently being
  912. processed (they may be nested). The current interior sequence
  913. (the one given by C<$seq_cmdE<lt>$seq_argE<gt>>) should always
  914. be at the top of this stack.
  915.  
  916. The base class implementation of the B<interior_sequence()> method simply
  917. returns the raw text of the of the interior sequence (as it occurred in
  918. the input) to the output filehandle.
  919.  
  920.  
  921.     I<text>    italicize text, used for emphasis or variables
  922.     B<text>    embolden text, used for switches and programs
  923.     S<text>    text contains non-breaking spaces
  924.     C<code>    literal code
  925.     L<name>    A link (cross reference) to name
  926.             L<name>        manual page
  927.             L<name/ident>    item in manual page
  928.             L<name/"sec">    section in other manual page
  929.             L<"sec">        section in this manual page
  930.                     (the quotes are optional)
  931.             L</"sec">        ditto
  932.     F<file>    Used for filenames
  933.     X<index>    An index entry
  934.     Z<>        A zero-width character
  935.     E<escape>    A named character (very similar to HTML escapes)
  936.             E<lt>        A literal <
  937.             E<gt>        A literal >
  938.             (these are optional except in other interior
  939.              sequences and when preceded by a capital letter)
  940.             E<n>        Character number n (probably in ASCII)
  941.             E<html>        Some non-numeric HTML entity, such
  942.                     as E<Agrave>
  943.  
  944. =cut
  945.  
  946. sub interior_sequence {
  947.     my $self = shift;
  948.     my $seq_cmd = shift;
  949.  
  950.     if ($seq_cmd eq 'I')
  951.     {
  952.       return [$italic->StyleWrap( @_ )];
  953.     }
  954.     elsif ($seq_cmd eq 'B')
  955.     {
  956.       return [$bold->StyleWrap( @_ )];
  957.     }
  958.     elsif ($seq_cmd eq 'S')
  959.     {
  960.       return encode( \&space2hard, @_);
  961.     }
  962.     elsif ($seq_cmd eq 'C')
  963.     {
  964.       return [$code->StyleWrap( @_ )];
  965.     }
  966.     elsif ($seq_cmd eq 'F')
  967.     {
  968.       return [$file->StyleWrap( @_ )];
  969.     }
  970.     elsif ($seq_cmd eq 'X')
  971.     {
  972.       return [$index->StyleWrap( @_ )];
  973.     }
  974.     elsif ($seq_cmd eq 'Z')
  975.     {
  976.       return '';
  977.     }
  978.     elsif ($seq_cmd eq 'L' || $seq_cmd eq 'E')
  979.     {
  980.     # Must be single scalar.
  981.     if( @_ != 1 || ref $_[0] )
  982.     {
  983.         return $self->error_text( "Interior sequence $seq_cmd<> must be simple scalar, not ", @_ )
  984.     }
  985.  
  986.     if ($seq_cmd eq 'L')
  987.     {
  988.         # L<name>        manual page
  989.         # L<name/ident>    item in manual page
  990.         # L<name/"sec">    section in other manual page
  991.         # L<"sec">        section in this manual page
  992.         #            (the quotes are optional)
  993.         # L</"sec">        ditto
  994.  
  995.         # How do I tell name from section when there are no quotes?
  996.  
  997.         local($_) = $_[0];
  998.  
  999.         s/\s+/ /g;
  1000.         my ($manpage, $sec, @ref) = ($_, '');
  1001.         if (/^\s*"\s*(.*)\s*"\s*$/o) {
  1002.         ($manpage, $sec) = ('', "\"$1\"");
  1003.         }
  1004.         elsif (m|\s*/\s*|o) {
  1005.         ($manpage, $sec) = ($`, $');
  1006.         }
  1007.  
  1008.         if ($sec eq '') {
  1009.         @ref = ('the chapter ', [$bold->StyleWrap( $manpage )])
  1010.  
  1011.         if ($manpage ne '');
  1012.         }
  1013.         elsif ($sec =~ /^\s*"\s*(.*)\s*"\s*$/o) {
  1014.         @ref = "the section on \"$1\"";
  1015.         push @ref, (' in the chapter ', [$bold->StyleWrap( $manpage )])
  1016.         if ($manpage ne '');
  1017.         }
  1018.         else {
  1019.          @ref = "the \"$sec\" entry";
  1020.          push @ref, ($manpage eq '') ? " in this chapter"
  1021.                   : (' in the chapter ', [$bold->StyleWrap( $manpage )]);
  1022.         }
  1023.         return @ref;
  1024.     }
  1025.     else
  1026.     {
  1027.         return chr $_[0] if $_[0]=~/^\d+$/;
  1028.         return $HTML_Escapes{$_[0]} if defined $HTML_Escapes{$_[0]};
  1029.         warn "Unknown escape: E<$_[0]>";
  1030.         # Drop through to the error generator
  1031.     }
  1032.     }
  1033.  
  1034.     return $self->error_text( "${seq_cmd}<",@_,'>' );
  1035. }
  1036.  
  1037. =head2 interpolate($text, $end_re)
  1038.  
  1039. This method will translate all text (including any embedded interior
  1040. sequences) in the given text string C<$text> and return the
  1041. interpolated result.  If a second argument is given, then it is taken to
  1042. be a regular expression that indicates when to quit interpolating the
  1043. string.  Upon return, the C<$text> parameter will have been modified to
  1044. contain only the un-processed portion of the given string (which will
  1045. I<not> contain any text matched by C<$end_re>).
  1046.  
  1047. This method should probably I<not> be overridden by subclasses.
  1048. It should be noted that this method invokes itself recursively
  1049. to handle any nested interior sequences.
  1050.  
  1051. =cut
  1052.  
  1053. sub interpolate {
  1054.     my $self = shift;
  1055.     my ($text, $end_re) = @_;
  1056.     $text   = ''   unless (defined $text);
  1057.     $end_re = '$'  unless ((defined $end_re) && ($end_re ne ''));
  1058.     local($_)  = $text;
  1059.     my @result;
  1060.     my ($seq_cmd, $end, @seq_arg) = ('', undef);
  1061.     while (($_ ne '') && /([A-Z])<|($end_re)/) {
  1062.     push @result, $`;  ## Append text before the match to the result
  1063.     $_ = $';        ## Only text after the match remains to be processed
  1064.     ## See if we matched an interior sequence or an end-expression
  1065.     ($seq_cmd, $end) = ($1, $2);
  1066.     last if (defined $end);  ## Saw the end - quit loop here
  1067.     ## At this point we have found an interior sequence,
  1068.     ## we need to obtain its argument
  1069.     push(@{$self->{SEQUENCES}}, $seq_cmd);
  1070.     @seq_arg = $self->interpolate($_, '>');
  1071.     ## Now process the interior sequence
  1072.     push @result, $self->interior_sequence($seq_cmd, @seq_arg);
  1073.     pop(@{$self->{SEQUENCES}});
  1074.     }
  1075.     ## Handle whatever is left if we didnt match the ending regexp
  1076.     unless ((defined $end) && ($end_re ne '$')) {
  1077.     push @result, $_;
  1078.     $_ = '';
  1079.     }
  1080.     ## Modify the input parameter to consume the text that was
  1081.     ## processed so far.
  1082.     $_[0] = $_;
  1083.     ## Return the processed-text
  1084.     return  @result;
  1085. }
  1086.