view release on metacpan or  search on metacpan

local/lib/perl5/Net/SFTP/Foreign/Compat.pm  view on Meta::CPAN

package Net::SFTP::Foreign::Compat;

our $VERSION = '1.70_05';

use warnings;
use strict;
use Carp;

require Net::SFTP::Foreign;
require Net::SFTP::Foreign::Constants;
require Net::SFTP::Foreign::Attributes::Compat;

our @ISA = qw(Net::SFTP::Foreign);

my $supplant;

sub import {
    for my $arg (@_[1..$#_]) {
	if ($arg eq ':supplant') {
            # print STDERR "suplanting Net::SFTP...\n";
	    if (!$supplant) {
		$supplant = 1;

		@Net::SFTP::ISA = qw(Net::SFTP::Foreign::Compat);
		@Net::SFTP::Attributes::ISA = qw(Net::SFTP::Foreign::Attributes::Compat);
		@Net::SFTP::Constant::ISA = qw(Net::SFTP::Foreign::Constants);

		$INC{q(Net/SFTP.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)};
		$INC{q(Net/SFTP/Attributes.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)};
		$INC{q(Net/SFTP/Constants.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)};

	    }
	}
	else {
	    croak "invalid import tag '$arg'"
	}
    }
}

our %DEFAULTS = ( put => [best_effort => 1],
                  get => [best_effort => 1],
                  ls  => [],
                  new => [] );

BEGIN {
    my @forbidden = qw( setcwd cwd open opendir sftpread sftpwrite
                        seek tell eof write flush read getc lstat stat
                        fstat remove rmdir mkdir setstat fsetstat
                        close closedir readdir realpath readlink
                        rename symlink abort get_content join glob
                        rremove rget rput error die_on_error );

    for my $method (@forbidden) {
        my $super = "SUPER::$method";
        no strict 'refs';
        *{$method} = sub {
            unless (index((caller)[0], "Net::SFTP::Foreign") == 0) {
                croak "Method '$method' is not available from " . __PACKAGE__
                    . ", use the real Net::SFTP::Foreign if you want it!";
            }
            shift->$super(@_);
        };
    }
}

sub new {
    my ($class, $host, %opts) = @_;

    my $warn;
    if (exists $opts{warn}) {
	$warn = delete($opts{warn}) || sub {};
    }
    else {
	$warn = sub { warn(CORE::join '', @_, "\n") };
    }

    my $sftp = $class->SUPER::new($host, @{$DEFAULTS{new}}, %opts);

    $sftp->{_compat_warn} = $warn;

    return $sftp;

}

sub _warn {
    my $sftp = shift;
    if (my $w = $sftp->{_compat_warn}) {
	$w->(@_);
    }
}

sub _warn_error {
    my $sftp = shift;
    if (my $e = $sftp->SUPER::error) {
	$sftp->_warn($e);
    }
}

sub status {
    my $status = shift->SUPER::status;
    return wantarray ? ($status + 0, "$status") : $status + 0;
}

sub get {
    croak '$Usage: $sftp->get($local, $remote, $cb)' if @_ < 2 or @_ > 4;
    my ($sftp, $remote, $local, $cb) = @_;

    my $save = defined(wantarray);
    my @content;
    my @cb;
    if (defined $cb or $save) {
        @cb = ( callback => sub {
                    my ($sftp, $data, $off, $size) = @_;
                    $cb->($sftp, $data, $off, $size) if $cb;
                    push @content, $data if $save
                });
    }