mirror of https://github.com/pkolano/shift.git
7338 lines
418 KiB
Perl
Executable File
7338 lines
418 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
#
|
|
# Copyright (C) 2012-2021 United States Government as represented by the
|
|
# Administrator of the National Aeronautics and Space Administration
|
|
# (NASA). All Rights Reserved.
|
|
#
|
|
# This software is distributed under the NASA Open Source Agreement
|
|
# (NOSA), version 1.3. The NOSA has been approved by the Open Source
|
|
# Initiative. See http://www.opensource.org/licenses/nasa1.3.php
|
|
# for the complete NOSA document.
|
|
#
|
|
# THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY OF ANY
|
|
# KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT
|
|
# LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO
|
|
# SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR
|
|
# A PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT
|
|
# THE SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT
|
|
# DOCUMENTATION, IF PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS
|
|
# AGREEMENT DOES NOT, IN ANY MANNER, CONSTITUTE AN ENDORSEMENT BY
|
|
# GOVERNMENT AGENCY OR ANY PRIOR RECIPIENT OF ANY RESULTS, RESULTING
|
|
# DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR ANY OTHER APPLICATIONS RESULTING
|
|
# FROM USE OF THE SUBJECT SOFTWARE. FURTHER, GOVERNMENT AGENCY DISCLAIMS
|
|
# ALL WARRANTIES AND LIABILITIES REGARDING THIRD-PARTY SOFTWARE, IF
|
|
# PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES IT "AS IS".
|
|
#
|
|
# RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST THE UNITED STATES
|
|
# GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY PRIOR
|
|
# RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN ANY
|
|
# LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE,
|
|
# INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM,
|
|
# RECIPIENT'S USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND
|
|
# HOLD HARMLESS THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND
|
|
# SUBCONTRACTORS, AS WELL AS ANY PRIOR RECIPIENT, TO THE EXTENT PERMITTED
|
|
# BY LAW. RECIPIENT'S SOLE REMEDY FOR ANY SUCH MATTER SHALL BE THE
|
|
# IMMEDIATE, UNILATERAL TERMINATION OF THIS AGREEMENT.
|
|
#
|
|
|
|
# This program is the Mesh Client and provides a simplified user
|
|
# interface for invoking remote Mesh commands. This program is also
|
|
# the Shift client for automated file transfers, which can be used with
|
|
# or without Mesh. To use Shift with Mesh, comment out all "=for mesh"
|
|
# and "=cut mesh" lines. The name of this program must start with
|
|
# "shift" when used without Mesh and must not start with "shift" when
|
|
# used with Mesh.
|
|
#
|
|
#
|
|
# Code Assumptions
|
|
#
|
|
# * A transfer may run as any user, including root
|
|
# * Never trust file names and pass them through a shell command line
|
|
# * Never leave permissions open to anyone other than the user until done
|
|
# * A transfer's metadata is writable by users and may be accessed as root
|
|
# * Never use insecure perl modules like Storable with user-writable data
|
|
# * A transfer may run locally, over the LAN, or over the WAN
|
|
# * All cases must be supported equally
|
|
# * A transfer may run on any operating system of any version
|
|
# * Never assume the same OS primitives exist everywhere
|
|
# * A transfer may run with any software installed of any version
|
|
# * Never assume the existence of anything beyond perl core and ssh
|
|
# * A transfer may have any number of files
|
|
# * Never assume the list of files can fit in memory
|
|
# * A transfer may take any amount of time to complete
|
|
# * Must periodically reassess things like systems and mount points
|
|
# * A transfer may be interrupted at any time at any point in its processing
|
|
# * Must be resilient against failures at every point in file processing
|
|
# * A transfer may run on a resource that may be taken away at any time
|
|
# * Must be able to recover and utilize alternative resources
|
|
#
|
|
#
|
|
# Code flow
|
|
#
|
|
# * shift_() (shiftc)
|
|
# * Begin all transfer processing
|
|
# * Parse options
|
|
# * Forward transfer monitoring and management options to a manager invocation
|
|
# * --history, --last-sum, --monitor (when not with --wait),
|
|
# --plot, --stats, --status, --stop
|
|
# * Check basic sanity of options
|
|
# * Process command-line or piped in arguments via shift_args()
|
|
#
|
|
# * shift_args() (shiftc)
|
|
# * Check sanity of src/dst files/directories
|
|
# * Existence or non-existence of files/directories, writability
|
|
# of dst
|
|
# * Normalize src/dst files/directories
|
|
# * Dereference links, expand wildcards, resolve hostnames
|
|
# * Create parent directories when specified or when --extract-tar
|
|
# * Record initial set of operations to file and return
|
|
# * shift_() again (shiftc)
|
|
# * Initialize transfer by invocation of "shift-mgr --put"
|
|
# * Pass options and arguments over stdout
|
|
# * put() (shift-mgr)
|
|
# * Find next available transfer id for the user
|
|
# * Initialize metadata for transfer (options and initial operations)
|
|
# * Return id over stdout back to client
|
|
# * shift_() again (shiftc)
|
|
# * Print id to stdout for user to reference
|
|
# * Spawn child process that enters shift_loop()
|
|
# * When --wait specified, wait for child to exit (while monitoring when
|
|
# --monitor specified)
|
|
# * shift_loop() (shiftc)
|
|
# * Detach completely from parent
|
|
# * Collect network parameters (shift_networks()) and mounts (shift_mounts())
|
|
# * Loop until told to stop
|
|
# * Collect induced load (shift_load()) and network latency
|
|
# (shift_latency())
|
|
# * Request new batch of operations to process while reporting results
|
|
# of last batch by invocation of "shift-mgr --get --put"
|
|
# * There will be nothing to report on the first invocation
|
|
# * All interaction is over local or remote stdin/stdout pipes
|
|
# from/to manager
|
|
# * put() (shift-mgr)
|
|
# * Record results of batch of operations
|
|
# * On success, operations enter the next stage of processing
|
|
# * find to mkdir/cp/ln, cp to sum, sum to cksum, cksum/mkdir/ln
|
|
# to chattr, chattr to done
|
|
# * On error, operations reenter same state with retry count incremented
|
|
# or error when retries exhausted
|
|
# * Partial checksum mismatch will become cp with smaller subset of file
|
|
# * Update metadata counts and other items such as silent corruption
|
|
# db and cache tracking
|
|
# * get() (shift-mgr)
|
|
# * Direct client to sleep for some purposes
|
|
# * Exponential backoff on previous warnings
|
|
# * Throttling to get resource utilization down to specified average
|
|
# * File likely still in cache on host (optional when configured and
|
|
# no fadvise available)
|
|
# * Gather transfer options that may be global or changed from
|
|
# initialization
|
|
# * Traverse operation logs to find next set of operations for client
|
|
# * May include previously sent operations when a host/process
|
|
# failure detected
|
|
# * Map local src/dst files or remote src/dst files from previous stage
|
|
# location to client location via map_local() and/or map_remote()
|
|
# * map_local() (shift-mgr)
|
|
# * 3 mount db files used to allow file system equivalence to be
|
|
# detected efficiently
|
|
# * A global database containing if mount_db is configured
|
|
# * A persistent per user database with mount information gathered
|
|
# and sent during transfer initialization
|
|
# * Used to make automatic parallelization decisions in remote
|
|
# cluster environments
|
|
# * A per transfer database that stores mount information that should
|
|
# not be used for other transfers
|
|
# * PBS-controlled hosts where the user only has temporary access
|
|
# * Equivalence requires the type, server, and remote mount point be
|
|
# identical
|
|
# * Paths are mapped from original host/path to mount point to local host/path
|
|
# * map_remote() (shift-mgr)
|
|
# * Operates mostly like map_local()
|
|
# * Maps remote file represented by host1:path1 to host2:path2
|
|
# * The original path1 is mapped to a server mount point
|
|
# * The set of hosts that have access to that mount point are determined
|
|
# * The new host2 is chosen by a callout to an external selection
|
|
# hook from among the derived set of hosts
|
|
# * A host will not be selected n times as a remote src/dst until
|
|
# every other host has been selected n-1 times
|
|
# * The server mount point is used to map path1 to path2 on host2
|
|
# * get() again (shift-mgr)
|
|
# * Direct client to stop if transfer done or cannot map operations
|
|
# * Determine if additional parallelization is needed to satisfy --clients
|
|
# or --hosts
|
|
# * For hosts, use another callout to external selection hook to
|
|
# find least loaded
|
|
# * Direct client to spawn itself either locally or on chosen system(s)
|
|
# * Return to client
|
|
# * shift_loop() (shiftc)
|
|
# * Continue loop
|
|
# * Spawn/stop/sleep as directed
|
|
# * On stop, remove crontab and exit
|
|
# * Sort file operations into buckets via tranport()
|
|
# * Each type of operation put into separate bucket for fewest
|
|
# local invocations
|
|
# * Each operation involving remote host put into host bucket for
|
|
# fewest remote invocations
|
|
# * On first iteration, install crontab to respawn itself on
|
|
# host/process failure
|
|
# * Call transport(`end')
|
|
# * transport() (shiftc)
|
|
# * transport(`end') begins actual processing of a batch of files
|
|
# * Individual transport_*() functions invoked for different operations
|
|
# and different hosts
|
|
# * find, chattr, tar, dmf, fadvise, and individual transports
|
|
# (built-in, mcp, rsync, bbftp)
|
|
# * These may invoke shift-aux during remote operations and/or shift-bin
|
|
# locally
|
|
# * Similar verify_*() functions for sums and checksums via built-in or msum
|
|
# * Results stored in file with control back to next iteration of shift_loop()
|
|
|
|
# need perl 5.8.5 as glob is broken in earlier versions
|
|
require 5.008_005;
|
|
use strict;
|
|
use Cwd qw(abs_path);
|
|
use Data::Dumper;
|
|
use Fcntl qw(:flock :mode);
|
|
use File::Basename;
|
|
use File::Find;
|
|
if ($^V lt v5.15.5) {
|
|
eval 'use File::Glob';
|
|
} else {
|
|
eval 'use File::Glob qw(:bsd_glob)';
|
|
}
|
|
use File::Path;
|
|
use File::Spec;
|
|
use File::Spec::Unix;
|
|
use File::Temp qw(tempdir tempfile);
|
|
use Getopt::Long qw(:config bundling no_auto_abbrev no_ignore_case require_order);
|
|
use IO::File;
|
|
use IO::Handle;
|
|
use IO::Socket::INET;
|
|
use IO::Socket::UNIX;
|
|
# use embedded IPC::Open3 since versions prior to perl 5.14.0 are buggy
|
|
require IPC::Open3;
|
|
use List::Util qw(first max min sum);
|
|
use MIME::Base64;
|
|
require Net::NTPTime;
|
|
use POSIX;
|
|
use Socket qw(IPPROTO_TCP TCP_NODELAY);
|
|
use Storable qw(nfreeze thaw);
|
|
use Symbol qw(gensym);
|
|
use Sys::Hostname;
|
|
use Text::ParseWords;
|
|
|
|
use constant SFTP_APPEND => 0x04;
|
|
use constant SFTP_CREAT => 0x08;
|
|
use constant SFTP_READ => 0x01;
|
|
use constant SFTP_TRUNC => 0x10;
|
|
use constant SFTP_WRITE => 0x02;
|
|
use constant SFTP_EXCL => 0x20;
|
|
|
|
our $VERSION = 8.17;
|
|
|
|
$Data::Dumper::Indent = 0;
|
|
$Data::Dumper::Purity = 1;
|
|
|
|
# do not die when receiving sigpipe
|
|
$SIG{PIPE} = 'IGNORE';
|
|
# add some basic paths
|
|
$ENV{PATH} .= ($ENV{PATH} ? ":" : "") .
|
|
"/bin:/usr/bin:/usr/local/bin:/sbin:/usr/sbin:/usr/local/sbin";
|
|
# disable graphical passphrase prompts
|
|
delete $ENV{SSH_ASKPASS};
|
|
delete $ENV{DISPLAY};
|
|
|
|
my %perl;
|
|
$perl{ssl} = eval 'use IO::Socket::SSL; 1';
|
|
# need threads and version of Thread::Queue/Semaphore from perl >= 5.10.1
|
|
$perl{threads} = eval 'require 5.010_001; use threads; use Thread::Queue; use Thread::Semaphore; 1';
|
|
|
|
#########################
|
|
#### default options ####
|
|
#########################
|
|
my %opts = (
|
|
abs0 => abs_path($0),
|
|
argv => [$0, @ARGV],
|
|
base0 => basename($0),
|
|
caux => "shift-aux",
|
|
cmgr => "shift-mgr",
|
|
encode => "latin1",
|
|
p => "none",
|
|
mgr => "none",
|
|
tmp_d => File::Spec->tmpdir,
|
|
);
|
|
|
|
###############################
|
|
#### site-specific options ####
|
|
###############################
|
|
|
|
=for mesh
|
|
|
|
$opts{a} = "MESHCONF_map_host";
|
|
$opts{ah} = "MESHCONF_map_key";
|
|
$opts{p} = "MESHCONF_mp_host";
|
|
$opts{ph} = "MESHCONF_mp_key";
|
|
|
|
#######################
|
|
#### parse options ####
|
|
#######################
|
|
exit 1 if (!GetOptions(\%opts,
|
|
"a=s", "b", "d=i", "g", "h", "i=s", "I=s", "keygen-user=s", "p=s", "r=s",
|
|
"s=s", "u=s", "v", "V=i",
|
|
"o=s" => sub {
|
|
my ($key, $val) = split(/=|\s+/, $_[1], 2);
|
|
$val = shift @ARGV if (!defined $val);
|
|
$opts{$_[0] . lc($key)} = " $val";
|
|
}
|
|
));
|
|
|
|
# may be escaped from shift
|
|
$opts{p} = unescape($opts{p});
|
|
|
|
################################
|
|
#### define aliases for vfs ####
|
|
################################
|
|
if ($opts{r} || $opts{s}) {
|
|
foreach (qw(a d i I p u V)) {
|
|
$opts{abs0} .= " -$_ '$opts{$_}'" if ($opts{$_});
|
|
}
|
|
my @ng_cmds = qw(cat cd chgrp chmod chown cmp cp df diff du file ln ls mkdir
|
|
mv pwd rm rmdir test touch);
|
|
my @cmds = qw(grep head less more tail tee wc);
|
|
#TODO: find, more/less without whole file
|
|
#TODO: can't use noglob alias with piped input (set -f destroys input)
|
|
#TODO: support csh
|
|
if ($opts{r} eq 'bash') {
|
|
#TODO: could do redirection by getting orig cmd, rewriting < to
|
|
# cat, rewriting > to tee, then rexec'ing (only if history 1 works)
|
|
print qq|unset -f mc_cd ; |;
|
|
print qq|unset -f mc_ng ; |;
|
|
print qq|unalias $_ ; | foreach (@cmds, @ng_cmds);
|
|
print q|export COMP_WORDBREAKS=${COMP_WORDBREAKS}: ; |;
|
|
print qq|complete -r $_ ; | foreach (@cmds, @ng_cmds);
|
|
# terminate vfs socket process
|
|
print open3_get([-1, undef], "$opts{abs0} -b -p none exit");
|
|
} elsif ($opts{s} eq 'bash') {
|
|
print qq|mc_cd () { eval `$opts{abs0} cd "\$@"`; RC=\$?; set +f; return \$RC ; } ; |;
|
|
print qq|mc_ng () { $opts{abs0} "\$@"; RC=\$?; set +f; return \$RC ; } ; |;
|
|
# aliases where glob can be safely disabled with set -f
|
|
print qq|alias $_='set -f; mc_ng $_$opts{"o$_"}' ; | foreach (@ng_cmds);
|
|
# aliases where glob cannot be disabled as set -f destroys stdin
|
|
print qq|alias $_='$opts{abs0} $_$opts{"o$_"}' ; | foreach (@cmds);
|
|
print qq|alias cd='set -f; mc_cd' ; |;
|
|
# need to remove : to allow completion of scp-style paths to work
|
|
print q|export COMP_WORDBREAKS=${COMP_WORDBREAKS/\:/} ; |;
|
|
print qq|complete -o default -o filenames -o nospace -C '$opts{abs0} complete' $_ ; |
|
|
foreach (@cmds, @ng_cmds);
|
|
}
|
|
exit;
|
|
}
|
|
|
|
######################
|
|
#### set defaults ####
|
|
######################
|
|
if (!defined $opts{d}) {
|
|
$opts{d} = "MESHCONF_key_days";
|
|
}
|
|
$opts{I} = glob("~/.ssh") if (!$opts{I});
|
|
$opts{i} = $opts{I} . "/meshid" if (!$opts{i});
|
|
$opts{V} = 2 if (!$opts{V});
|
|
if ($opts{'keygen-user'}) {
|
|
# format for inclusion on mesh-keygen command line
|
|
$opts{'keygen-user'} = " --user=" . $opts{'keygen-user'};
|
|
}
|
|
$opts{ssh_l} = "-l $opts{u}" if ($opts{u});
|
|
# skip login messages when not in verbose mode
|
|
$opts{ssh_q} = '-q' if (!$opts{v});
|
|
|
|
###################
|
|
#### show help ####
|
|
###################
|
|
print STDERR "Using version $VERSION\n" if ($opts{v});
|
|
$opts{h} = 1 if (scalar(@ARGV) == 0 && !$opts{g});
|
|
if ($opts{h}) {
|
|
print "Usage: $opts{base0} [OPTION]... COMMAND\n";
|
|
print "\n";
|
|
print "Execute COMMAND as if proxied hosts were directly connected.\n";
|
|
print "\n";
|
|
print "Options (defaults in brackets):\n";
|
|
print " -a MAP set Mesh Authentication Point to MAP [$opts{a}]\n";
|
|
print " -b batch mode (disable key renewal)\n";
|
|
print " -g force generation of new key\n";
|
|
print " -h help\n";
|
|
print " -i IDENTITY set long term identity file to IDENTITY [$opts{i}]\n";
|
|
print " -I DIR locate identities and keys in DIR [$opts{I}]\n";
|
|
print " -oCMD OPTS set alias options for CMD to OPTS\n";
|
|
print " -p MP set Mesh Proxy to MP [$opts{p}]\n";
|
|
print " -r SHELL remove aliases for SHELL shell\n";
|
|
print " -s SHELL set aliases for SHELL shell\n";
|
|
print " -u USER set remote user to USER [" . getpwuid($<) . "]\n";
|
|
print " -v verbose mode\n";
|
|
print " -V MINUTES set cert validity interval to MINUTES [$opts{V}]\n";
|
|
exit;
|
|
}
|
|
|
|
###############################
|
|
#### execute local command ####
|
|
###############################
|
|
if (scalar(@ARGV) > 0) {
|
|
# ignore command if key generation forced and no arguments given
|
|
my $cmd = shift @ARGV;
|
|
if ($cmd !~ /(?:^|\W)(?:bbftp|mesh-keykill|mesh-keytime|rsync|scp|sftp|shiftc?|ssh|ssh-balance)$/ && $< != 0) {
|
|
# resolve all symlinks to support links to host:/path in VFS
|
|
# (exclude rm so linked targets are not removed)
|
|
# (exclude root to prevent unintended exposure/modification)
|
|
require File::Spec::Link;
|
|
@ARGV = map {File::Spec::Link->resolve_all($_)} @ARGV;
|
|
}
|
|
my $argv_hostpath = 0;
|
|
$argv_hostpath ||= hostpath($_) foreach (@ARGV);
|
|
if ($cmd =~ /(?:^|\W)pwd$/) {
|
|
print "$ENV{PWD}\n";
|
|
exit;
|
|
} elsif ($cmd !~ /(?:^|\W)(?:bbftp|mesh-keykill|mesh-keytime|rsync|scp|sftp|ssh|ssh-balance)$/ &&
|
|
!$argv_hostpath && (!hostpath($ENV{PWD}) ||
|
|
grep(!/^[-\/]/, @ARGV) == 0 || $cmd =~ /(?:^|\W)complete$/ &&
|
|
$ARGV[1] =~ /^\//)) {
|
|
if ($cmd =~ /^(?:exit|shiftc?)$/) {
|
|
# do nothing for now
|
|
} elsif ($cmd =~ /(?:^|\W)(?:ls|du)$/ && hostpath($ENV{PWD}) &&
|
|
grep(/^\//, @ARGV) == 0) {
|
|
# add implicit current directory to remote ls/du
|
|
push(@ARGV, $ENV{PWD});
|
|
} else {
|
|
exit if ($cmd =~ /(?:^|\W)complete$/);
|
|
unshift(@ARGV, $cmd);
|
|
unshift(@ARGV, qw(echo builtin)) if ($cmd =~ /(?:^|\W)cd$/);
|
|
@ARGV = map {glob($_)} @ARGV;
|
|
exit WEXITSTATUS(system(@ARGV));
|
|
}
|
|
} elsif ($cmd =~ /(?:^|\W)complete$/) {
|
|
@ARGV = ($ARGV[1]);
|
|
}
|
|
# add previously shifted command back into argument list
|
|
unshift(@ARGV, $cmd);
|
|
}
|
|
|
|
##################################
|
|
#### check identity directory ####
|
|
##################################
|
|
if (! -d $opts{I}) {
|
|
print STDERR "Creating $opts{I}\n" if ($opts{v});
|
|
mkdir $opts{I} or die "Unable to create $opts{I}\n";
|
|
chmod(0700, $opts{I});
|
|
}
|
|
|
|
# write is always required for temp certs
|
|
my $fh = File::Temp->new(TEMPLATE => ".meshXXXXXXXX", DIR => $opts{I});
|
|
die "Unable to write to identity directory $opts{I}\n" if (!$fh);
|
|
close $fh;
|
|
unlink $fh->filename;
|
|
|
|
my $mesh_id_hash = key_validate($opts{i});
|
|
|
|
#########################
|
|
#### check host keys ####
|
|
#########################
|
|
print STDERR "Checking initialization of host keys\n" if ($opts{v});
|
|
for my $h (qw(a p)) {
|
|
my $hh = $h . "h";
|
|
open3_get([-1, -1, -1], "ssh-keygen -F $opts{$h}");
|
|
if ($?) {
|
|
print STDERR "Populating host key for $opts{$h}\n" if ($opts{v});
|
|
if (open(KH, '>>', glob("~/.ssh/known_hosts"))) {
|
|
print KH "$opts{$h} $opts{$hh}\n";
|
|
close KH;
|
|
} else {
|
|
die "Unable to populate host keys\n";
|
|
}
|
|
last if ($opts{p} eq $opts{a});
|
|
}
|
|
}
|
|
|
|
###########################
|
|
#### find existing key ####
|
|
###########################
|
|
my $mesh_key;
|
|
# ignore existing keys if key generation forced or identity invalid
|
|
$mesh_key = key_find() if (!$opts{g} && $mesh_id_hash);
|
|
|
|
=cut mesh
|
|
|
|
###############################
|
|
#### configure ssh command ####
|
|
###############################
|
|
# ssh command to reach target (possibly via MP)
|
|
$opts{ssh} = "ssh $opts{ssh_q} -ax -oBatchMode=yes $opts{ssh_l}";
|
|
$opts{ssh} .= " -oCertificateString=X -oIdentityHash=X" if ($opts{p} ne 'none');
|
|
# create template that allows ssh options from manager to be spliced in
|
|
$opts{sshTMPL} = $opts{ssh} . " OPTS_SSH";
|
|
# ssh command to reach MP
|
|
if ($opts{p} ne 'none') {
|
|
# X will be replaced in key_ssh()
|
|
$opts{sshmp} = "ssh -oIdentityFile=X $opts{ssh_q} -ax -oPKCS11Provider=none -oBatchMode=yes $opts{ssh_l} $opts{p}";
|
|
$opts{sshmpTMPL} = $opts{sshmp};
|
|
$opts{sshmpTMPL} =~ s/^(ssh)/$1 OPTS_SSH/;
|
|
$opts{ssh} = $opts{sshmp} . " " . $opts{ssh};
|
|
}
|
|
|
|
=for mesh
|
|
|
|
#############################
|
|
#### MAP access required ####
|
|
#############################
|
|
my ($map_cert, $map_hash);
|
|
if ($opts{p} ne 'none' &&
|
|
(!$mesh_key || $opts{g} || $ARGV[0] =~ /(?:^|\W)mesh-keykill$/)) {
|
|
# check time drift
|
|
$opts{drift} = 0;
|
|
print STDERR "Checking clock drift\n" if ($opts{v});
|
|
my $ntp;
|
|
eval {
|
|
local $SIG{ALRM} = sub {die};
|
|
alarm 2;
|
|
$ntp = Net::NTPTime::get_unix_time();
|
|
};
|
|
alarm 0;
|
|
if ($ntp) {
|
|
$opts{drift} = time - $ntp;
|
|
print STDERR "Drift of $opts{drift}s detected\n"
|
|
if ($opts{drift} && $opts{v});
|
|
}
|
|
|
|
# this step is not needed when MP and MAP are combined
|
|
if ($opts{p} ne $opts{a} && !key_validate("$opts{i}_ca")) {
|
|
die "Interaction required but batch mode enabled\n" if ($opts{b});
|
|
print STDERR "Initializing identity on $opts{a} (provide login information)\n";
|
|
print open3_get(["$opts{i}_ca.pub", undef],
|
|
"ssh $opts{ssh_q} -x -oPubkeyAuthentication=no $opts{ssh_l} $opts{a} mesh-keygen --init-add");
|
|
die "Unable to initialize identity\n" if ($?);
|
|
print STDERR "Storing initialization status in $opts{i}_ca\n" if ($opts{v});
|
|
key_comment("$opts{i}_ca", "meshinit=1");
|
|
}
|
|
|
|
if ($opts{p} ne $opts{a}) {
|
|
# generate tmp cert used by MP to auth to MAP
|
|
print STDERR "Generating temporary cert for $opts{a}\n" if ($opts{v});
|
|
$map_cert = key_cert("$opts{i}_ca");
|
|
}
|
|
|
|
$map_hash = $mesh_id_hash;
|
|
if (!$mesh_id_hash) {
|
|
my $out = open3_get([-1, undef], "ssh-keygen -l -f $opts{i}");
|
|
$map_hash = (split/\s+/, $out)[1];
|
|
# convert hash to path-safe variant
|
|
$map_hash =~ s/\+/-/g;
|
|
$map_hash =~ s/\//_/g;
|
|
$map_hash =~ s/^SHA256://;
|
|
}
|
|
}
|
|
|
|
######################
|
|
#### generate key ####
|
|
######################
|
|
if ($opts{p} ne 'none' && (!$mesh_key || $opts{g})) {
|
|
die "Interaction required but batch mode enabled\n" if ($opts{b});
|
|
$mesh_key = "$opts{I}/meshkey." . (time + $opts{drift} + $opts{d} * 24 * 60 * 60);
|
|
print STDERR "Generating key on $opts{p} (provide login information)\n";
|
|
print open3_get([$opts{i}, $mesh_key, undef],
|
|
"ssh $opts{ssh_q} -ax -oPubkeyAuthentication=no $opts{ssh_l} $opts{p} mesh-keygen" .
|
|
($map_cert ? " --cert=$map_cert" : "") .
|
|
" --hash=$map_hash" . $opts{'keygen-user'});
|
|
if ($? || -z $mesh_key) {
|
|
unlink $mesh_key;
|
|
die "Unable to generate key\n";
|
|
}
|
|
chmod(0600, $mesh_key);
|
|
print STDERR "Generating public key for private key $mesh_key\n" if ($opts{v});
|
|
print open3_get([-1, "$mesh_key.pub", undef], "ssh-keygen -y -f $mesh_key");
|
|
if (!$mesh_id_hash) {
|
|
$mesh_id_hash = $map_hash;
|
|
print STDERR "Storing initialization status in $opts{i}\n" if ($opts{v});
|
|
key_comment($opts{i}, "meshinit=1");
|
|
}
|
|
|
|
#######################
|
|
#### update client ####
|
|
#######################
|
|
if (!$opts{'keygen-user'}) {
|
|
# do not update client when key generated for different user
|
|
key_ssh();
|
|
my $mcv = open3_get([-1, undef, -1],
|
|
"$opts{sshmp} mesh-update --file=mc --version");
|
|
$mcv =~ s/\s+$//;
|
|
print STDERR "Latest client version is $mcv\n" if ($opts{v});
|
|
if ($mcv > $VERSION) {
|
|
print STDERR "A newer version of the client is available ($mcv vs. $VERSION)\n";
|
|
print STDERR "...do you wish to replace the current version? (y/n) ";
|
|
my $line = <STDIN>;
|
|
$line =~ s/^\s+|\s+$//g;
|
|
if ($line =~ /^y(es)?$/i) {
|
|
print open3_get([-1, $opts{abs0}, undef],
|
|
"$opts{sshmp} mesh-update --file=mc");
|
|
if ($?) {
|
|
print STDERR "Client update failed (ensure $opts{abs0} is writable)\n";
|
|
} else {
|
|
# reexec with original arguments to take advantage of fixes
|
|
exec @{$opts{argv}} if (!$opts{g});
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# ignore command if key generation forced and no arguments given
|
|
exit if ($opts{g} && scalar(@ARGV) == 0);
|
|
}
|
|
|
|
##################
|
|
#### kill key ####
|
|
##################
|
|
if ($ARGV[0] =~ /(?:^|\W)mesh-keykill$/) {
|
|
if ($ARGV[-1] eq '--all') {
|
|
die "Interaction required but batch mode enabled\n" if ($opts{b});
|
|
# must use interactive auth
|
|
$opts{sshmp} =~ s/-oBatchMode=yes/-oPubkeyAuthentication=no/;
|
|
$opts{keykill} = -1;
|
|
} elsif (scalar(@ARGV) == 2 && -e $ARGV[-1]) {
|
|
$opts{keykill} = abs_path($ARGV[-1]);
|
|
my $out = open3_get([-1, undef], "ssh-keygen -l -f $opts{keykill}");
|
|
die "Invalid key file $ARGV[-1]\n"
|
|
if ($out =~ /not a public key file|no such file/i);
|
|
$ARGV[-1] = (split/\s+/, $out)[1];
|
|
} else {
|
|
$opts{keykill} = $mesh_key;
|
|
}
|
|
splice(@ARGV, 1, 0, "--hash=$map_hash");
|
|
splice(@ARGV, 1, 0, "--cert=$map_cert") if ($map_cert);
|
|
}
|
|
|
|
=cut mesh
|
|
|
|
##########################
|
|
#### clean up on exit ####
|
|
##########################
|
|
END {exit_clean()};
|
|
use sigtrap qw(handler exit_clean normal-signals);
|
|
|
|
=for mesh
|
|
|
|
########################
|
|
#### modify command ####
|
|
########################
|
|
print STDERR "Old command is '" . join("' '", @ARGV) . "'\n" if ($opts{v});
|
|
key_ssh();
|
|
my $argc = scalar(@ARGV);
|
|
if ($ARGV[0] =~ /(?:^|\W)(?:scp|sftp)$/) {
|
|
my ($fh, $wrap) = tempfile(UNLINK => 1);
|
|
print $fh "#!/bin/sh\nexec $opts{ssh} \$@";
|
|
close $fh;
|
|
chmod(0700, $wrap);
|
|
splice(@ARGV, 1, 0, ("-S", $wrap));
|
|
} elsif ($ARGV[0] =~ /(?:^|\W)bbftp$/) {
|
|
splice(@ARGV, 1, 0, ("-L", $opts{ssh}));
|
|
} elsif ($ARGV[0] =~ /(?:^|\W)rsync$/) {
|
|
splice(@ARGV, 1, 0, ("-e", $opts{ssh}));
|
|
} elsif ($ARGV[0] =~ /(?:^|\W)ssh$/) {
|
|
splice(@ARGV, 0, 1, split(/\s+/, $opts{ssh}));
|
|
} elsif ($ARGV[0] =~ /(?:^|\W)(?:mesh-keykill|mesh-keytime|ssh-balance)$/) {
|
|
splice(@ARGV, 0, 0, split(/\s+/, $opts{sshmp}));
|
|
}
|
|
print STDERR "New command is '" . join("' '", @ARGV) . "'\n" if ($opts{v});
|
|
|
|
=cut mesh
|
|
|
|
if ($opts{base0} =~ /^shift/ || $ARGV[0] =~ /^shiftc?$/) {
|
|
shift_();
|
|
exit;
|
|
}
|
|
|
|
=for mesh
|
|
|
|
################################
|
|
#### execute remote command ####
|
|
################################
|
|
if (scalar(@ARGV) > $argc) {
|
|
# use system instead of exec so can clean up afterwards
|
|
my $rc = WEXITSTATUS(system(@ARGV));
|
|
# remove killed keys
|
|
if (!$rc && $opts{keykill}) {
|
|
if ($opts{keykill} == -1) {
|
|
foreach my $file (glob("$opts{I}/meshkey.[0-9]*")) {
|
|
unlink($file, "$file.pub");
|
|
}
|
|
} elsif (!$rc && $opts{keykill}) {
|
|
unlink($opts{keykill}, "$opts{keykill}.pub");
|
|
}
|
|
}
|
|
exit $rc;
|
|
}
|
|
|
|
###################
|
|
#### find sftp ####
|
|
###################
|
|
# store $< or else getuid() will be run on every glob item
|
|
my $uid = $<;
|
|
# use multi-stage glob in less elegant, but more audit-friendly fashion
|
|
my @sftps = grep {(stat $_)[4] == $uid} (glob("$opts{tmp_d}/mesh-*"));
|
|
@sftps = map {glob("$_/sftp.*")} @sftps;
|
|
my $sftp_time = -1;
|
|
my $sftp_sock;
|
|
foreach my $sftp (@sftps) {
|
|
my @stat = stat $sftp;
|
|
next if (! -S $sftp || $stat[9] < $sftp_time);
|
|
print STDERR "Checking validity of sftp socket $sftp\n" if ($opts{v});
|
|
my $sftpd = IO::Socket::UNIX->new(
|
|
Peer => $sftp,
|
|
Proto => 'tcp',
|
|
);
|
|
next if (!$sftpd);
|
|
$sftp_sock = $sftp;
|
|
$sftp_time = $stat[9];
|
|
}
|
|
|
|
############################
|
|
#### start sftp for vfs ####
|
|
############################
|
|
if (!defined $sftp_sock) {
|
|
$opts{sftp_d} = tempdir("mesh-XXXXXXXX", DIR => $opts{tmp_d});
|
|
$sftp_sock = "$opts{sftp_d}/sftp.$$";
|
|
mkdir "$opts{sftp_d}/empty";
|
|
require Net::SFTP::Foreign;
|
|
|
|
my $server = IO::Socket::UNIX->new(
|
|
Listen => 10,
|
|
Local => $sftp_sock,
|
|
Proto => 'tcp',
|
|
);
|
|
|
|
if (fork) {
|
|
close $server;
|
|
# prevent cleanup
|
|
$opts{sftp_d} = undef;
|
|
} else {
|
|
close STDIN;
|
|
close STDOUT;
|
|
close STDERR;
|
|
setsid;
|
|
open(STDIN, "</dev/null");
|
|
open(STDOUT, ">/dev/null");
|
|
open(STDERR, ">/dev/null");
|
|
|
|
while (my $client = $server->accept) {
|
|
$_ = <$client>;
|
|
if (!$_) {
|
|
close $client;
|
|
next;
|
|
}
|
|
my $pwd;
|
|
eval;
|
|
my %copts;
|
|
for (my $i = 1; $i < scalar(@ARGV); $i++) {
|
|
if ($ARGV[$i] =~ /^--(\w+)$/) {
|
|
$copts{$1} = 1;
|
|
} elsif ($ARGV[$i] =~ /^--(\w+)=(.*)$/) {
|
|
$copts{$1} = $2;
|
|
} elsif ($ARGV[$i] =~ /^-(\d+)$/) {
|
|
$copts{$1} = 1;
|
|
} elsif ($ARGV[$i] =~ /^-(\w+)$/) {
|
|
$copts{$_} = 1 foreach (split(//, $1));
|
|
} elsif (!defined $copts{-arg1} && $ARGV[0] =~
|
|
/(?:^|\W)(?:chgrp|chown|chmod|grep)$/) {
|
|
# first non-option argument
|
|
$copts{-arg1} = $ARGV[$i];
|
|
} else {
|
|
my ($host, $path) = hostpath($ARGV[$i]);
|
|
if ($host eq 'localhost') {
|
|
# rewrite arg for /localhost/path case
|
|
$ARGV[$i] = $path;
|
|
if ($path !~ /^\//) {
|
|
# relative path
|
|
($host, $path) = hostpath($pwd);
|
|
$path .= "/" . $ARGV[$i] if ($host ne 'localhost');
|
|
}
|
|
}
|
|
if ($host ne 'localhost') {
|
|
$path = File::Spec::Unix->canonpath($path);
|
|
1 while ($path =~ s/(?:^|\/?(?:[^\/]*\/))\.\.//);
|
|
$path = "/" if (!$path);
|
|
# original argument
|
|
$copts{-arg} = splice(@ARGV, $i--, 1);
|
|
if ($path =~ /[*?[]/ &&
|
|
$ARGV[0] !~ /(?:^|\W)(?:ls|complete)$/) {
|
|
my @glob = sftp($host)->glob($path, names_only => 1);
|
|
next if (scalar(@glob) == 0);
|
|
$path = shift @glob;
|
|
@glob = map {hostpath($host, $_)} @glob;
|
|
splice(@ARGV, $i + 1, 0, @glob);
|
|
}
|
|
push(@{$copts{-argv}}, hostpath($host, $path));
|
|
if ($ARGV[0] =~ /(?:^|\W)(cd|chgrp|chmod|chown|complete|df|du|head|ls|mkdir|rm|rmdir|tail|test|touch)$/) {
|
|
#TODO: this should probably be done differently (i.e. should rename
|
|
# all paths, then execute subs on all args at once)
|
|
$copts{-argsleft} = scalar(@ARGV) - $i - 1;
|
|
my $sub = \&{"v$1"};
|
|
&{$sub}($client, $host, $path, \%copts);
|
|
last if ($1 eq 'cd');
|
|
} elsif ($ARGV[0] !~ /(?:^|\W)(?:cp|ln|mv|tee)$/) {
|
|
#### commands that use tmp files for remote files ####
|
|
my $tmp = sftp_tmp() . "-" . basename($path);
|
|
if ($ARGV[0] =~ /(?:^|\W)file$/) {
|
|
#### commands that use first n bytes of files ####
|
|
open(FILE, '>', $tmp);
|
|
my $fh = sftp($host)->open($path);
|
|
print FILE sftp($host)->read($fh, 4096);
|
|
close $fh;
|
|
close FILE;
|
|
} else {
|
|
#### commands that use entire files ####
|
|
if ($tmp ne $copts{-arg}) {
|
|
my $ref = {};
|
|
transport('get', $host, $path, $tmp, $ref);
|
|
transport('end', $host);
|
|
#TODO: do something with error
|
|
}
|
|
}
|
|
splice(@ARGV, ++$i, 0, $tmp);
|
|
$copts{-argc}++;
|
|
}
|
|
} else {
|
|
$copts{-argc}++;
|
|
push(@{$copts{-argv}}, glob($ARGV[$i]));
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($ARGV[0] =~ /(?:^|\W)(cp|ln|mv|tee)$/) {
|
|
#### commands that process all arguments at once ####
|
|
my $sub = \&{"v$1"};
|
|
&{$sub}($client, \%copts);
|
|
}
|
|
if ($copts{-argc} || $copts{-arg1} && $ARGV[0] =~ /(?:^|\W)grep$/) {
|
|
#### commands that execute locally on local files ####
|
|
if ($ARGV[0] =~ /(?:^|\W)ls$/) {
|
|
# add directory to ls output
|
|
sftp_echo($client, "");
|
|
sftp_echo($client, $ARGV[-1] . ":")
|
|
if ($copts{-argc} == 1 && -d $ARGV[-1]);
|
|
}
|
|
@ARGV = map {glob($_)} @ARGV;
|
|
sftp_cmd($client, @ARGV);
|
|
}
|
|
close $client;
|
|
last if ($ARGV[0] eq 'exit');
|
|
}
|
|
exit;
|
|
}
|
|
}
|
|
|
|
#############################
|
|
#### execute vfs command ####
|
|
#############################
|
|
my $server = IO::Socket::UNIX->new(
|
|
Peer => $sftp_sock,
|
|
Proto => 'tcp',
|
|
);
|
|
print $server scalar(Data::Dumper->Dump([\@ARGV, $ENV{PWD}],
|
|
[qw(*ARGV pwd)])) . "\n";
|
|
my $rc = 0;
|
|
if ($ARGV[0] =~ /(?:^|\W)tee$/) {
|
|
while (<STDIN>) {
|
|
print;
|
|
print $server $_;
|
|
}
|
|
} else {
|
|
while (<$server>) {
|
|
eval;
|
|
$rc |= WEXITSTATUS(system(@ARGV));
|
|
unlink grep(/meshtmp-/, @ARGV);
|
|
}
|
|
}
|
|
exit $rc;
|
|
|
|
=cut mesh
|
|
|
|
################
|
|
#### escape ####
|
|
################
|
|
# return uri-escaped version of given string
|
|
sub escape {
|
|
my $text = shift;
|
|
$text =~ s/([^A-Za-z0-9\-\._~\/])/sprintf("%%%02X", ord($1))/eg
|
|
if (defined $text);
|
|
return $text;
|
|
}
|
|
|
|
####################
|
|
#### exit_clean ####
|
|
####################
|
|
# clean up agents/directories and exit
|
|
sub exit_clean {
|
|
my $rc = $?;
|
|
|
|
if ($opts{sftp_d} =~ /mesh-.{8}$/) {
|
|
# rmtree complains about current directory without chdir
|
|
chdir "/";
|
|
# remove temporary directory and all contents
|
|
rmtree($opts{sftp_d});
|
|
}
|
|
|
|
exit $rc;
|
|
}
|
|
|
|
#####################
|
|
#### fork_setsid ####
|
|
#####################
|
|
sub fork_setsid {
|
|
my $pid = fork;
|
|
if (!$pid) {
|
|
close STDIN;
|
|
close STDOUT;
|
|
close STDERR;
|
|
setsid;
|
|
open(STDIN, "</dev/null");
|
|
open(STDOUT, ">/dev/null");
|
|
open(STDERR, ">/dev/null");
|
|
POSIX::_exit(0) if (fork);
|
|
}
|
|
return $pid;
|
|
}
|
|
|
|
##############
|
|
#### fqdn ####
|
|
##############
|
|
# return fully qualified version of given host name
|
|
sub fqdn {
|
|
my $host = shift;
|
|
return $host if ($host eq '127.0.0.1');
|
|
my @uhost = split(/@/, $host);
|
|
if ($uhost[-1] =~ /^\d+\.\d+\.\d+\.\d+$/) {
|
|
my $name = gethostbyaddr(inet_aton($uhost[-1]), AF_INET);
|
|
$uhost[-1] = $name if ($name);
|
|
} elsif (wantarray) {
|
|
# resolve from name to ip back to name to normalize multiple aliases
|
|
my %names;
|
|
my ($n, $a, $t, $l, @addrs) = gethostbyname($uhost[-1]);
|
|
foreach my $addr (@addrs) {
|
|
my $name = gethostbyaddr($addr, AF_INET);
|
|
$names{$name} = 1 if ($name);
|
|
}
|
|
return keys(%names);
|
|
} else {
|
|
# resolve from name to ip back to name to normalize multiple aliases
|
|
my $ip = gethostbyname($uhost[-1]);
|
|
if ($ip) {
|
|
my $name = gethostbyaddr($ip, AF_INET);
|
|
$uhost[-1] = $name if ($name);
|
|
}
|
|
}
|
|
# user name will never appear in wantarray case used by mount collector
|
|
return wantarray ? ($uhost[-1]) : join('@', @uhost);
|
|
}
|
|
|
|
##################
|
|
#### hostpath ####
|
|
##################
|
|
# return parsed host/path in list context or true if remote path in scalar
|
|
sub hostpath {
|
|
my $path = $_[-1];
|
|
my $host = scalar(@_) > 1 ? $_[0] : 'localhost';
|
|
if (scalar(@_) > 1) {
|
|
# multiple arguments
|
|
# return host-path for non-localhost and original path otherwise
|
|
return $path if ($host eq 'localhost');
|
|
return $host . ":" . $path;
|
|
} elsif ($path =~ /^([\w@.-]+):(.*)$/s) {
|
|
my ($h, $p) = ($1, $2);
|
|
# leave user name as part of host
|
|
if ($h ne 'file' && $p !~ /^\/\//) {
|
|
# single host-path argument in scp format
|
|
($host, $path) = ($h, $p);
|
|
# remove leading ~/ since it is implied
|
|
$path =~ s/^~\/+//;
|
|
# resolve home dir for relative paths
|
|
if (wantarray && $path !~ /^\//) {
|
|
$path = sftp($host)->cwd . "/" . $path;
|
|
}
|
|
}
|
|
}
|
|
# for list context, return (host, path)
|
|
# for scalar context, return true if non-localhost host-path
|
|
return wantarray ? ($host, $path) : ($host ne 'localhost' ? 1 : 0);
|
|
}
|
|
|
|
=for mesh
|
|
|
|
##################
|
|
#### key_cert ####
|
|
##################
|
|
# return temporary cert for given CA or die on error
|
|
sub key_cert {
|
|
my $ca = shift;
|
|
my $fh = File::Temp->new(TEMPLATE => ".meshXXXXXXXX", DIR => $opts{I});
|
|
die "Unable to generate temporary cert name\n" if (!$fh);
|
|
close $fh;
|
|
my $file = $fh->filename;
|
|
# must unlink so can symlink
|
|
unlink $file;
|
|
# symlink identity so tmp cert name does not interfere with parallel clients
|
|
symlink($opts{i}, $file) or die "Unable to symlink identity $opts{i}\n";
|
|
# this is needed on older ssh clients
|
|
symlink("$opts{i}.pub", "$file.pub") or die "Unable to symlink identity $opts{i}.put\n";
|
|
# adjust for local drift;
|
|
my $vb = -60 + $opts{drift};
|
|
my $va = 60 * $opts{V} + $opts{drift};
|
|
$vb = "+$vb" if ($vb >= 0);
|
|
$va = "+$va" if ($va >= 0);
|
|
open3_get([-1, undef],
|
|
"ssh-keygen -s $ca -I $file -V ${vb}s:${va}s $file");
|
|
my $rc = $?;
|
|
unlink($file, "$file.pub");
|
|
die "Unable to generate temporary cert\n" if ($rc);
|
|
open(FILE, "$file-cert.pub") or die "Unable to read temporary cert\n";
|
|
my $cert = <FILE>;
|
|
close FILE;
|
|
unlink "$file-cert.pub";
|
|
chomp $cert;
|
|
die "Temporary cert empty\n" if (!$cert);
|
|
return escape($cert);
|
|
}
|
|
|
|
#####################
|
|
#### key_comment ####
|
|
#####################
|
|
# store given comment in given file since ssh-keygen -c not reliable
|
|
sub key_comment {
|
|
my ($file, $comment) = @_;
|
|
$file = "$file.pub" if ($file !~ /\.pub$/);
|
|
my $fh;
|
|
if (open($fh, '+<', $file)) {
|
|
my $line = <$fh>;
|
|
my ($type, $base64, $old) = split(/\s+/, $line, 3);
|
|
seek($fh, 0, 0);
|
|
truncate($fh, 0);
|
|
print $fh "$type $base64 $comment";
|
|
close $fh;
|
|
} else {
|
|
die "Unable to store initialization status for $file\n";
|
|
}
|
|
}
|
|
|
|
##################
|
|
#### key_find ####
|
|
##################
|
|
# return most recent valid key or undef if none found
|
|
sub key_find {
|
|
my $return;
|
|
foreach my $key (sort {(split(/\./, $b))[-1] <=> (split(/\./, $a))[-1]}
|
|
glob("$opts{I}/meshkey.[0-9]*")) {
|
|
if ($key =~ /\.(\d+)(\.pub)?$/) {
|
|
my ($time, $pub) = ($1, $2);
|
|
if ($time - time < 0) {
|
|
print STDERR "Removing expired key $key\n" if ($opts{v});
|
|
unlink $key;
|
|
next;
|
|
}
|
|
next if ($pub);
|
|
print STDERR "Checking validity of key $key\n" if ($opts{v});
|
|
my $out = open3_get([-1, undef], "ssh-keygen -l -f $key");
|
|
if ($out =~ /not a public key file|no such file/i) {
|
|
print STDERR "Removing invalid key $key\n" if ($opts{v});
|
|
unlink $key;
|
|
next;
|
|
}
|
|
# keep going through keys to delete old ones
|
|
next if ($return);
|
|
# ensure key has correct permissions
|
|
chmod(0600, $key);
|
|
$return = $key;
|
|
}
|
|
}
|
|
return $return;
|
|
}
|
|
|
|
=cut mesh
|
|
|
|
#################
|
|
#### key_ssh ####
|
|
#################
|
|
sub key_ssh {
|
|
=for mesh
|
|
my $cmd = shift;
|
|
my $save_v = $opts{v};
|
|
delete $opts{v};
|
|
my $key = key_find();
|
|
$opts{v} = $save_v;
|
|
die "Unable to find valid key\n" if (!$key);
|
|
if ($cmd =~ /(-oCertificateString=)\S+/) {
|
|
my $cert = key_cert($key);
|
|
$cmd =~ s/(-oCertificateString=)\S+/$1$cert/;
|
|
$cmd =~ s/(-oIdentityHash=)\S+/$1$mesh_id_hash/;
|
|
$cmd =~ s/(-oIdentityFile=)\S+/$1$key/;
|
|
return $cmd;
|
|
} elsif ($cmd) {
|
|
$cmd =~ s/(-oIdentityFile=)\S+/$1$key/;
|
|
return $cmd;
|
|
} elsif ($opts{ssh} =~ /(-oCertificateString=)\S+/) {
|
|
my $cert = key_cert($key);
|
|
$opts{ssh} =~ s/(-oCertificateString=)\S+/$1$cert/;
|
|
$opts{ssh} =~ s/(-oIdentityHash=)\S+/$1$mesh_id_hash/;
|
|
}
|
|
$opts{ssh} =~ s/(-oIdentityFile=)\S+/$1$key/;
|
|
$opts{sshmp} =~ s/(-oIdentityFile=)\S+/$1$key/;
|
|
=cut mesh
|
|
}
|
|
|
|
=for mesh
|
|
|
|
######################
|
|
#### key_validate ####
|
|
######################
|
|
# check validity of given key path, generating if it does not exist and
|
|
# return base64 key material if it has been initialized or undef otherwise
|
|
sub key_validate {
|
|
my $id = shift;
|
|
print STDERR "Checking validity of identity $id\n" if ($opts{v});
|
|
my $out = open3_get([-1, undef], "ssh-keygen -l -f $id");
|
|
if ($out =~ /not a public key file|no such file/i) {
|
|
unlink $id;
|
|
print STDERR "Generating identity $id\n" if ($opts{v});
|
|
print open3_get([-1, -1, -1], "ssh-keygen -C comment -N '' -t ecdsa -f $id");
|
|
die "Unable to generate identity $id\n" if ($?);
|
|
chmod(0600, $id);
|
|
} elsif ($out =~ /meshinit=1/) {
|
|
my $hash = (split(/\s+/, $out))[1];
|
|
# convert hash to path-safe variant
|
|
$hash =~ s/\+/-/g;
|
|
$hash =~ s/\//_/g;
|
|
$hash =~ s/^SHA256://;
|
|
return $hash;
|
|
} elsif (! -r "$id.pub") {
|
|
print STDERR "Generating public key for identity $id\n" if ($opts{v});
|
|
print open3_get([-1, "$id.pub", undef], "ssh-keygen -y -f $id");
|
|
if ($?) {
|
|
unlink "$id.pub";
|
|
die "Unable to generate public key $id.pub\n"
|
|
}
|
|
} else {
|
|
print STDERR "Identity $id has not been initialized\n" if ($opts{v});
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
=cut mesh
|
|
|
|
###################
|
|
#### open3_get ####
|
|
###################
|
|
# run given command with stdin/stdout/stderr from/to given files
|
|
# and return command output when requested
|
|
sub open3_get {
|
|
my $files = shift;
|
|
my @args = @_;
|
|
my $fhpid = open3_run($files, @args);
|
|
return undef if (!defined $fhpid);
|
|
my $ifh;
|
|
if (!defined $files->[1]) {
|
|
$ifh = 1;
|
|
} elsif (scalar(@{$files}) == 3 && !defined $files->[2]) {
|
|
$ifh = 2;
|
|
}
|
|
my $out;
|
|
if ($ifh) {
|
|
$out .= $_ while (defined ($_ = $fhpid->[$ifh]->getline));
|
|
}
|
|
open3_wait($fhpid);
|
|
return $out;
|
|
}
|
|
|
|
###################
|
|
#### open3_run ####
|
|
###################
|
|
# run given command with stdin/stdout/stderr either from/to given files
|
|
# or from/to autocreated pipes and return associated file handles and pid
|
|
sub open3_run {
|
|
my $files = shift;
|
|
my @args = @_;
|
|
if (scalar(@args) == 1) {
|
|
$args[0] =~ s/^\s+|\s+$//g;
|
|
@args = quotewords('\s+', 0, $args[0]);
|
|
}
|
|
my (@fh, @o3);
|
|
foreach my $i (0 .. scalar(@{$files}) - 1) {
|
|
my $dir = $i ? '>' : '<';
|
|
my $file = $files->[$i];
|
|
$file = File::Spec->devnull if ($file == -1);
|
|
if ($file) {
|
|
open($fh[$i], $dir, $file);
|
|
$o3[$i] = $dir . '&' . $fh[$i]->fileno;
|
|
} else {
|
|
$o3[$i] = gensym;
|
|
$fh[$i] = $o3[$i];
|
|
}
|
|
}
|
|
# combine stdout/stderr if nothing given for stderr
|
|
$o3[2] = $o3[1] if (scalar(@{$files}) == 2);
|
|
my $pid;
|
|
eval {$pid = IPC::Open3::open3(@o3, @args)};
|
|
if ($@ || !defined $pid) {
|
|
open3_wait([@fh]);
|
|
return undef;
|
|
} else {
|
|
$o3[0]->autoflush(1) if (ref $o3[0]);
|
|
return [@fh, $pid];
|
|
}
|
|
}
|
|
|
|
####################
|
|
#### open3_wait ####
|
|
####################
|
|
# wait for processes and clean up handles created by open3_run
|
|
sub open3_wait {
|
|
my $fhpid = shift;
|
|
return if (!defined $fhpid);
|
|
my $pid = pop(@{$fhpid});
|
|
close $_ foreach (@{$fhpid});
|
|
waitpid($pid, 0);
|
|
}
|
|
|
|
##############
|
|
#### sftp ####
|
|
##############
|
|
# return new/cached sftp connection to given host
|
|
sub sftp {
|
|
my $host = shift;
|
|
my $no_cwd = shift;
|
|
|
|
if ($opts{"sftp_$host"}) {
|
|
# use cwd to check for dead connection
|
|
$opts{"sftp_$host"}->cwd if (!$no_cwd);
|
|
# return cached connection to host if still connected
|
|
return $opts{"sftp_$host"} if ($opts{"sftp_$host"}->{_connected});
|
|
}
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
# create and cache new connection to host
|
|
$opts{"sftp_$host"} = Net::SFTP::Foreign->new(
|
|
autoflush => 1,
|
|
fs_encoding => $opts{encode},
|
|
open2_cmd => "$opts{ssh} -s $host sftp",
|
|
);
|
|
my $fqdn = fqdn($host);
|
|
# cache under fully qualified host name as well
|
|
$opts{"sftp_$fqdn"} = $opts{"sftp_$host"} if ($fqdn ne $host);
|
|
return $opts{"sftp_$host"};
|
|
}
|
|
|
|
##################
|
|
#### sftp_cmd ####
|
|
##################
|
|
# execute given command via given socket
|
|
sub sftp_cmd {
|
|
my $ref = shift;
|
|
if (ref $ref eq 'IO::Socket::UNIX') {
|
|
print $ref scalar(Data::Dumper->Dump([[@_]], [qw(*ARGV)])) . "\n";
|
|
}
|
|
}
|
|
|
|
###################
|
|
#### sftp_echo ####
|
|
###################
|
|
# print given message via given socket or set text in given hash
|
|
sub sftp_echo {
|
|
my $ref = shift;
|
|
return if (!defined $ref || !defined $_[0]);
|
|
if (ref $ref eq 'IO::Socket::UNIX') {
|
|
# use echo to print message
|
|
print $ref scalar(Data::Dumper->Dump([["echo", @_]], [qw(*ARGV)])) . "\n";
|
|
} else {
|
|
$ref->{text} .= join(" ", @_);
|
|
}
|
|
}
|
|
|
|
####################
|
|
#### sftp_error ####
|
|
####################
|
|
# print given error message via given socket or set error text in given hash
|
|
sub sftp_error {
|
|
my $ref = shift;
|
|
return if (!defined $ref || !defined $_[0]);
|
|
if (ref $ref eq 'IO::Socket::UNIX') {
|
|
# use echo to print message
|
|
print $ref scalar(Data::Dumper->Dump([["echo", @_]], [qw(*ARGV)])) . "\n";
|
|
# use false to set non-zero exit code
|
|
print $ref scalar(Data::Dumper->Dump([["false"]], [qw(*ARGV)])) . "\n";
|
|
} else {
|
|
# indicate error using special delimiter
|
|
$ref->{text} .= "\\E" . join(" ", @_);
|
|
}
|
|
}
|
|
|
|
######################
|
|
#### sftp_warning ####
|
|
######################
|
|
# print given warning message via given socket or set warning text in given hash
|
|
sub sftp_warning {
|
|
my $ref = shift;
|
|
return if (!defined $ref || !defined $_[0]);
|
|
if (ref $ref eq 'IO::Socket::UNIX') {
|
|
# use echo to print message
|
|
print $ref scalar(Data::Dumper->Dump([["echo", @_]], [qw(*ARGV)])) . "\n";
|
|
# use false to set non-zero exit code
|
|
print $ref scalar(Data::Dumper->Dump([["false"]], [qw(*ARGV)])) . "\n";
|
|
} else {
|
|
# indicate warning using special delimiter
|
|
$ref->{text} .= "\\W" . join(" ", @_);
|
|
}
|
|
}
|
|
|
|
#################
|
|
#### sftp_ls ####
|
|
#################
|
|
# return formatted ls string of given remote file
|
|
sub sftp_ls {
|
|
#TODO: size is negative in some cases (perhaps showing 64-bit results
|
|
# on 32-bit system?
|
|
my ($name, $attrs) = ($_[0]->{filename}, $_[0]->{a});
|
|
$name = basename($name) if ($_[1]);
|
|
return $name if (!$_[2]);
|
|
$name = "$name -> $_[0]->{link}" if ($_[0]->{link});
|
|
my $user = getpwuid($attrs->uid);
|
|
$user = $attrs->uid if (!$user);
|
|
my $group = getgrgid($attrs->gid);
|
|
$group = $attrs->gid if (!$group);
|
|
return sprintf("%10s %4d %7s %7s %9d %12s %s",
|
|
sftp_ls_mode($attrs->perm), 1, $user, $group, $attrs->size,
|
|
strftime("%b %d %Y", localtime $attrs->mtime), $name);
|
|
}
|
|
|
|
######################
|
|
#### sftp_ls_mode ####
|
|
######################
|
|
# return formatted ls permission string corresponding to given mode
|
|
sub sftp_ls_mode {
|
|
my $mode = shift;
|
|
my @perms = qw(--- --x -w- -wx r-- r-x rw- rwx);
|
|
my @ftype = qw(. p c ? d ? b ? - ? l ? s ? ? ?);
|
|
$ftype[0] = '';
|
|
my $setids = ($mode & 07000) >> 9;
|
|
my @permstrs = @perms[
|
|
($mode & 0700) >> 6, ($mode & 0070) >> 3, $mode & 0007];
|
|
my $ftype = $ftype[($mode & 0170000) >> 12];
|
|
|
|
if ($setids) {
|
|
$permstrs[2] =~ s/([-x])$/$1 eq 'x' ? 't' : 'T'/e if ($setids & 01);
|
|
$permstrs[0] =~ s/([-x])$/$1 eq 'x' ? 's' : 'S'/e if ($setids & 04);
|
|
$permstrs[1] =~ s/([-x])$/$1 eq 'x' ? 's' : 'S'/e if ($setids & 02);
|
|
}
|
|
|
|
return join('', $ftype, @permstrs);
|
|
}
|
|
|
|
##################
|
|
#### sftp_tmp ####
|
|
##################
|
|
# return new temporary file name (with handle in array context)
|
|
sub sftp_tmp {
|
|
my %dir;
|
|
# create in vfs socket directory if it exists
|
|
$dir{DIR} = defined $opts{sftp_d} ? $opts{sftp_d} : $opts{tmp_d};
|
|
my ($tmpfh, $tmp) = tempfile("meshtmp-XXXXXXXX", %dir);
|
|
if (wantarray) {
|
|
# in array context, return both file handle and file name
|
|
return ($tmpfh, $tmp);
|
|
} else {
|
|
close $tmpfh;
|
|
# in scalar context, return just file name
|
|
return $tmp;
|
|
}
|
|
}
|
|
|
|
################
|
|
#### shift_ ####
|
|
################
|
|
# starting point for all shift functionality
|
|
sub shift_ {
|
|
# shift: Self-Healing Independent File Transfer
|
|
my $shift = $opts{base0} !~ /^shift/ ? " " . shift @ARGV : "";
|
|
$opts{command} = join(" ", @{$opts{argv}});
|
|
die "Invalid options\n" if (!GetOptions(\%opts,
|
|
"bandwidth=s", "buffer=s", "clients=i", "cpu=i", "create-tar",
|
|
"directory|d", "disk=s", "exclude=s@", "extract-tar", "files=s",
|
|
"force|f", "help|h", "history:s", "host-file=s", "host-list=s",
|
|
"hosts=i", "id=s", "identity=s", "ignore-times|I", "include=s@",
|
|
"index-tar", "interval=i", "io=i", "ior=i", "iow=i", "dereference|L",
|
|
"last-sum", "local=s", "mgr=s", "mgr-identity=s", "mgr-user=s",
|
|
"monitor:s", "net=i", "netr=i", "netw=i", "newer=s", "no-cron",
|
|
"no-dereference|P", "no-mail:s", "no-offline", "no-preserve:s",
|
|
"no-recall", "no-sanity", "no-silent", "no-target-directory|T",
|
|
"no-verify", "older=s", "pid=i", "pipeline", "plot:s", "ports=s",
|
|
"preallocate=i", "recursive|R|r", "remote=s", "restart:s", "retry=i",
|
|
"search=s", "secure", "size=s", "split=s", "split-tar=s", "state=s",
|
|
"stats:s", "status:s", "stop", "streams=i", "stripe=s", "sync",
|
|
"threads=i", "user=s", "verify-fast", "wait", "window=s",
|
|
));
|
|
my %in_opts = map {$_ => 1} keys %opts;
|
|
|
|
# make sure user can read, write, execute/traverse files/dirs
|
|
# make sure root transfers do not inadvertently expose files
|
|
umask ($< == 0 ? 077 : 077 & umask);
|
|
my $host = fqdn(hostname);
|
|
my %hosts = map {fqdn($_) => 1} split(/,/, $opts{'host-list'});
|
|
if ($opts{'host-file'}) {
|
|
if (open(FILE, '<', $opts{'host-file'})) {
|
|
while (<FILE>) {
|
|
chomp;
|
|
$hosts{fqdn($_)} = 1;
|
|
}
|
|
close FILE;
|
|
} else {
|
|
die "Unable to read host file " . $opts{'host-file'} . ": $!\n";
|
|
}
|
|
}
|
|
if (scalar(keys %hosts) != 0) {
|
|
$hosts{$host} = 1;
|
|
$opts{hosts} = scalar(keys %hosts) if (!defined $opts{hosts});
|
|
$opts{'host-list'} = join(",", keys %hosts);
|
|
$in_opts{'host-list'} = 1;
|
|
$in_opts{hosts} = 1;
|
|
}
|
|
|
|
if ($opts{base0} =~ /^shift/) {
|
|
# these options are only needed when shift is standalone without mesh
|
|
$opts{ssh} .= " -i $opts{identity}" if ($opts{identity});
|
|
$opts{ssh} .= " -l $opts{user}" if ($opts{user});
|
|
$opts{ssh} .= " -q";
|
|
$opts{sshTMPL} = $opts{ssh} . " OPTS_SSH";
|
|
}
|
|
|
|
$opts{preserve} = 1;
|
|
if ($opts{'no-preserve'} && $opts{'no-preserve'} !~
|
|
/^((acl|mode|owner|stripe|time|xattr)(,|$))+$/) {
|
|
# argument was processed as optional value
|
|
unshift(@ARGV, $opts{'no-preserve'});
|
|
$opts{'no-preserve'} = "";
|
|
}
|
|
if (!$opts{sync} && defined $opts{'no-preserve'}) {
|
|
if ($opts{'no-preserve'}) {
|
|
my %pres = map {$_ => 1} qw(acl mode owner stripe time xattr);
|
|
delete $pres{$_} foreach (split(/,/, $opts{'no-preserve'}));
|
|
$opts{preserve} = join(",", keys %pres);
|
|
} else {
|
|
$opts{preserve} = 0;
|
|
}
|
|
}
|
|
|
|
$opts{mail} = 1;
|
|
if ($opts{'no-mail'} && $opts{'no-mail'} !~
|
|
/^((alert|done|error|run|stop|throttle|warn)(,|$))+$/) {
|
|
# argument was processed as optional value
|
|
unshift(@ARGV, $opts{'no-mail'});
|
|
$opts{'no-mail'} = "";
|
|
}
|
|
if (defined $opts{'no-mail'}) {
|
|
$in_opts{mail} = 1;
|
|
if ($opts{'no-mail'}) {
|
|
my %mail = map {$_ => 1}
|
|
qw(alert done error run stop throttle warn);
|
|
delete $mail{$_} foreach (split(/,/, $opts{'no-mail'}));
|
|
$opts{mail} = join(",", keys %mail);
|
|
} else {
|
|
$opts{mail} = 0;
|
|
}
|
|
}
|
|
|
|
if ($opts{monitor} && $opts{monitor} !~ /^(color|csv|pad)$/) {
|
|
# argument was processed as optional value
|
|
unshift(@ARGV, $opts{monitor});
|
|
$opts{monitor} = "";
|
|
}
|
|
|
|
foreach (qw(cron offline recall sanity silent verify)) {
|
|
$opts{$_} = $opts{"no-$_"} ? 0 : 1;
|
|
$in_opts{$_} = 1 if ($in_opts{"no-$_"});
|
|
}
|
|
$opts{sanity} = 1 if ($opts{sync});
|
|
# do not use cron if root
|
|
$opts{cron} = 0 if ($< == 0);
|
|
$opts{mail} = 0 if ($opts{wait});
|
|
$opts{mgr} = unescape($opts{mgr}) if ($opts{mgr});
|
|
$opts{offline} = 0 if ($opts{'create-tar'} || $opts{'extract-tar'});
|
|
# recursive must be set before no-dereference
|
|
$opts{recursive} = 1 if ($opts{'create-tar'});
|
|
$opts{'no-dereference'} = 1 if ($opts{recursive});
|
|
|
|
if ($opts{pid} > 0) {
|
|
# immediately exit if users should not be on the system
|
|
exit if (-e "/etc/nologin");
|
|
# check not already running
|
|
my $run = open3_get([-1, undef, -1], "ps -o command -p $opts{pid}");
|
|
if ($run =~ /shift/) {
|
|
# send keepalive
|
|
if ($opts{id}) {
|
|
# skip if there is already a keepalive running
|
|
$run = open3_get([-1, undef, -1], "ps -xo command");
|
|
if ($run !~ /--alive --id=$opts{id} --host=$host/) {
|
|
my $out = shift_mgr("--alive --id=$opts{id} --host=$host");
|
|
shift_stop() if ($out =~ /stop/);
|
|
}
|
|
}
|
|
exit;
|
|
}
|
|
#TODO: recreate user's original path?
|
|
}
|
|
|
|
my $usage = "Usage: $opts{base0}$shift [OPTION]... SOURCE DEST\n" .
|
|
" or: $opts{base0}$shift [OPTION]... SOURCE... DIRECTORY\n" .
|
|
" or: $opts{base0}$shift [OPTION]...\n";
|
|
if ($opts{stop} && $opts{id}) {
|
|
my $out = shift_mgr("--stop --id=$opts{id}");
|
|
die "$$out\n" if (ref $out);
|
|
shift_stop();
|
|
} elsif (defined $opts{stats}) {
|
|
my $stats = $opts{stats} ? "=$opts{stats}" : "";
|
|
my $out = shift_mgr("--stats$stats");
|
|
die "$$out\n" if (ref $out);
|
|
print $out;
|
|
exit;
|
|
} elsif (defined $opts{history}) {
|
|
my $id = $opts{id} ? "--id=$opts{id}" : "";
|
|
my $history= $opts{history} ? "=$opts{history}" : "";
|
|
my $search = $opts{search} ? "--search=" . escape($opts{search}) : "";
|
|
my $out = shift_mgr("--history$history $id $search");
|
|
die "$$out\n" if (ref $out);
|
|
print $out;
|
|
exit;
|
|
} elsif ($opts{'last-sum'} && $opts{search}) {
|
|
shift_mgr("--last-sum --search=" . escape($opts{search}));
|
|
exit;
|
|
} elsif ($opts{'last-sum'}) {
|
|
my ($ifh, $in) = tempfile();
|
|
my $extra;
|
|
if ($opts{'index-tar'}) {
|
|
$extra = "=0";
|
|
print $ifh escape(abs_path shift(@ARGV)), "\n";
|
|
foreach (@ARGV) {
|
|
print $ifh escape($_), "\n";
|
|
}
|
|
} else {
|
|
foreach (@ARGV) {
|
|
print $ifh escape(abs_path $_), "\n";
|
|
}
|
|
}
|
|
close $ifh;
|
|
my ($ofh, $out) = tempfile();
|
|
close $ofh;
|
|
shift_mgr("--last-sum$extra --host=$host", $in, $out);
|
|
open($ofh, '<', $out);
|
|
print while (<$ofh>);
|
|
unlink($in, $out);
|
|
exit;
|
|
} elsif (defined $opts{monitor} && !$opts{wait}) {
|
|
my $id = $opts{id} ? "--id=$opts{id}" : "";
|
|
my $search = $opts{search} ? "--search=" . escape($opts{search}) : "";
|
|
my $monitor = $opts{monitor} ? "=$opts{monitor}" : "";
|
|
shift_mgr("--monitor$monitor $id $search");
|
|
exit;
|
|
} elsif (defined $opts{plot}) {
|
|
my $id = $opts{id} ? "--id=$opts{id}" : "";
|
|
my $state = $opts{state} ? "--state=$opts{state}" : "";
|
|
my $plot = $opts{plot} ? "=$opts{plot}" : "";
|
|
# use file in case of very large output
|
|
my ($fh, $file) = tempfile();
|
|
close $fh;
|
|
my $out = shift_mgr("--plot$plot $id $state", undef, $file);
|
|
die "$$out\n" if (ref $out);
|
|
open($fh, '<', $file);
|
|
print while (<$fh>);
|
|
unlink $file;
|
|
exit;
|
|
} elsif (defined $opts{status}) {
|
|
my $id = $opts{id} ? "--id=$opts{id}" : "";
|
|
my $search = $opts{search} ? "--search=" . escape($opts{search}) : "";
|
|
my $state = $opts{state} ? "--state=$opts{state}" : "";
|
|
my $status = $opts{status} ? "=$opts{status}" : "";
|
|
# use file in case of very large output
|
|
my ($fh, $file) = tempfile();
|
|
close $fh;
|
|
my $out = shift_mgr("--status$status $id $search $state", undef, $file);
|
|
die "$$out\n" if (ref $out);
|
|
open($fh, '<', $file);
|
|
print while (<$fh>);
|
|
unlink $file;
|
|
exit;
|
|
} elsif ($opts{'create-tar'} && $opts{'extract-tar'}) {
|
|
die "--create-tar and --extract-tar are mutually exclusive\n";
|
|
} elsif ($opts{'index-tar'} && !$opts{'create-tar'}) {
|
|
die "--index-tar requires the --create-tar option\n";
|
|
} elsif ($opts{sync} && ($opts{'create-tar'} || $opts{'extract-tar'})) {
|
|
die "--sync cannot be used with --create-tar/--extract-tar\n";
|
|
} elsif (defined $opts{restart} && !$opts{id}) {
|
|
die "--restart requires the --id option\n";
|
|
} elsif ($opts{stop} && !$opts{id}) {
|
|
die "--stop requires the --id option\n";
|
|
} elsif ($opts{files} && $opts{files} !~ /^([1-9]\d*)([bkmgt])?$/i) {
|
|
die "Invalid count '$opts{files}' for option --files\n";
|
|
} elsif ($opts{ports} && $opts{ports} !~ /^\d+:\d+/) {
|
|
die "Invalid port range '$opts{ports}' in --ports\n";
|
|
} elsif ($opts{help}) {
|
|
print "$usage\n";
|
|
print "Reliably transfer SOURCE to DEST, multiple SOURCE(s) to DIRECTORY,\n";
|
|
print "or arbitrary SOURCE to DEST and/or SOURCE(s) to DIRECTORY combinations\n";
|
|
print "read from stdin.\n";
|
|
print "\n";
|
|
print "Local paths are specified normally. A path PATH on a remote host HOST\n";
|
|
print "is specified using scp-style \"HOST:PATH\".\n";
|
|
print "\n";
|
|
print "Initialization options (defaults in brackets):\n";
|
|
print " --clients=NUM use at most NUM clients per host [1]\n";
|
|
print " --create-tar create tar file of SOURCE(s) at DEST\n";
|
|
print " -L, --dereference always follow symbolic links\n";
|
|
print " -d, --directory create any missing parent directories\n";
|
|
print " --exclude=REGEX exclude files matching REGEX\n";
|
|
print " --extract-tar extract tar file(s) at SOURCE to DEST\n";
|
|
print " -f, --force overwrite existing read-only files at DEST\n";
|
|
print " -h, --help help\n";
|
|
print " --host-file=FILE parallelize transfer on hosts in FILE (one per line)\n";
|
|
print " --host-list=LIST parallelize transfer on hosts in LIST\n";
|
|
print " --hosts=NUM parallelize transfer on at most NUM client hosts [1]\n";
|
|
print " --identity=FILE access remote systems with ssh identity in FILE\n";
|
|
print " -I, --ignore-times do not skip files that match size and time\n";
|
|
print " --include=REGEX include only files matching REGEX\n";
|
|
print " --index-tar create table of contents during tar creation\n";
|
|
print " --newer=[TYPE:]DATE include only files with mtime [TYPE] newer than DATE\n";
|
|
print " (TYPE in form [acmACM]+(\|[acmACM]+)*)\n";
|
|
print " -P, --no-dereference never follow symbolic links\n";
|
|
print " -T, --no-target-directory treat target as a normal file\n";
|
|
print " --older=[TYPE:]DATE include only files with mtime [TYPE] older than DATE\n";
|
|
print " (TYPE in form [acmACM]+(\|[acmACM]+)*)\n";
|
|
print " --pipeline emit verified files sooner for parallel processing\n";
|
|
print " --ports=NUM1:NUM2 use ports NUM1-NUM2 for remote TCP-based transports\n";
|
|
print " -R, -r, --recursive copy directories recursively\n";
|
|
print " --secure encrypt data stream(s) and use secure ciphers/macs\n";
|
|
print " --sync synchronize files at destination\n";
|
|
print " --user=USER access remote systems as USER\n";
|
|
print " --wait block until transfer completes\n";
|
|
print " (exit 0 = success, 1 = failure)\n";
|
|
print "\n";
|
|
print "Feature-disablement options:\n";
|
|
print " --no-cron do not recover from host/process failures via cron\n";
|
|
print " --no-mail[=LIST] do not send status emails [for LIST of states]\n";
|
|
print " (LIST subset of {alert,done,error,run,stop,\n";
|
|
print " throttle,warn})\n";
|
|
print " --no-offline do not migrate DMF-managed files after transfer\n";
|
|
print " --no-preserve[=LIST] do not preserve attributes [on specific LIST]\n";
|
|
print " (LIST subset of {acl,mode,owner,stripe,time,xattr})\n";
|
|
print " --no-recall do not recall DMF-managed files before transfer\n";
|
|
print " --no-sanity do not check file existence/size (benchmarking only)\n";
|
|
print " --no-silent do not detect silent corruption or store checksums\n";
|
|
print " --no-verify do not verify/rectify integrity of destination files\n";
|
|
print "\n";
|
|
print "Monitoring and management options:\n";
|
|
print " --history[=csv] show command line/origin of transfers [in CSV form]\n";
|
|
print " --id=NUM use transfer identifier NUM for other commands\n";
|
|
print " --last-sum show last stored sum for SOURCE(s) or matching --search\n";
|
|
print " --mgr=HOST set host of shift manager to HOST\n";
|
|
print " --mgr-identity=FILE access manager host with ssh identity in FILE\n";
|
|
print " --mgr-user=USER access manager host as USER\n";
|
|
print " --monitor[=FORMAT] monitor progress of running transfers\n";
|
|
print " (FORMAT one of {color,csv,pad})\n";
|
|
print " --plot[=[BY[:/]]LIST] plot detailed performance when piped to gnuplot\n";
|
|
print " (BY one of {client,fs,host,id,net,user})\n";
|
|
print " (LIST subset of {bbftp,chattr,cksum,cp,find,fish,\n";
|
|
print " fish-tcp,io,ln,mcp,meta,mkdir,msum,\n";
|
|
print " rsync,shift-cp,shift-sum,sum,tool})\n";
|
|
print " --restart[=ignore] restart transfer with given --id [ignoring errors]\n";
|
|
print " --search=REGEX show only status/history/last-sum matching REGEX\n";
|
|
print " --state=STATE show status of only those operations in STATE\n";
|
|
print " (STATE one of {done,error,none,queue,run,warn})\n";
|
|
print " --stats[=csv] show stats across all transfers [in CSV form]\n";
|
|
print " --status[=FORMAT] show brief status of all transfers\n";
|
|
print " or detailed status of transfer with given --id\n";
|
|
print " (FORMAT one of {color,csv,pad})\n";
|
|
print " --stop stop transfer with given --id\n";
|
|
print "\n";
|
|
print "Tuning options (defaults in brackets):\n";
|
|
print " --bandwidth=BITS tune TCP-based transports based on BITS per second\n";
|
|
print " (use suffix {k,m,g,t} for {Kb,Mb,Gb,Tb})\n";
|
|
print " --buffer=SIZE use SIZE bytes for buffer in transports\n";
|
|
print " (use suffix {k,m,g,t} for {KiB,MiB,GiB,TiB}) [4m]\n";
|
|
print " --files=COUNT process transfer in batches of at least COUNT files\n";
|
|
print " (use suffix {k,m,b/g,t} for 1E{3,6,9,12}) [1k]\n";
|
|
print " --interval=NUM adjust batches to run for around NUM seconds [30]\n";
|
|
print " --local=LIST set local transport mechanism to one of LIST\n";
|
|
print " (LIST subset of {bbftp,fish,fish-tcp,mcp,rsync,shift})\n";
|
|
print " --preallocate=NUM preallocate files when sparsity under NUM percent\n";
|
|
print " --remote=LIST set remote transport mechanism to one of LIST\n";
|
|
print " (LIST subset of {bbftp,fish,fish-tcp,rsync,shift})\n";
|
|
print " --retry=NUM retry failed operations up to NUM times [2]\n";
|
|
print " --size=SIZE process transfer in batches of at least SIZE bytes\n";
|
|
print " (use suffix {k,m,g,t} for {KB,MB,GB,TB}) [4g]\n";
|
|
print " --split=SIZE parallelize single files using chunks of SIZE bytes\n";
|
|
print " (use suffix {k,m,g,t} for {KiB,MiB,GiB,TiB}) [0]\n";
|
|
print " --split-tar=SIZE create tar files of around SIZE bytes\n";
|
|
print " (use suffix {k,m,g,t} for {KB,MB,GB,TB}) [500g]\n";
|
|
print " --streams=NUM use NUM streams in remote transports [4]\n";
|
|
print " --stripe=[CEXP] choose stripe {count,size,pool} via expr {C,S,P}EXP\n";
|
|
print " [::[SEXP][::PEXP]] (EXP may be NUM, SIZE, or full perl expression w/\n";
|
|
print " const {DR,NM,SZ,SC,SS} for src {is_dir,name,size,scnt,ssz})\n";
|
|
print " (use suffix {k,m,g,t} for {KiB,MiB,GiB,TiB})\n";
|
|
print " --threads=NUM use NUM threads in local transports [4]\n";
|
|
print " --verify-fast verify faster but less safely by reusing src buffer\n";
|
|
print " --window=SIZE use SIZE bytes for window in TCP-based transports\n";
|
|
print " (use suffix {k,m,g,t} for {KB,MB,GB,TB}) [4m]\n";
|
|
print "\n";
|
|
print "Throttling options:\n";
|
|
print " --cpu=NUM throttle local cpu usage at NUM %\n";
|
|
print " --disk=NUM1:NUM2 suspend/resume transfer when target NUM1%/NUM2% full\n";
|
|
print " --io=NUM throttle local i/o usage at NUM MB/s\n";
|
|
print " --ior=NUM throttle local i/o reads at NUM MB/s\n";
|
|
print " --iow=NUM throttle local i/o writes at NUM MB/s\n";
|
|
print " --net=NUM throttle local network usage at NUM MB/s\n";
|
|
print " --netr=NUM throttle local network reads at NUM MB/s\n";
|
|
print " --netw=NUM throttle local network writes at NUM MB/s\n";
|
|
exit;
|
|
}
|
|
|
|
foreach my $opt (qw(bandwidth buffer size split split-tar window)) {
|
|
if ($opts{$opt} && $opts{$opt} !~ /^([1-9]\d*)([kmgt])?$/i) {
|
|
die "Invalid size '$opts{$opt}' for option --$opt\n";
|
|
}
|
|
}
|
|
foreach my $opt (qw(newer older)) {
|
|
if ($opts{$opt} && $opts{$opt} !~ /^\d+$/) {
|
|
my $spec;
|
|
($spec, $opts{$opt}) = ($1, $2)
|
|
if ($opts{$opt} =~ /^([acmACM\|]+:)(.*)/);
|
|
require Date::Parse;
|
|
my $time = Date::Parse::str2time($opts{$opt});
|
|
die "Unable to parse date string '$opts{$opt}'\n" if (!$time);
|
|
$opts{$opt} = (!$opts{'extract-tar'} && $spec ? $spec : "") . $time;
|
|
}
|
|
}
|
|
if (defined $opts{include}) {
|
|
foreach (@{$opts{include}}) {
|
|
die "Invalid regular expression '$_' in --include\n"
|
|
if (!eval {qr/$_/});
|
|
}
|
|
}
|
|
if (defined $opts{exclude}) {
|
|
foreach (@{$opts{exclude}}) {
|
|
die "Invalid regular expression '$_' in --exclude\n"
|
|
if (!eval {qr/$_/});
|
|
}
|
|
}
|
|
if (defined $opts{stripe}) {
|
|
my $i;
|
|
foreach my $e (split(/::/, $opts{stripe})) {
|
|
$_ = $e;
|
|
next if ($i == 2 && /^[\w.-]+$/);
|
|
s/(DR|NM|SZ|SC|SS|[1-9]\d*[kmgt])/1/g;
|
|
eval;
|
|
die "Invalid expression '$e' in --stripe\n" if ($@);
|
|
$i++;
|
|
}
|
|
}
|
|
|
|
# create single temporary directory
|
|
$opts{sftp_d} = tempdir("mesh-XXXXXXXX", DIR => $opts{tmp_d});
|
|
require Net::SFTP::Foreign;
|
|
|
|
# process arguments
|
|
if (!$opts{id}) {
|
|
my ($logfh, $log) = sftp_tmp();
|
|
$opts{logfh} = $logfh;
|
|
|
|
# send options
|
|
foreach (qw(bandwidth buffer clients command cpu create-tar cron
|
|
dereference disk extract-tar files force host-list hosts
|
|
ignore-times index-tar interval io ior iow local mail net
|
|
netr netw newer offline older pipeline ports preallocate
|
|
preserve recall remote retry sanity secure silent size split
|
|
split-tar streams stripe sync threads verify verify-fast
|
|
wait window)) {
|
|
print $logfh "args=getopt,$_ text=", escape($opts{$_}), "\n"
|
|
if (defined $opts{$_});
|
|
}
|
|
foreach (qw(exclude include)) {
|
|
print $logfh "args=getopt,$_ text=", escape(nfreeze($opts{$_})), "\n"
|
|
if (defined $opts{$_});
|
|
}
|
|
# send current directory
|
|
print $logfh "args=getopt,cwd text=", escape(getcwd()), "\n";
|
|
# indicate all options sent
|
|
print $logfh "args=getopt,end\n";
|
|
|
|
print "Reading argument lines from stdin...\n" if (scalar(@ARGV) == 0);
|
|
my $nfiles;
|
|
if (scalar(@ARGV) > 0) {
|
|
$nfiles += shift_args($host, \@ARGV);
|
|
} else {
|
|
while (my $line = <STDIN>) {
|
|
$line =~ s/^\s+|\s+$//g;
|
|
my @args = quotewords('\s+', 0, $line);
|
|
$nfiles += shift_args($host, \@args);
|
|
}
|
|
}
|
|
close $logfh;
|
|
if ($nfiles > 0) {
|
|
$opts{id} = shift_mgr("--host=$host --put", $log);
|
|
unlink $log;
|
|
die "${$opts{id}}\n" if (ref $opts{id});
|
|
$opts{id} =~ s/\s+$//;
|
|
print "Shift id is $opts{id}\n";
|
|
STDOUT->flush;
|
|
} else {
|
|
unlink $log;
|
|
print $usage;
|
|
exit 1;
|
|
}
|
|
} elsif (defined $opts{restart}) {
|
|
# send options that can be respecified
|
|
my ($logfh, $log) = sftp_tmp();
|
|
foreach (qw(bandwidth buffer clients cpu cron disk files force host-list
|
|
hosts interval io ior iow local mail net netr netw offline
|
|
pipeline ports preallocate recall remote retry secure silent
|
|
size streams stripe threads window)) {
|
|
print $logfh "args=getopt,$_ text=", escape($opts{$_}), "\n"
|
|
if ($in_opts{$_});
|
|
}
|
|
# indicate all options sent
|
|
print $logfh "args=getopt,end\n";
|
|
close $logfh;
|
|
my $extra = $opts{restart} ? "=$opts{restart}" : "";
|
|
my $out = shift_mgr(
|
|
"--restart$extra --id=$opts{id} --host=$host --put", $log);
|
|
unlink $log;
|
|
die "$$out\n" if (ref $out);
|
|
} elsif (!defined $opts{pid}) {
|
|
print $usage;
|
|
exit 1;
|
|
}
|
|
|
|
# this will either start a child or do nothing if one already started
|
|
my $pid = shift_loop();
|
|
|
|
# prevent cleanup
|
|
$opts{sftp_d} = undef;
|
|
|
|
# extra clients do not wait
|
|
POSIX::_exit(0) if ($opts{id} =~ /\D/);
|
|
|
|
if ($opts{wait}) {
|
|
print "Waiting for transfer to complete...";
|
|
STDOUT->flush;
|
|
# set exit to 1 in case killed while waiting
|
|
$? = 1;
|
|
if (defined $opts{monitor}) {
|
|
print "\n\n\n";
|
|
STDOUT->flush;
|
|
my $monitor = $opts{monitor} ? "=$opts{monitor}" : "";
|
|
shift_mgr("--monitor$monitor --id=$opts{id}");
|
|
}
|
|
waitpid($pid, 0);
|
|
my $out = shift_mgr("--status --state=none --id=$opts{id}");
|
|
if (defined $opts{monitor}) {
|
|
print "\e[1A\e[K" foreach (1 .. 5);
|
|
}
|
|
print "\n\n", (ref $out ? $$out : $out);
|
|
STDOUT->flush;
|
|
POSIX::_exit(1) if ($out !~ /done/);
|
|
} else {
|
|
print STDERR "Detaching process (use --status or --monitor to track progress)\n";
|
|
}
|
|
# use _exit to avoid END block processing
|
|
POSIX::_exit(0);
|
|
}
|
|
|
|
####################
|
|
#### shift_args ####
|
|
####################
|
|
sub shift_args {
|
|
my ($host, $args) = @_;
|
|
my $logfh = $opts{logfh};
|
|
my @args = @{$args};
|
|
|
|
my $dst = pop(@args);
|
|
my ($dhost, $dpath) = hostpath($dst);
|
|
my ($dmode, $nfiles, $test);
|
|
if ($dhost ne 'localhost') {
|
|
# remote dst
|
|
$dhost = fqdn($dhost);
|
|
if (!sftp($dhost)->stat($dpath)) {
|
|
if (sftp($dhost)->stat("$dpath-1.tar")) {
|
|
# check that first split tar does not exist
|
|
die "split/tmp file $dst-1.tar exists or is a directory\n";
|
|
}
|
|
# dst does not exist so use parent directory
|
|
my $dir = dirname($dpath);
|
|
if ($opts{directory}) {
|
|
# make parent directories if requested
|
|
die "Unable to create missing parent directories\n"
|
|
if (!sftp($dhost)->mkpath($dir));
|
|
}
|
|
if ($opts{'extract-tar'}) {
|
|
# make dst if extracting tar
|
|
sftp($dhost)->mkdir($dpath);
|
|
my $dattrs = sftp($dhost)->stat($dpath);
|
|
$dmode = $dattrs->perm if (defined $dattrs);
|
|
}
|
|
$test = "$dir/__shift_test__";
|
|
# reconstruct dpath using real path of parent
|
|
my $absdir = sftp($dhost)->realpath($dir);
|
|
$dpath = "$absdir/" . basename($dpath) if (defined $absdir);
|
|
} else {
|
|
die "$dst exists or is a directory\n" if ($opts{'create-tar'});
|
|
$test = sftp($dhost)->realpath($dpath);
|
|
$dpath = $test if ($test);
|
|
my $dattrs = sftp($dhost)->stat($dpath);
|
|
$dmode = $dattrs->perm if (defined $dattrs);
|
|
if (S_ISDIR($dmode)) {
|
|
$test .= "/";
|
|
} elsif (defined $dmode) {
|
|
die "$dst is not writable\n"
|
|
if (!($dmode & (S_IWUSR | S_IWGRP | S_IWOTH)));
|
|
}
|
|
# use different file name to avoid accidental DMF recall
|
|
$test .= "__shift_test__";
|
|
}
|
|
|
|
# check writability
|
|
my $fh = sftp($dhost)->open($test, SFTP_CREAT | SFTP_WRITE);
|
|
die "$dhost is currently inaccessible or $dst\nis not writable, not authorized for writes, or parent directory missing\n"
|
|
if (!$fh);
|
|
close $fh;
|
|
sftp($dhost)->remove($test);
|
|
$dst = hostpath($dhost, $dpath);
|
|
#TODO: error handling if can't remove
|
|
} else {
|
|
# local dst
|
|
# abs_path(/foo)=/foo but abs_path(/foo/)=undef for non-existent /foo
|
|
$dpath =~ s/(.+)\/+$/$1/;
|
|
$dst = abs_path($dpath);
|
|
if ($opts{'create-tar'}) {
|
|
die "$dst exists or is a directory\n" if (-e $dst);
|
|
# check that first split tar does not exist
|
|
die "split/tmp file $dst-1.tar exists or is a directory\n"
|
|
if (-e "$dst-1.tar");
|
|
}
|
|
if (!defined $dst && $opts{directory}) {
|
|
# make parent directories if requested
|
|
die "Unable to create missing parent directories: $!\n"
|
|
if (!defined eval {mkpath(dirname($dpath))});
|
|
$dst = abs_path($dpath);
|
|
} elsif (!defined $dst) {
|
|
die "Parent directory of $dpath does not exist\n";
|
|
}
|
|
if (! -e $dst && $opts{'extract-tar'}) {
|
|
# make dst if extracting tar
|
|
mkdir($dpath);
|
|
$dst = abs_path($dpath);
|
|
}
|
|
$dmode = (stat($dst))[2];
|
|
# check writability
|
|
$test = $dst;
|
|
if (S_ISDIR($dmode)) {
|
|
$test .= "/";
|
|
} elsif (defined $dmode) {
|
|
die "$dst is not writable\n"
|
|
if (!($dmode & (S_IWUSR | S_IWGRP | S_IWOTH)));
|
|
}
|
|
# use different file name to avoid accidental DMF recall
|
|
$test .= "__shift_test__";
|
|
die "$dst is not writable\n" if (!open(FILE, '>', $test));
|
|
close FILE;
|
|
unlink $test;
|
|
}
|
|
if (!S_ISDIR($dmode)) {
|
|
die "$dst is not a directory\n" if (!$opts{'create-tar'} &&
|
|
(scalar(@args) > 1 || $opts{'extract-tar'}));
|
|
}
|
|
|
|
# dereference links, check for errors, and expand wildcards
|
|
foreach my $src (@args) {
|
|
my $noglob;
|
|
if (ref $src) {
|
|
# only glob once
|
|
$noglob = 1;
|
|
$src = $src->[0];
|
|
}
|
|
my ($shost, $spath) = hostpath($src);
|
|
my $tar_name = $spath;
|
|
my $sdir;
|
|
if ($shost ne 'localhost') {
|
|
# remote src
|
|
if ($dhost ne 'localhost') {
|
|
die "Transfers between remote hosts are not supported\n";
|
|
}
|
|
# check for wildcards
|
|
if (!$noglob && $spath =~ /[[*?]/) {
|
|
my @glob = eval {sftp($shost)->glob($spath)};
|
|
if (scalar @glob > 0) {
|
|
# process expanded pathnames and ignore this arg
|
|
push(@args, map {[hostpath($shost, $_->{filename})]} @glob);
|
|
next;
|
|
}
|
|
}
|
|
$shost = fqdn($shost);
|
|
$sdir = sftp($shost)->realpath(dirname($spath));
|
|
} elsif (!$noglob && scalar(@ARGV) == 0 && $spath =~ /[[*?]/) {
|
|
# expand local wildcards given over stdin
|
|
my @glob = eval {glob $spath};
|
|
if (scalar @glob > 0) {
|
|
# process expanded pathnames and ignore this arg
|
|
push(@args, map {[hostpath($shost, $_)]} @glob);
|
|
next;
|
|
}
|
|
} else {
|
|
# local src
|
|
$sdir = abs_path(dirname($src));
|
|
}
|
|
# resolve src dir to absolute path but keep base name the same
|
|
my $base = basename($spath);
|
|
$sdir .= "/" if ($sdir !~ /\/$/);
|
|
# if trailing slash on dir link, then resolve top level
|
|
# even if --no-dereference is specified per posix spec
|
|
my $slash = $src =~ /.\/$/ ? 1 : 0;
|
|
$spath = $sdir . $base;
|
|
|
|
my ($smode, $lsmode);
|
|
if ($shost ne 'localhost') {
|
|
# remote src
|
|
my $sattrs = sftp($shost)->stat($spath);
|
|
$smode = $sattrs->perm if (defined $sattrs);
|
|
$sattrs = sftp($shost)->lstat($spath);
|
|
$lsmode = $sattrs->perm if (defined $sattrs);
|
|
} else {
|
|
# local src
|
|
$smode = (stat($spath))[2];
|
|
$lsmode = (lstat($spath))[2];
|
|
}
|
|
|
|
if (S_ISLNK($lsmode) && ($slash || !S_ISDIR($smode) &&
|
|
!$opts{'no-dereference'})) {
|
|
# resolve file symlinks and dir symlinks with slash by default
|
|
my $abs = $shost ne 'localhost' ?
|
|
sftp($shost)->realpath($spath) : abs_path($spath);
|
|
if ($shost ne 'localhost') {
|
|
my $fattrs = sftp($shost)->stat($abs);
|
|
# keep dangling links as is
|
|
$abs = undef if (!defined $fattrs);
|
|
} else {
|
|
# keep dangling links as is
|
|
$abs = undef if (! -e $abs);
|
|
}
|
|
$spath = $abs if ($abs);
|
|
} else {
|
|
$smode = $lsmode;
|
|
}
|
|
|
|
if (!defined $smode) {
|
|
print STDERR "$src: No such file or directory\n";
|
|
next;
|
|
}
|
|
if (!S_ISDIR($smode) && !S_ISREG($smode) && !S_ISLNK($smode)) {
|
|
print STDERR "Skipping unsupported file $src\n";
|
|
next;
|
|
}
|
|
if (S_ISDIR($smode) && (!S_ISLNK($smode) || $slash) &&
|
|
!$opts{recursive}) {
|
|
print STDERR "$src is a directory\n";
|
|
next;
|
|
}
|
|
if (S_ISDIR($smode) && (!S_ISLNK($smode) || $slash) &&
|
|
defined $dmode && !S_ISDIR($dmode) &&
|
|
!$opts{'create-tar'}) {
|
|
print STDERR "$dst is a file\n";
|
|
next;
|
|
}
|
|
if ((!S_ISDIR($smode) || S_ISLNK($smode) && !$slash) &&
|
|
defined $dmode && S_ISDIR($dmode) &&
|
|
$opts{'no-target-directory'} && !$opts{'extract-tar'}) {
|
|
print STDERR
|
|
"Cannot overwrite directory $dst with non-directory\n";
|
|
next;
|
|
}
|
|
if (S_ISDIR($smode) && (!S_ISLNK($smode) || $slash) &&
|
|
defined $dmode && !S_ISDIR($dmode) &&
|
|
$opts{'no-target-directory'}) {
|
|
print STDERR
|
|
"Cannot overwrite non-directory $dst with directory\n";
|
|
next;
|
|
}
|
|
|
|
if (S_ISREG($smode)) {
|
|
# check readability
|
|
if ($shost ne 'localhost') {
|
|
my $test = sftp($shost)->open($spath, SFTP_READ);
|
|
if (!$test) {
|
|
print STDERR
|
|
"$src is not readable or not authorized for reads\n";
|
|
next;
|
|
}
|
|
close $test if ($test);
|
|
} else {
|
|
if (!open(FILE, '<', $spath)) {
|
|
print STDERR "$src is not readable\n";
|
|
next;
|
|
}
|
|
close FILE;
|
|
}
|
|
}
|
|
|
|
my $dbase;
|
|
if (!$opts{'extract-tar'} && defined $dmode &&
|
|
(!S_ISDIR($smode) && S_ISDIR($dmode) ||
|
|
S_ISDIR($smode) && !$opts{'no-target-directory'})) {
|
|
$dbase = "/" . basename($spath);
|
|
if ($spath eq "$dst$dbase") {
|
|
print STDERR "$src and $dpath$dbase are the same file\n";
|
|
next;
|
|
}
|
|
} elsif ($spath eq $dst) {
|
|
print STDERR "$src and $dpath are the same file\n";
|
|
next;
|
|
}
|
|
print $logfh "args=find,", escape(hostpath($shost, $spath)), ",",
|
|
escape($dst . $dbase);
|
|
print $logfh " tar_name=" . escape($tar_name) if ($opts{'create-tar'});
|
|
print $logfh " host=$host\n";
|
|
$nfiles++;
|
|
}
|
|
return $nfiles;
|
|
}
|
|
|
|
####################
|
|
#### shift_cron ####
|
|
####################
|
|
sub shift_cron {
|
|
#TODO: cron job will never exit if doesn't pass first checks (e.g. invalid key)
|
|
# install crontab
|
|
my $tab;
|
|
my $fhpid = open3_run([-1, undef, -1], "crontab -l");
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
# ignore garbage added by crontab
|
|
next if (/^#.*(?:edit the master|installed on|Cron(ie)? version)/);
|
|
$tab .= $_;
|
|
}
|
|
open3_wait($fhpid);
|
|
# replace pid if entry already exists in crontab
|
|
if ($tab !~ s/(--id=$opts{id}\s+--pid=)\d+/$1$$/) {
|
|
# construct new crontab entry
|
|
$tab .= "\n*/10 * * * * $opts{abs0}";
|
|
if (basename($opts{abs0}) !~ /^shift/) {
|
|
$tab .= " -u $opts{u}" if ($opts{u});
|
|
my $mp = escape($opts{p});
|
|
$tab .= " -b -p $mp shift";
|
|
}
|
|
if ($opts{mgr}) {
|
|
my $mgr = escape($opts{mgr});
|
|
# percent needs to be escaped in crontab
|
|
$mgr =~ s/%/\\%/g;
|
|
$tab .= " --mgr=$mgr";
|
|
}
|
|
if ($opts{'mgr-user'}) {
|
|
my $user = escape($opts{'mgr-user'});
|
|
# percent needs to be escaped in crontab
|
|
$user =~ s/%/\\%/g;
|
|
$tab .= " --mgr-user=$user";
|
|
}
|
|
$tab .= " --mgr-identity=" . $opts{'mgr-identity'}
|
|
if ($opts{'mgr-identity'});
|
|
$tab .= " --identity=$opts{identity}" if ($opts{identity});
|
|
$tab .= " --user=$opts{user}" if ($opts{user});
|
|
# use >& so will be portable across csh/bash
|
|
$tab .= " --id=$opts{id} --pid=$$ >&/dev/null\n";
|
|
}
|
|
my ($fh, $file) = tempfile();
|
|
print $fh $tab;
|
|
close $fh;
|
|
open3_get([-1, -1, -1], "crontab $file");
|
|
$opts{cron} = 0 if ($?);
|
|
unlink $file;
|
|
# record that crontab now exists
|
|
$opts{crontab} = 1;
|
|
}
|
|
|
|
#######################
|
|
#### shift_latency ####
|
|
#######################
|
|
sub shift_latency {
|
|
my $rtthost = shift;
|
|
|
|
my ($np, $nps);
|
|
my %rtts;
|
|
|
|
foreach my $host (keys %{$rtthost}) {
|
|
next if ($host eq 'localhost' || $rtts{$host});
|
|
# compute round trip times for tcp tuning
|
|
my ($rc, $time);
|
|
if ($^O eq 'MSWin32') {
|
|
# try icmp ping command first
|
|
my $fhpid = open3_run([-1, undef, -1],
|
|
"ping", "-n", "1", "-w", "2", $host);
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
if (/Average\s*=\s*(\d+)\s*ms/) {
|
|
# convert milliseconds to seconds
|
|
$time = $1 / 1000;
|
|
last if ($time > 0);
|
|
}
|
|
}
|
|
open3_wait($fhpid);
|
|
$rc = $? >> 8;
|
|
$rc = ($rc >= 1 && $rc <= 2) ? -1 : 0;
|
|
} else {
|
|
# try icmp ping command first
|
|
my $fhpid = open3_run([-1, undef, -1], "ping", "-c1", "-W2", $host);
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
if (/[^\/]([\d.]+)\//) {
|
|
# convert milliseconds to seconds
|
|
$time = $1 / 1000;
|
|
last if ($time > 0);
|
|
}
|
|
}
|
|
open3_wait($fhpid);
|
|
$rc = $? >> 8;
|
|
$rc = ($rc >= 1 && $rc <= 2) ? -1 : 0;
|
|
}
|
|
if (!$time) {
|
|
# use tcp echo port as backup to icmp ping
|
|
if (!$np) {
|
|
# redhat/centos do not have core Time::HiRes by default
|
|
eval {
|
|
require Net::Ping;
|
|
$np = Net::Ping->new;
|
|
$np->hires;
|
|
};
|
|
next if (!$np);
|
|
}
|
|
eval {
|
|
# there may still be an exception from undefined subroutine
|
|
(undef, $time) = $np->ping($host);
|
|
$rc = $time ? 0 : -1;
|
|
};
|
|
|
|
if (!$time) {
|
|
# use ssh syn ping as backup to tcp echo port
|
|
if (!$nps) {
|
|
# redhat/centos do not have core Time::HiRes by default
|
|
eval {
|
|
require Net::Ping;
|
|
$nps = Net::Ping->new('syn');
|
|
$nps->hires;
|
|
$nps->port_number(22);
|
|
};
|
|
next if (!$nps);
|
|
}
|
|
eval {
|
|
# there may still be an exception from undefined subroutine
|
|
$nps->ping($host);
|
|
(undef, $time) = $nps->ack;
|
|
$rc = $time ? 0 : -1;
|
|
};
|
|
}
|
|
}
|
|
if ($time || $rc) {
|
|
$rtts{$host} = $time ? $time : $rc;
|
|
}
|
|
}
|
|
|
|
return scalar(keys %rtts) > 0 ? "args=latency " . join(" ",
|
|
(map {"$_=$rtts{$_}"} keys(%rtts))) . "\n" : undef;
|
|
}
|
|
|
|
####################
|
|
#### shift_load ####
|
|
####################
|
|
sub shift_load {
|
|
my ($load, $actual, $estimated, $diskfs) = @_;
|
|
|
|
# find number of cpus on the first call
|
|
if (!defined $load->{cpus}) {
|
|
if ($^O =~ /^(?:linux|cygwin)$/ && open(FILE, "/proc/stat")) {
|
|
while (my $line = <FILE>) {
|
|
$load->{cpus}++ if ($line =~ s/^cpu\d+\s+//);
|
|
}
|
|
close FILE;
|
|
} elsif ($^O eq 'MSWin32') {
|
|
} elsif ($^O =~ /bsd/) {
|
|
$load->{cpus} = open3_get([-1, undef, -1], "sysctl -n hw.ncpu");
|
|
}
|
|
$load->{cpus} =~ s/^\s+|\s+$//g;
|
|
$load->{cpus} = 1 if (!$load->{cpus});
|
|
}
|
|
|
|
# clear previous load
|
|
$load->{cpu} = 0;
|
|
|
|
# update ratio of actual size to estimated size
|
|
$load->{ratio} = $estimated ? $actual / $estimated : -1;
|
|
|
|
# update time
|
|
my $time_t = time;
|
|
$load->{time_t} = $time_t if (!defined $load->{time_t});
|
|
$load->{time} = $time_t - $load->{time_t};
|
|
$load->{time} = 1 if ($load->{time} < 1);
|
|
$load->{time_t} = $time_t;
|
|
|
|
# update cpu load
|
|
if ($^O ne 'MSWin32') {
|
|
my $cpu = open3_get([-1, undef, -1], "ps S -o %cpu -p $$");
|
|
$load->{cpu} = $1 if ($cpu =~ /%CPU\s*([\d.]+)/);
|
|
# adjust percentage for number of cpus
|
|
$load->{cpu} /= $load->{cpus};
|
|
}
|
|
|
|
# update disk capacity and availability
|
|
my (%disk_left, %disk_used);
|
|
foreach my $rpath (keys %{$diskfs}) {
|
|
my ($host, $path) = hostpath($rpath);
|
|
my $ref = {};
|
|
vdf($ref, $host, $path, {-argv => []});
|
|
if ($ref->{text} =~ /(\d+)\s+(\d+)\s+\d+%/) {
|
|
$disk_used{$diskfs->{$rpath}} = $1;
|
|
$disk_left{$diskfs->{$rpath}} = $2;
|
|
}
|
|
}
|
|
|
|
return "args=load " . join(" ",
|
|
(map {"$_=$load->{$_}"} qw(cpu ratio time)),
|
|
(map {"left_$_=$disk_left{$_}"} keys(%disk_left)),
|
|
(map {"used_$_=$disk_used{$_}"} keys(%disk_used))) . "\n";
|
|
}
|
|
|
|
####################
|
|
#### shift_loop ####
|
|
####################
|
|
# perform various interactions with shift manager to transfer files
|
|
sub shift_loop {
|
|
# detach process
|
|
my $pid = fork;
|
|
return $pid if ($pid);
|
|
|
|
# detach process
|
|
close STDIN;
|
|
close STDOUT;
|
|
close STDERR;
|
|
setsid;
|
|
open(STDIN, "</dev/null");
|
|
open(STDOUT, ">/dev/null");
|
|
open(STDERR, ">/dev/null");
|
|
|
|
my ($logfh, $log) = sftp_tmp();
|
|
$opts{logfh} = $logfh;
|
|
my ($taskfh, $task) = sftp_tmp();
|
|
close $taskfh;
|
|
|
|
my $host = fqdn(hostname);
|
|
my $load = {};
|
|
my @rop = ('get', 'put');
|
|
my ($size, $rsize);
|
|
my $diskfs0 = {};
|
|
my $diskfs = {};
|
|
my $rtthost = {};
|
|
|
|
# use catchall exception handler to report client failures
|
|
$SIG{__DIE__} = sub {
|
|
our @exception = @_ if (defined $^S && !$^S);
|
|
};
|
|
END {
|
|
our @exception;
|
|
if (@exception) {
|
|
my $text = localtime(time) . ": @exception";
|
|
chomp $text;
|
|
print $logfh "args=exception text=", escape($text);
|
|
close $logfh;
|
|
shift_mgr("--id=$opts{id} --host=$host --put $opts{get_host}", $log);
|
|
}
|
|
}
|
|
|
|
# first client sends static host info
|
|
if ($opts{id} !~ /\D/) {
|
|
# send client environment
|
|
my $env = "$VERSION:$^O:$]";
|
|
$env .= ":bin" if (first {-x "$_/shift-bin"} (split(/:/, $ENV{PATH})));
|
|
foreach (qw(ssl threads)) {
|
|
$env .= ":$_" if ($perl{$_});
|
|
}
|
|
$env .= shift_networks($host);
|
|
print $logfh "args=env text=$env\n";
|
|
# send file system information
|
|
print $logfh shift_mounts($host);
|
|
}
|
|
|
|
TASK: while (1) {
|
|
# add load to results for throttling
|
|
print $logfh shift_load($load, $size, $rsize, $diskfs);
|
|
# add latency results for autotuning
|
|
print $logfh shift_latency($rtthost);
|
|
$size = 0;
|
|
$rsize = 0;
|
|
$diskfs0 = $diskfs;
|
|
$diskfs = {};
|
|
$rtthost = {};
|
|
|
|
# retrieve next batch for processing
|
|
close $logfh;
|
|
my $out = shift_mgr(
|
|
"--id=$opts{id} --host=$host --pid=$$ --get --put $opts{get_host}",
|
|
$log, $task, 1);
|
|
die "$$out\n" if (ref $out);
|
|
#TODO: error checking if id doesn't exist
|
|
open($logfh, '>', $log);
|
|
$opts{logfh} = $logfh;
|
|
|
|
my $run = time;
|
|
my %ops;
|
|
open($taskfh, '<', $task);
|
|
while (my $line = <$taskfh>) {
|
|
$line =~ s/\s+$//;
|
|
$_ = $line;
|
|
s/=/ /g;
|
|
my %op = split(/\s+/);
|
|
my @args = split(/,/, $op{args});
|
|
my $cmd = shift @args;
|
|
if ($cmd eq 'client') {
|
|
# check that id is in expected format
|
|
next if ($args[0] !~ /^\d+\.\d+$/);
|
|
my $cmd = $opts{abs0};
|
|
if (basename($opts{abs0}) !~ /^shift/) {
|
|
$cmd .= " -u $opts{u}" if ($opts{u});
|
|
my $mp = escape($opts{p});
|
|
$cmd .= " -b -p $mp shift";
|
|
}
|
|
$cmd .= " --mgr=" . escape($opts{mgr}) if ($opts{mgr});
|
|
$cmd .= " --mgr-user=" . escape($opts{'mgr-user'})
|
|
if ($opts{'mgr-user'});
|
|
$cmd .= " --id=$args[0] --pid=-1";
|
|
open3_get([-1, -1], $cmd);
|
|
if ($?) {
|
|
$op{state} = "error";
|
|
$op{text} = escape("Client spawn '$cmd' failed");
|
|
print $logfh
|
|
join(" ", map {"$_=$op{$_}"} sort(keys(%op))) . "\n";
|
|
}
|
|
} elsif ($cmd eq 'getopt') {
|
|
# check validity of option
|
|
if ($args[0] =~ /^(?:local|remote)$/) {
|
|
my %have = (fish => 1, 'fish-tcp' => 1, 'shift' => 1);
|
|
foreach my $t (split(/,/, $op{text}), "bbftpd", $opts{caux}) {
|
|
next if ($t =~ /^(shift|fish(-tcp)?)$/);
|
|
foreach my $path (split(/:/, $ENV{PATH})) {
|
|
if (-x "$path/$t" ||
|
|
$t =~ /^fish(-tcp)$/ && -x "$path/$opts{caux}") {
|
|
$have{$t} = 1;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
# bbftp requires bbftpd for local transfers
|
|
delete $have{bbftp}
|
|
if ($args[0] eq 'local' && !$have{bbftpd});
|
|
# fish/fish-tcp require shift-aux for local transfers
|
|
if ($args[0] eq 'local' && !$have{$opts{caux}}) {
|
|
delete $have{fish};
|
|
delete $have{'fish-tcp'};
|
|
}
|
|
# fish-tcp requires perl with threads
|
|
if (!$perl{threads}) {
|
|
delete $have{'fish-tcp'};
|
|
}
|
|
$opts{$args[0]} = [];
|
|
foreach (split(/,/, $op{text})) {
|
|
push(@{$opts{$args[0]}}, $_) if ($have{$_});
|
|
}
|
|
} elsif ($args[0] =~ /^disk_(\S+)$/) {
|
|
$diskfs->{$1} = $op{text};
|
|
} elsif ($args[0] =~ /^rtt_(\S+)$/) {
|
|
$rtthost->{$1} = 1;
|
|
} elsif ($args[0] =~ /^(?:exclude|include)$/) {
|
|
$opts{$args[0]} = thaw(unescape($op{text}));
|
|
} elsif ($args[0] =~ /^(?:bandwidth|buffer|create-tar|cron|dereference|extract-tar|find-files|force|get_host|ignore-times|index-tar|newer|offline|older|opts_bbftp|opts_mcp|opts_msum|opts_ssh|ports|preallocate|preserve|recall|sanity|secure|streams|stripe|stripe-pool|stripe-size|sum_split|sum_type|sync|sync_host|threads|window|verify|verify-fast)$/) {
|
|
$opts{$args[0]} = defined $op{text} ?
|
|
unescape($op{text}) : 1;
|
|
}
|
|
} elsif ($cmd eq 'host') {
|
|
# check that host is in expected format
|
|
next if ($args[0] !~ /^[\w.-]+$/);
|
|
my $rcmd = "ssh -axq -oBatchMode=yes $args[0] $opts{base0}";
|
|
if ($opts{base0} !~ /^shift/) {
|
|
$rcmd .= " -u $opts{u}" if ($opts{u});
|
|
my $mp = escape($opts{p});
|
|
$rcmd .= " -b -p $mp shift";
|
|
}
|
|
$rcmd .= " --mgr=" . escape($opts{mgr}) if ($opts{mgr});
|
|
$rcmd .= " --mgr-user=" . escape($opts{'mgr-user'})
|
|
if ($opts{'mgr-user'});
|
|
$rcmd .= " --mgr-identity=" . $opts{'mgr-identity'}
|
|
if ($opts{'mgr-identity'});
|
|
$rcmd .= " --identity=$opts{identity}" if ($opts{identity});
|
|
$rcmd .= " --user=$opts{user}" if ($opts{user});
|
|
$rcmd .= " --no-cron" if (!$opts{cron});
|
|
$rcmd .= " --id=$opts{id} --pid=-1";
|
|
open3_get([-1, -1], $rcmd);
|
|
if ($?) {
|
|
$op{state} = "error";
|
|
$op{text} = escape("Host spawn '$rcmd' failed");
|
|
print $logfh
|
|
join(" ", map {"$_=$op{$_}"} sort(keys(%op))) . "\n";
|
|
}
|
|
} elsif ($cmd eq 'sleep') {
|
|
# keep previous diskfs so same disk loads computed after sleep
|
|
$diskfs = $diskfs0;
|
|
sleep $args[0];
|
|
next TASK;
|
|
} elsif ($cmd eq 'stop') {
|
|
close $logfh;
|
|
close $taskfh;
|
|
unlink $log;
|
|
unlink $task;
|
|
shift_stop();
|
|
} else {
|
|
$ops{$line} = \%op;
|
|
delete $op{state};
|
|
delete $op{text};
|
|
$op{tar_name} = unescape($op{tar_name}) if ($op{tar_name});
|
|
my (@rhost, @rpath);
|
|
if ($cmd =~ /^(?:c[hk]attr)/) {
|
|
# chattr index must be -1 since used with both 1 and 2 args
|
|
my ($rhost, $rpath) = hostpath(unescape($args[-1]));
|
|
# record original src for tar validation
|
|
$op{src} = unescape($args[0]) if (scalar(@args) > 1);
|
|
transport($cmd, $rhost, undef, $rpath, \%op);
|
|
} elsif ($cmd eq 'cksum') {
|
|
my $rindex = 1;
|
|
my $local = 1;
|
|
foreach my $i (0..1) {
|
|
($rhost[$i], $rpath[$i]) = hostpath(unescape($args[$i]));
|
|
if ($rhost[$i] ne 'localhost') {
|
|
$rindex = $i;
|
|
$local = 0;
|
|
}
|
|
}
|
|
# record if local or not for i/o throttling
|
|
$op{local} = $local;
|
|
# must cksum src if src was mapped from remote to local
|
|
$rindex = 0 if ($op{map0});
|
|
# record remote host index to determine offset in tar case
|
|
$op{rindex} = $rindex;
|
|
transport($cmd, $rhost[$rindex], undef, $rpath[$rindex], \%op);
|
|
$rsize += $op{size};
|
|
} elsif ($cmd eq 'cp') {
|
|
my $rindex = 1;
|
|
foreach my $i (0..1) {
|
|
($rhost[$i], $rpath[$i]) = hostpath(unescape($args[$i]));
|
|
$rindex = $i if ($rhost[$i] ne 'localhost');
|
|
}
|
|
transport($rop[$rindex], $rhost[$rindex], $rpath[0], $rpath[1], \%op);
|
|
$rsize += $op{size};
|
|
if ($op{suspend}) {
|
|
# disk overrun protection
|
|
my $du;
|
|
# calculate real disk usage of file
|
|
if ($rhost[1] eq 'localhost') {
|
|
$du = 512 * (lstat($rpath[1]))[12];
|
|
} else {
|
|
my ($fh, $tmp) = sftp_tmp();
|
|
print $fh "host " . escape($rpath[1]) . " /tmp ref";
|
|
close $fh;
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
my $out = open3_get([$tmp, undef],
|
|
"$opts{ssh} $rhost[1] $opts{caux} find");
|
|
unlink $tmp;
|
|
if ($out =~ /attrs=(\S*)/) {
|
|
my @attrs = split(/,/, $1);
|
|
$du = $attrs[8];
|
|
} else {
|
|
# must approximate without shift-aux
|
|
my $fattrs = sftp($rhost[1])->lstat($rpath[1]);
|
|
next if (!defined $fattrs);
|
|
$du = $fattrs->size;
|
|
}
|
|
}
|
|
my $left;
|
|
do {
|
|
my $ref = {};
|
|
vdf($ref, $rhost[1], $rpath[1], {-argv => []});
|
|
$left = $1 if ($ref->{text} =~ /(\d+)\s+\d+%/);
|
|
my $out = shift_mgr("--status=csv --state=none --id=$opts{id}");
|
|
exit if ($out =~ /stop/);
|
|
} while ($left && $left + $du < $op{suspend} && sleep 300);
|
|
}
|
|
} elsif ($cmd eq 'find') {
|
|
my ($rhost, $rpath) = hostpath(unescape($args[0]));
|
|
transport($cmd, $rhost, $rpath, unescape($args[1]), \%op);
|
|
} elsif ($cmd eq 'ln') {
|
|
my ($rhost, $rpath) = hostpath(unescape($args[1]));
|
|
transport($cmd, $rhost, unescape($args[0]), $rpath, \%op);
|
|
} elsif ($cmd eq 'mkdir') {
|
|
my ($rhost, $rpath) = hostpath(unescape($args[0]));
|
|
transport($cmd, $rhost, undef, $rpath, \%op);
|
|
} elsif ($cmd eq 'sum') {
|
|
my $rindex = 1;
|
|
foreach my $i (0..1) {
|
|
($rhost[$i], $rpath[$i]) = hostpath(unescape($args[$i]));
|
|
$rindex = $i if ($rhost[$i] ne 'localhost');
|
|
}
|
|
# decrement to reverse remote to local
|
|
$rindex--;
|
|
# record local host index to determine offset in tar case
|
|
$op{lindex} = $rindex;
|
|
transport($cmd, $rhost[$rindex], $rpath[$rindex], undef, \%op);
|
|
$rsize += $op{size};
|
|
}
|
|
}
|
|
}
|
|
close $taskfh;
|
|
#TODO: error if no ops?
|
|
|
|
# check that given ssh options are supported by local openssh client
|
|
if ($opts{opts_ssh} && open3_get([-1, undef], "ssh -V") =~ /openssh/i) {
|
|
if (open3_get([-1, undef], "ssh $opts{opts_ssh}") !~
|
|
/unknown (cipher|mac)|bad ssh2|illegal option/i) {
|
|
# incorporate options into ssh command lines
|
|
$opts{ssh} = $opts{sshTMPL};
|
|
$opts{ssh} =~ s/OPTS_SSH/$opts{opts_ssh}/;
|
|
if ($opts{sshmp}) {
|
|
$opts{sshmp} = $opts{sshmpTMPL};
|
|
$opts{sshmp} =~ s/OPTS_SSH/$opts{opts_ssh}/;
|
|
$opts{ssh} = $opts{sshmp} . " " . $opts{ssh};
|
|
}
|
|
}
|
|
}
|
|
|
|
# handle cron after opts have been received from manager
|
|
shift_cron() if (!$opts{crontab} && $opts{cron} && $opts{id} !~ /\D/);
|
|
|
|
# subtract i/o not actually done due to rsync size/time match
|
|
$size = -transport('end');
|
|
my $time = time - $run;
|
|
my $count;
|
|
while (my ($op, $ref) = each %ops) {
|
|
# add i/o successfully completed
|
|
next if ($ref->{text} =~ /\\[EW]/);
|
|
if ($op =~ /(?:^|\s)args=(?:cp|cksum|sum)(?:,|\s|$)/) {
|
|
$size += $ref->{size};
|
|
} else {
|
|
$count++;
|
|
}
|
|
}
|
|
my $iorate = max(1, $size / max($time, 1));
|
|
my $metarate = max(1, $count / max($time, 1));
|
|
|
|
my $fhpid;
|
|
my %sumfh;
|
|
while (my ($op, $ref) = each %ops) {
|
|
my $cmd = $op =~ /(?:^|\s)args=(\w+)(?:,|\s|$)/ ? $1 : undef;
|
|
my $rate = $cmd =~ /^(?:cp|cksum|sum)$/ ? $iorate : $metarate;
|
|
$op =~ s/(?:state|text)=\S+\s?//g;
|
|
$op =~ s/\s+$//;
|
|
my $text = $ref->{text};
|
|
my $tool = $ref->{tool};
|
|
$tool = " tool=$tool" if ($tool);
|
|
if ($text =~ s/\\H/,/g) {
|
|
$text =~ s/^,//;
|
|
print $logfh "$op state=done$tool time=$time rate=$rate hash=$text\n";
|
|
if ($opts{'index-tar'} && $opts{verify}) {
|
|
if (!defined $fhpid) {
|
|
$fhpid = shift_mgr("--lock");
|
|
$fhpid->[1]->getline if (defined $fhpid);
|
|
#TODO: do something if not "OK"?
|
|
}
|
|
my @args = split(/,/, $ref->{args});
|
|
my $tar = pop @args;
|
|
my ($thost, $tpath) = hostpath(unescape($tar));
|
|
$tpath .= ".sum";
|
|
if (!$sumfh{$tar}) {
|
|
if ($thost ne 'localhost') {
|
|
$sumfh{$tar} = sftp($thost)->open($tpath,
|
|
SFTP_APPEND | SFTP_CREAT | SFTP_WRITE);
|
|
} else {
|
|
open($sumfh{$tar}, '>>', $tpath);
|
|
}
|
|
# prevent undefined value exception in final close
|
|
delete $sumfh{$tar} if (!$sumfh{$tar});
|
|
}
|
|
my $tname = $ref->{tar_name};
|
|
$tname =~ s/(\n|\\)/$1 eq "\n" ? "\\n" : "\\\\"/eg;
|
|
print {$sumfh{$tar}} "$text $tname\n" if ($sumfh{$tar});
|
|
}
|
|
} elsif ($text =~ s/\\E//g) {
|
|
print $logfh "$op state=error$tool text=" . escape($text) . "\n";
|
|
} elsif ($text =~ s/\\W//g) {
|
|
print $logfh "$op state=warn$tool text=" . escape($text) . "\n";
|
|
} else {
|
|
print $logfh "$op state=done$tool time=$time";
|
|
print $logfh " rate=$rate" if ($size > 0 || $rate != $iorate);
|
|
print $logfh "\n";
|
|
}
|
|
}
|
|
open3_wait($fhpid);
|
|
close $_ foreach (values %sumfh);
|
|
# size may be negative if only rsync with no i/o
|
|
$size = 0 if ($size < 0);
|
|
}
|
|
exit;
|
|
}
|
|
|
|
###################
|
|
#### shift_mgr ####
|
|
###################
|
|
sub shift_mgr {
|
|
my ($cmd, $stdin, $stdout, $retry) = @_;
|
|
$cmd =~ s/\s+$//;
|
|
$cmd = "$opts{cmgr} $cmd";
|
|
if ($opts{mgr} ne 'none') {
|
|
if ($opts{p} eq $opts{mgr}) {
|
|
$opts{sshmp} =~ s/^(ssh)/$1 -t/ if ($cmd =~ /--monitor/);
|
|
$cmd = "$opts{sshmp} $cmd";
|
|
} elsif ($opts{p}) {
|
|
$opts{ssh} =~ s/(^|\s)(ssh)/$1$2 -t/g if ($cmd =~ /--monitor/);
|
|
$cmd = "$opts{ssh} $opts{mgr} $cmd";
|
|
} elsif ($opts{mgr}) {
|
|
my $extra;
|
|
$extra .= " -l " . $opts{'mgr-user'} if ($opts{'mgr-user'});
|
|
$extra .= " -i " . $opts{'mgr-identity'} if ($opts{'mgr-identity'});
|
|
$extra .= " -t " if ($cmd =~ /--monitor/);
|
|
$cmd = "ssh -Aqx -oBatchMode=yes $extra $opts{mgr} $cmd";
|
|
}
|
|
}
|
|
$cmd = "su " . $opts{'mgr-user'} . " -c '$cmd'"
|
|
if ($< == 0 && $opts{'mgr-user'} && !$opts{'mgr-identity'});
|
|
$cmd = key_ssh($cmd) if ($opts{p} ne 'none');
|
|
return open3_run([-1, undef, -1], $cmd) if ($cmd =~ /--lock/);
|
|
return system(quotewords('\s+', 0, $cmd))
|
|
if ($cmd =~ /--monitor/ || $cmd =~ /--last-sum/ && $cmd =~ /--search/);
|
|
$stdin = -1 if (!$stdin);
|
|
my $err;
|
|
do {
|
|
my $tmp = sftp_tmp();
|
|
$cmd = key_ssh($cmd) if ($opts{p} ne 'none');
|
|
my $out = open3_get([$stdin, $stdout, $tmp], $cmd);
|
|
if (!WIFEXITED($?) || WEXITSTATUS($?)) {
|
|
open(ERR, '<', $tmp);
|
|
$err .= $_ while (<ERR>);
|
|
chomp $err;
|
|
close ERR;
|
|
unlink $tmp;
|
|
} else {
|
|
unlink $tmp;
|
|
return $out;
|
|
}
|
|
} while ($retry && sleep 60);
|
|
#TODO: more error checking to determine correct action
|
|
return \"Unable to execute \"$cmd\": $err";
|
|
#TODO: needs to stop on its own at some point
|
|
# (e.g. key is expired and can't generate new key)
|
|
}
|
|
|
|
######################
|
|
#### shift_mounts ####
|
|
######################
|
|
sub shift_mounts {
|
|
my $host = shift;
|
|
my %fstab;
|
|
my %mnt = (
|
|
host => $host,
|
|
args => "mount",
|
|
);
|
|
|
|
# check for existence of getfacl
|
|
my $acl = first {-x "$_/getfacl"} (split(/:/, $ENV{PATH}));
|
|
# gather file system information from mount
|
|
my $mnts;
|
|
my $fhpid = open3_run([-1, undef, -1], "mount");
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
$mnt{opts} = /[\(,]ro[\),]/ ? "ro" : "rw";
|
|
# acl support is the default unless explicitly disabled
|
|
$mnt{opts} .= ",acl" if (/[\(,]acl[\),]/ || $acl && !/[\(,]noacl[\),]/);
|
|
$mnt{opts} .= ",dmf" if (/[\(,](dmapi|dmi|xdsm)[\),]/);
|
|
$mnt{opts} .= ",xattr" if (/[\(,]user_xattr[\),]/);
|
|
#TODO: need to escape local and remote?
|
|
(my $dev, $mnt{local}, my $type) = ($1, $2, $3)
|
|
if (/(\S+)\s+on\s+(\S+)\s+type\s+(\S+)/);
|
|
if ($mnt{local}) {
|
|
if ($dev eq 'systemd-1') {
|
|
if (!$fstab{"."} && open(FILE, "/etc/fstab")) {
|
|
$fstab{"."} = 1;
|
|
while (<FILE>) {
|
|
s/^\s+|\s+$//g;
|
|
next if (/^#/);
|
|
my ($dev, $local, $type) = split(/\s+/);
|
|
next if (!$type);
|
|
$fstab{$local} = [$dev, $type];
|
|
}
|
|
close FILE;
|
|
}
|
|
# systemd mounts must be read from fstab
|
|
my $fstab = $fstab{$mnt{local}};
|
|
($dev, $type) = ($fstab->[0], $fstab->[1]);
|
|
next if (!$type);
|
|
}
|
|
# try to avoid NFS hangs by resolving dir but not base
|
|
my ($base, $dir) = fileparse($mnt{local});
|
|
$dir = abs_path($dir);
|
|
$dir =~ s/\/$//;
|
|
$mnt{local} = "$dir/$base";
|
|
}
|
|
if (/server_list=\(([^\)]+)\)/) {
|
|
# cxfs appears as xfs but with server_list set
|
|
$mnt{servers} = join("|", map {fqdn($_)} split(/,/, $1));
|
|
$mnt{remote} = $mnt{local};
|
|
$type = "cxfs";
|
|
} elsif ($dev =~ /^(\S+):([^:]+)$/) {
|
|
# typical form for nfs
|
|
$mnt{remote} = $2;
|
|
$mnt{servers} = $1;
|
|
# lustre may have extra @id and multiple colon-separated servers
|
|
$mnt{servers} =~ s/@\w*//g;
|
|
# lustre may have both commas and colons in @kfi forms
|
|
$mnt{servers} = join("|", map {fqdn($_)} split(/[:,]/, $mnt{servers}));
|
|
} elsif ($type eq 'beegfs') {
|
|
# beegfs servers do not appear in mount output so call beegfs-ctl
|
|
my $srv = open3_get([-1, undef, -1],
|
|
"beegfs-ctl --listnodes --nodetype=management --mount=$mnt{local}");
|
|
next if (!defined $srv);
|
|
chomp $srv;
|
|
# output is host name then id
|
|
my @hosts;
|
|
push(@hosts, fqdn($1)) while ($srv =~ /^([\w-.]+)(\s|$)/mg);
|
|
next if (!scalar(@hosts));
|
|
$mnt{servers} = join("|", @hosts);
|
|
$mnt{remote} = "/" . $mnt{servers};
|
|
} elsif ($type eq 'gpfs') {
|
|
# gpfs servers do not appear in mount output so read config
|
|
if (open(FILE, "/var/mmfs/gen/mmfs.cfg")) {
|
|
while (<FILE>) {
|
|
s/^\s+|\s+$//g;
|
|
if (/^clustername\s+(\S+)/i) {
|
|
$mnt{servers} = $1;
|
|
$mnt{remote} = "/$dev";
|
|
last;
|
|
}
|
|
}
|
|
close FILE;
|
|
}
|
|
next if (!$mnt{servers});
|
|
} elsif ($mnt{opts} =~ /,dmf/) {
|
|
# always report dmf file systems even if local
|
|
$mnt{servers} = $mnt{host};
|
|
$mnt{remote} = $mnt{local};
|
|
} else {
|
|
# ignore local file systems
|
|
next;
|
|
}
|
|
$mnt{opts} = "$type,$mnt{opts}";
|
|
# ensure servers are in same order across all hosts
|
|
$mnt{servers} = join("|", sort(split(/\|/, $mnt{servers})));
|
|
# store hash in single line with space-separated key=val form
|
|
$mnts .= join(" ", map {"$_=$mnt{$_}"} sort(keys(%mnt))) . "\n";
|
|
}
|
|
open3_wait($fhpid);
|
|
|
|
# check if host under PBS control
|
|
my $pbs;
|
|
$fhpid = open3_run([-1, undef, -1], "ps -uroot -ocommand");
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
if (/(?:^|\/)pbs_mom(?:\s|$)/) {
|
|
$pbs = 1;
|
|
last;
|
|
}
|
|
}
|
|
open3_wait($fhpid);
|
|
|
|
# indicate that system is accessible
|
|
$mnts .= "args=shell host=$host" . ($pbs ? " pbs=1" : "") . "\n";
|
|
return $mnts;
|
|
}
|
|
|
|
########################
|
|
#### shift_networks ####
|
|
########################
|
|
sub shift_networks {
|
|
my $net;
|
|
if ($^O eq 'darwin') {
|
|
foreach my $d (qw(rcv snd)) {
|
|
my $tmp = open3_get([-1, undef, -1],
|
|
"sysctl -n net.inet.tcp.auto${d}bufmax");
|
|
chomp $tmp;
|
|
$net = $tmp if ($tmp > $net);
|
|
}
|
|
} else {
|
|
foreach (qw(rmem_max wmem_max)) {
|
|
if (open(FILE, "/proc/sys/net/core/$_")) {
|
|
my $tmp = <FILE>;
|
|
chomp $tmp;
|
|
$net = $tmp if ($tmp > $net);
|
|
close FILE;
|
|
}
|
|
}
|
|
}
|
|
$net = ":tcpwin_$net" if ($net);
|
|
|
|
my $fhpid = open3_run([-1, undef, -1], "lspci");
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
if (/10(\s|\-)?g[bei]|Chelsio/i) {
|
|
$net .= ":xge";
|
|
last;
|
|
}
|
|
}
|
|
open3_wait($fhpid);
|
|
return $net;
|
|
}
|
|
|
|
####################
|
|
#### shift_stop ####
|
|
####################
|
|
sub shift_stop {
|
|
# crontab not used when cron disabled or extra clients
|
|
exit if (!$opts{cron} || $opts{id} =~ /\D/);
|
|
# remove crontab
|
|
my $tab;
|
|
my $fhpid = open3_run([-1, undef, -1], "crontab -l");
|
|
exit if (!defined $fhpid);
|
|
while (defined ($_ = $fhpid->[1]->getline)) {
|
|
# ignore garbage added by crontab
|
|
next if (/^#.*(?:edit the master|installed on|Cron(ie)? version)/);
|
|
$tab .= $_;
|
|
}
|
|
open3_wait($fhpid);
|
|
if (defined $tab && $tab =~ /\Q$opts{abs0}\E[^\r\n]*\s+--id=$opts{id}\s+/) {
|
|
$tab =~ s/\r?\n[^\r\n]+\Q$opts{abs0}\E[^\r\n]*\s+--id=$opts{id}\s+[^\r\n]+\r?\n//s;
|
|
my ($fh, $file) = tempfile();
|
|
print $fh $tab;
|
|
close $fh;
|
|
$fhpid = open3_run([-1, -1, -1], "crontab $file");
|
|
open3_wait($fhpid);
|
|
unlink $file;
|
|
}
|
|
exit;
|
|
}
|
|
|
|
#######################
|
|
#### tar_canonpath ####
|
|
#######################
|
|
# return given path logically cleaned of . and .. and stripped of leading ..
|
|
sub tar_canonpath {
|
|
my $path = shift;
|
|
my $abs = $path =~ /^\//;
|
|
my @dirs = File::Spec->splitdir($path);
|
|
for (my $i = 0; $i < scalar(@dirs); $i++) {
|
|
if ($dirs[$i] eq '.' || $dirs[$i] eq '') {
|
|
# ./foo becomes foo, foo//bar becomes foo/bar
|
|
splice(@dirs, $i--, 1);
|
|
} elsif ($dirs[$i] ne '..' && $dirs[$i + 1] eq '..') {
|
|
# foo/../bar becomes bar
|
|
splice(@dirs, $i, 2);
|
|
$i -= 2;
|
|
}
|
|
}
|
|
# remove leading ..
|
|
shift @dirs while ($dirs[0] eq '..');
|
|
# make path absolute if it was originally
|
|
unshift(@dirs, "/") if ($abs);
|
|
return File::Spec->catdir(@dirs);
|
|
}
|
|
|
|
#####################
|
|
#### tar_extract ####
|
|
#####################
|
|
# based on Tar/Archive::Tar 0.07 by Calle Dybedahl (no license specified)
|
|
sub tar_extract {
|
|
my ($shost, $spath, $dst, $ref) = @_;
|
|
my $logfh = $opts{logfh};
|
|
my $src = hostpath($shost, $spath);
|
|
my $host = fqdn(hostname);
|
|
|
|
my $fh;
|
|
if ($shost ne 'localhost') {
|
|
$fh = sftp($shost)->open($spath, SFTP_READ);
|
|
} else {
|
|
$fh = undef if (!open($fh, '<', $spath));
|
|
}
|
|
|
|
my $tell = defined $ref->{tar_tell} ? $ref->{tar_tell} : 0;
|
|
if (!$fh) {
|
|
sftp_error($ref, "Unable to open tar file $src");
|
|
return;
|
|
} elsif ($tell > 0 && !seek($fh, $tell, 0)) {
|
|
sftp_error($ref, "Unable to seek in tar file $src");
|
|
return;
|
|
}
|
|
# Net::Foreign::SFTP does not support binmode
|
|
binmode $fh if ($shost eq 'localhost');
|
|
|
|
my %real;
|
|
my ($eof, $head, $nfiles);
|
|
read($fh, $head, 512);
|
|
while ((!defined $opts{'find-files'} || $nfiles < $opts{'find-files'}) &&
|
|
length($head) == 512) {
|
|
# end of archive is two blocks of 512 but GNU tar uses one sometimes
|
|
if ($head eq "\0" x 512) {
|
|
$eof = 1;
|
|
last;
|
|
}
|
|
|
|
# uid, gid, and size must be 'a' instead of 'A' for base-256 encoding
|
|
# name, lnk, mgc, unam, gnam, and pfx are 'Z' for trailing whitespace
|
|
my @attrs = unpack('Z100A8a8a8a12A12A8A1Z100Z6A2Z32Z32A8A8Z155', $head);
|
|
# name mode uid gid size time sum type lnk mgc ver unam gnam dmj dmn pfx
|
|
# 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
|
|
|
|
# prepend prefix to name
|
|
if ($attrs[15]) {
|
|
$attrs[0] = $attrs[15] . "/" . $attrs[0];
|
|
$attrs[15] = "";
|
|
}
|
|
# remove last non-standalone slash
|
|
$attrs[0] =~ s/(?!^)\/$//;
|
|
|
|
if (!$attrs[0]) {
|
|
# only record error if no progress made
|
|
sftp_error($ref, "Empty file name in tar file $src")
|
|
if (defined $ref->{tar_tell} && $ref->{tar_tell} == $tell);
|
|
last;
|
|
}
|
|
# old GNU tar may have space after ustar
|
|
if ($attrs[9] ne 'ustar' && $attrs[9] ne 'ustar ') {
|
|
# only record error if no progress made
|
|
sftp_error($ref, "Tar file $src not in supported ustar format")
|
|
if (defined $ref->{tar_tell} && $ref->{tar_tell} == $tell);
|
|
last;
|
|
}
|
|
|
|
# convert octal numeric fields
|
|
$attrs[$_] = oct($attrs[$_]) foreach (1, 5, 6, 13, 14);
|
|
|
|
# handle GNU large uid/gid/size extension (two's-complement base-256)
|
|
foreach my $i (2..4) {
|
|
if (substr($attrs[$i], 0, 1) eq "\x80") {
|
|
my $val = ord(substr($attrs[$i], 1, 1)) & 0xff;
|
|
for (2..($i == 4 ? 11 : 7)) {
|
|
$val <<= 8;
|
|
$val |= (ord(substr($attrs[$i], $_, 1)) & 0xff);
|
|
}
|
|
$attrs[$i] = $val;
|
|
} else {
|
|
$attrs[$i] = oct $attrs[$i];
|
|
}
|
|
}
|
|
|
|
# validate checksum
|
|
substr($head, 148, 8) = " ";
|
|
if (unpack("%16C*", $head) != $attrs[6]) {
|
|
# only record error if no progress made
|
|
sftp_error($ref, "Invalid tar header checksum for $attrs[0]")
|
|
if (defined $ref->{tar_tell} && $ref->{tar_tell} == $tell);
|
|
last;
|
|
}
|
|
|
|
# handle GNU long names
|
|
if ($attrs[7] =~ /^[LK]$/) {
|
|
do {
|
|
# read next header
|
|
read($fh, $head, 512);
|
|
$head = substr($head, 0, $attrs[4]) if ($attrs[4] < 512);
|
|
# remove the extra byte used for \0
|
|
$head =~ s/\0$//;
|
|
$real{$attrs[7]} .= $head;
|
|
$attrs[4] -= 512;
|
|
} while ($attrs[4] > 0);
|
|
# read next header
|
|
read($fh, $head, 512);
|
|
next;
|
|
}
|
|
|
|
# find next header
|
|
my $offset = tell($fh);
|
|
if (!seek($fh, $attrs[4], 1)) {
|
|
# only record error if no progress made
|
|
sftp_error($ref, "Unable to seek in tar file $src")
|
|
if (defined $ref->{tar_tell} && $ref->{tar_tell} == $tell);
|
|
last;
|
|
}
|
|
my $diff = $attrs[4] % 512;
|
|
# ignore padding
|
|
if ($diff != 0 && !seek($fh, 512 - $diff, 1)) {
|
|
# only record error if no progress made
|
|
sftp_error($ref, "Unable to ignore padding in tar file $src")
|
|
if (defined $ref->{tar_tell} && $ref->{tar_tell} == $tell);
|
|
last;
|
|
}
|
|
$tell = $offset + $attrs[4] + ($diff ? 512 - $diff : 0);
|
|
|
|
if ($real{L}) {
|
|
$attrs[0] = $real{L};
|
|
$real{L} = undef;
|
|
}
|
|
if ($real{K}) {
|
|
$attrs[8] = $real{K};
|
|
$real{K} = undef;
|
|
}
|
|
|
|
# read next header
|
|
read($fh, $head, 512);
|
|
|
|
# include files
|
|
if (defined $opts{include}) {
|
|
my $found;
|
|
foreach (@{$opts{include}}) {
|
|
my $re = /^\\Q/ ? quotemeta(substr($_, 2)) : $_;
|
|
next if (eval {$attrs[0] !~ /$re/});
|
|
$found = 1;
|
|
last;
|
|
}
|
|
next if (!$found);
|
|
}
|
|
# exclude files
|
|
if (defined $opts{exclude}) {
|
|
my $found;
|
|
foreach (@{$opts{exclude}}) {
|
|
my $re = /^\\Q/ ? quotemeta(substr($_, 2)) : $_;
|
|
next if (eval {$attrs[0] !~ /$re/});
|
|
$found = 1;
|
|
last;
|
|
}
|
|
next if ($found);
|
|
}
|
|
# newer/older files
|
|
next if (defined $opts{newer} && $attrs[5] < $opts{newer});
|
|
next if (defined $opts{older} && $attrs[5] >= $opts{older});
|
|
|
|
my $udst = tar_canonpath($attrs[0]);
|
|
substr($udst, 0, 0) = "/" if ($udst !~ /^\//);
|
|
$udst = escape($dst . $udst);
|
|
|
|
# print operation and stat info separated by commas
|
|
if ($attrs[7] eq '2') {
|
|
print $logfh "args=ln,", escape($attrs[8]), ",", $udst;
|
|
} elsif ($attrs[7] eq '5') {
|
|
print $logfh "args=mkdir,", $udst;
|
|
} elsif ($attrs[7] eq '0') {
|
|
print $logfh "args=cp,", escape($src), ",", $udst;
|
|
} else {
|
|
# unsupported file type (e.g. pipes, devices, etc.)
|
|
next;
|
|
}
|
|
print $logfh " host=$host size=$attrs[4] attrs=", join(",",
|
|
@attrs[1,2,3,5,5], escape($attrs[11]), escape($attrs[12]),
|
|
@attrs[4,4]);
|
|
my $bytes = $offset . "-" . ($offset + $attrs[4]);
|
|
print $logfh " bytes=$bytes tar_bytes=$bytes";
|
|
print $logfh " tar_name=", escape(tar_canonpath($attrs[0])), "\n";
|
|
$nfiles++;
|
|
}
|
|
if (length($head) < 512) {
|
|
sftp_error($ref,
|
|
"Unable to read header at offset $tell in tar file $src");
|
|
} elsif (!$eof && !$ref->{text}) {
|
|
# over init limit or error occurred without notification
|
|
print $logfh "args=find,", escape($src), ",", escape($dst),
|
|
" host=$host tar_tell=$tell\n";
|
|
}
|
|
close $fh;
|
|
}
|
|
|
|
####################
|
|
#### tar_record ####
|
|
####################
|
|
# based on Tar/Archive::Tar 0.07 by Calle Dybedahl (no license specified)
|
|
# checks for ustar limitations have already been done by this point
|
|
sub tar_record {
|
|
my ($fh, $type, $src, $ref, $ifh) = @_;
|
|
my $logfh = $opts{logfh};
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
my $file = $ref->{tar_name};
|
|
|
|
if ($ifh) {
|
|
if (!seek($ifh, $ref->{tar_index}, 0)) {
|
|
sftp_error($ref, "Unable to seek tar index file");
|
|
return;
|
|
}
|
|
print $ifh sprintf("%1s%9s %7s %7s %9d %12s %s\n",
|
|
$type eq 'mkdir' ? "d" : ($type eq 'ln' ? "l" : "-"),
|
|
sftp_ls_mode($attrs[0]), unescape($attrs[5]), unescape($attrs[6]),
|
|
$type =~ /^(?:ln|mkdir)$/ ? 0 : $attrs[7],
|
|
strftime("%b %d %Y", localtime $attrs[4]),
|
|
$type eq 'ln' ? "$ref->{tar_name} -> $src" : $ref->{tar_name});
|
|
}
|
|
my ($ttype, $size, $ln);
|
|
if ($type eq 'ln') {
|
|
if (length($src) > 100) {
|
|
# use GNU long link extension
|
|
$size = length($src);
|
|
$file = '././@LongLink';
|
|
$ttype = 'K';
|
|
} else {
|
|
$ln = $src;
|
|
$size = 0;
|
|
$ttype = 2;
|
|
}
|
|
} elsif ($type eq 'mkdir') {
|
|
$file .= "/";
|
|
$size = 0;
|
|
$ttype = 5;
|
|
} else {
|
|
# use attrs value instead of size, which changes with --split
|
|
$size = $attrs[7];
|
|
$ttype = 0;
|
|
}
|
|
|
|
my ($head, $prefix, $pos, $file0);
|
|
if (length($file) > 100) {
|
|
$pos = index($file, "/", length($file) - 100);
|
|
if ($pos == -1 || $pos > 155 || length($file) > 255) {
|
|
# use GNU long name extension
|
|
$size = length($file);
|
|
$file0 = $file;
|
|
$file = '././@LongLink';
|
|
$ttype = 'L';
|
|
} else {
|
|
$prefix = substr($file, 0, $pos);
|
|
$file = substr($file, $pos + 1);
|
|
}
|
|
}
|
|
|
|
# use GNU large uid/gid/size extension (two's-complement base-256)
|
|
my ($uid256, $gid256, $size256);
|
|
if ($attrs[1] > 2097151) {
|
|
my $val = $attrs[1];
|
|
foreach (1..7) {
|
|
$uid256 = chr($val & 0xff) . $uid256;
|
|
$val >>= 8;
|
|
}
|
|
$uid256 = "\x80" . $uid256;
|
|
}
|
|
if ($attrs[2] > 2097151) {
|
|
my $val = $attrs[2];
|
|
foreach (1..7) {
|
|
$gid256 = chr($val & 0xff) . $gid256;
|
|
$val >>= 8;
|
|
}
|
|
$gid256 = "\x80" . $gid256;
|
|
}
|
|
if ($size > 8589934591) {
|
|
my $val = $size;
|
|
foreach (1..11) {
|
|
$size256 = chr($val & 0xff) . $size256;
|
|
$val >>= 8;
|
|
}
|
|
$size256 = "\x80" . $size256;
|
|
}
|
|
|
|
my $head = pack("a100a8a8a8a12a12a8a1a100",
|
|
$file,
|
|
sprintf("%07o\0", $attrs[0]),
|
|
$uid256 ? $uid256 : sprintf("%07o\0", $attrs[1]),
|
|
$gid256 ? $gid256 : sprintf("%07o\0", $attrs[2]),
|
|
$size256 ? $size256 : sprintf("%011o\0", $size),
|
|
sprintf("%011o\0", $attrs[4]),
|
|
" ",
|
|
$ttype,
|
|
$ln,
|
|
);
|
|
$head .= pack("a6", "ustar\0");
|
|
$head .= "00";
|
|
# truncate user/group to 32 bytes, which is max supported by ustar format
|
|
$head .= pack("a32", substr(unescape($attrs[5]), 0, 32));
|
|
$head .= pack("a32", substr(unescape($attrs[6]), 0, 32));
|
|
# no handling for major/minor dev so use zero
|
|
$head .= pack("a8", sprintf("%07o\0", 0));
|
|
$head .= pack("a8", sprintf("%07o\0", 0));
|
|
$head .= pack("a155", $prefix);
|
|
# compute checksum
|
|
substr($head, 148, 6) = sprintf("%06o", unpack("%16C*", $head));
|
|
substr($head, 154, 1) = "\0";
|
|
# add header padding
|
|
$head .= "\0" x (512 - length($head));
|
|
|
|
if (!defined $fh || !seek($fh, $ref->{tar_start}, 0)) {
|
|
sftp_error($ref, "Unable to seek tar file to header");
|
|
return;
|
|
} elsif (!$fh->print($head)) {
|
|
sftp_error($ref, "Unable to write tar record header");
|
|
return;
|
|
}
|
|
|
|
# add long link/name data
|
|
if ($ttype eq 'K' && !$fh->print($src)) {
|
|
sftp_error($ref, "Unable to write long link data");
|
|
} elsif ($ttype eq 'L' && !$fh->print($file0)) {
|
|
sftp_error($ref, "Unable to write long name data");
|
|
}
|
|
|
|
# add file padding if needed
|
|
my $end = (split(/-/, $ref->{tar_bytes}))[1];
|
|
if ($size > 0 && $size % 512 > 0) {
|
|
if ($ttype !~ /[KL]/ && !seek($fh, $size, 1)) {
|
|
sftp_error($ref, "Unable to seek tar file to padding");
|
|
return;
|
|
} elsif (!$fh->print("\0" x (512 - ($size % 512)))) {
|
|
sftp_error($ref, "Unable to write tar record padding");
|
|
return;
|
|
}
|
|
$end += 512 - ($size % 512);
|
|
}
|
|
|
|
if ($ttype eq 'K') {
|
|
# add last record with long link file and truncated name
|
|
my $start0 = $ref->{tar_start};
|
|
$ref->{tar_start} = tell($fh);
|
|
tar_record($fh, $type, substr($src, 0, 100), $ref);
|
|
$ref->{tar_start} = $start0;
|
|
}
|
|
if ($ttype eq 'L') {
|
|
# add last record with truncated name
|
|
my $name0 = $ref->{tar_name};
|
|
my $start0 = $ref->{tar_start};
|
|
$ref->{tar_name} = substr($file0, 0, 100);
|
|
$ref->{tar_start} = tell($fh);
|
|
tar_record($fh, $type, $src, $ref);
|
|
$ref->{tar_name} = $name0;
|
|
$ref->{tar_start} = $start0;
|
|
}
|
|
|
|
if ($ref->{tar_last}) {
|
|
# add two full zero records to end of tar file
|
|
if (!seek($fh, $end, 0)) {
|
|
sftp_error($ref, "Unable to seek tar file to final record");
|
|
return;
|
|
} elsif (!$fh->print("\0" x 1024)) {
|
|
sftp_error($ref, "Unable to write tar final zero records");
|
|
return;
|
|
}
|
|
$end += 1024;
|
|
# pad out final block to full length (multiple of 10k)
|
|
my $zeros = $end % 10240;
|
|
if ($zeros && !$fh->print("\0" x (10240 - $zeros))) {
|
|
sftp_error($ref, "Unable to write tar final zero blocks");
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
|
|
######################
|
|
#### tar_validate ####
|
|
######################
|
|
sub tar_validate {
|
|
my ($fh, $ref) = @_;
|
|
my $head;
|
|
if (!defined $fh || !seek($fh, $ref->{tar_start}, 0)) {
|
|
sftp_error($ref, "Unable to seek tar file to header");
|
|
return 0;
|
|
} elsif (!read($fh, $head, 512)) {
|
|
sftp_error($ref, "Unable to read tar record header");
|
|
return 0;
|
|
}
|
|
|
|
# uid, gid, and size must be 'a' instead of 'A' for base-256 encoding
|
|
# name, lnk, mgc, unam, gnam, and pfx are 'Z' for trailing whitespace
|
|
my @attrs = unpack('Z100A8a8a8a12A12A8A1Z100Z6A2Z32Z32A8A8Z155', $head);
|
|
my $sum = oct $attrs[6];
|
|
|
|
# validate checksum
|
|
substr($head, 148, 8) = " ";
|
|
if (unpack("%16C*", $head) != $sum) {
|
|
sftp_error($ref, "Invalid tar header checksum");
|
|
return 0;
|
|
}
|
|
|
|
# handle GNU large size extension (two's-complement base-256)
|
|
my $size = $attrs[4];
|
|
if (substr($size, 0, 1) eq "\x80") {
|
|
my $val = ord(substr($size, 0, 1)) & 0xff;
|
|
for (1..11) {
|
|
$val = ($val << 8) + (ord(substr($size, $_, 1)) & 0xff);
|
|
}
|
|
$size = $val;
|
|
} else {
|
|
$size = oct $size;
|
|
}
|
|
|
|
# check long links/names
|
|
if ($attrs[7] =~ /[KL]/) {
|
|
my $name;
|
|
if (!read($fh, $name, $size)) {
|
|
sftp_error($ref, "Unable to read tar long link/name data");
|
|
return 0;
|
|
}
|
|
my $src = $attrs[7] eq 'K' ?
|
|
(split(/,/, $ref->{args}))[1] : $ref->{tar_name};
|
|
$src = unescape($src) if ($attrs[7] eq 'K');
|
|
# directory entries have an extra slash appended
|
|
$src .= "/" if (scalar(split(/,/, $ref->{args})) == 2);
|
|
if ($name ne $src) {
|
|
sftp_error($ref, "Invalid tar long link/name data");
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# check file padding
|
|
my $end = (split(/-/, $ref->{tar_bytes}))[1];
|
|
if ($size > 0 && $size % 512 > 0) {
|
|
my $pad;
|
|
if ($attrs[7] !~ /[KL]/ && !seek($fh, $size, 1)) {
|
|
sftp_error($ref, "Unable to seek tar file to padding");
|
|
return 0;
|
|
} elsif (!read($fh, $pad, 512 - ($size % 512))) {
|
|
sftp_error($ref, "Unable to read tar record padding");
|
|
return 0;
|
|
} elsif ($pad ne "\0" x (512 - ($size % 512))) {
|
|
sftp_error($ref, "Invalid tar record padding");
|
|
return 0;
|
|
}
|
|
$end += 512 - ($size % 512);
|
|
}
|
|
|
|
# check last truncated record
|
|
if ($attrs[7] =~ /[KL]/) {
|
|
my $start0 = $ref->{tar_start};
|
|
$ref->{tar_start} = tell($fh);
|
|
my $return = tar_validate($fh, $ref);
|
|
$ref->{tar_start} = $start0;
|
|
return $return;
|
|
}
|
|
|
|
# check archive padding
|
|
if ($ref->{tar_last}) {
|
|
my $pad;
|
|
if (!seek($fh, $end, 0)) {
|
|
sftp_error($ref, "Unable to seek tar file to final record");
|
|
return 0;
|
|
} elsif (!read($fh, $pad, 1024)) {
|
|
sftp_error($ref, "Unable to read tar final zero records");
|
|
return 0;
|
|
} elsif ($pad ne "\0" x 1024) {
|
|
sftp_error($ref, "Invalid tar final zero records");
|
|
return 0;
|
|
}
|
|
$end += 1024;
|
|
my $zeros = $end % 10240;
|
|
$zeros = 10240 - $zeros if ($zeros);
|
|
if ($zeros && !read($fh, $pad, $zeros)) {
|
|
sftp_error($ref, "Unable to read tar final zero blocks");
|
|
return 0;
|
|
} elsif ($zeros && $pad ne "\0" x $zeros) {
|
|
sftp_error($ref, "Invalid tar final zero blocks");
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# return true only if checksum and padding are correct
|
|
return 1;
|
|
}
|
|
|
|
###################
|
|
#### transport ####
|
|
###################
|
|
my %tcmds;
|
|
sub transport {
|
|
my ($op, $host, $src, $dst, $ref) = @_;
|
|
my $rsize;
|
|
if ($op ne 'end') {
|
|
push(@{$tcmds{$host}}, [$op, $src, $dst, $ref]);
|
|
return;
|
|
} elsif ($op eq 'end' && !defined $host) {
|
|
my @hosts = keys %tcmds;
|
|
# localhost must be first to create directories
|
|
$rsize += transport($op, 'localhost') if (grep(/^localhost$/, @hosts));
|
|
foreach $host (keys %tcmds) {
|
|
$rsize += transport($op, $host) if ($host ne 'localhost');
|
|
}
|
|
return $rsize;
|
|
}
|
|
# end op with defined host from this point
|
|
|
|
transport_find($host, $tcmds{$host});
|
|
transport_chattr($host, $tcmds{$host});
|
|
transport_tar($host, $tcmds{$host});
|
|
# dmf must be last since tar might still write file during chattr
|
|
transport_dmf($host, $tcmds{$host});
|
|
|
|
# split commands into tools used to process them
|
|
my %tools;
|
|
my $type = $host eq 'localhost' ? "local" : "remote";
|
|
$tools{$_} = [] foreach (@{$opts{$type}});
|
|
foreach my $cmd (@{$tcmds{$host}}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
next if ($op =~ /^(?:cksum|find|sum)$/);
|
|
if ($op !~ /^(?:get|put)$/) {
|
|
push(@{$tools{'shift'}}, $cmd);
|
|
next;
|
|
}
|
|
my $use;
|
|
for (my $i = 0; $i < scalar(@{$opts{$type}}); $i++) {
|
|
# try next available tool in list after a failure
|
|
my $tool = $opts{$type}->[
|
|
($i + $ref->{try}) % scalar(@{$opts{$type}})];
|
|
next if (
|
|
# bbftp does not encrypt and cannot handle partial transfers or
|
|
# whitespace/vt in file names
|
|
$tool eq 'bbftp' && ($opts{secure} || $ref->{bytes} ||
|
|
"$src$dst" =~ /[\s\x0b]/) ||
|
|
# rsync cannot handle partial transfers, and
|
|
# (using --files-from) cannot handle cr/lf in file names
|
|
$tool eq 'rsync' && ($ref->{bytes} || "$src$dst" =~ /[\n\r]/));
|
|
$use = $tool;
|
|
last;
|
|
}
|
|
if (!$use) {
|
|
if ($host ne 'localhost' && defined $tools{'fish-tcp'}) {
|
|
$use = "fish-tcp";
|
|
} elsif ($host ne 'localhost' && defined $tools{fish}) {
|
|
$use = "fish";
|
|
} else {
|
|
$use = "shift";
|
|
}
|
|
}
|
|
push(@{$tools{$use}}, $cmd);
|
|
|
|
if ($opts{force}) {
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
# force owner write permission on dst
|
|
my $mode = $attrs[0] | 128;
|
|
if ($host eq 'localhost' || $op eq 'get') {
|
|
chmod($mode, $dst);
|
|
} else {
|
|
my $sattrs = Net::SFTP::Foreign::Attributes->new;
|
|
$sattrs->set_perm($mode);
|
|
sftp($host)->setstat($dst, $sattrs);
|
|
}
|
|
# ignore failures since file doesn't exist or can't be written
|
|
}
|
|
}
|
|
|
|
foreach my $tool (keys %tools) {
|
|
next if (!scalar(@{$tools{$tool}}));
|
|
if ($tool eq 'bbftp') {
|
|
transport_bbftp($host, $tools{$tool});
|
|
} elsif ($tool eq 'fish') {
|
|
transport_fish($host, $tools{$tool});
|
|
} elsif ($tool eq 'fish-tcp') {
|
|
transport_fish($host, $tools{$tool}, 1);
|
|
} elsif ($tool eq 'mcp') {
|
|
transport_mcp($host, $tools{$tool});
|
|
} elsif ($tool eq 'rsync') {
|
|
$rsize += transport_rsync($host, $tools{$tool});
|
|
} else {
|
|
transport_shift($host, $tools{$tool});
|
|
}
|
|
}
|
|
|
|
if ($opts{verify}) {
|
|
verify_sum($tcmds{$host});
|
|
verify_cksum($host, $tcmds{$host});
|
|
}
|
|
|
|
transport_fadvise($host, $tcmds{$host});
|
|
|
|
delete $tcmds{$host};
|
|
|
|
# return is only defined during an end when rsync is used
|
|
return $rsize;
|
|
}
|
|
|
|
#########################
|
|
#### transport_bbftp ####
|
|
#########################
|
|
sub transport_bbftp {
|
|
my ($host, $tcmds) = @_;
|
|
my %errs;
|
|
my ($fh, $tmp);
|
|
my $nstream = $host eq 'localhost' ? $opts{threads} : $opts{streams};
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
if (!$tmp) {
|
|
($fh, $tmp) = sftp_tmp();
|
|
# must keep write access to handle warnings/corruption
|
|
print $fh "setoption nokeepmode\n";
|
|
print $fh "setbuffersize " . ($opts{buffer} >> 10) . "\n"
|
|
if ($opts{buffer});
|
|
print $fh "setnbstream " . $nstream . "\n" if ($nstream);
|
|
print $fh "setrecvwinsize " . ($opts{window} >> 10) . "\n"
|
|
if ($opts{window});
|
|
print $fh "setsendwinsize " . ($opts{window} >> 10) . "\n"
|
|
if ($opts{window});
|
|
# apply opts_bbftp last to override other settings
|
|
print $fh "$opts{opts_bbftp}\n";
|
|
}
|
|
my $s = "$op $src $dst";
|
|
print $fh "$s\n";
|
|
$errs{$s} = $ref;
|
|
$ref->{tool} = "bbftp";
|
|
}
|
|
return if (!$tmp);
|
|
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
my $dashe = $opts{ports} ? " -f -e $opts{ports}" : "";
|
|
my $dashl = $host ne 'localhost' ? $opts{ssh} : "bbftpd -s$dashe";
|
|
$dashe = "-E 'bbftpd $dashe'" if ($dashe);
|
|
# remove user name (if applicable)
|
|
$host = (split(/@/, $host))[-1];
|
|
my $out = open3_get([-1, undef], "bbftp $dashe -L \"$dashl\" -i $tmp $host");
|
|
$out =~ s/Child starting\s*//g;
|
|
if (! -f "$tmp.res" && $out =~ /BBFTP-ERROR-(\d+)/) {
|
|
my $code = $1;
|
|
my $type = ($code <= 30 || $code > 70 &&
|
|
$code <= 90 || $code >= 100) ? "\\E" : "\\W";
|
|
$errs{$_}->{text} = "$type$out" foreach (keys %errs);
|
|
} else {
|
|
my @lines = split(/\s*\n\s*/, $out);
|
|
if (open(FILE, '<', "$tmp.res")) {
|
|
my $i = 0;
|
|
while (<FILE>) {
|
|
next if (/Child starting/);
|
|
if (/(.*)\s+FAILED$/) {
|
|
my $op = $1;
|
|
# ignore option failure
|
|
next if (!$errs{$op});
|
|
my $type = "\\E";
|
|
if ($lines[$i] =~ /BBFTP-ERROR-(\d+)/) {
|
|
my $code = $1;
|
|
$type = "\\W"
|
|
if ($code > 30 && $code <= 70 ||
|
|
$code > 90 && $code < 100);
|
|
}
|
|
$errs{$op}->{text} = "$type$lines[$i]";
|
|
$i++;
|
|
} elsif (/(.*)\s+OK$/) {
|
|
my $op = $1;
|
|
# ignore option success
|
|
next if (!$errs{$op});
|
|
$errs{$op}->{text} = 0;
|
|
}
|
|
}
|
|
close FILE;
|
|
}
|
|
unlink "$tmp.res";
|
|
}
|
|
foreach my $op (keys %errs) {
|
|
if (!defined $errs{$op}->{text}) {
|
|
sftp_error($errs{$op}, "bbftp failure: " . substr($out, 0, 256));
|
|
}
|
|
}
|
|
unlink $tmp;
|
|
}
|
|
|
|
##########################
|
|
#### transport_chattr ####
|
|
##########################
|
|
sub transport_chattr {
|
|
my ($host, $tcmds) = @_;
|
|
|
|
# check for existence of commands
|
|
if ((!defined $opts{have} || !$opts{have}->{SET}) && $host eq 'localhost') {
|
|
$opts{have}->{SET} = 1;
|
|
foreach my $bin (qw(fallocate lfs setfacl setfattr shift-bin)) {
|
|
$opts{have}->{$bin} = first {-x "$_/$bin"} (split(/:/, $ENV{PATH}));
|
|
}
|
|
}
|
|
|
|
my (@chattrs, @allocs);
|
|
|
|
# lfs setstripe (must be done before fallocate)
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
# lfs setstripe (must be done before fallocate)
|
|
if ((!$opts{'create-tar'} && ($op =~ /^(?:get|put)$/ ||
|
|
$op eq 'mkdir' && $ref->{lustre_attrs}) ||
|
|
$op eq 'chattr' && $ref->{tar_creat}) &&
|
|
$ref->{dstfs} && $ref->{dstfs} =~ /^lustre/ && !$ref->{ln} &&
|
|
($opts{stripe} ne '0' || defined $opts{'stripe-size'} ||
|
|
defined $opts{'stripe-pool'})) {
|
|
# set striping
|
|
my @stripe = (0, 0);
|
|
# preserve existing striping when available
|
|
@stripe = split(/,/, $ref->{lustre_attrs}) if ($ref->{lustre_attrs});
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
# define variables that are allowed in striping expressions
|
|
my ($dr, $nm, $sz, $sc, $ss) =
|
|
($op eq 'mkdir', $dst, $attrs[7], @stripe);
|
|
# base striping on tar size instead of file size during tar creation
|
|
$sz = $ref->{tar_creat} if ($ref->{tar_creat});
|
|
my @evals = ($opts{stripe}, $opts{'stripe-size'});
|
|
push(@evals, $opts{'stripe-pool'})
|
|
if ($opts{'stripe-pool'} !~ /^[\w.-]+$/);
|
|
# evaluate all striping expressions
|
|
foreach my $i (0 .. 2) {
|
|
my $eval = $evals[$i];
|
|
next if (!$eval);
|
|
$eval =~ s/(DR|NM|SZ|SC|SS)/q($).lc($1)/eg;
|
|
$stripe[$i] = eval $eval;
|
|
}
|
|
# count >= 64k indicates a size per stripe
|
|
$stripe[0] = ceil($sz / $stripe[0]) if ($stripe[0] >= 65536);
|
|
# size should never be < 64k (llapi inexplicably returns 2 for dirs)
|
|
$stripe[1] = 0 if ($stripe[1] < 65536);
|
|
# striping may become disabled based on evaluated expressions
|
|
if ($stripe[0] || $stripe[1] || $stripe[2]) {
|
|
my @args = ("setstripe", escape($dst) . ($op eq 'mkdir' ? "/" : ""),
|
|
join(" ", @stripe));
|
|
push(@chattrs, \@args);
|
|
# ignore errors since files automatically striped anyway
|
|
}
|
|
}
|
|
|
|
# fallocate
|
|
if ($opts{preallocate} && ($op =~ /^(?:get|put)$/ ||
|
|
$op =~ /^(?:ln|mkdir)$/ && $ref->{tar_creat}) &&
|
|
# lustre/nfs do not seem to support fallocate at the moment
|
|
$ref->{dstfs} !~ /^(?:lustre|nfs)$/ &&
|
|
(!$opts{'create-tar'} || $ref->{tar_creat})) {
|
|
my $size;
|
|
if ($opts{'create-tar'}) {
|
|
$size = $ref->{tar_creat};
|
|
} else {
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
# don't preallocate small files or files above given sparsity
|
|
next if ($attrs[7] < 4194304 ||
|
|
1 - $attrs[8] / $attrs[7] >= $opts{preallocate} / 100);
|
|
$size = $attrs[7];
|
|
}
|
|
my @args = ("fallocate", escape($dst), $size);
|
|
# use different queue to give higher probability that striping done
|
|
push(@allocs, \@args);
|
|
# ignore errors since files automatically allocated anyway
|
|
}
|
|
|
|
# setfacl
|
|
if ($op eq 'chattr' && $ref->{acls} &&
|
|
(!$ref->{dstfs} || $ref->{dstfs} =~ /,acl/)) {
|
|
my @args = ("setfacl", escape($dst), $ref->{acls});
|
|
push(@chattrs, \@args);
|
|
# ignore errors since systems may have different command/users
|
|
}
|
|
|
|
# setfattr
|
|
if ($op eq 'chattr' && $ref->{xattrs} &&
|
|
(!$ref->{dstfs} || $ref->{dstfs} =~ /,xattr/)) {
|
|
my @args = ("setfattr", escape($dst), $ref->{xattrs});
|
|
push(@chattrs, \@args);
|
|
# ignore errors since systems may have different command/users
|
|
}
|
|
}
|
|
|
|
return if (!scalar(@chattrs) && !scalar(@allocs));
|
|
|
|
if ($host ne 'localhost') {
|
|
my ($fh, $tmp) = sftp_tmp();
|
|
foreach (@chattrs, @allocs) {
|
|
print $fh join(" ", @{$_}), "\n";
|
|
}
|
|
close $fh;
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
open3_get([$tmp, -1, -1], "$opts{ssh} $host $opts{caux} chattr");
|
|
unlink $tmp;
|
|
return;
|
|
}
|
|
|
|
if ($perl{threads} && $opts{threads} > 1) {
|
|
my $q = Thread::Queue->new(@chattrs, @allocs);
|
|
my $dqchattr = sub {
|
|
$opts{fhpid} = open3_run([undef, undef, -1], "shift-bin")
|
|
if ($opts{have}->{'shift-bin'});
|
|
transport_chattr1($_) while (defined ($_ = $q->dequeue_nb));
|
|
open3_wait($opts{fhpid}) if (defined $opts{fhpid});
|
|
};
|
|
my @threads = map {threads->create($dqchattr)} (1 .. $opts{threads} - 1);
|
|
# ensure work gets done even if thread creation fails
|
|
&$dqchattr();
|
|
foreach (@threads) {
|
|
$_->join if ($_);
|
|
}
|
|
} else {
|
|
# threads not supported, threads is 1, or thread creation failed
|
|
$opts{fhpid} = open3_run([undef, undef, -1], "shift-bin")
|
|
if ($opts{have}->{'shift-bin'});
|
|
transport_chattr1($_) foreach (@chattrs, @allocs);
|
|
open3_wait($opts{fhpid}) if (defined $opts{fhpid});
|
|
}
|
|
}
|
|
|
|
###########################
|
|
#### transport_chattr1 ####
|
|
###########################
|
|
# set attrs of a single file
|
|
sub transport_chattr1 {
|
|
my ($cmd, $file, $attrs) = @{$_[0]};
|
|
# short circuit if command not available
|
|
return if (!defined $opts{fhpid} && !$opts{have}->{$cmd});
|
|
# untaint arguments
|
|
$cmd = $1 if ($cmd =~ /(.*)/);
|
|
$file = $1 if ($file =~ /(.*)/s);
|
|
$attrs = $1 if ($attrs =~ /(.*)/);
|
|
my $ufile = unescape($file);
|
|
|
|
# make sure parent directory exists
|
|
my $dir = $ufile =~ s/\/$// ? $ufile : dirname($ufile);
|
|
eval {mkpath($dir)};
|
|
|
|
if (defined $opts{fhpid}) {
|
|
$opts{fhpid}->[0]->print(join(" ", $cmd, $file, $attrs), "\n");
|
|
# read line even though never used to prevent pipe overflow
|
|
$opts{fhpid}->[1]->getline;
|
|
# ignore errors
|
|
} else {
|
|
my ($cin, @copts, $in, $out);
|
|
if ($cmd eq 'fallocate') {
|
|
@copts = ("-n", "-l", unescape($attrs), $ufile);
|
|
} elsif ($cmd eq 'setstripe') {
|
|
$cmd = "lfs";
|
|
my ($count, $size, $pool) = split(/\s+/, unescape($attrs));
|
|
$count = 0 if (!$count);
|
|
$size = 0 if (!$size);
|
|
@copts = ("setstripe", "-c", $count, "-S", $size, $ufile);
|
|
splice(@copts, -1, 0, "-p", $pool) if ($pool);
|
|
} elsif ($cmd eq 'setfacl') {
|
|
$attrs =~ s/,/\n/g;
|
|
$cin = unescape($attrs);
|
|
@copts = ("-M-", $ufile);
|
|
} elsif ($cmd eq 'setfattr') {
|
|
$attrs =~ s/,/\n/g;
|
|
$cin = "# file: $ufile\n" . unescape($attrs);
|
|
@copts = ("-h", "--restore=-");
|
|
}
|
|
my $pid = IPC::Open3::open3($in, $out, $out, $cmd, @copts);
|
|
print $in $cin if ($cin);
|
|
close $in;
|
|
waitpid($pid, 0);
|
|
# ignore errors
|
|
close $out;
|
|
}
|
|
}
|
|
|
|
#######################
|
|
#### transport_dmf ####
|
|
#######################
|
|
sub transport_dmf {
|
|
my ($host, $tcmds) = @_;
|
|
|
|
# dmget processing
|
|
my (%getfh, %gettmp);
|
|
my %tars;
|
|
if ($opts{recall}) {
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
next if ($op eq 'find' && $ref->{tar_tell});
|
|
next if ($op !~ /^(?:find|get|put)$/ ||
|
|
!$ref->{srcfs} || $ref->{srcfs} !~ /,dmf/);
|
|
($getfh{$op}, $gettmp{$op}) = sftp_tmp() if (!$gettmp{$op});
|
|
if (!$tars{$src}) {
|
|
print {$getfh{$op}} $src, "\n";
|
|
}
|
|
# do not add the same tar over and over again
|
|
$tars{$src} = 1 if ($opts{'extract-tar'});
|
|
}
|
|
}
|
|
|
|
# dmput processing
|
|
my (%putfh, %puttmp);
|
|
if ($opts{offline}) {
|
|
#TODO: this does not dmput extracted tar files or created split tar files
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
next if ($op ne 'chattr' || !$ref->{src} || $ref->{text} ||
|
|
"$ref->{srcfs}$ref->{dstfs}" !~ /,dmf/);
|
|
if ($ref->{srcfs} =~ /,dmf/) {
|
|
my ($shost, $spath) = hostpath($ref->{src});
|
|
($putfh{$shost}, $puttmp{$shost}) = sftp_tmp() if (!$puttmp{$shost});
|
|
print {$putfh{$shost}} $spath, "\n";
|
|
}
|
|
if ($ref->{dstfs} =~ /,dmf/) {
|
|
($putfh{$host}, $puttmp{$host}) = sftp_tmp() if (!$puttmp{$host});
|
|
print {$putfh{$host}} $dst, "\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
return if (scalar(keys %gettmp) + scalar(keys %puttmp) == 0);
|
|
|
|
# fork to avoid intermittent hangs of dmget/dmput
|
|
my $pid = fork_setsid();
|
|
if ($pid) {
|
|
waitpid($pid, 0);
|
|
return;
|
|
}
|
|
|
|
my $extra = $opts{'create-tar'} ? " -a" : "";
|
|
foreach my $op (keys %gettmp) {
|
|
close $getfh{$op};
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
my $ssh = $op ne 'put' && $host ne 'localhost' ? "$opts{ssh} $host" : "";
|
|
# ignore errors since files are automatically retrieved anyway
|
|
open3_get([$gettmp{$op}, -1, -1], "$ssh dmget -nq$extra");
|
|
unlink $gettmp{$op};
|
|
}
|
|
|
|
foreach my $rhost (keys %puttmp) {
|
|
close $putfh{$rhost};
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
my $ssh = $rhost ne 'localhost' ? "$opts{ssh} $rhost" : "";
|
|
# ignore errors since files are automatically migrated anyway
|
|
open3_get([$puttmp{$rhost}, -1, -1], "$ssh dmput -n");
|
|
unlink $puttmp{$rhost};
|
|
}
|
|
POSIX::_exit(0);
|
|
}
|
|
|
|
###########################
|
|
#### transport_fadvise ####
|
|
###########################
|
|
sub transport_fadvise {
|
|
my ($host, $tcmds) = @_;
|
|
my ($fh, $tmp);
|
|
#TODO: do we want --no-fadvise?
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
my @ranges = $ref->{bytes} ? split(/,/, $ref->{bytes}) :
|
|
("0-" . $attrs[7]);
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
foreach my $range (@ranges) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
my ($soff, $doff) = ($x1, $x1);
|
|
if ($opts{'create-tar'}) {
|
|
# adjust src by tar start offset
|
|
$soff = $x1 - $t1;
|
|
} elsif ($opts{'extract-tar'}) {
|
|
# adjust dst by tar start offset
|
|
$doff = $x1 - $t1;
|
|
}
|
|
if ($op eq 'get') {
|
|
($fh, $tmp) = sftp_tmp() if (!$tmp);
|
|
print $fh escape($src), " ", $soff, " ", $x2 - $x1, "\n";
|
|
}
|
|
if ($op =~ /^(?:cksum|put)$/) {
|
|
($fh, $tmp) = sftp_tmp() if (!$tmp);
|
|
print $fh escape($dst), " ", $doff, " ", $x2 - $x1, "\n";
|
|
}
|
|
}
|
|
}
|
|
if ($tmp) {
|
|
close $fh;
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
open3_get([$tmp, -1, -1], $host eq 'localhost' ? "shift-bin" :
|
|
"$opts{ssh} $host $opts{caux} fadvise");
|
|
unlink $tmp;
|
|
# ignore errors since will eventually reclaim cache
|
|
}
|
|
}
|
|
|
|
########################
|
|
#### transport_find ####
|
|
########################
|
|
sub transport_find {
|
|
my ($host, $tcmds) = @_;
|
|
my $logfh = $opts{logfh};
|
|
my ($fh, $tmp);
|
|
my %refs;
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
next if ($op ne 'find');
|
|
if ($host ne 'localhost') {
|
|
($fh, $tmp) = sftp_tmp() if (!$tmp);
|
|
print $fh join(" ", map {escape($_)} ($host, $src, $dst));
|
|
foreach my $opt (qw(srcfs tar_name tar_tell)) {
|
|
print $fh " $opt=$ref->{$opt}" if (defined $ref->{$opt});
|
|
}
|
|
print $fh " $ref\n";
|
|
$ref->{tool} = "shift-find";
|
|
}
|
|
$refs{$ref} = [$src, $dst, $ref];
|
|
}
|
|
return if (!scalar(keys %refs));
|
|
|
|
$opts{lhost} = fqdn(hostname);
|
|
if ($tmp) {
|
|
# try to process remote finds using shift-aux
|
|
close $fh;
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
my $cmd = "$opts{ssh} $host $opts{caux} find";
|
|
foreach my $opt (qw(create-tar dereference extract-tar ignore-times
|
|
index-tar recall sync)) {
|
|
$cmd .= " --$opt" if ($opts{$opt});
|
|
}
|
|
foreach my $opt (qw(buffer find-files newer older preserve threads)) {
|
|
$cmd .= " --$opt $opts{$opt}" if ($opts{$opt});
|
|
}
|
|
foreach my $opt (qw(exclude include)) {
|
|
next if (!defined $opts{$opt});
|
|
$cmd .= " --$opt " . escape($_) foreach (@{$opts{$opt}});
|
|
}
|
|
|
|
my %drefs;
|
|
my $fhpid = open3_run([$tmp, undef, -1], $cmd);
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
s/\s+$//;
|
|
if (!/,/) {
|
|
if (/^ref\s+(\S+)$/) {
|
|
my $ref = $refs{$1}->[2];
|
|
$drefs{$ref} = $ref;
|
|
delete $refs{$ref};
|
|
} else {
|
|
# errors indicated by comma-less line
|
|
my ($ref, $err) = split(/:/, $_, 2);
|
|
$ref = $drefs{$ref};
|
|
sftp_error($ref, $err) if (defined $ref);
|
|
}
|
|
next;
|
|
}
|
|
print $logfh $_, " host=$opts{lhost}\n";
|
|
}
|
|
open3_wait($fhpid);
|
|
unlink $tmp;
|
|
return if (!scalar(keys %refs));
|
|
}
|
|
|
|
# process any remaining tar files
|
|
if ($opts{'extract-tar'}) {
|
|
tar_extract($host, @{$_}) foreach (values %refs);
|
|
return;
|
|
}
|
|
|
|
# check for existence of various commands
|
|
if ((!defined $opts{have} || !$opts{have}->{GET}) && $host eq 'localhost') {
|
|
$opts{have}->{GET} = 1;
|
|
foreach my $bin (qw(dmget lfs getfacl getfattr shift-bin)) {
|
|
$opts{have}->{$bin} = first {-x "$_/$bin"} (split(/:/, $ENV{PATH}));
|
|
}
|
|
}
|
|
|
|
if ($opts{recall} && $opts{have}->{dmget}) {
|
|
# must set up tmp file for recalls in case threads need to access
|
|
($opts{dmfh}, $opts{dmtmp}) = tempfile();
|
|
}
|
|
|
|
if ($perl{threads} && $opts{threads} > 1) {
|
|
$opts{findq} = Thread::Queue->new;
|
|
$opts{findeq} = Thread::Queue->new;
|
|
# number of worker "b's" processing files
|
|
$opts{findb4} = Thread::Semaphore->new(0);
|
|
# number of items that have been added to queue
|
|
$opts{findn4} = Thread::Semaphore->new(1);
|
|
# mutual exclusion for stdout
|
|
$opts{findo4} = Thread::Semaphore->new(1);
|
|
# number of unprocessed items on queue
|
|
$opts{findq4} = Thread::Semaphore->new(0);
|
|
} else {
|
|
# need to define file count as used in both single/multi-threaded cases
|
|
$opts{findn4} = \0;
|
|
$opts{fhpid} = open3_run([undef, undef, -1], "shift-bin")
|
|
if ($opts{have}->{'shift-bin'} && ($opts{preserve} == 1 ||
|
|
$opts{preserve} =~ /acl|stripe|xattr/));
|
|
}
|
|
|
|
foreach (values %refs) {
|
|
# compute local (or remote if shift-aux fails) files and sizes
|
|
my ($spath, $dst, $ref) = @{$_};
|
|
$ref->{tool} = "shift-find";
|
|
my $sdir = dirname($spath);
|
|
$sdir = "" if ($sdir eq '/');
|
|
my $ddir = dirname($dst);
|
|
$ddir = "" if ($ddir eq '/');
|
|
my $path = [[basename($spath), basename($dst),
|
|
$perl{threads} && $opts{threads} > 1 ? "" . $ref : $ref],
|
|
$host, $sdir, $dst, $ddir, $ref->{srcfs}];
|
|
if ($opts{'create-tar'}) {
|
|
my $tdir = dirname(unescape($ref->{tar_name}));
|
|
$tdir = "" if ($tdir eq '.');
|
|
$tdir .= "/" if ($tdir && $tdir !~ /\/$/);
|
|
push(@{$path}, $tdir);
|
|
}
|
|
if ($perl{threads} && $opts{threads} > 1) {
|
|
$opts{findq4}->up;
|
|
$opts{findn4}->up;
|
|
$opts{findq}->enqueue($path);
|
|
} else {
|
|
transport_find1($path);
|
|
}
|
|
}
|
|
|
|
if ($perl{threads} && $opts{threads} > 1) {
|
|
my @threads = map {threads->create(sub {
|
|
$opts{fhpid} = open3_run([undef, undef, -1], "shift-bin")
|
|
if ($opts{have}->{'shift-bin'} && ($opts{preserve} == 1 ||
|
|
$opts{preserve} =~ /acl|stripe|xattr/));
|
|
# remove existing ssh connections so threads use their own
|
|
delete @opts{grep(/^sftp_/, keys %opts)};
|
|
while (1) {
|
|
my $path;
|
|
if ($opts{findq}->can('dequeue_timed')) {
|
|
$path = $opts{findq}->dequeue_timed(1);
|
|
} else {
|
|
$path = $opts{findq}->dequeue_nb;
|
|
if (!defined $path) {
|
|
# must fake timed dequeue - use thread-safe sleep
|
|
select(undef, undef, undef, 1);
|
|
$path = $opts{findq}->dequeue_nb;
|
|
}
|
|
}
|
|
if (defined $path) {
|
|
$opts{findb4}->up;
|
|
$opts{findq4}->down;
|
|
transport_find1($path);
|
|
$opts{findb4}->down;
|
|
} elsif (!${$opts{findq4}} && !${$opts{findb4}}) {
|
|
transport_find_buffer();
|
|
last;
|
|
}
|
|
}
|
|
open3_wait($opts{fhpid}) if (defined $opts{fhpid});
|
|
})} (1 .. $opts{threads});
|
|
|
|
foreach (@threads) {
|
|
$_->join if ($_);
|
|
}
|
|
# add error messages back to original ref
|
|
while (defined (my $referr = $opts{findeq}->dequeue_nb)) {
|
|
my ($ref, $err) = @{$referr};
|
|
sftp_error($refs{$ref}->[2], $err) if (defined $refs{$ref});
|
|
}
|
|
delete $opts{"find" . $_} foreach (qw(q eq b4 n4 o4 q4));
|
|
} else {
|
|
transport_find_buffer();
|
|
open3_wait($opts{fhpid}) if (defined $opts{fhpid});
|
|
}
|
|
|
|
if ($opts{recall} && $opts{have}->{dmget}) {
|
|
close $opts{dmfh};
|
|
if (-s $opts{dmtmp}) {
|
|
# fork to avoid intermittent hangs of dmget
|
|
my $pid = fork_setsid();
|
|
if ($pid) {
|
|
waitpid($pid, 0);
|
|
delete $opts{dmfh};
|
|
delete $opts{dmtmp};
|
|
} else {
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
my $ssh = $host eq 'localhost' ? "" : "$opts{ssh} $host";
|
|
my $extra = $opts{'create-tar'} ? " -a" : "";
|
|
# ignore errors since files are automatically retrieved anyway
|
|
open3_get([$opts{dmtmp}, -1, -1], "$ssh dmget -nq$extra");
|
|
unlink $opts{dmtmp};
|
|
POSIX::_exit(0);
|
|
}
|
|
} else {
|
|
unlink $opts{dmtmp};
|
|
}
|
|
}
|
|
}
|
|
|
|
###############################
|
|
#### transport_find_buffer ####
|
|
###############################
|
|
# write output in blocks for efficiency
|
|
sub transport_find_buffer {
|
|
my ($text, $file) = @_;
|
|
$opts{find_buf} .= $text;
|
|
$opts{recall_buf} .= $file;
|
|
if (($opts{find_buf} || $opts{recall_buf}) &&
|
|
(!defined $text || length $opts{find_buf} >= $opts{buffer} ||
|
|
length $opts{recall_buf} >= $opts{buffer})) {
|
|
$opts{findo4}->down if ($perl{threads} && $opts{threads} > 1);
|
|
if ($opts{find_buf} && (!defined $text ||
|
|
length $opts{find_buf} >= $opts{buffer})) {
|
|
print {$opts{logfh}} $opts{find_buf};
|
|
$opts{logfh}->flush;
|
|
delete $opts{find_buf};
|
|
}
|
|
if ($opts{recall_buf} && (!defined $text ||
|
|
length $opts{recall_buf} >= $opts{buffer})) {
|
|
print {$opts{dmfh}} $opts{recall_buf};
|
|
$opts{dmfh}->flush;
|
|
delete $opts{recall_buf};
|
|
}
|
|
$opts{findo4}->up if ($perl{threads} && $opts{threads} > 1);
|
|
}
|
|
}
|
|
|
|
#########################
|
|
#### transport_find1 ####
|
|
#########################
|
|
# output list of files/dirs beneath given paths with stat info
|
|
sub transport_find1 {
|
|
my $path = shift;
|
|
my ($file0, $shost, $sdir, $dst, $ddir, $srcfs, $tdir) = @{$path};
|
|
my $dfile0 = $file0;
|
|
my ($top, $ref);
|
|
if (ref $file0) {
|
|
$top = 1;
|
|
($file0, $dfile0, $ref) = @{$file0};
|
|
}
|
|
return if ($file0 eq '.' || $file0 eq '..');
|
|
my $file = "$sdir/$file0";
|
|
|
|
my $dmf = $opts{recall} && $opts{have}->{dmget} && $srcfs =~ /,dmf/ ? 1 : 0;
|
|
|
|
# dereference before stat
|
|
if ($opts{dereference}) {
|
|
$file = $shost eq 'localhost' ?
|
|
abs_path($file) : sftp($shost)->realpath($file);
|
|
}
|
|
# always get stat info of real file
|
|
my @stat;
|
|
if ($file) {
|
|
if ($shost eq 'localhost') {
|
|
@stat = lstat($file);
|
|
} else {
|
|
my $fattrs = sftp($shost)->lstat($file);
|
|
if ($fattrs) {
|
|
# approximate local stat
|
|
@stat = (0, 0, $fattrs->perm , 0, $fattrs->uid, $fattrs->gid,
|
|
0, $fattrs->size, $fattrs->atime, $fattrs->mtime,
|
|
$fattrs->mtime, 0, int($fattrs->size / 512));
|
|
}
|
|
}
|
|
}
|
|
my $mode;
|
|
if (scalar(@stat) == 0) {
|
|
$file = "$sdir/$file0" if ($opts{dereference});
|
|
if ($top) {
|
|
# return error if original file
|
|
my $err = "Cannot stat $file";
|
|
if ($perl{threads} && $opts{threads} > 1) {
|
|
$opts{findeq}->enqueue([$ref, $err]);
|
|
} else {
|
|
sftp_error($ref, $err);
|
|
}
|
|
return;
|
|
}
|
|
# lower level files cannot return errors because there is no way
|
|
# to back out of previously added operations, so instead a find
|
|
# op is added, which will succeed/fail on its own when processed
|
|
} else {
|
|
$mode = $stat[2];
|
|
$stat[2] &= 07777;
|
|
|
|
# only directories, regular files, and symlinks are supported
|
|
return if (!S_ISDIR($mode) && !S_ISREG($mode) && !S_ISLNK($mode));
|
|
# dmf handling for individual files is carried out by transport_dmf
|
|
$dmf = 0 if ($top && !S_ISDIR($mode));
|
|
}
|
|
|
|
# exclude files (must be before dir processing)
|
|
if (defined $opts{exclude}) {
|
|
foreach (@{$opts{exclude}}) {
|
|
my $re = /^\\Q/ ? quotemeta(substr($_, 2)) : $_;
|
|
return if (eval {$file =~ /$re/});
|
|
}
|
|
}
|
|
|
|
my $dh;
|
|
if (scalar(@stat) == 0 || S_ISDIR($mode)) {
|
|
# ensure $err defined unless explicitly set to undef
|
|
my $err = "";
|
|
if (scalar(@stat) > 0 && ($top || !$opts{dereference}) &&
|
|
($top || !defined $opts{'find-files'} ||
|
|
${$opts{findn4}} < $opts{'find-files'})) {
|
|
# add subdirs of this directory for processing when below limit
|
|
if ($shost eq 'localhost' ? opendir($dh, $file) :
|
|
($dh = sftp($shost)->opendir($file))) {
|
|
$err = undef;
|
|
# directory will be processed after parent dir printed
|
|
} else {
|
|
$err = "Error opening directory $file";
|
|
}
|
|
if ($err && $top) {
|
|
# return error if original file
|
|
if ($perl{threads} && $opts{threads} > 1) {
|
|
$opts{findeq}->enqueue([$ref, $err]);
|
|
} else {
|
|
sftp_error($ref, $err);
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
if (defined $err) {
|
|
# this handles directories as well as lower level stat failures
|
|
my $line = "args=find," . escape(hostpath($shost, $file)) . ",";
|
|
$line .= $opts{'create-tar'} ? escape($dst) . " tar_name=" .
|
|
escape("$tdir$file0") : escape("$ddir/$dfile0");
|
|
transport_find_buffer($line . " host=$opts{lhost}\n");
|
|
return;
|
|
}
|
|
}
|
|
|
|
# include files
|
|
if (defined $opts{include}) {
|
|
my $found;
|
|
foreach (@{$opts{include}}) {
|
|
my $re = /^\\Q/ ? quotemeta(substr($_, 2)) : $_;
|
|
next if (eval {$file !~ /$re/});
|
|
$found = 1;
|
|
last;
|
|
}
|
|
# must be done both here for files and after dir processing
|
|
goto FIND_DIR if (!$found);
|
|
}
|
|
|
|
# newer/older files
|
|
my %ti = ('a' => 8, 'm' => 9, 'c' => 10);
|
|
if (defined $opts{newer}) {
|
|
if ($opts{newer} =~ /^([^:]+):(\S+)/) {
|
|
my ($type, $time) = ($1, $2);
|
|
$type =~ s/\|/1||/g;
|
|
$type =~ s/([amc])/$stat[$ti{$1}]>=$time&&/g;
|
|
$type =~ s/([AMC])/$stat[$ti{lc($1)}]<$time&&/g;
|
|
$type .= "1";
|
|
# must be done both here for files and after dir processing
|
|
goto FIND_DIR if (!eval $type);
|
|
} elsif ($stat[9] < $opts{newer}) {
|
|
# must be done both here for files and after dir processing
|
|
goto FIND_DIR;
|
|
}
|
|
}
|
|
if (defined $opts{older}) {
|
|
if ($opts{older} =~ /^([^:]+):(\S+)/) {
|
|
my ($type, $time) = ($1, $2);
|
|
$type =~ s/\|/1||/g;
|
|
$type =~ s/([amc])/$stat[$ti{$1}]<$time&&/g;
|
|
$type =~ s/([AMC])/$stat[$ti{lc($1)}]>=$time&&/g;
|
|
$type .= "1";
|
|
# must be done both here for files and after dir processing
|
|
goto FIND_DIR if (!eval $type);
|
|
} elsif ($stat[9] >= $opts{older}) {
|
|
# must be done both here for files and after dir processing
|
|
goto FIND_DIR;
|
|
}
|
|
}
|
|
|
|
# resolve uid/gid if possible
|
|
my $user = $opts{findu}->{$stat[4]};
|
|
if (!defined $user) {
|
|
$user = getpwuid($stat[4]);
|
|
$user = "uid_$stat[4]" if (!$user);
|
|
$opts{findu}->{$stat[4]} = $user;
|
|
}
|
|
my $group = $opts{findg}->{$stat[5]};
|
|
if (!defined $group) {
|
|
$group = getgrgid($stat[5]);
|
|
$group = "gid_$stat[5]" if (!$group);
|
|
$opts{findg}->{$stat[5]} = $group;
|
|
}
|
|
my $attrs = join(",", @stat[2,4,5,8,9],
|
|
escape($user), escape($group), $stat[7], 512 * $stat[12]);
|
|
|
|
my @acls;
|
|
my @lattrs;
|
|
my @xattrs;
|
|
if ($shost eq 'localhost') {
|
|
# if shift-aux failed, there is no backup to get this info remotely
|
|
# try to get acls
|
|
if (($opts{have}->{'shift-bin'} || $opts{have}->{getfacl}) &&
|
|
!$opts{'create-tar'} &&
|
|
($opts{preserve} == 1 || $opts{preserve} =~ /acl/) &&
|
|
(!$srcfs || $srcfs =~ /,acl/)) {
|
|
if (defined $opts{fhpid}) {
|
|
$opts{fhpid}->[0]->print("getfacl $file\n");
|
|
my $text = $opts{fhpid}->[1]->getline;
|
|
my @cols = split(/\s+/, $text);
|
|
push(@acls, $cols[2]) if ($file eq $cols[1] && $cols[-1] eq '0');
|
|
} else {
|
|
my $fhpid = open3_run([-1, undef, -1],
|
|
"getfacl", "-cps", "--", $file);
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
chomp;
|
|
next if (!$_);
|
|
push(@acls, escape($_));
|
|
}
|
|
open3_wait($fhpid);
|
|
}
|
|
}
|
|
|
|
# try to get xattrs
|
|
if (($opts{have}->{'shift-bin'} || $opts{have}->{getfattr}) &&
|
|
!$opts{'create-tar'} &&
|
|
($opts{preserve} == 1 || $opts{preserve} =~ /xattr/) &&
|
|
(!$srcfs || $srcfs =~ /,xattr/)) {
|
|
if (defined $opts{fhpid}) {
|
|
$opts{fhpid}->[0]->print("getfattr $file\n");
|
|
my $text = $opts{fhpid}->[1]->getline;
|
|
my @cols = split(/\s+/, $text);
|
|
push(@xattrs, $cols[2]) if ($file eq $cols[1] && $cols[-1] eq '0');
|
|
} else {
|
|
my $fhpid = open3_run([-1, undef, -1],
|
|
"getfattr", "-dhe", "base64", $file);
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
chomp;
|
|
next if (!$_ || /^\s*#/);
|
|
push(@xattrs, escape(decode_base64($_)));
|
|
}
|
|
open3_wait($fhpid);
|
|
}
|
|
}
|
|
|
|
# try to get lustre striping
|
|
if (($opts{have}->{'shift-bin'} || $opts{have}->{lfs}) &&
|
|
!S_ISLNK($mode) && !$opts{'create-tar'} &&
|
|
($opts{preserve} == 1 || $opts{preserve} =~ /stripe/) &&
|
|
$srcfs =~ /^lustre/) {
|
|
# ignore symlinks as link to fifo can hang forever
|
|
if (defined $opts{fhpid}) {
|
|
$opts{fhpid}->[0]->print("getstripe $file\n");
|
|
my $text = $opts{fhpid}->[1]->getline;
|
|
my @cols = split(/\s+/, $text);
|
|
@lattrs = split(/,/, $cols[2]) if ($file eq $cols[1] && $cols[-1] eq '0');
|
|
} else {
|
|
my $fhpid = open3_run([-1, undef, -1],
|
|
"lfs", "getstripe", "-d", $file);
|
|
while (defined $fhpid && defined ($_ = $fhpid->[1]->getline)) {
|
|
$lattrs[0] = $1 if (/stripe_count:\s*(-?\d+)/);
|
|
$lattrs[1] = $1 if (/stripe_size:\s*(-?\d+)/);
|
|
}
|
|
open3_wait($fhpid);
|
|
}
|
|
}
|
|
$lattrs[0] = 0 if (!defined $lattrs[0] && defined $lattrs[1]);
|
|
$lattrs[1] = 0 if (!defined $lattrs[1] && defined $lattrs[0]);
|
|
}
|
|
|
|
# begin log entry
|
|
my $line;
|
|
my $index_len = !$opts{'index-tar'} ? 0 : 28 + length("$tdir$file0") +
|
|
length(sprintf("%7s%7s%9d", $user, $group, $stat[7]));
|
|
if (S_ISLNK($mode)) {
|
|
my $ln = $shost eq 'localhost' ? readlink($file) :
|
|
sftp($shost)->readlink($file);
|
|
$line .= "args=ln," . escape($ln);
|
|
$index_len += 4 + length($ln);
|
|
} elsif (S_ISDIR($mode)) {
|
|
$line .= "args=mkdir";
|
|
} elsif ($opts{sync}) {
|
|
$line .= "args=ckattr" . ($opts{'ignore-times'} ? "0" : "") .
|
|
"," . escape(hostpath($shost, $file));
|
|
} else {
|
|
$line .= "args=cp," . escape(hostpath($shost, $file));
|
|
}
|
|
$line .= "," . (escape($opts{'create-tar'} ? $dst : "$ddir/$dfile0"));
|
|
$line .= " acls=" . join(",", @acls) if (scalar(@acls) > 0);
|
|
$line .= " xattrs=" . join(",", @xattrs) if (scalar(@xattrs) > 0);
|
|
$line .= " lustre_attrs=" . join(",", @lattrs) if (scalar(@lattrs) > 0);
|
|
$line .= " tar_index=$index_len" if ($opts{'index-tar'});
|
|
$line .= " tar_name=" . escape("$tdir$file0") if ($opts{'create-tar'});
|
|
$line .= " size=$stat[7] attrs=$attrs host=$opts{lhost}\n";
|
|
transport_find_buffer($line, !S_ISLNK($mode) && !S_ISDIR($mode) &&
|
|
$dmf ? $file . "\n" : undef);
|
|
|
|
FIND_DIR: if (defined $dh) {
|
|
# flush buffer to ensure parent dir printed before subdirs
|
|
transport_find_buffer();
|
|
while (1) {
|
|
my $ent;
|
|
if ($shost eq 'localhost') {
|
|
$ent = readdir $dh;
|
|
} else {
|
|
$ent = sftp($shost)->readdir($dh);
|
|
$ent = $ent->{filename} if ($ent);
|
|
}
|
|
last if (!defined $ent);
|
|
my $path = [$ent, $shost, $file, $dst, "$ddir/$dfile0", $srcfs];
|
|
push(@{$path}, "$tdir$file0/") if ($opts{'create-tar'});
|
|
if ($perl{threads} && $opts{threads} > 1 &&
|
|
#$opts{findq}->pending < $opts{'queue-size'}) {
|
|
#$opts{findq}->pending < $opts{'threads'}) {
|
|
#TODO: determine what size should go here
|
|
${$opts{findq4}} < 4 * $opts{threads}) {
|
|
# only add to queue if not already at capacity
|
|
$opts{findq4}->up;
|
|
$opts{findn4}->up;
|
|
$opts{findq}->enqueue($path);
|
|
} else {
|
|
# process now if single threaded or queue at capacity
|
|
transport_find1($path);
|
|
}
|
|
}
|
|
closedir $dh;
|
|
}
|
|
}
|
|
|
|
########################
|
|
#### transport_fish ####
|
|
########################
|
|
sub transport_fish {
|
|
my ($host, $tcmds, $tcp) = @_;
|
|
|
|
my $nstream = $host eq 'localhost' ? $opts{threads} : $opts{streams};
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
my $ssh = $host ne 'localhost' ?
|
|
"$opts{ssh} -oServerAliveInterval=60 $host " : "";
|
|
my ($extra, $extra_tcp);
|
|
$extra .= " --buffer-size=" . ($opts{buffer} >> 20) if ($opts{buffer});
|
|
if ($opts{verify} && $opts{'verify-fast'}) {
|
|
$extra .= " --verify --hash-type=$opts{sum_type}";
|
|
$extra .= " --split-size=" . ($opts{sum_split} >> 20);
|
|
}
|
|
if ($perl{threads} && $tcp && (!$opts{secure} || $perl{ssl})) {
|
|
$extra_tcp .= " --ports=" . $opts{ports} if ($opts{ports});
|
|
$extra_tcp .= " --secure" if ($opts{secure});
|
|
$extra_tcp .= " --streams=" . $nstream if ($nstream);
|
|
$extra_tcp .= " --tcp";
|
|
$extra_tcp .= " --window=" . ($opts{window}) if ($opts{window});
|
|
} else {
|
|
$tcp = 0;
|
|
}
|
|
my $fhpid = open3_run([undef, undef, -1],
|
|
"$ssh$opts{caux} fish $extra $extra_tcp");
|
|
my ($out, $in) = ($fhpid->[0], $fhpid->[1]);
|
|
|
|
my ($cert, $key, $port);
|
|
my $rc0 = transport_fish_return($in, "init");
|
|
if (ref $rc0 && $rc0->{error} =~ /noport|nossl|nothread/) {
|
|
$rc0 = undef;
|
|
$tcp = 0;
|
|
} elsif (!ref $rc0 && $tcp) {
|
|
($port, $key, my $scert) = split(/\s+/, $rc0);
|
|
if ($scert) {
|
|
(my $fh, $cert) = sftp_tmp();
|
|
print $fh unescape($scert);
|
|
close $fh;
|
|
}
|
|
}
|
|
|
|
my @fcmds;
|
|
my $qi = 0;
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
$ref->{tool} = $tcp ? "fish-tcp" : "fish";
|
|
if (ref $rc0) {
|
|
sftp_error($ref, $rc0->{error});
|
|
next;
|
|
}
|
|
if (!$opts{'create-tar'} && !$ref->{bytes} && $opts{recall} &&
|
|
$ref->{dstfs} =~ /,dmf/) {
|
|
# truncate dst on dmf to prevent file from being recalled
|
|
if ($host eq 'localhost') {
|
|
truncate($dst, 0);
|
|
} else {
|
|
sftp($host)->truncate($dst, 0);
|
|
}
|
|
}
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
my $size = $opts{'create-tar'} ? -1 : $attrs[7];
|
|
my ($toff) = split(/-/, $ref->{tar_bytes});
|
|
|
|
# create implicit directories
|
|
eval {mkpath(dirname($dst))} if ($op eq 'get');
|
|
|
|
my @ranges = split(/,/, $ref->{bytes});
|
|
push(@ranges, "-") if (scalar(@ranges) == 0);
|
|
foreach my $range (@ranges) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
if (!$perl{threads} || $nstream <= 1 && !$tcp) {
|
|
my $rc = transport_fish_io($in, $out, $op, $src, $dst,
|
|
$size, $toff, $x2 ? $x2 - $x1 : undef, $x2 ? $x1 : undef);
|
|
if (ref $rc) {
|
|
$ref->{error} .= $rc->{error} =~ /^\\H/ ?
|
|
$rc->{error} : "\\E" . $rc->{error};
|
|
}
|
|
next;
|
|
}
|
|
($x1, $x2) = (0, $size) if (!$x2);
|
|
# hard coded split size of 1 GB
|
|
for (my $x = $x1; $x == $x1 || $x < $x2; $x += 1073741824) {
|
|
push(@fcmds, [$qi, [$op, $src, $dst, $size, $toff,
|
|
min($x2 - $x, 1073741824), $x]]);
|
|
}
|
|
}
|
|
$qi++;
|
|
}
|
|
|
|
if (!$perl{threads} || $nstream <= 1 && !$tcp) {
|
|
# work has already been done in loop so exit
|
|
$out->write("#exit\n") if (!ref $rc0);
|
|
open3_wait($fhpid);
|
|
unlink $cert if ($cert);
|
|
return;
|
|
} elsif (ref $rc0) {
|
|
# unable to contact remote side (ops already marked with error)
|
|
return;
|
|
}
|
|
|
|
# original process is a thread when using ssh
|
|
$nstream-- if (!$tcp);
|
|
# choose min of specified threads and amount of work
|
|
$nstream = min($nstream, scalar(@fcmds));
|
|
if ($tcp) {
|
|
transport_fish_io(undef, $out, @{$_->[1]}) foreach (@fcmds);
|
|
$out->write("#streams $nstream\n");
|
|
$out->write("#exit\n");
|
|
}
|
|
|
|
foreach my $o (keys %opts) {
|
|
# must kill existing sftp connections or various things can hang
|
|
next if ($o !~ /^sftp_[^d]/);
|
|
$opts{$o}->disconnect;
|
|
delete $opts{$o};
|
|
}
|
|
|
|
require Digest::HMAC;
|
|
require Digest::SHA::PurePerl;
|
|
my $q = Thread::Queue->new;
|
|
my $qret = Thread::Queue->new;
|
|
|
|
# remove user name (if applicable)
|
|
$host = (split(/@/, $host))[-1];
|
|
$q->enqueue(0 .. scalar(@fcmds) - 1);
|
|
my @threads = map {threads->create(sub {
|
|
my ($tin, $tout, $tfhpid, $trc0);
|
|
my $nonce2;
|
|
if ($tcp) {
|
|
$tin = IO::Socket::INET->new(
|
|
Proto => "tcp",
|
|
PeerAddr => $host,
|
|
PeerPort => $port,
|
|
);
|
|
if ($opts{secure}) {
|
|
# this can only be reached if ssl is available
|
|
IO::Socket::SSL->start_SSL($tin,
|
|
SSL_use_cert => 1,
|
|
SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
|
|
SSL_verifycn_name => $key,
|
|
SSL_hostname => $key,
|
|
SSL_ca_file => $cert,
|
|
SSL_cert_file => $cert,
|
|
SSL_key_file => $cert,
|
|
) or return "Unable to start SSL";
|
|
}
|
|
if ($tin) {
|
|
if ($opts{window}) {
|
|
# this has been observed to be detrimental to performance
|
|
# in practice so revert to default linux window scaling
|
|
#$tin->sockopt(SO_RCVBUF, $opts{window});
|
|
#$tin->sockopt(SO_SNDBUF, $opts{window});
|
|
}
|
|
#TODO: de-hardcode 60 second timeout
|
|
$tin->sockopt(SO_RCVTIMEO, pack('L!L!', +60, 0));
|
|
$tin->sockopt(SO_SNDTIMEO, pack('L!L!', +60, 0));
|
|
$tin->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1);
|
|
$tout = $tin;
|
|
my $nonce = "" . rand();
|
|
my $hmac = Digest::HMAC::hmac_hex($nonce, $key,
|
|
\&Digest::SHA::PurePerl::sha512);
|
|
|
|
$tout->print($nonce . " " . $hmac . "\n### 100\n");
|
|
my $trc = transport_fish_return($tin, "auth");
|
|
my ($hmac2, $my_hmac2);
|
|
if (!ref $trc) {
|
|
($nonce2, $hmac2) = split(/\s+/, $trc);
|
|
$my_hmac2 = Digest::HMAC::hmac_hex($nonce . $nonce2, $key,
|
|
\&Digest::SHA::PurePerl::sha512);
|
|
}
|
|
if (ref $trc || $hmac2 ne $my_hmac2) {
|
|
# remote side cannot be authenticated
|
|
close $tout;
|
|
return ($trc->{error}) if ($trc->{error});
|
|
return "Unable to authenticate stream";
|
|
}
|
|
} else {
|
|
return "Unable to connect to $host:$port";
|
|
}
|
|
} else {
|
|
$tfhpid = open3_run([undef, undef, -1],
|
|
"$ssh$opts{caux} fish $extra");
|
|
($tout, $tin) = ($tfhpid->[0], $tfhpid->[1]);
|
|
$trc0 = transport_fish_return($tin, "tinit");
|
|
}
|
|
while (defined (my $fi = $q->dequeue_nb)) {
|
|
$tin = $fi . " " . Digest::HMAC::hmac_hex($fi . $nonce2++, $key,
|
|
\&Digest::SHA::PurePerl::sha512) if ($tcp);
|
|
my $trc = transport_fish_io($tin, $tout, @{$fcmds[$fi]->[1]});
|
|
my $text = ref $trc ? $trc->{error} : undef;
|
|
$text = "\\E" . $text if ($text && $text !~ /^\\H/);
|
|
$qret->enqueue([$fi, $text]);
|
|
}
|
|
if ($tcp) {
|
|
$tout->print("-1 " . Digest::HMAC::hmac_hex("-1" . $nonce2++, $key,
|
|
\&Digest::SHA::PurePerl::sha512) . "\n### 100\n");
|
|
close $tout;
|
|
} else {
|
|
$tout->write("#exit\n") if (!ref $trc0);
|
|
open3_wait($tfhpid);
|
|
}
|
|
return 0;
|
|
})} (1 .. $nstream);
|
|
|
|
if (!$tcp) {
|
|
while (defined (my $fi = $q->dequeue_nb)) {
|
|
my $trc = transport_fish_io($in, $out, @{$fcmds[$fi]->[1]});
|
|
my $text = ref $trc ? $trc->{error} : undef;
|
|
$text = "\\E" . $text if ($text && $text !~ /^\\H/);
|
|
$qret->enqueue([$fi, $text]);
|
|
}
|
|
$out->write("#exit\n") if (!ref $rc0);
|
|
}
|
|
if (first {defined($_)} @threads) {
|
|
my %errs;
|
|
foreach (@threads) {
|
|
my $err = $_ ? $_->join : undef;
|
|
$errs{$err}++ if ($err);
|
|
}
|
|
if (sum(values %errs) == scalar(@threads)) {
|
|
# no work has been done
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
sftp_error($ref, join("; ", keys %errs));
|
|
}
|
|
}
|
|
} elsif ($tcp) {
|
|
# no threads could be started and no work done by current process
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
sftp_error($ref, "Unable to create tcp thread(s)");
|
|
}
|
|
}
|
|
open3_wait($fhpid);
|
|
unlink $cert if ($cert);
|
|
|
|
# append any hashes/error messages back to original ref text
|
|
while (defined (my $itext = $qret->dequeue_nb)) {
|
|
my ($fi, $text) = @{$itext};
|
|
sftp_echo($tcmds->[$fcmds[$fi]->[0]]->[3], $text)
|
|
if ($tcmds->[$fcmds[$fi]->[0]]->[3]->{text} !~ /\Q$text\E/);
|
|
}
|
|
}
|
|
|
|
###########################
|
|
#### transport_fish_io ####
|
|
###########################
|
|
sub transport_fish_io {
|
|
my ($in, $out, $cmd, $src, $dst, $size, $toff, $len, $off) = @_;
|
|
my $file = $cmd eq 'get' ? $dst : $src;
|
|
$len = (stat $file)[7] if (!defined $len && $cmd eq 'put');
|
|
|
|
my $roff = $off;
|
|
$roff -= $toff if ($opts{'create-tar'} && $cmd eq 'get' ||
|
|
$opts{'extract-tar'} && $cmd eq 'put');
|
|
$off -= $toff if ($opts{'create-tar'} && $cmd eq 'put' ||
|
|
$opts{'extract-tar'} && $cmd eq 'get');
|
|
if (defined $in && !ref $in) {
|
|
$out->print($in, "\n### 100\n");
|
|
$in = $out;
|
|
} else {
|
|
$out->write("#" . join(" ", map {escape($_)}
|
|
($cmd, $src, $dst, $size, $len, $roff)) . "\n");
|
|
}
|
|
return if (!defined $in);
|
|
|
|
my $flags = $cmd eq 'put' ? O_RDONLY : O_WRONLY | O_CREAT;
|
|
$flags |= O_TRUNC if (!defined $off && $cmd eq 'get');
|
|
my $fh = IO::File->new($file, $flags);
|
|
my $err;
|
|
if (!defined $fh) {
|
|
$err = {error => "Error opening $file: $!"};
|
|
# remove cr/lf so doesn't interfere with protocol
|
|
$err->{error} =~ s/[\n\r]//g;
|
|
$out->write("### 500 $err->{error}: $!\n");
|
|
} elsif (defined $off && !$fh->seek($off, 0)) {
|
|
$fh->close;
|
|
$err = {error => "Error seeking $file: $!"};
|
|
# remove cr/lf so doesn't interfere with protocol
|
|
$err->{error} =~ s/[\n\r]//g;
|
|
$out->write("### 500 $err->{error}: $!\n");
|
|
} else {
|
|
$out->write("$len\n") if ($cmd eq 'put');
|
|
$out->write("### 100\n");
|
|
}
|
|
my $rc = transport_fish_return($in, "open");
|
|
return (ref $err ? $err : $rc) if (ref $err || ref $rc);
|
|
$len = $rc if ($cmd eq 'get');
|
|
$rc = undef;
|
|
my $wlen = $len;
|
|
|
|
my $sopts = !$opts{verify} || !$opts{'verify-fast'} || $cmd ne 'put' ? 0 :
|
|
verify_init(length => $len);
|
|
my $nbytes = $opts{buffer} ? $opts{buffer} : 4 << 20;
|
|
while ($len > 0) {
|
|
$nbytes = $len if ($len < $nbytes);
|
|
if ($cmd eq 'get') {
|
|
$rc = transport_fish_return($in, "copy $len");
|
|
if (ref $rc) {
|
|
$fh->close;
|
|
return $rc;
|
|
}
|
|
}
|
|
my $buf;
|
|
my $n = $cmd eq 'get' ?
|
|
$in->read($buf, $nbytes) : $fh->sysread($buf, $nbytes);
|
|
last if ($n < $nbytes);
|
|
$out->write("### 200\n") if ($cmd eq 'put');
|
|
my $wn = $cmd eq 'get' ? $fh->syswrite($buf) : $out->write($buf);
|
|
$len -= $n;
|
|
# write() only returns ok/fail and not size like read()
|
|
$wlen -= $cmd eq 'get' ? $wn : ($wn ? $n : 0);
|
|
verify_buffer($sopts, $buf, $sopts->{length} - $len)
|
|
if ($opts{verify} && $opts{'verify-fast'} && $cmd eq 'put');
|
|
}
|
|
$fh->close;
|
|
|
|
if ($len + $wlen > 0) {
|
|
my $io = $len ? "read" : "writ";
|
|
$rc = {error => "Error ${io}ing $file: $!"};
|
|
# remove newlines so doesn't interfere with protocol
|
|
$rc->{error} =~ s/\n//g;
|
|
$out->write("### 500 $rc->{error}\n");
|
|
transport_fish_return($in, $io);
|
|
} else {
|
|
$out->write("### 200\n");
|
|
$rc = transport_fish_return($in, "exit");
|
|
return {error => "\\H" . verify_buffer_end($sopts, $src, $off)}
|
|
if (!ref $rc && $opts{verify} && $opts{'verify-fast'} &&
|
|
$cmd eq 'put');
|
|
}
|
|
return $rc;
|
|
}
|
|
|
|
###############################
|
|
#### transport_fish_return ####
|
|
###############################
|
|
sub transport_fish_return {
|
|
my $in = shift;
|
|
my $msg = shift;
|
|
return {error => "Undefined input stream"} if (!defined $in);
|
|
my $text;
|
|
while (defined($_ = $in->getline)) {
|
|
if (/^###\s+(\d+)\s*(.*)/) {
|
|
if ($1 != 200 && $1 != 100) {
|
|
return {error => $2};
|
|
} else {
|
|
$text =~ s/\s+$//;
|
|
return $text;
|
|
}
|
|
} else {
|
|
$text .= $_;
|
|
}
|
|
}
|
|
return {error => "Invalid protocol return ($msg)"};
|
|
}
|
|
|
|
#######################
|
|
#### transport_mcp ####
|
|
#######################
|
|
sub transport_mcp {
|
|
my ($host, $tcmds) = @_;
|
|
my %emap = ("'" => "'", 0 => "\0", a => "\a", b => "\b", f => "\f",
|
|
n => "\n", r => "\r", t => "\t", v => "\v", '\\' => "\\");
|
|
my %errs;
|
|
my ($fh, $tmp);
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
($fh, $tmp) = sftp_tmp() if (!$tmp);
|
|
print $fh escape($src), " ", escape($dst);
|
|
my $bytes = $ref->{bytes};
|
|
if ($ref->{bytes}) {
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
my @stat = $opts{'create-tar'} ? () : stat $dst;
|
|
if ($opts{'create-tar'}) {
|
|
# copy full src to range of dst
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
my $prefix = " ";
|
|
foreach my $range (split(/,/, $ref->{bytes})) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
# adjust src by tar start offset
|
|
$bytes = ($x1 - $t1) . "-" . ($x2 - $t1);
|
|
print $fh $prefix, $bytes;
|
|
# prefix is ' ' initially, then ',' for the rest
|
|
$prefix = ",";
|
|
}
|
|
print $fh " $t1";
|
|
} elsif ($opts{'extract-tar'}) {
|
|
# copy src range to start of dst
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
my $prefix = " ";
|
|
foreach my $range (split(/,/, $ref->{bytes})) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
$bytes = "$x1-$x2";
|
|
print $fh $prefix, $bytes;
|
|
# prefix is ' ' initially, then ',' for the rest
|
|
$prefix = ",";
|
|
if ($x2 - $t1 == $attrs[7] && $stat[7] > $attrs[7]) {
|
|
# truncate dst if last split
|
|
truncate($dst, $attrs[7]);
|
|
}
|
|
}
|
|
# adjust dst by tar start offset
|
|
print $fh " -$t1";
|
|
} else {
|
|
foreach my $range (split(/,/, $ref->{bytes})) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
if ($x2 == $attrs[7] && $stat[7] > $attrs[7]) {
|
|
# truncate dst if last split
|
|
truncate($dst, $attrs[7]);
|
|
}
|
|
}
|
|
print $fh " $ref->{bytes}";
|
|
}
|
|
}
|
|
if ($ref->{split}) {
|
|
# need to track by split instead of file
|
|
$errs{"$dst bytes=$bytes"}->{$ref} = $ref;
|
|
$errs{"$src bytes=$bytes"}->{$ref} = $ref;
|
|
} else {
|
|
$errs{$dst}->{$ref} = $ref;
|
|
$errs{$src}->{$ref} = $ref;
|
|
}
|
|
print $fh "\n";
|
|
$ref->{tool} = "mcp";
|
|
}
|
|
return if (!$tmp);
|
|
close $fh;
|
|
|
|
my $out_tmp = sftp_tmp();
|
|
my $err_tmp = sftp_tmp();
|
|
my $extra = $opts{opts_mcp};
|
|
my ($type, $bits) = split(/_/, $opts{sum_type});
|
|
my $dash = $bits && $type =~ /\d$/ ? "-" : "";
|
|
$extra .= " --print-hash --check-tree --hash-type=$type$dash$bits --split-size=" .
|
|
($opts{sum_split} >> 20) if ($opts{verify} && $opts{'verify-fast'});
|
|
$extra .= " --buffer-size=" . ($opts{buffer} >> 20) if ($opts{buffer});
|
|
$extra .= " --threads=$opts{threads}" if ($opts{threads});
|
|
$extra .= " --print-src" if ($opts{'create-tar'});
|
|
# disable built-in striping as this will be handled by shift when needed
|
|
$extra .= " --stripe=0";
|
|
# must keep write access to handle warnings/corruption
|
|
open3_get([$tmp, $out_tmp, $err_tmp],
|
|
"mcp $extra --skip-chmod -P --read-stdin");
|
|
my $rc = $? >> 8;
|
|
|
|
if (open(ERR, '<', $err_tmp)) {
|
|
while (my $line = <ERR>) {
|
|
$line =~ s/\s+$//;
|
|
# any number of non-' or odd-\ with ' followed by
|
|
# non-' and non-\ or even-\ or odd-\ with '
|
|
while ($line =~ /[`']((?:[^']|[^'\\](\\\\)*\\')*(?:[^'\\]|[^'\\](\\\\)*|[^'\\](\\\\)*\\'))'/g) {
|
|
my $file = $1;
|
|
$file =~ s/\\([abfnrtv'\\])/$emap{$1}/g;
|
|
my @keys = grep(/^\Q$file\E( bytes=\d+-\d+)?$/, keys(%errs));
|
|
foreach my $key (@keys) {
|
|
$_->{text} = "\\E$line" foreach (values %{$errs{$key}});
|
|
}
|
|
}
|
|
}
|
|
close ERR;
|
|
}
|
|
unlink $err_tmp;
|
|
|
|
if ($opts{verify} && $opts{'verify-fast'} && open(OUT, '<', $out_tmp)) {
|
|
while (<OUT>) {
|
|
s/\s+$//;
|
|
if (/^(\S+)\s.(.*)/) {
|
|
my ($hash, $file) = ($1, $2);
|
|
# eliminate extra \ in files with \\ or \n
|
|
$file =~ s/\\([\\n])/$1 eq "n" ? "\n" : "\\"/eg
|
|
if ($hash =~ /(^|#)\\/);
|
|
my $refs = $errs{$file};
|
|
$refs = $errs{"$file bytes=$1-$2"}
|
|
if (!ref $refs && $hash =~ /^#mutil#(\d+)-(\d+)#/);
|
|
# skip if ref not found
|
|
next if (!ref $refs);
|
|
foreach my $ref (values %{$refs}) {
|
|
# skip if error/hash already recorded
|
|
next if ($ref->{text} =~ /^\\E|^\\H\Q$hash\E/);
|
|
# record hash in error ref
|
|
$ref->{text} .= "\\H$hash";
|
|
}
|
|
}
|
|
}
|
|
close OUT;
|
|
}
|
|
unlink $out_tmp;
|
|
unlink $tmp;
|
|
|
|
if ($rc == 127) {
|
|
foreach my $key (keys %errs) {
|
|
foreach (values %{$errs{$key}}) {
|
|
sftp_error($_, "unknown mcp failure") if (!defined $_->{text});
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#########################
|
|
#### transport_rsync ####
|
|
#########################
|
|
sub transport_rsync {
|
|
my ($host, $tcmds) = @_;
|
|
my %errs;
|
|
my ($fh, $tmp) = sftp_tmp();
|
|
my $sep = chr(0);
|
|
my ($shost, $spath, $dhost, $dpath, $args);
|
|
if ($host eq 'localhost') {
|
|
$shost = "";
|
|
$dhost = "";
|
|
} else {
|
|
$args = " -e '$opts{ssh} '";
|
|
}
|
|
|
|
my ($dmf, $rsize);
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
if (!$dmf && $opts{recall} && $ref->{dstfs} =~ /,dmf/) {
|
|
$dmf = 1;
|
|
# copy whole files to DMF to avoid destination reads/recalls
|
|
$args .= " -W";
|
|
}
|
|
$ref->{tool} = "rsync";
|
|
if (!defined $shost) {
|
|
$shost = $op eq 'get' ? "$host:" : "";
|
|
$dhost = $op eq 'put' ? "$host:" : "";
|
|
}
|
|
|
|
# find longest common suffix starting with "/"
|
|
if ("$src$sep$dst" =~ /^.*?(\/.*)$sep.*\1$/) {
|
|
my $lcs = $1;
|
|
if ($spath && $src eq "$spath$lcs" && $dst eq "$dpath$lcs") {
|
|
print $fh "$lcs\n";
|
|
$errs{"$spath$lcs"}->{$ref} = $ref;
|
|
$errs{"$dpath$lcs"}->{$ref} = $ref;
|
|
# track temporary dst name for permission errors
|
|
my $dst_tmp = dirname("$dpath$lcs") . "/." .
|
|
basename("$dpath$lcs") . ".XXXXXX";
|
|
$errs{$dst_tmp}->{$ref} = $ref;
|
|
next;
|
|
} elsif ($spath) {
|
|
# next file has different prefix so process current batch
|
|
close $fh;
|
|
# slash fixes one file in list bug where dst dir created as file
|
|
$rsize += transport_rsync_batch($args, $tmp,
|
|
"$shost$spath", "$dhost$dpath/", \%errs);
|
|
%errs = ();
|
|
open($fh, '>', $tmp);
|
|
}
|
|
print $fh "$lcs\n";
|
|
$spath = $src;
|
|
# escape lcs in case it contains regex characters
|
|
$spath =~ s/\Q$lcs\E$//;
|
|
$dpath = $dst;
|
|
$dpath =~ s/\Q$lcs\E$//;
|
|
$errs{"$spath$lcs"}->{$ref} = $ref;
|
|
$errs{"$dpath$lcs"}->{$ref} = $ref;
|
|
# track temporary dst name for permission errors
|
|
my $dst_tmp = dirname("$dpath$lcs") . "/." .
|
|
basename("$dpath$lcs") . ".XXXXXX";
|
|
$errs{$dst_tmp}->{$ref} = $ref;
|
|
} else {
|
|
# no common suffix implies single file copy with rename
|
|
# or symlink dereference
|
|
my %errs_tmp;
|
|
# use different hash as other files may already be in there
|
|
$errs_tmp{$src}->{$ref} = $ref;
|
|
$errs_tmp{$dst}->{$ref} = $ref;
|
|
# track temporary dst name for permission errors
|
|
my $dst_tmp = dirname($dst) . "/." . basename($dst) . ".XXXXXX";
|
|
$errs{$dst_tmp}->{$ref} = $ref;
|
|
$rsize += transport_rsync_batch($args, "",
|
|
"$shost$src", "$dhost$dst", \%errs_tmp);
|
|
}
|
|
}
|
|
|
|
close $fh;
|
|
if ($spath) {
|
|
# slash fixes one file in list bug where dst dir created as file
|
|
$rsize += transport_rsync_batch($args, $tmp,
|
|
"$shost$spath", "$dhost$dpath/", \%errs);
|
|
}
|
|
unlink $tmp;
|
|
return $rsize;
|
|
}
|
|
|
|
###############################
|
|
#### transport_rsync_batch ####
|
|
###############################
|
|
sub transport_rsync_batch {
|
|
my ($args, $from, $src, $dst, $errs) = @_;
|
|
my ($code, $code_text, $pid, $in, $out, $size);
|
|
$from = " --files-from $from" if ($from);
|
|
# copy inplace to avoid writing dot files in home directory
|
|
# do not do this when whole files used for DMF
|
|
$args .= " --inplace" if ($args !~ /-W/);
|
|
eval {
|
|
local $SIG{__WARN__} = sub {die};
|
|
# escape remote src/dst metacharacters since interpreted by remote shell
|
|
my ($esrc, $edst) = ($src, $dst);
|
|
$esrc =~ s/([^A-Za-z0-9\-_.\@:+\/])/\\$1/g if ($esrc =~ /^[^\/]/);
|
|
$edst =~ s/([^A-Za-z0-9\-_.\@:+\/])/\\$1/g if ($edst =~ /^[^\/]/);
|
|
# use open3 to avoid executing a shell command based on the name
|
|
# of a file being copied (which may contain metacharacters, etc.)
|
|
# must keep write access to handle warnings/corruption
|
|
$args = key_ssh($args) if ($opts{p} ne 'none');
|
|
$pid = IPC::Open3::open3($in, $out, $out,
|
|
# make sure quotewords string does not end in space
|
|
quotewords('\s+', 0, "rsync -l --chmod=u+rwX --stats$args$from"),
|
|
$esrc, $edst);
|
|
};
|
|
if ($@) {
|
|
$code = 1;
|
|
$code_text = "Unable to run rsync";
|
|
} else {
|
|
while (my $line = <$out>) {
|
|
$line =~ s/\s+$//;
|
|
if ($line =~ /"([^"]+)"/) {
|
|
my $file = $1;
|
|
foreach my $key (grep(/^\Q$file\E$/, keys(%{$errs}))) {
|
|
sftp_error($_, $line) foreach (values %{$errs->{$key}});
|
|
}
|
|
} elsif ($line =~ /\(code\s+(\d+)\)/) {
|
|
$code = $1;
|
|
$code_text = $line;
|
|
} elsif ($line =~ /Total file size:\s*([\d,]+)/) {
|
|
# start with total amount of data
|
|
my $tmp = $1;
|
|
$tmp =~ s/,//g;
|
|
$size += $tmp;
|
|
} elsif ($line =~ /Total transferred file size:\s*([\d,]+)/) {
|
|
# subtract data actually transferred
|
|
my $tmp = $1;
|
|
$tmp =~ s/,//g;
|
|
$size -= $tmp;
|
|
}
|
|
}
|
|
}
|
|
close $in;
|
|
close $out;
|
|
waitpid($pid, 0) if ($pid);
|
|
|
|
if (defined $code && $code != 23) {
|
|
# set error/warning on all failures except partial transfers (code 23)
|
|
my $type = $code <= 5 || $code == 255 ? "\\E" : "\\W";
|
|
foreach my $refs (values %{$errs}) {
|
|
foreach my $ref (values %{$refs}) {
|
|
$ref->{text} = "$type$code_text" if (!$ref->{text});
|
|
}
|
|
}
|
|
}
|
|
# return amount of data not actually transferred due to size/time match
|
|
return $size;
|
|
}
|
|
|
|
#########################
|
|
#### transport_shift ####
|
|
#########################
|
|
sub transport_shift {
|
|
my ($host, $tcmds) = @_;
|
|
my @scmds;
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
$ref->{tool} = $op eq 'chattr' ? "shift-chattr" : "shift-cp";
|
|
if (!$perl{threads} || $opts{threads} <= 1) {
|
|
transport_shift_1($host, $cmd);
|
|
next;
|
|
} elsif ($op !~ /^(get|put)$/) {
|
|
push(@scmds, [undef, $cmd]);
|
|
next;
|
|
}
|
|
if (!$opts{'create-tar'} && !$ref->{bytes} && $opts{recall} &&
|
|
$ref->{dstfs} =~ /,dmf/) {
|
|
# truncate dst on dmf or else it will be recalled on first write
|
|
if ($host eq 'localhost') {
|
|
truncate($dst, 0);
|
|
} else {
|
|
sftp($host)->truncate($dst, 0);
|
|
}
|
|
}
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
my @ranges = $ref->{bytes} ? split(/,/, $ref->{bytes}) :
|
|
("0-" . $attrs[7]);
|
|
foreach my $range (@ranges) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
# hard coded split size of 1 GB
|
|
my $x;
|
|
for ($x = $x1; $x + 1073741824 < $x2; $x += 1073741824) {
|
|
push(@scmds, [$x . "-" . ($x + 1073741824), $cmd]);
|
|
}
|
|
push(@scmds, [$x == $x1 ? undef : $x . "-" . $x2, $cmd]);
|
|
}
|
|
}
|
|
# return when no work (mainly when single-threaded)
|
|
return if (!scalar(@scmds));
|
|
|
|
foreach my $o (keys %opts) {
|
|
# must kill existing sftp connections or various things can hang
|
|
next if ($o !~ /^sftp_[^d]/);
|
|
$opts{$o}->disconnect;
|
|
delete $opts{$o};
|
|
}
|
|
|
|
my $q = Thread::Queue->new;
|
|
my $qret = Thread::Queue->new;
|
|
my $qi = 0;
|
|
$q->enqueue([$qi++, $_->[0], $_->[1]]) foreach (@scmds);
|
|
# choose min of specified threads minus self and amount of work
|
|
my $nthr = scalar(@scmds);
|
|
my $maxthr = $host eq 'localhost' ? $opts{threads} : $opts{streams};
|
|
$nthr = min($maxthr - 1, $nthr);
|
|
my $dqshift = sub {
|
|
while (defined (my $ircmd = $q->dequeue_nb)) {
|
|
my ($i, $range, $cmd) = @{$ircmd};
|
|
# no need to save original bytes value since ref is cloned by queue
|
|
$cmd->[3]->{bytes} = $range if (defined $range);
|
|
transport_shift_1($host, $cmd);
|
|
$qret->enqueue([$i, $cmd->[3]->{text}]);
|
|
}
|
|
};
|
|
my @threads = map {threads->create($dqshift)} (1 .. $nthr);
|
|
# ensure work gets done even if thread creation fails
|
|
&$dqshift();
|
|
foreach (@threads) {
|
|
$_->join if ($_);
|
|
}
|
|
# append any error messages back to original ref text
|
|
while (defined (my $itext = $qret->dequeue_nb)) {
|
|
my ($i, $text) = @{$itext};
|
|
$tcmds->[$i]->[3]->{text} .= $text;
|
|
}
|
|
}
|
|
|
|
###########################
|
|
#### transport_shift_1 ####
|
|
###########################
|
|
sub transport_shift_1 {
|
|
my ($host, $cmd) = @_;
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
if ($host eq 'localhost') {
|
|
transport_shift_local($op, $src, $dst, $ref);
|
|
} else {
|
|
transport_shift_remote($host, $op, $src, $dst, $ref);
|
|
}
|
|
return $ref;
|
|
}
|
|
|
|
###############################
|
|
#### transport_shift_local ####
|
|
###############################
|
|
sub transport_shift_local {
|
|
my ($op, $src, $dst, $ref) = @_;
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
if ($op eq 'mkdir' && !$opts{'create-tar'}) {
|
|
# create implicit directories
|
|
eval {mkpath(dirname($dst))};
|
|
# ignore if directory exists before/after mkdir
|
|
-d $dst or mkdir $dst or -d $dst or sftp_error($ref, "$!");
|
|
} elsif ($op eq 'rm') {
|
|
unlink $src or sftp_error($ref, "$!");
|
|
} elsif ($op eq 'rrm') {
|
|
sftp_error($ref, rmtree($src));
|
|
} elsif ($op eq 'ln' && !$opts{'create-tar'}) {
|
|
# create implicit directories
|
|
eval {mkpath(dirname($dst))};
|
|
# unlink dst if existing symlink since overwrite not possible
|
|
unlink $dst if (-l $dst);
|
|
symlink($src, $dst) or sftp_error($ref, "$!");
|
|
} elsif ($op =~ /^(?:get|put)$/) {
|
|
# create implicit directories
|
|
eval {mkpath(dirname($dst))};
|
|
my @ranges = $ref->{bytes} ? split(/,/, $ref->{bytes}) :
|
|
("0-" . $attrs[7]);
|
|
if (sysopen(SRC, $src, O_RDONLY)) {
|
|
if (sysopen(DST, $dst, O_RDWR | O_CREAT)) {
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
foreach my $range (@ranges) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
my ($sseek, $dseek) = ($x1, $x1);
|
|
if ($opts{'create-tar'}) {
|
|
# adjust src by tar start offset
|
|
$sseek = $x1 - $t1;
|
|
} elsif ($opts{'extract-tar'}) {
|
|
# adjust dst by tar start offset
|
|
$dseek = $x1 - $t1;
|
|
}
|
|
sysseek(SRC, $sseek, 0) or sftp_error($ref,
|
|
"Unable to seek source: $!");
|
|
sysseek(DST, $dseek, 0) or sftp_error($ref,
|
|
"Unable to seek destination: $!");
|
|
my $sopts = !$opts{verify} || !$opts{'verify-fast'} ? 0 :
|
|
verify_init(length => $x2 - $x1);
|
|
my $size = $opts{buffer} ? $opts{buffer} : 4 << 20;
|
|
for (my $x = $x2 - $x1; $x > 0; $x -= $size) {
|
|
$size = $x if ($x < $size);
|
|
my $buf;
|
|
my $n = sysread(SRC, $buf, $size);
|
|
sftp_error($ref, "Unable to read source: $!")
|
|
if (!defined $n);
|
|
defined syswrite(DST, $buf, $n) or
|
|
sftp_error($ref, "Unable to write destination: $!");
|
|
verify_buffer($sopts, $buf, $x2 - $x1 - $x + $n)
|
|
if ($opts{verify} && $opts{'verify-fast'});
|
|
}
|
|
if ($opts{verify} && $opts{'verify-fast'} && !$ref->{text}) {
|
|
my $hash = verify_buffer_end($sopts, $src,
|
|
$ref->{bytes} ? $sseek : undef);
|
|
# record hash in error ref
|
|
$ref->{text} = "\\H$hash";
|
|
}
|
|
if (!$opts{'create-tar'} && $dseek + $x2 - $x1 == $attrs[7] &&
|
|
(stat DST)[7] > $attrs[7]) {
|
|
# truncate dst if last split
|
|
DST->truncate($attrs[7]);
|
|
}
|
|
}
|
|
close DST;
|
|
} else {
|
|
sftp_error($ref, "Unable to open destination: $!");
|
|
}
|
|
close SRC;
|
|
} else {
|
|
sftp_error($ref, "Unable to open source: $!");
|
|
}
|
|
} elsif ($op eq 'chattr' && $ref->{tar_mv}) {
|
|
my $src = $dst;
|
|
# tar_mv only happens when there is one split ending in "-1.tar"
|
|
$dst =~ s/-1\.tar$//;
|
|
if (-e $dst) {
|
|
sftp_error($ref, "Unable to rename tar: dst exists");
|
|
} else {
|
|
rename($src, $dst) or sftp_error($ref, "$!");
|
|
if ($opts{'index-tar'}) {
|
|
rename("$src.toc", "$dst.toc") or sftp_error($ref, "$!");
|
|
if ($opts{verify} && $ref->{tar_mv} > 1) {
|
|
rename("$src.sum", "$dst.sum") or sftp_error($ref, "$!");
|
|
}
|
|
}
|
|
}
|
|
} elsif ($opts{preserve} && $op eq 'chattr' && $ref->{ln} &&
|
|
!$opts{'create-tar'}) {
|
|
if ($opts{preserve} == 1 || $opts{preserve} =~ /owner/) {
|
|
# hack since perl does not support symlink chown
|
|
system("chown", "-h", "$attrs[1]:$attrs[2]", $dst);
|
|
}
|
|
if ($opts{preserve} == 1 || $opts{preserve} =~ /time/) {
|
|
# hack since perl does not support symlink utime
|
|
system("touch", "-ht", strftime("%Y%m%d%H%M.%S",
|
|
localtime $attrs[4]), $dst);
|
|
}
|
|
} elsif ($opts{preserve} && $op eq 'chattr' && !$ref->{ln} &&
|
|
!$opts{'create-tar'}) {
|
|
if ($opts{preserve} == 1 || $opts{preserve} =~ /owner/) {
|
|
# don't return error for chown since unlikely to succeed
|
|
chown($attrs[1], $attrs[2], $dst);
|
|
}
|
|
if ($opts{preserve} == 1 || $opts{preserve} =~ /mode/) {
|
|
chmod($attrs[0], $dst) or sftp_error($ref, "$!") and return;
|
|
}
|
|
if ($opts{preserve} == 1 || $opts{preserve} =~ /time/) {
|
|
utime($attrs[3], $attrs[4], $dst) or
|
|
sftp_error($ref, "$!") and return;
|
|
}
|
|
}
|
|
if ($opts{sanity} && $op =~ /^c[hk]attr/ && !$ref->{ln} &&
|
|
!$opts{'create-tar'}) {
|
|
my @dattrs = stat $dst;
|
|
if (!defined $dattrs[7]) {
|
|
# record as error, which will trigger copy
|
|
sftp_error($ref, "No such file or directory");
|
|
} elsif ($op eq 'chattr' && !$ref->{src}) {
|
|
# ignore ln/mkdir during chattr size check
|
|
} elsif ($op eq 'ckattr0' || ($attrs[7] != $dattrs[7] ||
|
|
$op ne 'chattr' && $attrs[4] != $dattrs[9])) {
|
|
if ($op eq 'chattr') {
|
|
# check src size again
|
|
my ($shost, $spath) = hostpath($ref->{src});
|
|
my $ssize = -1;
|
|
if ($shost eq 'localhost') {
|
|
my @sattrs = stat $spath;
|
|
$ssize = $sattrs[7] if (@sattrs);
|
|
} else {
|
|
my $sattrs = sftp($shost)->stat($spath);
|
|
$ssize = $sattrs->size if ($sattrs);
|
|
}
|
|
sftp_error($ref, "Source/destination file sizes differ")
|
|
if ($ssize != $dattrs[7]);
|
|
} elsif ($opts{recall} && $ref->{dstfs} =~ /,dmf/) {
|
|
# trigger copy on dmf file systems to prevent recall
|
|
sftp_error($ref, "Ignoring attributes on DMF file system");
|
|
} else {
|
|
# record as warning, which will trigger sum
|
|
sftp_warning($ref, "File attributes ignored or differ");
|
|
}
|
|
}
|
|
# ckattr done state will trigger chattr
|
|
}
|
|
}
|
|
|
|
################################
|
|
#### transport_shift_remote ####
|
|
################################
|
|
sub transport_shift_remote {
|
|
my ($host, $op, $src, $dst, $ref) = @_;
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
# must keep write access to handle warnings/corruption
|
|
my %extra = (copy_perm => 0);
|
|
if ($op eq 'mkdir' && !$opts{'create-tar'}) {
|
|
# create implicit directories
|
|
sftp($host)->mkpath(dirname($dst));
|
|
# ignore if directory exists before/after mkdir
|
|
my $attrs = sftp($host)->stat($dst);
|
|
if ($attrs && !S_ISDIR($attrs->perm)) {
|
|
sftp_error($ref, "File exists");
|
|
} elsif (!$attrs && !sftp($host)->mkdir($dst)) {
|
|
$attrs = sftp($host)->stat($dst);
|
|
if (!$attrs || !S_ISDIR($attrs->perm)) {
|
|
sftp_error($ref, "Unable to create directory");
|
|
}
|
|
}
|
|
} elsif ($op eq 'rget') {
|
|
sftp($host)->rget($src, $dst) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
} elsif ($op eq 'rm') {
|
|
sftp($host)->remove($src) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
} elsif ($op eq 'rput') {
|
|
sftp($host)->rput($src, $dst) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
} elsif ($op eq 'rrm') {
|
|
sftp($host)->rremove($src) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
} elsif ($op eq 'ln' && !$opts{'create-tar'}) {
|
|
# create implicit directories
|
|
sftp($host)->mkpath(dirname($dst));
|
|
# unlink dst if existing symlink since overwrite not possible
|
|
sftp($host)->remove($dst) if (defined sftp($host)->readlink($dst));
|
|
# src and dst are reversed in sftp symlink
|
|
sftp($host)->symlink($dst, $src) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
} elsif ($op eq 'get') {
|
|
my @ranges = $ref->{bytes} ? split(/,/, $ref->{bytes}) :
|
|
("0-" . $attrs[7]);
|
|
my $src_fh = sftp($host)->open($src, SFTP_READ);
|
|
if ($src_fh) {
|
|
# create implicit directories
|
|
eval {mkpath(dirname($dst))};
|
|
if (sysopen(DST, $dst, O_RDWR | O_CREAT)) {
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
foreach my $range (@ranges) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
my ($sseek, $dseek) = ($x1, $x1);
|
|
if ($opts{'create-tar'}) {
|
|
# adjust src by tar start offset
|
|
$sseek = $x1 - $t1;
|
|
} elsif ($opts{'extract-tar'}) {
|
|
# adjust dst by tar start offset
|
|
$dseek = $x1 - $t1;
|
|
}
|
|
sftp($host)->seek($src_fh, $sseek, 0) or
|
|
sftp_error($ref, "Unable to seek source: " .
|
|
sftp($host, 1)->error);
|
|
sysseek(DST, $dseek, 0) or sftp_error($ref,
|
|
"Unable to seek destination: $!");
|
|
my $size = $opts{buffer} ? $opts{buffer} : 4 << 20;
|
|
for (my $x = $x2 - $x1; $x > 0; $x -= $size) {
|
|
$size = $x if ($x < $size);
|
|
my $buf = sftp($host)->read($src_fh, $size);
|
|
sftp_error($ref, "Unable to read source: " .
|
|
sftp($host, 1)->error) if (!defined $buf);
|
|
defined syswrite(DST, $buf, length($buf)) or
|
|
sftp_error($ref, "Unable to write destination: $!");
|
|
}
|
|
if (!$opts{'create-tar'} && $dseek + $x2 - $x1 == $attrs[7] &&
|
|
(stat DST)[7] > $attrs[7]) {
|
|
# truncate dst if last split
|
|
DST->truncate($attrs[7]);
|
|
}
|
|
}
|
|
close DST;
|
|
} else {
|
|
sftp_error($ref, "Unable to open destination: $!");
|
|
}
|
|
sftp($host)->close($src_fh);
|
|
} else {
|
|
sftp_error($ref, "Unable to open source: " . sftp($host, 1)->error);
|
|
}
|
|
} elsif ($op eq 'put') {
|
|
my @ranges = $ref->{bytes} ? split(/,/, $ref->{bytes}) :
|
|
("0-" . $attrs[7]);
|
|
if (sysopen(SRC, $src, O_RDONLY)) {
|
|
# create implicit directories
|
|
sftp($host)->mkpath(dirname($dst));
|
|
my $dst_fh = sftp($host)->open($dst, SFTP_WRITE | SFTP_CREAT);
|
|
if ($dst_fh) {
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
foreach my $range (@ranges) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
my ($sseek, $dseek) = ($x1, $x1);
|
|
if ($opts{'create-tar'}) {
|
|
# adjust src by tar start offset
|
|
$sseek = $x1 - $t1;
|
|
} elsif ($opts{'extract-tar'}) {
|
|
# adjust dst by tar start offset
|
|
$dseek = $x1 - $t1;
|
|
}
|
|
sysseek(SRC, $sseek, 0) or
|
|
sftp_error($ref, "Unable to seek source: $!");
|
|
sftp($host)->seek($dst_fh, $dseek, 0) or
|
|
sftp_error($ref, "Unable to seek destination: " .
|
|
sftp($host, 1)->error);
|
|
my $sopts = !$opts{verify} || !$opts{'verify-fast'} ? 0 :
|
|
verify_init(length => $x2 - $x1);
|
|
my $size = $opts{buffer} ? $opts{buffer} : 4 << 20;
|
|
for (my $x = $x2 - $x1; $x > 0; $x -= $size) {
|
|
$size = $x if ($x < $size);
|
|
my $buf;
|
|
my $n = sysread(SRC, $buf, $size);
|
|
sftp_error($ref, "Unable to read source: $!")
|
|
if (!defined $n);
|
|
defined sftp($host)->write($dst_fh, $buf) or
|
|
sftp_error($ref, "Unable to write destination: " .
|
|
sftp($host, 1)->error);
|
|
verify_buffer($sopts, $buf, $x2 - $x1 - $x + $n)
|
|
if ($opts{verify} && $opts{'verify-fast'});
|
|
}
|
|
if ($opts{verify} && $opts{'verify-fast'} && !$ref->{text}) {
|
|
my $hash = verify_buffer_end($sopts, $src,
|
|
$ref->{bytes} ? $sseek : undef);
|
|
# record hash in error ref
|
|
$ref->{text} = "\\H$hash";
|
|
}
|
|
if (!$opts{'create-tar'} && $ref->{bytes} &&
|
|
$dseek + $x2 - $x1 == $attrs[7]) {
|
|
my $dattrs = sftp($host)->stat($dst);
|
|
if (defined $dattrs && $dattrs->size > $attrs[7]) {
|
|
# truncate dst if last split
|
|
sftp($host)->truncate($dst, $attrs[7]);
|
|
}
|
|
}
|
|
}
|
|
sftp($host)->close($dst_fh);
|
|
} else {
|
|
sftp_error($ref, "Unable to open destination: " .
|
|
sftp($host, 1)->error);
|
|
}
|
|
close SRC;
|
|
} else {
|
|
sftp_error($ref, "Unable to open source: $!");
|
|
}
|
|
} elsif ($op eq 'chattr' && $ref->{tar_mv}) {
|
|
my $src = $dst;
|
|
# tar_mv only happens when there is one split ending in "-1.tar"
|
|
$dst =~ s/-1\.tar$//;
|
|
my $rc = sftp($host)->rename($src, $dst);
|
|
if (!$rc) {
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
} elsif ($opts{'index-tar'}) {
|
|
sftp($host)->rename("$src.toc", "$dst.toc", overwrite => 1) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
if ($opts{verify} && $ref->{tar_mv} > 1) {
|
|
sftp($host)->rename("$src.sum", "$dst.sum", overwrite => 1) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
}
|
|
}
|
|
} elsif ($opts{preserve} && $op eq 'chattr' && !$ref->{ln} &&
|
|
!$opts{'create-tar'}) {
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
if ($opts{preserve} == 1 || $opts{preserve} =~ /owner/) {
|
|
my $sattrs = Net::SFTP::Foreign::Attributes->new;
|
|
# don't return error for chown/chgrp since unlikely to succeed
|
|
$sattrs->set_ugid($attrs[1], $attrs[2]);
|
|
sftp($host)->setstat($dst, $sattrs);
|
|
}
|
|
if ($opts{preserve} == 1 || $opts{preserve} =~ /mode/) {
|
|
my $sattrs = Net::SFTP::Foreign::Attributes->new;
|
|
$sattrs->set_perm($attrs[0]);
|
|
sftp($host)->setstat($dst, $sattrs) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
}
|
|
if ($opts{preserve} == 1 || $opts{preserve} =~ /time/) {
|
|
my $sattrs = Net::SFTP::Foreign::Attributes->new;
|
|
$sattrs->set_amtime($attrs[3], $attrs[4]);
|
|
sftp($host)->setstat($dst, $sattrs) or
|
|
sftp_error($ref, "" . sftp($host, 1)->error);
|
|
}
|
|
}
|
|
if ($opts{sanity} && $op =~ /^c[hk]attr/ && !$ref->{ln} &&
|
|
!$opts{'create-tar'}) {
|
|
my @attrs = split(/,/, $ref->{attrs});
|
|
my $dattrs = sftp($host)->stat($dst);
|
|
if (!defined $dattrs) {
|
|
# record as error, which will trigger copy
|
|
sftp_error($ref, "No such file or directory");
|
|
} elsif ($op eq 'chattr' && !$ref->{src}) {
|
|
# ignore ln/mkdir during chattr size check
|
|
} elsif ($op eq 'ckattr0' || ($attrs[7] != $dattrs->size ||
|
|
$op ne 'chattr' && $attrs[4] != $dattrs->mtime)) {
|
|
if ($op eq 'chattr') {
|
|
# check src size again (src is local since dst is remote)
|
|
my $ssize = (stat $ref->{src})[7];
|
|
sftp_error($ref, "Source/destination file sizes differ")
|
|
if ($ssize != $dattrs->size);
|
|
} elsif ($opts{recall} && $ref->{dstfs} =~ /,dmf/) {
|
|
# trigger copy on dmf file systems to prevent recall
|
|
sftp_error($ref, "Ignoring attributes on DMF file system");
|
|
} else {
|
|
# record as warning, which will trigger sum
|
|
sftp_warning($ref, "File attributes ignored or differ");
|
|
}
|
|
}
|
|
# ckattr done state will trigger chattr
|
|
}
|
|
}
|
|
|
|
#######################
|
|
#### transport_tar ####
|
|
#######################
|
|
sub transport_tar {
|
|
my ($host, $tcmds) = @_;
|
|
return if (!$opts{'create-tar'});
|
|
# insert header and padding for each source file
|
|
my ($tar, $tarfh, $itar, $itarfh);
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
next if ($op !~ /^(?:chattr|get|ln|mkdir|put)/);
|
|
next if ($op ne 'chattr' && $ref->{bytes} ne $ref->{tar_bytes} &&
|
|
# write header during first split
|
|
$ref->{split} !~ /:0$/);
|
|
next if ($op eq 'chattr' && ($ref->{tar_mv} || $ref->{tar_creat}));
|
|
if (!$tar || $tar ne $dst) {
|
|
close $tarfh if ($tar && defined $tarfh);
|
|
$tarfh = undef;
|
|
$tar = $dst;
|
|
if ($opts{'index-tar'}) {
|
|
close $itarfh if ($itar && defined $itarfh);
|
|
$itarfh = undef;
|
|
$itar = $dst . ".toc";
|
|
}
|
|
if ($host ne 'localhost' && $op ne 'get') {
|
|
$tarfh = sftp($host)->open($tar,
|
|
SFTP_WRITE | SFTP_CREAT | SFTP_READ);
|
|
sftp_error($ref, "Unable to open tar file") if (!$tarfh);
|
|
if ($opts{'index-tar'}) {
|
|
$itarfh = sftp($host)->open($itar,
|
|
SFTP_WRITE | SFTP_CREAT | SFTP_READ);
|
|
sftp_error($ref, "Unable to open tar index file")
|
|
if (!$itarfh);
|
|
}
|
|
} else {
|
|
sysopen($tarfh, $tar, O_RDWR | O_CREAT) or
|
|
sftp_error($ref, "Unable to open tar file");
|
|
if ($opts{'index-tar'}) {
|
|
sysopen($itarfh, $itar, O_RDWR | O_CREAT) or
|
|
sftp_error($ref, "Unable to open tar index file");
|
|
}
|
|
}
|
|
}
|
|
if ($op eq 'chattr' && !tar_validate($tarfh, $ref)) {
|
|
if ($ref->{ln}) {
|
|
$op = "ln";
|
|
$src = $ref->{src};
|
|
} elsif ($ref->{src}) {
|
|
$op = "cp";
|
|
$src = $ref->{src};
|
|
} else {
|
|
$op = "mkdir";
|
|
}
|
|
}
|
|
tar_record($tarfh, $op, $src, $ref, $itarfh) if ($op ne 'chattr');
|
|
}
|
|
close $tarfh if ($tar && defined $tarfh);
|
|
close $itarfh if ($itar && defined $itarfh);
|
|
}
|
|
|
|
##################
|
|
#### unescape ####
|
|
##################
|
|
# return uri-unescaped version of given string
|
|
sub unescape {
|
|
my $text = shift;
|
|
$text =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if (defined $text);
|
|
return $text;
|
|
}
|
|
|
|
######################
|
|
#### verify_cksum ####
|
|
######################
|
|
sub verify_cksum {
|
|
my ($host, $tcmds) = @_;
|
|
my @progs = ("msum", $opts{caux});
|
|
my ($fh, $tmp);
|
|
foreach my $order (0, 1) {
|
|
my %errs;
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
next if ($op ne 'cksum');
|
|
next if ($ref->{try} % 2 != $order);
|
|
foreach my $hash (split(/,/, $ref->{hash})) {
|
|
# build checksum file for -c (two spaces required before file)
|
|
my $file = $dst;
|
|
# strip out \ from hash since src and dst names may differ
|
|
$hash =~ s/\\//;
|
|
if ($file =~ s/(\n|\\)/$1 eq "\n" ? "\\n" : "\\\\"/eg) {
|
|
# prepend \ to hash value if dst has \ or \n in name
|
|
substr($hash, rindex($hash, "#") + 1, 0) = "\\";
|
|
}
|
|
if (defined $ref->{tar_bytes}) {
|
|
my ($x1, $x2) = (0, $ref->{size});
|
|
($x1, $x2) = ($1, $2) if ($hash =~ /#(\d+)-(\d+)#/);
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
my $roff;
|
|
if ($opts{'create-tar'}) {
|
|
$roff = $ref->{rindex} ? $x1 + $t1 : $x1 - $t1;
|
|
} elsif ($opts{'extract-tar'}) {
|
|
$roff = $ref->{rindex} ? $x1 - $t1 : $x1 + $t1;
|
|
}
|
|
my $bytes = $roff . "-" . ($roff + ($x2 - $x1));
|
|
# eliminate original mutil prefix (if any)
|
|
$hash =~ s/^#mutil#(\d+-\d+)?#//;
|
|
# shift hash to new range
|
|
$hash = "#mutil#$bytes#$hash";
|
|
# need to track by bytes instead of file
|
|
$errs{"$dst bytes=$bytes"}->{$ref} = $ref;
|
|
} elsif (defined $ref->{split}) {
|
|
# need to track by split instead of file
|
|
$errs{"$dst bytes=$ref->{bytes}"}->{$ref} = $ref;
|
|
} else {
|
|
$errs{$dst}->{$ref} = $ref;
|
|
}
|
|
($fh, $tmp) = sftp_tmp() if (!$tmp);
|
|
print $fh "$hash $file\n";
|
|
}
|
|
}
|
|
|
|
next if (!$tmp);
|
|
close $fh;
|
|
foreach my $prog ($order ? reverse @progs : @progs) {
|
|
my $cmd;
|
|
key_ssh() if ($opts{p} ne 'none');
|
|
$cmd .= "$opts{ssh} $host " if ($host ne 'localhost');
|
|
$cmd .= $prog;
|
|
$cmd .= " sum" if ($prog eq $opts{caux});
|
|
$cmd .= " -c --split-size=" . ($opts{sum_split} >> 20);
|
|
$cmd .= " --buffer-size=" . ($opts{buffer} >> 20) if ($opts{buffer});
|
|
$cmd .= " --threads=$opts{threads}" if ($opts{threads});
|
|
if ($prog eq 'msum') {
|
|
$cmd .= " $opts{opts_msum} --check-tree";
|
|
my ($type, $bits) = split(/_/, $opts{sum_type});
|
|
my $dash = $bits && $type =~ /\d$/ ? "-" : "";
|
|
$cmd .= " --hash-type=$type$dash$bits";
|
|
} else {
|
|
$cmd .= " --hash-type=$opts{sum_type}";
|
|
}
|
|
my $run;
|
|
my $out_tmp = sftp_tmp();
|
|
my $err_tmp = sftp_tmp();
|
|
open3_get([$tmp, $out_tmp, $err_tmp], $cmd);
|
|
|
|
if (open(ERR, '<', $err_tmp)) {
|
|
while (my $line = <ERR>) {
|
|
$line =~ s/\r?\n$//;
|
|
#TODO: ' and \\ are escaped in return name
|
|
if ($line =~ /[`'](.*)'/) {
|
|
my $file = $1;
|
|
my @keys = grep(/^\Q$file\E( bytes=\d+-\d+)?$/,
|
|
keys(%errs));
|
|
foreach my $key (@keys) {
|
|
$_->{text} = "\\E$line" foreach (values %{$errs{$key}});
|
|
}
|
|
}
|
|
}
|
|
close ERR;
|
|
}
|
|
unlink $err_tmp;
|
|
|
|
if (open(OUT, '<', $out_tmp)) {
|
|
my $buf;
|
|
while (my $line = <OUT>) {
|
|
$line = $buf . $line if (defined $buf);
|
|
$buf = undef;
|
|
# use /s modifier as \n in file names are expanded
|
|
if ($line =~ /^(.+):\s*(OK|FAILED)(,\S*\d)?$/s) {
|
|
my ($file, $ok, $bytes) = ($1, $2, $3);
|
|
my $refs = $errs{$file};
|
|
$refs = $errs{"$file bytes=" . substr($bytes, 1)}
|
|
if (!ref $refs && $bytes);
|
|
if (!ref $refs && $bytes) {
|
|
# use only first range to find ref
|
|
my ($x1, $x2) = split(/-/, substr($bytes, 1));
|
|
# subset of split/tar range
|
|
ERR: foreach my $err (values %errs) {
|
|
foreach my $eref (values %{$err}) {
|
|
next if (!defined $eref->{split} &&
|
|
!defined $eref->{tar_bytes});
|
|
my @ranges = split(/,/, $eref->{bytes});
|
|
foreach my $range (@ranges) {
|
|
my ($min, $max) = split(/-/, $range);
|
|
if ($min <= $x1 && $x2 <= $max) {
|
|
$refs = $err;
|
|
last ERR;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
# skip if ref not found
|
|
next if (!ref $refs);
|
|
foreach my $ref (values %{$refs}) {
|
|
# skip if error already recorded
|
|
next if ($ref->{text} =~ /^\\E/);
|
|
if ($ok eq 'OK') {
|
|
$ref->{text} = "" if ($ref->{text} !~ /Corruption/);
|
|
} else {
|
|
$ref->{text} = "\\WCorruption"
|
|
if ($ref->{text} !~ /Corruption/);
|
|
if (defined $ref->{tar_bytes}) {
|
|
# adjust all byte ranges to ranges within tar
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
my @ranges = split(/,/, substr($bytes, 1));
|
|
my @tbytes;
|
|
foreach my $range (@ranges) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
my $roff;
|
|
if ($opts{'create-tar'}) {
|
|
$roff = $ref->{rindex} ? $x1 : $x1 + $t1;
|
|
} elsif ($opts{'extract-tar'}) {
|
|
$roff = $ref->{rindex} ? $x1 + $t1 : $x1;
|
|
}
|
|
push(@tbytes,
|
|
$roff . "-" . ($roff + ($x2 - $x1)));
|
|
}
|
|
$bytes = join(",", @tbytes);
|
|
}
|
|
$bytes =~ s/^([^,])/,$1/;
|
|
$ref->{text} .= $bytes if ($bytes);
|
|
}
|
|
$run = 1;
|
|
}
|
|
} else {
|
|
# output for files with \n in name spans multiple lines
|
|
$buf = $line;
|
|
}
|
|
}
|
|
close OUT;
|
|
}
|
|
unlink $out_tmp;
|
|
|
|
my $tool = $prog eq 'msum' ? $prog : "shift-sum";
|
|
foreach my $refs (values %errs) {
|
|
$_->{tool} = $tool foreach (values %{$refs});
|
|
}
|
|
|
|
# stop after the first program that runs
|
|
last if ($run);
|
|
}
|
|
unlink $tmp;
|
|
$tmp = undef;
|
|
foreach my $refs (values %errs) {
|
|
foreach (values %{$refs}) {
|
|
$_->{text} = "\\EUnable to compute destination hash"
|
|
if (!defined $_->{text});
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
####################
|
|
#### verify_sum ####
|
|
####################
|
|
sub verify_sum {
|
|
my $tcmds = shift;
|
|
|
|
# check for msum
|
|
my $msum = 0;
|
|
foreach my $path (split(/:/, $ENV{PATH})) {
|
|
if (-x "$path/msum") {
|
|
$msum = 1;
|
|
last;
|
|
}
|
|
}
|
|
|
|
my (@mcmds, @scmds);
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
next if ($op ne 'sum');
|
|
if (defined $ref->{tar_bytes}) {
|
|
my @bytes;
|
|
my ($t1, $t2) = split(/-/, $ref->{tar_bytes});
|
|
my @ranges = split(/,/, $ref->{bytes});
|
|
foreach my $range (@ranges) {
|
|
my ($x1, $x2) = split(/-/, $range);
|
|
my $loff;
|
|
if ($opts{'create-tar'}) {
|
|
$loff = $ref->{lindex} ? $x1 : $x1 - $t1;
|
|
} elsif ($opts{'extract-tar'}) {
|
|
$loff = $ref->{lindex} ? $x1 - $t1 : $x1;
|
|
}
|
|
push(@bytes, $loff . "-" . ($loff + ($x2 - $x1)));
|
|
}
|
|
$ref->{sum_bytes} = join(",", @bytes);
|
|
} elsif (defined $ref->{bytes}) {
|
|
$ref->{sum_bytes} = $ref->{bytes};
|
|
}
|
|
if ($msum && $ref->{try} % 2 == 0) {
|
|
# try msum on even tries
|
|
push(@mcmds, $cmd);
|
|
} else {
|
|
push(@scmds, $cmd);
|
|
}
|
|
}
|
|
|
|
verify_sum_msum(\@mcmds) if (scalar(@mcmds) > 0);
|
|
verify_sum_shift(\@scmds) if (scalar(@scmds) > 0);
|
|
|
|
foreach my $cmd (@{$tcmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
$ref->{text} = "\\EUnable to compute source hash"
|
|
if ($op eq 'sum' && $ref->{text} !~ /^\\[EHW]/);
|
|
}
|
|
}
|
|
|
|
#########################
|
|
#### verify_sum_msum ####
|
|
#########################
|
|
sub verify_sum_msum {
|
|
my $cmds = shift;
|
|
|
|
my %errs;
|
|
my ($fh, $tmp) = sftp_tmp();
|
|
foreach my $cmd (@{$cmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
$ref->{tool} = "msum";
|
|
print $fh escape($src);
|
|
print $fh " $ref->{sum_bytes}" if ($ref->{sum_bytes});
|
|
print $fh "\n";
|
|
if (defined $ref->{tar_bytes} || defined $ref->{split}) {
|
|
# need to track by bytes/split instead of file
|
|
$errs{$src . " bytes=$ref->{sum_bytes}"}->{$ref} = $ref;
|
|
} else {
|
|
$errs{$src}->{$ref} = $ref;
|
|
}
|
|
}
|
|
close $fh;
|
|
|
|
my %emap = ("'" => "'", 0 => "\0", a => "\a", b => "\b", f => "\f",
|
|
n => "\n", r => "\r", t => "\t", v => "\v", '\\' => "\\");
|
|
|
|
my $out_tmp = sftp_tmp();
|
|
my $err_tmp = sftp_tmp();
|
|
my ($type, $bits) = split(/_/, $opts{sum_type});
|
|
my $dash = $bits && $type =~ /\d$/ ? "-" : "";
|
|
my $extra;
|
|
$extra .= " --buffer-size=" . ($opts{buffer} >> 20) if ($opts{buffer});
|
|
$extra .= " --threads=$opts{threads}" if ($opts{threads});
|
|
|
|
open3_get([$tmp, $out_tmp, $err_tmp],
|
|
"msum $extra $opts{opts_msum} --read-stdin --check-tree" .
|
|
" --hash-type=$type$dash$bits" .
|
|
" --split-size=" . ($opts{sum_split} >> 20));
|
|
unlink $tmp;
|
|
if (open(ERR, '<', $err_tmp)) {
|
|
while (my $line = <ERR>) {
|
|
$line =~ s/\r?\n$//;
|
|
# any number of non-' or odd-\ with ' followed by
|
|
# non-' and non-\ or even-\ or odd-\ with '
|
|
while ($line =~ /[`']((?:[^']|[^'\\](\\\\)*\\')*(?:[^'\\]|[^'\\](\\\\)*|[^'\\](\\\\)*\\'))'/g) {
|
|
my $file = $1;
|
|
$file =~ s/\\([abfnrtv'\\])/$emap{$1}/g;
|
|
my @keys = grep(/^\Q$file\E( bytes=\d+-\d+)?$/,
|
|
keys(%errs));
|
|
foreach my $key (@keys) {
|
|
$_->{text} = "\\E$line" foreach (values %{$errs{$key}});
|
|
}
|
|
}
|
|
}
|
|
close ERR;
|
|
}
|
|
unlink $err_tmp;
|
|
|
|
if (open(OUT, '<', $out_tmp)) {
|
|
while (<OUT>) {
|
|
s/\n$//;
|
|
# only remove on windows or else removes trailing \r in names
|
|
s/\r$// if ($^O eq 'MSWin32');
|
|
if (/^(\S+)\s.(.*)/) {
|
|
my ($hash, $file) = ($1, $2);
|
|
# eliminate extra \ in files with \\ or \n
|
|
$file =~ s/\\([\\n])/$emap{$1}/g if ($hash =~ /(^|#)\\/);
|
|
my $refs = $errs{$file};
|
|
$refs = $errs{"$file bytes=$1-$2"}
|
|
if (!ref $refs && $hash =~ /^#mutil#(\d+)-(\d+)#/);
|
|
# skip if ref not found
|
|
next if (!ref $refs);
|
|
foreach my $ref (values %{$refs}) {
|
|
# skip if error/hash already recorded
|
|
next if ($ref->{text} =~ /^\\E|^\\H\Q$hash\E/);
|
|
# record hash in error ref
|
|
$ref->{text} .= "\\H$hash";
|
|
}
|
|
}
|
|
}
|
|
close OUT;
|
|
}
|
|
unlink $out_tmp;
|
|
}
|
|
|
|
##########################
|
|
#### verify_sum_shift ####
|
|
##########################
|
|
sub verify_sum_shift {
|
|
my $cmds = shift;
|
|
|
|
my ($qi, $q, $qret);
|
|
if ($perl{threads} && $opts{threads} > 1) {
|
|
$q = Thread::Queue->new;
|
|
$qret = Thread::Queue->new;
|
|
$qi = 0;
|
|
}
|
|
|
|
my $sopts = verify_init();
|
|
my ($fh, $tmp) = sftp_tmp();
|
|
foreach my $cmd (@{$cmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
$ref->{tool} = "shift-sum";
|
|
$ref->{partial} = 1;
|
|
my $bytes = $ref->{sum_bytes};
|
|
if (!defined $bytes) {
|
|
$bytes = "0-" . (stat($src))[7];
|
|
$ref->{partial} = 0;
|
|
}
|
|
$ref->{stack} = {};
|
|
my @ranges = split(/,/, $bytes);
|
|
foreach my $range (@ranges) {
|
|
my ($start, $stop) = split(/-/, $range);
|
|
if (!$perl{threads} || $opts{threads} <= 1) {
|
|
my $hash = verify_sum_shift1($src, $start, $stop, $ref->{partial});
|
|
if ($hash =~ /\\E/) {
|
|
$ref->{text} = $hash;
|
|
last;
|
|
} else {
|
|
$ref->{text} .= $hash;
|
|
next;
|
|
}
|
|
}
|
|
my $i = 0;
|
|
for (my $x1 = $start; $x1 == $start || $x1 < $stop;
|
|
$x1 += $sopts->{split_size}) {
|
|
my $x2 = min($x1 + $sopts->{split_size}, $stop);
|
|
$q->enqueue([$qi, $range, $i++, $src, $x1, $x2, $ref->{partial}]);
|
|
}
|
|
$ref->{stack}->{$range} = [];
|
|
}
|
|
$qi++;
|
|
}
|
|
|
|
return if (!$perl{threads} || $opts{threads} <= 1);
|
|
# choose min of specified threads minus self and amount of work
|
|
my $nthr = min($opts{threads} - 1, $q->pending);
|
|
my $dqsum = sub {
|
|
while (defined (my $sum = $q->dequeue_nb)) {
|
|
my ($qi, $range, $i, $file, $x1, $x2, $partial) = @{$sum};
|
|
my $hash = verify_sum_shift1($file, $x1, $x2, $partial, 1);
|
|
$qret->enqueue([$qi, $range, $i, $hash]);
|
|
}
|
|
};
|
|
my @threads = map {threads->create($dqsum)} (1 .. $nthr);
|
|
# ensure work gets done even if thread creation fails
|
|
&$dqsum();
|
|
foreach (@threads) {
|
|
$_->join if ($_);
|
|
}
|
|
# append any error messages back to original ref text
|
|
while (defined (my $sumret = $qret->dequeue_nb)) {
|
|
my ($qi, $range, $i, $hash) = @{$sumret};
|
|
$cmds->[$qi]->[3]->{stack}->{$range}->[$i] = $hash;
|
|
}
|
|
foreach my $cmd (@{$cmds}) {
|
|
my ($op, $src, $dst, $ref) = @{$cmd};
|
|
foreach my $range (keys %{$ref->{stack}}) {
|
|
my $stack = $ref->{stack}->{$range};
|
|
my @errs = grep(/\\E/, @{$stack});
|
|
if (scalar(@errs) > 0) {
|
|
$ref->{text} = join("", @errs);
|
|
last;
|
|
} else {
|
|
my $hash = "\\H";
|
|
if (scalar(@{$stack}) > 1 || $ref->{partial}) {
|
|
$hash .= "#mutil#";
|
|
$hash .= $range if ($ref->{partial});
|
|
$hash .= "#";
|
|
}
|
|
$hash .= "\\" if ($src =~ /\\|\n/);
|
|
$hash .= join("", @{$stack});
|
|
$ref->{text} .= $hash;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
###########################
|
|
#### verify_sum_shift1 ####
|
|
###########################
|
|
sub verify_sum_shift1 {
|
|
my ($file, $start, $stop, $partial, $subhash) = @_;
|
|
my $sopts = verify_init();
|
|
my ($hash, $fh);
|
|
if (open($fh, '<', $file)) {
|
|
if (!$subhash) {
|
|
$hash = "\\H";
|
|
if ($stop - $start > $sopts->{split_size} || $partial) {
|
|
$hash .= "#mutil#";
|
|
$hash .= "$start-$stop" if ($partial);
|
|
$hash .= "#";
|
|
}
|
|
$hash .= "\\" if ($file =~ /\\|\n/);
|
|
}
|
|
if ($start == $stop) {
|
|
# compute empty hex hash
|
|
$hash .= unpack("H*", $sopts->{hash_ctx}->digest);
|
|
} else {
|
|
for (my $x1 = $start; $x1 < $stop; $x1 += $sopts->{split_size}) {
|
|
my $x2 = min($x1 + $sopts->{split_size}, $stop);
|
|
sysseek($fh, $x1, 0);
|
|
my ($buf, $total) = ("", 0);
|
|
while ($total < $x2 - $x1) {
|
|
# read data into buffer
|
|
my $n = sysread($fh, $buf,
|
|
min($sopts->{buffer_size}, $x2 - $x1 - $total));
|
|
last if (!$n);
|
|
# add data to hash
|
|
$sopts->{hash_ctx}->add($buf);
|
|
$total += $n;
|
|
}
|
|
$hash .= unpack("H*", $sopts->{hash_ctx}->digest);
|
|
}
|
|
}
|
|
close $fh;
|
|
return $hash;
|
|
}
|
|
return "\\E$!";
|
|
}
|
|
|
|
#######################
|
|
#### verify_buffer ####
|
|
#######################
|
|
sub verify_buffer {
|
|
my ($sopts, $buf, $n_read_total) = @_;
|
|
my $n_hash = 0;
|
|
while ($sopts->{n_hash_total} + $sopts->{split_size} <= $n_read_total) {
|
|
verify_buffer_leaf($sopts, substr($buf, $n_hash,
|
|
$sopts->{split_size} - $sopts->{hash_ctx_len}));
|
|
$n_hash += $sopts->{split_size} - $sopts->{hash_ctx_len};
|
|
$sopts->{hash_ctx_len} = 0;
|
|
$sopts->{n_hash_total} += $sopts->{split_size};
|
|
}
|
|
if ($n_read_total >= $sopts->{length}) {
|
|
# last iteration
|
|
if ($n_read_total > $sopts->{n_hash_total}) {
|
|
verify_buffer_leaf($sopts, substr($buf, $n_hash,
|
|
$n_read_total - $sopts->{n_hash_total} - $sopts->{hash_ctx_len}));
|
|
}
|
|
} else {
|
|
# store in hash for next iteration
|
|
if ($n_read_total - $sopts->{n_hash_total} > 0) {
|
|
$sopts->{hash_ctx}->add(substr($buf, $n_hash,
|
|
$n_read_total - $sopts->{n_hash_total} - $sopts->{hash_ctx_len}));
|
|
}
|
|
$sopts->{hash_ctx_len} = $n_read_total - $sopts->{n_hash_total};
|
|
}
|
|
}
|
|
|
|
###########################
|
|
#### verify_buffer_end ####
|
|
###########################
|
|
sub verify_buffer_end {
|
|
my ($sopts, $file, $offset) = @_;
|
|
# push empty hash onto stack if stack empty
|
|
push(@{$sopts->{stack}}, $sopts->{hash_ctx}->digest)
|
|
if (scalar(@{$sopts->{stack}}) == 0);
|
|
my $hash = "#mutil#";
|
|
$hash .= $offset . "-" . ($offset + $sopts->{length}) if ($offset);
|
|
$hash .= "#";
|
|
$hash .= "\\" if ($file =~ /\\|\n/);
|
|
$hash .= join("", map {unpack("H*", $_)} @{$sopts->{stack}});
|
|
return $hash;
|
|
}
|
|
|
|
############################
|
|
#### verify_buffer_leaf ####
|
|
############################
|
|
sub verify_buffer_leaf {
|
|
my ($sopts, $buf) = @_;
|
|
my $buf_len = length $buf;
|
|
if ($sopts->{hash_ctx_len} + $buf_len > 0 ||
|
|
$sopts->{n_hash_total} == 0) {
|
|
# something to hash or zero-length buffer
|
|
# compute hash of block [start, end)
|
|
$sopts->{hash_ctx}->add($buf) if ($buf_len > 0);
|
|
# store hash on stack
|
|
push(@{$sopts->{stack}}, $sopts->{hash_ctx}->digest);
|
|
}
|
|
}
|
|
|
|
#####################
|
|
#### verify_init ####
|
|
#####################
|
|
sub verify_init {
|
|
my ($type, $bits) = split(/_/, $opts{sum_type});
|
|
my $mod = "Digest::" . uc($type);
|
|
my %sopts = (
|
|
buffer_size => $opts{buffer} >> 20,
|
|
hash_ctx => eval "require $mod; $mod->new($bits)",
|
|
split_size => $opts{sum_split} >> 20,
|
|
stack => [],
|
|
@_,
|
|
);
|
|
|
|
# adjust sizes to powers of 2
|
|
foreach my $key (qw(buffer_size split_size)) {
|
|
$sopts{$key} = 1 if ($sopts{$key} < 0);
|
|
my $tmp = $sopts{$key};
|
|
my $new = 1;
|
|
$new <<= 1 while ($tmp >>= 1);
|
|
$sopts{$key} = $new;
|
|
}
|
|
|
|
# scale sizes appropriately
|
|
$sopts{buffer_size} <<= 20;
|
|
$sopts{split_size} <<= 20;
|
|
$sopts{split_size} = $sopts{buffer_size}
|
|
if ($sopts{split_size} < $sopts{buffer_size});
|
|
|
|
return \%sopts;
|
|
}
|
|
|
|
=for mesh
|
|
|
|
#############
|
|
#### vcd ####
|
|
#############
|
|
sub vcd {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
my $attrs = sftp($host)->stat($path);
|
|
#TODO: pushd/popd?, set OLDPWD?
|
|
$path =~ s/\/*$//;
|
|
if (!$attrs) {
|
|
sftp_echo($ref, "echo " . hostpath($host, $path) .
|
|
": No such file or directory");
|
|
} elsif (!S_ISDIR($attrs->perm)) {
|
|
sftp_echo($ref, "echo " . hostpath($host, $path) .
|
|
": Not a directory");
|
|
} else {
|
|
my $dir = dirname($sftp_sock) . "/empty";
|
|
sftp_echo($ref, "builtin cd $dir; export PWD=" .
|
|
hostpath($host, $path));
|
|
}
|
|
}
|
|
|
|
################
|
|
#### vchgrp ####
|
|
################
|
|
sub vchgrp {
|
|
return vchown(@_, 1);
|
|
}
|
|
|
|
################
|
|
#### vchmod ####
|
|
################
|
|
sub vchmod {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
#TODO: handle options/links/etc., ago+rwx syntax
|
|
my $attrs = Net::SFTP::Foreign::Attributes->new;
|
|
$attrs->set_perm(oct $copts->{-arg1});
|
|
if (!sftp($host)->setstat($path, $attrs)) {
|
|
sftp_error($ref, sftp($host, 1)->error);
|
|
}
|
|
}
|
|
|
|
################
|
|
#### vchown ####
|
|
################
|
|
sub vchown {
|
|
my ($ref, $host, $path, $copts, $chgrp) = @_;
|
|
#TODO: handle options/links/etc.
|
|
if (!defined $copts->{-user} && !defined $copts->{-group}) {
|
|
my ($user, $group);
|
|
if ($chgrp) {
|
|
$group = $copts->{-arg1};
|
|
} else {
|
|
if ($copts->{-arg1} =~ /(\w+)?:(\w+)/) {
|
|
($user, $group) = ($1, $2);
|
|
} else {
|
|
$user = $copts->{-arg1};
|
|
}
|
|
}
|
|
if (defined $group) {
|
|
if ($group !~ /^\d+$/) {
|
|
# find remote group name in remote /etc/group
|
|
my $fh = sftp($host)->open("/etc/group");
|
|
while (<$fh>) {
|
|
if (/^\Q$group\E:[^:]*:(\d+)/) {
|
|
$copts->{-group} = $1;
|
|
last;
|
|
}
|
|
}
|
|
close $fh;
|
|
sftp_error($ref, "Invalid argument")
|
|
if (!defined $copts->{-group});
|
|
} else {
|
|
$copts->{-group} = $group;
|
|
}
|
|
}
|
|
if (defined $user) {
|
|
if ($user !~ /^\d+$/) {
|
|
# find remote user name in remote /etc/group
|
|
my $fh = sftp($host)->open("/etc/passwd");
|
|
while (<$fh>) {
|
|
if (/^\Q$user\E:[^:]*:(\d+)/) {
|
|
$copts->{-user} = $1;
|
|
last;
|
|
}
|
|
}
|
|
close $fh;
|
|
sftp_error($ref, "Invalid argument")
|
|
if (!defined $copts->{-user});
|
|
} else {
|
|
$copts->{-user} = $user;
|
|
}
|
|
}
|
|
}
|
|
my $attrs = sftp($host)->stat($path);
|
|
if (!$attrs) {
|
|
sftp_error($ref, "No such file or directory");
|
|
} else {
|
|
my ($user, $group) = ($attrs->uid, $attrs->gid);
|
|
$user = $copts->{-user} if (defined $copts->{-user});
|
|
$group = $copts->{-group} if (defined $copts->{-group});
|
|
$attrs->set_ugid($user, $group);
|
|
sftp_error($ref, "Operation not permitted")
|
|
if (!sftp($host)->setstat($path, $attrs));
|
|
}
|
|
}
|
|
|
|
###################
|
|
#### vcomplete ####
|
|
###################
|
|
sub vcomplete {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
my ($tmp_fh, $tmp) = sftp_tmp();
|
|
$path .= "/" if ($copts->{-arg} =~ /\/$/);
|
|
my @link;
|
|
my @glob = sftp($host)->glob("$path*", follow_links => 1,
|
|
on_error => sub {push(@link, $_[1])});
|
|
push(@glob, @link);
|
|
foreach (@glob) {
|
|
print $tmp_fh $copts->{-arg};
|
|
print $tmp_fh substr($_->{filename}, length $path);
|
|
print $tmp_fh "/" if (S_ISDIR($_->{a}->perm));
|
|
print $tmp_fh "\n";
|
|
}
|
|
close $tmp_fh;
|
|
sftp_cmd($ref, "sort", $tmp);
|
|
}
|
|
|
|
#############
|
|
#### vcp ####
|
|
#############
|
|
sub vcp {
|
|
vmv(@_, 1);
|
|
}
|
|
|
|
=cut mesh
|
|
|
|
#############
|
|
#### vdf ####
|
|
#############
|
|
sub vdf {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
if ($host eq 'localhost') {
|
|
return if ($^O eq 'MSWin32');
|
|
# collect disk space
|
|
my $out;
|
|
eval {
|
|
local $SIG{__WARN__} = sub {die};
|
|
# use 15s alarm in case df stalls
|
|
local $SIG{ALRM} = sub {die};
|
|
alarm 15;
|
|
# use open3 to avoid executing a shell command based on the name
|
|
# of a file being copied (which may contain metacharacters, etc.)
|
|
$out = open3_get([-1, undef], "df", "-Pk", $path);
|
|
alarm 0;
|
|
};
|
|
if (!$@) {
|
|
$out =~ s/^.*($)\s//m if (scalar(@{$copts->{-argv}}) != 1);
|
|
$ref->{text} = $out;
|
|
}
|
|
} else {
|
|
my $df = sftp($host)->statvfs($path);
|
|
if (defined $df && $copts->{i}) {
|
|
sftp_echo($ref, "Filesystem\tInodes\t\tIUsed\tIFree\t\tIUse% Mounted on")
|
|
if (scalar(@{$copts->{-argv}}) == 1);
|
|
sftp_echo($ref, "?\t\t$df->{files}\t" . ($df->{files} - $df->{ffree}) .
|
|
"\t$df->{ffree}\t" . int(100 * ($df->{files} - $df->{ffree}) /
|
|
$df->{files}) . "%\t$path");
|
|
} elsif (defined $df) {
|
|
sftp_echo($ref, "Filesystem\t1K-blocks\tUsed\t\tAvailable\tUse% Mounted on")
|
|
if (scalar(@{$copts->{-argv}}) == 1);
|
|
my $s = $df->{bsize} / 1024.0;
|
|
sftp_echo($ref, "?\t\t" . int($s * $df->{blocks}) . "\t" .
|
|
int($s * ($df->{blocks} - $df->{bfree})) . "\t" .
|
|
int($s * $df->{bfree}) . "\t" .
|
|
int(100 * ($df->{blocks} - $df->{bfree}) /
|
|
$df->{blocks}) . "%\t$path");
|
|
} else {
|
|
sftp_error($ref, "Statvfs is not supported by the target sftp server");
|
|
}
|
|
}
|
|
}
|
|
|
|
=for mesh
|
|
|
|
#############
|
|
#### vdu ####
|
|
#############
|
|
sub vdu {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
my ($dcurr, $dmin, $dprev) = (0, $path =~ tr/\///, 0);
|
|
my @dirs = ($path);
|
|
my @sizes = (0);
|
|
my %follow;
|
|
$follow{follow_links} = 1 if ($copts->{L});
|
|
sftp($host)->find($path,
|
|
%follow,
|
|
ordered => 1,
|
|
wanted => sub {
|
|
my $name = $_[1]->{filename};
|
|
my $perm = $_[1]->{a}->perm;
|
|
my $size = $_[1]->{a}->size;
|
|
if (!$copts->{b}) {
|
|
$size = int(($size + 1023) / 1024);
|
|
if (S_ISDIR($perm)) {
|
|
$size = 4 * int($size / 4);
|
|
} else {
|
|
$size = 4 * int(($size + 3) / 4);
|
|
}
|
|
}
|
|
$dcurr = ($name =~ tr/\///) - $dmin;
|
|
if (!$copts->{s}) {
|
|
for (my $i = $dprev - 1; $i >= $dcurr; $i--) {
|
|
sftp_echo($ref, "$sizes[$i]\t$dirs[$i]");
|
|
}
|
|
}
|
|
if (S_ISDIR($perm)) {
|
|
$dirs[$dcurr] = $name;
|
|
$sizes[$dcurr] = 0;
|
|
} elsif ($copts->{a}) {
|
|
sftp_echo($ref, "$size\t$name")
|
|
}
|
|
$sizes[$_] += $size for (0..$dcurr);
|
|
$dprev = $dcurr;
|
|
return undef;
|
|
});
|
|
sftp_echo($ref, "$sizes[0]\t$dirs[0]");
|
|
}
|
|
|
|
###############
|
|
#### vhead ####
|
|
###############
|
|
sub vhead {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
my $n = (grep(/^\d+$/, keys %{$copts}))[0];
|
|
$n = 10 if (!defined $n);
|
|
my $fh = sftp($host)->open($path);
|
|
if ($fh) {
|
|
my ($tmp_fh, $tmp) = sftp_tmp();
|
|
while (<$fh>) {
|
|
last if ($n-- <= 0);
|
|
print $tmp_fh $_;
|
|
}
|
|
close $tmp_fh;
|
|
close $fh;
|
|
sftp_cmd($ref, "cat", $tmp);
|
|
} else {
|
|
sftp_error($ref, sftp($host, 1)->error);
|
|
}
|
|
}
|
|
|
|
#############
|
|
#### vln ####
|
|
#############
|
|
sub vln {
|
|
my ($ref, $copts) = @_;
|
|
#TODO: handle opts, -f, etc.
|
|
# do not run original spliced command
|
|
$copts->{-argc} = 0;
|
|
my $dpath0 = pop @{$copts->{-argv}};
|
|
(my $dhost, $dpath0) = hostpath($dpath0);
|
|
if ($dhost ne 'localhost') {
|
|
my $attrs = sftp($dhost)->stat($dpath0);
|
|
foreach my $spath0 (@{$copts->{-argv}}) {
|
|
my $dpath = $dpath0;
|
|
$dpath .= "/" . basename($spath0)
|
|
if ($attrs && S_ISDIR($attrs->perm));
|
|
my ($shost, $spath) = hostpath($spath0);
|
|
if ($shost ne 'localhost') {
|
|
# link remote to remote
|
|
if ($shost eq $dhost) {
|
|
sftp($dhost)->symlink($dpath, $spath);
|
|
} else {
|
|
sftp($dhost)->symlink($dpath, $spath0);
|
|
}
|
|
} else {
|
|
# link remote to local
|
|
sftp_error($ref, "Cannot link remote file to local file");
|
|
}
|
|
}
|
|
} else {
|
|
# link local to remote
|
|
foreach my $spath (@{$copts->{-argv}}) {
|
|
next if (!hostpath($spath));
|
|
my $dpath = $dpath0;
|
|
$dpath .= "/" . basename($spath) if (-d $dpath0);
|
|
symlink($spath, $dpath);
|
|
}
|
|
}
|
|
}
|
|
|
|
#############
|
|
#### vls ####
|
|
#############
|
|
sub vls {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
my @glob;
|
|
if ($copts->{d}) {
|
|
@glob = sftp($host)->glob($path);
|
|
} else {
|
|
my @link;
|
|
@glob = sftp($host)->glob($path, follow_links => 1,
|
|
on_error => sub {push(@link, $_[1])});
|
|
push(@glob, @link);
|
|
}
|
|
my $rpath = hostpath($host, $path);
|
|
my $globc = scalar(@glob);
|
|
if (!$globc) {
|
|
sftp_error($ref, "$rpath: No such file or directory");
|
|
} elsif ($copts->{-vargc}) {
|
|
#TODO: this is wrong when path is a file and not dir
|
|
# probably need to do ls all at once like cp/mv
|
|
sftp_echo($ref, "");
|
|
sftp_echo($ref, "$rpath:");
|
|
} elsif ($copts->{-argc} || $copts->{-argsleft} > 0) {
|
|
#TODO: this is wrong when path is a file and not dir
|
|
# probably need to do ls all at once like cp/mv
|
|
sftp_echo($ref, "$rpath:");
|
|
}
|
|
$copts->{-vargc}++;
|
|
my $cmd = (!$copts->{l} && !$copts->{1} ? "column" : "cat");
|
|
my $tmp = sftp_tmp();
|
|
if ($globc) {
|
|
open(TMP, '|-', "sort -k 9 -o $tmp");
|
|
foreach (@glob) {
|
|
next if (!$copts->{d} && S_ISDIR($_->{a}->perm));
|
|
$_->{link} = sftp($host)->readlink($_->{filename})
|
|
if ($copts->{l} && S_ISLNK($_->{a}->perm));
|
|
print TMP sftp_ls($_, 0, $copts->{l}) . "\n";
|
|
}
|
|
close TMP;
|
|
sftp_cmd($ref, $cmd, $tmp);
|
|
$tmp = sftp_tmp();
|
|
}
|
|
open(TMP, '|-', "sort -k 9 -o $tmp");
|
|
if ($globc && !$copts->{d}) {
|
|
@glob = sftp($host)->glob("$path/*");
|
|
#TODO: empty directories do not show up
|
|
my $dir;
|
|
for (my $j = 0; $j < scalar(@glob); $j++) {
|
|
my $tdir = dirname($glob[$j]->{filename});
|
|
if ($tdir ne $dir) {
|
|
$dir = $tdir;
|
|
if ($j > 0) {
|
|
close TMP;
|
|
sftp_cmd($ref, $cmd, $tmp);
|
|
$tmp = sftp_tmp();
|
|
open(TMP, '|-', "sort -k 9 -o $tmp");
|
|
}
|
|
if ($globc > 1) {
|
|
#TODO: this is wrong when path is a file and not dir
|
|
# probably need to do ls all at once like cp/mv
|
|
sftp_echo($ref, "");
|
|
sftp_echo($ref, "$dir:");
|
|
}
|
|
}
|
|
if ($copts->{l} && S_ISLNK($glob[$j]->{a}->perm)) {
|
|
$glob[$j]->{link} = sftp($host)->readlink($glob[$j]->{filename});
|
|
}
|
|
print TMP sftp_ls($glob[$j], 1, $copts->{l}) . "\n";
|
|
}
|
|
}
|
|
close TMP;
|
|
sftp_cmd($ref, $cmd, $tmp);
|
|
}
|
|
|
|
################
|
|
#### vmkdir ####
|
|
################
|
|
sub vmkdir {
|
|
my ($ref, $host, $path) = @_;
|
|
my $attrs = sftp($host)->stat($path);
|
|
if ($attrs && !S_ISDIR($attrs->perm)) {
|
|
sftp_error($ref, "File exists");
|
|
} elsif (!$attrs && !sftp($host)->mkdir($path)) {
|
|
sftp_error($ref, "Permission denied");
|
|
}
|
|
}
|
|
|
|
#############
|
|
#### vmv ####
|
|
#############
|
|
sub vmv {
|
|
my ($ref, $copts, $cp) = @_;
|
|
if (scalar(@{$copts->{-argv}}) == 1) {
|
|
sftp_error($ref, "usage: " . ($cp ? "cp" : "mv") . " src ... dst");
|
|
next;
|
|
}
|
|
my %shosts;
|
|
my $dpath0 = pop @{$copts->{-argv}};
|
|
(my $dhost, $dpath0) = hostpath($dpath0);
|
|
if ($dhost ne 'localhost') {
|
|
# do not run original spliced command
|
|
$copts->{-argc} = 0;
|
|
my $dattrs = sftp($dhost)->stat($dpath0);
|
|
foreach my $spath (@{$copts->{-argv}}) {
|
|
my $dpath = $dpath0;
|
|
$dpath .= "/" . basename($spath)
|
|
if ($dattrs && S_ISDIR($dattrs->perm));
|
|
(my $shost, $spath) = hostpath($spath);
|
|
if ($shost ne 'localhost') {
|
|
# copy remote to remote
|
|
if ($shost eq $dhost) {
|
|
#TODO: check is src/dst host are the same
|
|
#so rename instead
|
|
} else {
|
|
$shosts{$shost} = 1;
|
|
}
|
|
my $tmp = sftp_tmp();
|
|
my $sattrs = sftp($shost)->stat($spath);
|
|
#TODO: need a check about copying multiple files to a file, etc.
|
|
if (!$sattrs) {
|
|
sftp_error($ref, "$spath: No such file or directory");
|
|
next;
|
|
} elsif (S_ISDIR($sattrs->perm)) {
|
|
if (!$copts->{r} && !$copts->{R} && $cp) {
|
|
sftp_error($ref, "$spath is a directory");
|
|
next;
|
|
} else {
|
|
transport('rget', $shost, $spath, $tmp, {});
|
|
transport('rput', $dhost, $tmp, $dpath, {});
|
|
#TODO: do error checking before rm
|
|
transport('rrm', $shost, $spath, undef, {}) if (!$cp);
|
|
transport('rrm', 'localhost', $tmp, undef, {});
|
|
}
|
|
} elsif (S_ISREG($sattrs->perm) || S_ISLNK($sattrs->perm)) {
|
|
transport('get', $shost, $spath, $tmp, {});
|
|
transport('put', $dhost, $tmp, $dpath, {});
|
|
#TODO: do error checking before rm
|
|
transport('rm', $shost, $spath, undef, {}) if (!$cp);
|
|
transport('rm', 'localhost', $tmp, undef, {});
|
|
} else {
|
|
sftp_error($ref, "$spath: Not a regular file");
|
|
next;
|
|
}
|
|
#TODO: warn on non-{dir|reg|lnk}
|
|
} else {
|
|
# copy local to remote
|
|
if (! -e $spath) {
|
|
sftp_error($ref, "$spath: No such file or directory");
|
|
next;
|
|
} elsif (-d $spath) {
|
|
if (!$copts->{r} && !$copts->{R} && $cp) {
|
|
sftp_error($ref, "$spath is a directory");
|
|
next;
|
|
} else {
|
|
transport('rput', $dhost, $spath, $dpath, {});
|
|
#TODO: do error checking before rm
|
|
transport('rrm', 'localhost', $spath, undef, {})
|
|
if (!$cp);
|
|
}
|
|
} elsif (-f $spath || -l $spath) {
|
|
transport('put', $dhost, $spath, $dpath, {});
|
|
transport('rm', 'localhost', $spath, undef, {}) if (!$cp);
|
|
} else {
|
|
sftp_error($ref, "$spath: Not a regular file");
|
|
next;
|
|
}
|
|
}
|
|
}
|
|
#TODO: warn if only one arg for general case?
|
|
} else {
|
|
# original spliced command needs at least two args
|
|
$copts->{-argc} = 0 if ($copts->{-argc} == 1);
|
|
foreach my $spath (@{$copts->{-argv}}) {
|
|
my $dpath = $dpath0;
|
|
$dpath .= "/" . basename($spath) if (-d $dpath0);
|
|
(my $shost, $spath) = hostpath($spath);
|
|
if ($shost ne 'localhost') {
|
|
# copy remote to local
|
|
$shosts{$shost} = 1;
|
|
my $sattrs = sftp($shost)->stat($spath);
|
|
if (!$sattrs) {
|
|
sftp_error($ref, "$spath: No such file or directory");
|
|
next;
|
|
} elsif (S_ISDIR($sattrs->perm)) {
|
|
if (!$copts->{r} && !$copts->{R} && $cp) {
|
|
sftp_error($ref, "$spath is a directory");
|
|
next;
|
|
} else {
|
|
transport('rget', $shost, $spath, $dpath, {});
|
|
#TODO: do error checking before rm
|
|
transport('rrm', $shost, $spath, undef, {}) if (!$cp);
|
|
}
|
|
} elsif (S_ISREG($sattrs->perm) || S_ISLNK($sattrs->perm)) {
|
|
transport('get', $shost, $spath, $dpath, {});
|
|
#TODO: do error checking before rm
|
|
transport('rm', $shost, $spath, undef, {}) if (!$cp);
|
|
} else {
|
|
sftp_error($ref, "$spath: Not a regular file");
|
|
next;
|
|
}
|
|
} else {
|
|
# copy local to local
|
|
if (! -e $spath) {
|
|
sftp_error($ref, "$spath: No such file or directory");
|
|
next;
|
|
} elsif (-d $spath) {
|
|
if (!$copts->{r} && !$copts->{R} && $cp) {
|
|
sftp_error($ref, "$spath is a directory");
|
|
next;
|
|
} else {
|
|
transport('rput', 'localhost', $spath, $dpath, {});
|
|
#TODO: do error checking before rm
|
|
transport('rrm', 'localhost', $spath, undef, {})
|
|
if (!$cp);
|
|
}
|
|
} elsif (-f $spath || -l $spath) {
|
|
transport('put', 'localhost', $spath, $dpath, {});
|
|
transport('rm', 'localhost', $spath, undef, {})
|
|
if (!$cp);
|
|
} else {
|
|
sftp_error($ref, "$spath: Not a regular file");
|
|
next;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
transport('end', 'localhost');
|
|
transport('end', $_) foreach (keys %shosts);
|
|
transport('end', $dhost);
|
|
#TODO: this is a problem because mkdir needs to be executed first on
|
|
# localhost but rm's needs to be last ... probably need 2 stages
|
|
# FIXED BUT NOT TESTED
|
|
transport('end', 'localhost', 1);
|
|
}
|
|
|
|
#############
|
|
#### vrm ####
|
|
#############
|
|
sub vrm {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
if ($copts->{r}) {
|
|
sftp_error($ref, sftp($host, 1)->error)
|
|
if (!sftp($host)->rremove($path));
|
|
} else {
|
|
sftp_error($ref, sftp($host, 1)->error)
|
|
if (!sftp($host)->remove($path));
|
|
}
|
|
}
|
|
|
|
################
|
|
#### vrmdir ####
|
|
################
|
|
sub vrmdir {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
#TODO: directory does not exist
|
|
sftp_error($ref, "Directory not empty or permission denied")
|
|
if (!sftp($host)->rmdir($path));
|
|
}
|
|
|
|
###############
|
|
#### vtail ####
|
|
###############
|
|
sub vtail {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
my $n = (grep(/^\d+$/, keys %{$copts}))[0];
|
|
$n = 10 if (!defined $n);
|
|
my $fh = sftp($host)->open($path);
|
|
if ($fh) {
|
|
my $attrs = sftp($host)->stat($path);
|
|
my ($seek, $block, $nl, $i, $line) = ($attrs->size, $n * 80, 0, 1);
|
|
do {
|
|
$seek -= $block * $i++;
|
|
$seek = 0 if ($seek < 0);
|
|
seek($fh, $seek, 0);
|
|
read($fh, $line, $block);
|
|
$nl++ while ($line =~ /\n/gs);
|
|
my $index = 0;
|
|
while ($nl > $n) {
|
|
$index = index($line, "\n", $index) + 1;
|
|
$nl--;
|
|
}
|
|
$seek += $index;
|
|
} while ($seek > 0 && $nl < $n);
|
|
my ($tmp_fh, $tmp) = sftp_tmp();
|
|
seek($fh, $seek, 0);
|
|
print $tmp_fh $_ while (<$fh>);
|
|
close $tmp_fh;
|
|
close $fh;
|
|
sftp_cmd($ref, "cat", $tmp);
|
|
} else {
|
|
sftp_error($ref, sftp($host, 1)->error);
|
|
}
|
|
}
|
|
|
|
##############
|
|
#### vtee ####
|
|
##############
|
|
sub vtee {
|
|
my ($ref, $copts) = @_;
|
|
# do not run original spliced command
|
|
$copts->{-argc} = 0;
|
|
my @fhs;
|
|
my $append = ($copts->{a} ? ">" : "");
|
|
my $flags = SFTP_WRITE | SFTP_CREAT;
|
|
$flags |= SFTP_TRUNC if (!$copts->{a});
|
|
foreach (@{$copts->{-argv}}) {
|
|
my $fh;
|
|
my ($host, $path) = hostpath($_);
|
|
if ($host ne 'localhost') {
|
|
$fh = sftp($host)->open($path, $flags);
|
|
seek($fh, 0, 2) if ($copts->{a});
|
|
} else {
|
|
open($fh, "$append>", $_);
|
|
}
|
|
push(@fhs, $fh);
|
|
}
|
|
#TODO: tee hangs to remote file if input from another vfs command
|
|
while (my $line = <$ref>) {
|
|
print $_ $line foreach (@fhs);
|
|
}
|
|
close $_ foreach (@fhs);
|
|
}
|
|
|
|
###############
|
|
#### vtest ####
|
|
###############
|
|
sub vtest {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
my $true = 0;
|
|
my $attrs = sftp($host)->stat($path);
|
|
# can't implement -x, -G, or -O w/o effective uid/gid
|
|
if ($attrs && (
|
|
$copts->{b} && S_ISBLK($attrs->perm) ||
|
|
$copts->{c} && S_ISCHR($attrs->perm) ||
|
|
$copts->{d} && S_ISDIR($attrs->perm) ||
|
|
$copts->{e} ||
|
|
$copts->{f} && S_ISREG($attrs->perm) ||
|
|
$copts->{g} && (S_ISGID & $attrs->perm) ||
|
|
$copts->{h} && S_ISLNK($attrs->perm) ||
|
|
$copts->{k} && (S_ISVTX & $attrs->perm) ||
|
|
$copts->{p} && S_ISFIFO($attrs->perm) && !S_ISSOCK($attrs->perm) ||
|
|
$copts->{s} && $attrs->size > 0 ||
|
|
$copts->{u} && (S_ISUID & $attrs->perm) ||
|
|
#TODO: this (maybe others) wrong because stat will never return a symlink
|
|
$copts->{L} && S_ISLNK($attrs->perm) ||
|
|
$copts->{S} && S_ISSOCK($attrs->perm))) {
|
|
$true = 1;
|
|
} elsif ($attrs && $copts->{r}) {
|
|
my $fh = sftp($host)->open($path);
|
|
if ($fh) {
|
|
close $fh;
|
|
$true = 1;
|
|
}
|
|
} elsif ($attrs && $copts->{w}) {
|
|
my $fh = sftp($host)->open($path, SFTP_WRITE);
|
|
if ($fh) {
|
|
close $fh;
|
|
$true = 1;
|
|
}
|
|
}
|
|
sftp_cmd($ref, $true ? "true" : "false");
|
|
}
|
|
|
|
################
|
|
#### vtouch ####
|
|
################
|
|
sub vtouch {
|
|
my ($ref, $host, $path, $copts) = @_;
|
|
my $attrs = sftp($host)->stat($path);
|
|
if (!$attrs) {
|
|
my $fh = sftp($host)->open($path, SFTP_CREAT | SFTP_WRITE);
|
|
if (!$fh) {
|
|
sftp_error($ref, "Permission denied");
|
|
} else {
|
|
close $fh;
|
|
}
|
|
} else {
|
|
my $time = time;
|
|
my $atime = ($copts->{a} || !$copts->{m} ? $time : $attrs->atime);
|
|
my $mtime = ($copts->{m} || !$copts->{a} ? $time : $attrs->mtime);
|
|
$attrs->set_amtime($atime, $mtime);
|
|
sftp_error($ref, "Permission denied")
|
|
if (!sftp($host)->setstat($path, $attrs));
|
|
}
|
|
}
|
|
|
|
=cut mesh
|
|
|
|
########
|
|
# NOTE: always remove Time::HiRes from SFTP since not always installed on RH
|
|
########
|
|
|
|
# This chunk of stuff was generated by App::FatPacker. To find the original
|
|
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
|
|
BEGIN {
|
|
my %fatpacked;
|
|
|
|
$fatpacked{"Date/Parse.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATE_PARSE';
|
|
package Date::Parse;require 5.000;use strict;use vars qw($VERSION @ISA @EXPORT);use Time::Local;use Carp;use Time::Zone;use Exporter;@ISA=qw(Exporter);@EXPORT=qw(&strtotime &str2time &strptime);$VERSION="2.33";my%month=(january=>0,february=>1,march=>2,april=>3,may=>4,june=>5,july=>6,august=>7,september=>8,sept=>8,october=>9,november=>10,december=>11,);my%day=(sunday=>0,monday=>1,tuesday=>2,tues=>2,wednesday=>3,wednes=>3,thursday=>4,thur=>4,thurs=>4,friday=>5,saturday=>6,);my@suf=(qw(th st nd rd th th th th th th))x 3;@suf[11,12,13]=qw(th th th);map {$month{substr($_,0,3)}=$month{$_}}keys%month;map {$day{substr($_,0,3)}=$day{$_}}keys%day;my$strptime=<<'ESQ';use vars qw($day_ref $mon_ref $suf_ref $obj);sub gen_parser {local($day_ref,$mon_ref,$suf_ref,$obj)=@_;if($obj){my$obj_strptime=$strptime;substr($obj_strptime,index($strptime,"sub")+6,0)=<<'ESQ';my$sub=eval "$obj_strptime" or die $@;return$sub}eval "$strptime" or die $@}*strptime=gen_parser(\%day,\%month,\@suf);sub str2time {my@t=strptime(@_);return undef unless@t;my($ss,$mm,$hh,$day,$month,$year,$zone,$century)=@t;my@lt=localtime(time);$hh ||= 0;$mm ||= 0;$ss ||= 0;my$frac=$ss - int($ss);$ss=int$ss;$month=$lt[4]unless(defined$month);$day=$lt[3]unless(defined$day);$year=($month > $lt[4])? ($lt[5]- 1): $lt[5]unless(defined$year);$year += 1900 if defined$century;return undef unless($month <= 11 && $day >= 1 && $day <= 31 && $hh <= 23 && $mm <= 59 && $ss <= 59);my$result;if (defined$zone){$result=eval {local$SIG{__DIE__}=sub {};timegm($ss,$mm,$hh,$day,$month,$year)};return undef if!defined$result or $result==-1 && join("",$ss,$mm,$hh,$day,$month,$year)ne "595923311169";$result -= $zone}else {$result=eval {local$SIG{__DIE__}=sub {};timelocal($ss,$mm,$hh,$day,$month,$year)};return undef if!defined$result or $result==-1 && join("",$ss,$mm,$hh,$day,$month,$year)ne join("",(localtime(-1))[0..5])}return$result + $frac}1;
|
|
my %month = map { lc $_ } %$mon_ref;
|
|
my $daypat = join("|", map { lc $_ } reverse sort keys %$day_ref);
|
|
my $monpat = join("|", reverse sort keys %month);
|
|
my $sufpat = join("|", reverse sort map { lc $_ } @$suf_ref);
|
|
|
|
my %ampm = (
|
|
'a' => 0, # AM
|
|
'p' => 12, # PM
|
|
);
|
|
|
|
my($AM, $PM) = (0,12);
|
|
|
|
sub {
|
|
|
|
my $dtstr = lc shift;
|
|
my $merid = 24;
|
|
|
|
my($century,$year,$month,$day,$hh,$mm,$ss,$zone,$dst,$frac);
|
|
|
|
$zone = tz_offset(shift) if @_;
|
|
|
|
1 while $dtstr =~ s#\([^\(\)]*\)# #o;
|
|
|
|
$dtstr =~ s#(\A|\n|\Z)# #sog;
|
|
|
|
# ignore day names
|
|
$dtstr =~ s#([\d\w\s])[\.\,]\s#$1 #sog;
|
|
$dtstr =~ s/,/ /g;
|
|
$dtstr =~ s#($daypat)\s*(den\s)?\b# #o;
|
|
# Time: 12:00 or 12:00:00 with optional am/pm
|
|
|
|
return unless $dtstr =~ /\S/;
|
|
|
|
if ($dtstr =~ s/\s(\d{4})([-:]?)(\d\d?)\2(\d\d?)(?:[-Tt ](\d\d?)(?:([-:]?)(\d\d?)(?:\6(\d\d?)(?:[.,](\d+))?)?)?)?(?=\D)/ /) {
|
|
($year,$month,$day,$hh,$mm,$ss,$frac) = ($1,$3-1,$4,$5,$7,$8,$9);
|
|
}
|
|
|
|
unless (defined $hh) {
|
|
if ($dtstr =~ s#[:\s](\d\d?):(\d\d?)(:(\d\d?)(?:\.\d+)?)?(z)?\s*(?:([ap])\.?m?\.?)?\s# #o) {
|
|
($hh,$mm,$ss) = ($1,$2,$4);
|
|
$zone = 0 if $5;
|
|
$merid = $ampm{$6} if $6;
|
|
}
|
|
|
|
# Time: 12 am
|
|
|
|
elsif ($dtstr =~ s#\s(\d\d?)\s*([ap])\.?m?\.?\s# #o) {
|
|
($hh,$mm,$ss) = ($1,0,0);
|
|
$merid = $ampm{$2};
|
|
}
|
|
}
|
|
|
|
if (defined $hh and $hh <= 12 and $dtstr =~ s# ([ap])\.?m?\.?\s# #o) {
|
|
$merid = $ampm{$1};
|
|
}
|
|
|
|
|
|
unless (defined $year) {
|
|
# Date: 12-June-96 (using - . or /)
|
|
|
|
if ($dtstr =~ s#\s(\d\d?)([\-\./])($monpat)(\2(\d\d+))?\s# #o) {
|
|
($month,$day) = ($month{$3},$1);
|
|
$year = $5 if $5;
|
|
}
|
|
|
|
# Date: 12-12-96 (using '-', '.' or '/' )
|
|
|
|
elsif ($dtstr =~ s#\s(\d+)([\-\./])(\d\d?)(\2(\d+))?\s# #o) {
|
|
($month,$day) = ($1 - 1,$3);
|
|
|
|
if ($5) {
|
|
$year = $5;
|
|
# Possible match for 1995-01-24 (short mainframe date format);
|
|
($year,$month,$day) = ($1, $3 - 1, $5) if $month > 12;
|
|
return if length($year) > 2 and $year < 1901;
|
|
}
|
|
}
|
|
elsif ($dtstr =~ s#\s(\d+)\s*($sufpat)?\s*($monpat)# #o) {
|
|
($month,$day) = ($month{$3},$1);
|
|
}
|
|
elsif ($dtstr =~ s#($monpat)\s*(\d+)\s*($sufpat)?\s# #o) {
|
|
($month,$day) = ($month{$1},$2);
|
|
}
|
|
elsif ($dtstr =~ s#($monpat)([\/-])(\d+)[\/-]# #o) {
|
|
($month,$day) = ($month{$1},$3);
|
|
}
|
|
|
|
# Date: 961212
|
|
|
|
elsif ($dtstr =~ s#\s(\d\d)(\d\d)(\d\d)\s# #o) {
|
|
($year,$month,$day) = ($1,$2-1,$3);
|
|
}
|
|
|
|
$year = $1 if !defined($year) and $dtstr =~ s#\s(\d{2}(\d{2})?)[\s\.,]# #o;
|
|
|
|
}
|
|
|
|
# Zone
|
|
|
|
$dst = 1 if $dtstr =~ s#\bdst\b##o;
|
|
|
|
if ($dtstr =~ s#\s"?([a-z]{3,4})(dst|\d+[a-z]*|_[a-z]+)?"?\s# #o) {
|
|
$dst = 1 if $2 and $2 eq 'dst';
|
|
$zone = tz_offset($1);
|
|
return unless defined $zone;
|
|
}
|
|
elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?):?(\d\d)?(00)?\s# #o) {
|
|
my $m = defined($4) ? "$2$4" : 0;
|
|
my $h = "$2$3";
|
|
$zone = defined($1) ? tz_offset($1) : 0;
|
|
return unless defined $zone;
|
|
$zone += 60 * ($m + (60 * $h));
|
|
}
|
|
|
|
if ($dtstr =~ /\S/) {
|
|
# now for some dumb dates
|
|
if ($dtstr =~ s/^\s*(ut?|z)\s*$//) {
|
|
$zone = 0;
|
|
}
|
|
elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?)(\d\d)?(00)?\s# #o) {
|
|
my $m = defined($4) ? "$2$4" : 0;
|
|
my $h = "$2$3";
|
|
$zone = defined($1) ? tz_offset($1) : 0;
|
|
return unless defined $zone;
|
|
$zone += 60 * ($m + (60 * $h));
|
|
}
|
|
|
|
return if $dtstr =~ /\S/o;
|
|
}
|
|
|
|
if (defined $hh) {
|
|
if ($hh == 12) {
|
|
$hh = 0 if $merid == $AM;
|
|
}
|
|
elsif ($merid == $PM) {
|
|
$hh += 12;
|
|
}
|
|
}
|
|
|
|
if (defined $year && $year > 1900) {
|
|
$century = int($year / 100);
|
|
$year -= 1900;
|
|
}
|
|
|
|
$zone += 3600 if defined $zone && $dst;
|
|
$ss += "0.$frac" if $frac;
|
|
|
|
return ($ss,$mm,$hh,$day,$month,$year,$zone,$century);
|
|
}
|
|
ESQ
|
|
shift; # package
|
|
ESQ
|
|
DATE_PARSE
|
|
|
|
$fatpacked{"Digest/HMAC.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DIGEST_HMAC';
|
|
package Digest::HMAC;$VERSION="1.03";use strict;sub new {my($class,$key,$hasher,$block_size)=@_;$block_size ||= 64;$key=$hasher->new->add($key)->digest if length($key)> $block_size;my$self=bless {},$class;$self->{k_ipad}=$key ^ (chr(0x36)x $block_size);$self->{k_opad}=$key ^ (chr(0x5c)x $block_size);$self->{hasher}=$hasher->new->add($self->{k_ipad});$self}sub reset {my$self=shift;$self->{hasher}->reset->add($self->{k_ipad});$self}sub add {my$self=shift;$self->{hasher}->add(@_);$self}sub addfile {my$self=shift;$self->{hasher}->addfile(@_);$self}sub _digest {my$self=shift;my$inner_digest=$self->{hasher}->digest;$self->{hasher}->reset->add($self->{k_opad},$inner_digest)}sub digest {shift->_digest->digest}sub hexdigest {shift->_digest->hexdigest}sub b64digest {shift->_digest->b64digest}require Exporter;*import=\&Exporter::import;use vars qw(@EXPORT_OK);@EXPORT_OK=qw(hmac hmac_hex);sub hmac {my($data,$key,$hash_func,$block_size)=@_;$block_size ||= 64;$key=&$hash_func($key)if length($key)> $block_size;my$k_ipad=$key ^ (chr(0x36)x $block_size);my$k_opad=$key ^ (chr(0x5c)x $block_size);&$hash_func($k_opad,&$hash_func($k_ipad,$data))}sub hmac_hex {unpack("H*",&hmac)}1;
|
|
DIGEST_HMAC
|
|
|
|
$fatpacked{"Digest/SHA/PurePerl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DIGEST_SHA_PUREPERL';
|
|
package Digest::SHA::PurePerl;require 5.003000;use strict;use warnings;use vars qw($VERSION @ISA @EXPORT_OK $errmsg);use Fcntl qw(O_RDONLY);use integer;use Carp qw(croak);$VERSION='6.01';require Exporter;@ISA=qw(Exporter);@EXPORT_OK=('$errmsg');eval {require Digest::base;push(@ISA,'Digest::base')};my$MAX32=0xffffffff;my$uses64bit=(((1 << 16)<< 16)<< 16)<< 15;my@H01=(0x67452301,0xefcdab89,0x98badcfe,0x10325476,0xc3d2e1f0);my@H0224=(0xc1059ed8,0x367cd507,0x3070dd17,0xf70e5939,0xffc00b31,0x68581511,0x64f98fa7,0xbefa4fa4);my@H0256=(0x6a09e667,0xbb67ae85,0x3c6ef372,0xa54ff53a,0x510e527f,0x9b05688c,0x1f83d9ab,0x5be0cd19);my(@H0384,@H0512,@H0512224,@H0512256);sub _c_SL32 {my($x,$n)=@_;"($x << $n)"}sub _c_SR32 {my($x,$n)=@_;my$mask=(1 << (32 - $n))- 1;"(($x >> $n) & $mask)"}sub _c_Ch {my($x,$y,$z)=@_;"($z ^ ($x & ($y ^ $z)))"}sub _c_Pa {my($x,$y,$z)=@_;"($x ^ $y ^ $z)"}sub _c_Ma {my($x,$y,$z)=@_;"(($x & $y) | ($z & ($x | $y)))"}sub _c_ROTR {my($x,$n)=@_;"(" ._c_SR32($x,$n)." | " ._c_SL32($x,32 - $n).")"}sub _c_ROTL {my($x,$n)=@_;"(" ._c_SL32($x,$n)." | " ._c_SR32($x,32 - $n).")"}sub _c_SIGMA0 {my($x)=@_;"(" ._c_ROTR($x,2)." ^ " ._c_ROTR($x,13)." ^ " ._c_ROTR($x,22).")"}sub _c_SIGMA1 {my($x)=@_;"(" ._c_ROTR($x,6)." ^ " ._c_ROTR($x,11)." ^ " ._c_ROTR($x,25).")"}sub _c_sigma0 {my($x)=@_;"(" ._c_ROTR($x,7)." ^ " ._c_ROTR($x,18)." ^ " ._c_SR32($x,3).")"}sub _c_sigma1 {my($x)=@_;"(" ._c_ROTR($x,17)." ^ " ._c_ROTR($x,19)." ^ " ._c_SR32($x,10).")"}sub _c_M1Ch {my($a,$b,$c,$d,$e,$k,$w)=@_;"$e += " ._c_ROTL($a,5)." + " ._c_Ch($b,$c,$d)." + $k + $w; $b = " ._c_ROTL($b,30).";\n"}sub _c_M1Pa {my($a,$b,$c,$d,$e,$k,$w)=@_;"$e += " ._c_ROTL($a,5)." + " ._c_Pa($b,$c,$d)." + $k + $w; $b = " ._c_ROTL($b,30).";\n"}sub _c_M1Ma {my($a,$b,$c,$d,$e,$k,$w)=@_;"$e += " ._c_ROTL($a,5)." + " ._c_Ma($b,$c,$d)." + $k + $w; $b = " ._c_ROTL($b,30).";\n"}sub _c_M11Ch {my($k,$w)=@_;_c_M1Ch('$a','$b','$c','$d','$e',$k,$w)}sub _c_M11Pa {my($k,$w)=@_;_c_M1Pa('$a','$b','$c','$d','$e',$k,$w)}sub _c_M11Ma {my($k,$w)=@_;_c_M1Ma('$a','$b','$c','$d','$e',$k,$w)}sub _c_M12Ch {my($k,$w)=@_;_c_M1Ch('$e','$a','$b','$c','$d',$k,$w)}sub _c_M12Pa {my($k,$w)=@_;_c_M1Pa('$e','$a','$b','$c','$d',$k,$w)}sub _c_M12Ma {my($k,$w)=@_;_c_M1Ma('$e','$a','$b','$c','$d',$k,$w)}sub _c_M13Ch {my($k,$w)=@_;_c_M1Ch('$d','$e','$a','$b','$c',$k,$w)}sub _c_M13Pa {my($k,$w)=@_;_c_M1Pa('$d','$e','$a','$b','$c',$k,$w)}sub _c_M13Ma {my($k,$w)=@_;_c_M1Ma('$d','$e','$a','$b','$c',$k,$w)}sub _c_M14Ch {my($k,$w)=@_;_c_M1Ch('$c','$d','$e','$a','$b',$k,$w)}sub _c_M14Pa {my($k,$w)=@_;_c_M1Pa('$c','$d','$e','$a','$b',$k,$w)}sub _c_M14Ma {my($k,$w)=@_;_c_M1Ma('$c','$d','$e','$a','$b',$k,$w)}sub _c_M15Ch {my($k,$w)=@_;_c_M1Ch('$b','$c','$d','$e','$a',$k,$w)}sub _c_M15Pa {my($k,$w)=@_;_c_M1Pa('$b','$c','$d','$e','$a',$k,$w)}sub _c_M15Ma {my($k,$w)=@_;_c_M1Ma('$b','$c','$d','$e','$a',$k,$w)}sub _c_W11 {my($s)=@_;'$W[' .(($s + 0)& 0xf).']'}sub _c_W12 {my($s)=@_;'$W[' .(($s + 13)& 0xf).']'}sub _c_W13 {my($s)=@_;'$W[' .(($s + 8)& 0xf).']'}sub _c_W14 {my($s)=@_;'$W[' .(($s + 2)& 0xf).']'}sub _c_A1 {my($s)=@_;my$tmp=_c_W11($s)." ^ " ._c_W12($s)." ^ " ._c_W13($s)." ^ " ._c_W14($s);"((\$tmp = $tmp), (" ._c_W11($s)." = " ._c_ROTL('$tmp',1)."))"}my$sha1_code='
|
|
|
|
my($K1, $K2, $K3, $K4) = ( # SHA-1 constants
|
|
0x5a827999, 0x6ed9eba1, 0x8f1bbcdc, 0xca62c1d6
|
|
);
|
|
|
|
sub _sha1 {
|
|
my($self, $block) = @_;
|
|
my(@W, $a, $b, $c, $d, $e, $tmp);
|
|
|
|
@W = unpack("N16", $block);
|
|
($a, $b, $c, $d, $e) = @{$self->{H}};
|
|
' ._c_M11Ch('$K1','$W[ 0]')._c_M12Ch('$K1','$W[ 1]')._c_M13Ch('$K1','$W[ 2]')._c_M14Ch('$K1','$W[ 3]')._c_M15Ch('$K1','$W[ 4]')._c_M11Ch('$K1','$W[ 5]')._c_M12Ch('$K1','$W[ 6]')._c_M13Ch('$K1','$W[ 7]')._c_M14Ch('$K1','$W[ 8]')._c_M15Ch('$K1','$W[ 9]')._c_M11Ch('$K1','$W[10]')._c_M12Ch('$K1','$W[11]')._c_M13Ch('$K1','$W[12]')._c_M14Ch('$K1','$W[13]')._c_M15Ch('$K1','$W[14]')._c_M11Ch('$K1','$W[15]')._c_M12Ch('$K1',_c_A1(0))._c_M13Ch('$K1',_c_A1(1))._c_M14Ch('$K1',_c_A1(2))._c_M15Ch('$K1',_c_A1(3))._c_M11Pa('$K2',_c_A1(4))._c_M12Pa('$K2',_c_A1(5))._c_M13Pa('$K2',_c_A1(6))._c_M14Pa('$K2',_c_A1(7))._c_M15Pa('$K2',_c_A1(8))._c_M11Pa('$K2',_c_A1(9))._c_M12Pa('$K2',_c_A1(10))._c_M13Pa('$K2',_c_A1(11))._c_M14Pa('$K2',_c_A1(12))._c_M15Pa('$K2',_c_A1(13))._c_M11Pa('$K2',_c_A1(14))._c_M12Pa('$K2',_c_A1(15))._c_M13Pa('$K2',_c_A1(0))._c_M14Pa('$K2',_c_A1(1))._c_M15Pa('$K2',_c_A1(2))._c_M11Pa('$K2',_c_A1(3))._c_M12Pa('$K2',_c_A1(4))._c_M13Pa('$K2',_c_A1(5))._c_M14Pa('$K2',_c_A1(6))._c_M15Pa('$K2',_c_A1(7))._c_M11Ma('$K3',_c_A1(8))._c_M12Ma('$K3',_c_A1(9))._c_M13Ma('$K3',_c_A1(10))._c_M14Ma('$K3',_c_A1(11))._c_M15Ma('$K3',_c_A1(12))._c_M11Ma('$K3',_c_A1(13))._c_M12Ma('$K3',_c_A1(14))._c_M13Ma('$K3',_c_A1(15))._c_M14Ma('$K3',_c_A1(0))._c_M15Ma('$K3',_c_A1(1))._c_M11Ma('$K3',_c_A1(2))._c_M12Ma('$K3',_c_A1(3))._c_M13Ma('$K3',_c_A1(4))._c_M14Ma('$K3',_c_A1(5))._c_M15Ma('$K3',_c_A1(6))._c_M11Ma('$K3',_c_A1(7))._c_M12Ma('$K3',_c_A1(8))._c_M13Ma('$K3',_c_A1(9))._c_M14Ma('$K3',_c_A1(10))._c_M15Ma('$K3',_c_A1(11))._c_M11Pa('$K4',_c_A1(12))._c_M12Pa('$K4',_c_A1(13))._c_M13Pa('$K4',_c_A1(14))._c_M14Pa('$K4',_c_A1(15))._c_M15Pa('$K4',_c_A1(0))._c_M11Pa('$K4',_c_A1(1))._c_M12Pa('$K4',_c_A1(2))._c_M13Pa('$K4',_c_A1(3))._c_M14Pa('$K4',_c_A1(4))._c_M15Pa('$K4',_c_A1(5))._c_M11Pa('$K4',_c_A1(6))._c_M12Pa('$K4',_c_A1(7))._c_M13Pa('$K4',_c_A1(8))._c_M14Pa('$K4',_c_A1(9))._c_M15Pa('$K4',_c_A1(10))._c_M11Pa('$K4',_c_A1(11))._c_M12Pa('$K4',_c_A1(12))._c_M13Pa('$K4',_c_A1(13))._c_M14Pa('$K4',_c_A1(14))._c_M15Pa('$K4',_c_A1(15)).' $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
|
|
$self->{H}->[3] += $d; $self->{H}->[4] += $e;
|
|
}
|
|
';eval($sha1_code);sub _c_M2 {my($a,$b,$c,$d,$e,$f,$g,$h,$w)=@_;"\$T1 = $h + " ._c_SIGMA1($e)." + " ._c_Ch($e,$f,$g)." + \$K256[\$i++] + $w; $h = \$T1 + " ._c_SIGMA0($a)." + " ._c_Ma($a,$b,$c)."; $d += \$T1;\n"}sub _c_M21 {_c_M2('$a','$b','$c','$d','$e','$f','$g','$h',$_[0])}sub _c_M22 {_c_M2('$h','$a','$b','$c','$d','$e','$f','$g',$_[0])}sub _c_M23 {_c_M2('$g','$h','$a','$b','$c','$d','$e','$f',$_[0])}sub _c_M24 {_c_M2('$f','$g','$h','$a','$b','$c','$d','$e',$_[0])}sub _c_M25 {_c_M2('$e','$f','$g','$h','$a','$b','$c','$d',$_[0])}sub _c_M26 {_c_M2('$d','$e','$f','$g','$h','$a','$b','$c',$_[0])}sub _c_M27 {_c_M2('$c','$d','$e','$f','$g','$h','$a','$b',$_[0])}sub _c_M28 {_c_M2('$b','$c','$d','$e','$f','$g','$h','$a',$_[0])}sub _c_W21 {my($s)=@_;'$W[' .(($s + 0)& 0xf).']'}sub _c_W22 {my($s)=@_;'$W[' .(($s + 14)& 0xf).']'}sub _c_W23 {my($s)=@_;'$W[' .(($s + 9)& 0xf).']'}sub _c_W24 {my($s)=@_;'$W[' .(($s + 1)& 0xf).']'}sub _c_A2 {my($s)=@_;"(" ._c_W21($s)." += " ._c_sigma1(_c_W22($s))." + " ._c_W23($s)." + " ._c_sigma0(_c_W24($s)).")"}my$sha256_code='
|
|
|
|
my @K256 = ( # SHA-224/256 constants
|
|
0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,
|
|
0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,
|
|
0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,
|
|
0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,
|
|
0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,
|
|
0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,
|
|
0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,
|
|
0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,
|
|
0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,
|
|
0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,
|
|
0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,
|
|
0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,
|
|
0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,
|
|
0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,
|
|
0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,
|
|
0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2
|
|
);
|
|
|
|
sub _sha256 {
|
|
my($self, $block) = @_;
|
|
my(@W, $a, $b, $c, $d, $e, $f, $g, $h, $i, $T1);
|
|
|
|
@W = unpack("N16", $block);
|
|
($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
|
|
' ._c_M21('$W[ 0]')._c_M22('$W[ 1]')._c_M23('$W[ 2]')._c_M24('$W[ 3]')._c_M25('$W[ 4]')._c_M26('$W[ 5]')._c_M27('$W[ 6]')._c_M28('$W[ 7]')._c_M21('$W[ 8]')._c_M22('$W[ 9]')._c_M23('$W[10]')._c_M24('$W[11]')._c_M25('$W[12]')._c_M26('$W[13]')._c_M27('$W[14]')._c_M28('$W[15]')._c_M21(_c_A2(0))._c_M22(_c_A2(1))._c_M23(_c_A2(2))._c_M24(_c_A2(3))._c_M25(_c_A2(4))._c_M26(_c_A2(5))._c_M27(_c_A2(6))._c_M28(_c_A2(7))._c_M21(_c_A2(8))._c_M22(_c_A2(9))._c_M23(_c_A2(10))._c_M24(_c_A2(11))._c_M25(_c_A2(12))._c_M26(_c_A2(13))._c_M27(_c_A2(14))._c_M28(_c_A2(15))._c_M21(_c_A2(0))._c_M22(_c_A2(1))._c_M23(_c_A2(2))._c_M24(_c_A2(3))._c_M25(_c_A2(4))._c_M26(_c_A2(5))._c_M27(_c_A2(6))._c_M28(_c_A2(7))._c_M21(_c_A2(8))._c_M22(_c_A2(9))._c_M23(_c_A2(10))._c_M24(_c_A2(11))._c_M25(_c_A2(12))._c_M26(_c_A2(13))._c_M27(_c_A2(14))._c_M28(_c_A2(15))._c_M21(_c_A2(0))._c_M22(_c_A2(1))._c_M23(_c_A2(2))._c_M24(_c_A2(3))._c_M25(_c_A2(4))._c_M26(_c_A2(5))._c_M27(_c_A2(6))._c_M28(_c_A2(7))._c_M21(_c_A2(8))._c_M22(_c_A2(9))._c_M23(_c_A2(10))._c_M24(_c_A2(11))._c_M25(_c_A2(12))._c_M26(_c_A2(13))._c_M27(_c_A2(14))._c_M28(_c_A2(15)).' $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
|
|
$self->{H}->[3] += $d; $self->{H}->[4] += $e; $self->{H}->[5] += $f;
|
|
$self->{H}->[6] += $g; $self->{H}->[7] += $h;
|
|
}
|
|
';eval($sha256_code);sub _sha512_placeholder {return}my$sha512=\&_sha512_placeholder;my$_64bit_code='
|
|
|
|
no warnings qw(portable);
|
|
|
|
my @K512 = (
|
|
0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f,
|
|
0xe9b5dba58189dbbc, 0x3956c25bf348b538, 0x59f111f1b605d019,
|
|
0x923f82a4af194f9b, 0xab1c5ed5da6d8118, 0xd807aa98a3030242,
|
|
0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2,
|
|
0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235,
|
|
0xc19bf174cf692694, 0xe49b69c19ef14ad2, 0xefbe4786384f25e3,
|
|
0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65, 0x2de92c6f592b0275,
|
|
0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5,
|
|
0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f,
|
|
0xbf597fc7beef0ee4, 0xc6e00bf33da88fc2, 0xd5a79147930aa725,
|
|
0x06ca6351e003826f, 0x142929670a0e6e70, 0x27b70a8546d22ffc,
|
|
0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df,
|
|
0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6,
|
|
0x92722c851482353b, 0xa2bfe8a14cf10364, 0xa81a664bbc423001,
|
|
0xc24b8b70d0f89791, 0xc76c51a30654be30, 0xd192e819d6ef5218,
|
|
0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8,
|
|
0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99,
|
|
0x34b0bcb5e19b48a8, 0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb,
|
|
0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3, 0x748f82ee5defb2fc,
|
|
0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec,
|
|
0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915,
|
|
0xc67178f2e372532b, 0xca273eceea26619c, 0xd186b8c721c0c207,
|
|
0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178, 0x06f067aa72176fba,
|
|
0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b,
|
|
0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc,
|
|
0x431d67c49c100d4c, 0x4cc5d4becb3e42b6, 0x597f299cfc657e2a,
|
|
0x5fcb6fab3ad6faec, 0x6c44198c4a475817);
|
|
|
|
@H0384 = (
|
|
0xcbbb9d5dc1059ed8, 0x629a292a367cd507, 0x9159015a3070dd17,
|
|
0x152fecd8f70e5939, 0x67332667ffc00b31, 0x8eb44a8768581511,
|
|
0xdb0c2e0d64f98fa7, 0x47b5481dbefa4fa4);
|
|
|
|
@H0512 = (
|
|
0x6a09e667f3bcc908, 0xbb67ae8584caa73b, 0x3c6ef372fe94f82b,
|
|
0xa54ff53a5f1d36f1, 0x510e527fade682d1, 0x9b05688c2b3e6c1f,
|
|
0x1f83d9abfb41bd6b, 0x5be0cd19137e2179);
|
|
|
|
@H0512224 = (
|
|
0x8c3d37c819544da2, 0x73e1996689dcd4d6, 0x1dfab7ae32ff9c82,
|
|
0x679dd514582f9fcf, 0x0f6d2b697bd44da8, 0x77e36f7304c48942,
|
|
0x3f9d85a86a1d36c8, 0x1112e6ad91d692a1);
|
|
|
|
@H0512256 = (
|
|
0x22312194fc2bf72c, 0x9f555fa3c84c64c2, 0x2393b86b6f53b151,
|
|
0x963877195940eabd, 0x96283ee2a88effe3, 0xbe5e1e2553863992,
|
|
0x2b0199fc2c85b8aa, 0x0eb72ddc81c52ca2);
|
|
|
|
use warnings;
|
|
|
|
sub _c_SL64 { my($x, $n) = @_; "($x << $n)" }
|
|
|
|
sub _c_SR64 {
|
|
my($x, $n) = @_;
|
|
my $mask = (1 << (64 - $n)) - 1;
|
|
"(($x >> $n) & $mask)";
|
|
}
|
|
|
|
sub _c_ROTRQ {
|
|
my($x, $n) = @_;
|
|
"(" . _c_SR64($x, $n) . " | " . _c_SL64($x, 64 - $n) . ")";
|
|
}
|
|
|
|
sub _c_SIGMAQ0 {
|
|
my($x) = @_;
|
|
"(" . _c_ROTRQ($x, 28) . " ^ " . _c_ROTRQ($x, 34) . " ^ " .
|
|
_c_ROTRQ($x, 39) . ")";
|
|
}
|
|
|
|
sub _c_SIGMAQ1 {
|
|
my($x) = @_;
|
|
"(" . _c_ROTRQ($x, 14) . " ^ " . _c_ROTRQ($x, 18) . " ^ " .
|
|
_c_ROTRQ($x, 41) . ")";
|
|
}
|
|
|
|
sub _c_sigmaQ0 {
|
|
my($x) = @_;
|
|
"(" . _c_ROTRQ($x, 1) . " ^ " . _c_ROTRQ($x, 8) . " ^ " .
|
|
_c_SR64($x, 7) . ")";
|
|
}
|
|
|
|
sub _c_sigmaQ1 {
|
|
my($x) = @_;
|
|
"(" . _c_ROTRQ($x, 19) . " ^ " . _c_ROTRQ($x, 61) . " ^ " .
|
|
_c_SR64($x, 6) . ")";
|
|
}
|
|
|
|
my $sha512_code = q/
|
|
sub _sha512 {
|
|
my($self, $block) = @_;
|
|
my(@N, @W, $a, $b, $c, $d, $e, $f, $g, $h, $T1, $T2);
|
|
|
|
@N = unpack("N32", $block);
|
|
($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
|
|
for ( 0 .. 15) { $W[$_] = (($N[2*$_] << 16) << 16) | $N[2*$_+1] }
|
|
for (16 .. 79) { $W[$_] = / .
|
|
_c_sigmaQ1(q/$W[$_- 2]/) . q/ + $W[$_- 7] + / .
|
|
_c_sigmaQ0(q/$W[$_-15]/) . q/ + $W[$_-16] }
|
|
for ( 0 .. 79) {
|
|
$T1 = $h + / . _c_SIGMAQ1(q/$e/) .
|
|
q/ + (($g) ^ (($e) & (($f) ^ ($g)))) +
|
|
$K512[$_] + $W[$_];
|
|
$T2 = / . _c_SIGMAQ0(q/$a/) .
|
|
q/ + ((($a) & ($b)) | (($c) & (($a) | ($b))));
|
|
$h = $g; $g = $f; $f = $e; $e = $d + $T1;
|
|
$d = $c; $c = $b; $b = $a; $a = $T1 + $T2;
|
|
}
|
|
$self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
|
|
$self->{H}->[3] += $d; $self->{H}->[4] += $e; $self->{H}->[5] += $f;
|
|
$self->{H}->[6] += $g; $self->{H}->[7] += $h;
|
|
}
|
|
/;
|
|
|
|
eval($sha512_code);
|
|
$sha512 = \&_sha512;
|
|
|
|
';eval($_64bit_code)if$uses64bit;sub _SETBIT {my($self,$pos)=@_;my@c=unpack("C*",$self->{block});$c[$pos >> 3]=0x00 unless defined$c[$pos >> 3];$c[$pos >> 3]|= (0x01 << (7 - $pos % 8));$self->{block}=pack("C*",@c)}sub _CLRBIT {my($self,$pos)=@_;my@c=unpack("C*",$self->{block});$c[$pos >> 3]=0x00 unless defined$c[$pos >> 3];$c[$pos >> 3]&= ~(0x01 << (7 - $pos % 8));$self->{block}=pack("C*",@c)}sub _BYTECNT {my($bitcnt)=@_;$bitcnt > 0 ? 1 + (($bitcnt - 1)>> 3): 0}sub _digcpy {my($self)=@_;my@dig;for (@{$self->{H}}){push(@dig,(($_>>16)>>16)& $MAX32)if$self->{alg}>= 384;push(@dig,$_ & $MAX32)}$self->{digest}=pack("N" .($self->{digestlen}>>2),@dig)}sub _sharewind {my($self)=@_;my$alg=$self->{alg};$self->{block}="";$self->{blockcnt}=0;$self->{blocksize}=$alg <= 256 ? 512 : 1024;for (qw(lenll lenlh lenhl lenhh)){$self->{$_}=0}$self->{digestlen}=$alg==1 ? 20 : ($alg % 1000)/8;if ($alg==1){$self->{sha}=\&_sha1;$self->{H}=[@H01]}elsif ($alg==224){$self->{sha}=\&_sha256;$self->{H}=[@H0224]}elsif ($alg==256){$self->{sha}=\&_sha256;$self->{H}=[@H0256]}elsif ($alg==384){$self->{sha}=$sha512;$self->{H}=[@H0384]}elsif ($alg==512){$self->{sha}=$sha512;$self->{H}=[@H0512]}elsif ($alg==512224){$self->{sha}=$sha512;$self->{H}=[@H0512224]}elsif ($alg==512256){$self->{sha}=$sha512;$self->{H}=[@H0512256]}push(@{$self->{H}},0)while scalar(@{$self->{H}})< 8;$self}sub _shaopen {my($alg)=@_;my($self);return unless grep {$alg==$_}(1,224,256,384,512,512224,512256);return if ($alg >= 384 &&!$uses64bit);$self->{alg}=$alg;_sharewind($self)}sub _shadirect {my($bitstr,$bitcnt,$self)=@_;my$savecnt=$bitcnt;my$offset=0;my$blockbytes=$self->{blocksize}>> 3;while ($bitcnt >= $self->{blocksize}){&{$self->{sha}}($self,substr($bitstr,$offset,$blockbytes));$offset += $blockbytes;$bitcnt -= $self->{blocksize}}if ($bitcnt > 0){$self->{block}=substr($bitstr,$offset,_BYTECNT($bitcnt));$self->{blockcnt}=$bitcnt}$savecnt}sub _shabytes {my($bitstr,$bitcnt,$self)=@_;my($numbits);my$savecnt=$bitcnt;if ($self->{blockcnt}+ $bitcnt >= $self->{blocksize}){$numbits=$self->{blocksize}- $self->{blockcnt};$self->{block}.= substr($bitstr,0,$numbits >> 3);$bitcnt -= $numbits;$bitstr=substr($bitstr,$numbits >> 3,_BYTECNT($bitcnt));&{$self->{sha}}($self,$self->{block});$self->{block}="";$self->{blockcnt}=0;_shadirect($bitstr,$bitcnt,$self)}else {$self->{block}.= substr($bitstr,0,_BYTECNT($bitcnt));$self->{blockcnt}+= $bitcnt}$savecnt}sub _shabits {my($bitstr,$bitcnt,$self)=@_;my($i,@buf);my$numbytes=_BYTECNT($bitcnt);my$savecnt=$bitcnt;my$gap=8 - $self->{blockcnt}% 8;my@c=unpack("C*",$self->{block});my@b=unpack("C" .$numbytes,$bitstr);$c[$self->{blockcnt}>>3]&= (~0 << $gap);$c[$self->{blockcnt}>>3]|= $b[0]>> (8 - $gap);$self->{block}=pack("C*",@c);$self->{blockcnt}+= ($bitcnt < $gap)? $bitcnt : $gap;return($savecnt)if$bitcnt < $gap;if ($self->{blockcnt}==$self->{blocksize}){&{$self->{sha}}($self,$self->{block});$self->{block}="";$self->{blockcnt}=0}return($savecnt)if ($bitcnt -= $gap)==0;for ($i=0;$i < $numbytes - 1;$i++){$buf[$i]=(($b[$i]<< $gap)& 0xff)| ($b[$i+1]>> (8 - $gap))}$buf[$numbytes-1]=($b[$numbytes-1]<< $gap)& 0xff;_shabytes(pack("C*",@buf),$bitcnt,$self);$savecnt}sub _shawrite {my($bitstr,$bitcnt,$self)=@_;return(0)unless$bitcnt > 0;no integer;my$TWO32=4294967296;if (($self->{lenll}+= $bitcnt)>= $TWO32){$self->{lenll}-= $TWO32;if (++$self->{lenlh}>= $TWO32){$self->{lenlh}-= $TWO32;if (++$self->{lenhl}>= $TWO32){$self->{lenhl}-= $TWO32;if (++$self->{lenhh}>= $TWO32){$self->{lenhh}-= $TWO32}}}}use integer;my$blockcnt=$self->{blockcnt};return(_shadirect($bitstr,$bitcnt,$self))if$blockcnt==0;return(_shabytes ($bitstr,$bitcnt,$self))if$blockcnt % 8==0;return(_shabits ($bitstr,$bitcnt,$self))}my$no_downgrade='sub utf8::downgrade { 1 }';my$pp_downgrade=q {
|
|
sub utf8::downgrade {
|
|
|
|
# No need to downgrade if character and byte
|
|
# semantics are equivalent. But this might
|
|
# leave the UTF-8 flag set, harmlessly.
|
|
|
|
require bytes;
|
|
return 1 if length($_[0]) == bytes::length($_[0]);
|
|
|
|
use utf8;
|
|
return 0 if $_[0] =~ /[^\x00-\xff]/;
|
|
$_[0] = pack('C*', unpack('U*', $_[0]));
|
|
return 1;
|
|
}
|
|
};{no integer;if ($] < 5.006){eval$no_downgrade}elsif ($] < 5.008){eval$pp_downgrade}}my$WSE='Wide character in subroutine entry';my$MWS=16384;sub _shaWrite {my($bytestr_r,$bytecnt,$self)=@_;return(0)unless$bytecnt > 0;croak$WSE unless utf8::downgrade($$bytestr_r,1);return(_shawrite($$bytestr_r,$bytecnt<<3,$self))if$bytecnt <= $MWS;my$offset=0;while ($bytecnt > $MWS){_shawrite(substr($$bytestr_r,$offset,$MWS),$MWS<<3,$self);$offset += $MWS;$bytecnt -= $MWS}_shawrite(substr($$bytestr_r,$offset,$bytecnt),$bytecnt<<3,$self)}sub _shafinish {my($self)=@_;my$LENPOS=$self->{alg}<= 256 ? 448 : 896;_SETBIT($self,$self->{blockcnt}++);while ($self->{blockcnt}> $LENPOS){if ($self->{blockcnt}< $self->{blocksize}){_CLRBIT($self,$self->{blockcnt}++)}else {&{$self->{sha}}($self,$self->{block});$self->{block}="";$self->{blockcnt}=0}}while ($self->{blockcnt}< $LENPOS){_CLRBIT($self,$self->{blockcnt}++)}if ($self->{blocksize}> 512){$self->{block}.= pack("N",$self->{lenhh}& $MAX32);$self->{block}.= pack("N",$self->{lenhl}& $MAX32)}$self->{block}.= pack("N",$self->{lenlh}& $MAX32);$self->{block}.= pack("N",$self->{lenll}& $MAX32);&{$self->{sha}}($self,$self->{block})}sub _shadigest {my($self)=@_;_digcpy($self);$self->{digest}}sub _shahex {my($self)=@_;_digcpy($self);join("",unpack("H*",$self->{digest}))}sub _shabase64 {my($self)=@_;_digcpy($self);my$b64=pack("u",$self->{digest});$b64 =~ s/^.//mg;$b64 =~ s/\n//g;$b64 =~ tr|` -_|AA-Za-z0-9+/|;my$numpads=(3 - length($self->{digest})% 3)% 3;$b64 =~ s/.{$numpads}$// if$numpads;$b64}sub _shadsize {my($self)=@_;$self->{digestlen}}sub _shacpy {my($to,$from)=@_;$to->{alg}=$from->{alg};$to->{sha}=$from->{sha};$to->{H}=[@{$from->{H}}];$to->{block}=$from->{block};$to->{blockcnt}=$from->{blockcnt};$to->{blocksize}=$from->{blocksize};for (qw(lenhh lenhl lenlh lenll)){$to->{$_}=$from->{$_}}$to->{digestlen}=$from->{digestlen};$to}sub _shadup {my($self)=@_;my($copy);_shacpy($copy,$self)}sub _shadump {my$self=shift;for (qw(alg H block blockcnt lenhh lenhl lenlh lenll)){return unless defined$self->{$_}}my@state=();my$fmt=($self->{alg}<= 256 ? "%08x" : "%016x");push(@state,"alg:" .$self->{alg});my@H=map {$self->{alg}<= 256 ? $_ & $MAX32 : $_}@{$self->{H}};push(@state,"H:" .join(":",map {sprintf($fmt,$_)}@H));my@c=unpack("C*",$self->{block});push(@c,0x00)while scalar(@c)< ($self->{blocksize}>> 3);push(@state,"block:" .join(":",map {sprintf("%02x",$_)}@c));push(@state,"blockcnt:" .$self->{blockcnt});push(@state,"lenhh:" .$self->{lenhh});push(@state,"lenhl:" .$self->{lenhl});push(@state,"lenlh:" .$self->{lenlh});push(@state,"lenll:" .$self->{lenll});join("\n",@state)."\n"}sub _shaload {my$state=shift;my%s=();for (split(/\n/,$state)){s/^\s+//;s/\s+$//;next if (/^(#|$)/);my@f=split(/[:\s]+/);my$tag=shift(@f);$s{$tag}=join('',@f)}grep {$_==$s{alg}}(1,224,256,384,512,512224,512256)or return;length($s{H})==($s{alg}<= 256 ? 64 : 128)or return;length($s{block})==($s{alg}<= 256 ? 128 : 256)or return;{no integer;for (qw(blockcnt lenhh lenhl lenlh lenll)){0 <= $s{$_}or return;$s{$_}<= 4294967295 or return}$s{blockcnt}< ($s{alg}<= 256 ? 512 : 1024)or return}my$self=_shaopen($s{alg})or return;my@h=$s{H}=~ /(.{8})/g;for (@{$self->{H}}){$_=hex(shift@h);if ($self->{alg}> 256){$_=(($_ << 16)<< 16)| hex(shift@h)}}$self->{blockcnt}=$s{blockcnt};$self->{block}=pack("H*",$s{block});$self->{block}=substr($self->{block},0,_BYTECNT($self->{blockcnt}));$self->{lenhh}=$s{lenhh};$self->{lenhl}=$s{lenhl};$self->{lenlh}=$s{lenlh};$self->{lenll}=$s{lenll};$self}sub _hmacopen {my($alg,$key)=@_;my($self);$self->{isha}=_shaopen($alg)or return;$self->{osha}=_shaopen($alg)or return;croak$WSE unless utf8::downgrade($key,1);if (length($key)> $self->{osha}->{blocksize}>> 3){$self->{ksha}=_shaopen($alg)or return;_shawrite($key,length($key)<< 3,$self->{ksha});_shafinish($self->{ksha});$key=_shadigest($self->{ksha})}$key .= chr(0x00)while length($key)< $self->{osha}->{blocksize}>> 3;my@k=unpack("C*",$key);for (@k){$_ ^= 0x5c}_shawrite(pack("C*",@k),$self->{osha}->{blocksize},$self->{osha});for (@k){$_ ^= (0x5c ^ 0x36)}_shawrite(pack("C*",@k),$self->{isha}->{blocksize},$self->{isha});$self}sub _hmacWrite {my($bytestr_r,$bytecnt,$self)=@_;_shaWrite($bytestr_r,$bytecnt,$self->{isha})}sub _hmacfinish {my($self)=@_;_shafinish($self->{isha});_shawrite(_shadigest($self->{isha}),$self->{isha}->{digestlen}<< 3,$self->{osha});_shafinish($self->{osha})}sub _hmacdigest {my($self)=@_;_shadigest($self->{osha})}sub _hmachex {my($self)=@_;_shahex($self->{osha})}sub _hmacbase64 {my($self)=@_;_shabase64($self->{osha})}my@suffix_extern=("","_hex","_base64");my@suffix_intern=("digest","hex","base64");my($i,$alg);for$alg (1,224,256,384,512,512224,512256){for$i (0 .. 2){my$fcn='sub sha' .$alg .$suffix_extern[$i].' {
|
|
my $state = _shaopen(' .$alg .') or return;
|
|
for (@_) { _shaWrite(\$_, length($_), $state) }
|
|
_shafinish($state);
|
|
_sha' .$suffix_intern[$i].'($state);
|
|
}';eval($fcn);push(@EXPORT_OK,'sha' .$alg .$suffix_extern[$i]);$fcn='sub hmac_sha' .$alg .$suffix_extern[$i].' {
|
|
my $state = _hmacopen(' .$alg .', pop(@_)) or return;
|
|
for (@_) { _hmacWrite(\$_, length($_), $state) }
|
|
_hmacfinish($state);
|
|
_hmac' .$suffix_intern[$i].'($state);
|
|
}';eval($fcn);push(@EXPORT_OK,'hmac_sha' .$alg .$suffix_extern[$i])}}sub hashsize {my$self=shift;_shadsize($self)<< 3}sub algorithm {my$self=shift;$self->{alg}}sub add {my$self=shift;for (@_){_shaWrite(\$_,length($_),$self)}$self}sub digest {my$self=shift;_shafinish($self);my$rsp=_shadigest($self);_sharewind($self);$rsp}sub hexdigest {my$self=shift;_shafinish($self);my$rsp=_shahex($self);_sharewind($self);$rsp}sub b64digest {my$self=shift;_shafinish($self);my$rsp=_shabase64($self);_sharewind($self);$rsp}sub new {my($class,$alg)=@_;$alg =~ s/\D+//g if defined$alg;if (ref($class)){if (!defined($alg)|| ($alg==$class->algorithm)){_sharewind($class);return($class)}my$self=_shaopen($alg)or return;return(_shacpy($class,$self))}$alg=1 unless defined$alg;my$self=_shaopen($alg)or return;bless($self,$class);$self}sub clone {my$self=shift;my$copy=_shadup($self)or return;bless($copy,ref($self))}BEGIN {*reset=\&new}sub add_bits {my($self,$data,$nbits)=@_;unless (defined$nbits){$nbits=length($data);$data=pack("B*",$data)}$nbits=length($data)* 8 if$nbits > length($data)* 8;_shawrite($data,$nbits,$self);return($self)}sub _bail {my$msg=shift;$errmsg=$!;$msg .= ": $!";croak$msg}sub _addfile {my ($self,$handle)=@_;my$n;my$buf="";while (($n=read($handle,$buf,4096))){$self->add($buf)}_bail("Read failed")unless defined$n;$self}{my$_can_T_filehandle;sub _istext {local*FH=shift;my$file=shift;if (!defined$_can_T_filehandle){local $^W=0;my$istext=eval {-T FH};$_can_T_filehandle=$@ ? 0 : 1;return$_can_T_filehandle ? $istext : -T $file}return$_can_T_filehandle ? -T FH : -T $file}}sub addfile {my ($self,$file,$mode)=@_;return(_addfile($self,$file))unless ref(\$file)eq 'SCALAR';$mode=defined($mode)? $mode : "";my ($binary,$UNIVERSAL,$BITS)=map {$_ eq $mode}("b","U","0");local*FH;$file eq '-' and open(FH,'< -')or sysopen(FH,$file,O_RDONLY)or _bail('Open failed');if ($BITS){my ($n,$buf)=(0,"");while (($n=read(FH,$buf,4096))){$buf =~ tr/01//cd;$self->add_bits($buf)}_bail("Read failed")unless defined$n;close(FH);return($self)}binmode(FH)if$binary || $UNIVERSAL;if ($UNIVERSAL && _istext(*FH,$file)){while (<FH>){s/\015\012/\012/g;s/\015/\012/g;$self->add($_)}}else {$self->_addfile(*FH)}close(FH);$self}sub getstate {my$self=shift;return _shadump($self)}sub putstate {my$class=shift;my$state=shift;if (ref($class)){my$self=_shaload($state)or return;return(_shacpy($class,$self))}my$self=_shaload($state)or return;bless($self,$class);return($self)}sub dump {my$self=shift;my$file=shift;my$state=$self->getstate or return;$file="-" if (!defined($file)|| $file eq "");local*FH;open(FH,"> $file")or return;print FH$state;close(FH);return($self)}sub load {my$class=shift;my$file=shift;$file="-" if (!defined($file)|| $file eq "");local*FH;open(FH,"< $file")or return;my$str=join('',<FH>);close(FH);$class->putstate($str)}1;
|
|
DIGEST_SHA_PUREPERL
|
|
|
|
$fatpacked{"File/Spec/Link.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_SPEC_LINK';
|
|
package File::Spec::Link;use strict;use warnings;use File::Spec ();use base q(File::Spec);our$VERSION=0.073;sub canonpath {my($spec,$path)=@_;return$spec->SUPER::canonpath($path)if$path;require Carp;Carp::cluck("canonpath: ",defined$path ? "empty path" : "path undefined");return$path}sub catdir {my$spec=shift;return @_ ? $spec->SUPER::catdir(@_): $spec->curdir}sub linked {my$self=shift -> new(@_);return unless$self -> follow;return$self -> path}sub resolve {my$self=shift -> new(@_);return unless$self -> resolved;return$self -> path}sub resolve_all {my$self=shift -> new(@_);return $_[0]if ($_[0]=~ /^(?:file:|[a-z]+:\/\/)/);return unless$self -> resolvedir;return$self -> path .(($_[0]=~ /\/$/)? "/" : "")}sub relative_to_file {my($spec,$path)=splice @_,0,2;my$self=$spec -> new(@_);return unless$self -> relative($path);return$self -> path}sub chopfile {my$self=shift -> new(@_);return$self -> path if length($self -> chop);return}sub full_resolve {my($spec,$file)=@_;my$path=$spec->resolve_path($file);return defined$path ? $path : $spec->resolve_all($file)}sub resolve_path {my($spec,$file)=@_;my$path=do {local$SIG{__WARN__}=sub {if ($_[0]=~ /^opendir\b/ and $_[0]=~ /\bNot\s+a\s+directory\b/ and $Cwd::VERSION < 2.18 and not -d $file){warn <<WARN}else {warn $_[0]}};eval {require Cwd}&& Cwd::abs_path($file)};return unless$path;return$spec->file_name_is_absolute($file)? $path : $spec->abs2rel($path)}sub splitlast {my$self=shift -> new(@_);my$last_path=$self -> chop;return ($self -> path,$last_path)}sub new {my$self=bless {},shift;$self -> split(shift)if @_;return$self}sub path {my$self=shift;return$self -> catpath($self->vol,$self->dir,q{})}sub canonical {my$self=shift;return$self -> canonpath($self -> path)}sub vol {my$vol=shift->{vol};return defined$vol ? $vol : q{}}sub dir {my$self=shift;return$self -> catdir($self -> dirs)}sub dirs {my$dirs=shift->{dirs};return$dirs ? @{$dirs}: ()}sub add {my($self,$file)=@_;if($file eq $self -> curdir){}elsif($file eq $self -> updir){$self -> pop}else {$self -> push($file)}return}sub pop {my$self=shift;my@dirs=$self -> dirs;if(not @dirs or $dirs[-1]eq $self -> updir){push @{$self->{dirs}},$self -> updir}elsif(length$dirs[-1]and $dirs[-1]ne $self -> curdir){CORE::pop @{$self->{dirs}}}else {require Carp;Carp::cluck("Can't go up from ",length$dirs[-1]? $dirs[-1]: "empty dir")}return}sub push {my$self=shift;my$file=shift;CORE::push @{$self->{dirs}},$file if length$file;return}sub split {my($self,$path)=@_;my($vol,$dir,$file)=$self->splitpath($path,1);$self->{vol}=$vol;$self->{dirs}=[$self->splitdir($dir)];$self->push($file);return}sub chop {my$self=shift;my$dirs=$self->{dirs};my$file='';while(@$dirs){last if @$dirs==1 and not length$dirs->[0];last if length($file=CORE::pop @$dirs)}return$file}sub follow {my$self=shift;my$path=$self -> path;my$link=readlink$self->path;return$self->relative($link)if defined$link;require Carp;Carp::confess("Can't readlink ",$self->path," : ",(-l $self->path ? "but it is" : "not")," a link")}sub relative {my($self,$path)=@_;unless($self->file_name_is_absolute($path)){return unless length($self->chop);$path=$self->catdir($self->path,$path)}$self->split($path);return 1}sub resolved {my$self=shift;my$seen=@_ ? shift : {};while(-l $self->path){return if$seen->{$self->canonical}++;return unless$self->follow}return 1}sub resolvedir {my$self=shift;my$seen=@_ ? shift : {};my@path;while(1){return unless$self->resolved($seen);my$last=$self->chop;last unless length$last;unshift@path,$last}$self->add($_)for@path;return 1}1;
|
|
Cwd::abs_path() only works on directories, not: $file
|
|
Use Cwd v2.18 or later
|
|
WARN
|
|
FILE_SPEC_LINK
|
|
|
|
$fatpacked{"IPC/Open3.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_OPEN3';
|
|
package IPC::Open3;use strict;no strict 'refs';our ($VERSION,@ISA,@EXPORT);require Exporter;use Carp;use Symbol qw(gensym qualify);$VERSION='1.20';@ISA=qw(Exporter);@EXPORT=qw(open3);our$Me='open3 (bug)';sub xpipe {pipe $_[0],$_[1]or croak "$Me: pipe($_[0], $_[1]) failed: $!"}sub xopen {open $_[0],$_[1],@_[2..$#_]and return;local $"=', ';carp "$Me: open(@_) failed: $!"}sub xclose {$_[0]=~ /\A=?(\d+)\z/ ? do {my$fh;open($fh,$_[1].'&=' .$1)and close($fh)}: close $_[0]or croak "$Me: close($_[0]) failed: $!"}sub xfileno {return $1 if $_[0]=~ /\A=?(\d+)\z/;return fileno $_[0]}use constant FORCE_DEBUG_SPAWN=>0;use constant DO_SPAWN=>$^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;sub _open3 {local$Me=shift;splice @_,0,1,undef if \$_[0]==\undef;splice @_,1,1,undef if \$_[1]==\undef;unless (eval {$_[0]=gensym unless defined $_[0]&& length $_[0];$_[1]=gensym unless defined $_[1]&& length $_[1];1}){$@ =~ s/(?<=value attempted) at .*//s;croak "$Me: $@"}my@handles=({mode=>'<',handle=>\*STDIN },{mode=>'>',handle=>\*STDOUT },{mode=>'>',handle=>\*STDERR },);for (@handles){$_->{parent}=shift;$_->{open_as}=gensym}if (@_ > 1 and $_[0]eq '-'){croak "Arguments don't make sense when the command is '-'"}$handles[2]{parent}||= $handles[1]{parent};$handles[2]{dup_of_out}=$handles[1]{parent}eq $handles[2]{parent};my$package;for (@handles){$_->{dup}=($_->{parent}=~ s/^[<>]&//);if ($_->{parent}!~ /\A=?(\d+)\z/){$package=caller 1 if (!defined$package);$_->{parent}=qualify $_->{parent},$package}next if $_->{dup}or $_->{dup_of_out};if ($_->{mode}eq '<'){xpipe $_->{open_as},$_->{parent}}else {xpipe $_->{parent},$_->{open_as}}}my$kidpid;if (!DO_SPAWN){xpipe my$stat_r,my$stat_w;$kidpid=fork;croak "$Me: fork failed: $!" unless defined$kidpid;if ($kidpid==0){eval {untie*STDIN;untie*STDOUT;untie*STDERR;close$stat_r;require Fcntl;my$flags=fcntl$stat_w,&Fcntl::F_GETFD,0;croak "$Me: fcntl failed: $!" unless$flags;fcntl$stat_w,&Fcntl::F_SETFD,$flags|&Fcntl::FD_CLOEXEC or croak "$Me: fcntl failed: $!";if (!$handles[2]{dup_of_out}&& $handles[2]{dup}&& xfileno($handles[2]{parent})==fileno \*STDOUT){my$tmp=gensym;xopen($tmp,'>&',$handles[2]{parent});$handles[2]{parent}=$tmp}for (@handles){if ($_->{dup_of_out}){xopen \*STDERR,">&STDOUT" if defined fileno STDERR && fileno STDERR!=fileno STDOUT}elsif ($_->{dup}){xopen $_->{handle},$_->{mode}.'&',$_->{parent}if fileno $_->{handle}!=xfileno($_->{parent})}else {xclose $_->{parent},$_->{mode};xopen $_->{handle},$_->{mode}.'&=',fileno $_->{open_as}}}return 1 if ($_[0]eq '-');exec @_ or do {local($")=(" ");croak "$Me: exec of @_ failed: $!"}}and do {close$stat_w;return 0};my$bang=0+$!;my$err=$@;utf8::encode$err if $] >= 5.008;print$stat_w pack('IIa*',$bang,length($err),$err);close$stat_w;eval {require POSIX;POSIX::_exit(255)};exit 255}else {close$stat_w;my$to_read=length(pack('I',0))* 2;my$bytes_read=read($stat_r,my$buf='',$to_read);if ($bytes_read){(my$bang,$to_read)=unpack('II',$buf);read($stat_r,my$err='',$to_read);waitpid$kidpid,0;if ($err){utf8::decode$err if $] >= 5.008}else {$err="$Me: " .($!=$bang)}$!=$bang;die($err)}}}else {my@close;for (@handles){if ($_->{dup_of_out}){$_->{open_as}=$handles[1]{open_as}}elsif ($_->{dup}){$_->{open_as}=$_->{parent}=~ /\A[0-9]+\z/ ? $_->{parent}: \*{$_->{parent}};push@close,$_->{open_as}}else {push@close,\*{$_->{parent}},$_->{open_as}}}require IO::Pipe;$kidpid=eval {spawn_with_handles(\@handles,\@close,@_)};die "$Me: $@" if $@}for (@handles){next if $_->{dup}or $_->{dup_of_out};xclose $_->{open_as},$_->{mode}}xclose$handles[0]{parent},$handles[0]{mode}if$handles[0]{dup};select((select($handles[0]{parent}),$|=1)[0]);$kidpid}sub open3 {if (@_ < 4){local $"=', ';croak "open3(@_): not enough arguments"}return _open3 'open3',@_}sub spawn_with_handles {my$fds=shift;my$close_in_child=shift;my ($fd,%saved,@errs);for$fd (@$fds){$fd->{tmp_copy}=IO::Handle->new_from_fd($fd->{handle},$fd->{mode});$saved{fileno$fd->{handle}}=$fd->{tmp_copy}if$fd->{tmp_copy}}for$fd (@$fds){bless$fd->{handle},'IO::Handle' unless eval {$fd->{handle}->isa('IO::Handle')};my$open_as=$fd->{open_as};my$fileno=fileno($open_as);$fd->{handle}->fdopen(defined($fileno)? $saved{$fileno}|| $open_as : $open_as,$fd->{mode})}unless ($^O eq 'MSWin32'){require Fcntl;for$fd (@$close_in_child){next unless fileno$fd;fcntl($fd,Fcntl::F_SETFD(),1)or push@errs,"fcntl $fd: $!" unless$saved{fileno$fd}}}my$pid;unless (@errs){if (FORCE_DEBUG_SPAWN){pipe my$r,my$w or die "Pipe failed: $!";$pid=fork;die "Fork failed: $!" unless defined$pid;if (!$pid){{no warnings;exec @_}print$w 0 + $!;close$w;require POSIX;POSIX::_exit(255)}close$w;my$bad=<$r>;if (defined$bad){$!=$bad;undef$pid}}else {$pid=eval {system 1,@_}}if($@){push@errs,"IO::Pipe: Can't spawn-NOWAIT: $@"}elsif(!$pid || $pid < 0){push@errs,"IO::Pipe: Can't spawn-NOWAIT: $!"}}for$fd (reverse @$fds){$fd->{handle}->fdopen($fd->{tmp_copy},$fd->{mode})}for (values%saved){$_->close or croak "Can't close: $!"}croak join "\n",@errs if@errs;return$pid}1;
|
|
IPC_OPEN3
|
|
|
|
$fatpacked{"Net/NTPTime.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_NTPTIME';
|
|
package Net::NTPTime;use Socket;use base qw(Exporter);our@EXPORT=qw(get_ntp_time get_unix_time);our$VERSION='1.03';sub get_ntp_time {my$hostname=shift(@_)|| '0.north-america.pool.ntp.org';socket(SOCKET,PF_INET,SOCK_DGRAM,getprotobyname('udp'));my$ipaddr=inet_aton($hostname);my$portaddr=sockaddr_in(123,$ipaddr);my$bstr="\010" ."\0"x47;send(SOCKET,$bstr,0,$portaddr);$portaddr=recv(SOCKET,$bstr,1024,0);my@words=unpack("N12",$bstr);return($words[10])}sub get_unix_time {my$hostname=shift(@_)|| '0.north-america.pool.ntp.org';return(&get_ntp_time($hostname)- 2208988800)}
|
|
NET_NTPTIME
|
|
|
|
$fatpacked{"Net/SFTP/Foreign.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN';
|
|
package Net::SFTP::Foreign;our$VERSION='1.89';use strict;use warnings;use warnings::register;use Carp qw(carp croak);use Symbol ();use Errno ();use Fcntl;use File::Spec ();use POSIX ();BEGIN {if ($] >= 5.008){require Encode}else {require bytes;bytes->import();*Encode::encode=sub {$_[1]};*Encode::decode=sub {$_[1]};*utf8::downgrade=sub {1}}}our$debug;BEGIN {*Net::SFTP::Foreign::Helpers::debug=\$debug};use Net::SFTP::Foreign::Helpers qw(_is_reg _is_lnk _is_dir _debug _sort_entries _gen_wanted _gen_converter _hexdump _ensure_list _catch_tainted_args _file_part _umask_save_and_set _untaint);use Net::SFTP::Foreign::Constants qw(:fxp :flags :att :status :error SSH2_FILEXFER_VERSION);use Net::SFTP::Foreign::Attributes;use Net::SFTP::Foreign::Buffer;require Net::SFTP::Foreign::Common;our@ISA=qw(Net::SFTP::Foreign::Common);our$dirty_cleanup;my$windows;BEGIN {$windows=$^O =~ /Win(?:32|64)/;if ($^O =~ /solaris/i){$dirty_cleanup=1 unless defined$dirty_cleanup}}my$thread_generation=1;sub CLONE {$thread_generation++}sub _deprecated {if (warnings::enabled('deprecated')and warnings::enabled(__PACKAGE__)){Carp::carp(join('',@_))}}sub _next_msg_id {shift->{_msg_id}++}use constant _empty_attributes=>Net::SFTP::Foreign::Attributes->new;sub _queue_new_msg {my$sftp=shift;my$code=shift;my$id=$sftp->_next_msg_id;my$msg=Net::SFTP::Foreign::Buffer->new(int8=>$code,int32=>$id,@_);$sftp->_queue_msg($msg);return$id}sub _queue_msg {my ($sftp,$buf)=@_;my$bytes=$buf->bytes;my$len=length$bytes;if ($debug and $debug & 1){$sftp->{_queued}++;_debug(sprintf("queueing msg len: %i, code:%i, id:%i ... [$sftp->{_queued}]",$len,unpack(CN=>$bytes)));$debug & 16 and _hexdump(pack('N',length($bytes)).$bytes)}$sftp->{_bout}.= pack('N',length($bytes));$sftp->{_bout}.= $bytes}sub _do_io {$_[0]->{_backend}->_do_io(@_)}sub _conn_lost {my ($sftp,$status,$err,@str)=@_;$debug and $debug & 32 and _debug("_conn_lost");$sftp->{_status}or $sftp->_set_status(defined$status ? $status : SSH2_FX_CONNECTION_LOST);$sftp->{_error}or $sftp->_set_error((defined$err ? $err : SFTP_ERR_CONNECTION_BROKEN),(@str ? @str : "Connection to remote server is broken"));undef$sftp->{_connected}}sub _conn_failed {my$sftp=shift;$sftp->_conn_lost(SSH2_FX_NO_CONNECTION,SFTP_ERR_CONNECTION_BROKEN,@_)unless$sftp->{_error}}sub _get_msg {my$sftp=shift;$debug and $debug & 1 and _debug("waiting for message... [$sftp->{_queued}]");unless ($sftp->_do_io($sftp->{_timeout})){$sftp->_conn_lost(undef,undef,"Connection to remote server stalled");return undef}my$bin=\$sftp->{_bin};my$len=unpack N=>substr($$bin,0,4,'');my$msg=Net::SFTP::Foreign::Buffer->make(substr($$bin,0,$len,''));if ($debug and $debug & 1){$sftp->{_queued}--;my ($code,$id,$status)=unpack(CNN=>$$msg);$id='-' if$code==SSH2_FXP_VERSION;$status='-' unless$code==SSH2_FXP_STATUS;_debug(sprintf("got it!, len:%i, code:%i, id:%s, status: %s",$len,$code,$id,$status));$debug & 8 and _hexdump($$msg)}return$msg}sub _croak_bad_options {if (@_){my$s=(@_ > 1 ? 's' : '');croak "Invalid option$s '" .CORE::join("', '",@_)."' or bad combination of options"}}sub _fs_encode {my ($sftp,$path)=@_;Encode::encode($sftp->{_fs_encoding},$path)}sub _fs_decode {my ($sftp,$path)=@_;Encode::decode($sftp->{_fs_encoding},$path)}sub new {${^TAINT} and &_catch_tainted_args;my$class=shift;unshift @_,'host' if @_ & 1;my%opts=@_;my$sftp={_msg_id=>0,_bout=>'',_bin=>'',_connected=>1,_queued=>0,_error=>0,_status=>0 };bless$sftp,$class;if ($debug){_debug "This is Net::SFTP::Foreign $Net::SFTP::Foreign::VERSION";_debug "Loaded from $INC{'Net/SFTP/Foreign.pm'}";_debug "Running on Perl $^V for $^O";_debug "debug set to $debug";_debug "~0 is " .~0}$sftp->_clear_error_and_status;my$backend=delete$opts{backend};unless (ref$backend){$backend=($windows ? 'Windows' : 'Unix')unless (defined$backend);$backend =~ /^\w+$/ or croak "Bad backend name $backend";my$backend_class="Net::SFTP::Foreign::Backend::$backend";eval "require $backend_class; 1" or croak "Unable to load backend $backend: $@";$backend=$backend_class->_new($sftp,\%opts)}$sftp->{_backend}=$backend;if ($debug){my$class=ref($backend)|| $backend;no strict 'refs';my$version=${$class .'::VERSION'}|| 0;_debug "Using backend $class $version"}my%defs=$backend->_defaults;$sftp->{_autodie}=delete$opts{autodie};$sftp->{_block_size}=delete$opts{block_size}|| $defs{block_size}|| 32*1024;$sftp->{_min_block_size}=delete$opts{min_block_size}|| $defs{min_block_size}|| 512;$sftp->{_queue_size}=delete$opts{queue_size}|| $defs{queue_size}|| 32;$sftp->{_read_ahead}=$defs{read_ahead}|| $sftp->{_block_size}* 4;$sftp->{_write_delay}=$defs{write_delay}|| $sftp->{_block_size}* 8;$sftp->{_autoflush}=delete$opts{autoflush};$sftp->{_late_set_perm}=delete$opts{late_set_perm};$sftp->{_dirty_cleanup}=delete$opts{dirty_cleanup};$sftp->{_remote_has_volumes}=delete$opts{remote_has_volumes};$sftp->{_timeout}=delete$opts{timeout};defined$sftp->{_timeout}and $sftp->{_timeout}<= 0 and croak "invalid timeout";$sftp->{_fs_encoding}=delete$opts{fs_encoding};if (defined$sftp->{_fs_encoding}){$] < 5.008 and carp "fs_encoding feature is not supported in this perl version $]"}else {$sftp->{_fs_encoding}='utf8'}$sftp->autodisconnect(delete$opts{autodisconnect});$backend->_init_transport($sftp,\%opts);%opts and _croak_bad_options(keys%opts);$sftp->_init unless$sftp->{_error};$backend->_after_init($sftp);$sftp}sub autodisconnect {my ($sftp,$ad)=@_;if (not defined$ad or $ad==2){$debug and $debug & 4 and _debug "setting disconnecting pid to $$ and thread to $thread_generation";$sftp->{_disconnect_by_pid}=$$;$sftp->{_disconnect_by_thread}=$thread_generation}else {delete$sftp->{_disconnect_by_thread};if ($ad==0){$sftp->{_disconnect_by_pid}=-1}elsif ($ad==1){delete$sftp->{_disconnect_by_pid}}else {croak "bad value '$ad' for autodisconnect"}}1}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);if ($dirty or not defined$dirty){$debug and $debug & 4 and _debug("starting dirty cleanup of process $pid");OUT: for my$sig (($dirty ? (): 0),qw(TERM TERM KILL KILL)){$debug and $debug & 4 and _debug("killing process $pid with signal $sig");$sig and kill$sig,$pid;local ($@,$SIG{__DIE__},$SIG{__WARN__});my$deadline=time + 8;while (time < $deadline){my$wpr=waitpid($pid,POSIX::WNOHANG());$debug and $debug & 4 and _debug("waitpid returned ",$wpr);last OUT if$wpr or $!==Errno::ECHILD();sleep(1)}}}else {while (1){last if waitpid($pid,0)> 0;if ($!!=Errno::EINTR()){warn "internal error: unexpected error in waitpid($pid): $!" if $!!=Errno::ECHILD();last}}}$debug and $debug & 4 and _debug "process $pid reaped"}}close$sftp->{_pty}if defined$sftp->{_pty};1}sub DESTROY {local ($?,$!,$@);my$sftp=shift;my$dbpid=$sftp->{_disconnect_by_pid};my$dbthread=$sftp->{_disconnect_by_thread};$debug and $debug & 4 and _debug("$sftp->DESTROY called (current pid: $$, disconnect_by_pid: " .($dbpid || '')."), current thread generation: $thread_generation, disconnect_by_thread: " .($dbthread || '').")");if (!defined$dbpid or ($dbpid==$$ and $dbthread==$thread_generation)){$sftp->disconnect}else {$debug and $debug & 4 and _debug "skipping disconnection because pid and/or thread generation don't match"}}sub _init {my$sftp=shift;$sftp->_queue_msg(Net::SFTP::Foreign::Buffer->new(int8=>SSH2_FXP_INIT,int32=>SSH2_FILEXFER_VERSION));if (my$msg=$sftp->_get_msg){my$type=$msg->get_int8;if ($type==SSH2_FXP_VERSION){my$version=$msg->get_int32;$sftp->{server_version}=$version;$sftp->{server_extensions}={};while (length $$msg){my$key=$msg->get_str;my$value=$msg->get_str;$sftp->{server_extensions}{$key}=$value;if ($key eq 'vendor-id'){my$vid=Net::SFTP::Foreign::Buffer->make("$value");$sftp->{_ext__vendor_id}=[Encode::decode(utf8=>$vid->get_str),Encode::decode(utf8=>$vid->get_str),Encode::decode(utf8=>$vid->get_str),$vid->get_int64 ]}elsif ($key eq 'supported2'){my$s2=Net::SFTP::Foreign::Buffer->make("$value");$sftp->{_ext__supported2}=[$s2->get_int32,$s2->get_int32,$s2->get_int32,$s2->get_int32,$s2->get_int32,$s2->get_int16,$s2->get_int16,[map Encode::decode(utf8=>$_),$s2->get_str_list],[map Encode::decode(utf8=>$_),$s2->get_str_list]]}}return$version}$sftp->_conn_lost(SSH2_FX_BAD_MESSAGE,SFTP_ERR_REMOTE_BAD_MESSAGE,"bad packet type, expecting SSH2_FXP_VERSION, got $type")}elsif ($sftp->{_status}==SSH2_FX_CONNECTION_LOST and $sftp->{_password_authentication}and $sftp->{_password_sent}){$sftp->_set_error(SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED,"Password authentication failed or connection lost")}return undef}sub server_extensions {%{shift->{server_extensions}}}sub _check_extension {my ($sftp,$name,$version,$error,$errstr)=@_;my$ext=$sftp->{server_extensions}{$name};return 1 if (defined$ext and $ext==$version);$sftp->_set_status(SSH2_FX_OP_UNSUPPORTED);$sftp->_set_error($error,"$errstr: extended operation not supported by server");return undef}sub _get_msg_and_check {my ($sftp,$etype,$eid,$err,$errstr)=@_;my$msg=$sftp->_get_msg;if ($msg){my$type=$msg->get_int8;my$id=$msg->get_int32;$sftp->_clear_error_and_status;if ($id!=$eid){$sftp->_conn_lost(SSH2_FX_BAD_MESSAGE,SFTP_ERR_REMOTE_BAD_MESSAGE,$errstr,"bad packet sequence, expected $eid, got $id");return undef}if ($type!=$etype){if ($type==SSH2_FXP_STATUS){my$code=$msg->get_int32;my$str=Encode::decode(utf8=>$msg->get_str);my$status=$sftp->_set_status($code,(defined$str ? $str : ()));$sftp->_set_error($err,$errstr,$status)}else {$sftp->_conn_lost(SSH2_FX_BAD_MESSAGE,SFTP_ERR_REMOTE_BAD_MESSAGE,$errstr,"bad packet type, expected $etype packet, got $type")}return undef}}$msg}sub _get_handle {my ($sftp,$eid,$error,$errstr)=@_;if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_HANDLE,$eid,$error,$errstr)){return$msg->get_str}return undef}sub _rid {my ($sftp,$rfh)=@_;my$rid=$rfh->_rid;unless (defined$rid){$sftp->_set_error(SFTP_ERR_REMOTE_ACCESING_CLOSED_FILE,"Couldn't access a file that has been previosly closed")}$rid}sub _rfid {$_[1]->_check_is_file;&_rid}sub _rdid {$_[1]->_check_is_dir;&_rid}sub _queue_rid_request {my ($sftp,$code,$fh,$attrs)=@_;my$rid=$sftp->_rid($fh);return undef unless defined$rid;$sftp->_queue_new_msg($code,str=>$rid,(defined$attrs ? (attr=>$attrs): ()))}sub _queue_rfid_request {$_[2]->_check_is_file;&_queue_rid_request}sub _queue_rdid_request {$_[2]->_check_is_dir;&_queue_rid_request}sub _queue_str_request {my($sftp,$code,$str,$attrs)=@_;$sftp->_queue_new_msg($code,str=>$str,(defined$attrs ? (attr=>$attrs): ()))}sub _check_status_ok {my ($sftp,$eid,$error,$errstr)=@_;if (defined$eid){if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_STATUS,$eid,$error,$errstr)){my$status=$sftp->_set_status($msg->get_int32,$msg->get_str);return 1 if$status==SSH2_FX_OK;$sftp->_set_error($error,$errstr,$status)}}return undef}sub setcwd {${^TAINT} and &_catch_tainted_args;my ($sftp,$cwd,%opts)=@_;$sftp->_clear_error_and_status;my$check=delete$opts{check};$check=1 unless defined$check;%opts and _croak_bad_options(keys%opts);if (defined$cwd){if ($check){$cwd=$sftp->realpath($cwd);return undef unless defined$cwd;_untaint($cwd);my$a=$sftp->stat($cwd)or return undef;unless (_is_dir($a->perm)){$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,"Remote object '$cwd' is not a directory");return undef}}else {$cwd=$sftp->_rel2abs($cwd)}return$sftp->{cwd}=$cwd}else {delete$sftp->{cwd};return$sftp->cwd if defined wantarray}}sub cwd {@_==1 or croak 'Usage: $sftp->cwd()';my$sftp=shift;return defined$sftp->{cwd}? $sftp->{cwd}: $sftp->realpath('')}sub open {(@_ >= 2 and @_ <= 4)or croak 'Usage: $sftp->open($path [, $flags [, $attrs]])';${^TAINT} and &_catch_tainted_args;my ($sftp,$path,$flags,$a)=@_;$path=$sftp->_rel2abs($path);defined$flags or $flags=SSH2_FXF_READ;defined$a or $a=Net::SFTP::Foreign::Attributes->new;my$id=$sftp->_queue_new_msg(SSH2_FXP_OPEN,str=>$sftp->_fs_encode($path),int32=>$flags,attr=>$a);my$rid=$sftp->_get_handle($id,SFTP_ERR_REMOTE_OPEN_FAILED,"Couldn't open remote file '$path'");if ($debug and $debug & 2){if (defined$rid){_debug("new remote file '$path' open, rid:");_hexdump($rid)}else {_debug("open failed: $sftp->{_status}")}}defined$rid or return undef;my$fh=Net::SFTP::Foreign::FileHandle->_new_from_rid($sftp,$rid);$fh->_flag(append=>1)if ($flags & SSH2_FXF_APPEND);$fh}sub _open_mkpath {my ($sftp,$filename,$mkpath,$flags,$attrs)=@_;$flags=($flags || 0)| SSH2_FXF_WRITE|SSH2_FXF_CREAT;my$fh=do {local$sftp->{_autodie};$sftp->open($filename,$flags,$attrs)};unless ($fh){if ($mkpath and $sftp->status==SSH2_FX_NO_SUCH_FILE){my$da=$attrs->clone;$da->set_perm(($da->perm || 0)| 0700);$sftp->mkpath($filename,$da,1)or return;$fh=$sftp->open($filename,$flags,$attrs)}else {$sftp->_ok_or_autodie}}$fh}sub opendir {@_ <= 2 or croak 'Usage: $sftp->opendir($path)';${^TAINT} and &_catch_tainted_args;my$sftp=shift;my$path=shift;$path='.' unless defined$path;$path=$sftp->_rel2abs($path);my$id=$sftp->_queue_str_request(SSH2_FXP_OPENDIR,$sftp->_fs_encode($path),@_);my$rid=$sftp->_get_handle($id,SFTP_ERR_REMOTE_OPENDIR_FAILED,"Couldn't open remote dir '$path'");if ($debug and $debug & 2){_debug("new remote dir '$path' open, rid:");_hexdump($rid)}defined$rid or return undef;Net::SFTP::Foreign::DirHandle->_new_from_rid($sftp,$rid,0)}sub sftpread {(@_ >= 3 and @_ <= 4)or croak 'Usage: $sftp->sftpread($fh, $offset [, $size])';my ($sftp,$rfh,$offset,$size)=@_;unless ($size){return '' if defined$size;$size=$sftp->{_block_size}}my$rfid=$sftp->_rfid($rfh);defined$rfid or return undef;my$id=$sftp->_queue_new_msg(SSH2_FXP_READ,str=>$rfid,int64=>$offset,int32=>$size);if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_DATA,$id,SFTP_ERR_REMOTE_READ_FAILED,"Couldn't read from remote file")){return$msg->get_str}return undef}sub sftpwrite {@_==4 or croak 'Usage: $sftp->sftpwrite($fh, $offset, $data)';my ($sftp,$rfh,$offset)=@_;my$rfid=$sftp->_rfid($rfh);defined$rfid or return undef;utf8::downgrade($_[3],1)or croak "wide characters found in data";my$id=$sftp->_queue_new_msg(SSH2_FXP_WRITE,str=>$rfid,int64=>$offset,str=>$_[3]);if ($sftp->_check_status_ok($id,SFTP_ERR_REMOTE_WRITE_FAILED,"Couldn't write to remote file")){return 1}return undef}sub seek {(@_ >= 3 and @_ <= 4)or croak 'Usage: $sftp->seek($fh, $pos [, $whence])';my ($sftp,$rfh,$pos,$whence)=@_;$sftp->flush($rfh)or return undef;if (!$whence){$rfh->_pos($pos)}elsif ($whence==1){$rfh->_inc_pos($pos)}elsif ($whence==2){my$a=$sftp->stat($rfh)or return undef;$rfh->_pos($pos + $a->size)}else {croak "invalid value for whence argument ('$whence')"}1}sub tell {@_==2 or croak 'Usage: $sftp->tell($fh)';my ($sftp,$rfh)=@_;return$rfh->_pos + length ${$rfh->_bout}}sub eof {@_==2 or croak 'Usage: $sftp->eof($fh)';my ($sftp,$rfh)=@_;$sftp->_fill_read_cache($rfh,1);return length(${$rfh->_bin})==0}sub _write {my ($sftp,$rfh,$off,$cb)=@_;$sftp->_clear_error_and_status;my$rfid=$sftp->_rfid($rfh);defined$rfid or return undef;my$qsize=$sftp->{_queue_size};my@msgid;my@written;my$written=0;my$end;while (!$end or @msgid){while (!$end and @msgid < $qsize){my$data=$cb->();if (defined$data and length$data){my$id=$sftp->_queue_new_msg(SSH2_FXP_WRITE,str=>$rfid,int64=>$off + $written,str=>$data);push@written,$written;$written += length$data;push@msgid,$id}else {$end=1}}my$eid=shift@msgid;my$last=shift@written;unless ($sftp->_check_status_ok($eid,SFTP_ERR_REMOTE_WRITE_FAILED,"Couldn't write to remote file")){$sftp->_get_msg for@msgid;return$last}}return$written}sub write {@_==3 or croak 'Usage: $sftp->write($fh, $data)';my ($sftp,$rfh)=@_;$sftp->flush($rfh,'in')or return undef;utf8::downgrade($_[2],1)or croak "wide characters found in data";my$datalen=length $_[2];my$bout=$rfh->_bout;$$bout .= $_[2];my$len=length $$bout;$sftp->flush($rfh,'out')if ($len >= $sftp->{_write_delay}or ($len and $sftp->{_autoflush}));return$datalen}sub flush {(@_ >= 2 and @_ <= 3)or croak 'Usage: $sftp->flush($fh [, $direction])';my ($sftp,$rfh,$dir)=@_;$dir ||= '';defined$sftp->_rfid($rfh)or return;if ($dir ne 'out'){${$rfh->_bin}=''}if ($dir ne 'in'){my$bout=$rfh->_bout;my$len=length $$bout;if ($len){my$start;my$append=$rfh->_flag('append');if ($append){my$attr=$sftp->stat($rfh)or return undef;$start=$attr->size}else {$start=$rfh->_pos;${$rfh->_bin}=''}my$off=0;my$written=$sftp->_write($rfh,$start,sub {my$data=substr($$bout,$off,$sftp->{_block_size});$off += length$data;$data});$rfh->_inc_pos($written)unless$append;substr($$bout,0,$written,'');$written==$len or return undef}}1}sub _fill_read_cache {my ($sftp,$rfh,$len)=@_;$sftp->_clear_error_and_status;$sftp->flush($rfh,'out')or return undef;my$rfid=$sftp->_rfid($rfh);defined$rfid or return undef;my$bin=$rfh->_bin;if (defined$len){return 1 if ($len < length $$bin);my$read_ahead=$sftp->{_read_ahead};$len=length($$bin)+ $read_ahead if$len - length($$bin)< $read_ahead}my$pos=$rfh->_pos;my$qsize=$sftp->{_queue_size};my$bsize=$sftp->{_block_size};do {local$sftp->{_autodie};my@msgid;my$askoff=length $$bin;my$ensure_eof;while (!defined$len or length $$bin < $len){while ((!defined$len or $askoff < $len)and @msgid < $qsize){my$id=$sftp->_queue_new_msg(SSH2_FXP_READ,str=>$rfid,int64=>$pos + $askoff,int32=>$bsize);push@msgid,$id;$askoff += $bsize}my$eid=shift@msgid;my$msg=$sftp->_get_msg_and_check(SSH2_FXP_DATA,$eid,SFTP_ERR_REMOTE_READ_FAILED,"Couldn't read from remote file")or last;my$data=$msg->get_str;$$bin .= $data;if (length$data < $bsize){unless (defined$len){$ensure_eof=$sftp->_queue_new_msg(SSH2_FXP_READ,str=>$rfid,int64=>$pos + length $$bin,int32=>1)}last}}$sftp->_get_msg for@msgid;if ($ensure_eof and $sftp->_get_msg_and_check(SSH2_FXP_DATA,$ensure_eof,SFTP_ERR_REMOTE_READ_FAILED,"Couldn't read from remote file")){$sftp->_set_error(SFTP_ERR_REMOTE_BLOCK_TOO_SMALL,"Received block was too small")}if ($sftp->{_status}==SSH2_FX_EOF){$sftp->_set_error;$sftp->_set_status if length $$bin}};$sftp->_ok_or_autodie and length $$bin}sub read {@_==3 or croak 'Usage: $sftp->read($fh, $len)';my ($sftp,$rfh,$len)=@_;if ($sftp->_fill_read_cache($rfh,$len)){my$bin=$rfh->_bin;my$data=substr($$bin,0,$len,'');$rfh->_inc_pos(length$data);return$data}return undef}sub _readline {my ($sftp,$rfh,$sep)=@_;$sep="\n" if @_ < 3;my$sl=length$sep;my$bin=$rfh->_bin;my$last=0;while(1){my$ix=index $$bin,$sep,$last + 1 - $sl ;if ($ix >= 0){$ix += $sl;$rfh->_inc_pos($ix);return substr($$bin,0,$ix,'')}$last=length $$bin;$sftp->_fill_read_cache($rfh,length($$bin)+ 1);unless (length $$bin > $last){$sftp->{_error}and return undef;my$line=$$bin;$rfh->_inc_pos(length$line);$$bin='';return (length$line ? $line : undef)}}}sub readline {(@_ >= 2 and @_ <= 3)or croak 'Usage: $sftp->readline($fh [, $sep])';my ($sftp,$rfh,$sep)=@_;$sep="\n" if @_ < 3;if (!defined$sep or $sep eq ''){$sftp->_fill_read_cache($rfh);$sftp->{_error}and return undef;my$bin=$rfh->_bin;my$line=$$bin;$rfh->_inc_pos(length$line);$$bin='';return$line}if (wantarray){my@lines;while (defined (my$line=$sftp->_readline($rfh,$sep))){push@lines,$line}return@lines}return$sftp->_readline($rfh,$sep)}sub getc {@_==2 or croak 'Usage: $sftp->getc($fh)';my ($sftp,$rfh)=@_;$sftp->_fill_read_cache($rfh,1);my$bin=$rfh->_bin;if (length$bin){$rfh->_inc_pos(1);return substr $$bin,0,1,''}return undef}sub lstat {@_ <= 2 or croak 'Usage: $sftp->lstat($path)';${^TAINT} and &_catch_tainted_args;my ($sftp,$path)=@_;$path='.' unless defined$path;$path=$sftp->_rel2abs($path);my$id=$sftp->_queue_str_request(SSH2_FXP_LSTAT,$sftp->_fs_encode($path));if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_ATTRS,$id,SFTP_ERR_REMOTE_LSTAT_FAILED,"Couldn't stat remote link")){return$msg->get_attributes}return undef}sub stat {@_ <= 2 or croak 'Usage: $sftp->stat($path_or_fh)';${^TAINT} and &_catch_tainted_args;my ($sftp,$pofh)=@_;$pofh='.' unless defined$pofh;my$id=$sftp->_queue_new_msg((ref$pofh and UNIVERSAL::isa($pofh,'Net::SFTP::Foreign::FileHandle'))? (SSH2_FXP_FSTAT,str=>$sftp->_rid($pofh)): (SSH2_FXP_STAT,str=>$sftp->_fs_encode($sftp->_rel2abs($pofh))));if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_ATTRS,$id,SFTP_ERR_REMOTE_STAT_FAILED,"Couldn't stat remote file")){return$msg->get_attributes}return undef}sub fstat {_deprecated "fstat is deprecated and will be removed on the upcoming 2.xx series, " ."stat method accepts now both file handlers and paths";goto&stat}sub _gen_remove_method {my($name,$code,$error,$errstr)=@_;my$sub=sub {@_==2 or croak "Usage: \$sftp->$name(\$path)";${^TAINT} and &_catch_tainted_args;my ($sftp,$path)=@_;$path=$sftp->_rel2abs($path);my$id=$sftp->_queue_str_request($code,$sftp->_fs_encode($path));$sftp->_check_status_ok($id,$error,$errstr)};no strict 'refs';*$name=$sub}_gen_remove_method(remove=>SSH2_FXP_REMOVE,SFTP_ERR_REMOTE_REMOVE_FAILED,"Couldn't delete remote file");_gen_remove_method(rmdir=>SSH2_FXP_RMDIR,SFTP_ERR_REMOTE_RMDIR_FAILED,"Couldn't remove remote directory");sub mkdir {(@_ >= 2 and @_ <= 3)or croak 'Usage: $sftp->mkdir($path [, $attrs])';${^TAINT} and &_catch_tainted_args;my ($sftp,$path,$attrs)=@_;$attrs=_empty_attributes unless defined$attrs;$path=$sftp->_rel2abs($path);my$id=$sftp->_queue_str_request(SSH2_FXP_MKDIR,$sftp->_fs_encode($path),$attrs);$sftp->_check_status_ok($id,SFTP_ERR_REMOTE_MKDIR_FAILED,"Couldn't create remote directory")}sub join {my$sftp=shift;my$vol='';my$a='.';while (@_){my$b=shift;if (defined$b){if (ref$sftp and $sftp->{_remote_has_volumes}and $b =~ /^([a-z]\:)(.*)/i){$vol=$1;$a='.';$b=$2}$b =~ s|^(?:\./+)+||;if (length$b and $b ne '.'){if ($b !~ m|^/| and $a ne '.'){$a=($a =~ m|/$| ? "$a$b" : "$a/$b")}else {$a=$b}$a =~ s|(?:/+\.)+/?$|/|;$a =~ s|(?<=[^/])/+$||;$a='.' unless length$a}}}"$vol$a"}sub _rel2abs {my ($sftp,$path)=@_;my$old=$path;my$cwd=$sftp->{cwd};$path=$sftp->join($sftp->{cwd},$path);$debug and $debug & 4096 and _debug("'$old' --> '$path'");return$path}sub mkpath {(@_ >= 2 and @_ <= 4)or croak 'Usage: $sftp->mkpath($path [, $attrs [, $parent]])';${^TAINT} and &_catch_tainted_args;my ($sftp,$path,$attrs,$parent)=@_;$sftp->_clear_error_and_status;my$first=!$parent;$path =~ s{^(/*)}{};my$start=$1;$path =~ s{/+$}{};my@path;while (1){if ($first){$first=0}else {$path =~ s{/*[^/]*$}{}}my$p="$start$path";$debug and $debug & 8192 and _debug "checking $p";if ($sftp->test_d($p)){$debug and $debug & 8192 and _debug "$p is a dir";last}unless (length$path){$sftp->_set_error(SFTP_ERR_REMOTE_MKDIR_FAILED,"Unable to make path, bad root");return undef}unshift@path,$p}for my$p (@path){$debug and $debug & 8192 and _debug "mkdir $p";if ($p =~ m{^(?:.*/)?\.{1,2}$} or $p =~ m{/$}){$debug and $debug & 8192 and _debug "$p is a symbolic dir, skipping";unless ($sftp->test_d($p)){$debug and $debug & 8192 and _debug "symbolic dir $p can not be checked";$sftp->{_error}or $sftp->_set_error(SFTP_ERR_REMOTE_MKDIR_FAILED,"Unable to make path, bad name");return undef}}else {$sftp->mkdir($p,$attrs)or return undef}}1}sub _mkpath_local {my ($sftp,$path,$perm,$parent)=@_;my@parts=File::Spec->splitdir($path);$debug and $debug & 32768 and _debug "_mkpath_local($path, $perm, ".($parent||0).")";if ($parent){pop@parts while@parts and not length$parts[-1];unless (@parts){$sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,"mkpath failed, top dir reached");return}pop@parts}my@tail;while (@parts){my$target=File::Spec->catdir(@parts);if (-e $target){unless (-d $target){$sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,"Local file '$target' is not a directory");return}last}unshift@tail,pop@parts}while (@tail){push@parts,shift@tail;my$target=File::Spec->catdir(@parts);$debug and $debug and 32768 and _debug "creating local directory '$target'";unless (CORE::mkdir$target,$perm){unless (do {local $!;-d $target}){$sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,"mkdir '$target' failed",$!);return}}}$debug and $debug & 32768 and _debug "_mkpath_local succeeded";return 1}sub setstat {@_==3 or croak 'Usage: $sftp->setstat($path_or_fh, $attrs)';${^TAINT} and &_catch_tainted_args;my ($sftp,$pofh,$attrs)=@_;my$id=$sftp->_queue_new_msg(((ref$pofh and UNIVERSAL::isa($pofh,'Net::SFTP::Foreign::FileHandle'))? (SSH2_FXP_FSETSTAT,str=>$sftp->_rid($pofh)): (SSH2_FXP_SETSTAT,str=>$sftp->_fs_encode($sftp->_rel2abs($pofh)))),attr=>$attrs);return$sftp->_check_status_ok($id,SFTP_ERR_REMOTE_SETSTAT_FAILED,"Couldn't setstat remote file")}sub fsetstat {_deprecated "fsetstat is deprecated and will be removed on the upcoming 2.xx series, " ."setstat method accepts now both file handlers and paths";goto&setstat}sub _gen_setstat_shortcut {my ($name,$rid_type,$attrs_flag,@arg_types)=@_;my$nargs=2 + @arg_types;my$usage=("\$sftp->$name(" .CORE::join(', ','$path_or_fh',map "arg$_",1..@arg_types).')');my$rid_method=($rid_type eq 'file' ? '_rfid' : $rid_type eq 'dir' ? '_rdid' : $rid_type eq 'any' ? '_rid' : croak "bad rid type $rid_type");my$sub=sub {@_==$nargs or croak$usage;my$sftp=shift;my$pofh=shift;my$id=$sftp->_queue_new_msg(((ref$pofh and UNIVERSAL::isa($pofh,'Net::SFTP::Foreign::FileHandle'))? (SSH2_FXP_FSETSTAT,str=>$sftp->$rid_method($pofh)): (SSH2_FXP_SETSTAT,str=>$sftp->_fs_encode($sftp->_rel2abs($pofh)))),int32=>$attrs_flag,map {$arg_types[$_]=>$_[$_]}0..$#arg_types);$sftp->_check_status_ok($id,SFTP_ERR_REMOTE_SETSTAT_FAILED,"Couldn't setstat remote file ($name)")};no strict 'refs';*$name=$sub}_gen_setstat_shortcut(truncate=>'file',SSH2_FILEXFER_ATTR_SIZE,'int64');_gen_setstat_shortcut(chown=>'any',SSH2_FILEXFER_ATTR_UIDGID,'int32','int32');_gen_setstat_shortcut(chmod=>'any',SSH2_FILEXFER_ATTR_PERMISSIONS,'int32');_gen_setstat_shortcut(utime=>'any',SSH2_FILEXFER_ATTR_ACMODTIME,'int32','int32');sub _close {@_==2 or croak 'Usage: $sftp->close($fh, $attrs)';my$sftp=shift;my$id=$sftp->_queue_rid_request(SSH2_FXP_CLOSE,@_);defined$id or return undef;my$ok=$sftp->_check_status_ok($id,SFTP_ERR_REMOTE_CLOSE_FAILED,"Couldn't close remote file");if ($debug and $debug & 2){_debug sprintf("closing file handle, return: %s, rid:",(defined$ok ? $ok : '-'));_hexdump($sftp->_rid($_[0]))}return$ok}sub close {@_==2 or croak 'Usage: $sftp->close($fh)';${^TAINT} and &_catch_tainted_args;my ($sftp,$rfh)=@_;$sftp->flush($rfh)or return undef;if ($sftp->_close($rfh)){$rfh->_close;return 1}undef}sub closedir {@_==2 or croak 'Usage: $sftp->closedir($dh)';${^TAINT} and &_catch_tainted_args;my ($sftp,$rdh)=@_;$rdh->_check_is_dir;if ($sftp->_close($rdh)){$rdh->_close;return 1}undef}sub readdir {@_==2 or croak 'Usage: $sftp->readdir($dh)';${^TAINT} and &_catch_tainted_args;my ($sftp,$rdh)=@_;my$rdid=$sftp->_rdid($rdh);defined$rdid or return undef;my$cache=$rdh->_cache;while (!@$cache or wantarray){my$id=$sftp->_queue_str_request(SSH2_FXP_READDIR,$rdid);if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_NAME,$id,SFTP_ERR_REMOTE_READDIR_FAILED,"Couldn't read remote directory")){my$count=$msg->get_int32 or last;for (1..$count){push @$cache,{filename=>$sftp->_fs_decode($msg->get_str),longname=>$sftp->_fs_decode($msg->get_str),a=>$msg->get_attributes }}}else {$sftp->_set_error if$sftp->{_status}==SSH2_FX_EOF;last}}if (wantarray){my$old=$cache;$cache=[];return @$old}shift @$cache}sub _readdir {my ($sftp,$rdh);if (wantarray){my$line=$sftp->readdir($rdh);if (defined$line){return$line->{filename}}}else {return map {$_->{filename}}$sftp->readdir($rdh)}}sub _gen_getpath_method {my ($code,$error,$name)=@_;return sub {@_==2 or croak 'Usage: $sftp->some_method($path)';${^TAINT} and &_catch_tainted_args;my ($sftp,$path)=@_;$path=$sftp->_rel2abs($path);my$id=$sftp->_queue_str_request($code,$sftp->_fs_encode($path));if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_NAME,$id,$error,"Couldn't get $name for remote '$path'")){$msg->get_int32 > 0 and return$sftp->_fs_decode($msg->get_str);$sftp->_set_error($error,"Couldn't get $name for remote '$path', no names on reply")}return undef}}*realpath=_gen_getpath_method(SSH2_FXP_REALPATH,SFTP_ERR_REMOTE_REALPATH_FAILED,"realpath");*readlink=_gen_getpath_method(SSH2_FXP_READLINK,SFTP_ERR_REMOTE_READLINK_FAILED,"link target");sub _rename {my ($sftp,$old,$new)=@_;$old=$sftp->_rel2abs($old);$new=$sftp->_rel2abs($new);my$id=$sftp->_queue_new_msg(SSH2_FXP_RENAME,str=>$sftp->_fs_encode($old),str=>$sftp->_fs_encode($new));$sftp->_check_status_ok($id,SFTP_ERR_REMOTE_RENAME_FAILED,"Couldn't rename remote file '$old' to '$new'")}sub rename {(@_ & 1)or croak 'Usage: $sftp->rename($old, $new, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,$old,$new,%opts)=@_;my$overwrite=delete$opts{overwrite};my$numbered=delete$opts{numbered};croak "'overwrite' and 'numbered' options can not be used together" if ($overwrite and $numbered);%opts and _croak_bad_options(keys%opts);if ($overwrite){$sftp->atomic_rename($old,$new)and return 1;$sftp->{_status}!=SSH2_FX_OP_UNSUPPORTED and return undef}for (1){local$sftp->{_autodie};if (!$sftp->_rename($old,$new)and $sftp->{_status}==SSH2_FX_FAILURE){if ($numbered and $sftp->test_e($new)){_inc_numbered($new);redo}elsif ($overwrite){my$rp_old=$sftp->realpath($old);my$rp_new=$sftp->realpath($new);if (defined$rp_old and defined$rp_new and $rp_old eq $rp_new){$sftp->_clear_error_and_status}elsif ($sftp->remove($new)){$overwrite=0;redo}}}}$sftp->_ok_or_autodie}sub atomic_rename {@_==3 or croak 'Usage: $sftp->atomic_rename($old, $new)';${^TAINT} and &_catch_tainted_args;my ($sftp,$old,$new)=@_;$sftp->_check_extension('posix-rename@openssh.com'=>1,SFTP_ERR_REMOTE_RENAME_FAILED,"atomic rename failed")or return undef;$old=$sftp->_rel2abs($old);$new=$sftp->_rel2abs($new);my$id=$sftp->_queue_new_msg(SSH2_FXP_EXTENDED,str=>'posix-rename@openssh.com',str=>$sftp->_fs_encode($old),str=>$sftp->_fs_encode($new));$sftp->_check_status_ok($id,SFTP_ERR_REMOTE_RENAME_FAILED,"Couldn't rename remote file '$old' to '$new'")}sub symlink {@_==3 or croak 'Usage: $sftp->symlink($sl, $target)';${^TAINT} and &_catch_tainted_args;my ($sftp,$sl,$target)=@_;$sl=$sftp->_rel2abs($sl);my$id=$sftp->_queue_new_msg(SSH2_FXP_SYMLINK,str=>$sftp->_fs_encode($target),str=>$sftp->_fs_encode($sl));$sftp->_check_status_ok($id,SFTP_ERR_REMOTE_SYMLINK_FAILED,"Couldn't create symlink '$sl' pointing to '$target'")}sub hardlink {@_==3 or croak 'Usage: $sftp->hardlink($hl, $target)';${^TAINT} and &_catch_tainted_args;my ($sftp,$hl,$target)=@_;$sftp->_check_extension('hardlink@openssh.com'=>1,SFTP_ERR_REMOTE_HARDLINK_FAILED,"hardlink failed")or return undef;$hl=$sftp->_rel2abs($hl);$target=$sftp->_rel2abs($target);my$id=$sftp->_queue_new_msg(SSH2_FXP_EXTENDED,str=>'hardlink@openssh.com',str=>$sftp->_fs_encode($target),str=>$sftp->_fs_encode($hl));$sftp->_check_status_ok($id,SFTP_ERR_REMOTE_HARDLINK_FAILED,"Couldn't create hardlink '$hl' pointing to '$target'")}sub _gen_save_status_method {my$method=shift;sub {my$sftp=shift;local ($sftp->{_error},$sftp->{_status})if$sftp->{_error};$sftp->$method(@_)}}*_close_save_status=_gen_save_status_method('close');*_closedir_save_status=_gen_save_status_method('closedir');*_remove_save_status=_gen_save_status_method('remove');sub _inc_numbered {$_[0]=~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e or $_[0]=~ s{((?:\.[^\.]*)?)$}{(1)$1};$debug and $debug & 128 and _debug("numbering to: $_[0]")}sub abort {my$sftp=shift;$sftp->_set_error(SFTP_ERR_ABORTED,($@ ? $_[0]: "Aborted"))}sub get {@_ >= 2 or croak 'Usage: $sftp->get($remote, $local, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,$remote,$local,%opts)=@_;defined$remote or croak "remote file path is undefined";$sftp->_clear_error_and_status;$remote=$sftp->_rel2abs($remote);$local=_file_part($remote)unless defined$local;my$local_is_fh=(ref$local and $local->isa('GLOB'));my$cb=delete$opts{callback};my$umask=delete$opts{umask};my$perm=delete$opts{perm};my$copy_perm=delete$opts{exists$opts{copy_perm}? 'copy_perm' : 'copy_perms'};my$copy_time=delete$opts{copy_time};my$overwrite=delete$opts{overwrite};my$resume=delete$opts{resume};my$append=delete$opts{append};my$block_size=delete$opts{block_size}|| $sftp->{_block_size};my$queue_size=delete$opts{queue_size}|| $sftp->{_queue_size};my$dont_save=delete$opts{dont_save};my$conversion=delete$opts{conversion};my$numbered=delete$opts{numbered};my$cleanup=delete$opts{cleanup};my$atomic=delete$opts{atomic};my$best_effort=delete$opts{best_effort};my$mkpath=delete$opts{mkpath};croak "'perm' and 'copy_perm' options can not be used simultaneously" if (defined$perm and defined$copy_perm);croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'" if ($numbered and ($overwrite or $resume or $append));if ($resume or $append){$resume and $append and croak "'resume' and 'append' options can not be used simultaneously";$atomic and croak "'atomic' can not be used with 'resume' or 'append'";$overwrite and croak "'overwrite' can not be used with 'resume' or 'append'"}if ($local_is_fh){my$tail='option can not be used when target is a file handle';$resume and croak "'resume' $tail";$overwrite and croak "'overwrite' $tail";$numbered and croak "'numbered' $tail";$dont_save and croak "'dont_save' $tail";$atomic and croak "'croak' $tail"}%opts and _croak_bad_options(keys%opts);if ($resume and $conversion){carp "resume option is useless when data conversion has also been requested";undef$resume}$overwrite=1 unless (defined$overwrite or $local_is_fh or $numbered or $append);$copy_perm=1 unless (defined$perm or defined$copy_perm or $local_is_fh);$copy_time=1 unless (defined$copy_time or $local_is_fh);$mkpath=1 unless defined$mkpath;$cleanup=($atomic || $numbered)unless defined$cleanup;my$a=do {local$sftp->{_autodie};$sftp->stat($remote)};my ($rperm,$size,$atime,$mtime)=($a ? ($a->perm,$a->size,$a->atime,$a->mtime): ());$size=-1 unless defined$size;if ($copy_time and not defined$atime){if ($best_effort){undef$copy_time}else {$sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,"Not enough information on stat, amtime not included");return undef}}$umask=(defined$perm ? 0 : umask)unless defined$umask;if ($copy_perm){if (defined$rperm){$perm=$rperm}elsif ($best_effort){undef$copy_perm}else {$sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,"Not enough information on stat, mode not included");return undef}}$perm &= ~$umask if defined$perm;$sftp->_clear_error_and_status;if ($resume and $resume eq 'auto'){undef$resume;if (defined$mtime){if (my@lstat=CORE::stat$local){$resume=($mtime <= $lstat[9])}}}my ($atomic_numbered,$atomic_local,$atomic_cleanup);my ($rfh,$fh);my$askoff=0;my$lstart=0;if ($dont_save){$rfh=$sftp->open($remote,SSH2_FXF_READ);defined$rfh or return undef}else {unless ($local_is_fh or $overwrite or $append or $resume or $numbered){if (-e $local){$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,"local file $local already exists");return undef}}if ($atomic){$atomic_local=$local;$local .= sprintf("(%d).tmp",rand(10000));$atomic_numbered=$numbered;$numbered=1;$debug and $debug & 128 and _debug("temporal local file name: $local")}if ($resume){if (CORE::open$fh,'+<',$local){binmode$fh;CORE::seek($fh,0,2);$askoff=CORE::tell$fh;if ($askoff < 0){$askoff=0;undef$fh}else {if ($size >=0 and $askoff > $size){$sftp->_set_error(SFTP_ERR_LOCAL_BIGGER_THAN_REMOTE,"Couldn't resume transfer, local file is bigger than remote");return undef}$size==$askoff and return 1}}}$rfh=$sftp->open($remote,SSH2_FXF_READ);defined$rfh or return undef;unless (defined$fh){if ($local_is_fh){$fh=$local;local ($@,$SIG{__DIE__},$SIG{__WARN__});eval {$lstart=CORE::tell($fh)};$lstart=0 unless ($lstart and $lstart > 0)}else {my$flags=Fcntl::O_CREAT|Fcntl::O_WRONLY;$flags |= Fcntl::O_APPEND if$append;$flags |= Fcntl::O_EXCL if ($numbered or (!$overwrite and!$append));unlink$local if$overwrite;my$open_perm=(defined$perm ? $perm : 0666);my$save=_umask_save_and_set($umask);$sftp->_mkpath_local($local,$open_perm|0700,1)if$mkpath;while (1){sysopen ($fh,$local,$flags,$open_perm)and last;unless ($numbered and -e $local){$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,"Can't open $local",$!);return undef}_inc_numbered($local)}$$numbered=$local if ref$numbered;binmode$fh;$lstart=sysseek($fh,0,2)if$append}}if (defined$perm){my$error;do {local ($@,$SIG{__DIE__},$SIG{__WARN__});unless (eval {CORE::chmod($perm,$local)> 0}){$error=($@ ? $@ : $!)}};if ($error and!$best_effort){unlink$local unless$resume or $append;$sftp->_set_error(SFTP_ERR_LOCAL_CHMOD_FAILED,"Can't chmod $local",$error);return undef}}}my$converter=_gen_converter$conversion;my$rfid=$sftp->_rfid($rfh);defined$rfid or die "internal error: rfid not defined";my@msgid;my@askoff;my$loff=$askoff;my$adjustment=0;local $\;my$slow_start=($size==-1 ? $queue_size - 1 : 0);my$safe_block_size=$sftp->{_min_block_size}>= $block_size;do {local$sftp->{_autodie};while (1){while (!@msgid or (($size==-1 or $size + $block_size > $askoff)and @msgid < $queue_size - $slow_start and $safe_block_size)){my$id=$sftp->_queue_new_msg(SSH2_FXP_READ,str=>$rfid,int64=>$askoff,int32=>$block_size);push@msgid,$id;push@askoff,$askoff;$askoff += $block_size}$slow_start-- if$slow_start;my$eid=shift@msgid;my$roff=shift@askoff;my$msg=$sftp->_get_msg_and_check(SSH2_FXP_DATA,$eid,SFTP_ERR_REMOTE_READ_FAILED,"Couldn't read from remote file");unless ($msg){$sftp->_set_error if$sftp->{_status}==SSH2_FX_EOF;last}my$data=$msg->get_str;my$len=length$data;if ($roff!=$loff or!$len){$sftp->_set_error(SFTP_ERR_REMOTE_BLOCK_TOO_SMALL,"remote packet received is too small");last}$loff += $len;unless ($safe_block_size){if ($len > $sftp->{_min_block_size}){$sftp->{min_block_size}=$len;if ($len < $block_size){$block_size=$len;$askoff=$loff}}$safe_block_size=1}my$adjustment_before=$adjustment;$adjustment += $converter->($data)if$converter;if (length($data)and defined$cb){local $\;$cb->($sftp,$data,$lstart + $roff + $adjustment_before,$lstart + $size + $adjustment);last if$sftp->{_error}}if (length($data)and!$dont_save){unless (print$fh $data){$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,"unable to write data to local file $local",$!);last}}}$sftp->_get_msg for (@msgid);goto CLEANUP if$sftp->{_error};if ($converter){my$data='';my$adjustment_before=$adjustment;$adjustment += $converter->($data);if (length($data)and defined$cb){local $\;$cb->($sftp,$data,$askoff + $adjustment_before,$size + $adjustment);goto CLEANUP if$sftp->{_error}}if (length($data)and!$dont_save){unless (print$fh $data){$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,"unable to write data to local file $local",$!);goto CLEANUP}}}if (defined$cb){my$data='';do {local $\;$cb->($sftp,$data,$askoff + $adjustment,$size + $adjustment)};return undef if$sftp->{_error};if (length($data)and!$dont_save){unless (print$fh $data){$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,"unable to write data to local file $local",$!);goto CLEANUP}}}unless ($dont_save){unless ($local_is_fh or CORE::close$fh){$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,"unable to write data to local file $local",$!);goto CLEANUP}if ($copy_time){unless (utime($atime,$mtime,$local)or $best_effort){$sftp->_set_error(SFTP_ERR_LOCAL_UTIME_FAILED,"Can't utime $local",$!);goto CLEANUP}}if ($atomic){if (!$overwrite){while (1){if (link$local,$atomic_local){unlink$local;last}my$err=$!;unless (-e $atomic_local){if (sysopen my$lock,$atomic_local,Fcntl::O_CREAT|Fcntl::O_EXCL|Fcntl::O_WRONLY,0600){$atomic_cleanup=1;goto OVERWRITE}$err=$!;unless (-e $atomic_local){$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,"Can't open $local",$err);goto CLEANUP}}unless ($numbered){$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,"local file $atomic_local already exists");goto CLEANUP}_inc_numbered($atomic_local)}}else {OVERWRITE: unless (CORE::rename$local,$atomic_local){$sftp->_set_error(SFTP_ERR_LOCAL_RENAME_FAILED,"Unable to rename temporal file to its final position '$atomic_local'",$!);goto CLEANUP}}$$atomic_numbered=$local if ref$atomic_numbered}}CLEANUP: if ($cleanup and $sftp->{_error}){unlink$local;unlink$atomic_local if$atomic_cleanup}};$sftp->_ok_or_autodie}sub get_content {@_==2 or croak 'Usage: $sftp->get_content($remote)';${^TAINT} and &_catch_tainted_args;my ($sftp,$name)=@_;my@data;my$rfh=$sftp->open($name)or return undef;scalar$sftp->readline($rfh,undef)}sub put {@_ >= 2 or croak 'Usage: $sftp->put($local, $remote, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,$local,$remote,%opts)=@_;defined$local or croak "local file path is undefined";$sftp->_clear_error_and_status;my$local_is_fh=(ref$local and $local->isa('GLOB'));unless (defined$remote){$local_is_fh and croak "unable to infer remote file name when a file handler is passed as local";$remote=(File::Spec->splitpath($local))[2]}my$cb=delete$opts{callback};my$umask=delete$opts{umask};my$perm=delete$opts{perm};my$copy_perm=delete$opts{copy_perm};$copy_perm=delete$opts{copy_perms}unless defined$copy_perm;my$copy_time=delete$opts{copy_time};my$overwrite=delete$opts{overwrite};my$resume=delete$opts{resume};my$append=delete$opts{append};my$block_size=delete$opts{block_size}|| $sftp->{_block_size};my$queue_size=delete$opts{queue_size}|| $sftp->{_queue_size};my$conversion=delete$opts{conversion};my$late_set_perm=delete$opts{late_set_perm};my$numbered=delete$opts{numbered};my$atomic=delete$opts{atomic};my$cleanup=delete$opts{cleanup};my$best_effort=delete$opts{best_effort};my$sparse=delete$opts{sparse};my$mkpath=delete$opts{mkpath};croak "'perm' and 'umask' options can not be used simultaneously" if (defined$perm and defined$umask);croak "'perm' and 'copy_perm' options can not be used simultaneously" if (defined$perm and $copy_perm);croak "'resume' and 'append' options can not be used simultaneously" if ($resume and $append);croak "'resume' and 'overwrite' options can not be used simultaneously" if ($resume and $overwrite);croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'" if ($numbered and ($overwrite or $resume or $append));croak "'atomic' can not be used with 'resume' or 'append'" if ($atomic and ($resume or $append));%opts and _croak_bad_options(keys%opts);$overwrite=1 unless (defined$overwrite or $numbered);$copy_perm=1 unless (defined$perm or defined$copy_perm or $local_is_fh);$copy_time=1 unless (defined$copy_time or $local_is_fh);$late_set_perm=$sftp->{_late_set_perm}unless defined$late_set_perm;$cleanup=($atomic || $numbered)unless defined$cleanup;$mkpath=1 unless defined$mkpath;my$neg_umask;if (defined$perm){$neg_umask=$perm}else {$umask=umask unless defined$umask;$neg_umask=0777 & ~$umask}my ($fh,$lmode,$lsize,$latime,$lmtime);if ($local_is_fh){$fh=$local}else {unless (CORE::open$fh,'<',$local){$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,"Unable to open local file '$local'",$!);return undef}binmode$fh}{local ($@,$SIG{__DIE__},$SIG{__WARN__});if ((undef,undef,$lmode,undef,undef,undef,undef,$lsize,$latime,$lmtime)=eval {no warnings;CORE::stat$fh}){$debug and $debug & 16384 and _debug "local file size is " .(defined$lsize ? $lsize : '<undef>');if ($local_is_fh and defined$lsize){my$tell=eval {CORE::tell$fh};$lsize -= $tell if$tell and $tell > 0}}elsif ($copy_perm or $copy_time){$sftp->_set_error(SFTP_ERR_LOCAL_STAT_FAILED,"Couldn't stat local file '$local'",$!);return undef}elsif ($resume and $resume eq 'auto'){$debug and $debug & 16384 and _debug "not resuming because stat'ing the local file failed";undef$resume}}$perm=$lmode & $neg_umask if$copy_perm;my$attrs=Net::SFTP::Foreign::Attributes->new;$attrs->set_perm($perm)if defined$perm;my$rfh;my$writeoff=0;my$converter=_gen_converter$conversion;my$converted_input='';my$rattrs;if ($resume or $append){$rattrs=do {local$sftp->{_autodie};$sftp->stat($remote)};if ($rattrs){if ($resume and $resume eq 'auto' and $rattrs->mtime <= $lmtime){$debug and $debug & 16384 and _debug "not resuming because local file is newer, r: ".$rattrs->mtime." l: $lmtime";undef$resume}else {$writeoff=$rattrs->size;$debug and $debug & 16384 and _debug "resuming from $writeoff"}}else {if ($append){$sftp->{_status}==SSH2_FX_NO_SUCH_FILE or $sftp->_ok_or_autodie or return undef;undef$append}$sftp->_clear_error_and_status}}my ($atomic_numbered,$atomic_remote);if ($writeoff){if ($resume){$debug and $debug & 16384 and _debug "resuming file transfer from $writeoff";if ($converter){my$off=0;my$eof_t;while (1){my$len=length$converted_input;my$delta=$writeoff - $off;if ($delta <= $len){$debug and $debug & 16384 and _debug "discarding $delta converted bytes";substr$converted_input,0,$delta,'';last}else {$off += $len;if ($eof_t){$sftp->_set_error(SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL,"Couldn't resume transfer, remote file is bigger than local");return undef}my$read=CORE::read($fh,$converted_input,$block_size * 4);unless (defined$read){$sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,"Couldn't read from local file '$local' to the resume point $writeoff",$!);return undef}$lsize += $converter->($converted_input)if defined$lsize;utf8::downgrade($converted_input,1)or croak "converter introduced wide characters in data";$read or $eof_t=1}}}elsif ($local_is_fh){my$off=$writeoff;while ($off){my$read=CORE::read($fh,my($buf),($off < 16384 ? $off : 16384));if ($read){$debug and $debug & 16384 and _debug "discarding $read bytes";$off -= $read}else {$sftp->_set_error(defined$read ? (SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL,"Couldn't resume transfer, remote file is bigger than local"): (SFTP_ERR_LOCAL_READ_ERROR,"Couldn't read from local file handler '$local' to the resume point $writeoff",$!))}}}else {if (defined$lsize and $writeoff > $lsize){$sftp->_set_error(SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL,"Couldn't resume transfer, remote file is bigger than local");return undef}unless (CORE::seek($fh,$writeoff,0)){$sftp->_set_error(SFTP_ERR_LOCAL_SEEK_FAILED,"seek operation on local file failed: $!");return undef}}if (defined$lsize and $writeoff==$lsize){if (defined$perm and $rattrs->perm!=$perm){return$sftp->_best_effort($best_effort,setstat=>$remote,$attrs)}return 1}}$rfh=$sftp->open($remote,SSH2_FXF_WRITE)or return undef}else {if ($atomic){if (!($numbered or $overwrite)and $sftp->test_e($remote)){$sftp->_set_status(SSH2_FX_FAILURE);$sftp->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,"Remote file '$remote' already exists");return undef}$atomic_remote=$remote;$remote .= sprintf("(%d).tmp",rand(10000));$atomic_numbered=$numbered;$numbered=1;$debug and $debug & 128 and _debug("temporal remote file name: $remote")}local$sftp->{_autodie};if ($numbered){while (1){$rfh=$sftp->_open_mkpath($remote,$mkpath,SSH2_FXF_WRITE | SSH2_FXF_CREAT | SSH2_FXF_EXCL,$attrs);last if ($rfh or $sftp->{_status}!=SSH2_FX_FAILURE or !$sftp->test_e($remote));_inc_numbered($remote)}$$numbered=$remote if$rfh and ref$numbered}else {for my$rep (0,1){$rfh=$sftp->_open_mkpath($remote,$mkpath,SSH2_FXF_WRITE | SSH2_FXF_CREAT | ($overwrite ? SSH2_FXF_TRUNC : SSH2_FXF_EXCL),$attrs);last if$rfh or $rep or!$overwrite or $sftp->{_status}!=SSH2_FX_PERMISSION_DENIED;$debug and $debug & 2 and _debug("retrying open after removing remote file");local ($sftp->{_status},$sftp->{_error});$sftp->remove($remote)}}}$sftp->_ok_or_autodie or return undef;my$last_block_was_zeros;do {local$sftp->{autodie};if (defined$perm and!$late_set_perm){$sftp->_best_effort($best_effort,setstat=>$rfh,$attrs)or goto CLEANUP}my$rfid=$sftp->_rfid($rfh);defined$rfid or die "internal error: rfid is undef";$lsize += $writeoff if ($append or not defined$lsize);my ($eof,$eof_t);my@msgid;OK: while (1){if (!$eof and @msgid < $queue_size){my ($data,$len);if ($converter){while (!$eof_t and length$converted_input < $block_size){my$read=CORE::read($fh,my$input,$block_size * 4);unless ($read){unless (defined$read){$sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,"Couldn't read from local file '$local'",$!);last OK}$eof_t=1}$lsize += $converter->($input);utf8::downgrade($input,1)or croak "converter introduced wide characters in data";$converted_input .= $input}$data=substr($converted_input,0,$block_size,'');$len=length$data;$eof=1 if ($eof_t and!$len)}else {$debug and $debug & 16384 and _debug "reading block at offset ".CORE::tell($fh)." block_size: $block_size";$len=CORE::read($fh,$data,$block_size);if ($len){$debug and $debug & 16384 and _debug "block read, size: $len";utf8::downgrade($data,1)or croak "wide characters unexpectedly read from file";$debug and $debug & 16384 and length$data!=$len and _debug "read data changed size on downgrade to " .length($data)}else {unless (defined$len){$sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,"Couldn't read from local file '$local'",$!);last OK}$eof=1}}my$nextoff=$writeoff + $len;if (defined$cb){$lsize=$nextoff if$nextoff > $lsize;$cb->($sftp,$data,$writeoff,$lsize);last OK if$sftp->{_error};utf8::downgrade($data,1)or croak "callback introduced wide characters in data";$len=length$data;$nextoff=$writeoff + $len}if ($len){if ($sparse and $data =~ /^\x{00}*$/s){$last_block_was_zeros=1;$debug and $debug & 16384 and _debug "skipping zeros block at offset $writeoff, length $len"}else {$debug and $debug & 16384 and _debug "writing block at offset $writeoff, length $len";my$id=$sftp->_queue_new_msg(SSH2_FXP_WRITE,str=>$rfid,int64=>$writeoff,str=>$data);push@msgid,$id;$last_block_was_zeros=0}$writeoff=$nextoff}}last if ($eof and!@msgid);next unless ($eof or @msgid >= $queue_size or $sftp->_do_io(0));my$id=shift@msgid;unless ($sftp->_check_status_ok($id,SFTP_ERR_REMOTE_WRITE_FAILED,"Couldn't write to remote file")){last OK}}CORE::close$fh unless$local_is_fh;$sftp->_get_msg for (@msgid);$sftp->truncate($rfh,$writeoff)if$last_block_was_zeros and not $sftp->{_error};$sftp->_close_save_status($rfh);goto CLEANUP if$sftp->{_error};if ($copy_time or ($late_set_perm and defined$perm)){$attrs->set_perm unless$late_set_perm and defined$perm;$attrs->set_amtime($latime,$lmtime)if$copy_time;$sftp->_best_effort($best_effort,setstat=>$remote,$attrs)or goto CLEANUP}if ($atomic){$sftp->rename($remote,$atomic_remote,overwrite=>$overwrite,numbered=>$atomic_numbered)or goto CLEANUP}CLEANUP: if ($cleanup and $sftp->{_error}){warn "cleanup $remote";$sftp->_remove_save_status($remote)}};$sftp->_ok_or_autodie}sub put_content {@_ >= 3 or croak 'Usage: $sftp->put_content($content, $remote, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,undef,$remote,%opts)=@_;my%put_opts=(map {$_=>delete$opts{$_}}qw(perm umask block_size queue_size overwrite conversion resume numbered late_set_perm atomic best_effort mkpath));%opts and _croak_bad_options(keys%opts);my$fh;unless (CORE::open$fh,'<',\$_[1]){$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,"Can't open scalar as file handle",$!);return undef}$sftp->put($fh,$remote,%opts)}sub ls {@_ >= 1 or croak 'Usage: $sftp->ls($remote_dir, %opts)';${^TAINT} and &_catch_tainted_args;my$sftp=shift;my%opts=@_ & 1 ? (dir=>@_): @_;my$dir=delete$opts{dir};my$ordered=delete$opts{ordered};my$follow_links=delete$opts{follow_links};my$atomic_readdir=delete$opts{atomic_readdir};my$names_only=delete$opts{names_only};my$realpath=delete$opts{realpath};my$queue_size=delete$opts{queue_size};my$cheap=($names_only and!$realpath);my ($cheap_wanted,$wanted);if ($cheap and ref$opts{wanted}eq 'Regexp' and not defined$opts{no_wanted}){$cheap_wanted=delete$opts{wanted}}else {$wanted=(delete$opts{_wanted}|| _gen_wanted(delete$opts{wanted},delete$opts{no_wanted}));undef$cheap if defined$wanted}%opts and _croak_bad_options(keys%opts);my$delayed_wanted=($atomic_readdir and $wanted);$queue_size=1 if ($follow_links or $realpath or ($wanted and not $delayed_wanted));my$max_queue_size=$queue_size || $sftp->{_queue_size};$queue_size ||= 2;$dir='.' unless defined$dir;$dir=$sftp->_rel2abs($dir);my$rdh=$sftp->opendir($dir);return unless defined$rdh;my$rdid=$sftp->_rdid($rdh);defined$rdid or return undef;my@dir;my@msgid;do {local$sftp->{_autodie};OK: while (1){push@msgid,$sftp->_queue_str_request(SSH2_FXP_READDIR,$rdid)while (@msgid < $queue_size);my$id=shift@msgid;if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_NAME,$id,SFTP_ERR_REMOTE_READDIR_FAILED,"Couldn't read directory '$dir'")){my$count=$msg->get_int32 or last;if ($cheap){for (1..$count){my$fn=$sftp->_fs_decode($msg->get_str);push@dir,$fn if (!defined$cheap_wanted or $fn =~ $cheap_wanted);$msg->skip_str;Net::SFTP::Foreign::Attributes->skip_from_buffer($msg)}}else {for (1..$count){my$fn=$sftp->_fs_decode($msg->get_str);my$ln=$sftp->_fs_decode($msg->get_str);my$a=Net::SFTP::Foreign::Attributes->new_from_buffer($msg);my$entry={filename=>$fn,longname=>$ln,a=>$a };if ($follow_links and _is_lnk($a->perm)){if ($a=$sftp->stat($sftp->join($dir,$fn))){$entry->{a}=$a}else {$sftp->_clear_error_and_status}}if ($realpath){my$rp=$sftp->realpath($sftp->join($dir,$fn));if (defined$rp){$fn=$entry->{realpath}=$rp}else {$sftp->_clear_error_and_status}}if (!$wanted or $delayed_wanted or $wanted->($sftp,$entry)){push@dir,(($names_only and!$delayed_wanted)? $fn : $entry)}}}$queue_size ++ if$queue_size < $max_queue_size}else {$sftp->_set_error if$sftp->{_status}==SSH2_FX_EOF;$sftp->_get_msg for@msgid;last}}$sftp->_closedir_save_status($rdh)if$rdh};unless ($sftp->{_error}){if ($delayed_wanted){@dir=grep {$wanted->($sftp,$_)}@dir;@dir=map {defined $_->{realpath}? $_->{realpath}: $_->{filename}}@dir if$names_only}if ($ordered){if ($names_only){@dir=sort@dir}else {_sort_entries \@dir}}return \@dir}croak$sftp->{_error}if$sftp->{_autodie};return undef}sub rremove {@_ >= 2 or croak 'Usage: $sftp->rremove($dirs, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,$dirs,%opts)=@_;my$on_error=delete$opts{on_error};local$sftp->{_autodie}if$on_error;my$wanted=_gen_wanted(delete$opts{wanted},delete$opts{no_wanted});%opts and _croak_bad_options(keys%opts);my$count=0;my@dirs;$sftp->find($dirs,on_error=>$on_error,atomic_readdir=>1,wanted=>sub {my$e=$_[1];my$fn=$e->{filename};if (_is_dir($e->{a}->perm)){push@dirs,$e}else {if (!$wanted or $wanted->($sftp,$e)){if ($sftp->remove($fn)){$count++}else {$sftp->_call_on_error($on_error,$e)}}}});_sort_entries(\@dirs);while (@dirs){my$e=pop@dirs;if (!$wanted or $wanted->($sftp,$e)){if ($sftp->rmdir($e->{filename})){$count++}else {$sftp->_call_on_error($on_error,$e)}}}return$count}sub get_symlink {@_ >= 3 or croak 'Usage: $sftp->get_symlink($remote, $local, %opts)';my ($sftp,$remote,$local,%opts)=@_;my$overwrite=delete$opts{overwrite};my$numbered=delete$opts{numbered};croak "'overwrite' and 'numbered' can not be used together" if ($overwrite and $numbered);%opts and _croak_bad_options(keys%opts);$overwrite=1 unless (defined$overwrite or $numbered);my$a=$sftp->lstat($remote)or return undef;unless (_is_lnk($a->perm)){$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,"Remote object '$remote' is not a symlink");return undef}my$link=$sftp->readlink($remote)or return undef;if ($numbered){_inc_numbered($local)while -e $local}elsif (-e $local){if ($overwrite){unlink$local}else {$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,"local file $local already exists");return undef}}unless (eval {CORE::symlink$link,$local}){$sftp->_set_error(SFTP_ERR_LOCAL_SYMLINK_FAILED,"creation of symlink '$local' failed",$!);return undef}$$numbered=$local if ref$numbered;1}sub put_symlink {@_ >= 3 or croak 'Usage: $sftp->put_symlink($local, $remote, %opts)';my ($sftp,$local,$remote,%opts)=@_;my$overwrite=delete$opts{overwrite};my$numbered=delete$opts{numbered};croak "'overwrite' and 'numbered' can not be used together" if ($overwrite and $numbered);%opts and _croak_bad_options(keys%opts);$overwrite=1 unless (defined$overwrite or $numbered);my$perm=(CORE::lstat$local)[2];unless (defined$perm){$sftp->_set_error(SFTP_ERR_LOCAL_STAT_FAILED,"Couldn't stat local file '$local'",$!);return undef}unless (_is_lnk($perm)){$sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,"Local file $local is not a symlink");return undef}my$target=readlink$local;unless (defined$target){$sftp->_set_error(SFTP_ERR_LOCAL_READLINK_FAILED,"Couldn't read link '$local'",$!);return undef}while (1){local$sftp->{_autodie};$sftp->symlink($remote,$target);if ($sftp->{_error}and $sftp->{_status}==SSH2_FX_FAILURE){if ($numbered and $sftp->test_e($remote)){_inc_numbered($remote);redo}elsif ($overwrite and $sftp->_remove_save_status($remote)){$overwrite=0;redo}}last}$$numbered=$remote if ref$numbered;$sftp->_ok_or_autodie}sub rget {@_ >= 2 or croak 'Usage: $sftp->rget($remote, $local, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,$remote,$local,%opts)=@_;defined$remote or croak "remote file path is undefined";$local=File::Spec->curdir unless defined$local;my$umask=delete$opts{umask};my$copy_perm=delete$opts{exists$opts{copy_perm}? 'copy_perm' : 'copy_perms'};my$copy_time=delete$opts{copy_time};my$newer_only=delete$opts{newer_only};my$on_error=delete$opts{on_error};local$sftp->{_autodie}if$on_error;my$ignore_links=delete$opts{ignore_links};my$mkpath=delete$opts{mkpath};my$wanted=_gen_wanted(delete$opts{wanted},delete$opts{no_wanted});my%get_opts=(map {$_=>delete$opts{$_}}qw(block_size queue_size overwrite conversion resume numbered atomic best_effort));if ($get_opts{resume}and $get_opts{conversion}){carp "resume option is useless when data conversion has also been requested";delete$get_opts{resume}}my%get_symlink_opts=(map {$_=>$get_opts{$_}}qw(overwrite numbered));%opts and _croak_bad_options(keys%opts);$remote=$sftp->join($remote,'./');my$qremote=quotemeta$remote;my$reremote=qr/^$qremote(.*)$/i;my$save=_umask_save_and_set$umask;$copy_perm=1 unless defined$copy_perm;$copy_time=1 unless defined$copy_time;$mkpath=1 unless defined$mkpath;my$count=0;$sftp->find([$remote],descend=>sub {my$e=$_[1];if (!$wanted or $wanted->($sftp,$e)){my$fn=$e->{filename};if ($fn =~ $reremote){my$lpath=File::Spec->catdir($local,$1);($lpath)=$lpath =~ /(.*)/ if ${^TAINT};if (-d $lpath){$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,"directory '$lpath' already exists");$sftp->_call_on_error($on_error,$e);return 1}else {my$perm=($copy_perm ? $e->{a}->perm & 0777 : 0777);if (CORE::mkdir($lpath,$perm)or ($mkpath and $sftp->_mkpath_local($lpath,$perm))){$count++;return 1}$sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,"mkdir '$lpath' failed",$!)}}else {$sftp->_set_error(SFTP_ERR_REMOTE_BAD_PATH,"bad remote path '$fn'")}$sftp->_call_on_error($on_error,$e)}return undef},wanted=>sub {my$e=$_[1];unless (_is_dir($e->{a}->perm)){if (!$wanted or $wanted->($sftp,$e)){my$fn=$e->{filename};if ($fn =~ $reremote){my$lpath=((length $1)? File::Spec->catfile($local,$1): $local);($lpath)=$lpath =~ /(.*)/ if ${^TAINT};if (_is_lnk($e->{a}->perm)and!$ignore_links){if ($sftp->get_symlink($fn,$lpath,%get_symlink_opts)){$count++;return undef}}elsif (_is_reg($e->{a}->perm)){if ($newer_only and -e $lpath and (CORE::stat _)[9]>= $e->{a}->mtime){$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,"newer local file '$lpath' already exists")}else {if ($sftp->get($fn,$lpath,copy_perm=>$copy_perm,copy_time=>$copy_time,%get_opts)){$count++;return undef}}}else {$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,($ignore_links ? "remote file '$fn' is not regular file or directory" : "remote file '$fn' is not regular file, directory or link"))}}else {$sftp->_set_error(SFTP_ERR_REMOTE_BAD_PATH,"bad remote path '$fn'")}$sftp->_call_on_error($on_error,$e)}}return undef});return$count}sub rput {@_ >= 2 or croak 'Usage: $sftp->rput($local, $remote, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,$local,$remote,%opts)=@_;defined$local or croak "local path is undefined";$remote='.' unless defined$remote;my$umask=delete$opts{umask};my$perm=delete$opts{perm};my$copy_perm=delete$opts{exists$opts{copy_perm}? 'copy_perm' : 'copy_perms'};my$copy_time=delete$opts{copy_time};my$newer_only=delete$opts{newer_only};my$on_error=delete$opts{on_error};local$sftp->{_autodie}if$on_error;my$ignore_links=delete$opts{ignore_links};my$mkpath=delete$opts{mkpath};my$wanted=_gen_wanted(delete$opts{wanted},delete$opts{no_wanted});my%put_opts=(map {$_=>delete$opts{$_}}qw(block_size queue_size overwrite conversion resume numbered late_set_perm atomic best_effort sparse));my%put_symlink_opts=(map {$_=>$put_opts{$_}}qw(overwrite numbered));croak "'perm' and 'umask' options can not be used simultaneously" if (defined$perm and defined$umask);croak "'perm' and 'copy_perm' options can not be used simultaneously" if (defined$perm and $copy_perm);%opts and _croak_bad_options(keys%opts);require Net::SFTP::Foreign::Local;my$lfs=Net::SFTP::Foreign::Local->new;$local=$lfs->join($local,'./');my$relocal;if ($local =~ m|^\./?$|){$relocal=qr/^(.*)$/}else {my$qlocal=quotemeta$local;$relocal=qr/^$qlocal(.*)$/i}$copy_perm=1 unless defined$copy_perm;$copy_time=1 unless defined$copy_time;$mkpath=1 unless defined$mkpath;my$mask;if (defined$perm){$mask=$perm & 0777}else {$umask=umask unless defined$umask;$mask=0777 & ~$umask}if ($on_error){my$on_error1=$on_error;$on_error=sub {my$lfs=shift;$sftp->_copy_error($lfs);$sftp->_call_on_error($on_error1,@_)}}my$count=0;$lfs->find([$local],descend=>sub {my$e=$_[1];if (!$wanted or $wanted->($lfs,$e)){my$fn=$e->{filename};$debug and $debug & 32768 and _debug "rput handling $fn";if ($fn =~ $relocal){my$rpath=$sftp->join($remote,File::Spec->splitdir($1));$debug and $debug & 32768 and _debug "rpath: $rpath";my$a=Net::SFTP::Foreign::Attributes->new;if (defined$perm){$a->set_perm($mask | 0300)}elsif ($copy_perm){$a->set_perm($e->{a}->perm & $mask)}if ($sftp->mkdir($rpath,$a)){$count++;return 1}if ($mkpath and $sftp->status==SSH2_FX_NO_SUCH_FILE){$sftp->_clear_error_and_status;if ($sftp->mkpath($rpath,$a)){$count++;return 1}}$lfs->_copy_error($sftp);if ($sftp->test_d($rpath)){$lfs->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,"Remote directory '$rpath' already exists");$lfs->_call_on_error($on_error,$e);return 1}}else {$lfs->_set_error(SFTP_ERR_LOCAL_BAD_PATH,"Bad local path '$fn'")}$lfs->_call_on_error($on_error,$e)}return undef},wanted=>sub {my$e=$_[1];unless (_is_dir($e->{a}->perm)){if (!$wanted or $wanted->($lfs,$e)){my$fn=$e->{filename};$debug and $debug & 32768 and _debug "rput handling $fn";if ($fn =~ $relocal){my (undef,$d,$f)=File::Spec->splitpath($1);my$rpath=$sftp->join($remote,File::Spec->splitdir($d),$f);if (_is_lnk($e->{a}->perm)and!$ignore_links){if ($sftp->put_symlink($fn,$rpath,%put_symlink_opts)){$count++;return undef}$lfs->_copy_error($sftp)}elsif (_is_reg($e->{a}->perm)){my$ra;if ($newer_only and $ra=$sftp->stat($rpath)and $ra->mtime >= $e->{a}->mtime){$lfs->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,"Newer remote file '$rpath' already exists")}else {if ($sftp->put($fn,$rpath,(defined($perm)? (perm=>$perm): $copy_perm ? (perm=>$e->{a}->perm & $mask): (copy_perm=>0,umask=>$umask)),copy_time=>$copy_time,%put_opts)){$count++;return undef}$lfs->_copy_error($sftp)}}else {$lfs->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,($ignore_links ? "Local file '$fn' is not regular file or directory" : "Local file '$fn' is not regular file, directory or link"))}}else {$lfs->_set_error(SFTP_ERR_LOCAL_BAD_PATH,"Bad local path '$fn'")}$lfs->_call_on_error($on_error,$e)}}return undef});return$count}sub mget {@_ >= 2 or croak 'Usage: $sftp->mget($remote, $localdir, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,$remote,$localdir,%opts)=@_;defined$remote or croak "remote pattern is undefined";my$on_error=$opts{on_error};local$sftp->{_autodie}if$on_error;my$ignore_links=delete$opts{ignore_links};my%glob_opts=(map {$_=>delete$opts{$_}}qw(on_error follow_links ignore_case wanted no_wanted strict_leading_dot));my%get_symlink_opts=(map {$_=>$opts{$_}}qw(overwrite numbered));my%get_opts=(map {$_=>delete$opts{$_}}qw(umask perm copy_perm copy_time block_size queue_size overwrite conversion resume numbered atomic best_effort mkpath));%opts and _croak_bad_options(keys%opts);my@remote=map$sftp->glob($_,%glob_opts),_ensure_list$remote;my$count=0;require File::Spec;for my$e (@remote){my$perm=$e->{a}->perm;if (_is_dir($perm)){$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,"Remote object '$e->{filename}' is a directory")}else {my$fn=$e->{filename};my ($local)=$fn =~ m{([^\\/]*)$};$local=File::Spec->catfile($localdir,$local)if defined$localdir;if (_is_lnk($perm)){next if$ignore_links;$sftp->get_symlink($fn,$local,%get_symlink_opts)}else {$sftp->get($fn,$local,%get_opts)}}$count++ unless$sftp->{_error};$sftp->_call_on_error($on_error,$e)}$count}sub mput {@_ >= 2 or croak 'Usage: $sftp->mput($local, $remotedir, %opts)';my ($sftp,$local,$remotedir,%opts)=@_;defined$local or die "local pattern is undefined";my$on_error=$opts{on_error};local$sftp->{_autodie}if$on_error;my$ignore_links=delete$opts{ignore_links};my%glob_opts=(map {$_=>delete$opts{$_}}qw(on_error follow_links ignore_case wanted no_wanted strict_leading_dot));my%put_symlink_opts=(map {$_=>$opts{$_}}qw(overwrite numbered));my%put_opts=(map {$_=>delete$opts{$_}}qw(umask perm copy_perm copy_time block_size queue_size overwrite conversion resume numbered late_set_perm atomic best_effort sparse mkpath));%opts and _croak_bad_options(keys%opts);require Net::SFTP::Foreign::Local;my$lfs=Net::SFTP::Foreign::Local->new;my@local=map$lfs->glob($_,%glob_opts),_ensure_list$local;my$count=0;require File::Spec;for my$e (@local){my$perm=$e->{a}->perm;if (_is_dir($perm)){$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,"Remote object '$e->{filename}' is a directory")}else {my$fn=$e->{filename};my$remote=(File::Spec->splitpath($fn))[2];$remote=$sftp->join($remotedir,$remote)if defined$remotedir;if (_is_lnk($perm)){next if$ignore_links;$sftp->put_symlink($fn,$remote,%put_symlink_opts)}else {$sftp->put($fn,$remote,%put_opts)}}$count++ unless$sftp->{_error};$sftp->_call_on_error($on_error,$e)}$count}sub fsync {@_==2 or croak 'Usage: $sftp->fsync($fh)';${^TAINT} and &_catch_tainted_args;my ($sftp,$fh)=@_;$sftp->flush($fh,"out");$sftp->_check_extension('fsync@openssh.com'=>1,SFTP_ERR_REMOTE_FSYNC_FAILED,"fsync failed, not implemented")or return undef;my$id=$sftp->_queue_new_msg(SSH2_FXP_EXTENDED,str=>'fsync@openssh.com',str=>$sftp->_rid($fh));if ($sftp->_check_status_ok($id,SFTP_ERR_REMOTE_FSYNC_FAILED,"Couldn't fsync remote file")){return 1}return undef}sub statvfs {@_==2 or croak 'Usage: $sftp->statvfs($path_or_fh)';${^TAINT} and &_catch_tainted_args;my ($sftp,$pofh)=@_;my ($extension,$arg)=((ref$pofh and UNIVERSAL::isa($pofh,'Net::SFTP::Foreign::FileHandle'))? ('fstatvfs@openssh.com',$sftp->_rid($pofh)): ('statvfs@openssh.com',$sftp->_fs_encode($sftp->_rel2abs($pofh))));$sftp->_check_extension($extension=>2,SFTP_ERR_REMOTE_STATVFS_FAILED,"statvfs failed, not implemented")or return undef;my$id=$sftp->_queue_new_msg(SSH2_FXP_EXTENDED,str=>$extension,str=>$arg);if (my$msg=$sftp->_get_msg_and_check(SSH2_FXP_EXTENDED_REPLY,$id,SFTP_ERR_REMOTE_STATVFS_FAILED,"Couldn't stat remote file system")){my%statvfs=map {$_=>$msg->get_int64}qw(bsize frsize blocks bfree bavail files ffree favail fsid flag namemax);return \%statvfs}return undef}sub fstatvfs {_deprecated "fstatvfs is deprecated and will be removed on the upcoming 2.xx series, " ."statvfs method accepts now both file handlers and paths";goto&statvfs}package Net::SFTP::Foreign::Handle;use Tie::Handle;our@ISA=qw(Tie::Handle);our@CARP_NOT=qw(Net::SFTP::Foreign Tie::Handle);my$gen_accessor=sub {my$ix=shift;sub {my$st=*{shift()}{ARRAY};if (@_){$st->[$ix]=shift}else {$st->[$ix]}}};my$gen_proxy_method=sub {my$method=shift;sub {my$self=$_[0];$self->_check or return undef;my$sftp=$self->_sftp;if (wantarray){my@ret=$sftp->$method(@_);$sftp->_set_errno unless@ret;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 _new_from_rid {my$class=shift;my$sftp=shift;my$rid=shift;my$flags=shift || 0;my$self=Symbol::gensym;bless$self,$class;*$self=[$sftp,$rid,0,$flags,@_];tie *$self,$self;$self}sub _close {my$self=shift;@{*{$self}{ARRAY}}=()}sub _check {return 1 if defined(*{shift()}{ARRAY}[0]);$!=Errno::EBADF();undef}sub FILENO {my$self=shift;$self->_check or return undef;my$hrid=unpack 'H*'=>$self->_rid;"-1:sftp(0x$hrid)"}sub _sftp {*{shift()}{ARRAY}[0]}sub _rid {*{shift()}{ARRAY}[1]}* _pos=$gen_accessor->(2);sub _inc_pos {my ($self,$inc)=@_;*{shift()}{ARRAY}[2]+= $inc}my%flag_bit=(append=>0x1);sub _flag {my$st=*{shift()}{ARRAY};my$fn=shift;my$flag=$flag_bit{$fn};Carp::croak("unknown flag $fn")unless defined$flag;if (@_){if (shift){$st->[3]|= $flag}else {$st->[3]&= ~$flag}}$st->[3]& $flag ? 1 : 0}sub _check_is_file {Carp::croak("expecting remote file handler, got directory handler")}sub _check_is_dir {Carp::croak("expecting remote directory handler, got file handler")}my$autoloaded;sub AUTOLOAD {my$self=shift;our$AUTOLOAD;if ($autoloaded){my$class=ref$self || $self;Carp::croak qq|Can't locate object method "$AUTOLOAD" via package "$class|}else {$autoloaded=1;require IO::File;require IO::Dir;my ($method)=$AUTOLOAD =~ /^.*::(.*)$/;$self->$method(@_)}}package Net::SFTP::Foreign::FileHandle;our@ISA=qw(Net::SFTP::Foreign::Handle IO::File);sub _new_from_rid {my$class=shift;my$sftp=shift;my$rid=shift;my$flags=shift;my$self=$class->SUPER::_new_from_rid($sftp,$rid,$flags,'','')}sub _check_is_file {}sub _bin {\(*{shift()}{ARRAY}[4])}sub _bout {\(*{shift()}{ARRAY}[5])}sub WRITE {my ($self,undef,$length,$offset)=@_;$self->_check or return undef;$offset=0 unless defined$offset;$offset=length $_[1]+ $offset if$offset < 0;$length=length $_[1]unless defined$length;my$sftp=$self->_sftp;my$ret=$sftp->write($self,substr($_[1],$offset,$length));$sftp->_set_errno unless defined$ret;$ret}sub READ {my ($self,undef,$len,$offset)=@_;$self->_check or return undef;$_[1]='' unless defined $_[1];$offset ||= 0;if ($offset > length $_[1]){$_[1].= "\0" x ($offset - length $_[1])}if ($len==0){substr($_[1],$offset)='';return 0}my$sftp=$self->_sftp;$sftp->_fill_read_cache($self,$len);my$bin=$self->_bin;if (length $$bin){my$data=substr($$bin,0,$len,'');$self->_inc_pos($len);substr($_[1],$offset)=$data;return length$data}return 0 if$sftp->{_status}==$sftp->SSH2_FX_EOF;$sftp->_set_errno;undef}sub EOF {my$self=$_[0];$self->_check or return undef;my$sftp=$self->_sftp;my$ret=$sftp->eof($self);$sftp->_set_errno unless defined$ret;$ret}*GETC=$gen_proxy_method->('getc');*TELL=$gen_proxy_method->('tell');*SEEK=$gen_proxy_method->('seek');*CLOSE=$gen_proxy_method->('close');my$readline=$gen_proxy_method->('readline');sub READLINE {$readline->($_[0],$/)}sub OPEN {shift->CLOSE;undef}sub DESTROY {local ($@,$!,$?);my$self=shift;my$sftp=$self->_sftp;$debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'<undef>').")");if ($self->_check and $sftp){local$sftp->{_autodie};$sftp->_close_save_status($self)}}package Net::SFTP::Foreign::DirHandle;our@ISA=qw(Net::SFTP::Foreign::Handle IO::Dir);sub _new_from_rid {my$class=shift;my$sftp=shift;my$rid=shift;my$flags=shift;my$self=$class->SUPER::_new_from_rid($sftp,$rid,$flags,[])}sub _check_is_dir {}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};$sftp->_closedir_save_status($self)}}1;
|
|
NET_SFTP_FOREIGN
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Attributes.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_ATTRIBUTES';
|
|
package Net::SFTP::Foreign::Attributes;our$VERSION='1.68_05';use strict;use warnings;use Carp;use Net::SFTP::Foreign::Constants qw(:att);use Net::SFTP::Foreign::Buffer;sub new {my$class=shift;return bless {flags=>0},$class}sub new_from_stat {if (@_ > 1){my ($class,undef,undef,$mode,undef,$uid,$gid,undef,$size,$atime,$mtime)=@_;my$self=$class->new;$self->set_perm($mode);$self->set_ugid($uid,$gid);$self->set_size($size);$self->set_amtime($atime,$mtime);return$self}return undef}sub new_from_buffer {my ($class,$buf)=@_;my$self=$class->new;my$flags=$self->{flags}=$buf->get_int32_untaint;if ($flags & SSH2_FILEXFER_ATTR_SIZE){$self->{size}=$buf->get_int64_untaint}if ($flags & SSH2_FILEXFER_ATTR_UIDGID){$self->{uid}=$buf->get_int32_untaint;$self->{gid}=$buf->get_int32_untaint}if ($flags & SSH2_FILEXFER_ATTR_PERMISSIONS){$self->{perm}=$buf->get_int32_untaint}if ($flags & SSH2_FILEXFER_ATTR_ACMODTIME){$self->{atime}=$buf->get_int32_untaint;$self->{mtime}=$buf->get_int32_untaint}if ($flags & SSH2_FILEXFER_ATTR_EXTENDED){my$n=$buf->get_int32;$n >= 0 and $n <= 10000 or return undef;my@pairs=map$buf->get_str,1..2*$n;$self->{extended}=\@pairs}$self}sub skip_from_buffer {my ($class,$buf)=@_;my$flags=$buf->get_int32;if ($flags==(SSH2_FILEXFER_ATTR_SIZE | SSH2_FILEXFER_ATTR_UIDGID | SSH2_FILEXFER_ATTR_PERMISSIONS | SSH2_FILEXFER_ATTR_ACMODTIME)){$buf->skip_bytes(28)}else {my$len=0;$len += 8 if$flags & SSH2_FILEXFER_ATTR_SIZE;$len += 8 if$flags & SSH2_FILEXFER_ATTR_UIDGID;$len += 4 if$flags & SSH2_FILEXFER_ATTR_PERMISSIONS;$len += 8 if$flags & SSH2_FILEXFER_ATTR_ACMODTIME;$buf->skip_bytes($len);if ($flags & SSH2_FILEXFER_ATTR_EXTENDED){my$n=$buf->get_int32;$buf->skip_str,$buf->skip_str for (1..$n)}}}sub as_buffer {my$a=shift;my$buf=Net::SFTP::Foreign::Buffer->new(int32=>$a->{flags});if ($a->{flags}& SSH2_FILEXFER_ATTR_SIZE){$buf->put_int64(int$a->{size})}if ($a->{flags}& SSH2_FILEXFER_ATTR_UIDGID){$buf->put(int32=>$a->{uid},int32=>$a->{gid})}if ($a->{flags}& SSH2_FILEXFER_ATTR_PERMISSIONS){$buf->put_int32($a->{perm})}if ($a->{flags}& SSH2_FILEXFER_ATTR_ACMODTIME){$buf->put(int32=>$a->{atime},int32=>$a->{mtime})}if ($a->{flags}& SSH2_FILEXFER_ATTR_EXTENDED){my$pairs=$a->{extended};$buf->put_int32(int(@$pairs / 2));$buf->put_str($_)for @$pairs}$buf}sub flags {shift->{flags}}sub size {shift->{size}}sub set_size {my ($self,$size)=@_;if (defined$size){$self->{flags}|= SSH2_FILEXFER_ATTR_SIZE;$self->{size}=$size}else {$self->{flags}&= ~SSH2_FILEXFER_ATTR_SIZE;delete$self->{size}}}sub uid {shift->{uid}}sub gid {shift->{gid}}sub set_ugid {my ($self,$uid,$gid)=@_;if (defined$uid and defined$gid){$self->{flags}|= SSH2_FILEXFER_ATTR_UIDGID;$self->{uid}=$uid;$self->{gid}=$gid}elsif (!defined$uid and!defined$gid){$self->{flags}&= ~SSH2_FILEXFER_ATTR_UIDGID;delete$self->{uid};delete$self->{gid}}else {croak "wrong arguments for set_ugid"}}sub perm {shift->{perm}}sub set_perm {my ($self,$perm)=@_;if (defined$perm){$self->{flags}|= SSH2_FILEXFER_ATTR_PERMISSIONS;$self->{perm}=$perm}else {$self->{flags}&= ~SSH2_FILEXFER_ATTR_PERMISSIONS;delete$self->{perm}}}sub atime {shift->{atime}}sub mtime {shift->{mtime}}sub set_amtime {my ($self,$atime,$mtime)=@_;if (defined$atime and defined$mtime){$self->{flags}|= SSH2_FILEXFER_ATTR_ACMODTIME;$self->{atime}=$atime;$self->{mtime}=$mtime}elsif (!defined$atime and!defined$mtime){$self->{flags}&= ~SSH2_FILEXFER_ATTR_ACMODTIME;delete$self->{atime};delete$self->{mtime}}else {croak "wrong arguments for set_amtime"}}sub extended {@{shift->{extended}|| []}}sub set_extended {my$self=shift;@_ & 1 and croak "odd number of arguments passed to set_extended";if (@_){$self->{flags}|= SSH2_FILEXFER_ATTR_EXTENDED;$self->{extended}=[@_]}else {$self->{flags}&= ~SSH2_FILEXFER_ATTR_EXTENDED;delete$self->{extended}}}sub append_extended {my$self=shift;@_ & 1 and croak "odd number of arguments passed to append_extended";my$pairs=$self->{extended};if (@$pairs){push @$pairs,@_}else {$self->set_extended(@_)}}sub clone {my$self=shift;my$clone={%$self };bless$clone,ref$self;$clone}1;
|
|
NET_SFTP_FOREIGN_ATTRIBUTES
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Attributes/Compat.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_ATTRIBUTES_COMPAT';
|
|
package Net::SFTP::Foreign::Attributes::Compat;our$VERSION='0.01';use strict;use warnings;use Net::SFTP::Foreign::Attributes;our@ISA=qw(Net::SFTP::Foreign::Attributes);my@fields=qw(flags size uid gid perm atime mtime);for my$f (@fields){no strict 'refs';*$f=sub {@_ > 1 ? $_[0]->{$f}=$_[1]: $_[0]->{$f}|| 0}}sub new {my ($class,%param)=@_;my$a=$class->SUPER::new();if (my$stat=$param{Stat}){$a->set_size($stat->[7]);$a->set_ugid($stat->[4],$stat->[5]);$a->set_perm($stat->[2]);$a->set_amtime($stat->[8],$stat->[9])}$a}1;
|
|
NET_SFTP_FOREIGN_ATTRIBUTES_COMPAT
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Backend/Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_BACKEND_UNIX';
|
|
package Net::SFTP::Foreign::Backend::Unix;our$VERSION='1.88_02';use strict;use warnings;use Carp;our@CARP_NOT=qw(Net::SFTP::Foreign);use Fcntl qw(O_NONBLOCK F_SETFL F_GETFL);use POSIX ();use Net::SFTP::Foreign::Helpers qw(_tcroak _ensure_list _debug _hexdump $debug);use Net::SFTP::Foreign::Constants qw(SSH2_FX_BAD_MESSAGE SFTP_ERR_REMOTE_BAD_MESSAGE);sub _new {shift}sub _defaults {(queue_size=>32)}sub _init_transport_streams {my (undef,$sftp)=@_;for my$dir (qw(ssh_in ssh_out)){binmode$sftp->{$dir};my$flags=fcntl($sftp->{$dir},F_GETFL,0);fcntl($sftp->{$dir},F_SETFL,$flags | O_NONBLOCK)}}sub _open_dev_null {my$sftp=shift;my$dev_null;unless (open$dev_null,'>',"/dev/null"){$sftp->_conn_failed("Unable to redirect stderr to /dev/null");return}$dev_null}sub _fileno_dup_over {my ($good_fn,$fh)=@_;if (defined$fh){my@keep_open;my$fn=fileno$fh;for (1..5){$fn >= $good_fn and return$fn;$fn=POSIX::dup($fn);push@keep_open,$fn}POSIX::_exit(255)}undef}sub _open4 {my$backend=shift;my$sftp=shift;my ($dad_in,$dad_out,$child_in,$child_out);unless (pipe ($dad_in,$child_out)and pipe ($child_in,$dad_out)){$sftp->_conn_failed("Unable to created pipes: $!");return}my$pid=fork;unless ($pid){unless (defined$pid){$sftp->_conn_failed("Unable to fork new process: $!");return}close ($dad_in);close ($dad_out);shift;shift;my$child_err=shift;my$pty=shift;$pty->make_slave_controlling_terminal if defined$pty;my$child_err_fno=eval {no warnings;fileno($child_err ? $child_err : *STDERR)};my$child_err_safe;if (defined$child_err_fno and $child_err_fno >= 0){open$child_err_safe,">&=$child_err_fno" or POSIX::_exit(1)}else {open$child_err_safe,">/dev/null" or POSIX::_exit(1)}my$child_in_fno=_fileno_dup_over(0=>$child_in);my$child_out_fno=_fileno_dup_over(1=>$child_out);my$child_err_safe_fno=_fileno_dup_over(2=>$child_err_safe);unless (($child_in_fno==0 or POSIX::dup2($child_in_fno,0))and ($child_out_fno==1 or POSIX::dup2($child_out_fno,1))and ($child_err_safe_fno==2 or POSIX::dup2($child_err_safe_fno,2))){POSIX::_exit(1)}do {exec @_};POSIX::_exit(1)}close$child_in;close$child_out;$_[0]=$dad_in;$_[1]=$dad_out;$pid}sub _init_transport {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}else {$pass=delete$opts->{password};if (defined$pass){$sftp->{_password_authentication}=1;$password_prompt=$sftp->{_password_prompt}=delete$opts->{password_prompt};if (defined$password_prompt){unless (ref$password_prompt eq 'Regexp'){$password_prompt=quotemeta$password_prompt;$password_prompt=qr/$password_prompt\s*$/i}}$ask_for_username_at_login=$sftp->{_ask_for_username_at_login}=(delete($opts->{ask_for_username_at_login})|| delete($opts->{asks_for_username_at_login}));if ($ask_for_username_at_login){croak "ask_for_username_at_login set but user was not given" unless defined$user;croak "ask_for_username_at_login can not be used with a custom password prompt" if defined$password_prompt}}}delete$opts->{expect_log_user};my$stderr_discard=delete$opts->{stderr_discard};my$stderr_fh=($stderr_discard ? undef : delete$opts->{stderr_fh});my$open2_cmd=delete$opts->{open2_cmd};my$ssh_cmd_interface=delete$opts->{ssh_cmd_interface};my@open2_cmd;if (defined$open2_cmd){@open2_cmd=_ensure_list($open2_cmd)}else {my$host=delete$opts->{host};defined$host or croak "sftp target host not defined";my$key_path=delete$opts->{key_path};my$ssh_cmd=delete$opts->{ssh_cmd};$ssh_cmd='ssh' unless defined$ssh_cmd;@open2_cmd=_ensure_list$ssh_cmd;unless (defined$ssh_cmd_interface){$ssh_cmd_interface=("@open2_cmd" =~ /\bplink\b/i ? 'plink' : "@open2_cmd" =~ /\bsshg3\b/i ? 'tectia' : 'ssh')}my$port=delete$opts->{port};my$ssh1=delete$opts->{ssh1};my$more=delete$opts->{more};defined$more and!ref($more)and $more =~ /^-\w\s+\S/ and warnings::warnif("Net::SFTP::Foreign","'more' argument looks like it should be split first");my@more=_ensure_list$more;my@preferred_authentications;if (defined$key_path){push@preferred_authentications,'publickey';push@open2_cmd,map {-i=>$_}_ensure_list$key_path}if ($ssh_cmd_interface eq 'plink'){push@open2_cmd,-P=>$port if defined$port;if (defined$pass and!$pass_is_passphrase){warnings::warnif("Net::SFTP::Foreign","using insecure password authentication with plink");push@open2_cmd,-pw=>$pass;undef$pass}}elsif ($ssh_cmd_interface eq 'ssh'){push@open2_cmd,-p=>$port if defined$port;if (defined$pass and!$pass_is_passphrase){push@open2_cmd,-o=>'NumberOfPasswordPrompts=1';push@preferred_authentications,('keyboard-interactive','password')}if (@preferred_authentications and not grep {$more[$_]eq '-o' and $more[$_ + 1]=~ /^PreferredAuthentications\W/}0..$#more-1){push@open2_cmd,-o=>'PreferredAuthentications=' .join(',',@preferred_authentications)}}elsif ($ssh_cmd_interface eq 'tectia'){}else {die "Unsupported ssh_cmd_interface '$ssh_cmd_interface'"}push@open2_cmd,-l=>$user if defined$user;push@open2_cmd,@more;push@open2_cmd,$host;push@open2_cmd,($ssh1 ? "/usr/lib/sftp-server" : -s=>'sftp')}my$redirect_stderr_to_tty=(defined$pass and (delete$opts->{redirect_stderr_to_tty}or $ssh_cmd_interface eq 'tectia'));$redirect_stderr_to_tty and ($stderr_discard or $stderr_fh)and croak "stderr_discard or stderr_fh can not be used together with password/passphrase " ."authentication when Tectia client is used";$debug and $debug & 1 and _debug "ssh cmd: @open2_cmd\n";%$opts and return;if (${^TAINT} and Scalar::Util::tainted($ENV{PATH})){_tcroak('Insecure $ENV{PATH}')}if ($stderr_discard){$stderr_fh=$backend->_open_dev_null($sftp)or return}if (defined$pass){eval {require IO::Pty;1}or croak "password authentication not available, IO::Pty is not installed or failed to load: $@";local ($ENV{SSH_ASKPASS},$ENV{SSH_AUTH_SOCK})if$pass_is_passphrase;my$name=$pass_is_passphrase ? 'Passphrase' : 'Password';my$child;my$pty=IO::Pty->new;$redirect_stderr_to_tty and $stderr_fh=$pty->slave;$child=$backend->_open4($sftp,$sftp->{ssh_in},$sftp->{ssh_out},$stderr_fh,$pty,@open2_cmd);unless (defined$child){$sftp->_conn_failed("Bad ssh command",$!);return}$sftp->{pid}=$child;open my$pty_dup,'+>&',$pty;$sftp->{_pty}=$pty_dup;$debug and $debug & 65536 and _debug "starting password authentication";my$rv='';vec($rv,fileno($pty),1)=1;my$buffer='';my$at=0;my$password_sent;my$start_time=time;while(1){if (defined$sftp->{_timeout}){$debug and $debug & 65536 and _debug "checking timeout, max: $sftp->{_timeout}, ellapsed: " .(time - $start_time);if (time - $start_time > $sftp->{_timeout}){$sftp->_conn_failed("login procedure timed out");return}}if (waitpid($child,POSIX::WNOHANG())> 0 or $!==Errno::ECHILD()){undef$sftp->{pid};my$err=$? >> 8;$sftp->_conn_failed("SSH slave exited unexpectedly with error code $err");return}$debug and $debug & 65536 and _debug "waiting for data from the pty to become available";my$rv1=$rv;select($rv1,undef,undef,1)> 0 or next;if (my$bytes=sysread($pty,$buffer,4096,length$buffer)){if ($debug and $debug & 65536){_debug "$bytes bytes readed from pty:";_hexdump substr($buffer,-$bytes)}if ($buffer =~ /^The authenticity of host/mi or $buffer =~ /^Warning: the \S+ host key for/mi){$sftp->_conn_failed("the authenticity of the target host can't be established, " ."the remote host public key is probably not present on the " ."'~/.ssh/known_hosts' file");return}if ($password_sent){$debug and $debug & 65536 and _debug "looking for password ok";last if substr($buffer,$at)=~ /\n$/}else {$debug and $debug & 65536 and _debug "looking for user/password prompt";my$re=(defined$password_prompt ? $password_prompt : qr/(user|name|login)?[:?]\s*$/i);$debug and $debug & 65536 and _debug "matching against $re";if (substr($buffer,$at)=~ $re){if ($ask_for_username_at_login and ($ask_for_username_at_login ne 'auto' or defined $1)){$debug and $debug & 65536 and _debug "sending username";print$pty "$user\n";undef$ask_for_username_at_login}else {$debug and $debug & 65536 and _debug "sending password";print$pty "$pass\n";$password_sent=1}$at=length$buffer}}}else {$debug and $debug & 65536 and _debug "no data available from pty, delaying until next read";sleep 1}}$debug and $debug & 65536 and _debug "password authentication done";$pty->close_slave()}else {$sftp->{pid}=$backend->_open4($sftp,$sftp->{ssh_in},$sftp->{ssh_out},$stderr_fh,undef,@open2_cmd);unless (defined$sftp->{pid}){$sftp->_conn_failed("Bad ssh command",$!);return}}}$backend->_init_transport_streams($sftp)}sub _after_init {my ($backend,$sftp)=@_;if ($sftp->{pid}and not $sftp->error){local ($@,$!);eval {setpgrp($sftp->{pid},0)}}}sub _do_io {my (undef,$sftp,$timeout)=@_;$debug and $debug & 32 and _debug(sprintf "_do_io connected: %s",$sftp->{_connected}|| 0);return undef unless$sftp->{_connected};my$fnoout=fileno$sftp->{ssh_out};my$fnoin=fileno$sftp->{ssh_in};my ($rv,$wv)=('','');vec($rv,$fnoin,1)=1;vec($wv,$fnoout,1)=1;my$bin=\$sftp->{_bin};my$bout=\$sftp->{_bout};local$SIG{PIPE}='IGNORE';my$len;while (1){my$lbin=length $$bin;if (defined$len){return 1 if$lbin >= $len}elsif ($lbin >= 4){$len=4 + unpack N=>$$bin;if ($len > 256 * 1024){$sftp->_set_status(SSH2_FX_BAD_MESSAGE);$sftp->_set_error(SFTP_ERR_REMOTE_BAD_MESSAGE,"bad remote message received");return undef}return 1 if$lbin >= $len}my$rv1=$rv;my$wv1=length($$bout)? $wv : '';$debug and $debug & 32 and _debug("_do_io select(-,-,-, ".(defined$timeout ? $timeout : 'undef').")");my$n=select($rv1,$wv1,undef,$timeout);if ($n > 0){if (vec($wv1,$fnoout,1)){my$written=syswrite($sftp->{ssh_out},$$bout,64 * 1024);if ($debug and $debug & 32){_debug (sprintf "_do_io write queue: %d, syswrite: %s, max: %d, \$!: %s",length $$bout,(defined$written ? $written : 'undef'),64 * 1024,$!);$debug & 2048 and $written and _hexdump(substr($$bout,0,$written))}if ($written){substr($$bout,0,$written,'')}elsif ($!!=Errno::EAGAIN()and $!!=Errno::EINTR()){$sftp->_conn_lost;return undef}}if (vec($rv1,$fnoin,1)){my$read=sysread($sftp->{ssh_in},$$bin,64 * 1024,length($$bin));if ($debug and $debug & 32){_debug (sprintf "_do_io read sysread: %s, total read: %d, \$!: %s",(defined$read ? $read : 'undef'),length $$bin,$!);$debug & 1024 and $read and _hexdump(substr($$bin,-$read))}if (!$read and $!!=Errno::EAGAIN()and $!!=Errno::EINTR()){$sftp->_conn_lost;return undef}}}else {$debug and $debug & 32 and _debug "_do_io select failed: $!";next if ($n < 0 and ($!==Errno::EINTR()or $!==Errno::EAGAIN()));return undef}}}1;
|
|
NET_SFTP_FOREIGN_BACKEND_UNIX
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Backend/Windows.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_BACKEND_WINDOWS';
|
|
package Net::SFTP::Foreign::Backend::Windows;our$VERSION='1.70_08';use strict;use warnings;use Carp;our@CARP_NOT=qw(Net::SFTP::Foreign);use IPC::Open3;use POSIX ();use Net::SFTP::Foreign::Helpers;use Net::SFTP::Foreign::Constants qw(SSH2_FX_BAD_MESSAGE SFTP_ERR_REMOTE_BAD_MESSAGE);require Net::SFTP::Foreign::Backend::Unix;our@ISA=qw(Net::SFTP::Foreign::Backend::Unix);sub _defaults {(queue_size=>16)}sub _init_transport_streams {my ($backend,$sftp)=@_;binmode$sftp->{ssh_in};binmode$sftp->{ssh_out}}sub _open_dev_null {my$sftp=shift;my$dev_null;unless (open$dev_null,'>','NUL:'){$sftp->_conn_failed("Unable to redirect stderr for slave SSH process to NUL: $!");return}$dev_null}sub _open4 {my$backend=shift;my$sftp=shift;defined $_[3]and croak "setting child PTY is not supported on Windows";my$fno=eval {defined $_[2]? fileno $_[2]: fileno*STDERR};unless (defined$fno and $fno >= 0){$sftp->_conn_failed("STDERR or stderr_fh is not a real file handle: " .(length $@ ? $@ : $!));return}local*SSHERR;unless (open(SSHERR,">>&=",$fno)){$sftp->_conn_failed("Unable to duplicate stderr redirection file handle: $!");return undef}goto NOTIE unless tied*STDERR;local*STDERR;unless (open STDERR,">&=2"){$sftp->_conn_failed("Unable to reattach STDERR to fd 2: $!");return}NOTIE: local ($@,$SIG{__DIE__},$SIG{__WARN__});my$ppid=$$;my$pid=eval {open3(@_[1,0],">&SSHERR",@_[4..$#_])};$ppid==$$ or POSIX::_exit(-1);$pid}sub _after_init {}sub _sysreadn {my ($sftp,$n)=@_;my$bin=\$sftp->{_bin};while (1){my$len=length $$bin;return 1 if$len >= $n;my$read=sysread($sftp->{ssh_in},$$bin,$n - $len,$len);unless ($read){$sftp->_conn_lost;return undef}}return$n}sub _do_io {my ($backend,$sftp,$timeout)=@_;return undef unless$sftp->{_connected};my$bin=\$sftp->{_bin};my$bout=\$sftp->{_bout};while (length $$bout){my$written=syswrite($sftp->{ssh_out},$$bout,20480);unless ($written){$sftp->_conn_lost;return undef}substr($$bout,0,$written,"")}defined$timeout and $timeout <= 0 and return;_sysreadn($sftp,4)or return undef;my$len=4 + unpack N=>$$bin;if ($len > 256 * 1024){$sftp->_set_status(SSH2_FX_BAD_MESSAGE);$sftp->_set_error(SFTP_ERR_REMOTE_BAD_MESSAGE,"bad remote message received");return undef}_sysreadn($sftp,$len)}1;
|
|
NET_SFTP_FOREIGN_BACKEND_WINDOWS
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Buffer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_BUFFER';
|
|
package Net::SFTP::Foreign::Buffer;our$VERSION='1.68_05';use strict;use warnings;no warnings 'uninitialized';use Carp;use constant HAS_QUADS=>do {local $@;local$SIG{__DIE__};no warnings;eval q{
|
|
pack(Q => 0x1122334455667788) eq "\x11\x22\x33\x44\x55\x66\x77\x88"
|
|
}};sub new {my$class=shift;my$data='';@_ and put(\$data,@_);bless \$data,$class}sub make {bless \$_[1],$_[0]}sub bytes {${$_[0]}}sub get_int8 {length ${$_[0]}>=1 or return undef;unpack(C=>substr(${$_[0]},0,1,''))}sub get_int16 {length ${$_[0]}>=2 or return undef;unpack(n=>substr(${$_[0]},0,2,''))}sub get_int32 {length ${$_[0]}>=4 or return undef;unpack(N=>substr(${$_[0]},0,4,''))}sub get_int32_untaint {my ($v)=substr(${$_[0]},0,4,'')=~ /(.*)/s;get_int32(\$v)}sub get_int64_quads {length ${$_[0]}>= 8 or return undef;unpack Q=>substr(${$_[0]},0,8,'')}sub get_int64_no_quads {length ${$_[0]}>= 8 or return undef;my ($big,$small)=unpack(NN=>substr(${$_[0]},0,8,''));if ($big){my$high=$big * 4294967296;my$result=$high + $small;unless ($result - $high==$small){require Math::BigInt;$result=Math::BigInt->new($big);$result <<= 32;$result += $small}return$result}return$small}*get_int64=(HAS_QUADS ? \&get_int64_quads : \&get_int64_no_quads);sub get_int64_untaint {my ($v)=substr(${$_[0]},0,8,'')=~ /(.*)/s;get_int64(\$v)}sub get_str {my$self=shift;length $$self >=4 or return undef;my$len=unpack(N=>substr($$self,0,4,''));length $$self >=$len or return undef;substr($$self,0,$len,'')}sub get_str_list {my$self=shift;my@a;if (my$n=$self->get_int32){for (1..$n){my$str=$self->get_str;last unless defined$str;push@a,$str}}return@a}sub get_attributes {Net::SFTP::Foreign::Attributes->new_from_buffer($_[0])}sub skip_bytes {substr(${$_[0]},0,$_[1],'')}sub skip_str {my$self=shift;my$len=$self->get_int32;substr($$self,0,$len,'')}sub put_int8 {${$_[0]}.= pack(C=>$_[1])}sub put_int32 {${$_[0]}.= pack(N=>$_[1])}sub put_int64_quads {${$_[0]}.= pack(Q=>$_[1])}sub put_int64_no_quads {if ($_[1]>= 4294967296){my$high=int ($_[1]/ 4294967296);my$low=int ($_[1]- $high * 4294967296);${$_[0]}.= pack(NN=>$high,$low)}else {${$_[0]}.= pack(NN=>0,$_[1])}}*put_int64=(HAS_QUADS ? \&put_int64_quads : \&put_int64_no_quads);sub put_str {utf8::downgrade($_[1])or croak "UTF8 data reached the SFTP buffer";${$_[0]}.= pack(N=>length($_[1])).$_[1]}sub put_char {${$_[0]}.= $_[1]}sub _attrs_as_buffer {my$attrs=shift;my$ref=ref$attrs;Net::SFTP::Foreign::Attributes->isa($ref)or croak("Object of class Net::SFTP::Foreign::Attributes " ."expected, $ref found");$attrs->as_buffer}sub put_attributes {${$_[0]}.= ${_attrs_as_buffer $_[1]}}my%unpack=(int8=>\&get_int8,int32=>\&get_int32,int64=>\&get_int64,str=>\&get_str,attr=>\&get_attributtes);sub get {my$buf=shift;map {$unpack{$_}->($buf)}@_}my%pack=(int8=>sub {pack C=>$_[0]},int32=>sub {pack N=>$_[0]},int64=>sub {if (HAS_QUADS){return pack(Q=>$_[0])}else {if ($_[0]>= 4294967296){my$high=int ($_[0]/ 4294967296);my$low=int ($_[0]- $high * 4294967296);return pack(NN=>$high,$low)}else {return pack(NN=>0,$_[0])}}},str=>sub {pack(N=>length($_[0])),$_[0]},char=>sub {$_[0]},attr=>sub {${_attrs_as_buffer $_[0]}});sub put {my$buf=shift;@_ & 1 and croak "bad number of arguments for put (@_)";my@parts;while (@_){my$type=shift;my$value=shift;my$packer=$pack{$type}or Carp::confess("internal error: bad packing type '$type'");push@parts,$packer->($value)}$$buf.=join('',@parts)}1;
|
|
NET_SFTP_FOREIGN_BUFFER
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Common.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_COMMON';
|
|
package Net::SFTP::Foreign::Common;our$VERSION='1.76_02';use strict;use warnings;use Carp;BEGIN {require Scalar::Util;eval {Scalar::Util->import(qw(dualvar tainted));1}or do {*tainted=sub {croak "The version of Scalar::Util installed on your system " ."does not provide 'tainted'"};*dualvar=sub {$_[0]}}}use Net::SFTP::Foreign::Helpers qw(_gen_wanted _ensure_list _debug _glob_to_regex _is_lnk _is_dir $debug);use Net::SFTP::Foreign::Constants qw(:status);my%status_str=(SSH2_FX_OK,"OK",SSH2_FX_EOF,"End of file",SSH2_FX_NO_SUCH_FILE,"No such file or directory",SSH2_FX_PERMISSION_DENIED,"Permission denied",SSH2_FX_FAILURE,"Failure",SSH2_FX_BAD_MESSAGE,"Bad message",SSH2_FX_NO_CONNECTION,"No connection",SSH2_FX_CONNECTION_LOST,"Connection lost",SSH2_FX_OP_UNSUPPORTED,"Operation unsupported");our$debug;sub _set_status {my$sftp=shift;my$code=shift;if ($code){my$str;if (@_){$str=join ': ',@_;($str)=$str =~ /(.*)/ if (${^TAINT} && tainted$str)}unless (defined$str and length$str){$str=$status_str{$code}|| "Unknown status ($code)"}$debug and $debug & 64 and _debug("_set_status code: $code, str: $str");return$sftp->{_status}=dualvar($code,$str)}else {return$sftp->{_status}=0}}sub status {shift->{_status}}sub _set_error {my$sftp=shift;my$code=shift;if ($code){my$str;if (@_){$str=join ': ',@_;($str)=$str =~ /(.*)/ if (${^TAINT} && tainted$str)}else {$str=$code ? "Unknown error $code" : "OK"}$debug and $debug & 64 and _debug("_set_err code: $code, str: $str");my$error=$sftp->{_error}=dualvar$code,$str;croak$error if$sftp->{_autodie}}elsif ($sftp->{_error}){if ($sftp->{_error}!=Net::SFTP::Foreign::Constants::SFTP_ERR_CONNECTION_BROKEN()){$sftp->{_error}=0}}return$sftp->{_error}}sub _clear_error_and_status {my$sftp=shift;$sftp->_set_error;$sftp->_set_status}sub _copy_error {my ($sftp,$other)=@_;unless ($sftp->{_error}and $sftp->{_error}==Net::SFTP::Foreign::Constants::SFTP_ERR_CONNECTION_BROKEN()){$sftp->{_error}=$other->{_error}}}sub error {shift->{_error}}sub die_on_error {my$sftp=shift;$sftp->{_error}and croak(@_ ? "@_: $sftp->{_error}" : $sftp->{_error})}sub _ok_or_autodie {my$sftp=shift;return 1 unless$sftp->{_error};$sftp->{_autodie}and croak$sftp->{_error};undef}sub _set_errno {my$sftp=shift;if ($sftp->{_error}){my$status=$sftp->{_status}+ 0;my$error=$sftp->{_error}+ 0;if ($status==SSH2_FX_EOF){return}elsif ($status==SSH2_FX_NO_SUCH_FILE){$!=Errno::ENOENT()}elsif ($status==SSH2_FX_PERMISSION_DENIED){$!=Errno::EACCES()}elsif ($status==SSH2_FX_BAD_MESSAGE){$!=Errno::EBADMSG()}elsif ($status==SSH2_FX_OP_UNSUPPORTED){$!=Errno::ENOTSUP()}elsif ($status){$!=Errno::EIO()}}}sub _best_effort {my$sftp=shift;my$best_effort=shift;my$method=shift;local ($sftp->{_error},$sftp->{_autodie})if$best_effort;$sftp->$method(@_);return (($best_effort or not $sftp->{_error})? 1 : undef)}sub _call_on_error {my ($sftp,$on_error,$entry)=@_;$on_error and $sftp->error and $on_error->($sftp,$entry);$sftp->_clear_error_and_status}sub find {@_ >= 1 or croak 'Usage: $sftp->find($remote_dirs, %opts)';my$self=shift;my%opts=@_ & 1 ? ('dirs',@_): @_;$self->_clear_error_and_status;my$dirs=delete$opts{dirs};my$follow_links=delete$opts{follow_links};my$on_error=delete$opts{on_error};local$self->{_autodie}if$on_error;my$realpath=delete$opts{realpath};my$ordered=delete$opts{ordered};my$names_only=delete$opts{names_only};my$atomic_readdir=delete$opts{atomic_readdir};my$wanted=_gen_wanted(delete$opts{wanted},delete$opts{no_wanted});my$descend=_gen_wanted(delete$opts{descend},delete$opts{no_descend});%opts and croak "invalid option(s) '".CORE::join("', '",keys%opts)."'";$dirs='.' unless defined$dirs;my$wantarray=wantarray;my (@res,$res);my%done;my%rpdone;my@dirs=_ensure_list$dirs;my@queue=map {{filename=>$_ }}($ordered ? sort@dirs : @dirs);my$task=sub {my$entry=shift;my$fn=$entry->{filename};for (1){my$follow=($follow_links and _is_lnk($entry->{a}->perm));if ($follow or $realpath){unless (defined$entry->{realpath}){my$rp=$entry->{realpath}=$self->realpath($fn);next unless (defined$rp and not $rpdone{$rp}++)}}if ($follow){my$a=$self->stat($fn);if (defined$a){$entry->{a}=$a;unshift@queue,$entry}next}if (!$wanted or $wanted->($self,$entry)){if ($wantarray){push@res,($names_only ? (exists$entry->{realpath}? $entry->{realpath}: $entry->{filename}): $entry)}else {$res++}}}continue {$self->_call_on_error($on_error,$entry)}};my$try;while (@queue){no warnings 'uninitialized';$try=shift@queue;my$fn=$try->{filename};my$a=$try->{a}||= $self->lstat($fn)or next;next if (_is_dir($a->perm)and $done{$fn}++);$task->($try);if (_is_dir($a->perm)){if (!$descend or $descend->($self,$try)){if ($ordered or $atomic_readdir){my$ls=$self->ls($fn,ordered=>$ordered,_wanted=>sub {my$child=$_[1]->{filename};if ($child !~ /^\.\.?$/){$_[1]->{filename}=$self->join($fn,$child);return 1}undef})or next;unshift@queue,@$ls}else {$self->ls($fn,_wanted=>sub {my$entry=$_[1];my$child=$entry->{filename};if ($child !~ /^\.\.?$/){$entry->{filename}=$self->join($fn,$child);if (_is_dir($entry->{a}->perm)){push@queue,$entry}else {$task->($entry)}}undef})or next}}}}continue {$self->_call_on_error($on_error,$try)}return wantarray ? @res : $res}sub glob {@_ >= 2 or croak 'Usage: $sftp->glob($pattern, %opts)';${^TAINT} and &_catch_tainted_args;my ($sftp,$glob,%opts)=@_;return ()if$glob eq '';my$on_error=delete$opts{on_error};local$sftp->{_autodie}if$on_error;my$follow_links=delete$opts{follow_links};my$ignore_case=delete$opts{ignore_case};my$names_only=delete$opts{names_only};my$realpath=delete$opts{realpath};my$ordered=delete$opts{ordered};my$wanted=_gen_wanted(delete$opts{wanted},delete$opts{no_wanted});my$strict_leading_dot=delete$opts{strict_leading_dot};$strict_leading_dot=1 unless defined$strict_leading_dot;%opts and _croak_bad_options(keys%opts);my$wantarray=wantarray;my (@parts,$top);if (ref$glob eq 'Regexp'){@parts=($glob);$top='.'}else {@parts=($glob =~ m{\G/*([^/]+)}g);push@parts,'.' unless@parts;$top=($glob =~ m|^/| ? '/' : '.')}my@res=({filename=>$top});my$res=0;while (@parts and @res){my@parents=@res;@res=();my$part=shift@parts;my ($re,$has_wildcards);if (ref$part eq 'Regexp'){$re=$part;$has_wildcards=1}else {($re,$has_wildcards)=_glob_to_regex($part,$strict_leading_dot,$ignore_case)}for my$parent (@parents){my$pfn=$parent->{filename};if ($has_wildcards){$sftp->ls($pfn,ordered=>$ordered,_wanted=>sub {my$e=$_[1];if ($e->{filename}=~ $re){my$fn=$e->{filename}=$sftp->join($pfn,$e->{filename});if ((@parts or $follow_links)and _is_lnk($e->{a}->perm)){if (my$a=$sftp->stat($fn)){$e->{a}=$a}else {$on_error and $sftp->_call_on_error($on_error,$e);return undef}}if (@parts){push@res,$e if _is_dir($e->{a}->perm)}elsif (!$wanted or $wanted->($sftp,$e)){if ($wantarray){if ($realpath){my$rp=$e->{realpath}=$sftp->realpath($e->{filename});unless (defined$rp){$on_error and $sftp->_call_on_error($on_error,$e);return undef}}push@res,($names_only ? ($realpath ? $e->{realpath}: $e->{filename}): $e)}$res++}}return undef})or ($on_error and $sftp->_call_on_error($on_error,$parent))}else {my$fn=$sftp->join($pfn,$part);my$method=((@parts or $follow_links)? 'stat' : 'lstat');if (my$a=$sftp->$method($fn)){my$e={filename=>$fn,a=>$a };if (@parts){push@res,$e if _is_dir($a->{perm})}elsif (!$wanted or $wanted->($sftp,$e)){if ($wantarray){if ($realpath){my$rp=$fn=$e->{realpath}=$sftp->realpath($fn);unless (defined$rp){$on_error and $sftp->_call_on_error($on_error,$e);next}}push@res,($names_only ? $fn : $e)}$res++}}}}}return wantarray ? @res : $res}sub test_d {my ($sftp,$name)=@_;{local$sftp->{_autodie};my$a=$sftp->stat($name);return _is_dir($a->perm)if$a}if ($sftp->{_status}==SSH2_FX_NO_SUCH_FILE){$sftp->_clear_error_and_status;return undef}$sftp->_ok_or_autodie}sub test_e {my ($sftp,$name)=@_;{local$sftp->{_autodie};$sftp->stat($name)and return 1}if ($sftp->{_status}==SSH2_FX_NO_SUCH_FILE){$sftp->_clear_error_and_status;return undef}$sftp->_ok_or_autodie}1;
|
|
NET_SFTP_FOREIGN_COMMON
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Compat.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_COMPAT';
|
|
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'){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})}$sftp->SUPER::get($remote,$local,@{$DEFAULTS{get}},dont_save=>!defined($local),@cb)or return undef;if ($save){return CORE::join('',@content)}}sub put {croak '$Usage: $sftp->put($local, $remote, $cb)' if @_ < 3 or @_ > 4;my ($sftp,$local,$remote,$cb)=@_;$sftp->SUPER::put($local,$remote,@{$DEFAULTS{put}},callback=>$cb);$sftp->_warn_error;!$sftp->SUPER::error}sub ls {croak '$Usage: $sftp->ls($path, $cb)' if @_ < 2 or @_ > 3;my ($sftp,$path,$cb)=@_;if ($cb){$sftp->SUPER::ls($path,@{$DEFAULTS{ls}},wanted=>sub {_rebless_attrs($_[1]->{a});$cb->($_[1]);0});return ()}else {if (my$ls=$sftp->SUPER::ls($path,@{$DEFAULTS{ls}})){_rebless_attrs($_->{a})for @$ls;return @$ls}return ()}}sub do_open {shift->SUPER::open(@_)}sub do_opendir {shift->SUPER::opendir(@_)}sub do_realpath {shift->SUPER::realpath(@_)}sub do_read {my$sftp=shift;my$read=$sftp->SUPER::sftpread(@_);$sftp->_warn_error;if (wantarray){return ($read,$sftp->status)}else {return$read}}sub _gen_do_and_status {my$method="SUPER::" .shift;return sub {my$sftp=shift;$sftp->$method(@_);$sftp->_warn_error;$sftp->status}}*do_write=_gen_do_and_status('sftpwrite');*do_close=_gen_do_and_status('close');*do_setstat=_gen_do_and_status('setstat');*do_fsetstat=_gen_do_and_status('setstat');*do_remove=_gen_do_and_status('remove');*do_rename=_gen_do_and_status('rename');*do_mkdir=_gen_do_and_status('mkdir');*do_rmdir=_gen_do_and_status('rmdir');sub _rebless_attrs {my$a=shift;if ($a){bless$a,($supplant ? "Net::SFTP::Attributes" : "Net::SFTP::Foreign::Attributes::Compat")}$a}sub _gen_do_stat {my$name=shift;my$method="SUPER::$name";return sub {croak '$Usage: $sftp->'.$name.'($local, $remote, $cb)' if @_!=2;my$sftp=shift;if (my$a=$sftp->$method(@_)){return _rebless_attrs($a)}else {$sftp->_warn_error;return undef}}}*do_lstat=_gen_do_stat('lstat');*do_fstat=_gen_do_stat('fstat');*do_stat=_gen_do_stat('stat');1;
|
|
NET_SFTP_FOREIGN_COMPAT
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Constants.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_CONSTANTS';
|
|
package Net::SFTP::Foreign::Constants;our$VERSION='1.63_05';use strict;use warnings;use Carp;require Exporter;our@ISA=qw(Exporter);our (@EXPORT_OK,%EXPORT_TAGS);BEGIN {my%constants=(SSH2_FXP_INIT=>1,SSH2_FXP_VERSION=>2,SSH2_FXP_OPEN=>3,SSH2_FXP_CLOSE=>4,SSH2_FXP_READ=>5,SSH2_FXP_WRITE=>6,SSH2_FXP_LSTAT=>7,SSH2_FXP_FSTAT=>8,SSH2_FXP_SETSTAT=>9,SSH2_FXP_FSETSTAT=>10,SSH2_FXP_OPENDIR=>11,SSH2_FXP_READDIR=>12,SSH2_FXP_REMOVE=>13,SSH2_FXP_MKDIR=>14,SSH2_FXP_RMDIR=>15,SSH2_FXP_REALPATH=>16,SSH2_FXP_STAT=>17,SSH2_FXP_RENAME=>18,SSH2_FXP_READLINK=>19,SSH2_FXP_SYMLINK=>20,SSH2_FXP_STATUS=>101,SSH2_FXP_HANDLE=>102,SSH2_FXP_DATA=>103,SSH2_FXP_NAME=>104,SSH2_FXP_ATTRS=>105,SSH2_FXP_EXTENDED=>200,SSH2_FXP_EXTENDED_REPLY=>201,SSH2_FXF_READ=>0x01,SSH2_FXF_WRITE=>0x02,SSH2_FXF_APPEND=>0x04,SSH2_FXF_CREAT=>0x08,SSH2_FXF_TRUNC=>0x10,SSH2_FXF_EXCL=>0x20,SSH2_FX_OK=>0,SSH2_FX_EOF=>1,SSH2_FX_NO_SUCH_FILE=>2,SSH2_FX_PERMISSION_DENIED=>3,SSH2_FX_FAILURE=>4,SSH2_FX_BAD_MESSAGE=>5,SSH2_FX_NO_CONNECTION=>6,SSH2_FX_CONNECTION_LOST=>7,SSH2_FX_OP_UNSUPPORTED=>8,SSH2_FILEXFER_ATTR_SIZE=>0x01,SSH2_FILEXFER_ATTR_UIDGID=>0x02,SSH2_FILEXFER_ATTR_PERMISSIONS=>0x04,SSH2_FILEXFER_ATTR_ACMODTIME=>0x08,SSH2_FILEXFER_ATTR_EXTENDED=>0x80000000,SSH2_FILEXFER_VERSION=>3,SSH2_FXE_STATVFS_ST_READONLY=>0x1,SSH2_FXE_STATVFS_ST_NOSUID=>0x2,SFTP_ERR_REMOTE_STAT_FAILED=>1,SFTP_ERR_REMOTE_OPEN_FAILED=>2,SFTP_ERR_LOCAL_ALREADY_EXISTS=>3,SFTP_ERR_LOCAL_OPEN_FAILED=>26,SFTP_ERR_REMOTE_READ_FAILED=>5,SFTP_ERR_REMOTE_BLOCK_TOO_SMALL=>6,SFTP_ERR_LOCAL_WRITE_FAILED=>7,SFTP_ERR_REMOTE_BAD_PERMISSIONS=>8,SFTP_ERR_LOCAL_CHMOD_FAILED=>9,SFTP_ERR_REMOTE_BAD_TIME=>10,SFTP_ERR_LOCAL_UTIME_FAILED=>11,SFTP_ERR_REMOTE_BAD_MESSAGE=>13,SFTP_ERR_REMOTE_REALPATH_FAILED=>14,SFTP_ERR_REMOTE_OPENDIR_FAILED=>15,SFTP_ERR_REMOTE_WRITE_FAILED=>16,SFTP_ERR_REMOTE_RENAME_FAILED=>17,SFTP_ERR_REMOTE_LSTAT_FAILED=>18,SFTP_ERR_REMOTE_FSTAT_FAILED=>19,SFTP_ERR_REMOTE_CLOSE_FAILED=>20,SFTP_ERR_REMOTE_REMOVE_FAILED=>21,SFTP_ERR_REMOTE_MKDIR_FAILED=>22,SFTP_ERR_REMOTE_RMDIR_FAILED=>23,SFTP_ERR_REMOTE_SETSTAT_FAILED=>24,SFTP_ERR_REMOTE_FSETSTAT_FAILED=>25,SFTP_ERR_LOCAL_STAT_FAILED=>27,SFTP_ERR_LOCAL_READ_ERROR=>28,SFTP_ERR_REMOTE_READDIR_FAILED=>29,SFTP_ERR_REMOTE_READLINK_FAILED=>30,SFTP_ERR_REMOTE_SYMLINK_FAILED=>31,SFTP_ERR_REMOTE_BAD_PATH=>32,SFTP_ERR_LOCAL_MKDIR_FAILED=>33,SFTP_ERR_LOCAL_SYMLINK_FAILED=>34,SFTP_ERR_REMOTE_BAD_OBJECT=>35,SFTP_ERR_REMOTE_ACCESING_CLOSED_FILE=>36,SFTP_ERR_CONNECTION_BROKEN=>37,SFTP_ERR_LOCAL_GENERIC_ERROR=>38,SFTP_ERR_LOCAL_READLINK_FAILED=>39,SFTP_ERR_LOCAL_BAD_PATH=>40,SFTP_ERR_LOCAL_BAD_OBJECT=>41,SFTP_ERR_REMOTE_ALREADY_EXISTS=>42,SFTP_ERR_ABORTED=>44,SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL=>45,SFTP_ERR_LOCAL_BIGGER_THAN_REMOTE=>46,SFTP_ERR_LOCAL_SEEK_FAILED=>47,SFTP_ERR_REMOTE_STATVFS_FAILED=>48,SFTP_ERR_REMOTE_FSTATVFS_FAILED=>49,SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED=>50,SFTP_ERR_REMOTE_HARDLINK_FAILED=>51,SFTP_ERR_LOCAL_RENAME_FAILED=>52,SFTP_ERR_REMOTE_FSYNC_FAILED=>53,);for my$key (keys%constants){no strict 'refs';my$value=$constants{$key};*{$key}=sub () {$value}}@EXPORT_OK=keys%constants;my%etagre=qw(fxp SSH2_FXP_ flags SSH2_FXF_ att SSH2_FILEXFER_ATTR status SSH2_FX_ error SFTP_ERR_ ext SSH2_FXE_);for my$key (keys%etagre){my$re=qr/^$etagre{$key}/;$EXPORT_TAGS{$key}=[grep $_=~$re,@EXPORT_OK]}}1;
|
|
NET_SFTP_FOREIGN_CONSTANTS
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Helpers.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_HELPERS';
|
|
package Net::SFTP::Foreign::Helpers;our$VERSION='1.74_06';use strict;use warnings;use Carp qw(croak carp);our@CARP_NOT=qw(Net::SFTP::Foreign);use Scalar::Util qw(tainted);require Exporter;our@ISA=qw(Exporter);our@EXPORT=qw(_sort_entries _gen_wanted _ensure_list _catch_tainted_args _debug _gen_converter _hexdump $debug);our@EXPORT_OK=qw(_is_lnk _is_dir _is_reg _do_nothing _glob_to_regex _file_part _umask_save_and_set _tcroak _untaint);our$debug;sub _debug {local ($\,$!);my$caller='';if ($debug & 8192){$caller=(caller 1)[3];$caller =~ s/[\w:]*:://;$caller .= ': '}my$line=join(' ',map {defined $_ ? $_ : '<undef>'}@_);if ($debug & 256){my$ts=sprintf("%010.5f",time);print STDERR "#$$ $ts $caller $line\n"}else {print STDERR "# $caller $line\n"}}sub _hexdump {local ($\,$!);no warnings qw(uninitialized);my$data=shift;while ($data =~ /(.{1,32})/smg){my$line=$1;my@c=((map {sprintf "%02x",$_}unpack('C*',$line)),((" ")x 32))[0..31];$line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms;local $\;print STDERR join(" ",@c,'|',$line),"\n"}}sub _do_nothing {}{my$has_sk;sub _has_sk {unless (defined$has_sk){local $@;local$SIG{__DIE__};eval {require Sort::Key};$has_sk=($@ eq '')}return$has_sk}}sub _sort_entries {my$e=shift;if (_has_sk){&Sort::Key::keysort_inplace(sub {$_->{filename}},$e)}else {@$e=sort {$a->{filename}cmp $b->{filename}}@$e}}sub _gen_wanted {my ($ow,$onw)=my ($w,$nw)=@_;if (ref$w eq 'Regexp'){$w=sub {$_[1]->{filename}=~ $ow}}if (ref$nw eq 'Regexp'){$nw=sub {$_[1]->{filename}!~ $onw}}elsif (defined$nw){$nw=sub {!&$onw}}if (defined$w and defined$nw){return sub {&$nw and &$w}}return$w || $nw}sub _ensure_list {my$l=shift;return ()unless defined$l;local $@;local$SIG{__DIE__};local$SIG{__WARN__};no warnings;(eval {@$l;1}? @$l : $l)}sub _glob_to_regex {my ($glob,$strict_leading_dot,$ignore_case)=@_;my ($regex,$in_curlies,$escaping);my$wildcards=0;my$first_byte=1;while ($glob =~ /\G(.)/g){my$char=$1;if ($char eq '\\'){$escaping=1}else {if ($first_byte){if ($strict_leading_dot){$regex .= '(?=[^\.])' unless$char eq '.'}$first_byte=0}if ($char eq '/'){$first_byte=1}if ($escaping){$regex .= quotemeta$char}else {$wildcards++;if ($char eq '*'){$regex .= ".*"}elsif ($char eq '?'){$regex .= '.'}elsif ($char eq '{'){$regex .= '(?:(?:';++$in_curlies}elsif ($char eq '}'){$regex .= "))";--$in_curlies;$in_curlies < 0 and croak "invalid glob pattern"}elsif ($char eq ',' && $in_curlies){$regex .= ")|(?:"}elsif ($char eq '['){if ($glob =~ /\G((?:\\.|[^\]])+)\]/g){$regex .= "[$1]"}else {croak "invalid glob pattern"}}else {$wildcards--;$regex .= quotemeta$char}}$escaping=0}}croak "invalid glob pattern" if$in_curlies;my$re=$ignore_case ? qr/^$regex$/i : qr/^$regex$/;wantarray ? ($re,($wildcards > 0 ? 1 : undef)): $re}sub _tcroak {if (${^TAINT} > 0){push @_," while running with -T switch";goto&croak}if (${^TAINT} < 0){push @_," while running with -t switch";goto&carp}}sub _catch_tainted_args {my$i;for (@_){next unless$i++;if (tainted($_)){my (undef,undef,undef,$subn)=caller 1;my$msg=($subn =~ /::([a-z]\w*)$/ ? "Insecure argument '$_' on '$1' method call" : "Insecure argument '$_' on method call");_tcroak($msg)}elsif (ref($_)){for (grep tainted($_),do {local ($@,$SIG{__DIE__});eval {values %$_}}){my (undef,undef,undef,$subn)=caller 1;my$msg=($subn =~ /::([a-z]\w*)$/ ? "Insecure argument on '$1' method call" : "Insecure argument on method call");_tcroak($msg)}}}}sub _gen_dos2unix {my$unix2dos=shift;my$name=($unix2dos ? 'unix2dos' : 'dos2unix');my$previous;my$done;sub {$done and die "Internal error: bad calling sequence for $name transformation";my$adjustment=0;for (@_){if ($debug and $debug & 128){_debug ("before $name: previous: $previous, data follows...");_hexdump($_)}if (length){if ($previous){$adjustment++;$_="\x0d$_"}$adjustment -= $previous=s/\x0d\z//s;if ($unix2dos){$adjustment += s/(?<!\x0d)\x0a/\x0d\x0a/gs}else {$adjustment -= s/\x0d\x0a/\x0a/gs}}elsif ($previous){$previous=0;$done=1;$adjustment++;$_="\x0d"}if ($debug and $debug & 128){_debug ("after $name: previous: $previous, adjustment: $adjustment, data follows...");_hexdump($_)}return$adjustment}}}sub _gen_converter {my$conversion=shift;return undef unless defined$conversion;if (ref$conversion){if (ref$conversion eq 'CODE'){return sub {my$before=length $_[0];$conversion->($_[0]);length($_[0])- $before}}else {croak "unsupported conversion argument"}}elsif ($conversion eq 'dos2unix'){return _gen_dos2unix(0)}elsif ($conversion eq 'unix2dos'){return _gen_dos2unix(1)}else {croak "unknown conversion '$conversion'"}}sub _is_lnk {(0120000 & shift)==0120000}sub _is_dir {(0040000 & shift)==0040000}sub _is_reg {(0100000 & shift)==0100000}sub _file_part {my$path=shift;$path =~ m{([^/]*)$} or croak "unable to get file part from path '$path'";$1}sub _untaint {if (${^TAINT}){for (@_){defined or next;($_)=/(.*)/s}}}sub _umask_save_and_set {my$umask=shift;if (defined$umask){my$old=umask$umask;return bless \$old,'Net::SFTP::Foreign::Helpers::umask_saver'}()}sub Net::SFTP::Foreign::Helpers::umask_saver::DESTROY {umask ${$_[0]}}1;
|
|
NET_SFTP_FOREIGN_HELPERS
|
|
|
|
$fatpacked{"Net/SFTP/Foreign/Local.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN_LOCAL';
|
|
package Net::SFTP::Foreign::Local;our$VERSION='1.57';use strict;use warnings;use Carp;use File::Spec;use Net::SFTP::Foreign::Attributes;use Net::SFTP::Foreign::Constants qw(:error);use Net::SFTP::Foreign::Helpers qw(_sort_entries _gen_wanted _do_nothing);require Net::SFTP::Foreign::Common;our@ISA=qw(Net::SFTP::Foreign::Common);sub new {my$class=shift;my$self={status=>0,error=>0 };bless$self,$class}sub realpath {$!=0;File::Spec->rel2abs($_[1])}sub stat {$!=0;my$a=Net::SFTP::Foreign::Attributes->new_from_stat(CORE::stat($_[1]));unless ($a){$_[0]->_set_error(SFTP_ERR_LOCAL_STAT_FAILED,"Couldn't stat local file '$_[1]'",$!)}$a}sub lstat {$!=0;my$a=Net::SFTP::Foreign::Attributes->new_from_stat(CORE::lstat($_[1]));unless ($a){$_[0]->_set_error(SFTP_ERR_LOCAL_STAT_FAILED,"Couldn't stat local file '$_[1]'",$!)}$a}sub readlink {$!=0;my$target=readlink $_[1];unless (defined$target){$_[0]->_set_error(SFTP_ERR_LOCAL_READLINK_FAILED,"Couldn't read link '$_[1]'",$!)}$target}sub join {shift;my$path=File::Spec->join(@_);$path=File::Spec->canonpath($path);$path}sub ls {my ($self,$dir,%opts)=@_;my$ordered=delete$opts{ordered};my$follow_links=delete$opts{follow_links};my$atomic_readdir=delete$opts{atomic_readdir};my$wanted=delete$opts{_wanted}|| _gen_wanted(delete$opts{wanted},delete$opts{no_wanted});%opts and croak "invalid option(s) '".CORE::join("', '",keys%opts)."'";$!=0;opendir(my$ldh,$dir)or return undef;my@dir;while (defined(my$part=readdir$ldh)){my$fn=File::Spec->join($dir,$part);my$a=$self->lstat($fn);if ($a and $follow_links and S_ISLNK($a->perm)){if (my$fa=$self->stat($fn)){$a=$fa}else {$!=0}}my$entry={filename=>$part,a=>$a };if ($atomic_readdir or!$wanted or $wanted->($self,$entry)){push@dir,$entry}}if ($atomic_readdir and $wanted){@dir=grep {$wanted->($self,$_)}@dir}_sort_entries(\@dir)if$ordered;return \@dir}1;
|
|
NET_SFTP_FOREIGN_LOCAL
|
|
|
|
$fatpacked{"Time/Zone.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_ZONE';
|
|
package Time::Zone;require 5.002;require Exporter;use Carp;use strict;use vars qw(@ISA @EXPORT $VERSION @tz_local);@ISA=qw(Exporter);@EXPORT=qw(tz2zone tz_local_offset tz_offset tz_name);$VERSION="2.24";sub tz2zone (;$$$) {my($TZ,$time,$isdst)=@_;use vars qw(%tzn_cache);$TZ=defined($ENV{'TZ'})? ($ENV{'TZ'}? $ENV{'TZ'}: 'GMT'): '' unless$TZ;if (!defined$isdst){my$j;$time=time()unless$time;($j,$j,$j,$j,$j,$j,$j,$j,$isdst)=localtime($time)}if (defined$tzn_cache{$TZ}->[$isdst]){return$tzn_cache{$TZ}->[$isdst]}if ($TZ =~ /^
|
|
( [^:\d+\-,] {3,} )
|
|
( [+-] ?
|
|
\d {1,2}
|
|
( : \d {1,2} ) {0,2}
|
|
)
|
|
( [^\d+\-,] {3,} )?
|
|
/x){my$dsttz=defined($4)? $4 : $1;$TZ=$isdst ? $dsttz : $1;$tzn_cache{$TZ}=[$1,$dsttz ]}else {$tzn_cache{$TZ}=[$TZ,$TZ ]}return$TZ}sub tz_local_offset (;$) {my ($time)=@_;$time=time()unless$time;my (@l)=localtime($time);my$isdst=$l[8];if (defined($tz_local[$isdst])){return$tz_local[$isdst]}$tz_local[$isdst]=&calc_off($time);return$tz_local[$isdst]}sub calc_off {my ($time)=@_;my (@l)=localtime($time);my (@g)=gmtime($time);my$off;$off=$l[0]- $g[0]+ ($l[1]- $g[1])* 60 + ($l[2]- $g[2])* 3600;if ($l[7]==$g[7]){}elsif ($l[7]==$g[7]+ 1){$off += 86400}elsif ($l[7]==$g[7]- 1){$off -= 86400}elsif ($l[7]< $g[7]){$off += 86400}else {$off -= 86400}return$off}CONFIG: {use vars qw(%dstZone %zoneOff %dstZoneOff %Zone);my@dstZone=("brst"=>-2*3600,"adt"=>-3*3600,"edt"=>-4*3600,"cdt"=>-5*3600,"mdt"=>-6*3600,"pdt"=>-7*3600,"akdt"=>-8*3600,"ydt"=>-8*3600,"hdt"=>-9*3600,"bst"=>+1*3600,"mest"=>+2*3600,"metdst"=>+2*3600,"sst"=>+2*3600,"fst"=>+2*3600,"cest"=>+2*3600,"eest"=>+3*3600,"msd"=>+4*3600,"wadt"=>+8*3600,"kdt"=>+10*3600,"aedt"=>+11*3600,"eadt"=>+11*3600,"nzd"=>+13*3600,"nzdt"=>+13*3600,);my@Zone=("gmt"=>0,"ut"=>0,"utc"=>0,"wet"=>0,"wat"=>-1*3600,"at"=>-2*3600,"fnt"=>-2*3600,"brt"=>-3*3600,"mnt"=>-4*3600,"ewt"=>-4*3600,"ast"=>-4*3600,"est"=>-5*3600,"act"=>-5*3600,"cst"=>-6*3600,"mst"=>-7*3600,"pst"=>-8*3600,"akst"=>-9*3600,"yst"=>-9*3600,"hst"=>-10*3600,"cat"=>-10*3600,"ahst"=>-10*3600,"nt"=>-11*3600,"idlw"=>-12*3600,"cet"=>+1*3600,"mez"=>+1*3600,"ect"=>+1*3600,"met"=>+1*3600,"mewt"=>+1*3600,"swt"=>+1*3600,"set"=>+1*3600,"fwt"=>+1*3600,"eet"=>+2*3600,"ukr"=>+2*3600,"bt"=>+3*3600,"msk"=>+3*3600,"zp4"=>+4*3600,"zp5"=>+5*3600,"zp6"=>+6*3600,"wst"=>+8*3600,"hkt"=>+8*3600,"cct"=>+8*3600,"jst"=>+9*3600,"kst"=>+9*3600,"aest"=>+10*3600,"east"=>+10*3600,"gst"=>+10*3600,"nzt"=>+12*3600,"nzst"=>+12*3600,"idle"=>+12*3600,);%Zone=@Zone;%dstZone=@dstZone;%zoneOff=reverse(@Zone);%dstZoneOff=reverse(@dstZone)}sub tz_offset (;$$) {my ($zone,$time)=@_;return&tz_local_offset($time)unless($zone);$time=time()unless$time;my(@l)=localtime($time);my$dst=$l[8];$zone=lc$zone;if($zone =~ /^(([\-\+])\d\d?)(\d\d)$/){my$v=$2 .$3;return $1 * 3600 + $v * 60}elsif (exists$dstZone{$zone}&& ($dst ||!exists$Zone{$zone})){return$dstZone{$zone}}elsif(exists$Zone{$zone}){return$Zone{$zone}}undef}sub tz_name (;$$) {my ($off,$dst)=@_;$off=tz_offset()unless(defined$off);$dst=(localtime(time))[8]unless(defined$dst);if (exists$dstZoneOff{$off}&& ($dst ||!exists$zoneOff{$off})){return$dstZoneOff{$off}}elsif (exists$zoneOff{$off}){return$zoneOff{$off}}sprintf("%+05d",int($off / 60)* 100 + $off % 60)}1;
|
|
TIME_ZONE
|
|
|
|
s/^ //mg for values %fatpacked;
|
|
|
|
my $class = 'FatPacked::'.(0+\%fatpacked);
|
|
no strict 'refs';
|
|
*{"${class}::files"} = sub { keys %{$_[0]} };
|
|
|
|
if ($] < 5.008) {
|
|
*{"${class}::INC"} = sub {
|
|
if (my $fat = $_[0]{$_[1]}) {
|
|
return sub {
|
|
return 0 unless length $fat;
|
|
$fat =~ s/^([^\n]*\n?)//;
|
|
$_ = $1;
|
|
return 1;
|
|
};
|
|
}
|
|
return;
|
|
};
|
|
}
|
|
|
|
else {
|
|
*{"${class}::INC"} = sub {
|
|
if (my $fat = $_[0]{$_[1]}) {
|
|
open my $fh, '<', \$fat
|
|
or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
|
|
return $fh;
|
|
}
|
|
return;
|
|
};
|
|
}
|
|
|
|
unshift @INC, bless \%fatpacked, $class;
|
|
} # END OF FATPACK CODE
|
|
|