our
$VERSION
=
'3.45'
;
our
@ISA
;
BEGIN {
@ISA
= (
'Pod::Simple::PullParser'
)}
BEGIN {
*DEBUG
= \
&Pod::Simple::DEBUG
unless
defined
&DEBUG
}
sub
to_uni ($) {
my
$x
=
shift
;
$x
=
chr
utf8::native_to_unicode(
ord
$x
)
if
$] ge 5.007_003
&&
ord
(
"A"
) != 65;
return
$x
;
}
my
$map_to_self
=
' !"#$%&\'()*+,-./0123456789:;<=>?@ABCDEGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz|~'
;
our
$WRAP
;
$WRAP
= 1
unless
defined
$WRAP
;
our
%Escape
= (
map
( (
chr
(
$_
) =>
sprintf
(
"\\'%02x"
,
$_
)), 0 .. 0xFF),
map
( (
substr
(
$map_to_self
,
$_
, 1)
=> to_uni(
substr
(
$map_to_self
,
$_
, 1))), 0 ..
length
(
$map_to_self
) - 1),
"\r"
=>
"\n"
,
"\cj"
=>
"\n"
,
"\n"
=>
"\n\\line "
,
"\t"
=>
"\\tab "
,
"\f"
=>
"\n\\page\n"
,
"-"
=>
"\\_"
,
$Pod::Simple::nbsp
=>
"\\~"
,
$Pod::Simple::shy
=>
"\\-"
,
"\n"
=>
"\\line\n"
,
"\r"
=>
"\n"
,
"\cb"
=>
"{\n\\cs21\\lang1024\\noproof "
,
"\cc"
=>
"}"
,
);
my
$escaped_sans_hyphen
=
""
;
$escaped_sans_hyphen
.=
$_
for
grep
{
$_
ne
$Escape
{
$_
} &&
$_
ne
'-'
}
sort
keys
%Escape
;
my
$escaped
=
"-$escaped_sans_hyphen"
;
$escaped_sans_hyphen
=
qr/[\Q$escaped_sans_hyphen \E]/
;
$escaped
=
qr/[\Q$escaped\E]/
;
sub
_openclose {
return
map
{;
m/^([-A-Za-z]+)=(\w[^\=]*)$/s or
die
"what's <$_>?"
;
( $1,
"{\\$2\n"
,
"/$1"
,
"}"
);
}
@_
;
}
my
@_to_accept
;
our
%Tagmap
= (
_openclose(
'B=cs18\b'
,
'I=cs16\i'
,
'C=cs19\f1\lang1024\noproof'
,
'F=cs17\i\lang1024\noproof'
,
'VerbatimI=cs26\i'
,
'VerbatimB=cs27\b'
,
'VerbatimBI=cs28\b\i'
,
map
{; m/^([-a-z]+)/s &&
push
@_to_accept
, $1;
$_
}
qw[
underline=ul smallcaps=scaps shadow=shad
superscript=super subscript=sub strikethrough=strike
outline=outl emboss=embo engrave=impr
dotted-underline=uld dash-underline=uldash
dot-dash-underline=uldashd dot-dot-dash-underline=uldashdd
double-underline=uldb thick-underline=ulth
word-underline=ulw wave-underline=ulwave
]
),
'L=pod'
=>
'{\cs22\i'
.
"\n"
,
'L=url'
=>
'{\cs23\i'
.
"\n"
,
'L=man'
=>
'{\cs24\i'
.
"\n"
,
'/L'
=>
'}'
,
'Data'
=>
"\n"
,
'/Data'
=>
"\n"
,
'Verbatim'
=>
"\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n"
,
'/Verbatim'
=>
"\n\\par}\n"
,
'VerbatimFormatted'
=>
"\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n"
,
'/VerbatimFormatted'
=>
"\n\\par}\n"
,
'Para'
=>
"\n{\\pard\\li#rtfindent#\\sa180\n"
,
'/Para'
=>
"\n\\par}\n"
,
'head1'
=>
"\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n"
,
'/head1'
=>
"\n}\\par}\n"
,
'head2'
=>
"\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n"
,
'/head2'
=>
"\n}\\par}\n"
,
'head3'
=>
"\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n"
,
'/head3'
=>
"\n}\\par}\n"
,
'head4'
=>
"\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n"
,
'/head4'
=>
"\n}\\par}\n"
,
'item-bullet'
=>
"\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n"
,
'/item-bullet'
=>
"\n\\par}\n"
,
'item-number'
=>
"\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n"
,
'/item-number'
=>
"\n\\par}\n"
,
'item-text'
=>
"\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n"
,
'/item-text'
=>
"\n\\par}\n"
,
);
sub
new {
my
$new
=
shift
->SUPER::new(
@_
);
$new
->nix_X_codes(1);
$new
->nbsp_for_S(1);
$new
->accept_targets(
'rtf'
,
'RTF'
);
$new
->{
'Tagmap'
} = {
%Tagmap
};
$new
->accept_codes(
@_to_accept
);
$new
->accept_codes(
'VerbatimFormatted'
);
DEBUG > 2 and
print
STDERR
"To accept: "
,
join
(
' '
,
@_to_accept
),
"\n"
;
$new
->doc_lang(
(
$ENV
{
'RTFDEFLANG'
} ||
''
) =~ m/^(\d{1,10})$/s ? $1
: (
$ENV
{
'RTFDEFLANG'
} ||
''
) =~ m/^0?x([a-fA-F0-9]{1,10})$/s ?
hex
($1)
: (
$ENV
{
'RTFDEFLANG'
} ||
''
) =~ m/^([a-fA-F0-9]{4})$/s ?
hex
($1)
:
'1033'
);
$new
->head1_halfpoint_size(32);
$new
->head2_halfpoint_size(28);
$new
->head3_halfpoint_size(25);
$new
->head4_halfpoint_size(22);
$new
->codeblock_halfpoint_size(18);
$new
->header_halfpoint_size(17);
$new
->normal_halfpoint_size(25);
return
$new
;
}
__PACKAGE__->_accessorize(
'doc_lang'
,
'head1_halfpoint_size'
,
'head2_halfpoint_size'
,
'head3_halfpoint_size'
,
'head4_halfpoint_size'
,
'codeblock_halfpoint_size'
,
'header_halfpoint_size'
,
'normal_halfpoint_size'
,
'no_proofing_exemptions'
,
);
sub
run {
my
$self
=
$_
[0];
return
$self
->do_middle
if
$self
->bare_output;
return
$self
->do_beginning &&
$self
->do_middle &&
$self
->do_end;
}
my
$id_re
= Pod::Simple::BlackBox::my_qr(
'[\'_\p{XIDS}][\'\p{XIDC}]+'
,
"ab"
);
$id_re
= Pod::Simple::BlackBox::my_qr(
'[\'_\p{IDS}][\'\p{IDC}]+'
,
"ab"
)
unless
$id_re
;
$id_re
=
qr/['_a-zA-Z]['a-zA-Z0-9_]+/
unless
$id_re
;
sub
do_middle {
my
$self
=
$_
[0];
my
$fh
=
$self
->{
'output_fh'
};
my
(
$token
,
$type
,
$tagname
,
$scratch
);
my
@stack
;
my
@indent_stack
;
$self
->{
'rtfindent'
} = 0
unless
defined
$self
->{
'rtfindent'
};
while
(
$token
=
$self
->get_token) {
if
( (
$type
=
$token
->type) eq
'text'
) {
if
(
$self
->{
'rtfverbatim'
} ) {
DEBUG > 1 and
print
STDERR
" $type "
,
$token
->text,
" in verbatim!\n"
;
rtf_esc(0,
$scratch
=
$token
->text);
print
$fh
$scratch
;
next
;
}
DEBUG > 1 and
print
STDERR
" $type "
,
$token
->text,
"\n"
;
$scratch
=
$token
->text;
$scratch
=~
tr
/\t\cb\cc/ /d;
$self
->{
'no_proofing_exemptions'
} or
$scratch
=~
s/(?:
^
|
(?<=[\r\n\t "\[\<\(])
)
(
(?:
[\$\@\:\<\*\\_]\S+
)
|
(?:
${id_re}[\$\@\:_<>\(\\\*]\S+
)
)
/\cb$1\cc/xsg
;
rtf_esc(1,
$scratch
);
$scratch
=~
s/(
[^\r\n]{65}
[^\r\n ]{0,50}
)
(\ {1,10})(?![\r\n])
/$1$2\n/gx
if
$WRAP
;
print
$fh
$scratch
;
}
elsif
(
$type
eq
'start'
) {
DEBUG > 1 and
print
STDERR
" +$type "
,
$token
->tagname,
" ("
,
map
(
"<$_> "
, %{
$token
->attr_hash}),
")\n"
;
if
( (
$tagname
=
$token
->tagname) eq
'Verbatim'
or
$tagname
eq
'VerbatimFormatted'
) {
++
$self
->{
'rtfverbatim'
};
my
$next
=
$self
->get_token;
next
unless
defined
$next
;
my
$line_count
= 1;
if
(
$next
->type eq
'text'
) {
my
$t
=
$next
->text_r;
while
(
$$t
=~ m/$/mg ) {
last
if
++
$line_count
> 15;
}
DEBUG > 3 and
print
STDERR
" verbatim line count: $line_count\n"
;
}
$self
->unget_token(
$next
);
$self
->{
'rtfkeep'
} = (
$line_count
> 15) ?
''
:
'\keepn'
;
}
elsif
(
$tagname
=~ m/^item-/s ) {
my
@to_unget
;
my
$text_count_here
= 0;
$self
->{
'rtfitemkeepn'
} =
''
;
while
(1) {
push
@to_unget
,
$self
->get_token;
pop
(
@to_unget
),
last
unless
defined
$to_unget
[-1];
if
(
$to_unget
[-1]->type eq
'text'
) {
if
( (
$text_count_here
+=
length
${
$to_unget
[-1]->text_r}) > 150 ){
DEBUG > 1 and
print
STDERR
" item-* is too long to be keepn'd.\n"
;
last
;
}
}
elsif
(
@to_unget
> 1 and
$to_unget
[-2]->type eq
'end'
and
$to_unget
[-2]->tagname =~ m/^item-/s
) {
$self
->{
'rtfitemkeepn'
} =
'\keepn'
if
$to_unget
[-1]->type eq
'start'
and
$to_unget
[-1]->tagname eq
'Para'
;
DEBUG > 1 and
printf
STDERR
" item-* before %s(%s) %s keepn'd.\n"
,
$to_unget
[-1]->type,
$to_unget
[-1]->can(
'tagname'
) ?
$to_unget
[-1]->tagname :
''
,
$self
->{
'rtfitemkeepn'
} ?
"gets"
:
"doesn't get"
;
last
;
}
elsif
(
@to_unget
> 40) {
DEBUG > 1 and
print
STDERR
" item-* now has too many tokens ("
,
scalar
(
@to_unget
),
(DEBUG > 4) ? (
q<: >
,
map
(
$_
->
dump
,
@to_unget
)) : (),
") to be keepn'd.\n"
;
last
;
}
}
$self
->unget_token(
@to_unget
);
}
elsif
(
$tagname
=~ m/^over-/s ) {
push
@stack
, $1;
push
@indent_stack
,
int
(
$token
->attr(
'indent'
) * 4 *
$self
->normal_halfpoint_size);
DEBUG and
print
STDERR
"Indenting over $indent_stack[-1] twips.\n"
;
$self
->{
'rtfindent'
} +=
$indent_stack
[-1];
}
elsif
(
$tagname
eq
'L'
) {
$tagname
.=
'='
. (
$token
->attr(
'type'
) ||
'pod'
);
}
elsif
(
$tagname
eq
'Data'
) {
my
$next
=
$self
->get_token;
next
unless
defined
$next
;
unless
(
$next
->type eq
'text'
) {
$self
->unget_token(
$next
);
next
;
}
DEBUG and
print
STDERR
" raw text "
,
$next
->text,
"\n"
;
printf
$fh
"\n"
.
$next
->text .
"\n"
;
next
;
}
defined
(
$scratch
=
$self
->{
'Tagmap'
}{
$tagname
}) or
next
;
$scratch
=~ s/\
print
$fh
$scratch
;
if
(
$tagname
eq
'item-number'
) {
print
$fh
$token
->attr(
'number'
),
". \n"
;
}
elsif
(
$tagname
eq
'item-bullet'
) {
print
$fh
"\\'"
,
ord
(
"_"
),
"\n"
;
}
}
elsif
(
$type
eq
'end'
) {
DEBUG > 1 and
print
STDERR
" -$type "
,
$token
->tagname,
"\n"
;
if
( (
$tagname
=
$token
->tagname) =~ m/^over-/s ) {
DEBUG and
print
STDERR
"Indenting back $indent_stack[-1] twips.\n"
;
$self
->{
'rtfindent'
} -=
pop
@indent_stack
;
pop
@stack
;
}
elsif
(
$tagname
eq
'Verbatim'
or
$tagname
eq
'VerbatimFormatted'
) {
--
$self
->{
'rtfverbatim'
};
}
defined
(
$scratch
=
$self
->{
'Tagmap'
}{
"/$tagname"
}) or
next
;
$scratch
=~ s/\
print
$fh
$scratch
;
}
}
return
1;
}
sub
do_beginning {
my
$self
=
$_
[0];
my
$fh
=
$self
->{
'output_fh'
};
return
print
$fh
join
''
,
$self
->doc_init,
$self
->font_table,
$self
->stylesheet,
$self
->color_table,
$self
->doc_info,
$self
->doc_start,
"\n"
;
}
sub
do_end {
my
$self
=
$_
[0];
my
$fh
=
$self
->{
'output_fh'
};
return
print
$fh
'}'
;
}
sub
stylesheet {
return
sprintf
<<'END',
{\stylesheet
{\snext0 Normal;}
{\*\cs10 \additive Default Paragraph Font;}
{\*\cs16 \additive \i \sbasedon10 pod-I;}
{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;}
{\*\cs18 \additive \b \sbasedon10 pod-B;}
{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;}
{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;}
{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;}
{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;}
{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;}
{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;}
{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;}
{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;}
{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;}
{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;}
{\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;}
{\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;}
{\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;}
{\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;}
}
END
$_
[0]->codeblock_halfpoint_size(),
$_
[0]->head1_halfpoint_size(),
$_
[0]->head2_halfpoint_size(),
$_
[0]->head3_halfpoint_size(),
$_
[0]->head4_halfpoint_size(),
;
}
sub
font_table {
return
<<'END'; # text font, code font, heading font
{\fonttbl
{\f0\froman Times New Roman;}
{\f1\fmodern Courier New;}
{\f2\fswiss Arial;}
}
END
}
sub
doc_init {
return
<<'END';
{\rtf1\ansi\deff0
END
}
sub
color_table {
return
<<'END';
{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
END
}
sub
doc_info {
my
$self
=
$_
[0];
my
$class
=
ref
(
$self
) ||
$self
;
my
$tag
= __PACKAGE__ .
' '
.
$VERSION
;
unless
(
$class
eq __PACKAGE__) {
$tag
=
" ($tag)"
;
$tag
=
" v"
.
$self
->VERSION .
$tag
if
defined
$self
->VERSION;
$tag
=
$class
.
$tag
;
}
return
sprintf
<<'END',
{\info{\doccomm
%s
using %s v%s
under Perl v%s at %s GMT}
{\author [see doc]}{\company [see doc]}{\operator [see doc]}
}
END
$tag
,
$ISA
[0],
$ISA
[0]->VERSION(),
$],
scalar
(
gmtime
(
$ENV
{SOURCE_DATE_EPOCH} ||
time
)),
;
}
sub
doc_start {
my
$self
=
$_
[0];
my
$title
=
$self
->get_short_title();
DEBUG and
print
STDERR
"Short Title: <$title>\n"
;
$title
.=
' '
if
length
$title
;
$title
=~ s/ *$/ /s;
$title
=~ s/^ //s;
$title
=~ s/ $/, /s;
my
$is_obviously_module_name
;
$is_obviously_module_name
= 1
if
$title
=~ m/^\S+$/s and
$title
=~ m/::/s;
DEBUG and
print
STDERR
"Title0: <$title>\n"
;
$title
= rtf_esc(1,
$title
);
DEBUG and
print
STDERR
"Title1: <$title>\n"
;
$title
=
'\lang1024\noproof '
.
$title
if
$is_obviously_module_name
;
return
sprintf
<<'END',
\deflang%s\plain\lang%s\widowctrl
{\header\pard\qr\plain\f2\fs%s
%s
p.\chpgn\par}
\fs%s
END
(
$self
->doc_lang) x 2,
$self
->header_halfpoint_size,
$title
,
$self
->normal_halfpoint_size,
;
}
my
$question_mark_code_points
=
Pod::Simple::BlackBox::my_qr(
'([^\x00-\x{D7FF}\x{E000}-\x{10FFFF}])'
,
"\x{110000}"
);
my
$plane0
=
Pod::Simple::BlackBox::my_qr(
'([\x{100}-\x{FFFF}])'
,
"\x{100}"
);
my
$other_unicode
=
Pod::Simple::BlackBox::my_qr(
'([\x{10000}-\x{10FFFF}])'
,
"\x{10000}"
);
sub
esc_uni($) {
use
if
$] le 5.006002,
'utf8'
;
my
$x
=
shift
;
$x
=~ s/
$question_mark_code_points
/?/g
if
$question_mark_code_points
;
$x
=~ s/
$plane0
/
'\\uc1\\u'
.((
ord
($1)<32768)?
ord
($1):(
ord
($1)-65536)).
'?'
/eg
if
$plane0
;
$x
=~ s/
$other_unicode
/
'\\uc1\\u'
. ((
ord
($1) >> 10) + 0xD7C0 - 65536) .
'\\u'
. (((
ord
$1) & 0x03FF) + 0xDC00 - 65536) .
'?'
/eg
if
$other_unicode
;
return
$x
;
}
sub
rtf_esc ($$) {
my
$escape_re
= ((
shift
) ?
$escaped
:
$escaped_sans_hyphen
);
my
$x
;
if
(!
defined
wantarray
) {
for
(
@_
) {
s/(
$escape_re
)/
$Escape
{$1}/g;
$_
= esc_uni(
$_
);
}
return
;
}
elsif
(
wantarray
) {
return
map
{; (
$x
=
$_
) =~
s/(
$escape_re
)/
$Escape
{$1}/g;
$x
= esc_uni(
$x
);
$x
;
}
@_
;
}
else
{
(
$x
= ((
@_
== 1) ?
$_
[0] :
join
''
,
@_
)
) =~ s/(
$escape_re
)/
$Escape
{$1}/g;
$x
= esc_uni(
$x
);
return
$x
;
}
}
1;