Grutatxt.pm

   1 #####################################################################
   2 #
   3 #   Grutatxt - A text to HTML (and other things) converter
   4 #
   5 #   Copyright (C) 2000/2004 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.9';
  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                         $l =~ s|(\s+)\./(\S+)\s+\(([^\)]+)\)|$1.$gh->_url($2,$3)|ge;
 241                         $l =~ s|^\./(\S+)\s+\(([^\)]+)\)|$gh->_url($1,$2)|ge;
 242
 243                         # URLs without phrase
 244                         $l =~ s/([^=][^\"])(https?:\/\/\S+)/$1.$gh->_url($2)/ge;
 245                         $l =~ s/([^=][^\"])(ftps?:\/\/\S+)/$1.$gh->_url($2)/ge;
 246                         $l =~ s/([^=][^\"])(file:\/?\S+)/$1.$gh->_url($2)/ge;
 247                         $l =~ s|(\s+)\./(\S+)|$1.$gh->_url($2)|ge;
 248
 249                         $l =~ s/^(https?:\/\/\S+)/$gh->_url($1)/ge;
 250                         $l =~ s/^(ftps?:\/\/\S+)/$gh->_url($1)/ge;
 251                         $l =~ s/^(file:\/?\S+)/$gh->_url($1)/ge;
 252                         $l =~ s|^\./(\S+)|$gh->_url($1)|ge;
 253                 }
 254
 255                 # change '''text''' and *text* into strong emphasis
 256                 $l =~ s/\'\'\'([^\'][^\'][^\']*)\'\'\'/$gh->_strong($1)/ge;
 257                 $l =~ s/\*(\S[^\*]+\S)\*/$gh->_strong($1)/ge;
 258                 $l =~ s/\*(\S+)\*/$gh->_strong($1)/ge;
 259
 260                 # change ''text'' and _text_ into emphasis
 261                 $l =~ s/\'\'([^\'][^\']*)\'\'/$gh->_em($1)/ge;
 262                 $l =~ s/\b_(\S[^_]*\S)_\b/$gh->_em($1)/ge;
 263                 $l =~ s/\b_(\S+)_\b/$gh->_em($1)/ge;
 264
 265                 # enclose function names
 266                 if($gh->{'strip-parens'})
 267                 {
 268                         $l =~ s/(\w+)\(\)/$gh->_funcname($1)/ge;
 269                 }
 270                 else
 271                 {
 272                         $l =~ s/(\w+)\(\)/$gh->_funcname($1."()")/ge;
 273                 }
 274
 275                 # enclose variable names
 276                 if($gh->{'strip-dollars'})
 277                 {
 278                         $l =~ s/\$([\w_\.]+)/$gh->_varname($1)/ge;
 279                 }
 280                 else
 281                 {
 282                         $l =~ s/(\$[\w_\.]+)/$gh->_varname($1)/ge;
 283                 }
 284
 285                 #
 286                 # main switch
 287                 #
 288
 289                 # definition list
 290                 if($l =~ s/^\s\*\s+([\w\s\-\(\)]+)\:\s+/$gh->_dl($1)/e)
 291                 {
 292                 }
 293
 294                 # unsorted list
 295                 elsif($gh->{'-mode'} ne "pre" and
 296                      ($l =~ s/^(\s+)\*\s+/$gh->_unsorted_list($1)/e or
 297                       $l =~ s/^(\s+)\-\s+/$gh->_unsorted_list($1)/e))
 298                 {
 299                 }
 300
 301                 # sorted list
 302                 elsif($gh->{'-mode'} ne "pre" and
 303                      ($l =~ s/^(\s+)\#\s+/$gh->_ordered_list($1)/e or
 304                       $l =~ s/^(\s+)1\s+/$gh->_ordered_list($1)/e))
 305                 {
 306                 }
 307
 308                 # quoted block
 309                 elsif($l =~ s/^\s\"/$gh->_blockquote()/e)
 310                 {
 311                 }
 312
 313                 # table rows
 314                 elsif($l =~ s/^\s*\|(.*)\|\s*$/$gh->_table_row($1)/e)
 315                 {
 316                 }
 317
 318                 # table heading / end of row
 319                 elsif($l =~ s/^\s*(\+[-\+\|]+\+)\s*$/$gh->_table($1)/e)
 320                 {
 321                 }
 322
 323                 # preformatted text
 324                 elsif($l =~ s/^(\s.*)$/$gh->_pre($1)/e)
 325                 {
 326                 }
 327
 328                 # anything else
 329                 else
 330                 {
 331                         # back to normal mode
 332                         $gh->_new_mode(undef);
 333                 }
 334
 335                 # 1 level heading
 336                 $l =~ s/^(=+)\s*$/$gh->_process_heading(1,$1)/e;
 337
 338                 # 2 level heading
 339                 $l =~ s/^(-+)\s*$/$gh->_process_heading(2,$1)/e;
 340
 341                 # 3 level heading
 342                 $l =~ s/^(~+)\s*$/$gh->_process_heading(3,$1)/e;
 343
 344                 # change ------ into hr
 345                 $l =~ s/^----*$/$gh->_hr()/e;
 346
 347                 # push finally
 348                 $gh->_push($l) if $l;
 349         }
 350
 351         # flush
 352         $gh->_new_mode(undef);
 353
 354         # postfix
 355         $gh->_postfix();
 356
 357         # set title
 358         ${$gh->{'title'}} = $gh->{'-title'} if ref($gh->{'title'});
 359
 360         # set abstract, if not set
 361         ${$gh->{'abstract'}} = scalar(@{$gh->{'o'}})
 362                 if ref($gh->{'abstract'}) and not ${$gh->{'abstract'}};
 363
 364         return(@{$gh->{'o'}});
 365 }
 366
 367
 368 =head2 B<process_file>
 369
 370  @output=$grutatxt->process_file($filename);
 371
 372 Processes a file in Grutatxt format.
 373
 374 =cut
 375
 376 sub process_file
 377 {
 378         my ($gh,$file) = @_;
 379
 380         open F, $file or return(undef);
 381
 382         my ($content) = join('',<F>);
 383         close F;
 384
 385         return($gh->process($content));
 386 }
 387
 388
 389 sub _push
 390 {
 391         my ($gh,$l) = @_;
 392
 393         push(@{$gh->{'o'}},$l);
 394 }
 395
 396
 397 sub _process_heading
 398 {
 399         my ($gh,$level,$hd) = @_;
 400         my ($l);
 401
 402         $l = pop(@{$gh->{'o'}});
 403
 404         if($l eq $gh->_empty_line())
 405         {
 406                 $gh->_push($l);
 407                 return($hd);
 408         }
 409
 410         # store title
 411         $gh->{'-title'} = $l if $level == 1 and not $gh->{'-title'};
 412
 413         # store index
 414         if(ref($gh->{'index'}))
 415         {
 416                 push(@{$gh->{'index'}},"$level,$l");
 417         }
 418
 419         return($gh->_heading($level,$l));
 420 }
 421
 422
 423 sub _calc_col_span
 424 {
 425         my ($gh,$l) = @_;
 426         my (@spans);
 427
 428         # strip first + and all -
 429         $l =~ s/^\+//;
 430         $l =~ s/-//g;
 431
 432         my ($t) = 1; @spans = ();
 433         for(my $n = 0;$n < length($l);$n++)
 434         {
 435                 if(substr($l,$n,1) eq '+')
 436                 {
 437                         push(@spans,$t);
 438                         $t = 1;
 439                 }
 440                 else
 441                 {
 442                         # it's a colspan mark:
 443                         # increment
 444                         $t++;
 445                 }
 446         }
 447
 448         return(@spans);
 449 }
 450
 451
 452 sub _table_row
 453 {
 454         my ($gh,$str) = @_;
 455
 456         my @s = split(/\|/,$str);
 457
 458         for(my $n = 0;$n < scalar(@s);$n++)
 459         {
 460                 ${$gh->{'-table'}}[$n] .= ' ' . $s[$n];
 461         }
 462
 463         push(@{$gh->{'-table-raw'}}, $str);
 464
 465         return("");
 466 }
 467
 468
 469 sub _pre
 470 {
 471         my ($gh,$l) = @_;
 472
 473         # if any other mode is active, add to it
 474         if($gh->{'-mode'} and $gh->{'-mode'} ne "pre")
 475         {
 476                 $l =~ s/^\s+//;
 477
 478                 my ($a) = pop(@{$gh->{'o'}})." ".$l;
 479                 $gh->_push($a);
 480                 $l = "";
 481         }
 482         else
 483         {
 484                 $gh->_new_mode("pre");
 485         }
 486
 487         return($l);
 488 }
 489
 490
 491 sub _multilevel_list
 492 {
 493         my ($gh, $str, $ind) = @_;
 494         my (@l,$level);
 495
 496         @l = @{$gh->{$str}};
 497         $ind = length($ind);
 498         $level = 0;
 499
 500         if($l[-1] < $ind)
 501         {
 502                 # if last level is less indented, increase
 503                 # nesting level
 504                 push(@l, $ind);
 505                 $level++;
 506         }
 507         elsif($l[-1] > $ind)
 508         {
 509                 # if last level is more indented, decrease
 510                 # levels until the same is found (or back to
 511                 # the beginning if not)
 512                 while(pop(@l))
 513                 {
 514                         $level--;
 515                         last if $l[-1] == $ind;
 516                 }
 517         }
 518
 519         $gh->{$str} = \@l;
 520
 521         return($level);
 522 }
 523
 524
 525 sub _unsorted_list
 526 {
 527         my ($gh, $ind) = @_;
 528
 529         return($gh->_ul($gh->_multilevel_list('-ul-levels', $ind)));
 530 }
 531
 532
 533 sub _ordered_list
 534 {
 535         my ($gh, $ind) = @_;
 536
 537         return($gh->_ol($gh->_multilevel_list('-ol-levels', $ind)));
 538 }
 539
 540
 541 # empty stubs for falling through the superclass
 542
 543 sub _inline { my ($gh,$l) = @_; $l; }
 544 sub _escape { my ($gh,$l) = @_; $l; }
 545 sub _empty_line { my ($gh) = @_; ""; }
 546 sub _url { my ($gh,$url,$label) = @_; ""; }
 547 sub _strong { my ($gh,$str) = @_; $str; }
 548 sub _em { my ($gh,$str) = @_; $str; }
 549 sub _funcname { my ($gh,$str) = @_; $str; }
 550 sub _varname { my ($gh,$str) = @_; $str; }
 551 sub _new_mode { my ($gh,$mode) = @_; }
 552 sub _dl { my ($gh,$str) = @_; $str; }
 553 sub _ul { my ($gh,$level) = @_; ""; }
 554 sub _ol { my ($gh,$level) = @_; ""; }
 555 sub _blockquote { my ($gh,$str) = @_; $str; }
 556 sub _hr { my ($gh) = @_; "" }
 557 sub _heading { my ($gh,$level,$l) = @_; $l; }
 558 sub _table { my ($gh,$str) = @_; $str; }
 559 sub _prefix { my ($gh) = @_; }
 560 sub _postfix { my ($gh) = @_; }
 561
 562 ###########################################################
 563
 564 =head1 DRIVER SPECIFIC INFORMATION
 565
 566 =cut
 567
 568 ###########################################################
 569 # HTML Driver
 570
 571 package Grutatxt::HTML;
 572
 573 @ISA = ("Grutatxt");
 574
 575 =head2 HTML Driver
 576
 577 The additional parameters for a new Grutatxt object are:
 578
 579 =over 4
 580
 581 =item I<table-headers>
 582
 583 If this boolean value is set, the first row in tables
 584 is assumed to be the heading and rendered using <th>
 585 instead of <td> tags.
 586
 587 =item I<center-tables>
 588
 589 If this boolean value is set, tables are centered.
 590
 591 =item I<expand-tables>
 592
 593 If this boolean value is set, tables are expanded (width 100%).
 594
 595 =item I<dl-as-dl>
 596
 597 If this boolean value is set, definition lists will be
 598 rendered using <dl>, <dt> and <dd> instead of tables.
 599
 600 =item I<header-offset>
 601
 602 Offset to be summed to the heading level when rendering
 603 <h?> tags (default is 0).
 604
 605 =item I<class-oddeven>
 606
 607 If this boolean value is set, tables will be rendered
 608 with an "oddeven" CSS class, and rows alternately classed
 609 as "even" or "odd". If it's not set, no CSS class info
 610 is added to tables.
 611
 612 =back
 613
 614 =cut
 615
 616 sub new
 617 {
 618         my ($class,%args) = @_;
 619         my ($gh);
 620
 621         bless(\%args,$class);
 622         $gh = \%args;
 623
 624         $gh->{'-process-urls'} = 1;
 625
 626         return($gh);
 627 }
 628
 629
 630 sub _inline
 631 {
 632         my ($gh,$l) = @_;
 633
 634         # accept unnamed and HTML inlines
 635         if($l =~ /^<<$/ or $l =~ /^<<\s*html$/i)
 636         {
 637                 $gh->{'-inline'} = "HTML";
 638                 return;
 639         }
 640
 641         if($l =~ /^>>$/)
 642         {
 643                 delete $gh->{'-inline'};
 644                 return;
 645         }
 646
 647         if($gh->{'-inline'} eq "HTML")
 648         {
 649                 $gh->_push($l);
 650         }
 651 }
 652
 653
 654 sub _escape
 655 {
 656         my ($gh,$l) = @_;
 657
 658         $l =~ s/&/&amp;/g;
 659         $l =~ s/</&lt;/g;
 660         $l =~ s/>/&gt;/g;
 661
 662         return($l);
 663 }
 664
 665
 666 sub _empty_line
 667 {
 668         my ($gh) = @_;
 669
 670         return("<p>");
 671 }
 672
 673
 674 sub _url
 675 {
 676         my ($gh,$url,$label) = @_;
 677
 678         $label = $url unless $label;
 679
 680         return("<a href=\"$url\">$label</a>");
 681 }
 682
 683
 684 sub _strong
 685 {
 686         my ($gh,$str) = @_;
 687         return("<strong class=strong>$str</strong>");
 688 }
 689
 690
 691 sub _em
 692 {
 693         my ($gh,$str) = @_;
 694         return("<em class=em>$str</em>");
 695 }
 696
 697
 698 sub _funcname
 699 {
 700         my ($gh,$str) = @_;
 701         return("<code class=funcname>$str</code>");
 702 }
 703
 704
 705 sub _varname
 706 {
 707         my ($gh,$str) = @_;
 708         return("<code class=var>$str</code>");
 709 }
 710
 711
 712 sub _new_mode
 713 {
 714         my ($gh,$mode,$params) = @_;
 715
 716         if($mode ne $gh->{'-mode'})
 717         {
 718                 my $tag;
 719
 720                 # flush previous mode
 721
 722                 # clean list levels
 723                 if($gh->{'-mode'} eq "ul")
 724                 {
 725                         $gh->_push("</ul>" x scalar(@{$gh->{'-ul-levels'}}));
 726                 }
 727                 elsif($gh->{'-mode'} eq "ol")
 728                 {
 729                         $gh->_push("</ol>" x scalar(@{$gh->{'-ol-levels'}}));
 730                 }
 731                 elsif($gh->{'-mode'})
 732                 {
 733                         $gh->_push("</$gh->{'-mode'}>");
 734                 }
 735
 736                 # send new one
 737                 $tag = $params ? "<$mode $params>" : "<$mode>";
 738                 $gh->_push($tag) if $mode;
 739
 740                 $gh->{'-mode'} = $mode;
 741
 742                 # clean previous lists
 743                 $gh->{'-ul-levels'} = undef;
 744                 $gh->{'-ol-levels'} = undef;
 745         }
 746 }
 747
 748
 749 sub _dl
 750 {
 751         my ($gh,$str) = @_;
 752
 753         if($gh->{'dl-as-dl'})
 754         {
 755                 $gh->_new_mode("dl");
 756                 return("<dt><strong class=term>$str</strong><dd>");
 757         }
 758         else
 759         {
 760                 $gh->_new_mode("table");
 761                 return("<tr><td valign=top><strong class=term>$1</strong>&nbsp;&nbsp;</td><td valign=top>");
 762         }
 763 }
 764
 765
 766 sub _ul
 767 {
 768         my ($gh, $levels) = @_;
 769         my ($ret);
 770
 771         $ret = "";
 772
 773         if($levels > 0)
 774         {
 775                 $ret = "<ul>";
 776         }
 777         elsif($levels < 0)
 778         {
 779                 $ret = "</ul>" x abs($levels);
 780         }
 781
 782         $gh->{'-mode'} = "ul";
 783
 784         $ret .= "<li>";
 785
 786         return($ret);
 787 }
 788
 789
 790 sub _ol
 791 {
 792         my ($gh, $levels) = @_;
 793         my ($ret);
 794
 795         $ret = "";
 796
 797         if($levels > 0)
 798         {
 799                 $ret = "<ol>";
 800         }
 801         elsif($levels < 0)
 802         {
 803                 $ret = "</ol>" x abs($levels);
 804         }
 805
 806         $gh->{'-mode'} = "ol";
 807
 808         $ret .= "<li>";
 809
 810         return($ret);
 811 }
 812
 813
 814 sub _blockquote
 815 {
 816         my ($gh) = @_;
 817
 818         $gh->_new_mode("blockquote");
 819         return("\"");
 820 }
 821
 822
 823 sub _hr
 824 {
 825         my ($gh) = @_;
 826
 827         return("<hr size=1 noshade>");
 828 }
 829
 830
 831 sub _heading
 832 {
 833         my ($gh,$level,$l) = @_;
 834
 835         # creates a valid anchor
 836         my ($a) = lc($l);
 837
 838         $a =~ s/[\"\']//g;
 839         $a =~ s/\s/_/g;
 840         $a =~ s/<[^>]+>//g;
 841
 842         $l = sprintf("<a name=\"%s\"></a>\n<h%d class=level$level>%s</h%d>",
 843                 $a, $level+$gh->{'header-offset'},
 844                 $l, $level+$gh->{'header-offset'});
 845
 846         return($l);
 847 }
 848
 849
 850 sub _table
 851 {
 852         my ($gh,$str) = @_;
 853
 854         if($gh->{'-mode'} eq "table")
 855         {
 856                 my ($class) = "";
 857                 my (@spans) = $gh->_calc_col_span($str);
 858
 859                 # calculate CSS class, if any
 860                 if($gh->{'class-oddeven'})
 861                 {
 862                         $class = ($gh->{'-tbl-row'} & 1) ? "odd" : "even";
 863                 }
 864
 865                 $str = "<tr $class>";
 866
 867                 # build columns
 868                 for(my $n = 0;$n < scalar(@{$gh->{'-table'}});$n++)
 869                 {
 870                         my ($i,$s);
 871
 872                         $i = ${$gh->{'-table'}}[$n];
 873                         $i = "&nbsp;" if $i =~ /^\s*$/;
 874
 875                         $s = " colspan=$spans[$n]" if $spans[$n] > 1;
 876
 877                         if($gh->{'table-headers'} and $gh->{'-tbl-row'} == 1)
 878                         {
 879                                 $str .= "<th $class $s>$i</th>";
 880                         }
 881                         else
 882                         {
 883                                 $str .= "<td $class $s>$i</td>";
 884                         }
 885                 }
 886
 887                 @{$gh->{'-table'}} = ();
 888                 $gh->{'-tbl-row'}++;
 889         }
 890         else
 891         {
 892                 # new table
 893                 my ($params);
 894
 895                 $params = "border=1";
 896                 $params .= " width='100\%'" if $gh->{'expand-tables'};
 897                 $params .= " align=center" if $gh->{'center-tables'};
 898                 $params .= " class=oddeven" if $gh->{'class-oddeven'};
 899
 900                 $gh->_new_mode("table", $params);
 901
 902                 @{$gh->{'-table'}} = ();
 903                 $gh->{'-tbl-row'} = 1;
 904                 $str = "";
 905         }
 906
 907         return($str);
 908 }
 909
 910
 911 ###########################################################
 912 # troff Driver
 913
 914 package Grutatxt::troff;
 915
 916 @ISA = ("Grutatxt");
 917
 918 =head2 troff Driver
 919
 920 The troff driver uses the B<-me> macros and B<tbl>. A
 921 good way to post-process this output (to PostScript in
 922 the example) could be by using
 923
 924  groff -t -me -Tps
 925
 926 The additional parameters for a new Grutatxt object are:
 927
 928 =over 4
 929
 930 =item I<normal-size>
 931
 932 The point size of normal text. By default is 10.
 933
 934 =item I<heading-sizes>
 935
 936 This argument must be a reference to an array containing
 937 the size in points of the 3 different heading levels. By
 938 default, level sizes are [ 20, 18, 15 ].
 939
 940 =item I<table-type>
 941
 942 The type of table to be rendered by B<tbl>. Can be
 943 I<allbox> (all lines rendered; this is the default value),
 944 I<box> (only outlined) or I<doublebox> (only outlined by
 945 a double line).
 946
 947 =back
 948
 949 =cut
 950
 951 sub new
 952 {
 953         my ($class,%args) = @_;
 954         my ($gh);
 955
 956         bless(\%args,$class);
 957         $gh = \%args;
 958
 959         $gh->{'-process-urls'} = 0;
 960
 961         $gh->{'heading-sizes'} ||= [ 20, 18, 15 ];
 962         $gh->{'normal-size'} ||= 10;
 963         $gh->{'table-type'} ||= "allbox"; # box, allbox, doublebox
 964
 965         return($gh);
 966 }
 967
 968
 969 sub _prefix
 970 {
 971         my ($gh) = @_;
 972
 973         $gh->_push(".nr pp $gh->{'normal-size'}");
 974         $gh->_push(".nh");
 975 }
 976
 977
 978 sub _inline
 979 {
 980         my ($gh,$l) = @_;
 981
 982         # accept only troff inlines
 983         if($l =~ /^<<\s*troff$/i)
 984         {
 985                 $gh->{'-inline'} = "troff";
 986                 return;
 987         }
 988
 989         if($l =~ /^>>$/)
 990         {
 991                 delete $gh->{'-inline'};
 992                 return;
 993         }
 994
 995         if($gh->{'-inline'} eq "troff")
 996         {
 997                 $gh->_push($l);
 998         }
 999 }
1000
1001
1002 sub _escape
1003 {
1004         my ($gh,$l) = @_;
1005
1006         $l =~ s/\\/\\\\/g;
1007         $l =~ s/^'/\\&'/;
1008
1009         return($l);
1010 }
1011
1012
1013 sub _empty_line
1014 {
1015         my ($gh) = @_;
1016
1017         return(".lp");
1018 }
1019
1020
1021 sub _strong
1022 {
1023         my ($gh,$str) = @_;
1024         return("\\fB$str\\fP");
1025 }
1026
1027
1028 sub _em
1029 {
1030         my ($gh,$str) = @_;
1031         return("\\fI$str\\fP");
1032 }
1033
1034
1035 sub _funcname
1036 {
1037         my ($gh,$str) = @_;
1038         return("\\fB$str\\fP");
1039 }
1040
1041
1042 sub _varname
1043 {
1044         my ($gh,$str) = @_;
1045         return("\\fI$str\\fP");
1046 }
1047
1048
1049 sub _new_mode
1050 {
1051         my ($gh,$mode,$params) = @_;
1052
1053         if($mode ne $gh->{'-mode'})
1054         {
1055                 my $tag;
1056
1057                 # flush previous list
1058                 if($gh->{'-mode'} eq "pre")
1059                 {
1060                         $gh->_push(".)l");
1061                 }
1062                 elsif($gh->{'-mode'} eq "table")
1063                 {
1064                         chomp($gh->{'-table-head'});
1065                         $gh->{'-table-head'} =~ s/\s+$//;
1066                         $gh->_push($gh->{'-table-head'} . ".");
1067                         $gh->_push($gh->{'-table-body'} . ".TE\n.sp 0.6");
1068                 }
1069                 elsif($gh->{'-mode'} eq "blockquote")
1070                 {
1071                         $gh->_push(".)q");
1072                 }
1073
1074                 # send new one
1075                 if($mode eq "pre")
1076                 {
1077                         $gh->_push(".(l L");
1078                 }
1079                 elsif($mode eq "blockquote")
1080                 {
1081                         $gh->_push(".(q");
1082                 }
1083
1084                 $gh->{'-mode'} = $mode;
1085         }
1086 }
1087
1088
1089 sub _dl
1090 {
1091         my ($gh,$str) = @_;
1092
1093         $gh->_new_mode("dl");
1094         return(".ip \"$str\"\n");
1095 }
1096
1097
1098 sub _ul
1099 {
1100         my ($gh) = @_;
1101
1102         $gh->_new_mode("ul");
1103         return(".bu\n");
1104 }
1105
1106
1107 sub _ol
1108 {
1109         my ($gh) = @_;
1110
1111         $gh->_new_mode("ol");
1112         return(".np\n");
1113 }
1114
1115
1116 sub _blockquote
1117 {
1118         my ($gh) = @_;
1119
1120         $gh->_new_mode("blockquote");
1121         return("\"");
1122 }
1123
1124
1125 sub _hr
1126 {
1127         my ($gh) = @_;
1128
1129         return(".hl");
1130 }
1131
1132
1133 sub _heading
1134 {
1135         my ($gh,$level,$l) = @_;
1136
1137         $l = ".sz " . ${$gh->{'heading-sizes'}}[$level - 1] . "\n$l\n.sp 0.6";
1138
1139         return($l);
1140 }
1141
1142
1143 sub _table
1144 {
1145         my ($gh,$str) = @_;
1146
1147         if($gh->{'-mode'} eq "table")
1148         {
1149                 my ($h,$b);
1150                 my (@spans) = $gh->_calc_col_span($str);
1151
1152                 # build columns
1153                 $h = "";
1154                 $b = "";
1155                 for(my $n = 0;$n < scalar(@{$gh->{'-table'}});$n++)
1156                 {
1157                         my ($i);
1158
1159                         if($gh->{'table-headers'} and $gh->{'-tbl-row'} == 1)
1160                         {
1161                                 $h .= "cB ";
1162                         }
1163                         else
1164                         {
1165                                 $h .= "l ";
1166                         }
1167
1168                         # add span columns
1169                         $h .= "s " x ($spans[$n] - 1) if $spans[$n] > 1;
1170
1171                         $b .= "#" if $n;
1172
1173                         $i = ${$gh->{'-table'}}[$n];
1174                         $i =~ s/^\s+//;
1175                         $i =~ s/\s+$//;
1176                         $i =~ s/(\s)+/$1/g;
1177                         $b .= $i;
1178                 }
1179
1180                 # add a separator
1181                 $b .= "\n_" if $gh->{'table-headers'} and
1182                              $gh->{'-tbl-row'} == 1 and
1183                              $gh->{'table-type'} ne "allbox";
1184
1185                 $gh->{'-table-head'} .= "$h\n";
1186                 $gh->{'-table-body'} .= "$b\n";
1187
1188                 @{$gh->{'-table'}} = ();
1189                 $gh->{'-tbl-row'}++;
1190         }
1191         else
1192         {
1193                 # new table
1194                 $gh->_new_mode("table");
1195
1196                 @{$gh->{'-table'}} = ();
1197                 $gh->{'-tbl-row'} = 1;
1198
1199                 $gh->{'-table-head'} = ".TS\n$gh->{'table-type'} tab (#);\n";
1200                 $gh->{'-table-body'} = "";
1201         }
1202
1203         $str = "";
1204         return($str);
1205 }
1206
1207
1208 sub _postfix
1209 {
1210         my ($gh) = @_;
1211
1212         # add to top headings and footers
1213         unshift(@{$gh->{'o'}},".ef '\%' ''");
1214         unshift(@{$gh->{'o'}},".of '' '\%'");
1215         unshift(@{$gh->{'o'}},".eh '$gh->{'-title'}' ''");
1216         unshift(@{$gh->{'o'}},".oh '' '$gh->{'-title'}'");
1217 }
1218
1219
1220 ###########################################################
1221 # man Driver
1222
1223 package Grutatxt::man;
1224
1225 @ISA = ("Grutatxt::troff", "Grutatxt");
1226
1227 =head2 man Driver
1228
1229 The man driver is used to generate Unix-like man pages. Note that
1230 all headings have the same level with this output driver.
1231
1232 The additional parameters for a new Grutatxt object are:
1233
1234 =over 4
1235
1236 =item I<section>
1237
1238 The man page section (see man documentation). By default is 1.
1239
1240 =item I<page-name>
1241
1242 The name of the page. This is usually the name of the program
1243 or function the man page is documenting and will be shown in the
1244 page header. By default is the empty string.
1245
1246 =back
1247
1248 =cut
1249
1250 sub new
1251 {
1252         my ($class,%args) = @_;
1253         my ($gh);
1254
1255         bless(\%args,$class);
1256         $gh = \%args;
1257
1258         $gh->{'-process-urls'} = 0;
1259
1260         $gh->{'section'} ||= 1;
1261         $gh->{'page-name'} ||= "";
1262
1263         return($gh);
1264 }
1265
1266
1267 sub _prefix
1268 {
1269         my ($gh) = @_;
1270
1271         $gh->_push(".TH \"$gh->{'page-name'}\" \"$gh->{'section'}\" \"" . localtime() . "\"");
1272 }
1273
1274
1275 sub _inline
1276 {
1277         my ($gh,$l) = @_;
1278
1279         # accept only man markup inlines
1280         if($l =~ /^<<\s*man$/i)
1281         {
1282                 $gh->{'-inline'} = "man";
1283                 return;
1284         }
1285
1286         if($l =~ /^>>$/)
1287         {
1288                 delete $gh->{'-inline'};
1289                 return;
1290         }
1291
1292         if($gh->{'-inline'} eq "man")
1293         {
1294                 $gh->_push($l);
1295         }
1296 }
1297
1298
1299 sub _empty_line
1300 {
1301         my ($gh) = @_;
1302
1303         return(".PP");
1304 }
1305
1306
1307 sub _new_mode
1308 {
1309         my ($gh,$mode,$params) = @_;
1310
1311         if($mode ne $gh->{'-mode'})
1312         {
1313                 my $tag;
1314
1315                 # flush previous list
1316                 if($gh->{'-mode'} eq "pre" or
1317                    $gh->{'-mode'} eq "table")
1318                 {
1319                         $gh->_push(".fi");
1320                 }
1321
1322                 if($gh->{'-mode'} eq "blockquote")
1323                 {
1324                         $gh->_push(".RE");
1325                 }
1326
1327                 if($gh->{'-mode'} eq "ul")
1328                 {
1329                         $gh->_push(".RE\n" x scalar(@{$gh->{'-ul-levels'}}));
1330                 }
1331
1332                 if($gh->{'-mode'} eq "ol")
1333                 {
1334                         $gh->_push(".RE\n" x scalar(@{$gh->{'-ol-levels'}}));
1335                 }
1336
1337                 # send new one
1338                 if($mode eq "pre" or
1339                    $mode eq "table")
1340                 {
1341                         $gh->_push(".nf");
1342                 }
1343
1344                 if($mode eq "blockquote")
1345                 {
1346                         $gh->_push(".RS 4");
1347                 }
1348
1349                 $gh->{'-mode'} = $mode;
1350         }
1351 }
1352
1353
1354 sub _dl
1355 {
1356         my ($gh,$str) = @_;
1357
1358         $gh->_new_mode("dl");
1359         return(".TP\n.B \"$str\"\n");
1360 }
1361
1362
1363 sub _ul
1364 {
1365         my ($gh, $levels) = @_;
1366         my ($ret) = "";
1367
1368         if($levels > 0)
1369         {
1370                 $ret = ".RS 4\n";
1371         }
1372         elsif($levels < 0)
1373         {
1374                 $ret = ".RE\n" x abs($levels);
1375         }
1376
1377         $gh->_new_mode("ul");
1378         return($ret . ".TP 4\n\\(bu\n");
1379 }
1380
1381
1382 sub _ol
1383 {
1384         my ($gh, $levels) = @_;
1385         my $l = @{$gh->{'-ol-levels'}};
1386         my $ret = "";
1387
1388         $gh->{'-ol-level'} += $levels;
1389
1390         if($levels > 0)
1391         {
1392                 $ret = ".RS 4\n";
1393
1394                 $l[$gh->{'-ol-level'}] = 1;
1395         }
1396         elsif($levels < 0)
1397         {
1398                 $ret = ".RE\n" x abs($levels);
1399         }
1400
1401         $gh->_new_mode("ol");
1402         $ret .= ".TP 4\n" . $l[$gh->{'-ol-level'}]++ . ".\n";
1403
1404         return($ret);
1405 }
1406
1407
1408 sub _hr
1409 {
1410         my ($gh) = @_;
1411
1412         return("");
1413 }
1414
1415
1416 sub _heading
1417 {
1418         my ($gh,$level,$l) = @_;
1419
1420         # all headers are the same depth in man pages
1421         return(".SH \"" . uc($l) . "\"");
1422 }
1423
1424
1425 sub _table
1426 {
1427         my ($gh,$str) = @_;
1428
1429         if($gh->{'-mode'} eq "table")
1430         {
1431                 foreach my $r (@{$gh->{'-table-raw'}})
1432                 {
1433                         $gh->_push("|$r|");
1434                 }
1435         }
1436         else
1437         {
1438                 $gh->_new_mode("table");
1439         }
1440
1441         @{$gh->{'-table'}} = ();
1442         @{$gh->{'-table-raw'}} = ();
1443
1444         $gh->_push($str);
1445
1446         return("");
1447 }
1448
1449
1450 sub _postfix
1451 {
1452 }
1453
1454
1455 =head1 AUTHOR
1456
1457 Angel Ortega angel@triptico.com
1458
1459 =cut
1460
1461 1;