X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;ds=sidebyside;f=SL%2FRequest.pm;h=a8ae4c13702a0338d49a7418a19f1f662c5ff558;hb=c2f911bdbad03f7b81e0121e4e866bb96586168c;hp=b91bc524ccd130009be6bd029a6c0a48736b6f30;hpb=48abd6c981f62e880b94e1ad9659d0a4d406912b;p=kivitendo-erp.git
diff --git a/SL/Request.pm b/SL/Request.pm
index b91bc524c..a8ae4c137 100644
--- a/SL/Request.pm
+++ b/SL/Request.pm
@@ -6,12 +6,13 @@ use SL::Common;
use SL::MoreCommon qw(uri_encode uri_decode);
use List::Util qw(first max min sum);
use List::MoreUtils qw(all any apply);
+use Exporter qw(import);
-sub _store_value {
- $::lxdebug->enter_sub(2);
+our @EXPORT_OK = qw(flatten unflatten read_cgi_input);
+sub _store_value {
my ($target, $key, $value) = @_;
- my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
+ my @tokens = split /((?:\[\+?\])?(?:\.)|(?:\[\+?\]))/, $key;
my $curr;
if (scalar @tokens) {
@@ -22,7 +23,9 @@ sub _store_value {
my $sep = shift @tokens;
my $key = shift @tokens;
- $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
+ $curr = \ $$curr->[$#$$curr], next if $sep eq '[]' && @tokens;
+ $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]' && !@tokens;
+ $curr = \ $$curr->[++$#$$curr], next if $sep eq '[+]';
$curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
$curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
$curr = \ $$curr->{$key}
@@ -30,8 +33,6 @@ sub _store_value {
$$curr = $value;
- $::lxdebug->leave_sub(2);
-
return $curr;
}
@@ -49,18 +50,38 @@ sub _input_to_hash {
$::lxdebug->leave_sub(2);
}
-sub parse_multipart_formdata {
- my ($target, $input) = @_;
- my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
- my $uploads = {};
+sub _parse_multipart_formdata {
+ my ($target, $temp_target, $input) = @_;
+ my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous, $p_attachment, $encoding, $transfer_encoding);
+ my $data_start = 0;
+
+ # teach substr and length to use good ol' bytes, not 'em fancy characters
+ use bytes;
+
+ # 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...
+ # 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*(.+)$/;
my $boundary = '--' . $1;
+ my $index = 0;
+ my $line_length;
foreach my $line (split m/\n/, $input) {
- last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
+ $line_length = length $line;
- if (($line eq $boundary) || ($line eq "$boundary\r")) {
- ${ $previous } =~ s|\r?\n$|| if $previous;
+ if ($line =~ /^\Q$boundary\E(--)?\r?$/) {
+ my $last_boundary = $1;
+ my $data = substr $input, $data_start, $index - $data_start;
+ $data =~ s/\r?\n$//;
+
+ if ($previous && !$filename && $transfer_encoding && $transfer_encoding ne 'binary') {
+ ${ $previous } = Encode::decode($encoding, $data);
+ } else {
+ ${ $previous } = $data;
+ }
undef $previous;
undef $filename;
@@ -69,7 +90,9 @@ sub parse_multipart_formdata {
$content_type = "text/plain";
$boundary_found = 1;
$need_cr = 0;
-
+ $encoding = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
+ $transfer_encoding = undef;
+ last if $last_boundary;
next;
}
@@ -80,6 +103,7 @@ sub parse_multipart_formdata {
if (!$line) {
$headers_done = 1;
+ $data_start = $index + $line_length + 1;
next;
}
@@ -94,75 +118,97 @@ sub parse_multipart_formdata {
substr $line, $-[0], $+[0] - $-[0], "";
}
- $previous = _store_value($uploads, $name, '') if ($name);
- $target->{FILENAME} = $filename if ($filename);
+ if ($name) {
+ # legacy, some old upload routines expect this to be here
+ $temp_target->{FILENAME} = $filename if defined $filename;
- next;
- }
+ # 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);
- if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
- $content_type = $1;
- }
+ # set the reference for appending of multiline data to the correct one
+ $previous = defined $filename ? $target_slot : $temp_target_slot;
- next;
- }
+ # 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", {});
- next unless $previous;
+ $$target_attachment->{data} = $previous;
+ $$temp_target_attachment->{filename} = $filename;
- ${ $previous } .= "${line}\n";
- }
+ $p_attachment = $$temp_target_attachment;
+ }
+ }
- ${ $previous } =~ s|\r?\n$|| if $previous;
+ next;
+ }
- $::lxdebug->leave_sub(2);
+ if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
+ $content_type = $1;
+ $p_attachment->{content_type} = $1;
-}
+ if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
+ $encoding = $2;
+ }
-sub _request_to_hash {
- $::lxdebug->enter_sub(2);
+ next;
+ }
- my ($target, $input) = @_;
- my $uploads;
+ 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.';
+ }
+ $p_attachment->{transfer_encoding} = $transfer_encoding;
+
+ next;
+ }
- if (!$ENV{'CONTENT_TYPE'}
- || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
+ next;
+ }
- $uploads = { };
- _input_to_hash($target, $input);
+ next unless $previous;
- } else {
- $uploads = _parse_multipart_formdata($target, $input);
+ } continue {
+ $index += $line_length + 1;
}
- $main::lxdebug->leave_sub(2);
- return $uploads;
+ $::lxdebug->leave_sub(2);
}
sub _recode_recursively {
- $main::lxdebug->enter_sub();
- my ($iconv, $param) = @_;
+ $::lxdebug->enter_sub;
+ my ($iconv, $from, $to) = @_;
- if (any { ref $param eq $_ } qw(Form HASH)) {
- foreach my $key (keys %{ $param }) {
- if (!ref $param->{$key}) {
- # Workaround for a bug: converting $param->{$key} directly
+ 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
# leads to 'undef'. I don't know why. Converting a copy works,
# though.
- $param->{$key} = $iconv->convert("" . $param->{$key});
+ $to->{$key} = $iconv->convert("" . $from->{$key}) if defined $from->{$key} && !defined $to->{$key};
} else {
- _recode_recursively($iconv, $param->{$key});
+ $to->{$key} ||= {} if 'HASH' eq ref $from->{$key};
+ $to->{$key} ||= [] if 'ARRAY' eq ref $from->{$key};
+ _recode_recursively($iconv, $from->{$key}, $to->{$key});
}
}
- } elsif (ref $param eq 'ARRAY') {
- foreach my $idx (0 .. scalar(@{ $param }) - 1) {
- if (!ref $param->[$idx]) {
- # Workaround for a bug: converting $param->[$idx] directly
+ } elsif (ref $from eq 'ARRAY') {
+ foreach my $idx (0 .. scalar(@{ $from }) - 1) {
+ if (!ref $from->[$idx]) {
+ # Workaround for a bug: converting $from->[$idx] directly
# leads to 'undef'. I don't know why. Converting a copy works,
# though.
- $param->[$idx] = $iconv->convert("" . $param->[$idx]);
+ $to->[$idx] = $iconv->convert("" . $from->[$idx]);
} else {
- _recode_recursively($iconv, $param->[$idx]);
+ $to->[$idx] ||= {} if 'HASH' eq ref $from->[$idx];
+ $to->[$idx] ||= [] if 'ARRAY' eq ref $from->[$idx];
+ _recode_recursively($iconv, $from->[$idx], $to->[$idx]);
}
}
}
@@ -173,31 +219,99 @@ sub read_cgi_input {
$::lxdebug->enter_sub;
my ($target) = @_;
+ 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.
+
+ # 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 = { };
- _input_to_hash($target, $ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
- _input_to_hash($target, $ARGV[0]) if @ARGV && $ARGV[0];
+ # 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];
- my $uploads;
if ($ENV{CONTENT_LENGTH}) {
my $content;
read STDIN, $content, $ENV{CONTENT_LENGTH};
- $uploads = _request_to_hash($target, $content);
+ 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);
+ }
}
+ my $encoding = delete $temp_target->{INPUT_ENCODING} || $db_charset;
+
+ _recode_recursively(SL::Iconv->new($encoding, $db_charset), $temp_target => $target) if keys %$target;
+
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);
- _input_to_hash($target, join '&', map { uri_encode($_) . '=' . uri_encode($temp_form{$_}) } keys %temp_form);
+ _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
}
- my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
- my $encoding = delete $target->{INPUT_ENCODING} || $db_charset;
+ $::lxdebug->leave_sub;
- _recode_recursively(SL::Iconv->new($encoding, $db_charset), $target);
+ return $target;
+}
- map { $target->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads;
+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";
+ }
- $::lxdebug->leave_sub;
+ return $target;
+}
+
+
+sub unflatten {
+ my ($data, $target) = @_;
+ $target ||= {};
+
+ for my $pair (@$data) {
+ _store_value($target, @$pair) if defined $pair->[0];
+ }
return $target;
}
@@ -208,14 +322,157 @@ __END__
=head1 NAME
-SL::Form.pm - main data object.
+SL::Request.pm - request parsing and data serialization
=head1 SYNOPSIS
-This module handles unpacking of cgi parameters. usually you donÃt want to call
-anything in here directly,
+This module handles unpacking of cgi parameters. usually you don't want to call
+anything in here directly.
+
+ 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);
+
+
+=head1 DESCRIPTION
+
+This module handles flattening and unflattening of data for request
+roundtrip purposes. Lx-Office uses the format as described below:
+
+=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 %]
+
+ [% 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 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
+
+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
+
+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.
- SL::Request::read_cgi_input($target_hash_ref);
+=back
=head1 SPECIAL FUNCTIONS
@@ -224,7 +481,7 @@ anything in here directly,
parses a complex var name, and stores it in the form.
syntax:
- $form->_store_value($key, $value);
+ _store_value($target, $key, $value);
keys must start with a string, and can contain various tokens.
supported key structures are: