From 48abd6c981f62e880b94e1ad9659d0a4d406912b Mon Sep 17 00:00:00 2001 From: =?utf8?q?Sven=20Sch=C3=B6ling?= Date: Wed, 28 Dec 2011 15:41:41 +0100 Subject: [PATCH] Request Handling aus Form ausgelagert. --- SL/Form.pm | 282 ++--------------------------------------------- SL/MoreCommon.pm | 23 +++- SL/Request.pm | 277 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 308 insertions(+), 274 deletions(-) create mode 100644 SL/Request.pm diff --git a/SL/Form.pm b/SL/Form.pm index dc20d2ce6..f873458e7 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -58,7 +58,9 @@ use SL::IC; use SL::IS; use SL::Mailer; use SL::Menu; +use SL::MoreCommon qw(uri_encode uri_decode); use SL::OE; +use SL::Request; use SL::Template; use SL::User; use SL::X; @@ -81,168 +83,6 @@ sub disconnect_standard_dbh { undef $standard_dbh; } -sub _store_value { - $main::lxdebug->enter_sub(2); - - my $self = shift; - my $key = shift; - my $value = shift; - - my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key; - - my $curr; - - if (scalar @tokens) { - $curr = \ $self->{ shift @tokens }; - } - - while (@tokens) { - my $sep = shift @tokens; - my $key = shift @tokens; - - $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]'; - $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].'; - $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].'; - $curr = \ $$curr->{$key} - } - - $$curr = $value; - - $main::lxdebug->leave_sub(2); - - return $curr; -} - -sub _input_to_hash { - $main::lxdebug->enter_sub(2); - - my $self = shift; - my $input = shift; - - my @pairs = split(/&/, $input); - - foreach (@pairs) { - my ($key, $value) = split(/=/, $_, 2); - $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key); - } - - $main::lxdebug->leave_sub(2); -} - -sub _request_to_hash { - $main::lxdebug->enter_sub(2); - - my $self = shift; - my $input = shift; - my $uploads = {}; - - if (!$ENV{'CONTENT_TYPE'} - || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) { - - $self->_input_to_hash($input); - - $main::lxdebug->leave_sub(2); - return $uploads; - } - - my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous); - - my $boundary = '--' . $1; - - foreach my $line (split m/\n/, $input) { - last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r")); - - if (($line eq $boundary) || ($line eq "$boundary\r")) { - ${ $previous } =~ s|\r?\n$|| if $previous; - - undef $previous; - undef $filename; - - $headers_done = 0; - $content_type = "text/plain"; - $boundary_found = 1; - $need_cr = 0; - - next; - } - - next unless $boundary_found; - - if (!$headers_done) { - $line =~ s/[\r\n]*$//; - - if (!$line) { - $headers_done = 1; - next; - } - - if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) { - if ($line =~ m|filename\s*=\s*"(.*?)"|i) { - $filename = $1; - substr $line, $-[0], $+[0] - $-[0], ""; - } - - if ($line =~ m|name\s*=\s*"(.*?)"|i) { - $name = $1; - substr $line, $-[0], $+[0] - $-[0], ""; - } - - $previous = _store_value($uploads, $name, '') if ($name); - $self->{FILENAME} = $filename if ($filename); - - next; - } - - if ($line =~ m|^content-type\s*:\s*(.*?)$|i) { - $content_type = $1; - } - - next; - } - - next unless $previous; - - ${ $previous } .= "${line}\n"; - } - - ${ $previous } =~ s|\r?\n$|| if $previous; - - $main::lxdebug->leave_sub(2); - - return $uploads; -} - -sub _recode_recursively { - $main::lxdebug->enter_sub(); - my ($iconv, $param) = @_; - - if (any { ref $param eq $_ } qw(Form HASH)) { - foreach my $key (keys %{ $param }) { - if (!ref $param->{$key}) { - # Workaround for a bug: converting $param->{$key} directly - # leads to 'undef'. I don't know why. Converting a copy works, - # though. - $param->{$key} = $iconv->convert("" . $param->{$key}); - } else { - _recode_recursively($iconv, $param->{$key}); - } - } - - } elsif (ref $param eq 'ARRAY') { - foreach my $idx (0 .. scalar(@{ $param }) - 1) { - if (!ref $param->[$idx]) { - # Workaround for a bug: converting $param->[$idx] directly - # leads to 'undef'. I don't know why. Converting a copy works, - # though. - $param->[$idx] = $iconv->convert("" . $param->[$idx]); - } else { - _recode_recursively($iconv, $param->[$idx]); - } - } - } - $main::lxdebug->leave_sub(); -} - sub new { $main::lxdebug->enter_sub(); @@ -258,43 +98,6 @@ sub new { bless $self, $type; - $main::lxdebug->leave_sub(); - - return $self; -} - -sub read_cgi_input { - $main::lxdebug->enter_sub(); - - my ($self) = @_; - - $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING}; - $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0]; - - my $uploads; - if ($ENV{CONTENT_LENGTH}) { - my $content; - read STDIN, $content, $ENV{CONTENT_LENGTH}; - $uploads = $self->_request_to_hash($content); - } - - if ($self->{RESTORE_FORM_FROM_SESSION_ID}) { - my %temp_form; - $::auth->restore_form_from_session(delete $self->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form); - $self->_input_to_hash(join '&', map { $self->escape($_) . '=' . $self->escape($temp_form{$_}) } keys %temp_form); - } - - my $db_charset = $::lx_office_conf{system}->{dbcharset}; - $db_charset ||= Common::DEFAULT_CHARSET; - - my $encoding = $self->{INPUT_ENCODING} || $db_charset; - delete $self->{INPUT_ENCODING}; - - _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self); - - map { $self->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads; - - #$self->{version} = "2.6.1"; # Old hardcoded but secure style open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file $self->{version} = ; close VERSION_FILE; @@ -305,6 +108,11 @@ sub read_cgi_input { return $self; } +sub read_cgi_input { + my ($self) = @_; + SL::Request::read_cgi_input($self); +} + sub _flatten_variables_rec { $main::lxdebug->enter_sub(2); @@ -404,32 +212,15 @@ sub dumper { } sub escape { - $main::lxdebug->enter_sub(2); - my ($self, $str) = @_; - $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8; - $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge; - - $main::lxdebug->leave_sub(2); - - return $str; + return uri_encode($str); } sub unescape { - $main::lxdebug->enter_sub(2); - my ($self, $str) = @_; - $str =~ tr/+/ /; - $str =~ s/\\$//; - - $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg; - $str = Encode::decode('utf-8-strict', $str) if $::locale->is_utf8; - - $main::lxdebug->leave_sub(2); - - return $str; + return uri_decode($str); } sub quote { @@ -3790,61 +3581,6 @@ Points of interest for a beginner are: =head1 SPECIAL FUNCTIONS -=head2 C<_store_value()> - -parses a complex var name, and stores it in the form. - -syntax: - $form->_store_value($key, $value); - -keys must start with a string, and can contain various tokens. -supported key structures are: - -1. simple access - simple key strings work as expected - - id => $form->{id} - -2. hash access. - separating two keys by a dot (.) will result in a hash lookup for the inner value - this is similar to the behaviour of java and templating mechanisms. - - filter.description => $form->{filter}->{description} - -3. array+hashref access - - adding brackets ([]) before the dot will cause the next hash to be put into an array. - using [+] instead of [] will force a new array index. this is useful for recurring - data structures like part lists. put a [+] into the first varname, and use [] on the - following ones. - - repeating these names in your template: - - invoice.items[+].id - invoice.items[].parts_id - - will result in: - - $form->{invoice}->{items}->[ - { - id => ... - parts_id => ... - }, - { - id => ... - parts_id => ... - } - ... - ] - -4. arrays - - using brackets at the end of a name will result in a pure array to be created. - note that you mustn't use [+], which is reserved for array+hash access and will - result in undefined behaviour in array context. - - filter.status[] => $form->{status}->[ val1, val2, ... ] - =head2 C PARAMS PARAMS (not named): diff --git a/SL/MoreCommon.pm b/SL/MoreCommon.pm index bb31f2def..1b83653e2 100644 --- a/SL/MoreCommon.pm +++ b/SL/MoreCommon.pm @@ -4,7 +4,7 @@ require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(save_form restore_form compare_numbers any cross); -our @EXPORT_OK = qw(ary_union ary_intersect ary_diff listify ary_to_hash); +our @EXPORT_OK = qw(ary_union ary_intersect ary_diff listify ary_to_hash uri_encode uri_decode uri_encode uri_decode); use List::MoreUtils qw(zip); use YAML; @@ -161,6 +161,27 @@ sub ary_to_hash { return zip(@indexes, @values); } +sub uri_encode { + my ($str) = @_; + + $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8; + $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge; + + return $str; +} + +sub uri_decode { + my ($str) = @_; + + $str =~ tr/+/ /; + $str =~ s/\\$//; + + $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg; + $str = Encode::decode('utf-8-strict', $str) if $::locale->is_utf8; + + return $str; +} + 1; __END__ diff --git a/SL/Request.pm b/SL/Request.pm new file mode 100644 index 000000000..b91bc524c --- /dev/null +++ b/SL/Request.pm @@ -0,0 +1,277 @@ +package SL::Request; + +use strict; + +use SL::Common; +use SL::MoreCommon qw(uri_encode uri_decode); +use List::Util qw(first max min sum); +use List::MoreUtils qw(all any apply); + +sub _store_value { + $::lxdebug->enter_sub(2); + + my ($target, $key, $value) = @_; + my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key; + my $curr; + + if (scalar @tokens) { + $curr = \ $target->{ shift @tokens }; + } + + while (@tokens) { + my $sep = shift @tokens; + my $key = shift @tokens; + + $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]'; + $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].'; + $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].'; + $curr = \ $$curr->{$key} + } + + $$curr = $value; + + $::lxdebug->leave_sub(2); + + return $curr; +} + +sub _input_to_hash { + $::lxdebug->enter_sub(2); + + my ($target, $input) = @_; + my @pairs = split(/&/, $input); + + foreach (@pairs) { + my ($key, $value) = split(/=/, $_, 2); + _store_value($target, uri_decode($key), uri_decode($value)) if ($key); + } + + $::lxdebug->leave_sub(2); +} + +sub parse_multipart_formdata { + my ($target, $input) = @_; + my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous); + my $uploads = {}; + + my $boundary = '--' . $1; + + foreach my $line (split m/\n/, $input) { + last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r")); + + if (($line eq $boundary) || ($line eq "$boundary\r")) { + ${ $previous } =~ s|\r?\n$|| if $previous; + + undef $previous; + undef $filename; + + $headers_done = 0; + $content_type = "text/plain"; + $boundary_found = 1; + $need_cr = 0; + + next; + } + + next unless $boundary_found; + + if (!$headers_done) { + $line =~ s/[\r\n]*$//; + + if (!$line) { + $headers_done = 1; + next; + } + + if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) { + if ($line =~ m|filename\s*=\s*"(.*?)"|i) { + $filename = $1; + substr $line, $-[0], $+[0] - $-[0], ""; + } + + if ($line =~ m|name\s*=\s*"(.*?)"|i) { + $name = $1; + substr $line, $-[0], $+[0] - $-[0], ""; + } + + $previous = _store_value($uploads, $name, '') if ($name); + $target->{FILENAME} = $filename if ($filename); + + next; + } + + if ($line =~ m|^content-type\s*:\s*(.*?)$|i) { + $content_type = $1; + } + + next; + } + + next unless $previous; + + ${ $previous } .= "${line}\n"; + } + + ${ $previous } =~ s|\r?\n$|| if $previous; + + $::lxdebug->leave_sub(2); + +} + +sub _request_to_hash { + $::lxdebug->enter_sub(2); + + my ($target, $input) = @_; + my $uploads; + + if (!$ENV{'CONTENT_TYPE'} + || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) { + + $uploads = { }; + _input_to_hash($target, $input); + + } else { + $uploads = _parse_multipart_formdata($target, $input); + } + + $main::lxdebug->leave_sub(2); + return $uploads; +} + +sub _recode_recursively { + $main::lxdebug->enter_sub(); + my ($iconv, $param) = @_; + + if (any { ref $param eq $_ } qw(Form HASH)) { + foreach my $key (keys %{ $param }) { + if (!ref $param->{$key}) { + # Workaround for a bug: converting $param->{$key} directly + # leads to 'undef'. I don't know why. Converting a copy works, + # though. + $param->{$key} = $iconv->convert("" . $param->{$key}); + } else { + _recode_recursively($iconv, $param->{$key}); + } + } + + } elsif (ref $param eq 'ARRAY') { + foreach my $idx (0 .. scalar(@{ $param }) - 1) { + if (!ref $param->[$idx]) { + # Workaround for a bug: converting $param->[$idx] directly + # leads to 'undef'. I don't know why. Converting a copy works, + # though. + $param->[$idx] = $iconv->convert("" . $param->[$idx]); + } else { + _recode_recursively($iconv, $param->[$idx]); + } + } + } + $main::lxdebug->leave_sub(); +} + +sub read_cgi_input { + $::lxdebug->enter_sub; + + my ($target) = @_; + + _input_to_hash($target, $ENV{QUERY_STRING}) if $ENV{QUERY_STRING}; + _input_to_hash($target, $ARGV[0]) if @ARGV && $ARGV[0]; + + my $uploads; + if ($ENV{CONTENT_LENGTH}) { + my $content; + read STDIN, $content, $ENV{CONTENT_LENGTH}; + $uploads = _request_to_hash($target, $content); + } + + if ($target->{RESTORE_FORM_FROM_SESSION_ID}) { + my %temp_form; + $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form); + _input_to_hash($target, join '&', map { uri_encode($_) . '=' . uri_encode($temp_form{$_}) } keys %temp_form); + } + + my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET; + my $encoding = delete $target->{INPUT_ENCODING} || $db_charset; + + _recode_recursively(SL::Iconv->new($encoding, $db_charset), $target); + + map { $target->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads; + + $::lxdebug->leave_sub; + + return $target; +} + +1; + +__END__ + +=head1 NAME + +SL::Form.pm - main data object. + +=head1 SYNOPSIS + +This module handles unpacking of cgi parameters. usually you donÄt want to call +anything in here directly, + + SL::Request::read_cgi_input($target_hash_ref); + +=head1 SPECIAL FUNCTIONS + +=head2 C<_store_value()> + +parses a complex var name, and stores it in the form. + +syntax: + $form->_store_value($key, $value); + +keys must start with a string, and can contain various tokens. +supported key structures are: + +1. simple access + simple key strings work as expected + + id => $form->{id} + +2. hash access. + separating two keys by a dot (.) will result in a hash lookup for the inner value + this is similar to the behaviour of java and templating mechanisms. + + filter.description => $form->{filter}->{description} + +3. array+hashref access + + adding brackets ([]) before the dot will cause the next hash to be put into an array. + using [+] instead of [] will force a new array index. this is useful for recurring + data structures like part lists. put a [+] into the first varname, and use [] on the + following ones. + + repeating these names in your template: + + invoice.items[+].id + invoice.items[].parts_id + + will result in: + + $form->{invoice}->{items}->[ + { + id => ... + parts_id => ... + }, + { + id => ... + parts_id => ... + } + ... + ] + +4. arrays + + using brackets at the end of a name will result in a pure array to be created. + note that you mustn't use [+], which is reserved for array+hash access and will + result in undefined behaviour in array context. + + filter.status[] => $form->{status}->[ val1, val2, ... ] + +=cut -- 2.20.1