6 use SL::MoreCommon qw(uri_encode uri_decode);
7 use List::Util qw(first max min sum);
8 use List::MoreUtils qw(all any apply);
11 $::lxdebug->enter_sub(2);
13 my ($target, $key, $value) = @_;
14 my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
18 $curr = \ $target->{ shift @tokens };
22 my $sep = shift @tokens;
23 my $key = shift @tokens;
25 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
26 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
27 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
28 $curr = \ $$curr->{$key}
33 $::lxdebug->leave_sub(2);
39 $::lxdebug->enter_sub(2);
41 my ($target, $input) = @_;
42 my @pairs = split(/&/, $input);
45 my ($key, $value) = split(/=/, $_, 2);
46 _store_value($target, uri_decode($key), uri_decode($value)) if ($key);
49 $::lxdebug->leave_sub(2);
52 sub _parse_multipart_formdata {
53 my ($target, $temp_target, $input) = @_;
54 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous, $encoding, $transfer_encoding);
56 # We SHOULD honor encodings and transfer-encodings here, but as hard as I
57 # looked I couldn't find a reasonably recent webbrowser that makes use of
58 # these. Transfer encoding just eats up bandwidth...
60 # so all I'm going to do is add a fail safe that if anyone ever encounters
61 # this, it's going to croak so that debugging is easier
62 $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/;
63 my $boundary = '--' . $1;
65 foreach my $line (split m/\n/, $input) {
66 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
68 if (($line eq $boundary) || ($line eq "$boundary\r")) {
69 ${ $previous } =~ s|\r?\n$|| if $previous;
70 ${ $previous } = Encode::decode($encoding, $$previous) if $previous && !$filename && !$transfer_encoding eq 'binary';
76 $content_type = "text/plain";
79 $encoding = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
80 $transfer_encoding = undef;
85 next unless $boundary_found;
88 $line =~ s/[\r\n]*$//;
95 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
96 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
98 substr $line, $-[0], $+[0] - $-[0], "";
101 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
103 substr $line, $-[0], $+[0] - $-[0], "";
106 $previous = _store_value($filename ? $target : $temp_target, $name, '') if ($name);
107 $temp_target->{FILENAME} = $filename if ($filename);
109 # for multiple uploads: save the attachments in a SL/Mailer like structure
110 if ($name && $filename) {
111 _store_value($target, "ATTACHMENTS.$name.data", $previous);
112 _store_value($temp_target, "ATTACHMENTS.$name.filename", $filename);
118 if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
120 _store_value($temp_target, "ATTACHMENTS.$name.content_type", $1);
122 if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
129 if ($line =~ m|^content-transfer-encoding\s*=\s*(.*?)$|i) {
130 $transfer_encoding = lc($1);
131 if ($transfer_encoding && $transfer_encoding !~ /^[78]bit|binary$/) {
132 die 'Transfer encodings beyond 7bit/8bit and binary are not implemented.';
141 next unless $previous;
143 ${ $previous } .= "${line}\n";
146 ${ $previous } =~ s|\r?\n$|| if $previous;
148 $::lxdebug->leave_sub(2);
151 sub _recode_recursively {
152 $::lxdebug->enter_sub;
153 my ($iconv, $from, $to) = @_;
155 if (any { ref $from eq $_ } qw(Form HASH)) {
156 for my $key (keys %{ $from }) {
157 if (!ref $from->{$key}) {
158 # Workaround for a bug: converting $from->{$key} directly
159 # leads to 'undef'. I don't know why. Converting a copy works,
161 $to->{$key} = $iconv->convert("" . $from->{$key});
163 $to->{$key} ||= {} if 'HASH' eq ref $from->{$key};
164 $to->{$key} ||= [] if 'ARRAY' eq ref $from->{$key};
165 _recode_recursively($iconv, $from->{$key}, $to->{$key});
169 } elsif (ref $from eq 'ARRAY') {
170 foreach my $idx (0 .. scalar(@{ $from }) - 1) {
171 if (!ref $from->[$idx]) {
172 # Workaround for a bug: converting $from->[$idx] directly
173 # leads to 'undef'. I don't know why. Converting a copy works,
175 $to->[$idx] = $iconv->convert("" . $from->[$idx]);
177 $to->[$idx] ||= {} if 'HASH' eq ref $from->[$idx];
178 $to->[$idx] ||= [] if 'ARRAY' eq ref $from->[$idx];
179 _recode_recursively($iconv, $from->[$idx], $to->[$idx]);
183 $main::lxdebug->leave_sub();
187 $::lxdebug->enter_sub;
190 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
192 # yes i know, copying all those values around isn't terribly efficient, but
193 # the old version of dumping everything into form and then launching a
194 # tactical recode nuke at the data is still worse.
196 # this way the data can at least be recoded on the fly as soon as we get to
197 # know the source encoding and only in the cases where encoding may be hidden
198 # among the payload we take the hit of copying the request around
199 my $temp_target = { };
201 # since both of these can potentially bring their encoding in INPUT_ENCODING
202 # they get dumped into temp_target
203 _input_to_hash($temp_target, $ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
204 _input_to_hash($temp_target, $ARGV[0]) if @ARGV && $ARGV[0];
206 if ($ENV{CONTENT_LENGTH}) {
208 read STDIN, $content, $ENV{CONTENT_LENGTH};
209 if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
210 # multipart formdata can bring it's own encoding, so give it both
211 # and let ti decide on it's own
212 _parse_multipart_formdata($target, $temp_target, $content);
214 # normal encoding must be recoded
215 _input_to_hash($temp_target, $content);
219 my $encoding = delete $temp_target->{INPUT_ENCODING} || $db_charset;
221 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $temp_target => $target) if keys %$target;
223 if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
225 $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
226 _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
229 $::lxdebug->leave_sub;
240 SL::Form.pm - main data object.
244 This module handles unpacking of cgi parameters. usually you donÄt want to call
245 anything in here directly,
247 SL::Request::read_cgi_input($target_hash_ref);
249 =head1 SPECIAL FUNCTIONS
251 =head2 C<_store_value()>
253 parses a complex var name, and stores it in the form.
256 $form->_store_value($key, $value);
258 keys must start with a string, and can contain various tokens.
259 supported key structures are:
262 simple key strings work as expected
267 separating two keys by a dot (.) will result in a hash lookup for the inner value
268 this is similar to the behaviour of java and templating mechanisms.
270 filter.description => $form->{filter}->{description}
272 3. array+hashref access
274 adding brackets ([]) before the dot will cause the next hash to be put into an array.
275 using [+] instead of [] will force a new array index. this is useful for recurring
276 data structures like part lists. put a [+] into the first varname, and use [] on the
279 repeating these names in your template:
282 invoice.items[].parts_id
286 $form->{invoice}->{items}->[
300 using brackets at the end of a name will result in a pure array to be created.
301 note that you mustn't use [+], which is reserved for array+hash access and will
302 result in undefined behaviour in array context.
304 filter.status[] => $form->{status}->[ val1, val2, ... ]