SL/Request.pm

   1 package SL::Request;
   2
   3 use strict;
   4
   5 use SL::Common;
   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);
   9
  10 sub _store_value {
  11   $::lxdebug->enter_sub(2);
  12
  13   my ($target, $key, $value) = @_;
  14   my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
  15   my $curr;
  16
  17   if (scalar @tokens) {
  18      $curr = \ $target->{ shift @tokens };
  19   }
  20
  21   while (@tokens) {
  22     my $sep = shift @tokens;
  23     my $key = shift @tokens;
  24
  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}
  29   }
  30
  31   $$curr = $value;
  32
  33   $::lxdebug->leave_sub(2);
  34
  35   return $curr;
  36 }
  37
  38 sub _input_to_hash {
  39   $::lxdebug->enter_sub(2);
  40
  41   my ($target, $input) = @_;
  42   my @pairs = split(/&/, $input);
  43
  44   foreach (@pairs) {
  45     my ($key, $value) = split(/=/, $_, 2);
  46     _store_value($target, uri_decode($key), uri_decode($value)) if ($key);
  47   }
  48
  49   $::lxdebug->leave_sub(2);
  50 }
  51
  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);
  55
  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...
  59
  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;
  64
  65   foreach my $line (split m/\n/, $input) {
  66     last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
  67
  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';
  71
  72       undef $previous;
  73       undef $filename;
  74
  75       $headers_done   = 0;
  76       $content_type   = "text/plain";
  77       $boundary_found = 1;
  78       $need_cr        = 0;
  79       $encoding       = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
  80       $transfer_encoding = undef;
  81
  82       next;
  83     }
  84
  85     next unless $boundary_found;
  86
  87     if (!$headers_done) {
  88       $line =~ s/[\r\n]*$//;
  89
  90       if (!$line) {
  91         $headers_done = 1;
  92         next;
  93       }
  94
  95       if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
  96         if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
  97           $filename = $1;
  98           substr $line, $-[0], $+[0] - $-[0], "";
  99         }
 100
 101         if ($line =~ m|name\s*=\s*"(.*?)"|i) {
 102           $name = $1;
 103           substr $line, $-[0], $+[0] - $-[0], "";
 104         }
 105
 106         $previous                = _store_value($filename ? $target : $temp_target, $name, '') if ($name);
 107         $temp_target->{FILENAME} = $filename if ($filename);
 108
 109         next;
 110       }
 111
 112       if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
 113         $content_type = $1;
 114
 115         if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
 116           $encoding = $2;
 117         }
 118
 119         next;
 120       }
 121
 122       if ($line =~ m|^content-transfer-encoding\s*=\s*(.*?)$|i) {
 123         $transfer_encoding = lc($1);
 124         if ($transfer_encoding  && $transfer_encoding !~ /^[78]bit|binary$/) {
 125           die 'Transfer encodings beyond 7bit/8bit and binary are not implemented.';
 126         }
 127
 128         next;
 129       }
 130
 131       next;
 132     }
 133
 134     next unless $previous;
 135
 136     ${ $previous } .= "${line}\n";
 137   }
 138
 139   ${ $previous } =~ s|\r?\n$|| if $previous;
 140
 141   $::lxdebug->leave_sub(2);
 142 }
 143
 144 sub _recode_recursively {
 145   $::lxdebug->enter_sub;
 146   my ($iconv, $from, $to) = @_;
 147
 148   if (any { ref $from eq $_ } qw(Form HASH)) {
 149     for my $key (keys %{ $from }) {
 150       if (!ref $from->{$key}) {
 151         # Workaround for a bug: converting $from->{$key} directly
 152         # leads to 'undef'. I don't know why. Converting a copy works,
 153         # though.
 154         $to->{$key} = $iconv->convert("" . $from->{$key});
 155       } else {
 156         $to->{$key} = {} if 'HASH'  eq ref $from->{$key};
 157         $to->{$key} = [] if 'ARRAY' eq ref $from->{$key};
 158         _recode_recursively($iconv, $from->{$key}, $to->{$key});
 159       }
 160     }
 161
 162   } elsif (ref $from eq 'ARRAY') {
 163     foreach my $idx (0 .. scalar(@{ $from }) - 1) {
 164       if (!ref $from->[$idx]) {
 165         # Workaround for a bug: converting $from->[$idx] directly
 166         # leads to 'undef'. I don't know why. Converting a copy works,
 167         # though.
 168         $from->[$idx] = $iconv->convert("" . $from->[$idx]);
 169       } else {
 170         $to->[$idx] = {} if 'HASH'  eq ref $from->[$idx];
 171         $to->[$idx] = [] if 'ARRAY' eq ref $from->[$idx];
 172         _recode_recursively($iconv, $from->[$idx], $to->[$idx]);
 173       }
 174     }
 175   }
 176   $main::lxdebug->leave_sub();
 177 }
 178
 179 sub read_cgi_input {
 180   $::lxdebug->enter_sub;
 181
 182   my ($target) = @_;
 183   my $db_charset   = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 184
 185   # yes i know, copying all those values around isn't terribly efficient, but
 186   # the old version of dumping everything into form and then launching a
 187   # tactical recode nuke at the data is still worse.
 188
 189   # this way the data can at least be recoded on the fly as soon as we get to
 190   # know the source encoding and only in the cases where encoding may be hidden
 191   # among the payload we take the hit of copying the request around
 192   my $temp_target = { };
 193
 194   # since both of these can potentially bring their encoding in INPUT_ENCODING
 195   # they get dumped into temp_target
 196   _input_to_hash($temp_target, $ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
 197   _input_to_hash($temp_target, $ARGV[0])           if @ARGV && $ARGV[0];
 198
 199   if ($ENV{CONTENT_LENGTH}) {
 200     my $content;
 201     read STDIN, $content, $ENV{CONTENT_LENGTH};
 202     open my $fh, '>:raw', '/tmp/blubb.bin' or die;
 203     print $fh $content;
 204     close $fh;
 205     if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
 206       # multipart formdata can bring it's own encoding, so give it both
 207       # and let ti decide on it's own
 208       _parse_multipart_formdata($target, $temp_target, $content);
 209     } else {
 210       # normal encoding must be recoded
 211       _input_to_hash($temp_target, $content);
 212     }
 213   }
 214
 215   if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
 216     my %temp_form;
 217     $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
 218     _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
 219   }
 220
 221   my $encoding     = delete $temp_target->{INPUT_ENCODING} || $db_charset;
 222
 223   _recode_recursively(SL::Iconv->new($encoding, $db_charset), $temp_target => $target) if keys %$target;
 224
 225   map { $target->{$_} = $temp_target->{$_} } keys %{ $temp_target };
 226
 227   $::lxdebug->leave_sub;
 228
 229   return $target;
 230 }
 231
 232 1;
 233
 234 __END__
 235
 236 =head1 NAME
 237
 238 SL::Form.pm - main data object.
 239
 240 =head1 SYNOPSIS
 241
 242 This module handles unpacking of cgi parameters. usually you donÄt want to call
 243 anything in here directly,
 244
 245   SL::Request::read_cgi_input($target_hash_ref);
 246
 247 =head1 SPECIAL FUNCTIONS
 248
 249 =head2 C<_store_value()>
 250
 251 parses a complex var name, and stores it in the form.
 252
 253 syntax:
 254   $form->_store_value($key, $value);
 255
 256 keys must start with a string, and can contain various tokens.
 257 supported key structures are:
 258
 259 1. simple access
 260   simple key strings work as expected
 261
 262   id => $form->{id}
 263
 264 2. hash access.
 265   separating two keys by a dot (.) will result in a hash lookup for the inner value
 266   this is similar to the behaviour of java and templating mechanisms.
 267
 268   filter.description => $form->{filter}->{description}
 269
 270 3. array+hashref access
 271
 272   adding brackets ([]) before the dot will cause the next hash to be put into an array.
 273   using [+] instead of [] will force a new array index. this is useful for recurring
 274   data structures like part lists. put a [+] into the first varname, and use [] on the
 275   following ones.
 276
 277   repeating these names in your template:
 278
 279     invoice.items[+].id
 280     invoice.items[].parts_id
 281
 282   will result in:
 283
 284     $form->{invoice}->{items}->[
 285       {
 286         id       => ...
 287         parts_id => ...
 288       },
 289       {
 290         id       => ...
 291         parts_id => ...
 292       }
 293       ...
 294     ]
 295
 296 4. arrays
 297
 298   using brackets at the end of a name will result in a pure array to be created.
 299   note that you mustn't use [+], which is reserved for array+hash access and will
 300   result in undefined behaviour in array context.
 301
 302   filter.status[]  => $form->{status}->[ val1, val2, ... ]
 303
 304 =cut