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, $p_attachment, $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         if ($name) {
 107           # legacy, some old upload routines expect this to be here
 108           $temp_target->{FILENAME} = $filename if defined $filename;
 109
 110           # name can potentially be both a normal variable or a file upload
 111           # a file upload can be identified by its "filename" attribute
 112           # the thing is, if a [+] clause vivifies atructur in one of the
 113           # branches it must be done in both, or subsequent "[]" will fail
 114           my $temp_target_slot = _store_value($temp_target, $name);
 115           my $target_slot      = _store_value($target,      $name);
 116
 117           # set the reference for appending of multiline data to the correct one
 118           $previous            = defined $filename ? $target_slot : $temp_target_slot;
 119
 120           # for multiple uploads: save the attachments in a SL/Mailer like structure
 121           if (defined $filename) {
 122             my $target_attachment      = _store_value($target,      "ATTACHMENTS.$name", {});
 123             my $temp_target_attachment = _store_value($temp_target, "ATTACHMENTS.$name", {});
 124
 125             $$target_attachment->{data}          = $previous;
 126             $$temp_target_attachment->{filename} = $filename;
 127
 128             $p_attachment = $$temp_target_attachment;
 129           }
 130         }
 131
 132         next;
 133       }
 134
 135       if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
 136         $content_type = $1;
 137         $p_attachment->{content_type} = $1;
 138
 139         if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
 140           $encoding = $2;
 141         }
 142
 143         next;
 144       }
 145
 146       if ($line =~ m|^content-transfer-encoding\s*=\s*(.*?)$|i) {
 147         $transfer_encoding = lc($1);
 148         if ($transfer_encoding  && $transfer_encoding !~ /^[78]bit|binary$/) {
 149           die 'Transfer encodings beyond 7bit/8bit and binary are not implemented.';
 150         }
 151         $p_attachment->{transfer_encoding} = $transfer_encoding;
 152
 153         next;
 154       }
 155
 156       next;
 157     }
 158
 159     next unless $previous;
 160
 161     ${ $previous } .= "${line}\n";
 162   }
 163
 164   ${ $previous } =~ s|\r?\n$|| if $previous;
 165
 166   $::lxdebug->leave_sub(2);
 167 }
 168
 169 sub _recode_recursively {
 170   $::lxdebug->enter_sub;
 171   my ($iconv, $from, $to) = @_;
 172
 173   if (any { ref $from eq $_ } qw(Form HASH)) {
 174     for my $key (keys %{ $from }) {
 175       if (!ref $from->{$key}) {
 176         # Workaround for a bug: converting $from->{$key} directly
 177         # leads to 'undef'. I don't know why. Converting a copy works,
 178         # though.
 179         $to->{$key} = $iconv->convert("" . $from->{$key}) if defined $from->{$key} && !defined $to->{$key};
 180       } else {
 181         $to->{$key} ||= {} if 'HASH'  eq ref $from->{$key};
 182         $to->{$key} ||= [] if 'ARRAY' eq ref $from->{$key};
 183         _recode_recursively($iconv, $from->{$key}, $to->{$key});
 184       }
 185     }
 186
 187   } elsif (ref $from eq 'ARRAY') {
 188     foreach my $idx (0 .. scalar(@{ $from }) - 1) {
 189       if (!ref $from->[$idx]) {
 190         # Workaround for a bug: converting $from->[$idx] directly
 191         # leads to 'undef'. I don't know why. Converting a copy works,
 192         # though.
 193         $to->[$idx] = $iconv->convert("" . $from->[$idx]);
 194       } else {
 195         $to->[$idx] ||= {} if 'HASH'  eq ref $from->[$idx];
 196         $to->[$idx] ||= [] if 'ARRAY' eq ref $from->[$idx];
 197         _recode_recursively($iconv, $from->[$idx], $to->[$idx]);
 198       }
 199     }
 200   }
 201   $main::lxdebug->leave_sub();
 202 }
 203
 204 sub read_cgi_input {
 205   $::lxdebug->enter_sub;
 206
 207   my ($target) = @_;
 208   my $db_charset   = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 209
 210   # yes i know, copying all those values around isn't terribly efficient, but
 211   # the old version of dumping everything into form and then launching a
 212   # tactical recode nuke at the data is still worse.
 213
 214   # this way the data can at least be recoded on the fly as soon as we get to
 215   # know the source encoding and only in the cases where encoding may be hidden
 216   # among the payload we take the hit of copying the request around
 217   my $temp_target = { };
 218
 219   # since both of these can potentially bring their encoding in INPUT_ENCODING
 220   # they get dumped into temp_target
 221   _input_to_hash($temp_target, $ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
 222   _input_to_hash($temp_target, $ARGV[0])           if @ARGV && $ARGV[0];
 223
 224   if ($ENV{CONTENT_LENGTH}) {
 225     my $content;
 226     read STDIN, $content, $ENV{CONTENT_LENGTH};
 227     if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
 228       # multipart formdata can bring it's own encoding, so give it both
 229       # and let ti decide on it's own
 230       _parse_multipart_formdata($target, $temp_target, $content);
 231     } else {
 232       # normal encoding must be recoded
 233       _input_to_hash($temp_target, $content);
 234     }
 235   }
 236
 237   my $encoding     = delete $temp_target->{INPUT_ENCODING} || $db_charset;
 238
 239   _recode_recursively(SL::Iconv->new($encoding, $db_charset), $temp_target => $target) if keys %$target;
 240
 241   if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
 242     my %temp_form;
 243     $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
 244     _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
 245   }
 246
 247   $::lxdebug->leave_sub;
 248
 249   return $target;
 250 }
 251
 252 1;
 253
 254 __END__
 255
 256 =head1 NAME
 257
 258 SL::Form.pm - main data object.
 259
 260 =head1 SYNOPSIS
 261
 262 This module handles unpacking of cgi parameters. usually you donÄt want to call
 263 anything in here directly,
 264
 265   SL::Request::read_cgi_input($target_hash_ref);
 266
 267 =head1 SPECIAL FUNCTIONS
 268
 269 =head2 C<_store_value()>
 270
 271 parses a complex var name, and stores it in the form.
 272
 273 syntax:
 274   $form->_store_value($key, $value);
 275
 276 keys must start with a string, and can contain various tokens.
 277 supported key structures are:
 278
 279 1. simple access
 280   simple key strings work as expected
 281
 282   id => $form->{id}
 283
 284 2. hash access.
 285   separating two keys by a dot (.) will result in a hash lookup for the inner value
 286   this is similar to the behaviour of java and templating mechanisms.
 287
 288   filter.description => $form->{filter}->{description}
 289
 290 3. array+hashref access
 291
 292   adding brackets ([]) before the dot will cause the next hash to be put into an array.
 293   using [+] instead of [] will force a new array index. this is useful for recurring
 294   data structures like part lists. put a [+] into the first varname, and use [] on the
 295   following ones.
 296
 297   repeating these names in your template:
 298
 299     invoice.items[+].id
 300     invoice.items[].parts_id
 301
 302   will result in:
 303
 304     $form->{invoice}->{items}->[
 305       {
 306         id       => ...
 307         parts_id => ...
 308       },
 309       {
 310         id       => ...
 311         parts_id => ...
 312       }
 313       ...
 314     ]
 315
 316 4. arrays
 317
 318   using brackets at the end of a name will result in a pure array to be created.
 319   note that you mustn't use [+], which is reserved for array+hash access and will
 320   result in undefined behaviour in array context.
 321
 322   filter.status[]  => $form->{status}->[ val1, val2, ... ]
 323
 324 =cut