Projekt

Allgemein

Profil

Herunterladen (18,7 KB) Statistiken
| Zweig: | Markierung: | Revision:
48abd6c9 Sven Schöling
package SL::Request;

use strict;

8c6871be Moritz Bunkus
use parent qw(Rose::Object);

use CGI qw(-no_xhtml);
48abd6c9 Sven Schöling
use List::Util qw(first max min sum);
use List::MoreUtils qw(all any apply);
9414d575 Sven Schöling
use Exporter qw(import);
48abd6c9 Sven Schöling
8c6871be Moritz Bunkus
use SL::Common;
7d5fbd92 Moritz Bunkus
use SL::JSON;
8c6871be Moritz Bunkus
use SL::MoreCommon qw(uri_encode uri_decode);
use SL::Layout::None;
use SL::Presenter;

7d5fbd92 Moritz Bunkus
our @EXPORT_OK = qw(flatten unflatten);
48abd6c9 Sven Schöling
8c6871be Moritz Bunkus
use Rose::Object::MakeMethods::Generic
(
7d5fbd92 Moritz Bunkus
scalar => [ qw(applying_database_upgrades post_data) ],
90d4d3fd Sven Schöling
'scalar --get_set_init' => [ qw(cgi layout presenter is_ajax is_mobile type) ],
8c6871be Moritz Bunkus
);

sub init_cgi {
return CGI->new({});
}

sub init_layout {
return SL::Layout::None->new;
}

sub init_presenter {
return SL::Presenter->new;
}

sub init_is_ajax {
return ($ENV{HTTP_X_REQUESTED_WITH} || '') eq 'XMLHttpRequest' ? 1 : 0;
}

90d4d3fd Sven Schöling
sub init_is_mobile {
# mobile clients will change their user agent when the user requests
# desktop version so user agent is the most reliable way to identify
return ($ENV{HTTP_USER_AGENT} || '') =~ /Mobi/ ? 1 : 0;
}

8c6871be Moritz Bunkus
sub init_type {
return 'html';
}

8e51379e Sven Schöling
sub is_https {
$ENV{HTTPS} && 'on' eq lc $ENV{HTTPS};
}

55872fd8 Moritz Bunkus
sub cache {
my ($self, $topic, $default) = @_;

$topic = '::' . (caller(0))[0] . "::$topic" unless $topic =~ m{^::};

$self->{_cache} //= {};
$self->{_cache}->{$topic} //= ($default // {});

return $self->{_cache}->{$topic};
}

9414d575 Sven Schöling
sub _store_value {
48abd6c9 Sven Schöling
my ($target, $key, $value) = @_;
9414d575 Sven Schöling
my @tokens = split /((?:\[\+?\])?(?:\.)|(?:\[\+?\]))/, $key;
48abd6c9 Sven Schöling
my $curr;

if (scalar @tokens) {
$curr = \ $target->{ shift @tokens };
}

while (@tokens) {
my $sep = shift @tokens;
my $key = shift @tokens;

9414d575 Sven Schöling
$curr = \ $$curr->[$#$$curr], next if $sep eq '[]' && @tokens;
$curr = \ $$curr->[++$#$$curr], next if $sep eq '[]' && !@tokens;
$curr = \ $$curr->[++$#$$curr], next if $sep eq '[+]';
48abd6c9 Sven Schöling
$curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
$curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
$curr = \ $$curr->{$key}
}

$$curr = $value;

return $curr;
}

sub _input_to_hash {
$::lxdebug->enter_sub(2);

e8557567 Sven Schöling
my ($target, $input, $log) = @_;
48abd6c9 Sven Schöling
my @pairs = split(/&/, $input);

foreach (@pairs) {
my ($key, $value) = split(/=/, $_, 2);
e8557567 Sven Schöling
next unless $key;
_store_value($target, uri_decode($key), uri_decode($value));

# for debugging
$::lxdebug->add_request_params(uri_decode($key) => uri_decode($value)) if $log;
48abd6c9 Sven Schöling
}

$::lxdebug->leave_sub(2);
}

6056e1d7 Sven Schöling
sub _parse_multipart_formdata {
e8557567 Sven Schöling
my ($target, $temp_target, $input, $log) = @_;
4785d221 Sven Schöling
my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous, $p_attachment, $encoding, $transfer_encoding);
dc3f6120 Sven Schöling
my $data_start = 0;

# teach substr and length to use good ol' bytes, not 'em fancy characters
use bytes;
6056e1d7 Sven Schöling
# We SHOULD honor encodings and transfer-encodings here, but as hard as I
# looked I couldn't find a reasonably recent webbrowser that makes use of
# these. Transfer encoding just eats up bandwidth...
48abd6c9 Sven Schöling
6056e1d7 Sven Schöling
# so all I'm going to do is add a fail safe that if anyone ever encounters
# this, it's going to croak so that debugging is easier
$ENV{'CONTENT_TYPE'} =~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/;
48abd6c9 Sven Schöling
my $boundary = '--' . $1;

dc3f6120 Sven Schöling
my $index = 0;
my $line_length;
48abd6c9 Sven Schöling
foreach my $line (split m/\n/, $input) {
dc3f6120 Sven Schöling
$line_length = length $line;

if ($line =~ /^\Q$boundary\E(--)?\r?$/) {
my $last_boundary = $1;
my $data = substr $input, $data_start, $index - $data_start;
$data =~ s/\r?\n$//;
48abd6c9 Sven Schöling
dc3f6120 Sven Schöling
if ($previous && !$filename && $transfer_encoding && $transfer_encoding ne 'binary') {
${ $previous } = Encode::decode($encoding, $data);
} else {
${ $previous } = $data;
}
e8557567 Sven Schöling
$::lxdebug->add_request_params($name, $$previous) if $log;
48abd6c9 Sven Schöling
undef $previous;
undef $filename;

$headers_done = 0;
$content_type = "text/plain";
$boundary_found = 1;
$need_cr = 0;
dbda14c2 Moritz Bunkus
$encoding = 'UTF-8';
6056e1d7 Sven Schöling
$transfer_encoding = undef;
dc3f6120 Sven Schöling
last if $last_boundary;
48abd6c9 Sven Schöling
next;
}

next unless $boundary_found;

if (!$headers_done) {
$line =~ s/[\r\n]*$//;

if (!$line) {
$headers_done = 1;
dc3f6120 Sven Schöling
$data_start = $index + $line_length + 1;
48abd6c9 Sven Schöling
next;
}

if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
$filename = $1;
substr $line, $-[0], $+[0] - $-[0], "";
}

if ($line =~ m|name\s*=\s*"(.*?)"|i) {
$name = $1;
substr $line, $-[0], $+[0] - $-[0], "";
}

4785d221 Sven Schöling
if ($name) {
# legacy, some old upload routines expect this to be here
$temp_target->{FILENAME} = $filename if defined $filename;
48abd6c9 Sven Schöling
7c215391 Geoffrey Richardson
# Name can potentially be both a normal variable or a file upload.
# A file upload can be identified by its "filename" attribute.
# The thing is, if a [+] clause vivifies structure in one of the
4785d221 Sven Schöling
# branches it must be done in both, or subsequent "[]" will fail
my $temp_target_slot = _store_value($temp_target, $name);
my $target_slot = _store_value($target, $name);

# set the reference for appending of multiline data to the correct one
$previous = defined $filename ? $target_slot : $temp_target_slot;

# for multiple uploads: save the attachments in a SL/Mailer like structure
if (defined $filename) {
my $target_attachment = _store_value($target, "ATTACHMENTS.$name", {});
my $temp_target_attachment = _store_value($temp_target, "ATTACHMENTS.$name", {});

$$target_attachment->{data} = $previous;
$$temp_target_attachment->{filename} = $filename;

$p_attachment = $$temp_target_attachment;
}
34967eb4 Sven Schöling
}

48abd6c9 Sven Schöling
next;
}

6056e1d7 Sven Schöling
if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
48abd6c9 Sven Schöling
$content_type = $1;
4785d221 Sven Schöling
$p_attachment->{content_type} = $1;
6056e1d7 Sven Schöling
if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
$encoding = $2;
}

next;
}

if ($line =~ m|^content-transfer-encoding\s*=\s*(.*?)$|i) {
$transfer_encoding = lc($1);
if ($transfer_encoding && $transfer_encoding !~ /^[78]bit|binary$/) {
die 'Transfer encodings beyond 7bit/8bit and binary are not implemented.';
}
4785d221 Sven Schöling
$p_attachment->{transfer_encoding} = $transfer_encoding;
6056e1d7 Sven Schöling
next;
48abd6c9 Sven Schöling
}

next;
}

next unless $previous;

dc3f6120 Sven Schöling
} continue {
$index += $line_length + 1;
48abd6c9 Sven Schöling
}

$::lxdebug->leave_sub(2);
}

7d5fbd92 Moritz Bunkus
sub _parse_json_formdata {
my ($content) = @_;

return $content ? SL::JSON::decode_json($content) : undef;
}

48abd6c9 Sven Schöling
sub _recode_recursively {
6056e1d7 Sven Schöling
$::lxdebug->enter_sub;
my ($iconv, $from, $to) = @_;
48abd6c9 Sven Schöling
6056e1d7 Sven Schöling
if (any { ref $from eq $_ } qw(Form HASH)) {
for my $key (keys %{ $from }) {
if (!ref $from->{$key}) {
# Workaround for a bug: converting $from->{$key} directly
48abd6c9 Sven Schöling
# leads to 'undef'. I don't know why. Converting a copy works,
# though.
4785d221 Sven Schöling
$to->{$key} = $iconv->convert("" . $from->{$key}) if defined $from->{$key} && !defined $to->{$key};
48abd6c9 Sven Schöling
} else {
efd3ab01 Sven Schöling
$to->{$key} ||= {} if 'HASH' eq ref $from->{$key};
$to->{$key} ||= [] if 'ARRAY' eq ref $from->{$key};
6056e1d7 Sven Schöling
_recode_recursively($iconv, $from->{$key}, $to->{$key});
48abd6c9 Sven Schöling
}
}

6056e1d7 Sven Schöling
} elsif (ref $from eq 'ARRAY') {
foreach my $idx (0 .. scalar(@{ $from }) - 1) {
if (!ref $from->[$idx]) {
# Workaround for a bug: converting $from->[$idx] directly
48abd6c9 Sven Schöling
# leads to 'undef'. I don't know why. Converting a copy works,
# though.
6ccea476 Martin Helmling
$to->[$idx] = $iconv->convert("" . $from->[$idx]) if defined $from->[$idx] && !defined $to->[$idx];
48abd6c9 Sven Schöling
} else {
efd3ab01 Sven Schöling
$to->[$idx] ||= {} if 'HASH' eq ref $from->[$idx];
$to->[$idx] ||= [] if 'ARRAY' eq ref $from->[$idx];
6056e1d7 Sven Schöling
_recode_recursively($iconv, $from->[$idx], $to->[$idx]);
48abd6c9 Sven Schöling
}
}
}
$main::lxdebug->leave_sub();
}

sub read_cgi_input {
$::lxdebug->enter_sub;

7d5fbd92 Moritz Bunkus
my ($self, $target) = @_;
6056e1d7 Sven Schöling
# yes i know, copying all those values around isn't terribly efficient, but
# the old version of dumping everything into form and then launching a
# tactical recode nuke at the data is still worse.
48abd6c9 Sven Schöling
6056e1d7 Sven Schöling
# this way the data can at least be recoded on the fly as soon as we get to
# know the source encoding and only in the cases where encoding may be hidden
# among the payload we take the hit of copying the request around
7d5fbd92 Moritz Bunkus
$self->post_data(undef);
my $data_to_decode = { };
my $iconv = SL::Iconv->new('UTF-8', 'UTF-8');
6056e1d7 Sven Schöling
7d5fbd92 Moritz Bunkus
_input_to_hash($data_to_decode, $ENV{QUERY_STRING}, 1) if $ENV{QUERY_STRING};
_input_to_hash($data_to_decode, $ARGV[0], 1) if @ARGV && $ARGV[0];
48abd6c9 Sven Schöling
if ($ENV{CONTENT_LENGTH}) {
my $content;
read STDIN, $content, $ENV{CONTENT_LENGTH};
7d5fbd92 Moritz Bunkus
6056e1d7 Sven Schöling
if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
7d5fbd92 Moritz Bunkus
$self->post_data({});
my $post_data_to_decode = { };

6056e1d7 Sven Schöling
# multipart formdata can bring it's own encoding, so give it both
7c215391 Geoffrey Richardson
# and let it decide on it's own
7d5fbd92 Moritz Bunkus
_parse_multipart_formdata($self->post_data, $post_data_to_decode, $content, 1);
_recode_recursively($iconv, $post_data_to_decode, $self->post_data) if keys %$post_data_to_decode;

$target->{$_} = $self->post_data->{$_} for keys %{ $self->post_data };

bfe30464 Moritz Bunkus
} elsif (($ENV{CONTENT_TYPE} // '') =~ m{^application/json}i) {
7d5fbd92 Moritz Bunkus
$self->post_data(_parse_json_formdata($content));

6056e1d7 Sven Schöling
} else {
# normal encoding must be recoded
7d5fbd92 Moritz Bunkus
_input_to_hash($data_to_decode, $content, 1);
6056e1d7 Sven Schöling
}
48abd6c9 Sven Schöling
}

7d5fbd92 Moritz Bunkus
_recode_recursively($iconv, $data_to_decode, $target) if keys %$data_to_decode;
ec52855f Sven Schöling
48abd6c9 Sven Schöling
if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
my %temp_form;
$::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
6056e1d7 Sven Schöling
_store_value($target, $_, $temp_form{$_}) for keys %temp_form;
48abd6c9 Sven Schöling
}

$::lxdebug->leave_sub;

return $target;
}

9414d575 Sven Schöling
sub flatten {
my ($source, $target, $prefix, $in_array) = @_;
$target ||= [];

7c215391 Geoffrey Richardson
# There are two edge cases that need attention. First: more than one hash
# inside an array. Only the first of each nested can have a [+]. Second: if
9414d575 Sven Schöling
# an array contains mixed values _store_value will rely on autovivification.
7c215391 Geoffrey Richardson
# So any type change must have a [+]
# This closure decides one recursion step AFTER an array has been found if a
9414d575 Sven Schöling
# [+] needs to be generated
my $arr_prefix = sub {
return $_[0] ? '[+]' : '[]' if $in_array;
return '';
};

for (ref $source) {
/^HASH$/ && do {
my $first = 1;
95470a2f Sven Schöling
for my $key (sort keys %$source) {
9414d575 Sven Schöling
flatten($source->{$key} => $target, (defined $prefix ? $prefix . $arr_prefix->($first) . '.' : '') . $key);
$first = 0;
};
next;
};
/^ARRAY$/ && do {
for my $i (0 .. $#$source) {
flatten($source->[$i] => $target, $prefix . $arr_prefix->($i == 0), '1');
}
next;
};
!$_ && do {
die "can't flatten a pure scalar" unless defined $prefix;
push @$target, [ $prefix . $arr_prefix->(0) => $source ];
next;
};
die "unrecognized reference of a data structure $_. cannot serialize refs, globs and code yet. to serialize Form please use the method there";
}

return $target;
}


sub unflatten {
my ($data, $target) = @_;
$target ||= {};

for my $pair (@$data) {
_store_value($target, @$pair) if defined $pair->[0];
}

return $target;
}

48abd6c9 Sven Schöling
1;

__END__

=head1 NAME

8c6871be Moritz Bunkus
SL::Request.pm - request parsing, data serialization, request information
48abd6c9 Sven Schöling
=head1 SYNOPSIS

8c6871be Moritz Bunkus
This module handles unpacking of CGI parameters. It also gives
7c215391 Geoffrey Richardson
information about the request, such as whether or not it was done via AJAX,
8c6871be Moritz Bunkus
or the requested content type.
9414d575 Sven Schöling
7d5fbd92 Moritz Bunkus
use SL::Request;
9414d575 Sven Schöling
# read cgi input depending on request type, unflatten and recode
7d5fbd92 Moritz Bunkus
$::request->read_cgi_input($target_hash_ref);
9414d575 Sven Schöling
# $hashref and $new_hashref should be identical
my $new_arrayref = flatten($hashref);
my $new_hashref = unflatten($new_arrayref);

8c6871be Moritz Bunkus
# Handle AJAX requests differently than normal requests:
if ($::request->is_ajax) {
$controller->render('json-mask', { type => 'json' });
} else {
$controller->render('full-mask');
}
9414d575 Sven Schöling
=head1 DESCRIPTION

8c6871be Moritz Bunkus
This module provides information about the request made by the
browser.

It also handles flattening and unflattening of data for request
008c2e15 Moritz Bunkus
roundtrip purposes. kivitendo uses the format as described below:
9414d575 Sven Schöling
=over 4

=item Hashes

Hash entries will be connected with a dot (C<.>). A simple hash like this

order => {
item => 2,
customer => 5
}

will be serialized to

[ order.item => 2 ],
[ order.customer => 5 ],

=item Arrays

7c215391 Geoffrey Richardson
Arrays will be marked by empty brackets (C<[]>). A hash like this
9414d575 Sven Schöling
selected_id => [ 2, 6, 8, 9 ]

will be flattened to

[ selected_id[] => 2 ],
[ selected_id[] => 6 ],
[ selected_id[] => 8 ],
[ selected_id[] => 9 ],

Since this will produce identical keys, the resulting flattened list can not be
used as a hash. It is however very easy to use this in a template to generate
input:

[% FOREACH id = selected_ids %]
<input type="hidden" name="selected_id[]" value="[% id | html %]">
[% END %]

=item Nested structures

7c215391 Geoffrey Richardson
A special version of this are nested hashes in an array, which is very common.
9414d575 Sven Schöling
The combined operator (C<[].>) will be used. As a special case, every time a new
array slice is started, the special convention (C<[+].>) will be used. Again this
is because it's easy to write a template with it.

So this

order => {
orderitems => [
{
id => 1,
part => 15
},
{
id => 2,
part => 7
},
]
}

will be

[ order.orderitems[+].id => 1 ],
[ order.orderitems[].part => 15 ],
[ order.orderitems[+].id => 2 ],
[ order.orderitems[].part => 7 ],

=item Limitations

The format currently does have certain limitations when compared to other
serialization formats.

=over 4

=item Order

The order of serialized values matters to reconstruct arrays properly. This
should rarely be a problem if you just flatten and dump into a url or a field
of hiddens.

=item Empty Keys

The current implementation of flatten does produce correct serialization of
empty keys, but unflatten is unable to resolve these. Do no use C<''> or
C<undef> as keys. C<0> is fine.

=item Key Escaping

You cannot use the tokens C<[]>, C<[+]> and C<.> in keys. No way around it.

=item Sparse Arrays

7c215391 Geoffrey Richardson
It is not possible to serialize something like
9414d575 Sven Schöling
sparse_array => do { my $sa = []; $sa[100] = 1; $sa },

This is a feature, as perl doesn't do well with very large arrays.

=item Recursion

There is currently no support nor prevention for flattening a circular structure.

=item Custom Delimiter

No support for other delimiters, sorry.

=item Other References

No support for globs, scalar refs, code refs, filehandles and the like. These will die.

=back

=back

=head1 FUNCTIONS

=over 4

=item C<flatten HASHREF [ ARRAYREF ]>

This function will flatten the provided hash ref into the provided array ref.
The array ref may be non empty, but will be changed in this case.

7c215391 Geoffrey Richardson
The return value is the flattened array ref.
9414d575 Sven Schöling
=item C<unflatten ARRAYREF [ HASHREF ]>

This function will parse the array ref, and will store the contents into the hash ref. The hash ref may be non empty, in this case any new keys will override the old ones only on leafs with same type. Type changes on a node will die.
48abd6c9 Sven Schöling
8c6871be Moritz Bunkus
=item C<is_ajax>

Returns trueish if the request is an XML HTTP request, also known as
an 'AJAX' request.

=item C<type>

Returns the requested content type (either C<html>, C<js> or C<json>).

42f69828 Sven Schöling
=item C<layout>

Set and retrieve the layout object for the current request. Must be an instance
7c215391 Geoffrey Richardson
of L<SL::Layout::Base>. Defaults to an instance of L<SL::Layout::None>.
42f69828 Sven Schöling
For more information about layouts, see L<SL::Layout::Dispatcher>.

55872fd8 Moritz Bunkus
=item C<cache $topic[, $default ]>

Caches an item for the duration of the request. C<$topic> must be an
index name referring to the thing to cache. It is used for retrieving
it later on. If C<$topic> doesn't start with C<::> then the caller's
package name is prepended to the topic. For example, if the a from
package C<SL::StuffedStuff> calls with topic = C<get_stuff> then the
actual key will be C<::SL::StuffedStuff::get_stuff>.

If no item exists in the cache for C<$topic> then it is created and
its initial value is set to C<$default>. If C<$default> is not given
(undefined) then a new, empty hash reference is created.

Returns the cached item.

7d5fbd92 Moritz Bunkus
=item C<post_data>

If the client sends data in the request body with the content type of
either C<application/json> or C<multipart/form-data>, the content will
be stored in the global request object, too. It can be retrieved via
the C<post_data> function.

For content type C<multipart/form-data> the same data is additionally
stored in the global C<$::form> instance, potentially overwriting
parameters given in the URL. This is done primarily for compatibility
purposes with existing code that expects all parameters to be present
in C<$::form>.

For content type C<application/json> the data is only available in
C<$::request>. The reason is that the top-level data in a JSON
documents doesn't have to be an object which could be mapped to the
hash C<$::form>. Instead, the top-level data can also be an
array. Additionally keeping the namespaces of URL and POST parameters
separate is cleaner and allows for fewer accidental conflicts.

9414d575 Sven Schöling
=back
48abd6c9 Sven Schöling
=head1 SPECIAL FUNCTIONS

=head2 C<_store_value()>

7c215391 Geoffrey Richardson
Parses a complex var name, and stores it in the form.
48abd6c9 Sven Schöling
7c215391 Geoffrey Richardson
Syntax:
9414d575 Sven Schöling
_store_value($target, $key, $value);
48abd6c9 Sven Schöling
7c215391 Geoffrey Richardson
Keys must start with a string, and can contain various tokens.
Supported key structures are:
48abd6c9 Sven Schöling
1. simple access
7c215391 Geoffrey Richardson
Simple key strings work as expected
48abd6c9 Sven Schöling
id => $form->{id}

2. hash access.
7c215391 Geoffrey Richardson
Separating two keys by a dot (.) will result in a hash lookup for the inner value
This is similar to the behaviour of java and templating mechanisms.
48abd6c9 Sven Schöling
filter.description => $form->{filter}->{description}

3. array+hashref access

7c215391 Geoffrey Richardson
Adding brackets ([]) before the dot will cause the next hash to be put into an array.
Using [+] instead of [] will force a new array index. This is useful for recurring
data structures like part lists. Put a [+] into the first varname, and use [] on the
48abd6c9 Sven Schöling
following ones.

7c215391 Geoffrey Richardson
Repeating these names in your template:
48abd6c9 Sven Schöling
invoice.items[+].id
invoice.items[].parts_id

will result in:

$form->{invoice}->{items}->[
{
id => ...
parts_id => ...
},
{
id => ...
parts_id => ...
}
...
]

4. arrays

7c215391 Geoffrey Richardson
Using brackets at the end of a name will result in the creation of a pure array.
Note that you mustn't use [+], which is reserved for array+hash access and will
48abd6c9 Sven Schöling
result in undefined behaviour in array context.

filter.status[] => $form->{status}->[ val1, val2, ... ]

=cut