App-SimpleBackuper

 view release on metacpan or  search on metacpan

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

sub disconnect {
    my $sftp = shift;
    my $pid = delete $sftp->{pid};

    $debug and $debug & 4 and _debug("$sftp->disconnect called (ssh pid: ".($pid||'').")");

    local $sftp->{_autodie};
    $sftp->_conn_lost;

    if (defined $pid) {
        close $sftp->{ssh_out} if (defined $sftp->{ssh_out} and not $sftp->{_ssh_out_is_not_dupped});
        close $sftp->{ssh_in} if defined $sftp->{ssh_in};
        if ($windows) {
	    kill KILL => $pid
                and waitpid($pid, 0);
            $debug and $debug & 4 and _debug "process $pid reaped";
        }
        else {
	    my $dirty = ( defined $sftp->{_dirty_cleanup}
                          ? $sftp->{_dirty_cleanup}
                          : $dirty_cleanup );

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

	    return @ret;
	}
	else {
	    my $ret = $sftp->$method(@_);
	    $sftp->_set_errno unless defined $ret;
	    return $ret;
	}
    }
};

my $gen_not_supported = sub {
    sub {
	$! = Errno::ENOTSUP();
	undef
    }
};

sub TIEHANDLE { return shift }

# sub UNTIE {}

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

sub _cache { *{shift()}{ARRAY}[4] }

*CLOSEDIR = $gen_proxy_method->('closedir');
*READDIR = $gen_proxy_method->('_readdir');

sub OPENDIR {
    shift->CLOSEDIR;
    undef;
}

*REWINDDIR = $gen_not_supported->();
*TELLDIR = $gen_not_supported->();
*SEEKDIR = $gen_not_supported->();

sub DESTROY {
    local ($@, $!, $?);
    my $self = shift;
    my $sftp = $self->_sftp;

    $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")");

    if ($self->_check and $sftp) {
        local $sftp->{_autodie};

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

    my ($backend, $sftp, $opts) = @_;

    my $transport = delete $opts->{transport};

    if (defined $transport) {
	if (ref $transport eq 'ARRAY') {
            @{$sftp}{qw(ssh_in ssh_out pid)} = @$transport;
        }
        else {
            $sftp->{ssh_in} = $sftp->{ssh_out} = $transport;
            $sftp->{_ssh_out_is_not_dupped} = 1;
        }
    }
    else {
        my $user = delete $opts->{user};
        my $pass = delete $opts->{passphrase};
        my $ask_for_username_at_login;
	my $pass_is_passphrase;
        my $password_prompt;
        if (defined $pass) {
            $pass_is_passphrase = 1;

local/lib/perl5/Test/Trap/Builder.pm  view on Meta::CPAN

  }

  sub Exception {
    my $self = shift;
    $self->ExceptionFunction->(@_);
  }
}

# Utility functions and methods on the builder class/object:

sub _carpnot_for (@) {
  my %seen = ( __PACKAGE__, 1 );
  my @pkg = grep { !$seen{$_}++ } @_;
  return @pkg;
}

sub new { $builder }

sub trap {
  my $self = shift;
  my ($trapper, $glob, $layers, $code) = @_;

local/lib/perl5/Test/Trap/Builder.pm  view on Meta::CPAN

    for (reverse @{$trap->Prop->{teardown}}) {
    TEST_TRAP_BUILDER_INTERNAL_EXCEPTION: {
	eval { $_->(); 1} or $trap->Exception("Rethrowing teardown exception: $@");
      }
    }
    last if @{$trap->Prop->{exception}||[]};
    ${*$glob} = $trap;
    my @return = eval { @{$trap->return} };
    return $wantarray ? @return : $return[0];
  }
  local( GOT_CARP_NOT ? @CARP_NOT : @ISA ) = _carpnot_for $trapper, scalar caller;
  croak join"\n", @{$trap->Prop->{exception}};
}

BEGIN { # The register (private) functions:
  my %register;
  sub _register {
    my ($type, $package, $name, $val) = @_;
    $register{$type}{$package}{$name} = $val;
  }
  sub _register_packages {

local/lib/perl5/Test/Trap/Builder.pm  view on Meta::CPAN

      my $strategy = $self->capture_strategy($_);
      return $strategy if $strategy;
    }
    croak "No capture strategy found for " . dump(@strategy);
  }
}

sub layer_implementation {
  my $self = shift;
  # Directly querying layer implementation, we should know what we're doing:
  local( GOT_CARP_NOT ? @CARP_NOT : @ISA ) = _carpnot_for caller;
  my $trapper = shift;
  my @r;
  for (@_) {
    if ( length ref and eval { exists &$_ } ) {
      push @r, $_;
      next;
    }
    my ($name, $arg) =
      /^ ( [^\(]+ )      # layer name: anything but '('
         (?:             # begin optional group