Grutatxt.pm

   1 #####################################################################
   2 #
   3 #   Grutatxt - A text to HTML (and other things) converter
   4 #
   5 #   Copyright (C) 2000/2011 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.17-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     my $is_title = 0;
 474
 475     $l = pop(@{$gh->{'o'}});
 476
 477     if ($l eq $gh->_empty_line()) {
 478         $gh->_push($l);
 479         return $hd;
 480     }
 481
 482     # store title
 483     if ($level == 1 and not $gh->{'-title'}) {
 484         $gh->{'-title'} = $l;
 485         $is_title = 1;
 486     }
 487
 488     # store index
 489     if (ref($gh->{'index'})) {
 490         push(@{$gh->{'index'}}, [ $level, $l ]);
 491     }
 492
 493     return $gh->_heading($level, $l, $is_title);
 494 }
 495
 496
 497 sub _calc_col_span
 498 {
 499         my ($gh, $l) = @_;
 500         my (@spans);
 501
 502         # strip first + and all -
 503         $l =~ s/^\+//;
 504         $l =~ s/-//g;
 505
 506         my ($t) = 1; @spans = ();
 507         for (my $n = 0; $n < length($l); $n++) {
 508                 if (substr($l, $n, 1) eq '+') {
 509                         push(@spans, $t);
 510                         $t = 1;
 511                 }
 512                 else {
 513                         # it's a colspan mark:
 514                         # increment
 515                         $t++;
 516                 }
 517         }
 518
 519         return @spans;
 520 }
 521
 522
 523 sub _table_row
 524 {
 525         my ($gh, $str) = @_;
 526
 527         my @s = split(/\|/,$str);
 528
 529         for (my $n = 0; $n < scalar(@s); $n++) {
 530                 ${$gh->{'-table'}}[$n] .= ' ' . $s[$n];
 531         }
 532
 533         push(@{$gh->{'-table-raw'}}, $str);
 534
 535         return '';
 536 }
 537
 538
 539 sub _pre
 540 {
 541         my ($gh, $l) = @_;
 542
 543         # if any other mode is active, add to it
 544         if ($gh->{'-mode'} and $gh->{'-mode'} ne 'pre') {
 545                 $l =~ s/^\s+//;
 546
 547                 my ($a) = pop(@{$gh->{'o'}})." ".$l;
 548                 $gh->_push($a);
 549                 $l = '';
 550         }
 551         else {
 552                 # tabs to spaces if a non-zero tabsize is given (only in LaTex)
 553                 $l =~ s/\t/' ' x $gh->{'tabsize'}/ge if $gh->{'tabsize'} > 0;
 554
 555                 $gh->_new_mode('pre');
 556         }
 557
 558         return $l;
 559 }
 560
 561
 562 sub _multilevel_list
 563 {
 564         my ($gh, $str, $ind) = @_;
 565         my (@l,$level);
 566
 567         @l = @{$gh->{$str}};
 568         $ind = length($ind);
 569         $level = 0;
 570
 571         if ($l[-1] < $ind) {
 572                 # if last level is less indented, increase
 573                 # nesting level
 574                 push(@l, $ind);
 575                 $level++;
 576         }
 577         elsif ($l[-1] > $ind) {
 578                 # if last level is more indented, decrease
 579                 # levels until the same is found (or back to
 580                 # the beginning if not)
 581                 while (pop(@l)) {
 582                         $level--;
 583                         last if $l[-1] == $ind;
 584                 }
 585         }
 586
 587         $gh->{$str} = \@l;
 588
 589         return $level;
 590 }
 591
 592
 593 sub _unsorted_list
 594 {
 595         my ($gh, $ind) = @_;
 596
 597         return $gh->_ul($gh->_multilevel_list('-ul-levels', $ind));
 598 }
 599
 600
 601 sub _ordered_list
 602 {
 603         my ($gh, $ind) = @_;
 604
 605         return $gh->_ol($gh->_multilevel_list('-ol-levels', $ind));
 606 }
 607
 608
 609 # empty stubs for falling through the superclass
 610
 611 sub _inline { my ($gh, $l) = @_; $l; }
 612 sub _escape { my ($gh, $l) = @_; $l; }
 613 sub _escape_post { my ($gh, $l) = @_; $l; }
 614 sub _empty_line { my ($gh) = @_; ''; }
 615 sub _url { my ($gh, $url, $label) = @_; ''; }
 616 sub _strong { my ($gh, $str) = @_; $str; }
 617 sub _em { my ($gh, $str) = @_; $str; }
 618 sub _code { my ($gh, $str) = @_; $str; }
 619 sub _funcname { my ($gh, $str) = @_; $str; }
 620 sub _varname { my ($gh, $str) = @_; $str; }
 621 sub _new_mode { my ($gh, $mode) = @_; }
 622 sub _dl { my ($gh, $str) = @_; $str; }
 623 sub _ul { my ($gh, $level) = @_; ''; }
 624 sub _ol { my ($gh, $level) = @_; ''; }
 625 sub _blockquote { my ($gh, $str) = @_; $str; }
 626 sub _hr { my ($gh) = @_; ''; }
 627 sub _heading { my ($gh, $level, $l) = @_; $l; }
 628 sub _table { my ($gh, $str) = @_; $str; }
 629 sub _prefix { my ($gh) = @_; }
 630 sub _postfix { my ($gh) = @_; }
 631 sub _toc { my ($gh) = @_; return (); }
 632
 633 ###########################################################
 634
 635 =head1 DRIVER SPECIFIC INFORMATION
 636
 637 =cut
 638
 639 ###########################################################
 640 # HTML Driver
 641
 642 package Grutatxt::HTML;
 643
 644 @ISA = ("Grutatxt");
 645
 646 =head2 HTML Driver
 647
 648 The additional parameters for a new Grutatxt object are:
 649
 650 =over 4
 651
 652 =item I<table-headers>
 653
 654 If this boolean value is set, the first row in tables
 655 is assumed to be the heading and rendered using 'th'
 656 instead of 'td' tags.
 657
 658 =item I<center-tables>
 659
 660 If this boolean value is set, tables are centered.
 661
 662 =item I<expand-tables>
 663
 664 If this boolean value is set, tables are expanded (width 100%).
 665
 666 =item I<dl-as-dl>
 667
 668 If this boolean value is set, definition lists will be
 669 rendered using 'dl', 'dt' and 'dd' instead of tables.
 670
 671 =item I<header-offset>
 672
 673 Offset to be summed to the heading level when rendering
 674 'h?' tags (default is 0).
 675
 676 =item I<class-oddeven>
 677
 678 If this boolean value is set, tables will be rendered
 679 with an "oddeven" CSS class, and rows alternately classed
 680 as "even" or "odd". If it's not set, no CSS class info
 681 is added to tables.
 682
 683 =item I<url-label-max>
 684
 685 If an URL without label is given (that is, the URL itself
 686 is used as the label), it's trimmed to have as much
 687 characters as this value says. By default it's 80.
 688
 689 =back
 690
 691 =cut
 692
 693 sub new
 694 {
 695         my ($class, %args) = @_;
 696         my ($gh);
 697
 698         bless(\%args, $class);
 699         $gh = \%args;
 700
 701         $gh->{'-process-urls'} = 1;
 702         $gh->{'url-label-max'} ||= 80;
 703
 704         return $gh;
 705 }
 706
 707
 708 sub _inline
 709 {
 710         my ($gh, $l) = @_;
 711
 712         # accept unnamed and HTML inlines
 713         if ($l =~ /^<<$/ or $l =~ /^<<\s*html$/i) {
 714                 $gh->{'-inline'} = 'HTML';
 715                 return;
 716         }
 717
 718         if ($l =~ /^>>$/) {
 719                 delete $gh->{'-inline'};
 720                 return;
 721         }
 722
 723         if ($gh->{'-inline'} eq 'HTML') {
 724                 $gh->_push($l);
 725         }
 726 }
 727
 728
 729 sub _escape
 730 {
 731         my ($gh, $l) = @_;
 732
 733         $l =~ s/&/&amp;/g;
 734         $l =~ s/</&lt;/g;
 735         $l =~ s/>/&gt;/g;
 736
 737         return $l;
 738 }
 739
 740
 741 sub _empty_line
 742 {
 743         my ($gh) = @_;
 744
 745         return('<p>');
 746 }
 747
 748
 749 sub _url
 750 {
 751         my ($gh, $url, $label) = @_;
 752
 753         if (!$label) {
 754                 $label = $url;
 755
 756                 if (length($label) > $gh->{'url-label-max'}) {
 757                         $label = substr($label, 0,
 758                                 $gh->{'url-label-max'}) . '...';
 759                 }
 760         }
 761
 762         return "<a href = \"$url\">$label</a>";
 763 }
 764
 765
 766 sub _strong
 767 {
 768         my ($gh, $str) = @_;
 769         return "<strong>$str</strong>";
 770 }
 771
 772
 773 sub _em
 774 {
 775         my ($gh, $str) = @_;
 776         return "<em>$str</em>";
 777 }
 778
 779
 780 sub _code
 781 {
 782         my ($gh, $str) = @_;
 783         return "<code class = 'literal'>$str</code>";
 784 }
 785
 786
 787 sub _funcname
 788 {
 789         my ($gh, $str) = @_;
 790         return "<code class = 'funcname'>$str</code>";
 791 }
 792
 793
 794 sub _varname
 795 {
 796         my ($gh, $str) = @_;
 797         return "<code class = 'var'>$str</code>";
 798 }
 799
 800
 801 sub _new_mode
 802 {
 803         my ($gh, $mode, $params) = @_;
 804
 805         if ($mode ne $gh->{'-mode'}) {
 806                 my $tag;
 807
 808                 # clean list levels
 809                 if ($gh->{'-mode'} eq 'ul') {
 810                         $gh->_push('</li>' . '</ul>' x scalar(@{$gh->{'-ul-levels'}}));
 811                 }
 812                 elsif ($gh->{'-mode'} eq 'ol') {
 813                         $gh->_push('</li>' . '</ol>' x scalar(@{$gh->{'-ol-levels'}}));
 814                 }
 815                 elsif ($gh->{'-mode'}) {
 816                         $gh->_push("</$gh->{'-mode'}>");
 817                 }
 818
 819                 # send new one
 820                 $tag = $params ? "<$mode $params>" : "<$mode>";
 821                 $gh->_push($tag) if $mode;
 822
 823                 $gh->{'-mode'} = $mode;
 824                 $gh->{'-mode-elems'} = 0;
 825
 826                 # clean previous lists
 827                 $gh->{'-ul-levels'} = undef;
 828                 $gh->{'-ol-levels'} = undef;
 829         }
 830 }
 831
 832
 833 sub _dl
 834 {
 835         my ($gh, $str) = @_;
 836         my ($ret) = '';
 837
 838         if ($gh->{'dl-as-dl'}) {
 839                 $gh->_new_mode('dl');
 840                 $ret .= "<dt><strong class = 'term'>$str</strong><dd>";
 841         }
 842         else {
 843                 $gh->_new_mode('table');
 844                 $ret .= "<tr><td valign = 'top'><strong class = 'term'>$1</strong>&nbsp;&nbsp;</td><td valign = 'top'>";
 845         }
 846
 847         return $ret;
 848 }
 849
 850
 851 sub _ul
 852 {
 853         my ($gh, $levels) = @_;
 854         my ($ret);
 855
 856         $ret = '';
 857
 858         if ($levels > 0) {
 859                 $ret .= '<ul>';
 860         }
 861         elsif ($levels < 0) {
 862                 $ret .= '</li></ul>' x abs($levels);
 863         }
 864
 865         if ($gh->{'-mode'} ne 'ul') {
 866                 $gh->{'-mode'} = 'ul';
 867         }
 868         else {
 869                 $ret .= '</li>' if $levels <= 0;
 870         }
 871
 872         $ret .= '<li>';
 873
 874         return $ret;
 875 }
 876
 877
 878 sub _ol
 879 {
 880         my ($gh, $levels) = @_;
 881         my ($ret);
 882
 883         $ret = '';
 884
 885         if ($levels > 0) {
 886                 $ret .= '<ol>';
 887         }
 888         elsif ($levels < 0) {
 889                 $ret .= '</li></ol>' x abs($levels);
 890         }
 891
 892         if ($gh->{'-mode'} ne 'ol') {
 893                 $gh->{'-mode'} = 'ol';
 894         }
 895         else {
 896                 $ret .= '</li>' if $levels <= 0;
 897         }
 898
 899         $ret .= '<li>';
 900
 901         return $ret;
 902 }
 903
 904
 905 sub _blockquote
 906 {
 907         my ($gh) = @_;
 908
 909         $gh->_new_mode('blockquote');
 910         return "\"";
 911 }
 912
 913
 914 sub _hr
 915 {
 916         my ($gh) = @_;
 917
 918         return "<hr size = '1' noshade = 'noshade'>";
 919 }
 920
 921
 922 sub __mkanchor
 923 {
 924         my $gh =        shift;
 925         my $a =         shift;
 926
 927         $a = lc($a);
 928         $a =~ s/[\"\'\/]//g;
 929         $a =~ s/\s/_/g;
 930         $a =~ s/<[^>]+>//g;
 931
 932         return $a;
 933 }
 934
 935
 936 sub _heading
 937 {
 938     my ($gh, $level, $l, $title) = @_;
 939
 940     # creates a valid anchor
 941     my $a = $gh->__mkanchor($l);
 942
 943     $l = sprintf(
 944         "<a %s name = '%s'></a>\n<h%d class = 'level$level'>%s</h%d>",
 945         $title ? "class = 'title'" : '',
 946         $a,
 947         $level + $gh->{'header-offset'},
 948         $l,
 949         $level + $gh->{'header-offset'}
 950     );
 951
 952     return $l;
 953 }
 954
 955
 956 sub _table
 957 {
 958         my ($gh, $str) = @_;
 959
 960         if ($gh->{'-mode'} eq 'table') {
 961                 my ($class) = '';
 962                 my (@spans) = $gh->_calc_col_span($str);
 963
 964                 # calculate CSS class, if any
 965                 if ($gh->{'class-oddeven'}) {
 966                         $class = "class = '" . ($gh->{'-tbl-row'} & 1) ? "odd'" : "even'";
 967                 }
 968
 969                 $str = "<tr $class>";
 970
 971                 # build columns
 972                 for (my $n = 0; $n < scalar(@{$gh->{'-table'}}); $n++) {
 973                         my ($i,$s);
 974
 975                         $i = ${$gh->{'-table'}}[$n];
 976                         $i = "&nbsp;" if $i =~ /^\s*$/;
 977
 978                         $s = " colspan = '$spans[$n]'" if $spans[$n] > 1;
 979
 980                         if ($gh->{'table-headers'} and $gh->{'-tbl-row'} == 1) {
 981                                 $str .= "<th $class $s>$i</th>";
 982                         }
 983                         else {
 984                                 $str .= "<td $class $s>$i</td>";
 985                         }
 986                 }
 987
 988                 $str .= '</tr>';
 989
 990                 @{$gh->{'-table'}} = ();
 991                 $gh->{'-tbl-row'}++;
 992         }
 993         else {
 994                 # new table
 995                 my ($params);
 996
 997                 $params = "border = '1'";
 998                 $params .= " width = '100\%'" if $gh->{'expand-tables'};
 999                 $params .= " align = 'center'" if $gh->{'center-tables'};
1000                 $params .= " class = 'oddeven'" if $gh->{'class-oddeven'};
1001
1002                 $gh->_new_mode('table', $params);
1003
1004                 @{$gh->{'-table'}} = ();
1005                 $gh->{'-tbl-row'} = 1;
1006                 $str = '';
1007         }
1008
1009         return $str;
1010 }
1011
1012
1013 sub _toc
1014 {
1015         my $gh = shift;
1016         my @t = ();
1017
1018         push(@t, "<div class = 'TOC'>");
1019
1020         my $l = 0;
1021
1022         foreach my $e (@{$gh->{index}}) {
1023                 # ignore level 1 headings
1024                 if ($e->[0] == 1) {
1025                         next;
1026                 }
1027
1028                 if ($l < $e->[0]) {
1029                         push(@t, '<ol>');
1030                 }
1031                 elsif ($l > $e->[0]) {
1032                         push(@t, '</ol>');
1033                 }
1034
1035                 $l = $e->[0];
1036
1037                 push(@t, sprintf("<li><a href = '#%s'>%s</a></li>",
1038                         $gh->__mkanchor($e->[1]), $e->[1]));
1039         }
1040
1041         while (--$l) {
1042                 push(@t, '</ol>');
1043         }
1044
1045         push(@t, "</div>");
1046
1047         return @t;
1048 }
1049
1050 ###########################################################
1051 # troff Driver
1052
1053 package Grutatxt::troff;
1054
1055 @ISA = ("Grutatxt");
1056
1057 =head2 troff Driver
1058
1059 The troff driver uses the B<-me> macros and B<tbl>. A
1060 good way to post-process this output (to PostScript in
1061 the example) could be by using
1062
1063  groff -t -me -Tps
1064
1065 The additional parameters for a new Grutatxt object are:
1066
1067 =over 4
1068
1069 =item I<normal-size>
1070
1071 The point size of normal text. By default is 10.
1072
1073 =item I<heading-sizes>
1074
1075 This argument must be a reference to an array containing
1076 the size in points of the 3 different heading levels. By
1077 default, level sizes are [ 20, 18, 15 ].
1078
1079 =item I<table-type>
1080
1081 The type of table to be rendered by B<tbl>. Can be
1082 I<allbox> (all lines rendered; this is the default value),
1083 I<box> (only outlined) or I<doublebox> (only outlined by
1084 a double line).
1085
1086 =back
1087
1088 =cut
1089
1090 sub new
1091 {
1092         my ($class, %args) = @_;
1093         my ($gh);
1094
1095         bless(\%args,$class);
1096         $gh = \%args;
1097
1098         $gh->{'-process-urls'} = 0;
1099
1100         $gh->{'heading-sizes'} ||= [ 20, 18, 15 ];
1101         $gh->{'normal-size'} ||= 10;
1102         $gh->{'table-type'} ||= "allbox"; # box, allbox, doublebox
1103
1104         return $gh;
1105 }
1106
1107
1108 sub _prefix
1109 {
1110         my ($gh) = @_;
1111
1112         $gh->_push(".nr pp $gh->{'normal-size'}");
1113         $gh->_push(".nh");
1114 }
1115
1116
1117 sub _inline
1118 {
1119         my ($gh,$l) = @_;
1120
1121         # accept only troff inlines
1122         if ($l =~ /^<<\s*troff$/i) {
1123                 $gh->{'-inline'} = 'troff';
1124                 return;
1125         }
1126
1127         if ($l =~ /^>>$/) {
1128                 delete $gh->{'-inline'};
1129                 return;
1130         }
1131
1132         if ($gh->{'-inline'} eq 'troff') {
1133                 $gh->_push($l);
1134         }
1135 }
1136
1137
1138 sub _escape
1139 {
1140         my ($gh,$l) = @_;
1141
1142         $l =~ s/\\/\\\\/g;
1143         $l =~ s/^'/\\&'/;
1144
1145         return $l;
1146 }
1147
1148
1149 sub _empty_line
1150 {
1151         my ($gh) = @_;
1152
1153         return '.lp';
1154 }
1155
1156
1157 sub _strong
1158 {
1159         my ($gh, $str) = @_;
1160         return "\\fB$str\\fP";
1161 }
1162
1163
1164 sub _em
1165 {
1166         my ($gh, $str) = @_;
1167         return "\\fI$str\\fP";
1168 }
1169
1170
1171 sub _code
1172 {
1173         my ($gh, $str) = @_;
1174         return "\\fI$str\\fP";
1175 }
1176
1177
1178 sub _funcname
1179 {
1180         my ($gh, $str) = @_;
1181         return "\\fB$str\\fP";
1182 }
1183
1184
1185 sub _varname
1186 {
1187         my ($gh, $str) = @_;
1188         return "\\fI$str\\fP";
1189 }
1190
1191
1192 sub _new_mode
1193 {
1194         my ($gh, $mode, $params) = @_;
1195
1196         if ($mode ne $gh->{'-mode'}) {
1197                 my $tag;
1198
1199                 # flush previous list
1200                 if ($gh->{'-mode'} eq 'pre') {
1201                         $gh->_push('.)l');
1202                 }
1203                 elsif ($gh->{'-mode'} eq 'table') {
1204                         chomp($gh->{'-table-head'});
1205                         $gh->{'-table-head'} =~ s/\s+$//;
1206                         $gh->_push($gh->{'-table-head'} . '.');
1207                         $gh->_push($gh->{'-table-body'} . '.TE\n.sp 0.6');
1208                 }
1209                 elsif ($gh->{'-mode'} eq 'blockquote') {
1210                         $gh->_push('.)q');
1211                 }
1212
1213                 # send new one
1214                 if ($mode eq 'pre') {
1215                         $gh->_push('.(l L');
1216                 }
1217                 elsif ($mode eq 'blockquote') {
1218                         $gh->_push('.(q');
1219                 }
1220
1221                 $gh->{'-mode'} = $mode;
1222         }
1223 }
1224
1225
1226 sub _dl
1227 {
1228         my ($gh, $str) = @_;
1229
1230         $gh->_new_mode('dl');
1231         return ".ip \"$str\"\n";
1232 }
1233
1234
1235 sub _ul
1236 {
1237         my ($gh) = @_;
1238
1239         $gh->_new_mode('ul');
1240         return ".bu\n";
1241 }
1242
1243
1244 sub _ol
1245 {
1246         my ($gh) = @_;
1247
1248         $gh->_new_mode('ol');
1249         return ".np\n";
1250 }
1251
1252
1253 sub _blockquote
1254 {
1255         my ($gh) = @_;
1256
1257         $gh->_new_mode('blockquote');
1258         return "\"";
1259 }
1260
1261
1262 sub _hr
1263 {
1264         my ($gh) = @_;
1265
1266         return '.hl';
1267 }
1268
1269
1270 sub _heading
1271 {
1272         my ($gh, $level, $l) = @_;
1273
1274         $l = '.sz ' . ${$gh->{'heading-sizes'}}[$level - 1] . "\n$l\n.sp 0.6";
1275
1276         return $l;
1277 }
1278
1279
1280 sub _table
1281 {
1282         my ($gh, $str) = @_;
1283
1284         if ($gh->{'-mode'} eq 'table') {
1285                 my ($h, $b);
1286                 my (@spans) = $gh->_calc_col_span($str);
1287
1288                 # build columns
1289                 $h = '';
1290                 $b = '';
1291                 for (my $n = 0; $n < scalar(@{$gh->{'-table'}}); $n++) {
1292                         my ($i);
1293
1294                         if ($gh->{'table-headers'} and $gh->{'-tbl-row'} == 1) {
1295                                 $h .= 'cB ';
1296                         }
1297                         else {
1298                                 $h .= 'l ';
1299                         }
1300
1301                         # add span columns
1302                         $h .= 's ' x ($spans[$n] - 1) if $spans[$n] > 1;
1303
1304                         $b .= '#' if $n;
1305
1306                         $i = ${$gh->{'-table'}}[$n];
1307                         $i =~ s/^\s+//;
1308                         $i =~ s/\s+$//;
1309                         $i =~ s/(\s)+/$1/g;
1310                         $b .= $i;
1311                 }
1312
1313                 # add a separator
1314                 $b .= "\n_" if $gh->{'table-headers'} and
1315                              $gh->{'-tbl-row'} == 1 and
1316                              $gh->{'table-type'} ne "allbox";
1317
1318                 $gh->{'-table-head'} .= "$h\n";
1319                 $gh->{'-table-body'} .= "$b\n";
1320
1321                 @{$gh->{'-table'}} = ();
1322                 $gh->{'-tbl-row'}++;
1323         }
1324         else {
1325                 # new table
1326                 $gh->_new_mode('table');
1327
1328                 @{$gh->{'-table'}} = ();
1329                 $gh->{'-tbl-row'} = 1;
1330
1331                 $gh->{'-table-head'} = ".TS\n$gh->{'table-type'} tab (#);\n";
1332                 $gh->{'-table-body'} = '';
1333         }
1334
1335         $str = '';
1336         return $str;
1337 }
1338
1339
1340 sub _postfix
1341 {
1342         my ($gh) = @_;
1343
1344         # add to top headings and footers
1345         unshift(@{$gh->{'o'}},".ef '\%' ''");
1346         unshift(@{$gh->{'o'}},".of '' '\%'");
1347         unshift(@{$gh->{'o'}},".eh '$gh->{'-title'}' ''");
1348         unshift(@{$gh->{'o'}},".oh '' '$gh->{'-title'}'");
1349 }
1350
1351
1352 ###########################################################
1353 # man Driver
1354
1355 package Grutatxt::man;
1356
1357 @ISA = ("Grutatxt::troff", "Grutatxt");
1358
1359 =head2 man Driver
1360
1361 The man driver is used to generate Unix-like man pages. Note that
1362 all headings have the same level with this output driver.
1363
1364 The additional parameters for a new Grutatxt object are:
1365
1366 =over 4
1367
1368 =item I<section>
1369
1370 The man page section (see man documentation). By default is 1.
1371
1372 =item I<page-name>
1373
1374 The name of the page. This is usually the name of the program
1375 or function the man page is documenting and will be shown in the
1376 page header. By default is the empty string.
1377
1378 =back
1379
1380 =cut
1381
1382 sub new
1383 {
1384         my ($class, %args) = @_;
1385         my ($gh);
1386
1387         bless(\%args,$class);
1388         $gh = \%args;
1389
1390         $gh->{'-process-urls'} = 0;
1391
1392         $gh->{'section'} ||= 1;
1393         $gh->{'page-name'} ||= "";
1394
1395         return $gh;
1396 }
1397
1398
1399 sub _prefix
1400 {
1401         my ($gh) = @_;
1402
1403         $gh->_push(".TH \"$gh->{'page-name'}\" \"$gh->{'section'}\" \"" . localtime() . "\"");
1404 }
1405
1406
1407 sub _inline
1408 {
1409         my ($gh, $l) = @_;
1410
1411         # accept only man markup inlines
1412         if ($l =~ /^<<\s*man$/i) {
1413                 $gh->{'-inline'} = 'man';
1414                 return;
1415         }
1416
1417         if ($l =~ /^>>$/) {
1418                 delete $gh->{'-inline'};
1419                 return;
1420         }
1421
1422         if ($gh->{'-inline'} eq 'man') {
1423                 $gh->_push($l);
1424         }
1425 }
1426
1427
1428 sub _empty_line
1429 {
1430         my ($gh) = @_;
1431
1432         return ' ';
1433 }
1434
1435
1436 sub _new_mode
1437 {
1438         my ($gh,$mode,$params) = @_;
1439
1440         if ($mode ne $gh->{'-mode'}) {
1441                 my $tag;
1442
1443                 # flush previous list
1444                 if ($gh->{'-mode'} eq 'pre' or
1445                    $gh->{'-mode'} eq 'table') {
1446                         $gh->_push('.fi');
1447                 }
1448
1449                 if ($gh->{'-mode'} eq 'blockquote') {
1450                         $gh->_push('.RE');
1451                 }
1452
1453                 if ($gh->{'-mode'} eq 'ul') {
1454                         $gh->_push(".RE\n" x scalar(@{$gh->{'-ul-levels'}}));
1455                 }
1456
1457                 if ($gh->{'-mode'} eq 'ol') {
1458                         $gh->_push(".RE\n" x scalar(@{$gh->{'-ol-levels'}}));
1459                 }
1460
1461                 # send new one
1462                 if ($mode eq 'pre' or $mode eq 'table') {
1463                         $gh->_push('.nf');
1464                 }
1465
1466                 if ($mode eq 'blockquote') {
1467                         $gh->_push('.RS 4');
1468                 }
1469
1470                 $gh->{'-mode'} = $mode;
1471         }
1472 }
1473
1474
1475 sub _dl
1476 {
1477         my ($gh, $str) = @_;
1478
1479         $gh->_new_mode('dl');
1480         return ".TP\n.B \"$str\"\n";
1481 }
1482
1483
1484 sub _ul
1485 {
1486         my ($gh, $levels) = @_;
1487         my ($ret) = '';
1488
1489         if ($levels > 0) {
1490                 $ret = ".RS 4\n";
1491         }
1492         elsif ($levels < 0) {
1493                 $ret = ".RE\n" x abs($levels);
1494         }
1495
1496         $gh->_new_mode('ul');
1497         return $ret . ".TP 4\n\\(bu\n";
1498 }
1499
1500
1501 sub _ol
1502 {
1503         my ($gh, $levels) = @_;
1504         my $l = @{$gh->{'-ol-levels'}};
1505         my $ret = '';
1506
1507         $gh->{'-ol-level'} += $levels;
1508
1509         if ($levels > 0) {
1510                 $ret = ".RS 4\n";
1511
1512                 $l[$gh->{'-ol-level'}] = 1;
1513         }
1514         elsif ($levels < 0) {
1515                 $ret = ".RE\n" x abs($levels);
1516         }
1517
1518         $gh->_new_mode('ol');
1519         $ret .= ".TP 4\n" . $l[$gh->{'-ol-level'}]++ . ".\n";
1520
1521         return $ret;
1522 }
1523
1524
1525 sub _hr
1526 {
1527         my ($gh) = @_;
1528
1529         return '';
1530 }
1531
1532
1533 sub _heading
1534 {
1535         my ($gh, $level, $l) = @_;
1536
1537         # all headers are the same depth in man pages
1538         return ".SH \"" . uc($l) . "\"";
1539 }
1540
1541
1542 sub _table
1543 {
1544         my ($gh, $str) = @_;
1545
1546         if ($gh->{'-mode'} eq 'table') {
1547                 foreach my $r (@{$gh->{'-table-raw'}}) {
1548                         $gh->_push("|$r|");
1549                 }
1550         }
1551         else {
1552                 $gh->_new_mode('table');
1553         }
1554
1555         @{$gh->{'-table'}} = ();
1556         @{$gh->{'-table-raw'}} = ();
1557
1558         $gh->_push($str);
1559
1560         return '';
1561 }
1562
1563
1564 sub _postfix
1565 {
1566 }
1567
1568
1569 ###########################################################
1570 # latex Driver
1571
1572 package Grutatxt::latex;
1573
1574 @ISA = ("Grutatxt");
1575
1576 =head2 LaTeX Driver
1577
1578 The additional parameters for a new Grutatxt object are:
1579
1580 =over 4
1581
1582 =item I<docclass>
1583
1584 The LaTeX document class. By default is 'report'. You can also use
1585 'article' or 'book' (consult your LaTeX documentation for details).
1586
1587 =item I<papersize>
1588
1589 The paper size to be used in the document. By default is 'a4paper'.
1590
1591 =item I<encoding>
1592
1593 The character encoding used in the document. By default is 'latin1'.
1594
1595 =back
1596
1597 Note that you can't nest further than 4 levels in LaTeX; if you do,
1598 LaTeX will choke in the generated code with a 'Too deeply nested' error.
1599
1600 =cut
1601
1602 sub new
1603 {
1604         my ($class, %args) = @_;
1605         my ($gh);
1606
1607         bless(\%args,$class);
1608         $gh = \%args;
1609
1610         $gh->{'-process-urls'} = 0;
1611
1612         $gh->{'-docclass'} ||= 'report';
1613         $gh->{'-papersize'} ||= 'a4paper';
1614         $gh->{'-encoding'} ||= 'latin1';
1615
1616         return $gh;
1617 }
1618
1619
1620 sub _prefix
1621 {
1622         my ($gh) = @_;
1623
1624         $gh->_push("\\documentclass[$gh->{'-papersize'}]{$gh->{-docclass}}");
1625         $gh->_push("\\usepackage[$gh->{'-encoding'}]{inputenc}");
1626
1627         $gh->_push("\\begin{document}");
1628 }
1629
1630
1631 sub _inline
1632 {
1633         my ($gh, $l) = @_;
1634
1635         # accept only latex inlines
1636         if ($l =~ /^<<\s*latex$/i) {
1637                 $gh->{'-inline'} = 'latex';
1638                 return;
1639         }
1640
1641         if ($l =~ /^>>$/) {
1642                 delete $gh->{'-inline'};
1643                 return;
1644         }
1645
1646         if ($gh->{'-inline'} eq 'latex') {
1647                 $gh->_push($l);
1648         }
1649 }
1650
1651
1652 sub _escape
1653 {
1654         my ($gh, $l) = @_;
1655
1656         $l =~ s/ _ / \\_ /g;
1657         $l =~ s/ ~ / \\~ /g;
1658         $l =~ s/ & / \\& /g;
1659
1660         return $l;
1661 }
1662
1663
1664 sub _escape_post
1665 {
1666         my ($gh, $l) = @_;
1667
1668         $l =~ s/ # / \\# /g;
1669         $l =~ s/^\\n$//g;
1670         $l =~ s/([^\s_])_([^\s_])/$1\\_$2/g;
1671
1672         return $l;
1673 }
1674
1675
1676 sub _empty_line
1677 {
1678         my ($gh) = @_;
1679
1680         return "\\n";
1681 }
1682
1683
1684 sub _strong
1685 {
1686         my ($gh, $str) = @_;
1687         return "\\textbf{$str}";
1688 }
1689
1690
1691 sub _em
1692 {
1693         my ($gh, $str) = @_;
1694         return "\\emph{$str}";
1695 }
1696
1697
1698 sub _code
1699 {
1700         my ($gh, $str) = @_;
1701         return "{\\tt $str}";
1702 }
1703
1704
1705 sub _funcname
1706 {
1707         my ($gh, $str) = @_;
1708         return "{\\tt $str}";
1709 }
1710
1711
1712 sub _varname
1713 {
1714         my ($gh, $str) = @_;
1715
1716         $str =~ s/^\$/\\\$/;
1717
1718         return "{\\tt $str}";
1719 }
1720
1721
1722 sub _new_mode
1723 {
1724         my ($gh, $mode, $params) = @_;
1725
1726         # mode equivalences
1727         my %latex_modes = (
1728                 'pre'           =>      'verbatim',
1729                 'blockquote'    =>      'quote',
1730                 'table'         =>      'tabular',
1731                 'dl'            =>      'description',
1732                 'ul'            =>      'itemize',
1733                 'ol'            =>      'enumerate'
1734         );
1735
1736         if ($mode ne $gh->{'-mode'}) {
1737                 # close previous mode
1738                 if ($gh->{'-mode'} eq 'ul') {
1739                         $gh->_push("\\end{itemize}" x scalar(@{$gh->{'-ul-levels'}}));
1740                 }
1741                 elsif ($gh->{'-mode'} eq 'ol') {
1742                         $gh->_push("\\end{enumerate}" x scalar(@{$gh->{'-ol-levels'}}));
1743                 }
1744                 elsif ($gh->{'-mode'} eq 'table') {
1745                         $gh->_push("\\end{tabular}\n");
1746                 }
1747                 else {
1748                         $gh->_push("\\end{" . $latex_modes{$gh->{'-mode'}} . "}")
1749                         if $gh->{'-mode'};
1750                 }
1751
1752                 # send new one
1753                 $gh->_push("\\begin{" . $latex_modes{$mode} . "}" . $params)
1754                         if $mode;
1755
1756                 $gh->{'-mode'} = $mode;
1757
1758                 $gh->{'-ul-levels'} = undef;
1759                 $gh->{'-ol-levels'} = undef;
1760         }
1761 }
1762
1763
1764 sub _dl
1765 {
1766         my ($gh, $str) = @_;
1767
1768         $gh->_new_mode('dl');
1769         return "\\item[$str]\n";
1770 }
1771
1772
1773 sub _ul
1774 {
1775         my ($gh, $levels) = @_;
1776         my ($ret);
1777
1778         $ret = '';
1779
1780         if ($levels > 0) {
1781                 $ret .= "\\begin{itemize}\n";
1782         }
1783         elsif ($levels < 0) {
1784                 $ret .= "\\end{itemize}\n" x abs($levels);
1785         }
1786
1787         $gh->{'-mode'} = 'ul';
1788
1789         $ret .= "\\item\n";
1790
1791         return $ret;
1792 }
1793
1794
1795 sub _ol
1796 {
1797         my ($gh, $levels) = @_;
1798         my ($ret);
1799
1800         $ret = '';
1801
1802         if ($levels > 0) {
1803                 $ret .= "\\begin{enumerate}\n";
1804         }
1805         elsif ($levels < 0) {
1806                 $ret .= "\\end{enumerate}\n" x abs($levels);
1807         }
1808
1809         $gh->{'-mode'} = 'ol';
1810
1811         $ret .= "\\item\n";
1812
1813         return $ret;
1814 }
1815
1816
1817 sub _blockquote
1818 {
1819         my ($gh) = @_;
1820
1821         $gh->_new_mode('blockquote');
1822         return "``";
1823 }
1824
1825
1826 sub _hr
1827 {
1828         my ($gh) = @_;
1829
1830         return "------------\n";
1831 }
1832
1833
1834 sub _heading
1835 {
1836         my ($gh, $level, $l) = @_;
1837
1838         my @latex_headings = ( "\\section*{", "\\subsection*{",
1839                 "\\subsubsection*{");
1840
1841         $l = "\n" . $latex_headings[$level - 1] . $l . "}";
1842
1843         return $l;
1844 }
1845
1846
1847 sub _table
1848 {
1849         my ($gh,$str) = @_;
1850
1851         if ($gh->{'-mode'} eq 'table') {
1852                 my ($class) = '';
1853                 my (@spans) = $gh->_calc_col_span($str);
1854                 my (@cols);
1855
1856                 $str = '';
1857
1858                 # build columns
1859                 for (my $n = 0; $n < scalar(@{$gh->{'-table'}}); $n++) {
1860                         my ($i, $s);
1861
1862                         $i = ${$gh->{'-table'}}[$n];
1863                         $i = "&nbsp;" if $i =~ /^\s*$/;
1864
1865 #                       $s = " colspan='$spans[$n]'" if $spans[$n] > 1;
1866
1867                         # multispan columns
1868                         $i = "\\multicolumn{$spans[$n]}{|l|}{$i}"
1869                                 if $spans[$n] > 1;
1870
1871                         $i =~ s/\s{2,}/ /g;
1872                         $i =~ s/^\s+//;
1873                         $i =~ s/\s+$//;
1874
1875                         push(@cols, $i);
1876                 }
1877
1878                 $str .= join('&', @cols) . "\\\\\n\\hline";
1879
1880 #               $str .= "\n\\hline" if $gh->{'-tbl-row'} == 1;
1881
1882                 @{$gh->{'-table'}} = ();
1883                 $gh->{'-tbl-row'}++;
1884         }
1885         else {
1886                 # new table
1887
1888                 # count the number of columns
1889                 $str =~ s/[^\+]//g;
1890                 my $params = "{" . "|l" x (length($str) - 1) . "|}\n\\hline";
1891
1892                 $gh->_push();
1893                 $gh->_new_mode('table', $params);
1894
1895                 @{$gh->{'-table'}} = ();
1896                 $gh->{'-tbl-row'} = 1;
1897                 $str = '';
1898         }
1899
1900         return $str;
1901 }
1902
1903
1904 sub _postfix
1905 {
1906         my ($gh) = @_;
1907
1908         $gh->_push("\\end{document}");
1909 }
1910
1911
1912 ###########################################################
1913 # RTF Driver
1914
1915 package Grutatxt::rtf;
1916
1917 @ISA = ("Grutatxt");
1918
1919 =head2 RTF Driver
1920
1921 The additional parameters for a new Grutatxt object are:
1922
1923 =over 4
1924
1925 =item I<normal-size>
1926
1927 The point size of normal text. By default is 20.
1928
1929 =item I<heading-sizes>
1930
1931 This argument must be a reference to an array containing
1932 the size in points of the 3 different heading levels. By
1933 default, level sizes are [ 34, 30, 28 ].
1934
1935 =back
1936
1937 =cut
1938
1939 sub new
1940 {
1941         my ($class, %args) = @_;
1942         my ($gh);
1943
1944         bless(\%args, $class);
1945         $gh = \%args;
1946
1947         $gh->{'-process-urls'} = 0;
1948
1949         $gh->{'heading-sizes'} ||= [ 34, 30, 28 ];
1950         $gh->{'normal-size'} ||= 20;
1951
1952         return $gh;
1953 }
1954
1955
1956 sub _prefix
1957 {
1958         my $gh = shift;
1959
1960         $gh->_push('{\rtf1\ansi {\plain \fs' . $gh->{'normal-size'} . ' \sa227');
1961 }
1962
1963
1964 sub _empty_line
1965 {
1966         my $gh = shift;
1967
1968         return '\par';
1969 }
1970
1971
1972 sub _heading
1973 {
1974         my ($gh, $level, $l) = @_;
1975
1976         return '{\b \fs' . $gh->{'heading-sizes'}->[$level] . ' ' . $l . '}';
1977 }
1978
1979
1980 sub _strong
1981 {
1982         my ($gh, $str) = @_;
1983         return "{\\b $str}";
1984 }
1985
1986
1987 sub _em
1988 {
1989         my ($gh, $str) = @_;
1990         return "{\\i $str}";
1991 }
1992
1993
1994 sub _code
1995 {
1996         my ($gh, $str) = @_;
1997         return "{\\tt $str}";
1998 }
1999
2000
2001 sub _ul
2002 {
2003         my ($gh, $levels) = @_;
2004
2005         $gh->_new_mode('ul');
2006         return "{{\\bullet \\li" . $levels . ' ';
2007 }
2008
2009
2010 sub _dl
2011 {
2012         my ($gh, $str) = @_;
2013
2014         $gh->_new_mode('dl');
2015         return "{{\\b $str \\par} {\\li566 ";
2016 }
2017
2018
2019 sub _new_mode
2020 {
2021         my ($gh, $mode, $params) = @_;
2022
2023         if ($mode ne $gh->{'-mode'}) {
2024                 if ($gh->{'-mode'} =~ /^(dl|ul)$/) {
2025                         $gh->_push('}}');
2026                 }
2027
2028                 $gh->{'-mode'} = $mode;
2029
2030                 $gh->{'-ul-levels'} = undef;
2031                 $gh->{'-ol-levels'} = undef;
2032         }
2033         else {
2034                 if ($mode =~ /^(dl|ul)$/) {
2035                         $gh->_push('}\par}');
2036                 }
2037         }
2038 }
2039
2040
2041 sub _postfix
2042 {
2043         my $gh = shift;
2044
2045         @{$gh->{o}} = map { $_ . ' '; } @{$gh->{o}};
2046
2047         $gh->_push('}}');
2048 }
2049
2050
2051 =head1 AUTHOR
2052
2053 Angel Ortega angel@triptico.com
2054
2055 =cut
2056
2057 1;