| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package RTF::Encode; | 
| 2 |  |  |  |  |  |  | # vim:ts=4:shiftwidth=4:expandtab | 
| 3 |  |  |  |  |  |  |  | 
| 4 |  |  |  |  |  |  | # ABSTRACT: Escapes strings into RTF | 
| 5 |  |  |  |  |  |  |  | 
| 6 | 1 |  |  | 1 |  | 76622 | use strict; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 26 |  | 
| 7 | 1 |  |  | 1 |  | 4 | use warnings; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 36 |  | 
| 8 |  |  |  |  |  |  |  | 
| 9 |  |  |  |  |  |  | our $VERSION = '1.01'; | 
| 10 |  |  |  |  |  |  |  | 
| 11 |  |  |  |  |  |  | =head1 NAME | 
| 12 |  |  |  |  |  |  |  | 
| 13 |  |  |  |  |  |  | RTF::Encode - Escapes strings into RTF | 
| 14 |  |  |  |  |  |  |  | 
| 15 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 16 |  |  |  |  |  |  |  | 
| 17 |  |  |  |  |  |  | use RTF::Encode qw/ encode_rtf /; | 
| 18 |  |  |  |  |  |  | print encode_rtf("Smiling cat with heart shaped eyes, ".chr(0x1f63b); | 
| 19 |  |  |  |  |  |  |  | 
| 20 |  |  |  |  |  |  | =cut | 
| 21 |  |  |  |  |  |  |  | 
| 22 | 1 |  |  | 1 |  | 484 | use Encode qw/ encode /; | 
|  | 1 |  |  |  |  | 10263 |  | 
|  | 1 |  |  |  |  | 66 |  | 
| 23 | 1 |  |  | 1 |  | 872 | use parent qw/ Exporter /; | 
|  | 1 |  |  |  |  | 267 |  | 
|  | 1 |  |  |  |  | 4 |  | 
| 24 |  |  |  |  |  |  |  | 
| 25 |  |  |  |  |  |  | our (@EXPORT_OK); | 
| 26 |  |  |  |  |  |  |  | 
| 27 |  |  |  |  |  |  | BEGIN { | 
| 28 | 1 |  |  | 1 |  | 260 | @EXPORT_OK = qw(encode_rtf); | 
| 29 |  |  |  |  |  |  | } | 
| 30 |  |  |  |  |  |  |  | 
| 31 |  |  |  |  |  |  | =head2 encode_rtf | 
| 32 |  |  |  |  |  |  |  | 
| 33 |  |  |  |  |  |  | my $rtf = encode_rtf($unicode); | 
| 34 |  |  |  |  |  |  |  | 
| 35 |  |  |  |  |  |  | This function takes a string, which may contain Unicode characters, and | 
| 36 |  |  |  |  |  |  | returns a string escaped to be used in an RTF file. It can be used to safely | 
| 37 |  |  |  |  |  |  | insert arbitrary text into a template RTF file, perhaps via L. | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | C<\uN> escaping is always used, even for characters less than 255, because | 
| 40 |  |  |  |  |  |  | the alternative, C<\'hh> needs to know the current code page. | 
| 41 |  |  |  |  |  |  |  | 
| 42 |  |  |  |  |  |  | Line breaks are encoded as line breaks, C<\line>, not as paragraphs. | 
| 43 |  |  |  |  |  |  |  | 
| 44 |  |  |  |  |  |  | C<\ucN> is not generated, it does not appear to be necessary. | 
| 45 |  |  |  |  |  |  |  | 
| 46 |  |  |  |  |  |  | =cut | 
| 47 |  |  |  |  |  |  |  | 
| 48 |  |  |  |  |  |  | sub encode_rtf { | 
| 49 | 5 |  |  | 5 | 1 | 80 | my ($string) = @_; | 
| 50 |  |  |  |  |  |  |  | 
| 51 | 5 |  |  |  |  | 7 | my $output = ""; | 
| 52 |  |  |  |  |  |  |  | 
| 53 | 5 |  |  |  |  | 13 | while ($string ne "") { | 
| 54 | 5 | 50 |  |  |  | 28 | $string =~ /^([A-Za-z0-9_\.\, ]*)(.?)(.*)$/s or die "regexp unexpectedly failed for '$string'"; | 
| 55 |  |  |  |  |  |  |  | 
| 56 | 5 |  |  |  |  | 12 | $output .= $1; | 
| 57 | 5 |  |  |  |  | 7 | $string = $3; | 
| 58 |  |  |  |  |  |  |  | 
| 59 | 5 | 50 |  |  |  | 20 | if (!defined $2) { | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | } | 
| 61 |  |  |  |  |  |  | elsif ($2 eq "\n") { | 
| 62 | 1 |  |  |  |  | 3 | $output .= "\\line\n"; | 
| 63 |  |  |  |  |  |  | } | 
| 64 |  |  |  |  |  |  | elsif ($2 eq "\t") { | 
| 65 | 1 |  |  |  |  | 2 | $output .= "\\tab "; | 
| 66 |  |  |  |  |  |  | } | 
| 67 |  |  |  |  |  |  | else { | 
| 68 | 3 |  |  |  |  | 4 | my $char = $2; | 
| 69 | 3 |  |  |  |  | 11 | my $utf16 = encode('UTF16-LE', $char, Encode::FB_CROAK); | 
| 70 | 3 |  |  |  |  | 3209 | my @shorts = unpack("s<*", $utf16); | 
| 71 | 3 |  |  |  |  | 6 | foreach my $s (@shorts) { | 
| 72 | 4 |  |  |  |  | 14 | $output .= "\\u$s\\'3f"; | 
| 73 |  |  |  |  |  |  | } | 
| 74 |  |  |  |  |  |  | } | 
| 75 |  |  |  |  |  |  | } | 
| 76 | 5 |  |  |  |  | 22 | return $output; | 
| 77 |  |  |  |  |  |  | } | 
| 78 |  |  |  |  |  |  |  | 
| 79 |  |  |  |  |  |  | =head1 SPECIFICATION | 
| 80 |  |  |  |  |  |  |  | 
| 81 |  |  |  |  |  |  | L | 
| 82 |  |  |  |  |  |  |  | 
| 83 |  |  |  |  |  |  | =head1 SEE ALSO | 
| 84 |  |  |  |  |  |  |  | 
| 85 |  |  |  |  |  |  | =over | 
| 86 |  |  |  |  |  |  |  | 
| 87 |  |  |  |  |  |  | =item L | 
| 88 |  |  |  |  |  |  |  | 
| 89 |  |  |  |  |  |  | =back | 
| 90 |  |  |  |  |  |  |  | 
| 91 |  |  |  |  |  |  | =head1 AUTHOR | 
| 92 |  |  |  |  |  |  |  | 
| 93 |  |  |  |  |  |  | Dave Lambley | 
| 94 |  |  |  |  |  |  |  | 
| 95 |  |  |  |  |  |  | =head1 LICENSE | 
| 96 |  |  |  |  |  |  |  | 
| 97 |  |  |  |  |  |  | This is free software; you can redistribute it and/or modify it under | 
| 98 |  |  |  |  |  |  | the same terms as the Perl 5 programming language system itself. | 
| 99 |  |  |  |  |  |  |  | 
| 100 |  |  |  |  |  |  | =cut | 
| 101 |  |  |  |  |  |  |  | 
| 102 |  |  |  |  |  |  | 1; |