X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;ds=sidebyside;f=SL%2FRequest.pm;h=a8ae4c13702a0338d49a7418a19f1f662c5ff558;hb=c2f911bdbad03f7b81e0121e4e866bb96586168c;hp=a38f3c0522a4ca047070c5d947843490c8dd9fff;hpb=1954092b8d019bbaedede98167795f08878c8a08;p=kivitendo-erp.git
diff --git a/SL/Request.pm b/SL/Request.pm
index a38f3c052..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;
}
@@ -51,7 +52,11 @@ sub _input_to_hash {
sub _parse_multipart_formdata {
my ($target, $temp_target, $input) = @_;
- my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous, $encoding, $transfer_encoding);
+ 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
@@ -62,12 +67,21 @@ sub _parse_multipart_formdata {
$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;
- ${ $previous } = Encode::decode($encoding, $$previous) if $previous && !$filename && !$transfer_encoding eq 'binary';
+ 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;
@@ -78,7 +92,7 @@ sub _parse_multipart_formdata {
$need_cr = 0;
$encoding = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
$transfer_encoding = undef;
-
+ last if $last_boundary;
next;
}
@@ -89,6 +103,7 @@ sub _parse_multipart_formdata {
if (!$line) {
$headers_done = 1;
+ $data_start = $index + $line_length + 1;
next;
}
@@ -103,13 +118,30 @@ sub _parse_multipart_formdata {
substr $line, $-[0], $+[0] - $-[0], "";
}
- $previous = _store_value(defined $filename ? $target : $temp_target, $name, '') if ($name);
- $temp_target->{FILENAME} = $filename if (defined $filename);
+ if ($name) {
+ # legacy, some old upload routines expect this to be here
+ $temp_target->{FILENAME} = $filename if defined $filename;
+
+ # 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 ($name && defined $filename) {
- _store_value($target, "ATTACHMENTS.$name.data", $previous);
- _store_value($temp_target, "ATTACHMENTS.$name.filename", $filename);
+ # 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;
+ }
}
next;
@@ -117,7 +149,7 @@ sub _parse_multipart_formdata {
if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
$content_type = $1;
- _store_value($temp_target, "ATTACHMENTS.$name.content_type", $1);
+ $p_attachment->{content_type} = $1;
if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
$encoding = $2;
@@ -131,6 +163,7 @@ sub _parse_multipart_formdata {
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;
}
@@ -140,11 +173,10 @@ sub _parse_multipart_formdata {
next unless $previous;
- ${ $previous } .= "${line}\n";
+ } continue {
+ $index += $line_length + 1;
}
- ${ $previous } =~ s|\r?\n$|| if $previous;
-
$::lxdebug->leave_sub(2);
}
@@ -158,7 +190,7 @@ sub _recode_recursively {
# Workaround for a bug: converting $from->{$key} directly
# leads to 'undef'. I don't know why. Converting a copy works,
# though.
- $to->{$key} = $iconv->convert("" . $from->{$key});
+ $to->{$key} = $iconv->convert("" . $from->{$key}) if defined $from->{$key} && !defined $to->{$key};
} else {
$to->{$key} ||= {} if 'HASH' eq ref $from->{$key};
$to->{$key} ||= [] if 'ARRAY' eq ref $from->{$key};
@@ -231,20 +263,216 @@ sub read_cgi_input {
return $target;
}
+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;
+}
+
1;
__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
@@ -253,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: