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     if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
 203       # multipart formdata can bring it's own encoding, so give it both
 204       # and let ti decide on it's own
 205       _parse_multipart_formdata($target, $temp_target, $content);
 206     } else {
 207       # normal encoding must be recoded
 208       _input_to_hash($temp_target, $content);
 209     }
 210   }
 211
 212   my $encoding     = delete $temp_target->{INPUT_ENCODING} || $db_charset;
 213
 214   _recode_recursively(SL::Iconv->new($encoding, $db_charset), $temp_target => $target) if keys %$target;
 215
 216   if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
 217     my %temp_form;
 218     $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
 219     _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
 220   }
 221
 222   $::lxdebug->leave_sub;
 223
 224   return $target;
 225 }
 226
 227 1;
 228
 229 __END__
 230
 231 =head1 NAME
 232
 233 SL::Form.pm - main data object.
 234
 235 =head1 SYNOPSIS
 236
 237 This module handles unpacking of cgi parameters. usually you donÄt want to call
 238 anything in here directly,
 239
 240   SL::Request::read_cgi_input($target_hash_ref);
 241
 242 =head1 SPECIAL FUNCTIONS
 243
 244 =head2 C<_store_value()>
 245
 246 parses a complex var name, and stores it in the form.
 247
 248 syntax:
 249   $form->_store_value($key, $value);
 250
 251 keys must start with a string, and can contain various tokens.
 252 supported key structures are:
 253
 254 1. simple access
 255   simple key strings work as expected
 256
 257   id => $form->{id}
 258
 259 2. hash access.
 260   separating two keys by a dot (.) will result in a hash lookup for the inner value
 261   this is similar to the behaviour of java and templating mechanisms.
 262
 263   filter.description => $form->{filter}->{description}
 264
 265 3. array+hashref access
 266
 267   adding brackets ([]) before the dot will cause the next hash to be put into an array.
 268   using [+] instead of [] will force a new array index. this is useful for recurring
 269   data structures like part lists. put a [+] into the first varname, and use [] on the
 270   following ones.
 271
 272   repeating these names in your template:
 273
 274     invoice.items[+].id
 275     invoice.items[].parts_id
 276
 277   will result in:
 278
 279     $form->{invoice}->{items}->[
 280       {
 281         id       => ...
 282         parts_id => ...
 283       },
 284       {
 285         id       => ...
 286         parts_id => ...
 287       }
 288       ...
 289     ]
 290
 291 4. arrays
 292
 293   using brackets at the end of a name will result in a pure array to be created.
 294   note that you mustn't use [+], which is reserved for array+hash access and will
 295   result in undefined behaviour in array context.
 296
 297   filter.status[]  => $form->{status}->[ val1, val2, ... ]
 298
 299 =cut