LWP::Protocol::sftp - adds support for SFTP uris to LWP package

LWP-Protocol-sftp documentation Contained in the LWP-Protocol-sftp distribution.

Index

Code Index:

NAME

Top

LWP::Protocol::sftp - adds support for SFTP uris to LWP package

SYNOPSIS

Top

  use LWP::Simple;
  my $content = get('sftp://me@myhost:29/home/me/foo/bar');

DESCRIPTION

Top

After this module is installed, LWP can be used to access remote file systems via SFTP.

This module is based on Net::SFTP::Foreign.

SEE ALSO

Top

LWP and Net::SFTP::Foreign documentation. ssh(1), sftp(1) manual pages. OpenSSH web site at http://www.openssh.org.

COPYRIGHT

Top

Copyright (C) 2005, 2006, 2008, 2009 by Salvador Fandiño (sfandino@yahoo.com).

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.10.0 or, at your option, any later version of Perl 5 you may have available.

LWP-Protocol-sftp documentation Contained in the LWP-Protocol-sftp distribution. 
package LWP::Protocol::sftp;

our $VERSION = '0.04';

# BEGIN { local $| =1; print "loading LWP::Protocol::sftp\n"; }


use strict;
use warnings;

use base qw(LWP::Protocol);
LWP::Protocol::implementor(sftp => __PACKAGE__);

require LWP::MediaTypes;
require HTTP::Request;
require HTTP::Response;
require HTTP::Status;
require HTTP::Date;

require URI::Escape;
require HTML::Entities;

use Net::SFTP::Foreign;
use Net::SFTP::Foreign::Constants qw(:flags :status);
use Fcntl qw(S_ISDIR);

use constant PUT_BLOCK_SIZE => 8192;

sub request
{
    my($self, $request, $proxy, $arg, $size) = @_;

    # print __PACKAGE__."->request($self, $request, $proxy, $arg, $size)\n";

    $size = 4096 unless defined $size and $size > 0;

    # check proxy
    defined $proxy and
	return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
				  'You can not proxy through the sftp subsystem');

    # check method
    my $method = $request->method;

    # check url
    my $url = $request->url;

    my $scheme = $url->scheme;
    if ($scheme ne 'sftp') {
	return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
				   "LWP::Protocol::sftp::request called for '$scheme'")
    }

    my $host = $url->host;
    my $port = $url->port;
    my $user = $url->user;
    my $password = $url->password;

    my $path  = $url->path;

    my $sftp = Net::SFTP::Foreign->new(host => $host,
                                       user => $user,
                                       port => $port,
                                       password => $password);
    if ($sftp->error) {
	return HTTP::Response->new(HTTP::Status::RC_SERVICE_UNAVAILABLE,
				   "unable to establish SSH connection to remote machine (".$sftp->error.")")
    }

    # handle GET and HEAD methods

    my $response = eval {

	if ($method eq 'GET' || $method eq 'HEAD') {

	    my $stat = $sftp->stat($path) or die "remote file stat failed";

	    # check if-modified-since
	    my $ims = $request->header('If-Modified-Since');
	    if (defined $ims) {
		my $time = HTTP::Date::str2time($ims);
		if (defined $time and $time >= $stat->mtime) {
		    return HTTP::Response->new(HTTP::Status::RC_NOT_MODIFIED,
					       "$method $path")
		}
	    }

	    # Ok, should be an OK response by now...
	    my $response = HTTP::Response->new(HTTP::Status::RC_OK);

	    # fill in response headers
	    $response->header('Last-Modified', HTTP::Date::time2str($stat->mtime));

	    if (S_ISDIR($stat->perm)) {         # If the path is a directory, process it
		# generate the HTML for directory
		my $ls = $sftp->ls($path, ordered => 1) or die "remote ls failed";

		# Make directory listing
		my $pathe = $path . '/';
		my @lines = map {
		    my $fn=$_->{filename};
		    my $furl = URI::Escape::uri_escape($fn);
		    if (S_ISDIR($_->{a}->perm)) {
			$fn .= '/';
			$furl .= '/';
		    }
		    my $desc = HTML::Entities::encode($fn);
		    qq{<li><a href="$furl">$desc</a>}
		} @$ls;

		# Ensure that the base URL is "/" terminated
		my $base = $url->clone;
		unless ($base->path =~ m|/$|) {
		    $base->path($base->path . "/");
		}
		my $html = join("\n",
				"<HTML>\n<HEAD>",
				"<TITLE>Directory $path</TITLE>",
				"<BASE HREF=\"$base\">",
				"</HEAD>\n<BODY>",
				"<H1>Directory listing of $path</H1>",
				"<UL>", @lines, "</UL>",
				"</BODY>\n</HTML>\n");

		$response->header('Content-Type',   'text/html');
		$response->header('Content-Length', length $html);
		$html = "" if $method eq "HEAD";

		return $self->collect_once($arg, $response, $html);
	    }

	    # path is a regular file
	    my $file_size = $stat->size;
	    $response->header('Content-Length', $file_size);
	    LWP::MediaTypes::guess_media_type($path, $response);

	    # read the file
	    if ($method ne "HEAD") {
		my $fh = $sftp->open($path) or die "remote file open failed";
		$response = $self->collect($arg, $response, sub {
                                               my $content = $sftp->read($fh, $size);
                                               defined $content ? \$content : \"" });
		$sftp->close($fh) or die "remote file read failed";
	    }
	    return $response;
	}

	# handle PUT method
	if ($method eq 'PUT') {
	    my $fh = $sftp->open($path, SSH2_FXF_WRITE | SSH2_FXF_CREAT | SSH2_FXF_TRUNC) or die "remote file open failed";

	    my $content = $request->content;
	    while (length $content) {
		my $bytes = $sftp->write($fh, $content) or die "remote file write failed";
                substr($content, 0, $bytes, '');
	    }

	    $sftp->close($fh) or die "remote file write failed";

	    return HTTP::Response->new(HTTP::Status::RC_OK);
	}

	# unsupported method
	return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
                                   "Library does not allow method $method for 'sftp:' URLs");
    };

    if ($@) {
	my $error = $sftp->error;
	return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
				   "SFTP error: $@ - $error");
    }
    return $response;
}

1;
__END__