5 use parent qw(Rose::Object);
8 use List::Util qw(first max min sum);
9 use List::MoreUtils qw(all any apply);
10 use Exporter qw(import);
13 use SL::MoreCommon qw(uri_encode uri_decode);
17 our @EXPORT_OK = qw(flatten unflatten read_cgi_input);
19 use Rose::Object::MakeMethods::Generic
21 scalar => [ qw(applying_database_upgrades) ],
22 'scalar --get_set_init' => [ qw(cgi layout presenter is_ajax type) ],
30 return SL::Layout::None->new;
34 return SL::Presenter->new;
38 return ($ENV{HTTP_X_REQUESTED_WITH} || '') eq 'XMLHttpRequest' ? 1 : 0;
46 my ($self, $topic, $default) = @_;
48 $topic = '::' . (caller(0))[0] . "::$topic" unless $topic =~ m{^::};
50 $self->{_cache} //= {};
51 $self->{_cache}->{$topic} //= ($default // {});
53 return $self->{_cache}->{$topic};
57 my ($target, $key, $value) = @_;
58 my @tokens = split /((?:\[\+?\])?(?:\.)|(?:\[\+?\]))/, $key;
62 $curr = \ $target->{ shift @tokens };
66 my $sep = shift @tokens;
67 my $key = shift @tokens;
69 $curr = \ $$curr->[$#$$curr], next if $sep eq '[]' && @tokens;
70 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]' && !@tokens;
71 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[+]';
72 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
73 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
74 $curr = \ $$curr->{$key}
83 $::lxdebug->enter_sub(2);
85 my ($target, $input, $log) = @_;
86 my @pairs = split(/&/, $input);
89 my ($key, $value) = split(/=/, $_, 2);
91 _store_value($target, uri_decode($key), uri_decode($value));
94 $::lxdebug->add_request_params(uri_decode($key) => uri_decode($value)) if $log;
97 $::lxdebug->leave_sub(2);
100 sub _parse_multipart_formdata {
101 my ($target, $temp_target, $input, $log) = @_;
102 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous, $p_attachment, $encoding, $transfer_encoding);
105 # teach substr and length to use good ol' bytes, not 'em fancy characters
108 # We SHOULD honor encodings and transfer-encodings here, but as hard as I
109 # looked I couldn't find a reasonably recent webbrowser that makes use of
110 # these. Transfer encoding just eats up bandwidth...
112 # so all I'm going to do is add a fail safe that if anyone ever encounters
113 # this, it's going to croak so that debugging is easier
114 $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/;
115 my $boundary = '--' . $1;
119 foreach my $line (split m/\n/, $input) {
120 $line_length = length $line;
122 if ($line =~ /^\Q$boundary\E(--)?\r?$/) {
123 my $last_boundary = $1;
124 my $data = substr $input, $data_start, $index - $data_start;
127 if ($previous && !$filename && $transfer_encoding && $transfer_encoding ne 'binary') {
128 ${ $previous } = Encode::decode($encoding, $data);
130 ${ $previous } = $data;
132 $::lxdebug->add_request_params($name, $$previous) if $log;
138 $content_type = "text/plain";
142 $transfer_encoding = undef;
143 last if $last_boundary;
147 next unless $boundary_found;
149 if (!$headers_done) {
150 $line =~ s/[\r\n]*$//;
154 $data_start = $index + $line_length + 1;
158 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
159 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
161 substr $line, $-[0], $+[0] - $-[0], "";
164 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
166 substr $line, $-[0], $+[0] - $-[0], "";
170 # legacy, some old upload routines expect this to be here
171 $temp_target->{FILENAME} = $filename if defined $filename;
173 # Name can potentially be both a normal variable or a file upload.
174 # A file upload can be identified by its "filename" attribute.
175 # The thing is, if a [+] clause vivifies structure in one of the
176 # branches it must be done in both, or subsequent "[]" will fail
177 my $temp_target_slot = _store_value($temp_target, $name);
178 my $target_slot = _store_value($target, $name);
180 # set the reference for appending of multiline data to the correct one
181 $previous = defined $filename ? $target_slot : $temp_target_slot;
183 # for multiple uploads: save the attachments in a SL/Mailer like structure
184 if (defined $filename) {
185 my $target_attachment = _store_value($target, "ATTACHMENTS.$name", {});
186 my $temp_target_attachment = _store_value($temp_target, "ATTACHMENTS.$name", {});
188 $$target_attachment->{data} = $previous;
189 $$temp_target_attachment->{filename} = $filename;
191 $p_attachment = $$temp_target_attachment;
198 if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
200 $p_attachment->{content_type} = $1;
202 if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
209 if ($line =~ m|^content-transfer-encoding\s*=\s*(.*?)$|i) {
210 $transfer_encoding = lc($1);
211 if ($transfer_encoding && $transfer_encoding !~ /^[78]bit|binary$/) {
212 die 'Transfer encodings beyond 7bit/8bit and binary are not implemented.';
214 $p_attachment->{transfer_encoding} = $transfer_encoding;
222 next unless $previous;
225 $index += $line_length + 1;
228 $::lxdebug->leave_sub(2);
231 sub _recode_recursively {
232 $::lxdebug->enter_sub;
233 my ($iconv, $from, $to) = @_;
235 if (any { ref $from eq $_ } qw(Form HASH)) {
236 for my $key (keys %{ $from }) {
237 if (!ref $from->{$key}) {
238 # Workaround for a bug: converting $from->{$key} directly
239 # leads to 'undef'. I don't know why. Converting a copy works,
241 $to->{$key} = $iconv->convert("" . $from->{$key}) if defined $from->{$key} && !defined $to->{$key};
243 $to->{$key} ||= {} if 'HASH' eq ref $from->{$key};
244 $to->{$key} ||= [] if 'ARRAY' eq ref $from->{$key};
245 _recode_recursively($iconv, $from->{$key}, $to->{$key});
249 } elsif (ref $from eq 'ARRAY') {
250 foreach my $idx (0 .. scalar(@{ $from }) - 1) {
251 if (!ref $from->[$idx]) {
252 # Workaround for a bug: converting $from->[$idx] directly
253 # leads to 'undef'. I don't know why. Converting a copy works,
255 $to->[$idx] = $iconv->convert("" . $from->[$idx]) if defined $from->[$idx] && !defined $to->[$idx];
257 $to->[$idx] ||= {} if 'HASH' eq ref $from->[$idx];
258 $to->[$idx] ||= [] if 'ARRAY' eq ref $from->[$idx];
259 _recode_recursively($iconv, $from->[$idx], $to->[$idx]);
263 $main::lxdebug->leave_sub();
267 $::lxdebug->enter_sub;
271 # yes i know, copying all those values around isn't terribly efficient, but
272 # the old version of dumping everything into form and then launching a
273 # tactical recode nuke at the data is still worse.
275 # this way the data can at least be recoded on the fly as soon as we get to
276 # know the source encoding and only in the cases where encoding may be hidden
277 # among the payload we take the hit of copying the request around
278 my $temp_target = { };
280 # since both of these can potentially bring their encoding in INPUT_ENCODING
281 # they get dumped into temp_target
282 _input_to_hash($temp_target, $ENV{QUERY_STRING}, 1) if $ENV{QUERY_STRING};
283 _input_to_hash($temp_target, $ARGV[0], 1) if @ARGV && $ARGV[0];
285 if ($ENV{CONTENT_LENGTH}) {
287 read STDIN, $content, $ENV{CONTENT_LENGTH};
288 if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
289 # multipart formdata can bring it's own encoding, so give it both
290 # and let it decide on it's own
291 _parse_multipart_formdata($target, $temp_target, $content, 1);
293 # normal encoding must be recoded
294 _input_to_hash($temp_target, $content, 1);
298 my $encoding = delete $temp_target->{INPUT_ENCODING} || 'UTF-8';
300 _recode_recursively(SL::Iconv->new($encoding, 'UTF-8'), $temp_target => $target) if keys %$target;
302 if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
304 $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
305 _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
308 $::lxdebug->leave_sub;
314 my ($source, $target, $prefix, $in_array) = @_;
317 # There are two edge cases that need attention. First: more than one hash
318 # inside an array. Only the first of each nested can have a [+]. Second: if
319 # an array contains mixed values _store_value will rely on autovivification.
320 # So any type change must have a [+]
321 # This closure decides one recursion step AFTER an array has been found if a
322 # [+] needs to be generated
323 my $arr_prefix = sub {
324 return $_[0] ? '[+]' : '[]' if $in_array;
331 for my $key (sort keys %$source) {
332 flatten($source->{$key} => $target, (defined $prefix ? $prefix . $arr_prefix->($first) . '.' : '') . $key);
338 for my $i (0 .. $#$source) {
339 flatten($source->[$i] => $target, $prefix . $arr_prefix->($i == 0), '1');
344 die "can't flatten a pure scalar" unless defined $prefix;
345 push @$target, [ $prefix . $arr_prefix->(0) => $source ];
348 die "unrecognized reference of a data structure $_. cannot serialize refs, globs and code yet. to serialize Form please use the method there";
356 my ($data, $target) = @_;
359 for my $pair (@$data) {
360 _store_value($target, @$pair) if defined $pair->[0];
372 SL::Request.pm - request parsing, data serialization, request information
376 This module handles unpacking of CGI parameters. It also gives
377 information about the request, such as whether or not it was done via AJAX,
378 or the requested content type.
380 use SL::Request qw(read_cgi_input);
382 # read cgi input depending on request type, unflatten and recode
383 read_cgi_input($target_hash_ref);
385 # $hashref and $new_hashref should be identical
386 my $new_arrayref = flatten($hashref);
387 my $new_hashref = unflatten($new_arrayref);
389 # Handle AJAX requests differently than normal requests:
390 if ($::request->is_ajax) {
391 $controller->render('json-mask', { type => 'json' });
393 $controller->render('full-mask');
398 This module provides information about the request made by the
401 It also handles flattening and unflattening of data for request
402 roundtrip purposes. kivitendo uses the format as described below:
408 Hash entries will be connected with a dot (C<.>). A simple hash like this
415 will be serialized to
418 [ order.customer => 5 ],
422 Arrays will be marked by empty brackets (C<[]>). A hash like this
424 selected_id => [ 2, 6, 8, 9 ]
428 [ selected_id[] => 2 ],
429 [ selected_id[] => 6 ],
430 [ selected_id[] => 8 ],
431 [ selected_id[] => 9 ],
433 Since this will produce identical keys, the resulting flattened list can not be
434 used as a hash. It is however very easy to use this in a template to generate
437 [% FOREACH id = selected_ids %]
438 <input type="hidden" name="selected_id[]" value="[% id | html %]">
441 =item Nested structures
443 A special version of this are nested hashes in an array, which is very common.
444 The combined operator (C<[].>) will be used. As a special case, every time a new
445 array slice is started, the special convention (C<[+].>) will be used. Again this
446 is because it's easy to write a template with it.
465 [ order.orderitems[+].id => 1 ],
466 [ order.orderitems[].part => 15 ],
467 [ order.orderitems[+].id => 2 ],
468 [ order.orderitems[].part => 7 ],
472 The format currently does have certain limitations when compared to other
473 serialization formats.
479 The order of serialized values matters to reconstruct arrays properly. This
480 should rarely be a problem if you just flatten and dump into a url or a field
485 The current implementation of flatten does produce correct serialization of
486 empty keys, but unflatten is unable to resolve these. Do no use C<''> or
487 C<undef> as keys. C<0> is fine.
491 You cannot use the tokens C<[]>, C<[+]> and C<.> in keys. No way around it.
495 It is not possible to serialize something like
497 sparse_array => do { my $sa = []; $sa[100] = 1; $sa },
499 This is a feature, as perl doesn't do well with very large arrays.
503 There is currently no support nor prevention for flattening a circular structure.
505 =item Custom Delimiter
507 No support for other delimiters, sorry.
509 =item Other References
511 No support for globs, scalar refs, code refs, filehandles and the like. These will die.
521 =item C<flatten HASHREF [ ARRAYREF ]>
523 This function will flatten the provided hash ref into the provided array ref.
524 The array ref may be non empty, but will be changed in this case.
526 The return value is the flattened array ref.
528 =item C<unflatten ARRAYREF [ HASHREF ]>
530 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.
534 Returns trueish if the request is an XML HTTP request, also known as
539 Returns the requested content type (either C<html>, C<js> or C<json>).
543 Set and retrieve the layout object for the current request. Must be an instance
544 of L<SL::Layout::Base>. Defaults to an instance of L<SL::Layout::None>.
546 For more information about layouts, see L<SL::Layout::Dispatcher>.
548 =item C<cache $topic[, $default ]>
550 Caches an item for the duration of the request. C<$topic> must be an
551 index name referring to the thing to cache. It is used for retrieving
552 it later on. If C<$topic> doesn't start with C<::> then the caller's
553 package name is prepended to the topic. For example, if the a from
554 package C<SL::StuffedStuff> calls with topic = C<get_stuff> then the
555 actual key will be C<::SL::StuffedStuff::get_stuff>.
557 If no item exists in the cache for C<$topic> then it is created and
558 its initial value is set to C<$default>. If C<$default> is not given
559 (undefined) then a new, empty hash reference is created.
561 Returns the cached item.
565 =head1 SPECIAL FUNCTIONS
567 =head2 C<_store_value()>
569 Parses a complex var name, and stores it in the form.
572 _store_value($target, $key, $value);
574 Keys must start with a string, and can contain various tokens.
575 Supported key structures are:
578 Simple key strings work as expected
583 Separating two keys by a dot (.) will result in a hash lookup for the inner value
584 This is similar to the behaviour of java and templating mechanisms.
586 filter.description => $form->{filter}->{description}
588 3. array+hashref access
590 Adding brackets ([]) before the dot will cause the next hash to be put into an array.
591 Using [+] instead of [] will force a new array index. This is useful for recurring
592 data structures like part lists. Put a [+] into the first varname, and use [] on the
595 Repeating these names in your template:
598 invoice.items[].parts_id
602 $form->{invoice}->{items}->[
616 Using brackets at the end of a name will result in the creation of a pure array.
617 Note that you mustn't use [+], which is reserved for array+hash access and will
618 result in undefined behaviour in array context.
620 filter.status[] => $form->{status}->[ val1, val2, ... ]