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, $input) = @_;
  54   my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
  55   my $uploads = {};
  56
  57   my $boundary = '--' . $1;
  58
  59   foreach my $line (split m/\n/, $input) {
  60     last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
  61
  62     if (($line eq $boundary) || ($line eq "$boundary\r")) {
  63       ${ $previous } =~ s|\r?\n$|| if $previous;
  64
  65       undef $previous;
  66       undef $filename;
  67
  68       $headers_done   = 0;
  69       $content_type   = "text/plain";
  70       $boundary_found = 1;
  71       $need_cr        = 0;
  72
  73       next;
  74     }
  75
  76     next unless $boundary_found;
  77
  78     if (!$headers_done) {
  79       $line =~ s/[\r\n]*$//;
  80
  81       if (!$line) {
  82         $headers_done = 1;
  83         next;
  84       }
  85
  86       if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
  87         if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
  88           $filename = $1;
  89           substr $line, $-[0], $+[0] - $-[0], "";
  90         }
  91
  92         if ($line =~ m|name\s*=\s*"(.*?)"|i) {
  93           $name = $1;
  94           substr $line, $-[0], $+[0] - $-[0], "";
  95         }
  96
  97         $previous           = _store_value($uploads, $name, '') if ($name);
  98         $target->{FILENAME} = $filename if ($filename);
  99
 100         next;
 101       }
 102
 103       if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
 104         $content_type = $1;
 105       }
 106
 107       next;
 108     }
 109
 110     next unless $previous;
 111
 112     ${ $previous } .= "${line}\n";
 113   }
 114
 115   ${ $previous } =~ s|\r?\n$|| if $previous;
 116
 117   $::lxdebug->leave_sub(2);
 118
 119 }
 120
 121 sub _request_to_hash {
 122   $::lxdebug->enter_sub(2);
 123
 124   my ($target, $input) = @_;
 125   my $uploads;
 126
 127   if (!$ENV{'CONTENT_TYPE'}
 128       || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
 129
 130    $uploads = { };
 131     _input_to_hash($target, $input);
 132
 133   } else {
 134    $uploads = _parse_multipart_formdata($target, $input);
 135   }
 136
 137   $main::lxdebug->leave_sub(2);
 138   return $uploads;
 139 }
 140
 141 sub _recode_recursively {
 142   $main::lxdebug->enter_sub();
 143   my ($iconv, $param) = @_;
 144
 145   if (any { ref $param eq $_ } qw(Form HASH)) {
 146     foreach my $key (keys %{ $param }) {
 147       if (!ref $param->{$key}) {
 148         # Workaround for a bug: converting $param->{$key} directly
 149         # leads to 'undef'. I don't know why. Converting a copy works,
 150         # though.
 151         $param->{$key} = $iconv->convert("" . $param->{$key});
 152       } else {
 153         _recode_recursively($iconv, $param->{$key});
 154       }
 155     }
 156
 157   } elsif (ref $param eq 'ARRAY') {
 158     foreach my $idx (0 .. scalar(@{ $param }) - 1) {
 159       if (!ref $param->[$idx]) {
 160         # Workaround for a bug: converting $param->[$idx] directly
 161         # leads to 'undef'. I don't know why. Converting a copy works,
 162         # though.
 163         $param->[$idx] = $iconv->convert("" . $param->[$idx]);
 164       } else {
 165         _recode_recursively($iconv, $param->[$idx]);
 166       }
 167     }
 168   }
 169   $main::lxdebug->leave_sub();
 170 }
 171
 172 sub read_cgi_input {
 173   $::lxdebug->enter_sub;
 174
 175   my ($target) = @_;
 176
 177   _input_to_hash($target, $ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
 178   _input_to_hash($target, $ARGV[0])           if @ARGV && $ARGV[0];
 179
 180   my $uploads;
 181   if ($ENV{CONTENT_LENGTH}) {
 182     my $content;
 183     read STDIN, $content, $ENV{CONTENT_LENGTH};
 184     $uploads = _request_to_hash($target, $content);
 185   }
 186
 187   if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
 188     my %temp_form;
 189     $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
 190     _input_to_hash($target, join '&', map { uri_encode($_) . '=' . uri_encode($temp_form{$_}) } keys %temp_form);
 191   }
 192
 193   my $db_charset   = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 194   my $encoding     = delete $target->{INPUT_ENCODING} || $db_charset;
 195
 196   _recode_recursively(SL::Iconv->new($encoding, $db_charset), $target);
 197
 198   map { $target->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads;
 199
 200   $::lxdebug->leave_sub;
 201
 202   return $target;
 203 }
 204
 205 1;
 206
 207 __END__
 208
 209 =head1 NAME
 210
 211 SL::Form.pm - main data object.
 212
 213 =head1 SYNOPSIS
 214
 215 This module handles unpacking of cgi parameters. usually you donÄt want to call
 216 anything in here directly,
 217
 218   SL::Request::read_cgi_input($target_hash_ref);
 219
 220 =head1 SPECIAL FUNCTIONS
 221
 222 =head2 C<_store_value()>
 223
 224 parses a complex var name, and stores it in the form.
 225
 226 syntax:
 227   $form->_store_value($key, $value);
 228
 229 keys must start with a string, and can contain various tokens.
 230 supported key structures are:
 231
 232 1. simple access
 233   simple key strings work as expected
 234
 235   id => $form->{id}
 236
 237 2. hash access.
 238   separating two keys by a dot (.) will result in a hash lookup for the inner value
 239   this is similar to the behaviour of java and templating mechanisms.
 240
 241   filter.description => $form->{filter}->{description}
 242
 243 3. array+hashref access
 244
 245   adding brackets ([]) before the dot will cause the next hash to be put into an array.
 246   using [+] instead of [] will force a new array index. this is useful for recurring
 247   data structures like part lists. put a [+] into the first varname, and use [] on the
 248   following ones.
 249
 250   repeating these names in your template:
 251
 252     invoice.items[+].id
 253     invoice.items[].parts_id
 254
 255   will result in:
 256
 257     $form->{invoice}->{items}->[
 258       {
 259         id       => ...
 260         parts_id => ...
 261       },
 262       {
 263         id       => ...
 264         parts_id => ...
 265       }
 266       ...
 267     ]
 268
 269 4. arrays
 270
 271   using brackets at the end of a name will result in a pure array to be created.
 272   note that you mustn't use [+], which is reserved for array+hash access and will
 273   result in undefined behaviour in array context.
 274
 275   filter.status[]  => $form->{status}->[ val1, val2, ... ]
 276
 277 =cut