Срочно нужен скрипт на Perl!!!!!!!

0

0

Народ, кто разбирается в Перле, помогите, плз! Срочно нужен скрипт, реализующий метод http-PUT/DELETE на Apache под WinXP. В интернете ничего не нашли, подсобите, т.к. на Perle никогда ничего не писали, а надо сегодня до вечера.

Огромное спасибо! Если удобнее на e-mail, то: dimabutov@hotmail.com

Ссылка

←

учусь!

Запуск проги....& массив

→

а че такое "метод http-PUT/DELETE"???

Че он делает то??

~~vilfred~~ ☆☆
(14.09.03 13:57:00 MSD)

Ссылка

Ну, если ты хочешь удалённо зааплоадить/удалить файл на http (не ftp!) например, с помощью winie (есть такой проектик на Java), http-сервер использует метод PUT/DELETE. В Apache этот метод есть, но ему не соответствует никакой скрипт (попросту говоря, он не имплементирован). Нашли пару скриптов, но они у нас почему-то не работают :((( Вот они:

#1#################################################### #!C:\Perl\bin

# Very simple PUT handler. Read the Apache Week article before attempting # to use this script. You are responsible for ensure that this script is # used securely.

# A simple log file, must be writable by the user that this program runs as. # Should not be within the document tree. $putlog = "/tmp/put1.log";

# Check we are using PUT method if ($ENV{'REQUEST_METHOD'} ne "PUT") { &reply(500, "Request method is not PUT"); }

# Note: should also check we are an authentication user by checking # REMOTE_USER

# Check we got a destination filename $filename = $ENV{'PATH_TRANSLATED'}; if (!$filename) { &reply(500, "No PATH_TRANSLATED"); }

# Check we got some content $clength = $ENV{'CONTENT_LENGTH'}; if (!$clength) { &reply(500, "Content-Length missing or zero ($clength)"); }

# Read the content itself $toread = $clength; $content = ""; while ($toread > 0) { $nread = read(STDIN, $data, $clength); &reply(500, "Error reading content") if !defined($nread); $toread -= $nread; $content = $data; }

# Write it out # Note: doesn't check the location of the file, whether it already # exists, whether it is a special file, directory or link. Does not # set the access permissions. Does not handle subdirectories that # need creating. open(OUT, "> $filename") || &reply(500, "Cannot write to $filename"); print OUT $content; close(OUT);

# Everything seemed to work, reply with 204 (or 200). Should reply with 201 # if content was created, not updated. &reply(204);

exit(0);

# # Send back reply to client for a given status. #

sub reply { local($status, $message) = @_; local($remuser, $remhost, $logline) = ();

print "Status: $status\n"; print "Content-Type: text/html\n\n";

if ($status == 200) { print "<HEAD><TITLE>OK</TITLE></HEAD><H1>Content Accepted</H1>\n"; } elsif ($status == 500) { print "<HEAD><TITLE>Error</TITLE></HEAD><H1>Error Publishing File</H1>\n"; print "An error occurred publishing this file ($message).\n"; } # Note: status 204 and 201 gives have content part

# Create a simple log $remuser = $ENV{'REMOTE_USER'} || "-"; $remhost = $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} || "-"; $logline = "$remhost $remuser $filename status $status"; $logline .= " ($message)" if ($status == 500); &log($logline); exit(0); }

sub log { local($msg) = @_; open (LOG, ">> $putlog") || return; print LOG "$msg\n"; close(LOG); }

А вот второй:

#2############################################################################## # #!C:\Perl\bin\perl.exe

### Config my $datadir = 'C:\Program Files\Apache Group\Apache2\htdocs\'; my $maxfilesize = 64 * 1024; my $maxdirsize = 128 * 1024; # when overwriting maxdirsize must # provide room for old version # + new version

use strict;

my $file; if ($ENV{'PATH_TRANSLATED'} =~ /^([a-zA-Z0-9_.\-\/]+)$/){ # Untaint $file = $1; if ($file =~ /\.\./){ # Don't give out PATH_TRANSLATED here! my $badfile = $ENV{'REQUEST_URI'}; &reply(403, "Access to $badfile forbidden"); } } else { # Don't give out PATH_TRANSLATED here! my $badfile = $ENV{'REQUEST_URI'}; &reply(403, "Access to $badfile forbidden"); }

my $userdir; if ($file =~ m#^(.+)/([^/]+)$#){ $userdir = $1; }

if ($userdir ne $datadir . $user){ # Don't give out PATH_TRANSLATED here! my $badfile = $ENV{'REQUEST_URI'}; &reply(403, "Access to $badfile forbidden for $user"); }

if (!defined $ENV{'CONTENT_LENGTH'}){ &reply(411, "Client failed to specify Content-Length"); } my $length = $ENV{'CONTENT_LENGTH'};

if (-d $userdir){ my $dirsize = 0; opendir (DIR, $userdir) || &reply(500, "Can't open user directory:$!\n"); my @userfiles = readdir(DIR); closedir (DIR); for (@userfiles){ next if -d "$userdir/$_"; $dirsize += -s _; }

if ($dirsize > $maxdirsize){ &reply(413, "User directory too large ($dirsize), contact admin"); }elsif ($dirsize + $length > $ maxdirsize){ &reply(413, "File too large ($length) for your user quota"); }elsif ($length > $maxfilesize){ &reply(413, "File length $length too large"); } }

### Ready for the action

my $newfile = 1; if (-e $file){ $newfile = 0; }

open (FILE, ">$file") || reply(500, "Couldn't create directory $userdir: $!");

while($length){ my $data; my $bytes = read(STDIN, $data, 8192 < $length ? 8192 : $length); if (!defined($bytes)){ reply(500, "Error reading input: $!"); } $length -= $bytes; print FILE $data; } close FILE;

my $location = 'http://' . $ENV{'SERVER_NAME'} . $ENV{'REQUEST_URI'}; if ($newfile){ &reply(201, "File created at $location", "Location: $location"); }else{ &reply(204, '', "Location: $location"); }

### Never reached exit 0;

sub reply{ my($code, $message, $location) = @_; my %status = (200 => 'OK', 201 => 'Created', 204 => 'No content returned', 400 => 'Bad request', 403 => 'Forbidden', 411 => 'Length required', 413 => 'Request entity too large', 500 => 'Server error'); my $status = $status{$code};

print <<EOF; Status: $code $status Content-type: text/html EOF

if (defined $location){ print "$location\n"; } print "\n"; if ($message){ print <<EOF; <HTML><HEAD> <TITLE>$code $status</TITLE> </HEAD><BODY> <H1>$status</H1> $message.<P> </BODY></HTML> EOF }

exit ($code < 300) ? 0 : 1; }

Всё. Повторяю: о Перле я знаю только то, что он существует. Не успеваю освоить сам, поэтому и обращаюсь за помощью. В любом случае, спасибо.

anonymous
(14.09.03 14:21:48 MSD)

Ссылка

Не, лучше, наверное, дам линк на свой сайт с этими скриптами:

http://www.geocities.com/dimabtvsk/examples.zip

anonymous
(14.09.03 14:35:46 MSD)

Ссылка

вот тебе скрипт, аплоидящий файлы на www:

#!/usr/bin/perl -w
$basedir = "/usr/home/vovka/public_html/files";
$donepage = "http://www.myserver.ru/~vovka/files";;
use CGI; 
$onnum = 1;
while ($onnum != 9) {
	my $req = new CGI; 
	my $file = $req->param("FILE$onnum"); 
	if ($file ne "") {
		my $fileName = $file; 
		$fileName =~ s!^.*(\\|\/)!!; 
		$newmain = $fileName;
		open (OUTFILE, ">$basedir/$fileName"); 
		while (my $bytesread = read($file, my $buffer, 1024)) { 
			print OUTFILE $buffer; 
		} 
		close (OUTFILE); 
	}
	$onnum++;
}
print "Content-type: text/html\n";
print "Location:$donepage\n\n";

Соответственно указывая число в цикле while ($onnum != 9) 
можно подгружать нужное чилсо файлов при одном POST запросе. 
html-код формы для скрипта такой:

<form method="POST" action="/cgi-bin/fup.pl"
ENCTYPE="multipart/form-data">
File 1: <input type="file" name="FILE1">
<br>File 2: <input type="file" name="FILE2">
<br>File 3: <input type="file" name="FILE3">
<br>File 4: <input type="file" name="FILE4">
<br>File 5: <input type="file" name="FILE5">
<br>File 6: <input type="file" name="FILE6">
<br>File 7: <input type="file" name="FILE7">
<br>File 8: <input type="file" name="FILE8">
<br>File 9: <input type="file" name="FILE9">
<br>
<input type="submit" value="Upload!">
</form>

Пакеты вида multipart/form-data описываются rfc1867, который будет 
описан более подродбно на предмет автоматической посылки изображений 
через формы, в которых сказано ENCTYPE="multipart/form-data", помимо 
простого текста(закодированного URI). Т.е. скрипт, посылающий картинки
 и текст на удаленный сервер. 

Вот все тоже самое, но по другому(для запароленных страничек и помимо 
этого, подгружение еще и текста по multipatr'у):

Для того, чтобы заполнить текстовые поля name и descr в форме:

<form action="http://www.server.ru/cgi-bin/gbook.pl"; method=post>
<input type=text name=name size=20><br>
<input type=text name=descr size=20><br>
<input type=submit value="Submit"><br>
<input type=reset value="clear">
</form>

нужно написать следующий скрипт(соответствующие значения полей name 
и descr указаны в квадратных скобках):

#!/usr/bin/perl -w
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
$ua = LWP::UserAgent->new();
my $req = POST 'http://www.server.su/cgi-bin/gbook.pl',
  [ name => 'lalala', 
   descr => 'aaa'];
print $content = $ua->request($req)->as_string;

Если в форме полей больше, чем в приведенном примере, то их нужно 
просто перечислить в квадратных скобочках через запятую, причем после 
поледнего поля запятую ставить не нужно:

my $req = POST 'http://www.server.su/cgi-bin/gbook.pl',
  [ name => 'lalala',
   email => 'user\@host.ru',
    text => qx{
bla-bla-bla
alalalalal hahahaha test

s privetom,
Vasya
}
   descr => 'aaa'];

Если необходимо подгрузить помимо текста еще и картинку(картинки), 
то нужно указать Content_Type => 'form-data':

#!/usr/bin/perl -w
$test = "http://www.server.ru/add.html";;
$file = "test.gif";
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
use CGI qw(header -no_debug);

my $req = POST $test,
Content_Type => 'form-data',
Content      => [
        user => 'vasya',
    password => '123456',
       image => [$file],
        href => 'aaaaaaaaaaaa',
     profile => '13',
       ratio => '333333',
         alt => 'Hot News!',
                ];
my $res = LWP::UserAgent->new->request($req);
print header, $res->is_success ? $res->content : $res->status_line;
print $req->as_string;

если необходимо подгружать одновременно несколько картинок(любое 
число), без текста, то это описано тут или слегка модифицировав 
POST-запрос:

my $req = POST $test,
Content_Type => 'form-data',
Content      => [
        user => 'vasya',
    password => '123456',
      image1 => [$file1],
      image2 => [$file2],
      image3 => [$file3],
      image4 => [$file4],
        href => 'aaaaaaaaaaaa',
     profile => '13',
       ratio => '333333',
         alt => 'Hot News!',
                ];

~~vilfred~~ ☆☆
(14.09.03 15:34:37 MSD)