Grutatxt.pm

   1 #####################################################################
   2 #
   3 #   Grutatxt - A text to HTML (and other things) converter
   4 #
   5 #   Copyright (C) 2000/2010 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://triptico.com
  22 #
  23 #####################################################################
  24
  25 package Grutatxt;
  26
  27 use locale;
  28
  29 $VERSION = '2.0.16-dev';
  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 =for html <->
  66
  67 A comprehensive description of the markup is defined in
  68 the README file, included with the Grutatxt package (it is
  69 written in Grutatxt format itself, so it can be converted
  70 using the I<grutatxt> tool to any of the supported formats).
  71 The latest version (and more information) can be retrieved
  72 from the Grutatxt home page at:
  73
  74  http://triptico.com/software/grutatxt.html
  75
  76 =head1 FUNCTIONS AND METHODS
  77
  78 =head2 new
  79
  80  $grutatxt = new Grutatxt([ "mode"  => $mode, ]
  81                         [ "title" => \$title, ]
  82                         [ "marks" => \@marks, ]
  83                         [ "index" => \@index, ]
  84                         [ "abstract" => \$abstract, ]
  85                         [ "strip-parens" => $bool, ]
  86                         [ "strip-dollars" => $bool, ]
  87                         [ %driver_specific_arguments ] );
  88
  89 Creates a new Grutatxt object instance. All parameters are
  90 optional.
  91
  92 =over 4
  93
  94 =item I<mode>
  95
  96 Output format. Can be HTML, troff or man. HTML is used if not specified.
  97
  98 =item I<title>
  99
 100 If I<title> is specified as a reference to scalar, the first
 101 level 1 heading found in the text is stored inside it.
 102
 103 =item I<marks>
 104
 105 Marks in the Grutatxt markup are created by inserting the
 106 string <-> alone in a line. If I<marks> is specified as a
 107 reference to array, it will be filled with the subscripts
 108 (relative to the output array) of the lines where the marks
 109 are found in the text.
 110
 111 =item I<index>
 112
 113 If I<index> is specified as a reference to array, it will
 114 be filled with two element arrayrefs with the level as first
 115 argument and the heading as second.
 116
 117 This information can be used to build a table of contents
 118 of the processed text.
 119
 120 =item I<strip-parens>
 121
 122 Function names in the Grutatxt markup are strings of
 123 alphanumeric characters immediately followed by a pair
 124 of open and close parentheses. If this boolean value is
 125 set, function names found in the processed text will have
 126 their parentheses deleted.
 127
 128 =item I<strip-dollars>
 129
 130 Variable names in the Grutatxt markup are strings of
 131 alphanumeric characters preceded by a dollar sign.
 132 If this boolean value is set, variable names found in
 133 the processed text will have the dollar sign deleted.
 134
 135 =item I<abstract>
 136
 137 The I<abstract> of a Grutatxt document is the fragment of text
 138 from the beginning of the document to the end of the first
 139 paragraph after the title. If I<abstract> is specified as a
 140 reference to scalar, it will contain (after each call to the
 141 B<process()> method) the subscript of the element of the output
 142 array that marks the end of the subject.
 143
 144 =item I<no-pure-verbatim>
 145
 146 Since version 2.0.15, text effects as italics and bold are not
 147 processed in I<verbatim> (preformatted) mode. If you want to
 148 revert to the old behaviour, use this option.
 149
 150 =item I<toc>
 151
 152 If set, a table of contents will be generated after the abstract.
 153 The table of contents will be elaborated using headings from 2
 154 and 3 levels.
 155
 156 =back
 157
 158 =cut
 159
 160 sub new
 161 {
 162         my ($class, %args) = @_;
 163         my ($gh);
 164
 165         $args{'mode'} ||= 'HTML';
 166
 167         $class .= "::" . $args{'mode'};
 168
 169         $gh = new $class(%args);
 170
 171         return $gh;
 172 }
 173
 174
 175 sub escape
 176 # escapes special characters, ignoring passthrough code
 177 {
 178         my ($gh, $l) = @_;
 179
 180         # splits between << and >>
 181         my (@l) = split(/(<<|>>)/, $l);
 182
 183         @l = map {
 184                         my $l = $_;
 185
 186                         # escape only text outside << and >>
 187                         unless ($l eq '<<' .. $l eq '>>') {
 188                                 $l = $gh->_escape($l);
 189                         }
 190
 191                         $_ = $l;
 192                 } @l;
 193
 194         # join again, stripping << and >>
 195         $l = join('', grep(!/^(<<|>>)$/, @l));
 196
 197         return $l;
 198 }
 199
 200
 201 =head2 process
 202
 203  @output = $grutatxt->process($text);
 204
 205 Processes a text in Grutatxt format. The result is returned
 206 as an array of lines.
 207
 208 =cut
 209
 210 sub process
 211 {
 212         my ($gh, $content) = @_;
 213         my ($p);
 214
 215         # clean output
 216         @{$gh->{'o'}} = ();
 217
 218         # clean title and paragraph numbers
 219         $gh->{'-title'} = '';
 220         $gh->{'-p'} = 0;
 221
 222         # clean marks
 223         if (!defined $gh->{marks}) {
 224                 $gh->{marks} = [];
 225         }
 226
 227         @{$gh->{'marks'}} = ();
 228
 229         # clean index
 230         if (!$gh->{index}) {
 231                 $gh->{index} = [];
 232         }
 233
 234         @{$gh->{'index'}} = ();
 235
 236         # reset abstract line
 237         if (!$gh->{abstract}) {
 238                 $gh->{abstract} = \$gh->{_abstract};
 239         }
 240
 241         ${$gh->{'abstract'}} = 0;
 242
 243         # insert prefix
 244         $gh->_prefix();
 245
 246         $gh->{'-mode'} = undef;
 247
 248         foreach my $l (split(/\n/,$content)) {
 249                 # inline data (passthrough)
 250                 if ($l =~ /^<<$/ .. $l =~ /^>>$/) {
 251                         $gh->_inline($l);
 252                         next;
 253                 }
 254
 255                 # marks
 256                 if ($l =~ /^\s*<\->\s*$/) {
 257                         push(@{$gh->{'marks'}},scalar(@{$gh->{'o'}}))
 258                                 if ref($gh->{'marks'});
 259
 260                         next;
 261                 }
 262
 263                 # TOC mark
 264                 if ($l =~ /^\s*<\?>\s*$/) {
 265                         $gh->{toc} = $gh->{_toc_pos} = scalar(@{$gh->{o}});
 266                         next;
 267                 }
 268
 269                 # escape possibly dangerous characters
 270                 $l = $gh->escape($l);
 271
 272                 # empty lines
 273                 $l =~ s/^\r$//ge;
 274                 if ($l =~ s/^$/$gh->_empty_line()/ge) {
 275                         # mark the abstract end
 276                         if ($gh->{'-title'}) {
 277                                 $gh->{'-p'}++;
 278
 279                                 # mark abstract if it's the
 280                                 # second paragraph from the title
 281                                 ${$gh->{'abstract'}} = scalar(@{$gh->{'o'}})-1
 282                                         if $gh->{'-p'} == 2;
 283                         }
 284                 }
 285
 286                 # line-mutating process
 287                 my $ol = $l;
 288
 289                 if ($gh->{'-process-urls'}) {
 290                         # URLs followed by a parenthesized phrase
 291                         $l =~ s/(https?:\/\/\S+)\s+\(([^\)]+)\)/$gh->_url($1,$2)/ge;
 292                         $l =~ s/(ftps?:\/\/\S+)\s+\(([^\)]+)\)/$gh->_url($1,$2)/ge;
 293                         $l =~ s/(file:\/?\S+)\s+\(([^\)]+)\)/$gh->_url($1,$2)/ge;
 294                         $l =~ s|(\s+)\./(\S+)\s+\(([^\)]+)\)|$1.$gh->_url($2,$3)|ge;
 295                         $l =~ s|^\./(\S+)\s+\(([^\)]+)\)|$gh->_url($1,$2)|ge;
 296                         $l =~ s/(mailto:\S+)\s+\(([^\)]+)\)/$gh->_url($1,$2)/ge;
 297
 298                         # URLs without phrase
 299                         $l =~ s/([^=][^\"])(https?:\/\/\S+)/$1.$gh->_url($2)/ge;
 300                         $l =~ s/([^=][^\"])(ftps?:\/\/\S+)/$1.$gh->_url($2)/ge;
 301                         $l =~ s/([^=][^\"])(file:\/?\S+)/$1.$gh->_url($2)/ge;
 302                         $l =~ s|(\s+)\./(\S+)|$1.$gh->_url($2)|ge;
 303                         $l =~ s/([^=][^\"])(mailto:)(\S+)/$1.$gh->_url($2.$3,$3)/ge;
 304
 305                         $l =~ s/^(https?:\/\/\S+)/$gh->_url($1)/ge;
 306                         $l =~ s/^(ftps?:\/\/\S+)/$gh->_url($1)/ge;
 307                         $l =~ s/^(file:\/?\S+)/$gh->_url($1)/ge;
 308                         $l =~ s|^\./(\S+)|$gh->_url($1)|ge;
 309                 }
 310
 311                 # change '''text''' and *text* into strong emphasis
 312                 $l =~ s/\'\'\'([^\'][^\'][^\']*)\'\'\'/$gh->_strong($1)/ge;
 313                 $l =~ s/\*(\S[^\*]+\S)\*/$gh->_strong($1)/ge;
 314                 $l =~ s/\*(\S+)\*/$gh->_strong($1)/ge;
 315
 316                 # change ''text'' and _text_ into emphasis
 317                 $l =~ s/\'\'([^\'][^\']*)\'\'/$gh->_em($1)/ge;
 318                 $l =~ s/\b_(\S[^_]*\S)_\b/$gh->_em($1)/ge;
 319                 $l =~ s/\b_(\S+)_\b/$gh->_em($1)/ge;
 320
 321                 # change `text' into code
 322                 $l =~ s/`([^\']*)\'/$gh->_code($1)/ge;
 323
 324                 # enclose function names
 325                 if ($gh->{'strip-parens'}) {
 326                         $l =~ s/(\w+)\(\)/$gh->_funcname($1)/ge;
 327                 }
 328                 else {
 329                         $l =~ s/(\w+)\(\)/$gh->_funcname($1."()")/ge;
 330                 }
 331
 332                 # enclose variable names
 333                 if ($gh->{'strip-dollars'}) {
 334                         $l =~ s/\$([\w_\.]+)/$gh->_varname($1)/ge;
 335                 }
 336                 else {
 337                         $l =~ s/(\$[\w_\.]+)/$gh->_varname($1)/ge;
 338                 }
 339
 340                 #
 341                 # main switch
 342                 #
 343
 344                 # definition list
 345                 if ($l =~ /^\s\*\s+/ && $l =~ s/^\s\*\s+([^:\.,;]+)\:\s+/$gh->_dl($1)/e) {
 346                         $gh->{'-mode-elems'} ++;
 347                 }
 348
 349                 # unsorted list
 350                 elsif ($gh->{'-mode'} ne 'pre' and
 351                      ($l =~ s/^(\s+)\*\s+/$gh->_unsorted_list($1)/e or
 352                       $l =~ s/^(\s+)\-\s+/$gh->_unsorted_list($1)/e)) {
 353                         $gh->{'-mode-elems'} ++;
 354                 }
 355
 356                 # sorted list
 357                 elsif ($gh->{'-mode'} ne 'pre' and
 358                      ($l =~ s/^(\s+)\#\s+/$gh->_ordered_list($1)/e or
 359                       $l =~ s/^(\s+)1\s+/$gh->_ordered_list($1)/e)) {
 360                         $gh->{'-mode-elems'} ++;
 361                 }
 362
 363                 # quoted block
 364                 elsif ($gh->{'-mode'} ne 'pre' and
 365                         $l =~ s/^\s\"/$gh->_blockquote()/e) {
 366                 }
 367
 368                 # table rows
 369                 elsif ($l =~ s/^\s*\|(.*)\|\s*$/$gh->_table_row($1)/e) {
 370                         $gh->{'-mode-elems'} ++;
 371                 }
 372
 373                 # table heading / end of row
 374                 elsif ($l =~ s/^\s*(\+[-\+\|]+\+)\s*$/$gh->_table($1)/e) {
 375                 }
 376
 377                 # preformatted text
 378                 elsif ($l =~ s/^(\s.*)$/$gh->_pre($1)/e) {
 379                         if ($gh->{'-mode'} eq 'pre' &&
 380                                 !$gh->{'no-pure-verbatim'}) {
 381                                 # set line back to original
 382                                 $l = $ol;
 383                         }
 384                 }
 385
 386                 # anything else
 387                 else {
 388                         # back to normal mode
 389                         $gh->_new_mode(undef);
 390                 }
 391
 392                 # 1 level heading
 393                 $l =~ s/^(=+)\s*$/$gh->_process_heading(1,$1)/e;
 394
 395                 # 2 level heading
 396                 $l =~ s/^(-+)\s*$/$gh->_process_heading(2,$1)/e;
 397
 398                 # 3 level heading
 399                 $l =~ s/^(~+)\s*$/$gh->_process_heading(3,$1)/e;
 400
 401                 # change ------ into hr
 402                 $l =~ s/^----*$/$gh->_hr()/e;
 403
 404                 # push finally
 405                 $gh->_push($l) if $l;
 406         }
 407
 408         # flush
 409         $gh->_new_mode(undef);
 410
 411         # postfix
 412         $gh->_postfix();
 413
 414         # set title
 415         ${$gh->{'title'}} = $gh->{'-title'} if ref($gh->{'title'});
 416
 417         # set abstract, if not set
 418         ${$gh->{'abstract'}} = scalar(@{$gh->{'o'}})
 419                 if ref($gh->{'abstract'}) and not ${$gh->{'abstract'}};
 420
 421         # travel all lines again, post-escaping
 422         @{$gh->{'o'}} = map { $_ = $gh->_escape_post($_); } @{$gh->{'o'}};
 423
 424         # add TOC after first paragraph
 425         if ($gh->{toc} && @{$gh->{o}}) {
 426                 my $p = $gh->{_toc_pos} ||
 427                         $gh->{marks}->[0] ||
 428                         ${$gh->{abstract}};
 429
 430                 @{$gh->{o}} = (@{$gh->{o}}[0 .. $p],
 431                         $gh->_toc(),
 432                         @{$gh->{o}}[$p + 1 ..
 433                                 scalar(@{$gh->{o}})]);
 434         }
 435
 436         return @{$gh->{'o'}};
 437 }
 438
 439
 440 =head2 process_file
 441
 442  @output = $grutatxt->process_file($filename);
 443
 444 Processes a file in Grutatxt format.
 445
 446 =cut
 447
 448 sub process_file
 449 {
 450         my ($gh, $file) = @_;
 451
 452         open F, $file or return(undef);
 453
 454         my ($content) = join('',<F>);
 455         close F;
 456
 457         return $gh->process($content);
 458 }
 459
 460
 461 sub _push
 462 {
 463         my ($gh, $l) = @_;
 464
 465         push(@{$gh->{'o'}},$l);
 466 }
 467
 468
 469 sub _process_heading
 470 {
 471         my ($gh, $level, $hd) = @_;
 472         my ($l);
 473
 474         $l = pop(@{$gh->{'o'}});
 475
 476         if ($l eq $gh->_empty_line()) {
 477                 $gh->_push($l);
 478                 return $hd;
 479         }
 480
 481         # store title
 482         $gh->{'-title'} = $l if $level == 1 and not $gh->{'-title'};
 483
 484         # store index
 485         if (ref($gh->{'index'})) {
 486                 push(@{$gh->{'index'}}, [ $level, $l ]);
 487         }
 488
 489         return $gh->_heading($level,$l);
 490 }
 491
 492
 493 sub _calc_col_span
 494 {
 495         my ($gh, $l) = @_;
 496         my (@spans);
 497
 498         # strip first + and all -
 499         $l =~ s/^\+//;
 500         $l =~ s/-//g;
 501
 502         my ($t) = 1; @spans = ();
 503         for (my $n = 0; $n < length($l); $n++) {
 504                 if (substr($l, $n, 1) eq '+') {
 505                         push(@spans, $t);
 506                         $t = 1;
 507                 }
 508                 else {
 509                         # it's a colspan mark:
 510                         # increment
 511                         $t++;
 512                 }
 513         }
 514
 515         return @spans;
 516 }
 517
 518
 519 sub _table_row
 520 {
 521         my ($gh, $str) = @_;
 522
 523         my @s = split(/\|/,$str);
 524
 525         for (my $n = 0; $n < scalar(@s); $n++) {
 526                 ${$gh->{'-table'}}[$n] .= ' ' . $s[$n];
 527         }
 528
 529         push(@{$gh->{'-table-raw'}}, $str);
 530
 531         return '';
 532 }
 533
 534
 535 sub _pre
 536 {
 537         my ($gh, $l) = @_;
 538
 539         # if any other mode is active, add to it
 540         if ($gh->{'-mode'} and $gh->{'-mode'} ne 'pre') {
 541                 $l =~ s/^\s+//;
 542
 543                 my ($a) = pop(@{$gh->{'o'}})." ".$l;
 544                 $gh->_push($a);
 545                 $l = '';
 546         }
 547         else {
 548                 # tabs to spaces if a non-zero tabsize is given (only in LaTex)
 549                 $l =~ s/\t/' ' x $gh->{'tabsize'}/ge if $gh->{'tabsize'} > 0;
 550
 551                 $gh->_new_mode('pre');
 552         }
 553
 554         return $l;
 555 }
 556
 557
 558 sub _multilevel_list
 559 {
 560         my ($gh, $str, $ind) = @_;
 561         my (@l,$level);
 562
 563         @l = @{$gh->{$str}};
 564         $ind = length($ind);
 565         $level = 0;
 566
 567         if ($l[-1] < $ind) {
 568                 # if last level is less indented, increase
 569                 # nesting level
 570                 push(@l, $ind);
 571                 $level++;
 572         }
 573         elsif ($l[-1] > $ind) {
 574                 # if last level is more indented, decrease
 575                 # levels until the same is found (or back to
 576                 # the beginning if not)
 577                 while (pop(@l)) {
 578                         $level--;
 579                         last if $l[-1] == $ind;
 580                 }
 581         }
 582
 583         $gh->{$str} = \@l;
 584
 585         return $level;
 586 }
 587
 588
 589 sub _unsorted_list
 590 {
 591         my ($gh, $ind) = @_;
 592
 593         return $gh->_ul($gh->_multilevel_list('-ul-levels', $ind));
 594 }
 595
 596
 597 sub _ordered_list
 598 {
 599         my ($gh, $ind) = @_;
 600
 601         return $gh->_ol($gh->_multilevel_list('-ol-levels', $ind));
 602 }
 603
 604
 605 # empty stubs for falling through the superclass
 606
 607 sub _inline { my ($gh, $l) = @_; $l; }
 608 sub _escape { my ($gh, $l) = @_; $l; }
 609 sub _escape_post { my ($gh, $l) = @_; $l; }
 610 sub _empty_line { my ($gh) = @_; ''; }
 611 sub _url { my ($gh, $url, $label) = @_; ''; }
 612 sub _strong { my ($gh, $str) = @_; $str; }
 613 sub _em { my ($gh, $str) = @_; $str; }
 614 sub _code { my ($gh, $str) = @_; $str; }
 615 sub _funcname { my ($gh, $str) = @_; $str; }
 616 sub _varname { my ($gh, $str) = @_; $str; }
 617 sub _new_mode { my ($gh, $mode) = @_; }
 618 sub _dl { my ($gh, $str) = @_; $str; }
 619 sub _ul { my ($gh, $level) = @_; ''; }
 620 sub _ol { my ($gh, $level) = @_; ''; }
 621 sub _blockquote { my ($gh, $str) = @_; $str; }
 622 sub _hr { my ($gh) = @_; ''; }
 623 sub _heading { my ($gh, $level, $l) = @_; $l; }
 624 sub _table { my ($gh, $str) = @_; $str; }
 625 sub _prefix { my ($gh) = @_; }
 626 sub _postfix { my ($gh) = @_; }
 627 sub _toc { my ($gh) = @_; return (); }
 628
 629 ###########################################################
 630
 631 =head1 DRIVER SPECIFIC INFORMATION
 632
 633 =cut
 634
 635 ###########################################################
 636 # HTML Driver
 637
 638 package Grutatxt::HTML;
 639
 640 @ISA = ("Grutatxt");
 641
 642 =head2 HTML Driver
 643
 644 The additional parameters for a new Grutatxt object are:
 645
 646 =over 4
 647
 648 =item I<table-headers>
 649
 650 If this boolean value is set, the first row in tables
 651 is assumed to be the heading and rendered using 'th'
 652 instead of 'td' tags.
 653
 654 =item I<center-tables>
 655
 656 If this boolean value is set, tables are centered.
 657
 658 =item I<expand-tables>
 659
 660 If this boolean value is set, tables are expanded (width 100%).
 661
 662 =item I<dl-as-dl>
 663
 664 If this boolean value is set, definition lists will be
 665 rendered using 'dl', 'dt' and 'dd' instead of tables.
 666
 667 =item I<header-offset>
 668
 669 Offset to be summed to the heading level when rendering
 670 'h?' tags (default is 0).
 671
 672 =item I<class-oddeven>
 673
 674 If this boolean value is set, tables will be rendered
 675 with an "oddeven" CSS class, and rows alternately classed
 676 as "even" or "odd". If it's not set, no CSS class info
 677 is added to tables.
 678
 679 =item I<url-label-max>
 680
 681 If an URL without label is given (that is, the URL itself
 682 is used as the label), it's trimmed to have as much
 683 characters as this value says. By default it's 80.
 684
 685 =back
 686
 687 =cut
 688
 689 sub new
 690 {
 691         my ($class, %args) = @_;
 692         my ($gh);
 693
 694         bless(\%args, $class);
 695         $gh = \%args;
 696
 697         $gh->{'-process-urls'} = 1;
 698         $gh->{'url-label-max'} ||= 80;
 699
 700         return $gh;
 701 }
 702
 703
 704 sub _inline
 705 {
 706         my ($gh, $l) = @_;
 707
 708         # accept unnamed and HTML inlines
 709         if ($l =~ /^<<$/ or $l =~ /^<<\s*html$/i) {
 710                 $gh->{'-inline'} = 'HTML';
 711                 return;
 712         }
 713
 714         if ($l =~ /^>>$/) {
 715                 delete $gh->{'-inline'};
 716                 return;
 717         }
 718
 719         if ($gh->{'-inline'} eq 'HTML') {
 720                 $gh->_push($l);
 721         }
 722 }
 723
 724
 725 sub _escape
 726 {
 727         my ($gh, $l) = @_;
 728
 729         $l =~ s/&/&amp;/g;
 730         $l =~ s/</&lt;/g;
 731         $l =~ s/>/&gt;/g;
 732
 733         return $l;
 734 }
 735
 736
 737 sub _empty_line
 738 {
 739         my ($gh) = @_;
 740
 741         return('<p>');
 742 }
 743
 744
 745 sub _url
 746 {
 747         my ($gh, $url, $label) = @_;
 748
 749         if (!$label) {
 750                 $label = $url;
 751
 752                 if (length($label) > $gh->{'url-label-max'}) {
 753                         $label = substr($label, 0,
 754                                 $gh->{'url-label-max'}) . '...';
 755                 }
 756         }
 757
 758         return "<a href = \"$url\">$label</a>";
 759 }
 760
 761
 762 sub _strong
 763 {
 764         my ($gh, $str) = @_;
 765         return "<strong>$str</strong>";
 766 }
 767
 768
 769 sub _em
 770 {
 771         my ($gh, $str) = @_;
 772         return "<em>$str</em>";
 773 }
 774
 775
 776 sub _code
 777 {
 778         my ($gh, $str) = @_;
 779         return "<code class = 'literal'>$str</code>";
 780 }
 781
 782
 783 sub _funcname
 784 {
 785         my ($gh, $str) = @_;
 786         return "<code class = 'funcname'>$str</code>";
 787 }
 788
 789
 790 sub _varname
 791 {
 792         my ($gh, $str) = @_;
 793         return "<code class = 'var'>$str</code>";
 794 }
 795
 796
 797 sub _new_mode
 798 {
 799         my ($gh, $mode, $params) = @_;
 800
 801         if ($mode ne $gh->{'-mode'}) {
 802                 my $tag;
 803
 804                 # clean list levels
 805                 if ($gh->{'-mode'} eq 'ul') {
 806                         $gh->_push('</li>' . '</ul>' x scalar(@{$gh->{'-ul-levels'}}));
 807                 }
 808                 elsif ($gh->{'-mode'} eq 'ol') {
 809                         $gh->_push('</li>' . '</ol>' x scalar(@{$gh->{'-ol-levels'}}));
 810                 }
 811                 elsif ($gh->{'-mode'}) {
 812                         $gh->_push("</$gh->{'-mode'}>");
 813                 }
 814
 815                 # send new one
 816                 $tag = $params ? "<$mode $params>" : "<$mode>";
 817                 $gh->_push($tag) if $mode;
 818
 819                 $gh->{'-mode'} = $mode;
 820                 $gh->{'-mode-elems'} = 0;
 821
 822                 # clean previous lists
 823                 $gh->{'-ul-levels'} = undef;
 824                 $gh->{'-ol-levels'} = undef;
 825         }
 826 }
 827
 828
 829 sub _dl
 830 {
 831         my ($gh, $str) = @_;
 832         my ($ret) = '';
 833
 834         if ($gh->{'dl-as-dl'}) {
 835                 $gh->_new_mode('dl');
 836                 $ret .= "<dt><strong class = 'term'>$str</strong><dd>";
 837         }
 838         else {
 839                 $gh->_new_mode('table');
 840                 $ret .= "<tr><td valign = 'top'><strong class = 'term'>$1</strong>&nbsp;&nbsp;</td><td valign = 'top'>";
 841         }
 842
 843         return $ret;
 844 }
 845
 846
 847 sub _ul
 848 {
 849         my ($gh, $levels) = @_;
 850         my ($ret);
 851
 852         $ret = '';
 853
 854         if ($levels > 0) {
 855                 $ret .= '<ul>';
 856         }
 857         elsif ($levels < 0) {
 858                 $ret .= '</li></ul>' x abs($levels);
 859         }
 860
 861         if ($gh->{'-mode'} ne 'ul') {
 862                 $gh->{'-mode'} = 'ul';
 863         }
 864         else {
 865                 $ret .= '</li>' if $levels <= 0;
 866         }
 867
 868         $ret .= '<li>';
 869
 870         return $ret;
 871 }
 872
 873
 874 sub _ol
 875 {
 876         my ($gh, $levels) = @_;
 877         my ($ret);
 878
 879         $ret = '';
 880
 881         if ($levels > 0) {
 882                 $ret .= '<ol>';
 883         }
 884         elsif ($levels < 0) {
 885                 $ret .= '</li></ol>' x abs($levels);
 886         }
 887
 888         if ($gh->{'-mode'} ne 'ol') {
 889                 $gh->{'-mode'} = 'ol';
 890         }
 891         else {
 892                 $ret .= '</li>' if $levels <= 0;
 893         }
 894
 895         $ret .= '<li>';
 896
 897         return $ret;
 898 }
 899
 900
 901 sub _blockquote
 902 {
 903         my ($gh) = @_;
 904
 905         $gh->_new_mode('blockquote');
 906         return "\"";
 907 }
 908
 909
 910 sub _hr
 911 {
 912         my ($gh) = @_;
 913
 914         return "<hr size = '1' noshade = 'noshade'>";
 915 }
 916
 917
 918 sub __mkanchor
 919 {
 920         my $gh =        shift;
 921         my $a =         shift;
 922
 923         $a = lc($a);
 924         $a =~ s/[\"\'\/]//g;
 925         $a =~ s/\s/_/g;
 926         $a =~ s/<[^>]+>//g;
 927
 928         return $a;
 929 }
 930
 931
 932 sub _heading
 933 {
 934         my ($gh, $level, $l) = @_;
 935
 936         # creates a valid anchor
 937         my $a = $gh->__mkanchor($l);
 938
 939         $l = sprintf("<a name = '%s'></a>\n<h%d class = 'level$level'>%s</h%d>",
 940                 $a, $level+$gh->{'header-offset'},
 941                 $l, $level+$gh->{'header-offset'});
 942
 943         return $l;
 944 }
 945
 946
 947 sub _table
 948 {
 949         my ($gh, $str) = @_;
 950
 951         if ($gh->{'-mode'} eq 'table') {
 952                 my ($class) = '';
 953                 my (@spans) = $gh->_calc_col_span($str);
 954
 955                 # calculate CSS class, if any
 956                 if ($gh->{'class-oddeven'}) {
 957                         $class = "class = '" . ($gh->{'-tbl-row'} & 1) ? "odd'" : "even'";
 958                 }
 959
 960                 $str = "<tr $class>";
 961
 962                 # build columns
 963                 for (my $n = 0; $n < scalar(@{$gh->{'-table'}}); $n++) {
 964                         my ($i,$s);
 965
 966                         $i = ${$gh->{'-table'}}[$n];
 967                         $i = "&nbsp;" if $i =~ /^\s*$/;
 968
 969                         $s = " colspan = '$spans[$n]'" if $spans[$n] > 1;
 970
 971                         if ($gh->{'table-headers'} and $gh->{'-tbl-row'} == 1) {
 972                                 $str .= "<th $class $s>$i</th>";
 973                         }
 974                         else {
 975                                 $str .= "<td $class $s>$i</td>";
 976                         }
 977                 }
 978
 979                 $str .= '</tr>';
 980
 981                 @{$gh->{'-table'}} = ();
 982                 $gh->{'-tbl-row'}++;
 983         }
 984         else {
 985                 # new table
 986                 my ($params);
 987
 988                 $params = "border = '1'";
 989                 $params .= " width = '100\%'" if $gh->{'expand-tables'};
 990                 $params .= " align = 'center'" if $gh->{'center-tables'};
 991                 $params .= " class = 'oddeven'" if $gh->{'class-oddeven'};
 992
 993                 $gh->_new_mode('table', $params);
 994
 995                 @{$gh->{'-table'}} = ();
 996                 $gh->{'-tbl-row'} = 1;
 997                 $str = '';
 998         }
 999
1000         return $str;
1001 }
1002
1003
1004 sub _toc
1005 {
1006         my $gh = shift;
1007         my @t = ();
1008
1009         push(@t, "<div class = 'TOC'>");
1010
1011         my $l = 0;
1012
1013         foreach my $e (@{$gh->{index}}) {
1014                 # ignore level 1 headings
1015                 if ($e->[0] == 1) {
1016                         next;
1017                 }
1018
1019                 if ($l < $e->[0]) {
1020                         push(@t, '<ol>');
1021                 }
1022                 elsif ($l > $e->[0]) {
1023                         push(@t, '</ol>');
1024                 }
1025
1026                 $l = $e->[0];
1027
1028                 push(@t, sprintf("<li><a href = '#%s'>%s</a></li>",
1029                         $gh->__mkanchor($e->[1]), $e->[1]));
1030         }
1031
1032         while (--$l) {
1033                 push(@t, '</ol>');
1034         }
1035
1036         push(@t, "</div>");
1037
1038         return @t;
1039 }
1040
1041 ###########################################################
1042 # troff Driver
1043
1044 package Grutatxt::troff;
1045
1046 @ISA = ("Grutatxt");
1047
1048 =head2 troff Driver
1049
1050 The troff driver uses the B<-me> macros and B<tbl>. A
1051 good way to post-process this output (to PostScript in
1052 the example) could be by using
1053
1054  groff -t -me -Tps
1055
1056 The additional parameters for a new Grutatxt object are:
1057
1058 =over 4
1059
1060 =item I<normal-size>
1061
1062 The point size of normal text. By default is 10.
1063
1064 =item I<heading-sizes>
1065
1066 This argument must be a reference to an array containing
1067 the size in points of the 3 different heading levels. By
1068 default, level sizes are [ 20, 18, 15 ].
1069
1070 =item I<table-type>
1071
1072 The type of table to be rendered by B<tbl>. Can be
1073 I<allbox> (all lines rendered; this is the default value),
1074 I<box> (only outlined) or I<doublebox> (only outlined by
1075 a double line).
1076
1077 =back
1078
1079 =cut
1080
1081 sub new
1082 {
1083         my ($class, %args) = @_;
1084         my ($gh);
1085
1086         bless(\%args,$class);
1087         $gh = \%args;
1088
1089         $gh->{'-process-urls'} = 0;
1090
1091         $gh->{'heading-sizes'} ||= [ 20, 18, 15 ];
1092         $gh->{'normal-size'} ||= 10;
1093         $gh->{'table-type'} ||= "allbox"; # box, allbox, doublebox
1094
1095         return $gh;
1096 }
1097
1098
1099 sub _prefix
1100 {
1101         my ($gh) = @_;
1102
1103         $gh->_push(".nr pp $gh->{'normal-size'}");
1104         $gh->_push(".nh");
1105 }
1106
1107
1108 sub _inline
1109 {
1110         my ($gh,$l) = @_;
1111
1112         # accept only troff inlines
1113         if ($l =~ /^<<\s*troff$/i) {
1114                 $gh->{'-inline'} = 'troff';
1115                 return;
1116         }
1117
1118         if ($l =~ /^>>$/) {
1119                 delete $gh->{'-inline'};
1120                 return;
1121         }
1122
1123         if ($gh->{'-inline'} eq 'troff') {
1124                 $gh->_push($l);
1125         }
1126 }
1127
1128
1129 sub _escape
1130 {
1131         my ($gh,$l) = @_;
1132
1133         $l =~ s/\\/\\\\/g;
1134         $l =~ s/^'/\\&'/;
1135
1136         return $l;
1137 }
1138
1139
1140 sub _empty_line
1141 {
1142         my ($gh) = @_;
1143
1144         return '.lp';
1145 }
1146
1147
1148 sub _strong
1149 {
1150         my ($gh, $str) = @_;
1151         return "\\fB$str\\fP";
1152 }
1153
1154
1155 sub _em
1156 {
1157         my ($gh, $str) = @_;
1158         return "\\fI$str\\fP";
1159 }
1160
1161
1162 sub _code
1163 {
1164         my ($gh, $str) = @_;
1165         return "\\fI$str\\fP";
1166 }
1167
1168
1169 sub _funcname
1170 {
1171         my ($gh, $str) = @_;
1172         return "\\fB$str\\fP";
1173 }
1174
1175
1176 sub _varname
1177 {
1178         my ($gh, $str) = @_;
1179         return "\\fI$str\\fP";
1180 }
1181
1182
1183 sub _new_mode
1184 {
1185         my ($gh, $mode, $params) = @_;
1186
1187         if ($mode ne $gh->{'-mode'}) {
1188                 my $tag;
1189
1190                 # flush previous list
1191                 if ($gh->{'-mode'} eq 'pre') {
1192                         $gh->_push('.)l');
1193                 }
1194                 elsif ($gh->{'-mode'} eq 'table') {
1195                         chomp($gh->{'-table-head'});
1196                         $gh->{'-table-head'} =~ s/\s+$//;
1197                         $gh->_push($gh->{'-table-head'} . '.');
1198                         $gh->_push($gh->{'-table-body'} . '.TE\n.sp 0.6');
1199                 }
1200                 elsif ($gh->{'-mode'} eq 'blockquote') {
1201                         $gh->_push('.)q');
1202                 }
1203
1204                 # send new one
1205                 if ($mode eq 'pre') {
1206                         $gh->_push('.(l L');
1207                 }
1208                 elsif ($mode eq 'blockquote') {
1209                         $gh->_push('.(q');
1210                 }
1211
1212                 $gh->{'-mode'} = $mode;
1213         }
1214 }
1215
1216
1217 sub _dl
1218 {
1219         my ($gh, $str) = @_;
1220
1221         $gh->_new_mode('dl');
1222         return ".ip \"$str\"\n";
1223 }
1224
1225
1226 sub _ul
1227 {
1228         my ($gh) = @_;
1229
1230         $gh->_new_mode('ul');
1231         return ".bu\n";
1232 }
1233
1234
1235 sub _ol
1236 {
1237         my ($gh) = @_;
1238
1239         $gh->_new_mode('ol');
1240         return ".np\n";
1241 }
1242
1243
1244 sub _blockquote
1245 {
1246         my ($gh) = @_;
1247
1248         $gh->_new_mode('blockquote');
1249         return "\"";
1250 }
1251
1252
1253 sub _hr
1254 {
1255         my ($gh) = @_;
1256
1257         return '.hl';
1258 }
1259
1260
1261 sub _heading
1262 {
1263         my ($gh, $level, $l) = @_;
1264
1265         $l = '.sz ' . ${$gh->{'heading-sizes'}}[$level - 1] . "\n$l\n.sp 0.6";
1266
1267         return $l;
1268 }
1269
1270
1271 sub _table
1272 {
1273         my ($gh, $str) = @_;
1274
1275         if ($gh->{'-mode'} eq 'table') {
1276                 my ($h, $b);
1277                 my (@spans) = $gh->_calc_col_span($str);
1278
1279                 # build columns
1280                 $h = '';
1281                 $b = '';
1282                 for (my $n = 0; $n < scalar(@{$gh->{'-table'}}); $n++) {
1283                         my ($i);
1284
1285                         if ($gh->{'table-headers'} and $gh->{'-tbl-row'} == 1) {
1286                                 $h .= 'cB ';
1287                         }
1288                         else {
1289                                 $h .= 'l ';
1290                         }
1291
1292                         # add span columns
1293                         $h .= 's ' x ($spans[$n] - 1) if $spans[$n] > 1;
1294
1295                         $b .= '#' if $n;
1296
1297                         $i = ${$gh->{'-table'}}[$n];
1298                         $i =~ s/^\s+//;
1299                         $i =~ s/\s+$//;
1300                         $i =~ s/(\s)+/$1/g;
1301                         $b .= $i;
1302                 }
1303
1304                 # add a separator
1305                 $b .= "\n_" if $gh->{'table-headers'} and
1306                              $gh->{'-tbl-row'} == 1 and
1307                              $gh->{'table-type'} ne "allbox";
1308
1309                 $gh->{'-table-head'} .= "$h\n";
1310                 $gh->{'-table-body'} .= "$b\n";
1311
1312                 @{$gh->{'-table'}} = ();
1313                 $gh->{'-tbl-row'}++;
1314         }
1315         else {
1316                 # new table
1317                 $gh->_new_mode('table');
1318
1319                 @{$gh->{'-table'}} = ();
1320                 $gh->{'-tbl-row'} = 1;
1321
1322                 $gh->{'-table-head'} = ".TS\n$gh->{'table-type'} tab (#);\n";
1323                 $gh->{'-table-body'} = '';
1324         }
1325
1326         $str = '';
1327         return $str;
1328 }
1329
1330
1331 sub _postfix
1332 {
1333         my ($gh) = @_;
1334
1335         # add to top headings and footers
1336         unshift(@{$gh->{'o'}},".ef '\%' ''");
1337         unshift(@{$gh->{'o'}},".of '' '\%'");
1338         unshift(@{$gh->{'o'}},".eh '$gh->{'-title'}' ''");
1339         unshift(@{$gh->{'o'}},".oh '' '$gh->{'-title'}'");
1340 }
1341
1342
1343 ###########################################################
1344 # man Driver
1345
1346 package Grutatxt::man;
1347
1348 @ISA = ("Grutatxt::troff", "Grutatxt");
1349
1350 =head2 man Driver
1351
1352 The man driver is used to generate Unix-like man pages. Note that
1353 all headings have the same level with this output driver.
1354
1355 The additional parameters for a new Grutatxt object are:
1356
1357 =over 4
1358
1359 =item I<section>
1360
1361 The man page section (see man documentation). By default is 1.
1362
1363 =item I<page-name>
1364
1365 The name of the page. This is usually the name of the program
1366 or function the man page is documenting and will be shown in the
1367 page header. By default is the empty string.
1368
1369 =back
1370
1371 =cut
1372
1373 sub new
1374 {
1375         my ($class, %args) = @_;
1376         my ($gh);
1377
1378         bless(\%args,$class);
1379         $gh = \%args;
1380
1381         $gh->{'-process-urls'} = 0;
1382
1383         $gh->{'section'} ||= 1;
1384         $gh->{'page-name'} ||= "";
1385
1386         return $gh;
1387 }
1388
1389
1390 sub _prefix
1391 {
1392         my ($gh) = @_;
1393
1394         $gh->_push(".TH \"$gh->{'page-name'}\" \"$gh->{'section'}\" \"" . localtime() . "\"");
1395 }
1396
1397
1398 sub _inline
1399 {
1400         my ($gh, $l) = @_;
1401
1402         # accept only man markup inlines
1403         if ($l =~ /^<<\s*man$/i) {
1404                 $gh->{'-inline'} = 'man';
1405                 return;
1406         }
1407
1408         if ($l =~ /^>>$/) {
1409                 delete $gh->{'-inline'};
1410                 return;
1411         }
1412
1413         if ($gh->{'-inline'} eq 'man') {
1414                 $gh->_push($l);
1415         }
1416 }
1417
1418
1419 sub _empty_line
1420 {
1421         my ($gh) = @_;
1422
1423         return ' ';
1424 }
1425
1426
1427 sub _new_mode
1428 {
1429         my ($gh,$mode,$params) = @_;
1430
1431         if ($mode ne $gh->{'-mode'}) {
1432                 my $tag;
1433
1434                 # flush previous list
1435                 if ($gh->{'-mode'} eq 'pre' or
1436                    $gh->{'-mode'} eq 'table') {
1437                         $gh->_push('.fi');
1438                 }
1439
1440                 if ($gh->{'-mode'} eq 'blockquote') {
1441                         $gh->_push('.RE');
1442                 }
1443
1444                 if ($gh->{'-mode'} eq 'ul') {
1445                         $gh->_push(".RE\n" x scalar(@{$gh->{'-ul-levels'}}));
1446                 }
1447
1448                 if ($gh->{'-mode'} eq 'ol') {
1449                         $gh->_push(".RE\n" x scalar(@{$gh->{'-ol-levels'}}));
1450                 }
1451
1452                 # send new one
1453                 if ($mode eq 'pre' or $mode eq 'table') {
1454                         $gh->_push('.nf');
1455                 }
1456
1457                 if ($mode eq 'blockquote') {
1458                         $gh->_push('.RS 4');
1459                 }
1460
1461                 $gh->{'-mode'} = $mode;
1462         }
1463 }
1464
1465
1466 sub _dl
1467 {
1468         my ($gh, $str) = @_;
1469
1470         $gh->_new_mode('dl');
1471         return ".TP\n.B \"$str\"\n";
1472 }
1473
1474
1475 sub _ul
1476 {
1477         my ($gh, $levels) = @_;
1478         my ($ret) = '';
1479
1480         if ($levels > 0) {
1481                 $ret = ".RS 4\n";
1482         }
1483         elsif ($levels < 0) {
1484                 $ret = ".RE\n" x abs($levels);
1485         }
1486
1487         $gh->_new_mode('ul');
1488         return $ret . ".TP 4\n\\(bu\n";
1489 }
1490
1491
1492 sub _ol
1493 {
1494         my ($gh, $levels) = @_;
1495         my $l = @{$gh->{'-ol-levels'}};
1496         my $ret = '';
1497
1498         $gh->{'-ol-level'} += $levels;
1499
1500         if ($levels > 0) {
1501                 $ret = ".RS 4\n";
1502
1503                 $l[$gh->{'-ol-level'}] = 1;
1504         }
1505         elsif ($levels < 0) {
1506                 $ret = ".RE\n" x abs($levels);
1507         }
1508
1509         $gh->_new_mode('ol');
1510         $ret .= ".TP 4\n" . $l[$gh->{'-ol-level'}]++ . ".\n";
1511
1512         return $ret;
1513 }
1514
1515
1516 sub _hr
1517 {
1518         my ($gh) = @_;
1519
1520         return '';
1521 }
1522
1523
1524 sub _heading
1525 {
1526         my ($gh, $level, $l) = @_;
1527
1528         # all headers are the same depth in man pages
1529         return ".SH \"" . uc($l) . "\"";
1530 }
1531
1532
1533 sub _table
1534 {
1535         my ($gh, $str) = @_;
1536
1537         if ($gh->{'-mode'} eq 'table') {
1538                 foreach my $r (@{$gh->{'-table-raw'}}) {
1539                         $gh->_push("|$r|");
1540                 }
1541         }
1542         else {
1543                 $gh->_new_mode('table');
1544         }
1545
1546         @{$gh->{'-table'}} = ();
1547         @{$gh->{'-table-raw'}} = ();
1548
1549         $gh->_push($str);
1550
1551         return '';
1552 }
1553
1554
1555 sub _postfix
1556 {
1557 }
1558
1559
1560 ###########################################################
1561 # latex Driver
1562
1563 package Grutatxt::latex;
1564
1565 @ISA = ("Grutatxt");
1566
1567 =head2 LaTeX Driver
1568
1569 The additional parameters for a new Grutatxt object are:
1570
1571 =over 4
1572
1573 =item I<docclass>
1574
1575 The LaTeX document class. By default is 'report'. You can also use
1576 'article' or 'book' (consult your LaTeX documentation for details).
1577
1578 =item I<papersize>
1579
1580 The paper size to be used in the document. By default is 'a4paper'.
1581
1582 =item I<encoding>
1583
1584 The character encoding used in the document. By default is 'latin1'.
1585
1586 =back
1587
1588 Note that you can't nest further than 4 levels in LaTeX; if you do,
1589 LaTeX will choke in the generated code with a 'Too deeply nested' error.
1590
1591 =cut
1592
1593 sub new
1594 {
1595         my ($class, %args) = @_;
1596         my ($gh);
1597
1598         bless(\%args,$class);
1599         $gh = \%args;
1600
1601         $gh->{'-process-urls'} = 0;
1602
1603         $gh->{'-docclass'} ||= 'report';
1604         $gh->{'-papersize'} ||= 'a4paper';
1605         $gh->{'-encoding'} ||= 'latin1';
1606
1607         return $gh;
1608 }
1609
1610
1611 sub _prefix
1612 {
1613         my ($gh) = @_;
1614
1615         $gh->_push("\\documentclass[$gh->{'-papersize'}]{$gh->{-docclass}}");
1616         $gh->_push("\\usepackage[$gh->{'-encoding'}]{inputenc}");
1617
1618         $gh->_push("\\begin{document}");
1619 }
1620
1621
1622 sub _inline
1623 {
1624         my ($gh, $l) = @_;
1625
1626         # accept only latex inlines
1627         if ($l =~ /^<<\s*latex$/i) {
1628                 $gh->{'-inline'} = 'latex';
1629                 return;
1630         }
1631
1632         if ($l =~ /^>>$/) {
1633                 delete $gh->{'-inline'};
1634                 return;
1635         }
1636
1637         if ($gh->{'-inline'} eq 'latex') {
1638                 $gh->_push($l);
1639         }
1640 }
1641
1642
1643 sub _escape
1644 {
1645         my ($gh, $l) = @_;
1646
1647         $l =~ s/ _ / \\_ /g;
1648         $l =~ s/ ~ / \\~ /g;
1649         $l =~ s/ & / \\& /g;
1650
1651         return $l;
1652 }
1653
1654
1655 sub _escape_post
1656 {
1657         my ($gh, $l) = @_;
1658
1659         $l =~ s/ # / \\# /g;
1660         $l =~ s/^\\n$//g;
1661         $l =~ s/([^\s_])_([^\s_])/$1\\_$2/g;
1662
1663         return $l;
1664 }
1665
1666
1667 sub _empty_line
1668 {
1669         my ($gh) = @_;
1670
1671         return "\\n";
1672 }
1673
1674
1675 sub _strong
1676 {
1677         my ($gh, $str) = @_;
1678         return "\\textbf{$str}";
1679 }
1680
1681
1682 sub _em
1683 {
1684         my ($gh, $str) = @_;
1685         return "\\emph{$str}";
1686 }
1687
1688
1689 sub _code
1690 {
1691         my ($gh, $str) = @_;
1692         return "{\\tt $str}";
1693 }
1694
1695
1696 sub _funcname
1697 {
1698         my ($gh, $str) = @_;
1699         return "{\\tt $str}";
1700 }
1701
1702
1703 sub _varname
1704 {
1705         my ($gh, $str) = @_;
1706
1707         $str =~ s/^\$/\\\$/;
1708
1709         return "{\\tt $str}";
1710 }
1711
1712
1713 sub _new_mode
1714 {
1715         my ($gh, $mode, $params) = @_;
1716
1717         # mode equivalences
1718         my %latex_modes = (
1719                 'pre'           =>      'verbatim',
1720                 'blockquote'    =>      'quote',
1721                 'table'         =>      'tabular',
1722                 'dl'            =>      'description',
1723                 'ul'            =>      'itemize',
1724                 'ol'            =>      'enumerate'
1725         );
1726
1727         if ($mode ne $gh->{'-mode'}) {
1728                 # close previous mode
1729                 if ($gh->{'-mode'} eq 'ul') {
1730                         $gh->_push("\\end{itemize}" x scalar(@{$gh->{'-ul-levels'}}));
1731                 }
1732                 elsif ($gh->{'-mode'} eq 'ol') {
1733                         $gh->_push("\\end{enumerate}" x scalar(@{$gh->{'-ol-levels'}}));
1734                 }
1735                 elsif ($gh->{'-mode'} eq 'table') {
1736                         $gh->_push("\\end{tabular}\n");
1737                 }
1738                 else {
1739                         $gh->_push("\\end{" . $latex_modes{$gh->{'-mode'}} . "}")
1740                         if $gh->{'-mode'};
1741                 }
1742
1743                 # send new one
1744                 $gh->_push("\\begin{" . $latex_modes{$mode} . "}" . $params)
1745                         if $mode;
1746
1747                 $gh->{'-mode'} = $mode;
1748
1749                 $gh->{'-ul-levels'} = undef;
1750                 $gh->{'-ol-levels'} = undef;
1751         }
1752 }
1753
1754
1755 sub _dl
1756 {
1757         my ($gh, $str) = @_;
1758
1759         $gh->_new_mode('dl');
1760         return "\\item[$str]\n";
1761 }
1762
1763
1764 sub _ul
1765 {
1766         my ($gh, $levels) = @_;
1767         my ($ret);
1768
1769         $ret = '';
1770
1771         if ($levels > 0) {
1772                 $ret .= "\\begin{itemize}\n";
1773         }
1774         elsif ($levels < 0) {
1775                 $ret .= "\\end{itemize}\n" x abs($levels);
1776         }
1777
1778         $gh->{'-mode'} = 'ul';
1779
1780         $ret .= "\\item\n";
1781
1782         return $ret;
1783 }
1784
1785
1786 sub _ol
1787 {
1788         my ($gh, $levels) = @_;
1789         my ($ret);
1790
1791         $ret = '';
1792
1793         if ($levels > 0) {
1794                 $ret .= "\\begin{enumerate}\n";
1795         }
1796         elsif ($levels < 0) {
1797                 $ret .= "\\end{enumerate}\n" x abs($levels);
1798         }
1799
1800         $gh->{'-mode'} = 'ol';
1801
1802         $ret .= "\\item\n";
1803
1804         return $ret;
1805 }
1806
1807
1808 sub _blockquote
1809 {
1810         my ($gh) = @_;
1811
1812         $gh->_new_mode('blockquote');
1813         return "``";
1814 }
1815
1816
1817 sub _hr
1818 {
1819         my ($gh) = @_;
1820
1821         return "------------\n";
1822 }
1823
1824
1825 sub _heading
1826 {
1827         my ($gh, $level, $l) = @_;
1828
1829         my @latex_headings = ( "\\section*{", "\\subsection*{",
1830                 "\\subsubsection*{");
1831
1832         $l = "\n" . $latex_headings[$level - 1] . $l . "}";
1833
1834         return $l;
1835 }
1836
1837
1838 sub _table
1839 {
1840         my ($gh,$str) = @_;
1841
1842         if ($gh->{'-mode'} eq 'table') {
1843                 my ($class) = '';
1844                 my (@spans) = $gh->_calc_col_span($str);
1845                 my (@cols);
1846
1847                 $str = '';
1848
1849                 # build columns
1850                 for (my $n = 0; $n < scalar(@{$gh->{'-table'}}); $n++) {
1851                         my ($i, $s);
1852
1853                         $i = ${$gh->{'-table'}}[$n];
1854                         $i = "&nbsp;" if $i =~ /^\s*$/;
1855
1856 #                       $s = " colspan='$spans[$n]'" if $spans[$n] > 1;
1857
1858                         # multispan columns
1859                         $i = "\\multicolumn{$spans[$n]}{|l|}{$i}"
1860                                 if $spans[$n] > 1;
1861
1862                         $i =~ s/\s{2,}/ /g;
1863                         $i =~ s/^\s+//;
1864                         $i =~ s/\s+$//;
1865
1866                         push(@cols, $i);
1867                 }
1868
1869                 $str .= join('&', @cols) . "\\\\\n\\hline";
1870
1871 #               $str .= "\n\\hline" if $gh->{'-tbl-row'} == 1;
1872
1873                 @{$gh->{'-table'}} = ();
1874                 $gh->{'-tbl-row'}++;
1875         }
1876         else {
1877                 # new table
1878
1879                 # count the number of columns
1880                 $str =~ s/[^\+]//g;
1881                 my $params = "{" . "|l" x (length($str) - 1) . "|}\n\\hline";
1882
1883                 $gh->_push();
1884                 $gh->_new_mode('table', $params);
1885
1886                 @{$gh->{'-table'}} = ();
1887                 $gh->{'-tbl-row'} = 1;
1888                 $str = '';
1889         }
1890
1891         return $str;
1892 }
1893
1894
1895 sub _postfix
1896 {
1897         my ($gh) = @_;
1898
1899         $gh->_push("\\end{document}");
1900 }
1901
1902
1903 ###########################################################
1904 # RTF Driver
1905
1906 package Grutatxt::rtf;
1907
1908 @ISA = ("Grutatxt");
1909
1910 =head2 RTF Driver
1911
1912 The additional parameters for a new Grutatxt object are:
1913
1914 =over 4
1915
1916 =item I<normal-size>
1917
1918 The point size of normal text. By default is 20.
1919
1920 =item I<heading-sizes>
1921
1922 This argument must be a reference to an array containing
1923 the size in points of the 3 different heading levels. By
1924 default, level sizes are [ 34, 30, 28 ].
1925
1926 =back
1927
1928 =cut
1929
1930 sub new
1931 {
1932         my ($class, %args) = @_;
1933         my ($gh);
1934
1935         bless(\%args, $class);
1936         $gh = \%args;
1937
1938         $gh->{'-process-urls'} = 0;
1939
1940         $gh->{'heading-sizes'} ||= [ 34, 30, 28 ];
1941         $gh->{'normal-size'} ||= 20;
1942
1943         return $gh;
1944 }
1945
1946
1947 sub _prefix
1948 {
1949         my $gh = shift;
1950
1951         $gh->_push('{\rtf1\ansi {\plain \fs' . $gh->{'normal-size'} . ' \sa227');
1952 }
1953
1954
1955 sub _empty_line
1956 {
1957         my $gh = shift;
1958
1959         return '\par';
1960 }
1961
1962
1963 sub _heading
1964 {
1965         my ($gh, $level, $l) = @_;
1966
1967         return '{\b \fs' . $gh->{'heading-sizes'}->[$level] . ' ' . $l . '}';
1968 }
1969
1970
1971 sub _strong
1972 {
1973         my ($gh, $str) = @_;
1974         return "{\\b $str}";
1975 }
1976
1977
1978 sub _em
1979 {
1980         my ($gh, $str) = @_;
1981         return "{\\i $str}";
1982 }
1983
1984
1985 sub _code
1986 {
1987         my ($gh, $str) = @_;
1988         return "{\\tt $str}";
1989 }
1990
1991
1992 sub _ul
1993 {
1994         my ($gh, $levels) = @_;
1995
1996         $gh->_new_mode('ul');
1997         return "{{\\bullet \\li" . $levels . ' ';
1998 }
1999
2000
2001 sub _dl
2002 {
2003         my ($gh, $str) = @_;
2004
2005         $gh->_new_mode('dl');
2006         return "{{\\b $str \\par} {\\li566 ";
2007 }
2008
2009
2010 sub _new_mode
2011 {
2012         my ($gh, $mode, $params) = @_;
2013
2014         if ($mode ne $gh->{'-mode'}) {
2015                 if ($gh->{'-mode'} =~ /^(dl|ul)$/) {
2016                         $gh->_push('}}');
2017                 }
2018
2019                 $gh->{'-mode'} = $mode;
2020
2021                 $gh->{'-ul-levels'} = undef;
2022                 $gh->{'-ol-levels'} = undef;
2023         }
2024         else {
2025                 if ($mode =~ /^(dl|ul)$/) {
2026                         $gh->_push('}\par}');
2027                 }
2028         }
2029 }
2030
2031
2032 sub _postfix
2033 {
2034         my $gh = shift;
2035
2036         @{$gh->{o}} = map { $_ . ' '; } @{$gh->{o}};
2037
2038         $gh->_push('}}');
2039 }
2040
2041
2042 =head1 AUTHOR
2043
2044 Angel Ortega angel@triptico.com
2045
2046 =cut
2047
2048 1;