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       = 'UTF-8';
 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
 259   # yes i know, copying all those values around isn't terribly efficient, but
 260   # the old version of dumping everything into form and then launching a
 261   # tactical recode nuke at the data is still worse.
 262
 263   # this way the data can at least be recoded on the fly as soon as we get to
 264   # know the source encoding and only in the cases where encoding may be hidden
 265   # among the payload we take the hit of copying the request around
 266   my $temp_target = { };
 267
 268   # since both of these can potentially bring their encoding in INPUT_ENCODING
 269   # they get dumped into temp_target
 270   _input_to_hash($temp_target, $ENV{QUERY_STRING}, 1) if $ENV{QUERY_STRING};
 271   _input_to_hash($temp_target, $ARGV[0],           1) if @ARGV && $ARGV[0];
 272
 273   if ($ENV{CONTENT_LENGTH}) {
 274     my $content;
 275     read STDIN, $content, $ENV{CONTENT_LENGTH};
 276     if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
 277       # multipart formdata can bring it's own encoding, so give it both
 278       # and let ti decide on it's own
 279       _parse_multipart_formdata($target, $temp_target, $content, 1);
 280     } else {
 281       # normal encoding must be recoded
 282       _input_to_hash($temp_target, $content, 1);
 283     }
 284   }
 285
 286   my $encoding     = delete $temp_target->{INPUT_ENCODING} || 'UTF-8';
 287
 288   _recode_recursively(SL::Iconv->new($encoding, 'UTF-8'), $temp_target => $target) if keys %$target;
 289
 290   if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
 291     my %temp_form;
 292     $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
 293     _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
 294   }
 295
 296   $::lxdebug->leave_sub;
 297
 298   return $target;
 299 }
 300
 301 sub flatten {
 302   my ($source, $target, $prefix, $in_array) = @_;
 303   $target ||= [];
 304
 305   # there are two edge cases that need attention. first: more than one hash
 306   # inside an array.  only the first of each nested can have a [+].  second: if
 307   # an array contains mixed values _store_value will rely on autovivification.
 308   # so any type change must have a [+]
 309   # this closure decides one recursion step AFTER an array has been found if a
 310   # [+] needs to be generated
 311   my $arr_prefix = sub {
 312     return $_[0] ? '[+]' : '[]' if $in_array;
 313     return '';
 314   };
 315
 316   for (ref $source) {
 317     /^HASH$/ && do {
 318       my $first = 1;
 319       for my $key (sort keys %$source) {
 320         flatten($source->{$key} => $target, (defined $prefix ? $prefix . $arr_prefix->($first) . '.' : '') . $key);
 321         $first = 0;
 322       };
 323       next;
 324     };
 325     /^ARRAY$/ && do {
 326       for my $i (0 .. $#$source) {
 327         flatten($source->[$i] => $target, $prefix . $arr_prefix->($i == 0), '1');
 328       }
 329       next;
 330     };
 331     !$_ && do {
 332       die "can't flatten a pure scalar" unless defined $prefix;
 333       push @$target, [ $prefix . $arr_prefix->(0) => $source ];
 334       next;
 335     };
 336     die "unrecognized reference of a data structure $_. cannot serialize refs, globs and code yet. to serialize Form please use the method there";
 337   }
 338
 339   return $target;
 340 }
 341
 342
 343 sub unflatten {
 344   my ($data, $target) = @_;
 345   $target ||= {};
 346
 347   for my $pair (@$data) {
 348     _store_value($target, @$pair) if defined $pair->[0];
 349   }
 350
 351   return $target;
 352 }
 353
 354 1;
 355
 356 __END__
 357
 358 =head1 NAME
 359
 360 SL::Request.pm - request parsing, data serialization, request information
 361
 362 =head1 SYNOPSIS
 363
 364 This module handles unpacking of CGI parameters. It also gives
 365 information about the request like whether or not it was done via AJAX
 366 or the requested content type.
 367
 368   use SL::Request qw(read_cgi_input);
 369
 370   # read cgi input depending on request type, unflatten and recode
 371   read_cgi_input($target_hash_ref);
 372
 373   # $hashref and $new_hashref should be identical
 374   my $new_arrayref = flatten($hashref);
 375   my $new_hashref  = unflatten($new_arrayref);
 376
 377   # Handle AJAX requests differently than normal requests:
 378   if ($::request->is_ajax) {
 379     $controller->render('json-mask', { type => 'json' });
 380   } else {
 381     $controller->render('full-mask');
 382   }
 383
 384 =head1 DESCRIPTION
 385
 386 This module provides information about the request made by the
 387 browser.
 388
 389 It also handles flattening and unflattening of data for request
 390 roundtrip purposes. kivitendo uses the format as described below:
 391
 392 =over 4
 393
 394 =item Hashes
 395
 396 Hash entries will be connected with a dot (C<.>). A simple hash like this
 397
 398   order => {
 399     item     => 2,
 400     customer => 5
 401   }
 402
 403 will be serialized to
 404
 405   [ order.item     => 2 ],
 406   [ order.customer => 5 ],
 407
 408 =item Arrays
 409
 410 Arrays will by trailing empty brackets (C<[]>). An hash like this
 411
 412   selected_id => [ 2, 6, 8, 9 ]
 413
 414 will be flattened to
 415
 416   [ selected_id[] => 2 ],
 417   [ selected_id[] => 6 ],
 418   [ selected_id[] => 8 ],
 419   [ selected_id[] => 9 ],
 420
 421 Since this will produce identical keys, the resulting flattened list can not be
 422 used as a hash. It is however very easy to use this in a template to generate
 423 input:
 424
 425   [% FOREACH id = selected_ids %]
 426     <input type="hidden" name="selected_id[]" value="[% id | html %]">
 427   [% END %]
 428
 429 =item Nested structures
 430
 431 A special version of this are nested hashs in an array, which is very common.
 432 The combined operator (C<[].>) will be used. As a special case, every time a new
 433 array slice is started, the special convention (C<[+].>) will be used. Again this
 434 is because it's easy to write a template with it.
 435
 436 So this
 437
 438   order => {
 439     orderitems => [
 440       {
 441         id   => 1,
 442         part => 15
 443       },
 444       {
 445         id   => 2,
 446         part => 7
 447       },
 448     ]
 449   }
 450
 451 will be
 452
 453   [ order.orderitems[+].id  => 1  ],
 454   [ order.orderitems[].part => 15 ],
 455   [ order.orderitems[+].id  => 2  ],
 456   [ order.orderitems[].part => 7  ],
 457
 458 =item Limitations
 459
 460   The format currently does have certain limitations when compared to other
 461   serialization formats.
 462
 463 =over 4
 464
 465 =item Order
 466
 467 The order of serialized values matters to reconstruct arrays properly. This
 468 should rarely be a problem if you just flatten and dump into a url or a field
 469 of hiddens.
 470
 471 =item Empty Keys
 472
 473 The current implementation of flatten does produce correct serialization of
 474 empty keys, but unflatten is unable to resolve these. Do no use C<''> or
 475 C<undef> as keys. C<0> is fine.
 476
 477 =item Key Escaping
 478
 479 You cannot use the tokens C<[]>, C<[+]> and C<.> in keys. No way around it.
 480
 481 =item Sparse Arrays
 482
 483 It is not possible to serialize somehing like
 484
 485   sparse_array => do { my $sa = []; $sa[100] = 1; $sa },
 486
 487 This is a feature, as perl doesn't do well with very large arrays.
 488
 489 =item Recursion
 490
 491 There is currently no support nor prevention for flattening a circular structure.
 492
 493 =item Custom Delimiter
 494
 495 No support for other delimiters, sorry.
 496
 497 =item Other References
 498
 499 No support for globs, scalar refs, code refs, filehandles and the like. These will die.
 500
 501 =back
 502
 503 =back
 504
 505 =head1 FUNCTIONS
 506
 507 =over 4
 508
 509 =item C<flatten HASHREF [ ARRAYREF ]>
 510
 511 This function will flatten the provided hash ref into the provided array ref.
 512 The array ref may be non empty, but will be changed in this case.
 513
 514 Return value is the flattened array ref.
 515
 516 =item C<unflatten ARRAYREF [ HASHREF ]>
 517
 518 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.
 519
 520 =item C<is_ajax>
 521
 522 Returns trueish if the request is an XML HTTP request, also known as
 523 an 'AJAX' request.
 524
 525 =item C<type>
 526
 527 Returns the requested content type (either C<html>, C<js> or C<json>).
 528
 529 =item C<layout>
 530
 531 Set and retrieve the layout object for the current request. Must be an instance
 532 of L<SL::Layout::Base>. Defaults to an isntance of L<SL::Layout::None>.
 533
 534 For more information about layouts, see L<SL::Layout::Dispatcher>.
 535
 536 =back
 537
 538 =head1 SPECIAL FUNCTIONS
 539
 540 =head2 C<_store_value()>
 541
 542 parses a complex var name, and stores it in the form.
 543
 544 syntax:
 545   _store_value($target, $key, $value);
 546
 547 keys must start with a string, and can contain various tokens.
 548 supported key structures are:
 549
 550 1. simple access
 551   simple key strings work as expected
 552
 553   id => $form->{id}
 554
 555 2. hash access.
 556   separating two keys by a dot (.) will result in a hash lookup for the inner value
 557   this is similar to the behaviour of java and templating mechanisms.
 558
 559   filter.description => $form->{filter}->{description}
 560
 561 3. array+hashref access
 562
 563   adding brackets ([]) before the dot will cause the next hash to be put into an array.
 564   using [+] instead of [] will force a new array index. this is useful for recurring
 565   data structures like part lists. put a [+] into the first varname, and use [] on the
 566   following ones.
 567
 568   repeating these names in your template:
 569
 570     invoice.items[+].id
 571     invoice.items[].parts_id
 572
 573   will result in:
 574
 575     $form->{invoice}->{items}->[
 576       {
 577         id       => ...
 578         parts_id => ...
 579       },
 580       {
 581         id       => ...
 582         parts_id => ...
 583       }
 584       ...
 585     ]
 586
 587 4. arrays
 588
 589   using brackets at the end of a name will result in a pure array to be created.
 590   note that you mustn't use [+], which is reserved for array+hash access and will
 591   result in undefined behaviour in array context.
 592
 593   filter.status[]  => $form->{status}->[ val1, val2, ... ]
 594
 595 =cut