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