@ISA
=
qw(LWP::Protocol)
;
eval
{
Net::FTP->require_version(2.00);
@ISA
=
qw(Net::FTP)
;
sub
new {
my
$class
=
shift
;
my
$self
=
$class
->SUPER::new(
@_
) ||
return
undef
;
my
$mess
=
$self
->message;
$mess
=~ s|\n.*||s;
$mess
=~ s|\s
*ready
\.?$||;
$mess
=~ s|\s*\(Version\s*|/| and
$mess
=~ s|\)$||;
${
*$self
}{myftp_server} =
$mess
;
$self
;
}
sub
http_server {
my
$self
=
shift
;
${
*$self
}{myftp_server};
}
sub
home {
my
$self
=
shift
;
my
$old
= ${
*$self
}{myftp_home};
if
(
@_
) {
${
*$self
}{myftp_home} =
shift
;
}
$old
;
}
sub
go_home {
my
$self
=
shift
;
$self
->cwd(${
*$self
}{myftp_home});
}
sub
request_count {
my
$self
=
shift
;
++${
*$self
}{myftp_reqcount};
}
sub
ping {
my
$self
=
shift
;
return
$self
->go_home;
}
};
my
$init_failed
= $@;
sub
_connect {
my
(
$self
,
$host
,
$port
,
$user
,
$account
,
$password
,
$timeout
) =
@_
;
my
$key
;
my
$conn_cache
=
$self
->{ua}{conn_cache};
if
(
$conn_cache
) {
$key
=
"$host:$port:$user"
;
$key
.=
":$account"
if
defined
(
$account
);
if
(
my
$ftp
=
$conn_cache
->withdraw(
"ftp"
,
$key
)) {
if
(
$ftp
->ping) {
$conn_cache
->deposit(
"ftp"
,
$key
,
$ftp
);
return
$ftp
;
}
}
}
my
$ftp
= LWP::Protocol::MyFTP->new(
$host
,
Port
=>
$port
,
Timeout
=>
$timeout
,
LocalAddr
=>
$self
->{ua}{local_address},
);
unless
(
$ftp
) {
$@ =~ s/^Net::FTP: //;
return
HTTP::Response->new(
&HTTP::Status::RC_INTERNAL_SERVER_ERROR
, $@);
}
unless
(
$ftp
->login(
$user
,
$password
,
$account
)) {
my
$mess
=
scalar
(
$ftp
->message);
$mess
=~ s/\n$//;
my
$res
= HTTP::Response->new(
&HTTP::Status::RC_UNAUTHORIZED
,
$mess
);
$res
->header(
"Server"
,
$ftp
->http_server);
$res
->header(
"WWW-Authenticate"
,
qq(Basic Realm="FTP login")
);
return
$res
;
}
my
$home
=
$ftp
->pwd;
$ftp
->home(
$home
);
$conn_cache
->deposit(
"ftp"
,
$key
,
$ftp
)
if
$conn_cache
;
return
$ftp
;
}
sub
request
{
my
(
$self
,
$request
,
$proxy
,
$arg
,
$size
,
$timeout
) =
@_
;
$size
= 4096
unless
$size
;
if
(
defined
$proxy
)
{
return
HTTP::Response->new(
&HTTP::Status::RC_BAD_REQUEST
,
'You can not proxy through the ftp'
);
}
my
$url
=
$request
->uri;
if
(
$url
->scheme ne
'ftp'
) {
my
$scheme
=
$url
->scheme;
return
HTTP::Response->new(
&HTTP::Status::RC_INTERNAL_SERVER_ERROR
,
"LWP::Protocol::ftp::request called for '$scheme'"
);
}
my
$method
=
$request
->method;
unless
(
$method
eq
'GET'
||
$method
eq
'HEAD'
||
$method
eq
'PUT'
) {
return
HTTP::Response->new(
&HTTP::Status::RC_BAD_REQUEST
,
'Library does not allow method '
.
"$method for 'ftp:' URLs"
);
}
if
(
$init_failed
) {
return
HTTP::Response->new(
&HTTP::Status::RC_INTERNAL_SERVER_ERROR
,
$init_failed
);
}
my
$host
=
$url
->host;
my
$port
=
$url
->port;
my
$user
=
$url
->user;
my
$password
=
$url
->password;
{
my
(
$u
,
$p
) =
$request
->authorization_basic;
if
(
defined
$u
) {
$user
=
$u
;
$password
=
$p
;
}
}
my
$account
=
$request
->header(
'Account'
);
my
$ftp
=
$self
->_connect(
$host
,
$port
,
$user
,
$account
,
$password
,
$timeout
);
return
$ftp
if
ref
(
$ftp
) eq
"HTTP::Response"
;
my
$response
= HTTP::Response->new(
&HTTP::Status::RC_OK
,
"OK"
);
$response
->header(
Server
=>
$ftp
->http_server);
$response
->header(
'Client-Request-Num'
=>
$ftp
->request_count);
$response
->request(
$request
);
my
@path
=
grep
{
length
}
$url
->path_segments;
my
$remote_file
=
pop
(
@path
);
$remote_file
=
''
unless
defined
$remote_file
;
my
$type
;
if
(
ref
$remote_file
) {
my
@params
;
(
$remote_file
,
@params
) =
@$remote_file
;
for
(
@params
) {
$type
=
$_
if
s/^type=//;
}
}
if
(
$type
&&
$type
eq
'a'
) {
$ftp
->ascii;
}
else
{
$ftp
->binary;
}
for
(
@path
) {
unless
(
$ftp
->cwd(
$_
)) {
return
HTTP::Response->new(
&HTTP::Status::RC_NOT_FOUND
,
"Can't chdir to $_"
);
}
}
if
(
$method
eq
'GET'
||
$method
eq
'HEAD'
) {
if
(
my
$mod_time
=
$ftp
->mdtm(
$remote_file
)) {
$response
->last_modified(
$mod_time
);
if
(
my
$ims
=
$request
->if_modified_since) {
if
(
$mod_time
<=
$ims
) {
$response
->code(
&HTTP::Status::RC_NOT_MODIFIED
);
$response
->message(
"Not modified"
);
return
$response
;
}
}
}
my
$max_size
=
undef
;
if
(
$request
->header(
'Range'
) &&
$ftp
->supported(
'REST'
))
{
my
$range_info
=
$request
->header(
'Range'
);
my
(
$start_byte
,
$end_byte
) =
$range_info
=~ /.*=\s*(\d+)-(\d+)?/;
if
(
defined
$start_byte
&& !
defined
$end_byte
) {
$ftp
->restart(
$start_byte
);
}
elsif
(
defined
$start_byte
&&
defined
$end_byte
&&
$start_byte
>= 0 &&
$end_byte
>=
$start_byte
) {
$ftp
->restart(
$start_byte
);
$max_size
=
$end_byte
-
$start_byte
;
}
else
{
return
HTTP::Response->new(
&HTTP::Status::RC_BAD_REQUEST
,
'Incorrect syntax for Range request'
);
}
}
elsif
(
$request
->header(
'Range'
) && !
$ftp
->supported(
'REST'
))
{
return
HTTP::Response->new(
&HTTP::Status::RC_NOT_IMPLEMENTED
,
"Server does not support resume."
);
}
my
$data
;
if
(
length
(
$remote_file
) and
$data
=
$ftp
->retr(
$remote_file
)) {
my
(
$type
,
@enc
) = LWP::MediaTypes::guess_media_type(
$remote_file
);
$response
->header(
'Content-Type'
,
$type
)
if
$type
;
for
(
@enc
) {
$response
->push_header(
'Content-Encoding'
,
$_
);
}
my
$mess
=
$ftp
->message;
if
(
$mess
=~ /\((\d+)\s+bytes\)/) {
$response
->header(
'Content-Length'
,
"$1"
);
}
if
(
$method
ne
'HEAD'
) {
$response
=
$self
->collect(
$arg
,
$response
,
sub
{
my
$content
=
''
;
my
$result
=
$data
->
read
(
$content
,
$size
);
if
(
defined
$max_size
)
{
my
$bytes_received
=
$data
->bytes_read();
if
(
$bytes_received
-
length
(
$content
) >
$max_size
)
{
$content
=
''
;
}
elsif
(
$bytes_received
>
$max_size
)
{
$content
=
substr
(
$content
, 0,
$max_size
- (
$bytes_received
-
length
(
$content
)) );
}
else
{
}
}
return
\
$content
;
} );
}
unless
(
$data
->abort) {
if
(
$method
ne
'HEAD'
||
$ftp
->code != 0) {
$response
->code(
&HTTP::Status::RC_INTERNAL_SERVER_ERROR
);
$response
->message(
"FTP close response: "
.
$ftp
->code .
" "
.
$ftp
->message);
}
}
}
elsif
(!
length
(
$remote_file
) || (
$ftp
->code >= 400 &&
$ftp
->code < 600 )) {
if
(
length
(
$remote_file
) && !
$ftp
->cwd(
$remote_file
)) {
return
HTTP::Response->new(
&HTTP::Status::RC_NOT_FOUND
,
"File '$remote_file' not found"
);
}
my
@lsl
=
$ftp
->dir;
my
@variants
=
(
[
'html'
, 0.60,
'text/html'
],
[
'dir'
, 1.00,
'text/ftp-dir-listing'
]
);
my
$prefer
= HTTP::Negotiate::choose(\
@variants
,
$request
);
my
$content
=
''
;
if
(!
defined
(
$prefer
)) {
return
HTTP::Response->new(
&HTTP::Status::RC_NOT_ACCEPTABLE
,
"Neither HTML nor directory listing wanted"
);
}
elsif
(
$prefer
eq
'html'
) {
$response
->header(
'Content-Type'
=>
'text/html'
);
$content
=
"<HEAD><TITLE>File Listing</TITLE>\n"
;
my
$base
=
$request
->uri->clone;
my
$path
=
$base
->path;
$base
->path(
"$path/"
)
unless
$path
=~ m|/$|;
$content
.=
qq(<BASE HREF="$base">\n</HEAD>\n)
;
$content
.=
"<BODY>\n<UL>\n"
;
for
(File::Listing::parse_dir(\
@lsl
,
'GMT'
)) {
my
(
$name
,
$type
,
$size
,
$mtime
,
$mode
) =
@$_
;
$content
.=
qq( <LI> <a href="$name">$name</a>)
;
$content
.=
" $size bytes"
if
$type
eq
'f'
;
$content
.=
"\n"
;
}
$content
.=
"</UL></body>\n"
;
}
else
{
$response
->header(
'Content-Type'
,
'text/ftp-dir-listing'
);
$content
=
join
(
"\n"
,
@lsl
,
''
);
}
$response
->header(
'Content-Length'
,
length
(
$content
));
if
(
$method
ne
'HEAD'
) {
$response
=
$self
->collect_once(
$arg
,
$response
,
$content
);
}
}
else
{
my
$res
= HTTP::Response->new(
&HTTP::Status::RC_BAD_REQUEST
,
"FTP return code "
.
$ftp
->code);
$res
->content_type(
"text/plain"
);
$res
->content(
$ftp
->message);
return
$res
;
}
}
elsif
(
$method
eq
'PUT'
) {
unless
(
length
(
$remote_file
)) {
return
HTTP::Response->new(
&HTTP::Status::RC_BAD_REQUEST
,
"Must have a file name to PUT to"
);
}
my
$data
;
if
(
$data
=
$ftp
->stor(
$remote_file
)) {
my
$content
=
$request
->content;
my
$bytes
= 0;
if
(
defined
$content
) {
if
(
ref
(
$content
) eq
'SCALAR'
) {
$bytes
=
$data
->
write
(
$$content
,
length
(
$$content
));
}
elsif
(
ref
(
$content
) eq
'CODE'
) {
my
(
$buf
,
$n
);
while
(
length
(
$buf
=
&$content
)) {
$n
=
$data
->
write
(
$buf
,
length
(
$buf
));
last
unless
$n
;
$bytes
+=
$n
;
}
}
elsif
(!
ref
(
$content
)) {
if
(
defined
$content
&&
length
(
$content
)) {
$bytes
=
$data
->
write
(
$content
,
length
(
$content
));
}
}
else
{
die
"Bad content"
;
}
}
$data
->
close
;
$response
->code(
&HTTP::Status::RC_CREATED
);
$response
->header(
'Content-Type'
,
'text/plain'
);
$response
->content(
"$bytes bytes stored as $remote_file on $host\n"
)
}
else
{
my
$res
= HTTP::Response->new(
&HTTP::Status::RC_BAD_REQUEST
,
"FTP return code "
.
$ftp
->code);
$res
->content_type(
"text/plain"
);
$res
->content(
$ftp
->message);
return
$res
;
}
}
else
{
return
HTTP::Response->new(
&HTTP::Status::RC_BAD_REQUEST
,
"Illegal method $method"
);
}
$response
;
}
1;