From a43319c7ccb78a65b0dbaf1d3c5b180e557d6ad9 Mon Sep 17 00:00:00 2001 From: Paul Kolano Date: Tue, 12 Jul 2016 13:37:42 -0700 Subject: [PATCH] Initial commit --- CHANGES | 150 + COPYING | 256 ++ INSTALL | 314 ++ README.md | 41 +- doc/shiftc.1 | 950 ++++++ etc/shift-mounts.pl | 72 + etc/shift-select.hook | 35 + etc/shiftrc | 357 +++ perl/shift-aux | 1626 ++++++++++ perl/shift-mgr | 3849 ++++++++++++++++++++++++ perl/shiftc | 6579 +++++++++++++++++++++++++++++++++++++++++ 11 files changed, 14228 insertions(+), 1 deletion(-) create mode 100644 CHANGES create mode 100644 COPYING create mode 100644 INSTALL create mode 100644 doc/shiftc.1 create mode 100755 etc/shift-mounts.pl create mode 100755 etc/shift-select.hook create mode 100644 etc/shiftrc create mode 100755 perl/shift-aux create mode 100755 perl/shift-mgr create mode 100755 perl/shiftc diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..31aedc7 --- /dev/null +++ b/CHANGES @@ -0,0 +1,150 @@ +CHANGES +======= + +* Shift 3.0 (01/09/14) + - First public release + - Note that --no-offline is currently enabled by default due to + DMF corruption issues found when releasing files immediately + after they are copied + +* Shift 3.1 (01/13/14) + - Fixed bad metadata counts during --sync preventing dirs from completing + - Removed some site-specific config that was mistakenly included in shiftc + +* Shift 3.2 (02/07/14) + - Added note about mcp/msum >= 1.76.7 since earlier versions do not + support all required functionality + - Added warning message when --no-check option specified + - Fixed leftover temp files after --status + - Fixed hung transfers with one but not both of --no-check/--no-preserve + - Fixed not an array reference exception during some rsync scenarios + - Fixed use of undefined value exception during some tar scenarios + +* Shift 3.3 (10/15/14) + - Added file name to fish error messages + - Changed final file size checks to reread src size when dst size differs + - Changed status totals to use total+ instead of - during initialization + - Changed mkdir and dir chattr ops to be limited by --files setting + - Fixed tar file renaming when multiple unsplit tar files created via stdin + - Fixed remote tar extraction due to missing fields in shift-aux tar parsing + - Fixed parsing of @ in remote addresses (user name still dropped however) + - Fixed local lustre striping when stripes > 160 for lustre < 2.4 + - Fixed unescape of src for tar link validation + - Fixed display of ssize in --stats when --verify not used + - Fixed addition to meta file if --meta=0 specified + - Fixed reversion of metadata corruption after abrupt termination + - Fixed truncation of existing file during file corruption recovery + - Fixed possible truncation of directory prefix during tar creation + - Fixed writability check of remote files + - Fixed hang when getting striping of link to fifo (due to lfs bug) + +* Shift 3.4 (01/07/15) + - Added support for GNU long names/links during tar creation + - Added inclusion/exclusion of file names based on regular expressions + - Added --io[rw] and --net[rw] options to throttle by read/write only + - Added global throttling to throttle read/writes/both by fs/host/user + - Added --sync-fast to synchronize files without verifying integrity + - Added built-in metadata sync mechanism for improved scalability + - Added estimated time until completion in status + - Added ability to specify some transport options in manager config + - Added background spawn of dmget/dmput to avoid intermittent hangs + - Changed disk throttling based on high/low threshold for suspend/resume + - Fixed inadvertent tar file renaming when transfer completes with errors + - Fixed error parsing of mcp/msum based on coreutils 8.x + - Fixed table of contents truncation during remote tar creation + +* Shift 4.0 (07/23/15) + - Note that this version is not backward compatible with previous versions + - Added backgroundable, parallelizable, and restartable initialization + - Added --newer and --older options for incremental backups + - Added --preallocate option to preallocate files below given sparsity + - Added --no-verify to disable verification, which is now enabled by default + - Added preservation of extended attributes during non-tar transfers + - Added backoff to alternate transports/checksums during retries + - Added error handling when transfer metadata dir can't be created + - Added ability to use --state w/o --id for brief status of xfers in state + - Added situational attribute handling for optimized transfer initialization + - Added ability to specify default tar split size in manager config + - Changed handling of embedded modules to use App::FatPacker + - Changed detailed status to show source file during tar creation + - Changed intra-source symlink dereferencing due to initialization changes + (location of dereferenced links may differ depending on traversal order) + - Changed status output to omit some completed transfers beyond threshold + - Changed --meta manager option to require --id + - Fixed verification of files ending in whitespace + - Fixed time estimate to reflect mgr overhead, parallelism, and chattr speed + - Fixed sum handling of names containing trailing carriage returns + - Fixed handling of pathological umasks + - Fixed overrun of metadata directories when linux subdir limit reached + - Fixed automatic striping of tar files on lustre + - Fixed tar extraction of files with trailing spaces + - Fixed preservation of symlink times + - Fixed --no-cron propagation across parallel clients + - Fixed tar header validation of symlinks containing escaped characters + - Fixed bbftp inability to handle vt character + - Fixed rsync inability to handle cr/lf characters (due to --files-from) + - Fixed rsync unexpected rename behavior when one file in --files-from list + - Fixed fish handling of errors with linefeeds + - Removed --sync-fast since it is now equivalent to --sync --no-verify + - Removed file/dir meter during initialization since init now backgrounded + +* Shift 5.0 (07/12/16) + - Added better detection of lan transfers in stats + - Added error handling for malformed tar headers + - Added --buffer option to adjust buffer size used by underlying transports + - Added --streams option to adjust tcp streams used by tcp-based transports + - Added --window option to set tcp window size used by tcp-based transports + - Added --ports option to set the remote ports used by tcp-based transports + - Added --threads option to set number of threads used by local transports + - Added --bandwidth option to set bandwidth for stream/window calculation + - Added adjustment of tcp window/streams based on b/w heuristics and latency + - Added ability to set small file breakeven points for local/lan/wan cases + - Added minimum split setting to prevent file system overload with metadata + - Added rescan of mesh keys between batches to pick up newly generated keys + - Added support for bbcp as underlying transport + - Added support for all remote transports to be used as local transports + - Added manager setting for lustre default stripe count + - Added multi-threading of single/multi-file batches to built-in transports + - Added multi-threading of single/multi-file batches to built-in hashing + - Added multi-threaded tcp-based remote transport based on fish protocol + - Added support for --verify-fast during fish gets + - Added output across transfers of all users when --status invoked as root + - Added zero-padding to duration and estimated time when --status=pad used + - Changed status emails to limit length of original command sent + - Changed brief status so at least one completed transfer is always shown + - Changed --encrypt to --secure, which also changes ssh cipher/mac selection + - Changed dmput handling so -r is no longer used in automatic offlining + - Changed help output into functional units + - Changed external invocations to eliminate all extra shell processes + - Changed client selection to use selection hook instead of random policy + - Changed shift-aux sums so file issues are errors and not bad checksums + - Changed handling of estimated completion to reflect actual operation rates + - Changed extraction of tar files to remove relative path components + - Changed --stats output to omit rows without non-empty values + - Fixed gridftp support using unbuffer utility to interlace stderr/stdout + - Fixed umask for root transfers so won't inadvertently expose files + - Fixed status after --wait, which sometimes did not appear when redirected + - Fixed getting/setting of acls and xattrs on symlinks + - Fixed existence check of target path when using openssh 7.x + - Fixed infinite loop in built-in hashing when source file shrinks + - Fixed reported rate when operations report in after transfer stopped + - Fixed improper dst truncation in some non-tar corruption recovery cases + - Fixed infinite loop when extracting tar files less than 512 bytes + - Fixed host/process failures due to dmgets on every command line file + - Fixed --include/--exclude options to handle malformed regular expressions + - Fixed truncation of built-in local copies when dst larger than src + - Fixed toc file empty blocks of increasing size during split tar creation + - Fixed built-in hashing chopping off range when file has backslash/newline + - Fixed correction of corruption in multiple byte ranges during tar creation + - Fixed distribution of clients to remote hosts when more clients than hosts + - Fixed built-in transport detection when user $PATH is empty + - Fixed sum file rename when no regular files during tar creation + - Fixed -d with unwritable or trailing slash dst (bug report by J. Otey) + - Fixed exception in fish protocol when input stream is invalid + - Fixed transport selection order when first transport not suitable + - Fixed crontab handling with csh variants + - Fixed exception when fish input stream is unreadable + - Fixed mkdir errors during parallelization in some scenarios + - Fixed sum file rename when transfer w/o regular files grouped with regular + - Fixed abort due to embedded use of Time::HiRes in some perl versions + - Removed use of File::Copy for built-in local copies diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..6ee273e --- /dev/null +++ b/COPYING @@ -0,0 +1,256 @@ +NASA OPEN SOURCE AGREEMENT VERSION 1.3 + +THIS OPEN SOURCE AGREEMENT ("AGREEMENT") DEFINES THE RIGHTS OF USE, +REPRODUCTION, DISTRIBUTION, MODIFICATION AND REDISTRIBUTION OF CERTAIN +COMPUTER SOFTWARE ORIGINALLY RELEASED BY THE UNITED STATES GOVERNMENT +AS REPRESENTED BY THE GOVERNMENT AGENCY LISTED BELOW ("GOVERNMENT +AGENCY"). THE UNITED STATES GOVERNMENT, AS REPRESENTED BY GOVERNMENT +AGENCY, IS AN INTENDED THIRD-PARTY BENEFICIARY OF ALL SUBSEQUENT +DISTRIBUTIONS OR REDISTRIBUTIONS OF THE SUBJECT SOFTWARE. ANYONE WHO +USES, REPRODUCES, DISTRIBUTES, MODIFIES OR REDISTRIBUTES THE SUBJECT +SOFTWARE, AS DEFINED HEREIN, OR ANY PART THEREOF, IS, BY THAT ACTION, +ACCEPTING IN FULL THE RESPONSIBILITIES AND OBLIGATIONS CONTAINED IN +THIS AGREEMENT. + +Government Agency: + National Aeronautics and Space_Administration (NASA) +Government Agency Original Software Designation: + ARC-16940-1 +Government Agency Original Software Title: + Shift: Self-Healing Independent File Transfer +Government Agency Point of Contact for Original Software: + Paul Kolano (paul.kolano@nasa.gov). + +User Registration Requested. Please Visit http://opensource.arc.nasa.gov + + +1. DEFINITIONS + +A. "Contributor" means Government Agency, as the developer of the +Original Software, and any entity that makes a Modification. +B. "Covered Patents" mean patent claims licensable by a Contributor +that are necessarily infringed by the use or sale of its Modification +alone or when combined with the Subject Software. +C. "Display" means the showing of a copy of the Subject Software, +either directly or by means of an image, or any other device. +D. "Distribution" means conveyance or transfer of the Subject +Software, regardless of means, to another. +E. "Larger Work" means computer software that combines Subject +Software, or portions thereof, with software separate from the Subject +Software that is not governed by the terms of this Agreement. +F. "Modification" means any alteration of, including addition to or +deletion from, the substance or structure of either the Original +Software or Subject Software, and includes derivative works, as that +term is defined in the Copyright Statute, 17 USC 101. However, the +act of including Subject Software as part of a Larger Work does not in +and of itself constitute a Modification. +G. "Original Software" means the computer software first released +under this Agreement by Government Agency with Government Agency +designation ARC-16940-1 and entitled Shift: Self-Healing Independent +File Transfer, including source code, object code and accompanying +documentation, if any. +H. "Recipient" means anyone who acquires the Subject Software under +this Agreement, including all Contributors. +I. "Redistribution" means Distribution of the Subject Software after a +Modification has been made. +J. "Reproduction" means the making of a counterpart, image or copy of +the Subject Software. +K. "Sale" means the exchange of the Subject Software for money or +equivalent value. +L. "Subject Software" means the Original Software, Modifications, or +any respective parts thereof. +M. "Use" means the application or employment of the Subject Software +for any purpose. + + +2. GRANT OF RIGHTS + +A. Under Non-Patent Rights: Subject to the terms and conditions of +this Agreement, each Contributor, with respect to its own contribution +to the Subject Software, hereby grants to each Recipient a +non-exclusive, world-wide, royalty-free license to engage in the +following activities pertaining to the Subject Software: + +1. Use +2. Distribution +3. Reproduction +4. Modification +5. Redistribution +6. Display + +B. Under Patent Rights: Subject to the terms and conditions of this +Agreement, each Contributor, with respect to its own contribution to +the Subject Software, hereby grants to each Recipient under Covered +Patents a non-exclusive, world-wide, royalty-free license to engage in +the following activities pertaining to the Subject Software: + +1. Use +2. Distribution +3. Reproduction +4. Sale +5. Offer for Sale + +C. The rights granted under Paragraph B. also apply to the combination +of a Contributor's Modification and the Subject Software if, at the +time the Modification is added by the Contributor, the addition of +such Modification causes the combination to be covered by the Covered +Patents. It does not apply to any other combinations that include a +Modification. + +D. The rights granted in Paragraphs A. and B. allow the Recipient to +sublicense those same rights. Such sublicense must be under the same +terms and conditions of this Agreement. + + +3. OBLIGATIONS OF RECIPIENT + +A. Distribution or Redistribution of the Subject Software must be made +under this Agreement except for additions covered under paragraph 3H. + +1. Whenever a Recipient distributes or redistributes the Subject + Software, a copy of this Agreement must be included with each copy + of the Subject Software; and +2. If Recipient distributes or redistributes the Subject Software in + any form other than source code, Recipient must also make the + source code freely available, and must provide with each copy of + the Subject Software information on how to obtain the source code + in a reasonable manner on or through a medium customarily used for + software exchange. + +B. Each Recipient must ensure that the following copyright notice +appears prominently in the Subject Software: + +Copyright (C) 2012 United States Government as represented by the +Administrator of the National Aeronautics and Space Administration +(NASA). All Rights Reserved. + +C. Each Contributor must characterize its alteration of the Subject +Software as a Modification and must identify itself as the originator +of its Modification in a manner that reasonably allows subsequent +Recipients to identify the originator of the Modification. In +fulfillment of these requirements, Contributor must include a file +(e.g., a change log file) that describes the alterations made and the +date of the alterations, identifies Contributor as originator of the +alterations, and consents to characterization of the alterations as a +Modification, for example, by including a statement that the +Modification is derived, directly or indirectly, from Original +Software provided by Government Agency. Once consent is granted, it +may not thereafter be revoked. + +D. A Contributor may add its own copyright notice to the Subject +Software. Once a copyright notice has been added to the Subject +Software, a Recipient may not remove it without the express permission +of the Contributor who added the notice. + +E. A Recipient may not make any representation in the Subject Software +or in any promotional, advertising or other material that may be +construed as an endorsement by Government Agency or by any prior +Recipient of any product or service provided by Recipient, or that may +seek to obtain commercial advantage by the fact of Government Agency's +or a prior Recipient's participation in this Agreement. + +F. In an effort to track usage and maintain accurate records of the +Subject Software, each Recipient, upon receipt of the Subject +Software, is requested to register with Government Agency by visiting +the following website: http://opensource.arc.nasa.gov. Recipient's +name and personal information shall be used for statistical purposes +only. Once a Recipient makes a Modification available, it is requested +that the Recipient inform Government Agency at the web site provided +above how to access the Modification. + +G. Each Contributor represents that that its Modification is believed +to be Contributor's original creation and does not violate any +existing agreements, regulations, statutes or rules, and further that +Contributor has sufficient rights to grant the rights conveyed by this +Agreement. + +H. A Recipient may choose to offer, and to charge a fee for, warranty, +support, indemnity and/or liability obligations to one or more other +Recipients of the Subject Software. A Recipient may do so, however, +only on its own behalf and not on behalf of Government Agency or any +other Recipient. Such a Recipient must make it absolutely clear that +any such warranty, support, indemnity and/or liability obligation is +offered by that Recipient alone. Further, such Recipient agrees to +indemnify Government Agency and every other Recipient for any +liability incurred by them as a result of warranty, support, indemnity +and/or liability offered by such Recipient. + +I. A Recipient may create a Larger Work by combining Subject Software +with separate software not governed by the terms of this agreement and +distribute the Larger Work as a single product. In such case, the +Recipient must make sure Subject Software, or portions thereof, +included in the Larger Work is subject to this Agreement. + +J. Notwithstanding any provisions contained herein, Recipient is +hereby put on notice that export of any goods or technical data from +the United States may require some form of export license from the +U.S. Government. Failure to obtain necessary export licenses may +result in criminal liability under U.S. laws. Government Agency +neither represents that a license shall not be required nor that, if +required, it shall be issued. Nothing granted herein provides any +such export license. + + +4. DISCLAIMER OF WARRANTIES AND LIABILITIES; WAIVER AND INDEMNIFICATION + +A. No Warranty: 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." + +B. Waiver and Indemnity: 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. + + +5. GENERAL TERMS + +A. Termination: This Agreement and the rights granted hereunder will +terminate automatically if a Recipient fails to comply with these +terms and conditions, and fails to cure such noncompliance within +thirty (30) days of becoming aware of such noncompliance. Upon +termination, a Recipient agrees to immediately cease use and +distribution of the Subject Software. All sublicenses to the Subject +Software properly granted by the breaching Recipient shall survive any +such termination of this Agreement. + +B. Severability: If any provision of this Agreement is invalid or +unenforceable under applicable law, it shall not affect the validity +or enforceability of the remainder of the terms of this Agreement. + +C. Applicable Law: This Agreement shall be subject to United States +federal law only for all purposes, including, but not limited to, +determining the validity of this Agreement, the meaning of its +provisions and the rights, obligations and remedies of the parties. + +D. Entire Understanding: This Agreement constitutes the entire +understanding and agreement of the parties relating to release of the +Subject Software and may not be superseded, modified or amended except +by further written agreement duly executed by the parties. + +E. Binding Authority: By accepting and using the Subject Software +under this Agreement, a Recipient affirms its authority to bind the +Recipient to all terms and conditions of this Agreement and that that +Recipient hereby agrees to all terms and conditions herein. + +F. Point of Contact: Any Recipient contact with Government Agency is +to be directed to the designated representative as follows: +Paul Kolano (paul.kolano@nasa.gov). diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..173dc39 --- /dev/null +++ b/INSTALL @@ -0,0 +1,314 @@ +Shift Installation and Configuration +==================================== + +1. Deployments + + Shift consists of three executable components: + + o shiftc - the Shift client, which is invoked by users and other + client instances and must exist on hosts that initiate + transfers and hosts on which a transfer is to be + parallelized (henceforth called "client hosts") + + o shift-mgr - the Shift manager, which is invoked by client instances + and must exist either on all client hosts or on a host + accessible via ssh hostbased or pubkey authentication + (henceforth called "manager hosts") + + o shift-aux - the Shift auxiliary utility, which is invoked by client + instances and is optional for basic functionality, but + must be installed on any hosts accessed as the source or + destination of a transfer initiated from a different host + (henceforth called "remote hosts") for efficient remote + file initialization, higher speed transfers via the + built-in fish/fish-tcp protocols, remote acl/xattr + preservation, remote lustre striping, and remote + verification (if msum from mutil is not installed) + + The main consideration for a Shift deployment is deciding which hosts will + be the manager hosts. In the simplest case, all client hosts are manager + hosts. If there is more than one client host, then the manager must be + configured to store its metadata on a shared file system that supports + locking. + + In a more complex multi-user, multi-host environment without a shared file + system across all potential client hosts, one or more hosts must be + designated as manager hosts. Since the manager is not an active server + and is simply a passive executable invoked by clients, the manager can be + located on any host with ssh access. These hosts must support either + hostbased or pubkey authentication, however, since Shift is an automated + framework that performs actions without the user present. The manager has + a synchronization mechanism allowing multiple hosts without a shared file + system to be used for redundancy. + + +2. Prerequisites + + 2.1. Required + + o perl >= 5.8.5 (>= 5.10.1 is required for multi-threading support) + o ssh (and sftp) access to manager/remote hosts via hostbased or + pubkey authentication + + 2.2. Optional + + o mcp/msum >= 1.76.7 - high speed local copy/sum + (http://mutil.sf.net) + o bbcp - high speed remote copy + (http://www.slac.stanford.edu/~abh/bbcp) + o bbftp - high speed remote copy + (http://doc.in2p3.fr/bbftp) + o gridftp - high speed remote copy + (http://toolkit.globus.org/toolkit/data/gridftp) + o rsync - bandwidth-efficient local/remote copy + (http://rsync.samba.org) + o mesh - lightweight single sign-on via ssh pubkeys + (http://mesh.sf.net) + + 2.3. Invoked (standard on most systems or when specific file systems in use) + + o chown - change symlink ownership + o crontab - install cron jobs to recover from host/process failures + o df - get file system utilization + o dm{get,put} - recall and migrate DMF-managed files + o fallocate - preallocate files + o {get,set}facl - get and set file ACLs + o {get,set}fattr - get and set file extended attributes + o lfs - get and set Lustre striping + o lspci - find 10GE adapters + o mmlsmgr - get GPFS server information + o mount - get file system information + o ping - determine network latency + o ps - find clients and PBS processes, and determine client CPU load + o su - become non-root process to access manager during root transfers + o sysctl - determine number of cpus on BSD + o touch - change symlink modification time + o unbuffer - interleave stdout/stderr when using gridftp + + +3. Installation + + Note that the following shows the exact files needed on each type of host. + Since the number of files is small, however, there is minimal penalty to + simply installing them all on every host. + + 3.1. Single-user installation + + Note that the user's home directory is used as the default install + prefix in all examples, but can be changed to any other desired location + as long as the corresponding bin directory is in the user's path. + + 3.1.1. Client hosts + + install -m 700 perl/shiftc ~/bin/shiftc + install -m 600 doc/shiftc.1 ~/man/man1/shiftc.1 + + 3.1.2. Manager hosts + + install -m 700 perl/shift-mgr ~/bin/shift-mgr + install -m 600 etc/shiftrc ~/.shiftrc + + 3.1.3. Remote hosts (optional but recommended when possible) + + install -m 700 perl/shift-aux ~/bin/shift-aux + + 3.2. Multi-user installation + + Note that /usr/local is used as the default install prefix in all + examples, but can be changed to any other desired location as long + as the corresponding bin directory is in the default system path. + + 3.2.1. Client hosts + + install -m 755 perl/shiftc /usr/local/bin/shiftc + install -m 644 doc/shiftc.1 /usr/local/man/man1/shiftc.1 + + 3.2.2. Manager hosts + + install -m 755 perl/shift-mgr /usr/local/bin/shift-mgr + install -m 644 etc/shiftrc /etc/shiftrc + + 3.2.3. Remote hosts (optional but recommended when possible) + + install -m 755 perl/shift-aux /usr/local/bin/shift-aux + + +4. Configuration + + 4.1. Client hosts + + 4.1.1. ~/.ssh/id_rsa (or similar) + + If hostbased authentication is not supported by client hosts, + manager hosts, and/or remote hosts, pubkey authentication must be + used. Clients must have access to private keys to access these + systems, which may either be referenced explicitly via the + --mgr-identity and --identity options for manager and remote + hosts, respectively, or be added to an ssh agent on the client(s). + Note that the private keys used for these options must not be + protected by a passphrase. The use of an ssh agent to access + manager or remote hosts may be preferable from a security standpoint + but comes with a drop in reliability as any failure of the agent or + agent host leaves any associated transfers with no way to recover. + + 4.1.2. ~/.ssh/authorized_keys + + If hostbased authentication is not supported to other client hosts + for parallelization, pubkey authentication must be used. In this + case, the public key(s) corresponding to the private key(s) used by + clients (those named ~/.ssh/id* loaded into an ssh agent) must be + added to the invoking user's authorized_keys file on other client + hosts. + + 4.1.3. ~/bin/shiftc (single-user) or /usr/local/bin/shiftc (multi-user) + + If the manager hosts differ from the client hosts, the manager + host(s) can be hardcoded within the shiftc program in the + "site-specific options" section. This allows the client to be used + without specifying the --mgr option every time. For example, the + line: + + $opts{"mgr"} = "mgr.example.com"; + + would be equivalent to specifying the option "--mgr=mgr.example.com". + In general, any shiftc command-line option --X can be hardcoded using: + + $opts{"X"} = "hardcoded_value"; + + Those familiar with perl can add more complex logic (e.g. choosing + which manager host out of a set of hosts will be used for each + invocation). + + 4.2. Manager hosts + + 4.2.1. ~/.shiftrc (single-user) or /etc/shiftrc (multi-user) + + All items in the default config file should be reviewed. + The only required setting is: + + user_dir + + If there are multiple manager hosts, the configured directory must + either be a file system shared across all manager hosts that + supports file locking or the setting: + + sync_host + + must be configured to sync the transfer metadata across two + manager hosts. Note that the existing synchronization + mechanism has been found to be a bottleneck when there are + many clients in a single transfer or many simultaneous + transfers by a single user. This will be fixed in a future + version. + + The transport options should definitely be reviewed to + enable any higher performance transports that may be + available. Higher performance remote transports based on + TCP connections (fish-tcp) and SSH connections (fish) are + built-in, but require that the shift-aux executable exist + on remote hosts. Note that transports can be enabled on a + case-by-case basic using the client --local and --remote + options. + + To allow Shift to make parallelization decisions and enable + functionality specific to certain remote file systems (e.g. Lustre + striping), it is desirable to configure: + + db_file + + with a database of host and file system information from within + the local environment. A template for producing this database is + provided in the file "etc/shift-mounts.pl". After the items + indicated in the script are configured, it can be run + once/periodically to initialize/update the file system database. + + To optimize access to remote hosts on the LAN, the setting: + + select_hook + + may be configured to specify how remote hosts should be selected + when more than one is available. This may include deciding which + hosts are up, which are least loaded, which have the best + connectivity to the given client host, etc. A skeleton for a + suitable selection hook is provided in the file + "etc/shift-select.hook", but must be fleshed out based on + site-specific knowledge and/or calls to the local load balancing + infrastructure. If not configured, hosts will be chosen randomly + after a successful sshd ping test. + + 4.2.2. ~/.ssh/authorized_keys + + If hostbased authentication is not supported to manager hosts, + pubkey authentication must be used. In this case, the public key(s) + corresponding to the private key(s) used by clients (either loaded + into an ssh agent or specified via --mgr-identity) must be added to + the appropriate user's authorized_keys file on manager hosts. + This user will either be the invoking user or the one specified by + --mgr-user. + + + 4.3. Remote hosts + + 4.3.1. ~/.ssh/authorized_keys + + If hostbased authentication is not supported to remote hosts, pubkey + authentication must be used. In this case, the public key(s) + corresponding to the private key(s) used by clients (either loaded + into an ssh agent or specified via --identity) must be added to the + appropriate user's authorized_keys file on remote hosts. This user + will either be the invoking user or the one specified by --user. + + +5. Usage + + 5.1. shiftc + + Client usage is detailed in the man page "doc/shiftc.1", which can be + viewed with: + + nroff -man doc/shiftc.1 |less -r + + if not already in a manpath directory. Basic usage is drop-in + compatible with cp/scp with special consideration for the authentication + options --mgr, --mgr-identity, --mgr-user, --identity, and --user. + Note that the scp "user@host" syntax is not currently supported (the + "user@" portion will be dropped) so --user must be specified instead + when the remote user differs from the local user. + + 5.2. shift-mgr + + Normal users need not invoke shift-mgr directly as all relevant manager + functionality is accessed indirectly through the client. Additional + capabilities are available for administrators, however, to aid in + collecting usage stats and debugging information. Below is a sampling + of some of the most useful administrative shift-mgr commands. + + To see the status of a particular user X's transfers, run: + + shift-mgr --user=X --status + + To see the history of a particular user X's transfers, run: + + shift-mgr --user=X --history + + To see the status of running transfers across all users, run: + + shift-mgr --status --state=run + + To see detailed stats across the transfers of all users including a + sampling of error messages, run: + + shift-mgr --stats + + This can be added to a cron job (normally at the interval of the + "data_expire" setting in shiftrc) with a redirection to a file to + periodically save usage stats. + + To see the metadata associated with a given user X's transfer T, run: + + shift-mgr --user=X --id=T --meta + + The metadata is log structured, so it is also possible to view the + metadata at any number of steps S back in time using: + + shift-mgr --user=X --id=T --meta=S diff --git a/README.md b/README.md index c666c86..7c63ae6 100644 --- a/README.md +++ b/README.md @@ -1 +1,40 @@ -# shift \ No newline at end of file +Self-Healing Independent File Transfer (Shift) +============================================== + +In high-end computing environments, remote file transfers of very large data +sets to and from computational resources are commonplace as users are typically +widely distributed across different organizations and must transfer in data to +be processed and transfer out results for further analysis. Local transfers +of this same data across file systems are also frequently performed by +administrators to optimize resource utilization when new file systems come +on-line or storage becomes imbalanced between existing file systems. In both +cases, files must traverse many components on their journey from source to +destination where there are numerous opportunities for performance optimization +as well as failure. A number of tools exist for providing reliable and/or high +performance file transfer capabilities, but most either do not support local +transfers, require specific security models and/or transport applications, are +difficult for individual users to deploy, and/or are not fully optimized for +highest performance. + +Shift is a framework for Self-Healing Independent File Transfer that provides +high performance and resilience for local and remote transfers through a variety +of techniques. These include end-to-end integrity via cryptographic hashes, +throttling of transfers to prevent resource exhaustion, balancing transfers +across resources based on load and availability, and parallelization of +transfers across multiple source and destination hosts for increased redundancy +and performance. In addition, Shift was specifically designed to accommodate +the diverse heterogeneous environments of a widespread user base with minimal +assumptions about operating environments. In particular, Shift is unique in its +ability to provide advanced reliability and automatic single and multi-file +parallelization to any stock command-line transfer application while being +easily deployed by both individual users as well as entire organizations. + +For full details of the Shift architecture, see +https://pkolano.github.io/papers/resilience12.pdf. For installation +details, see "INSTALL". For usage details, see "doc/shiftc.1" (in man +page format, viewable with "nroff -man"). + +Questions, comments, fixes, and/or enhancements welcome. + +--Paul Kolano + diff --git a/doc/shiftc.1 b/doc/shiftc.1 new file mode 100644 index 0000000..8dd3d91 --- /dev/null +++ b/doc/shiftc.1 @@ -0,0 +1,950 @@ +.TH "shiftc" "1" "02 Dec 2015" "" "" +./"################################################################ +.SH "NAME" +./"################################################################ +\fBshiftc\fP \(em a high performance reliable file transfer tool +./"################################################################ +.SH "SYNOPSIS" +./"################################################################ +.nf +\fBshiftc\fP [OPTION]... SOURCE DEST +\fBshiftc\fP [OPTION]... SOURCE... DIRECTORY +\fBshiftc\fP [OPTION]... +.fi +.PP +Reliably transfer SOURCE to DEST, multiple SOURCE(s) to DIRECTORY, or +arbitrary SOURCE to DEST and/or SOURCE(s) to DIRECTORY combinations +read from stdin. By default, symbolic links to files on the command +line are followed, but symbolic links to directories are not (identical +to the default behavior of cp). +.PP +Local paths are specified normally. A path PATH on a remote host HOST +is specified using scp-style "HOST:PATH". Note that transfers between +two remote hosts are not supported. +./"################################################################ +.SH "DESCRIPTION" +./"################################################################ +.PP +shiftc is the client for Shift, which is a framework for +\fBS\fPelf-\fBH\fPealing \fBI\fPndependent \fBF\fPile \fBT\fPransfers. Shift +includes the following features, among others: +.IP - +support for local, LAN, and WAN transfers +.IP - +drop-in replacement for both cp and scp (basic options only) +.IP - +tracking of individual file operations with on-demand status +.IP - +transfer stop and restart +.IP - +email notification of completion, errors, and warnings +.IP - +local and remote tar creation/extraction +.IP - +rsync-like synchronization based on modification times and checksums +.IP - +integrity verification of transfers with partial retransfer/resum to +rectify corruption +.IP - +throttling based on local and remote resource utilization +.IP - +automatic retrieval and release of files residing on DMF-managed file +systems +.IP - +automatic striping of files transferred to Lustre file systems +.IP - +fully self-contained besides perl core and ssh +.IP - +automatic detection and selection of higher performance transports and +hash utilities when available including bbcp, bbftp, gridftp, mcp, +msum, and rsync +.IP - +automatic many-to-many parallelization of single and multi-file +transfers with file system equivalence detection and rewriting +.PP +To support these features, shiftc communicates with a manager component +that is responsible for tracking transfers and directing the client to +process batches of file operations and return the results. +./"################################################################ +.SH "OPTIONS SUMMARY" +./"################################################################ +The following options are available in shiftc. Defaults are shown in +brackets. Some options have short and long variants separated by +commas. The \(cq\&=\(cq\& for options that take a parameter is +optional; whitespace may be used instead. Detailed descriptions are +given in following sections. +.PP +.nf +\fBInitialization options (defaults in brackets):\fP +\-\-clients=NUM use at most NUM clients per host [1] +\-\-create\-tar create tar file of SOURCE(s) at DEST +\-L, \-\-dereference always follow symbolic links +\-d, \-\-directory create any missing parent directories +\-\-exclude=REGEX exclude files matching REGEX +\-\-extract\-tar extract tar file(s) at SOURCE to DEST +\-h, \-\-help help +\-\-host\-file=FILE parallelize transfer on hosts in FILE (one per line) +\-\-host\-list=LIST parallelize transfer on hosts in LIST +\-\-hosts=NUM parallelize transfer on at most NUM client hosts [1] +\-\-identity=FILE access remote systems with ssh identity in FILE +\-I, \-\-ignore\-times do not skip files that match size and time +\-\-include=REGEX include only files matching REGEX +\-\-index\-tar create table of contents during tar creation +\-\-newer=DATE include only files with mtime newer than DATE +\-P, \-\-no\-dereference never follow symbolic links +\-T, \-\-no\-target\-directory treat target as a normal file +\-\-older=DATE include only files with mtime older than DATE +\-\-ports=NUM1:NUM2 use ports NUM1\-NUM2 for remote TCP\-based transports +\-R, \-r, \-\-recursive copy directories recursively +\-\-secure encrypt data stream(s) and use secure ciphers/macs +\-\-sync synchronize files at destination +\-\-user=USER access remote systems as USER +\-\-wait block until transfer completes + (exit 0 = success, 1 = failure) +.PP +\fBFeature\-disablement options:\fP +\-\-no\-check do not check file existence/size (benchmarking only) +\-\-no\-cron do not recover from host/process failures via cron +\-\-no\-mail do not send status emails +\-\-no\-offline do not migrate DMF\-managed files after transfer +\-\-no\-preserve do not preserve times, mode, owner, acls, or xattrs +\-\-no\-verify do not verify/rectify integrity of destination files +.PP +\fBMonitoring/management options:\fP +\-\-history show list of transfer commands and origin host/dir +\-\-id=NUM use transfer identifier NUM for other commands +\-\-mgr=HOST set host of shift manager to HOST +\-\-mgr\-identity=FILE access manager host with ssh identity in FILE +\-\-mgr\-user=USER access manager host as USER +\-\-restart restart transfer with given \-\-id +\-\-search=REGEX show only status/history matching REGEX +\-\-state=STATE show status of only those operations in STATE + (STATE one of {done,error,none,queue,run,warn}) +\-\-stats show stats across all transfers +\-\-status[={csv,pad}] show brief status of all transfers +\-\-stop stop transfer with given \-\-id + or detailed status of transfer with given \-\-id +.PP +\fBTuning options (defaults in brackets):\fP +\-\-bandwidth=BITS tune TCP\-based transports based on BITS per second + (use suffix {k,m,g,t} for {Kb,Mb,Gb,Tb}) +\-\-buffer=SIZE use SIZE bytes for buffer in transports + (use suffix {k,m,g,t} for {KiB,MiB,GiB,TiB}) [4m] +\-\-files=COUNT process transfer in batches of COUNT files + (use suffix {k,m,b/g,t} for 1E{3,6,9,12}) [1k] +\-\-local=LIST set local transport mechanism to one of LIST + (LIST subset of {bbcp,bbftp,fish,fish-tcp,gridftp, + mcp,rsync,shift}) +\-\-preallocate=NUM preallocate files when sparsity under NUM percent +\-\-remote=LIST set remote transport mechanism to one of LIST + (LIST subset of {bbcp,bbftp,fish,fish-tcp,gridftp, + rsync,shift}) +\-\-retry=NUM retry failed operations up to NUM times [2] +\-\-size=SIZE process transfer in batches of SIZE bytes + (use suffix {k,m,g,t} for {KB,MB,GB,TB}) [4g] +\-\-split=SIZE parallelize single files using chunks of SIZE bytes + (use suffix {k,m,g,t} for {KiB,MiB,GiB,TiB}) [0] +\-\-split\-tar=SIZE create tar files of around SIZE bytes + (use suffix {k,m,g,t} for {KB,MB,GB,TB}) [500g] +\-\-streams=NUM use NUM streams in remote transports [4] +\-\-stripe=SIZE|NUM use 1 stripe per SIZE bytes or NUM stripes + (use suffix {k,m,g,t} for {KB,MB,GB,TB}) [1g] +\-\-threads=NUM use NUM threads in local transports [4] +\-\-verify\-fast verify faster but less safely by reusing src buffer +\-\-window=SIZE use SIZE bytes for window in TCP\-based transports + (use suffix {k,m,g,t} for {KB,MB,GB,TB}) [4m] +.PP +\fBThrottling options:\fP +\-\-cpu=NUM throttle local cpu usage at NUM % +\-\-disk=NUM1:NUM2 suspend/resume transfer when target NUM1%/NUM2% full +\-\-io=NUM throttle local i/o usage at NUM MB/s +\-\-ior=NUM throttle local i/o reads at NUM MB/s +\-\-iow=NUM throttle local i/o writes at NUM MB/s +\-\-net=NUM throttle local network usage at NUM MB/s +\-\-netr=NUM throttle local network reads at NUM MB/s +\-\-netw=NUM throttle local network writes at NUM MB/s +.fi +./"################################################################ +.SH "TRANSFER INITIALIZATION" +./"################################################################ +Transfers are initialized using syntax identical to cp/scp for +local/remote transfers, respectively. The most commonly used options +during initialization are listed below. +.IP "\fB\-\-clients=NUM\fP" +Parallelize the transfer by using additional clients on each host. If +the number given is one, no additional clients will be used. A number +greater than one will fork additional processes on each host to more +fully utilize system resources and increase transfer performance. +.IP "\fB\-\-create\-tar\fP" +Create a tar file of all sources at the destination, which must be a +non-existing file name. This option implies \fB\-\-recursive\fP and +\fB\-\-no\-offline\fP. By default, multiple tar files are created at +500 GB boundaries. The split size may be changed or splitting disabled +using the \fB\-\-split\-tar\fP option. The \fB\-\-index\-tar\fP option +may be used to produce a table of contents file for each tar file +created. Note that this option cannot be used with \fB\-\-sync\fP. +.IP "\fB\-L, \-\-dereference\fP" +Always follow symbolic links to both files and directories. Note that +this can result in file and directory duplication at the destination as +all symbolic links will become real files and directories. +.IP "\fB\-d, \-\-directory\fP" +Create any missing parent directories. This option allows files to be +transferred to a directory hierarchy that may not already exist, similar +to the \fB\-d\fP option of the "install" command. +.IP "\fB\-\-exclude=REGEX\fP" +Do not transfer source files matching the given regular expression. +Note that regular expressions must be given in Perl syntax (see +perlre(1) for details) and should be quoted on the command line when +including characters normally expanded by the shell (e.g. "*"). Shell +wildcard behavior can be approximated by using ".*" in place of "*". +.IP "\fB\-\-extract\-tar\fP" +Extract all source tar files to the destination, which must be an +existing directory or non-existing directory name. This option implies +\fB\-\-no\-offline\fP. Note that only tar archives in the POSIX ustar +format are supported, but GNU extensions for large uids, gids, file +sizes, and file names are handled appropriately. Also note that this +option cannot be used with \fB\-\-sync\fP. +.IP "\fB\-\-host\-file=FILE\fP" +Parallelize the transfer by using additional clients on the hosts +specified in the given file (one host name per line). This option +implies a \fB\-\-hosts\fP value equal to the number of hosts in the file +plus any additional hosts from the \fB\-\-host\-list\fP option. Less +hosts may be used by explicitly specifying a \fB\-\-hosts\fP value. +Note that the actual number of client hosts used will depend upon number +of hosts that have equivalent access to the source and/or destination +file systems. Within PBS job scripts, this option can be set to the +$PBS_NODEFILE variable to use all nodes of the job. +.IP "\fB\-\-host\-list=LIST\fP" +Parallelize the transfer by using additional clients on the hosts +specified in the given comma-separated list. This option implies a +\fB\-\-hosts\fP value equal to the number of hosts on the list plus any +additional hosts from the \fB\-\-host\-file\fP option. Less hosts may +be used by explicitly specifying a \fB\-\-hosts\fP value. Note that the +actual number of client hosts used will depend upon number of hosts that +have equivalent access to the source and/or destination file systems. +.IP "\fB\-\-hosts=NUM\fP" +Parallelize the transfer by using additional clients on at most the +given number of hosts. If the number given is one, no additional +client hosts will be used. A number greater than one enables automatic +transfer parallelization where additional clients may be invoked on +additional hosts to increase transfer performance. Note that the actual +number of client hosts used will depend upon the number of hosts for +which Shift has file system information and the number of hosts that +have equivalent access to the source and/or destination file systems. +Client hosts will be accessed as the current user with hostbased +authentication or an existing ssh agent that contains an ssh identity +from a file matching ~/.ssh/id*. +.IP "\fB\-\-identity=FILE\fP" +Authenticate to remote systems using the given ssh identity file. +The corresponding public key must reside in the appropriate user's +~/.ssh/authorized_keys file on the remote host. Note that only +identity files without passphrases are supported. If a passphrase is +required, an ssh agent may be used instead, but with a loss of +reliability. This option is not needed if the remote host accepts +hostbased authentication from client hosts. +.IP "\fB\-I, \-\-ignore\-times\fP" +By default, the \fB\-\-sync\fP option skips the processing of files +that have the same size and modification time at the source and +destination. This option specifies that files should always be +processed by checksum regardless of size and modification time. +.IP "\fB\-\-include=REGEX\fP" +Only transfer source files matching the given regular expression. +Note that regular expressions must be given in Perl syntax (see +perlre(1) for details) and should be quoted on the command line when +including characters normally expanded by the shell (e.g. "*"). Shell +wildcard behavior can be approximated by using ".*" in place of "*". +.IP "\fB\-\-index\-tar\fP" +Create a table of contents file for each tar file created with +\fB\-\-create\-tar\fP. The table of contents will show each file in the +tar file along with permissions, user/group ownership, and size. For a +tar file "file.tar", the table of contents will be named "file.tar.toc". +Unless the \fB\-\-no\-verify\fP option is used, a checksum file will +also be created named "file.tar.sum", which is suitable as input for +"msum --check-tree -c". Note that when \fB\-\-split\-tar\fP is used, +multiple table of contents and checksum files may be created. For each +split tar file "file.tar-i.tar", the table of contents will be named +"file.tar-i.tar.toc" and the checksum file will be named +"file.tar-i.tar.sum". +.IP "\fB\-\-newer=DATE\fP" +Only transfer source files whose modification time is newer (inclusive) +than the given date. Any date string supported by the Perl +Date::Parse module can be specified. Note that this option can be +combined with \fB\-\-older\fP to specify exact date ranges. +.IP "\fB\-P, \-\-no\-dereference\fP" +Never follow symbolic links to file or directories. Note that this +can result in broken links at the destination as files and directories +referenced by symbolic links that were not explicitly transferred or +implicitly transferred using \fB\-\-recursive\fP may not exist on the +target. +.IP "\fB\-T, \-\-no\-target\-directory\fP" +Do not treat the destination specially when it is a directory or a +symbolic link to a directory. This option can be used with recursive +transfers to copy a directory's contents into an existing directory +instead of into a new subdirectory beneath it as is done by default. +.IP "\fB\-\-older=DATE\fP" +Only transfer source files whose modification time is older than the +given date. Any date string supported by the Perl Date::Parse module +can be specified. Note that this option can be combined with +\fB\-\-newer\fP to specify exact date ranges. +.IP "\fB\-\-ports=NUM1:NUM2\fP" +Use ports from the range NUM1-NUM2 for the data streams of TCP-based +transports (currently, bbcp, bbftp, fish-tcp, and gridftp). All +connections originate from the client host so the given port range must +be allowed on the network path to the remote host and by the remote host +itself. +.IP "\fB\-R, \-r, \-\-recursive\fP" +Transfer directories recursively. This option implies +\fB\-\-no\-dereference\fP.Note that any symbolic links pointing +to directories given on the command line will be followed during +recursive transfers (identical to the default behavior of cp). +.IP "\fB\-\-secure\fP" +Encrypt data during remote transfers and use secure ciphers and MACs +with SSH-based tranports. Note that this option will, in most cases, +decrease performance as it eliminates some higher performance transports +and increases CPU utilization during SSH connections. +.IP "\fB\-\-sync\fP" +Synchronize files between the source and destination, similar to the +rsync command. By default, files that have the same size and +modification time at the source and destination will not be transferred. +If the size or modification time of a file differs between the two, the +contents of the file will be compared via checksum and any portions that +differ will be transferred to the destination. To skip the size and +modification time checks and always begin with the checksum stage, use +\fB\-I\fP or \fB\-\-ignore\-times\fP. If \fB\-\-no\-verify\fP is +specified, integrity verification is not performed, which will increase +performance when there are many files at the source that are not at +the destination but will decrease performance when there are large files +that have only small changes between the source and destination. +Setting \fB\-\-retry\fP to zero with this option can be used to show +which files differ without making any changes. Note that when syncing +directories, the destination should be specified as the parent of the +location where the source directory should be transferred to. Also note +that this option cannot be used with \fB\-\-create\-tar\fP or +\fB\-\-extract\-tar\fB. +.IP "\fB\-\-user=USER\fP" +Set the user that will be used to access remote systems. +.IP "\fB\-\-wait\fP" +Block until the transfer completes and print a summary of the transfer. +This option implies \fB\-\-no\-mail\fP. An exit value of 0 indicates +that the transfer has successfully completed while an exit value of 1 +indicates that the transfer has failed or that the waiting process was +terminated prematurely. +./"################################################################ +.SH "FEATURE DISABLEMENT +./"################################################################ +.IP "\fB\-\-no\-check\fP" +Disable file existence and size checks at the end of the transfer. +This option was included for benchmarking and completeness purposes +and is not recommended for general use. +.IP "\fB\-\-no\-cron\fP" +Do not attempt to recover from host/process failures via cron. Note +that when such a failure occurs, the transfer will become stuck in the +"run" state until stopped. +.IP "\fB\-\-no\-mail\fP" +Prevents sending of emails due to errors, warnings, or completion. +This option may be desirable when performing a large number of scripted +transfers. Note that equivalent transfer status and history information +can always be manually retrieved using \fB\-\-status\fP and +\fB\-\-history\fP, respectively. +.IP "\fB\-\-no\-offline\fP" +By default, files transferred to/from DMF-managed file systems will be +migrated to offline media as soon as the transfer completes. This +option specifies that files should not be migrated. Note that DMF may +still choose to migrate (and possibly release) files even when this +option is enabled. +.IP "\fB\-\-no\-preserve\fP" +By default, times, permissions, ownership, ACLs, and extended attributes +of transferred files and directories are preserved when possible. +This option specifies that these items should not be preserved. Note +that permissions may be left in various states depending on the invoking +user's umask and the transport utilized. In particular, read access at +the destination may be more permissive than read access at the source. +.IP "\fB\-\-no\-verify\fP" +By default, files are checksummed at the source and destination to +verify that they have not been corrupted and if corruption is detected, +the corrupted portion of the destination file is automatically corrected +using a partial transfer from the original source. This functionality +decreases the performance of transfers in proportion to the file size. +If assurance of integrity is not required, the \fB\-\-no\-verify\fP +option may be used to disable verification. +./"################################################################ +.SH "TRANSFER MONITORING AND MANAGEMENT +./"################################################################ +Once one or more transfers have been initialized, the user may view +transfer history, stop/restart transfers, and/or check transfer status +with the following options. +.IP "\fB\-\-history\fP" +Show a brief history of all transfers including the transfer identifier, +the origin host/directory and the original command. +.IP "\fB\-\-id=NUM\fP" +Specify the transfer identifier to be used with management and status +commands. +.IP "\fB\-\-mgr=HOST\fP" +Set the host that will be used to manage transfers. By default, this +host will be accessed as the current user with hostbased authentication +or an existing ssh agent. The user and/or identity used to access the +manager host may be changed with the \fB\-\-mgr\-user\fP and +\fB\-\-mgr\-identity\fP options, respectively. +.IP "\fB\-\-mgr\-identity=FILE\fP" +Authenticate to the manager host using the given ssh identity file. +The corresponding public key must reside in the appropriate user's +~/.ssh/authorized_keys file on the manager host. Note that only +identity files without passphrases are supported. If a passphrase is +required, an ssh agent may be used instead, but with a loss of +reliability. This option is not needed if the manager host accepts +hostbased authentication from client hosts. +.IP "\fB\-\-mgr\-user=USER\fP" +Set the user that will be used to access the manager host. Note that if +the transfer is initiated by root and \fB\-\-mgr\-identity\fP is not +specified, manager communication will be performed as the given user +so that user must be authorized to run processes locally. In +particular, care should be taken on PBS-controlled nodes, where the +given user should either own the node or be on the user exception list. +.IP "\fB\-\-restart\fP" +Restart the transfer associated with the given \fB\-\-id\fP that was +stopped due to unrecoverable errors or stopped explicitly via +\fB\-\-stop\fP. Note that transfers must be restarted on the original +client host or one that has equivalent file system access. A subset of +the available command-line options may be respecified during a restart +including \fB\-\-bandwidth\fP, \fB\-\-buffer\fP, \fB\-\-clients\fP, +\fB\-\-cpu\fP, \fB\-\-disk\fP, \fB\-\-files\fP, \fB\-\-host-file\fP, +\fB\-\-host-list\fP, \fB\-\-hosts\fP, \fB\-\-io\fP, \fB\-\-ior\fP, +\fB\-\-iow\fP, \fB\-\-local\fP, \fB\-\-net\fP, \fB\-\-netr\fP, +\fB\-\-netw\fP, \fB\-\-no\-cron\fP, \fB\-\-no\-mail\fP, +\fB\-\-no\-offline\fP, \fB\-\-ports\fP, \fB\-\-preallocate\fP, +\fB\-\-remote\fP, \fB\-\-retry\fP, \fB\-\-secure\fP, \fB\-\-size\fP, +\fB\-\-streams\fP, \fB\-\-stripe\fP, \fB\-\-threads\fP, and \fB\-\-window\fP. +.IP "\fB\-\-search=REGEX\fP" +When \fB\-\-status\fP and \fB\-\-id\fP are specified, this option will +show the full status of file operations in the associated transfer whose +source or destination file name match the given regular expression. +.IP +When \fB\-\-history\fP is specified, this option will show a brief +history of the transfers whose origin host or original command match the +given regular expression. +.IP +Note that regular expressions must be given in Perl syntax (see +perlre(1) for details). +.IP "\fB\-\-state=STATE\fP" +When \fB\-\-status\fP and \fB\-\-id\fP are specified, this option will +show the full status of file operations in the associated transfer that +have the given state. When \fB\-\-id\fP is not specified, this option +will show the brief status of transfers in the given state. Valid +states are done, error, none, queue, run, and warn. A state of "none" +will show a summary of the given transfer. +.IP "\fB\-\-stats\fP" +Show stats across all transfers including transfer counts, rates, tool +usage, initialization options, error counts, and error messages. +.IP "\fB\-\-status[={csv,pad}]\fP" +Show a brief status of all transfers including the transfer identifier, +the current state, the number of directories completed, the number of +files transferred, the number of files checksummed, the number of +attributes preserved, the amount of data transferred, the amount of data +checksummed, the time the transfer started, the duration of the +transfer, the estimated time remaining in the transfer, and the rate of +the transfer. When the number of transfers exceeds a set threshold (20 +by default), older successfully completed transfers beyond that limit +will be omitted for readability. These omitted transfers can be shown +using \fB\-\-status\fP with \fB\-\-state=done\fP. Status will be +returned in CSV format when \fB\-\-status=csv\fP is specified. Duration +and estimated time will be zero-padded when \fB\-\-status=pad\fP is +specified. +.IP +When \fB\-\-id\fP is specified, this option will show the full status of +every file operation in the associated transfer. For each operation, +this includes the state, the type, the tool used for processing, the +target path, associated information (error messages, checksums, byte +ranges, and/or running host) when applicable, the size of the file, +the time processing started, and the rate of the operation. Note that +not all of these items will be applicable at all times (e.g. rate will +be empty if the state is error). Also note that operations are +processed in batches so the rate shown for a single operation will +depend on the other operations processed in the same batch. +.IP "\fB\-\-stop\fP" +Stop the transfer associated with the given \fB\-\-id\fP. Note that +transfer operations currently in progress will run to completion but new +operations will not be processed. Stopped transfers may be restarted +with \fB\-\-restart\fP. +./"################################################################ +.SH "TRANSFER TUNING" +./"################################################################ +Some advanced options are available to tune various aspects of shiftc +behavior. These options are not needed by most users. +.IP "\fB\-\-bandwidth=BITS\fP" +Choose the TCP window size and number of TCP streams of TCP-based +transports (currently, bbcp, bbftp, fish-tcp, and gridftp) based on +the given bits per second. The suffixes k, m, g, and t may be used for +Kb, Mb, Gb, and Tb, respectively. The default bandwidth is estimated to +be 10 Gb/s if a 10 GE adapter is found on the client host, 1 Gb/s if the +client host can be resolved to an organization domain (by default, one +of the six original generic top-level domains), and 100 Mb/s otherwise. +.IP "\fB\-\-buffer=SIZE\fP" +Use memory buffer(s) of the given size when configurable in the +underlying tranport being utilized (currently, all but rsync). The +suffixes k, m, g, and t may be used for KiB, MiB, GiB, and TiB, +respectively. The default buffer size is 4 MiB. Increasing the +buffer size trades higher memory utilization for more efficient I/O. +.IP "\fB\-\-files=COUNT\fP" +Process transfers in batches of the given number of files. The +suffixes k, m, b or g, and t may be used for 1E3, 1E6, 1E9, and 1E12, +respectively. The default batch count is 1000 files. Lowering the +batch count will increase the number of checkpoints and the overhead of +transfer management. Raising the batch count will have the opposite +effect. A batch will be sent for processing when the number of files in +the batch reaches the given value. Note that batches of less than the +given count can occur if the batch size specified by \fB\-\-size\fP is +reached first. +.IP "\fB\-\-local=LIST\fP" +Specify one or more local transports to be used for the transfer in +order of preference, separated by commas. Valid transports for this +option currently include bbcp, bbftp, cp, fish, fish-tcp, gridftp, +mcp, and rsync. Note that the given transport(s) will be given +priority, but may not be used in some cases (e.g. rsync is not capable +of transferring a specific portion of a file as needed by verification +mode). In such cases, the default transport based on File::Copy will be +used. The tool actually used for each file operation can be shown using +\fB\-\-status\fP with \fB\-\-id\fP set to the given transfer identifier. +.IP "\fB\-\-preallocate=NUM\fP" +Preallocate files when their sparsity is under the given percent, where +sparsity is defined as the number of bytes a file takes up on disk +divided by its size. Note that this option will only have an effect +when the fallocate command is available, the destination file does not +already exist, and the target file system properly supports fallocate's +-n option. Also note that this option will not function properly when +either bbftp or rsync (to a DMF file system) is utilized as the +transport due to their use of temporary files. +.IP "\fB\-\-remote=LIST\fP" +Specify one or more remote transports to be used for the transfer in +order of preference, separated by commas. Valid transports for this +option currently include bbcp, bbftp, fish, fish-tcp, gridftp, rsync, +and sftp. Note that the given transport(s) will be given priority, but +may not be used in some cases (e.g. bbftp is not capable of transferring +files with spaces in their names and is also incompatible with +\fB\-\-secure\fP). In such cases, the default transport based on sftp +will be used. The tool actually used for each file operation can be +shown using \fB\-\-status\fP with \fB\-\-id\fP set to the given transfer +identifier. +.IP "\fB\-\-retry=NUM\fP" +Retry operations deemed recoverable up to the given number of attempts +per file. The default number of retries is 2. A value of zero disables +retries. Note that disabling retries also disables the ability of +\fB\-\-sync\fP to change file contents. Also note that the given +value is cumulative across all stages of a file's processing so +different stages may not be retried the same number of times. +.IP "\fB\-\-size=SIZE\fP" +Process transfers in batches of approximately the given total file size. +The suffixes k, m, g, and t may be used for KB, MB, GB, and TB, +respectively. The default batch size is 4 GB. Lowering the batch size +will increase the number of checkpoints and the overhead of transfer +management. Raising the batch size will have the opposite effect. A +batch will be sent for processing when the total size of all files in +the batch reaches the given value. Note that batches of less than the +given size can occur if the batch count specified by \fB\-\-files\fP +is reached first. +.IP "\fB\-\-split=SIZE\fP" +Parallelize the processing of single files using chunks of the given +size. The suffixes k, m, g, and t may be used for KB, MB, GB, and TB, +respectively. The default split size is zero, which disables single +file parallelization. A split size of less than 1 GB is not +recommended. Lowering the split size will increase parallelism but +decrease the performance of each file chunk and increase the overhead of +transfer management. Raising the split size will have the opposite +effect. The ideal split size for a given file is the size of the file +divided by the number of concurrent clients available. Note that this +option does not have an effect unless \fB\-\-hosts\fP is greater than +one. Also note that this option can, in some cases, decrease remote +transfer performance as it eliminates some higher performance +transports. +.IP "\fB\-\-split\-tar=SIZE\fP" +Create tar files of around the given size when used with +\fB\-\-create\-tar\fP. When multiple tar files are created for a +destination tar file "file.tar", the resulting split tar files will be +named "file.tar-i.tar" starting from "file.tar-1.tar". The suffixes k, +m, g, and t may be used for KB, MB, GB, and TB, respectively. The +default split tar size is 500 GB. A value of zero disables splitting. +A split tar size of greater than 2 TB is not recommended. Note that +resulting tar files may still be larger than specified when source files +exist that are larger than the given size. +.IP "\fB\-\-streams=NUM\fP" +Use the given number of TCP streams in TCP-based transports (currently, +bbcp, bbftp, fish-tcp, and gridftp). The default is the number of +streams necessary to fully utilize the specified/estimated bandwidth +using the maximum TCP window size. Note that it is usually preferable +to specify \fB\-\-bandwidth\fP, which allows an appropriate number of +streams to be set automatically. Increasing the number of streams can +increase performance when the maximum window size is set too low or +there is cross-traffic on the network, but too high a value can decrease +performance due to increased congestion and packet loss. +.IP "\fB\-\-stripe=SIZE|NUM\fP" +By default, a file transferred to a Lustre file system will be striped +according to size (one stripe per GB) unless the source resides on +Lustre and has non-default striping, in which case striping will be +preserved. Directory striping is preserved when applicable. If a +positive number is specified, the stripe count of all destination files +and directories will be set to the given value. If the given value is a +size (specified with the suffixes k, m, g, and t for KB, MB, GB, and TB, +respectively), files will be allocated one stripe per given size while +directories will be striped according to the default policy. A value of +zero disables automatic striping and uses the default policy for all +files and directories. +.IP "\fB\-\-threads=NUM\fP" +Use the given number of threads in multi-threaded transports and +checksum utilities (currently, mcp and msum). The default number of +threads is 4. Increasing the number of threads can increase +transfer/checksum performance when a host has excess resource capacity, +but can reduce performance when any associated resource has reached +its maximum. +.IP "\fB\-\-verify\-fast\fP" +Checksum files at the source and destination to verify that they have +not been corrupted. If corruption is detected in a file, the corrupted +portion will be automatically corrected using a partial transfer. This +option differs from the default verification in that the source buffer +will be reused when possible for the source checksum calculations. This +potentially increases performance up to 33%, but is more subject to +corruption as the source is only read once. +.IP "\fB\-\-window=SIZE\fP" +Use a TCP send/receive window of the given size in TCP-based transports +(currently, bbcp, bbftp, fish-tcp, and gridftp). The suffixes k, m, +g, and t may be used for KB, MB, GB, and TB, respectively. The default +is the product of the specified/estimated bandwidth and the round-trip +time between source and destination. Note that it is usually preferable +to specify \fB\-\-bandwidth\fP, which allows an appropriate window size +to be set automatically. Increasing the window size allows TCP to +operate more efficiently over high bandwidth and/or high latency +networks, but too high a value can overrun the receiver and cause packet +loss. +./"################################################################ +.SH "TRANSFER THROTTLING" +./"################################################################ +.IP "\fB\-\-cpu=NUM\fP" +Throttle the transfer when the local CPU usage reaches the specified +percent of the total available. This option is disabled by default but +may be desirable to prevent transfers from consuming too much of the +local CPU. Once the given threshold is reached, a sleep period will +be induced between each batch of files to achieve an average CPU +utilization equal to the value specified. Note that this functionality +is currently only supported on Unix-like systems. +.IP "\fB\-\-disk=NUM1:NUM2\fP" +Suspend/resume the transfer when the target file system disk usage +reaches the specified percent of the total available. This option is +disabled by default but may be desirable to prevent transfers from +consuming too much local or remote disk space. Once the first +threshold is reached, the transfer will suspend until enough disk +resources have been freed on the target to bring the disk utilization +under the second threshold. Note that this functionality is currently +only supported on Unix-like systems. +.IP "\fB\-\-io=NUM\fP" +Throttle the transfer when the local I/O usage reaches the specified +rate in MB/s. This option is disabled by default but may be desirable +to prevent transfers from consuming too much of the local I/O bandwidth. +Once the given threshold is reached, a sleep period will be induced +between each batch of files to achieve an average I/O rate equal to +the value specified. +.IP "\fB\-\-ior=NUM\fP" +Throttle the transfer when the local I/O reads reach the specified +rate in MB/s. This option is similar to \fB\-\-io\fP but only applies +to reads. +.IP "\fB\-\-iow=NUM\fP" +Throttle the transfer when the local I/O writes reach the specified +rate in MB/s. This option is similar to \fB\-\-io\fP but only applies +to writes. +.IP "\fB\-\-net=NUM\fP" +Throttle the transfer when the local network usage reaches the specified +rate in MB/s. This option is disabled by default but may be desirable +to prevent transfers from consuming too much of the local network +bandwidth. Once the given threshold is reached, a sleep period will be +induced between each batch of files to achieve an average network rate +equal to the value specified. +.IP "\fB\-\-netr=NUM\fP" +Throttle the transfer when the local network reads reach the specified +rate in MB/s. This option is similar to \fB\-\-net\fP but only applies +to reads. +.IP "\fB\-\-netw=NUM\fP" +Throttle the transfer when the local network writes reach the specified +rate in MB/s. This option is similar to \fB\-\-net\fP but only applies +to writes. +./"################################################################ +.SH "EXAMPLES" +./"################################################################ +Copy local file "file1" in the current directory to existing local +directory "/dir1": +.PP +.RS +.nf +\fBshiftc file1 /dir1\fP + +Shift id is 1 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Copy local file "file1" in the current directory to the user's home +directory on host "host2" while preserving file attributes: +.PP +.RS +.nf +\fBshiftc -p file1 host2:\fP + +Shift id is 2 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Recursively copy local directory "/dir1" to local directory "/dir2" +and skip verifying that the contents have not been corrupted during the +transfer: +.PP +.RS +.nf +\fBshiftc -r --no-verify /dir1 /dir2\fP + +Shift id is 3 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Recursively copy remote directory "/dir2" on host "host2" to the current +directory using a secure transport: +.PP +.RS +.nf +\fBshiftc -r --secure host2:/dir2 .\fP + +Shift id is 4 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Recursively copy local directory "/bigdir1" to local directory +"/bigdir2" using 4 client hosts to perform the transfer. +.PP +.RS +.nf +\fBshiftc -r --hosts=4 /bigdir1 /bigdir2\fP + +Shift id is 5 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Show the status of all transfers: +.PP +.RS +.nf +\fBshiftc --status\fP + +id | state | dirs | files | file size | date | length | rate + | | sums | attrs | sum size | time | | +---+-------+------+-------+---------------+-------+--------+--------- + 1 | done | 0/0 | 1/1 | 92KB/92KB | 10/03 | 2s | 46KB/s + | | 0/0 | 0/0 | 0.0B/0.0B | 17:06 | | + 2 | done | 0/0 | 1/1 | 92KB/92KB | 10/03 | 8s | 11.5KB/s + | | 0/0 | 1/1 | 0.0B/0.0B | 17:06 | | + 3 | done | 1/1 | 2/2 | 99KB/99KB | 10/03 | 1s | 99KB/s + | | 4/4 | 0/0 | 198KB/198KB | 17:07 | | + 4 | error | 1/1 | 1/2 | 92KB/99KB | 10/03 | 3s | 30.7KB/s + | | 0/0 | 0/0 | 0.0B/0.0B | 17:08 | | + 5 | done | 1/1 | 64/64 | 65.5GB/65.5GB | 10/03 | 29s | 2.26GB/s + | | 0/0 | 0/0 | 0.0B/0.0B | 17:09 | | +.fi +.RE +.PP +Show the detailed status of all operations in transfer #2: +.PP +.RS +.nf +\fBshiftc --status --id=2\fP + +state | op | target | size | date | length | rate + | tool | info | | time | | +------+--------+-------------------------+------+-------+--------+------- +done | cp | host2:/home/user1/file1 | 92KB | 10/03 | 5s | 18KB/s + | bbftp | - | | 17:06 | | +done | chattr | host2:/home/user1/file1 | - | 10/03 | 1s | - + | sftp | - | | 17:06 | | +.fi +.RE +.PP +Show the detailed status of all operations in transfer #4 that have an +error state: +.PP +.RS +.nf +\fBshiftc --status --id=4 --state=error\fP + +state | op | target | size | date | length | rate + | tool | info | | time | | +------+-------+-------------------+------+------+--------+----- +error | cp | /tmp/dir2/file2 | 7KB | - | - | - + | rsync | rsync: send_files | | | | + | | failed to open | | | | + | | "/dir2/file2": | | | | + | | Permission denied | | | | +.fi +.RE +.PP +Show the detailed status of all operations in transfer #3 that involve a +file name containing "file2": +.PP +.RS +.nf +\fBshiftc --status --id=3 --search=file2\fP + +state | op | target | size | date | length | rate + | tool | info | | time | | +------+-------+-------------+------+-------+--------+------ +done | cp | /dir2/file2 | 7KB | 10/03 | 1s | 7KB/s + | mcp | - | | 17:07 | | +done | cksum | /dir2/file2 | 7KB | 10/03 | 1s | 7KB/s + | msum | - | | 17:07 | | +.fi +.RE +.PP +Show the history of all transfers: +.PP +.RS +.nf +\fBshiftc --history\fP + +id | origin | command +---+---------------+-------------------------------------- + 1 | host1.domain | shiftc file1 /dir1 + | [/home/user1] | + 2 | host1.domain | shiftc -p file1 host2: + | [/home/user1] | + 3 | host1.domain | shiftc -r --no-verify /dir1 /dir2 + | [/home/user1] | + 4 | host1.domain | shiftc -r --secure host2:/dir2 . + | [/tmp] | + 5 | host1.domain | shiftc -r --hosts=4 /bigdir1 /bigdir2 + | [/home/user1] | +.fi +.RE +.PP +Show the history of all transfers that involve a host or a command +containing "host2": +.PP +.RS +.nf +\fBshiftc --history --search=host2\fP + +id | origin | command +---+---------------+---------------------------------- + 2 | host1.domain | shiftc -p file1 host2: + | [/home/user1] | + 4 | host1.domain | shiftc -r --secure host2:/dir2 . + | [/tmp] | +.fi +.RE +.PP +Create a tar file "bigdir1.tar" in the current directory that consists +of the contents of "/bigdir1" with a corresponding table of contents +stored in "bigdir1.tar.toc" in the current directory: +.PP +.RS +.nf +\fBshiftc --create-tar --index-tar /bigdir1 bigdir1.tar\fP + +Shift id is 6 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Create tar files prefixed with "bd1.tar" in the remote directory +"/dir2" on host "host2" that consist of the contents of "/bigdir1", +split at 16 GB boundaries: +.PP +.RS +.nf +\fBshiftc --create-tar --split-tar=16g /bigdir1 host2:/dir2/bd1.tar\fP + +Shift id is 7 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Extract the split tar files prefixed with "bd1.tar" in the remote +directory "/dir2" on host "host2" to the current directory: +.PP +.RS +.nf +\fBshiftc --extract-tar host2:'/dir2/bd1.*tar' .\fP + +Shift id is 8 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Sychronize the local directory "/dir1" with the remote directory +"/dir2/dir1" on host "host2" while waiting for completion: +.PP +.RS +.nf +\fBshiftc -r --sync --wait /dir1 host2:/dir2\fP + +Shift id is 9 +Detaching process (use --status option to monitor progress) +Waiting for transfer to complete... + +id | state | dirs | files | file size | date | length | rate + | | sums | attrs | sum size | time | | +---+-------+------+-------+---------------+-------+--------+------- + 9 | done | 1/1 | 2/2 | 99KB/99KB | 10/03 | 5s | 18KB/s + | | 4/4 | 3/3 | 198KB/198KB | 17:14 | | +.fi +.RE +.PP +Recursively copy local directory "/bigdir1" to local directory +"/bigdir2" but exclude files ending in ".log". +.PP +.RS +.nf +\fBshiftc -r --exclude='\\.log$' /bigdir1 /bigdir2\fP + +Shift id is 10 +Detaching process (use --status option to monitor progress) +.fi +.RE +.PP +Extract the files "1g.20" through "1g.29" from "bigdir.tar" to the +current directory: +.PP +.RS +.nf +\fBshiftc --extract-tar --include='1g\\.2[0-9]' bigdir1.tar .\fP + +Shift id is 11 +Detaching process (use --status option to monitor progress) +.fi +.RE +./"################################################################ +.SH "NOTES" +Transfers of files from DMF-managed file systems can take significantly +longer than other transfers as files may need to be retrieved from +tertiary storage before they can be copied. +./"################################################################ +./"################################################################ +.SH "EXIT STATUS" +./"################################################################ +shiftc exits with 0 on success or >0 if an error occurs. +./"################################################################ +.SH "FILES" +./"################################################################ +/var/spool/cron/tabs/$USER +.RS +An entry is added into the user's crontab on each client host on which +a given transfer is being processed unless \fB\-\-no\-cron\fP is +specified. This entry periodically invokes the client with specific +arguments to check if the original client is still running. If so, the +manager is notified that the transfer is still in progress. If not, the +cron-invoked client will take over transfer processing. +.RE +./"################################################################ +.SH "AUTHOR" +./"################################################################ +shiftc was written by Paul Kolano. +./"################################################################ +.SH "SEE ALSO" +./"################################################################ +bbcp(1), bbftp(1), cp(1), Date::Parse(3), globus-url-copy(1), mcp(1), +msum(1), perlre(1), rsync(1), scp(1), sftp(1) diff --git a/etc/shift-mounts.pl b/etc/shift-mounts.pl new file mode 100755 index 0000000..cc734f9 --- /dev/null +++ b/etc/shift-mounts.pl @@ -0,0 +1,72 @@ +#!/usr/bin/perl -T + +# This program is a template that can be used to periodically collect file +# system information for Shift, which is used to determine file system +# equivalence for client spawns and transfer load balancing. + +use strict; +use File::Temp; +use POSIX qw(setuid); + +our $VERSION = 0.06; + +# untaint PATH +$ENV{PATH} = "/bin:/usr/bin:/usr/local/bin"; + +############################ +#### begin config items #### +############################ + +# user to use for ssh +# (it is assumed this script will be invoked from root's crontab) +my $user = "someuser"; + +# set of hosts to collect mount information from +# (it is assumed hostbased authentication can be used to reach all hosts) +# (it is assumed shift-aux is in the default path on all hosts) +my @hosts = qw( + host1 host2 ... hostN +); + +# host where manager invoked +# (it is assumed hostbased authentication can be used to reach this host) +# (it is assumed shift-mgr is in the default path on this host) +my $mgr = "somehost"; + +########################## +#### end config items #### +########################## + +# drop privileges and become defined user +my $uid = getpwnam($user); +setuid($uid) if (defined $uid); +die "Unable to setuid to $user\n" + if (!defined $uid || $< != $uid || $> != $uid); + +# create temporary file (automatically unlinked on exit) +my $tmp = File::Temp->new; +my $file = $tmp->filename; +close $tmp; + +# gather info from all hosts +foreach my $host (@hosts) { + open(TMP, ">>$file"); + # use shift-aux to collect mount information and append to file + open(FILE, "ssh -aqx -oHostBasedAuthentication=yes -oBatchMode=yes -l $user $host shift-aux mount |"); + while () { + # print once for fully qualified host + print TMP $_; + # ignore shell line for plain host + next if (!/^args=/ || /^args=shell/); + # replace fully qualified host with plain host + s/(host=$host)\.\S+/$1/; + # duplicate line for plain host + print TMP $_; + } + close FILE; + close TMP; +} + +# call shift-mgr to add collected info to global database +system("ssh -aqx -oHostBasedAuthentication=yes -oBatchMode=yes -l $user $mgr shift-mgr --mounts < $file"); + diff --git a/etc/shift-select.hook b/etc/shift-select.hook new file mode 100755 index 0000000..d7e01aa --- /dev/null +++ b/etc/shift-select.hook @@ -0,0 +1,35 @@ +#!/usr/bin/perl -T + +# This is a skeleton for a script that can be used in the shiftrc +# select_hook setting, which chooses a remote host given the local +# client host, the original remote host, and a Storable file mapping +# candidate host names to the relevant file system information for +# each. The file system information is in hash format, with contents +# similar to the following: +# +# host => host23.example.com +# local => /home1 +# opts => rw +# remote => /mnt/home1 +# servers => nfsserver1.example.com +# type => nfs + +use strict; +use Storable qw(retrieve); + +# untaint path +$ENV{PATH} = "/bin:/usr/bin:/usr/local/bin"; + +exit if (scalar(@ARGV) != 3 || ! -f $ARGV[2]); +my $lhost = $ARGV[0]; +my $rhost = $ARGV[1]; +my %hosts = %{retrieve($ARGV[2])}; + +# do something to decide which host(s) of keys(%hosts) is best/least loaded, +# which might involve calls to the local load balancing infrastruture, +# and/or site-specific knowledge of which hosts have best connectivity +# (either in general or to the given local host) + +# print a set of comma-separated host names of the best choices or +# print nothing to revert to default policy + diff --git a/etc/shiftrc b/etc/shiftrc new file mode 100644 index 0000000..8dde734 --- /dev/null +++ b/etc/shiftrc @@ -0,0 +1,357 @@ +# +# Skeleton configuration file for Shift manager. +# +# This file should be located in /etc/shiftrc for multi-user installs +# and in ~/.shiftrc for single-user installs. +# +# Items that are commented out show the default value. +# +# A value of nodefault indicates no default value for that item. +# +# Items that are not commented out indicate values that must be +# explicitly configured. The values given for these items are +# examples only. +# + +######################### +#### manager options #### +######################### + +# directory where transfer metadata will be stored +# (use %u as substitution for user name) +# (parent dir must be world writable with sticky bit for multi-user installs) +# (multi-user example: user_dir /var/lib/shift/%u) +user_dir /home/%u/.shift + +# time (seconds) to store transfer metadata after last activity +#data_expire 604800 + +# location of file system information database +# (must be world readable for multi-user installs) +# (example: db_file /var/lib/shift/db) +#db_file nodefault + +# log debugging information for user X in user_dir/X.debug +# (may be specified multiple times for different users) +# (example: debug_alice 1) +#debug_X 1 + +# domain to which user accounts belong for email notifications +# (assumes user X can receive email at X@email_domain) +# (assumes localhost:25 SMTP server running on manager host) +# (example: email_domain example.com) +#email_domain nodefault + +# command to invoke to make host selection decisions +# (must be world readable/executable for multi-user installs) +# (example: select_hook /usr/local/bin/shift-select.hook) +#select_hook nodefault + +# host to which transfer metadata should be synchronized +# (assumes hostbased authentication available to host) +# (example: sync_host mgr2.example.com) +#sync_host nodefault + + +########################### +#### transport options #### +########################### + +# supported local transports by decreasing performance/preference +# (example: default_local mcp,rsync,shift) +#default_local fish,shift + +# supported remote transports by decreasing performance/preference +# (example: default_remote fish-tcp,bbftp,rsync,fish,shift) +#default_remote shift + +# supported local transports by decreasing small file performance/preference +# (example: local_small mcp,rsync,shift) +#local_small fish,shift + +# minimum size allowed for --split and --split-tar options +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +# (it is not recommended to set this below 1GB) +#min_split 1g + +# command-line options that will be used by bbcp on client hosts +# (example: opts_bbcp -s 4 -w 4194304) +#opts_bbcp nodefault + +# behavior commands that will be used by bbftp on client hosts +# (see the "behavior commands" section of bbftp man page for details) +# (options must be separated by "\n" as shown in example below) +# (example: opts_bbftp setnbstream 4\nsetrecvwinsize 4096\nsetsendwinsize 4096) +#opts_bbftp nodefault + +# command-line options that will be used by globus-url-copy on client hosts +# (example: opts_gridftp -p 4 -tcp-bs 4194304) +#opts_gridftp nodefault + +# command-line options that will be used by mcp on client hosts +# (if mcp >= 1.822.1, a --preallocate setting is recommended for DMF on CXFS) +#opts_mcp --double-buffer + +# command-line options that will be used by msum on client hosts +#opts_msum --double-buffer + +# command-line options that will be used by ssh on client hosts +# (example: opts_ssh -c arcfour256 -m umac-64@openssh.com) +#opts_ssh nodefault + +# command-line options that will be used by ssh on client hosts with --secure +# (example: opts_ssh_secure -c aes256-ctr -m hmac-sha2-512) +#opts_ssh_secure nodefault + +# supported remote transports by decreasing small file performance/preference +# (example: remote_small fish-tcp,rsync,fish,shift,bbftp) +#remote_small shift + +# average size under which a lan batch will be optimized for small files +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#small_size_lan 256m + +# average size under which a local batch will be optimized for small files +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#small_size_local 1g + +# average size under which a wan batch will be optimized for small files +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#small_size_wan 64m + + +################################ +#### general tuning options #### +################################ + +# size of buffer to use in transports +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#default_buffer 4m + +# maximum number of files to transfer in each batch +# (use suffix {k,m,b/g,t} for 10E{3,6,9,12}) +#default_files 1k + +# minimum number of files to process in each initialization batch +# (note use of dash instead of underscore) +# (use suffix {k,m,b/g,t} for 10E{3,6,9,12}) +#default_find-files 2k + +# source sparsity percentage at which to preallocate destination file +# (sparsity defined as 1 - (512 * allocated_blocks / size)) +# (note that transports using temporary files are not supported) +# (example: default_preallocate 10) +#default_preallocate 0 + +# number of times to retry failed operations +# (must be at least 1 for --sync to function) +#default_retry 2 + +# approximate maximum amount of data to transfer in each batch +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#default_size 4g + +# approximate maximum size of created tar files +# (note use of dash instead of underscore) +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#default_split-tar 500g + +# amount of data per lustre stripe +# (set to 0 to use default striping) +# (note that transports using temporary files are not supported) +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#default_stripe 1g + +# number of stripes that local lustre file systems use by default +# (if file systems use different values, use max default across them) +#lustre_default_stripe 1 + +# number of status entries at which some older done transfers may be omitted +#status_lines 20 + + +################################ +#### network tuning options #### +################################ + +# WAN bandwidth assumed for non-organization/non-xge hosts +# (use suffix {k,m,g,t} for {Kb,Mb,Gb,Tb}) +#bandwidth_ind 100m + +# WAN bandwidth assumed when end of host FQDN matches org_domains setting +# (use suffix {k,m,g,t} for {Kb,Mb,Gb,Tb}) +#bandwidth_org 1g + +# WAN bandwidth assumed when 10GE adapter found on host via lspci +# (use suffix {k,m,g,t} for {Kb,Mb,Gb,Tb}) +#bandwidth_xge 10g + +# minimum number of streams to use in remote LAN transfers +#min_streams_lan 1 + +# minimum number of streams to use in remote WAN transfers +#min_streams_wan 4 + +# minimum window size to use over LAN with TCP-based transports +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#min_window_lan 1m + +# minimum window size to use over WAN with TCP-based transports +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#min_window_wan 4m + +# maximum number of streams to use in remote LAN transfers +#max_streams_lan 8 + +# maximum number of streams to use in remote WAN transfers +#max_streams_wan 16 + +# latency (seconds) assumed to remote LAN hosts when measurement fails +#latency_lan 0.001 + +# latency (seconds) assumed to remote WAN hosts when measurement fails +#latency_wan 0.05 + +# regular expression for determining if host may have higher bandwidth +#org_domains com|edu|gov|mil|net|org + + +################################# +#### parallelization options #### +################################# + +# number of clients to spawn on each host +#default_clients 1 + +# maximum number of source hosts to involve in a transfer +#default_hosts 1 + +# amount of data at which single files will be parallelized +# (use suffix {k,m,g,t} for {KB,MB,GB,TB}) +#default_split 0 + +# number of threads to use in multi-threaded transports +#default_threads 4 + + +################################### +#### client throttling options #### +################################### + +# local avg. cpu usage (%) at which to throttle transfer +# (example: default_cpu 75) +#default_cpu nodefault + +# target disk usage (%) at which to suspend/resume transfer +# (example: default_disk 95:85) +#default_disk nodefault:nodefault + +# local avg. i/o usage (MB/s) at which to throttle transfer +# (example: default_io 1000) +#default_io nodefault + +# local avg. i/o reads (MB/s) at which to throttle transfer +# (example: default_ior 1000) +#default_ior nodefault + +# local avg. i/o writes (MB/s) at which to throttle transfer +# (example: default_iow 1000) +#default_iow nodefault + +# local avg. network usage (MB/s) at which to throttle transfer +# (example: default_net 80) +#default_net nodefault + +# local avg. network reads (MB/s) at which to throttle transfer +# (example: default_netr 80) +#default_netr nodefault + +# local avg. network writes (MB/s) at which to throttle transfer +# (example: default_netw 80) +#default_netw nodefault + + +################################# +#### user throttling options #### +################################# + +# global avg. i/o usage (MB/s) at which to throttle user X's transfers +# (example: throttle_io_user_alice 1000) +#throttle_io_user_X nodefault + +# global avg. i/o reads (MB/s) at which to throttle user X's transfers +# (example: throttle_ior_user_alice 1000) +#throttle_ior_user_X nodefault + +# global avg. i/o writes (MB/s) at which to throttle user X's transfers +# (example: throttle_iow_user_alice 1000) +#throttle_iow_user_X nodefault + +# global avg. network usage (MB/s) at which to throttle user X's transfers +# (example: throttle_net_user_alice 80) +#throttle_net_user_X nodefault + +# global avg. network reads (MB/s) at which to throttle user X's transfers +# (example: throttle_netr_user_alice 80) +#throttle_netr_user_X nodefault + +# global avg. network writes (MB/s) at which to throttle user X's transfers +# (example: throttle_netw_user_alice 80) +#throttle_netw_user_X nodefault + + +######################################## +#### file system throttling options #### +######################################## + +# disk usage (%) at which to suspend/resume transfers to file system X +# (the format for each file system X is SERVERS:REMOTE, where SERVERS +# and REMOTE are the values of "servers" and "remote", respectively, +# listed for X when running "shift-aux mount" on a host that mounts X) +# (example: throttle_disk_homenfs1.example.com:/home 95:85) +#throttle_disk_X nodefault:nodefault + +# global avg. i/o usage (MB/s) at which to throttle transfers to file system X +# (format of X is identical to disk usage above) +# (example: throttle_io_fs_homenfs1.example.com:/home 1000) +#throttle_io_fs_X nodefault + +# global avg. i/o reads (MB/s) at which to throttle transfers to file system X +# (format of X is identical to disk usage above) +# (example: throttle_ior_fs_homenfs1.example.com:/home 1000) +#throttle_ior_fs_X nodefault + +# global avg. i/o writes (MB/s) at which to throttle transfers to file system X +# (format of X is identical to disk usage above) +# (example: throttle_iow_fs_homenfs1.example.com:/home 1000) +#throttle_iow_fs_X nodefault + + +################################# +#### host throttling options #### +################################# + +# global avg. i/o usage (MB/s) at which to throttle transfers on host X +# (example: throttle_io_host_host1.example.com 10000) +#throttle_io_host_X nodefault + +# global avg. i/o reads (MB/s) at which to throttle transfers on host X +# (example: throttle_ior_host_host1.example.com 10000) +#throttle_ior_host_X nodefault + +# global avg. i/o writes (MB/s) at which to throttle transfers on host X +# (example: throttle_iow_host_host1.example.com 10000) +#throttle_iow_host_X nodefault + +# global avg. network usage (MB/s) at which to throttle transfers on host X +# (example: throttle_net_host_host1.example.com 10000) +#throttle_net_host_X nodefault + +# global avg. network reads (MB/s) at which to throttle transfers on host X +# (example: throttle_netr_host_host1.example.com 10000) +#throttle_netr_host_X nodefault + +# global avg. network writes (MB/s) at which to throttle transfers on host X +# (example: throttle_netw_host_host1.example.com 10000) +#throttle_netw_host_X nodefault + diff --git a/perl/shift-aux b/perl/shift-aux new file mode 100755 index 0000000..8b2f711 --- /dev/null +++ b/perl/shift-aux @@ -0,0 +1,1626 @@ +#!/usr/bin/perl -T +# +# Copyright (C) 2012-2016 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 outputs various information based on the given command. +# The 'chattr' command sets acls, striping, and/or xattrs of each given file. +# The 'find' command outputs the list of files and/or directories +# beneath the given set of paths and corresponding stat information. +# The 'fish' command initiates processing of FISH-like protocol commands. +# The 'mount' command outputs the set of remotely mounted file systems. +# The 'sum' command outputs whether or not the hashes computed for the +# given list of files match the hashes given for each. + +require 5.007_003; +use strict; +use Cwd qw(abs_path); +use Digest::MD5 qw(md5); +use Fcntl qw(:DEFAULT :mode); +use File::Basename; +use File::Path; +use File::Spec; +use File::Temp qw(tempfile); +use Getopt::Long qw(:config bundling no_ignore_case require_order); +use IO::File; +use IO::Handle; +use IO::Socket::INET; +# use embedded IPC::Open3 since versions prior to perl 5.14.0 are buggy +require IPC::Open3; +use List::Util qw(min); +use POSIX; +use Socket; +use Symbol qw(gensym); +use Sys::Hostname; +use Text::ParseWords; + +our $VERSION = 0.90; + +# need threads and version of Thread::Queue from perl >= 5.10.1 +my $have_threads = eval 'require 5.010_001; use threads; use Thread::Queue; 1'; + +# do not die when receiving sigpipe +$SIG{PIPE} = 'IGNORE'; +# untaint path +$ENV{PATH} = "/bin:/usr/bin:/usr/local/bin:/sbin:/usr/sbin:/usr/local/sbin"; +# untaint env +delete $ENV{ENV}; + +my %opts; +my $cmd = shift @ARGV; + +# make sure user can read, write, execute/traverse files/dirs +# make sure root transfers do not inadvertently expose files +umask ($< == 0 ? 077 : 077 & umask); + +# parse options and perform corresponding command +if (!$cmd) { + die "Invalid command\n"; +} elsif ($cmd eq 'chattr') { + die "Invalid options\n" if (scalar(@ARGV) > 0); + chattr(); +} elsif ($cmd eq 'find') { + die "Invalid options\n" if (!GetOptions(\%opts, + "create-tar", "dereference|L", "exclude=s@", "extract-tar", + "find-files=i", "ignore-times", "include=s@", "newer=i", "older=i", + "preserve", "sync", + )); + die "Invalid options\n" if (scalar(@ARGV) > 0); + find(); +} elsif ($cmd eq 'fish') { + %opts = ( + 'buffer-size' => 4, + 'ports' => "50000:51000", + 'streams' => 4, + 'window' => 4194304, + ); + die "Invalid options\n" if (!GetOptions(\%opts, + "buffer-size=i", "ports=s", "streams=i", "tcp", "verify", "window=i", + )); + die "Invalid options\n" if (scalar(@ARGV) > 0); + $opts{'buffer-size'} <<= 20; + fish(); +} elsif ($cmd eq 'mount') { + die "Invalid options\n" if (scalar(@ARGV) > 0); + mount(); +} elsif ($cmd eq 'sum') { + %opts = ( + 'buffer-size' => 4, + 'split-size' => 1024, + 'threads' => 4, + ); + die "Invalid options\n" if (!GetOptions(\%opts, + "buffer-size=i", "c", "split-size=i", "threads=i", + )); + die "Invalid options\n" if (!$opts{c}); + sum(); +} + +################ +#### chattr #### +################ +# set given attr of files given on STDIN to given value(s) and output ok/error +sub chattr { + # check for existence of commands + my %have; + foreach my $bin (qw(fallocate lfs setfacl setfattr)) { + foreach my $path (split(/:/, $ENV{PATH})) { + if (-x "$path/$bin") { + $have{$bin} = 1; + last; + } + } + } + + while (my $line = ) { + chomp $line; + my ($cmd, $file, $attrs) = split(/\s+/, $line, 3); + # short circuit if command not available + next if (!$have{$cmd}); + # untaint arguments + $cmd = $1 if ($cmd =~ /(.*)/); + $file = $1 if ($file =~ /(.*)/s); + $attrs = $1 if ($attrs =~ /(.*)/); + my $ufile = unescape($file); + my $uattrs = unescape($attrs); + + # make sure parent directory exists + my $dir = $ufile =~ s/\/$// ? $ufile : dirname($ufile); + eval {mkpath($dir)}; + + my ($cin, @copts, $in, $out); + if ($cmd eq 'fallocate') { + @copts = ("-n", "-l", $uattrs, $ufile); + } elsif ($cmd eq 'lfs') { + my ($count, $size) = split(/\s+/, $uattrs); + $count = 0 if (!$count); + $size = 0 if (!$size); + # stripes > 160 may fail due to max of lustre < 2.4 + $count = 160 if ($count > 160); + @copts = ("setstripe", "-c", $count, "-s", $size, $ufile); + } elsif ($cmd eq 'setfacl') { + $uattrs =~ s/,/\n/g; + $cin = $uattrs; + @copts = ("-PM-", $ufile); + } elsif ($cmd eq 'setfattr') { + $uattrs =~ s/,/\n/g; + $cin = "# file: $ufile\n$uattrs"; + @copts = ("-h", "--restore=-"); + } + my $pid = IPC::Open3::open3($in, $out, $out, $cmd, @copts); + print $in $cin if ($cin); + close $in; + waitpid($pid, 0); + if ($?) { + my $text; + $text .= $_ while (<$out>); + $text =~ s/\n/ /g; + print "$file,", escape($text), "\n"; + } else { + print "$file,ok\n"; + } + close $out; + } +} + +################ +#### 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; +} + +############## +#### find #### +############## +# output list of files/dirs beneath paths given on STDIN with stat info +sub find { + while (my $line = ) { + chomp $line; + $opts{$_} = undef foreach (qw(srcfs tar_name tar_tell)); + my @args = split(/\s+/, $line); + my $ref = pop @args; + print "ref $ref\n"; + while (scalar(@args) > 3) { + my $opt = pop @args; + $opts{$1} = $2 if ($opt =~ /(\w+)=(\S+)/); + } + find1(map {unescape($_)} @args); + } +} + +############### +#### find1 #### +############### +# output list of files/dirs beneath given paths with stat info +sub find1 { + my ($shost, $spath, $dst) = @_; + + # process local tar files + if ($opts{'extract-tar'}) { + find_tar($shost, $spath, $dst); + return; + } + + # check for existence of various commands + my %have; + foreach my $bin (qw(dmget lfs getfacl getfattr)) { + foreach my $path (split(/:/, $ENV{PATH})) { + if (-x "$path/$bin") { + $have{$bin} = 1; + last; + } + } + } + + my $dmf = $have{dmget} && $opts{srcfs} =~ /,dmi/ ? 1 : 0; + my ($dmfh, $dmtmp); + + my $sdir = dirname($spath); + $sdir = "" if ($sdir eq '/'); + my $ddir = dirname($dst); + $ddir = "" if ($ddir eq '/'); + my $tdir = $opts{'create-tar'} ? dirname($opts{tar_name}) : undef; + $tdir = "" if ($tdir eq '.'); + $tdir .= "/" if ($tdir && $tdir !~ /\/$/); + my $dname = basename($dst); + my @files = (basename($spath)); + FILE: foreach my $file0 (@files) { + if (ref $file0) { + # processing subdir so update prefix + $sdir = $file0->[0]; + $ddir = $file0->[1]; + $tdir = $file0->[2] . "/" if ($opts{'create-tar'}); + # dname only needed on first iteration where src/dst name may differ + $dname = undef; + next; + } + next if ($file0 eq '.' || $file0 eq '..'); + my $file = "$sdir/$file0"; + my $dfile0 = $dname ? $dname : $file0; + + # dereference before stat + $file = abs_path($file) if ($opts{dereference}); + # always get stat info of real file + my @stat = lstat($file); + my $mode; + if (scalar(@stat) == 0) { + $file = "$sdir/$file0" if ($opts{dereference}); + if (scalar(@files) == 1) { + # escape commas + $file =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + # return error if original file + print "Cannot stat $file\n"; + next; + } + # 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 + next if (!S_ISDIR($mode) && !S_ISREG($mode) && !S_ISLNK($mode)); + # dmf handling for individual files is carried out by transport_dmf + $dmf = 0 if (scalar(@files) == 1 && !S_ISDIR($mode)); + } + + if (scalar(@stat) == 0 || S_ISDIR($mode)) { + my $err = ""; + if (scalar(@stat) > 0 && (!$opts{dereference} || scalar(@files) == 1) && + (!defined $opts{'find-files'} || + scalar(@files) < $opts{'find-files'})) { + # add subdirs of this directory for processing when below limit + if (opendir(DIR, $file)) { + $! = undef; + my @sub_files = readdir DIR; + if ($! || scalar(@sub_files) == 0) { + # there is currently no good way to detect readdir errors + # dirs should always contain . and .. at a minimum + $err = "Error reading directory $file"; + } else { + my $dirs = [$file, "$ddir/$dfile0"]; + push(@{$dirs}, "$tdir$file0") if ($opts{'create-tar'}); + push(@files, $dirs, @sub_files); + $err = undef; + } + closedir DIR; + } else { + $err = "Error opening directory $file"; + } + if ($err && scalar(@files) == 1) { + # escape commas + $err =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + # return error if original file + print $err, "\n"; + next; + } + } + if (defined $err) { + # this handles directories as well as lower level stat failures + print "args=find,", escape("$shost:$file"), ","; + if ($opts{'create-tar'}) { + print escape($dst), " tar_name=" . escape("$tdir$file0"); + } else { + print escape("$ddir/$dfile0"); + } + print "\n"; + next; + } + } + + # include files + if (defined $opts{include}) { + my $found; + foreach my $re (@{$opts{include}}) { + my $ure = unescape($re); + next if (eval {$file !~ /$ure/}); + $found = 1; + last; + } + next if (!$found); + } + # exclude files + if (defined $opts{exclude}) { + foreach my $re (@{$opts{exclude}}) { + my $ure = unescape($re); + next FILE if (eval {$file =~ /$ure/}); + } + } + # newer/older files + next if (defined $opts{newer} && $stat[9] < $opts{newer}); + next if (defined $opts{older} && $stat[9] >= $opts{older}); + + # dereference before stat + # resolve uid/gid if possible + my $user = getpwuid($stat[4]); + my $group = getgrgid($stat[5]); + $user = "uid_$stat[4]" if (!$user); + $group = "gid_$stat[5]" if (!$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; + # try to get acls + if ($have{getacl} && !$opts{'create-tar'} && $opts{preserve} && + (!$opts{srcfs} || $opts{srcfs} =~ /,acl/)) { + open(FILE, '-|', "getfacl", "-cPps", "--", $file); + while () { + chomp; + next if (!$_); + push(@acls, escape($_)); + } + close FILE; + } + + # try to get xattrs + if ($have{getfattr} && !$opts{'create-tar'} && $opts{preserve} && + (!$opts{srcfs} || $opts{srcfs} =~ /,xattr/)) { + open(FILE, '-|', "getfattr", "-dhe", "base64", $file); + while () { + chomp; + next if (!$_ || /^\s*#/); + push(@xattrs, escape($_)); + } + close FILE; + } + + # try to get lustre striping + if ($have{lfs} && !S_ISLNK($mode) && !$opts{'create-tar'} && + $opts{preserve} && $opts{srcfs} =~ /^lustre/) { + # ignore symlinks as link to fifo can hang forever + open(FILE, '-|', "lfs", "getstripe", "-d", $file); + while () { + $lattrs[0] = $1 if (/stripe_count:\s*(-?\d+)/); + $lattrs[1] = $1 if (/stripe_size:\s*(-?\d+)/); + } + close FILE; + } + $lattrs[0] = 0 if (!defined $lattrs[0] && defined $lattrs[1]); + $lattrs[1] = 0 if (!defined $lattrs[1] && defined $lattrs[0]); + + # begin log entry + 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 = readlink($file); + print "args=ln,", escape($ln); + $index_len += 4 + length($ln); + } elsif (S_ISDIR($mode)) { + print "args=mkdir"; + } elsif ($opts{sync}) { + print "args=ckattr", $opts{'ignore-times'} ? "0" : "", + ",", escape("$shost:$file"); + } else { + print "args=cp,", escape("$shost:$file"); + } + print ",", escape($opts{'create-tar'} ? $dst : "$ddir/$dfile0"); + print " acls=" . join(",", @acls) if (scalar(@acls) > 0); + print " xattrs=" . join(",", @xattrs) if (scalar(@xattrs) > 0); + print " lustre_attrs=" . join(",", @lattrs) if (scalar(@lattrs) > 0); + print " tar_index=$index_len" if ($opts{'index-tar'}); + print " tar_name=" . escape("$tdir$file0") if ($opts{'create-tar'}); + print " size=$stat[7] attrs=$attrs\n"; + if ($dmf) { + ($dmfh, $dmtmp) = tempfile() if (!$dmtmp); + print $dmfh $file, "\n" if (!S_ISLNK($mode) && !S_ISDIR($mode)); + } + } + + if ($dmf) { + close $dmfh; + # fork to avoid intermittent hangs of dmget + my $pid = fork_setsid(); + if ($pid) { + waitpid($pid, 0); + } else { + # ignore errors since files will be automatically retrieved anyway + open3_get([$dmtmp, -1, -1], "dmget -nq"); + unlink $dmtmp; + POSIX::_exit(0); + } + } +} + +################## +#### find_tar #### +################## +# output list of files/dirs within given files with stat info +# based on Tar/Archive::Tar 0.07 by Calle Dybedahl (no license specified) +sub find_tar { + my ($shost, $spath, $dst) = @_; + my $src = "$shost:$spath"; + + my $fh; + $fh = undef if (!open($fh, '<', $spath)); + + my $tell = defined $opts{tar_tell} ? $opts{tar_tell} : 0; + if (!$fh) { + # escape commas + $src =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + print "Unable to open tar file $src\n"; + return; + } elsif ($tell > 0 && !seek($fh, $tell, 0)) { + # escape commas + $src =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + print "Unable to seek in tar file $src\n"; + return; + } + binmode $fh; + + my %real; + my ($eof, $err, $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 + if (defined $opts{tar_tell} && $opts{tar_tell} == $tell) { + $err = 1; + # escape commas + $src =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + print "Empty file name in tar file $src\n"; + } + 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 + if (defined $opts{tar_tell} && $opts{tar_tell} == $tell) { + $err = 1; + # escape commas + $src =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + print "Tar file $src not in supported ustar format\n"; + } + 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 + if (defined $opts{tar_tell} && $opts{tar_tell} == $tell) { + $err = 1; + # escape commas + $attrs[0] =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + print "Invalid tar header checksum for $attrs[0]\n"; + } + 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 + if (defined $opts{tar_tell} && $opts{tar_tell} == $tell) { + $err = 1; + # escape commas + $src =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + print "Unable to seek in tar file $src\n"; + } + last; + } + my $diff = $attrs[4] % 512; + # ignore padding + if ($diff != 0 && !seek($fh, 512 - $diff, 1)) { + $err = 1; + # only record error if no progress made + if (defined $opts{tar_tell} && $opts{tar_tell} == $tell) { + # escape commas + $src =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + print "Unable to ignore padding in tar file $src\n"; + } + 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 my $re (@{$opts{include}}) { + my $ure = unescape($re); + next if (eval {$attrs[0] !~ /$ure/}); + $found = 1; + last; + } + next if (!$found); + } + # exclude files + if (defined $opts{exclude}) { + my $found; + foreach my $re (@{$opts{exclude}}) { + my $ure = unescape($re); + next if (eval {$attrs[0] !~ /$ure/}); + $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 "args=ln,", escape($attrs[8]), ",", $udst; + } elsif ($attrs[7] eq '5') { + print "args=mkdir,", $udst; + } elsif ($attrs[7] eq '0') { + print "args=cp,", escape($src), ",", $udst; + } else { + # unsupported file type (e.g. pipes, devices, etc.) + next; + } + print " 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 " bytes=$bytes tar_bytes=$bytes\n"; + $nfiles++; + } + if (length($head) < 512) { + # escape commas + $src =~ s/(,)/sprintf("%%%02X", ord($1))/eg; + print "Unable to read header at offset $tell in tar file $src\n"; + } elsif (!$eof && !$err) { + # over init limit or error occurred without notification + print "args=find,", escape($src), ",", escape($dst), " tar_tell=$tell\n"; + } + close $fh; +} + +############## +#### fish #### +############## +# initiate fish protocol and perform each transfer given on STDIN +sub fish { + $SIG{'CHLD'} = 'IGNORE'; + + my $in = \*STDIN; + my $out = \*STDOUT; + $out->autoflush(1); + + # default is to indicate running + my $rc = "### 200"; + my ($port, $sock, $key); + if (!$have_threads && $opts{tcp}) { + # indicate that threads are not supported + $rc = "### 500 nothread"; + $opts{tcp} = 0; + } elsif ($opts{tcp}) { + my ($port1, $port2) = split(/:/, $opts{ports}); + foreach (sort {(-1,1)[rand 2]} ($port1..$port2)) { + $port = $_; + $sock = IO::Socket::INET->new( + LocalPort => $port, + Listen => $opts{streams}, + Proto => 'tcp', + ); + last if ($sock); + } + if (!$sock) { + $rc = "### 500 noport"; + $opts{tcp} = 0; + } else { + if ($opts{window}) { + $sock->sockopt(SO_RCVBUF, $opts{window}); + $sock->sockopt(SO_SNDBUF, $opts{window}); + } + #TODO: de-hardcode 60 second timeout + $sock->sockopt(SO_RCVTIMEO, pack('L!L!', +60, 0)); + $key = "" . rand(); + $rc = "$port $key\n$rc"; + } + } + $out->write($rc . "\n"); + + my @fcmds; + while (defined($_ = $in->getline)) { + s/^\s+|\s+$//g; + next if (!s/^#//); + my @args = map {unescape($_)} split(/\s+/); + if ($opts{tcp}) { + if ($args[0] eq 'exit') { + last; + } elsif ($args[0] eq 'streams') { + $opts{streams} = $args[1]; + } else { + push(@fcmds, [@args]); + } + } else { + return if ($args[0] eq 'exit'); + fish_io($in, $out, @args); + } + } + return if (!$opts{tcp}); + require Digest::HMAC_SHA1; + + my @threads = map {threads->create(sub { + my ($tsock, $trc0); + $tsock = $sock->accept; + my $trc = fish_return($tsock); + my ($nonce, $hmac) = split(/\s+/, $trc); + my $my_hmac = Digest::HMAC_SHA1::hmac_sha1_hex($nonce, $key); + if ($hmac ne $my_hmac) { + # remote side cannot be authenticated + close $tsock; + return; + } + my $nonce2 = "" . rand(); + my $hmac2 = Digest::HMAC_SHA1::hmac_sha1_hex($nonce . $nonce2, $key); + $tsock->print($nonce2 . " " . $hmac2 . "\n### 100\n"); + + while (1) { + my $trc = fish_return($tsock); + my ($fi, $fi_hmac) = split(/\s+/, $trc); + my $my_fi_hmac = Digest::HMAC_SHA1::hmac_sha1_hex( + $fi . $nonce2++, $key); + if ($fi_hmac ne $my_fi_hmac) { + # remote side cannot be authenticated + close $tsock; + return; + } + last if ($fi == -1); + fish_io($tsock, $tsock, @{$fcmds[$fi]}); + } + close $tsock; + })} (1 .. $opts{streams}); + $_->join foreach (@threads); + close $sock; +} + +################# +#### fish_io #### +################# +# perform given transfer and return result or return error message in hash +sub fish_io { + my ($in, $out, $cmd, $src, $dst, $size, $len, $off) = @_; + my ($err, $file, $fh); + if ($cmd !~ /^(?:get|put)$/ || !$src || !$dst) { + $err = {error => "Invalid arguments"}; + } else { + # untaint cmd as it taints other things via conditionals + $cmd = $1 if ($cmd =~ /(.*)/); + $file = $cmd eq 'get' ? $src : $dst; + # untaint file + $file = $1 if ($file =~ /(.*)/s); + $len = (stat $file)[7] if (!defined $len && $cmd eq 'get'); + + # create implicit directories + eval {mkpath(dirname($file))} if ($cmd eq 'put'); + + my $flags = $cmd eq 'get' ? O_RDONLY : O_WRONLY | O_CREAT; + $flags |= O_TRUNC if (!defined $off && $cmd eq 'put'); + $fh = IO::File->new($file, $flags); + if (!defined $fh) { + $err = {error => "Error opening $file: $!"}; + } elsif (defined $off && !$fh->seek($off, 0)) { + $fh->close; + $err = {error => "Error seeking $file: $!"}; + } + } + if ($err) { + # 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 'get'); + $out->write("### 100\n"); + } + my $rc = fish_return($in); + return (ref $err ? $err : $rc) if (ref $err || ref $rc); + $len = $rc if ($cmd eq 'put'); + $rc = undef; + + my $sopts = !$opts{verify} || $cmd ne 'get' ? 0 : + verify_init(length => $len); + my $nbytes = $opts{'buffer-size'}; + while ($len > 0) { + $nbytes = $len if ($len < $nbytes); + if ($cmd eq 'put') { + $rc = fish_return($in); + if (ref $rc) { + $fh->close; + return $rc; + } + } + my $buf; + my $n = $cmd eq 'put' ? + $in->read($buf, $nbytes) : $fh->sysread($buf, $nbytes); + last if ($n < $nbytes); + $out->write("### 200\n") if ($cmd eq 'get'); + $cmd eq 'put' ? $fh->syswrite($buf) : $out->write($buf); + $len -= $n; + verify_buffer($sopts, $buf, $sopts->{length} - $len) + if ($opts{verify} && $cmd eq 'get'); + } + $fh->close; + + if ($len > 0) { + $rc = {error => "Error reading $file: $!"}; + # remove cr/lf so doesn't interfere with protocol + $rc->{error} =~ s/[\n\r]//g; + $out->write("### 500 $rc->{error}\n"); + fish_return($in); + } else { + if ($cmd eq 'put' && defined $size && $size != -1 && + $len + $off == $size && (stat $dst)[7] > $size) { + # truncate dst if last split + truncate($dst, $size); + } + if ($opts{verify} && $cmd eq 'get') { + $out->write("### 500 \\H" . verify_buffer_end($sopts, $src, $off) . "\n"); + } else { + $out->write("### 200\n"); + } + $rc = fish_return($in); + } + return $rc; +} + +##################### +#### fish_return #### +##################### +# parse fish return values and return text or return error message in hash +sub fish_return { + my $in = shift; + 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"}; +} + +##################### +#### fork_setsid #### +##################### +sub fork_setsid { + my $pid = fork; + if (!$pid) { + close STDIN; + close STDOUT; + close STDERR; + setsid; + open(STDIN, "/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; + if ($host =~ /^\d+\.\d+\.\d+\.\d+$/) { + my $name = gethostbyaddr(inet_aton($host), AF_INET); + return $name if ($name); + } else { + my @cols = gethostbyname($host); + return $cols[0] if ($cols[0]); + } + return $host; +} + +############### +#### mount #### +############### +# output the set of remotely mounted file systems +sub mount { + my $host = fqdn(hostname); + my %mnt; + $mnt{host} = $host; + $mnt{args} = "mount"; + + # check for existence of getfacl + my $acl; + foreach my $path (split(/:/, $ENV{PATH})) { + if (-x "$path/getfacl") { + $acl = 1; + last; + } + } + + # gather file system information from mount + 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} .= ",dmi" if (/[\(,]dmi[\),]/); + $mnt{opts} .= ",xattr" if (/[\(,]user_xattr[\),]/); + #TODO: need to escape local and remote? + (my $dev, $mnt{local}, $mnt{type}) = ($1, $2, $3) + if (/(\S+)\s+on\s+(\S+)\s+type\s+(\S+)/); + if ($mnt{local}) { + # 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{type} = "cxfs"; + $mnt{remote} = $mnt{local}; + } elsif (/^(\S+):(\S+)/) { + # typical form for nfs + $mnt{remote} = $2; + $mnt{servers} = $1; + $mnt{servers} =~ s/@.*//; + $mnt{servers} = fqdn($mnt{servers}); + } elsif ($mnt{type} eq 'gpfs') { + # gpfs servers do not appear in mount output so call mmlsmgr + my $srv = open3_get([-1, undef, -1], "mmlsmgr $dev"); + # try a default location if not in path + $srv = open3_get([-1, undef, -1], + "/usr/lpp/mmfs/bin/mmlsmgr $dev") if (!$srv); + next if (!defined $srv); + # output is file system then server ip address + if ($srv =~ /^(\w+)\s+(\d+\.\d+\.\d+\.\d+)/m) { + $mnt{remote} = "/$1"; + $mnt{servers} = fqdn($2); + } + } elsif ($mnt{opts} =~ /,dmi/) { + # always report dmi file systems even if local + $mnt{servers} = $mnt{host}; + $mnt{remote} = $mnt{local}; + } else { + # ignore local file systems + next; + } + # print hash in single line with space-separated key=val form + print 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 + print "args=shell host=$host", ($pbs ? " pbs=1" : ""), "\n"; +} + +################### +#### 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); +} + +############# +#### sum #### +############# +# output whether or not the hash given on STDIN matches the hash +# computed for the file given on STDIN +sub sum { + # adjust sizes to powers of 2 + foreach my $key (qw(buffer-size split-size)) { + $opts{$key} = 1 if ($opts{$key} < 0); + my $tmp = $opts{$key}; + my $new = 1; + $new <<= 1 while ($tmp >>= 1); + $opts{$key} = $new; + } + + # scale sizes appropriately + $opts{'buffer-size'} <<= 20; + $opts{'split-size'} <<= 20; + $opts{'split-size'} = $opts{'buffer-size'} + if ($opts{'split-size'} < $opts{'buffer-size'}); + + my ($qi, $q, $qret, @sums); + if ($have_threads && $opts{threads} > 1) { + require Thread::Queue; + $q = Thread::Queue->new; + $qret = Thread::Queue->new; + $qi = 0; + } + + # check hashes + while (my $line = ) { + chomp $line; + my ($start, $stop, $partial); + if ($line =~ /^#mutil#(\d+)-(\d+)/) { + # hash specific file subset + $start = $1; + $stop = $2; + $partial = 1; + } + $line =~ s/^#mutil#[^#]*#//; + # ignore comment lines that do not contain mutil + next if ($line =~ /^#/); + if ($line =~ /^(\S+)\s.(.*)/) { + # lines contain a hex hash then two chars then file path + my ($hash0, $file) = ($1, $2); + # unescape according to md5sum input rules + $file =~ s/\\([\\n])/$1 eq "n" ? "\n" : "\\"/eg + if ($hash0 =~ s/^\\//); + # use file start if no start given + $start = 0 if (!defined $start); + # use file end if no end given + $stop = (stat($file))[7] if (!defined $stop); + if (!$have_threads || $opts{threads} <= 1) { + my $hash = sum1($file, $start, $stop); + sum_check($file, $hash0, $hash, $start, $stop, $partial); + next; + } + my $i = 0; + for (my $x1 = $start; $x1 == $start || $x1 < $stop; + $x1 += $opts{'split-size'}) { + my $x2 = min($x1 + $opts{'split-size'}, $stop); + $q->enqueue([$qi, $i++, $file, $x1, $x2]); + } + push(@sums, [$file, $hash0, [], $start, $stop, $partial]); + $qi++; + } + } + + return if (!$have_threads || $opts{threads} <= 1); + # choose min of specified threads and amount of work + my $nthr = min($opts{threads}, $q->pending); + my @threads = map {threads->create(sub { + while (defined (my $sum = $q->dequeue)) { + my ($qi, $i, $file, $x1, $x2) = @{$sum}; + my $hash = sum1($file, $x1, $x2); + $qret->enqueue([$qi, $i, $hash]); + } + })} (1 .. $nthr); + # force threads to exit + $q->enqueue(undef) foreach (1 .. $nthr); + $_->join foreach (@threads); + # append any error messages back to original ref text + while (defined (my $sumret = $qret->dequeue_nb)) { + my ($qi, $i, $hash) = @{$sumret}; + $sums[$qi]->[2]->[$i] = $hash; + } + foreach my $sum (@sums) { + $sum->[2] = join("", @{$sum->[2]}); + sum_check(@{$sum}); + } +} + +############## +#### sum1 #### +############## +# return hex hash of given file between given start and stop +sub sum1 { + my ($file, $start, $stop) = @_; + my ($hash, $fh); + if (open($fh, '<', $file)) { + if ($start == $stop) { + # compute empty hex hash + $hash .= unpack("H*", md5("")); + } else { + # compute concatenated list of hex hashes for each split + for (my $x1 = $start; $x1 < $stop; $x1 += $opts{'split-size'}) { + my $x2 = min($x1 + $opts{'split-size'}, $stop); + sysseek($fh, $x1, 0) or + print STDERR "Unable to seek '$file': $!\n"; + my ($buf, $md5, $total) = ("", Digest::MD5->new, 0); + while ($total < $x2 - $x1) { + # read data into buffer + my $n = sysread($fh, $buf, + min($opts{'buffer-size'}, $x2 - $x1 - $total)); + print STDERR "Unable to read '$file': $!\n" if (!defined $n); + last if (!$n); + last if (!$n); + # add data to hash + $md5->add($buf); + $total += $n; + } + $hash .= unpack("H*", $md5->digest); + } + } + close $fh; + } else { + print STDERR "Unable to open '$file'\n"; + } + return $hash; +} + +################### +#### sum_check #### +################### +# output whether or not the given file's two given hashes match in the +# given range +sub sum_check { + my ($file, $hash0, $hash, $start, $stop, $partial) = @_; + print "$file: "; + if ($hash eq $hash0) { + # computed hash matches given hash + print "OK"; + print ",$start-$stop" if ($partial); + } else { + # computed hash differs from given hash + print "FAILED"; + if (defined $stop) { + # output which splits of file differed + my $i = 0; + for (my $x1 = $start; $x1 < $stop; $x1 += $opts{'split-size'}) { + my $x2 = min($x1 + $opts{'split-size'}, $stop); + if (substr($hash, $i * 32, 32) ne substr($hash0, $i * 32, 32)) { + print ",", $x1, "-", $x2; + } + $i++; + } + } elsif ($partial) { + # output portion of file that differed + print ",$start-$stop"; + } + } + print "\n"; +} + +####################### +#### 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); +} + +################## +#### 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_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 %sopts = ( + buffer_size => $opts{buffer} ? $opts{buffer} >> 20 : 4, + hash_ctx => Digest::MD5->new, + split_size => 1024, + 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; +} + +# 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{"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/HMAC_MD5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DIGEST_HMAC_MD5'; + package Digest::HMAC_MD5;$VERSION="1.01";use strict;use Digest::MD5 qw(md5);use Digest::HMAC qw(hmac);use vars qw(@ISA);@ISA=qw(Digest::HMAC);sub new {my$class=shift;$class->SUPER::new($_[0],"Digest::MD5",64)}require Exporter;*import=\&Exporter::import;use vars qw(@EXPORT_OK);@EXPORT_OK=qw(hmac_md5 hmac_md5_hex);sub hmac_md5 {hmac($_[0],$_[1],\&md5,64)}sub hmac_md5_hex {unpack("H*",&hmac_md5)}1; +DIGEST_HMAC_MD5 + +$fatpacked{"Digest/HMAC_SHA1.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DIGEST_HMAC_SHA1'; + package Digest::HMAC_SHA1;$VERSION="1.03";use strict;use Digest::SHA::PurePerl qw(sha1);use Digest::HMAC qw(hmac);use vars qw(@ISA);@ISA=qw(Digest::HMAC);sub new {my$class=shift;$class->SUPER::new($_[0],"Digest::SHA",64)}require Exporter;*import=\&Exporter::import;use vars qw(@EXPORT_OK);@EXPORT_OK=qw(hmac_sha1 hmac_sha1_hex);sub hmac_sha1 {hmac($_[0],$_[1],\&sha1,64)}sub hmac_sha1_hex {unpack("H*",&hmac_sha1)}1; +DIGEST_HMAC_SHA1 + +$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 @EXPORT_OK);use Fcntl;use integer;use Carp qw(croak);$VERSION='5.95';require Exporter;@ISA=qw(Exporter);@EXPORT_OK=();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;$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,$portable)=map {$_ eq $mode}("b","U","0","p");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 =~ s/[^01]//g;$self->add_bits($buf)}_bail("Read failed")unless defined$n;close(FH);return($self)}binmode(FH)if$binary || $portable || $UNIVERSAL;if ($UNIVERSAL && _istext(*FH,$file)){while (){s/\015\012/\012/g;s/\015/\012/g;$self->add($_)}}elsif ($portable && _istext(*FH,$file)){while (){s/\015?\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('',);close(FH);$class->putstate($str)}1; +DIGEST_SHA_PUREPERL + +$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.18';@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,@_}}push@errs,"IO::Pipe: Can't spawn-NOWAIT: $!" if!$pid || $pid < 0}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 + +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 + diff --git a/perl/shift-mgr b/perl/shift-mgr new file mode 100755 index 0000000..81ea5f9 --- /dev/null +++ b/perl/shift-mgr @@ -0,0 +1,3849 @@ +#!/usr/bin/perl -T +# +# Copyright (C) 2012-2016 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 coordinates the tracking of file operations that are +# performed as part of a user-initiated transfer. It provides a way for +# the Shift/Mesh client to add operations, set their state, and retrieve +# operations for processing. It also provides various status output to +# the user upon request. + +require 5.009_003; +use strict; +use Compress::Zlib; +use DB_File; +use Fcntl qw(:DEFAULT :flock :mode); +use File::Basename; +use File::Path; +use File::Spec; +use File::Temp qw(tempfile); +use Getopt::Long qw(:config bundling no_ignore_case require_order); +use IO::File; +use IO::Handle; +# 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 Math::BigInt; +use MIME::Base64; +use Net::Ping; +use POSIX qw(ceil setsid setuid strftime); +use Storable qw(dclone nfreeze nstore retrieve thaw); +use Symbol qw(gensym); +use Text::ParseWords; + +our $VERSION = 0.90; + +# binary byte string conversions +my %bibytes = ( + '' => 1, + K => 1024, + M => 1024**2, + G => 1024**3, + T => 1024**4, + P => 1024**5, + E => 1024**6, +); + +# byte string conversions +my %bytes = ( + '' => 1, + K => 1000, + M => 1000**2, + G => 1000**3, + T => 1000**4, + P => 1000**5, + E => 1000**6, +); + +# second string conversions +my %seconds = ( + s => 1, + m => 60, + h => 60 * 60, + d => 24 * 60 * 60, + w => 7 * 24 * 60 * 60, +); + +# define default defaults +my %conf = ( + bandwidth_ind => "100m", + bandwidth_org => "1g", + bandwidth_xge => "10g", + data_expire => 604800, + default_buffer => "4m", + default_clients => 1, + default_files => "1k", + 'default_find-files' => "2k", + default_hosts => 1, + default_local => "fish,shift", + default_preallocate => 0, + default_remote => "shift", + default_retry => 2, + default_size => "4g", + default_split => 0, + 'default_split-tar' => "500g", + default_stripe => "1g", + default_threads => 4, + latency_lan => 0.001, + latency_wan => 0.05, + local_small => "fish,shift", + lustre_default_stripe => 1, + max_streams_lan => 8, + max_streams_wan => 16, + min_split => "1g", + min_streams_lan => 1, + min_streams_wan => 4, + min_window_lan => "1m", + min_window_wan => "4m", + opts_bbcp => "", + opts_bbftp => "", + opts_gridftp => "", + opts_mcp => "--double-buffer", + opts_msum => "--double-buffer", + opts_ssh => "", + opts_ssh_secure => "", + org_domains => "com|edu|gov|mil|net|org", + remote_small => "shift", + small_size_lan => "256m", + small_size_local => "1g", + small_size_wan => "64m", + status_lines => 20, +); + +my %db; +my $dbgfh; +my $ilockfh; +my $ulockfh; +my %nload; +my $localtime = localtime; +my %meta; +my $time = time; +my %udb; + +# files only readable by owner unless explicitly specified +umask 077; + +# untaint path +$ENV{PATH} = "/bin:/usr/bin:/usr/local/bin"; +# untaint env +delete $ENV{ENV}; + +# unlock files at program termination +END { + close $dbgfh if (defined $dbgfh); + close $ilockfh if (defined $ilockfh); + close $ulockfh if (defined $ulockfh); +} + +# parse options +my %opts; +my $rc = GetOptions(\%opts, + "alive", "get", "history", "host=s", "id=s", "lock", "meta:1", "mounts", + "pid=i", "put", "restart", "search=s", "shift-mgr", "state=s", "stats", + "status:s", "stop", "sync", "user=s", +); +die "Invalid options\n" if (!$rc || scalar(@ARGV) != 0); + +# parse configuration +foreach my $file ("/etc/shiftrc", (getpwuid($<))[7] . "/.shiftrc") { + open(FILE, '<', $file) or next; + my $mline; + while (my $line = ) { + # strip whitespace and comments + $line =~ s/^\s+|\s+$|\s*#.*//g; + next if (!$line); + # support line continuation operator + $mline .= $line; + next if ($mline =~ s/\s*\\$/ /); + if ($mline =~ /^(\S+)\s+(.*)/) { + $conf{$1} = $2; + } + $mline = undef; + } + close FILE; +} +die "The user_dir setting must be configured\n" if (!$conf{user_dir}); +# opts_bbftp may have fake newlines that must become real newlines +$conf{opts_bbftp} =~ s/\\n/\n/g; + +# process --stats immediately before setuid or $conf{user_dir} changes +if ($opts{stats}) { + stats(); + exit; +} + +if (defined $opts{user}) { + die "Only root can specify user\n" if ($> != 0); + # untaint user + $opts{user} = $1 if ($opts{user} =~ /^([\w-]+)$/); + # perform operations without notifying user + $opts{quiet} = 1; + # become user so synchronization will work correctly + my $uid = getpwnam($opts{user}); + setuid($uid) if (defined $uid); + die "Unable to setuid to user\n" + if (!defined $uid || $< != $uid || $> != $uid); +} else { + $opts{user} = getpwuid($<); +} +if (defined $opts{host}) { + # untaint host + $opts{host} = $1 if ($opts{host} =~ /^([\w.-]+)$/); +} elsif ($opts{get} || $opts{put}) { + die "No host name given\n"; +} +if (defined $opts{id}) { + # untaint id.cid + ($opts{id}, $opts{cid}) = ($1, $2) if ($opts{id} =~ /^(\d+)(\.\d+)?$/); +} +if (defined $opts{search}) { + # unescape whitespace and special characters in search string + $opts{search} = unescape($opts{search}); +} + +# save user_dir and modify it for globbing across all users +$opts{user_dir} = $conf{user_dir}; +$opts{user_dir} =~ s/%u/*/g; + +# replace %u with user in config and make directory if necessary; +if ($conf{user_dir} =~ s/%u/$opts{user}/g) { + if (-e $conf{user_dir} && ! -d $conf{user_dir}) { + die "$conf{user_dir} exists and is not a directory\n"; + } elsif (! -d $conf{user_dir}) { + # directory should be world readable for load info + mkdir $conf{user_dir} or + die "Cannot create user metadata directory: $!\n"; + chmod(0755, $conf{user_dir}); + } +} +$conf{udb_file} = "$conf{user_dir}/$opts{user}.db"; + +if ($opts{put} && !defined $opts{id}) { + # lock user info + open($ulockfh, '>', "$conf{user_dir}/$opts{user}.lock"); + flock($ulockfh, LOCK_EX); + # new transfer so create identifier and directory + my @ids; + my $dir = $conf{user_dir}; + my $cdir; + while (-d $dir) { + my @dirs = glob "$dir/$opts{user}.[0-9]*"; + # linux has a compiled in max of 32k subdirs so cap at 30k + $cdir = $dir if (!$cdir && scalar(@dirs) < 30000); + push(@ids, @dirs); + $dir .= "/$opts{user}.more"; + } + if (!$cdir) { + mkdir $dir or die "Cannot create overflow metadata directory: $!\n"; + chmod(0700, $dir); + $cdir = $dir; + } + @ids = map {substr($_, rindex($_, '.') + 1)} @ids; + $opts{id} = (sort {$b <=> $a} @ids)[0]; + $opts{id}++; + # untaint id + $opts{id} = $1 if ($opts{id} =~ /(\d+)/); + $opts{base} = "$cdir/$opts{user}.$opts{id}"; + mkdir $opts{base} or die "Cannot create transfer metadata directory: $!\n"; + chmod(0700, $conf{base}); + # unlock user info + close $ulockfh; + + # initialize tells + $meta{$_} = 0 foreach (qw(do tree rtree)); + + # initialize log sizes + $meta{"$_\_size"} = 0 foreach (qw(do done error meta tree)); + + # initialize done, error, size, and total counts + foreach (qw(chattr cksum cp find ln mkdir sum)) { + $meta{"d_$_"} = 0; + $meta{"e_$_"} = 0; + $meta{"s_$_"} = 0; + $meta{"t_$_"} = 0; + } + $meta{"e_$_"} = 0 foreach (qw(corruption exception)); + + # initialize run counts + $meta{s_run} = 0; + $meta{t_run} = 0; + $meta{w_run} = 0; + $meta{s_error} = 0; + $meta{s_total} = 0; + $meta{t_split} = 0; + + # initialize other items + $meta{last} = 0; + $meta{origin} = $opts{host}; + $meta{split_id} = 0; + $meta{stop} = 0; + $meta{time0} = $time; + + # store initial metadata to file + put_meta(); + put_meta(\%meta); + + # return id + print "$opts{id}\n"; +} elsif ($opts{mounts}) { + # replace mount info in user db + while (my $line = ) { + $line =~ s/\s*\r?\n$//; + my %op = split(/[= ]+/, $line); + # ignore malformed lines with undefined op values + next if (grep(!/./, values %op)); + if ($op{args} eq 'mount') { + # eliminate any random double slashes that crept in + $line =~ s/\/\//\//g; + $udb{"mount_$op{host}:$op{local}"} = $line; + } elsif ($op{args} eq 'shell') { + $udb{"shell_$op{host}"} = 1; + } + } + # store user db to file + nstore(\%udb, $conf{udb_file}); + + # synchronize user db + sync_local("$opts{user}.db") if ($conf{sync_host}); + exit; +} elsif (defined $opts{meta}) { + $opts{meta} = 1 if ($opts{meta} <= 0); + die "Identifier required\n" if (!defined $opts{id}); + meta(); + exit; +} elsif ($opts{history}) { + history(); + exit; +} elsif (!defined $opts{id} && defined $opts{status}) { + status(); + exit; +} elsif ($opts{sync}) { + sync_remote(); + exit; +} elsif (!defined $opts{id}) { + die "Invalid options\n"; +} else { + my $dir = $conf{user_dir}; + while (-d $dir) { + last if (-d "$dir/$opts{user}.$opts{id}"); + $dir .= "/$opts{user}.more"; + } + $opts{base} = "$dir/$opts{user}.$opts{id}"; +} +if (! -d $opts{base}) { + if ($opts{get} || $opts{put}) { + print "args=stop\n"; + # exit with success so old crontabs fail in loop + exit; + } + die "Invalid identifier\n"; +} + +# prevent other processes from accessing files +lock_id(); + +if ($opts{lock}) { + # indicate ok to proceed + print "OK\n"; + STDIN->flush; + $SIG{ALRM} = sub {exit 1}; + alarm 300; + # block until alarm or connection closed + ; + exit; +} + +# retrieve metadata from file +%meta = %{get_meta()}; +$opts{meta_pack} = unpack("H*", pack("Q", $meta{meta_size})); + +# perform requested actions that require only metadata read access +if (defined $opts{status} && $opts{state} eq 'none') { + print status(); + exit; +} elsif (defined $opts{status}) { + id_status(); + exit; +} elsif ($opts{restart} && !($meta{stop} || $meta{time1} && + sum(map {$meta{"e_$_"}} qw(chattr cksum cp find ln mkdir sum)) > 0)) { + die "Only transfers in stop or error states can be restarted\n"; +} elsif ($opts{stop} && ($meta{stop} || $meta{time1})) { + die "Only running transfers can be stopped\n"; +} + +# initialize next metadata line so can detect interruption +put_meta(); + +# initialize other items for hosts that have never been seen +if (defined $opts{host} && !defined $meta{"host_$opts{host}"}) { + $meta{"clients_$opts{host}"} = 1; + $meta{"host_$opts{host}"} = 1; + $meta{ohosts}++; +} + +# create host-specific doing log if doesn't already exist +$opts{doing} = "doing_$opts{host}$opts{cid}"; +$opts{doing_log} = "$opts{base}/$opts{doing}"; +if (! -f $opts{doing_log} && ($opts{get} || $opts{put})) { + open(FILE, '>', $opts{doing_log}); + close FILE; + $meta{$opts{doing}} = 0; +} + +# update last access time +$meta{"last_$opts{host}"} = $time + if ($opts{alive} || $opts{get} || $opts{put}); + +# track client pids to prevent inadvertent simultaneous processing +if ($opts{pid}) { + my $pids = "pids_$opts{host}$opts{cid}"; + if ($meta{$pids} !~ /(?:^|,)$opts{pid}(?:,|$)/) { + # a new process has taken over the transfer + $meta{$pids} .= "," if ($meta{$pids}); + $meta{$pids} .= $opts{pid}; + } +} + +# perform put separately so it can be combined with other operations +put() if ($opts{put} && (!$opts{pid} || + # only process puts of most recent client + $meta{"pids_$opts{host}$opts{cid}"} =~ /(?:^|,)$opts{pid}$/)); + +# perform requested actions that require metadata write access +if ($opts{stop}) { + $meta{stop} = 1; + $meta{time1} = $time; +} elsif ($opts{restart}) { + # clear counts + $meta{"e_$_"} = 0 foreach (qw(chattr cksum cp find ln mkdir sum)); + $meta{$_} = 0 foreach (qw(stop s_run t_run w_run)); + delete $meta{time1}; + delete $meta{"t0_$_"} foreach (qw(chattr cksum cp find ln mkdir sum)); + delete $meta{"s0_$_"} foreach (qw(chattr cksum cp find ln mkdir sum)); + # clear host/client info so clients can be respawned + $meta{ohosts} = 0; + delete $meta{$_} foreach + (grep(/^(clients|email|host|load|os|perl|pids|shell|sleep|version|warn)_/, + keys %meta)); + + # move all failed operations out of error back into do/tree + open(DO, '>>', "$opts{base}/do"); + open(TREE, '>>', "$opts{base}/tree"); + open(ERROR, '+<', "$opts{base}/error"); + while () { + # reset number of attempts + s/((^|\s)try=)\d+/${1}0/; + if ($meta{'create-tar'} && /(^|\s)args=find/) { + # find retries must go in tree during tar creation + print TREE $_; + } else { + # use do for all other cases + print DO $_; + } + } + # clear error contents + truncate(ERROR, 0); + close ERROR; + + # move all running operations out of doing_* back into do/tree + foreach my $file (glob "$opts{base}/doing_*") { + my $log = $file; + $log =~ s/.*\///; + # untaint file + $file = $1 if ($file =~ /^(.*)$/); + open(FILE, '+<', $file); + seek(FILE, $meta{$log}, 0); + while (my $line = ) { + $line =~ s/\s*\r?\n$//; + if ($line !~ /^ /) { + # record position and skip processing if already done + $meta{$log} = tell FILE; + next; + } + + # record operation as done so not retried later + my $tell = $meta{$log}; + $meta{$log} = tell FILE; + seek(FILE, $tell, 0); + print FILE $opts{meta_pack}; + seek(FILE, $meta{$log}, 0); + + # put operation in do/tree + my %op = split(/[= ]+/, substr($line, 16)); + delete $op{$_} foreach (qw(doing rate run time)); + # do not delete hash when retrying cksum + delete $op{hash} if ($op{args} !~ /^cksum/); + $line = join(" ", map {"$_=$op{$_}"} sort(keys %op)) . "\n"; + if ($meta{'create-tar'} && $op{args} =~ /^find/) { + # find retries must go in tree during tar creation + print TREE $line; + } else { + # use do for all other cases + print DO $line; + } + } + } + + close DO; + close TREE; +} elsif ($opts{get} && ($meta{stop} || $meta{time1} || + # stop client if a new process has taken over + $meta{"pids_$opts{host}$opts{cid}"} =~ /(?:^|,)$opts{pid},/)) { + print "args=stop\n"; +} elsif ($opts{get}) { + get(); +} elsif ($opts{alive}) { + # host has functional cron if --alive used + $meta{"cron_$opts{host}"} = 1; + print "args=stop\n" if ($meta{stop} || $meta{time1}); +} +#TODO: option to list operations or state of each client host + +# send email status updates +email_status() + if ($meta{mail} && !$opts{quiet} && $opts{put} && $conf{email_domain}); + +# update log sizes +foreach my $file (glob "$opts{base}/*") { + next if ($file =~ /\/(?:find|lock)$/); + my $log = $file; + $log =~ s/.*\///; + $meta{"$log\_size"} = (stat $file)[7]; +} + +# store metadata to file +put_meta(\%meta); + +# synchronize log files +sync_local() if ($conf{sync_host}); + +# unlock id before cleanup +close $ilockfh if (defined $ilockfh); + +# detach process during cleanup +close STDIN; +close STDOUT; +close STDERR; +setsid; +open(STDIN, "/dev/null"); +open(STDERR, ">/dev/null"); + +# update global load info after detach to avoid blocking on other transfers +if ($opts{get} || $opts{put}) { + # lock user info + open($ulockfh, '>', "$conf{user_dir}/$opts{user}.lock"); + flock($ulockfh, LOCK_EX); + my %loaddb = eval {%{retrieve("$conf{user_dir}/$opts{user}.load")}}; + if ($meta{time1}) { + # remove load info for completed transfers + delete $loaddb{$_} foreach (grep(/^(next_)?id_$opts{id}(\.|_)/, + keys %loaddb)); + } else { + my $key = "id_$opts{id}$opts{cid}_$opts{host}"; + my %cload = split(/[= ]+/, $meta{"load_$opts{host}$opts{cid}"}); + if ($cload{ratio} == -1 && $loaddb{$key}) { + # client was throttled so recompute current load + my %load = split(/[= ]+/, $loaddb{$key}); + my $old = $load{time}; + my $new = $old + $cload{time}; + delete $load{time}; + # scale rates by adjusted interval + $load{$_} *= $old / $new foreach (keys %load); + $load{"cpu_host_$opts{host}"} += $cload{cpu} * $cload{time} / $new; + $load{time} = $new; + $loaddb{$key} = join(" ", map {"$_=$load{$_}"} keys(%load)); + } elsif ($loaddb{"next_$key"}) { + my %load = split(/[= ]+/, $loaddb{"next_$key"}); + $cload{time} = 1 if (!$cload{time}); + # convert sizes to MB/s and scale by actual/estimated ratio + $load{$_} = $cload{ratio} * $load{$_} / 1E6 / $cload{time} + foreach (keys %load); + $load{"cpu_host_$opts{host}"} = $cload{cpu}; + $load{time} = $cload{time}; + $loaddb{$key} = join(" ", map {"$_=$load{$_}"} keys(%load)); + } + # update next load with fs/host info collected in get() + $loaddb{"next_$key"} = join(" ", map {"$_=$nload{$_}"} keys(%nload)) + if (scalar(keys %nload)); + } + nstore(\%loaddb, "$conf{user_dir}/$opts{user}.load"); + chmod(0644, "$conf{user_dir}/$opts{user}.load"); + sync_local("$opts{user}.load") if ($conf{sync_host}); + # unlock user info + close $ulockfh; +} + +# remove status directories older than expiration time +my $more; +while (-d "$conf{user_dir}/$more") { + foreach my $dir (glob "$conf{user_dir}/$more$opts{user}.[0-9]*") { + # untaint dir (should be user.id under base+more user directory) + $dir = $1 if ($dir =~ /^(\Q$conf{user_dir}\E\/\Q$more\E\Q$opts{user}\E\.\d+)$/); + my $id = $dir; + $id =~ s/.*\.//; + # do not remove directory associated with this manager invocation + next if ($id == $opts{id}); + my $mtime = (stat("$dir/meta"))[9]; + if ($mtime + $conf{data_expire} < $time) { + rmtree($dir); + # synchronize deleted directory + sync_local("$more$opts{user}.$id") if ($conf{sync_host}); + } + } + $more .= "$opts{user}.more/"; +} + +#################### +#### build_find #### +#################### +# build tied db of processed directories from entries in tree log +sub build_find { + # remove old db + unlink "$opts{base}/find"; + my %find; + tie(%find, 'DB_File', "$opts{base}/find", O_RDWR | O_CREAT, 0600); + if (open(TREE, '<', "$opts{base}/tree")) { + while () { + s/\s*\r?\n$//; + my %op = split(/[= ]+/, $_); + my @args = split(/,/, $op{args}); + # only initial finds are used during reconstruction + next if ($args[0] ne 'find' || defined $op{try}); + $find{unescape($args[1])} = 1; + } + close TREE; + $find{t_find} = $meta{t_find}; + } + untie %find; + #TODO: error handling if cannot tie or open tree +} + +##################### +#### debug_print #### +##################### +# print given text from get to stdout and mirror to file if debugging enabled +sub debug_print { + my $type = shift; + if ($conf{debug} || $conf{"debug_$opts{user}"}) { + # open user-specific debug file if not already open + open($dbgfh, '>>', "$conf{user_dir}/$opts{user}.debug") if (!$dbgfh); + print $dbgfh "$localtime $opts{host} $opts{id}$opts{cid} $type "; + print $dbgfh $_ foreach (@_); + } + if ($type eq 'GET') { + print $_ foreach (@_); + } +} + +######################## +#### default_select #### +######################## +# return random host whose sshd is pingable from set of given hosts +sub default_select { + # choose original host if available + my $host = shift; + my @hosts = @_; + my $np = Net::Ping->new('tcp', 1); + $np->port_number(22); + do { + # pick random host + $host = splice(@hosts, rand @hosts, 1); + # check availability via tcp ping to ssh port + return $host if ($np->ping($host)); + } while ($host); + return undef; +} + +###################### +#### email_status #### +###################### +# send invoking user email with current status +sub email_status { + # obtain status by parsing status() output + my $table = status(); + my @rows = split(/\n/, $table); + my @cols = split(/\s*\|\s*/, $rows[3]); + my $state0 = $cols[1]; + my $state = $state0; + # ignore warnings when --sync used + $state =~ s/\+warn// if ($meta{sync}); + $state =~ s/run\+//; + # abort if running or have sent this message type before + return if ($state eq 'run' || $meta{"email_$state0"}); + + # show original command so will be correct for user's installation + my $ucmd = $meta{command}; + # customized escape to allow ' ', ':', '=', and '\' + $ucmd =~ s/([^A-Za-z0-9\- :=\\_.!~*'()\/])/sprintf("%%%02X", ord($1))/eg; + # limit length of command line for performance/usability + my $dindex = rindex($ucmd, " "); + $ucmd = substr($ucmd, 0, rindex($ucmd, " ", 1024)) . "..." . + substr($ucmd, $dindex) if ($dindex > 1024); + my $cmd = $ucmd; + $cmd =~ s/(^\S*(?:\s+|\/)shiftc?[^\s\/]*)(?:\s|$).*/$1/; + + # use simple html pre wrapper so will show correctly on html/text clients + my $msg = "
\n";
+    $msg .= "#" x length($ucmd);
+    $msg .= "\n$ucmd\n";
+    $msg .= "#" x length($ucmd);
+
+    # status table is always shown
+    $msg .= "\n\n$table";
+    # record email type to prevent duplicate emails
+    $meta{"email_$state0"} = $time;
+    if ($state =~ s/throttle/throttled/) {
+        $msg .= "\n\nThis transfer is being throttled based on user or admin-specified";
+        $msg .= "\nresource limits to preserve the stability of the environment.";
+        $msg .= "\nIt will continue at a rate reduced in proportion to the load it is";
+        $msg .= "\ngenerating until system load decreases to configured thresholds.";
+    }
+    if ($state =~ s/warn/warning/) {
+        my $stable = id_status('warn');
+        if (($stable =~ tr/\n/\n/) == 23) {
+            # subset of warnings
+            $msg .= "\n\nThe first 10 warnings encountered are shown below.";
+            $msg .= "\nTo show the complete set, run the following:\n\n";
+            $msg .= "    $cmd --id=$opts{id} --status --state=warn";
+        } else {
+            # all warnings
+            $msg .= "\n\nThe set of the warnings encountered is shown below.";
+        }
+        $msg .= "\n\nThese operations will be retried automatically and may";
+        $msg .= "\nstill complete successfully.  To stop this transfer";
+        $msg .= "\nwithout retrying these operations, run the following:\n\n";
+        $msg .= "    $cmd --id=$opts{id} --stop\n";
+        $msg .= "\n\n" . $stable . "\n\n";
+    }
+    if ($state =~ /error/) {
+        my $stable = id_status('error');
+        if (($stable =~ tr/\n/\n/) == 23) {
+            # subset of errors
+            $msg .= "\n\nThe first 10 errors encountered are shown below.";
+            $msg .= "\nTo show the complete set, run the following:\n\n";
+            $msg .= "    $cmd --id=$opts{id} --status --state=error";
+        } else {
+            # all errors
+            $msg .= "\n\nThe set of the errors encountered is shown below.";
+        }
+        if ($state0 =~ /run/) {
+            $msg .= "\n\nThis transfer will continue to run until all remaining";
+            $msg .= "\noperations have been attempted.  To stop this transfer";
+            $msg .= "\nwithout attempting the remainder, run the following:\n\n";
+            $msg .= "    $cmd --id=$opts{id} --stop\n";
+        } else {
+            $msg .= "\n\nTo retry the failed/incomplete portions of this ";
+            $msg .= "transfer,\nrun the following on $meta{origin} ";
+            $msg .= "(or equivalent):\n\n";
+            $msg .= "    $cmd --id=$opts{id} --restart\n";
+        }
+        $msg .= "\n\n" . $stable . "\n\n";
+    }
+    $msg .= "
\n"; + + # send message using server on localhost + require Mail::Sendmail; + Mail::Sendmail::sendmail( + Smtp => 'localhost', + From => "$opts{user}\@$conf{email_domain}", + To => "$opts{user}\@$conf{email_domain}", + Subject => "shift transfer $opts{id} $state", + Message => $msg, + 'Content-Type' => "text/html", + ); +} + +################ +#### 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; +} + +######################## +#### format_seconds #### +######################## +# return human-readable time output for given number of seconds +sub format_seconds { + my $rem = shift; + my $secs; + foreach my $unit (sort {$seconds{$b} <=> $seconds{$a}} keys(%seconds)) { + # keep dividing by largest unit + my $div = int($rem / $seconds{$unit}); + $rem %= $seconds{$unit}; + # concatenate each result + if ($opts{status} eq 'pad') { + if ($unit eq 'd' || $unit eq 'w') { + $secs .= sprintf("%0d$unit", $div); + } else { + $secs .= sprintf("%02d$unit", $div); + } + } else { + $secs .= "$div$unit" if ($div); + } + } + return $secs ? $secs : ($opts{status} eq 'pad' ? "00s" : "0s"); +} + +###################### +#### format_bytes #### +###################### +# return human-readable size output for given number of bytes +sub format_bytes { + my $nbytes = shift; + my $empty_zero = shift; + return "" if (!$nbytes && $empty_zero); + foreach my $unit (sort {$bytes{$b} <=> $bytes{$a}} keys(%bytes)) { + if (abs $nbytes >= $bytes{$unit}) { + # use 3 significant digits in fixed/scientific notation with unit + return sprintf("%.3g$unit\B", $nbytes / $bytes{$unit}); + } + } + # use 1 significant digit for fractional values + return sprintf("%.1f\B", $nbytes) if ($nbytes < 1); + # use 3 significant digits in fixed/scientific notation without unit + return sprintf("%.3g\B", $nbytes); +} + +############# +#### get #### +############# +# output a set of operations for the invoking client to process +sub get { + if ($meta{"host_$opts{host}"} == 1) { + $meta{"host_$opts{host}"} = 2; + # host retrieving operations so reduce outstanding hosts + $meta{ohosts}--; + } + + # retrieve global database from file + eval { + local $SIG{__WARN__} = sub {die}; + %db = %{retrieve($conf{db_file})}; + }; + if ($@) { + # database could not be opened + %db = (); + } + + # retrieve user database from file + eval { + local $SIG{__WARN__} = sub {die}; + %udb = %{retrieve($conf{udb_file})}; + }; + if ($@) { + # database could not be opened + %udb = (); + } + + if ($meta{"warn_$opts{host}$opts{cid}"} == 1) { + # use exponential backoff + my $sleep = 1 << $meta{"sleep_$opts{host}$opts{cid}"}; + $sleep = 10 + int(rand($sleep)) * 60; + # wait for more files or for transfer to be done + debug_print('GET', "args=sleep,$sleep\n"); + # keep doubling sleep time up to an hour + $meta{"sleep_$opts{host}$opts{cid}"}++ + if ($meta{"sleep_$opts{host}$opts{cid}"} < 6); + return; + } elsif ($meta{"warn_$opts{host}$opts{cid}"} == 0) { + # progress has been made so reset sleep timer + $meta{"sleep_$opts{host}$opts{cid}"} = 0; + } + + # throttle if load beyond given resource limits + my $sleep = throttle(); + if ($sleep > 0) { + debug_print('GET', "args=sleep,$sleep\n"); + $meta{"throttle_$opts{host}$opts{cid}"} += $sleep; + $meta{"throttled_$opts{host}$opts{cid}"} = 1; + #TODO: do something with throttle info in stats + return; + } else { + delete $meta{"throttled_$opts{host}$opts{cid}"}; + } + + # send static options first + foreach (qw(check create-tar cron dereference exclude extract-tar find-files + ignore-times include index-tar newer no-stripe offline older + ports preallocate preserve secure stripe sync verify + verify-fast)) { + debug_print('GET', "args=getopt,$_ text=", escape($meta{$_}), "\n") + if (defined $meta{$_}); + } + foreach (qw(lustre_default_stripe)) { + debug_print('GET', "args=getopt,$_ text=", escape($conf{$_}), "\n") + if (defined $conf{$_}); + } + + # determine logs to process + my @logs = ("tree", $opts{doing}); + my %sizes = ($opts{doing} => (stat $opts{doing_log})[7]); + # add operations from hosts that have cron and have timed out + foreach my $cron (grep(/^cron_/, keys %meta)) { + my $host = substr($cron, 5); + if ($meta{"last_$host"} + 1800 < $time) { + # idle for 30 minutes + if ($host ne $opts{host}) { + push(@logs, "doing_$host"); + # add logs for extra clients + foreach my $i (2..$meta{clients}) { + push(@logs, "doing_$host.$i"); + } + } + } + } + # only process other logs during tar creation when tar_creat chattrs done + push(@logs, qw(do rtree)) if (!$meta{'create-tar'} || $meta{last} && + $meta{d_chattr} >= $meta{tar_creat}); + + open(DOING, '>>', $opts{doing_log}); + open(ERROR, '>>', "$opts{base}/error"); + #TODO: need error if cannot be opened + my ($size, $files, $ops, $all); + my (%diskfs, %localfs, %rtthost); + LOG: foreach my $log (@logs) { + # process dir attrs last by themselves + last if ($log eq 'rtree' && (!$meta{last} || $meta{t_run} || $ops || + (!$meta{check} && !$meta{preserve}))); + my $fh; + if ($log eq 'rtree') { + $fh = IO::File->new("$opts{base}/tree"); + } elsif ($log =~ /^doing_/) { + # need read/write access to doing log + $fh = IO::File->new("$opts{base}/$log", 'r+'); + } else { + $fh = IO::File->new("$opts{base}/$log"); + } + $fh->seek($meta{$log}, 0); + next if (!defined $fh); + #TODO: need error if cannot be opened or seeked + my $line; + while ($size < $meta{size} && $all < $meta{files} && + ($log ne 'rtree' && defined($line = $fh->getline) || + $log eq 'rtree' && defined($line = last_line($fh)))) { + $line =~ s/\s*\r?\n$//; + # first line of rtree will be blank + next if (!$line); + # prevent loop of current host doing log + next LOG if (defined $sizes{$log} && $fh->tell > $sizes{$log}); + + if ($log =~ /^doing_/) { + if ($line !~ /^ /) { + # record position and skip processing if already done + $meta{$log} = $fh->tell; + next; + } + $line = substr($line, 16); + } + + my %op = split(/[= ]+/, $line); + my @args = split(/,/, $op{args}); + my $cmd = shift @args; + my $save_arg = $args[-1]; + + # only mkdirs are used for dir chattrs + next if ($cmd ne 'mkdir' && $log eq 'rtree'); + + if ($log =~ /^doing_/) { + # this operation was originally not completed so record failure + $meta{s_run} -= $op{size}; + $meta{t_run}--; + $op{text} = escape("Host or process failure"); + if ($op{try} >= $meta{retry}) { + # record as error and abort + my $tell = $meta{$log}; + $meta{$log} = $fh->tell; + $fh->seek($tell, 0); + # mark operation as done in case dead host reports in + $fh->print($opts{meta_pack}); + $fh->seek($meta{$log}, 0); + $line =~ s/(^|\s)text=\S+//; + print ERROR $line, " text=$op{text}\n"; + $meta{s_error} += $op{size}; + $meta{"e_$cmd"}++; + $meta{"e_$op{tool}"}++; + $meta{time1} = $time + if (($meta{last} || $meta{e_find}) && !run()); + next; + } else { + # record as warning and retry + $op{try}++; + $meta{w_run}++; + $op{state} = "warn"; + } + } + + for (my $i = 0; $i < scalar(@args); $i++) { + # skip arg 1 of ln/ln chattr since it's a name and not a file + next if (!$i && ($cmd eq 'ln' || $cmd eq 'chattr' && $op{ln})); + my $ref = {}; + # write access needed for last arg of chattr/cp/find/ln/mkdir + my $ref->{rw} = $cmd =~ /^(?:chattr|cp|find|ln|mkdir)/ && + $i == scalar(@args) - 1 ? 1 : 0; + if ($args[$i] !~ /^\//) { + # do not map remote tar dst to prevent size/split corruption + next if ($i == 1 && $cmd eq 'find' && $meta{'create-tar'}); + $args[$i] = map_remote($opts{host}, $args[$i], $ref); + last LOG if (!defined $args[$i]); + my $host = $args[$i] =~ /^([^\/:]+)%3A/ ? $1 : "localhost"; + if ($host ne 'localhost' && !defined $rtthost{$host}) { + # determine if already have round-trip time for domain + my $dn = $host; + $dn =~ s/^[^.]+.//; + # only include hosts in new domains + $rtthost{$host} = $meta{"rtt_$dn"} ? -1 : 1; + } + if ($cmd eq 'cp' && $i == 1 && $ref->{local}) { + # store target file systems for disk throttling + $diskfs{"$host:$ref->{local}"} = + "$ref->{servers}:$ref->{remote}"; + } + } else { + my $new = map_local($op{host}, $args[$i], $opts{host}, $ref); + if (defined $new) { + $args[$i] = $new; + next if (!$ref->{local}); + $localfs{$ref->{local}} |= $ref->{rw}; + if ($cmd eq 'cp' && $i == 1) { + # store target file systems for disk throttling + $diskfs{"localhost:$ref->{local}"} = + "$ref->{servers}:$ref->{remote}"; + } + } elsif ($meta{"host_$opts{host}"}) { + # host does not have access to appropriate + # file system and host name hasn't changed + last LOG; + } + } + + # store file system type/options + my $loc = $i == 0 && scalar(@args) > 1 ? "src" : "dst"; + $op{"${loc}fs"} = "$ref->{type},$ref->{opts}" if ($ref->{type}); + + # store amount of data read/written from/to host/file systems + if ($cmd eq 'cp' || $cmd eq 'sum' && $i == 0 || + $cmd eq 'cksum' && $i == 1) { + if ($cmd eq 'cp' && $i == 1) { + $nload{"iow_fs_$ref->{servers}:$ref->{remote}"} += $op{size}; + $nload{"iow_host_$ref->{host}"} += $op{size}; + if ($args[0] !~ /^\// || $args[1] !~ /^\//) { + # remote transfer so record network load + $nload{"netr_host_$ref->{host}"} += $op{size}; + } + } else { + $nload{"ior_fs_$ref->{servers}:$ref->{remote}"} += $op{size}; + $nload{"ior_host_$ref->{host}"} += $op{size}; + if ($cmd eq 'cp' && + ($args[0] !~ /^\// || $args[1] !~ /^\//)) { + # remote transfer so record network load + $nload{"netw_host_$ref->{host}"} += $op{size}; + } + } + } + } + + # never count mkdir or chattr on dir against the file total + $files++ if (scalar(@args) > 1); + $size += $op{size} if ($cmd =~ /^(?:cp|sum|cksum)/); + $ops++ if ($log ne 'rtree'); + $all++; + $meta{s_run} += $op{size} if ($op{size}); + $meta{t_run}++; + $meta{w_run}-- if ($op{state} eq 'warn'); + # record time of first instance of each operation type + if (!defined $meta{"t0_$cmd"} && + # operations should be timed from end of previous stage + ($cmd ne 'sum' || $meta{d_cp} == $meta{t_cp}) && + ($cmd ne 'cksum' || $meta{d_sum} == $meta{t_sum}) && + ($cmd ne 'chattr' || $meta{d_cksum} == $meta{t_cksum})) { + $meta{"t0_$cmd"} = $time; + # record size already done + $meta{"s0_$cmd"} = $meta{($cmd eq 'chattr' ? "d_" : "s_") . $cmd}; + if ($cmd eq 'cp' && $meta{'verify-fast'}) { + # sum operations begin with copies when --verify-fast enabled + $meta{t0_sum} = $time; + $meta{s0_sum} = 0; + } + } + + my $tell = $meta{$log}; + $meta{$log} = $fh->tell; + if ($log =~ /^doing_/) { + $fh->seek($tell, 0); + # mark operation as done in case dead host reports in + $fh->print($opts{meta_pack}); + $fh->seek($meta{$log}, 0); + } + + # rtree is for preserving directory attributes + $cmd = "chattr" if ($log eq 'rtree'); + # rejoin mapped arguments + $op{args} = join(",", $cmd, @args); + $op{host} = $opts{host}; + $op{run} = $time; + $op{doing} = tell DOING; + delete $op{state}; + delete $op{tool}; + + # dynamically insert tar_last for last record of last tar split + if ($meta{'create-tar'} && $meta{"tar_last_$save_arg"} > 0) { + my ($t1, $t2) = split(/-/, $op{tar_bytes}); + if ($meta{"tar_last_$save_arg"} < $t2 + 512) { + $op{tar_last} = 1; + # only insert very first time (will be propagated) + delete $meta{"tar_last_$save_arg"}; + } + } + + my $get = join(" ", map {"$_=$op{$_}"} sort(keys %op)) . "\n"; + print DOING " " x 16, $get; + debug_print('GET', $get); + } + $fh->close; + } + + my $errs = sum(map {$meta{"e_$_"}} qw(chattr cksum cp find ln mkdir sum)); + if (!$errs && $meta{last} && !$all && !$meta{t_run} && $meta{tar_mv}) { + foreach my $file (grep(/^tar_split_/, keys %meta)) { + next if ($meta{$file} != 1); + $file =~ s/^tar_split_//; + # dynamically insert tar_mv as final op during single split + my $get = "args=chattr,$file-1.tar host=$opts{host} size=0"; + $get .= " tar_mv=" . ($meta{"tar_nosum_$file"} ? 1 : 2); + $get .= " run=$time doing=" . (tell DOING) . "\n"; + print DOING " " x 16, $get; + debug_print('GET', $get); + $all++; + $meta{t_run}++; + } + } elsif (!$all) { + if ($meta{last} && !$meta{t_run}) { + # no retries and none running so stop + debug_print('GET', "args=stop\n"); + $meta{"sleep_$opts{host}$opts{cid}"} = 0; + } else { + # use exponential backoff + my $sleep = 1 << $meta{"sleep_$opts{host}$opts{cid}"}; + $sleep = 10 + int(rand($sleep)) * 60; + # wait for more files or for transfer to be done + debug_print('GET', "args=sleep,$sleep\n"); + # keep doubling sleep time up to an hour + $meta{"sleep_$opts{host}$opts{cid}"}++ + if ($meta{"sleep_$opts{host}$opts{cid}"} < 6); + } + } + close DOING; + close ERROR; + return if (!$all); + + # send potentially dynamic options last + foreach (keys %diskfs) { + # send target file systems for disk throttling + debug_print('GET', "args=getopt,disk_$_ text=$diskfs{$_}\n"); + } + + # these could potentially be dynamic in the future + foreach (qw(buffer threads)) { + debug_print('GET', "args=getopt,$_ text=", $meta{$_}, "\n") + if ($meta{$_}); + } + + # send individual transport options + foreach (qw(bbcp bbftp gridftp mcp msum), + $meta{secure} ? "ssh_secure" : "ssh") { + my $val = $conf{"opts_$_"}; + next if (!$val); + debug_print('GET', "args=getopt,opts_$_ text=", escape($val), "\n"); + } + + # attempt to determine type of transfer (i.e. local/lan/wan) + my ($net_dn, $net_rtt, $net_type) = ($opts{host}, 0, "wan"); + $net_dn =~ s/^[^.]+\.//; + foreach my $host (keys %rtthost) { + # transfer is on lan if domain of invoking host matches target domain + $net_type = "lan" if ($net_dn && $host =~ /\Q$net_dn\E$/); + + # find latency for associated domain + my $dn = $host; + $dn =~ s/^[^.]+\.//; + $net_rtt = $meta{"rtt_$dn"} if ($meta{"rtt_$dn"}); + # negative values are for rtt/type calculations only + next if ($rtthost{$host} == -1); + + # send remote hosts for latency measurements + debug_print('GET', "args=getopt,rtt_$host\n"); + } + $net_rtt = parse_bytes($conf{"latency_$net_type"}) if (!$net_rtt); + + my $net_bw = $meta{bandwidth}; + if (!$net_bw) { + # set default bandwidth based on xge availability or host domain + my $type = $meta{"xge_$opts{host}"} ? "xge" : + ($net_dn =~ /\.(?:$conf{org_domains})$/ ? "org" : "ind"); + $net_bw = parse_bytes($conf{"bandwidth_$type"}); + } + + my $net_win = $meta{window}; + if (!$meta{window}) { + # set default window to BDP + $net_win = int($net_bw * $net_rtt / 8); + # make sure default window is less than max window + $net_win = min($net_win, $meta{"tcpwin_$opts{host}"}) + if ($meta{"tcpwin_$opts{host}"}); + # make sure default window is greater than configured minimum + $net_win = max($net_win, parse_bytes($conf{"min_window_$net_type"})); + } + debug_print('GET', "args=getopt,window text=$net_win\n"); + + my $net_ns = $meta{streams}; + if (!$meta{streams}) { + # set default streams to number of max windows needed to consume bw + $net_ns = int($net_bw * $net_rtt / 8 / $meta{"tcpwin_$opts{host}"}) + if ($meta{"tcpwin_$opts{host}"} && + $net_win >= $meta{"tcpwin_$opts{host}"}); + $net_ns = int($net_bw * $net_rtt / 8 / $net_win) + if ($net_win < $meta{"tcpwin_$opts{host}"}); + # make sure default streams is less than configured maximum + $net_ns = min($net_ns, $conf{"max_streams_$net_type"}); + # make sure default streams is greater than configured minimum + $net_ns = max($net_ns, parse_bytes($conf{"min_streams_$net_type"})); + } + debug_print('GET', "args=getopt,streams text=$net_ns\n"); + + # send local/remote transport selections based on average file size + debug_print('GET', "args=getopt,local text=", + # use given transport if specified + $meta{local} ? $meta{local} : + # optimize for small files if avg file size less than defined size + ($size / ($files + 1) < parse_bytes($conf{small_size_local}) ? + $conf{local_small} : $conf{default_local}), "\n"); + debug_print('GET', "args=getopt,remote text=", + # use given transport if specified + $meta{remote} ? $meta{remote} : + # optimize for small files if avg file size less than defined size + ($size / ($files + 1) < parse_bytes($conf{"small_size_$net_type"}) ? + $conf{remote_small} : $conf{default_remote}), "\n"); + + if (grep(/^host_/, keys %meta) < $meta{hosts} || + $meta{"clients_$opts{host}"} < $meta{clients}) { + # run client on other/same hosts if there are enough files + my $qfiles = $meta{t_split} - $meta{t_run}; + $qfiles += $meta{"t_$_"} - $meta{"d_$_"} - $meta{"e_$_"} + foreach (qw(chattr cksum cp find ln mkdir sum)); + my $qsize = $meta{s_total} - $meta{s_run} - $meta{s_error}; + $qsize += 2 * $meta{s_total} if ($meta{verify}); + $qsize -= $meta{"s_$_"} foreach (qw(cksum cp sum)); + my $nclients; + if ($qsize * $meta{files} > $qfiles * $meta{size}) { + # queue avg size per file greater than limit avg size per file + # estimate nclients based on queue sizes + $nclients = 1.0 * $qsize / $meta{size}; + # don't use more hosts than number of files + $nclients = $qfiles if ($nclients > $qfiles); + } else { + # queue avg size per file less than limit avg size per file + # estimate nclients based on queue files + $nclients = 1.0 * $qfiles / $meta{files}; + } + + # reduce by outstanding hosts + $nclients -= $meta{ohosts}; + if ($nclients > 0 && scalar(keys %localfs) > 0) { + my %hosts; + if ($meta{'host-list'}) { + # use given host list + $hosts{$_} = {} foreach (split(/,/, $meta{'host-list'})); + } else { + # find accessible hosts based on global/user db + $hosts{substr($_, 6)} = {} foreach (grep(/^shell_/, keys %meta)); + $hosts{substr($_, 6)} = {} foreach (grep(/^shell_/, keys %db)); + $hosts{substr($_, 6)} = {} foreach (grep(/^shell_/, keys %udb)); + } + + # determine potential hosts + foreach my $fs (keys %localfs) { + foreach my $host (keys %hosts) { + if ($meta{"host_$host"} || $meta{"nohost_$host"} || + !$meta{'host-list'} && !map_local($opts{host}, + $fs, $host, {rw => $localfs{$fs}})) { + # remove hosts without local file system access + delete $hosts{$host}; + } + } + } + + while ($nclients > 0 && scalar(keys %hosts) > 0 && + grep(/^host_/, keys %meta) < $meta{hosts}) { + my $host; + if (defined $conf{select_hook}) { + # select host using configured selection hook + my ($fh, $file) = tempfile(UNLINK => 1); + close $fh; + nstore(\%hosts, $file); + # invoke configured selection hook + #TODO: remove extra shell spawn + $host = open3_get([-1, undef, -1], + "$conf{select_hook} $opts{host} $opts{host} $file"); + } + # select host using random selection policy + $host = (keys %hosts)[rand(keys %hosts)] if (!$host); + $host =~ s/\s*\r?\n$//; + delete $hosts{$host}; + debug_print('GET', "args=host,$host\n"); + $meta{"host_$host"} = 1; + $meta{"clients_$host"} = 1; + $meta{ohosts}++; + $nclients--; + } + } + + # spawn extra clients on invoking host if enough work remains + while ($nclients > 0 && $meta{"clients_$opts{host}"} < $meta{clients}) { + $nclients--; + debug_print('GET', "args=client,$opts{id}.", + ++$meta{"clients_$opts{host}"}, "\n"); + } + } +} + +################## +#### get_meta #### +################## +# return (and possibly revert to) last validated metadata from given meta file +sub get_meta { + my $mfile = shift; + my $past = shift; + my $mtell; + if (!defined $mfile) { + $mfile = "$opts{base}/meta"; + $mtell = 0; + } + my $meta; + my $fh; + open($fh, '<', $mfile); + seek($fh, -1, 2); + while (1) { + # find line starting with '[' and ending with ']', indicating valid line + my $line = last_line($fh); + last if (!defined $line); + $meta = substr($line, 1, -1); + last if (substr($line, 0, 1) eq '[' && substr($line, -1, 1) eq ']' && + (!defined $past || !--$past)); + $meta = undef; + $mtell = $fh->tell + 1 if (defined $mtell); + } + close $fh; + + if ($meta) { + # meta lines are serialized, compressed, and base64 encoded + my $zmeta64 = decode_base64($meta); + my $zmeta = uncompress($zmeta64); + $meta = thaw($zmeta); + } + if ($meta && defined $mtell && $mtell > 0) { + # metadata corrupted so revert to last known good state + foreach my $file (glob "$opts{base}/*") { + next if ($file =~ /\/(?:find|lock|meta)$/); + my $log = $file; + $log =~ s/.*\///; + my $size = defined $meta->{"$log\_size"} ? $meta->{"$log\_size"} : 0; + # untaint file + $file = $1 if ($file =~ /^(.*)$/); + # truncate all logs to last known good size + truncate($file, $size); + if ($log =~ /^doing_/ && defined $meta->{"$log\_size"}) { + # undo all operations that were processed after last good state + open(FILE, '+<', $file); + my $tell0 = $meta->{"$log\_size"}; + seek(FILE, $tell0, 0); + while () { + my $tell = tell FILE; + my $msize = substr($_, 0, 16); + $msize = unpack("Q", pack("H*", $msize)); + if ($msize >= $meta->{meta_size}) { + seek(FILE, $tell0, 0); + print FILE " " x 16; + seek(FILE, $tell, 0); + } + $tell0 = $tell; + } + close FILE; + } + } + # rebuild find db since it may contain reverted operations + build_find() if ($meta{dereference} && !$meta{'extract-tar'}); + # truncate last in case any other operations interrupted + truncate($mfile, $mtell); + } + #TODO: handle errors; + return $meta; +} + +################# +#### history #### +################# +# output table of hosts and commands for invoking user +sub history { + require Text::FormatTable; + # configure table headers + my $t = Text::FormatTable->new('r | l | l'); + $t->head(qw(id origin command)); + $t->rule; + # sort by modification time of meta file + my @metas; + my $dir = $conf{user_dir}; + while (-d $dir) { + push(@metas, glob "$dir/$opts{user}.*/meta"); + $dir .= "/$opts{user}.more"; + } + foreach my $file (sort {(stat $a)[9] <=> (stat $b)[9]} @metas) { + my $id = $file; + $id =~ s/.*\.|\/meta//g; + next if (defined $opts{id} && $opts{id} != $id); + # retrieve metadata from file + %meta = %{get_meta($file)}; + # ignore rows that do not match optional search + next if ($opts{search} && + join(" ", $meta{origin}, $meta{command}) !~ qr/$opts{search}/); + # add row for each transfer + my $cmd = $meta{command}; + # limit length of command line for performance/usability + my $dindex = rindex($cmd, " "); + $cmd = substr($cmd, 0, rindex($cmd, " ", 1024)) . "..." . + substr($cmd, $dindex) if ($dindex > 1024); + $t->row($id, "$meta{origin}\n[$meta{cwd}]", $cmd); + } + # output final table + print $t->render; +} + +################### +#### id_status #### +################### +# output detailed table of all relevant operations in current transfer or +# return subset of table in given state +sub id_status { + my $state = shift; + my $nrows = 10000; + my $once = 0; + if (defined $state) { + # this is used in email_status() to send a subset of errors/warnings + $nrows = 10; + $once = 1; + } else { + # user only wants items in a particular state + $state = $opts{state}; + } + + require Text::FormatTable; + my $t0 = Text::FormatTable->new('l | l | l | r | r | r | r'); + # target is the same for all files during tar creation so use source + my @row = (qw(state op), $meta{'create-tar'} ? "source" : "target", + qw(size date length rate)); + my @row2 = ("", "tool", "info", "", "time", "", ""); + if ($opts{status} eq 'csv') { + print join(",", @row, @row2), "\n"; + } else { + $t0->head(@row); + $t0->head(@row2); + $t0->rule; + } + + my $rows = 0; + my $t = dclone($t0); + + if (!$state || $state =~ /^(?:queue|warn)$/) { + # queued/warn operations are found in the do log + open(FILE, '<', "$opts{base}/do"); + seek(FILE, $meta{do}, 0); + while () { + chomp; + # unescape colons in remote paths + s/%3A/:/g; + my %op = split(/[= ]+/); + my @args = split(/,/, $op{args}); + # ignore rows that do not match optional search + next if ($opts{search} && join(" ", @args) !~ qr/$opts{search}/); + # target is the same for all files during tar creation so use source + $args[-1] = $op{tar_name} if ($meta{'create-tar'}); + my $size = "-"; + $size = format_bytes($op{size}) if ($args[0] =~ /^(?:cksum|cp|sum)/); + if ($op{state} eq 'warn' && (!$state || $state eq 'warn')) { + # add first row for each operation with bulk of info + @row = ("warn", $args[0], $args[-1], $size, "-", "-", "-"); + # add second row for each operation with tool and message + @row2 = ("", $op{tool}, unescape($op{text}), "", "", "", ""); + } elsif ($op{state} ne 'warn' && (!$state || $state eq 'queue')) { + @row = ("queue", $args[0], $args[-1], $size, "-", "-", "-"); + @row2 = ("", "", "", "", "", "", ""); + } else { + next; + } + if ($opts{status} eq 'csv') { + $row2[2] =~ s/"/""/g; + $row2[2] = "\"$row2[2]\"" if ($row2[2] =~ /[,"\n]/); + print join(",", @row, @row2), "\n"; + } else { + $t->row(@row); + $t->row(@row2) if ($row[0] ne 'queue'); + if (++$rows >= $nrows) { + last if ($once); + # render in multiple parts when large number of rows + print $t->render, "\n"; + $t = dclone($t0); + $rows = 0; + } + } + } + close FILE; + } + + if (!$state || $state eq 'run') { + # running operations are found in the doing logs for each host + foreach my $file (glob "$opts{base}/doing_*") { + my $doing = basename($file); + my $host = $doing; + $host =~ s/^doing_//; + open(FILE, '<', $file); + seek(FILE, $meta{$doing}, 0); + while () { + next if (!/^ /); + $_ = substr($_, 16); + chomp; + # unescape colons in remote paths + s/%3A/:/g; + my %op = split(/[= ]+/); + my @args = split(/,/, $op{args}); + # ignore rows that do not match optional search + next if ($opts{search} && join(" ", @args) !~ qr/$opts{search}/); + # target is the same for all files during tar creation so use source + $args[-1] = $op{tar_name} if ($meta{'create-tar'}); + my $size = "-"; + $size = format_bytes($op{size}) if ($args[0] =~ /^(?:cksum|cp|sum)/); + # add first row for each operation with bulk of info + @row = ("run", $args[0], $args[-1], $size, + strftime('%m/%d', localtime($op{run})), + format_seconds($time - $op{run}), "-"); + # add second row for each operation with tool and message + @row2 = ("", $op{tool}, "\@$host" . + ($op{bytes} ? " [$op{bytes})" : ""), "", + strftime('%R', localtime($op{run})), "", ""); + if ($opts{status} eq 'csv') { + $row2[2] =~ s/"/""/g; + $row2[2] = "\"$row2[2]\"" if ($row2[2] =~ /[,"\n]/); + print join(",", @row, @row2), "\n"; + } else { + $t->row(@row); + $t->row(@row2); + if (++$rows >= $nrows) { + last if ($once); + # render in multiple parts when large number of rows + print $t->render, "\n"; + $t = dclone($t0); + $rows = 0; + } + } + } + close FILE; + } + } + + if (!$state || $state eq 'error') { + # error operations are found in the error log + open(FILE, '<', "$opts{base}/error"); + while () { + chomp; + # unescape colons in remote paths + s/%3A/:/g; + my %op = split(/[= ]+/); + my @args = split(/,/, $op{args}); + # ignore rows that do not match optional search + next if ($opts{search} && join(" ", @args) !~ qr/$opts{search}/); + # target is the same for all files during tar creation so use source + $args[-1] = $op{tar_name} if ($meta{'create-tar'}); + my $size = "-"; + $size = format_bytes($op{size}) if ($args[0] =~ /^(?:cksum|cp|sum)/); + # add first row for each operation with bulk of info + @row = ("error", $args[0], $args[-1], $size, "-", "-", "-"); + # add second row for each operation with tool and message + @row2 = ("", $op{tool}, unescape($op{text}), "", "", "", ""); + if ($opts{status} eq 'csv') { + $row2[2] =~ s/"/""/g; + $row2[2] = "\"$row2[2]\"" if ($row2[2] =~ /[,"\n]/); + print join(",", @row, @row2), "\n"; + } else { + $t->row(@row); + $t->row(@row2); + if (++$rows >= $nrows) { + last if ($once); + # render in multiple parts when large number of rows + print $t->render, "\n"; + $t = dclone($t0); + $rows = 0; + } + } + } + close FILE; + } + + if (!$state || $state eq 'done') { + # done operations are found in the done log + open(FILE, '<', "$opts{base}/done"); + while () { + chomp; + # unescape colons in remote paths + s/%3A/:/g; + my %op = split(/[= ]+/); + my @args = split(/,/, $op{args}); + # ignore rows that do not match optional search + next if ($opts{search} && join(" ", @args) !~ qr/$opts{search}/); + # target is the same for all files during tar creation so use source + $args[-1] = $op{tar_name} if ($meta{'create-tar'}); + my $secs = $op{time} > 0 ? $op{time} : 1; + my $size = "-"; + my $rate = "-"; + if ($args[0] =~ /^(?:cksum|cp|sum)/) { + $size = format_bytes($op{size}); + $rate = format_bytes($op{rate}) . "/s"; + } + my $info; + $info = "#$op{hash}" if ($op{hash} && $args[0] =~ /^(?:cp|sum)/); + $info .= " " if ($info && $op{bytes}); + $info .= "[$op{bytes})" if ($op{bytes}); + $info = "-" if (!$info); + + # add first row for each operation with bulk of info + @row = ("done", $args[0], $args[-1], $size, + strftime('%m/%d', localtime($op{run})), + format_seconds($secs), $rate); + # add second row for each operation with tool and message + @row2 = ("", $op{tool}, $info, "", + strftime('%R', localtime($op{run})), "", ""); + if ($opts{status} eq 'csv') { + $row2[2] =~ s/"/""/g; + $row2[2] = "\"$row2[2]\"" if ($row2[2] =~ /[,"\n]/); + print join(",", @row, @row2), "\n"; + } else { + $t->row(@row); + $t->row(@row2); + if (++$rows >= $nrows) { + last if ($once); + # render in multiple parts when large number of rows + print $t->render, "\n"; + $t = dclone($t0); + $rows = 0; + } + } + } + close FILE; + } + + if ($opts{status} ne 'csv') { + # return/output final table depending on initial given state + $once ? return $t->render : print $t->render; + } +} + +################# +#### init_id #### +################# +# initialize settings for transfer based on getopt lines and/or defaults +sub init_id { + # initialize options with default values + foreach (qw(clients cpu hosts io ior iow net netr netw ports retry threads)) { + $meta{$_} = $conf{"default_$_"} + if (!defined $meta{$_} && $conf{"default_$_"}); + } + + # change files unit from billion to gig + $meta{files} =~ tr/[bB]/g/ if (defined $meta{files}); + + # convert size strings to numbers + foreach my $key (qw(bandwidth buffer files find-files size split split-tar + stripe window)) { + # stripe can be zero + next if ($key eq 'stripe' && defined $meta{$key} && $meta{$key} == 0); + # parse some values in binary bytes instead of decimal bytes + my $bin = $key =~ /^(?:buffer|split|stripe)$/ ? 1 : 0; + my $new = defined $meta{$key} ? parse_bytes($meta{$key}, $bin) : undef; + if (!defined $new && defined $conf{"default_$key"}) { + $new = parse_bytes($conf{"default_$key"}, $bin); + # indicate that striping was not specified + $meta{'no-stripe'} = 1 if ($key eq 'stripe'); + } + + if ($key =~ /^(?:buffer|split|stripe)$/) { + # adjust binary values to power of 2 if string not used + if ($new && $meta{$key} !~ /\D/) { + my $tmp = 1; + $tmp <<= 1 while ($new >>= 1); + $new = $tmp; + } + } + if ($key =~ /^(?:files|find-files|size)$/) { + # do not allow zero values + $new = 1 if (!$new); + } + if ($key =~ /^(?:split|split-tar)$/) { + # do not allow values that would cause metadata overrun + my $min = parse_bytes($conf{"min_split"}, $bin); + $new = $min if ($new && $new < $min); + } + + $meta{$key} = $new if (defined $new); + } +} + +################### +#### last_line #### +################### +# return the line before the current position of a given file handle +sub last_line { + my $fh = shift; + my $tell0 = $fh->tell; + # return nothing when file is at beginning + return undef if ($tell0 == 0); + my $tell = $tell0; + my ($buf, $line, $len, $pos); + do { + $tell = $tell0 - 1024; + $tell = 0 if ($tell < 0); + # seek to earlier position in file + $fh->seek($tell, 0); + my $len = 1024; + $len = $tell0 - $tell if ($len > $tell0); + # read up to initial location or that of last round + $fh->read($line, $len); + $buf = $line . $buf; + # find last newline in buffer + $pos = rindex($buf, "\n"); + $tell0 = $tell; + # keep looping while no newline found + } while ($tell > 0 && $pos < 0); + $pos = 0 if ($pos < 0); + # set file handle position for next invocation + $fh->seek($tell + $pos, 0); + # return buffer after newline + my $buf = substr($buf, $pos); + $buf =~ s/\r?\n//; + return $buf; +} + +################# +#### lock_id #### +################# +# lock the current transfer or wait for an unlock +sub lock_id { + open($ilockfh, '>', "$opts{base}/lock") || return 0; + flock($ilockfh, LOCK_EX); +} + +################## +#### fs_mount #### +################## +# return the mount point on the given host holding the given path +my %fs_cache; +sub fs_mount { + my ($host, $path) = @_; + + # check cache first to see if mount already computed + my $pos = length($path); + while (($pos = rindex($path, "/", $pos)) > 0) { + my $mnt = $fs_cache{"$host:" . substr($path, 0, $pos-- || 1)}; + return $mnt if ($mnt); + } + + # use mount info provided by global/user db + my @mnts = grep(/^mount_\Q$host\E:/, keys %meta); + push(@mnts, grep(/^mount_\Q$host\E:/, keys %db)); + push(@mnts, grep(/^mount_\Q$host\E:/, keys %udb)); + my %mnt; + # sort in descending length order to find greatest prefix + foreach (sort {length($b) <=> length($a)} @mnts) { + my $mnt = $meta{$_} ? $meta{$_} : ($udb{$_} ? $udb{$_} : $db{$_}); + %mnt = split(/[= ]+/, $mnt); + if ($path =~ /^\Q$mnt{local}\E/) { + # path begins with mount point so stop looking + last; + } else { + %mnt = (); + } + } + + if ($mnt{servers}) { + $pos = length($path); + while (($pos = rindex($path, "/", $pos)) > 0) { + # save in cache to speed up future requests + $fs_cache{"$host:" . substr($path, 0, $pos-- || 1)} = \%mnt; + last if ($pos < length($mnt{local})); + } + return \%mnt; + } + # return undef if local file system + return undef; +} + +###################### +#### map_fs_mount #### +###################### +# return the mount point on the given host that corresponds to the +# given mount point on another +my %map_fs_cache; +sub map_fs_mount { + my ($mnt1, $host2) = @_; + + # check cache first to see if mapping already computed + my $mnt2 = $map_fs_cache{"$host2:$mnt1"}; + return $mnt2 if ($mnt2); + + my @srv1 = split(/,/, $mnt1->{servers}); + # use mount info provided by global/user db + my @mnts2 = grep(/^mount_\Q$host2\E:/, keys %meta); + push(@mnts2, grep(/^mount_\Q$host2\E:/, keys %db)); + push(@mnts2, grep(/^mount_\Q$host2\E:/, keys %udb)); + # sort in descending length order to find greatest prefix + foreach (sort {length($b) <=> length($a)} @mnts2) { + $mnt2 = $meta{$_} ? $meta{$_} : ($udb{$_} ? $udb{$_} : $db{$_}); + my %mnt2 = split(/[= ]+/, $mnt2); + + # must have same remote path and type on server + if ($mnt1->{remote} eq $mnt2{remote} && $mnt1->{type} eq $mnt2{type}) { + # compute intersection of servers + my %srv2 = map {$_ => 1} split(/,/, $mnt2{servers}); + if (grep($srv2{$_}, @srv1)) { + # save in cache to speed up future requests + $map_fs_cache{"$host2:$mnt1"} = \%mnt2; + return \%mnt2; + } + } + } + $map_fs_cache{"$host2:$mnt1"} = -1; + return -1; +} + +################### +#### map_local #### +################### +# return the equivalent of a given path on a given host on another given host +sub map_local { + my ($host1, $path1, $host2, $ref) = @_; + # find file system mount of path on original host + my $mnt1 = fs_mount($host1, $path1); + if ($host1 eq $host2) { + if ($mnt1) { + # store mount info + $ref->{$_} = $mnt1->{$_} foreach (keys %{$mnt1}); + } + # return original path + return $path1; + } elsif (!$mnt1) { + # no equivalent mount found on host + return undef; + } + my $mnt2 = map_fs_mount($mnt1, $host2); + # must have correct mode + if ($mnt2 != -1 && (!$ref->{rw} || $mnt2->{opts} =~ /(?:^|,)rw(?:$|,)/)) { + # replace original mount point with new mount point + $path1 =~ s/^\Q$mnt1->{local}\E/$mnt2->{local}/; + # store mount info + $ref->{$_} = $mnt2->{$_} foreach (keys %{$mnt2}); + return $path1; + } + return undef; +} + +#################### +#### map_remote #### +#################### +# return the equivalent of a given remote path on a given host +my %map_remote_cache; +sub map_remote { + my ($lhost, $path1, $ref) = @_; + # remote paths will still be escaped at this point + if ($path1 =~ /^([^\/:]+)%3A(\/.*)?/) { + my ($rhost, $rpath) = ($1, $2); + # check if remote file system exists on local host + my $path2 = map_local($rhost, $rpath, $lhost, $ref); + return $path2 if (defined $path2); + + # find file system mount of path on original host + my $mnt1 = fs_mount($rhost, $rpath); + # return original if no mount found + return $path1 if (!$mnt1); + # check cache first to see if mapping already computed + my $mnt2 = $map_remote_cache{"$mnt1->{host}:$mnt1->{local}"}; + if (!defined $mnt2) { + # find accessible hosts based on global/user db + my @hosts = grep(/^shell_/, keys %meta); + push(@hosts, grep(/^shell_/, keys %db)); + push(@hosts, grep(/^shell_/, keys %udb)); + my %fs_hosts; + # determine potential hosts + foreach my $host (@hosts) { + $host =~ s/^shell_//; + $mnt2 = map_fs_mount($mnt1, $host); + if ($mnt2 != -1) { + # host has access to the file + if (!$ref->{rw} || $mnt2->{opts} =~ /(?:^|,)rw(?:$|,)/) { + # host has proper read/write access + $fs_hosts{$host} = $mnt2; + } + } + } + + # prune potential hosts based on number currently assigned + my $min = 1E9; + my %min_hosts; + foreach my $host (keys %fs_hosts) { + my $npicks = scalar(keys %{$meta{"picks_$host"}}); + # don't count previous selection for this host + $npicks-- if ($meta{"picks_$host"}->{$lhost}); + next if ($npicks > $min); + $min = $npicks; + $min_hosts{$npicks} = [] if (!defined $min_hosts{$npicks}); + push(@{$min_hosts{$npicks}}, $host); + } + my %picks; + $picks{$_} = $fs_hosts{$_} foreach (@{$min_hosts{$min}}); + + $mnt2 = undef; + my $pick; + if (defined $conf{select_hook}) { + # select host using configured selection hook + my ($fh, $file) = tempfile(UNLINK => 1); + close $fh; + nstore(\%picks, $file); + # invoke configured selection hook + $pick = open3_get([-1, undef], + "$conf{select_hook} $lhost $rhost $file"); + } + # revert to default selection policy when no selection + $pick = default_select($rhost, keys %picks) if (!$pick); + $pick =~ s/\s*\r?\n$//; + if ($pick) { + # clear previously picked hosts + foreach (grep(/^picks_/, keys %meta)) { + delete $meta{$_}->{$lhost}; + delete $meta{$_} if (scalar(keys %{$meta{$_}}) == 0); + } + # store that host has already been selected + $meta{"picks_$pick"}->{$lhost} = 1; + $mnt2 = $picks{$pick}; + # save in cache to speed up future requests + $map_remote_cache{"$mnt1->{host}:$mnt1->{local}"} = $mnt2; + } + } + + if (!$mnt2) { + # store mount info + $ref->{$_} = $mnt1->{$_} foreach (keys %{$mnt1}); + # return original path if can't find suitable mount + return $path1 + } + + # replace original mount point with new mount point + $rpath =~ s/^\Q$mnt1->{local}\E/$mnt2->{local}/; + # construct remote path using escaped colon after host + $rpath = "$mnt2->{host}%3A$rpath"; + # store mount info + $ref->{$_} = $mnt2->{$_} foreach (keys %{$mnt2}); + return $rpath; + } + return undef; +} + +############## +#### meta #### +############## +# output metadata for transfer specified with id option +sub meta { + my $dir = $conf{user_dir}; + while (-d $dir) { + last if (-d "$dir/$opts{user}.$opts{id}"); + $dir .= "/$opts{user}.more"; + } + if (-d $dir) { + my $file = "$dir/$opts{user}.$opts{id}/meta"; + print "$file:\n"; + # retrieve metadata from file + %meta = %{get_meta($file, $opts{meta})}; + foreach my $key (sort keys(%meta)) { + if ($key =~ /^picks_/) { + print " $key = ", join(",", keys %{$meta{$key}}), "\n"; + } else { + print " $key = $meta{$key}\n"; + } + } + } +} + +################### +#### 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); +} + +##################### +#### parse_bytes #### +##################### +# return decimal/binary equivalent of given string +sub parse_bytes { + my $text = shift; + my $binary = shift; + my $tbytes = $binary ? \%bibytes : \%bytes; + if ($text =~ /^([1-9]\d*)([kmgt])?$/i) { + my ($val, $unit) = ($1, $2); + $unit = "" if (!defined $unit); + return $val * $tbytes->{uc $unit}; + } + return undef; +} + +############# +#### put #### +############# +# record the state of file operations that were processed by a client +sub put { + # open/create log files + my %fhs; + foreach (qw(do done error tree)) { + $fhs{$_} = IO::File->new(">>$opts{base}/$_"); + #TODO: need error if cannot be opened + } + $fhs{doing} = IO::File->new("+<$opts{doing_log}"); + my $doing_size = ($fhs{doing}->stat)[7]; + my $more_finds = $meta{d_find} + $meta{e_find} == $meta{t_find} ? 0 : 1; + + my %find; + my %mnts; + $meta{"warn_$opts{host}$opts{cid}"} = -1; + $SIG{ALRM} = sub {exit 1}; + alarm 300; + while (my $line = ) { + debug_print('PUT', $line); + $line =~ s/\s*\r?\n$//; + #TODO: size limit? compression? + my %op = split(/[= ]+/, $line); + # ignore malformed lines with undefined op values + next if (grep(!/./, values %op)); + next if (defined $op{doing} && ($op{doing} < $meta{$opts{doing}} || + $op{doing} >= $doing_size)); + if (defined $op{doing}) { + $fhs{doing}->seek($op{doing}, 0); + my $done; + $fhs{doing}->read($done, 1); + # skip processing if this operation has been timed out + next if ($done ne ' '); + # indicate that operation has been seen + $fhs{doing}->seek($op{doing}, 0); + $fhs{doing}->print($opts{meta_pack}); + } + + my @args = split(/,/, $op{args}); + my $cmd = shift @args; + my ($sid, $split) = split(/:/, $op{split}); + + if ($cmd =~ /^ckattr/ && defined $op{state}) { + $meta{s_run} -= $op{size}; + $meta{t_run}--; + if ($op{state} eq 'error') { + # dst does not exist so next state is cp + $cmd = "cp"; + } else { + if (defined $op{split}) { + # record all split copies done + $meta{"sd_cp_$sid"}->bnot; + $meta{"st_cp_$sid"} = 0; + if ($meta{verify} && $op{state} eq 'done') { + # record all split sums and cksums done + $meta{"sd_sum_$sid"}->bnot; + $meta{"st_sum_$sid"} = 0; + $meta{"sd_cksum_$sid"}->bnot; + $meta{"st_cksum_$sid"} = 0; + } + } + # record copy done + $meta{s_cp} += $op{size}; + $meta{d_cp}++; + if ($op{state} eq 'done') { + if ($meta{verify}) { + # record sum and cksum done + $meta{s_sum} += $op{size}; + $meta{s_cksum} += $op{size}; + $meta{d_sum}++; + $meta{d_cksum}++; + } + # dst exists with same attrs so next state is chattr + $cmd = "chattr"; + # do not create partial operations for chattr + delete $op{split} if (defined $op{split}); + } else { + # dst exists with diff/ignored attrs so next state is cp/sum + $cmd = $meta{verify} ? "sum" : "cp"; + } + } + $op{args} =~ s/^[^,]+/$cmd/; + # more work to be done + delete $op{$_} foreach (qw(doing rate run state text time)); + $line = join(" ", map {"$_=$op{$_}"} sort(keys %op)); + if (defined $op{split}) { + my $pos = 0; + my $split = 0; + while ($pos < $op{size}) { + # create a partial operation for each split + my $end = min($pos + $meta{split}, $op{size}); + # adjust size + my $size = $end - $pos; + $line =~ s/size=\d+/size=$size/; + $line =~ s/split=\S+/split=$sid:$split/; + $fhs{do}->print("$line bytes=$pos-$end\n"); + $split++; + $pos += $meta{split}; + } + } else { + $fhs{do}->print("$line\n"); + } + } elsif ($cmd eq 'latency') { + # record domain network latency + foreach my $host (keys %op) { + next if ($host eq 'args'); + my $dn = $host; + $dn =~ s/^[^.]+.//; + $meta{"rtt_$dn"} = $op{$host}; + } + } elsif ($cmd eq 'load') { + # record host load for throttling + $meta{"load_$opts{host}$opts{cid}"} = $line; + } elsif ($cmd eq 'network') { + # record client network properties + $meta{"tcpwin_$opts{host}"} = $op{tcpwin} if ($op{tcpwin}); + $meta{"xge_$opts{host}"} = $op{xge} if ($op{xge}); + } elsif ($cmd eq 'getopt') { + # initialize transfer settings once all getopt lines received + init_id() if ($args[0] eq 'end'); + # check validity of option + next if ($args[0] !~ /^(?:bandwidth|buffer|check|clients|command|cpu|create-tar|cron|cwd|dereference|disk|exception|exclude|extract-tar|files|host-list|hosts|ignore-times|include|index-tar|io[rw]?|local|mail|net[rw]?|newer|offline|older|os|perl|ports|preallocate|preserve|remote|retry|secure|size|split|split-tar|streams|stripe|sync|threads|verify|verify-fast|version|window)$/); + if ($args[0] eq 'exception') { + # track exceptions for stats processing + $meta{e_exception}++; + } + $args[0] .= "_$opts{host}$opts{cid}" + if ($args[0] =~ /(?:exception|os|perl|version)$/); + $meta{$args[0]} = defined $op{text} ? unescape($op{text}) : 1; + } elsif ($cmd eq 'host') { + # host error so remove host from outstanding hosts + $meta{ohosts}--; + delete $meta{"host_$args[0]"}; + $meta{"nohost_$args[0]"} = 1; + } elsif ($op{state} eq 'done') { + $meta{"warn_$opts{host}$opts{cid}"} = 0; + $fhs{done}->print("$line\n"); + $meta{s_run} -= $op{size}; + $meta{"s_$cmd"} += $op{size}; + $meta{t_run}--; + # count operations that check in after transfer stopped against rate + $meta{time1} = $time if ($meta{time1}); + if (defined $op{split}) { + my $test = Math::BigInt->new(1); + $test->blsft($split); + if ($test->copy->band($meta{"sd_$cmd\_$sid"})->is_zero) { + # record that this particular split was done; + $meta{"sd_$cmd\_$sid"}->bior($test); + # decrement number of splits that need to be done; + $meta{"st_$cmd\_$sid"}--; + } + } + if (!defined $op{split} || $meta{"st_$cmd\_$sid"} <= 0) { + # only update cmd totals for unsplit files or last split + $meta{"d_$cmd"}++; + $meta{"d_$op{tool}"}++; + } + if ($meta{verify} && $cmd eq 'cp') { + if ($op{hash}) { + # transport already summed so next state is cksum + $cmd = "cksum"; + $op{args} =~ s/^[^,]+/$cmd/; + if (defined $op{split}) { + my $test = Math::BigInt->new(1); + $test->blsft($split); + if ($test->copy->band($meta{"sd_sum_$sid"})->is_zero) { + # record that this particular split was done; + $meta{"sd_sum_$sid"}->bior($test); + # decrement number of splits that need to be done; + $meta{"st_sum_$sid"}--; + } + } + if (!defined $op{split} || $meta{"st_sum_$sid"} <= 0) { + # only update sum totals for unsplit files or last split + $meta{d_sum}++; + } + $meta{s_sum} += $op{size}; + } else { + # next state is sum + $cmd = "sum"; + $op{args} =~ s/^[^,]+/$cmd/; + } + } elsif ($meta{verify} && $cmd eq 'sum') { + # next state is cksum + $cmd = "cksum"; + $op{args} =~ s/^[^,]+/$cmd/; + } elsif (($meta{check} || $meta{preserve}) && + ($cmd =~ /^(?:cksum|cp|ln)/ || + # tar mkdirs are not put in tree so are not handled by rtree + $cmd eq 'mkdir' && $meta{'create-tar'})) { + if (!defined $op{split} || + $cmd eq 'cksum' && $meta{"st_cksum_$sid"} <= 0 || + $cmd eq 'cp' && $meta{"st_cp_$sid"} <= 0) { + # indicate operation was ln so can handle differently + $op{ln} = 1 if ($cmd eq 'ln'); + # only chattr unsplit files or last split + # next state is chattr + $cmd = "chattr"; + $op{args} =~ s/^[^,]+/$cmd/; + delete $op{bytes}; + delete $op{hash}; + delete $op{split}; + } else { + # ignore splits before last split + next; + } + } else { + $meta{time1} = $time + if (($meta{last} || $meta{e_find}) && !run()); + next; + } + # more work to be done + delete $op{$_} foreach (qw(doing rate run state text time)); + $line = join(" ", map {"$_=$op{$_}"} sort(keys %op)); + $fhs{do}->print("$line\n"); + } elsif ($op{state} && $op{try} >= $meta{retry}) { + $meta{"warn_$opts{host}$opts{cid}"} = 0; + $fhs{error}->print("$line\n"); + $meta{t_run}--; + $meta{s_run} -= $op{size}; + $meta{s_error} += $op{size}; + $meta{"e_$cmd"}++; + $meta{"e_$op{tool}"}++; + $meta{time1} = $time if (($meta{last} || $meta{e_find}) && !run()); + if ($cmd eq 'chattr' && unescape($op{text}) =~ /file sizes differ$/ || + $cmd eq 'cksum' && unescape($op{text}) =~ /^Corruption/) { + # track corruption for stats processing + $meta{e_corruption}++; + } + } elsif ($op{state}) { + $meta{s_run} -= $op{size}; + $meta{t_run}--; + $op{try}++; + # count operations that check in after transfer stopped against rate + $meta{time1} = $time if ($meta{time1}); + if ($cmd eq 'chattr' && + unescape($op{text}) =~ /file sizes differ$/) { + # track corruption for stats processing + $meta{e_corruption}++; + # reset size since may have changed during chattr split join + $op{size} = (split(/,/, $op{attrs}))[7]; + # file corrupted so next state is cp + $cmd = "cp"; + $op{args} =~ s/^[^,]+/$cmd/; + # mark operations as not done + $meta{d_cp}--; + $meta{s_cp} -= $op{size}; + if ($meta{verify}) { + $meta{d_sum}--; + $meta{d_cksum}--; + $meta{s_sum} -= $op{size}; + $meta{s_cksum} -= $op{size}; + } + if ($meta{split} > 0 && $op{size} > $meta{split}) { + $op{state} = "warn"; + # more work to be done + delete $op{$_} foreach (qw(doing rate run time)); + $line = join(" ", map {"$_=$op{$_}"} sort(keys %op)); + my ($x1, $x2) = (0, $op{size}); + # bytes must be subset of existing tar bytes range + ($x1, $x2) = ($1, $2) if ($op{tar_bytes} =~ /(\d+)-(\d+)/); + my $split = 0; + while ($x1 < $x2) { + $meta{w_run}++; + # create a partial copy operation for each split + my $end = min($x1 + $meta{split}, $x2); + # adjust size + my $size = $end - $x1; + $line =~ s/size=\d+/size=$size/; + $fhs{do}->print("$line split=$meta{split_id}:$split bytes=$x1-$end\n"); + $split++; + $x1 += $meta{split}; + } + # use new split id (old one lost during chattr stage) + foreach ($meta{verify} ? qw(cp sum cksum) : qw(cp)) { + $meta{t_split} += $split; + $meta{"st_$_\_$meta{split_id}"} = $split; + $meta{"sd_$_\_$meta{split_id}"} = Math::BigInt->new(0); + } + $meta{split_id}++; + next; + } elsif ($op{tar_bytes}) { + # tar operations expect bytes field to exist + $op{bytes} = $op{tar_bytes}; + } + } elsif ($cmd eq 'cksum' && + unescape($op{text}) =~ /^Corruption,?(.*\d)?/) { + my $bytes = $1; + # track corruption for stats processing + $meta{e_corruption}++; + $meta{s_cksum} += $op{size}; + if ($bytes) { + my $end = (split(/,/, $op{attrs}))[7]; + # bytes must be subset of existing tar bytes range + $end = $1 if ($op{tar_bytes} =~ /\d+-(\d+)/); + if (defined $end) { + # adjust ranges to sane values + my @ranges = split(/,/, $bytes); + foreach my $range (@ranges) { + my ($x1, $x2) = split(/-/, $range); + if ($x1 >= $end) { + # remove range if min beyond end offset + $range = undef; + } elsif ($x2 > $end) { + # truncate dst if max beyond end offset + $range = $x1 . "-" . $end + } + } + $bytes = join(",", @ranges); + # remove empty ranges + $bytes =~ s/^,+|,+$//g; + $bytes =~ s/,,+/,/g; + } + if ($bytes) { + # reduce tries if progress being made + $op{try}-- if ($op{bytes} ne $bytes); + $op{bytes} = $bytes; + # adjust size of remaining operations + $op{size} = 0; + foreach (split(/,/, $bytes)) { + $op{size} += $2 - $1 if (/(\d+)-(\d+)/); + } + } + } + + if (!$bytes && defined $bytes) { + # remaining operations empty so done + $meta{"warn_$opts{host}$opts{cid}"} = 0; + $fhs{done}->print("$line\n"); + $meta{"s_$cmd"} += $op{size}; + if (defined $op{split}) { + my $test = Math::BigInt->new(1); + $test->blsft($split); + if ($test->copy->band($meta{"sd_$cmd\_$sid"})->is_zero) { + # record that this particular split was done; + $meta{"sd_$cmd\_$sid"}->bior($test); + # decrement number of splits that need to be done; + $meta{"st_$cmd\_$sid"}--; + } + } + if (!defined $op{split} || $meta{"st_$cmd\_$sid"} <= 0) { + # only update cmd totals for unsplit files or last split + $meta{"d_$cmd"}++; + $meta{"d_$op{tool}"}++; + if ($meta{check} || $meta{preserve}) { + # only chattr unsplit files or last split + # next state is chattr + $cmd = "chattr"; + $op{args} =~ s/^[^,]+/$cmd/; + } else { + # ignore splits before last split + next; + } + } else { + $meta{time1} = $time + if (($meta{last} || $meta{e_find}) && !run()); + next; + } + # more work to be done + delete $op{$_} foreach + (qw(bytes doing hash rate run split state text time)); + $line = join(" ", map {"$_=$op{$_}"} sort(keys %op)); + $fhs{do}->print("$line\n"); + next; + } + + if (defined $op{split}) { + my $test = Math::BigInt->new(1); + $test->blsft($split); + $test->bnot; + foreach (qw(cp sum)) { + # record that this particular split was not done; + $meta{"sd_$_\_$sid"}->band($test); + # increment number of splits that need to be done; + $meta{"st_$_\_$sid"}++; + $meta{"d_$_"}-- if ($meta{"st_$_\_$sid"} == 1); + } + } else { + $meta{d_cp}--; + $meta{d_sum}--; + } + + # file corrupted so next state is cp + $cmd = "cp"; + $op{args} =~ s/^[^,]+/$cmd/; + # reduce sizes by amount of file that was corrupt + $meta{s_cp} -= $op{size}; + $meta{s_sum} -= $op{size}; + $meta{s_cksum} -= $op{size}; + } elsif ($meta{"warn_$opts{host}$opts{cid}"}) { + $meta{"warn_$opts{host}$opts{cid}"} = 1; + } + $op{state} = "warn"; + $meta{w_run}++; + # more work to be done + delete $op{$_} foreach (qw(doing rate run time)); + # do not delete hash when retrying cksum + delete $op{hash} if ($op{args} !~ /^cksum/); + $line = join(" ", map {"$_=$op{$_}"} sort(keys %op)); + # find retries must go in tree during tar creation + my $log = $cmd eq 'find' && $meta{'create-tar'} ? "tree" : "do"; + $fhs{$log}->print("$line\n"); + } elsif (defined $op{size}) { + $meta{"t_$cmd"}++; + $meta{t_chattr}++ if ($meta{check} || $meta{preserve}); + + if ($meta{'create-tar'} && $cmd =~ /^(?:cp|ln|mkdir)/) { + if (!defined $meta{"tar_size_$args[-1]"}) { + # initialize tar metadata for this file + $meta{"tar_size_$args[-1]"} = 0; + $meta{"tar_split_$args[-1]"} = 1; + $meta{"tar_index_$args[-1]"} = 0 if ($meta{'index-tar'}); + $meta{"tar_nosum_$args[-1]"} = 1 if ($meta{verify}); + } elsif ($meta{"tar_size_$args[-1]"} < 0) { + # a negative size indicates the final size of the last split + $meta{"tar_size_$args[-1]"} = 0; + $meta{"tar_split_$args[-1]"}++; + $meta{"tar_index_$args[-1]"} = 0 if ($meta{'index-tar'}); + } + + # need .sum mv for reg files / no tracking needed for 2+ splits + delete $meta{"tar_nosum_$args[-1]"} + if ($cmd eq 'cp' || $meta{"tar_split_$args[-1]"} > 1); + $op{tar_start} = $meta{"tar_size_$args[-1]"}; + if ($cmd eq 'ln') { + my $llen = length(unescape($args[0])); + if ($llen > 100) { + # add size of long link plus extra record + my $asize = $llen + 512; + $asize += (512 - ($asize % 512)) if ($asize % 512 > 0); + $meta{"tar_size_$args[-1]"} += $asize; + } + } + my $tar_name = unescape($op{tar_name}); + if (length($tar_name) > 100) { + my $pos = index($tar_name, "/", length($tar_name) - 100); + if ($pos == -1 || $pos > 155 || length($tar_name) > 255) { + # add size of long name plus extra record + my $asize = length($tar_name) + 512; + $asize += (512 - ($asize % 512)) if ($asize % 512 > 0); + $meta{"tar_size_$args[-1]"} += $asize; + } + } + + my $size = $cmd ne 'cp' ? 0 : $op{size}; + # tar entries contain 512 byte header plus file plus padding + $meta{"tar_size_$args[-1]"} += 512; + # file contents are written after the header + $op{bytes} = $meta{"tar_size_$args[-1]"} . "-"; + $meta{"tar_size_$args[-1]"} += $size; + $op{bytes} .= $meta{"tar_size_$args[-1]"}; + $op{tar_bytes} = $op{bytes}; + # pad entry to 512 byte boundary + $meta{"tar_size_$args[-1]"} += (512 - ($size % 512)) + if ($size > 0 && $size % 512 > 0); + # use appropriate split as target + $op{args} .= "-" . $meta{"tar_split_$args[-1]"} . ".tar"; + + if ($meta{'index-tar'}) { + # designate position of entry in index file + $meta{"tar_index_$args[-1]"} += $op{tar_index}; + $op{tar_index} = $meta{"tar_index_$args[-1]"} - $op{tar_index}; + } + if ($meta{'split-tar'} && + $meta{"tar_size_$args[-1]"} >= $meta{'split-tar'}) { + # indicate last tar entry so final padding can be added + $op{tar_last} = 1; + # insert chattr op in tree to preallocate and stripe + $fhs{tree}->print("args=chattr,$args[-1]-" . + $meta{"tar_split_$args[-1]"} . ".tar host=$opts{host}" . + " tar_creat=" . $meta{"tar_size_$args[-1]"} . "\n"); + $meta{t_chattr}++; + $meta{tar_creat}++; + # move to next split by inverting size to save final value + $meta{"tar_size_$args[-1]"} = -$meta{"tar_size_$args[-1]"}; + $meta{"tar_index_$args[-1]"} = 0 if ($meta{'index-size'}); + } + + $line = join(" ", map {"$_=$op{$_}"} sort(keys %op)); + } + + if ($cmd eq 'mkdir') { + my $log = $meta{'create-tar'} ? "do" : "tree"; + $fhs{$log}->print("$line\n"); + } elsif ($cmd eq 'cp') { + $meta{s_total} += $op{size}; + if ($meta{verify}) { + $meta{t_sum}++; + $meta{t_cksum}++; + } + if ($meta{split} > 0 && $op{size} > $meta{split}) { + my ($x1, $x2) = (0, $op{size}); + # bytes must be subset of existing tar bytes range + ($x1, $x2) = ($1, $2) if ($op{bytes} =~ /(\d+)-(\d+)/); + my $split = 0; + while ($x1 < $x2) { + # create a partial copy operation for each split + my $end = min($x1 + $meta{split}, $x2); + # adjust size + my $size = $end - $x1; + $line =~ s/size=\d+/size=$size/; + $line =~ s/ bytes=\S+//; + $fhs{do}->print("$line split=$meta{split_id}:$split bytes=$x1-$end\n"); + $split++; + $x1 += $meta{split}; + } + foreach ($meta{verify} ? qw(cp sum cksum) : qw(cp)) { + $meta{t_split} += $split; + $meta{"st_$_\_$meta{split_id}"} = $split; + $meta{"sd_$_\_$meta{split_id}"} = Math::BigInt->new(0); + } + $meta{split_id}++; + } else { + $fhs{do}->print("$line\n"); + } + } else { + if ($cmd =~ /^ckattr/) { + # create additional operations without adding to logs + my @ops = qw(cp); + push(@ops, qw(sum cksum)) if ($meta{verify}); + $meta{"t_$_"}++ foreach (@ops); + $meta{s_total} += $op{size}; + if ($meta{split} > 0 && $op{size} > $meta{split}) { + my $split = ceil($op{size} / $meta{split}); + foreach (@ops) { + $meta{t_split} += $split; + $meta{"st_$_\_$meta{split_id}"} = $split; + $meta{"sd_$_\_$meta{split_id}"} = Math::BigInt->new(0); + } + # record split info for result processing + $line .= " split=$meta{split_id}:$split"; + $meta{split_id}++; + } + } + $fhs{do}->print("$line\n"); + } + } elsif ($cmd eq 'find') { + if ($meta{dereference} && !$meta{'extract-tar'}) { + # these conditions are only valid after getopt lines processed + if (!defined $find{t_find}) { + tie(%find, 'DB_File', "$opts{base}/find", O_RDWR, 0600); + if (!defined $find{t_find} || $find{t_find} != $meta{t_find}) { + # this can happen when mgr fails over as find not sync'd + untie %find; + build_find(); + tie(%find, 'DB_File', "$opts{base}/find", O_RDWR, 0600); + } + #TODO: need error if cannot be tied + } + # skip src directories already processed due to symlinks + next if ($find{$args[0]}); + $find{$args[0]} = 1; + $find{t_find}++; + } + $meta{"t_$cmd"}++; + $fhs{tree}->print("$line\n"); + } elsif ($cmd eq 'mount') { + $mnts{"mount_$op{host}:$op{local}"} = $line; + } elsif ($cmd eq 'shell') { + $mnts{"shell_$op{host}"} = $op{pbs} ? "pbs" : 1; + } + } + alarm 0; + + if ($more_finds && $meta{d_find} == $meta{t_find} && $meta{'create-tar'}) { + # tar transition from finds outstanding to no finds outstanding + foreach my $file (grep(/^tar_size_/, keys %meta)) { + my $size = abs $meta{$file}; + $file =~ s/^tar_size_//; + my $split = $meta{"tar_split_$file"}; + # store file and size so final cp op can insert tar eof padding + $meta{"tar_last_$file-$split.tar"} = $size; + if ($split == 1) { + # rename first split if there is only one split + $meta{tar_mv}++; + # use chattr to track additional move + $meta{t_chattr}++; + } + # insert chattr op in tree to preallocate and stripe + $fhs{tree}->print("args=chattr,$file-$split.tar host=$opts{host} ", + "tar_creat=$size\n"); + $meta{t_chattr}++; + $meta{tar_creat}++; + } + } + + # close log files + $fhs{$_}->close foreach (keys %fhs); + untie %find if (defined $find{t_find}); + + if ($more_finds && $meta{d_find} + $meta{e_find} == $meta{t_find}) { + # non-tar transition from finds outstanding to no finds outstanding + # mark transfers complete if no files after find + $meta{time1} = $time if (!run()); + if ($meta{e_find} + $meta{t_cp} + $meta{t_ln} + $meta{t_mkdir} == 0) { + # force error if no files (e.g. non-matching --include) + my $line; + if (open(TREE, '<', "$opts{base}/tree")) { + # use first tree line (should be find) for error line + $line = ; + close TREE; + chomp $line; + } + # this should never happen if client/manager versions match + $line = "args=find,no_src,no_dst host=no_host" if (!$line); + $line .= " run=$time state=error tool=shift-mgr text=" . + escape("No files found - this transfer cannot be restarted"); + if (open(ERROR, '>>', "$opts{base}/error")) { + print ERROR $line, "\n"; + close ERROR; + } + } elsif (!$meta{e_find}) { + # mark initialization done + $meta{last} = 1; + # initialize rtree size (log files must be closed before this) + $meta{rtree} = (stat "$opts{base}/tree")[7]; + } + } + + # update user db + if (scalar(keys %mnts) > 0) { + # retrieve global database from file + eval { + local $SIG{__WARN__} = sub {die}; + %db = %{retrieve($conf{db_file})}; + }; + if ($@) { + # database could not be opened + %db = (); + } + + # retrieve user database from file + eval { + local $SIG{__WARN__} = sub {die}; + %udb = %{retrieve($conf{udb_file})}; + }; + if ($@) { + # database could not be opened + %udb = (); + } + + my $store; + while (my ($key, $val) = each %mnts) { + if ($key =~ /^shell_/) { + # only add hosts that are not in global db + next if ($db{$key}); + if ($val eq 'pbs') { + $meta{$key} = 1; + } else { + $udb{$key} = 1; + $store = 1; + } + next; + } + + # eliminate any random double slashes that crept in + $val =~ s/\/\//\//g; + my %mnt = split(/[= ]+/, $val); + # only add hosts that are not in global db + next if ($db{"shell_$mnt{host}"}); + if ($mnts{"shell_$mnt{host}"} eq 'pbs') { + $meta{$key} = $val; + } else { + $udb{$key} = $val; + $store = 1; + } + + # add implicit mounts + foreach my $srv (split(/,/, $mnt{servers})) { + my %imnt = %mnt; + $imnt{local} = $imnt{remote}; + $imnt{host} = $srv; + $imnt{servers} = $srv; + $udb{"mount_$srv:$imnt{remote}"} = + join(" ", map {"$_=$imnt{$_}"} sort(keys %imnt)); + $store = 1; + } + } + + if ($store) { + # store user db to file + nstore(\%udb, $conf{udb_file}); + + # synchronize user db + sync_local("$opts{user}.db") if ($conf{sync_host}); + } + } +} + +################## +#### put_meta #### +################## +# begin metadata line or save given metadata and end line +sub put_meta { + my $meta = shift; + my $file = "$opts{base}/meta"; + open(FILE, '>>', $file); + if (defined $meta) { + print FILE encode_base64(compress(nfreeze($meta)), ""), "]\n"; + } else { + print FILE "["; + } + close FILE; + #TODO: handle errors; +} + +############# +#### run #### +############# +# return whether or not the current transfer is running +sub run { + my $expect = $meta{t_find} + $meta{tar_creat}; + if (!$meta{'create-tar'} || + $meta{last} && $meta{d_chattr} >= $meta{tar_creat}) { + $expect += $meta{"t_$_"} foreach (qw(cp ln mkdir)); + } + if ($meta{verify} && ($meta{check} || $meta{preserve})) { + # expect sums for done cps and cksums for done sums + $expect += $meta{"d_$_"} foreach (qw(cp sum)); + # expect file chattrs for done cksums and done lns + $expect += $meta{d_cksum} + $meta{d_ln}; + # expect dir chattrs only when no other errors + my $errs = sum(map {$meta{"e_$_"}} qw(chattr cksum cp find ln mkdir sum)); + $expect += $errs ? 0 : $meta{t_mkdir}; + } elsif ($meta{verify}) { + # expect sums for done cps and cksums for done sums + $expect += $meta{"d_$_"} foreach (qw(cp sum)); + } elsif ($meta{check} || $meta{preserve}) { + # expect file chattrs for done cps and done lns + $expect += $meta{d_cp} + $meta{d_ln}; + # expect dir chattrs only when no other errors + my $errs = sum(map {$meta{"e_$_"}} qw(chattr cp find ln mkdir)); + # when errs > 0 and rtree == 0, any chattr errors are from dirs + # and not files, so should still expect t_mkdir dir chattrs + $expect += $errs && $meta{rtree} ? 0 : $meta{t_mkdir}; + } + my $actual = sum(map {$meta{"d_$_"}} qw(chattr cksum cp find ln mkdir sum)); + my $errs = sum(map {$meta{"e_$_"}} qw(chattr cksum cp find ln mkdir sum)); + $actual += $errs; + # expect tar_mv chattrs only when no other errors + $expect += $errs ? 0 : $meta{tar_mv}; + # running if actual operations differ from expected operations + return ($expect != $actual); +} + +############### +#### stats #### +############### +# output table of consolidated stats across all transfers of invoking +# user or all users if invoked as root +sub stats { + my $all; + my %heads; + my %types; + my %users; + + # define headers for each table type + $heads{Transfers} = + [qw(xfers local lan wan dirs files size sums ssize attrs hosts)]; + $heads{Rates} = + [qw(local_min local_max local_avg lan_min lan_max lan_avg wan_min + wan_max wan_avg all_min all_max all_avg)]; + $heads{Tools} = + [qw(bbcp bbftp fish fish-tcp gridftp mcp msum rsync shiftc shift-aux)]; + $heads{Options_1} = + [qw(bandwidth buffer clients cpu create-tar exclude extract-tar files host-list + hosts include index-tar)]; + $heads{Options_2} = + [qw(io ior iow local net netr netw newer no-check no-cron no-offline + no-mail no-preserve no-verify older)]; + $heads{Options_3} = + [qw(ports preallocate remote retry secure size split split-tar streams + stripe sync threads verify-fast window)]; + $heads{Errors} = + [qw(corruption exception chattr cksum cp host ln mkdir sum)]; + + # define order in output + my @order = qw(Transfers Rates Tools Options_1 Options_2 Options_3 Errors); + + # add tool errors + push(@{$heads{Errors}}, @{$heads{Tools}}); + $_ = "e_$_" foreach (@{$heads{Errors}}); + $_ = "o_$_" foreach ( + @{$heads{Options_1}}, @{$heads{Options_2}}, @{$heads{Options_3}}); + + if (!$opts{user} && $> == 0) { + # replace %u with * to get stats from all users + $conf{user_dir} =~ s/%u/*/g; + } else { + $opts{user} = getpwuid($<) if (!$opts{user}); + $conf{user_dir} =~ s/%u/$opts{user}/g; + } + + # compute totals over all transfers + my @metas; + my $dir = $conf{user_dir}; + while (1) { + my @files = glob "$dir/*/meta"; + last if (scalar(@files) == 0); + push(@metas, @files); + $dir .= "/*.more"; + } + + foreach my $file (@metas) { + # skip transfers that have expired + my $mtime = (stat($file))[9]; + next if ($mtime + $conf{data_expire} < $time); + + # retrieve metadata from file + my %meta = %{get_meta($file)}; + + # derive transfer type + my $type = "local"; + my @args = split(/\s+/, $meta{command}); + if ($meta{origin} =~ /\Q$conf{email_domain}\E$/ && + grep(/^picks_.*\Q$conf{email_domain}\E$/, keys %meta)) { + # original client host is in local domain and remote host picked + $type = "lan"; + } elsif ($meta{origin} !~ /\Q$conf{email_domain}\E$/) { + # original client host is not in local domain + $type = "wan"; + } + + # derive user from meta file + my $user = $file; + $user =~ s/.*\/(\w+)\.\d+\/meta/$1/; + + foreach (qw(e_corruption e_exception)) { + # add corruption/exception totals even if transfer not completed + $all->{$_} += $meta{$_}; + $users{$user}->{$_} += $meta{$_}; + $types{$type}->{$_} += $meta{$_}; + } + + # skip transfers that have not completed + next if (!$meta{time1}); + my %totals; + + # transfer totals + $totals{attrs} = $meta{d_chattr}; + $totals{hosts} = grep(/^last_/, keys %meta); + $totals{dirs} = $meta{d_mkdir}; + $totals{files} = $meta{d_cp} + $meta{d_ln}; + $totals{size} = $meta{s_cp}; + $totals{ssize} = $meta{s_sum} + $meta{s_cksum}; + $totals{sums} = $meta{d_sum} + $meta{d_cksum}; + $totals{xfers} = 1; + $totals{$type} = 1; + + # tool operation totals and tool error totals + foreach (@{$heads{Tools}}) { + $totals{$_} = $meta{"d_$_"}; + $totals{"e_$_"} = $meta{"e_$_"}; + } + + # option totals + # options that must differ from configured default + foreach my $key (qw(buffer clients cpu files hosts io ior iow net netr + netw ports retry size split split-tar streams stripe + threads window)) { + # parse some values in binary bytes instead of decimal bytes + my $bin = $key =~ /^(?:buffer|split|stripe)$/ ? 1 : 0; + my $default = parse_bytes($conf{"default_$key"}, $bin); + $totals{"o_$key"} = defined $meta{$key} && + $meta{$key} ne $default ? 1 : 0; + } + # options that must be inverted + $totals{"o_no-offline"} = !$meta{offline} && !$meta{'create-tar'} && + !$meta{'extract-tar'} ? 1 : 0; + foreach (qw(check cron mail preserve verify)) { + $totals{"o_no-$_"} = !$meta{$_} ? 1 : 0; + } + # normal options + foreach (qw(create-tar exclude extract-tar host-list include index-tar + local newer older remote secure sync verify-fast wait)) { + $totals{"o_$_"} = $meta{$_} ? 1 : 0; + } + + # error totals (corruption and exception handled earlier) + foreach (qw(chattr cksum cp find ln mkdir sum)) { + $totals{"e_$_"} = $meta{"e_$_"}; + } + $totals{e_host} = grep(/^nohost_/, keys %meta); + + # add transfer stats to totals per user, per type, and overall + foreach my $head (keys %heads) { + # rates must be processed differently + next if ($head eq 'Rates'); + foreach my $key (@{$heads{$head}}) { + $all->{$key} += $totals{$key}; + $users{$user}->{$key} += $totals{$key}; + $types{$type}->{$key} += $totals{$key}; + } + } + + # compute rate for this transfer + my $dtime = $meta{time1} - $meta{time0}; + $dtime = 1 if ($dtime <= 0); + my $rate = $meta{s_cp} / $dtime; + # ignore rates of zero + next if (!$rate); + + # compute rates per user, per type, and overall + foreach my $ref ($users{$user}, $types{$type}, $all) { + $ref->{"$type\_max"} = max($rate, $ref->{"$type\_max"}); + $ref->{"$type\_min"} = $ref->{"$type\_min"} ? + min($rate, $ref->{"$type\_min"}) : $rate; + $ref->{all_max} = max($rate, $ref->{all_max}); + $ref->{all_min} = + $ref->{all_min} ? min($rate, $ref->{all_min}) : $rate; + # cumulative moving averages + $ref->{"$type\_avg"} += + (($rate - $ref->{"$type\_avg"}) / $ref->{$type}); + $ref->{all_avg} += (($rate - $ref->{all_avg}) / $ref->{xfers}); + } + } + + # convert rates to human readable format + foreach my $rate (@{$heads{Rates}}) { + $all->{$rate} = format_bytes($all->{$rate}) . "/s" + if ($all->{$rate}); + foreach my $user (keys %users) { + $users{$user}->{$rate} = format_bytes($users{$user}->{$rate}) . "/s" + if ($users{$user}->{$rate}); + } + foreach my $type (keys %types) { + $types{$type}->{$rate} = format_bytes($types{$type}->{$rate}) . "/s" + if ($types{$type}->{$rate}); + } + } + + # convert sizes to human readable format + foreach my $size (qw(size ssize)) { + $all->{$size} = format_bytes($all->{$size}, 1); + foreach my $user (keys %users) { + $users{$user}->{$size} = format_bytes($users{$user}->{$size}, 1); + } + foreach my $type (keys %types) { + $types{$type}->{$size} = format_bytes($types{$type}->{$size}, 1); + } + } + + # compute start and end dates + my $date1 = strftime('%m/%d/%y', localtime($time - $conf{data_expire})); + my $date2 = strftime('%m/%d/%y', localtime); + + # print tables + require Text::FormatTable; + foreach my $head (@order) { + my @heads = @{$heads{$head}}; + print "$head per user ($date1 - $date2)\n\n"; + + # configure table headers + my $t = Text::FormatTable->new("r" . " | r" x scalar(@heads)); + $t->head("user", map {/^\w_/ ? substr($_, 2) : $_} @heads); + $t->rule; + + # add row for each user + my $rows = 0; + foreach my $user (sort keys(%users)) { + my @row = map {$users{$user}->{$_} || ""} @heads; + # only print row if there is an actual non-empty value + next if (!first {$_} @row); + $t->row($user, @row); + $rows++; + } + + # add separator between user and type rows + $t->rule; + + # add row for each transfer type + foreach my $type (qw(local lan wan)) { + $t->row($type, map {$types{$type}->{$_} || ""} @heads); + } + # add overall totals + $t->row("all ($rows)", map {$all->{$_} || ""} @heads); + + # output final table + print $t->render, "\n\n"; + } + + # print error message table + print "Error messages per user ($date1 - $date2)\n\n"; + # configure table headers + my $t = Text::FormatTable->new("r | r | l | l"); + $t->head(qw(user id op target)); + $t->head("", "", "tool", "message"); + $t->rule; + my $ulast; + + foreach my $file + # sort by user.id + (sort {(split(/\//, $a))[-2] cmp (split(/\//, $b))[-2]} @metas) { + # skip transfers that have expired + my $mtime = (stat($file))[9]; + next if ($mtime + $conf{data_expire} < $time); + + # retrieve metadata from file + my %meta = %{get_meta($file)}; + + # skip transfers without errors + next if (!$meta{error_size} && !$meta{e_exception}); + + # derive user and id from meta file + my ($user, $id); + if ($file =~ /.*\/(\w+)\.(\d+)\/meta/) { + ($user, $id) = ($1, $2); + } else { + next; + } + + my $count; + # add all exceptions stored in metadata + if ($meta{e_exception}) { + foreach my $ex (grep(/^exception_/, keys %meta)) { + # separate different users with line + $t->rule if ($ulast && $user ne $ulast); + # only print user and id once to reduce clutter + $t->row($user ne $ulast ? $user : "", + !$count ? $id : "", "-", $ex); + $t->row("", "", "shiftc", unescape($meta{$ex})); + $count++; + $ulast = $user; + } + } + + # add up to three error messages stored in error file + $file =~ s/meta$/error/; + if (open(FILE, '<', $file)) { + # separate different users with line + $t->rule if ($ulast && $user ne $ulast); + foreach (1..3) { + my $line = ; + last if (!$line); + $line =~ s/\s*\r?\n$//; + my %op = split(/[= ]+/, $line); + my @args = split(/,/, $op{args}); + # only print user and id once to reduce clutter + $t->row($user ne $ulast ? $user : "", + !$count ? $id : "", $args[0], unescape($args[-1])); + $t->row("", "", $op{tool}, unescape($op{text})); + $count++; + $ulast = $user; + } + close FILE; + } + } + # output final table + print $t->render; +} + +################ +#### status #### +################ +# output table of all transfers with status and statistics or +# return single row when manager invoked with id option +sub status { + require Text::FormatTable; + # configure table headers + my $t = Text::FormatTable->new('r | l | r | r | r | r | r | r'); + my @row = (qw(id state dirs files), "file size", qw(date run rate)); + my @row2 = ("", "", "sums", "attrs", "sum size", "time", "left", ""); + if ($opts{status} eq 'csv') { + print join(",", @row, @row2), "\n"; + } else { + $t->head(@row); + $t->head(@row2); + $t->rule; + } + + # sort by modification time of meta file + my @metas; + my @rows; + my $dones; + my $dir = $> != 0 ? $conf{user_dir} : $opts{user_dir}; + my $user = $> != 0 ? $opts{user} : "*"; + while (1) { + my @dirs = glob "$dir/$user.[0-9]*/meta"; + last if (!scalar(@dirs)); + push(@metas, @dirs); + $dir .= "/*.more"; + } + foreach my $file (sort {$> != 0 ? (stat $a)[9] <=> (stat $b)[9] : + # sort by user name when root invocation across all transfers + $a <=> $b} @metas) { + my $id = $file; + if ($> != 0) { + $id =~ s/.*\.|\/meta//g; + } else { + # ignore old transfers + next if ((stat $file)[9] + $conf{data_expire} < $time); + # leave user name in id + $id =~ s/.*\/([\w-]+\.\d+)\/meta/$1/g; + } + if ($opts{id}) { + # ignore other ids when id is defined + next if ($id != $opts{id}); + } else { + # retrieve metadata from file + %meta = %{get_meta($file)}; + } + my $time1 = defined $meta{time1} ? $meta{time1} : $time; + my $state = "run"; + # compute number of operations in various states + my $done = sum(map {$meta{"d_$_"}} qw(chattr cksum cp find ln mkdir sum)); + my $error = sum(map {$meta{"e_$_"}} qw(chattr cksum cp find ln mkdir sum)); + my $total = sum(map {$meta{"t_$_"}} qw(chattr cksum cp find ln mkdir sum)); + # determine transfer state + if ($meta{last} && defined $meta{time1} && $done == $total) { + $state = "done"; + $dones++; + } elsif ($meta{stop}) { + $state = "stop"; + } elsif ($meta{time1}) { + $state = "error"; + } else { + $state .= "+warn" if ($meta{w_run} > 0); + $state .= "+error" if ($error > 0); + $state .= "+throttle" if (grep(/^throttled_/, keys(%meta))); + } + # skip transfers that do not match the given state + next if (!$opts{id} && $opts{state} && + $state !~ /(?:^|\+)\Q$opts{state}\E(?:$|\+)/); + # add first row for each transfer with bulk of info + my $rate = $time1 - $meta{time0} ? + $meta{s_cp} / ($time1 - $meta{time0}) : $meta{s_cp}; + my @row = ($id, $state, + "$meta{d_mkdir}/$meta{t_mkdir}" . ($meta{last} ? "" : "+"), + ($meta{d_cp} + $meta{d_ln}) . "/" . ($meta{t_cp} + $meta{t_ln}) . + ($meta{last} ? "" : "+"), + format_bytes($meta{s_cp}) . "/" . format_bytes($meta{s_total}) . + ($meta{last} ? "" : "+"), + strftime('%m/%d', localtime($meta{time0})), + format_seconds($time1 - $meta{time0}), + format_bytes($rate) . "/s"); + my $left; + if ($rate && $meta{last} && !$meta{time1}) { + # add estimated time to completion + my $rate1 = $rate; + # add time for cps, sums, cksums + foreach my $cmd (qw(cp sum cksum)) { + # skip if no operations of this type needed + next if ($meta{"t_$cmd"} == 0); + if (defined $meta{"t0_$cmd"} && $time1 > $meta{"t0_$cmd"} && + $meta{"s_$cmd"} > $meta{"s0_$cmd"}) { + # use previous rate for same operation type if available + $rate1 = ($meta{"s_$cmd"} - $meta{"s0_$cmd"}) / + ($time1 - $meta{"t0_$cmd"}); + } + # use rate for previous operation type otherwise + $left += ($meta{s_total} - $meta{"s_$cmd"}) / $rate1; + } + my $ncli = sum(map {$meta{$_}} (grep(/^clients_/, keys %meta))); + $ncli = 1 if (!$ncli); + if (defined $meta{t0_chattr} && $time1 > $meta{t0_chattr} && + $meta{d_chattr} > $meta{s0_chattr}) { + # use previous rate for chattrs when available + $rate1 = ($meta{d_chattr} - $meta{s0_chattr}) / + ($time1 - $meta{t0_chattr}); + $left += ($meta{t_chattr} - $meta{d_chattr}) / $rate1; + } else { + # add time for chattrs assuming 100/s rate otherwise + $left += ($meta{t_chattr} - $meta{d_chattr}) / 100 / $ncli; + } + # add time for non-cp manager calls assuming 1/s rate + foreach (qw(chattr cksum sum)) { + $left += ($meta{"t_$_"} - $meta{"d_$_"} - $meta{"e_$_"}) / + $meta{files} / $ncli; + } + $left = format_seconds($left); + } + my $s_total = $meta{verify} ? 2 * $meta{s_total} : 0; + # add second row for each transfer with sums, attrs and sum size + my @row2 = ("", "", + ($meta{d_sum} + $meta{d_cksum}) . "/" . + ($meta{t_sum} + $meta{t_cksum}) . ($meta{last} ? "" : "+"), + "$meta{d_chattr}/$meta{t_chattr}" . ($meta{last} ? "" : "+"), + format_bytes($meta{s_sum} + $meta{s_cksum}) . "/" . + format_bytes($s_total) . ($meta{last} ? "" : "+"), + strftime('%R', localtime($meta{time0})), $left, ""); + if ($opts{status} eq 'csv') { + print join(",", @row, @row2), "\n"; + } else { + push(@rows, \@row, \@row2); + } + } + # csv output has already been printed by this point + return if ($opts{status} eq 'csv'); + if (scalar(@metas) > $conf{status_lines}) { + if ($dones && $dones < scalar(@metas) - $conf{status_lines}) { + # leave at least one completed transfer in output + $dones--; + } elsif ($dones > scalar(@metas) - $conf{status_lines}) { + # skip older completed transfers beyond configured output limit + $dones = scalar(@metas) - $conf{status_lines}; + } + } + my $skip = $> != 0 && $dones && !$opts{id} && !$opts{state} && + scalar(@metas) > $conf{status_lines} ? $dones : 0; + for (my $i = 0; $i < scalar(@rows); $i += 2) { + next if ($skip && $rows[$i]->[1] eq 'done' && $dones-- > 0); + # add saved rows into table + $t->row(@{$rows[$i]}); + $t->row(@{$rows[$i + 1]}); + } + # return/output final table depending on id option + $opts{id} ? return $t->render : print $t->render; + # notify user when completed transfers not shown + print "\n" . ucfirst("$skip completed transfer(s) omitted ") . + "(show using \"--status --state=done\")\n" if ($skip); +} + +#################### +#### sync_local #### +#################### +# synchronize given file or metadata of current transfer to configured sync host +sub sync_local { + my $file = shift; + my $fhpid = open3_run([undef, undef, -1], + "ssh $conf{sync_host} shift-mgr --sync"); + my ($out, $in) = ($fhpid->[0], $fhpid->[1]); + + my $rc0 = sync_return($in); + + if ($file && ! -e "$conf{user_dir}/$file") { + $out->write("#" . escape($file) . " -1\n### 200\n"); + sync_return($in); + } else { + my ($meta1, $meta2); + my @files; + if ($file) { + @files = ($file); + } else { + @files = glob "$opts{base}/*"; + @files = map {s/^$conf{user_dir}\///; $_} @files; + my $mfile = "$opts{base}/meta"; + $meta1 = get_meta($mfile, 1); + $meta2 = get_meta($mfile, 2); + } + foreach $file (@files) { + my $base = basename($file); + # find is not log-structured so is rebuilt instead of sync'd + next if ($base eq 'find'); + my $doing; + if ($base =~ /^doing_/ && $meta1 && $meta2) { + $doing = min($meta1->{$base}, $meta2->{$base}); + } + # retry on failure + foreach (1 .. $conf{default_retry}) { + my @stat = stat "$conf{user_dir}/$file"; + $out->write("#" . escape($file) . " $stat[7] $stat[2] $doing\n"); + my $rc = sync_local_io($in, $out, $file, $stat[7]); + last if (!ref $rc); + } + } + } + $out->write("#exit\n") if (!ref $rc0); + open3_wait($fhpid); +} + +####################### +#### sync_local_io #### +####################### +# perform local side of sync and return result or return error message in hash +sub sync_local_io { + my ($in, $out, $file, $len) = @_; + + my $fh = IO::File->new("$conf{user_dir}/$file", O_RDONLY); + my $err; + if (!defined $fh) { + $err = {error => "Error opening $file: $!"}; + # remove newlines so doesn't interfere with protocol + $err->{error} =~ s/\n//g; + $out->write("### 500 $err->{error}: $!\n"); + } else { + $out->write("### 100\n"); + } + my $rc = sync_return($in); + return (ref $err ? $err : $rc) if (ref $err || ref $rc); + my $off = $rc; + $len -= $off; + # assume seek works + $fh->seek($off, 0); + $rc = undef; + + my $size = 4 * 1048576; + while ($len > 0) { + $size = $len if ($len < $size); + my $buf; + my $n = $fh->sysread($buf, $size); + last if ($n < $size); + $out->write("### 200\n"); + $out->write($buf); + $len -= $n; + } + $fh->close; + + if ($len > 0) { + $rc = {error => "Error reading $file: $!"}; + # remove newlines so doesn't interfere with protocol + $rc->{error} =~ s/\n//g; + $out->write("### 500 $rc->{error}\n"); + sync_return($in); + } else { + $out->write("### 200\n"); + $rc = sync_return($in); + } + return $rc; +} + +##################### +#### sync_remote #### +##################### +# initiate fish protocol and perform each transfer given on STDIN +sub sync_remote { + $SIG{'CHLD'} = 'IGNORE'; + + my $in = \*STDIN; + my $out = \*STDOUT; + $out->autoflush(1); + + # indicate running + $out->write("### 200\n"); + + while (defined($_ = $in->getline)) { + s/^\s+|\s+$//g; + next if (!s/^#//); + my @args = map {unescape($_)} split(/\s+/); + exit if (scalar(@args) == 1 && $args[0] eq 'exit'); + my $rc = sync_remote_io($in, $out, @args); + } +} + +######################## +#### sync_remote_io #### +######################## +# perform remote side of sync and return result or return error message in hash +sub sync_remote_io { + my ($in, $out, $file, $len, $mode, $doing) = @_; + + # untaint file + $file = $1 if ($file =~ /(.*)/); + # untaint mode + $mode = $1 if ($mode =~ /(.*)/); + + $file = "$conf{user_dir}/$file"; + if ($len < 0) { + # file/dir does not exist on client so remove + rmtree($file); + $out->write("### 200\n"); + return sync_return($in); + } + + my $off = (stat $file)[7]; + if ($off > $len || $file =~ /\.(db|load)$/) { + # server file bigger than client file or db/lock file - copy whole + truncate($file, 0); + $off = 0; + } elsif ($file =~ /doing_/) { + $off = $doing; + } elsif ($off && $off < $len) { + $off--; + } + + # create implicit directories + eval {mkpath(dirname($file), {mode => 0755})}; + + my $fh = IO::File->new($file, O_WRONLY | O_CREAT); + my $err; + if (!defined $fh) { + $err = {error => "Error opening $file: $!"}; + } elsif (defined $off && !$fh->seek($off, 0)) { + $fh->close; + $err = {error => "Error seeking $file: $!"}; + } + + if ($err) { + # remove newlines so doesn't interfere with protocol + $err->{error} =~ s/\n//g; + $out->write("### 500 $err->{error}\n"); + } else { + $out->write("$off\n"); + $out->write("### 100\n"); + } + my $rc = sync_return($in); + return (ref $err ? $err : $rc) if (ref $err || ref $rc); + $rc = undef; + $len -= $off; + + my $size = 4 * 1048576; + while ($len > 0) { + $size = $len if ($len < $size); + $rc = sync_return($in); + if (ref $rc) { + $fh->close; + return $rc; + } + my $buf; + my $n = $in->read($buf, $size); + last if ($n < $size); + $fh->syswrite($buf); + $len -= $n; + } + $fh->close; + chmod($mode & 07777, $file); + + if ($len > 0) { + $rc = {error => "Error reading $file: $!"}; + # remove newlines so doesn't interfere with protocol + $rc->{error} =~ s/\n//g; + $out->write("### 500 $rc->{error}\n"); + sync_return($in); + # revert to original size + truncate($file, $off); + } else { + $out->write("### 200\n"); + $rc = sync_return($in); + } + return $rc; +} + +##################### +#### sync_return #### +##################### +# parse fish return values and return text or return error message in hash +sub sync_return { + my $in = shift; + my $text; + while (defined($_ = $in->getline)) { + if (/^###\s+(\d+)(.*)/) { + if ($1 != 200 && $1 != 100) { + return {error => $2}; + } else { + $text =~ s/\s+$//; + return $text; + } + } else { + $text .= $_; + } + } + return {error => "Invalid protocol return"}; +} + +################## +#### throttle #### +################## +# return amount of time transfer should sleep based on configured limits +sub throttle { + my %cli_load = split(/[= ]+/, $meta{"load_$opts{host}$opts{cid}"}); + my $sleep = 0; + + # disk throttling + foreach my $fs (grep(/^disk_/, keys %cli_load)) { + if (defined $meta{$fs} && $cli_load{$fs} <= $meta{$fs}) { + # load has become less than lower threshold + delete $meta{$fs}; + } elsif (defined $meta{$fs}) { + # load still higher than lower threshold + $sleep = 300; + } + foreach my $hl ($meta{disk}, $conf{"throttle_$fs"}) { + next if ($hl !~ /^(\d+):(\d+)$/); + my ($high, $low) = split(/:/, $hl); + if ($cli_load{$fs} >= $high) { + # load has become higher than upper threshold + $meta{$fs} = $low; + $sleep = 300; + } + } + } + + # only throttle further when there was some load generated + return $sleep if ($cli_load{ratio} <= 0); + my @cli_keys = grep(/^(cpu|io[rw]?|net[rw]?)$/, keys %meta); + my @user_keys = grep(/^throttle_\w+_user/, keys %conf); + my @fshost_keys = grep(/^throttle_\w+_(fs|host)/, keys %conf); + # only throttle further when configured + return $sleep if (!scalar(@cli_keys) && !scalar(@user_keys) && + !scalar(@fshost_keys)); + + # compute new load for this transfer since its global data not updated yet + my %my_loaddb = eval {%{retrieve("$conf{user_dir}/$opts{user}.load")}}; + my %my_load = + split(/[= ]+/, $my_loaddb{"next_id_$opts{id}$opts{cid}_$opts{host}"}); + $cli_load{time} = 1 if (!$cli_load{time}); + # convert sizes to MB/s and scale by actual/estimated ratio + $my_load{$_} = $cli_load{ratio} * $my_load{$_} / 1E6 / $cli_load{time} + foreach (keys %my_load); + $my_load{time} = $cli_load{time}; + + # client throttling + foreach my $key (@cli_keys) { + next if ($meta{$key} <= 0); + my $metric = $key; + # count both r/w cases when r/w not specified + $metric .= "." if ($metric eq 'io' || $metric eq 'net'); + my $total; + $total += $my_load{$_} foreach (grep(/^$metric\_host_/, keys %my_load)); + # sleep amount necessary to bring average to specified limit + my $tmp = ($total / $meta{$key} - 1) * $my_load{time}; + $sleep = $tmp if ($tmp > $sleep); + } + + # user throttling + my $my_key = "id_$opts{id}$opts{cid}_$opts{host}"; + foreach my $key (@user_keys) { + next if ($conf{$key} <= 0); + if ($key =~ /^throttle_([a-z]+)_user(?:_(\S+))?$/) { + my ($metric, $user) = ($1, $2); + # only throttle if limit relevant to this user + next if ($user && $user ne $opts{user}); + # count both r/w cases when r/w not specified + $metric .= "." if ($metric eq 'io' || $metric eq 'net'); + my @id_vals; + my $id_load; + my $my_index; + # compute relevant load for all transfers of user + foreach my $id_key (grep(/^id_/, keys %my_loaddb)) { + if ($id_key eq $my_key) { + # use current computed load for this transfer + $my_index = scalar(@id_vals); + $id_load = \%my_load; + } else { + # all other transfers based on global load data + $id_load = {split(/[= ]+/, $my_loaddb{$id_key})}; + } + my $val; + # value may be based on multiple items when r/w not given + $val += $id_load->{$_} + foreach (grep(/^$metric\_host_/, keys %{$id_load})); + push(@id_vals, $val); + } + # only throttle if combined load of all transfers is above limit + next if (!scalar(@id_vals) || sum(@id_vals) <= $conf{$key}); + + # each transfer initially gets an equal share of the load limit + my $per_id = $conf{$key} / scalar(@id_vals); + my ($extra, $n_extra); + # determine if any transfers are not using their entire share + foreach (@id_vals) { + my $tmp = $per_id - $_; + if ($tmp > 0) { + $extra += $tmp; + $n_extra++; + } + } + # adjust per transfer limit by dividing up unused shares + $per_id += $extra / (scalar(@id_vals) - $n_extra); + # sleep amount necessary to bring average to specified limit + my $tmp = ($id_vals[$my_index] / $per_id - 1) * $cli_load{time}; + $sleep = $tmp if ($tmp > $sleep); + } + } + + # fs/host throttling + my %all_loaddb; + if (scalar(@fshost_keys)) { + # consolidate the load info from all users + foreach my $file (glob "$opts{user_dir}/*.load") { + my $user = $file; + $user =~ s/.*\/|\.load$//g; + my %loaddb = eval {%{retrieve($file)}}; + # ignore the ^next_ load fields + $all_loaddb{"$user\_$_"} = $loaddb{$_} + foreach (grep(/^id_/, keys %loaddb)); + } + } + + $my_key = "$opts{user}_$my_key"; + foreach my $key (@fshost_keys) { + next if ($conf{$key} <= 0); + if ($key =~ /^throttle_([a-z]+)_(fs|host)(?:_(\S+))?$/) { + my ($metric, $type, $type_val) = ($1, $2, $3); + # count both r/w cases when r/w not specified + $metric .= "." if ($metric eq 'io' || $metric eq 'net'); + # only throttle if limit relevant to this transfer + next if ($type_val && !grep(/^$metric\_$type\_$type_val$/, + keys %my_load)); + + # compute the fs/host values applicable to this transfer + my %my_type_vals; + if ($type_val) { + # use specified value when given + $my_type_vals{$type_val} = 1; + } else { + # use all fs/host values in this transfer when no value given + foreach (grep(/^$metric\_$type\_/, keys %my_load)) { + my $val = $_; + $val =~ s/^$metric\_$type\_//; + $my_type_vals{$val} = 1; + } + } + + foreach my $my_type_val (keys %my_type_vals) { + my @all_users; + my @all_vals; + my $all_load; + my ($my_index, $my_user_index1, $my_user_index2, $prev_user); + # compute relevant load for all transfers + foreach my $all_key (sort(keys %all_loaddb)) { + if ($all_key eq $my_key) { + # use current computed load for this transfer + $my_index = scalar(@all_vals); + $all_load = \%my_load; + } else { + # all other transfers based on global load data + $all_load = {split(/[= ]+/, $all_loaddb{$all_key})}; + } + my $user = $all_key; + $user =~ s/_id_.*//g; + # store where each user's transfer begin in load list + if ($prev_user ne $user) { + $my_user_index1 = scalar(@all_vals) + if ($user eq $opts{user}); + $my_user_index2 = scalar(@all_vals) + if ($prev_user eq $opts{user}); + push(@all_users, scalar(@all_vals)); + $prev_user = $user; + } + my $val; + # value may be based on multiple items when r/w not given + $val += $all_load->{$_} + foreach (grep(/^$metric\_$type\_$my_type_val$/, + keys %{$all_load})); + push(@all_vals, $val); + } + # only throttle if combined load of all transfers is above limit + next if (!scalar(@all_vals) || sum(@all_vals) <= $conf{$key}); + + # each user initially gets an equal share of the load limit + my $per_user = $conf{$key} / scalar(@all_users); + my $my_user_index2 = scalar(@all_vals) + if (!defined $my_user_index2); + # no throttling needed if this user is under per_user limit + next if (sum(@all_vals[ + $my_user_index1 .. $my_user_index2 - 1]) <= $per_user); + + # add extra index for processing of last user + push(@all_users, scalar(@all_vals)); + my $index1 = shift @all_users; + my ($extra, $n_extra); + # determine if any users are not using their entire share + foreach my $index2 (@all_users) { + my $tmp = $per_user - sum(@all_vals[$index1 .. $index2 - 1]); + if ($tmp > 0) { + $extra += $tmp; + $n_extra++; + } + $index1 = $index2; + } + # adjust per user limit by dividing up unused shares + $per_user += $extra / (scalar(@all_vals) - $n_extra); + + # each transfer initially gets an equal share of the user limit + my $per_id = $per_user / ($my_user_index2 - $my_user_index1); + ($extra, $n_extra) = (0, 0); + # determine if any transfers are not using their entire share + foreach (@all_vals[$my_user_index1 .. $my_user_index2 - 1]) { + my $tmp = $per_id - $_; + if ($tmp > 0) { + $extra += $tmp; + $n_extra++; + } + } + # adjust per transfer limit by dividing up unused shares + $per_id += $extra / ($my_user_index2 - $my_user_index1 - $n_extra); + # sleep amount necessary to bring average to specified limit + my $tmp = ($all_vals[$my_index] / $per_id - 1) * $cli_load{time}; + $sleep = $tmp if ($tmp > $sleep); + } + } + } + + # eliminate fractions + $sleep = int($sleep + 0.5) if ($sleep); + return $sleep; +} + +################## +#### 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; +} + +# 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{"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.18';@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;$_->{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,@_}}push@errs,"IO::Pipe: Can't spawn-NOWAIT: $!" if!$pid || $pid < 0}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{"Mail/Sendmail.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MAIL_SENDMAIL'; + package Mail::Sendmail;$VERSION='0.79';%mailcfg=('smtp'=>[qw(localhost) ],'from'=>'','mime'=>1,'retries'=>1,'delay'=>1,'tz'=>'','port'=>25,'debug'=>0);require Exporter;use strict;use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %mailcfg $address_rx $debug $log $error $retry_delay $connect_retries);use Socket;use Time::Local;use Sys::Hostname;eval("use MIME::QuotedPrint");$mailcfg{'mime'}&&=(!$@);@ISA=qw(Exporter);@EXPORT=qw(&sendmail);@EXPORT_OK=qw(%mailcfg time_to_date $address_rx $debug $log $error);my$word_rx='[\x21\x23-\x27\x2A-\x2B\x2D\x2F\w\x3D\x3F]+';my$user_rx=$word_rx .'(?:\.' .$word_rx .')*' ;my$dom_rx='\w[-\w]*(?:\.\w[-\w]*)*';my$ip_rx='\[\d{1,3}(?:\.\d{1,3}){3}\]';$address_rx='((' .$user_rx .')\@(' .$dom_rx .'|' .$ip_rx .'))';;sub time_to_date {my$time=$_[0]|| time();my@months=qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);my@wdays=qw(Sun Mon Tue Wed Thu Fri Sat);my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime($time);my$TZ=$mailcfg{'tz'};if ($TZ eq ""){my$offset=sprintf "%.1f",(timegm(localtime)- time)/ 3600;my$minutes=sprintf "%02d",abs($offset - int($offset))* 60;$TZ=sprintf("%+03d",int($offset)).$minutes}return join(" ",($wdays[$wday].','),$mday,$months[$mon],$year+1900,sprintf("%02d:%02d:%02d",$hour,$min,$sec),$TZ)}sub sendmail {$error='';$log="Mail::Sendmail v. $VERSION - " .scalar(localtime())."\n";my$CRLF="\015\012";local $/=$CRLF;local $\='';local $_;my (%mail,$k,$smtp,$server,$port,$connected,$localhost,$fromaddr,$recip,@recipients,$to,$header,);sub fail {print STDERR @_ if $^W;$error .= join(" ",@_)."\n";close S;return 0}sub socket_write {my$i;for$i (0..$#_){my$data=ref($_[$i])? $_[$i]: \$_[$i];if ($mailcfg{'debug'}> 5){if (length($$data)< 500){print ">",$$data}else {print "> [...",length($$data)," bytes sent ...]\n"}}print(S $$data)|| return 0}1}sub socket_read {my$response;do {chomp($_=);print "<$_\n" if$mailcfg{'debug'}> 5;if (/^[45]/ or!$_){return}$response .= $_}while (/^[\d]+-/);return$response}for$k (keys%mailcfg){if ($k =~ /[A-Z]/){$mailcfg{lc($k)}=$mailcfg{$k}}}while (@_){$k=shift @_;if (!$k and $^W){warn "Received false mail hash key: \'$k\'. Did you forget to put it in quotes?\n"}$k=ucfirst lc($k);$k =~ s/\s*:\s*$//o;$k =~ s/-(.)/"-" . uc($1)/ge;$mail{$k}=shift @_}$smtp=$mail{'Smtp'}|| $mail{'Server'};unshift @{$mailcfg{'smtp'}},$smtp if ($smtp and $mailcfg{'smtp'}->[0]ne $smtp);delete$mail{'Smtp'};delete$mail{'Server'};$mailcfg{'port'}=$mail{'Port'}|| $mailcfg{'port'}|| 25;delete$mail{'Port'};{local $^W=0;$mail{'Message'}=join("",$mail{'Message'},$mail{'Body'},$mail{'Text'})}delete$mail{'Body'};delete$mail{'Text'};$fromaddr=$mail{'Sender'}|| $mail{'From'}|| $mailcfg{'from'};delete$mail{'Sender'};unless ($fromaddr =~ /$address_rx/){return fail("Bad or missing From address: \'$fromaddr\'")}$fromaddr=$1;$mail{Date}||=time_to_date();$log .= "Date: $mail{Date}\n";$mail{'Message'}=~ s/\r\n/\n/go;$mail{'Mime-Version'}||='1.0';$mail{'Content-Type'}||='text/plain; charset="iso-8859-1"';unless ($mail{'Content-Transfer-Encoding'}|| $mail{'Content-Type'}=~ /multipart/io){if ($mailcfg{'mime'}){$mail{'Content-Transfer-Encoding'}='quoted-printable';$mail{'Message'}=encode_qp($mail{'Message'})}else {$mail{'Content-Transfer-Encoding'}='8bit';if ($mail{'Message'}=~ /[\x80-\xFF]/o){$error .= "MIME::QuotedPrint not present!\nSending 8bit characters, hoping it will come across OK.\n";warn "MIME::QuotedPrint not present!\n","Sending 8bit characters without encoding, hoping it will come across OK.\n" if $^W}}}$mail{'Message'}=~ s/^\./\.\./gom;$mail{'Message'}=~ s/\n/$CRLF/go;{local $^W=0;$recip=join(", ",$mail{To},$mail{Cc},$mail{Bcc})}delete$mail{'Bcc'};@recipients=();while ($recip =~ /$address_rx/go){push@recipients,$1}unless (@recipients){return fail("No recipient!")}$localhost=hostname()|| 'localhost';for$server (@{$mailcfg{'smtp'}}){unless (socket S,AF_INET,SOCK_STREAM,scalar(getprotobyname 'tcp')){return fail("socket failed ($!)")}print "- trying $server\n" if$mailcfg{'debug'}> 1;$server =~ s/\s+//go;$port=($server =~ s/:(\d+)$//o)? $1 : $mailcfg{'port'};$smtp=$server;my$smtpaddr=inet_aton$server;unless ($smtpaddr){$error .= "$server not found\n";next}my$retried=0;while ((not $connected=connect S,pack_sockaddr_in($port,$smtpaddr))and ($retried < $mailcfg{'retries'})){$retried++;$error .= "connect to $server failed ($!)\n";print "- connect to $server failed ($!)\n" if$mailcfg{'debug'}> 1;print "retrying in $mailcfg{'delay'} seconds...\n" if$mailcfg{'debug'}> 1;sleep$mailcfg{'delay'}}if ($connected){print "- connected to $server\n" if$mailcfg{'debug'}> 3;last}else {$error .= "connect to $server failed\n";print "- connect to $server failed, next server...\n" if$mailcfg{'debug'}> 1;next}}unless ($connected){return fail("connect to $smtp failed ($!) no (more) retries!")};{local $^W=0;$log .= "Server: $smtp Port: $port\n" ."From: $fromaddr\n" ."Subject: $mail{Subject}\n" ."To: "}my($oldfh)=select(S);$|=1;select($oldfh);socket_read()|| return fail("Connection error from $smtp on port $port ($_)");socket_write("HELO $localhost$CRLF")|| return fail("send HELO error");socket_read()|| return fail("HELO error ($_)");socket_write("MAIL FROM: <$fromaddr>$CRLF")|| return fail("send MAIL FROM: error");socket_read()|| return fail("MAIL FROM: error ($_)");for$to (@recipients){socket_write("RCPT TO: <$to>$CRLF")|| return fail("send RCPT TO: error");socket_read()|| return fail("RCPT TO: error ($_)");$log .= "$to\n "}socket_write("DATA$CRLF")|| return fail("send DATA error");socket_read()|| return fail("DATA error ($_)");for$header (keys%mail){next if$header eq "Message";$mail{$header}=~ s/\s+$//o;socket_write("$header: $mail{$header}$CRLF")|| return fail("send $header: error")};socket_write($CRLF,\$mail{'Message'},"$CRLF.$CRLF")|| return fail("send message error");socket_read()|| return fail("message transmission error ($_)");$log .= "\nResult: $_";socket_write("QUIT$CRLF")|| return fail("send QUIT error");socket_read();close S;return 1}1; +MAIL_SENDMAIL + +$fatpacked{"Text/FormatTable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_FORMATTABLE'; + package Text::FormatTable;use Carp;use strict;use warnings;use vars qw($VERSION);$VERSION='1.03';sub _uncolorized_length($) {my$str=shift;$str =~ s/\e \[ [^m]* m//xmsg;return length$str}sub _min_width($) {my$str=shift;my$min;for my$s (split(/\s+/,$str)){my$l=_uncolorized_length$s;$min=$l if not defined$min or $l > $min}return$min ? $min : 1}sub _max_width($) {my$str=shift;my$len=_uncolorized_length$str;return$len ? $len : 1}sub _max($$) {my ($a,$b)=@_;return$a if defined$a and (not defined$b or $a >= $b);return$b}sub _wrap($$) {my ($width,$text)=@_;my@lines=split(/\n/,$text);my@w=();for my$l (@lines){push@w,@{_wrap_line($width,$l)}}return \@w}sub _wrap_line($$) {my ($width,$text)=@_;my$width_m1=$width-1;my@t=($text);while(1){my$t=pop@t;my$l=_uncolorized_length$t;if($l <= $width){push@t,$t;return \@t}elsif($t =~ /^(.{0,$width_m1}\S)\s+(\S.*?)$/){push@t,$1;push@t,$2}elsif($t =~ /(.{$width,}?\S)\s+(\S.*?)$/){if (_uncolorized_length $1 > $width_m1){my$left=substr($1,0,$width);my$right=substr($1,$width);push@t,$left;push@t,$right;push@t,$2}else {push@t,$1;push@t,$2}}else {my$left=substr($t,0,$width);my$right=substr($t,$width);push@t,$left;push@t,$right;return \@t}}return \@t}sub _l_box($$) {my ($width,$text)=@_;my$lines=_wrap($width,$text);map {$_ .= ' 'x($width-_uncolorized_length($_))}@$lines;return$lines}sub _r_box($$) {my ($width,$text)=@_;my$lines=_wrap($width,$text);map {$_=(' 'x($width-_uncolorized_length($_)).$_)}@$lines;return$lines}sub _distribution_f($) {my$max_width=shift;return log($max_width)}sub _calculate_widths($$) {my ($self,$width)=@_;my@widths=();for my$r (@{$self->{data}}){$r->[0]eq 'data' or $r->[0]eq 'head' or next;my$cn=0;my ($max,$min)=(0,0);for my$c (@{$r->[1]}){if ($self->{fixed_widths}[$cn]){$widths[$cn][0]=$self->{fixed_widths}[$cn];$widths[$cn][1]=$self->{fixed_widths}[$cn]}else {$widths[$cn][0]=_max($widths[$cn][0],_min_width$c);$widths[$cn][1]=_max($widths[$cn][1],_max_width$c)}$cn++}}my ($total_min,$total_max)=(0,0);for my$c (@widths){$total_min += $c->[0];$total_max += $c->[1]}my$extra_width += scalar grep {$_->[0]eq '|' or $_->[0]eq ' '}(@{$self->{format}});$total_min += $extra_width;$total_max += $extra_width;if($total_max <= $width){my$cn=0;for my$c (@widths){$self->{widths}[$cn]=$c->[1];$cn++}$self->{total_width}=$total_max}else {my@dist_width;ITERATION: while(1){my$total_f=0.0;my$fixed_width=0;my$remaining=0;for my$c (@widths){if(defined$c->[2]){$fixed_width += $c->[2]}else {$total_f += _distribution_f($c->[1]);$remaining++}}my$available_width=$width-$extra_width-$fixed_width;if($available_width < $remaining*5){$available_width=$remaining*5;$width=$extra_width+$fixed_width+$available_width}my$cn=-1;COLUMN: for my$c (@widths){$cn++;next COLUMN if defined$c->[2];my$w=_distribution_f($c->[1])* $available_width / $total_f;if($c->[0]> $w){$c->[2]=$c->[0];next ITERATION}if($c->[1]< $w){$c->[2]=$c->[1];next ITERATION}$dist_width[$cn]=int($w)}last}my$cn=0;for my$c (@widths){$self->{widths}[$cn]=defined$c->[2]? $c->[2]: $dist_width[$cn];$cn++}}}sub _render_rule($$) {my ($self,$char)=@_;my$out='';my ($col,$data_col)=(0,0);for my$c (@{$self->{format}}){if($c->[0]eq '|'){if ($char eq '-'){$out .= '+'}elsif($char eq ' '){$out .= '|'}else {$out .= $char}}elsif($c->[0]eq ' '){$out .= $char}elsif($c->[0]eq 'l' or $c->[0]eq 'L' or $c->[0]eq 'r' or $c->[0]eq 'R'){$out .= ($char)x($self->{widths}[$data_col]);$data_col++}$col++}return$out."\n"}sub _render_data($$) {my ($self,$data)=@_;my@rdata;my ($col,$data_col)=(0,0);my$lines=0;my@rows_in_column;for my$c (@{$self->{format}}){if(($c->[0]eq 'l')or ($c->[0]eq 'L')){my$lb=_l_box($self->{widths}[$data_col],$data->[$data_col]);$rdata[$data_col]=$lb;my$l=scalar @$lb ;$lines=$l if$lines < $l;$rows_in_column[$data_col]=$l;$data_col++}elsif(($c->[0]eq 'r')or ($c->[0]eq 'R')){my$rb=_r_box($self->{widths}[$data_col],$data->[$data_col]);$rdata[$data_col]=$rb;my$l=scalar @$rb ;$lines=$l if$lines < $l;$rows_in_column[$data_col]=$l ;$data_col++}$col++}my$out='';for my$l (0..($lines-1)){my ($col,$data_col)=(0,0);for my$c (@{$self->{format}}){if($c->[0]eq '|'){$out .= '|'}elsif($c->[0]eq ' '){$out .= ' '}elsif($c->[0]eq 'L' or $c->[0]eq 'R'){my$start_print=$lines - $rows_in_column[$data_col];if (defined$rdata[$data_col][$l-$start_print]and $l >= $start_print){$out .= $rdata[$data_col][$l-$start_print]}else {$out .= ' 'x($self->{widths}[$data_col])}$data_col++}elsif($c->[0]eq 'l' or $c->[0]eq 'r'){if(defined$rdata[$data_col][$l]){$out .= $rdata[$data_col][$l]}else {$out .= ' 'x($self->{widths}[$data_col])}$data_col++}$col++}$out .= "\n"}return$out}sub _parse_format($$) {my ($self,$format)=@_;my@f=split(//,$format);my@format=();my@width=();my ($col,$data_col)=(0,0);my$wid;for my$f (@f){if ($f =~ /(\d+)/){$wid .= $f;next}if($f eq 'l' or $f eq 'L' or $f eq 'r' or $f eq 'R'){$format[$col]=[$f,$data_col];$width[$data_col]=$wid;$wid=undef;$data_col++}elsif($f eq '|' or $f eq ' '){$format[$col]=[$f]}else {croak "unknown column format: $f"}$col++}$self->{format}=\@format;$self->{fixed_widths}=\@width;$self->{col}=$col;$self->{data_col}=$data_col}sub new($$) {my ($class,$format)=@_;croak "new() requires one argument: format" unless defined$format;my$self={col=>'0',row=>'0',data=>[]};bless$self,$class;$self->_parse_format($format);return$self}sub _preprocess_row_data($$) {my ($self,$data)=@_;my$cn=0;for my$c (0..($#$data)){$data->[$c]=~ s/^\s+//m;$data->[$c]=~ s/\s+$//m}}sub head($@) {my ($self,@data)=@_;scalar@data==$self->{data_col}or croak "number of columns must be $self->{data_col}";$self->_preprocess_row_data(\@data);$self->{data}[$self->{row}++]=['head',\@data]}sub row($@) {my ($self,@data)=@_;scalar@data==$self->{data_col}or croak "number of columns must be $self->{data_col}";@data=map {defined $_ ? $_ : ""}@data;$self->_preprocess_row_data(\@data);$self->{data}[$self->{row}++]=['data',\@data]}sub rule($$) {my ($self,$char)=@_;$char='-' unless defined$char;$self->{data}[$self->{row}++]=['rule',$char]}sub render($$) {my ($self,$width)=@_;$width=79 unless defined$width;$self->_calculate_widths($width);my$out='';for my$r (@{$self->{data}}){if($r->[0]eq 'rule'){$out .= $self->_render_rule($r->[1])}elsif($r->[0]eq 'head'){$out .= $self->_render_data($r->[1])}elsif($r->[0]eq 'data'){$out .= $self->_render_data($r->[1])}}return$out}1; +TEXT_FORMATTABLE + +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 + diff --git a/perl/shiftc b/perl/shiftc new file mode 100755 index 0000000..b3a15ca --- /dev/null +++ b/perl/shiftc @@ -0,0 +1,6579 @@ +#!/usr/bin/perl +# +# Copyright (C) 2012-2016 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. + +# 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 Digest::MD5 qw(md5); +use Fcntl qw(:flock :mode); +use File::Basename; +use File::Find; +use File::Glob qw(:glob); +use File::Path; +use File::Spec; +use File::Spec::Unix; +use File::Temp qw(tempdir tempfile); +use Getopt::Long qw(:config bundling 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 min sum); +use Net::Ping; +use POSIX; +use Socket; +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 = 0.90; + +$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}; + +# need threads and version of Thread::Queue from perl >= 5.10.1 +my $have_threads = eval 'require 5.010_001; use threads; use Thread::Queue; 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{af} = "MESHCONF_map_print"; +$opts{d} = "MESHCONF_key_days"; +$opts{p} = "MESHCONF_mp_host"; +$opts{pf} = "MESHCONF_mp_print"; + +$opts{d} = 60 if ($opts{'keygen-user'}); #SITE + +####################### +#### parse options #### +####################### +exit 1 if (!GetOptions(\%opts, + "a=s", "b", "d=i", "f", "g", "h", "i=s", "I=s", "k", "keygen-user=s", + "m=s", "n", "N", "p=s", "r=s", "s=s", "u=s", "v", + "o=s" => sub { + my ($key, $val) = split(/=|\s+/, $_[1], 2); + $val = shift @ARGV if (!defined $val); + $opts{$_[0] . lc($key)} = " $val"; + } +)); +$opts{I} = glob("~/.ssh") if (!$opts{I}); +$opts{i} = $opts{I} . "/id_rsa" if (!$opts{i}); +# spawn new agent in batch mode or if shift transfer +$opts{n} = 1 if ($opts{b} || $ARGV[0] =~ /^shiftc?$/); +# kill agent on exit when new agent forced +$opts{k} = 1 if ($opts{n}); +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}); + +################################ +#### define aliases for vfs #### +################################ +if ($opts{r} || $opts{s}) { + foreach (qw(a d i m p t u)) { + $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 -N -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; +} + +################### +#### show help #### +################### +$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, implies -k)\n"; + print " -d DAYS keys are valid for DAYS days [$opts{d}]\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 " -k kill spawned agent (no effect if agent preexists)\n"; + print " -n force spawning of new agent\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"; + exit; +} +print STDERR "Using version $VERSION\n" if ($opts{v}); + +############################### +#### execute local command #### +############################### +if (scalar(@ARGV) > 0) { + # ignore command if key generation forced and no arguments given + my $cmd = shift @ARGV; + if ($cmd !~ /(?:^|\W)(?:bbcp|bbftp|bbscp|globus-url-copy|mesh-keykill|mesh-keytime|pcp\+|rm|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)(?:bbcp|bbftp|bbscp|globus-url-copy|mesh-keykill|mesh-keytime|pcp\+|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); +} + +=cut mesh + +#################### +#### find agent #### +#################### +my $agent_sock; +if (!$opts{n}) { + my @agents = glob("$opts{tmp_d}/ssh-*/agent.*"); + push(@agents, glob("/tmp/ssh-*/agent.*")) if ($opts{tmp_d} ne "/tmp"); + unshift(@agents, $ENV{SSH_AUTH_SOCK}); + foreach my $agent (@agents) { + my @stat = stat $agent; + next if ($stat[4] != $< || ! -S $agent); + print STDERR "Checking validity of agent socket $agent\n" if ($opts{v}); + $ENV{SSH_AUTH_SOCK} = $agent; + my $out = open3_get([-1, undef], "ssh-add -l"); + next if ($out =~ /error connecting|open a connection|authentication socket/i); + $agent_sock = $agent; + last; + } +} + +=for mesh + +##################### +#### start agent #### +##################### +if (!$opts{N} && !defined $agent_sock) { + print STDERR "Starting agent\n" if ($opts{v}); + $agent_sock = open3_get([-1, undef, -1], "ssh-agent -c"); + if ($opts{k} && $agent_sock =~ /SSH_AGENT_PID\s+(\d+);/) { + $opts{k} = $1; + print STDERR "Agent pid is $opts{k}\n" if ($opts{v}); + } + if ($agent_sock =~ /SSH_AUTH_SOCK\s+([^;]+);/) { + $agent_sock = $1; + } else { + die "Unable to start agent\n"; + } +} +print STDERR "Agent socket is $agent_sock\n" if ($opts{v}); +$ENV{SSH_AUTH_SOCK} = $agent_sock; + +################## +#### find key #### +################## +my $agent_key; +my $agent_key_time; +if (!$opts{N} && !$opts{g}) { + # ignore agent keys if key generation forced + my $agent_keys = open3_get([-1, undef, -1], "ssh-add -l"); + while ($agent_keys =~ /\/meshkey\.(\d+)/g) { + if ($1 > time - 60) { + $agent_key = $1; + last; + } + } +} + +################# +#### add key #### +################# +if (!$opts{N} && !$agent_key && !$opts{g}) { + # ignore existing keys if key generation forced + foreach my $key (glob("$opts{I}/meshkey.[0-9]*")) { + if ($key =~ /\.(\d+)$/) { + $agent_key_time = $1; + my $time = $agent_key_time - time; + if ($time < 0) { + print STDERR "Removing expired key $key\n" if ($opts{v}); + unlink $key; + unlink "$key.pub"; + next; + } + print STDERR "Checking validity of key $key\n" if ($opts{v}); + my $out = open3_get([-1, undef], "ssh-keygen -l -f $key.pub"); + if ($out =~ /not a public key file|no such file/i) { + print STDERR "Removing invalid key $key\n" if ($opts{v}); + unlink $key; + unlink "$key.pub"; + next; + } + $agent_key = $key; + print STDERR "Adding key $agent_key to agent\n" if ($opts{v}); + open3_get([-1, undef], "ssh-add -t $time $agent_key"); + die "Unable to add key to agent\n" if ($?); + last; + } + } +} + +###################### +#### generate key #### +###################### +if ($opts{p} ne 'none' && (!$agent_key || $opts{g})) { + die "Key generation required but batch mode enabled\n" if ($opts{b}); + print STDERR "Testing initialization of host keys\n" if ($opts{v}); + for my $h (qw(a p)) { + my $hf = $h . "f"; + my $out = open3_get([-1, undef], + "ssh -ax -oBatchMode=yes $opts{ssh_l} $opts{$h} bad-cmd"); + if ($out =~ /verification\s+failed/) { + print STDERR "No host key found for $opts{$h}\n"; + print STDERR "...continue if fingerprint is $opts{$hf}\n"; + open3_get([-1, undef], + "ssh -aqx -oStrictHostKeyChecking=ask -oPreferredAuthentications=none $opts{ssh_l} $opts{$h} bad-cmd"); + last if ($opts{p} eq $opts{a}); + } + } + + if ($opts{p} ne $opts{a}) { + # this step is not needed when MP and MAP are combined + print STDERR "Testing initialization of agent identities\n" + if ($opts{v}); + my $out = open3_get([-1, undef], + "ssh -ax -i /dev/null -oBatchMode=yes $opts{ssh_l} $opts{a} bad-cmd"); + if ($out =~ /verification\s+failed/) { + die "Host key verification failed for $opts{a}\n" + } elsif ($out =~ /denied/ && $out =~ /publickey/) { + if (! -r $opts{i}) { + print STDERR "Cannot find identity $opts{i}\n"; + print STDERR "...do you wish to generate it? (y/n) "; + my $line = ; + $line =~ s/^\s+|\s+$//g; + if ($line =~ /^y(es)?$/i) { + print STDERR "Generating identity $opts{i}\n" if ($opts{v}); + print open3_get([-1, undef], "ssh-keygen -t rsa -f $opts{i}"); + die "Unable to generate identity $opts{i}\n" if ($?); + chmod(0600, $opts{i}); + } else { + die "Unable to continue without identity $opts{i}\n"; + } + } + print STDERR "Adding identity $opts{i} to agent\n"; + print open3_get([-1, undef], "ssh-add $opts{i}"); + die "Unable to add identity to agent\n" if ($?); + print STDERR "Testing initialization of identity $opts{i}\n" + if ($opts{v}); + $out = open3_get([-1, undef], + "ssh -ax -i /dev/null -oBatchMode=yes $opts{ssh_l} $opts{a} bad-cmd"); + if ($out =~ /denied/ && $out =~ /publickey/) { + print STDERR "Checking validity of public key $opts{i}.pub\n" + if ($opts{v}); + $out = open3_get([-1, undef, -1], + "ssh-keygen -l -f $opts{i}.pub") if (-r "$opts{i}.pub"); + if ($out =~ /not a public key file/ || ! -r "$opts{i}.pub") { + print STDERR "Generating public key $opts{i}.pub from identity $opts{i}\n"; + print open3_get([-1, "$opts{i}.pub", undef], + "ssh-keygen -y -f $opts{i}"); + if ($?) { + unlink "$opts{i}.pub"; + die "Unable to generate public key $opts{i}.pub\n" + } + } + print STDERR "Initializing identity on $opts{a} (provide login information)\n"; + print open3_get(["$opts{i}.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 ($?); + } + } elsif ($out =~ /denied/ && $out =~ /command/) { + # identity already loaded + } else { + die "Unknown output encountered: '$out'\n" + } + } + if (! -d $opts{I}) { + print STDERR "Creating $opts{I}\n" if ($opts{v}); + mkdir $opts{I}; + chmod(0700, $opts{I}); + } + my $time = $opts{d} * 24 * 60 * 60; + $agent_key_time = time + $time; + $agent_key = "$opts{I}/meshkey.$agent_key_time"; + print STDERR "Generating key on $opts{p} (provide login information)\n"; + print open3_get([-1, $agent_key, undef], + "ssh $opts{ssh_q} -Ax -oPubkeyAuthentication=no $opts{ssh_l} $opts{p} mesh-keygen " . $opts{'keygen-user'}); + if ($? || -z $agent_key) { + unlink $agent_key; + die "Unable to generate key\n"; + } + chmod(0600, $agent_key); + print STDERR "Generating public key $agent_key.pub from private key $agent_key\n" if ($opts{v}); + print open3_get([-1, "$agent_key.pub", undef], "ssh-keygen -y -f $agent_key"); + print STDERR "Adding key $agent_key to agent\n" if ($opts{v}); + print open3_get([-1, undef], "ssh-add -t $time $agent_key"); + die "Unable to add key to agent\n" if ($?); + + ####################### + #### update client #### + ####################### + if (!$opts{'keygen-user'}) { + # do not update client when key generated for different user + my $mcv = open3_get([-1, undef, -1], + "ssh -Aqx -oBatchMode=yes $opts{ssh_l} $opts{p} 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 = ; + $line =~ s/^\s+|\s+$//g; + if ($line =~ /^y(es)?$/i) { + print open3_get([-1, $opts{abs0}, undef], + "ssh -Aqx -oBatchMode=yes $opts{ssh_l} $opts{p} mesh-update --file=mc"); + # 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); +} + +=cut mesh + +########################## +#### clean up on exit #### +########################## +END {exit_clean()}; +use sigtrap qw(handler exit_clean normal-signals); + +######################## +#### modify command #### +######################## +# ssh command to reach target (possibly via MP) +$opts{ssh} = "ssh $opts{ssh_q} -ax -oBatchMode=yes $opts{ssh_l}"; +# 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') { + $opts{sshmp} = "ssh $opts{ssh_q} -Ax -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 + +print STDERR "Old command is '" . join("' '", @ARGV) . "'\n" if ($opts{v}); +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)bbcp$/) { + splice(@ARGV, 1, 0, ("-S", "$opts{ssh} %H bbcp", "-T", "$opts{ssh} %H bbcp")); +} elsif ($ARGV[0] =~ /(?:^|\W)(?:bbftp|bbscp)$/) { + splice(@ARGV, 1, 0, ("-L", $opts{ssh})); +} elsif ($ARGV[0] =~ /(?:^|\W)globus-url-copy$/) { + my $dir = glob("~/.globus"); + mkdir $dir if (! -d $dir); + my $file = "$dir/gridftp-ssh"; + open(FILE, '>', $file); + print FILE "#!/bin/sh\n$opts{ssh} \$2 sshftp"; + close FILE; + chmod(0700, $file); + # reduce $argc since no additional args are spliced onto @ARGV + $argc--; +} elsif ($ARGV[0] =~ /(?:^|\W)pcp\+$/) { + splice(@ARGV, 1, 0, ("-s", "$opts{ssh_l} $opts{p}")); +} 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)); + exit $rc; +} + +################### +#### find sftp #### +################### +my @sftps = glob("$opts{tmp_d}/mesh-*/sftp.*"); +my $sftp_time = -1; +my $sftp_sock; +foreach my $sftp (@sftps) { + my @stat = stat $sftp; + next if ($stat[4] != $< || ! -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; + $opts{k} = undef; + } else { + close STDIN; + close STDOUT; + close STDERR; + setsid; + open(STDIN, "/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}, + $ENV{SSH_AUTH_SOCK}], [qw(*ARGV pwd agent_sock)])) . "\n"; +my $rc = 0; +if ($ARGV[0] =~ /(?:^|\W)tee$/) { + while () { + 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{k} > 1) { + # kill spawned agent + print STDERR "Killing agent with pid $opts{k}\n" if ($opts{v}); + kill(SIGTERM, $opts{k}) && waitpid($opts{k}, 0); + } + + 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(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'); + if ($host =~ /^\d+\.\d+\.\d+\.\d+$/) { + my $name = gethostbyaddr(inet_aton($host), AF_INET); + return $name if ($name); + } else { + my @cols = gethostbyname($host); + return $cols[0] if ($cols[0]); + } + return $host; +} + +################## +#### 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); + # remove user name if specified + #TODO: do something with user? + $h = (split(/@/, $h))[-1]; + 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); +} + +################### +#### 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}); + } + # use global agent socket for authentication + $ENV{SSH_AUTH_SOCK} = $agent_sock; + # 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}}); + # preserve site-specific settings if applicable + my $save_mgr = $opts{mgr}; + 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", + "help|h", "history", "host-file=s", "host-list=s", "hosts=i", "id=s", + "identity=s", "ignore-times|I", "include=s@", "index-tar", "io=i", + "ior=i", "iow=i", "dereference|L", "local=s", "mgr=s", "mgr-identity=s", + "mgr-user=s", "net=i", "netr=i", "netw=i", "newer=s", "no-check", + "no-cron", "no-dereference|P", "no-mail", "no-offline", "no-preserve", + "no-target-directory|T", "no-verify", "older=s", "pid=i", "ports=s", + "preallocate=i", "recursive|R|r", "remote=s", "restart", "retry=i", + "search=s", "secure", "size=s", "split=s", "split-tar=s", + "state=s", "stats", "status:s", "stop", "streams=i", "stripe=s", "sync", + "threads=i", "user=s", "verify-fast", "wait", "window=s", + # previously allowed inverse options + "preserve|p", "verify", + #TODO: deprecated options: remove when enough time passed + "encrypt", + )); + $opts{mgr} = $save_mgr if ($save_mgr); +#TODO: deprecated options: remove when enough time passed + if ($opts{encrypt}) { + delete $opts{encrypt}; + $opts{secure} = 1; + print STDERR "NOTE: The --encrypt option is deprecated and is now named --secure with\n"; + print STDERR " additional security functionality. Please use --secure in the future.\n"; + } +#TODO: end deprecated options + 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 () { + chomp; + $hosts{fqdn($_)} = 1; + } + close FILE; + } else { + die "Unable to read host file " . $opts{'host-file'} . ": $!\n"; + } + } + foreach my $opt (qw(newer older)) { + if ($opts{$opt} && $opts{$opt} !~ /^\d+$/) { + require Date::Parse; + my $time = Date::Parse::str2time($opts{$opt}); + die "Unable to parse date string '$opts{$opt}'\n" if (!$time); + $opts{$opt} = $time; + } + } + 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"; + } + + foreach (qw(check cron mail offline preserve verify)) { + $opts{$_} = $opts{"no-$_"} ? 0 : 1; + $in_opts{$_} = 1 if ($in_opts{"no-$_"}); + } + $opts{check} = 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{'no-dereference'} = 1 if ($opts{recursive}); + $opts{offline} = 0 if ($opts{'create-tar'} || $opts{'extract-tar'}); + $opts{preserve} = 1 if ($opts{sync}); + $opts{recursive} = 1 if ($opts{'create-tar'}); + + 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}) { + my $out = shift_mgr("--alive --id=$opts{id} --host=$host"); + shift_stop() if ($out =~ /stop/); + } + exit; + } + #TODO: recreate user's original path? + } + + #TODO: mgr should check after certain time and notify user that no + # progress has been made on a particular transfer + #TODO: need warning if key about to expire as have no way to notify + # user once key expires + #TODO: --overwrite option? + #TODO: need to be careful about spawning when using mesh as + # other systems may not have mesh keys + #TODO: need to be careful about changing target when using mesh as + # other systems may not have same meshrc + + 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 ($opts{stats}) { + my $out = shift_mgr("--stats"); + die "$$out\n" if (ref $out); + print $out; + exit; + } elsif ($opts{history}) { + my $id = $opts{id} ? "--id=$opts{id}" : ""; + my $search = $opts{search} ? "--search=" . escape($opts{search}) : ""; + my $out = shift_mgr("--history $id $search"); + die "$$out\n" if (ref $out); + print $out; + 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 ($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{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 " -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=DATE include only files with mtime newer than DATE\n"; + print " -P, --no-dereference never follow symbolic links\n"; + print " -T, --no-target-directory treat target as a normal file\n"; + print " --older=DATE include only files with mtime older than DATE\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-check do not check file existence/size (benchmarking only)\n"; + print " --no-cron do not recover from host/process failures via cron\n"; + print " --no-mail do not send status emails\n"; + print " --no-offline do not migrate DMF-managed files after transfer\n"; + print " --no-preserve do not preserve times, mode, owner, acls, or xattrs\n"; + print " --no-verify do not verify/rectify integrity of destination files\n"; + print "\n"; + print "Monitoring and management options:\n"; + print " --history show list of transfer commands and origin host/dir\n"; + print " --id=NUM use transfer identifier NUM for other commands\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 " --restart restart transfer with given --id\n"; + print " --search=REGEX show only status/history 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 show stats across all transfers\n"; + print " --status[={csv,pad}] show brief status of all transfers\n"; + print " --stop stop transfer with given --id\n"; + print " or detailed status of 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 COUNT files\n"; + print " (use suffix {k,m,b/g,t} for 1E{3,6,9,12}) [1k]\n"; + print " --local=LIST set local transport mechanism to one of LIST\n"; + print " (LIST subset of {bbcp,bbftp,fish,fish-tcp,gridftp,\n"; + print " 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 {bbcp,bbftp,fish,fish-tcp,gridftp,\n"; + print " rsync,shift})\n"; + print " --retry=NUM retry failed operations up to NUM times [2]\n"; + print " --size=SIZE process transfer in batches of 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=SIZE|NUM use 1 stripe per SIZE bytes or NUM stripes\n"; + print " (use suffix {k,m,g,t} for {KB,MB,GB,TB}) [1g]\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; + } + 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/$_/}); + } + } + + # 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(); + + # send options + foreach (qw(bandwidth buffer check clients command cpu create-tar cron + dereference disk extract-tar files host-list hosts + ignore-times index-tar io ior iow local mail net netr netw + newer offline older ports preallocate preserve remote retry + secure 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 client version + print $logfh "args=getopt,version text=$VERSION\n"; + # send perl version + print $logfh "args=getopt,perl text=$]\n"; + # send os type + print $logfh "args=getopt,os text=$^O\n"; + # 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(\$logfh, $log, $host, \@ARGV); + } else { + while (my $line = ) { + $line =~ s/^\s+|\s+$//g; + my @args = quotewords('\s+', 0, $line); + $nfiles += shift_args(\$logfh, $log, $host, \@args); + } + } + close $logfh; + if ($nfiles > 0) { + $opts{id} = shift_mgr("--host=$host --put", $log); + die "${$opts{id}}\n" if (ref $opts{id}); + $opts{id} =~ s/\s+$//; + print "Shift id is $opts{id}\n"; + STDOUT->flush; + } else { + print $usage; + exit; + } + } elsif ($opts{restart}) { + # send options that can be respecified + my ($logfh, $log) = sftp_tmp(); + foreach (qw(bandwidth buffer clients cpu cron disk files host-list hosts + io ior iow local mail net netr netw offline ports preallocate + remote retry secure 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"; + my $out = shift_mgr("--restart --id=$opts{id} --host=$host --put", $log); + die "$$out\n" if (ref $out); + } elsif (!defined $opts{pid}) { + print $usage; + exit; + } + + # this will either start a child or do nothing if one already started + shift_loop(); + + # prevent cleanup + $opts{sftp_d} = undef; + $opts{k} = undef; + + # do not use crontab when extra clients + POSIX::_exit(0) if ($opts{id} =~ /\D/); + +#TODO: cron job will never exit if doesn't pass first checks (e.g. invalid key) + if ($opts{cron}) { + # install crontab + my $tab; + my $fhpid = open3_run([-1, undef, -1], "crontab -l"); + if (defined $fhpid) { + while (defined ($_ = $fhpid->[1]->getline)) { + # ignore garbage added by crontab + next if (/^#.*(?:edit the master|installed on|Cron version)/); + $tab .= $_; + } + open3_wait($fhpid); + } + # replace pid if entry already exists in crontab + if ($tab !~ s/(--id=$opts{id}\s+--pid=)\d+/$1$opts{child_pid}/) { + # construct new crontab entry + $tab .= "\n*/10 * * * * $opts{abs0}"; + if (basename($opts{abs0}) !~ /^shift/) { + $tab .= " -u $opts{u}" if ($opts{u}); + $tab .= " -b -p $opts{p} 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=$opts{child_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; + } + if (!$opts{cron}) { + print STDERR "WARNING: Unable to install crontab or --no-cron option specified.\n"; + print STDERR " Automated recovery across host/process failures is disabled.\n"; + } + if ($opts{wait}) { + print "Waiting for transfer to complete..."; + STDOUT->flush; + # set exit to 1 in case killed while waiting + $? = 1; + waitpid($opts{child_pid}, 0); + my $out = shift_mgr("--status --state=none --id=$opts{id}"); + print "\n\n", $out; + STDOUT->flush; + POSIX::_exit(1) if ($out !~ /done/); + } else { + print STDERR "Detaching process (use --status option to monitor progress)\n"; + } + # use _exit to avoid END block processing + POSIX::_exit(0); +} + +#################### +#### shift_args #### +#################### +sub shift_args { + my ($logfh_ref, $log, $host, $args) = @_; + my $logfh = $$logfh_ref; + 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)) { + # 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); + die "$dst exists or is a directory\n" + if (-e $dst && $opts{'create-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)); + } 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; + } + } + + print $logfh "args=find,", escape(hostpath($shost, $spath)), ","; + if (!$opts{'extract-tar'} && defined $dmode && + (!S_ISDIR($smode) && S_ISDIR($dmode) || + S_ISDIR($smode) && !$opts{'no-target-directory'})) { + print $logfh escape($dst . "/" . basename($spath)); + } else { + print $logfh escape($dst); + } + print $logfh " tar_name=" . escape($tar_name) if ($opts{'create-tar'}); + print $logfh " host=$host\n"; + $nfiles++; + } + return $nfiles; +} + +#################### +#### shift_find #### +#################### +sub shift_find { + my ($shost, $spath, $dst, $ref) = @_; + my $logfh = $ref->{logfh}; + my $host = fqdn(hostname); + + # process tar files + if ($opts{'extract-tar'}) { + tar_extract($shost, $spath, $dst, $ref); + return; + } + + # check for existence of various commands + my %have; + foreach my $bin (qw(dmget lfs getfacl getfattr)) { + foreach my $path (split(/:/, $ENV{PATH})) { + if (-x "$path/$bin") { + $have{$bin} = 1; + last; + } + } + } + + $ref->{tool} = "shiftc"; + my $dmf = $have{dmget} && $ref->{srcfs} =~ /,dmi/ ? 1 : 0; + my ($dmfh, $dmtmp); + + # compute local (or remote if shift-aux fails) files and sizes + my $sdir = dirname($spath); + $sdir = "" if ($sdir eq '/'); + my $ddir = dirname($dst); + $ddir = "" if ($ddir eq '/'); + my $tdir = $opts{'create-tar'} ? dirname(unescape($ref->{tar_name})) : undef; + $tdir = "" if ($tdir eq '.'); + $tdir .= "/" if ($tdir && $tdir !~ /\/$/); + my $dname = basename($dst); + my @files = (basename($spath)); + FILE: foreach my $file0 (@files) { + if (ref $file0) { + # processing subdir so update prefix + $sdir = $file0->[0]; + $ddir = $file0->[1]; + $tdir = $file0->[2] . "/" if ($opts{'create-tar'}); + # dname only needed on first iteration where src/dst name may differ + $dname = undef; + next; + } + next if ($file0 eq '.' || $file0 eq '..'); + my $file = "$sdir/$file0"; + my $dfile0 = $dname ? $dname : $file0; + + # 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 ($shost eq 'localhost') { + @stat = lstat($file); + } else { + my $fattrs = sftp($shost)->lstat($file); + # 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 (scalar(@files) == 1) { + # return error if original file + sftp_error($ref, "Cannot stat $file"); + next; + } + # 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 + next if (!S_ISDIR($mode) && !S_ISREG($mode) && !S_ISLNK($mode)); + # dmf handling for individual files is carried out by transport_dmf + $dmf = 0 if (scalar(@files) == 1 && !S_ISDIR($mode)); + } + + if (scalar(@stat) == 0 || S_ISDIR($mode)) { + my $err = ""; + if (scalar(@stat) > 0 && (!$opts{dereference} || scalar(@files) == 1) && + (!defined $opts{'find-files'} || + scalar(@files) < $opts{'find-files'})) { + # add subdirs of this directory for processing when below limit + my $rc = $shost eq 'localhost' ? opendir(DIR, $file) : + sftp($shost)->opendir($file); + if ($rc) { + my @sub_files; + if ($shost eq 'localhost') { + $! = undef; + @sub_files = readdir DIR; + # there is currently no good way to detect readdir errors + @sub_files = () if ($!); + closedir DIR; + } else { + @sub_files = map {$_->{filename}} sftp($shost)->readdir($rc); + sftp($shost)->closedir($rc); + } + if (scalar(@sub_files) > 0) { + my $dirs = [$file, "$ddir/$dfile0"]; + push(@{$dirs}, "$tdir$file0") if ($opts{'create-tar'}); + push(@files, $dirs, @sub_files); + $err = undef; + } else { + # dirs should always contain . and .. at a minimum + $err = "Error reading directory $file"; + } + } else { + $err = "Error opening directory $file"; + } + if ($err && scalar(@files) == 1) { + # return error if original file + sftp_error($ref, $err); + next; + } + } + if (defined $err) { + # this handles directories as well as lower level failures + print $logfh "args=find,", escape(hostpath($shost, $file)), ","; + if ($opts{'create-tar'}) { + print $logfh escape($dst), " tar_name=" . escape("$tdir$file0"); + } else { + print $logfh escape("$ddir/$dfile0"); + } + print $logfh " host=$host\n"; + next; + } + } + + # include files + if (defined $opts{include}) { + my $found; + foreach my $re (@{$opts{include}}) { + next if (eval {$file !~ /$re/}); + $found = 1; + last; + } + next if (!$found); + } + # exclude files + if (defined $opts{exclude}) { + foreach my $re (@{$opts{exclude}}) { + next FILE if (eval {$file =~ /$re/}); + } + } + # newer/older files + next if (defined $opts{newer} && $stat[9] < $opts{newer}); + next if (defined $opts{older} && $stat[9] >= $opts{older}); + + # resolve uid/gid if possible + my $user = getpwuid($stat[4]); + my $group = getgrgid($stat[5]); + $user = "uid_$stat[4]" if (!$user); + $group = "gid_$stat[5]" if (!$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') { + # try to get acls + if ($have{getfacl} && !$opts{'create-tar'} && $opts{preserve} && + (!$ref->{srcfs} || $ref->{srcfs} =~ /,acl/)) { + open(FILE, '-|', "getfacl", "-cPps", "--", $file); + while () { + chomp; + next if (!$_); + push(@acls, escape($_)); + } + close FILE; + } + + # try to get xattrs + if ($have{getfattr} && !$opts{'create-tar'} && $opts{preserve} && + (!$ref->{srcfs} || $ref->{srcfs} =~ /,xattr/)) { + open(FILE, '-|', "getfattr", "-dhe", "base64", $file); + while () { + chomp; + next if (!$_ || /^\s*#/); + push(@xattrs, escape($_)); + } + close FILE; + } + + # try to get lustre striping + if ($have{lfs} && !S_ISLNK($mode) && !$opts{'create-tar'} && + $opts{preserve} && $ref->{srcfs} =~ /^lustre/) { + # ignore symlinks as link to fifo can hang forever + open(FILE, '-|', "lfs", "getstripe", "-d", $file); + while () { + $lattrs[0] = $1 if (/stripe_count:\s*(-?\d+)/); + $lattrs[1] = $1 if (/stripe_size:\s*(-?\d+)/); + } + close FILE; + } + $lattrs[0] = 0 if (!defined $lattrs[0] && defined $lattrs[1]); + $lattrs[1] = 0 if (!defined $lattrs[1] && defined $lattrs[0]); + } + + # begin log entry + 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); + print $logfh "args=ln,", escape($ln); + $index_len += 4 + length($ln); + } elsif (S_ISDIR($mode)) { + print $logfh "args=mkdir"; + } elsif ($opts{sync}) { + print $logfh "args=ckattr", $opts{'ignore-times'} ? "0" : "", + ",", escape(hostpath($shost, $file)); + } else { + print $logfh "args=cp,", escape(hostpath($shost, $file)); + } + print $logfh ",", escape($opts{'create-tar'} ? $dst : "$ddir/$dfile0"); + print $logfh " acls=" . join(",", @acls) if (scalar(@acls) > 0); + print $logfh " xattrs=" . join(",", @xattrs) if (scalar(@xattrs) > 0); + print $logfh " lustre_attrs=" . join(",", @lattrs) if (scalar(@lattrs) > 0); + print $logfh " tar_index=$index_len" if ($opts{'index-tar'}); + print $logfh " tar_name=" . escape("$tdir$file0") if ($opts{'create-tar'}); + print $logfh " host=$host size=$stat[7] attrs=$attrs\n"; + if ($dmf) { + ($dmfh, $dmtmp) = sftp_tmp() if (!$dmtmp); + print $dmfh $file, "\n" if (!S_ISLNK($mode) && !S_ISDIR($mode)); + } + } + + if ($dmf) { + close $dmfh; + # fork to avoid intermittent hangs of dmget + my $pid = fork_setsid(); + if ($pid) { + waitpid($pid, 0); + } else { + my $ssh = $shost eq 'localhost' ? "" : "$opts{ssh} $shost"; + # ignore errors since files will be automatically retrieved anyway + open3_get([$dmtmp, -1, -1], "$ssh dmget -nq"); + unlink $dmtmp; + POSIX::_exit(0); + } + } +} + +####################### +#### 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 $time; + if ($^O ne 'MSWin32') { + # try icmp ping command first + if (open(CMD, '-|', "ping", "-c1", "-W2", $host)) { + while () { + if (/[^\/]([\d.]+)\//) { + # convert milliseconds to seconds + $time = $1 / 1000; + last; + } + } + close CMD; + } + } + if (!$time) { + # use tcp echo port as backup to icmp ping + if (!$np) { + $np = Net::Ping->new; + $np->hires; + } + my $rc; + ($rc, $time) = $np->ping($host); + + if (!$rc) { + # use ssh syn ping as backup to tcp echo port + if (!$nps) { + $nps = Net::Ping->new('syn'); + $nps->hires; + $nps->port_number(22); + } + $nps->ping($host); + ($rc, $time) = $nps->ack; + $time /= 2; + } + } + $rtts{$host} = $time if ($time); + } + + 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 = ) { + $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}; + } + + my %disk_load; + foreach my $rpath (keys %{$diskfs}) { + my ($host, $path) = hostpath($rpath); + my $ref = {}; + vdf($ref, $host, $path, {-argv => []}); + $disk_load{$diskfs->{$rpath}} = $1 if ($ref->{text} =~ /(\d+)%/); + } + + return "args=load " . join(" ", + (map {"$_=$load->{$_}"} qw(cpu ratio time)), + (map {"disk_$_=$disk_load{$_}"} keys(%disk_load))) . "\n"; +} + +#################### +#### shift_loop #### +#################### +# perform various interactions with shift manager to transfer files +sub shift_loop { + # detach process + $opts{child_pid} = fork if (!$opts{child_pid}); + return if ($opts{child_pid}); + + # detach process + close STDIN; + close STDOUT; + close STDERR; + setsid; + open(STDIN, "/dev/null"); + open(STDERR, ">/dev/null"); + + # find agents loaded with a key from ~/.ssh/id* for other hosts + my @agents = glob("$opts{tmp_d}/ssh-*/agent.*"); + push(@agents, glob("/tmp/ssh-*/agent.*")) if ($opts{tmp_d} ne "/tmp"); + unshift(@agents, $ENV{SSH_AUTH_SOCK}); + my @host_agents; + foreach my $agent (@agents) { + my @stat = stat $agent; + next if ($stat[4] != $< || ! -S $agent); + $ENV{SSH_AUTH_SOCK} = $agent; + my $out = open3_get([-1, undef, -1], "ssh-add -l"); + push(@host_agents, $agent) if ($out =~ /\.ssh.id/); + } + # restore agent socket + $ENV{SSH_AUTH_SOCK} = $agent_sock; + # ensure at least one agent to cover host-based authentication + push(@host_agents, $agent_sock) if (scalar(@host_agents) == 0); + + my ($logfh, $log) = sftp_tmp(); + 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=getopt,exception text=", escape($text); + shift_mgr("--id=$opts{id} --host=$host --put", $log, undef, 1440); + } + } + + # send client version + print $logfh "args=getopt,version text=$VERSION\n"; + # send file system information + print $logfh shift_mounts($host); + # send network properties + print $logfh shift_networks($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 = {}; + +=for mesh + # try to reload mesh key when approaching expiration + if ($opts{p} ne 'none' && $agent_key_time - time < 60) { + foreach my $key (sort {$b cmp $a} glob("$opts{I}/meshkey.[0-9]*")) { + # keys are sorted by reverse expiration time + if ($key =~ /\.(\d+)$/) { + my $etime = $1; + my $time = $etime - time; + last if ($time < 60); + my $out = open3_get([-1, undef, -1], "ssh-keygen -l -f $key.pub"); + next if ($out =~ /not a public key file/); + open3_get([-1, undef], "ssh-add -t $time $key"); + $agent_key = $key; + $agent_key_time = $etime; + last; + } + } + } +=cut mesh + + # retrieve next batch for processing + close $logfh; + my $out = shift_mgr("--id=$opts{id} --host=$host --pid=$$ --get --put", + $log, $task, 1440); + die "$$out\n" if (ref $out); + #TODO: error checking if id doesn't exist + open($logfh, '>', $log); + + 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}); + $cmd .= " -b -p $opts{p} 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 eq 'gridftp' && -x "$path/globus-url-copy" || + $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'}; + } + $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|check|create-tar|cron|dereference|extract-tar|find-files|ignore-times|index-tar|lustre_default_stripe|newer|no-stripe|offline|older|opts_bbcp|opts_bbftp|opts_gridftp|opts_mcp|opts_msum|opts_ssh|ports|preallocate|preserve|secure|streams|stripe|sync|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}); + $rcmd .= " -b -p $opts{p} 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"; + my $done; + foreach my $agent (@host_agents) { + $ENV{SSH_AUTH_SOCK} = $agent; + open3_get([-1, -1], $rcmd); + if (!$?) { + $done = 1; + last; + } + } + $ENV{SSH_AUTH_SOCK} = $agent_sock; + if (!$done) { + $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; + 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; + # 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}; + } elsif ($cmd eq 'find') { + my ($rhost, $rpath) = hostpath(unescape($args[0])); + $op{logfh} = $logfh; + 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}; + } + } + } + + $size = transport('end'); + my $time = time - $run; + my $rate = $rsize / ($time ? $time : 1); + my $fhpid; + my %sumfh; + while (my ($op, $ref) = each %ops) { + $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"; + $size += $ref->{size}; + 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); + } + } + my $tname = $ref->{tar_name}; + $tname =~ s/(\n|\\)/$1 eq "\n" ? "\\n" : "\\\\"/eg; + print {$sumfh{$tar}} "$text $tname\n"; + } + } 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 rate=$rate\n"; + # rsync size is already included in total + $size += $ref->{size} if ($ref->{tool} ne 'rsync' && + ($ref->{local} || $op =~ /(?:^|\s)args=(?:cp|sum)/)); + } + } + open3_wait($fhpid); + close $_ foreach (values %sumfh); + } + exit; +} + +################### +#### shift_mgr #### +################### +sub shift_mgr { + my ($cmd, $stdin, $stdout, $retry) = @_; + my $lock = $cmd eq '--lock' ? 1 : 0; + $cmd = "$opts{cmgr} $cmd"; + if ($opts{mgr} ne 'none') { + if ($opts{p} eq $opts{mgr}) { + $cmd = $opts{sshmp} . " " . $cmd; + } elsif ($opts{mgr}) { + my $extra; + $extra .= " -l " . $opts{'mgr-user'} if ($opts{'mgr-user'}); + $extra .= " -i " . $opts{'mgr-identity'} if ($opts{'mgr-identity'}); + $cmd = "ssh -Aqx -oBatchMode=yes $extra $opts{mgr} $cmd"; + } + } + $cmd = "su " . $opts{'mgr-user'} . " -c '$cmd'" + if ($< == 0 && $opts{'mgr-user'} && !$opts{'mgr-identity'}); + return open3_run([-1, undef, -1], $cmd) if ($lock); + $stdin = -1 if (!$stdin); + my $start = time; + my $err; + do { + my $tmp = sftp_tmp(); + my $out = open3_get([$stdin, $stdout, $tmp], $cmd); + my $rc = WEXITSTATUS($?); + if ($rc) { + open(ERR, '<', $tmp); + $err .= $_ while (); + chomp $err; + close ERR; + } + unlink $tmp; + return $out if (!$rc); + } while ($retry && time < $start + $retry * 60 && 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 %mnt = ( + host => $host, + args => "mount", + ); + my $mnts; + + # check for existence of getfacl + my $acl; + foreach my $path (split(/:/, $ENV{PATH})) { + if (-x "$path/getfacl") { + $acl = 1; + last; + } + } + + # gather file system information from mount + 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} .= ",dmi" if (/[\(,]dmi[\),]/); + $mnt{opts} .= ",xattr" if (/[\(,]user_xattr[\),]/); + #TODO: need to escape local and remote? + (my $dev, $mnt{local}, $mnt{type}) = ($1, $2, $3) + if (/(\S+)\s+on\s+(\S+)\s+type\s+(\S+)/); + if ($mnt{local}) { + # 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{type} = "cxfs"; + $mnt{remote} = $mnt{local}; + } elsif (/^(\S+):(\S+)/) { + # typical form for nfs + $mnt{remote} = $2; + $mnt{servers} = $1; + $mnt{servers} =~ s/@.*//; + $mnt{servers} = fqdn($mnt{servers}); + } elsif ($mnt{type} eq 'gpfs') { + # gpfs servers do not appear in mount output so call mmlsmgr + my $srv = open3_get([-1, undef, -1], "mmlsmgr $dev"); + # try a default location if not in path + $srv = open3_get([-1, undef, -1], + "/usr/lpp/mmfs/bin/mmlsmgr $dev") if (!$srv); + next if (!defined $srv); + # output is file system then server ip address + if ($srv =~ /^(\w+)\s+(\d+\.\d+\.\d+\.\d+)/m) { + $mnt{remote} = "/$1"; + $mnt{servers} = fqdn($2); + } + } elsif ($mnt{opts} =~ /,dmi/) { + # always report dmi file systems even if local + $mnt{servers} = $mnt{host}; + $mnt{remote} = $mnt{local}; + } else { + # ignore local file systems + next; + } + # 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 $win; + foreach (qw(rmem_max wmem_max)) { + if (open(FILE, "/proc/sys/net/core/$_")) { + my $tmp = ; + chomp $tmp; + $win = $tmp if ($tmp > $win); + close FILE; + } + } + $win = " tcpwin=$win" if ($win); + + my $xge; + if (open(CMD, '-|', "lspci")) { + while () { + if (/10\s?g[bei]/i) { + $xge = " xge=1"; + last; + } + } + close CMD; + } + return $win || $xge ? "args=network$win$xge\n" : undef; +} + +#################### +#### 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 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 = $ref->{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; + } + binmode $fh; + + 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 my $re (@{$opts{include}}) { + next if (eval {$attrs[0] !~ /$re/}); + $found = 1; + last; + } + next if (!$found); + } + # exclude files + if (defined $opts{exclude}) { + my $found; + foreach my $re (@{$opts{exclude}}) { + 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\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 @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 ( + # bbcp does not encrypt and cannot handle partial transfers or + # (using --infiles) colon/ff/cr/lf/tab/vt in file names + $tool eq 'bbcp' && ($opts{secure} || $ref->{bytes} || + "$src$dst" =~ /[:\f\n\r\t\x0b]/) || + # 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]/) || + # fish-tcp does not encrypt + $tool eq 'fish-tcp' && $opts{secure} || + # gridftp cannot handle tar ops due to differing src/dst offsets + $tool eq 'gridftp' && defined $ref->{tar_bytes} || + # 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'} && + !$opts{secure}) { + $use = "fish-tcp"; + } elsif ($host ne 'localhost' && defined $tools{fish}) { + $use = "fish"; + } else { + $use = "shift"; + } + } + push(@{$tools{$use}}, $cmd); + } + + foreach my $tool (keys %tools) { + next if (!scalar(@{$tools{$tool}})); + if ($tool eq 'bbcp') { + transport_bbcp($host, $tools{$tool}); + } elsif ($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 'gridftp') { + transport_gridftp($host, $tools{$tool}); + } 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}); + } + + delete $tcmds{$host}; + + # return is only defined during an end when rsync is used + return $rsize; +} + +######################## +#### transport_bbcp #### +######################## +sub transport_bbcp { + 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 = ""; + # bbcp assumes host name instead of localhost when host not given + $dhost = "localhost:"; + $args = " -S bbcp -T bbcp"; + } else { + $args = " -S '$opts{ssh} %H bbcp' -T '$opts{ssh} %H bbcp'"; + } + + foreach my $cmd (@{$tcmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + $ref->{tool} = "bbcp"; + 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; + # bbcp batch mode does not use leading slashes like rsync + $lcs =~ s/^\/+//; + if ($spath && $src eq "$spath/$lcs" && $dst eq "$dpath/$lcs") { + print $fh ($shost ? $shost . ":" : ""), "$lcs\n"; + push(@{$errs{"$spath/$lcs"}}, $ref); + push(@{$errs{"$dpath/$lcs"}}, $ref); + next; + } elsif ($spath) { + # next file has different prefix so process current batch + close $fh; + transport_bbcp_batch($args . ($shost ? " -z" : ""), $tmp, + "$shost$spath", "$dhost$dpath", \%errs, $host); + %errs = (); + open($fh, '>', $tmp); + } + print $fh ($shost ? $shost . ":" : ""), "$lcs\n"; + $spath = $src; + # escape lcs in case it contains regex characters + $spath =~ s/\/\Q$lcs\E$//; + $dpath = $dst; + $dpath =~ s/\/\Q$lcs\E$//; + push(@{$errs{"$spath/$lcs"}}, $ref); + push(@{$errs{"$dpath/$lcs"}}, $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]; + $errs_tmp{$dst} = [$ref]; + transport_bbcp_batch($args . ($shost ? " -z" : ""), "", + "$shost$src", "$dhost$dst", \%errs_tmp, $host); + } + } + + close $fh; + if ($spath) { + transport_bbcp_batch($args . ($shost ? " -z" : ""), $tmp, + "$shost$spath", "$dhost$dpath", \%errs, $host); + } + unlink $tmp; +} + +############################## +#### transport_bbcp_batch #### +############################## +sub transport_bbcp_batch { + my ($args, $from, $src, $dst, $errs, $host) = @_; + my ($pid, $in, $out, $size); + $from = " --infiles $from -d" if ($from); + 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 =~ /^[^\/]/); + my $nstream = $host eq 'localhost' ? $opts{threads} : $opts{streams}; + my $extra; + $extra .= " -B " . $opts{buffer} if ($opts{buffer}); + $extra .= " -s " . $nstream if ($nstream); + $extra .= " -w " . $opts{window} if ($opts{window}); + $extra .= " -Z " . $opts{ports} if ($opts{ports}); + # apply opts_bbcp last to override other settings + $extra .= " " . $opts{opts_bbcp}; + # 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 + $pid = IPC::Open3::open3($in, $out, $out, + # make sure quotewords string does not end in space + quotewords('\s+', 0, "bbcp $extra -AfKv -m 0600$args$from"), + $esrc, $edst); + }; + if (!$@) { + while (my $line = <$out>) { + $line =~ s/\s+$//; + if ($line =~ /^File (.*) created(?!.*created)/) { + my $file = $1; + foreach my $key (grep(/^\Q$file\E$/, keys(%{$errs}))) { + $_->{text} = 0 foreach(@{$errs->{$key}}); + } + } elsif ($line =~ /^bbcp: [^\/]*(\/.*)/) { + my $file = $1; + foreach my $key (grep(/^\Q$file\E$/, keys(%{$errs}))) { + sftp_error($_, $line) foreach(@{$errs->{$key}}); + } + } + } + } + close $in; + close $out; + waitpid($pid, 0) if ($pid); + + foreach my $key (keys %{$errs}) { + foreach(@{$errs->{$key}}) { + if (!defined $_->{text}) { + sftp_error($_, "unknown bbcp failure"); + } + } + } +} + +######################### +#### 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); + + my $dashe = $opts{ports} ? " -e $opts{ports}" : ""; + my $dashl = $host ne 'localhost' ? $opts{ssh} : "bbftpd -s$dashe"; + $dashe = "-E 'bbftpd $dashe'" if ($dashe); + 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 () { + 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) = @_; + my ($fh, $tmp); + + # check for existence of commands + my %have; + if ($host eq 'localhost') { + foreach my $bin (qw(fallocate lfs setfacl setfattr)) { + foreach my $path (split(/:/, $ENV{PATH})) { + if (-x "$path/$bin") { + $have{$bin} = 1; + last; + } + } + } + } + + # lfs setstripe (must be done before fallocate) + if ($have{lfs} || $host ne 'localhost') { + foreach my $cmd (@{$tcmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + next if (($op eq 'chattr' || $opts{'create-tar'}) && + !$ref->{tar_creat}); + next if ($op !~ /^(?:chattr|get|mkdir|put)$/ || !$ref->{dstfs} || + $ref->{dstfs} !~ /^lustre/ || $opts{stripe} == 0); + # set striping + my ($scount, $ssize) = (0, 0); + if ($opts{'no-stripe'} && $ref->{lustre_attrs}) { + # preserve existing striping + ($scount, $ssize) = split(/,/, $ref->{lustre_attrs}); + } + # don't preserve if stripe count is <= lustre default + if ($scount <= $opts{lustre_default_stripe} && $opts{stripe} < 1000) { + $scount = $opts{stripe}; + } elsif ($ref->{tar_creat}) { + $scount = int($ref->{tar_creat} / $opts{stripe}); + } elsif ($op ne 'mkdir' && $scount <= $opts{lustre_default_stripe}) { + my @attrs = split(/,/, $ref->{attrs}); + $scount = int($attrs[7] / $opts{stripe}); + } + if ($host eq 'localhost' || $op eq 'get') { + # stripe local files immediately + my $dir = $op eq 'mkdir' ? $dst : dirname($dst); + eval {mkpath($dir)}; + system("lfs", "setstripe", "-c", $scount, "-s", $ssize, $dst); + # try again if error > 160 stripes due to max of lustre < 2.4 + system("lfs", "setstripe", "-c", -1, "-s", $ssize, $dst) + if ($? && $scount > 160); + # ignore errors since files automatically striped anyway + } else { + # stripe remote files in batch + ($fh, $tmp) = sftp_tmp() if (!$tmp); + # use trailing / to indicate directories + print $fh "lfs ", escape($dst), $op eq 'mkdir' ? "/" : "", + " $scount $ssize\n"; + } + } + } + + # fallocate + if ($have{fallocate} || $host ne 'localhost') { + foreach my $cmd (@{$tcmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + next if ($op !~ /^(?:chattr|get|put)$/); + next if ($op eq 'chattr' && (!$ref->{tar_creat} || + !$ref->{dstfs} || $ref->{dstfs} !~ /,dmi/)); + my $size; + if ($op ne 'chattr') { + next if (!$opts{preallocate} || $opts{'create-tar'}); + 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]; + } else { + $size = $ref->{tar_creat}; + } + if ($host eq 'localhost' || $op eq 'get') { + $ref->{tool} = "shiftc"; + # allocate local files immediately + eval {mkpath(dirname($dst))}; + system("fallocate", "-n", "-l", $size, $dst); + # ignore errors since files automatically allocated anyway + } else { + $ref->{tool} = "shift-aux"; + # stripe remote files in batch + ($fh, $tmp) = sftp_tmp() if (!$tmp); + print $fh "fallocate ", escape($dst), " $size\n"; + } + } + } + + # setfacl + if ($have{setfacl} || $host ne 'localhost') { + foreach my $cmd (@{$tcmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + next if ($op ne 'chattr' || !$ref->{acls} || + $ref->{dstfs} && $ref->{dstfs} !~ /,acl/); + if ($host eq 'localhost') { + # chattr local files immediately + if (open(SOUT, '|-', "setfacl", "-PM-", $dst)) { + my $acls = unescape($ref->{acls}); + $acls =~ s/,/\n/g; + print SOUT $acls; + close SOUT; + } + # ignore errors since systems may have different command/users + } else { + # chattr remote files in batch + ($fh, $tmp) = sftp_tmp() if (!$tmp); + print $fh "setfacl ", escape($dst), " $ref->{acls}\n"; + } + } + } + + # setfattr + if ($have{setfattr} || $host ne 'localhost') { + foreach my $cmd (@{$tcmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + next if ($op ne 'chattr' || !$ref->{xattrs} || + $ref->{dstfs} && $ref->{dstfs} !~ /,xattr/); + if ($host eq 'localhost') { + # chattr local files immediately + if (open(SOUT, '|-', "setfattr", "-h", "--restore=-")) { + my $xattrs = unescape($ref->{xattrs}); + $xattrs =~ s/,/\n/g; + print SOUT "# file: $dst\n$xattrs"; + close SOUT; + } + # ignore errors since systems may have different command/users + } else { + # chattr remote files in batch + ($fh, $tmp) = sftp_tmp() if (!$tmp); + print $fh "setfattr ", escape($dst), " $ref->{xattrs}\n"; + } + } + } + + if ($tmp) { + close $fh; + open3_get([$tmp, -1, -1], "$opts{ssh} $host $opts{caux} chattr"); + unlink $tmp; + # ignore errors since will fail to system defaults + } +} + +####################### +#### transport_dmf #### +####################### +sub transport_dmf { + my ($host, $tcmds) = @_; + + # dmget processing + my (%getfh, %gettmp); + 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} !~ /,dmi/); + ($getfh{$op}, $gettmp{$op}) = sftp_tmp() if (!$gettmp{$op}); + print {$getfh{$op}} $src, "\n"; + } + + # 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}" !~ /,dmi/); + if ($ref->{srcfs} =~ /,dmi/) { + my ($shost, $spath) = hostpath($ref->{src}); + ($putfh{$shost}, $puttmp{$shost}) = sftp_tmp() if (!$puttmp{$shost}); + print {$putfh{$shost}} $spath, "\n"; + } + if ($ref->{dstfs} =~ /,dmi/) { + ($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; + } + + foreach my $op (keys %gettmp) { + close $getfh{$op}; + my $ssh = $op eq 'get' && $host ne 'localhost' ? "$opts{ssh} $host" : ""; + # ignore errors since files will be automatically retrieved anyway + open3_get([$gettmp{$op}, -1, -1], "$ssh dmget -nq"); + unlink $gettmp{$op}; + } + + foreach my $rhost (keys %puttmp) { + close $putfh{$rhost}; + my $ssh = $rhost ne 'localhost' ? "$opts{ssh} $rhost" : ""; + # ignore errors since files will be automatically migrated anyway + open3_get([$puttmp{$rhost}, -1, -1], "$ssh dmput -n"); + unlink $puttmp{$rhost}; + } + POSIX::_exit(0); +} + +######################## +#### transport_find #### +######################## +# compute remote files and sizes via shift-aux +sub transport_find { + my ($host, $tcmds) = @_; + my ($fh, $tmp); + my %refs; + foreach my $cmd (@{$tcmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + next if ($op ne 'find'); + if ($host eq 'localhost') { + shift_find($host, $src, $dst, $ref); + next; + } + ($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-aux"; + $refs{$ref} = [$src, $dst, $ref]; + } + return if (!$tmp); + close $fh; + + my $cmd = "$opts{ssh} $host $opts{caux} find"; + foreach my $opt (qw(create-tar dereference extract-tar ignore-times + index-tar preserve sync)) { + $cmd .= " --$opt" if ($opts{$opt}); + } + foreach my $opt (qw(find-files newer older)) { + $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 $fhpid = open3_run([$tmp, undef, -1], $cmd); + if ($fhpid) { + my $lhost = fqdn(hostname); + my ($ref, $logfh); + while (defined ($_ = $fhpid->[1]->getline)) { + s/\s+$//; + if (!/,/) { + if (/^ref\s+(\S+)$/) { + $ref = $refs{$1}->[2]; + $logfh = $ref->{logfh}; + delete $refs{$1}; + } else { + # errors indicated by comma-less line + sftp_error($ref, $_); + } + next; + } + print $logfh $_, " host=$lhost\n"; + } + open3_wait($fhpid); + unlink $tmp; + } + # additional processing needed if shift-aux failed + shift_find($host, @{$_}) foreach (values %refs); +} + +######################## +#### transport_fish #### +######################## +sub transport_fish { + my ($host, $tcmds, $tcp) = @_; + + my $nstream = $host eq 'localhost' ? $opts{threads} : $opts{streams}; + my $ssh = $host ne 'localhost' ? "$opts{ssh} $host " : ""; + my ($extra, $extra_tcp); + $extra .= " --buffer-size=" . ($opts{buffer} >> 20) if ($opts{buffer}); + $extra .= " --verify" if ($opts{verify} && $opts{'verify-fast'}); + if ($have_threads && $tcp) { + $extra_tcp .= " --ports=" . $opts{ports} if ($opts{ports}); + $extra_tcp .= " --streams=" . $nstream if ($nstream); + $extra_tcp .= " --tcp"; + $extra_tcp .= " --window=" . ($opts{window}) if ($opts{window}); + } + my $fhpid = open3_run([undef, undef, -1], + "$ssh$opts{caux} fish $extra $extra_tcp"); + my ($out, $in) = ($fhpid->[0], $fhpid->[1]); + + my ($port, $key); + my $rc0 = transport_fish_return($in); + if (ref $rc0 && $rc0->{error} =~ /nothread|noport/) { + $rc0 = undef; + $tcp = 0; + } elsif (!ref $rc0 && $tcp) { + ($port, $key) = split(/\s+/, $rc0); + } + + 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; + } + 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 (!$have_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 (!$have_threads || $nstream <= 1 && !$tcp) { + # work has already been done in loop so exit + $out->write("#exit\n") if (!ref $rc0); + open3_wait($fhpid); + 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) { +#TODO: need error checking or rc0 check here? + 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_SHA1; + require Thread::Queue; + my $q = Thread::Queue->new; + my $qret = Thread::Queue->new; + + $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 ($tin) { + if ($opts{window}) { + $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)); + $tout = $tin; + my $nonce = "" . rand(); + my $hmac = Digest::HMAC_SHA1::hmac_sha1_hex($nonce, $key); + $tout->print($nonce . " " . $hmac . "\n### 100\n"); + my $trc = transport_fish_return($tin); + my ($hmac2, $my_hmac2); + if (!ref $trc) { + ($nonce2, $hmac2) = split(/\s+/, $trc); + $my_hmac2 = Digest::HMAC_SHA1::hmac_sha1_hex( + $nonce . $nonce2, $key); + } + 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); + } + while (defined (my $fi = $q->dequeue)) { + $tin = $fi . " " . Digest::HMAC_SHA1::hmac_sha1_hex( + $fi . $nonce2++, $key) 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_SHA1::hmac_sha1_hex( + "-1" . $nonce2++, $key) . "\n### 100\n"); + close $tout; + } else { + $tout->write("#exit\n") if (!ref $trc0); + open3_wait($tfhpid); + } + return 0; + })} (1 .. $nstream); + # force threads to exit (add extra for original process) + $q->enqueue(undef) foreach (1 .. $nstream + 1); + + if (!$tcp) { + while (defined (my $fi = $q->dequeue)) { + 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; + $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); + + # 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); + } +} + +########################### +#### 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)) { + $err = {error => "Error opening $file: $!"}; + $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); + return (ref $err ? $err : $rc) if (ref $err || ref $rc); + $len = $rc if ($cmd eq 'get'); + $rc = undef; + + 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); + 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'); + $cmd eq 'get' ? $fh->syswrite($buf) : $out->write($buf); + $len -= $n; + verify_buffer($sopts, $buf, $sopts->{length} - $len) + if ($opts{verify} && $opts{'verify-fast'} && $cmd eq 'put'); + } + $fh->close; + + if ($len > 0) { + $rc = {error => "Error reading $file: $!"}; + # remove newlines so doesn't interfere with protocol + $rc->{error} =~ s/\n//g; + $out->write("### 500 $rc->{error}\n"); + transport_fish_return($in); + } else { + $out->write("### 200\n"); + $rc = transport_fish_return($in); + 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; + 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"}; +} + +########################### +#### transport_gridftp #### +########################### +sub transport_gridftp { + my ($host, $tcmds) = @_; + # make sure gridftp-ssh is set up properly + my $prefix = $host ne 'localhost' ? "sshftp://$host" : "file://"; + my $dir = glob("~/.globus"); + mkdir $dir if (! -d $dir); + my $file = "$dir/gridftp-ssh"; + open(FILE, '>', $file); + # note that sshftp must exist in path (normally resides in .globus/sshftp) + print FILE "#!/bin/sh\n$opts{ssh} \$2 sshftp"; + close FILE; + chmod(0700, $file); + + my %errs; + my ($fh, $tmp); + foreach my $cmd (@{$tcmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + ($fh, $tmp) = sftp_tmp() if (!$tmp); + if ($op eq 'put') { + $src = "file://" . escape($src); + $dst = $prefix . escape($dst); + $errs{$dst} = $ref; + } else { + $src = $prefix . escape($src); + $dst = "file://" . escape($dst); + $errs{$dst} = $ref; + } + if ($ref->{bytes}) { + my @ranges = split(/,/, $ref->{bytes}); + foreach my $range (@ranges) { + my ($x1, $x2) = split(/-/, $range); + print $fh "$src $dst $x1,", $x2 - $x1, "\n"; + } + } else { + print $fh "$src $dst\n"; + } + $ref->{tool} = "gridftp"; + } + return if (!$tmp); + close $fh; + + my $nstream = $host eq 'localhost' ? $opts{threads} : $opts{streams}; + my $extra; + $extra .= " -bs " . $opts{buffer} if ($opts{buffer}); + $extra .= " -p " . $nstream if ($nstream); + $extra .= " -tcp-bs " . $opts{window} if ($opts{window}); + # encrypt data channel during secure transfers + $extra .= " -dcpriv" if ($opts{secure}); + # apply opts_gridftp last to override other settings + $extra .= " " . $opts{opts_gridftp}; + if ($opts{ports}) { + #TODO: test that this really works (both on open3 side and globus side) + my $ports = $opts{ports}; + $ports =~ s/:/,/; + $ENV{GLOBUS_TCP_RANGE} = $ports; + $ENV{GLOBUS_TCP_PORT_RANGE} = $ports; + $ENV{GLOBUS_TCP_SOURCE_RANGE} = $ports; + $ENV{GLOBUS_UDP_PORT_RANGE} = $ports; + $ENV{GLOBUS_UDP_SOURCE_RANGE} = $ports; + } + if (open(OUT, '-|', + # unbuffer must be used to interleave stdout/stderr + "unbuffer globus-url-copy $extra -c -cd -r -v -f $tmp 2>&1")) { + my ($src, $dst, $text); + while (my $line = ) { + $line =~ s/\s+$//; + if ($line =~ /^Source:\s*(\S+)/) { + if ($dst && $text && $errs{$dst}) { + sftp_error($errs{$dst}, $text); + } elsif ($dst && $errs{$dst}) { + $errs{$dst}->{text} = 0; + } + $text = undef; + $src = $1; + } elsif ($line =~ /^Dest:\s*(\S+)/) { + $dst = $1; + } elsif ($line =~ /^\s*(\S+)\s*->\s*(\S+)$/) { + $src .= $1; + $dst .= $2; + } elsif ($line =~ /^\s*(\S+)$/) { + $src .= $1; + $dst .= $1; + } elsif ($line && $line !~ /^error: There was an error with/) { + $text .= $line . " "; + } + } + if ($dst && $text && $errs{$dst}) { + sftp_error($errs{$dst}, $text); + } elsif ($dst && $errs{$dst}) { + $errs{$dst}->{text} = 0; + } + } + close OUT; + + foreach my $key (keys %errs) { + if (!defined $errs{$key}->{text}) { + sftp_error($errs{$key}, "unknown gridftp failure"); + } + } + unlink $tmp; +} + +####################### +#### 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 + push(@{$errs{"$dst bytes=$bytes"}}, $ref); + push(@{$errs{"$src bytes=$bytes"}}, $ref); + } else { + push(@{$errs{$dst}}, $ref); + push(@{$errs{$src}}, $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}; + $extra .= " --print-hash --check-tree --hash-type=md5 --hash-leaf-size=1048576" + if ($opts{verify} && $opts{'verify-fast'}); + $extra .= " --buffer-size=" . ($opts{buffer} >> 20) if ($opts{buffer}); + $extra .= " --threads=$opts{threads}" if ($opts{threads}); + my $stripes = $opts{stripe} < 1000 ? $opts{stripe} : + ($opts{stripe} / 1E9) . "s"; + if (!$opts{'no-stripe'}) { + $stripes = ($opts{stripe} / 1E9) . "l" + if ($opts{'extract-tar'} && $opts{stripe} >= 1000); + $extra .= " --stripe-count=$stripes"; + } + $extra .= " --print-src" if ($opts{'create-tar'}); + # must keep write access to handle warnings/corruption + open3_get([$tmp, $out_tmp, $err_tmp], + "mcp $extra --skip-chmod -P --read-stdin"); + + if (open(ERR, '<', $err_tmp)) { + while (my $line = ) { + $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 (@{$errs{$key}}); + } + } + } + close ERR; + } + unlink $err_tmp; + + if ($opts{verify} && $opts{'verify-fast'} && open(OUT, '<', $out_tmp)) { + while () { + 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 $ref = $errs{$file}->[0]; + $ref = $errs{"$file bytes=$1-$2"}->[0] + if (!ref $ref && $hash =~ /^#mutil#(\d+)-(\d+)#/); + # skip if ref not found or error already recorded + next if (!ref $ref || $ref->{text} =~ /^\\E/); + # record hash in error ref + $ref->{text} .= "\\H$hash"; + } + } + close OUT; + } + unlink $out_tmp; + unlink $tmp; +} + +######################### +#### 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 && $ref->{dstfs} =~ /,dmi/) { + $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"; + push(@{$errs{"$spath$lcs"}}, $ref); + push(@{$errs{"$dpath$lcs"}}, $ref); + # track temporary dst name for permission errors + my $dst_tmp = dirname("$dpath$lcs") . "/." . + basename("$dpath$lcs") . ".XXXXXX"; + push(@{$errs{$dst_tmp}}, $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$//; + push(@{$errs{"$spath$lcs"}}, $ref); + push(@{$errs{"$dpath$lcs"}}, $ref); + # track temporary dst name for permission errors + my $dst_tmp = dirname("$dpath$lcs") . "/." . + basename("$dpath$lcs") . ".XXXXXX"; + push(@{$errs{$dst_tmp}}, $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]; + $errs_tmp{$dst} = [$ref]; + # track temporary dst name for permission errors + my $dst_tmp = dirname($dst) . "/." . basename($dst) . ".XXXXXX"; + $errs{$dst_tmp} = [$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 + $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(@{$errs->{$key}}); + } + } elsif ($line =~ /\(code\s+(\d+)\)/) { + $code = $1; + $code_text = $line; + } elsif ($line =~ /Total bytes sent:\s*(\d+)/) { + $size += $1; + } elsif ($line =~ /Total bytes received:\s*(\d+)/) { + $size += $1; + } + } + } + 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 (@{$refs}) { + $ref->{text} = "$type$code_text" if (!$ref->{text}); + } + } + } + return $size; +} + +######################### +#### transport_shift #### +######################### +sub transport_shift { + my ($host, $tcmds) = @_; + if (!$have_threads || $opts{threads} <= 1) { + transport_shift_1($host, $_) foreach (@{$tcmds}); + return; + } + my @scmds; + foreach my $cmd (@{$tcmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + $ref->{tool} = "shiftc"; + if ($op !~ /^(get|put)$/) { + push(@scmds, [undef, $cmd]); + next; + } + 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]); + } + } + if (scalar(@scmds) <= 1) { + transport_shift_1($host, $_->[1]) foreach (@scmds); + return; + } + + 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 Thread::Queue; + 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 and amount of work + my $nthr = scalar(@scmds); + my $maxthr = $host eq 'localhost' ? $opts{threads} : $opts{streams}; + $nthr = $maxthr if ($maxthr < $nthr); + my @threads = map {threads->create(sub { + while (defined (my $ircmd = $q->dequeue)) { + 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}]); + } + })} (1 .. $nthr); + # force threads to exit + $q->enqueue(undef) foreach (1 .. $nthr); + if (first {defined($_)} @threads) { + $_->join foreach (@threads); + } else { + # no threads could be started - fallback to unthreaded + transport_shift_1($host, $_->[1]) foreach (@scmds); + return; + } + # 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 + -d $dst or mkdir $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))}; + ($src && readlink($dst) eq $src) or 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$//; + 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'}) { + # hack since perl does not support symlink chown + system("chown", "-h", "$attrs[1]:$attrs[2]", $dst); + # 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'}) { + # don't return error for chown since unlikely to succeed + chown($attrs[1], $attrs[2], $dst); + chmod($attrs[0], $dst) or sftp_error($ref, "$!") and return; + utime($attrs[3], $attrs[4], $dst) or + sftp_error($ref, "$!") and return; + } + if ($opts{check} && $op =~ /^c[hk]attr/ && !$ref->{ln} && + !$opts{'create-tar'}) { + my @dattrs = stat $dst; + if (!@dattrs || $dattrs[7] == 0 && $op ne 'chattr') { + # 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]); + } 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)); + my $attrs = sftp($host)->stat($dst); + if ($attrs && !S_ISDIR($attrs->perm)) { + sftp_error($ref, "File exists"); + } elsif (!$attrs && !sftp($host)->mkdir($dst)) { + sftp_error($ref, "Permission denied"); + } + } 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)); + # src and dst are reversed in sftp symlink + ($src && sftp($host)->readlink($dst) eq $src) or + 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$//; + sftp($host)->rename($src, $dst, overwrite => 1) or + sftp_error($ref, "" . sftp($host, 1)->error); + if ($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}); + # don't return error for chown/chgrp since unlikely to succeed + my $sattrs = Net::SFTP::Foreign::Attributes->new; + $sattrs->set_ugid($attrs[1], $attrs[2]); + sftp($host)->setstat($dst, $sattrs); + + $sattrs = Net::SFTP::Foreign::Attributes->new; + $sattrs->set_perm($attrs[0]); + $sattrs->set_amtime($attrs[3], $attrs[4]); + sftp($host)->setstat($dst, $sattrs) or + sftp_error($ref, "" . sftp($host, 1)->error); + } + if ($opts{check} && $op =~ /^c[hk]attr/ && !$ref->{ln} && + !$opts{'create-tar'}) { + my @attrs = split(/,/, $ref->{attrs}); + my $dattrs = sftp($host)->stat($dst); + if (!defined $dattrs || $dattrs->size == 0 && $op ne 'chattr') { + # 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); + } 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 ($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) = sftp_tmp(); + foreach my $order (0, 1) { + my %errs = (); + open($fh, '>', $tmp); + 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; + } elsif (defined $ref->{split}) { + # need to track by split instead of file + $errs{"$dst bytes=$ref->{bytes}"} = $ref; + } else { + $errs{$dst} = $ref; + } + print $fh "$hash $file\n"; + } + } + + close $fh; + next if (scalar(keys(%errs) == 0)); + foreach my $prog ($order ? reverse @progs : @progs) { + my $cmd; + $cmd .= "$opts{ssh} $host " if ($host ne 'localhost'); + $cmd .= $prog; + $cmd .= " sum" if ($prog eq $opts{caux}); + $cmd .= " -c --split-size=1024"; + $cmd .= " --buffer-size=" . ($opts{buffer} >> 20) if ($opts{buffer}); + $cmd .= " --threads=$opts{threads}" if ($opts{threads}); + $cmd .= " --check-tree --hash-leaf-size=1048576 --hash-type=md5 " . + $opts{opts_msum} if ($prog eq 'msum'); + 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 = ) { + $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)); + $errs{$_}->{text} = "\\E$line" foreach (@keys); + } + } + close ERR; + } + unlink $err_tmp; + + if (open(OUT, '<', $out_tmp)) { + my $buf; + while (my $line = ) { + $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 $ref = $errs{$file}; + $ref = $errs{"$file bytes=" . substr($bytes, 1)} + if (!ref $ref && $bytes); + if (!ref $ref && $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)) { + next if (!defined $err->{split} && + !defined $err->{tar_bytes}); + my @ranges = split(/,/, $err->{bytes}); + foreach my $range (@ranges) { + my ($min, $max) = split(/-/, $range); + if ($min <= $x1 && $x2 <= $max) { + $ref = $err; + last ERR; + } + } + } + } + # skip if ref not found or error already recorded + next if (!ref $ref || $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; + + $_->{tool} = $prog foreach (values(%errs)); + + # stop after the first program that runs + last if ($run); + } + unlink $tmp; + foreach my $ref (values(%errs)) { + $ref->{text} = "\\EUnable to compute destination hash" + if (!defined $ref->{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; + } else { + $errs{$src} = $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 $extra; + $extra .= " --buffer-size=" . ($opts{buffer} >> 20) if ($opts{buffer}); + $extra .= " --threads=$opts{threads}" if ($opts{threads}); + $extra .= " $opts{opts_msum}"; + + open3_get([$tmp, $out_tmp, $err_tmp], + "msum $extra --check-tree --hash-type=md5 --hash-leaf-size=1048576 --read-stdin --split-size=1024"); + if (open(ERR, '<', $err_tmp)) { + while (my $line = ) { + $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)); + $errs{$_}->{text} = "\\E$line" foreach (@keys); + } + } + close ERR; + } + unlink $err_tmp; + + if (open(OUT, '<', $out_tmp)) { + while () { + 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 $ref = $errs{$file}; + $ref = $errs{"$file bytes=$1-$2"} + if (!ref $ref && $hash =~ /^#mutil#(\d+)-(\d+)#/); + # skip if ref not found or error already recorded + next if ($ref->{text} =~ /^\\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 ($have_threads && $opts{threads} > 1) { + require Thread::Queue; + $q = Thread::Queue->new; + $qret = Thread::Queue->new; + $qi = 0; + } + + my $sopts = verify_init(); + my %errs; + my ($fh, $tmp) = sftp_tmp(); + foreach my $cmd (@{$cmds}) { + my ($op, $src, $dst, $ref) = @{$cmd}; + $ref->{tool} = "shiftc"; + $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 (!$have_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 (!$have_threads || $opts{threads} <= 1); + # choose min of specified threads and amount of work + my $nthr = min($opts{threads}, $q->pending); + my @threads = map {threads->create(sub { + while (defined (my $sum = $q->dequeue)) { + 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]); + } + })} (1 .. $nthr); + # force threads to exit + $q->enqueue(undef) foreach (1 .. $nthr); + $_->join foreach (@threads); + # 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*", md5("")); + } 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 %sopts = ( + buffer_size => $opts{buffer} ? $opts{buffer} >> 20 : 4, + hash_ctx => Digest::MD5->new, + split_size => 1024, + 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 ($pid, $in, $out); + eval { + local $SIG{__WARN__} = sub {die}; + # use 2s alarm in case df stalls + local $SIG{ALRM} = sub {die}; + alarm 2; + # use open3 to avoid executing a shell command based on the name + # of a file being copied (which may contain metacharacters, etc.) + alarm 0; + $pid = IPC::Open3::open3($in, $out, $out, 'df', '-Pk', $path); + }; + if (!$@) { + <$out> if (scalar(@{$copts->{-argv}}) != 1); + while (my $line = <$out>) { + $line =~ s/\s+$//; + sftp_echo($ref, $line); + } + } + close $in; + close $out; + waitpid($pid, 0) if ($pid); + } 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 + +# 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.30";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)=@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);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($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; + } + } + + $year -= 1900 if defined $year && $year > 1900; + + $zone += 3600 if defined $zone && $dst; + $ss += "0.$frac" if $frac; + + return ($ss,$mm,$hh,$day,$month,$year,$zone); + } + 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/HMAC_MD5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DIGEST_HMAC_MD5'; + package Digest::HMAC_MD5;$VERSION="1.01";use strict;use Digest::MD5 qw(md5);use Digest::HMAC qw(hmac);use vars qw(@ISA);@ISA=qw(Digest::HMAC);sub new {my$class=shift;$class->SUPER::new($_[0],"Digest::MD5",64)}require Exporter;*import=\&Exporter::import;use vars qw(@EXPORT_OK);@EXPORT_OK=qw(hmac_md5 hmac_md5_hex);sub hmac_md5 {hmac($_[0],$_[1],\&md5,64)}sub hmac_md5_hex {unpack("H*",&hmac_md5)}1; +DIGEST_HMAC_MD5 + +$fatpacked{"Digest/HMAC_SHA1.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DIGEST_HMAC_SHA1'; + package Digest::HMAC_SHA1;$VERSION="1.03";use strict;use Digest::SHA::PurePerl qw(sha1);use Digest::HMAC qw(hmac);use vars qw(@ISA);@ISA=qw(Digest::HMAC);sub new {my$class=shift;$class->SUPER::new($_[0],"Digest::SHA",64)}require Exporter;*import=\&Exporter::import;use vars qw(@EXPORT_OK);@EXPORT_OK=qw(hmac_sha1 hmac_sha1_hex);sub hmac_sha1 {hmac($_[0],$_[1],\&sha1,64)}sub hmac_sha1_hex {unpack("H*",&hmac_sha1)}1; +DIGEST_HMAC_SHA1 + +$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 @EXPORT_OK);use Fcntl;use integer;use Carp qw(croak);$VERSION='5.95';require Exporter;@ISA=qw(Exporter);@EXPORT_OK=();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;$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,$portable)=map {$_ eq $mode}("b","U","0","p");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 =~ s/[^01]//g;$self->add_bits($buf)}_bail("Read failed")unless defined$n;close(FH);return($self)}binmode(FH)if$binary || $portable || $UNIVERSAL;if ($UNIVERSAL && _istext(*FH,$file)){while (){s/\015\012/\012/g;s/\015/\012/g;$self->add($_)}}elsif ($portable && _istext(*FH,$file)){while (){s/\015?\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('',);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 <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.18';@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,@_}}push@errs,"IO::Pipe: Can't spawn-NOWAIT: $!" if!$pid || $pid < 0}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/SFTP/Foreign.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_SFTP_FOREIGN'; + package Net::SFTP::Foreign;our$VERSION='1.81';use strict;use warnings;use warnings::register;use Carp qw(carp croak);use Symbol ();use Errno ();use Fcntl;use File::Spec ();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->{_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");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$wpr;eval {local$SIG{ALRM}=sub {die "timeout\n"};alarm 8;$wpr=waitpid($pid,0);alarm 0};$debug and $debug & 4 and _debug("waitpid returned " .(defined$wpr ? $wpr : ''));if ($wpr){last if$wpr > 0 or $!==Errno::ECHILD()}}}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=$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};my@msgid;my$askoff=length $$bin;my$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){$eof=$sftp->_queue_new_msg(SSH2_FXP_READ,str=>$rfid,int64=>$pos + length $$bin,int32=>1)}last}}$sftp->_get_msg for@msgid;if ($eof){$sftp->_get_msg_and_check(SSH2_FXP_DATA,$eof,SFTP_ERR_REMOTE_BLOCK_TOO_SMALL,"received block was too small")}if ($sftp->{_status}==SSH2_FX_EOF and length $$bin){$sftp->_clear_error_and_status}return$sftp->{_error}? undef : 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$line}}}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$a='.';while (@_){my$b=shift;if (defined$b){$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}}}$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);my@tail;if ($debug and $debug & 32768){my$target=File::Spec->join(@parts);_debug "_mkpath_local('$target')"}if ($parent){pop@parts while@parts and not length$parts[-1];@parts or goto top_dir_reached;pop@parts}while (1){my$target=File::Spec->join(@parts);$target='' unless defined$target;if (-e $target){if (-d $target){while (@tail){$target=File::Spec->join($target,shift(@tail));$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}}}return 1}else {$sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,"Local file '$target' is not a directory");return}}@parts or last;unshift@tail,pop@parts}top_dir_reached: $sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,"mkpath failed, top dir reached");return}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 "'resume' and 'append' options can not be used simultaneously" if ($resume and $append);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));if ($local_is_fh){my$append='option can not be used when target is a file handle';$resume and croak "'resume' $append";$overwrite and croak "'overwrite' $append";$numbered and croak "'numbered' $append";$dont_save and croak "'dont_save' $append";$atomic and croak "'croak' $append"}%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);$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,1)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)=@_;$name=$sftp->_rel2abs($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]}$remote=$sftp->_rel2abs($remote);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 : '');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=File::Spec->catfile($local,$1);($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||'').")");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.76_03';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){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 .= ': '}if ($debug & 256){my$ts=sprintf("%010.5f",time);print STDERR "#$$ $ts $caller",@_,"\n"}else {print STDERR "# $caller",@_,"\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/(?($_[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 + +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 +