Модераторы: korob2001, ginnie

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> интересный вопрос: LWP! 
:(
    Опции темы
BlackLFL
Дата 24.4.2006, 10:41 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 263
Регистрация: 15.9.2005
Где: Москва

Репутация: 3
Всего: 12



Цитата(Shadex @  24.4.2006,  10:46 Найти цитируемый пост)
да, это прекрасно работает... =) но не в моем скрипте! я ещё раз все перепробовал! я спрашивал, может быть это как-нибудь связано с тем, что передается формой файл??? пользователь закачивает файл на сервер, через форму, CGI-скрипотом! может не работает из-за закачки - из-за того, что файл должен передаваться???  

показывайте полный исходник, будем разбираться ... 
PM WWW   Вверх
Shadex
Дата 24.4.2006, 12:32 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 40
Регистрация: 23.5.2005

Репутация: нет
Всего: 1



файл upload.cgi
Код

#!/usr/bin/perl
use strict;
use CGI::Carp qw(fatalsToBrowser);
use CGI qw/:standard/;
use XUploadConfig;
use LWP::UserAgent;

my $ua = LWP::UserAgent->new;
my $cont = $ua->get("http://test.com/test.php")->content;  #тут все работает и файл читается
if ($cont eq '12345')                                      #условие тоже выполняется
{
   print redirect('http://ya.ru');                         # а вот это и НЕ РАБОТАЕТ
   exit;
}

$CGI::POST_MAX = 1024 * $c->{max_upload_size};   # set max Total upload size

my $sid = (split(/[&=]/,$ENV{QUERY_STRING}))[1]; # get the random id for temp files

$sid ||= join '', map int rand 10, 1..7;         # if client has no javascript, generate server-side
&xmessage("Invalid Upload ID") unless $sid=~/^\d+$/; # Checking for invalid IDs
my $temp_dir = "$c->{temp_dir}/$sid";
mkdir $temp_dir;
my $mode = 0777;
chmod $mode,$temp_dir;

# Tell CGI.pm to use our directory based on sid
$CGITempFile::TMPDIRECTORY = $TempFile::TMPDIRECTORY = $temp_dir;


# Remove all files if user presses stop
sub CleanUp
{
   &DelData($temp_dir);
   exit(0);
}

$SIG{HUP} = 'IGNORE';
local $SIG{__DIE__} = 'CleanUp';

if($ENV{'CONTENT_LENGTH'} > 1024*$c->{max_upload_size})
{
   &lmsg('ERROR: Maximum upload size exceeded<br>You should stop transfer right now');
   sleep 1;
   &DelData($temp_dir);
   &xmessage("Maximum upload size exceeded");
}
else
{
   open FILE,">$temp_dir/flength";
   print FILE $ENV{'CONTENT_LENGTH'}."\n";
   close FILE;
   my $mode = 0777; chmod $mode,"$temp_dir/flength";
}

my $cg = new CGI;
if( $cg->cgi_error() )
{
   &DelData($temp_dir);
   &xmessage("ERROR: Maximum upload size exceeded");
}

my (@fileslots,@filenames,@file_status);
my @params = $cg->param;

for my $k ( keys %{$cg->{'.tmpfiles'}} )
{
   $cg->{'.tmpfiles'}->{$k}->{info}->{'Content-Disposition'} =~ /name="(.+?)"; filename="(.+?)"/;
   my ($field_name,$filename) = ($1,$2);

   $filename =~ s/.*\\([^\\]*)$/$1/;

   push @fileslots, $field_name;
   push @filenames, $filename;
   $filename=~ /(.+)\.(.+)/;
   my ($fn,$ext) = ($1,$2);
   if($ext !~ /^$c->{ext_allowed}$/i)
   {
      &lmsg("MSG:File $filename have unallowed extension!");
      push @file_status, "unallowed extension";
      next;
   }
   $fn = substr($fn,0,$c->{max_name_length});
   my $i;
   $i++ while (-e "$c->{target_dir}/$fn$i.$ext" && $c->{copy_mode} eq 'Rename');

   $filename="$fn$i.$ext";
   push @file_status, "OK. renamed to:$fn$i.$ext" if $i;
   &lmsg("MSG:File '$fn.$ext' already exist!<br>New file saved as '$filename'.") if $i;

   if(-e "$c->{target_dir}/$filename" && $c->{copy_mode} eq 'Warn')
   {
      &lmsg("MSG:File $filename already exist! New file wasn't saved.");
      push @file_status, "error:filename already exist";
      next;
   }

   &SaveFile2( ${$cg->{'.tmpfiles'}->{$k}->{name}}, $c->{target_dir}, $filename );
   push @file_status, "OK" unless $i;
}

### Small pause to sync messages with pop-up
select(undef, undef, undef,0.1);
&DelData($temp_dir);
&DeleteOldTempFiles;

print"Content-type: text/html\n\n";

### Sending data with POST request if required
my $url_post = $cg->param('url_post');
$url_post ||= $c->{url_post};
if($url_post)
{
   my ($str,@har);
   for (0..$#fileslots)
   {
      push @har, { name=>$fileslots[$_],          'value'=>$filenames[$_] };
      push @har, { name=>"$fileslots[$_]_status", 'value'=>$file_status[$_] };
   }
   for my $k (@params)
   {
      my @arr = $cg->param($k);
      for my $p (@arr)
      {
         next if ref $p eq 'Fh'; #&& $p !~ /\.$c->{ext_allowed}$/i; # Skip unallowed files
         $p =~ s/.*\\([^\\]*)$/$1/;
         push @har, { name=>$k, value=>$p };
      }
   }

   push @har, { name=>'target_dir', value=>$c->{target_dir} };

   print"<HTML><BODY onLoad='document.F1.submit();'><Form name='F1' action='$url_post' target='_parent' method='POST'>";
   print"<textarea name='$_->{name}'>$_->{value}</textarea>" for @har;
   print"</Form></BODY></HTML>";
   exit;
}

### Upload finished, redirecting
my $redirect_link = $cg->param('redirect_link');
$redirect_link ||= $c->{redirect_link};
print"<HTML><script>parent.document.location='$redirect_link';</Script></HTML>";

#############################################

sub DeleteOldTempFiles
{
   my @ff;
   opendir(DIR, $c->{temp_dir}) || &xmessage("Can't opendir temporary folder: $!");
   @ff = readdir(DIR);
   closedir(DIR);
   foreach my $fn (@ff)
   {
      next if $fn =~ /^\.{1,2}$/;
      my $file = $c->{temp_dir}.'/'.$fn;
      my $ftime = (lstat($file))[9];
      my $diff = time() - $ftime;
      next if $diff < $c->{temp_files_lifetime};
      -d $file ? &DelData($file) : unlink($file);
   }
}

sub SaveFile2
{
   my ($temp,$dir,$fname) = @_;
   rename($temp,"$dir/$fname");
}

sub DelData
{
   my ($dir) = @_;
   opendir(DIR, $dir) || die"Error2";
   my @ff = readdir(DIR);
   closedir(DIR);
   for my $fn(@ff)
   {
      unlink("$dir/$fn");
   }
   rmdir("$dir");
}

sub xmessage
{
   my ($msg) = @_;
   print"Content-type: text/html\n\n";
   print"<HTML><BODY><b>$msg</b><br><input type='button' value='&lt; Back' onclick='javascript:history.go(-1);'></BODY></HTML>";
   exit;
}

sub lmsg
{
   my ($msg) = @_;
   open(FILE,">>$temp_dir/flength");
   print FILE $msg."\n";
   close FILE;
}

XUploadConfig
Код

package XUploadConfig;

BEGIN
{
  use Exporter;
  @XUploadConfig::ISA = qw( Exporter );
  @XUploadConfig::EXPORT = qw( $c );
}

our $c=
{
 temp_dir        => '/home/httpd/vhosts/sexyuni.com/cgi-bin/temp',
 target_dir      => '/home/httpd/vhosts/sexyuni.com/cgi-bin/uploads',
 templates_dir   => '/home/httpd/vhosts/sexyuni.com/httpdocs/Templates',
 ext_allowed     => 'jpg|jpeg|gif|png|rar|zip|mp3|avi|txt|csv|pdf',
 url_post        => 'http://www.test.com/cgi-bin/post.cgi',
 redirect_link   => 'http://www.test.com/upload_form.html',
 max_name_length => 64,
 copy_mode       => 'Rename',
 max_upload_size => 7000000000,
 temp_files_lifetime => 86400,
};
1;
 
PM MAIL   Вверх
Shadex
Дата 28.4.2006, 11:21 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 40
Регистрация: 23.5.2005

Репутация: нет
Всего: 1



неужели так никто и не может понять в чем проблема?!  
PM MAIL   Вверх
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Perl: CGI программирование"
korob2001
sharq
  • В этом разделе обсуждаются вопросы относящиеся только к CGI программированию
  • Если ваш вопрос не относится к системному или CGI программированию, задавайте его в общем разделе
  • Если ваш вопрос относится к системному программированию, задавайте его здесь
  • Интерпретатор Perl можно скачать здесь ActiveState, O'REILLY, The source for Perl
  • Справочное руководство "Установка perl-модулей", качать здесь


Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, korob2001, sharq.

 
1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Perl: разработка для Web | Следующая тема »


 




[ Время генерации скрипта: 0.0550 ]   [ Использовано запросов: 21 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.