projekt kivitendo

use SL::MoreCommon qw(uri_encode uri_decode);

use SL::Request;

sub read_cgi_input {

  my ($self) = @_;

  SL::Request::read_cgi_input($self);

}

  return uri_encode($str);

  return uri_decode($str);

our @EXPORT_OK = qw(ary_union ary_intersect ary_diff listify ary_to_hash uri_encode uri_decode uri_encode uri_decode);

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;

}

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