File Coverage

blib/lib/Encode/Unicode/UTF7.pm
Criterion Covered Total %
statement 52 59 88.1
branch 16 26 61.5
condition n/a
subroutine 9 10 90.0
pod 3 3 100.0
total 80 98 81.6


line stmt bran cond sub pod time code
1             #
2             # $Id: UTF7.pm,v 2.10 2017/06/10 17:23:50 dankogai Exp $
3             #
4             package Encode::Unicode::UTF7;
5 6     6   41 use strict;
  6         16  
  6         197  
6 6     6   40 use warnings;
  6         14  
  6         204  
7 6     6   34 use parent qw(Encode::Encoding);
  6         13  
  6         44  
8             __PACKAGE__->Define('UTF-7');
9             our $VERSION = do { my @r = ( q$Revision: 2.10 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
10 6     6   1960 use MIME::Base64;
  6         1625  
  6         418  
11 6     6   42 use Encode qw(find_encoding);
  6         14  
  6         2204  
12              
13             #
14             # Algorithms taken from Unicode::String by Gisle Aas
15             #
16              
17             our $OPTIONAL_DIRECT_CHARS = 1;
18             my $specials = quotemeta "\'(),-./:?";
19             $OPTIONAL_DIRECT_CHARS
20             and $specials .= quotemeta "!\"#$%&*;<=>@[]^_`{|}";
21              
22             # \s will not work because it matches U+3000 DEOGRAPHIC SPACE
23             # We use qr/[\n\r\t\ ] instead
24             my $re_asis = qr/(?:[\n\r\t\ A-Za-z0-9$specials])/;
25             my $re_encoded = qr/(?:[^\n\r\t\ A-Za-z0-9$specials])/;
26             my $e_utf16 = find_encoding("UTF-16BE");
27              
28 0     0 1 0 sub needs_lines { 1 }
29              
30             sub encode($$;$) {
31 10     10 1 34 my ( $obj, $str, $chk ) = @_;
32 10 100       36 return undef unless defined $str;
33 9         359 my $len = length($str);
34 9         32 pos($str) = 0;
35 9         34 my $bytes = substr($str, 0, 0); # to propagate taintedness
36 9         29 while ( pos($str) < $len ) {
37 4211 100       13192 if ( $str =~ /\G($re_asis+)/ogc ) {
    50          
38 2109         3629 my $octets = $1;
39 2109         4300 utf8::downgrade($octets);
40 2109         5522 $bytes .= $octets;
41             }
42             elsif ( $str =~ /\G($re_encoded+)/ogsc ) {
43 2102 50       4304 if ( $1 eq "+" ) {
44 0         0 $bytes .= "+-";
45             }
46             else {
47 2102         3315 my $s = $1;
48 2102         9596 my $base64 = encode_base64( $e_utf16->encode($s), '' );
49 2102         5775 $base64 =~ s/=+$//;
50 2102         6562 $bytes .= "+$base64-";
51             }
52             }
53             else {
54 0         0 die "This should not happen! (pos=" . pos($str) . ")";
55             }
56             }
57 9 50       27 $_[1] = '' if $chk;
58 9         94 return $bytes;
59             }
60              
61             sub decode($$;$) {
62 6     6   43 use re 'taint';
  6         14  
  6         462  
63 10     10 1 37 my ( $obj, $bytes, $chk ) = @_;
64 10 100       37 return undef unless defined $bytes;
65 9         793 my $len = length($bytes);
66 9         24 my $str = substr($bytes, 0, 0); # to propagate taintedness;
67 9         34 pos($bytes) = 0;
68 6     6   45 no warnings 'uninitialized';
  6         13  
  6         1523  
69 9         35 while ( pos($bytes) < $len ) {
70 4211 100       13401 if ( $bytes =~ /\G([^+]+)/ogc ) {
    50          
    50          
    0          
71 2109         4865 $str .= $1;
72             }
73             elsif ( $bytes =~ /\G\+-/ogc ) {
74 0         0 $str .= "+";
75             }
76             elsif ( $bytes =~ /\G\+([A-Za-z0-9+\/]+)-?/ogsc ) {
77 2102         3552 my $base64 = $1;
78 2102         4024 my $pad = length($base64) % 4;
79 2102 100       4906 $base64 .= "=" x ( 4 - $pad ) if $pad;
80 2102         12576 $str .= $e_utf16->decode( decode_base64($base64) );
81             }
82             elsif ( $bytes =~ /\G\+/ogc ) {
83 0 0       0 $^W and warn "Bad UTF7 data escape";
84 0         0 $str .= "+";
85             }
86             else {
87 0         0 die "This should not happen " . pos($bytes);
88             }
89             }
90 9 50       32 $_[1] = '' if $chk;
91 9         91 return $str;
92             }
93             1;
94             __END__