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