Projekt

Allgemein

Profil

Herunterladen (16 KB) Statistiken
| Zweig: | Markierung: | Revision:

kivitendo/SL/Request.pm @ 245d5036

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;
use SL::MoreCommon qw(uri_encode uri_decode);
use SL::Layout::None;
use SL::Presenter;

9414d575 Sven Schöling
our @EXPORT_OK = qw(flatten unflatten read_cgi_input);
48abd6c9 Sven Schöling
8c6871be Moritz Bunkus
use Rose::Object::MakeMethods::Generic
(
'scalar --get_set_init' => [ qw(cgi layout presenter is_ajax type) ],
);

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;
}

sub init_type {
return 'html';
}

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);

my ($target, $input) = @_;
my @pairs = split(/&/, $input);

foreach (@pairs) {
my ($key, $value) = split(/=/, $_, 2);
_store_value($target, uri_decode($key), uri_decode($value)) if ($key);
}

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

6056e1d7 Sven Schöling
sub _parse_multipart_formdata {
my ($target, $temp_target, $input) = @_;
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;
}
48abd6c9 Sven Schöling
undef $previous;
undef $filename;

$headers_done = 0;
$content_type = "text/plain";
$boundary_found = 1;
$need_cr = 0;
6056e1d7 Sven Schöling
$encoding = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
$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
4785d221 Sven Schöling
# 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 atructur in one of the
# 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);
}

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.
40d21a2d Sven Schöling
$to->[$idx] = $iconv->convert("" . $from->[$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;

my ($target) = @_;
6056e1d7 Sven Schöling
my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;

# 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
my $temp_target = { };

# since both of these can potentially bring their encoding in INPUT_ENCODING
# they get dumped into temp_target
_input_to_hash($temp_target, $ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
_input_to_hash($temp_target, $ARGV[0]) if @ARGV && $ARGV[0];
48abd6c9 Sven Schöling
if ($ENV{CONTENT_LENGTH}) {
my $content;
read STDIN, $content, $ENV{CONTENT_LENGTH};
6056e1d7 Sven Schöling
if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
# multipart formdata can bring it's own encoding, so give it both
# and let ti decide on it's own
_parse_multipart_formdata($target, $temp_target, $content);
} else {
# normal encoding must be recoded
_input_to_hash($temp_target, $content);
}
48abd6c9 Sven Schöling
}

ec52855f Sven Schöling
my $encoding = delete $temp_target->{INPUT_ENCODING} || $db_charset;

_recode_recursively(SL::Iconv->new($encoding, $db_charset), $temp_target => $target) if keys %$target;

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 ||= [];

# 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
# an array contains mixed values _store_value will rely on autovivification.
# so any type change must have a [+]
# this closure decides one recursion step AFTER an array has been found if a
# [+] needs to be generated
my $arr_prefix = sub {
return $_[0] ? '[+]' : '[]' if $in_array;
return '';
};

for (ref $source) {
/^HASH$/ && do {
my $first = 1;
for my $key (keys %$source) {
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
information about the request like whether or not it was done via AJAX
or the requested content type.
9414d575 Sven Schöling
use SL::Request qw(read_cgi_input);

# read cgi input depending on request type, unflatten and recode
read_cgi_input($target_hash_ref);

# $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

Arrays will by trailing empty brackets (C<[]>). An hash like this

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

A special version of this are nested hashs in an array, which is very common.
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

It is not possible to serialize somehing like

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.

Return value is the flattened array ref.

=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
of L<SL::Layout::Base>. Defaults to an isntance of L<SL::Layout::None>.

For more information about layouts, see L<SL::Layout::Dispatcher>.

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

=head2 C<_store_value()>

parses a complex var name, and stores it in the form.

syntax:
9414d575 Sven Schöling
_store_value($target, $key, $value);
48abd6c9 Sven Schöling
keys must start with a string, and can contain various tokens.
supported key structures are:

1. simple access
simple key strings work as expected

id => $form->{id}

2. hash access.
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.

filter.description => $form->{filter}->{description}

3. array+hashref access

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
following ones.

repeating these names in your template:

invoice.items[+].id
invoice.items[].parts_id

will result in:

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

4. arrays

using brackets at the end of a name will result in a pure array to be created.
note that you mustn't use [+], which is reserved for array+hash access and will
result in undefined behaviour in array context.

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

=cut