SL/Request.pm

   1 package SL::Request;
   2
   3 use strict;
   4
   5 use parent qw(Rose::Object);
   6
   7 use CGI qw(-no_xhtml);
   8 use List::Util qw(first max min sum);
   9 use List::MoreUtils qw(all any apply);
  10 use Exporter qw(import);
  11
  12 use SL::Common;
  13 use SL::MoreCommon qw(uri_encode uri_decode);
  14 use SL::Layout::None;
  15 use SL::Presenter;
  16
  17 our @EXPORT_OK = qw(flatten unflatten read_cgi_input);
  18
  19 use Rose::Object::MakeMethods::Generic
  20 (
  21   'scalar --get_set_init' => [ qw(cgi layout presenter is_ajax type) ],
  22 );
  23
  24 sub init_cgi {
  25   return CGI->new({});
  26 }
  27
  28 sub init_layout {
  29   return SL::Layout::None->new;
  30 }
  31
  32 sub init_presenter {
  33   return SL::Presenter->new;
  34 }
  35
  36 sub init_is_ajax {
  37   return ($ENV{HTTP_X_REQUESTED_WITH} || '') eq 'XMLHttpRequest' ? 1 : 0;
  38 }
  39
  40 sub init_type {
  41   return 'html';
  42 }
  43
  44 sub _store_value {
  45   my ($target, $key, $value) = @_;
  46   my @tokens = split /((?:\[\+?\])?(?:\.)|(?:\[\+?\]))/, $key;
  47   my $curr;
  48
  49   if (scalar @tokens) {
  50      $curr = \ $target->{ shift @tokens };
  51   }
  52
  53   while (@tokens) {
  54     my $sep = shift @tokens;
  55     my $key = shift @tokens;
  56
  57     $curr = \ $$curr->[$#$$curr], next   if $sep eq '[]' && @tokens;
  58     $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]' && !@tokens;
  59     $curr = \ $$curr->[++$#$$curr], next if $sep eq '[+]';
  60     $curr = \ $$curr->[max 0, $#$$curr]  if $sep eq '[].';
  61     $curr = \ $$curr->[++$#$$curr]       if $sep eq '[+].';
  62     $curr = \ $$curr->{$key}
  63   }
  64
  65   $$curr = $value;
  66
  67   return $curr;
  68 }
  69
  70 sub _input_to_hash {
  71   $::lxdebug->enter_sub(2);
  72
  73   my ($target, $input, $log) = @_;
  74   my @pairs = split(/&/, $input);
  75
  76   foreach (@pairs) {
  77     my ($key, $value) = split(/=/, $_, 2);
  78     next unless $key;
  79     _store_value($target, uri_decode($key), uri_decode($value));
  80
  81     # for debugging
  82     $::lxdebug->add_request_params(uri_decode($key) => uri_decode($value)) if $log;
  83   }
  84
  85   $::lxdebug->leave_sub(2);
  86 }
  87
  88 sub _parse_multipart_formdata {
  89   my ($target, $temp_target, $input, $log) = @_;
  90   my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous, $p_attachment, $encoding, $transfer_encoding);
  91   my $data_start = 0;
  92
  93   # teach substr and length to use good ol' bytes, not 'em fancy characters
  94   use bytes;
  95
  96   # We SHOULD honor encodings and transfer-encodings here, but as hard as I
  97   # looked I couldn't find a reasonably recent webbrowser that makes use of
  98   # these. Transfer encoding just eats up bandwidth...
  99
 100   # so all I'm going to do is add a fail safe that if anyone ever encounters
 101   # this, it's going to croak so that debugging is easier
 102   $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/;
 103   my $boundary = '--' . $1;
 104
 105   my $index = 0;
 106   my $line_length;
 107   foreach my $line (split m/\n/, $input) {
 108     $line_length = length $line;
 109
 110     if ($line =~ /^\Q$boundary\E(--)?\r?$/) {
 111       my $last_boundary = $1;
 112       my $data       =  substr $input, $data_start, $index - $data_start;
 113       $data =~ s/\r?\n$//;
 114
 115       if ($previous && !$filename && $transfer_encoding && $transfer_encoding ne 'binary') {
 116         ${ $previous } = Encode::decode($encoding, $data);
 117       } else {
 118         ${ $previous } = $data;
 119       }
 120       $::lxdebug->add_request_params($name, $$previous) if $log;
 121
 122       undef $previous;
 123       undef $filename;
 124
 125       $headers_done   = 0;
 126       $content_type   = "text/plain";
 127       $boundary_found = 1;
 128       $need_cr        = 0;
 129       $encoding       = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 130       $transfer_encoding = undef;
 131       last if $last_boundary;
 132       next;
 133     }
 134
 135     next unless $boundary_found;
 136
 137     if (!$headers_done) {
 138       $line =~ s/[\r\n]*$//;
 139
 140       if (!$line) {
 141         $headers_done = 1;
 142         $data_start = $index + $line_length + 1;
 143         next;
 144       }
 145
 146       if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
 147         if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
 148           $filename = $1;
 149           substr $line, $-[0], $+[0] - $-[0], "";
 150         }
 151
 152         if ($line =~ m|name\s*=\s*"(.*?)"|i) {
 153           $name = $1;
 154           substr $line, $-[0], $+[0] - $-[0], "";
 155         }
 156
 157         if ($name) {
 158           # legacy, some old upload routines expect this to be here
 159           $temp_target->{FILENAME} = $filename if defined $filename;
 160
 161           # name can potentially be both a normal variable or a file upload
 162           # a file upload can be identified by its "filename" attribute
 163           # the thing is, if a [+] clause vivifies atructur in one of the
 164           # branches it must be done in both, or subsequent "[]" will fail
 165           my $temp_target_slot = _store_value($temp_target, $name);
 166           my $target_slot      = _store_value($target,      $name);
 167
 168           # set the reference for appending of multiline data to the correct one
 169           $previous            = defined $filename ? $target_slot : $temp_target_slot;
 170
 171           # for multiple uploads: save the attachments in a SL/Mailer like structure
 172           if (defined $filename) {
 173             my $target_attachment      = _store_value($target,      "ATTACHMENTS.$name", {});
 174             my $temp_target_attachment = _store_value($temp_target, "ATTACHMENTS.$name", {});
 175
 176             $$target_attachment->{data}          = $previous;
 177             $$temp_target_attachment->{filename} = $filename;
 178
 179             $p_attachment = $$temp_target_attachment;
 180           }
 181         }
 182
 183         next;
 184       }
 185
 186       if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
 187         $content_type = $1;
 188         $p_attachment->{content_type} = $1;
 189
 190         if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
 191           $encoding = $2;
 192         }
 193
 194         next;
 195       }
 196
 197       if ($line =~ m|^content-transfer-encoding\s*=\s*(.*?)$|i) {
 198         $transfer_encoding = lc($1);
 199         if ($transfer_encoding  && $transfer_encoding !~ /^[78]bit|binary$/) {
 200           die 'Transfer encodings beyond 7bit/8bit and binary are not implemented.';
 201         }
 202         $p_attachment->{transfer_encoding} = $transfer_encoding;
 203
 204         next;
 205       }
 206
 207       next;
 208     }
 209
 210     next unless $previous;
 211
 212   } continue {
 213     $index += $line_length + 1;
 214   }
 215
 216   $::lxdebug->leave_sub(2);
 217 }
 218
 219 sub _recode_recursively {
 220   $::lxdebug->enter_sub;
 221   my ($iconv, $from, $to) = @_;
 222
 223   if (any { ref $from eq $_ } qw(Form HASH)) {
 224     for my $key (keys %{ $from }) {
 225       if (!ref $from->{$key}) {
 226         # Workaround for a bug: converting $from->{$key} directly
 227         # leads to 'undef'. I don't know why. Converting a copy works,
 228         # though.
 229         $to->{$key} = $iconv->convert("" . $from->{$key}) if defined $from->{$key} && !defined $to->{$key};
 230       } else {
 231         $to->{$key} ||= {} if 'HASH'  eq ref $from->{$key};
 232         $to->{$key} ||= [] if 'ARRAY' eq ref $from->{$key};
 233         _recode_recursively($iconv, $from->{$key}, $to->{$key});
 234       }
 235     }
 236
 237   } elsif (ref $from eq 'ARRAY') {
 238     foreach my $idx (0 .. scalar(@{ $from }) - 1) {
 239       if (!ref $from->[$idx]) {
 240         # Workaround for a bug: converting $from->[$idx] directly
 241         # leads to 'undef'. I don't know why. Converting a copy works,
 242         # though.
 243         $to->[$idx] = $iconv->convert("" . $from->[$idx]);
 244       } else {
 245         $to->[$idx] ||= {} if 'HASH'  eq ref $from->[$idx];
 246         $to->[$idx] ||= [] if 'ARRAY' eq ref $from->[$idx];
 247         _recode_recursively($iconv, $from->[$idx], $to->[$idx]);
 248       }
 249     }
 250   }
 251   $main::lxdebug->leave_sub();
 252 }
 253
 254 sub read_cgi_input {
 255   $::lxdebug->enter_sub;
 256
 257   my ($target) = @_;
 258   my $db_charset   = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 259
 260   # yes i know, copying all those values around isn't terribly efficient, but
 261   # the old version of dumping everything into form and then launching a
 262   # tactical recode nuke at the data is still worse.
 263
 264   # this way the data can at least be recoded on the fly as soon as we get to
 265   # know the source encoding and only in the cases where encoding may be hidden
 266   # among the payload we take the hit of copying the request around
 267   my $temp_target = { };
 268
 269   # since both of these can potentially bring their encoding in INPUT_ENCODING
 270   # they get dumped into temp_target
 271   _input_to_hash($temp_target, $ENV{QUERY_STRING}, 1) if $ENV{QUERY_STRING};
 272   _input_to_hash($temp_target, $ARGV[0],           1) if @ARGV && $ARGV[0];
 273
 274   if ($ENV{CONTENT_LENGTH}) {
 275     my $content;
 276     read STDIN, $content, $ENV{CONTENT_LENGTH};
 277     if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
 278       # multipart formdata can bring it's own encoding, so give it both
 279       # and let ti decide on it's own
 280       _parse_multipart_formdata($target, $temp_target, $content, 1);
 281     } else {
 282       # normal encoding must be recoded
 283       _input_to_hash($temp_target, $content, 1);
 284     }
 285   }
 286
 287   my $encoding     = delete $temp_target->{INPUT_ENCODING} || $db_charset;
 288
 289   _recode_recursively(SL::Iconv->new($encoding, $db_charset), $temp_target => $target) if keys %$target;
 290
 291   if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
 292     my %temp_form;
 293     $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
 294     _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
 295   }
 296
 297   $::lxdebug->leave_sub;
 298
 299   return $target;
 300 }
 301
 302 sub flatten {
 303   my ($source, $target, $prefix, $in_array) = @_;
 304   $target ||= [];
 305
 306   # there are two edge cases that need attention. first: more than one hash
 307   # inside an array.  only the first of each nested can have a [+].  second: if
 308   # an array contains mixed values _store_value will rely on autovivification.
 309   # so any type change must have a [+]
 310   # this closure decides one recursion step AFTER an array has been found if a
 311   # [+] needs to be generated
 312   my $arr_prefix = sub {
 313     return $_[0] ? '[+]' : '[]' if $in_array;
 314     return '';
 315   };
 316
 317   for (ref $source) {
 318     /^HASH$/ && do {
 319       my $first = 1;
 320       for my $key (sort keys %$source) {
 321         flatten($source->{$key} => $target, (defined $prefix ? $prefix . $arr_prefix->($first) . '.' : '') . $key);
 322         $first = 0;
 323       };
 324       next;
 325     };
 326     /^ARRAY$/ && do {
 327       for my $i (0 .. $#$source) {
 328         flatten($source->[$i] => $target, $prefix . $arr_prefix->($i == 0), '1');
 329       }
 330       next;
 331     };
 332     !$_ && do {
 333       die "can't flatten a pure scalar" unless defined $prefix;
 334       push @$target, [ $prefix . $arr_prefix->(0) => $source ];
 335       next;
 336     };
 337     die "unrecognized reference of a data structure $_. cannot serialize refs, globs and code yet. to serialize Form please use the method there";
 338   }
 339
 340   return $target;
 341 }
 342
 343
 344 sub unflatten {
 345   my ($data, $target) = @_;
 346   $target ||= {};
 347
 348   for my $pair (@$data) {
 349     _store_value($target, @$pair) if defined $pair->[0];
 350   }
 351
 352   return $target;
 353 }
 354
 355 1;
 356
 357 __END__
 358
 359 =head1 NAME
 360
 361 SL::Request.pm - request parsing, data serialization, request information
 362
 363 =head1 SYNOPSIS
 364
 365 This module handles unpacking of CGI parameters. It also gives
 366 information about the request like whether or not it was done via AJAX
 367 or the requested content type.
 368
 369   use SL::Request qw(read_cgi_input);
 370
 371   # read cgi input depending on request type, unflatten and recode
 372   read_cgi_input($target_hash_ref);
 373
 374   # $hashref and $new_hashref should be identical
 375   my $new_arrayref = flatten($hashref);
 376   my $new_hashref  = unflatten($new_arrayref);
 377
 378   # Handle AJAX requests differently than normal requests:
 379   if ($::request->is_ajax) {
 380     $controller->render('json-mask', { type => 'json' });
 381   } else {
 382     $controller->render('full-mask');
 383   }
 384
 385 =head1 DESCRIPTION
 386
 387 This module provides information about the request made by the
 388 browser.
 389
 390 It also handles flattening and unflattening of data for request
 391 roundtrip purposes. kivitendo uses the format as described below:
 392
 393 =over 4
 394
 395 =item Hashes
 396
 397 Hash entries will be connected with a dot (C<.>). A simple hash like this
 398
 399   order => {
 400     item     => 2,
 401     customer => 5
 402   }
 403
 404 will be serialized to
 405
 406   [ order.item     => 2 ],
 407   [ order.customer => 5 ],
 408
 409 =item Arrays
 410
 411 Arrays will by trailing empty brackets (C<[]>). An hash like this
 412
 413   selected_id => [ 2, 6, 8, 9 ]
 414
 415 will be flattened to
 416
 417   [ selected_id[] => 2 ],
 418   [ selected_id[] => 6 ],
 419   [ selected_id[] => 8 ],
 420   [ selected_id[] => 9 ],
 421
 422 Since this will produce identical keys, the resulting flattened list can not be
 423 used as a hash. It is however very easy to use this in a template to generate
 424 input:
 425
 426   [% FOREACH id = selected_ids %]
 427     <input type="hidden" name="selected_id[]" value="[% id | html %]">
 428   [% END %]
 429
 430 =item Nested structures
 431
 432 A special version of this are nested hashs in an array, which is very common.
 433 The combined operator (C<[].>) will be used. As a special case, every time a new
 434 array slice is started, the special convention (C<[+].>) will be used. Again this
 435 is because it's easy to write a template with it.
 436
 437 So this
 438
 439   order => {
 440     orderitems => [
 441       {
 442         id   => 1,
 443         part => 15
 444       },
 445       {
 446         id   => 2,
 447         part => 7
 448       },
 449     ]
 450   }
 451
 452 will be
 453
 454   [ order.orderitems[+].id  => 1  ],
 455   [ order.orderitems[].part => 15 ],
 456   [ order.orderitems[+].id  => 2  ],
 457   [ order.orderitems[].part => 7  ],
 458
 459 =item Limitations
 460
 461   The format currently does have certain limitations when compared to other
 462   serialization formats.
 463
 464 =over 4
 465
 466 =item Order
 467
 468 The order of serialized values matters to reconstruct arrays properly. This
 469 should rarely be a problem if you just flatten and dump into a url or a field
 470 of hiddens.
 471
 472 =item Empty Keys
 473
 474 The current implementation of flatten does produce correct serialization of
 475 empty keys, but unflatten is unable to resolve these. Do no use C<''> or
 476 C<undef> as keys. C<0> is fine.
 477
 478 =item Key Escaping
 479
 480 You cannot use the tokens C<[]>, C<[+]> and C<.> in keys. No way around it.
 481
 482 =item Sparse Arrays
 483
 484 It is not possible to serialize somehing like
 485
 486   sparse_array => do { my $sa = []; $sa[100] = 1; $sa },
 487
 488 This is a feature, as perl doesn't do well with very large arrays.
 489
 490 =item Recursion
 491
 492 There is currently no support nor prevention for flattening a circular structure.
 493
 494 =item Custom Delimiter
 495
 496 No support for other delimiters, sorry.
 497
 498 =item Other References
 499
 500 No support for globs, scalar refs, code refs, filehandles and the like. These will die.
 501
 502 =back
 503
 504 =back
 505
 506 =head1 FUNCTIONS
 507
 508 =over 4
 509
 510 =item C<flatten HASHREF [ ARRAYREF ]>
 511
 512 This function will flatten the provided hash ref into the provided array ref.
 513 The array ref may be non empty, but will be changed in this case.
 514
 515 Return value is the flattened array ref.
 516
 517 =item C<unflatten ARRAYREF [ HASHREF ]>
 518
 519 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.
 520
 521 =item C<is_ajax>
 522
 523 Returns trueish if the request is an XML HTTP request, also known as
 524 an 'AJAX' request.
 525
 526 =item C<type>
 527
 528 Returns the requested content type (either C<html>, C<js> or C<json>).
 529
 530 =item C<layout>
 531
 532 Set and retrieve the layout object for the current request. Must be an instance
 533 of L<SL::Layout::Base>. Defaults to an isntance of L<SL::Layout::None>.
 534
 535 For more information about layouts, see L<SL::Layout::Dispatcher>.
 536
 537 =back
 538
 539 =head1 SPECIAL FUNCTIONS
 540
 541 =head2 C<_store_value()>
 542
 543 parses a complex var name, and stores it in the form.
 544
 545 syntax:
 546   _store_value($target, $key, $value);
 547
 548 keys must start with a string, and can contain various tokens.
 549 supported key structures are:
 550
 551 1. simple access
 552   simple key strings work as expected
 553
 554   id => $form->{id}
 555
 556 2. hash access.
 557   separating two keys by a dot (.) will result in a hash lookup for the inner value
 558   this is similar to the behaviour of java and templating mechanisms.
 559
 560   filter.description => $form->{filter}->{description}
 561
 562 3. array+hashref access
 563
 564   adding brackets ([]) before the dot will cause the next hash to be put into an array.
 565   using [+] instead of [] will force a new array index. this is useful for recurring
 566   data structures like part lists. put a [+] into the first varname, and use [] on the
 567   following ones.
 568
 569   repeating these names in your template:
 570
 571     invoice.items[+].id
 572     invoice.items[].parts_id
 573
 574   will result in:
 575
 576     $form->{invoice}->{items}->[
 577       {
 578         id       => ...
 579         parts_id => ...
 580       },
 581       {
 582         id       => ...
 583         parts_id => ...
 584       }
 585       ...
 586     ]
 587
 588 4. arrays
 589
 590   using brackets at the end of a name will result in a pure array to be created.
 591   note that you mustn't use [+], which is reserved for array+hash access and will
 592   result in undefined behaviour in array context.
 593
 594   filter.status[]  => $form->{status}->[ val1, val2, ... ]
 595
 596 =cut