[Summary view] [Print] [Text view]

   1  
   2  require 5;
   3  package Pod::Simple::RTF;
   4  
   5  #sub DEBUG () {4};
   6  #sub Pod::Simple::DEBUG () {4};
   7  #sub Pod::Simple::PullParser::DEBUG () {4};
   8  
   9  use strict;
  10  use vars qw($VERSION @ISA %Escape $WRAP %Tagmap);
  11  $VERSION = '2.02';
  12  use Pod::Simple::PullParser ();
  13  BEGIN {@ISA = ('Pod::Simple::PullParser')}
  14  
  15  use Carp ();
  16  BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
  17  
  18  $WRAP = 1 unless defined $WRAP;
  19  
  20  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  21  
  22  sub _openclose {
  23   return map {;
  24     m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?";
  25     ( $1,  "{\\$2\n",   "/$1",  "}" );
  26   } @_;
  27  }
  28  
  29  my @_to_accept;
  30  
  31  %Tagmap = (
  32   # 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}')
  33   _openclose(
  34    'B=cs18\b',
  35    'I=cs16\i',
  36    'C=cs19\f1\lang1024\noproof',
  37    'F=cs17\i\lang1024\noproof',
  38  
  39    'VerbatimI=cs26\i',
  40    'VerbatimB=cs27\b',
  41    'VerbatimBI=cs28\b\i',
  42  
  43    map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
  44     qw[
  45         underline=ul         smallcaps=scaps  shadow=shad
  46         superscript=super    subscript=sub    strikethrough=strike
  47         outline=outl         emboss=embo      engrave=impr   
  48         dotted-underline=uld          dash-underline=uldash
  49         dot-dash-underline=uldashd    dot-dot-dash-underline=uldashdd     
  50         double-underline=uldb         thick-underline=ulth
  51         word-underline=ulw            wave-underline=ulwave
  52     ]
  53     # But no double-strikethrough, because MSWord can't agree with the
  54     #  RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!)
  55   ),
  56  
  57   # Bit of a hack here:
  58   'L=pod' => '{\cs22\i'."\n",
  59   'L=url' => '{\cs23\i'."\n",
  60   'L=man' => '{\cs24\i'."\n",
  61   '/L' => '}',
  62  
  63   'Data'  => "\n",
  64   '/Data' => "\n",
  65  
  66   'Verbatim'  => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
  67   '/Verbatim' => "\n\\par}\n",
  68   'VerbatimFormatted'  => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
  69   '/VerbatimFormatted' => "\n\\par}\n",
  70   'Para'    => "\n{\\pard\\li#rtfindent#\\sa180\n",
  71   '/Para'   => "\n\\par}\n",
  72   'head1'   => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n",
  73   '/head1'  => "\n}\\par}\n",
  74   'head2'   => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n",
  75   '/head2'  => "\n}\\par}\n",
  76   'head3'   => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n",
  77   '/head3'  => "\n}\\par}\n",
  78   'head4'   => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n",
  79   '/head4'  => "\n}\\par}\n",
  80     # wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2
  81  
  82   'item-bullet'  => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
  83   '/item-bullet' => "\n\\par}\n",
  84   'item-number'  => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
  85   '/item-number' => "\n\\par}\n",
  86   'item-text'    => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
  87   '/item-text'   => "\n\\par}\n",
  88  
  89   # we don't need any styles for over-* and /over-*
  90  );
  91  
  92  
  93  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  94  sub new {
  95    my $new = shift->SUPER::new(@_);
  96    $new->nix_X_codes(1);
  97    $new->nbsp_for_S(1);
  98    $new->accept_targets( 'rtf', 'RTF' );
  99  
 100    $new->{'Tagmap'} = {%Tagmap};
 101  
 102    $new->accept_codes(@_to_accept);
 103    $new->accept_codes('VerbatimFormatted');
 104    DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
 105    $new->doc_lang(
 106      (  $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1
 107      : ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1)
 108                                        # yes, tolerate hex!
 109      : ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1)
 110                                        # yes, tolerate even more hex!
 111      : '1033'
 112    );
 113  
 114    $new->head1_halfpoint_size(32);
 115    $new->head2_halfpoint_size(28);
 116    $new->head3_halfpoint_size(25);
 117    $new->head4_halfpoint_size(22);
 118    $new->codeblock_halfpoint_size(18);
 119    $new->header_halfpoint_size(17);
 120    $new->normal_halfpoint_size(25);
 121  
 122    return $new;
 123  }
 124  
 125  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 126  
 127  __PACKAGE__->_accessorize(
 128   'doc_lang',
 129   'head1_halfpoint_size',
 130   'head2_halfpoint_size',
 131   'head3_halfpoint_size',
 132   'head4_halfpoint_size',
 133   'codeblock_halfpoint_size',
 134   'header_halfpoint_size',
 135   'normal_halfpoint_size',
 136   'no_proofing_exemptions',
 137  );
 138  
 139  
 140  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 141  sub run {
 142    my $self = $_[0];
 143    return $self->do_middle if $self->bare_output;
 144    return
 145     $self->do_beginning && $self->do_middle && $self->do_end;
 146  }
 147  
 148  
 149  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 150  
 151  sub do_middle {      # the main work
 152    my $self = $_[0];
 153    my $fh = $self->{'output_fh'};
 154    
 155    my($token, $type, $tagname, $scratch);
 156    my @stack;
 157    my @indent_stack;
 158    $self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'};
 159    
 160    while($token = $self->get_token) {
 161    
 162      if( ($type = $token->type) eq 'text' ) {
 163        if( $self->{'rtfverbatim'} ) {
 164          DEBUG > 1 and print "  $type " , $token->text, " in verbatim!\n";
 165          rtf_esc_codely($scratch = $token->text);
 166          print $fh $scratch;
 167          next;
 168        }
 169  
 170        DEBUG > 1 and print "  $type " , $token->text, "\n";
 171        
 172        $scratch = $token->text;
 173        $scratch =~ tr/\t\cb\cc/ /d;
 174        
 175        $self->{'no_proofing_exemptions'} or $scratch =~
 176         s/(?:
 177             ^
 178             |
 179             (?<=[\cm\cj\t "\[\<\(])
 180           )   # start on whitespace, sequence-start, or quote
 181           ( # something looking like a Perl token:
 182            (?:
 183             [\$\@\:\<\*\\_]\S+  # either starting with a sigil, etc.
 184            )
 185            |
 186            # or starting alpha, but containing anything strange:
 187            (?:
 188             [a-zA-Z'\x80-\xFF]+[\$\@\:_<>\(\\\*]\S+
 189            )
 190           )
 191          /\cb$1\cc/xsg
 192        ;
 193        
 194        rtf_esc($scratch);
 195        $scratch =~
 196           s/(
 197              [^\cm\cj\n]{65}        # Snare 65 characters from a line
 198              [^\cm\cj\n\x20]{0,50}  #  and finish any current word
 199             )
 200             (\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end
 201            /$1$2\n/gx     # and put a NL before those spaces
 202          if $WRAP;
 203          # This may wrap at well past the 65th column, but not past the 120th.
 204        
 205        print $fh $scratch;
 206  
 207      } elsif( $type eq 'start' ) {
 208        DEBUG > 1 and print "  +$type ",$token->tagname,
 209          " (", map("<$_> ", %{$token->attr_hash}), ")\n";
 210  
 211        if( ($tagname = $token->tagname) eq 'Verbatim'
 212            or $tagname eq 'VerbatimFormatted'
 213        ) {
 214          ++$self->{'rtfverbatim'};
 215          my $next = $self->get_token;
 216          next unless defined $next;
 217          my $line_count = 1;
 218          if($next->type eq 'text') {
 219            my $t = $next->text_r;
 220            while( $$t =~ m/$/mg ) {
 221              last if  ++$line_count  > 15; # no point in counting further
 222            }
 223            DEBUG > 3 and print "    verbatim line count: $line_count\n";
 224          }
 225          $self->unget_token($next);
 226          $self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;     
 227  
 228        } elsif( $tagname =~ m/^item-/s ) {
 229          my @to_unget;
 230          my $text_count_here = 0;
 231          $self->{'rtfitemkeepn'} = '';
 232          # Some heuristics to stop item-*'s functioning as subheadings
 233          #  from getting split from the things they're subheadings for.
 234          #
 235          # It's not terribly pretty, but it really does make things pretty.
 236          #
 237          while(1) {
 238            push @to_unget, $self->get_token;
 239            pop(@to_unget), last unless defined $to_unget[-1];
 240             # Erroneously used to be "unshift" instead of pop!  Adds instead
 241             # of removes, and operates on the beginning instead of the end!
 242            
 243            if($to_unget[-1]->type eq 'text') {
 244              if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
 245                DEBUG > 1 and print "    item-* is too long to be keepn'd.\n";
 246                last;
 247              }
 248            } elsif (@to_unget > 1 and
 249              $to_unget[-2]->type eq 'end' and
 250              $to_unget[-2]->tagname =~ m/^item-/s
 251            ) {
 252              # Bail out here, after setting rtfitemkeepn yea or nay.
 253              $self->{'rtfitemkeepn'} = '\keepn' if 
 254                $to_unget[-1]->type eq 'start' and
 255                $to_unget[-1]->tagname eq 'Para';
 256  
 257              DEBUG > 1 and printf "    item-* before %s(%s) %s keepn'd.\n",
 258                $to_unget[-1]->type,
 259                $to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '',
 260                $self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
 261              last;
 262            } elsif (@to_unget > 40) {
 263              DEBUG > 1 and print "    item-* now has too many tokens (",
 264                scalar(@to_unget),
 265                (DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (),
 266                ") to be keepn'd.\n";
 267              last; # give up
 268            }
 269            # else keep while'ing along
 270          }
 271          # Now put it aaaaall back...
 272          $self->unget_token(@to_unget);
 273  
 274        } elsif( $tagname =~ m/^over-/s ) {
 275          push @stack, $1;
 276          push @indent_stack,
 277           int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
 278          DEBUG and print "Indenting over $indent_stack[-1] twips.\n";
 279          $self->{'rtfindent'} += $indent_stack[-1];
 280          
 281        } elsif ($tagname eq 'L') {
 282          $tagname .= '=' . ($token->attr('type') || 'pod');
 283          
 284        } elsif ($tagname eq 'Data') {
 285          my $next = $self->get_token;
 286          next unless defined $next;
 287          unless( $next->type eq 'text' ) {
 288            $self->unget_token($next);
 289            next;
 290          }
 291          DEBUG and print "    raw text ", $next->text, "\n";
 292          printf $fh "\n" . $next->text . "\n";
 293          next;
 294        }
 295  
 296        defined($scratch = $self->{'Tagmap'}{$tagname}) or next;
 297        $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
 298        print $fh $scratch;
 299        
 300        if ($tagname eq 'item-number') {
 301          print $fh $token->attr('number'), ". \n";
 302        } elsif ($tagname eq 'item-bullet') {
 303          print $fh "\\'95 \n";
 304          #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}");
 305        }
 306  
 307      } elsif( $type eq 'end' ) {
 308        DEBUG > 1 and print "  -$type ",$token->tagname,"\n";
 309        if( ($tagname = $token->tagname) =~ m/^over-/s ) {
 310          DEBUG and print "Indenting back $indent_stack[-1] twips.\n";
 311          $self->{'rtfindent'} -= pop @indent_stack;
 312          pop @stack;
 313        } elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
 314          --$self->{'rtfverbatim'};
 315        }
 316        defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next;
 317        $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
 318        print $fh $scratch;
 319      }
 320    }
 321    return 1;
 322  }
 323  
 324  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 325  sub do_beginning {
 326    my $self = $_[0];
 327    my $fh = $self->{'output_fh'};
 328    return print $fh join '',
 329      $self->doc_init,
 330      $self->font_table,
 331      $self->stylesheet,
 332      $self->color_table,
 333      $self->doc_info,
 334      $self->doc_start,
 335      "\n"
 336    ;
 337  }
 338  
 339  sub do_end {
 340    my $self = $_[0];
 341    my $fh = $self->{'output_fh'};
 342    return print $fh '}'; # that should do it
 343  }
 344  
 345  ###########################################################################
 346  
 347  sub stylesheet {
 348    return sprintf <<'END',
 349  {\stylesheet
 350  {\snext0 Normal;}
 351  {\*\cs10 \additive Default Paragraph Font;}
 352  {\*\cs16 \additive \i \sbasedon10 pod-I;}
 353  {\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;}
 354  {\*\cs18 \additive \b \sbasedon10 pod-B;}
 355  {\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;}
 356  {\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;}
 357  {\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;}
 358  {\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;}
 359  {\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;}
 360  {\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;}
 361  
 362  {\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;}
 363  {\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;}
 364  {\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;}
 365  {\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;}
 366  
 367  {\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;}
 368  {\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;}
 369  {\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;}
 370  {\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;}
 371  }
 372  
 373  END
 374  
 375     $_[0]->codeblock_halfpoint_size(),
 376     $_[0]->head1_halfpoint_size(),
 377     $_[0]->head2_halfpoint_size(),
 378     $_[0]->head3_halfpoint_size(),
 379     $_[0]->head4_halfpoint_size(),
 380    ;
 381  }
 382  
 383  ###########################################################################
 384  # Override these as necessary for further customization
 385  
 386  sub font_table {
 387    return <<'END';  # text font, code font, heading font
 388  {\fonttbl
 389  {\f0\froman Times New Roman;}
 390  {\f1\fmodern Courier New;}
 391  {\f2\fswiss Arial;}
 392  }
 393  
 394  END
 395  }
 396  
 397  sub doc_init {
 398     return <<'END';
 399  {\rtf1\ansi\deff0
 400  
 401  END
 402  }
 403  
 404  sub color_table {
 405     return <<'END';
 406  {\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
 407  END
 408  }
 409  
 410  
 411  sub doc_info {
 412     my $self = $_[0];
 413  
 414     my $class = ref($self) || $self;
 415  
 416     my $tag = __PACKAGE__ . ' ' . $VERSION;
 417     
 418     unless($class eq __PACKAGE__) {
 419       $tag = " ($tag)";
 420       $tag = " v" . $self->VERSION . $tag   if   defined $self->VERSION;
 421       $tag = $class . $tag;
 422     }
 423  
 424     return sprintf <<'END',
 425  {\info{\doccomm
 426  %s
 427   using %s v%s
 428   under Perl v%s at %s GMT}
 429  {\author [see doc]}{\company [see doc]}{\operator [see doc]}
 430  }
 431  
 432  END
 433  
 434    # None of the following things should need escaping, I dare say!
 435      $tag, 
 436      $ISA[0], $ISA[0]->VERSION(),
 437      $], scalar(gmtime),
 438    ;
 439  }
 440  
 441  sub doc_start {
 442    my $self = $_[0];
 443    my $title = $self->get_short_title();
 444    DEBUG and print "Short Title: <$title>\n";
 445    $title .= ' ' if length $title;
 446    
 447    $title =~ s/ *$/ /s;
 448    $title =~ s/^ //s;
 449    $title =~ s/ $/, /s;
 450     # make sure it ends in a comma and a space, unless it's 0-length
 451  
 452    my $is_obviously_module_name;
 453    $is_obviously_module_name = 1
 454     if $title =~ m/^\S+$/s and $title =~ m/::/s;
 455      # catches the most common case, at least
 456  
 457    DEBUG and print "Title0: <$title>\n";
 458    $title = rtf_esc($title);
 459    DEBUG and print "Title1: <$title>\n";
 460    $title = '\lang1024\noproof ' . $title
 461     if $is_obviously_module_name;
 462  
 463    return sprintf <<'END', 
 464  \deflang%s\plain\lang%s\widowctrl
 465  {\header\pard\qr\plain\f2\fs%s
 466  %s
 467  p.\chpgn\par}
 468  \fs%s
 469  
 470  END
 471      ($self->doc_lang) x 2,
 472      $self->header_halfpoint_size,
 473      $title,
 474      $self->normal_halfpoint_size,
 475    ;
 476  }
 477  
 478  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 479  #-------------------------------------------------------------------------
 480  
 481  use integer;
 482  sub rtf_esc {
 483    my $x; # scratch
 484    if(!defined wantarray) { # void context: alter in-place!
 485      for(@_) {
 486        s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g;  # ESCAPER
 487        s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
 488      }
 489      return;
 490    } elsif(wantarray) {  # return an array
 491      return map {; ($x = $_) =~
 492        s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g;  # ESCAPER
 493        $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
 494        $x;
 495      } @_;
 496    } else { # return a single scalar
 497      ($x = ((@_ == 1) ? $_[0] : join '', @_)
 498      ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g;  # ESCAPER
 499               # Escape \, {, }, -, control chars, and 7f-ff.
 500      $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
 501      return $x;
 502    }
 503  }
 504  
 505  sub rtf_esc_codely {
 506    # Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts.
 507    # We don't want to change the "-" to hard-hyphen, because we want to
 508    #  be able to paste this into a file and run it without there being
 509    #  dire screaming about the mysterious hard-hyphen character (which
 510    #  looks just like a normal dash character).
 511    
 512    my $x; # scratch
 513    if(!defined wantarray) { # void context: alter in-place!
 514      for(@_) {
 515        s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;  # ESCAPER
 516        s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
 517      }
 518      return;
 519    } elsif(wantarray) {  # return an array
 520      return map {; ($x = $_) =~
 521        s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;  # ESCAPER
 522        $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
 523        $x;
 524      } @_;
 525    } else { # return a single scalar
 526      ($x = ((@_ == 1) ? $_[0] : join '', @_)
 527      ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;  # ESCAPER
 528               # Escape \, {, }, -, control chars, and 7f-ff.
 529      $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
 530      return $x;
 531    }
 532  }
 533  
 534  %Escape = (
 535    map( (chr($_),chr($_)),       # things not apparently needing escaping
 536         0x20 .. 0x7E ),
 537    map( (chr($_),sprintf("\\'%02x", $_)),    # apparently escapeworthy things
 538         0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46),
 539  
 540    # We get to escape out 'F' so that we can send RTF files thru the mail
 541    # without the slightest worry that paragraphs beginning with "From"
 542    # will get munged.
 543  
 544    # And some refinements:
 545    "\cm"  => "\n",
 546    "\cj"  => "\n",
 547    "\n"   => "\n\\line ",
 548  
 549    "\t"   => "\\tab ",     # Tabs (altho theoretically raw \t's are okay)
 550    "\f"   => "\n\\page\n", # Formfeed
 551    "-"    => "\\_",        # Turn plaintext '-' into a non-breaking hyphen
 552    "\xA0" => "\\~",        # Latin-1 non-breaking space
 553    "\xAD" => "\\-",        # Latin-1 soft (optional) hyphen
 554  
 555    # CRAZY HACKS:
 556    "\n" => "\\line\n",
 557    "\r" => "\n",
 558    "\cb" => "{\n\\cs21\\lang1024\\noproof ",  # \\cf1
 559    "\cc" => "}",
 560  );
 561  1;
 562  
 563  __END__
 564  
 565  =head1 NAME
 566  
 567  Pod::Simple::RTF -- format Pod as RTF
 568  
 569  =head1 SYNOPSIS
 570  
 571    perl -MPod::Simple::RTF -e \
 572     "exit Pod::Simple::RTF->filter(shift)->any_errata_seen" \
 573     thingy.pod > thingy.rtf
 574  
 575  =head1 DESCRIPTION
 576  
 577  This class is a formatter that takes Pod and renders it as RTF, good for
 578  viewing/printing in MSWord, WordPad/write.exe, TextEdit, etc.
 579  
 580  This is a subclass of L<Pod::Simple> and inherits all its methods.
 581  
 582  =head1 FORMAT CONTROL ATTRIBUTES
 583  
 584  You can set these attributes on the parser object before you
 585  call C<parse_file> (or a similar method) on it:
 586  
 587  =over
 588  
 589  =item $parser->head1_halfpoint_size( I<halfpoint_integer> );
 590  
 591  =item $parser->head2_halfpoint_size( I<halfpoint_integer> );
 592  
 593  =item $parser->head3_halfpoint_size( I<halfpoint_integer> );
 594  
 595  =item $parser->head4_halfpoint_size( I<halfpoint_integer> );
 596  
 597  These methods set the size (in half-points, like 52 for 26-point)
 598  that these heading levels will appear as.
 599  
 600  =item $parser->codeblock_halfpoint_size( I<halfpoint_integer> );
 601  
 602  This method sets the size (in half-points, like 21 for 10.5-point)
 603  that codeblocks ("verbatim sections") will appear as.
 604  
 605  =item $parser->header_halfpoint_size( I<halfpoint_integer> );
 606  
 607  This method sets the size (in half-points, like 15 for 7.5-point)
 608  that the header on each page will appear in.  The header
 609  is usually just "I<modulename> p. I<pagenumber>".
 610  
 611  =item $parser->normal_halfpoint_size( I<halfpoint_integer> );
 612  
 613  This method sets the size (in half-points, like 26 for 13-point)
 614  that normal paragraphic text will appear in.
 615  
 616  =item $parser->no_proofing_exemptions( I<true_or_false> );
 617  
 618  Set this value to true if you don't want the formatter to try
 619  putting a hidden code on all Perl symbols (as best as it can
 620  notice them) that labels them as being not in English, and
 621  so not worth spellchecking.
 622  
 623  =item $parser->doc_lang( I<microsoft_decimal_language_code> )
 624  
 625  This sets the language code to tag this document as being in. By
 626  default, it is currently the value of the environment variable
 627  C<RTFDEFLANG>, or if that's not set, then the value
 628  1033 (for US English).
 629  
 630  Setting this appropriately is useful if you want to use the RTF
 631  to spellcheck, and/or if you want it to hyphenate right.
 632  
 633  Here are some notable values:
 634  
 635    1033  US English
 636    2057  UK English
 637    3081  Australia English
 638    4105  Canada English
 639    1034  Spain Spanish
 640    2058  Mexico Spanish
 641    1031  Germany German
 642    1036  France French
 643    3084  Canada French
 644    1035  Finnish
 645    1044  Norwegian (Bokmal)
 646    2068  Norwegian (Nynorsk)
 647  
 648  =back
 649  
 650  If you are particularly interested in customizing this module's output
 651  even more, see the source and/or write to me.
 652  
 653  =head1 SEE ALSO
 654  
 655  L<Pod::Simple>, L<RTF::Writer>, L<RTF::Cookbook>, L<RTF::Document>,
 656  L<RTF::Generator>
 657  
 658  =head1 COPYRIGHT AND DISCLAIMERS
 659  
 660  Copyright (c) 2002 Sean M. Burke.  All rights reserved.
 661  
 662  This library is free software; you can redistribute it and/or modify it
 663  under the same terms as Perl itself.
 664  
 665  This program is distributed in the hope that it will be useful, but
 666  without any warranty; without even the implied warranty of
 667  merchantability or fitness for a particular purpose.
 668  
 669  =head1 AUTHOR
 670  
 671  Sean M. Burke C<sburke@cpan.org>
 672  
 673  =cut
 674