1package Web::Machine::Util::BodyEncoding;
2# ABSTRACT: Module to handle body encoding
3
4use strict;
5use warnings;
6
7our $VERSION = '0.17';
8
9use Scalar::Util qw/ weaken isweak /;
10use Encode ();
11use Web::Machine::Util qw[ first pair_key pair_value ];
12
13use Sub::Exporter -setup => {
14    exports => [qw[
15        encode_body_if_set
16        encode_body
17    ]]
18};
19
20sub encode_body_if_set {
21    my ($resource, $response) = @_;
22    encode_body( $resource, $response ) if $response->body;
23}
24
25sub encode_body {
26    my ($resource, $response) = @_;
27
28    my $metadata        = $resource->request->env->{'web.machine.context'};
29    my $chosen_encoding = $metadata->{'Content-Encoding'};
30    my $encoder         = $resource->encodings_provided->{ $chosen_encoding };
31
32    my $chosen_charset = $metadata->{'Charset'};
33    my $charsetter;
34    if ( $chosen_charset && $resource->charsets_provided ) {
35        my $match =             first {
36                my $name = $_ && ref $_ ? pair_key($_) : $_;
37                $name && $name eq $chosen_charset;
38            }
39            @{ $resource->charsets_provided };
40
41        $charsetter
42            = ref $match
43            ? pair_value($match)
44            : sub { Encode::encode( $match, $_[1] ) };
45    }
46
47    $charsetter ||= sub { $_[1] };
48
49    push @{ $resource->request->env->{'web.machine.content_filters'} ||= [] },
50        sub {
51            my $chunk = shift;
52            weaken $resource unless isweak $resource;
53            return unless defined $chunk;
54            return $resource->$encoder($resource->$charsetter($chunk));
55        };
56}
57
58
591;
60
61__END__
62
63=pod
64
65=encoding UTF-8
66
67=head1 NAME
68
69Web::Machine::Util::BodyEncoding - Module to handle body encoding
70
71=head1 VERSION
72
73version 0.17
74
75=head1 SYNOPSIS
76
77  use Web::Machine::Util::BodyEncoding;
78
79=head1 DESCRIPTION
80
81This handles the body encoding.
82
83=head1 FUNCTIONS
84
85=over 4
86
87=item C<encode_body_if_set ( $resource, $response, $metadata )>
88
89If the C<$response> has a body, this will call C<encode_body>.
90
91=item C<encode_body ( $resource, $response, $metadata )>
92
93This will find the right encoding (from the 'Content-Encoding' entry
94in the C<$metadata> HASH ref) and the right charset (from the 'Charset'
95entry in the C<$metadata> HASH ref), then find the right transformers
96in the C<$resource>. After that it will attempt to convert the charset
97and encode the body of the C<$response>. Once completed it will set
98the C<Content-Length> header in the response as well.
99
100B<CAVEAT:> Note that currently this subroutine doesn't do anything when the
101body is returned as a CODE ref. This is a bug to be remedied in the future.
102
103=back
104
105=head1 SUPPORT
106
107bugs may be submitted through L<https://github.com/houseabsolute/webmachine-perl/issues>.
108
109=head1 AUTHORS
110
111=over 4
112
113=item *
114
115Stevan Little <stevan@cpan.org>
116
117=item *
118
119Dave Rolsky <autarch@urth.org>
120
121=back
122
123=head1 COPYRIGHT AND LICENCE
124
125This software is copyright (c) 2016 by Infinity Interactive, Inc.
126
127This is free software; you can redistribute it and/or modify it under
128the same terms as the Perl 5 programming language system itself.
129
130=cut
131