Эта тема на forum.dklab.ru


Ant: Разбор строки запроса. Загрузка (upload) файлов на сервер.
По мотивам: http://forum.dklab.ru/perl/heap/AnalysisOfALineOfInquiry.html.

Функция обрабатывает входные данные (либо GET-формата, либо POST, либо всё вместе — как недавно выяснилось, и такое возможно) и возвращает хэш данных. Если происходит загрузка файлов, то загружает их. Если передаются данные с одинаковыми именами (что-то вроде «q=1&q=2&w=3&w=4»), то возвращает хэш, где ключ — имя, а значение — анонимный массив, в котором содержатся все данные повторяющихся имён. Возможен многократный вызов функции — даже если метод передачи — «POST».


# Parsing CGI query. If there's file to upload, then uploading file.
# If there're many values for one name then creating anonymous array.
{{{
my $cache; # «cache» for next calls
sub getQuery {
return %$cache if $cache;
my ( $buffer, %in );

# «multipart/form-data» request.
if ( $ENV{ 'CONTENT_TYPE' } and $ENV{ 'CONTENT_TYPE' } =~ m{^multipart/form-data} ) {
if ( $ENV{'REQUEST_METHOD'} ne 'POST' ) { return } # wrong request for «multipart/form-data»

# Read STDIN to buffer.
binmode( STDIN ); seek( STDIN, 0, 0 ); read( STDIN, $buffer, $ENV{ 'CONTENT_LENGTH' } );
my $boundary = "--".( $ENV{ 'CONTENT_TYPE' } =~ /boundary=("?)(\S+|[^"]+)\1/ )[ 1 ];
$buffer = substr( $buffer, length( $boundary ), index( $buffer, $boundary."--\x0D\x0A" ) - length( $boundary ) );

# Parse buffer.
for ( split( /$boundary\x0D\x0A/, $buffer ) ) {
$_ = substr( $_, 0, length( $_ ) - 2 );
my $pos = index( $_, "\x0D\x0A\x0D\x0A" );
my $header = substr( $_, 0, $pos );
my $value = substr( $_, $pos + 4 );
my $name = ( $header =~ /\bname=("?)([^\s:;]+|[^"]+)\1/ )[ 1 ];
my $fname = ( $header =~ /\bfilename=("?)([^\s:;]+|[^"]*)\1/ )[ 1 ];
#$fname = substr( $fname, rindex( $fname, "\\" ) + 1 ) if $fname;

# Uploading file.
if ( $header =~ /filename=/i ) {
if ( $in{ $name } ) {
if ( ref $in{ $name }[ 0 ] ) {
push( @{ $in{ $name } }, [ $fname, $value ] )
} else {
my @temp = delete( $in{ $name } );
push( @{ $in{ $name } }, @temp, [ $fname, $value ] );
}
} else { $in{ $name } = [ $fname, $value ] }
# Usual variable.
} else {
if ( $in{ $name } ) {
if ( ref $in{ $name } ) {
push( @{ $in{ $name } }, $value )
} else {
my $temp = delete( $in{ $name } );
push( @{ $in{ $name } }, $temp, $value );
}
} else { $in{ $name } = $value }
}
}
# Usual request.
} else {
if ( $ENV{ 'REQUEST_METHOD' } eq "POST" ) { read( STDIN, $buffer, $ENV{ 'CONTENT_LENGTH' } ) }
$buffer .= $buffer ? $ENV{ 'QUERY_STRING' } : '&'.$ENV{ 'QUERY_STRING' };

$buffer =~ s/&(?!amp;)/&/g; # XHTML standard
for ( split( /&/, $buffer ) ) {
my ( $name, $value ) = split( /=/ );
if ( $name ) {
for ( $name, $value ) { tr/+/ /; s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; }
if ( $in{ $name } ) {
if ( ref $in{ $name } ) {
push( @{ $in{ $name } }, $value )
} else {
my $temp = delete( $in{ $name } );
push( @{ $in{ $name } }, $temp, $value );
}
} else { $in{ $name } = $value }
}
}
}
$cache = \%in;
return %$cache;
}}}}


Вызов:
my %in = getQuery();

Примеры:
[1] При передачи обычных переменных («http://host/cgi-bin/script.pl?q=1&q=2&w=2&e=3», например) получим хеш:

# Получаем хэш:
%in == (
'q' => [ 1, 2 ],
'w' => '2',
'e' => '3'
);

# Или (что тоже самое):
$in{ 'q' }[ 0 ] == '1';
$in{ 'q' }[ 1 ] == '2';
$in{ 'w' } == '2';
$in{ 'e' } == '3';


[2] При закачке файлов получим следующее:

# Получаем хэш:
%in == (
'q' => [ 1, 2 ], # простые данные
'w' => '2', # простые данные
'e' => '3', # простые данные
'file' => [ имя_файла, содержимое_файла ], # файл
'many_files' => [ [ имя_файла, содержимое_файла ], [ имя_файла, содержимое_файла ] ] # файлы из полей с одинаковым именем
);

# Или (что тоже самое):
$in{ 'q' }[ 0 ] == '1';
$in{ 'q' }[ 1 ] == '2';
$in{ 'w' } == '2';
$in{ 'e' } == '3';
$in{ 'file' }[ 0 ] == 'имя_файла';
$in{ 'file' }[ 1 ] == 'содержимое_файла';
$in{ 'many_files' }[ 0 ][ 0 ] == 'имя_файла';
$in{ 'many_files' }[ 0 ][ 1 ] == 'содержимое_файла';
$in{ 'many_files' }[ 1 ][ 0 ] == 'имя_файла';
$in{ 'many_files' }[ 1 ][ 1 ] == 'содержимое_файла';


Дмитрий Котеров:
Огромное спасибо за предыдущую критику. Новая приветствуется. (-;

Обсуждение всего, что каким-либо образом связано с функцией в данной теме, прошу проводить здесь: http://forum.dklab.ru/perl/heap/AnalysisOfALineOfInquiry.html
Ant:
Я же просил все обсуждения проводить в теме http://forum.dklab.ru/perl/heap/AnalysisOfALineOfInquiry.html! Захотите получить ответ, пишите туда.
Ant:
Тема закрыта.

Эта тема на forum.dklab.ru