File Coverage

lib/HTTP/Promise/Stream/QuotedPrint.pm
Criterion Covered Total %
statement 76 91 83.5
branch 16 42 38.1
condition 8 21 38.1
subroutine 14 17 82.3
pod 7 7 100.0
total 121 178 67.9


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Stream/QuotedPrint.pm
3             ## Version v0.2.0
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/05/30
7             ## Modified 2023/09/08
8             ## All rights reserved.
9             ##
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             package HTTP::Promise::Stream::QuotedPrint;
15             BEGIN
16             {
17 6     6   232087 use strict;
  6         25  
  6         260  
18 6     6   47 use warnings;
  6         24  
  6         261  
19 6     6   788 use HTTP::Promise::Stream;
  6         29  
  6         79  
20 6     6   2474 use parent -norequire, qw( HTTP::Promise::Stream::Generic );
  6         16  
  6         83  
21 6     6   475 use vars qw( @EXPORT_OK $VERSION $EXCEPTION_CLASS $QuotedPrintError $DEBUG );
  6         13  
  6         583  
22 6     6   46 use Encode ();
  6         34  
  6         192  
23 6     6   64 use Module::Generic::File::IO;
  6         22  
  6         84  
24 6     6   3129 our @EXPORT_OK = qw( decode_qp encode_qp );
25 6         23 our $EXCEPTION_CLASS = 'HTTP::Promise::Exception';
26 6         20 our $VERSION = 'v0.2.0';
27 6         165 our $DEBUG = 0;
28             };
29              
30 6     6   49 use strict;
  6         30  
  6         145  
31 6     6   48 use warnings;
  6         77  
  6         5753  
32              
33             sub decode
34             {
35 3     3 1 2274 my $self = shift( @_ );
36 3         7 my $from = shift( @_ );
37 3         4 my $to = shift( @_ );
38 3         27 my $opts = $self->_get_args_as_hash( @_ );
39 3         51 my( $from_fh, $reader ) = $self->_get_glob_from_arg( $from );
40 3         17 my( $to_fh, $writer ) = $self->_get_glob_from_arg( $to, write => 1 );
41 3 50 33     57 return( $self->pass_error ) if( !defined( $from_fh ) || !defined( $to_fh ) );
42 3 50       71 $self->_load_class( 'MIME::QuotedPrint', { no_import => 1 } ) || return( $self->pass_error );
43             # Wrap the filehandle into an object-oriented one that support the getline() method
44 3 50       5349 unless( $self->_can( $from_fh => 'getline' ) )
45             {
46 0         0 my $io = Module::Generic::File::IO->new;
47 0 0       0 $io->fdopen( ( $self->_can( $from_fh => 'fileno' ) ? $from_fh->fileno : fileno( $from_fh ) ), 'r' ) ||
    0          
48             return( $self->pass_error( $io->error ) );
49 0         0 $from_fh = $io;
50             }
51            
52 3         108 my $buff;
53 3         40 while( defined( $buff = $from_fh->getline ) )
54             {
55 10         2037 my $decoded = MIME::QuotedPrint::decode_qp( $buff );
56             # MIME::QuotedPrint::decode_qp() will decode the data into an utf-8 bytes (not the perl's internal representation)
57             # This is fine and we save it as it is in the output
58 10         37 my $rv = $writer->( $decoded );
59 10 50       48 return( $self->pass_error ) if( !defined( $rv ) );
60             }
61 3 50 33     366 return( $self->pass_error( $from_fh->error ) ) if( !defined( $buff ) && $self->_can( $from_fh => 'error' ) && $self->error );
      33        
62 3         494 return( $self );
63             }
64              
65             sub decode_qp
66             {
67 2     2 1 33 my $s = __PACKAGE__->new( debug => $DEBUG );
68 2         23 my $rv = $s->decode( @_ );
69 2 50       526 if( !defined( $rv ) )
70             {
71 0         0 $QuotedPrintError = $s->error;
72 0         0 return;
73             }
74             else
75             {
76 2         12 undef( $QuotedPrintError );
77 2         23 return( $rv );
78             }
79             }
80              
81             sub encode
82             {
83 2     2 1 8471 my $self = shift( @_ );
84 2         16 my $from = shift( @_ );
85 2         10 my $to = shift( @_ );
86 2         25 my $opts = $self->_get_args_as_hash( @_ );
87 2         254 my( $from_fh, $reader ) = $self->_get_glob_from_arg( $from );
88 2         25 my( $to_fh, $writer ) = $self->_get_glob_from_arg( $to, write => 1 );
89 2 50 33     68 return( $self->pass_error ) if( !defined( $from_fh ) || !defined( $to_fh ) );
90 2 50       72 $self->_load_class( 'MIME::QuotedPrint', { no_import => 1 } ) || return( $self->pass_error );
91             # Wrap the filehandle into an object-oriented one that support the getline() method
92 2 50       4972 unless( $self->_can( $from_fh => 'getline' ) )
93             {
94 0         0 my $io = Module::Generic::File::IO->new;
95 0 0       0 $io->fdopen( ( $self->_can( $from_fh => 'fileno' ) ? $from_fh->fileno : fileno( $from_fh ) ), 'r' ) ||
    0          
96             return( $self->pass_error( $io->error ) );
97 0         0 $from_fh = $io;
98             }
99 2 100 66     132 my $eol = ( exists( $opts->{eol} ) && defined( $opts->{eol} ) ) ? $opts->{eol} : $/;
100 2         17 my $has_eol = length( $eol );
101            
102 2         11 my $buff;
103 2         27 while( defined( $buff = $from_fh->getline ) )
104             {
105             # Make sure the chunk of data is in formal utf-8 encoding, i.e. not perl's internal representation
106             # Should probably use Encode::encode( 'utf-8', $buff ) instead though
107 11 50       1357 $buff = Encode::encode_utf8( $buff ) if( Encode::is_utf8( $buff ) );
108 11 50       60 my $encoded = MIME::QuotedPrint::encode_qp( $buff, ( $has_eol ? ( $eol ) : () ) );
109             # MIME::QuotedPrint::decode_qp() will decode the data into an utf-8 bytes (not the perl's internal representation)
110             # This is fine and we save it as it is in the output
111 11         31 my $rv = $writer->( $encoded );
112 11 50       49 return( $self->pass_error ) if( !defined( $rv ) );
113             }
114 2 50 33     229 return( $self->pass_error( $from_fh->error ) ) if( !defined( $buff ) && $self->_can( $from_fh => 'error' ) && $self->error );
      33        
115 2         394 return( $self );
116             }
117              
118             sub encode_qp
119             {
120 1     1 1 18 my $s = __PACKAGE__->new;
121 1         17 my $rv = $s->encode( @_ );
122 1 50       297 if( !defined( $rv ) )
123             {
124 0         0 $QuotedPrintError = $s->error;
125 0         0 return;
126             }
127             else
128             {
129 1         4 undef( $QuotedPrintError );
130 1         12 return( $rv );
131             }
132             }
133              
134 0     0 1   sub encode_qp_utf8 { return( shift->encode_qp( Encode::encode_utf8( shift( @_ ) ) ) ); }
135              
136             sub is_decoder_installed
137             {
138 0     0 1   eval( 'use MIME::QuotedPrint ();' );
139 0 0         return( $@ ? 0 : 1 );
140             }
141              
142             sub is_encoder_installed
143             {
144 0     0 1   eval( 'use MIME::QuotedPrint ();' );
145 0 0         return( $@ ? 0 : 1 );
146             }
147              
148             # NOTE: sub FREEZE is inherited
149              
150             # NOTE: sub STORABLE_freeze is inherited
151              
152             # NOTE: sub STORABLE_thaw is inherited
153              
154             # NOTE: sub THAW is inherited
155              
156             1;
157             # NOTE: POD
158             __END__
159              
160             =encoding utf-8
161              
162             =head1 NAME
163              
164             HTTP::Promise::Stream::QuotedPrint - Stream Encoder for QuotedPrint Encoding
165              
166             =head1 SYNOPSIS
167              
168             use HTTP::Promise::Stream::QuotedPrint;
169             my $s = HTTP::Promise::Stream::QuotedPrint->new ||
170             die( HTTP::Promise::Stream::QuotedPrint->error, "\n" );
171             $s->encode( $input => $output, eol => "\n" ) ||
172             die( $s->error );
173             $s->decode( $input => $output ) || die( $s->error );
174             HTTP::Promise::Stream::QuotedPrint::encode_qp( $input => $output, eol => "\n" ) ||
175             die( $HTTP::Promise::Stream::QuotedPrint::QuotedPrintError );
176             HTTP::Promise::Stream::QuotedPrint::decode_qp( $input => $output, eol => "\n" ) ||
177             die( $HTTP::Promise::Stream::QuotedPrint::QuotedPrintError );
178              
179             =head1 VERSION
180              
181             v0.2.0
182              
183             =head1 DESCRIPTION
184              
185             This implements an encoding and decoding mechanism for quoted-printable encoding using either of the following on input and output:
186              
187             =over 4
188              
189             =item C<filepath>
190              
191             If the parameter is neither a scalar reference nor a file handle, it will be assumed to be a file path.
192              
193             =item C<file handle>
194              
195             This can be a native file handle, or an object oriented one as long as it implements the C<print> or C<write>, and C<read> methods. The C<read> method is expected to return the number of bytes read or C<undef> upon error. The C<print> and C<write> methods are expected to simply return true upon success and C<undef> upon error.
196              
197             Alternatively, those methods can die and those exceptions wil be caught.
198              
199             =item C<scalar reference>
200              
201             This can be a simple scalar reference, or an object scalar reference.
202              
203             =back
204              
205             Requires the XS module L<MIME::QuotedPrint> for encoding and decoding.
206              
207             This encodes and decodes the quoted-printable data according to L<rfc2045, section 6.7|https://tools.ietf.org/html/rfc2045#section-6.7>
208              
209             =head1 CONSTRUCTOR
210              
211             =head2 new
212              
213             Creates a new L<HTTP::Promise::Stream::QuotedPrint> object and returns it.
214              
215             =head1 METHODS
216              
217             =head2 decode
218              
219             This takes 2 arguments: an input and an output. Each one can be either a file path, a file handle, or a scalar reference.
220              
221             It will decode the quoted-printable encoded data and write the result into the output.
222              
223             It returns true upon success and sets an L<error|Module::Generic/error> and return C<undef> upon error.
224              
225             =head2 encode
226              
227             This takes 2 arguments: an input and an output. Each one can be either a file path, a file handle, or a scalar reference.
228              
229             It will encode the data into quoted-printable encoded data and write the result into the output.
230              
231             If the option I<eol> (standing for "End of line") is provided, it will be used at the end of each line of 76 characters. If I<eol> is not provided, it will default to C<$/>, which usually is C<\n>.
232              
233             It returns true upon success and sets an L<error|Module::Generic/error> and return C<undef> upon error.
234              
235             =head1 CLASS FUNCTIONS
236              
237             The following class functions are available and can also be exported, such as:
238              
239             use HTTP::Promise::Stream::QuotedPrint qw( decode_qp encode_qp );
240              
241             =head2 decode_qp
242              
243             This takes the same 2 arguments used in L</decode>: an input and an output. Each one can be either a file path, a file handle, or a scalar reference.
244              
245             It will decode the quoted-printable encoded data and write the result into the output.
246              
247             It returns true upon success, and upon error, it will set the error in the global variable C<$QuotedPrintError> and return C<undef>
248              
249             my $decoded = HTTP::Promise::Stream::QuotedPrint::decode_qp( $encoded );
250             die( "Something went wrong: $HTTP::Promise::Stream::QuotedPrint::QuotedPrintError\n" if( !defined( $decoded ) );
251             print( "Decoded data is: $decoded\n" );
252              
253             =head2 encode_qp
254              
255             This takes the same 2 arguments used in L</encode>: an input and an output. Each one can be either a file path, a file handle, or a scalar reference.
256              
257             It will encode the data into quoted-printable encoded data and write the result into the output.
258              
259             It returns true upon success, and upon error, it will set the error in the global variable C<$QuotedPrintError> and return C<undef>
260              
261             my $encoded = HTTP::Promise::Stream::QuotedPrint::encode_qp( $data );
262             die( "Something went wrong: $HTTP::Promise::Stream::QuotedPrint::QuotedPrintError\n" if( !defined( $encoded ) );
263             print( "Encoded data is: $encoded\n" );
264              
265             =head2 encode_qp_utf8
266              
267             This takes a string, encode it into an UTF-8 string using L<Encode/encode_utf8> and then encode the resulting string into quoted-printable and returns the result.
268              
269             =head2 is_decoder_installed
270              
271             Returns true if the module L<MIME::QuotedPrint> is installed, false otherwise.
272              
273             =head2 is_encoder_installed
274              
275             Returns true if the module L<MIME::QuotedPrint> is installed, false otherwise.
276              
277             =head1 AUTHOR
278              
279             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
280              
281             =head1 SEE ALSO
282              
283             This encodes and decodes the quoted-printable data according to L<rfc2045, section 6.7|https://tools.ietf.org/html/rfc2045#section-6.7>
284              
285             See also the L<Wikipedia page|https://en.wikipedia.org/wiki/Quoted-printable>
286              
287             L<PerlIO::via::QuotedPrint>
288              
289             L<HTTP::Promise>, L<HTTP::Promise::Request>, L<HTTP::Promise::Response>, L<HTTP::Promise::Message>, L<HTTP::Promise::Entity>, L<HTTP::Promise::Headers>, L<HTTP::Promise::Body>, L<HTTP::Promise::Body::Form>, L<HTTP::Promise::Body::Form::Data>, L<HTTP::Promise::Body::Form::Field>, L<HTTP::Promise::Status>, L<HTTP::Promise::MIME>, L<HTTP::Promise::Parser>, L<HTTP::Promise::IO>, L<HTTP::Promise::Stream>, L<HTTP::Promise::Exception>
290              
291             =head1 COPYRIGHT & LICENSE
292              
293             Copyright(c) 2022 DEGUEST Pte. Ltd.
294              
295             All rights reserved.
296              
297             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
298              
299             =cut