Grutatxt.pm

   1 #####################################################################
   2 #
   3 #   Grutatxt - A text to HTML (and other things) converter
   4 #
   5 #   Copyright (C) 2000/2003 Angel Ortega <angel@triptico.com>
   6 #
   7 #   This program is free software; you can redistribute it and/or
   8 #   modify it under the terms of the GNU General Public License
   9 #   as published by the Free Software Foundation; either version 2
  10 #   of the License, or (at your option) any later version.
  11 #
  12 #   This program is distributed in the hope that it will be useful,
  13 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 #   GNU General Public License for more details.
  16 #
  17 #   You should have received a copy of the GNU General Public License
  18 #   along with this program; if not, write to the Free Software
  19 #   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
  20 #
  21 #   http://www.triptico.com
  22 #
  23 #####################################################################
  24
  25 package Grutatxt;
  26
  27 use locale;
  28
  29 $VERSION = '2.0.5';
  30
  31 =pod
  32
  33 =head1 NAME
  34
  35 Grutatxt - Text to HTML (and other formats) converter
  36
  37 =head1 SYNOPSIS
  38
  39  use Grutatxt;
  40
  41  # create a new Grutatxt converter object
  42  $grutatxt=new Grutatxt();
  43
  44  # process a Grutatxt format string
  45  @output=$grutatxt->process($text);
  46
  47  # idem for a file
  48  @output2=$grutatxt->process_file($file);
  49
  50 =head1 DESCRIPTION
  51
  52 Grutatxt is a module to process text documents in
  53 a special markup format (also called Grutatxt), very
  54 similar to plain ASCII text. These documents can be
  55 converted to HTML or troff.
  56
  57 The markup is designed to be fairly intuitive and
  58 straightforward and can include headings, bold and italic
  59 text effects, bulleted, numbered and definition lists, URLs,
  60 function and variable names, preformatted text, horizontal
  61 separators and tables. Special marks can be inserted in the
  62 text and a heading-based structural index can be obtained
  63 from it.
  64
  65 A comprehensive description of the markup is defined in
  66 the README file, included with the Grutatxt package (it is
  67 written in Grutatxt format itself, so it can be converted
  68 using the I<grutatxt> tool to any of the supported formats).
  69 The latest version (and more information) can be retrieved
  70 from the Grutatxt home page at:
  71
  72  http://www.triptico.com/software/grutatxt.html
  73
  74 =head1 FUNCTIONS AND METHODS
  75
  76 =head2 B<new>
  77
  78  $grutatxt=new Grutatxt([ "mode"  => $mode, ]
  79                         [ "title" => \$title, ]
  80                         [ "marks" => \@marks, ]
  81                         [ "index" => \@index, ]
  82                         [ "abstract" => \$abstract, ]
  83                         [ "strip-parens" => $bool, ]
  84                         [ "strip-dollars" => $bool, ]
  85                         [ %driver_specific_arguments ] );
  86
  87 Creates a new Grutatxt object instance. All parameters are
  88 optional.
  89
  90 =over 4
  91
  92 =item I<mode>
  93
  94 Output format. Can be HTML or troff. HTML is used if not specified.
  95
  96 =item I<title>
  97
  98 If I<title> is specified as a reference to scalar, the first
  99 level 1 heading found in the text is stored inside it.
 100
 101 =item I<marks>
 102
 103 Marks in the Grutatxt markup are created by inserting the
 104 string <-> alone in a line. If I<marks> is specified as a
 105 reference to array, it will be filled with the subscripts
 106 (relative to the output array) of the lines where the marks
 107 are found in the text.
 108
 109 =item I<index>
 110
 111 If I<index> is specified as a reference to array, it will
 112 be filled with strings in the format
 113
 114  level,heading
 115
 116 This information can be used to build a table of contents
 117 of the processed text.
 118
 119 =item I<strip-parens>
 120
 121 Function names in the Grutatxt markup are strings of
 122 alphanumeric characters immediately followed by a pair
 123 of open and close parentheses. If this boolean value is
 124 set, function names found in the processed text will have
 125 their parentheses deleted.
 126
 127 =item I<strip-dollars>
 128
 129 Variable names in the Grutatxt markup are strings of
 130 alphanumeric characters preceded by a dollar sign.
 131 If this boolean value is set, variable names found in
 132 the processed text will have the dollar sign deleted.
 133
 134 =item I<abstract>
 135
 136 The I<abstract> of a Grutatxt document is the fragment of text
 137 from the beginning of the document to the end of the first
 138 paragraph after the title. If I<abstract> is specified as a
 139 reference to scalar, it will contain (after each call to the
 140 B<process()> method) the subscript of the element of the output
 141 array that marks the end of the subject.
 142
 143 =back
 144
 145 =cut
 146
 147 sub new
 148 {
 149         my ($class,%args) = @_;
 150         my ($gh);
 151
 152         $args{'mode'} ||= 'HTML';
 153
 154         $class .= "::" . $args{'mode'};
 155
 156         $gh = new $class(%args);
 157
 158         return($gh);
 159 }
 160
 161
 162 =head2 B<process>
 163
 164  @output=$grutatxt->process($text);
 165
 166 Processes a text in Grutatxt format. The result is returned
 167 as an array of lines.
 168
 169 =cut
 170
 171 sub process
 172 {
 173         my ($gh,$content) = @_;
 174         my ($p);
 175
 176         # clean output
 177         @{$gh->{'o'}} = ();
 178
 179         # clean title and paragraph numbers
 180         $gh->{'-title'} = "";
 181         $gh->{'-p'} = 0;
 182
 183         # clean marks
 184         @{$gh->{'marks'}} = () if ref($gh->{'marks'});
 185
 186         # clean index
 187         @{$gh->{'index'}} = () if ref($gh->{'index'});
 188
 189         # reset abstract line
 190         ${$gh->{'abstract'}} = 0 if ref($gh->{'abstract'});
 191
 192         # insert prefix
 193         $gh->_prefix();
 194
 195         $gh->{'-mode'} = undef;
 196
 197         foreach my $l (split(/\n/,$content))
 198         {
 199                 # inline data (passthrough)
 200                 if($l =~ /^<<$/ .. $l =~ /^>>$/)
 201                 {
 202                         $gh->_inline($l);
 203                         next;
 204                 }
 205
 206                 # marks
 207                 if($l =~ /^\s*<\->\s*$/)
 208                 {
 209                         push(@{$gh->{'marks'}},scalar(@{$gh->{'o'}}))
 210                                 if ref($gh->{'marks'});
 211
 212                         next;
 213                 }
 214
 215                 # escape possibly dangerous characters
 216                 $l = $gh->_escape($l);
 217
 218                 # empty lines
 219                 $l =~ s/^\r$//ge;
 220                 if($l =~ s/^$/$gh->_empty_line()/ge)
 221                 {
 222                         # mark the abstract end
 223                         if($gh->{'-title'})
 224                         {
 225                                 $gh->{'-p'}++;
 226
 227                                 # mark abstract if it's the
 228                                 # second paragraph from the title
 229                                 ${$gh->{'abstract'}} = scalar(@{$gh->{'o'}})-1
 230                                         if $gh->{'-p'} == 2;
 231                         }
 232                 }
 233
 234                 if($gh->{'-process-urls'})
 235                 {
 236                         # URLs followed by a parenthesized phrase
 237                         $l =~ s/(https?:\/\/\S+)\s+\(([^\)]+)\)/$gh->_url($1,$2)/ge;
 238                         $l =~ s/(ftps?:\/\/\S+)\s+\(([^\)]+)\)/$gh->_url($1,$2)/ge;
 239                         $l =~ s/(file:\/?\S+)\s+\(([^\)]+)\)/$gh->_url($1,$2)/ge;
 240
 241                         # URLs without phrase
 242                         $l =~ s/([^=][^\"])(https?:\/\/\S+)/$1.$gh->_url($2)/ge;
 243                         $l =~ s/([^=][^\"])(ftps?:\/\/\S+)/$1.$gh->_url($2)/ge;
 244                         $l =~ s/([^=][^\"])(file:\/?\S+)/$1.$gh->_url($2)/ge;
 245                         $l =~ s/^(https?:\/\/\S+)/$gh->_url($1)/ge;
 246                         $l =~ s/^(ftps?:\/\/\S+)/$gh->_url($1)/ge;
 247                         $l =~ s/^(file:\/?\S+)/$gh->_url($1)/ge;
 248                 }
 249
 250                 # change '''text''' and *text* into strong emphasis
 251                 $l =~ s/\'\'\'([^\'][^\'][^\']*)\'\'\'/$gh->_strong($1)/ge;
 252                 $l =~ s/\*(\S[^\*]+\S)\*/$gh->_strong($1)/ge;
 253                 $l =~ s/\*(\S+)\*/$gh->_strong($1)/ge;
 254
 255                 # change ''text'' and _text_ into emphasis
 256                 $l =~ s/\'\'([^\'][^\']*)\'\'/$gh->_em($1)/ge;
 257                 $l =~ s/\b_(\S[^_]*\S)_\b/$gh->_em($1)/ge;
 258                 $l =~ s/\b_(\S+)_\b/$gh->_em($1)/ge;
 259
 260                 # enclose function names
 261                 if($gh->{'strip-parens'})
 262                 {
 263                         $l =~ s/(\w+)\(\)/$gh->_funcname($1)/ge;
 264                 }
 265                 else
 266                 {
 267                         $l =~ s/(\w+)\(\)/$gh->_funcname($1."()")/ge;
 268                 }
 269
 270                 # enclose variable names
 271                 if($gh->{'strip-dollars'})
 272                 {
 273                         $l =~ s/\$([\w_\.]+)/$gh->_varname($1)/ge;
 274                 }
 275                 else
 276                 {
 277                         $l =~ s/(\$[\w_\.]+)/$gh->_varname($1)/ge;
 278                 }
 279
 280                 #
 281                 # main switch
 282                 #
 283
 284                 # definition list
 285                 if($l =~ s/^\s\*\s+([\w\s\-\(\)]+)\:\s+/$gh->_dl($1)/e)
 286                 {
 287                 }
 288
 289                 # unsorted list
 290                 elsif($gh->{'-mode'} ne "pre" and
 291                      ($l =~ s/^(\s+)\*\s+/$gh->_unsorted_list($1)/e or
 292                       $l =~ s/^(\s+)\-\s+/$gh->_unsorted_list($1)/e))
 293                 {
 294                 }
 295
 296                 # sorted list
 297                 elsif($gh->{'-mode'} ne "pre" and
 298                      ($l =~ s/^(\s+)\#\s+/$gh->_ordered_list($1)/e or
 299                       $l =~ s/^(\s+)1\s+/$gh->_ordered_list($1)/e))
 300                 {
 301                 }
 302
 303                 # quoted block
 304                 elsif($l =~ s/^\s\"/$gh->_blockquote()/e)
 305                 {
 306                 }
 307
 308                 # table rows
 309                 elsif($l =~ s/^\s*\|(.*)\|\s*$/$gh->_table_row($1)/e)
 310                 {
 311                 }
 312
 313                 # table heading / end of row
 314                 elsif($l =~ s/^\s*(\+[-\+\|]+\+)\s*$/$gh->_table($1)/e)
 315                 {
 316                 }
 317
 318                 # preformatted text
 319                 elsif($l =~ s/^(\s.*)$/$gh->_pre($1)/e)
 320                 {
 321                 }
 322
 323                 # anything else
 324                 else
 325                 {
 326                         # back to normal mode
 327                         $gh->_new_mode(undef);
 328                 }
 329
 330                 # 1 level heading
 331                 $l =~ s/^(=+)\s*$/$gh->_process_heading(1,$1)/e;
 332
 333                 # 2 level heading
 334                 $l =~ s/^(-+)\s*$/$gh->_process_heading(2,$1)/e;
 335
 336                 # 3 level heading
 337                 $l =~ s/^(~+)\s*$/$gh->_process_heading(3,$1)/e;
 338
 339                 # change ------ into hr
 340                 $l =~ s/^----*$/$gh->_hr()/e;
 341
 342                 # push finally
 343                 $gh->_push($l) if $l;
 344         }
 345
 346         # flush
 347         $gh->_new_mode(undef);
 348
 349         # postfix
 350         $gh->_postfix();
 351
 352         # set title
 353         ${$gh->{'title'}} = $gh->{'-title'} if ref($gh->{'title'});
 354
 355         # set abstract, if not set
 356         ${$gh->{'abstract'}} = scalar(@{$gh->{'o'}})
 357                 if ref($gh->{'abstract'}) and not ${$gh->{'abstract'}};
 358
 359         return(@{$gh->{'o'}});
 360 }
 361
 362
 363 =head2 B<process_file>
 364
 365  @output=$grutatxt->process_file($filename);
 366
 367 Processes a file in Grutatxt format.
 368
 369 =cut
 370
 371 sub process_file
 372 {
 373         my ($gh,$file) = @_;
 374
 375         open F, $file or return(undef);
 376
 377         my ($content) = join('',<F>);
 378         close F;
 379
 380         return($gh->process($content));
 381 }
 382
 383
 384 sub _push
 385 {
 386         my ($gh,$l) = @_;
 387
 388         push(@{$gh->{'o'}},$l);
 389 }
 390
 391
 392 sub _process_heading
 393 {
 394         my ($gh,$level,$hd) = @_;
 395         my ($l);
 396
 397         $l = pop(@{$gh->{'o'}});
 398
 399         if($l eq $gh->_empty_line())
 400         {
 401                 $gh->_push($l);
 402                 return($hd);
 403         }
 404
 405         # store title
 406         $gh->{'-title'} = $l if $level == 1 and not $gh->{'-title'};
 407
 408         # store index
 409         if(ref($gh->{'index'}))
 410         {
 411                 push(@{$gh->{'index'}},"$level,$l");
 412         }
 413
 414         return($gh->_heading($level,$l));
 415 }
 416
 417
 418 sub _calc_col_span
 419 {
 420         my ($gh,$l) = @_;
 421         my (@spans);
 422
 423         # strip first + and all -
 424         $l =~ s/^\+//;
 425         $l =~ s/-//g;
 426
 427         my ($t) = 1; @spans = ();
 428         for(my $n = 0;$n < length($l);$n++)
 429         {
 430                 if(substr($l,$n,1) eq '+')
 431                 {
 432                         push(@spans,$t);
 433                         $t = 1;
 434                 }
 435                 else
 436                 {
 437                         # it's a colspan mark:
 438                         # increment
 439                         $t++;
 440                 }
 441         }
 442
 443         return(@spans);
 444 }
 445
 446
 447 sub _table_row
 448 {
 449         my ($gh,$str) = @_;
 450
 451         my @s = split(/\|/,$str);
 452
 453         for(my $n = 0;$n < scalar(@s);$n++)
 454         {
 455                 ${$gh->{'-table'}}[$n] .= ' ' . $s[$n];
 456         }
 457
 458         return("");
 459 }
 460
 461
 462 sub _pre
 463 {
 464         my ($gh,$l) = @_;
 465
 466         # if any other mode is active, add to it
 467         if($gh->{'-mode'} and $gh->{'-mode'} ne "pre")
 468         {
 469                 $l =~ s/^\s+//;
 470
 471                 my ($a) = pop(@{$gh->{'o'}})." ".$l;
 472                 $gh->_push($a);
 473                 $l = "";
 474         }
 475         else
 476         {
 477                 $gh->_new_mode("pre");
 478         }
 479
 480         return($l);
 481 }
 482
 483
 484 sub _multilevel_list
 485 {
 486         my ($gh, $str, $ind) = @_;
 487         my (@l,$level);
 488
 489         @l = @{$gh->{$str}};
 490         $ind = length($ind);
 491         $level = 0;
 492
 493         if($l[-1] < $ind)
 494         {
 495                 # if last level is less indented, increase
 496                 # nesting level
 497                 push(@l, $ind);
 498                 $level++;
 499         }
 500         elsif($l[-1] > $ind)
 501         {
 502                 # if last level is more indented, decrease
 503                 # levels until the same is found (or back to
 504                 # the beginning if not)
 505                 while(pop(@l))
 506                 {
 507                         $level--;
 508                         last if $l[-1] == $ind;
 509                 }
 510         }
 511
 512         $gh->{$str} = \@l;
 513
 514         return($level);
 515 }
 516
 517
 518 sub _unsorted_list
 519 {
 520         my ($gh, $ind) = @_;
 521
 522         return($gh->_ul($gh->_multilevel_list('-ul-levels', $ind)));
 523 }
 524
 525
 526 sub _ordered_list
 527 {
 528         my ($gh, $ind) = @_;
 529
 530         return($gh->_ol($gh->_multilevel_list('-ol-levels', $ind)));
 531 }
 532
 533
 534 # empty stubs for falling through the superclass
 535
 536 sub _inline { my ($gh,$l) = @_; $l; }
 537 sub _escape { my ($gh,$l) = @_; $l; }
 538 sub _empty_line { my ($gh) = @_; ""; }
 539 sub _url { my ($gh,$url,$label) = @_; ""; }
 540 sub _strong { my ($gh,$str) = @_; $str; }
 541 sub _em { my ($gh,$str) = @_; $str; }
 542 sub _funcname { my ($gh,$str) = @_; $str; }
 543 sub _varname { my ($gh,$str) = @_; $str; }
 544 sub _new_mode { my ($gh,$mode) = @_; }
 545 sub _dl { my ($gh,$str) = @_; $str; }
 546 sub _ul { my ($gh,$level) = @_; ""; }
 547 sub _ol { my ($gh,$level) = @_; ""; }
 548 sub _blockquote { my ($gh,$str) = @_; $str; }
 549 sub _hr { my ($gh) = @_; "" }
 550 sub _heading { my ($gh,$level,$l) = @_; $l; }
 551 sub _table { my ($gh,$str) = @_; $str; }
 552 sub _prefix { my ($gh) = @_; }
 553 sub _postfix { my ($gh) = @_; }
 554
 555 ###########################################################
 556
 557 =head1 DRIVER SPECIFIC INFORMATION
 558
 559 =cut
 560
 561 ###########################################################
 562 # HTML Driver
 563
 564 package Grutatxt::HTML;
 565
 566 @ISA = ("Grutatxt");
 567
 568 =head2 HTML Driver
 569
 570 The additional parameters for a new Grutatxt object are:
 571
 572 =over 4
 573
 574 =item I<table-headers>
 575
 576 If this boolean value is set, the first row in tables
 577 is assumed to be the heading and rendered using <th>
 578 instead of <td> tags.
 579
 580 =item I<center-tables>
 581
 582 If this boolean value is set, tables are centered.
 583
 584 =item I<expand-tables>
 585
 586 If this boolean value is set, tables are expanded (width 100%).
 587
 588 =item I<dl-as-dl>
 589
 590 If this boolean value is set, definition lists will be
 591 rendered using <dl>, <dt> and <dd> instead of tables.
 592
 593 =item I<header-offset>
 594
 595 Offset to be summed to the heading level when rendering
 596 <h?> tags (default is 0).
 597
 598 =item I<class-oddeven>
 599
 600 If this boolean value is set, tables will be rendered
 601 with an "oddeven" CSS class, and rows alternately classed
 602 as "even" or "odd". If it's not set, no CSS class info
 603 is added to tables.
 604
 605 =back
 606
 607 =cut
 608
 609 sub new
 610 {
 611         my ($class,%args) = @_;
 612         my ($gh);
 613
 614         bless(\%args,$class);
 615         $gh = \%args;
 616
 617         $gh->{'-process-urls'} = 1;
 618
 619         return($gh);
 620 }
 621
 622
 623 sub _inline
 624 {
 625         my ($gh,$l) = @_;
 626
 627         # accept unnamed and HTML inlines
 628         if($l =~ /^<<$/ or $l =~ /^<<\s*html$/i)
 629         {
 630                 $gh->{'-inline'} = "HTML";
 631                 return;
 632         }
 633
 634         if($l =~ /^>>$/)
 635         {
 636                 delete $gh->{'-inline'};
 637                 return;
 638         }
 639
 640         if($gh->{'-inline'} eq "HTML")
 641         {
 642                 $gh->_push($l);
 643         }
 644 }
 645
 646
 647 sub _escape
 648 {
 649         my ($gh,$l) = @_;
 650
 651         $l =~ s/&/&amp;/g;
 652         $l =~ s/</&lt;/g;
 653         $l =~ s/>/&gt;/g;
 654
 655         return($l);
 656 }
 657
 658
 659 sub _empty_line
 660 {
 661         my ($gh) = @_;
 662
 663         return("<p>");
 664 }
 665
 666
 667 sub _url
 668 {
 669         my ($gh,$url,$label) = @_;
 670
 671         $label = $url unless $label;
 672
 673         return("<a href=\"$url\">$label</a>");
 674 }
 675
 676
 677 sub _strong
 678 {
 679         my ($gh,$str) = @_;
 680         return("<strong class=strong>$str</strong>");
 681 }
 682
 683
 684 sub _em
 685 {
 686         my ($gh,$str) = @_;
 687         return("<em class=em>$str</em>");
 688 }
 689
 690
 691 sub _funcname
 692 {
 693         my ($gh,$str) = @_;
 694         return("<code class=funcname>$str</code>");
 695 }
 696
 697
 698 sub _varname
 699 {
 700         my ($gh,$str) = @_;
 701         return("<code class=var>$str</code>");
 702 }
 703
 704
 705 sub _new_mode
 706 {
 707         my ($gh,$mode,$params) = @_;
 708
 709         if($mode ne $gh->{'-mode'})
 710         {
 711                 my $tag;
 712
 713                 # flush previous mode
 714
 715                 # clean list levels
 716                 if($gh->{'-mode'} eq "ul")
 717                 {
 718                         $gh->_push("</ul>" x scalar(@{$gh->{'-ul-levels'}}));
 719                 }
 720                 elsif($gh->{'-mode'} eq "ol")
 721                 {
 722                         $gh->_push("</ol>" x scalar(@{$gh->{'-ol-levels'}}));
 723                 }
 724                 elsif($gh->{'-mode'})
 725                 {
 726                         $gh->_push("</$gh->{'-mode'}>");
 727                 }
 728
 729                 # send new one
 730                 $tag = $params ? "<$mode $params>" : "<$mode>";
 731                 $gh->_push($tag) if $mode;
 732
 733                 $gh->{'-mode'} = $mode;
 734
 735                 # clean previous lists
 736                 $gh->{'-ul-levels'} = undef;
 737                 $gh->{'-ol-levels'} = undef;
 738         }
 739 }
 740
 741
 742 sub _dl
 743 {
 744         my ($gh,$str) = @_;
 745
 746         if($gh->{'dl-as-dl'})
 747         {
 748                 $gh->_new_mode("dl");
 749                 return("<dt><strong class=term>$str</strong><dd>");
 750         }
 751         else
 752         {
 753                 $gh->_new_mode("table");
 754                 return("<tr><td valign=top><strong class=term>$1</strong>&nbsp;&nbsp;</td><td valign=top>");
 755         }
 756 }
 757
 758
 759 sub _ul
 760 {
 761         my ($gh, $levels) = @_;
 762         my ($ret);
 763
 764         $ret = "";
 765
 766         if($levels > 0)
 767         {
 768                 $ret = "<ul>";
 769         }
 770         elsif($levels < 0)
 771         {
 772                 $ret = "</ul>" x abs($levels);
 773         }
 774
 775         $gh->{'-mode'} = "ul";
 776
 777         $ret .= "<li>";
 778
 779         return($ret);
 780 }
 781
 782
 783 sub _ol
 784 {
 785         my ($gh, $levels) = @_;
 786         my ($ret);
 787
 788         $ret = "";
 789
 790         if($levels > 0)
 791         {
 792                 $ret = "<ol>";
 793         }
 794         elsif($levels < 0)
 795         {
 796                 $ret = "</ol>" x abs($levels);
 797         }
 798
 799         $gh->{'-mode'} = "ol";
 800
 801         $ret .= "<li>";
 802
 803         return($ret);
 804 }
 805
 806
 807 sub _blockquote
 808 {
 809         my ($gh) = @_;
 810
 811         $gh->_new_mode("blockquote");
 812         return("\"");
 813 }
 814
 815
 816 sub _hr
 817 {
 818         my ($gh) = @_;
 819
 820         return("<hr size=1 noshade>");
 821 }
 822
 823
 824 sub _heading
 825 {
 826         my ($gh,$level,$l) = @_;
 827
 828         # substitute anchor spaces with underscores
 829         my ($a) = lc($l); $a =~ s/\s/_/g;
 830
 831         $l = sprintf("<a name=\"%s\"></a>\n<h%d class=level$level>%s</h%d>",
 832                 $a, $level+$gh->{'header-offset'},
 833                 $l, $level+$gh->{'header-offset'});
 834
 835         return($l);
 836 }
 837
 838
 839 sub _table
 840 {
 841         my ($gh,$str) = @_;
 842
 843         if($gh->{'-mode'} eq "table")
 844         {
 845                 my ($class) = "";
 846                 my (@spans) = $gh->_calc_col_span($str);
 847
 848                 # calculate CSS class, if any
 849                 if($gh->{'class-oddeven'})
 850                 {
 851                         $class = ($gh->{'-tbl-row'} & 1) ? "odd" : "even";
 852                 }
 853
 854                 $str = "<tr $class>";
 855
 856                 # build columns
 857                 for(my $n = 0;$n < scalar(@{$gh->{'-table'}});$n++)
 858                 {
 859                         my ($i,$s);
 860
 861                         $i = ${$gh->{'-table'}}[$n];
 862                         $i = "&nbsp;" if $i =~ /^\s*$/;
 863
 864                         $s = " colspan=$spans[$n]" if $spans[$n] > 1;
 865
 866                         if($gh->{'table-headers'} and $gh->{'-tbl-row'} == 1)
 867                         {
 868                                 $str .= "<th $class $s>$i</th>";
 869                         }
 870                         else
 871                         {
 872                                 $str .= "<td $class $s>$i</td>";
 873                         }
 874                 }
 875
 876                 @{$gh->{'-table'}} = ();
 877                 $gh->{'-tbl-row'}++;
 878         }
 879         else
 880         {
 881                 # new table
 882                 my ($params);
 883
 884                 $params = "border=1";
 885                 $params .= " width='100\%'" if $gh->{'expand-tables'};
 886                 $params .= " align=center" if $gh->{'center-tables'};
 887                 $params .= " class=oddeven" if $gh->{'class-oddeven'};
 888
 889                 $gh->_new_mode("table", $params);
 890
 891                 @{$gh->{'-table'}} = ();
 892                 $gh->{'-tbl-row'} = 1;
 893                 $str = "";
 894         }
 895
 896         return($str);
 897 }
 898
 899
 900 ###########################################################
 901 # troff Driver
 902
 903 package Grutatxt::troff;
 904
 905 @ISA = ("Grutatxt");
 906
 907 =head2 troff Driver
 908
 909 The troff driver uses the B<-me> macros and B<tbl>. A
 910 good way to post-process this output (to PostScript in
 911 the example) could be by using
 912
 913  groff -t -me -Tps
 914
 915 The additional parameters for a new Grutatxt object are:
 916
 917 =over 4
 918
 919 =item I<normal-size>
 920
 921 The point size of normal text. By default is 10.
 922
 923 =item I<heading-sizes>
 924
 925 This argument must be a reference to an array containing
 926 the size in points of the 3 different heading levels. By
 927 default, level sizes are [ 20, 18, 15 ].
 928
 929 =item I<table-type>
 930
 931 The type of table to be rendered by B<tbl>. Can be
 932 I<allbox> (all lines rendered; this is the default value),
 933 I<box> (only outlined) or I<doublebox> (only outlined by
 934 a double line).
 935
 936 =back
 937
 938 =cut
 939
 940 sub new
 941 {
 942         my ($class,%args) = @_;
 943         my ($gh);
 944
 945         bless(\%args,$class);
 946         $gh = \%args;
 947
 948         $gh->{'-process-urls'} = 0;
 949
 950         $gh->{'heading-sizes'} ||= [ 20, 18, 15 ];
 951         $gh->{'normal-size'} ||= 10;
 952         $gh->{'table-type'} ||= "allbox"; # box, allbox, doublebox
 953
 954         return($gh);
 955 }
 956
 957
 958 sub _prefix
 959 {
 960         my ($gh) = @_;
 961
 962         $gh->_push(".nr pp $gh->{'normal-size'}");
 963         $gh->_push(".nh");
 964 }
 965
 966
 967 sub _inline
 968 {
 969         my ($gh,$l) = @_;
 970
 971         # accept only troff inlines
 972         if($l =~ /^<<\s*troff$/i)
 973         {
 974                 $gh->{'-inline'} = "troff";
 975                 return;
 976         }
 977
 978         if($l =~ /^>>$/)
 979         {
 980                 delete $gh->{'-inline'};
 981                 return;
 982         }
 983
 984         if($gh->{'-inline'} eq "troff")
 985         {
 986                 $gh->_push($l);
 987         }
 988 }
 989
 990
 991 sub _escape
 992 {
 993         my ($gh,$l) = @_;
 994
 995         $l =~ s/\\/\\\\/g;
 996         $l =~ s/^'/\\&'/;
 997
 998         return($l);
 999 }
1000
1001
1002 sub _empty_line
1003 {
1004         my ($gh) = @_;
1005
1006         return(".lp");
1007 }
1008
1009
1010 sub _strong
1011 {
1012         my ($gh,$str) = @_;
1013         return("\\fB$str\\fP");
1014 }
1015
1016
1017 sub _em
1018 {
1019         my ($gh,$str) = @_;
1020         return("\\fI$str\\fP");
1021 }
1022
1023
1024 sub _funcname
1025 {
1026         my ($gh,$str) = @_;
1027         return("\\fB$str\\fP");
1028 }
1029
1030
1031 sub _varname
1032 {
1033         my ($gh,$str) = @_;
1034         return("\\fI$str\\fP");
1035 }
1036
1037
1038 sub _new_mode
1039 {
1040         my ($gh,$mode,$params) = @_;
1041
1042         if($mode ne $gh->{'-mode'})
1043         {
1044                 my $tag;
1045
1046                 # flush previous list
1047                 if($gh->{'-mode'} eq "pre")
1048                 {
1049                         $gh->_push(".)l");
1050                 }
1051                 elsif($gh->{'-mode'} eq "table")
1052                 {
1053                         chomp($gh->{'-table-head'});
1054                         $gh->{'-table-head'} =~ s/\s+$//;
1055                         $gh->_push($gh->{'-table-head'} . ".");
1056                         $gh->_push($gh->{'-table-body'} . ".TE\n.sp 0.6");
1057                 }
1058                 elsif($gh->{'-mode'} eq "blockquote")
1059                 {
1060                         $gh->_push(".)q");
1061                 }
1062
1063                 # send new one
1064                 if($mode eq "pre")
1065                 {
1066                         $gh->_push(".(l L");
1067                 }
1068                 elsif($mode eq "blockquote")
1069                 {
1070                         $gh->_push(".(q");
1071                 }
1072
1073                 $gh->{'-mode'} = $mode;
1074         }
1075 }
1076
1077
1078 sub _dl
1079 {
1080         my ($gh,$str) = @_;
1081
1082         $gh->_new_mode("dl");
1083         return(".ip \"$str\"\n");
1084 }
1085
1086
1087 sub _ul
1088 {
1089         my ($gh) = @_;
1090
1091         $gh->_new_mode("ul");
1092         return(".bu\n");
1093 }
1094
1095
1096 sub _ol
1097 {
1098         my ($gh) = @_;
1099
1100         $gh->_new_mode("ol");
1101         return(".np\n");
1102 }
1103
1104
1105 sub _blockquote
1106 {
1107         my ($gh) = @_;
1108
1109         $gh->_new_mode("blockquote");
1110         return("\"");
1111 }
1112
1113
1114 sub _hr
1115 {
1116         my ($gh) = @_;
1117
1118         return(".hl");
1119 }
1120
1121
1122 sub _heading
1123 {
1124         my ($gh,$level,$l) = @_;
1125
1126         $l = ".sz " . ${$gh->{'heading-sizes'}}[$level - 1] . "\n$l\n.sp 0.6";
1127
1128         return($l);
1129 }
1130
1131
1132 sub _table
1133 {
1134         my ($gh,$str) = @_;
1135
1136         if($gh->{'-mode'} eq "table")
1137         {
1138                 my ($h,$b);
1139                 my (@spans) = $gh->_calc_col_span($str);
1140
1141                 # build columns
1142                 $h = "";
1143                 $b = "";
1144                 for(my $n = 0;$n < scalar(@{$gh->{'-table'}});$n++)
1145                 {
1146                         my ($i);
1147
1148                         if($gh->{'table-headers'} and $gh->{'-tbl-row'} == 1)
1149                         {
1150                                 $h .= "cB ";
1151                         }
1152                         else
1153                         {
1154                                 $h .= "l ";
1155                         }
1156
1157                         # add span columns
1158                         $h .= "s " x ($spans[$n] - 1) if $spans[$n] > 1;
1159
1160                         $b .= "#" if $n;
1161
1162                         $i = ${$gh->{'-table'}}[$n];
1163                         $i =~ s/^\s+//;
1164                         $i =~ s/\s+$//;
1165                         $i =~ s/(\s)+/$1/g;
1166                         $b .= $i;
1167                 }
1168
1169                 # add a separator
1170                 $b .= "\n_" if $gh->{'table-headers'} and
1171                              $gh->{'-tbl-row'} == 1 and
1172                              $gh->{'table-type'} ne "allbox";
1173
1174                 $gh->{'-table-head'} .= "$h\n";
1175                 $gh->{'-table-body'} .= "$b\n";
1176
1177                 @{$gh->{'-table'}} = ();
1178                 $gh->{'-tbl-row'}++;
1179         }
1180         else
1181         {
1182                 # new table
1183                 $gh->_new_mode("table");
1184
1185                 @{$gh->{'-table'}} = ();
1186                 $gh->{'-tbl-row'} = 1;
1187
1188                 $gh->{'-table-head'} = ".TS\n$gh->{'table-type'} tab (#);\n";
1189                 $gh->{'-table-body'} = "";
1190         }
1191
1192         $str = "";
1193         return($str);
1194 }
1195
1196
1197 sub _postfix
1198 {
1199         my ($gh) = @_;
1200
1201         # add to top headings and footers
1202         unshift(@{$gh->{'o'}},".ef '\%' ''");
1203         unshift(@{$gh->{'o'}},".of '' '\%'");
1204         unshift(@{$gh->{'o'}},".eh '$gh->{'-title'}' ''");
1205         unshift(@{$gh->{'o'}},".oh '' '$gh->{'-title'}'");
1206 }
1207
1208
1209 =head1 AUTHOR
1210
1211 Angel Ortega angel@triptico.com
1212
1213 =cut
1214
1215 1;