Projekt

Allgemein

Profil

« Zurück | Weiter » 

Revision 48abd6c9

Von Sven Schöling vor fast 13 Jahren hinzugefügt

  • ID 48abd6c981f62e880b94e1ad9659d0a4d406912b
  • Vorgänger 5c695f5d
  • Nachfolger 0ab92915

Request Handling aus Form ausgelagert.

Unterschiede anzeigen:

SL/Form.pm
58 58
use SL::IS;
59 59
use SL::Mailer;
60 60
use SL::Menu;
61
use SL::MoreCommon qw(uri_encode uri_decode);
61 62
use SL::OE;
63
use SL::Request;
62 64
use SL::Template;
63 65
use SL::User;
64 66
use SL::X;
......
81 83
  undef $standard_dbh;
82 84
}
83 85

  
84
sub _store_value {
85
  $main::lxdebug->enter_sub(2);
86

  
87
  my $self  = shift;
88
  my $key   = shift;
89
  my $value = shift;
90

  
91
  my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
92

  
93
  my $curr;
94

  
95
  if (scalar @tokens) {
96
     $curr = \ $self->{ shift @tokens };
97
  }
98

  
99
  while (@tokens) {
100
    my $sep = shift @tokens;
101
    my $key = shift @tokens;
102

  
103
    $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
104
    $curr = \ $$curr->[max 0, $#$$curr]  if $sep eq '[].';
105
    $curr = \ $$curr->[++$#$$curr]       if $sep eq '[+].';
106
    $curr = \ $$curr->{$key}
107
  }
108

  
109
  $$curr = $value;
110

  
111
  $main::lxdebug->leave_sub(2);
112

  
113
  return $curr;
114
}
115

  
116
sub _input_to_hash {
117
  $main::lxdebug->enter_sub(2);
118

  
119
  my $self  = shift;
120
  my $input = shift;
121

  
122
  my @pairs = split(/&/, $input);
123

  
124
  foreach (@pairs) {
125
    my ($key, $value) = split(/=/, $_, 2);
126
    $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
127
  }
128

  
129
  $main::lxdebug->leave_sub(2);
130
}
131

  
132
sub _request_to_hash {
133
  $main::lxdebug->enter_sub(2);
134

  
135
  my $self  = shift;
136
  my $input = shift;
137
  my $uploads = {};
138

  
139
  if (!$ENV{'CONTENT_TYPE'}
140
      || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
141

  
142
    $self->_input_to_hash($input);
143

  
144
    $main::lxdebug->leave_sub(2);
145
    return $uploads;
146
  }
147

  
148
  my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
149

  
150
  my $boundary = '--' . $1;
151

  
152
  foreach my $line (split m/\n/, $input) {
153
    last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
154

  
155
    if (($line eq $boundary) || ($line eq "$boundary\r")) {
156
      ${ $previous } =~ s|\r?\n$|| if $previous;
157

  
158
      undef $previous;
159
      undef $filename;
160

  
161
      $headers_done   = 0;
162
      $content_type   = "text/plain";
163
      $boundary_found = 1;
164
      $need_cr        = 0;
165

  
166
      next;
167
    }
168

  
169
    next unless $boundary_found;
170

  
171
    if (!$headers_done) {
172
      $line =~ s/[\r\n]*$//;
173

  
174
      if (!$line) {
175
        $headers_done = 1;
176
        next;
177
      }
178

  
179
      if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
180
        if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
181
          $filename = $1;
182
          substr $line, $-[0], $+[0] - $-[0], "";
183
        }
184

  
185
        if ($line =~ m|name\s*=\s*"(.*?)"|i) {
186
          $name = $1;
187
          substr $line, $-[0], $+[0] - $-[0], "";
188
        }
189

  
190
        $previous         = _store_value($uploads, $name, '') if ($name);
191
        $self->{FILENAME} = $filename if ($filename);
192

  
193
        next;
194
      }
195

  
196
      if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
197
        $content_type = $1;
198
      }
199

  
200
      next;
201
    }
202

  
203
    next unless $previous;
204

  
205
    ${ $previous } .= "${line}\n";
206
  }
207

  
208
  ${ $previous } =~ s|\r?\n$|| if $previous;
209

  
210
  $main::lxdebug->leave_sub(2);
211

  
212
  return $uploads;
213
}
214

  
215
sub _recode_recursively {
216
  $main::lxdebug->enter_sub();
217
  my ($iconv, $param) = @_;
218

  
219
  if (any { ref $param eq $_ } qw(Form HASH)) {
220
    foreach my $key (keys %{ $param }) {
221
      if (!ref $param->{$key}) {
222
        # Workaround for a bug: converting $param->{$key} directly
223
        # leads to 'undef'. I don't know why. Converting a copy works,
224
        # though.
225
        $param->{$key} = $iconv->convert("" . $param->{$key});
226
      } else {
227
        _recode_recursively($iconv, $param->{$key});
228
      }
229
    }
230

  
231
  } elsif (ref $param eq 'ARRAY') {
232
    foreach my $idx (0 .. scalar(@{ $param }) - 1) {
233
      if (!ref $param->[$idx]) {
234
        # Workaround for a bug: converting $param->[$idx] directly
235
        # leads to 'undef'. I don't know why. Converting a copy works,
236
        # though.
237
        $param->[$idx] = $iconv->convert("" . $param->[$idx]);
238
      } else {
239
        _recode_recursively($iconv, $param->[$idx]);
240
      }
241
    }
242
  }
243
  $main::lxdebug->leave_sub();
244
}
245

  
246 86
sub new {
247 87
  $main::lxdebug->enter_sub();
248 88

  
......
258 98

  
259 99
  bless $self, $type;
260 100

  
261
  $main::lxdebug->leave_sub();
262

  
263
  return $self;
264
}
265

  
266
sub read_cgi_input {
267
  $main::lxdebug->enter_sub();
268

  
269
  my ($self) = @_;
270

  
271
  $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
272
  $self->_input_to_hash($ARGV[0])           if @ARGV && $ARGV[0];
273

  
274
  my $uploads;
275
  if ($ENV{CONTENT_LENGTH}) {
276
    my $content;
277
    read STDIN, $content, $ENV{CONTENT_LENGTH};
278
    $uploads = $self->_request_to_hash($content);
279
  }
280

  
281
  if ($self->{RESTORE_FORM_FROM_SESSION_ID}) {
282
    my %temp_form;
283
    $::auth->restore_form_from_session(delete $self->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
284
    $self->_input_to_hash(join '&', map { $self->escape($_) . '=' . $self->escape($temp_form{$_}) } keys %temp_form);
285
  }
286

  
287
  my $db_charset   = $::lx_office_conf{system}->{dbcharset};
288
  $db_charset    ||= Common::DEFAULT_CHARSET;
289

  
290
  my $encoding     = $self->{INPUT_ENCODING} || $db_charset;
291
  delete $self->{INPUT_ENCODING};
292

  
293
  _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
294

  
295
  map { $self->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads;
296

  
297
  #$self->{version} =  "2.6.1";                 # Old hardcoded but secure style
298 101
  open VERSION_FILE, "VERSION";                 # New but flexible code reads version from VERSION-file
299 102
  $self->{version} =  <VERSION_FILE>;
300 103
  close VERSION_FILE;
......
305 108
  return $self;
306 109
}
307 110

  
111
sub read_cgi_input {
112
  my ($self) = @_;
113
  SL::Request::read_cgi_input($self);
114
}
115

  
308 116
sub _flatten_variables_rec {
309 117
  $main::lxdebug->enter_sub(2);
310 118

  
......
404 212
}
405 213

  
406 214
sub escape {
407
  $main::lxdebug->enter_sub(2);
408

  
409 215
  my ($self, $str) = @_;
410 216

  
411
  $str =  Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
412
  $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge;
413

  
414
  $main::lxdebug->leave_sub(2);
415

  
416
  return $str;
217
  return uri_encode($str);
417 218
}
418 219

  
419 220
sub unescape {
420
  $main::lxdebug->enter_sub(2);
421

  
422 221
  my ($self, $str) = @_;
423 222

  
424
  $str =~ tr/+/ /;
425
  $str =~ s/\\$//;
426

  
427
  $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
428
  $str =  Encode::decode('utf-8-strict', $str) if $::locale->is_utf8;
429

  
430
  $main::lxdebug->leave_sub(2);
431

  
432
  return $str;
223
  return uri_decode($str);
433 224
}
434 225

  
435 226
sub quote {
......
3790 3581

  
3791 3582
=head1 SPECIAL FUNCTIONS
3792 3583

  
3793
=head2 C<_store_value()>
3794

  
3795
parses a complex var name, and stores it in the form.
3796

  
3797
syntax:
3798
  $form->_store_value($key, $value);
3799

  
3800
keys must start with a string, and can contain various tokens.
3801
supported key structures are:
3802

  
3803
1. simple access
3804
  simple key strings work as expected
3805

  
3806
  id => $form->{id}
3807

  
3808
2. hash access.
3809
  separating two keys by a dot (.) will result in a hash lookup for the inner value
3810
  this is similar to the behaviour of java and templating mechanisms.
3811

  
3812
  filter.description => $form->{filter}->{description}
3813

  
3814
3. array+hashref access
3815

  
3816
  adding brackets ([]) before the dot will cause the next hash to be put into an array.
3817
  using [+] instead of [] will force a new array index. this is useful for recurring
3818
  data structures like part lists. put a [+] into the first varname, and use [] on the
3819
  following ones.
3820

  
3821
  repeating these names in your template:
3822

  
3823
    invoice.items[+].id
3824
    invoice.items[].parts_id
3825

  
3826
  will result in:
3827

  
3828
    $form->{invoice}->{items}->[
3829
      {
3830
        id       => ...
3831
        parts_id => ...
3832
      },
3833
      {
3834
        id       => ...
3835
        parts_id => ...
3836
      }
3837
      ...
3838
    ]
3839

  
3840
4. arrays
3841

  
3842
  using brackets at the end of a name will result in a pure array to be created.
3843
  note that you mustn't use [+], which is reserved for array+hash access and will
3844
  result in undefined behaviour in array context.
3845

  
3846
  filter.status[]  => $form->{status}->[ val1, val2, ... ]
3847

  
3848 3584
=head2 C<update_business> PARAMS
3849 3585

  
3850 3586
PARAMS (not named):
SL/MoreCommon.pm
4 4
our @ISA = qw(Exporter);
5 5

  
6 6
our @EXPORT    = qw(save_form restore_form compare_numbers any cross);
7
our @EXPORT_OK = qw(ary_union ary_intersect ary_diff listify ary_to_hash);
7
our @EXPORT_OK = qw(ary_union ary_intersect ary_diff listify ary_to_hash uri_encode uri_decode uri_encode uri_decode);
8 8

  
9 9
use List::MoreUtils qw(zip);
10 10
use YAML;
......
161 161
  return zip(@indexes, @values);
162 162
}
163 163

  
164
sub uri_encode {
165
  my ($str) = @_;
166

  
167
  $str =  Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
168
  $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge;
169

  
170
  return $str;
171
}
172

  
173
sub uri_decode {
174
  my ($str) = @_;
175

  
176
  $str =~ tr/+/ /;
177
  $str =~ s/\\$//;
178

  
179
  $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
180
  $str =  Encode::decode('utf-8-strict', $str) if $::locale->is_utf8;
181

  
182
  return $str;
183
}
184

  
164 185
1;
165 186

  
166 187
__END__
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

Auch abrufbar als: Unified diff